Merge branch 'master' of git://factorcode.org/git/factor
Doug Coleman
commit
8b728e0a8a
basis
compiler
cfg
branch-folding
branch-splitting
builder
instructions
intrinsics
iterator
linear-scan/assignment
linearization
optimizer
stack-analysis
tco
useless-blocks
useless-conditionals
utilities
codegen
math/vectors
|
|
@ -0,0 +1,30 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors combinators.short-circuit kernel sequences vectors
|
||||
compiler.cfg.instructions compiler.cfg.rpo ;
|
||||
IN: compiler.cfg.branch-folding
|
||||
|
||||
! Fold comparisons where both inputs are the same. Predecessors must be
|
||||
! recomputed after this
|
||||
|
||||
: fold-branch? ( bb -- ? )
|
||||
instructions>> last {
|
||||
[ ##compare-branch? ]
|
||||
[ [ src1>> ] [ src2>> ] bi = ]
|
||||
} 1&& ;
|
||||
|
||||
: chosen-successor ( bb -- succ )
|
||||
[ instructions>> last cc>> { cc= cc<= cc>= } memq? 0 1 ? ]
|
||||
[ successors>> ]
|
||||
bi nth ;
|
||||
|
||||
: fold-branch ( bb -- )
|
||||
dup chosen-successor 1vector >>successors
|
||||
instructions>> [ pop* ] [ [ \ ##branch new-insn ] dip push ] bi ;
|
||||
|
||||
: fold-branches ( cfg -- cfg' )
|
||||
dup [
|
||||
dup fold-branch?
|
||||
[ fold-branch ] [ drop ] if
|
||||
] each-basic-block
|
||||
f >>post-order ;
|
||||
|
|
@ -1,24 +1,31 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! Copyright (C) 2009 Doug Coleman, Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors combinators.short-circuit compiler.cfg.def-use
|
||||
compiler.cfg.rpo kernel math sequences ;
|
||||
USING: accessors combinators.short-circuit kernel math sequences
|
||||
compiler.cfg.def-use compiler.cfg compiler.cfg.rpo ;
|
||||
IN: compiler.cfg.branch-splitting
|
||||
|
||||
: split-branch ( branch -- )
|
||||
! Predecessors must be recomputed after this
|
||||
|
||||
: split-branch-for ( bb predecessor -- )
|
||||
[
|
||||
[ instructions>> ] [ predecessors>> ] bi [
|
||||
instructions>> [ pop* ] [ push-all ] bi
|
||||
] with each
|
||||
] [
|
||||
[ successors>> ] [ predecessors>> ] bi [
|
||||
[ drop clone ] change-successors drop
|
||||
] with each
|
||||
] bi ;
|
||||
[
|
||||
<basic-block>
|
||||
swap
|
||||
[ instructions>> [ clone ] map >>instructions ]
|
||||
[ successors>> clone >>successors ]
|
||||
bi
|
||||
] keep
|
||||
] dip
|
||||
[ [ 2dup eq? [ 2drop ] [ 2nip ] if ] with with map ] change-successors
|
||||
drop ;
|
||||
|
||||
: split-branch ( bb -- )
|
||||
dup predecessors>> [ split-branch-for ] with each ;
|
||||
|
||||
: split-branches? ( bb -- ? )
|
||||
{
|
||||
[ predecessors>> length 1 >= ]
|
||||
[ successors>> length 1 <= ]
|
||||
[ successors>> empty? ]
|
||||
[ predecessors>> length 1 > ]
|
||||
[ instructions>> [ defs-vregs ] any? not ]
|
||||
[ instructions>> [ temp-vregs ] any? not ]
|
||||
} 1&& ;
|
||||
|
|
@ -26,4 +33,5 @@ IN: compiler.cfg.branch-splitting
|
|||
: split-branches ( cfg -- cfg' )
|
||||
dup [
|
||||
dup split-branches? [ split-branch ] [ drop ] if
|
||||
] each-basic-block f >>post-order ;
|
||||
] each-basic-block
|
||||
f >>post-order ;
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! Copyright (C) 2004, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays assocs combinators hashtables kernel
|
||||
math fry namespaces make sequences words byte-arrays
|
||||
|
|
@ -11,7 +11,6 @@ compiler.tree.propagation.info
|
|||
compiler.cfg
|
||||
compiler.cfg.hats
|
||||
compiler.cfg.stacks
|
||||
compiler.cfg.iterator
|
||||
compiler.cfg.utilities
|
||||
compiler.cfg.registers
|
||||
compiler.cfg.intrinsics
|
||||
|
|
@ -26,10 +25,6 @@ SYMBOL: procedures
|
|||
SYMBOL: current-word
|
||||
SYMBOL: current-label
|
||||
SYMBOL: loops
|
||||
SYMBOL: first-basic-block
|
||||
|
||||
! Basic block after prologue, makes recursion faster
|
||||
SYMBOL: current-label-start
|
||||
|
||||
: add-procedure ( -- )
|
||||
basic-block get current-word get current-label get
|
||||
|
|
@ -46,27 +41,22 @@ SYMBOL: current-label-start
|
|||
: with-cfg-builder ( nodes word label quot -- )
|
||||
'[ begin-procedure @ ] with-scope ; inline
|
||||
|
||||
GENERIC: emit-node ( node -- next )
|
||||
GENERIC: emit-node ( node -- )
|
||||
|
||||
: check-basic-block ( node -- node' )
|
||||
basic-block get [ drop f ] unless ; inline
|
||||
|
||||
: emit-nodes ( nodes -- )
|
||||
[ current-node emit-node check-basic-block ] iterate-nodes ;
|
||||
[ basic-block get [ emit-node ] [ drop ] if ] each ;
|
||||
|
||||
: begin-word ( -- )
|
||||
#! We store the basic block after the prologue as a loop
|
||||
#! labeled by the current word, so that self-recursive
|
||||
#! calls can skip an epilogue/prologue.
|
||||
##prologue
|
||||
##branch
|
||||
begin-basic-block
|
||||
basic-block get first-basic-block set ;
|
||||
begin-basic-block ;
|
||||
|
||||
: (build-cfg) ( nodes word label -- )
|
||||
[
|
||||
begin-word
|
||||
V{ } clone node-stack set
|
||||
emit-nodes
|
||||
] with-cfg-builder ;
|
||||
|
||||
|
|
@ -77,37 +67,30 @@ GENERIC: emit-node ( node -- next )
|
|||
] with-variable
|
||||
] keep ;
|
||||
|
||||
: local-recursive-call ( basic-block -- next )
|
||||
: local-recursive-call ( basic-block -- )
|
||||
##branch
|
||||
basic-block get successors>> push
|
||||
stop-iterating ;
|
||||
basic-block off ;
|
||||
|
||||
: emit-call ( word height -- next )
|
||||
{
|
||||
{ [ over loops get key? ] [ drop loops get at local-recursive-call ] }
|
||||
{ [ terminate-call? ] [ ##call stop-iterating ] }
|
||||
{ [ tail-call? not ] [ ##call ##branch begin-basic-block iterate-next ] }
|
||||
{ [ dup current-label get eq? ] [ 2drop first-basic-block get local-recursive-call ] }
|
||||
[ drop ##epilogue ##jump stop-iterating ]
|
||||
} cond ;
|
||||
: emit-call ( word -- )
|
||||
dup loops get key?
|
||||
[ loops get at local-recursive-call ]
|
||||
[ ##call ##branch begin-basic-block ]
|
||||
if ;
|
||||
|
||||
! #recursive
|
||||
: recursive-height ( #recursive -- n )
|
||||
[ label>> return>> in-d>> length ] [ in-d>> length ] bi - ;
|
||||
|
||||
: emit-recursive ( #recursive -- next )
|
||||
[ [ label>> id>> ] [ recursive-height ] bi emit-call ]
|
||||
: emit-recursive ( #recursive -- )
|
||||
[ label>> id>> emit-call ]
|
||||
[ [ child>> ] [ label>> word>> ] [ label>> id>> ] tri (build-cfg) ] bi ;
|
||||
|
||||
: remember-loop ( label -- )
|
||||
basic-block get swap loops get set-at ;
|
||||
|
||||
: emit-loop ( node -- next )
|
||||
: emit-loop ( node -- )
|
||||
##loop-entry
|
||||
##branch
|
||||
begin-basic-block
|
||||
[ label>> id>> remember-loop ] [ child>> emit-nodes ] bi
|
||||
iterate-next ;
|
||||
[ label>> id>> remember-loop ] [ child>> emit-nodes ] bi ;
|
||||
|
||||
M: #recursive emit-node
|
||||
dup label>> loop?>> [ emit-loop ] [ emit-recursive ] if ;
|
||||
|
|
@ -121,7 +104,7 @@ M: #recursive emit-node
|
|||
] with-scope ;
|
||||
|
||||
: emit-if ( node -- )
|
||||
children>> [ emit-branch ] map
|
||||
children>> [ emit-branch ] map
|
||||
end-basic-block
|
||||
begin-basic-block
|
||||
basic-block get '[ [ _ swap successors>> push ] when* ] each ;
|
||||
|
|
@ -157,23 +140,23 @@ M: #if emit-node
|
|||
{ [ dup trivial-if? ] [ drop emit-trivial-if ] }
|
||||
{ [ dup trivial-not-if? ] [ drop emit-trivial-not-if ] }
|
||||
[ ds-pop ##branch-t emit-if ]
|
||||
} cond iterate-next ;
|
||||
} cond ;
|
||||
|
||||
! #dispatch
|
||||
M: #dispatch emit-node
|
||||
ds-pop ^^offset>slot i ##dispatch emit-if iterate-next ;
|
||||
ds-pop ^^offset>slot i ##dispatch emit-if ;
|
||||
|
||||
! #call
|
||||
M: #call emit-node
|
||||
dup word>> dup "intrinsic" word-prop
|
||||
[ emit-intrinsic ] [ swap call-height emit-call ] if ;
|
||||
[ emit-intrinsic ] [ nip emit-call ] if ;
|
||||
|
||||
! #call-recursive
|
||||
M: #call-recursive emit-node [ label>> id>> ] [ call-height ] bi emit-call ;
|
||||
M: #call-recursive emit-node label>> id>> emit-call ;
|
||||
|
||||
! #push
|
||||
M: #push emit-node
|
||||
literal>> ^^load-literal ds-push iterate-next ;
|
||||
literal>> ^^load-literal ds-push ;
|
||||
|
||||
! #shuffle
|
||||
M: #shuffle emit-node
|
||||
|
|
@ -183,19 +166,18 @@ M: #shuffle emit-node
|
|||
[ [ in-r>> [ length rs-load ] keep ] dip '[ _ set-at ] 2each ]
|
||||
[ nip ] 2tri
|
||||
[ [ [ out-d>> ] [ mapping>> ] bi ] dip '[ _ at _ at ] map ds-store ]
|
||||
[ [ [ out-r>> ] [ mapping>> ] bi ] dip '[ _ at _ at ] map rs-store ] 2bi
|
||||
iterate-next ;
|
||||
[ [ [ out-r>> ] [ mapping>> ] bi ] dip '[ _ at _ at ] map rs-store ] 2bi ;
|
||||
|
||||
! #return
|
||||
M: #return emit-node
|
||||
drop ##epilogue ##return stop-iterating ;
|
||||
drop ##epilogue ##return ;
|
||||
|
||||
M: #return-recursive emit-node
|
||||
label>> id>> loops get key?
|
||||
[ iterate-next ] [ ##epilogue ##return stop-iterating ] if ;
|
||||
[ ##epilogue ##return ] unless ;
|
||||
|
||||
! #terminate
|
||||
M: #terminate emit-node drop stop-iterating ;
|
||||
M: #terminate emit-node drop ##no-tco ;
|
||||
|
||||
! FFI
|
||||
: return-size ( ctype -- n )
|
||||
|
|
@ -215,9 +197,9 @@ M: #terminate emit-node drop stop-iterating ;
|
|||
: alien-stack-frame ( params -- )
|
||||
<alien-stack-frame> ##stack-frame ;
|
||||
|
||||
: emit-alien-node ( node quot -- next )
|
||||
: emit-alien-node ( node quot -- )
|
||||
[ params>> ] dip [ drop alien-stack-frame ] [ call ] 2bi
|
||||
##branch begin-basic-block iterate-next ; inline
|
||||
##branch begin-basic-block ; inline
|
||||
|
||||
M: #alien-invoke emit-node
|
||||
[ ##alien-invoke ] emit-alien-node ;
|
||||
|
|
@ -229,17 +211,16 @@ M: #alien-callback emit-node
|
|||
dup params>> xt>> dup
|
||||
[
|
||||
##prologue
|
||||
dup [ ##alien-callback ] emit-alien-node drop
|
||||
dup [ ##alien-callback ] emit-alien-node
|
||||
##epilogue
|
||||
params>> ##callback-return
|
||||
] with-cfg-builder
|
||||
iterate-next ;
|
||||
] with-cfg-builder ;
|
||||
|
||||
! No-op nodes
|
||||
M: #introduce emit-node drop iterate-next ;
|
||||
M: #introduce emit-node drop ;
|
||||
|
||||
M: #copy emit-node drop iterate-next ;
|
||||
M: #copy emit-node drop ;
|
||||
|
||||
M: #enter-recursive emit-node drop iterate-next ;
|
||||
M: #enter-recursive emit-node drop ;
|
||||
|
||||
M: #phi emit-node drop iterate-next ;
|
||||
M: #phi emit-node drop ;
|
||||
|
|
|
|||
|
|
@ -1,7 +1,9 @@
|
|||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel arrays vectors accessors
|
||||
namespaces math make fry sequences ;
|
||||
USING: kernel arrays vectors accessors assocs sets
|
||||
namespaces math make fry sequences
|
||||
combinators.short-circuit
|
||||
compiler.cfg.instructions ;
|
||||
IN: compiler.cfg
|
||||
|
||||
TUPLE: basic-block < identity-tuple
|
||||
|
|
@ -20,6 +22,25 @@ M: basic-block hashcode* nip id>> ;
|
|||
V{ } clone >>predecessors
|
||||
\ basic-block counter >>id ;
|
||||
|
||||
: empty-block? ( bb -- ? )
|
||||
instructions>> {
|
||||
[ length 1 = ]
|
||||
[ first ##branch? ]
|
||||
} 1&& ;
|
||||
|
||||
SYMBOL: visited
|
||||
|
||||
: (skip-empty-blocks) ( bb -- bb' )
|
||||
dup visited get key? [
|
||||
dup empty-block? [
|
||||
dup visited get conjoin
|
||||
successors>> first (skip-empty-blocks)
|
||||
] when
|
||||
] unless ;
|
||||
|
||||
: skip-empty-blocks ( bb -- bb' )
|
||||
H{ } clone visited [ (skip-empty-blocks) ] with-variable ;
|
||||
|
||||
: add-instructions ( bb quot -- )
|
||||
[ instructions>> building ] dip '[
|
||||
building get pop
|
||||
|
|
|
|||
|
|
@ -53,10 +53,13 @@ INSN: ##inc-r { n integer } ;
|
|||
|
||||
! Subroutine calls
|
||||
INSN: ##stack-frame stack-frame ;
|
||||
INSN: ##call word { height integer } ;
|
||||
INSN: ##call word ;
|
||||
INSN: ##jump word ;
|
||||
INSN: ##return ;
|
||||
|
||||
! Dummy instruction that simply inhibits TCO
|
||||
INSN: ##no-tco ;
|
||||
|
||||
! Jump tables
|
||||
INSN: ##dispatch src temp ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,11 +1,10 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: sequences accessors layouts kernel math namespaces
|
||||
combinators fry locals
|
||||
compiler.tree.propagation.info
|
||||
compiler.cfg.hats
|
||||
compiler.cfg.stacks
|
||||
compiler.cfg.iterator
|
||||
compiler.cfg.instructions
|
||||
compiler.cfg.utilities
|
||||
compiler.cfg.registers ;
|
||||
|
|
@ -102,8 +101,8 @@ IN: compiler.cfg.intrinsics.fixnum
|
|||
: (emit-fixnum-comparison) ( cc -- quot1 quot2 )
|
||||
[ ^^compare ] [ ^^compare-imm ] bi-curry ; inline
|
||||
|
||||
: emit-eq ( node cc -- )
|
||||
(emit-fixnum-comparison) emit-commutative-fixnum-op ;
|
||||
: emit-eq ( node -- )
|
||||
cc= (emit-fixnum-comparison) emit-commutative-fixnum-op ;
|
||||
|
||||
: emit-fixnum-comparison ( node cc -- )
|
||||
(emit-fixnum-comparison) emit-fixnum-op ;
|
||||
|
|
@ -114,15 +113,6 @@ IN: compiler.cfg.intrinsics.fixnum
|
|||
: emit-fixnum>bignum ( -- )
|
||||
ds-pop ^^untag-fixnum ^^integer>bignum ds-push ;
|
||||
|
||||
: emit-fixnum-overflow-op ( quot quot-tail -- next )
|
||||
[ 2inputs 1 ##inc-d ] 2dip
|
||||
tail-call? [
|
||||
##epilogue
|
||||
nip call
|
||||
stop-iterating
|
||||
] [
|
||||
drop call
|
||||
##branch
|
||||
begin-basic-block
|
||||
iterate-next
|
||||
] if ; inline
|
||||
: emit-fixnum-overflow-op ( quot -- next )
|
||||
[ 2inputs 1 ##inc-d ] dip call ##branch
|
||||
begin-basic-block ; inline
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: words sequences kernel combinators cpu.architecture
|
||||
compiler.cfg.hats
|
||||
|
|
@ -8,8 +8,7 @@ compiler.cfg.intrinsics.allot
|
|||
compiler.cfg.intrinsics.fixnum
|
||||
compiler.cfg.intrinsics.float
|
||||
compiler.cfg.intrinsics.slots
|
||||
compiler.cfg.intrinsics.misc
|
||||
compiler.cfg.iterator ;
|
||||
compiler.cfg.intrinsics.misc ;
|
||||
QUALIFIED: kernel
|
||||
QUALIFIED: arrays
|
||||
QUALIFIED: byte-arrays
|
||||
|
|
@ -95,66 +94,66 @@ IN: compiler.cfg.intrinsics
|
|||
: enable-fixnum-log2 ( -- )
|
||||
\ math.integers.private:fixnum-log2 t "intrinsic" set-word-prop ;
|
||||
|
||||
: emit-intrinsic ( node word -- node/f )
|
||||
: emit-intrinsic ( node word -- )
|
||||
{
|
||||
{ \ kernel.private:tag [ drop emit-tag iterate-next ] }
|
||||
{ \ kernel.private:getenv [ emit-getenv iterate-next ] }
|
||||
{ \ math.private:both-fixnums? [ drop emit-both-fixnums? iterate-next ] }
|
||||
{ \ math.private:fixnum+ [ drop [ ##fixnum-add ] [ ##fixnum-add-tail ] emit-fixnum-overflow-op ] }
|
||||
{ \ math.private:fixnum- [ drop [ ##fixnum-sub ] [ ##fixnum-sub-tail ] emit-fixnum-overflow-op ] }
|
||||
{ \ math.private:fixnum* [ drop [ i i ##fixnum-mul ] [ i i ##fixnum-mul-tail ] emit-fixnum-overflow-op ] }
|
||||
{ \ math.private:fixnum+fast [ [ ^^add ] [ ^^add-imm ] emit-commutative-fixnum-op iterate-next ] }
|
||||
{ \ math.private:fixnum-fast [ [ ^^sub ] [ ^^sub-imm ] emit-fixnum-op iterate-next ] }
|
||||
{ \ math.private:fixnum-bitand [ [ ^^and ] [ ^^and-imm ] emit-commutative-fixnum-op iterate-next ] }
|
||||
{ \ math.private:fixnum-bitor [ [ ^^or ] [ ^^or-imm ] emit-commutative-fixnum-op iterate-next ] }
|
||||
{ \ math.private:fixnum-bitxor [ [ ^^xor ] [ ^^xor-imm ] emit-commutative-fixnum-op iterate-next ] }
|
||||
{ \ math.private:fixnum-shift-fast [ emit-fixnum-shift-fast iterate-next ] }
|
||||
{ \ math.private:fixnum-bitnot [ drop emit-fixnum-bitnot iterate-next ] }
|
||||
{ \ math.integers.private:fixnum-log2 [ drop emit-fixnum-log2 iterate-next ] }
|
||||
{ \ math.private:fixnum*fast [ emit-fixnum*fast iterate-next ] }
|
||||
{ \ math.private:fixnum< [ cc< emit-fixnum-comparison iterate-next ] }
|
||||
{ \ math.private:fixnum<= [ cc<= emit-fixnum-comparison iterate-next ] }
|
||||
{ \ math.private:fixnum>= [ cc>= emit-fixnum-comparison iterate-next ] }
|
||||
{ \ math.private:fixnum> [ cc> emit-fixnum-comparison iterate-next ] }
|
||||
{ \ kernel:eq? [ cc= emit-eq iterate-next ] }
|
||||
{ \ math.private:bignum>fixnum [ drop emit-bignum>fixnum iterate-next ] }
|
||||
{ \ math.private:fixnum>bignum [ drop emit-fixnum>bignum iterate-next ] }
|
||||
{ \ math.private:float+ [ drop [ ^^add-float ] emit-float-op iterate-next ] }
|
||||
{ \ math.private:float- [ drop [ ^^sub-float ] emit-float-op iterate-next ] }
|
||||
{ \ math.private:float* [ drop [ ^^mul-float ] emit-float-op iterate-next ] }
|
||||
{ \ math.private:float/f [ drop [ ^^div-float ] emit-float-op iterate-next ] }
|
||||
{ \ math.private:float< [ drop cc< emit-float-comparison iterate-next ] }
|
||||
{ \ math.private:float<= [ drop cc<= emit-float-comparison iterate-next ] }
|
||||
{ \ math.private:float>= [ drop cc>= emit-float-comparison iterate-next ] }
|
||||
{ \ math.private:float> [ drop cc> emit-float-comparison iterate-next ] }
|
||||
{ \ math.private:float= [ drop cc= emit-float-comparison iterate-next ] }
|
||||
{ \ math.private:float>fixnum [ drop emit-float>fixnum iterate-next ] }
|
||||
{ \ math.private:fixnum>float [ drop emit-fixnum>float iterate-next ] }
|
||||
{ \ slots.private:slot [ emit-slot iterate-next ] }
|
||||
{ \ slots.private:set-slot [ emit-set-slot iterate-next ] }
|
||||
{ \ strings.private:string-nth [ drop emit-string-nth iterate-next ] }
|
||||
{ \ strings.private:set-string-nth-fast [ drop emit-set-string-nth-fast iterate-next ] }
|
||||
{ \ classes.tuple.private:<tuple-boa> [ emit-<tuple-boa> iterate-next ] }
|
||||
{ \ arrays:<array> [ emit-<array> iterate-next ] }
|
||||
{ \ byte-arrays:<byte-array> [ emit-<byte-array> iterate-next ] }
|
||||
{ \ byte-arrays:(byte-array) [ emit-(byte-array) iterate-next ] }
|
||||
{ \ kernel:<wrapper> [ emit-simple-allot iterate-next ] }
|
||||
{ \ alien.accessors:alien-unsigned-1 [ 1 emit-alien-unsigned-getter iterate-next ] }
|
||||
{ \ alien.accessors:set-alien-unsigned-1 [ 1 emit-alien-integer-setter iterate-next ] }
|
||||
{ \ alien.accessors:alien-signed-1 [ 1 emit-alien-signed-getter iterate-next ] }
|
||||
{ \ alien.accessors:set-alien-signed-1 [ 1 emit-alien-integer-setter iterate-next ] }
|
||||
{ \ alien.accessors:alien-unsigned-2 [ 2 emit-alien-unsigned-getter iterate-next ] }
|
||||
{ \ alien.accessors:set-alien-unsigned-2 [ 2 emit-alien-integer-setter iterate-next ] }
|
||||
{ \ alien.accessors:alien-signed-2 [ 2 emit-alien-signed-getter iterate-next ] }
|
||||
{ \ alien.accessors:set-alien-signed-2 [ 2 emit-alien-integer-setter iterate-next ] }
|
||||
{ \ alien.accessors:alien-unsigned-4 [ 4 emit-alien-unsigned-getter iterate-next ] }
|
||||
{ \ alien.accessors:set-alien-unsigned-4 [ 4 emit-alien-integer-setter iterate-next ] }
|
||||
{ \ alien.accessors:alien-signed-4 [ 4 emit-alien-signed-getter iterate-next ] }
|
||||
{ \ alien.accessors:set-alien-signed-4 [ 4 emit-alien-integer-setter iterate-next ] }
|
||||
{ \ alien.accessors:alien-cell [ emit-alien-cell-getter iterate-next ] }
|
||||
{ \ alien.accessors:set-alien-cell [ emit-alien-cell-setter iterate-next ] }
|
||||
{ \ alien.accessors:alien-float [ single-float-regs emit-alien-float-getter iterate-next ] }
|
||||
{ \ alien.accessors:set-alien-float [ single-float-regs emit-alien-float-setter iterate-next ] }
|
||||
{ \ alien.accessors:alien-double [ double-float-regs emit-alien-float-getter iterate-next ] }
|
||||
{ \ alien.accessors:set-alien-double [ double-float-regs emit-alien-float-setter iterate-next ] }
|
||||
{ \ kernel.private:tag [ drop emit-tag ] }
|
||||
{ \ kernel.private:getenv [ emit-getenv ] }
|
||||
{ \ math.private:both-fixnums? [ drop emit-both-fixnums? ] }
|
||||
{ \ math.private:fixnum+ [ drop [ ##fixnum-add ] emit-fixnum-overflow-op ] }
|
||||
{ \ math.private:fixnum- [ drop [ ##fixnum-sub ] emit-fixnum-overflow-op ] }
|
||||
{ \ math.private:fixnum* [ drop [ i i ##fixnum-mul ] emit-fixnum-overflow-op ] }
|
||||
{ \ math.private:fixnum+fast [ [ ^^add ] [ ^^add-imm ] emit-commutative-fixnum-op ] }
|
||||
{ \ math.private:fixnum-fast [ [ ^^sub ] [ ^^sub-imm ] emit-fixnum-op ] }
|
||||
{ \ math.private:fixnum-bitand [ [ ^^and ] [ ^^and-imm ] emit-commutative-fixnum-op ] }
|
||||
{ \ math.private:fixnum-bitor [ [ ^^or ] [ ^^or-imm ] emit-commutative-fixnum-op ] }
|
||||
{ \ math.private:fixnum-bitxor [ [ ^^xor ] [ ^^xor-imm ] emit-commutative-fixnum-op ] }
|
||||
{ \ math.private:fixnum-shift-fast [ emit-fixnum-shift-fast ] }
|
||||
{ \ math.private:fixnum-bitnot [ drop emit-fixnum-bitnot ] }
|
||||
{ \ math.integers.private:fixnum-log2 [ drop emit-fixnum-log2 ] }
|
||||
{ \ math.private:fixnum*fast [ emit-fixnum*fast ] }
|
||||
{ \ math.private:fixnum< [ cc< emit-fixnum-comparison ] }
|
||||
{ \ math.private:fixnum<= [ cc<= emit-fixnum-comparison ] }
|
||||
{ \ math.private:fixnum>= [ cc>= emit-fixnum-comparison ] }
|
||||
{ \ math.private:fixnum> [ cc> emit-fixnum-comparison ] }
|
||||
{ \ kernel:eq? [ emit-eq ] }
|
||||
{ \ math.private:bignum>fixnum [ drop emit-bignum>fixnum ] }
|
||||
{ \ math.private:fixnum>bignum [ drop emit-fixnum>bignum ] }
|
||||
{ \ math.private:float+ [ drop [ ^^add-float ] emit-float-op ] }
|
||||
{ \ math.private:float- [ drop [ ^^sub-float ] emit-float-op ] }
|
||||
{ \ math.private:float* [ drop [ ^^mul-float ] emit-float-op ] }
|
||||
{ \ math.private:float/f [ drop [ ^^div-float ] emit-float-op ] }
|
||||
{ \ math.private:float< [ drop cc< emit-float-comparison ] }
|
||||
{ \ math.private:float<= [ drop cc<= emit-float-comparison ] }
|
||||
{ \ math.private:float>= [ drop cc>= emit-float-comparison ] }
|
||||
{ \ math.private:float> [ drop cc> emit-float-comparison ] }
|
||||
{ \ math.private:float= [ drop cc= emit-float-comparison ] }
|
||||
{ \ math.private:float>fixnum [ drop emit-float>fixnum ] }
|
||||
{ \ math.private:fixnum>float [ drop emit-fixnum>float ] }
|
||||
{ \ slots.private:slot [ emit-slot ] }
|
||||
{ \ slots.private:set-slot [ emit-set-slot ] }
|
||||
{ \ strings.private:string-nth [ drop emit-string-nth ] }
|
||||
{ \ strings.private:set-string-nth-fast [ drop emit-set-string-nth-fast ] }
|
||||
{ \ classes.tuple.private:<tuple-boa> [ emit-<tuple-boa> ] }
|
||||
{ \ arrays:<array> [ emit-<array> ] }
|
||||
{ \ byte-arrays:<byte-array> [ emit-<byte-array> ] }
|
||||
{ \ byte-arrays:(byte-array) [ emit-(byte-array) ] }
|
||||
{ \ kernel:<wrapper> [ emit-simple-allot ] }
|
||||
{ \ alien.accessors:alien-unsigned-1 [ 1 emit-alien-unsigned-getter ] }
|
||||
{ \ alien.accessors:set-alien-unsigned-1 [ 1 emit-alien-integer-setter ] }
|
||||
{ \ alien.accessors:alien-signed-1 [ 1 emit-alien-signed-getter ] }
|
||||
{ \ alien.accessors:set-alien-signed-1 [ 1 emit-alien-integer-setter ] }
|
||||
{ \ alien.accessors:alien-unsigned-2 [ 2 emit-alien-unsigned-getter ] }
|
||||
{ \ alien.accessors:set-alien-unsigned-2 [ 2 emit-alien-integer-setter ] }
|
||||
{ \ alien.accessors:alien-signed-2 [ 2 emit-alien-signed-getter ] }
|
||||
{ \ alien.accessors:set-alien-signed-2 [ 2 emit-alien-integer-setter ] }
|
||||
{ \ alien.accessors:alien-unsigned-4 [ 4 emit-alien-unsigned-getter ] }
|
||||
{ \ alien.accessors:set-alien-unsigned-4 [ 4 emit-alien-integer-setter ] }
|
||||
{ \ alien.accessors:alien-signed-4 [ 4 emit-alien-signed-getter ] }
|
||||
{ \ alien.accessors:set-alien-signed-4 [ 4 emit-alien-integer-setter ] }
|
||||
{ \ alien.accessors:alien-cell [ emit-alien-cell-getter ] }
|
||||
{ \ alien.accessors:set-alien-cell [ emit-alien-cell-setter ] }
|
||||
{ \ alien.accessors:alien-float [ single-float-regs emit-alien-float-getter ] }
|
||||
{ \ alien.accessors:set-alien-float [ single-float-regs emit-alien-float-setter ] }
|
||||
{ \ alien.accessors:alien-double [ double-float-regs emit-alien-float-getter ] }
|
||||
{ \ alien.accessors:set-alien-double [ double-float-regs emit-alien-float-setter ] }
|
||||
} case ;
|
||||
|
|
|
|||
|
|
@ -1,45 +0,0 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: namespaces sequences kernel compiler.tree ;
|
||||
IN: compiler.cfg.iterator
|
||||
|
||||
SYMBOL: node-stack
|
||||
|
||||
: >node ( cursor -- ) node-stack get push ;
|
||||
: node> ( -- cursor ) node-stack get pop ;
|
||||
: node@ ( -- cursor ) node-stack get last ;
|
||||
: current-node ( -- node ) node@ first ;
|
||||
: iterate-next ( -- cursor ) node@ rest-slice ;
|
||||
: skip-next ( -- next ) node> rest-slice [ first ] [ >node ] bi ;
|
||||
|
||||
: iterate-nodes ( cursor quot: ( -- ) -- )
|
||||
over empty? [
|
||||
2drop
|
||||
] [
|
||||
[ swap >node call node> drop ] keep iterate-nodes
|
||||
] if ; inline recursive
|
||||
|
||||
DEFER: (tail-call?)
|
||||
|
||||
: tail-phi? ( cursor -- ? )
|
||||
[ first #phi? ] [ rest-slice (tail-call?) ] bi and ;
|
||||
|
||||
: (tail-call?) ( cursor -- ? )
|
||||
[ t ] [
|
||||
[
|
||||
first
|
||||
[ #return? ]
|
||||
[ #return-recursive? ]
|
||||
[ #terminate? ] tri or or
|
||||
] [ tail-phi? ] bi or
|
||||
] if-empty ;
|
||||
|
||||
: tail-call? ( -- ? )
|
||||
node-stack get [
|
||||
rest-slice
|
||||
[ t ] [ (tail-call?) ] if-empty
|
||||
] all? ;
|
||||
|
||||
: terminate-call? ( -- ? )
|
||||
node-stack get last
|
||||
rest-slice [ f ] [ first #terminate? ] if-empty ;
|
||||
|
|
@ -1 +0,0 @@
|
|||
Utility for iterating for high-level IR
|
||||
|
|
@ -50,9 +50,12 @@ ERROR: already-spilled ;
|
|||
: handle-spill ( live-interval -- )
|
||||
dup spill-to>> [ [ record-spill ] [ insert-spill ] bi ] [ drop ] if ;
|
||||
|
||||
: next-interval ( live-interval -- live-interval' )
|
||||
split-next>> dup split-before>> [ next-interval ] [ ] ?if ;
|
||||
|
||||
: insert-copy ( live-interval -- )
|
||||
{
|
||||
[ split-next>> reg>> ]
|
||||
[ next-interval reg>> ]
|
||||
[ reg>> ]
|
||||
[ vreg>> reg-class>> ]
|
||||
[ end>> ]
|
||||
|
|
|
|||
|
|
@ -24,19 +24,8 @@ M: insn linearize-insn , drop ;
|
|||
#! don't need to branch.
|
||||
[ number>> ] bi@ 1 - = ; inline
|
||||
|
||||
: branch-to-branch? ( successor -- ? )
|
||||
#! A branch to a block containing just a jump return is cloned.
|
||||
instructions>> dup length 2 = [
|
||||
[ first ##epilogue? ]
|
||||
[ second [ ##return? ] [ ##jump? ] bi or ] bi and
|
||||
] [ drop f ] if ;
|
||||
|
||||
: emit-branch ( basic-block successor -- )
|
||||
{
|
||||
{ [ 2dup useless-branch? ] [ 2drop ] }
|
||||
{ [ dup branch-to-branch? ] [ nip linearize-basic-block ] }
|
||||
[ nip number>> _branch ]
|
||||
} cond ;
|
||||
2dup useless-branch? [ 2drop ] [ nip number>> _branch ] if ;
|
||||
|
||||
M: ##branch linearize-insn
|
||||
drop dup successors>> first emit-branch ;
|
||||
|
|
|
|||
|
|
@ -1,12 +1,15 @@
|
|||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel sequences accessors combinators namespaces
|
||||
compiler.cfg.tco
|
||||
compiler.cfg.predecessors
|
||||
compiler.cfg.useless-blocks
|
||||
compiler.cfg.useless-conditionals
|
||||
compiler.cfg.stack-analysis
|
||||
compiler.cfg.branch-splitting
|
||||
compiler.cfg.alias-analysis
|
||||
compiler.cfg.value-numbering
|
||||
compiler.cfg.dce
|
||||
compiler.cfg.branch-folding
|
||||
compiler.cfg.write-barrier
|
||||
compiler.cfg.liveness
|
||||
compiler.cfg.rpo
|
||||
|
|
@ -22,14 +25,20 @@ SYMBOL: check-optimizer?
|
|||
] when ;
|
||||
|
||||
: optimize-cfg ( cfg -- cfg' )
|
||||
! Note that compute-predecessors has to be called several times.
|
||||
! The passes that need this document it.
|
||||
[
|
||||
optimize-tail-calls
|
||||
compute-predecessors
|
||||
! delete-useless-blocks
|
||||
delete-useless-conditionals
|
||||
split-branches
|
||||
compute-predecessors
|
||||
stack-analysis
|
||||
compute-liveness
|
||||
alias-analysis
|
||||
value-numbering
|
||||
fold-branches
|
||||
compute-predecessors
|
||||
eliminate-dead-code
|
||||
eliminate-write-barriers
|
||||
eliminate-phis
|
||||
|
|
|
|||
|
|
@ -48,7 +48,8 @@ M: ##inc-r visit
|
|||
! Instructions which don't have any effect on the stack
|
||||
UNION: neutral-insn
|
||||
##effect
|
||||
##flushable ;
|
||||
##flushable
|
||||
##no-tco ;
|
||||
|
||||
M: neutral-insn visit , ;
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,85 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors combinators.short-circuit kernel math
|
||||
namespaces sequences fry combinators
|
||||
compiler.cfg
|
||||
compiler.cfg.rpo
|
||||
compiler.cfg.hats
|
||||
compiler.cfg.instructions ;
|
||||
IN: compiler.cfg.tco
|
||||
|
||||
! Tail call optimization. You must run compute-predecessors after this
|
||||
|
||||
: return? ( bb -- ? )
|
||||
skip-empty-blocks
|
||||
instructions>> {
|
||||
[ length 2 = ]
|
||||
[ first ##epilogue? ]
|
||||
[ second ##return? ]
|
||||
} 1&& ;
|
||||
|
||||
: penultimate ( seq -- elt ) [ length 2 - ] keep nth ;
|
||||
|
||||
: tail-call? ( bb -- ? )
|
||||
{
|
||||
[ instructions>> { [ length 2 >= ] [ last ##branch? ] } 1&& ]
|
||||
[ successors>> first return? ]
|
||||
} 1&& ;
|
||||
|
||||
: word-tail-call? ( bb -- ? )
|
||||
instructions>> penultimate ##call? ;
|
||||
|
||||
: convert-tail-call ( bb quot: ( insn -- tail-insn ) -- )
|
||||
'[
|
||||
instructions>>
|
||||
[ pop* ] [ pop ] [ ] tri
|
||||
[ [ \ ##epilogue new-insn ] dip push ]
|
||||
[ _ dip push ] bi
|
||||
]
|
||||
[ successors>> delete-all ]
|
||||
bi ; inline
|
||||
|
||||
: convert-word-tail-call ( bb -- )
|
||||
[ word>> \ ##jump new-insn ] convert-tail-call ;
|
||||
|
||||
: loop-tail-call? ( bb -- ? )
|
||||
instructions>> penultimate
|
||||
{ [ ##call? ] [ word>> cfg get label>> eq? ] } 1&& ;
|
||||
|
||||
: convert-loop-tail-call ( bb -- )
|
||||
! If a word calls itself, this becomes a loop in the CFG.
|
||||
[ instructions>> [ pop* ] [ pop* ] [ [ \ ##branch new-insn ] dip push ] tri ]
|
||||
[ successors>> delete-all ]
|
||||
[ [ cfg get entry>> successors>> first ] dip successors>> push ]
|
||||
tri ;
|
||||
|
||||
: fixnum-tail-call? ( bb -- ? )
|
||||
instructions>> penultimate
|
||||
{ [ ##fixnum-add? ] [ ##fixnum-sub? ] [ ##fixnum-mul? ] } 1|| ;
|
||||
|
||||
GENERIC: convert-fixnum-tail-call* ( src1 src2 insn -- insn' )
|
||||
|
||||
M: ##fixnum-add convert-fixnum-tail-call* drop \ ##fixnum-add-tail new-insn ;
|
||||
M: ##fixnum-sub convert-fixnum-tail-call* drop \ ##fixnum-sub-tail new-insn ;
|
||||
M: ##fixnum-mul convert-fixnum-tail-call* drop i i \ ##fixnum-mul-tail new-insn ;
|
||||
|
||||
: convert-fixnum-tail-call ( bb -- )
|
||||
[
|
||||
[ src1>> ] [ src2>> ] [ ] tri
|
||||
convert-fixnum-tail-call*
|
||||
] convert-tail-call ;
|
||||
|
||||
: optimize-tail-call ( bb -- )
|
||||
dup tail-call? [
|
||||
{
|
||||
{ [ dup loop-tail-call? ] [ convert-loop-tail-call ] }
|
||||
{ [ dup word-tail-call? ] [ convert-word-tail-call ] }
|
||||
{ [ dup fixnum-tail-call? ] [ convert-fixnum-tail-call ] }
|
||||
[ drop ]
|
||||
} cond
|
||||
] [ drop ] if ;
|
||||
|
||||
: optimize-tail-calls ( cfg -- cfg' )
|
||||
dup cfg set
|
||||
dup [ optimize-tail-call ] each-basic-block
|
||||
f >>post-order ;
|
||||
|
|
@ -1,11 +0,0 @@
|
|||
IN: compiler.cfg.useless-blocks.tests
|
||||
USING: fry kernel sequences compiler.cfg.useless-blocks compiler.cfg.checker
|
||||
compiler.cfg.debugger compiler.cfg.predecessors tools.test ;
|
||||
|
||||
{
|
||||
[ [ drop 1 ] when ]
|
||||
[ [ drop 1 ] unless ]
|
||||
} [
|
||||
[ [ ] ] dip
|
||||
'[ _ test-cfg first compute-predecessors delete-useless-blocks check-cfg ] unit-test
|
||||
] each
|
||||
|
|
@ -1,62 +0,0 @@
|
|||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel accessors sequences combinators combinators.short-circuit
|
||||
classes vectors compiler.cfg compiler.cfg.instructions compiler.cfg.rpo ;
|
||||
IN: compiler.cfg.useless-blocks
|
||||
|
||||
: update-predecessor-for-delete ( bb -- )
|
||||
! We have to replace occurrences of bb with bb's successor
|
||||
! in bb's predecessor's list of successors.
|
||||
dup predecessors>> first [
|
||||
[
|
||||
2dup eq? [ drop successors>> first ] [ nip ] if
|
||||
] with map
|
||||
] change-successors drop ;
|
||||
|
||||
: update-successor-for-delete ( bb -- )
|
||||
! We have to replace occurrences of bb with bb's predecessor
|
||||
! in bb's sucessor's list of predecessors.
|
||||
dup successors>> first [
|
||||
[
|
||||
2dup eq? [ drop predecessors>> first ] [ nip ] if
|
||||
] with map
|
||||
] change-predecessors drop ;
|
||||
|
||||
: delete-basic-block ( bb -- )
|
||||
[ update-predecessor-for-delete ]
|
||||
[ update-successor-for-delete ]
|
||||
bi ;
|
||||
|
||||
: delete-basic-block? ( bb -- ? )
|
||||
{
|
||||
[ instructions>> length 1 = ]
|
||||
[ predecessors>> length 1 = ]
|
||||
[ successors>> length 1 = ]
|
||||
[ instructions>> first ##branch? ]
|
||||
} 1&& ;
|
||||
|
||||
: delete-useless-blocks ( cfg -- cfg' )
|
||||
dup [
|
||||
dup delete-basic-block? [ delete-basic-block ] [ drop ] if
|
||||
] each-basic-block
|
||||
f >>post-order ;
|
||||
|
||||
: delete-conditional? ( bb -- ? )
|
||||
dup instructions>> [ drop f ] [
|
||||
last class {
|
||||
##compare-branch
|
||||
##compare-imm-branch
|
||||
##compare-float-branch
|
||||
} memq? [ successors>> first2 eq? ] [ drop f ] if
|
||||
] if-empty ;
|
||||
|
||||
: delete-conditional ( bb -- )
|
||||
dup successors>> first 1vector >>successors
|
||||
[ but-last \ ##branch new-insn suffix ] change-instructions
|
||||
drop ;
|
||||
|
||||
: delete-useless-conditionals ( cfg -- cfg' )
|
||||
dup [
|
||||
dup delete-conditional? [ delete-conditional ] [ drop ] if
|
||||
] each-basic-block
|
||||
f >>post-order ;
|
||||
|
|
@ -0,0 +1,21 @@
|
|||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel accessors sequences math combinators combinators.short-circuit
|
||||
classes vectors compiler.cfg compiler.cfg.instructions compiler.cfg.rpo ;
|
||||
IN: compiler.cfg.useless-conditionals
|
||||
|
||||
: delete-conditional? ( bb -- ? )
|
||||
{
|
||||
[ instructions>> last class { ##compare-branch ##compare-imm-branch ##compare-float-branch } memq? ]
|
||||
[ successors>> first2 [ skip-empty-blocks ] bi@ eq? ]
|
||||
} 1&& ;
|
||||
|
||||
: delete-conditional ( bb -- )
|
||||
[ first skip-empty-blocks 1vector ] change-successors
|
||||
instructions>> [ pop* ] [ [ \ ##branch new-insn ] dip push ] bi ;
|
||||
|
||||
: delete-useless-conditionals ( cfg -- cfg' )
|
||||
dup [
|
||||
dup delete-conditional? [ delete-conditional ] [ drop ] if
|
||||
] each-basic-block
|
||||
f >>post-order ;
|
||||
|
|
@ -35,8 +35,5 @@ IN: compiler.cfg.utilities
|
|||
|
||||
: stop-iterating ( -- next ) end-basic-block f ;
|
||||
|
||||
: call-height ( ##call -- n )
|
||||
[ out-d>> length ] [ in-d>> length ] bi - ;
|
||||
|
||||
: emit-primitive ( node -- )
|
||||
[ word>> ] [ call-height ] bi ##call ##branch begin-basic-block ;
|
||||
word>> ##call ##branch begin-basic-block ;
|
||||
|
|
|
|||
|
|
@ -67,6 +67,8 @@ SYMBOL: labels
|
|||
: lookup-label ( id -- label )
|
||||
labels get [ drop <label> ] cache ;
|
||||
|
||||
M: ##no-tco generate-insn drop ;
|
||||
|
||||
M: ##load-immediate generate-insn
|
||||
[ dst>> register ] [ val>> ] bi %load-immediate ;
|
||||
|
||||
|
|
|
|||
|
|
@ -16,3 +16,5 @@ USING: math.vectors tools.test ;
|
|||
[ { 1.75 2.125 } ] [ { 1.0 2.5 } { 2.5 1.0 } { 0.5 0.25 } vlerp ] unit-test
|
||||
|
||||
[ 1.125 ] [ 0.0 1.0 2.0 4.0 { 0.5 0.25 } bilerp ] unit-test
|
||||
|
||||
[ 17 ] [ 0 1 2 3 4 5 6 7 { 1 2 3 } trilerp ] unit-test
|
||||
Loading…
Reference in New Issue