compiler.cfg.linear-scan: redo resolve pass to fix a correctness issue

basis/compiler/cfg/instructions/instructions.factor

@@ -240,7 +240,7 @@ INSN: _compare-imm-branch label { src1 vreg } { src2 integer } cc ;
 
 INSN: _compare-float-branch < _conditional-branch ;
 
-TUPLE: spill-slot { n integer } ; C: <spill-slot> spill-slot
+TUPLE: spill-slot n ; C: <spill-slot> spill-slot
 
 INSN: _gc { temp1 vreg } { temp2 vreg } gc-roots gc-root-count gc-root-size ;
 

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

@@ -33,6 +33,20 @@ SYMBOL: spill-slots
 : spill-slots-for ( vreg -- assoc )
     reg-class>> spill-slots get at ;
 
+! Mapping from basic blocks to values which are live at the start
+SYMBOL: register-live-ins
+
+! Mapping from basic blocks to values which are live at the end
+SYMBOL: register-live-outs
+
+: init-assignment ( live-intervals -- )
+    V{ } clone pending-intervals set
+    <min-heap> unhandled-intervals set
+    [ H{ } clone ] reg-class-assoc spill-slots set
+    H{ } clone register-live-ins set
+    H{ } clone register-live-outs set
+    init-unhandled ;
+
 ERROR: already-spilled ;
 
 : record-spill ( live-interval -- )
@@ -102,6 +116,9 @@ ERROR: already-reloaded ;
         ] [ 2drop ] if
     ] if ;
 
+: prepare-insn ( insn -- )
+    insn#>> [ expire-old-intervals ] [ activate-new-intervals ] bi ;
+
 GENERIC: assign-registers-in-insn ( insn -- )
 
 : register-mapping ( live-intervals -- alist )
@@ -118,60 +135,65 @@ ERROR: overlapping-registers intervals ;
     dup [ copy-from>> ] map sift '[ vreg>> _ member? not ] filter
     dup [ reg>> ] map all-unique? [ drop ] [ overlapping-registers ] if ;
 
-: active-intervals ( insn -- intervals )
+: active-intervals ( n -- intervals )
-    insn#>> pending-intervals get [ covers? ] with filter
+    pending-intervals get [ covers? ] with filter
     check-assignment? get [
         dup check-assignment
     ] when ;
 
 M: vreg-insn assign-registers-in-insn
-    dup [ active-intervals ] [ all-vregs ] bi
+    dup [ insn#>> active-intervals ] [ all-vregs ] bi
     '[ vreg>> _ member? ] filter
     register-mapping
     >>regs drop ;
 
-: compute-live-registers ( insn -- assoc )
+: compute-live-registers ( n -- assoc )
-    [ active-intervals ] [ temp-vregs ] bi
+    active-intervals register-mapping ;
-    '[ vreg>> _ memq? not ] filter
-    register-mapping ;
 
 : compute-live-spill-slots ( -- assocs )
-    spill-slots get values
+    spill-slots get values first2
-    [ [ vreg>> swap <spill-slot> ] H{ } assoc-map-as ] map ;
+    [ [ vreg>> swap <spill-slot> ] H{ } assoc-map-as ] bi@
+    assoc-union ;
 
-: compute-live-values ( insn -- assoc )
+: compute-live-values ( n -- assoc )
-    [ compute-live-spill-slots ] dip compute-live-registers suffix
+    [ compute-live-spill-slots ] dip compute-live-registers
-    assoc-combine ;
+    assoc-union ;
+
+: compute-live-gc-values ( insn -- assoc )
+    [ insn#>> compute-live-values ] [ temp-vregs ] bi
+    '[ drop _ memq? not ] assoc-filter ;
 
 M: ##gc assign-registers-in-insn
     dup call-next-method
-    dup compute-live-values >>live-values
+    dup compute-live-gc-values >>live-values
     drop ;
 
 M: insn assign-registers-in-insn drop ;
 
-: init-assignment ( live-intervals -- )
+: begin-block ( bb -- )
-    V{ } clone pending-intervals set
+    [ block-from compute-live-values ] keep register-live-ins get set-at ;
-    <min-heap> unhandled-intervals set
+
-    [ H{ } clone ] reg-class-assoc spill-slots set 
+: end-block ( bb -- )
-    init-unhandled ;
+    [ block-to compute-live-values ] keep register-live-outs get set-at ;
+
+: vreg-at-start ( vreg bb -- state ) register-live-ins get at at ;
+
+: vreg-at-end ( vreg bb -- state ) register-live-outs get at at ;
 
 : assign-registers-in-block ( bb -- )
+    dup
+    begin-block
     [
         [
             [
-                [
+                [ prepare-insn ]
-                    insn#>>
-                    [ expire-old-intervals ]
-                    [ activate-new-intervals ]
-                    bi
-                ]
                 [ assign-registers-in-insn ]
                 [ , ]
                 tri
             ] each
         ] V{ } make
-    ] change-instructions drop ;
+    ] change-instructions
+    end-block ;
 
 : assign-registers ( live-intervals rpo -- )
     [ init-assignment ] dip

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

@@ -1353,7 +1353,7 @@ USING: math.private ;
 
 ! Spill slot liveness was computed incorrectly, leading to a FEP
 ! early in bootstrap on x86-32
-[ t t ] [
+[ t ] [
     [
         H{ } clone live-ins set
         H{ } clone live-outs set
@@ -1379,8 +1379,7 @@ USING: math.private ;
            }
         } dup 1array { { int-regs V{ 0 1 2 3 } } } (linear-scan)
         instructions>> first
-        [ live-spill-slots>> empty? ]
+        live-values>> assoc-empty?
-        [ live-registers>> empty? ] bi
     ] with-scope
 ] unit-test
 
