compiler.cfg.*: refactoring to remove the initial-basic-block word

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

@@ -1,12 +1,11 @@
 USING: compiler.cfg compiler.cfg.stacks.local compiler.tree help.markup
-help.syntax literals math multiline quotations sequences ;
+help.syntax literals make math multiline quotations sequences ;
 IN: compiler.cfg.builder.blocks
 
 <<
 STRING: ex-emit-trivial-block
-USING: compiler.cfg.builder.blocks prettyprint ;
-initial-basic-block [ [ gensym ##call, ] emit-trivial-block ] { } make drop
-basic-block get .
+USING: compiler.cfg.builder.blocks make prettyprint ;
+<basic-block> set-basic-block [ [ gensym ##call, ] emit-trivial-block ] { } make drop basic-block get .
 T{ basic-block
     { id 2040412 }
     { successors
@@ -52,12 +51,13 @@ HELP: end-branch
 { $values { "pair/f" "two-tuple" } }
 { $description "pair is { final-bb final-height }" } ;
 
-HELP: initial-basic-block
-{ $description "Creates an initial empty " { $link basic-block } " and stores it in the basic-block dynamic variable." } ;
-
 HELP: make-kill-block
 { $description "Marks the current " { $link basic-block } " being processed as a kill block." } ;
 
+HELP: set-basic-block
+{ $values { "basic-block" 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: set-successors
 { $values { "successor" basic-block } { "blocks" sequence } }
 { $description "Set the successor of each block to " { $slot "successor" } "." } ;

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

@@ -1,5 +1,5 @@
-USING: accessors compiler.cfg compiler.cfg.builder.blocks kernel sequences
-tools.test ;
+USING: accessors compiler.cfg compiler.cfg.builder.blocks compiler.cfg.stacks
+kernel namespaces sequences tools.test ;
 IN: compiler.cfg.builder.blocks.tests
 
 {
@@ -9,3 +9,9 @@ IN: compiler.cfg.builder.blocks.tests
     [ set-successors ] keep
     [ 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

@@ -1,8 +1,8 @@
 ! Copyright (C) 2009, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays compiler.cfg compiler.cfg.instructions
-compiler.cfg.stacks compiler.cfg.stacks.local kernel make math
-namespaces sequences ;
+compiler.cfg.stacks compiler.cfg.stacks.local compiler.cfg.utilities kernel
+make math namespaces sequences ;
 SLOT: in-d
 SLOT: out-d
 IN: compiler.cfg.builder.blocks
@@ -11,18 +11,13 @@ IN: compiler.cfg.builder.blocks
     [ basic-block set ] [ instructions>> building set ] bi
     begin-local-analysis ;
 
-: initial-basic-block ( -- )
-    <basic-block> set-basic-block ;
-
 : end-basic-block ( -- )
     basic-block get [ end-local-analysis ] when
     building off
     basic-block off ;
 
 : (begin-basic-block) ( -- )
-    <basic-block>
-    basic-block get [ dupd successors>> push ] when*
-    set-basic-block ;
+    <basic-block> basic-block get [ over connect-bbs ] when* set-basic-block ;
 
 : begin-basic-block ( -- )
     basic-block get [ end-local-analysis ] when

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

@@ -7,7 +7,8 @@ IN: compiler.cfg.builder
 STRING: ex-emit-call
 USING: compiler.cfg.builder compiler.cfg.builder.blocks compiler.cfg.stacks
 kernel make prettyprint ;
-begin-stack-analysis initial-basic-block \ dummy 3 [ emit-call ] { } make drop
+begin-stack-analysis <basic-block> set-basic-block
+\ dummy 3 [ emit-call ] { } make drop
 height-state basic-block [ get . ] bi@
 { { 3 0 } { 0 0 } }
 T{ basic-block

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

@@ -280,6 +280,13 @@ IN: compiler.cfg.builder.tests
     basic-block get successors>> length
 ] unit-test
 
+! begin-cfg
+SYMBOL: foo
+
+{ foo } [
+    begin-stack-analysis \ foo f begin-cfg word>>
+] unit-test
+
 ! store-shuffle
 {
     H{ { D 2 1 } }

basis/compiler/cfg/builder/builder.factor

@@ -12,9 +12,8 @@ SYMBOL: procedures
 SYMBOL: loops
 
 : begin-cfg ( word label -- cfg )
-    initial-basic-block
     H{ } clone loops set
-    [ basic-block get ] 2dip <cfg> dup cfg set ;
+    <basic-block> dup set-basic-block <cfg> dup cfg set ;
 
 : begin-procedure ( word label -- )
     begin-cfg procedures get push ;

basis/compiler/cfg/cfg-docs.factor

@@ -17,6 +17,10 @@ HELP: <basic-block>
 { $values { "bb" basic-block } }
 { $description "Creates a new empty basic block. The " { $slot "id" } " slot is initialized with the value of the basic-block " { $link counter } "." } ;
 
+HELP: <cfg>
+{ $values { "entry" basic-block } { "word" word } { "label" "label" } { "cfg" cfg } }
+{ $description "Constructor for " { $link cfg } "." } ;
+
 HELP: cfg
 { $class-description
   "Call flow graph. It has the following slots:"

basis/compiler/cfg/cfg-tests.factor

@@ -0,0 +1,10 @@
+USING: accessors compiler.cfg kernel tools.test ;
+IN: compiler.cfg.tests
+
+{
+    "word"
+    "label"
+} [
+    "word" "label" <basic-block> <cfg>
+    [ word>> ] [ label>> ] bi
+] unit-test

basis/compiler/cfg/cfg.factor

@@ -27,11 +27,11 @@ frame-pointer?
 post-order linear-order
 predecessors-valid? dominance-valid? loops-valid? ;
 
-: <cfg> ( entry word label -- cfg )
+: <cfg> ( word label entry -- cfg )
     cfg new
+        swap >>entry
         swap >>label
-        swap >>word
-        swap >>entry ;
+        swap >>word ;
 
 : cfg-changed ( cfg -- )
     f >>post-order