compiler.cfg.linear-scan.assignment: refactoring

Better definitions for expire-old-intervals, activate-new-intervals and
assign-registers-in-insn.

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

@@ -16,6 +16,21 @@ IN: compiler.cfg.linear-scan.assignment.tests
     T{ ##peek f 37 D: 0 0 } [ assign-insn-defs ] keep
 ] unit-test
 
+! assign-all-registers
+{
+    T{ ##replace-imm f 20 D: 0 f }
+    T{ ##replace f RAX D: 0 f }
+} [
+    ! It doesn't do anything because ##replace-imm isn't a vreg-insn.
+    T{ ##replace-imm { src 20 } { loc D: 0 } } [ assign-all-registers ] keep
+
+    ! This one does something.
+    H{ { 37 RAX } } pending-interval-assoc set
+    H{ { 37 37 } } leader-map set
+    T{ ##replace { src 37 } { loc D: 0 } } clone
+    [ assign-all-registers ] keep
+] unit-test
+
 ! assign-registers
 { } [
     V{ T{ ##inc { loc D: 3 } { insn# 7 } } } 0 insns>block block>cfg { }
@@ -59,23 +74,39 @@ IN: compiler.cfg.linear-scan.assignment.tests
     ] V{ } make
 ] unit-test
 
+: cherry-pick ( seq indices -- seq' )
+    [ swap nth ] with map  ;
+
+: (setup-vreg-spills) ( vreg-defs -- reps leaders spill-slots )
+    [ [ 2 head ] map ]
+    [ [ { 0 2 } cherry-pick ] map ]
+    [
+        [
+            first4 [ nip [ rep-size 2array ] dip 2array ] [ 3drop f ] if*
+        ] map sift
+    ] tri ;
+
+: setup-vreg-spills ( vreg-defs -- )
+    (setup-vreg-spills)
+    [ representations set ] [ leader-map set ] [ spill-slots set ] tri* ;
+
+! vreg>spill-slot
+{ T{ spill-slot { n 990 } } } [
+    { { 10 int-rep 10 T{ spill-slot { n 990 } } } } setup-vreg-spills
+    10 vreg>spill-slot
+] unit-test
+
 ! vreg>reg
 { T{ spill-slot f 16 } } [
-    H{ { 45 double-2-rep } } representations set
-    H{ { 45 45 } } leader-map set
-    H{ { { 45 16 } T{ spill-slot { n 16 } } } } spill-slots set
+    { { 45 double-rep 45 T{ spill-slot { n 16 } } } } setup-vreg-spills
     45 vreg>reg
 ] unit-test
 
 [
     ! It gets very strange if the leader of a vreg has a different
     ! sized representation than the vreg being led.
-    H{
-        { 45 double-2-rep }
-        { 46 double-rep }
-    } representations set
-    H{ { 45 45 } { 46 45 } } leader-map set
-    H{ { { 45 16 } T{ spill-slot { n 16 } } } } spill-slots set
+    { { 45 double-2-rep 45 T{ spill-slot { n 16 } } }
+      { 46 double-rep 45 f } } setup-vreg-spills
     46 vreg>reg
 ] [ bad-vreg? ] must-fail-with
 
@@ -85,7 +116,6 @@ IN: compiler.cfg.linear-scan.assignment.tests
 ] unit-test
 
 { 3 } [
-    { 50 90 95 120 } [ 25 <live-interval> 2array ] map >min-heap
-    pending-interval-heap set 90 expire-old-intervals
-    pending-interval-heap get heap-size
+    90 { 50 90 95 120 } [ 25 <live-interval> 2array ] map >min-heap
+    [ expire-old-intervals ] keep heap-size
 ] unit-test

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

@@ -29,8 +29,7 @@ ERROR: not-spilled-error vreg ;
 
 : vreg>spill-slot ( vreg -- spill-slot )
     dup vreg>reg dup spill-slot?
-    [ nip ]
-    [ drop leader not-spilled-error ] if ;
+    [ nip ] [ drop leader not-spilled-error ] if ;
 
 : vregs>regs ( vregs -- assoc )
     [ dup vreg>reg ] H{ } map>assoc ;
@@ -75,9 +74,8 @@ SYMBOL: machine-live-outs
 : expire-interval ( live-interval -- )
     [ remove-pending ] [ handle-spill ] bi ;
 
-: expire-old-intervals ( n -- )
-    pending-interval-heap get swap '[ _ < ] heap-pop-while
-    [ expire-interval ] each ;
+: expire-old-intervals ( n pending-heap -- )
+    swap '[ _ < ] heap-pop-while [ expire-interval ] each ;
 
 : insert-reload ( live-interval -- )
     [ reg>> ] [ reload-rep>> ] [ reload-from>> ] tri ##reload, ;
@@ -88,18 +86,16 @@ SYMBOL: machine-live-outs
 : activate-interval ( live-interval -- )
     [ add-pending ] [ handle-reload ] bi ;
 
-: activate-new-intervals ( n -- )
-    unhandled-intervals get swap '[ _ = ] heap-pop-while
-    [ activate-interval ] each ;
+: activate-new-intervals ( n unhandled-heap -- )
+    swap '[ _ = ] heap-pop-while [ activate-interval ] each ;
 
 : prepare-insn ( n -- )
-    [ expire-old-intervals ] [ activate-new-intervals ] bi ;
-
-GENERIC: assign-registers-in-insn ( insn -- )
+    [ pending-interval-heap get expire-old-intervals ]
+    [ unhandled-intervals get activate-new-intervals ] bi ;
 
 RENAMING: assign [ vreg>reg ] [ vreg>reg ] [ vreg>reg ]
 
-M: vreg-insn assign-registers-in-insn
+: assign-all-registers ( insn -- )
     [ assign-insn-defs ] [ assign-insn-uses ] [ assign-insn-temps ] tri ;
 
 : assign-gc-roots ( gc-map -- )
@@ -108,17 +104,15 @@ M: vreg-insn assign-registers-in-insn
 : assign-derived-roots ( gc-map -- )
     [ [ [ vreg>spill-slot ] bi@ ] assoc-map ] change-derived-roots drop ;
 
-M: gc-map-insn assign-registers-in-insn
-    [ [ assign-insn-defs ] [ assign-insn-uses ] [ assign-insn-temps ] tri ]
-    [ gc-map>> [ assign-gc-roots ] [ assign-derived-roots ] bi ]
-    bi ;
-
-M: insn assign-registers-in-insn drop ;
+: assign-registers-in-insn ( insn -- )
+    dup assign-all-registers dup gc-map-insn? [
+        gc-map>> [ assign-gc-roots ] [ assign-derived-roots ] bi
+    ] [ drop ] if ;
 
 : begin-block ( bb -- )
     {
         [ basic-block namespaces:set ]
-        [ block-from activate-new-intervals ]
+        [ block-from unhandled-intervals get activate-new-intervals ]
         [ compute-edge-live-in ]
         [ compute-live-in ]
     } cleave ;