compiler.cfg.*: new word connect-Nto1-bbs

using that word predecessors is already up-to-date so calling needs-predecessors isn't needed

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

@@ -58,10 +58,6 @@ 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" } "." } ;
-
 HELP: with-branch
 { $values { "quot" quotation } { "pair/f" "a pair or f" } }
 { $description "The pair is either " { $link f } " or a two-tuple containing a " { $link basic-block } " and a " { $link height-state } " two-tuple." } ;

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

@@ -1,13 +1,12 @@
 USING: accessors compiler.cfg compiler.cfg.builder.blocks compiler.cfg.stacks
-kernel namespaces sequences tools.test ;
+compiler.cfg.utilities kernel namespaces sequences tools.test ;
 IN: compiler.cfg.builder.blocks.tests
 
 {
     { "succ" "succ" "succ" }
 } [
-    <basic-block> "succ" >>number 3 [ <basic-block> ] replicate
-    [ set-successors ] keep
-    [ successors>> first number>> ] map
+    3 [ <basic-block> ] replicate <basic-block> "succ" >>number
+    dupd connect-Nto1-bbs [ successors>> first number>> ] map
 ] unit-test
 
 { 33 } [

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

@@ -1,7 +1,7 @@
 ! 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 compiler.cfg.utilities kernel
+compiler.cfg.stacks compiler.cfg.stacks.local compiler.cfg.utilities fry kernel
 make math namespaces sequences ;
 SLOT: in-d
 SLOT: out-d
@@ -55,14 +55,11 @@ IN: compiler.cfg.builder.blocks
 : with-branch ( quot -- pair/f )
     [ begin-branch call end-branch ] with-scope ; inline
 
-: set-successors ( successor blocks -- )
-    [ successors>> push ] with each ;
-
 : emit-conditional ( branches -- )
     ! branches is a sequence of pairs as above
     end-basic-block
     sift [
         dup first second height-state set
         begin-basic-block
-        [ basic-block get ] dip [ first ] map set-successors
+        [ first ] map basic-block get connect-Nto1-bbs
     ] unless-empty ;

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

@@ -280,6 +280,14 @@ IN: compiler.cfg.builder.tests
     basic-block get successors>> length
 ] unit-test
 
+! emit-loop-call
+{ "bar" } [
+    V{ } "foo" insns>block basic-block set
+    begin-stack-analysis begin-local-analysis [
+        V{ } "bar" insns>block emit-loop-call
+    ] V{ } make drop basic-block get successors>> first number>>
+] unit-test
+
 ! begin-cfg
 SYMBOL: foo
 

basis/compiler/cfg/builder/builder.factor

@@ -5,7 +5,8 @@ compiler.cfg.builder.blocks compiler.cfg.comparisons
 compiler.cfg.hats compiler.cfg.instructions
 compiler.cfg.intrinsics compiler.cfg.registers
 compiler.cfg.stacks compiler.cfg.stacks.local compiler.tree
-cpu.architecture fry kernel make math namespaces sequences words ;
+compiler.cfg.utilities cpu.architecture fry kernel make math namespaces
+sequences words ;
 IN: compiler.cfg.builder
 
 SYMBOL: procedures
@@ -61,7 +62,7 @@ GENERIC: emit-node ( node -- )
 : emit-loop-call ( basic-block -- )
     ##safepoint,
     ##branch,
-    basic-block get successors>> push
+    basic-block get swap connect-bbs
     end-basic-block ;
 
 : emit-call ( word height -- )

basis/compiler/cfg/stacks/finalize/finalize.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs compiler.cfg compiler.cfg.instructions
-compiler.cfg.predecessors compiler.cfg.rpo
+USING: accessors assocs compiler.cfg.checker compiler.cfg
+compiler.cfg.instructions compiler.cfg.predecessors compiler.cfg.rpo
 compiler.cfg.stacks.global compiler.cfg.stacks.height
 compiler.cfg.stacks.local compiler.cfg.utilities fry kernel
 locals make math sequences ;
@@ -42,6 +42,4 @@ ERROR: bad-peek dst loc ;
     [ predecessors>> ] keep '[ _ visit-edge ] each ;
 
 : finalize-stack-shuffling ( cfg -- )
-    [ needs-predecessors ]
-    [ [ visit-block ] each-basic-block ]
-    [ cfg-changed ] tri ;
+    [ [ visit-block ] each-basic-block ] [ cfg-changed ] bi ;

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

@@ -1,6 +1,10 @@
 USING: compiler.cfg help.markup help.syntax sequences ;
 IN: compiler.cfg.utilities
 
+HELP: connect-Nto1-bbs
+{ $values { "froms" sequence } { "to" basic-block } }
+{ $description "Connects all basic blocks in 'froms' so that 'to' is a successor of them all." } ;
+
 HELP: insert-basic-block
 { $values { "from" basic-block } { "to" basic-block } { "insns" sequence } }
 { $description "Insert basic block on the edge between 'from' and 'to'." } ;

basis/compiler/cfg/utilities/utilities.factor

@@ -90,5 +90,8 @@ IN: compiler.cfg.utilities
     [ [ successors>> ] dip suffix! drop ]
     [ predecessors>> swap suffix! drop ] 2bi ;
 
+: connect-Nto1-bbs ( froms to -- )
+    '[ _ connect-bbs ] each ;
+
 : make-edges ( block-map edgelist -- )
     [ [ of ] with map first2 connect-bbs ] with each ;