compiler.cfg.linear-scan.assignment: more efficient data structures

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

@@ -16,10 +16,16 @@ IN: compiler.cfg.linear-scan.assignment
 
 ! This contains both active and inactive intervals; any interval
 ! such that start <= insn# <= end is in this set.
-SYMBOL: pending-intervals
+SYMBOL: pending-interval-heap
+SYMBOL: pending-interval-assoc
 
-: add-active ( live-interval -- )
+: add-pending ( live-interval -- )
-    dup end>> pending-intervals get heap-push ;
+    [ dup end>> pending-interval-heap get heap-push ]
+    [ [ reg>> ] [ vreg>> ] bi pending-interval-assoc get set-at ]
+    bi ;
+
+: remove-pending ( live-interval -- )
+    vreg>> pending-interval-assoc get delete-at ;
 
 ! Minheap of live intervals which still need a register allocation
 SYMBOL: unhandled-intervals
@@ -37,7 +43,8 @@ SYMBOL: register-live-ins
 SYMBOL: register-live-outs
 
 : init-assignment ( live-intervals -- )
-    <min-heap> pending-intervals set
+    <min-heap> pending-interval-heap set
+    H{ } clone pending-interval-assoc set
     <min-heap> unhandled-intervals set
     H{ } clone register-live-ins set
     H{ } clone register-live-outs set
@@ -49,16 +56,19 @@ SYMBOL: register-live-outs
 : handle-spill ( live-interval -- )
     dup spill-to>> [ insert-spill ] [ drop ] if ;
 
+: expire-interval ( live-interval -- )
+    [ remove-pending ] [ handle-spill ] bi ;
+
 : (expire-old-intervals) ( n heap -- )
     dup heap-empty? [ 2drop ] [
         2dup heap-peek nip <= [ 2drop ] [
-            dup heap-pop drop handle-spill
+            dup heap-pop drop expire-interval
             (expire-old-intervals)
         ] if
     ] if ;
 
 : expire-old-intervals ( n -- )
-    pending-intervals get (expire-old-intervals) ;
+    pending-interval-heap get (expire-old-intervals) ;
 
 : insert-reload ( live-interval -- )
     [ reg>> ] [ vreg>> reg-class>> ] [ reload-from>> ] tri _reload ;
@@ -66,45 +76,32 @@ SYMBOL: register-live-outs
 : handle-reload ( live-interval -- )
     dup reload-from>> [ insert-reload ] [ drop ] if ;
 
-: activate-new-intervals ( n -- )
+: activate-interval ( live-interval -- )
-    #! Any live intervals which start on the current instruction
+    [ add-pending ] [ handle-reload ] bi ;
-    #! are added to the active set.
+
-    unhandled-intervals get dup heap-empty? [ 2drop ] [
+: (activate-new-intervals) ( n heap -- )
-        2dup heap-peek drop start>> = [
+    dup heap-empty? [ 2drop ] [
-            heap-pop drop
+        2dup heap-peek nip = [
-            [ add-active ] [ handle-reload ] bi
+            dup heap-pop drop activate-interval
-            activate-new-intervals
+            (activate-new-intervals)
         ] [ 2drop ] if
     ] if ;
 
+: activate-new-intervals ( n -- )
+    unhandled-intervals get (activate-new-intervals) ;
+
 : prepare-insn ( n -- )
     [ expire-old-intervals ] [ activate-new-intervals ] bi ;
 
 GENERIC: assign-registers-in-insn ( insn -- )
 
-: register-mapping ( live-intervals -- alist )
-    [ [ vreg>> ] [ reg>> ] bi ] H{ } map>assoc ;
-
 : all-vregs ( insn -- vregs )
     [ [ temp-vregs ] [ uses-vregs ] bi append ]
     [ defs-vreg ] bi
     [ suffix ] when* ;
 
-SYMBOL: check-assignment?
-
-ERROR: overlapping-registers intervals ;
-
-: check-assignment ( intervals -- )
-    dup [ copy-from>> ] map sift '[ vreg>> _ member? not ] filter
-    dup [ reg>> ] map all-unique? [ drop ] [ overlapping-registers ] if ;
-
-: active-intervals ( n -- intervals )
-    pending-intervals get heap-values [ covers? ] with filter
-    check-assignment? get [ dup check-assignment ] when ;
-
 M: vreg-insn assign-registers-in-insn
-    dup [ all-vregs ] [ insn#>> active-intervals register-mapping ] bi
+    dup all-vregs pending-interval-assoc get extract-keys >>regs drop ;
-    extract-keys >>regs drop ;
 
 M: ##gc assign-registers-in-insn
     ! This works because ##gc is always the first instruction
@@ -115,33 +112,22 @@ M: ##gc assign-registers-in-insn
 
 M: insn assign-registers-in-insn drop ;
 
-: compute-live-spill-slots ( vregs -- assoc )
+: compute-live-values ( vregs -- assoc )
-    spill-slots get '[ _ at dup [ <spill-slot> ] when ] assoc-map ;
-
-: compute-live-registers ( n -- assoc )
-    active-intervals register-mapping ;
-
-ERROR: bad-live-values live-values ;
-
-: check-live-values ( assoc -- assoc )
-    check-assignment? get [
-        dup values [ not ] any? [ bad-live-values ] when
-    ] when ;
-
-: compute-live-values ( vregs n -- assoc )
     ! If a live vreg is not in active or inactive, then it must have been
     ! spilled.
-    [ compute-live-spill-slots ] [ compute-live-registers ] bi*
+    dup assoc-empty? [
-    assoc-union check-live-values ;
+        pending-interval-assoc get
+        '[ _ ?at [ ] [ spill-slots get at <spill-slot> ] if ] assoc-map
+    ] unless ;
 
 : begin-block ( bb -- )
     dup basic-block set
     dup block-from activate-new-intervals
-    [ [ live-in ] [ block-from ] bi compute-live-values ] keep
+    [ live-in compute-live-values ] keep
     register-live-ins get set-at ;
 
 : end-block ( bb -- )
-    [ [ live-out ] [ block-to ] bi compute-live-values ] keep
+    [ live-out compute-live-values ] keep
     register-live-outs get set-at ;
 
 ERROR: bad-vreg vreg ;

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

@@ -21,10 +21,7 @@ compiler.cfg.linear-scan.allocation.splitting
 compiler.cfg.linear-scan.allocation.spilling
 compiler.cfg.linear-scan.debugger ;
 
-FROM: compiler.cfg.linear-scan.assignment => check-assignment? ;
-
 check-allocation? on
-check-assignment? on
 check-numbering? on
 
 [