diff --git a/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor b/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor
index fad1c022ef..7579b46175 100644
--- a/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor
+++ b/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor
@@ -65,83 +65,15 @@ T{ live-interval
1 get test-live-interval-2 reload-from
] unit-test
-[
- {
- 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 0 } { to 1 } { reg-class int-regs } }
- T{ register->register { from 1 } { to 2 } { 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 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
-] 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
-] 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{ 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
-] 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{ _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 } }
}
] [
{
@@ -155,10 +87,10 @@ T{ live-interval
[
{
- T{ _spill { src 1 } { class int-regs } { n 3 } }
- T{ _copy { dst 1 } { src 0 } { class int-regs } }
+ T{ _spill { src 0 } { class int-regs } { n 3 } }
T{ _copy { dst 0 } { src 2 } { class int-regs } }
- T{ _reload { dst 2 } { class int-regs } { n 3 } }
+ T{ _copy { dst 2 } { src 1 } { class int-regs } }
+ T{ _reload { dst 1 } { class int-regs } { n 3 } }
}
] [
{
@@ -170,10 +102,10 @@ T{ live-interval
[
{
- T{ _spill { src 1 } { class int-regs } { n 3 } }
- T{ _copy { dst 1 } { src 0 } { class int-regs } }
+ T{ _spill { src 0 } { class int-regs } { n 3 } }
T{ _copy { dst 0 } { src 2 } { class int-regs } }
- T{ _reload { dst 2 } { class int-regs } { n 3 } }
+ T{ _copy { dst 2 } { src 1 } { class int-regs } }
+ T{ _reload { dst 1 } { class int-regs } { n 3 } }
}
] [
{
@@ -210,3 +142,58 @@ T{ live-interval
T{ register->memory { from 4 } { to 4 } { reg-class int-regs } }
} mapping-instructions
] unit-test
+
+
+[
+ {
+ T{ _copy { dst 1 } { src 0 } { class int-regs } }
+ T{ _copy { dst 2 } { src 0 } { class int-regs } }
+ T{ _copy { dst 0 } { src 3 } { 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
+
+[
+ {
+ 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{ _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->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 b29a661fbf..a9e3372fe4 100644
--- 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 ;
+
+: 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 [ trace-chains ] dip
- [
+ 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 ;