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

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

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

basis/compiler/cfg/builder/blocks/blocks-tests.factor

@@ -1,16 +1,27 @@
-USING: accessors compiler.cfg compiler.cfg.builder.blocks compiler.cfg.stacks
+USING: accessors compiler.cfg compiler.cfg.builder.blocks
-compiler.cfg.utilities kernel namespaces sequences tools.test ;
+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 <basic-block> begin-branch height-state get eq?
+] cfg-unit-test
+
+! make-kill-block
+{ t } [
+    <basic-block> [ make-kill-block ] keep kill-block?>>
+] unit-test
+
 {
     { "succ" "succ" "succ" }
 } [
     3 [ <basic-block> ] replicate <basic-block> "succ" >>number
     dupd connect-Nto1-bbs [ successors>> first number>> ] map
 ] unit-test
-
-{ 33 } [
-    begin-stack-analysis <basic-block> 33 >>number basic-block set
-    (begin-basic-block)
-    basic-block get predecessors>> first number>>
-] unit-test

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 ( -- )
+: end-basic-block ( block -- )
-    basic-block get [ end-local-analysis ] when*
+    [ end-local-analysis ] when* building off basic-block off ;
-    building off
-    basic-block off ;
 
-: (begin-basic-block) ( -- )
+: (begin-basic-block) ( block -- )
-    <basic-block> basic-block get [ over connect-bbs ] when* set-basic-block ;
+    <basic-block> swap [ over connect-bbs ] when* set-basic-block ;
 
-: begin-basic-block ( -- )
+: begin-basic-block ( block -- )
-    basic-block get [ end-local-analysis ] when*
+    dup [ end-local-analysis ] when* (begin-basic-block) ;
-    (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 ( -- )
+: make-kill-block ( block -- )
-    basic-block get t >>kill-block? drop ;
+    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 ( -- )
+: begin-branch ( block -- )
-    height-state [ clone-height-state ] change
+    height-state [ clone-height-state ] change (begin-basic-block) ;
-    (begin-basic-block) ;
 
-: end-branch ( -- pair/f )
+: end-branch ( block -- pair/f )
-    basic-block get dup [
+    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 ;

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

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{ } "foo" insns>block basic-block set
-    [ V{ } "bar" insns>block emit-loop-call ] V{ } make drop
+    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 } }

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 ( -- )
+: begin-word ( block -- )
-    make-kill-block
+    dup make-kill-block
-    ##safepoint,
+    ##safepoint, ##prologue, ##branch,
-    ##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
+    [ swap connect-bbs ] [ end-basic-block ] bi ;
-    end-basic-block ;
 
 : 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 -- )
+: remember-loop ( label block -- )
-    basic-block get swap loops get set-at ;
+    swap loops get set-at ;
 
-: emit-loop ( node -- )
+: emit-loop ( node block -- )
-    ##branch,
+    ##branch, begin-basic-block
-    begin-basic-block
+    [ label>> id>> basic-block get remember-loop ]
-    [ label>> id>> remember-loop ] [ child>> emit-nodes ] bi ;
+    [ 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
+    basic-block get begin-basic-block
-    make-kill-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 ;