compiler.cfg.linear-scan: fix coalescing to take lifetime holes into account

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

@@ -2,44 +2,27 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors assocs heaps kernel namespaces sequences fry math
 combinators arrays sorting compiler.utilities
+compiler.cfg.linear-scan.live-intervals
 compiler.cfg.linear-scan.allocation.coalescing
 compiler.cfg.linear-scan.allocation.spilling
 compiler.cfg.linear-scan.allocation.splitting
 compiler.cfg.linear-scan.allocation.state ;
 IN: compiler.cfg.linear-scan.allocation
 
-: relevant-ranges ( new inactive -- new' inactive' )
+: free-positions ( new -- assoc )
-    ! Slice off all ranges of 'inactive' that precede the start of 'new'
+    vreg>> reg-class>> registers get at [ 1/0. ] H{ } map>assoc ;
-    [ [ ranges>> ] bi@ ] [ nip start>> ] 2bi '[ to>> _ >= ] filter ;
 
-: intersect-live-range ( range1 range2 -- n/f )
+: active-positions ( new -- assoc )
-    2dup [ from>> ] bi@ > [ swap ] when
+    vreg>> active-intervals-for [ reg>> 0 ] H{ } map>assoc ;
-    2dup [ to>> ] [ from>> ] bi* >= [ nip from>> ] [ 2drop f ] if ;
 
-: intersect-live-ranges ( ranges1 ranges2 -- n )
+: inactive-positions ( new -- assoc )
-    {
+    dup vreg>> inactive-intervals-for
-        { [ over empty? ] [ 2drop 1/0. ] }
+    [ [ reg>> swap ] keep relevant-ranges intersect-live-ranges ]
-        { [ dup empty? ] [ 2drop 1/0. ] }
+    with H{ } map>assoc ;
-        [
-            2dup [ first ] bi@ intersect-live-range dup [ 2nip ] [
-                drop
-                2dup [ first from>> ] bi@ <
-                [ [ rest-slice ] dip ] [ rest-slice ] if
-                intersect-live-ranges
-            ] if
-        ]
-    } cond ;
-
-: intersect-inactive ( new inactive -- n )
-    relevant-ranges intersect-live-ranges ;
 
 : compute-free-pos ( new -- free-pos )
-    dup vreg>>
+    [ free-positions ] [ inactive-positions ] [ active-positions ] tri
-    [ nip reg-class>> registers get at [ 1/0. ] H{ } map>assoc ]
+    3array assoc-combine >alist alist-max ;
-    [ inactive-intervals-for [ [ reg>> swap ] keep intersect-inactive ] with H{ } map>assoc ]
-    [ nip active-intervals-for [ reg>> 0 ] H{ } map>assoc ]
-    2tri 3array assoc-combine
-    >alist alist-max ;
 
 : no-free-registers? ( result -- ? )
     second 0 = ; inline

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

@@ -1,18 +1,28 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel sequences
+combinators.short-circuit
+compiler.cfg.linear-scan.live-intervals
 compiler.cfg.linear-scan.allocation.state ;
 IN: compiler.cfg.linear-scan.allocation.coalescing
 
 : active-interval ( vreg -- live-interval )
     dup [ dup active-intervals-for [ vreg>> = ] with find nip ] when ;
 
+: intersects-inactive-intervals? ( live-interval -- ? )
+    dup vreg>> inactive-intervals-for
+    [ relevant-ranges intersect-live-ranges 1/0. = ] with all? ;
+
 : coalesce? ( live-interval -- ? )
-    [ start>> ] [ copy-from>> active-interval ] bi
+    {
-    dup [ end>> = ] [ 2drop f ] if ;
+        [ copy-from>> active-interval ]
+        [ [ start>> ] [ copy-from>> active-interval end>> ] bi = ]
+        [ intersects-inactive-intervals? ]
+    } 1&& ;
 
 : coalesce ( live-interval -- )
     dup copy-from>> active-interval
     [ [ add-active ] [ [ delete-active ] [ add-handled ] bi ] bi* ]
     [ reg>> >>reg drop ]
     2bi ;
+ 

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

@@ -144,3 +144,25 @@ M: ##copy-float compute-live-intervals*
         live-intervals set
         <reversed> [ compute-live-intervals-step ] each
     ] keep values dup finish-live-intervals ;
+
+: relevant-ranges ( new inactive -- new' inactive' )
+    ! Slice off all ranges of 'inactive' that precede the start of 'new'
+    [ [ ranges>> ] bi@ ] [ nip start>> ] 2bi '[ to>> _ >= ] filter ;
+
+: intersect-live-range ( range1 range2 -- n/f )
+    2dup [ from>> ] bi@ > [ swap ] when
+    2dup [ to>> ] [ from>> ] bi* >= [ nip from>> ] [ 2drop f ] if ;
+
+: intersect-live-ranges ( ranges1 ranges2 -- n )
+    {
+        { [ over empty? ] [ 2drop 1/0. ] }
+        { [ dup empty? ] [ 2drop 1/0. ] }
+        [
+            2dup [ first ] bi@ intersect-live-range dup [ 2nip ] [
+                drop
+                2dup [ first from>> ] bi@ <
+                [ [ rest-slice ] dip ] [ rest-slice ] if
+                intersect-live-ranges
+            ] if
+        ]
+    } cond ;