@@ -1859,4 +1858,56 @@ test-diamond
 
 [ _spill ] [ 3 get instructions>> second class ] unit-test
 
-[ _reload ] [ 4 get instructions>> first class ] unit-test
+[ _reload ] [ 4 get instructions>> first class ] unit-test
+
+! Resolve pass
+V{
+    T{ ##branch }
+} 0 test-bb
+
+V{
+    T{ ##peek f V int-regs 0 D 0 }
+    T{ ##compare-imm-branch f V int-regs 0 5 cc= }
+} 1 test-bb
+
+V{
+    T{ ##replace f V int-regs 0 D 0 }
+    T{ ##peek f V int-regs 1 D 0 }
+    T{ ##peek f V int-regs 2 D 0 }
+    T{ ##replace f V int-regs 1 D 0 }
+    T{ ##replace f V int-regs 2 D 0 }
+    T{ ##branch }
+} 2 test-bb
+
+V{
+    T{ ##branch }
+} 3 test-bb
+
+V{
+    T{ ##peek f V int-regs 1 D 0 }
+    T{ ##compare-imm-branch f V int-regs 1 5 cc= }
+} 4 test-bb
+
+V{
+    T{ ##replace f V int-regs 0 D 0 }
+    T{ ##return }
+} 5 test-bb
+
+V{
+    T{ ##replace f V int-regs 0 D 0 }
+    T{ ##return }
+} 6 test-bb
+
+0 get 1 get V{ } 1sequence >>successors drop
+1 get 2 get 3 get V{ } 2sequence >>successors drop
+2 get 4 get V{ } 1sequence >>successors drop
+3 get 4 get V{ } 1sequence >>successors drop
+4 get 5 get 6 get V{ } 2sequence >>successors drop
+
+[ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test
+
+[ t ] [ 2 get instructions>> [ _spill? ] any? ] unit-test
+
+[ t ] [ 3 get instructions>> [ _spill? ] any? ] unit-test
+
+[ t ] [ 5 get instructions>> [ _reload? ] any? ] unit-test

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

@@ -12,59 +12,6 @@ IN: compiler.cfg.linear-scan.resolve.tests
     { 3 4 } V{ 1 2 } clone [ { 5 6 } 3append-here ] keep >array
 ] unit-test
 
-V{
-    T{ ##peek f V int-regs 0 D 0 }
-    T{ ##branch }
-} 0 test-bb
-
-V{
-    T{ ##replace f V int-regs 0 D 1 }
-    T{ ##return }
-} 1 test-bb
-
-1 get 1vector 0 get (>>successors)
-
-cfg new 0 get >>entry
-compute-predecessors
-dup reverse-post-order number-instructions
-drop
-
-CONSTANT: test-live-interval-1
-T{ live-interval
-   { start 0 }
-   { end 6 }
-   { uses V{ 0 6 } }
-   { ranges V{ T{ live-range f 0 2 } T{ live-range f 4 6 } } }
-   { spill-to 0 }
-   { vreg V int-regs 0 }
-}
-
-[ f ] [
-    test-live-interval-1 0 get spill-to
-] unit-test
-
-[ 0 ] [
-    test-live-interval-1 1 get spill-to
-] unit-test
-
-CONSTANT: test-live-interval-2
-T{ live-interval
-   { start 0 }
-   { end 6 }
-   { uses V{ 0 6 } }
-   { ranges V{ T{ live-range f 0 2 } T{ live-range f 4 6 } } }
-   { reload-from 0 }
-   { vreg V int-regs 0 }
-}
-
-[ 0 ] [
-    test-live-interval-2 0 get reload-from
-] unit-test
-
-[ f ] [
-    test-live-interval-2 1 get reload-from
-] unit-test
-
 [
     {
         T{ _copy { dst 5 } { src 4 } { class int-regs } }
@@ -142,8 +89,8 @@ T{ live-interval
     }
 ] [
     {
-       T{ register->memory { from 3 } { to 4 } { reg-class int-regs } }
+        T{ register->memory { from 3 } { to T{ spill-slot f 4 } } { reg-class int-regs } }
-       T{ memory->register { from 1 } { to 2 } { reg-class int-regs } }
+        T{ memory->register { from T{ spill-slot f 1 } } { to 2 } { reg-class int-regs } }
     } mapping-instructions
 ] unit-test
 

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

@@ -3,7 +3,7 @@
 USING: accessors arrays assocs classes.parser classes.tuple
 combinators combinators.short-circuit fry hashtables kernel locals
 make math math.order namespaces sequences sets words parser
-compiler.cfg.instructions compiler.cfg.linear-scan.live-intervals
+compiler.cfg.instructions compiler.cfg.linear-scan.assignment
 compiler.cfg.liveness ;
 IN: compiler.cfg.linear-scan.resolve
 
@@ -14,50 +14,33 @@ TUPLE: operation from to reg-class ;
 SYNTAX: OPERATION:
     CREATE-CLASS dup save-location
     [ operation { } define-tuple-class ]
-    [
+    [ dup '[ _ boa , ] (( from to reg-class -- )) define-declared ] bi ;
-        [ scan-word scan-word ] keep
-        '[
-            [ [ _ execute ] [ _ execute ] bi* ]
-            [ vreg>> reg-class>> ]
-            bi _ boa ,
-        ] (( from to -- )) define-declared
-    ] bi ;
 
 >>
 
-: insn-in-block? ( insn# bb -- ? )
+OPERATION: register->memory
-    [ block-from ] [ block-to ] bi between? ;
+OPERATION: memory->register
+OPERATION: register->register
 
-: reload-from ( live-interval bb -- n/f )
+! This should never come up because of how spill slots are assigned,
-    2dup [ start>> ] dip insn-in-block?
+! so make it an error.
-    [ drop reload-from>> ] [ 2drop f ] if ;
+: memory->memory ( from to reg-class -- ) drop [ n>> ] bi@ assert= ;
 
-: spill-to ( live-interval bb -- n/f )
+: add-mapping ( from to reg-class -- )
-    2dup [ end>> ] dip insn-in-block?
+    over spill-slot? [
-    [ drop spill-to>> ] [ 2drop f ] if ;
+        pick spill-slot?
-
+        [ memory->memory ]
-OPERATION: memory->memory spill-to>> reload-from>>
+        [ register->memory ] if
-OPERATION: register->memory reg>> reload-from>>
-OPERATION: memory->register spill-to>> reg>>
-OPERATION: register->register reg>> reg>>
-
-:: add-mapping ( bb1 bb2 li1 li2 -- )
-    li2 bb2 reload-from [
-        li1 bb1 spill-to
-        [ li1 li2 memory->memory ]
-        [ li1 li2 register->memory ] if
     ] [
-        li1 bb1 spill-to
+        pick spill-slot?
-        [ li1 li2 memory->register ]
+        [ memory->register ]
-        [ li1 li2 register->register ] if
+        [ register->register ] if
     ] if ;
 
-: resolve-value-data-flow ( bb to vreg -- )
+:: resolve-value-data-flow ( bb to vreg -- )
-    [ 2dup ] dip
+    vreg bb vreg-at-end
-    live-intervals get at
+    vreg to vreg-at-start
-    [ [ block-to ] dip child-interval-at ]
+    2dup eq? [ 2drop ] [ vreg reg-class>> add-mapping ] if ;
-    [ [ block-from ] dip child-interval-at ]
-    bi-curry bi* 2dup eq? [ 2drop 2drop ] [ add-mapping ] if ;
 
 : compute-mappings ( bb to -- mappings )
     [
@@ -67,48 +50,23 @@ OPERATION: register->register reg>> reg>>
 
 GENERIC: >insn ( operation -- )
 
-M: memory->memory >insn
-    [ from>> ] [ to>> ] bi = [ "Not allowed" throw ] unless ;
-
 M: register->memory >insn
-    [ from>> ] [ reg-class>> ] [ to>> ] tri _spill ;
+    [ from>> ] [ reg-class>> ] [ to>> n>> ] tri _spill ;
 
 M: memory->register >insn
-    [ to>> ] [ reg-class>> ] [ from>> ] tri  _reload ;
+    [ to>> ] [ reg-class>> ] [ from>> n>> ] tri  _reload ;
 
 M: register->register >insn
     [ to>> ] [ from>> ] [ reg-class>> ] tri _copy ;
 
-GENERIC: >collision-table ( operation -- )
-
-M: memory->memory >collision-table
-    [ from>> ] [ to>> ] bi = [ "Not allowed" throw ] unless ;
-
-M: register->memory >collision-table
-    [ from>> ] [ reg-class>> ] [ to>> ] tri _spill ;
-
-M: memory->register >collision-table
-    [ to>> ] [ reg-class>> ] [ from>> ] tri _reload ;
-
-M: register->register >collision-table
-    [ to>> ] [ from>> ] [ reg-class>> ] tri _copy ;
-
 SYMBOL: froms
 SYMBOL: tos
 
 SINGLETONS: memory register ;
 
-GENERIC: from-loc ( operation -- obj )
+: from-loc ( operation -- obj ) from>> spill-slot? memory register ? ;
-M: memory->memory from-loc drop memory ;
-M: register->memory from-loc drop register ;
-M: memory->register from-loc drop memory ;
-M: register->register from-loc drop register ;
 
-GENERIC: to-loc ( operation -- obj )
+: to-loc ( operation -- obj ) to>> spill-slot? memory register ? ;
-M: memory->memory to-loc drop memory ;
-M: register->memory to-loc drop memory ;
-M: memory->register to-loc drop register ;
-M: register->register to-loc drop register ;
 
 : from-reg ( operation -- seq )
     [ from-loc ] [ from>> ] [ reg-class>> ] tri 3array ;
@@ -142,7 +100,6 @@ M: register->register to-loc drop register ;
         dup dup associate (trace-chain)
     ] { } make prune reverse ;
 
-
 : trace-chains ( seq -- seq' )
     [ trace-chain ] map concat ;
 
@@ -159,10 +116,10 @@ ERROR: resolve-error ;
 
 : break-cycle-n ( operations -- operations' )
     split-cycle [
-        [ from>> spill-temp ]
+        [ from>> spill-temp <spill-slot> ]
         [ reg-class>> ] bi \ register->memory boa
     ] [
-        [ to>> spill-temp swap ]
+        [ to>> spill-temp <spill-slot> swap ]
         [ reg-class>> ] bi \ memory->register boa
     ] bi [ 1array ] bi@ surround ;