compiler.cfg.linear-scan: compute-free-pos was broken in the case where more than one inactive interval had the same physical register assigned

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

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors assocs heaps kernel namespaces sequences fry math
-combinators arrays sorting compiler.utilities
+math.order combinators arrays sorting compiler.utilities
 compiler.cfg.linear-scan.live-intervals
 compiler.cfg.linear-scan.allocation.coalescing
 compiler.cfg.linear-scan.allocation.spilling
@@ -12,17 +12,23 @@ IN: compiler.cfg.linear-scan.allocation
 : free-positions ( new -- assoc )
     vreg>> reg-class>> registers get at [ 1/0. ] H{ } map>assoc ;
 
-: active-positions ( new -- assoc )
+: add-use-position ( n reg assoc -- ) [ [ min ] when* ] change-at ;
-    vreg>> active-intervals-for [ reg>> 0 ] H{ } map>assoc ;
 
-: inactive-positions ( new -- assoc )
+: active-positions ( new assoc -- )
-    dup vreg>> inactive-intervals-for
+    [ vreg>> active-intervals-for ] dip
-    [ [ reg>> swap ] keep relevant-ranges intersect-live-ranges ]
+    '[ [ 0 ] dip reg>> _ add-use-position ] each ;
-    with H{ } map>assoc ;
+
+: inactive-positions ( new assoc -- )
+    [ [ vreg>> inactive-intervals-for ] keep ] dip
+    '[
+        [ _ relevant-ranges intersect-live-ranges ] [ reg>> ] bi
+        _ add-use-position
+    ] each ;
 
 : compute-free-pos ( new -- free-pos )
-    [ free-positions ] [ inactive-positions ] [ active-positions ] tri
+    dup free-positions
-    3array assoc-combine >alist alist-max ;
+    [ inactive-positions ] [ active-positions ] [ nip ] 2tri
+    >alist alist-max ;
 
 : no-free-registers? ( result -- ? )
     second 0 = ; inline

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

@@ -104,8 +104,16 @@ GENERIC: assign-registers-in-insn ( insn -- )
 : all-vregs ( insn -- vregs )
     [ defs-vregs ] [ temp-vregs ] [ uses-vregs ] tri 3append ;
 
+SYMBOL: check-assignment?
+
+ERROR: overlapping-registers intervals ;
+
 : active-intervals ( insn -- intervals )
-    insn#>> pending-intervals get [ covers? ] with filter ;
+    insn#>> pending-intervals get [ covers? ] with filter
+    check-assignment? get [
+        dup [ reg>> ] map all-unique?
+        [ overlapping-registers ] unless
+    ] when ;
 
 M: vreg-insn assign-registers-in-insn
     dup [ active-intervals ] [ all-vregs ] bi

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

@@ -18,10 +18,12 @@ compiler.cfg.linear-scan.allocation
 compiler.cfg.linear-scan.allocation.state
 compiler.cfg.linear-scan.allocation.splitting
 compiler.cfg.linear-scan.allocation.spilling
-compiler.cfg.linear-scan.assignment
 compiler.cfg.linear-scan.debugger ;
 
+FROM: compiler.cfg.linear-scan.assignment => check-assignment? ;
+
 check-allocation? on
+check-assignment? on
 
 [
     { T{ live-range f 1 10 } T{ live-range f 15 15 } }
@@ -1417,6 +1419,58 @@ USING: math.private ;
     relevant-ranges intersect-live-ranges
 ] unit-test
 
+! compute-free-pos had problems because it used map>assoc where the sequence
+! had multiple keys
+[ { 0 10 } ] [
+    H{ { int-regs { 0 1 } } } registers set
+    H{
+        { int-regs
+          {
+              T{ live-interval
+                 { vreg V int-regs 1 }
+                 { start 0 }
+                 { end 20 }
+                 { reg 0 }
+                 { ranges V{ T{ live-range f 0 2 } T{ live-range f 10 20 } } }
+                 { uses V{ 0 2 10 20 } }
+              }
+
+              T{ live-interval
+                 { vreg V int-regs 2 }
+                 { start 4 }
+                 { end 40 }
+                 { reg 0 }
+                 { ranges V{ T{ live-range f 4 6 } T{ live-range f 30 40 } } }
+                 { uses V{ 4 6 30 40 } }
+              }
+          }
+        }
+    } inactive-intervals set
+    H{
+        { int-regs
+          {
+              T{ live-interval
+                 { vreg V int-regs 3 }
+                 { start 0 }
+                 { end 40 }
+                 { reg 1 }
+                 { ranges V{ T{ live-range f 0 40 } } }
+                 { uses V{ 0 40 } }
+              }
+          }
+        }
+    } active-intervals set
+
+    T{ live-interval
+       { vreg V int-regs 4 }
+        { start 8 }
+        { end 10 }
+        { ranges V{ T{ live-range f 8 10 } } }
+        { uses V{ 8 10 } }
+    }
+    compute-free-pos
+] unit-test
+
 ! Bug in live spill slots calculation
 
 V{ T{ ##prologue } T{ ##branch } } 0 test-bb