compiler.cfg.*: more refactoring to remove basic-block get:s

Now almost all words pass around the current basic block on the
stack. Left is updating all intrinsics.

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

@@ -59,7 +59,11 @@ HELP: emit-conditional
 { $description "Emits a sequence of conditional branches to the current " { $link cfg } ". Each branch is a pair where the first item is the entry basic block and the second the branches " { $link height-state } ". 'block' is the block in which the control flow is branched and \"block'\" the block in which it converges again." } ;
 
 HELP: emit-trivial-block
-{ $values { "quot" quotation } }
+{ $values
+  { "block" basic-block }
+  { "quot" quotation }
+  { "block'" basic-block }
+}
 { $description "Combinator that emits a new trivial block, constructed by calling the supplied quotation. The quotation should not end the current block -- only add instructions to it." }
 { $examples { $unchecked-example $[ ex-emit-trivial-block ] } } ;
 
@@ -76,7 +80,11 @@ HELP: set-basic-block
 { $description "Sets the given blocks as the current one by storing it in the basic-block dynamic variable. If it has any " { $slot "instructions" } " the current " { $link building } " is set to those." } ;
 
 HELP: with-branch
-{ $values { "quot" quotation } { "pair/f" { $maybe "pair" } } }
+{ $values
+  { "block" basic-block }
+  { "quot" quotation }
+  { "pair/f" { $maybe "pair" } }
+}
 { $description "The pair is either " { $link f } " or a two-tuple containing a " { $link basic-block } " and a " { $link height-state } " two-tuple." } ;
 
 ARTICLE: "compiler.cfg.builder.blocks"

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

