From 1a71407112b5b08507b8881c740c2cd175328703 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Bj=C3=B6rn=20Lindqvist?= <bjourne@gmail.com>
Date: Sun, 3 Apr 2016 02:48:37 +0200
Subject: [PATCH] compiler.cfg.linear-scan.assignment: refactoring + tests

better expire-old-intervals, activate-new-intervals and assign-gc-roots
---
 .../assignment/assignment-tests.factor        | 54 +++++++++++--------
 .../linear-scan/assignment/assignment.factor  |  6 +--
 2 files changed, 34 insertions(+), 26 deletions(-)

diff --git a/basis/compiler/cfg/linear-scan/assignment/assignment-tests.factor b/basis/compiler/cfg/linear-scan/assignment/assignment-tests.factor
index e436d37ea5..d82ac4e5c3 100644
--- a/basis/compiler/cfg/linear-scan/assignment/assignment-tests.factor
+++ b/basis/compiler/cfg/linear-scan/assignment/assignment-tests.factor
@@ -6,13 +6,36 @@ cpu.x86.assembler.operands grouping heaps kernel make namespaces random
 sequences sorting tools.test ;
 IN: compiler.cfg.linear-scan.assignment.tests
 
+: 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* ;
+
+! assign-gc-roots
+{
+    T{ gc-map { gc-roots { T{ spill-slot { n 7 } } } } }
+} [
+    { { 23 int-rep 23 T{ spill-slot { n 7 } } } } setup-vreg-spills
+    <gc-map> 23 1array >>gc-roots [ assign-gc-roots ] keep
+] unit-test
+
 ! assign-insn-defs
 {
     T{ ##peek { dst RAX } { loc T{ ds-loc } } { insn# 0 } }
 } [
     H{ { 37 RAX } } pending-interval-assoc set
-    H{ { 37 int-rep } } representations set
-    H{ { 37 37 } } leader-map set
+    { { 37 int-rep 37 f } } setup-vreg-spills
     T{ ##peek f 37 D: 0 0 } [ assign-insn-defs ] keep
 ] unit-test
 
@@ -46,6 +69,12 @@ IN: compiler.cfg.linear-scan.assignment.tests
     [ assign-registers-in-block ] keep instructions>>
 ] unit-test
 
+! expire-old-intervals
+{ 3 } [
+    90 { 50 90 95 120 } [ 25 <live-interval> 2array ] map >min-heap
+    [ expire-old-intervals ] keep heap-size
+] unit-test
+
 ! insert-reload
 {
     { T{ ##reload { dst RAX } { rep int-rep } { src T{ spill-slot } } } }
@@ -74,22 +103,6 @@ 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
@@ -114,8 +127,3 @@ IN: compiler.cfg.linear-scan.assignment.tests
     { { 3 7 } { -1 56 } { -1 3 } } >min-heap [ -1 = ] heap-pop-while
     natural-sort
 ] unit-test
-
-{ 3 } [
-    90 { 50 90 95 120 } [ 25 <live-interval> 2array ] map >min-heap
-    [ expire-old-intervals ] keep heap-size
-] unit-test
diff --git a/basis/compiler/cfg/linear-scan/assignment/assignment.factor b/basis/compiler/cfg/linear-scan/assignment/assignment.factor
index 0ee605d2a2..3db448de70 100644
--- a/basis/compiler/cfg/linear-scan/assignment/assignment.factor
+++ b/basis/compiler/cfg/linear-scan/assignment/assignment.factor
@@ -75,7 +75,7 @@ SYMBOL: machine-live-outs
     [ remove-pending ] [ handle-spill ] bi ;
 
 : expire-old-intervals ( n pending-heap -- )
-    swap '[ _ < ] heap-pop-while [ expire-interval ] each ;
+    [ > ] with heap-pop-while [ expire-interval ] each ;
 
 : insert-reload ( live-interval -- )
     [ reg>> ] [ reload-rep>> ] [ reload-from>> ] tri ##reload, ;
@@ -87,7 +87,7 @@ SYMBOL: machine-live-outs
     [ add-pending ] [ handle-reload ] bi ;
 
 : activate-new-intervals ( n unhandled-heap -- )
-    swap '[ _ = ] heap-pop-while [ activate-interval ] each ;
+    [ = ] with heap-pop-while [ activate-interval ] each ;
 
 : prepare-insn ( n -- )
     [ pending-interval-heap get expire-old-intervals ]
@@ -99,7 +99,7 @@ RENAMING: assign [ vreg>reg ] [ vreg>reg ] [ vreg>reg ]
     [ assign-insn-defs ] [ assign-insn-uses ] [ assign-insn-temps ] tri ;
 
 : assign-gc-roots ( gc-map -- )
-    [ [ vreg>spill-slot ] map ] change-gc-roots drop ;
+    gc-roots>> [ vreg>spill-slot ] map! drop ;
 
 : assign-derived-roots ( gc-map -- )
     [ [ [ vreg>spill-slot ] bi@ ] assoc-map ] change-derived-roots drop ;