steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' of git://factorcode.org/git/factor

db4
Doug Coleman 2009-06-30 23:02:04 -05:00
parent b1c7374175 3385e50c43
commit 8b728e0a8a
22 changed files with 311 additions and 289 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
basis/compiler/cfg/branch-folding/branch-folding.factor Normal file
View File

@ -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 ;

38
basis/compiler/cfg/branch-splitting/branch-splitting.factor
View File

@ -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. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators.short-circuit compiler.cfg.def-use USING: accessors combinators.short-circuit kernel math sequences
compiler.cfg.rpo kernel math sequences ; compiler.cfg.def-use compiler.cfg compiler.cfg.rpo ;
IN: compiler.cfg.branch-splitting 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 <basic-block>
] with each swap
] [ [ instructions>> [ clone ] map >>instructions ]
[ successors>> ] [ predecessors>> ] bi [ [ successors>> clone >>successors ]
[ drop clone ] change-successors drop bi
] with each ] keep
] bi ; ] 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 -- ? ) : split-branches? ( bb -- ? )
{ {
[ predecessors>> length 1 >= ] [ successors>> empty? ]
[ successors>> length 1 <= ] [ predecessors>> length 1 > ]
[ instructions>> [ defs-vregs ] any? not ] [ instructions>> [ defs-vregs ] any? not ]
[ instructions>> [ temp-vregs ] any? not ] [ instructions>> [ temp-vregs ] any? not ]
} 1&& ; } 1&& ;
@ -26,4 +33,5 @@ IN: compiler.cfg.branch-splitting
: split-branches ( cfg -- cfg' ) : split-branches ( cfg -- cfg' )
dup [ dup [
dup split-branches? [ split-branch ] [ drop ] if dup split-branches? [ split-branch ] [ drop ] if
] each-basic-block f >>post-order ; ] each-basic-block
f >>post-order ;

83
basis/compiler/cfg/builder/builder.factor
View File