@@ -23,8 +23,9 @@ IN: compiler.cfg.builder.blocks.tests
 {
     V{ T{ ##no-tco } T{ ##branch } }
 } [
-    [ [ drop ##no-tco, ] emit-trivial-block ] V{ } make drop
-    basic-block get successors>> first instructions>>
+    <basic-block> dup set-basic-block
+    [ drop ##no-tco, ] emit-trivial-block
+    predecessors>> first instructions>>
 ] cfg-unit-test
 
 ! end-basic-block

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

@@ -21,10 +21,10 @@ IN: compiler.cfg.builder.blocks
 : begin-basic-block ( block -- block' )
     dup [ end-local-analysis ] when* (begin-basic-block) ;
 
-: emit-trivial-block ( quot: ( ..a block -- ..b ) -- )
-    ##branch, basic-block get begin-basic-block
+: emit-trivial-block ( block quot: ( ..a block' -- ..b ) -- block' )
+    ##branch, swap begin-basic-block
     [ swap call ] keep
-    ##branch, begin-basic-block drop ; inline
+    ##branch, begin-basic-block ; inline
 
 : make-kill-block ( block -- )
     t swap kill-block?<< ;
@@ -35,8 +35,8 @@ IN: compiler.cfg.builder.blocks
 : emit-call-block ( word height block -- )
     make-kill-block adjust-d ##call, ;
 
-: emit-primitive ( node -- )
-    [ word>> ] [ call-height ] bi
+: emit-primitive ( block node -- block' )
+    [ word>> ] [ call-height ] bi rot
     [ emit-call-block ] emit-trivial-block ;
 
 : begin-branch ( block -- block' )
@@ -49,12 +49,8 @@ IN: compiler.cfg.builder.blocks
         height-state get clone-height-state 2array
     ] when* ;
 
-: with-branch ( quot -- pair/f )
-    [
-        basic-block get begin-branch drop
-        call
-        basic-block get end-branch
-    ] with-scope ; inline
+: with-branch ( block quot: ( ..a block -- ..b block' ) -- pair/f )
+    [ [ begin-branch ] dip call end-branch ] with-scope ; inline
 
 : emit-conditional ( block branches -- block' )
     swap end-basic-block

basis/compiler/cfg/builder/builder.factor

@@ -55,9 +55,7 @@ GENERIC: emit-node ( block node -- block' )
     [ swap connect-bbs ] [ end-basic-block ] bi ;
 
 : emit-trivial-call ( block word height -- block' )
-    ##branch, rot begin-basic-block
-    [ emit-call-block ] keep
-    ##branch, begin-basic-block ;
+    rot [ emit-call-block ] emit-trivial-block ;
 
 : emit-call ( block word height -- block' )
     over loops get at [
@@ -81,7 +79,7 @@ M: #recursive emit-node ( block node -- block' )
 
 ! #if
 : emit-branch ( nodes block -- pair/f )
-    [ begin-branch swap emit-nodes end-branch ] with-scope ;
+    [ swap emit-nodes ] with-branch ;
 
 : emit-if ( block node -- block' )
     children>> over '[ _ emit-branch ] map emit-conditional ;

basis/compiler/cfg/intrinsics/alien/alien.factor

@@ -1,11 +1,10 @@
 ! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel sequences alien math classes.algebra fry
-locals combinators combinators.short-circuit cpu.architecture
-compiler.tree.propagation.info compiler.cfg.hats
-compiler.cfg.registers compiler.cfg.stacks
-compiler.cfg.instructions compiler.cfg.utilities
-compiler.cfg.builder.blocks ;
+USING: accessors alien classes.algebra combinators
+combinators.short-circuit compiler.cfg compiler.cfg.builder.blocks
+compiler.cfg.hats compiler.cfg.instructions compiler.cfg.stacks
+compiler.tree.propagation.info cpu.architecture fry kernel locals math
+namespaces sequences ;
 IN: compiler.cfg.intrinsics.alien
 
 : emit-<displaced-alien>? ( node -- ? )
@@ -20,13 +19,13 @@ IN: compiler.cfg.intrinsics.alien
             _ node-input-infos second class>>
             ^^box-displaced-alien
         ] binary-op
-    ] [ emit-primitive ] if ;
+    ] [ basic-block get swap emit-primitive drop ] if ;
 
 :: inline-accessor ( node quot test -- )
     node node-input-infos :> infos
     infos test call
     [ infos quot call ]
-    [ node emit-primitive ] if ; inline
+    [ node basic-block get swap emit-primitive drop ] if ; inline
 
 : inline-load-memory? ( infos -- ? )
     [ first class>> c-ptr class<= ]

basis/compiler/cfg/intrinsics/allot/allot.factor

@@ -1,10 +1,10 @@
 ! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays byte-arrays compiler.cfg.builder.blocks
-compiler.cfg.hats compiler.cfg.instructions compiler.cfg.registers
-compiler.cfg.stacks compiler.constants compiler.tree.propagation.info
-cpu.architecture fry kernel layouts locals math math.order
-sequences ;
+USING: accessors arrays byte-arrays compiler.cfg
+compiler.cfg.builder.blocks compiler.cfg.hats
+compiler.cfg.instructions compiler.cfg.registers compiler.cfg.stacks
+compiler.constants compiler.tree.propagation.info cpu.architecture fry
+kernel layouts locals math math.order namespaces sequences ;
 IN: compiler.cfg.intrinsics.allot
 
 : ##set-slots, ( regs obj class -- )
@@ -28,7 +28,7 @@ IN: compiler.cfg.intrinsics.allot
         ds-drop
         [ tuple-slot-regs ] [ second ^^allot-tuple ] bi
         [ tuple ##set-slots, ] [ ds-push drop ] 2bi
-    ] [ drop emit-primitive ] if ;
+    ] [ drop basic-block get swap emit-primitive drop ] if ;
 
 : store-length ( len reg class -- )
     [ [ ^^load-literal ] dip 1 ] dip type-number ##set-slot-imm, ;
@@ -51,7 +51,7 @@ IN: compiler.cfg.intrinsics.allot
         len reg array store-length
         len reg elt array store-initial-element
         reg ds-push
-    ] [ node emit-primitive ] if ;
+    ] [ node basic-block get swap emit-primitive drop ] if ;
 
 : expand-(byte-array)? ( obj -- ? )
     dup integer? [ 0 1024 between? ] [ drop f ] if ;
@@ -69,7 +69,7 @@ IN: compiler.cfg.intrinsics.allot
 
 : emit-(byte-array) ( node -- )
     dup node-input-infos first literal>> dup expand-(byte-array)?
-    [ nip emit-allot-byte-array drop ] [ drop emit-primitive ] if ;
+    [ nip emit-allot-byte-array drop ] [ drop basic-block get swap emit-primitive drop ] if ;
 
 :: zero-byte-array ( len reg -- )
     0 ^^load-literal :> elt
@@ -83,4 +83,4 @@ IN: compiler.cfg.intrinsics.allot
         :> len
         len emit-allot-byte-array :> reg
         len reg zero-byte-array
-    ] [ drop node emit-primitive ] if ;
+    ] [ drop node basic-block get swap emit-primitive drop ] if ;

basis/compiler/cfg/intrinsics/fixnum/fixnum.factor

@@ -27,8 +27,8 @@ IN: compiler.cfg.intrinsics.fixnum
 
 : emit-fixnum-shift-general ( -- )
     ds-peek 0 cc> ##compare-integer-imm-branch,
-    [ emit-fixnum-left-shift ] with-branch
-    [ emit-fixnum-right-shift ] with-branch
+    basic-block get [ emit-fixnum-left-shift ] with-branch
+    basic-block get [ emit-fixnum-right-shift ] with-branch
     2array basic-block get swap emit-conditional drop ;
 
 : emit-fixnum-shift-fast ( node -- )
@@ -42,11 +42,13 @@ IN: compiler.cfg.intrinsics.fixnum
     '[ _ ^^compare-integer ] binary-op ;
 
 : emit-no-overflow-case ( dst -- final-bb )
-    [ D: -2 inc-stack ds-push ] with-branch ;
+    basic-block get [
+        swap D: -2 inc-stack ds-push
+    ] with-branch ;
 
 : emit-overflow-case ( word -- final-bb )
-    [
-        -1 basic-block get emit-call-block
+    basic-block get [
+        swap -1 basic-block get emit-call-block
     ] with-branch ;
 
 : emit-fixnum-overflow-op ( quot word -- )

basis/compiler/cfg/intrinsics/misc/misc.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors classes.algebra classes.struct
+USING: accessors classes.algebra classes.struct compiler.cfg
 compiler.cfg.builder.blocks compiler.cfg.comparisons compiler.cfg.hats
 compiler.cfg.instructions compiler.cfg.stacks compiler.constants
 compiler.tree.propagation.info cpu.architecture kernel layouts math
@@ -19,13 +19,13 @@ IN: compiler.cfg.intrinsics.misc
         ds-drop
         vm-special-object-offset ^^vm-field
         ds-push
-    ] [ emit-primitive ] ?if ;
+    ] [ basic-block get swap emit-primitive drop ] ?if ;
 
 : emit-set-special-object ( node -- )
     dup node-input-infos second literal>> [
         ds-drop
         [ ds-pop ] dip vm-special-object-offset ##set-vm-field,
-    ] [ emit-primitive ] ?if ;
+    ] [ basic-block get swap emit-primitive drop ] ?if ;
 
 : context-object-offset ( n -- n )
     cells "context-objects" context offset-of + ;
@@ -34,7 +34,7 @@ IN: compiler.cfg.intrinsics.misc
     dup node-input-infos first literal>> [
         "ctx" vm offset-of ^^vm-field
         ds-drop swap context-object-offset cell /i 0 ^^slot-imm ds-push
-    ] [ emit-primitive ] ?if ;
+    ] [ basic-block get swap emit-primitive drop ] ?if ;
 
 : emit-identity-hashcode ( -- )
     [
@@ -47,8 +47,8 @@ IN: compiler.cfg.intrinsics.misc
 : emit-local-allot ( node -- )
     dup node-input-infos first2 [ literal>> ] bi@ 2dup [ integer? ] both?
     [ ds-drop ds-drop f ^^local-allot ^^box-alien ds-push drop ]
-    [ 2drop emit-primitive ]
+    [ 2drop basic-block get swap emit-primitive drop ]
     if ;
 
 : emit-cleanup-allot ( -- )
-    [ drop ##no-tco, ] emit-trivial-block ;
+    basic-block get [ drop ##no-tco, ] emit-trivial-block drop ;

basis/compiler/cfg/intrinsics/slots/slots.factor

@@ -1,10 +1,10 @@
 ! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors classes.algebra classes.builtin
-combinators.short-circuit compiler.cfg.builder.blocks
+combinators.short-circuit compiler.cfg compiler.cfg.builder.blocks
 compiler.cfg.hats compiler.cfg.instructions compiler.cfg.registers
 compiler.cfg.stacks compiler.tree.propagation.info cpu.architecture
-kernel layouts locals math namespaces sequences slots.private ;
+kernel layouts locals math namespaces sequences ;
 IN: compiler.cfg.intrinsics.slots
 
 : class-tag ( class -- tag/f )
@@ -37,7 +37,7 @@ IN: compiler.cfg.intrinsics.slots
         dup second literal>> immediate-slot-offset?
         [ (emit-slot-imm) ] [ (emit-slot) ] if
         ds-push
-    ] [ drop emit-primitive ] if ;
+    ] [ drop basic-block get swap emit-primitive drop ] if ;
 
 :: (emit-set-slot-imm) ( write-barrier? tag slot -- )
     ds-drop
@@ -71,4 +71,4 @@ IN: compiler.cfg.intrinsics.slots
 : emit-set-slot ( node -- )
     dup node>set-slot-data over [
         emit-intrinsic-set-slot drop
-    ] [ 3drop emit-primitive ] if ;
+    ] [ 3drop basic-block get swap emit-primitive drop ] if ;