compiler.cfg.linear-scan: fix bad interaction between split position calculation and register-clobbering instructions

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

@@ -48,52 +48,33 @@ IN: compiler.cfg.linear-scan.allocation
     2dup spill-at-sync-point?
     [ swap n>> spill f ] [ 2drop t ] if ;
 
-: handle-interval ( live-interval -- )
+GENERIC: handle ( obj -- )
+
+M: live-interval handle
     [ start>> deactivate-intervals ]
     [ start>> activate-intervals ]
     [ assign-register ]
     tri ;
 
-: (handle-sync-point) ( sync-point -- )
+: handle-sync-point ( sync-point -- )
     active-intervals get values
     [ [ spill-at-sync-point ] with filter! drop ] with each ;
 
-: handle-sync-point ( sync-point -- )
+M: sync-point handle ( sync-point -- )
     [ n>> deactivate-intervals ]
-    [ (handle-sync-point) ]
+    [ handle-sync-point ]
     [ n>> activate-intervals ]
     tri ;
 
+: smallest-heap ( heap1 heap2 -- heap )
+    [ [ heap-peek nip ] bi@ <= ] most ;
+
 :: (allocate-registers-step) ( unhandled-intervals unhandled-sync-points -- )
     {
-        {
+        { [ unhandled-intervals heap-empty? ] [ unhandled-sync-points ] }
-            [ unhandled-intervals heap-empty? ]
+        { [ unhandled-sync-points heap-empty? ] [ unhandled-intervals ] }
-            [ unhandled-sync-points heap-pop drop handle-sync-point ]
+        [ unhandled-sync-points unhandled-intervals smallest-heap ]
-        }
+    } cond heap-pop drop handle ;
-        {
-            [ unhandled-sync-points heap-empty? ]
-            [ unhandled-intervals heap-pop drop handle-interval ]
-        }
-        [
-            unhandled-intervals heap-peek :> ( i ik )
-            unhandled-sync-points heap-peek :> ( s sk )
-            {
-                {
-                    [ ik sk < ]
-                    [ unhandled-intervals heap-pop* i handle-interval ]
-                }
-                {
-                    [ ik sk > ]
-                    [ unhandled-sync-points heap-pop* s handle-sync-point ]
-                }
-                [
-                    unhandled-intervals heap-pop*
-                    i handle-interval
-                    s (handle-sync-point)
-                ]
-            } cond
-        ]
-    } cond ;
 
 : (allocate-registers) ( unhandled-intervals unhandled-sync-points -- )
     2dup [ heap-empty? ] both? [ 2drop ] [

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

@@ -79,12 +79,13 @@ ERROR: bad-live-ranges interval ;
 : split-for-spill ( live-interval n -- before after )
     split-interval [ spill-before ] [ spill-after ] bi* ;
 
-: find-use-position ( live-interval new -- n )
+: find-next-use ( live-interval new -- n )
-    [ uses>> ] [ start>> '[ n>> _ >= ] ] bi* find nip
+    [ uses>> ] [ start>> ] bi*
+    '[ [ spill-slot?>> not ] [ n>> ] bi _ >= and ] find nip
     [ n>> ] [ 1/0. ] if* ;
 
 : find-use-positions ( live-intervals new assoc -- )
-    '[ [ _ find-use-position ] [ reg>> ] bi _ add-use-position ] each ;
+    '[ [ _ find-next-use ] [ reg>> ] bi _ add-use-position ] each ;
 
 : active-positions ( new assoc -- )
     [ [ active-intervals-for ] keep ] dip

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

@@ -16,7 +16,7 @@ TUPLE: live-range from to ;
 
 C: <live-range> live-range
 
-TUPLE: vreg-use n def-rep use-rep ;
+TUPLE: vreg-use n def-rep use-rep spill-slot? ;
 
 : <vreg-use> ( n -- vreg-use ) vreg-use new swap >>n ;
 
@@ -36,8 +36,10 @@ reg-class ;
 : last-use? ( insn# uses -- use/f )
     [ drop f ] [ last [ n>> = ] keep and ] if-empty ;
 
-: (add-use) ( insn# live-interval -- use )
+:: (add-use) ( insn# live-interval spill-slot? -- use )
-    uses>> 2dup last-use? dup [ 2nip ] [ drop new-use ] if ;
+    live-interval uses>> :> uses
+    insn# uses last-use? [ insn# uses new-use ] unless*
+    spill-slot? [ t >>spill-slot? ] when ;
 
 GENERIC: covers? ( insn# obj -- ? )
 
@@ -105,28 +107,42 @@ GENERIC: compute-live-intervals* ( insn -- )
 
 M: insn compute-live-intervals* drop ;
 
-:: record-def ( vreg n -- )
+:: record-def ( vreg n spill-slot? -- )
     vreg live-interval :> live-interval
 
     n live-interval shorten-range
-    n live-interval (add-use) vreg rep-of >>def-rep drop ;
+    n live-interval spill-slot? (add-use) vreg rep-of >>def-rep drop ;
 
-:: record-use ( vreg n -- )
+:: record-use ( vreg n spill-slot? -- )
     vreg live-interval :> live-interval
 
     from get n live-interval add-range
-    n live-interval (add-use) vreg rep-of >>use-rep drop ;
+    n live-interval spill-slot? (add-use) vreg rep-of >>use-rep drop ;
 
 :: record-temp ( vreg n -- )
     vreg live-interval :> live-interval
 
     n n live-interval add-range
-    n live-interval (add-use) vreg rep-of >>def-rep drop ;
+    n live-interval f (add-use) vreg rep-of >>def-rep drop ;
 
 M: vreg-insn compute-live-intervals* ( insn -- )
     dup insn#>>
-    [ [ defs-vregs ] dip '[ _ record-def ] each ]
+    [ [ defs-vregs ] dip '[ _ f record-def ] each ]
-    [ [ uses-vregs ] dip '[ _ record-use ] each ]
+    [ [ uses-vregs ] dip '[ _ f record-use ] each ]
+    [ [ temp-vregs ] dip '[ _ record-temp ] each ]
+    2tri ;
+
+M: clobber-insn compute-live-intervals* ( insn -- )
+    dup insn#>>
+    [ [ defs-vregs ] dip '[ _ f record-def ] each ]
+    [ [ uses-vregs ] dip '[ _ t record-use ] each ]
+    [ [ temp-vregs ] dip '[ _ record-temp ] each ]
+    2tri ;
+
+M: hairy-clobber-insn compute-live-intervals* ( insn -- )
+    dup insn#>>
+    [ [ defs-vregs ] dip '[ _ t record-def ] each ]
+    [ [ uses-vregs ] dip '[ _ t record-use ] each ]
     [ [ temp-vregs ] dip '[ _ record-temp ] each ]
     2tri ;