@ -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. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs combinators hashtables kernel USING: accessors arrays assocs combinators hashtables kernel
math fry namespaces make sequences words byte-arrays math fry namespaces make sequences words byte-arrays
@ -11,7 +11,6 @@ compiler.tree.propagation.info
compiler.cfg compiler.cfg
compiler.cfg.hats compiler.cfg.hats
compiler.cfg.stacks compiler.cfg.stacks
compiler.cfg.iterator
compiler.cfg.utilities compiler.cfg.utilities
compiler.cfg.registers compiler.cfg.registers
compiler.cfg.intrinsics compiler.cfg.intrinsics
@ -26,10 +25,6 @@ SYMBOL: procedures
SYMBOL: current-word SYMBOL: current-word
SYMBOL: current-label SYMBOL: current-label
SYMBOL: loops SYMBOL: loops
SYMBOL: first-basic-block
! Basic block after prologue, makes recursion faster
SYMBOL: current-label-start
: add-procedure ( -- ) : add-procedure ( -- )
basic-block get current-word get current-label get basic-block get current-word get current-label get
@ -46,27 +41,22 @@ SYMBOL: current-label-start
: with-cfg-builder ( nodes word label quot -- ) : with-cfg-builder ( nodes word label quot -- )
'[ begin-procedure @ ] with-scope ; inline '[ begin-procedure @ ] with-scope ; inline
GENERIC: emit-node ( node -- next ) GENERIC: emit-node ( node -- )
: check-basic-block ( node -- node' ) : check-basic-block ( node -- node' )
basic-block get [ drop f ] unless ; inline basic-block get [ drop f ] unless ; inline
: emit-nodes ( nodes -- ) : emit-nodes ( nodes -- )
[ current-node emit-node check-basic-block ] iterate-nodes ; [ basic-block get [ emit-node ] [ drop ] if ] each ;
: begin-word ( -- ) : 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 ##prologue
##branch ##branch
begin-basic-block begin-basic-block ;
basic-block get first-basic-block set ;
: (build-cfg) ( nodes word label -- ) : (build-cfg) ( nodes word label -- )
[ [
begin-word begin-word
V{ } clone node-stack set
emit-nodes emit-nodes
] with-cfg-builder ; ] with-cfg-builder ;
@ -77,37 +67,30 @@ GENERIC: emit-node ( node -- next )
] with-variable ] with-variable
] keep ; ] keep ;
: local-recursive-call ( basic-block -- next ) : local-recursive-call ( basic-block -- )
##branch ##branch
basic-block get successors>> push basic-block get successors>> push
stop-iterating ; basic-block off ;
: emit-call ( word height -- next ) : emit-call ( word -- )
{ dup loops get key?
{ [ over loops get key? ] [ drop loops get at local-recursive-call ] } [ loops get at local-recursive-call ]
{ [ terminate-call? ] [ ##call stop-iterating ] } [ ##call ##branch begin-basic-block ]
{ [ tail-call? not ] [ ##call ##branch begin-basic-block iterate-next ] } if ;
{ [ dup current-label get eq? ] [ 2drop first-basic-block get local-recursive-call ] }
[ drop ##epilogue ##jump stop-iterating ]
} cond ;
! #recursive ! #recursive
: recursive-height ( #recursive -- n ) : emit-recursive ( #recursive -- )
[ label>> return>> in-d>> length ] [ in-d>> length ] bi - ; [ label>> id>> emit-call ]
: emit-recursive ( #recursive -- next )
[ [ label>> id>> ] [ recursive-height ] bi emit-call ]
[ [ child>> ] [ label>> word>> ] [ label>> id>> ] tri (build-cfg) ] bi ; [ [ child>> ] [ label>> word>> ] [ label>> id>> ] tri (build-cfg) ] bi ;
: remember-loop ( label -- ) : remember-loop ( label -- )
basic-block get swap loops get set-at ; basic-block get swap loops get set-at ;
: emit-loop ( node -- next ) : emit-loop ( node -- )
##loop-entry ##loop-entry
##branch ##branch
begin-basic-block begin-basic-block
[ label>> id>> remember-loop ] [ child>> emit-nodes ] bi [ label>> id>> remember-loop ] [ child>> emit-nodes ] bi ;
iterate-next ;
M: #recursive emit-node M: #recursive emit-node
dup label>> loop?>> [ emit-loop ] [ emit-recursive ] if ; dup label>> loop?>> [ emit-loop ] [ emit-recursive ] if ;
@ -157,23 +140,23 @@ M: #if emit-node
{ [ dup trivial-if? ] [ drop emit-trivial-if ] } { [ dup trivial-if? ] [ drop emit-trivial-if ] }
{ [ dup trivial-not-if? ] [ drop emit-trivial-not-if ] } { [ dup trivial-not-if? ] [ drop emit-trivial-not-if ] }
[ ds-pop ##branch-t emit-if ] [ ds-pop ##branch-t emit-if ]
} cond iterate-next ; } cond ;
! #dispatch ! #dispatch
M: #dispatch emit-node M: #dispatch emit-node
ds-pop ^^offset>slot i ##dispatch emit-if iterate-next ; ds-pop ^^offset>slot i ##dispatch emit-if ;
! #call ! #call
M: #call emit-node M: #call emit-node
dup word>> dup "intrinsic" word-prop dup word>> dup "intrinsic" word-prop
[ emit-intrinsic ] [ swap call-height emit-call ] if ; [ emit-intrinsic ] [ nip emit-call ] if ;
! #call-recursive ! #call-recursive
M: #call-recursive emit-node [ label>> id>> ] [ call-height ] bi emit-call ; M: #call-recursive emit-node label>> id>> emit-call ;
! #push ! #push
M: #push emit-node M: #push emit-node
literal>> ^^load-literal ds-push iterate-next ; literal>> ^^load-literal ds-push ;
! #shuffle ! #shuffle
M: #shuffle emit-node M: #shuffle emit-node
@ -183,19 +166,18 @@ M: #shuffle emit-node
[ [ in-r>> [ length rs-load ] keep ] dip '[ _ set-at ] 2each ] [ [ in-r>> [ length rs-load ] keep ] dip '[ _ set-at ] 2each ]
[ nip ] 2tri [ nip ] 2tri
[ [ [ out-d>> ] [ mapping>> ] bi ] dip '[ _ at _ at ] map ds-store ] [ [ [ out-d>> ] [ mapping>> ] bi ] dip '[ _ at _ at ] map ds-store ]
[ [ [ out-r>> ] [ mapping>> ] bi ] dip '[ _ at _ at ] map rs-store ] 2bi [ [ [ out-r>> ] [ mapping>> ] bi ] dip '[ _ at _ at ] map rs-store ] 2bi ;
iterate-next ;
! #return ! #return
M: #return emit-node M: #return emit-node
drop ##epilogue ##return stop-iterating ; drop ##epilogue ##return ;
M: #return-recursive emit-node M: #return-recursive emit-node
label>> id>> loops get key? label>> id>> loops get key?
[ iterate-next ] [ ##epilogue ##return stop-iterating ] if ; [ ##epilogue ##return ] unless ;
! #terminate ! #terminate
M: #terminate emit-node drop stop-iterating ; M: #terminate emit-node drop ##no-tco ;
! FFI ! FFI
: return-size ( ctype -- n ) : return-size ( ctype -- n )
@ -215,9 +197,9 @@ M: #terminate emit-node drop stop-iterating ;
: alien-stack-frame ( params -- ) : alien-stack-frame ( params -- )
<alien-stack-frame> ##stack-frame ; <alien-stack-frame> ##stack-frame ;
: emit-alien-node ( node quot -- next ) : emit-alien-node ( node quot -- )
[ params>> ] dip [ drop alien-stack-frame ] [ call ] 2bi [ 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 M: #alien-invoke emit-node
[ ##alien-invoke ] emit-alien-node ; [ ##alien-invoke ] emit-alien-node ;
@ -229,17 +211,16 @@ M: #alien-callback emit-node
dup params>> xt>> dup dup params>> xt>> dup
[ [
##prologue ##prologue
dup [ ##alien-callback ] emit-alien-node drop dup [ ##alien-callback ] emit-alien-node
##epilogue ##epilogue
params>> ##callback-return params>> ##callback-return
] with-cfg-builder ] with-cfg-builder ;
iterate-next ;
! No-op nodes ! 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 ;

0
basis/compiler/cfg/cfg-tests.factor Normal file
View File

25
basis/compiler/cfg/cfg.factor
View File

@ -1,7 +1,9 @@
! Copyright (C) 2008, 2009 Slava Pestov. ! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel arrays vectors accessors USING: kernel arrays vectors accessors assocs sets
namespaces math make fry sequences ; namespaces math make fry sequences
combinators.short-circuit
compiler.cfg.instructions ;
IN: compiler.cfg IN: compiler.cfg
TUPLE: basic-block < identity-tuple TUPLE: basic-block < identity-tuple
@ -20,6 +22,25 @@ M: basic-block hashcode* nip id>> ;
V{ } clone >>predecessors V{ } clone >>predecessors
\ basic-block counter >>id ; \ 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 -- ) : add-instructions ( bb quot -- )
[ instructions>> building ] dip '[ [ instructions>> building ] dip '[
building get pop building get pop

5
basis/compiler/cfg/instructions/instructions.factor
View File

@ -53,10 +53,13 @@ INSN: ##inc-r { n integer } ;
! Subroutine calls ! Subroutine calls
INSN: ##stack-frame stack-frame ; INSN: ##stack-frame stack-frame ;
INSN: ##call word { height integer } ; INSN: ##call word ;
INSN: ##jump word ; INSN: ##jump word ;
INSN: ##return ; INSN: ##return ;
! Dummy instruction that simply inhibits TCO
INSN: ##no-tco ;
! Jump tables ! Jump tables
INSN: ##dispatch src temp ; INSN: ##dispatch src temp ;

22
basis/compiler/cfg/intrinsics/fixnum/fixnum.factor
View File

@ -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. ! See http://factorcode.org/license.txt for BSD license.
USING: sequences accessors layouts kernel math namespaces USING: sequences accessors layouts kernel math namespaces
combinators fry locals combinators fry locals
compiler.tree.propagation.info compiler.tree.propagation.info
compiler.cfg.hats compiler.cfg.hats
compiler.cfg.stacks compiler.cfg.stacks
compiler.cfg.iterator
compiler.cfg.instructions compiler.cfg.instructions
compiler.cfg.utilities compiler.cfg.utilities
compiler.cfg.registers ; compiler.cfg.registers ;
@ -102,8 +101,8 @@ IN: compiler.cfg.intrinsics.fixnum
: (emit-fixnum-comparison) ( cc -- quot1 quot2 ) : (emit-fixnum-comparison) ( cc -- quot1 quot2 )
[ ^^compare ] [ ^^compare-imm ] bi-curry ; inline [ ^^compare ] [ ^^compare-imm ] bi-curry ; inline
: emit-eq ( node cc -- ) : emit-eq ( node -- )
(emit-fixnum-comparison) emit-commutative-fixnum-op ; cc= (emit-fixnum-comparison) emit-commutative-fixnum-op ;
: emit-fixnum-comparison ( node cc -- ) : emit-fixnum-comparison ( node cc -- )
(emit-fixnum-comparison) emit-fixnum-op ; (emit-fixnum-comparison) emit-fixnum-op ;
@ -114,15 +113,6 @@ IN: compiler.cfg.intrinsics.fixnum
: emit-fixnum>bignum ( -- ) : emit-fixnum>bignum ( -- )
ds-pop ^^untag-fixnum ^^integer>bignum ds-push ; ds-pop ^^untag-fixnum ^^integer>bignum ds-push ;
: emit-fixnum-overflow-op ( quot quot-tail -- next ) : emit-fixnum-overflow-op ( quot -- next )
[ 2inputs 1 ##inc-d ] 2dip [ 2inputs 1 ##inc-d ] dip call ##branch
tail-call? [ begin-basic-block ; inline
##epilogue
nip call
stop-iterating
] [
drop call
##branch
begin-basic-block
iterate-next
] if ; inline

127
basis/compiler/cfg/intrinsics/intrinsics.factor
View File

@ -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. ! See http://factorcode.org/license.txt for BSD license.
USING: words sequences kernel combinators cpu.architecture USING: words sequences kernel combinators cpu.architecture
compiler.cfg.hats compiler.cfg.hats
@ -8,8 +8,7 @@ compiler.cfg.intrinsics.allot
compiler.cfg.intrinsics.fixnum compiler.cfg.intrinsics.fixnum
compiler.cfg.intrinsics.float compiler.cfg.intrinsics.float
compiler.cfg.intrinsics.slots compiler.cfg.intrinsics.slots
compiler.cfg.intrinsics.misc compiler.cfg.intrinsics.misc ;
compiler.cfg.iterator ;
QUALIFIED: kernel QUALIFIED: kernel
QUALIFIED: arrays QUALIFIED: arrays
QUALIFIED: byte-arrays QUALIFIED: byte-arrays
@ -95,66 +94,66 @@ IN: compiler.cfg.intrinsics
: enable-fixnum-log2 ( -- ) : enable-fixnum-log2 ( -- )
\ math.integers.private:fixnum-log2 t "intrinsic" set-word-prop ; \ 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:tag [ drop emit-tag ] }
{ \ kernel.private:getenv [ emit-getenv iterate-next ] } { \ kernel.private:getenv [ emit-getenv ] }
{ \ math.private:both-fixnums? [ drop emit-both-fixnums? iterate-next ] } { \ math.private:both-fixnums? [ drop emit-both-fixnums? ] }
{ \ math.private:fixnum+ [ drop [ ##fixnum-add ] [ ##fixnum-add-tail ] emit-fixnum-overflow-op ] } { \ math.private:fixnum+ [ drop [ ##fixnum-add ] emit-fixnum-overflow-op ] }
{ \ math.private:fixnum- [ drop [ ##fixnum-sub ] [ ##fixnum-sub-tail ] emit-fixnum-overflow-op ] } { \ math.private:fixnum- [ drop [ ##fixnum-sub ] emit-fixnum-overflow-op ] }
{ \ math.private:fixnum* [ drop [ i i ##fixnum-mul ] [ i i ##fixnum-mul-tail ] 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 iterate-next ] } { \ math.private:fixnum+fast [ [ ^^add ] [ ^^add-imm ] emit-commutative-fixnum-op ] }
{ \ math.private:fixnum-fast [ [ ^^sub ] [ ^^sub-imm ] emit-fixnum-op iterate-next ] } { \ math.private:fixnum-fast [ [ ^^sub ] [ ^^sub-imm ] emit-fixnum-op ] }
{ \ math.private:fixnum-bitand [ [ ^^and ] [ ^^and-imm ] emit-commutative-fixnum-op iterate-next ] } { \ math.private:fixnum-bitand [ [ ^^and ] [ ^^and-imm ] emit-commutative-fixnum-op ] }
{ \ math.private:fixnum-bitor [ [ ^^or ] [ ^^or-imm ] emit-commutative-fixnum-op iterate-next ] } { \ math.private:fixnum-bitor [ [ ^^or ] [ ^^or-imm ] emit-commutative-fixnum-op ] }
{ \ math.private:fixnum-bitxor [ [ ^^xor ] [ ^^xor-imm ] emit-commutative-fixnum-op iterate-next ] } { \ math.private:fixnum-bitxor [ [ ^^xor ] [ ^^xor-imm ] emit-commutative-fixnum-op ] }
{ \ math.private:fixnum-shift-fast [ emit-fixnum-shift-fast iterate-next ] } { \ math.private:fixnum-shift-fast [ emit-fixnum-shift-fast ] }
{ \ math.private:fixnum-bitnot [ drop emit-fixnum-bitnot iterate-next ] } { \ math.private:fixnum-bitnot [ drop emit-fixnum-bitnot ] }
{ \ math.integers.private:fixnum-log2 [ drop emit-fixnum-log2 iterate-next ] } { \ math.integers.private:fixnum-log2 [ drop emit-fixnum-log2 ] }
{ \ math.private:fixnum*fast [ emit-fixnum*fast iterate-next ] } { \ math.private:fixnum*fast [ emit-fixnum*fast ] }
{ \ math.private:fixnum< [ cc< emit-fixnum-comparison iterate-next ] } { \ math.private:fixnum< [ cc< emit-fixnum-comparison ] }
{ \ math.private:fixnum<= [ cc<= emit-fixnum-comparison iterate-next ] } { \ math.private:fixnum<= [ cc<= emit-fixnum-comparison ] }
{ \ math.private:fixnum>= [ cc>= emit-fixnum-comparison iterate-next ] } { \ math.private:fixnum>= [ cc>= emit-fixnum-comparison ] }
{ \ math.private:fixnum> [ cc> emit-fixnum-comparison iterate-next ] } { \ math.private:fixnum> [ cc> emit-fixnum-comparison ] }
{ \ kernel:eq? [ cc= emit-eq iterate-next ] } { \ kernel:eq? [ emit-eq ] }
{ \ math.private:bignum>fixnum [ drop emit-bignum>fixnum iterate-next ] } { \ math.private:bignum>fixnum [ drop emit-bignum>fixnum ] }
{ \ math.private:fixnum>bignum [ drop emit-fixnum>bignum iterate-next ] } { \ math.private:fixnum>bignum [ drop emit-fixnum>bignum ] }
{ \ math.private:float+ [ drop [ ^^add-float ] emit-float-op iterate-next ] } { \ math.private:float+ [ drop [ ^^add-float ] emit-float-op ] }
{ \ math.private:float- [ drop [ ^^sub-float ] emit-float-op iterate-next ] } { \ math.private:float- [ drop [ ^^sub-float ] emit-float-op ] }
{ \ math.private:float* [ drop [ ^^mul-float ] emit-float-op iterate-next ] } { \ math.private:float* [ drop [ ^^mul-float ] emit-float-op ] }
{ \ math.private:float/f [ drop [ ^^div-float ] emit-float-op iterate-next ] } { \ math.private:float/f [ drop [ ^^div-float ] emit-float-op ] }
{ \ math.private:float< [ drop cc< emit-float-comparison iterate-next ] } { \ math.private:float< [ drop cc< emit-float-comparison ] }
{ \ math.private:float<= [ drop cc<= emit-float-comparison iterate-next ] } { \ math.private:float<= [ drop cc<= emit-float-comparison ] }
{ \ math.private:float>= [ drop cc>= emit-float-comparison iterate-next ] } { \ math.private:float>= [ drop cc>= emit-float-comparison ] }
{ \ math.private:float> [ drop cc> emit-float-comparison iterate-next ] } { \ math.private:float> [ drop cc> emit-float-comparison ] }
{ \ math.private:float= [ drop cc= emit-float-comparison iterate-next ] } { \ math.private:float= [ drop cc= emit-float-comparison ] }
{ \ math.private:float>fixnum [ drop emit-float>fixnum iterate-next ] } { \ math.private:float>fixnum [ drop emit-float>fixnum ] }
{ \ math.private:fixnum>float [ drop emit-fixnum>float iterate-next ] } { \ math.private:fixnum>float [ drop emit-fixnum>float ] }
{ \ slots.private:slot [ emit-slot iterate-next ] } { \ slots.private:slot [ emit-slot ] }
{ \ slots.private:set-slot [ emit-set-slot iterate-next ] } { \ slots.private:set-slot [ emit-set-slot ] }
{ \ strings.private:string-nth [ drop emit-string-nth iterate-next ] } { \ strings.private:string-nth [ drop emit-string-nth ] }
{ \ strings.private:set-string-nth-fast [ drop emit-set-string-nth-fast iterate-next ] } { \ strings.private:set-string-nth-fast [ drop emit-set-string-nth-fast ] }
{ \ classes.tuple.private:<tuple-boa> [ emit-<tuple-boa> iterate-next ] } { \ classes.tuple.private:<tuple-boa> [ emit-<tuple-boa> ] }
{ \ arrays:<array> [ emit-<array> iterate-next ] } { \ arrays:<array> [ emit-<array> ] }
{ \ byte-arrays:<byte-array> [ emit-<byte-array> iterate-next ] } { \ byte-arrays:<byte-array> [ emit-<byte-array> ] }
{ \ byte-arrays:(byte-array) [ emit-(byte-array) iterate-next ] } { \ byte-arrays:(byte-array) [ emit-(byte-array) ] }
{ \ kernel:<wrapper> [ emit-simple-allot iterate-next ] } { \ kernel:<wrapper> [ emit-simple-allot ] }
{ \ alien.accessors:alien-unsigned-1 [ 1 emit-alien-unsigned-getter iterate-next ] } { \ alien.accessors:alien-unsigned-1 [ 1 emit-alien-unsigned-getter ] }
{ \ alien.accessors:set-alien-unsigned-1 [ 1 emit-alien-integer-setter iterate-next ] } { \ alien.accessors:set-alien-unsigned-1 [ 1 emit-alien-integer-setter ] }
{ \ alien.accessors:alien-signed-1 [ 1 emit-alien-signed-getter iterate-next ] } { \ alien.accessors:alien-signed-1 [ 1 emit-alien-signed-getter ] }
{ \ alien.accessors:set-alien-signed-1 [ 1 emit-alien-integer-setter iterate-next ] } { \ alien.accessors:set-alien-signed-1 [ 1 emit-alien-integer-setter ] }
{ \ alien.accessors:alien-unsigned-2 [ 2 emit-alien-unsigned-getter iterate-next ] } { \ alien.accessors:alien-unsigned-2 [ 2 emit-alien-unsigned-getter ] }
{ \ alien.accessors:set-alien-unsigned-2 [ 2 emit-alien-integer-setter iterate-next ] } { \ alien.accessors:set-alien-unsigned-2 [ 2 emit-alien-integer-setter ] }
{ \ alien.accessors:alien-signed-2 [ 2 emit-alien-signed-getter iterate-next ] } { \ alien.accessors:alien-signed-2 [ 2 emit-alien-signed-getter ] }
{ \ alien.accessors:set-alien-signed-2 [ 2 emit-alien-integer-setter iterate-next ] } { \ alien.accessors:set-alien-signed-2 [ 2 emit-alien-integer-setter ] }
{ \ alien.accessors:alien-unsigned-4 [ 4 emit-alien-unsigned-getter iterate-next ] } { \ alien.accessors:alien-unsigned-4 [ 4 emit-alien-unsigned-getter ] }
{ \ alien.accessors:set-alien-unsigned-4 [ 4 emit-alien-integer-setter iterate-next ] } { \ alien.accessors:set-alien-unsigned-4 [ 4 emit-alien-integer-setter ] }
{ \ alien.accessors:alien-signed-4 [ 4 emit-alien-signed-getter iterate-next ] } { \ alien.accessors:alien-signed-4 [ 4 emit-alien-signed-getter ] }
{ \ alien.accessors:set-alien-signed-4 [ 4 emit-alien-integer-setter iterate-next ] } { \ alien.accessors:set-alien-signed-4 [ 4 emit-alien-integer-setter ] }
{ \ alien.accessors:alien-cell [ emit-alien-cell-getter iterate-next ] } { \ alien.accessors:alien-cell [ emit-alien-cell-getter ] }
{ \ alien.accessors:set-alien-cell [ emit-alien-cell-setter iterate-next ] } { \ alien.accessors:set-alien-cell [ emit-alien-cell-setter ] }
{ \ alien.accessors:alien-float [ single-float-regs emit-alien-float-getter iterate-next ] } { \ alien.accessors:alien-float [ single-float-regs emit-alien-float-getter ] }
{ \ alien.accessors:set-alien-float [ single-float-regs emit-alien-float-setter iterate-next ] } { \ alien.accessors:set-alien-float [ single-float-regs emit-alien-float-setter ] }
{ \ alien.accessors:alien-double [ double-float-regs emit-alien-float-getter iterate-next ] } { \ alien.accessors:alien-double [ double-float-regs emit-alien-float-getter ] }
{ \ alien.accessors:set-alien-double [ double-float-regs emit-alien-float-setter iterate-next ] } { \ alien.accessors:set-alien-double [ double-float-regs emit-alien-float-setter ] }
} case ; } case ;

45
basis/compiler/cfg/iterator/iterator.factor
View File

@ -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
basis/compiler/cfg/iterator/summary.txt
View File

@ -1 +0,0 @@
Utility for iterating for high-level IR

5
basis/compiler/cfg/linear-scan/assignment/assignment.factor
View File

@ -50,9 +50,12 @@ ERROR: already-spilled ;
: handle-spill ( live-interval -- ) : handle-spill ( live-interval -- )
dup spill-to>> [ [ record-spill ] [ insert-spill ] bi ] [ drop ] if ; 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 -- ) : insert-copy ( live-interval -- )
{ {
[ split-next>> reg>> ] [ next-interval reg>> ]
[ reg>> ] [ reg>> ]
[ vreg>> reg-class>> ] [ vreg>> reg-class>> ]
[ end>> ] [ end>> ]

13
basis/compiler/cfg/linearization/linearization.factor
View File

@ -24,19 +24,8 @@ M: insn linearize-insn , drop ;
#! don't need to branch. #! don't need to branch.
[ number>> ] bi@ 1 - = ; inline [ 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 -- ) : emit-branch ( basic-block successor -- )
{ 2dup useless-branch? [ 2drop ] [ nip number>> _branch ] if ;
{ [ 2dup useless-branch? ] [ 2drop ] }
{ [ dup branch-to-branch? ] [ nip linearize-basic-block ] }
[ nip number>> _branch ]
} cond ;
M: ##branch linearize-insn M: ##branch linearize-insn
drop dup successors>> first emit-branch ; drop dup successors>> first emit-branch ;

13
basis/compiler/cfg/optimizer/optimizer.factor
View File

@ -1,12 +1,15 @@
! Copyright (C) 2008, 2009 Slava Pestov. ! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences accessors combinators namespaces USING: kernel sequences accessors combinators namespaces
compiler.cfg.tco
compiler.cfg.predecessors compiler.cfg.predecessors
compiler.cfg.useless-blocks compiler.cfg.useless-conditionals
compiler.cfg.stack-analysis compiler.cfg.stack-analysis
compiler.cfg.branch-splitting
compiler.cfg.alias-analysis compiler.cfg.alias-analysis
compiler.cfg.value-numbering compiler.cfg.value-numbering
compiler.cfg.dce compiler.cfg.dce
compiler.cfg.branch-folding
compiler.cfg.write-barrier compiler.cfg.write-barrier
compiler.cfg.liveness compiler.cfg.liveness
compiler.cfg.rpo compiler.cfg.rpo
@ -22,14 +25,20 @@ SYMBOL: check-optimizer?
] when ; ] when ;
: optimize-cfg ( cfg -- cfg' ) : 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 compute-predecessors
! delete-useless-blocks
delete-useless-conditionals delete-useless-conditionals
split-branches
compute-predecessors
stack-analysis stack-analysis
compute-liveness compute-liveness
alias-analysis alias-analysis
value-numbering value-numbering
fold-branches
compute-predecessors
eliminate-dead-code eliminate-dead-code
eliminate-write-barriers eliminate-write-barriers
eliminate-phis eliminate-phis

3
basis/compiler/cfg/stack-analysis/stack-analysis.factor
View File

@ -48,7 +48,8 @@ M: ##inc-r visit
! Instructions which don't have any effect on the stack ! Instructions which don't have any effect on the stack
UNION: neutral-insn UNION: neutral-insn
##effect ##effect
##flushable ; ##flushable
##no-tco ;
M: neutral-insn visit , ; M: neutral-insn visit , ;

85
basis/compiler/cfg/tco/tco.factor Normal file
View File

@ -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 ;

11
basis/compiler/cfg/useless-blocks/useless-blocks-tests.factor
View File

@ -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

62
basis/compiler/cfg/useless-blocks/useless-blocks.factor
View File

@ -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
basis/compiler/cfg/useless-blocks/summary.txt → basis/compiler/cfg/useless-conditionals/summary.txt
View File

21
basis/compiler/cfg/useless-conditionals/useless-conditionals.factor Normal file
View File

@ -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 ;

5
basis/compiler/cfg/utilities/utilities.factor
View File

@ -35,8 +35,5 @@ IN: compiler.cfg.utilities
: stop-iterating ( -- next ) end-basic-block f ; : stop-iterating ( -- next ) end-basic-block f ;
: call-height ( ##call -- n )
[ out-d>> length ] [ in-d>> length ] bi - ;
: emit-primitive ( node -- ) : emit-primitive ( node -- )
[ word>> ] [ call-height ] bi ##call ##branch begin-basic-block ; word>> ##call ##branch begin-basic-block ;

2
basis/compiler/codegen/codegen.factor
View File

@ -67,6 +67,8 @@ SYMBOL: labels
: lookup-label ( id -- label ) : lookup-label ( id -- label )
labels get [ drop <label> ] cache ; labels get [ drop <label> ] cache ;
M: ##no-tco generate-insn drop ;
M: ##load-immediate generate-insn M: ##load-immediate generate-insn
[ dst>> register ] [ val>> ] bi %load-immediate ; [ dst>> register ] [ val>> ] bi %load-immediate ;

2
basis/math/vectors/vectors-tests.factor
View File

@ -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.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 [ 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