compiler.cfg.linear-scan.resolve: get it to work on CFGs with critical edges

basis/compiler/cfg/linear-scan/linear-scan-tests.factor

@@ -1509,6 +1509,7 @@ SYMBOL: linear-scan-result
         compute-liveness
         dup reverse-post-order
         { { int-regs regs } } (linear-scan)
+        cfg-changed
         flatten-cfg 1array mr.
     ] with-scope ;
 
@@ -1803,7 +1804,7 @@ test-diamond
 
 [ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test
 
-[ _spill ] [ 2 get instructions>> first class ] unit-test
+[ _spill ] [ 2 get successors>> first instructions>> first class ] unit-test
 
 [ _spill ] [ 3 get instructions>> second class ] unit-test
 
@@ -1859,7 +1860,7 @@ V{
 
 [ t ] [ 2 get instructions>> [ _spill? ] any? ] unit-test
 
-[ t ] [ 3 get instructions>> [ _spill? ] any? ] unit-test
+[ t ] [ 3 get predecessors>> first instructions>> [ _spill? ] any? ] unit-test
 
 [ t ] [ 5 get instructions>> [ _reload? ] any? ] unit-test
 
@@ -1926,7 +1927,7 @@ V{
 [ V{ 3 2 1 } ] [ 9 get instructions>> [ _reload? ] filter [ n>> ] map ] unit-test
 
 ! Resolve pass should insert this
-[ _reload ] [ 5 get instructions>> first class ] unit-test
+[ _reload ] [ 5 get predecessors>> first instructions>> first class ] unit-test
 
 ! Some random bug
 V{
@@ -2484,7 +2485,7 @@ test-diamond
 
 [ 1 ] [ 2 get instructions>> [ _spill? ] count ] unit-test
 
-[ 1 ] [ 3 get instructions>> [ _spill? ] count ] unit-test
+[ 1 ] [ 3 get predecessors>> first instructions>> [ _spill? ] count ] unit-test
 
 [ 1 ] [ 4 get instructions>> [ _reload? ] count ] unit-test
 

basis/compiler/cfg/linear-scan/linear-scan.factor

@@ -40,4 +40,5 @@ IN: compiler.cfg.linear-scan
         init-mapping
         dup reverse-post-order machine-registers (linear-scan)
         spill-counts get >>spill-counts
+        cfg-changed
     ] with-scope ;

basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor

@@ -1,7 +0,0 @@
-USING: arrays compiler.cfg.linear-scan.resolve kernel
-tools.test ;
-IN: compiler.cfg.linear-scan.resolve.tests
-
-[ { 1 2 3 4 5 6 } ] [
-    { 3 4 } V{ 1 2 } clone [ { 5 6 } 3append-here ] keep >array
-] unit-test

basis/compiler/cfg/linear-scan/resolve/resolve.factor

@@ -3,6 +3,7 @@
 USING: accessors arrays assocs combinators
 combinators.short-circuit fry kernel locals
 make math sequences
+compiler.cfg.utilities
 compiler.cfg.instructions
 compiler.cfg.linear-scan.assignment
 compiler.cfg.linear-scan.mapping compiler.cfg.liveness ;
@@ -30,42 +31,14 @@ IN: compiler.cfg.linear-scan.resolve
         [ resolve-value-data-flow ] with with each
     ] { } make ;
 
-: fork? ( from to -- ? )
+: perform-mappings ( bb to mappings -- )
-    {
+    dup empty? [ 3drop ] [
-        [ drop successors>> length 1 >= ]
+        mapping-instructions <simple-block>
-        [ nip predecessors>> length 1 = ]
+        insert-basic-block
-    } 2&& ; inline
-
-: insert-position/fork ( from to -- before after )
-    nip instructions>> [ >array ] [ dup delete-all ] bi swap ;
-
-: join? ( from to -- ? )
-    {
-        [ drop successors>> length 1 = ]
-        [ nip predecessors>> length 1 >= ]
-    } 2&& ; inline
-
-: insert-position/join ( from to -- before after )
-    drop instructions>> dup pop 1array ;
-
-: insert-position ( bb to -- before after )
-    {
-        { [ 2dup fork? ] [ insert-position/fork ] }
-        { [ 2dup join? ] [ insert-position/join ] }
-    } cond ;
-
-: 3append-here ( seq2 seq1 seq3 -- )
-    #! Mutate seq1
-    swap '[ _ push-all ] bi@ ;
-
-: perform-mappings ( mappings bb to -- )
-    pick empty? [ 3drop ] [
-        [ mapping-instructions ] 2dip
-        insert-position 3append-here
     ] if ;
 
 : resolve-edge-data-flow ( bb to -- )
-    [ compute-mappings ] [ perform-mappings ] 2bi ;
+    2dup compute-mappings perform-mappings ;
 
 : resolve-block-data-flow ( bb -- )
     dup successors>> [ resolve-edge-data-flow ] with each ;

basis/compiler/cfg/utilities/utilities.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors assocs combinators combinators.short-circuit
 compiler.cfg compiler.cfg.instructions cpu.architecture kernel
-layouts locals make math namespaces sequences sets vectors ;
+layouts locals make math namespaces sequences sets vectors fry ;
 IN: compiler.cfg.utilities
 
 : value-info-small-fixnum? ( value-info -- ? )
@@ -74,12 +74,12 @@ SYMBOL: added-instructions
     to predecessors>> [ dup from eq? [ drop bb ] when ] change-each
     from successors>> [ dup to eq? [ drop bb ] when ] change-each ;
 
-:: insert-basic-blocks ( bb -- )
+: <simple-block> ( insns -- bb )
-    added-instructions get
+    <basic-block>
-    [| predecessor instructions |
+    swap >vector
-        \ ##branch new-insn instructions push
+    \ ##branch new-insn over push
-        predecessor bb
+    >>instructions ;
-        <basic-block> instructions >>instructions
-        insert-basic-block
-    ] assoc-each ;
 
+: insert-basic-blocks ( bb -- )
+    [ added-instructions get ] dip
+    '[ [ _ ] dip <simple-block> insert-basic-block ] assoc-each ;