compiler.cfg.linearization.order: basic blocks were being inserted twice if some blocks had repeated successors, causing problems for register allocation

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

@@ -28,10 +28,12 @@ SYMBOL: pending-interval-assoc
 : remove-pending ( live-interval -- )
     vreg>> pending-interval-assoc get delete-at ;
 
+ERROR: bad-vreg vreg ;
+
 : (vreg>reg) ( vreg pending -- reg )
     ! If a live vreg is not in the pending set, then it must
     ! have been spilled.
-    ?at [ spill-slots get at <spill-slot> ] unless ;
+    ?at [ spill-slots get ?at [ <spill-slot> ] [ bad-vreg ] if ] unless ;
 
 : vreg>reg ( vreg -- reg )
     pending-interval-assoc get (vreg>reg) ;
@@ -157,8 +159,6 @@ M: insn assign-registers-in-insn drop ;
 : end-block ( bb -- )
     [ live-out vregs>regs ] keep register-live-outs get set-at ;
 
-ERROR: bad-vreg vreg ;
-
 : vreg-at-start ( vreg bb -- state )
     register-live-ins get at ?at [ bad-vreg ] unless ;
 

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

@@ -4,12 +4,18 @@ USING: kernel accessors math sequences grouping namespaces
 compiler.cfg.linearization.order ;
 IN: compiler.cfg.linear-scan.numbering
 
-: number-instructions ( rpo -- )
+ERROR: already-numbered insn ;
-    linearization-order 0 [
+
-        instructions>> [
+: number-instruction ( n insn -- n' )
-            [ (>>insn#) ] [ drop 2 + ] 2bi
+    [ nip dup insn#>> [ already-numbered ] [ drop ] if ]
-        ] each
+    [ (>>insn#) ]
-    ] reduce drop ;
+    [ drop 2 + ]
+    2tri ;
+
+: number-instructions ( cfg -- )
+    linearization-order
+    0 [ instructions>> [ number-instruction ] each ] reduce
+    drop ;
 
 SYMBOL: check-numbering?
 

basis/compiler/cfg/linearization/order/order-tests.factor

@@ -0,0 +1,14 @@
+USING: compiler.cfg.debugger compiler.cfg compiler.cfg.linearization.order
+kernel accessors sequences sets tools.test ;
+IN: compiler.cfg.linearization.order.tests
+
+V{ } 0 test-bb
+
+V{ } 1 test-bb
+
+V{ } 2 test-bb
+
+0 { 1 1 } edges
+1 2 edge
+
+[ t ] [ cfg new 0 get >>entry linearization-order [ id>> ] map all-unique? ] unit-test

basis/compiler/cfg/linearization/order/order.factor

@@ -3,7 +3,7 @@
 USING: accessors assocs deques dlists kernel make sorting
 namespaces sequences combinators combinators.short-circuit
 fry math sets compiler.cfg.rpo compiler.cfg.utilities
-compiler.cfg.loop-detection ;
+compiler.cfg.loop-detection compiler.cfg.predecessors ;
 IN: compiler.cfg.linearization.order
 
 ! This is RPO except loops are rotated. Based on SBCL's src/compiler/control.lisp
@@ -56,10 +56,12 @@ SYMBOLS: work-list loop-heads visited ;
     successors>> <reversed> [ loop-nesting-at ] sort-with ;
 
 : process-block ( bb -- )
+    dup visited? [ drop ] [
         [ , ]
         [ visited get conjoin ]
         [ sorted-successors [ process-successor ] each ]
-    tri ;
+        tri
+    ] if ;
 
 : (linearization-order) ( cfg -- bbs )
     init-linearization-order
@@ -69,7 +71,7 @@ SYMBOLS: work-list loop-heads visited ;
 PRIVATE>
 
 : linearization-order ( cfg -- bbs )
-    needs-post-order needs-loops
+    needs-post-order needs-loops needs-predecessors
 
     dup linear-order>> [ ] [
         dup (linearization-order)

basis/compiler/tests/codegen.factor

@@ -416,3 +416,18 @@ cell 4 = [
 [ 1 "0.169967142900241" "0.9854497299884601" ] [ 1.4 1 [ swap >float [ fcos ] [ fsin ] bi ] compile-call [ number>string ] bi@ ] unit-test
 
 [ 6.0 ] [ 1.0 [ >float 3.0 + [ B{ 0 0 0 0 } 0 set-alien-float ] [ 2.0 + ] bi ] compile-call ] unit-test
+
+! Bug in linearization
+[ 283686952174081 ] [
+    B{ 1 1 1 1 } [
+        { byte-array } declare
+        [ 0 2 ] dip
+        [
+            [ drop ] 2dip
+            [
+                swap 1 < [ [ ] dip ] [ [ ] dip ] if
+                0 alien-signed-4
+            ] curry dup bi *
+        ] curry each-integer
+    ] compile-call
+] unit-test