fix bug in linear-scan.resolve by rewriting entire algorithm

diff --git a/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor b/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor
index fad1c022ef285dd2aaf1b2b19e34b0960d476080..7579b46175cd98f896b45d77befb5a7ad18091ee 100644 (file)
--- a/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor
+++ b/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor
@@ -67,119 +67,94 @@ T{ live-interval
 
 [
     {
-        T{ register->register { from 1 } { to 2 } { reg-class int-regs } }
-        T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
+        T{ _copy { dst 5 } { src 4 } { class int-regs } }
+        T{ _spill { src 0 } { class int-regs } { n 6 } }
+        T{ _copy { dst 0 } { src 1 } { class int-regs } }
+        T{ _reload { dst 1 } { class int-regs } { n 6 } }
+        T{ _spill { src 0 } { class float-regs } { n 7 } }
+        T{ _copy { dst 0 } { src 1 } { class float-regs } }
+        T{ _reload { dst 1 } { class float-regs } { n 7 } }
     }
 ] [
     {
         T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
-        T{ register->register { from 1 } { to 2 } { reg-class int-regs } }
-    } trace-chains
+        T{ register->register { from 1 } { to 0 } { reg-class int-regs } }
+        T{ register->register { from 0 } { to 1 } { reg-class float-regs } }
+        T{ register->register { from 1 } { to 0 } { reg-class float-regs } }
+        T{ register->register { from 4 } { to 5 } { reg-class int-regs } }
+    } mapping-instructions
 ] unit-test
 
 [
     {
-        T{ register->register { from 2 } { to 3 } { reg-class int-regs } }
-        T{ register->register { from 1 } { to 2 } { reg-class int-regs } }
-        T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
+        T{ _spill { src 0 } { class int-regs } { n 3 } }
+        T{ _copy { dst 0 } { src 2 } { class int-regs } }
+        T{ _copy { dst 2 } { src 1 } { class int-regs } }
+        T{ _reload { dst 1 } { class int-regs } { n 3 } }
     }
 ] [
     {
-        T{ register->register { from 2 } { to 3 } { reg-class int-regs } }
-        T{ register->register { from 1 } { to 2 } { reg-class int-regs } }
-        T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
-    } trace-chains
-] unit-test
-
-[
-    {
-        T{ register->register { from 2 } { to 3 } { reg-class int-regs } }
-        T{ register->register { from 1 } { to 2 } { reg-class int-regs } }
         T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
-    }
-] [
-    {
         T{ register->register { from 1 } { to 2 } { reg-class int-regs } }
-        T{ register->register { from 2 } { to 3 } { reg-class int-regs } }
-        T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
-    } trace-chains
+        T{ register->register { from 2 } { to 0 } { reg-class int-regs } }
+    } mapping-instructions
 ] unit-test
 
 [
     {
-        T{ register->register { from 2 } { to 3 } { reg-class int-regs } }
-        T{ register->register { from 1 } { to 2 } { reg-class int-regs } }
-        T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
+        T{ _spill { src 0 } { class int-regs } { n 3 } }
+        T{ _copy { dst 0 } { src 2 } { class int-regs } }
+        T{ _copy { dst 2 } { src 1 } { class int-regs } }
+        T{ _reload { dst 1 } { class int-regs } { n 3 } }
     }
 ] [
     {
         T{ register->register { from 1 } { to 2 } { reg-class int-regs } }
-        T{ register->register { from 2 } { to 3 } { reg-class int-regs } }
+        T{ register->register { from 2 } { to 0 } { reg-class int-regs } }
         T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
-    } trace-chains
+    } mapping-instructions
 ] unit-test
 
 [
     {
-        T{ register->register { from 2 } { to 3 } { reg-class int-regs } }
-        T{ register->memory { from 1 } { to 2 } { reg-class int-regs } }
-        T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
+        T{ _copy { dst 1 } { src 0 } { class int-regs } }
+        T{ _copy { dst 2 } { src 0 } { class int-regs } }
     }
 ] [
     {
-        T{ register->memory { from 1 } { to 2 } { reg-class int-regs } }
-        T{ register->register { from 2 } { to 3 } { reg-class int-regs } }
         T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
-    } trace-chains
+        T{ register->register { from 0 } { to 2 } { reg-class int-regs } }
+    } mapping-instructions
 ] unit-test
 
 [
-    {
-        T{ _copy { dst 5 } { src 4 } { class int-regs } }
-        T{ _spill { src 1 } { class int-regs } { n 6 } }
-        T{ _copy { dst 1 } { src 0 } { class int-regs } }
-        T{ _reload { dst 0 } { class int-regs } { n 6 } }
-        T{ _spill { src 1 } { class float-regs } { n 7 } }
-        T{ _copy { dst 1 } { src 0 } { class float-regs } }
-        T{ _reload { dst 0 } { class float-regs } { n 7 } }
-    }
+    { }
 ] [
     {
-        T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
-        T{ register->register { from 1 } { to 0 } { reg-class int-regs } }
-        T{ register->register { from 0 } { to 1 } { reg-class float-regs } }
-        T{ register->register { from 1 } { to 0 } { reg-class float-regs } }
-        T{ register->register { from 4 } { to 5 } { reg-class int-regs } }
+       T{ register->register { from 4 } { to 4 } { reg-class int-regs } }
     } mapping-instructions
 ] unit-test
 
 [
-    {
-        T{ _spill { src 1 } { class int-regs } { n 3 } }
-        T{ _copy { dst 1 } { src 0 } { class int-regs } }
-        T{ _copy { dst 0 } { src 2 } { class int-regs } }
-        T{ _reload { dst 2 } { class int-regs } { n 3 } }
-    }
+    { T{ _spill { src 4 } { class int-regs } { n 4 } } }
 ] [
     {
-        T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
-        T{ register->register { from 1 } { to 2 } { reg-class int-regs } }
-        T{ register->register { from 2 } { to 0 } { reg-class int-regs } }
+       T{ register->memory { from 4 } { to 4 } { reg-class int-regs } }
     } mapping-instructions
 ] unit-test
 
