compiler.cfg.*: more fixes to pass basic-block on the stack than in a

dynamic variable

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 basic-block get begin-word
+        needs-frame-pointer begin-word
         {
             [ params>> callee-parameters ##callback-inputs, ]
             [ params>> box-parameters ]
@@ -177,5 +177,5 @@ M: #alien-callback emit-node
             [ params>> emit-callback-return ]
             [ params>> callback-stack-cleanup ]
         } cleave
-        basic-block get [ end-word ] when
+        basic-block get [ end-word ] when*
     ] with-cfg-builder ;

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

@@ -45,7 +45,7 @@ HELP: call-height
 
 HELP: emit-trivial-block
 { $values { "quot" quotation } }
-{ $description "Combinator that emits a trivial block, constructed by calling the supplied quotation." }
+{ $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 ] } } ;
 
 HELP: end-branch

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

@@ -1,6 +1,7 @@
 USING: accessors compiler.cfg compiler.cfg.builder.blocks
-compiler.cfg.stacks.local compiler.cfg.utilities compiler.test kernel
-namespaces sequences tools.test ;
+compiler.cfg.instructions compiler.cfg.stacks.local
+compiler.cfg.utilities compiler.test kernel make namespaces sequences
+tools.test ;
 IN: compiler.cfg.builder.blocks.tests
 
 ! (begin-basic-block)
@@ -14,6 +15,14 @@ IN: compiler.cfg.builder.blocks.tests
     height-state get <basic-block> begin-branch height-state get eq?
 ] cfg-unit-test
 
