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

diff --git a/basis/compiler/cfg/builder/blocks/blocks-docs.factor b/basis/compiler/cfg/builder/blocks/blocks-docs.factor
index 69186836a6d42f5096b7c49b74a137dfcdec8d00..b96f7969afa9a44936a71b4166bcffe5283065bc 100644 (file)
--- a/basis/compiler/cfg/builder/blocks/blocks-docs.factor
+++ b/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" } "." } ;

diff --git a/basis/compiler/cfg/builder/blocks/blocks-tests.factor b/basis/compiler/cfg/builder/blocks/blocks-tests.factor
index 6784796d8161c26032cdcd4c1c4d355251d814d8..032802f488b0b16ac5bbc6d8768899aae66d0b24 100644 (file)
--- a/basis/compiler/cfg/builder/blocks/blocks-tests.factor
+++ b/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

diff --git a/basis/compiler/cfg/builder/blocks/blocks.factor b/basis/compiler/cfg/builder/blocks/blocks.factor
index f59a92cf2778f1431f37776691aef0623208e4f3..972695ae74855fe85151299d84d1c6ddada9a76e 100644 (file)
--- a/basis/compiler/cfg/builder/blocks/blocks.factor
+++ b/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

diff --git a/basis/compiler/cfg/builder/builder-docs.factor b/basis/compiler/cfg/builder/builder-docs.factor
index 596600743a6611f20875cf1c9915a194927a69db..fde3973bbeca97f5613b6760fab934ffe50d312f 100644 (file)
--- a/basis/compiler/cfg/builder/builder-docs.factor
+++ b/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

diff --git a/basis/compiler/cfg/builder/builder-tests.factor b/basis/compiler/cfg/builder/builder-tests.factor
index 4dfbadee418f662035f76c21804059057140bb33..8d3e5b6490548c1546c072520462bc6b19006563 100644 (file)
--- a/basis/compiler/cfg/builder/builder-tests.factor
+++ b/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 } }

diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor
index b656ddb0b3a4b556b227601823bf89f502312ffc..8f4752bc162afd3f213f325241bedc1692d8a283 100644 (file)
--- a/basis/compiler/cfg/builder/builder.factor
+++ b/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 ;

diff --git a/basis/compiler/cfg/cfg-docs.factor b/basis/compiler/cfg/cfg-docs.factor
index 8fd27be9df4d9fa1a831c9da45685d9c9d8010fe..0dd93f37752174763edbb7d772f2c142ebf820ac 100644 (file)
--- a/basis/compiler/cfg/cfg-docs.factor
+++ b/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:"

diff --git a/basis/compiler/cfg/cfg-tests.factor b/basis/compiler/cfg/cfg-tests.factor
new file mode 100644 (file)
index 0000000..c99f1a7
--- /dev/null
+++ b/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

diff --git a/basis/compiler/cfg/cfg.factor b/basis/compiler/cfg/cfg.factor
index 6628ce0aae94c6c94df54fce57ea965418acb58f..a5e056d455a258fa1b1291cebdd36688e26c9cdb 100644 (file)
--- a/basis/compiler/cfg/cfg.factor
+++ b/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