+
 [
     {
-        T{ _spill { src 1 } { class int-regs } { n 3 } }
         T{ _copy { dst 1 } { src 0 } { class int-regs } }
-        T{ _copy { dst 0 } { src 2 } { class int-regs } }
-        T{ _reload { dst 2 } { class int-regs } { n 3 } }
+        T{ _copy { dst 2 } { src 0 } { class int-regs } }
+        T{ _copy { dst 0 } { src 3 } { class int-regs } }
     }
 ] [
     {
-        T{ register->register { from 1 } { to 2 } { reg-class int-regs } }
-        T{ register->register { from 2 } { to 0 } { reg-class int-regs } }
         T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
+        T{ register->register { from 3 } { to 0 } { reg-class int-regs } }
+        T{ register->register { from 0 } { to 2 } { reg-class int-regs } }
     } mapping-instructions
 ] unit-test
 
@@ -187,26 +162,38 @@ T{ live-interval
     {
         T{ _copy { dst 1 } { src 0 } { class int-regs } }
         T{ _copy { dst 2 } { src 0 } { class int-regs } }
+        T{ _spill { src 3 } { class int-regs } { n 5 } }
+        T{ _copy { dst 4 } { src 0 } { class int-regs } }
+        T{ _copy { dst 3 } { src 4 } { class int-regs } }
+        T{ _reload { dst 0 } { class int-regs } { n 5 } }
     }
 ] [
     {
         T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
         T{ register->register { from 0 } { to 2 } { reg-class int-regs } }
+        T{ register->register { from 3 } { to 0 } { reg-class int-regs } }
+        T{ register->register { from 4 } { to 3 } { reg-class int-regs } }
+        T{ register->register { from 0 } { to 4 } { reg-class int-regs } }
     } mapping-instructions
 ] unit-test
 
 [
-    { }
-] [
     {
-       T{ register->register { from 4 } { to 4 } { reg-class int-regs } }
-    } mapping-instructions
-] unit-test
-
-[
-    { T{ _spill { src 4 } { class int-regs } { n 4 } } }
+        T{ _copy { dst 2 } { src 0 } { class int-regs } }
+        T{ _copy { dst 9 } { src 1 } { class int-regs } }
+        T{ _copy { dst 1 } { src 0 } { class int-regs } }
+        T{ _spill { src 3 } { class int-regs } { n 10 } }
+        T{ _copy { dst 4 } { src 0 } { class int-regs } }
+        T{ _copy { dst 3 } { src 4 } { class int-regs } }
+        T{ _reload { dst 0 } { class int-regs } { n 10 } }
+    }
 ] [
     {
-       T{ register->memory { from 4 } { to 4 } { reg-class int-regs } }
+        T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
+        T{ register->register { from 0 } { to 2 } { reg-class int-regs } }
+        T{ register->register { from 1 } { to 9 } { reg-class int-regs } }
+        T{ register->register { from 3 } { to 0 } { reg-class int-regs } }
+        T{ register->register { from 4 } { to 3 } { reg-class int-regs } }
+        T{ register->register { from 0 } { to 4 } { reg-class int-regs } }
     } mapping-instructions
 ] unit-test

diff --git a/basis/compiler/cfg/linear-scan/resolve/resolve.factor b/basis/compiler/cfg/linear-scan/resolve/resolve.factor
index b29a661fbf45864e6b9e8b24de186a43180d74f4..a9e3372fe4950970efba8480dae763259c67a869 100644 (file)
--- a/basis/compiler/cfg/linear-scan/resolve/resolve.factor
+++ b/basis/compiler/cfg/linear-scan/resolve/resolve.factor
@@ -3,9 +3,9 @@
 USING: accessors arrays assocs classes.parser classes.tuple
 combinators combinators.short-circuit compiler.cfg.instructions
 compiler.cfg.linear-scan.live-intervals compiler.cfg.liveness
