compiler.cfg.linear-scan: split off parallel mapping code from resolve pass, use it in assignment pass to resolve parallel copies

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

@@ -38,7 +38,7 @@ ERROR: bad-live-ranges interval ;
     } 2cleave ;
 
 : assign-spill ( live-interval -- )
-    dup vreg>> assign-spill-slot >>spill-to drop ;
+    dup vreg>> assign-spill-slot >>spill-to f >>split-next drop ;
 
 : assign-reload ( live-interval -- )
     dup vreg>> assign-spill-slot >>reload-from drop ;

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

@@ -8,6 +8,7 @@ compiler.cfg.def-use
 compiler.cfg.liveness
 compiler.cfg.registers
 compiler.cfg.instructions
+compiler.cfg.linear-scan.mapping
 compiler.cfg.linear-scan.allocation
 compiler.cfg.linear-scan.allocation.state
 compiler.cfg.linear-scan.live-intervals ;
@@ -42,16 +43,11 @@ SYMBOL: register-live-outs
     H{ } clone register-live-outs set
     init-unhandled ;
 
-: insert-spill ( live-interval -- )
-    {
-        [ reg>> ]
-        [ vreg>> reg-class>> ]
-        [ spill-to>> ]
-        [ end>> ]
-    } cleave f swap \ _spill boa , ;
-
 : handle-spill ( live-interval -- )
