compiler.cfg.tco: Tail call optimization moved out of compiler.cfg.builder into its own pass
parent
bc2a6c0ecc
commit
5c6c3ecd85
|
@ -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,19 +67,16 @@ 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 height -- )
|
||||
over loops get key?
|
||||
[ drop loops get at local-recursive-call ]
|
||||
[ ##call ##branch begin-basic-block ]
|
||||
if ;
|
||||
|
||||
! #recursive
|
||||
: recursive-height ( #recursive -- n )
|
||||
|
@ -102,12 +89,11 @@ GENERIC: emit-node ( node -- next )
|
|||
: 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 +107,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,11 +143,11 @@ 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
|
||||
|
@ -173,7 +159,7 @@ M: #call-recursive emit-node [ label>> id>> ] [ call-height ] bi 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 +169,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 ;
|
||||
|
||||
! FFI
|
||||
: return-size ( ctype -- n )
|
||||
|
@ -215,9 +200,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 +214,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 ;
|
||||
|
|
|
@ -5,7 +5,6 @@ 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 ;
|
||||
|
@ -79,15 +78,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
|
||||
|
|
|
@ -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-fixnum-op iterate-next ] }
|
||||
{ \ math.private:fixnum-fast [ [ ^^sub ] [ ^^sub-imm ] emit-fixnum-op iterate-next ] }
|
||||
{ \ math.private:fixnum-bitand [ [ ^^and ] [ ^^and-imm ] emit-fixnum-op iterate-next ] }
|
||||
{ \ math.private:fixnum-bitor [ [ ^^or ] [ ^^or-imm ] emit-fixnum-op iterate-next ] }
|
||||
{ \ math.private:fixnum-bitxor [ [ ^^xor ] [ ^^xor-imm ] emit-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-fixnum-comparison 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-fixnum-op ] }
|
||||
{ \ math.private:fixnum-fast [ [ ^^sub ] [ ^^sub-imm ] emit-fixnum-op ] }
|
||||
{ \ math.private:fixnum-bitand [ [ ^^and ] [ ^^and-imm ] emit-fixnum-op ] }
|
||||
{ \ math.private:fixnum-bitor [ [ ^^or ] [ ^^or-imm ] emit-fixnum-op ] }
|
||||
{ \ math.private:fixnum-bitxor [ [ ^^xor ] [ ^^xor-imm ] emit-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? [ cc= emit-fixnum-comparison ] }
|
||||
{ \ 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
|
|
@ -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,6 +1,7 @@
|
|||
! 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.stack-analysis
|
||||
|
@ -23,6 +24,7 @@ SYMBOL: check-optimizer?
|
|||
|
||||
: optimize-cfg ( cfg -- cfg' )
|
||||
[
|
||||
optimize-tail-calls
|
||||
compute-predecessors
|
||||
! delete-useless-blocks
|
||||
delete-useless-conditionals
|
||||
|
|
|
@ -0,0 +1,83 @@
|
|||
! 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.instructions ;
|
||||
IN: compiler.cfg.tco
|
||||
|
||||
! Tail call optimization. You must run compute-predecessors after this
|
||||
|
||||
: return? ( bb -- ? )
|
||||
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 \ ##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 ;
|
Loading…
Reference in New Issue