-fry hashtables histogram kernel locals make math math.order
+fry hashtables kernel locals make math math.order
 namespaces parser prettyprint random sequences sets
-sorting.functor sorting.slots words ;
+sorting.functor sorting.slots words io ;
 IN: compiler.cfg.linear-scan.resolve
 
 <<
@@ -114,38 +114,40 @@ M: register->register to-loc drop register ;
 : to-reg ( operation -- seq )
     [ to-loc ] [ to>> ] [ reg-class>> ] tri 3array ;
 
-: (trace-chain) ( pair -- )
-    to-reg froms get at [
-        dup length 1 = [
-            first [ , ] [ (trace-chain) ] bi
-        ] [
-            drop
-        ] if
-    ] when* ;
-
-: trace-chain ( pair -- seq )
-    [ [ , ] [ (trace-chain) ] bi ] { } make reverse ;
-
 : start? ( operations -- pair )
     from-reg tos get key? not ;
 
+: independent-assignment? ( operations -- pair )
+    to-reg froms get key? not ;
+
 : init-temp-spill ( operations -- )
     [ [ to>> ] [ from>> ] bi max ] [ max ] map-reduce
     1 + temp-spill set ;
 
 : set-tos/froms ( operations -- )
     {
-        [ [ from-reg ] collect-values froms set ]
-        [ [ to-reg ] collect-values tos set ]
+        [ [ [ from-reg ] keep ] H{ } map>assoc froms set ]
+        [ [ [ to-reg ] keep ] H{ } map>assoc tos set ]
     } cleave ;
 
-: trace-chains ( operations -- operations' )
-    [ set-tos/froms ]
-    [ [ start? ] filter [ trace-chain ] map concat ] bi ;
+:: (trace-chain) ( obj hashtable -- )
+    obj to-reg froms get at* [
+        obj over hashtable clone [ maybe-set-at ] keep swap
+        [ (trace-chain) ] [ , drop ] if
+    ] [
+        drop hashtable ,
+    ] if ;
 
-: break-cycle-n ( operations -- operations' )
-    unclip [ trace-chains ] dip
+: trace-chain ( obj -- seq )
     [
+        dup dup associate (trace-chain)
+    ] { } make [ keys ] map concat reverse ;
+
+: trace-chains ( seq -- seq' )
+    [ trace-chain ] map concat ;
+
+: break-cycle-n ( operations -- operations' )
+    unclip [
         [ from>> temp-spill get ]
         [ reg-class>> ] bi \ register->memory boa
     ] [
@@ -155,32 +157,30 @@ M: register->register to-loc drop register ;
 
 : break-cycle ( operations -- operations' )
     dup length {
-        { 1 [ drop { } ] }
+        { 1 [ ] }
         [ drop break-cycle-n ]
     } case ;
 
-: follow-cycle ( obj -- seq )
-   dup dup associate [
-        [ to-reg froms get at first dup dup ] dip
-        [ maybe-set-at ] keep swap
-    ] loop nip keys ;
-
 : (group-cycles) ( seq -- )
     [
-        unclip follow-cycle [ diff ] keep , (group-cycles)
+        dup set-tos/froms
+        unclip trace-chain
+        [ diff ] keep , (group-cycles)
     ] unless-empty ;
 
 : group-cycles ( seq -- seqs )
     [ (group-cycles) ] { } make ;
 
-: partition-mappings ( mappings -- no-cycles cycles )
-    [ start? not ] partition
-    [ trace-chain ] map concat tuck diff ;
+: remove-dead-mappings ( seq -- seq' )
+    prune [ [ from-reg ] [ to-reg ] bi = not ] filter ;
 
 : parallel-mappings ( operations -- seq )
-    partition-mappings [
-        group-cycles [ break-cycle ] map concat append
-    ] unless-empty ;
+    [
+        [ 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 )
     [
@@ -191,15 +191,19 @@ M: register->register to-loc drop register ;
     ] with-scope ;
 
 : fork? ( from to -- ? )
-    [ successors>> length 1 >= ]
-    [ predecessors>> length 1 = ] bi* and ; inline
+    {
+        [ drop successors>> length 1 >= ]
+        [ nip predecessors>> length 1 = ]
+    } 2&& ; inline
 
 : insert-position/fork ( from to -- before after )
     nip instructions>> [ >array ] [ dup delete-all ] bi swap ;
 
 : join? ( from to -- ? )
-    [ successors>> length 1 = ]
-    [ predecessors>> length 1 >= ] bi* and ; inline
+    {
+        [ drop successors>> length 1 = ]
+        [ nip predecessors>> length 1 >= ]
+    } 2&& ; inline
 
 : insert-position/join ( from to -- before after )
     drop instructions>> dup pop 1array ;