From 5c6c3ecd85be2a6c63617149f5f578b1e990f1f0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 30 Jun 2009 20:13:35 -0500 Subject: [PATCH] compiler.cfg.tco: Tail call optimization moved out of compiler.cfg.builder into its own pass --- basis/compiler/cfg/builder/builder.factor | 74 ++++------- .../cfg/intrinsics/fixnum/fixnum.factor | 16 +-- .../compiler/cfg/intrinsics/intrinsics.factor | 125 +++++++++--------- basis/compiler/cfg/iterator/iterator.factor | 45 ------- basis/compiler/cfg/iterator/summary.txt | 1 - .../cfg/linearization/linearization.factor | 13 +- basis/compiler/cfg/optimizer/optimizer.factor | 2 + basis/compiler/cfg/tco/tco.factor | 83 ++++++++++++ 8 files changed, 180 insertions(+), 179 deletions(-) delete mode 100644 basis/compiler/cfg/iterator/iterator.factor delete mode 100644 basis/compiler/cfg/iterator/summary.txt create mode 100644 basis/compiler/cfg/tco/tco.factor diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor index d323263fc7..f4421e3ef4 100755 --- a/basis/compiler/cfg/builder/builder.factor +++ b/basis/compiler/cfg/builder/builder.factor @@ -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 -- ) ##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 ; diff --git a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor index cb5f2e926d..0b391b7de9 100644 --- a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor +++ b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor @@ -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 diff --git a/basis/compiler/cfg/intrinsics/intrinsics.factor b/basis/compiler/cfg/intrinsics/intrinsics.factor index ec819f9440..3bf54b837b 100644 --- a/basis/compiler/cfg/intrinsics/intrinsics.factor +++ b/basis/compiler/cfg/intrinsics/intrinsics.factor @@ -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: [ emit- iterate-next ] } - { \ arrays: [ emit- iterate-next ] } - { \ byte-arrays: [ emit- iterate-next ] } - { \ byte-arrays:(byte-array) [ emit-(byte-array) iterate-next ] } - { \ kernel: [ 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: [ emit- ] } + { \ arrays: [ emit- ] } + { \ byte-arrays: [ emit- ] } + { \ byte-arrays:(byte-array) [ emit-(byte-array) ] } + { \ kernel: [ 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 ; diff --git a/basis/compiler/cfg/iterator/iterator.factor b/basis/compiler/cfg/iterator/iterator.factor deleted file mode 100644 index eb7f71ad60..0000000000 --- a/basis/compiler/cfg/iterator/iterator.factor +++ /dev/null @@ -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 ; diff --git a/basis/compiler/cfg/iterator/summary.txt b/basis/compiler/cfg/iterator/summary.txt deleted file mode 100644 index b5afb479bd..0000000000 --- a/basis/compiler/cfg/iterator/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Utility for iterating for high-level IR diff --git a/basis/compiler/cfg/linearization/linearization.factor b/basis/compiler/cfg/linearization/linearization.factor index 9e222f1832..8165553a28 100755 --- a/basis/compiler/cfg/linearization/linearization.factor +++ b/basis/compiler/cfg/linearization/linearization.factor @@ -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 ; diff --git a/basis/compiler/cfg/optimizer/optimizer.factor b/basis/compiler/cfg/optimizer/optimizer.factor index e789fc9c21..c8450a1c47 100644 --- a/basis/compiler/cfg/optimizer/optimizer.factor +++ b/basis/compiler/cfg/optimizer/optimizer.factor @@ -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 diff --git a/basis/compiler/cfg/tco/tco.factor b/basis/compiler/cfg/tco/tco.factor new file mode 100644 index 0000000000..9b223ad980 --- /dev/null +++ b/basis/compiler/cfg/tco/tco.factor @@ -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 ; \ No newline at end of file