From 1421779c9e319eea43bd4dc99e833d075861a1dd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Bj=C3=B6rn=20Lindqvist?= Date: Thu, 19 Nov 2015 00:53:46 +0100 Subject: [PATCH] compiler.cfg.*: refactors words to take a block parameter instead of using the basic-block dynamic variable the idea is to make the code easier to follow by limiting the use of dynamic variables --- basis/compiler/cfg/builder/alien/alien.factor | 2 +- .../cfg/builder/blocks/blocks-docs.factor | 6 ++- .../cfg/builder/blocks/blocks-tests.factor | 27 ++++++++---- .../compiler/cfg/builder/blocks/blocks.factor | 44 +++++++++---------- .../compiler/cfg/builder/builder-docs.factor | 2 +- .../compiler/cfg/builder/builder-tests.factor | 14 ++++-- basis/compiler/cfg/builder/builder.factor | 40 ++++++++--------- 7 files changed, 77 insertions(+), 58 deletions(-) diff --git a/basis/compiler/cfg/builder/alien/alien.factor b/basis/compiler/cfg/builder/alien/alien.factor index ad75cd38b9..3515f01f03 100644 --- a/basis/compiler/cfg/builder/alien/alien.factor +++ b/basis/compiler/cfg/builder/alien/alien.factor @@ -169,7 +169,7 @@ M: #alien-assembly emit-node ( node -- ) M: #alien-callback emit-node dup params>> xt>> dup [ - needs-frame-pointer begin-word + needs-frame-pointer basic-block get begin-word { [ params>> callee-parameters ##callback-inputs, ] [ params>> box-parameters ] diff --git a/basis/compiler/cfg/builder/blocks/blocks-docs.factor b/basis/compiler/cfg/builder/blocks/blocks-docs.factor index 4d28e57a75..301d80113c 100644 --- a/basis/compiler/cfg/builder/blocks/blocks-docs.factor +++ b/basis/compiler/cfg/builder/blocks/blocks-docs.factor @@ -29,7 +29,8 @@ T{ basic-block >> HELP: begin-basic-block -{ $description "Terminates the current block and initializes a new " { $link basic-block } " to begin outputting instructions to. The new block is included in the old blocks " { $slot "successors" } "." } ; +{ $values { "block" basic-block } } +{ $description "Terminates the given block and initializes a new " { $link basic-block } " to begin outputting instructions to. The new block is included in the old blocks " { $slot "successors" } "." } ; HELP: call-height { $values { "#call" #call } { "n" number } } @@ -52,7 +53,8 @@ HELP: end-branch { $description "pair is { final-bb final-height }" } ; HELP: make-kill-block -{ $description "Marks the current " { $link basic-block } " being processed as a kill block." } ; +{ $values { "block" basic-block } } +{ $description "Marks the block as a kill block." } ; HELP: set-basic-block { $values { "basic-block" basic-block } } diff --git a/basis/compiler/cfg/builder/blocks/blocks-tests.factor b/basis/compiler/cfg/builder/blocks/blocks-tests.factor index f39fec0e0e..1717064738 100644 --- a/basis/compiler/cfg/builder/blocks/blocks-tests.factor +++ b/basis/compiler/cfg/builder/blocks/blocks-tests.factor @@ -1,16 +1,27 @@ -USING: accessors compiler.cfg compiler.cfg.builder.blocks compiler.cfg.stacks -compiler.cfg.utilities kernel namespaces sequences tools.test ; +USING: accessors compiler.cfg compiler.cfg.builder.blocks +compiler.cfg.stacks.local compiler.cfg.utilities compiler.test kernel +namespaces sequences tools.test ; IN: compiler.cfg.builder.blocks.tests +! (begin-basic-block) +{ 20 } [ + { } 20 insns>block (begin-basic-block) + basic-block get predecessors>> first number>> +] cfg-unit-test + +! begin-branch +{ f } [ + height-state get begin-branch height-state get eq? +] cfg-unit-test + +! make-kill-block +{ t } [ + [ make-kill-block ] keep kill-block?>> +] unit-test + { { "succ" "succ" "succ" } } [ 3 [ ] replicate "succ" >>number dupd connect-Nto1-bbs [ successors>> first number>> ] map ] unit-test - -{ 33 } [ - begin-stack-analysis 33 >>number basic-block set - (begin-basic-block) - basic-block get predecessors>> first number>> -] unit-test diff --git a/basis/compiler/cfg/builder/blocks/blocks.factor b/basis/compiler/cfg/builder/blocks/blocks.factor index 705cc38f8d..75a1e29a36 100644 --- a/basis/compiler/cfg/builder/blocks/blocks.factor +++ b/basis/compiler/cfg/builder/blocks/blocks.factor @@ -12,56 +12,56 @@ IN: compiler.cfg.builder.blocks [ instructions>> building set ] [ begin-local-analysis ] tri ; -: end-basic-block ( -- ) - basic-block get [ end-local-analysis ] when* - building off - basic-block off ; +: end-basic-block ( block -- ) + [ end-local-analysis ] when* building off basic-block off ; -: (begin-basic-block) ( -- ) - basic-block get [ over connect-bbs ] when* set-basic-block ; +: (begin-basic-block) ( block -- ) + swap [ over connect-bbs ] when* set-basic-block ; -: begin-basic-block ( -- ) - basic-block get [ end-local-analysis ] when* - (begin-basic-block) ; +: begin-basic-block ( block -- ) + dup [ end-local-analysis ] when* (begin-basic-block) ; : emit-trivial-block ( quot -- ) - ##branch, begin-basic-block + ##branch, basic-block get begin-basic-block call - ##branch, begin-basic-block ; inline + ##branch, basic-block get begin-basic-block ; inline -: make-kill-block ( -- ) - basic-block get t >>kill-block? drop ; +: make-kill-block ( block -- ) + t swap kill-block?<< ; : call-height ( #call -- n ) [ out-d>> length ] [ in-d>> length ] bi - ; : emit-call-block ( word height -- ) - adjust-d ##call, make-kill-block ; + adjust-d ##call, basic-block get make-kill-block ; : emit-primitive ( node -- ) [ [ word>> ] [ call-height ] bi emit-call-block ] emit-trivial-block ; -: begin-branch ( -- ) - height-state [ clone-height-state ] change - (begin-basic-block) ; +: begin-branch ( block -- ) + height-state [ clone-height-state ] change (begin-basic-block) ; -: end-branch ( -- pair/f ) - basic-block get dup [ +: end-branch ( block -- pair/f ) + dup [ ##branch, end-local-analysis height-state get clone-height-state 2array ] when* ; : with-branch ( quot -- pair/f ) - [ begin-branch call end-branch ] with-scope ; inline + [ + basic-block get begin-branch + call + basic-block get end-branch + ] with-scope ; inline : emit-conditional ( branches -- ) ! branches is a sequence of pairs as above - end-basic-block + basic-block get end-basic-block sift [ dup first second height-state set - begin-basic-block + basic-block get begin-basic-block [ first ] map basic-block get connect-Nto1-bbs ] unless-empty ; diff --git a/basis/compiler/cfg/builder/builder-docs.factor b/basis/compiler/cfg/builder/builder-docs.factor index 6a8b781ac0..3ebb301197 100644 --- a/basis/compiler/cfg/builder/builder-docs.factor +++ b/basis/compiler/cfg/builder/builder-docs.factor @@ -62,7 +62,7 @@ HELP: emit-call { $see-also call-height } ; HELP: emit-loop-call -{ $values { "basic-block" basic-block } } +{ $values { "successor-block" basic-block } { "current-block" basic-block } } { $description "Sets the given block as the successor of the current block. Then ends the block." } ; HELP: emit-node diff --git a/basis/compiler/cfg/builder/builder-tests.factor b/basis/compiler/cfg/builder/builder-tests.factor index b08ab59f27..b6e095f0f5 100644 --- a/basis/compiler/cfg/builder/builder-tests.factor +++ b/basis/compiler/cfg/builder/builder-tests.factor @@ -297,14 +297,15 @@ IN: compiler.cfg.builder.tests { 1 } [ V{ } 0 insns>block basic-block set init-cfg-test - V{ } 1 insns>block [ emit-loop-call ] V{ } make drop + V{ } 1 insns>block [ basic-block get emit-loop-call ] V{ } make drop basic-block get successors>> length ] unit-test ! emit-loop-call { "bar" } [ - V{ } "foo" insns>block basic-block set init-cfg-test - [ V{ } "bar" insns>block emit-loop-call ] V{ } make drop + V{ } "foo" insns>block basic-block set + init-cfg-test + [ V{ } "bar" insns>block basic-block get emit-loop-call ] V{ } make drop basic-block get successors>> first number>> ] unit-test @@ -315,6 +316,13 @@ SYMBOL: foo \ foo f begin-cfg word>> ] cfg-unit-test +! remember-loop +{ 20 } [ + H{ } clone loops set + "hello" { } 20 insns>block remember-loop + loops get "hello" of number>> +] cfg-unit-test + ! store-shuffle { H{ { D: 2 1 } } diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor index 34c49fc864..150b9baea5 100644 --- a/basis/compiler/cfg/builder/builder.factor +++ b/basis/compiler/cfg/builder/builder.factor @@ -38,17 +38,15 @@ GENERIC: emit-node ( node -- ) : emit-nodes ( nodes -- ) [ basic-block get [ emit-node ] [ drop ] if ] each ; -: begin-word ( -- ) - make-kill-block - ##safepoint, - ##prologue, - ##branch, +: begin-word ( block -- ) + dup make-kill-block + ##safepoint, ##prologue, ##branch, begin-basic-block ; : (build-cfg) ( nodes word label -- ) [ - begin-word + basic-block get begin-word emit-nodes ] with-cfg-builder ; @@ -59,15 +57,14 @@ GENERIC: emit-node ( node -- ) ] with-variable ] keep ; -: emit-loop-call ( basic-block -- ) +: emit-loop-call ( successor-block current-block -- ) ##safepoint, ##branch, - basic-block get swap connect-bbs - end-basic-block ; + [ swap connect-bbs ] [ end-basic-block ] bi ; : emit-call ( word height -- ) over loops get key? - [ drop loops get at emit-loop-call ] + [ drop loops get at basic-block get emit-loop-call ] [ [ emit-call-block ] emit-trivial-block ] if ; @@ -80,16 +77,16 @@ GENERIC: emit-node ( node -- ) [ [ label>> id>> ] [ recursive-height ] bi emit-call ] [ [ child>> ] [ label>> word>> ] [ label>> id>> ] tri (build-cfg) ] bi ; -: remember-loop ( label -- ) - basic-block get swap loops get set-at ; +: remember-loop ( label block -- ) + swap loops get set-at ; -: emit-loop ( node -- ) - ##branch, - begin-basic-block - [ label>> id>> remember-loop ] [ child>> emit-nodes ] bi ; +: emit-loop ( node block -- ) + ##branch, begin-basic-block + [ label>> id>> basic-block get remember-loop ] + [ child>> emit-nodes ] bi ; M: #recursive emit-node - dup label>> loop?>> [ emit-loop ] [ emit-recursive ] if ; + dup label>> loop?>> [ basic-block get emit-loop ] [ emit-recursive ] if ; ! #if : emit-branch ( obj -- pair/f ) @@ -172,14 +169,14 @@ M: #push emit-node [ make-input-map ] [ mapping>> ] [ extract-outputs ] tri [ first2 [ [ of of peek-loc ] 2with map ] dip 2array ] 2with map ; -M: #shuffle emit-node +M: #shuffle emit-node ( node -- ) [ out-vregs/stack ] keep store-height-changes [ first2 store-vregs ] each ; ! #return : end-word ( -- ) ##branch, - begin-basic-block - make-kill-block + basic-block get begin-basic-block + basic-block get make-kill-block ##safepoint, ##epilogue, ##return, ; @@ -190,7 +187,8 @@ M: #return-recursive emit-node label>> id>> loops get key? [ end-word ] unless ; ! #terminate -M: #terminate emit-node drop ##no-tco, end-basic-block ; +M: #terminate emit-node ( node -- ) + drop ##no-tco, basic-block get end-basic-block ; ! No-op nodes M: #introduce emit-node drop ;