compiler.cfg.linear-scan: Further progress on inactive interval handling

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

@@ -1,21 +1,66 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs heaps kernel namespaces sequences
+USING: accessors assocs heaps kernel namespaces sequences fry math
+combinators arrays sorting
 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' )
+    ! 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 ;
+
+: intersect-inactive ( new inactive -- n )
+    relevant-ranges intersect-live-ranges ;
+
+: compute-free-pos ( new -- free-pos )
+    dup vreg>>
+    [ nip reg-class>> registers get at [ 1/0. ] H{ } map>assoc ]
+    [ 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 sort-values ;
+
+: no-free-registers? ( new result -- ? )
+    second 0 = ; inline
+
+: register-available? ( new result -- ? )
+    [ end>> ] [ second ] bi* < ; inline
+
+: register-available ( new result -- )
+    first >>reg add-active ;
+
+: register-partially-available ( new result -- )
+    [ second split-before-use ] keep
+    '[ _ register-available ] [ add-unhandled ] bi* ;
+
 : assign-register ( new -- )
     dup coalesce? [ coalesce ] [
-        dup vreg>> free-registers-for [
+        dup compute-free-pos last {
-            dup intersecting-inactive
+            { [ dup no-free-registers? ] [ drop assign-blocked-register ] }
-            [ assign-blocked-register ]
+            { [ 2dup register-available? ] [ register-available ] }
-            [ assign-inactive-register ]
+            [ register-partially-available ]
-            if-empty
+        } cond
-        ] [ assign-free-register ]
-        if-empty
     ] if ;
 
 : handle-interval ( live-interval -- )

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

@@ -39,8 +39,8 @@ IN: compiler.cfg.linear-scan.allocation.spilling
     #! with the most distant use location. Spill the existing
     #! interval, then process the new interval and the tail end
     #! of the existing interval again.
-    [ reuse-register ]
+    [ reg>> >>reg drop ]
-    [ nip delete-active ]
+    [ [ add-handled ] [ delete-active ] bi* ]
     [ split-and-spill [ add-handled ] [ add-unhandled ] bi* ] 2tri ;
 
 : spill-new ( new existing -- )

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

@@ -28,9 +28,7 @@ IN: compiler.cfg.linear-scan.allocation.splitting
     '[ _ <= ] partition ;
 
 : record-split ( live-interval before after -- )
-    [ >>split-next drop ]
+    [ >>split-before ] [ >>split-after ] bi* drop ; inline
-    [ [ >>split-before ] [ >>split-after ] bi* drop ]
-    2bi ; inline
 
 ERROR: splitting-too-early ;
 
@@ -59,62 +57,21 @@ ERROR: splitting-atomic-interval ;
 
 HINTS: split-interval live-interval object ;
 
-: reuse-register ( new existing -- )
+: split-between-blocks ( new n -- before after )
-    reg>> >>reg add-active ;
+    split-interval
-
+    2dup [ compute-start/end ] bi@ ;
-: 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 ;
-
-: intersect-inactive ( new inactive active-regs -- n/f )
-    ! If the interval's register is currently in use, we cannot
-    ! re-use it.
-    2dup [ reg>> ] dip key?
-    [ 3drop f ] [ drop relevant-ranges intersect-live-ranges ] if ;
-
-: intersecting-inactive ( new -- live-intervals )
-    dup vreg>>
-    [ inactive-intervals-for ]
-    [ active-intervals-for [ reg>> ] map unique ] bi
-    '[ tuck _ intersect-inactive ] with { } map>assoc
-    [ nip ] assoc-filter ;
 
 : insert-use-for-copy ( seq n -- seq' )
-    [ 1array split1 ] keep [ 1 - ] keep 2array glue ;
+    dup 1 + [ nip 1array split1 ] 2keep 2array glue ;
 
 : split-before-use ( new n -- before after )
     ! Find optimal split position
     ! Insert move instruction
+    1 -
+    2dup swap covers? [
         [ '[ _ insert-use-for-copy ] change-uses ] keep
-    1 - split-interval
+        split-between-blocks
-    2dup [ compute-start/end ] bi@ ;
+        2dup >>split-next drop
-
-: assign-inactive-register ( new live-intervals -- )
-    ! If there is an interval which is inactive for the entire lifetime
-    ! if the new interval, reuse its vreg. Otherwise, split new so that
-    ! the first half fits.
-    sort-values last
-    2dup [ end>> ] [ second ] bi* < [
-        first reuse-register
     ] [
-        [ second split-before-use ] keep
+        split-between-blocks
-        '[ _ first reuse-register ] [ add-unhandled ] bi*
     ] if ;

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

@@ -6,13 +6,7 @@ compiler.cfg.linear-scan.live-intervals ;
 IN: compiler.cfg.linear-scan.allocation.state
 
 ! Mapping from register classes to sequences of machine registers
-SYMBOL: free-registers
+SYMBOL: registers
-
-: free-registers-for ( vreg -- seq )
-    reg-class>> free-registers get at ;
-
-: deallocate-register ( live-interval -- )
-    [ reg>> ] [ vreg>> ] bi free-registers-for push ;
 
 ! Vector of active live intervals
 SYMBOL: active-intervals
@@ -47,7 +41,7 @@ SYMBOL: handled-intervals
 : finished? ( n live-interval -- ? ) end>> swap < ;
 
 : finish ( n live-interval -- keep? )
-    nip [ deallocate-register ] [ add-handled ] bi f ;
+    nip add-handled f ;
 
 SYMBOL: check-allocation?
 
@@ -121,7 +115,7 @@ SYMBOL: spill-counts
     spill-counts get [ dup 1 + ] change-at ;
 
 : init-allocator ( registers -- )
-    [ reverse >vector ] assoc-map free-registers set
+    registers set
     [ 0 ] reg-class-assoc spill-counts set
     <min-heap> unhandled-intervals set
     [ V{ } clone ] reg-class-assoc active-intervals set

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

@@ -1410,7 +1410,6 @@ USING: math.private compiler.cfg.debugger ;
        { uses { 5 10 } }
        { ranges V{ T{ live-range f 5 10 } } }
     }
-    H{ }
     intersect-inactive
 ] unit-test