From 90017eb2489aa2ce4b253a961bde84b4b13ddf0e Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Fri, 26 Jun 2009 21:48:21 -0500
Subject: [PATCH] add spill-temp to compiler.cfg.instructions, implement
 parallel register assignment in linear-scan.resolve

---
 .../cfg/instructions/instructions.factor      |   2 +
 .../linear-scan/resolve/resolve-tests.factor  | 154 +++++++++++++++++-
 .../cfg/linear-scan/resolve/resolve.factor    | 126 +++++++++++++-
 3 files changed, 271 insertions(+), 11 deletions(-)

diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor
index 1bf94985a6..5b3e1af930 100644
--- a/basis/compiler/cfg/instructions/instructions.factor
+++ b/basis/compiler/cfg/instructions/instructions.factor
@@ -247,3 +247,5 @@ INSN: _spill src class n ;
 INSN: _reload dst class n ;
 INSN: _copy dst src class ;
 INSN: _spill-counts counts ;
+
+SYMBOL: temp-spill
diff --git a/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor b/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor
index 3e98d6c9f0..717cf36e14 100644
--- a/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor
+++ b/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor
@@ -1,10 +1,10 @@
-USING: accessors arrays compiler.cfg compiler.cfg.instructions
-compiler.cfg.linear-scan.debugger
+USING: accessors arrays classes compiler.cfg
+compiler.cfg.instructions compiler.cfg.linear-scan.debugger
 compiler.cfg.linear-scan.live-intervals
 compiler.cfg.linear-scan.numbering
 compiler.cfg.linear-scan.resolve compiler.cfg.predecessors
 compiler.cfg.registers compiler.cfg.rpo cpu.architecture kernel
-namespaces tools.test vectors ;
+multiline namespaces tools.test vectors ;
 IN: compiler.cfg.linear-scan.resolve.tests
 
 [ { 1 2 3 4 5 6 } ] [
@@ -62,4 +62,150 @@ T{ live-interval
 
 [ f ] [
     1 get test-live-interval-2 reload-from
-] unit-test
\ No newline at end of file
+] 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{ 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 } }
+    } 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{ 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 } }
+    } 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{ 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 } }
+    } mapping-instructions
+] unit-test
+
+[
+    {
+        T{ _copy { dst 1 } { src 0 } { class int-regs } }
+        T{ _copy { dst 2 } { src 0 } { 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 } }
+    } 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{ register->memory { from 4 } { 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 55a2eab41b..b29a661fbf 100644
--- a/basis/compiler/cfg/linear-scan/resolve/resolve.factor
+++ b/basis/compiler/cfg/linear-scan/resolve/resolve.factor
@@ -1,9 +1,11 @@
-! Copyright (C) 2009 Slava Pestov
+! Copyright (C) 2009 Slava Pestov, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs kernel math namespaces sequences
-classes.tuple classes.parser parser fry words make arrays
-locals combinators compiler.cfg.linear-scan.live-intervals
-compiler.cfg.liveness compiler.cfg.instructions ;
+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
+namespaces parser prettyprint random sequences sets
+sorting.functor sorting.slots words ;
 IN: compiler.cfg.linear-scan.resolve
 
 <<
@@ -75,8 +77,118 @@ M: memory->register >insn
 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 )
+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 )
+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 ;
+
+: 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 ;
+
+: 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 ]
+    } cleave ;
+
+: trace-chains ( operations -- operations' )
+    [ set-tos/froms ]
+    [ [ start? ] filter [ trace-chain ] map concat ] bi ;
+
+: break-cycle-n ( operations -- operations' )
+    unclip [ trace-chains ] dip
+    [
+        [ from>> temp-spill get ]
+        [ reg-class>> ] bi \ register->memory boa
+    ] [
+        [ to>> temp-spill [ get ] [ inc ] bi swap ]
+        [ reg-class>> ] bi \ memory->register boa
+    ] bi [ 1array ] bi@ surround ;
+
+: break-cycle ( operations -- operations' )
+    dup length {
+        { 1 [ drop { } ] }
+        [ 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)
+    ] unless-empty ;
+
+: group-cycles ( seq -- seqs )
+    [ (group-cycles) ] { } make ;
+
+: partition-mappings ( mappings -- no-cycles cycles )
+    [ start? not ] partition
+    [ trace-chain ] map concat tuck diff ;
+
+: parallel-mappings ( operations -- seq )
+    partition-mappings [
+        group-cycles [ break-cycle ] map concat append
+    ] unless-empty ;
+
 : mapping-instructions ( mappings -- insns )
-    [ [ >insn ] each ] { } make ;
+    [
+        [ init-temp-spill ]
+        [ set-tos/froms ]
+        [ parallel-mappings ] tri
+        [ [ >insn ] each ] { } make
+    ] with-scope ;
 
 : fork? ( from to -- ? )
     [ successors>> length 1 >= ]
@@ -115,4 +227,4 @@ M: register->register >insn
     dup successors>> [ resolve-edge-data-flow ] with each ;
 
 : resolve-data-flow ( rpo -- )
-    [ resolve-block-data-flow ] each ;
\ No newline at end of file
+    [ resolve-block-data-flow ] each ;