+! emit-trivial-block
+{
+    V{ T{ ##no-tco } T{ ##branch } }
+} [
+    [ [ drop ##no-tco, ] emit-trivial-block ] V{ } make drop
+    basic-block get successors>> first instructions>>
+] cfg-unit-test
+
 ! make-kill-block
 { t } [
     <basic-block> [ make-kill-block ] keep kill-block?>>

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

@@ -23,8 +23,8 @@ IN: compiler.cfg.builder.blocks
 
 : emit-trivial-block ( quot -- )
     ##branch, basic-block get begin-basic-block
-    call
-    ##branch, basic-block get begin-basic-block ; inline
+    basic-block get [ swap call ] keep
+    ##branch, begin-basic-block ; inline
 
 : make-kill-block ( block -- )
     t swap kill-block?<< ;
@@ -32,13 +32,12 @@ IN: compiler.cfg.builder.blocks
 : call-height ( #call -- n )
     [ out-d>> length ] [ in-d>> length ] bi - ;
 
-: emit-call-block ( word height -- )
-    adjust-d ##call, basic-block get make-kill-block ;
+: emit-call-block ( word height block -- )
+    make-kill-block adjust-d ##call, ;
 
 : emit-primitive ( node -- )
-    [
-        [ word>> ] [ call-height ] bi emit-call-block
-    ] emit-trivial-block ;
+    [ word>> ] [ call-height ] bi
+    [ emit-call-block ] emit-trivial-block ;
 
 : begin-branch ( block -- )
     height-state [ clone-height-state ] change (begin-basic-block) ;
@@ -57,9 +56,9 @@ IN: compiler.cfg.builder.blocks
         basic-block get end-branch
     ] with-scope ; inline
 
-: emit-conditional ( branches -- )
+: emit-conditional ( branches block -- )
     ! branches is a sequence of pairs as above
-    basic-block get end-basic-block
+    end-basic-block
     sift [
         dup first second height-state set
         basic-block get begin-basic-block

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

@@ -1,6 +1,6 @@
 USING: assocs compiler.cfg compiler.cfg.builder.blocks
-compiler.cfg.stacks.local compiler.tree help.markup help.syntax
-kernel literals math multiline sequences vectors words ;
+compiler.cfg.stacks.local compiler.tree help.markup help.syntax kernel
+literals math multiline quotations sequences vectors words ;
 IN: compiler.cfg.builder
 
 <<
@@ -44,6 +44,10 @@ H{
 ;
 >>
 
+HELP: build-cfg
+{ $values { "nodes" sequence } { "word" word } { "procedures" sequence } }
+{ $description "Builds one or more cfgs from the given word." } ;
+
 HELP: procedures
 { $var-description "A " { $link vector } " used as temporary storage during cfg construction for all procedures being built." } ;
 
@@ -84,9 +88,9 @@ HELP: trivial-branch?
   }
 } ;
 
-HELP: build-cfg
-{ $values { "nodes" sequence } { "word" word } { "procedures" sequence } }
-{ $description "Builds one or more cfgs from the given word." } ;
+HELP: with-cfg-builder
+{ $values { "nodes" sequence } { "word" word } { "label" word } { "quot" quotation } }
+{ $description "Combinator used to begin and end stack analysis so that the given quotation can build the cfg. The quotation is passed the initial basic block on the stack." } ;
 
 ARTICLE: "compiler.cfg.builder"
 "Final stage of compilation generates machine code from dataflow IR"

basis/compiler/cfg/builder/builder.factor

@@ -23,14 +23,14 @@ SYMBOL: loops
     '[
         begin-stack-analysis
         begin-procedure
-        @
+        basic-block get @
         end-stack-analysis
     ] with-scope ; inline
 
 : with-dummy-cfg-builder ( node quot -- )
     [
         [ V{ } clone procedures ] 2dip
-        '[ _ t t [ _ call( node -- ) ] with-cfg-builder ] with-variable
+        '[ _ t t [ drop _ call( node -- ) ] with-cfg-builder ] with-variable
     ] { } make drop ;
 
 GENERIC: emit-node ( node -- )
@@ -44,11 +44,7 @@ GENERIC: emit-node ( node -- )
     begin-basic-block ;
 
 : (build-cfg) ( nodes word label -- )
-    [
-
-        basic-block get begin-word
-        emit-nodes
-    ] with-cfg-builder ;
+    [ begin-word emit-nodes ] with-cfg-builder ;
 
 : build-cfg ( nodes word -- procedures )
     V{ } clone [
@@ -93,7 +89,7 @@ M: #recursive emit-node
     [ emit-nodes ] with-branch ;
 
 : emit-if ( node -- )
-    children>> [ emit-branch ] map emit-conditional ;
+    children>> [ emit-branch ] map basic-block get emit-conditional ;
 
 : trivial-branch? ( nodes -- value ? )
     dup length 1 = [
@@ -136,11 +132,12 @@ M: #dispatch emit-node
     ! though.
     ds-pop ^^offset>slot next-vreg ##dispatch, emit-if ;
 
-M: #call emit-node
+M: #call emit-node ( node -- )
     dup word>> dup "intrinsic" word-prop
     [ emit-intrinsic ] [ swap call-height emit-call ] if ;
 
-M: #call-recursive emit-node [ label>> id>> ] [ call-height ] bi emit-call ;
+M: #call-recursive emit-node ( node -- )
+    [ label>> id>> ] [ call-height ] bi emit-call ;
 
 M: #push emit-node
     literal>> ^^load-literal ds-push ;
@@ -173,18 +170,18 @@ M: #shuffle emit-node ( node -- )
     [ out-vregs/stack ] keep store-height-changes [ first2 store-vregs ] each ;
 
 ! #return
-: end-word ( -- )
-    ##branch,
-    basic-block get begin-basic-block
+: end-word ( block -- )
+    ##branch, begin-basic-block
     basic-block get make-kill-block
     ##safepoint,
     ##epilogue,
     ##return, ;
 
-M: #return emit-node drop end-word ;
+M: #return emit-node ( node -- )
+    drop basic-block get end-word ;
 
-M: #return-recursive emit-node
-    label>> id>> loops get key? [ end-word ] unless ;
+M: #return-recursive emit-node ( node -- )
+    label>> id>> loops get key? [ basic-block get end-word ] unless ;
 
 ! #terminate
 M: #terminate emit-node ( node -- )

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

@@ -1,10 +1,11 @@
 ! Copyright (C) 2008, 2010 Slava Pestov, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays combinators compiler.cfg.builder.blocks
-compiler.cfg.comparisons compiler.cfg.hats
-compiler.cfg.instructions compiler.cfg.stacks.local compiler.cfg.registers
-compiler.cfg.stacks compiler.tree.propagation.info cpu.architecture fry kernel
-layouts math math.intervals namespaces sequences ;
+USING: accessors arrays combinators compiler.cfg
+compiler.cfg.builder.blocks compiler.cfg.comparisons compiler.cfg.hats
+compiler.cfg.instructions compiler.cfg.registers compiler.cfg.stacks
+compiler.cfg.stacks.local compiler.tree.propagation.info
+cpu.architecture fry kernel layouts math math.intervals namespaces
+sequences ;
 IN: compiler.cfg.intrinsics.fixnum
 
 : emit-both-fixnums? ( -- )
@@ -28,7 +29,7 @@ IN: compiler.cfg.intrinsics.fixnum
     ds-peek 0 cc> ##compare-integer-imm-branch,
     [ emit-fixnum-left-shift ] with-branch
     [ emit-fixnum-right-shift ] with-branch
-    2array emit-conditional ;
+    2array basic-block get emit-conditional ;
 
 : emit-fixnum-shift-fast ( node -- )
     node-input-infos second interval>> {
@@ -45,7 +46,7 @@ IN: compiler.cfg.intrinsics.fixnum
 
 : emit-overflow-case ( word -- final-bb )
     [
-        -1 emit-call-block
+        -1 basic-block get emit-call-block
     ] with-branch ;
 
 : emit-fixnum-overflow-op ( quot word -- )
@@ -53,7 +54,7 @@ IN: compiler.cfg.intrinsics.fixnum
     ! of loc>vreg sync
     [ [ (2inputs) [ any-rep ^^copy ] bi@ cc/o ] dip call ] dip
     [ emit-no-overflow-case ] [ emit-overflow-case ] bi* 2array
-    emit-conditional ; inline
+    basic-block get emit-conditional ; inline
 
 : fixnum+overflow ( x y -- z ) [ >bignum ] bi@ + ;
 

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

@@ -51,4 +51,4 @@ IN: compiler.cfg.intrinsics.misc
     if ;
 
 : emit-cleanup-allot ( -- )
-    [ ##no-tco, ] emit-trivial-block ;
+    [ drop ##no-tco, ] emit-trivial-block ;