-    dup spill-to>> [ insert-spill ] [ drop ] if ;
+    dup spill-to>> [
+        [ reg>> ] [ spill-to>> <spill-slot> ] [ vreg>> reg-class>> ] tri
+        register->memory
+    ] [ drop ] if ;
 
 : first-split ( live-interval -- live-interval' )
     dup split-before>> [ first-split ] [ ] ?if ;
@@ -59,22 +55,19 @@ SYMBOL: register-live-outs
 : next-interval ( live-interval -- live-interval' )
     split-next>> first-split ;
 
-: insert-copy ( live-interval -- )
-    {
-        [ next-interval reg>> ]
-        [ reg>> ]
-        [ vreg>> reg-class>> ]
-        [ end>> ]
-    } cleave f swap \ _copy boa , ;
-
 : handle-copy ( live-interval -- )
-    dup split-next>> [ insert-copy ] [ drop ] if ;
+    dup split-next>> [
+        [ reg>> ] [ next-interval reg>> ] [ vreg>> reg-class>> ] tri
+        register->register
+    ] [ drop ] if ;
 
 : expire-old-intervals ( n -- )
-    [ pending-intervals get ] dip '[
+    [
-        dup end>> _ <
+        [ pending-intervals get ] dip '[
-        [ [ handle-spill ] [ handle-copy ] bi f ] [ drop t ] if
+            dup end>> _ <
-    ] filter-here ;
+            [ [ handle-spill ] [ handle-copy ] bi f ] [ drop t ] if
+        ] filter-here
+    ] { } make mapping-instructions % ;
 
 : insert-reload ( live-interval -- )
     {

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

@@ -10,7 +10,8 @@ compiler.cfg.linear-scan.live-intervals
 compiler.cfg.linear-scan.allocation
 compiler.cfg.linear-scan.allocation.state
 compiler.cfg.linear-scan.assignment
-compiler.cfg.linear-scan.resolve ;
+compiler.cfg.linear-scan.resolve
+compiler.cfg.linear-scan.mapping ;
 IN: compiler.cfg.linear-scan
 
 ! References:
@@ -36,6 +37,7 @@ IN: compiler.cfg.linear-scan
 
 : linear-scan ( cfg -- cfg' )
     [
+        init-mapping
         dup reverse-post-order machine-registers (linear-scan)
         spill-counts get >>spill-counts
     ] with-scope ;

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

@@ -0,0 +1,148 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs classes.parser classes.tuple
+combinators compiler.cfg.instructions
+compiler.cfg.linear-scan.allocation.state fry hashtables kernel
+locals make namespaces parser sequences sets words ;
+IN: compiler.cfg.linear-scan.mapping
+
+SYMBOL: spill-temps
+
+: spill-temp ( reg-class -- n )
+    spill-temps get [ next-spill-slot ] cache ;
+
+<<
+
+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 ;
+
+>>
+
+OPERATION: register->memory
+OPERATION: memory->register
+OPERATION: register->register
+
+! This should never come up because of how spill slots are assigned,
+! so make it an error.
+: memory->memory ( from to reg-class -- ) drop [ n>> ] bi@ assert= ;
+
+GENERIC: >insn ( operation -- )
+
+M: register->memory >insn
+    [ from>> ] [ reg-class>> ] [ to>> n>> ] tri _spill ;
+
+M: memory->register >insn
+    [ to>> ] [ reg-class>> ] [ from>> n>> ] tri  _reload ;
+
+M: register->register >insn
+    [ to>> ] [ from>> ] [ reg-class>> ] tri _copy ;
+
+SYMBOL: froms
+SYMBOL: tos
+
+SINGLETONS: memory register ;
+
+: from-loc ( operation -- obj ) from>> spill-slot? memory register ? ;
+
+: to-loc ( operation -- obj ) to>> spill-slot? memory register ? ;
+
+: from-reg ( operation -- seq )
+    [ from-loc ] [ from>> ] [ reg-class>> ] tri 3array ;
+
+: to-reg ( operation -- seq )
+    [ to-loc ] [ to>> ] [ reg-class>> ] tri 3array ;
+
+: start? ( operations -- pair )
+    from-reg tos get key? not ;
+
+: independent-assignment? ( operations -- pair )
+    to-reg froms get key? not ;
+
+: set-tos/froms ( operations -- )
+    [ [ [ from-reg ] keep ] H{ } map>assoc froms set ]
+    [ [ [ to-reg ] keep ] H{ } map>assoc tos set ]
+    bi ;
+
+:: (trace-chain) ( obj hashtable -- )
+    obj to-reg froms get at* [
+        dup ,
+        obj over hashtable clone [ maybe-set-at ] keep swap
+        [ (trace-chain) ] [ 2drop ] if
+    ] [
+        drop
+    ] if ;
+
+: trace-chain ( obj -- seq )
+    [
+        dup ,
+        dup dup associate (trace-chain)
+    ] { } make prune reverse ;
+
+: trace-chains ( seq -- seq' )
+    [ trace-chain ] map concat ;
+
+ERROR: resolve-error ;
+
+: split-cycle ( operations -- chain spilled-operation )
+    unclip [
+        [ set-tos/froms ]
+        [
+            [ start? ] find nip
+            [ resolve-error ] unless* trace-chain
+        ] bi
+    ] dip ;
+
+: break-cycle-n ( operations -- operations' )
+    split-cycle [
+        [ from>> ]
+        [ reg-class>> spill-temp <spill-slot> ]
+        [ reg-class>> ]
+        tri \ register->memory boa
+    ] [
+        [ reg-class>> spill-temp <spill-slot> ]
+        [ to>> ]
+        [ reg-class>> ]
+        tri \ memory->register boa
+    ] bi [ 1array ] bi@ surround ;
+
+: break-cycle ( operations -- operations' )
+    dup length {
+        { 1 [ ] }
+        [ drop break-cycle-n ]
+    } case ;
+
+: (group-cycles) ( seq -- )
+    [
+        dup set-tos/froms
+        unclip trace-chain
+        [ diff ] keep , (group-cycles)
+    ] unless-empty ;
+
+: group-cycles ( seq -- seqs )
+    [ (group-cycles) ] { } make ;
+
+: remove-dead-mappings ( seq -- seq' )
+    prune [ [ from-reg ] [ to-reg ] bi = not ] filter ;
+
+: parallel-mappings ( operations -- seq )
+    [
+        [ independent-assignment? not ] partition %
+        [ start? not ] partition
+        [ trace-chain ] map concat dup %
+        diff group-cycles [ break-cycle ] map concat %
+    ] { } make remove-dead-mappings ;
+
+: mapping-instructions ( mappings -- insns )
+    [ { } ] [
+        [
+            [ set-tos/froms ] [ parallel-mappings ] bi
+            [ [ >insn ] each ] { } make
+        ] with-scope
+    ] if-empty ;
+
+: init-mapping ( -- )
+    H{ } clone spill-temps set ;

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

@@ -1,36 +1,13 @@
-! Copyright (C) 2009 Slava Pestov, Doug Coleman.
+! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays assocs classes.parser classes.tuple
+USING: accessors arrays assocs combinators
-combinators combinators.short-circuit fry hashtables kernel locals
+combinators.short-circuit fry kernel locals
-make math math.order namespaces sequences sets words parser
+make math sequences
-compiler.cfg.instructions compiler.cfg.linear-scan.allocation.state
+compiler.cfg.instructions
-compiler.cfg.linear-scan.assignment compiler.cfg.liveness ;
+compiler.cfg.linear-scan.assignment
+compiler.cfg.linear-scan.mapping compiler.cfg.liveness ;
 IN: compiler.cfg.linear-scan.resolve
 
-SYMBOL: spill-temps
-
-: spill-temp ( reg-class -- n )
-    spill-temps get [ next-spill-slot ] cache ;
-
-<<
-
-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 ;
-
->>
-
-OPERATION: register->memory
-OPERATION: memory->register
-OPERATION: register->register
-
-! This should never come up because of how spill slots are assigned,
-! so make it an error.
-: memory->memory ( from to reg-class -- ) drop [ n>> ] bi@ assert= ;
-
 : add-mapping ( from to reg-class -- )
     over spill-slot? [
         pick spill-slot?
@@ -53,118 +30,6 @@ OPERATION: register->register
         [ resolve-value-data-flow ] with with each
     ] { } make ;
 
-GENERIC: >insn ( operation -- )
-
-M: register->memory >insn
-    [ from>> ] [ reg-class>> ] [ to>> n>> ] tri _spill ;
-
-M: memory->register >insn
-    [ to>> ] [ reg-class>> ] [ from>> n>> ] tri  _reload ;
-
-M: register->register >insn
-    [ to>> ] [ from>> ] [ reg-class>> ] tri _copy ;
-
-SYMBOL: froms
-SYMBOL: tos
-
-SINGLETONS: memory register ;
-
-: from-loc ( operation -- obj ) from>> spill-slot? memory register ? ;
-
-: to-loc ( operation -- obj ) to>> spill-slot? memory register ? ;
-
-: from-reg ( operation -- seq )
-    [ from-loc ] [ from>> ] [ reg-class>> ] tri 3array ;
-
-: to-reg ( operation -- seq )
-    [ to-loc ] [ to>> ] [ reg-class>> ] tri 3array ;
-
-: start? ( operations -- pair )
-    from-reg tos get key? not ;
-
-: independent-assignment? ( operations -- pair )
-    to-reg froms get key? not ;
-
-: set-tos/froms ( operations -- )
-    [ [ [ from-reg ] keep ] H{ } map>assoc froms set ]
-    [ [ [ to-reg ] keep ] H{ } map>assoc tos set ]
-    bi ;
-
-:: (trace-chain) ( obj hashtable -- )
-    obj to-reg froms get at* [
-        dup ,
-        obj over hashtable clone [ maybe-set-at ] keep swap
-        [ (trace-chain) ] [ 2drop ] if
-    ] [
-        drop
-    ] if ;
-
-: trace-chain ( obj -- seq )
-    [
-        dup ,
-        dup dup associate (trace-chain)
-    ] { } make prune reverse ;
-
-: trace-chains ( seq -- seq' )
-    [ trace-chain ] map concat ;
-
-ERROR: resolve-error ;
-
-: split-cycle ( operations -- chain spilled-operation )
-    unclip [
-        [ set-tos/froms ]
-        [
-            [ start? ] find nip
-            [ resolve-error ] unless* trace-chain
-        ] bi
-    ] dip ;
-
-: break-cycle-n ( operations -- operations' )
-    split-cycle [
-        [ from>> ]
-        [ reg-class>> spill-temp <spill-slot> ]
-        [ reg-class>> ]
-        tri \ register->memory boa
-    ] [
-        [ reg-class>> spill-temp <spill-slot> ]
-        [ to>> ]
-        [ reg-class>> ]
-        tri \ memory->register boa
-    ] bi [ 1array ] bi@ surround ;
-
-: break-cycle ( operations -- operations' )
-    dup length {
-        { 1 [ ] }
-        [ drop break-cycle-n ]
-    } case ;
-
-: (group-cycles) ( seq -- )
-    [
-        dup set-tos/froms
-        unclip trace-chain
-        [ diff ] keep , (group-cycles)
-    ] unless-empty ;
-
-: group-cycles ( seq -- seqs )
-    [ (group-cycles) ] { } make ;
-
-: remove-dead-mappings ( seq -- seq' )
-    prune [ [ from-reg ] [ to-reg ] bi = not ] filter ;
-
-: parallel-mappings ( operations -- seq )
-    [
-        [ independent-assignment? not ] partition %
-        [ start? not ] partition
-        [ trace-chain ] map concat dup %
-        diff group-cycles [ break-cycle ] map concat %
-    ] { } make remove-dead-mappings ;
-
-: mapping-instructions ( mappings -- insns )
-    [
-        [ set-tos/froms ] [ parallel-mappings ] bi
-        [ [ >insn ] each ] { } make
-    ] with-scope ;
-
 : fork? ( from to -- ? )
     {
         [ drop successors>> length 1 >= ]
@@ -206,5 +71,4 @@ ERROR: resolve-error ;
     dup successors>> [ resolve-edge-data-flow ] with each ;
 
 : resolve-data-flow ( rpo -- )
-    H{ } clone spill-temps set
     [ resolve-block-data-flow ] each ;

core/hashtables/hashtables-tests.factor

@@ -176,3 +176,6 @@ H{ } "x" set
 [ 1 ] [ "h" get assoc-size ] unit-test
 
 [ 1 ] [ 2 "h" get at ] unit-test
+
+! Random test case
+[ "A" ] [ 100 [ dup ] H{ } map>assoc 32 over delete-at "A" 32 pick set-at 32 swap at ] unit-test