From e7e5bee9a278e554a1f151586c715feaf6921819 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 21 Jul 2009 17:49:30 -0500
Subject: [PATCH 1/3] compiler.cfg.ssa: Cytron's SSA construction algorithm

---
 .../cfg/dominance/dominance-tests.factor      |   9 +-
 basis/compiler/cfg/dominance/dominance.factor |   7 +-
 basis/compiler/cfg/renaming/renaming.factor   |   8 +
 basis/compiler/cfg/ssa/ssa-tests.factor       |  79 ++++++++++
 basis/compiler/cfg/ssa/ssa.factor             | 146 ++++++++++++++++++
 5 files changed, 240 insertions(+), 9 deletions(-)
 create mode 100644 basis/compiler/cfg/ssa/ssa-tests.factor
 create mode 100644 basis/compiler/cfg/ssa/ssa.factor

diff --git a/basis/compiler/cfg/dominance/dominance-tests.factor b/basis/compiler/cfg/dominance/dominance-tests.factor
index e3e0d09cfc..b87f668d88 100644
--- a/basis/compiler/cfg/dominance/dominance-tests.factor
+++ b/basis/compiler/cfg/dominance/dominance-tests.factor
@@ -34,11 +34,10 @@ V{ } 5 test-bb
 
 [ t ] [ 0 get dom-children 1 get 2 get 4 get 3array set= ] unit-test
 
-[ t ] [ 4 get 1 get dom-frontier key? ] unit-test
-[ f ] [ 3 get 1 get dom-frontier key? ] unit-test
-[ t ] [ 4 get 2 get dom-frontier key? ] unit-test
-[ t ] [ 0 get dom-frontier assoc-empty? ] unit-test
-[ t ] [ 4 get dom-frontier assoc-empty? ] unit-test
+[ { 4 } ] [ 1 get dom-frontier [ number>> ] map ] unit-test
+[ { 4 } ] [ 2 get dom-frontier [ number>> ] map ] unit-test
+[ f ] [ 0 get dom-frontier ] unit-test
+[ f ] [ 4 get dom-frontier ] unit-test
 
 ! Example from the paper
 V{ } 0 test-bb
diff --git a/basis/compiler/cfg/dominance/dominance.factor b/basis/compiler/cfg/dominance/dominance.factor
index 8b8d006560..9c8fc79619 100644
--- a/basis/compiler/cfg/dominance/dominance.factor
+++ b/basis/compiler/cfg/dominance/dominance.factor
@@ -1,8 +1,7 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs combinators sets math compiler.cfg.rpo
-compiler.cfg.stack-analysis fry kernel math.order namespaces
-sequences ;
+USING: accessors assocs combinators sets math fry kernel math.order
+namespaces sequences sorting compiler.cfg.rpo ;
 IN: compiler.cfg.dominance
 
 ! Reference:
@@ -66,7 +65,7 @@ SYMBOL: dom-frontiers
 
 PRIVATE>
 
-: dom-frontier ( bb -- set ) dom-frontiers get at ;
+: dom-frontier ( bb -- set ) dom-frontiers get at keys ;
 
 <PRIVATE
 
diff --git a/basis/compiler/cfg/renaming/renaming.factor b/basis/compiler/cfg/renaming/renaming.factor
index efc841e21f..8dbcadfe8b 100644
--- a/basis/compiler/cfg/renaming/renaming.factor
+++ b/basis/compiler/cfg/renaming/renaming.factor
@@ -14,6 +14,14 @@ M: ##flushable rename-insn-defs
     [ rename-value ] change-dst
     drop ;
 
+M: ##fixnum-overflow rename-insn-defs
+    [ rename-value ] change-dst
+    drop ;
+
+M: _fixnum-overflow rename-insn-defs
+    [ rename-value ] change-dst
+    drop ;
+
 M: insn rename-insn-defs drop ;
 
 GENERIC: rename-insn-uses ( insn -- )
diff --git a/basis/compiler/cfg/ssa/ssa-tests.factor b/basis/compiler/cfg/ssa/ssa-tests.factor
new file mode 100644
index 0000000000..c53d30af5d
--- /dev/null
+++ b/basis/compiler/cfg/ssa/ssa-tests.factor
@@ -0,0 +1,79 @@
+USING: accessors compiler.cfg compiler.cfg.debugger
+compiler.cfg.dominance compiler.cfg.instructions
+compiler.cfg.predecessors compiler.cfg.ssa assocs
+compiler.cfg.registers cpu.architecture kernel namespaces sequences
+tools.test vectors ;
+IN: compiler.cfg.ssa.tests
+
+! Reset counters so that results are deterministic w.r.t. hash order
+0 vreg-counter set-global
+0 basic-block set-global
+
+V{
+    T{ ##load-immediate f V int-regs 1 100 }
+    T{ ##add-imm f V int-regs 2 V int-regs 1 50 }
+    T{ ##add-imm f V int-regs 2 V int-regs 2 10 }
+    T{ ##branch }
+} 0 test-bb
+
+V{
+    T{ ##load-immediate f V int-regs 3 3 }
+    T{ ##branch }
+} 1 test-bb
+
+V{
+    T{ ##load-immediate f V int-regs 3 4 }
+    T{ ##branch }
+} 2 test-bb
+
+V{
+    T{ ##replace f V int-regs 3 D 0 }
+    T{ ##return }
+} 3 test-bb
+
+0 get 1 get 2 get V{ } 2sequence >>successors drop
+1 get 3 get 1vector >>successors drop
+2 get 3 get 1vector >>successors drop
+
+: test-ssa ( -- )
+    cfg new 0 get >>entry
+    compute-predecessors
+    compute-dominance
+    construct-ssa
+    drop ;
+
+[ ] [ test-ssa ] unit-test
+
+[
+    V{
+        T{ ##load-immediate f V int-regs 1 100 }
+        T{ ##add-imm f V int-regs 2 V int-regs 1 50 }
+        T{ ##add-imm f V int-regs 3 V int-regs 2 10 }
+        T{ ##branch }
+    }
+] [ 0 get instructions>> ] unit-test
+
+[
+    V{
+        T{ ##load-immediate f V int-regs 4 3 }
+        T{ ##branch }
+    }
+] [ 1 get instructions>> ] unit-test
+
+[
+    V{
+        T{ ##load-immediate f V int-regs 5 4 }
+        T{ ##branch }
+    }
+] [ 2 get instructions>> ] unit-test
+
+[
+    V{
+        T{ ##phi f V int-regs 6 H{ { 1 V int-regs 4 } { 2 V int-regs 5 } } }
+        T{ ##replace f V int-regs 6 D 0 }
+        T{ ##return }
+    }
+] [
+    3 get instructions>>
+    [ dup ##phi? [ [ [ [ number>> ] dip ] assoc-map ] change-inputs ] when ] map
+] unit-test
\ No newline at end of file
diff --git a/basis/compiler/cfg/ssa/ssa.factor b/basis/compiler/cfg/ssa/ssa.factor
new file mode 100644
index 0000000000..e11701965b
--- /dev/null
+++ b/basis/compiler/cfg/ssa/ssa.factor
@@ -0,0 +1,146 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: namespaces kernel accessors sequences fry dlists
+deques assocs sets math combinators sorting
+compiler.cfg
+compiler.cfg.rpo
+compiler.cfg.def-use
+compiler.cfg.renaming
+compiler.cfg.registers
+compiler.cfg.dominance
+compiler.cfg.instructions ;
+IN: compiler.cfg.ssa
+
+! SSA construction. Predecessors and dominance must be computed first.
+
+! This is the classical algorithm based on dominance frontiers:
+! http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.25.8240
+
+! Eventually might be worth trying something fancier:
+! http://portal.acm.org/citation.cfm?id=1065887.1065890
+
+<PRIVATE
+
+! Maps vreg to sequence of basic blocks
+SYMBOL: defs
+
+! Maps basic blocks to sequences of vregs
+SYMBOL: inserting-phi-nodes
+
+: compute-defs ( cfg -- )
+    H{ } clone dup defs set
+    '[
+        dup instructions>> [
+            defs-vregs [
+                _ push-at
+            ] with each
+        ] with each
+    ] each-basic-block ;
+
+SYMBOLS: has-already ever-on-work-list work-list ;
+
+: init-insert-phi-nodes ( bbs -- )
+    H{ } clone has-already set
+    [ unique ever-on-work-list set ]
+    [ <hashed-dlist> [ push-all-front ] keep work-list set ] bi ;
+
+: add-to-work-list ( bb -- )
+    dup ever-on-work-list get key? [ drop ] [
+        [ ever-on-work-list get conjoin ]
+        [ work-list get push-front ]
+        bi
+    ] if ;
+
+: insert-phi-node-later ( vreg bb -- )
+    [ predecessors>> over '[ _ ] H{ } map>assoc \ ##phi new-insn ] keep
+    inserting-phi-nodes get push-at ;
+
+: compute-phi-node-in ( vreg bb -- )
+    dup has-already get key? [ 2drop ] [
+        [ insert-phi-node-later ]
+        [ has-already get conjoin ]
+        [ add-to-work-list ]
+        tri
+    ] if ;
+
+: compute-phi-nodes-for ( vreg bbs -- )
+    dup length 2 >= [
+        init-insert-phi-nodes
+        work-list get [
+            dom-frontier [
+                compute-phi-node-in
+            ] with each
+        ] with slurp-deque
+    ] [ 2drop ] if ;
+
+: compute-phi-nodes ( -- )
+    H{ } clone inserting-phi-nodes set
+    defs get [ compute-phi-nodes-for ] assoc-each ;
+
+: insert-phi-nodes-in ( phis bb -- )
+    [ append ] change-instructions drop ;
+
+: insert-phi-nodes ( -- )
+    inserting-phi-nodes get [ swap insert-phi-nodes-in ] assoc-each ;
+
+SYMBOLS: stacks originals ;
+
+: init-renaming ( -- )
+    H{ } clone stacks set
+    H{ } clone originals set ;
+
+: gen-name ( vreg -- vreg' )
+    [ reg-class>> next-vreg ] keep
+    [ stacks get push-at ]
+    [ swap originals get set-at ]
+    [ drop ]
+    2tri ;
+
+: top-name ( vreg -- vreg' )
+    stacks get at last ;
+
+GENERIC: rename-insn ( insn -- )
+
+M: insn rename-insn
+    [ dup uses-vregs [ dup top-name ] { } map>assoc renamings set rename-insn-uses ]
+    [ dup defs-vregs [ dup gen-name ] { } map>assoc renamings set rename-insn-defs ]
+    bi ;
+
+M: ##phi rename-insn
+    dup defs-vregs [ dup gen-name ] { } map>assoc renamings set rename-insn-defs ;
+
+: rename-insns ( bb -- )
+    instructions>> [ rename-insn ] each ;
+
+: rename-successor-phi ( phi bb -- )
+    swap inputs>> [ top-name ] change-at ;
+
+: rename-successor-phis ( succ bb -- )
+    [ inserting-phi-nodes get at ] dip
+    '[ _ rename-successor-phi ] each ;
+
+: rename-successors-phis ( bb -- )
+    [ successors>> ] keep '[ _ rename-successor-phis ] each ;
+
+: pop-stacks ( bb -- )
+    instructions>> [
+        defs-vregs originals get stacks get
+        '[ _ at _ at pop* ] each
+    ] each ;
+
+: rename-in-block ( bb -- )
+    {
+        [ rename-insns ]
+        [ rename-successors-phis ]
+        [ dom-children [ rename-in-block ] each ]
+        [ pop-stacks ]
+    } cleave ;
+
+: rename ( cfg -- )
+    init-renaming
+    entry>> rename-in-block ;
+
+PRIVATE>
+
+: construct-ssa ( cfg -- cfg' )
+    dup [ compute-defs compute-phi-nodes insert-phi-nodes ] [ rename ] bi ;
\ No newline at end of file

From ead57fc5dde4cc15770d74301f197be96e9777a0 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 21 Jul 2009 17:49:44 -0500
Subject: [PATCH 2/3] compiler.cfg.registers: minor optimization

---
 basis/compiler/cfg/registers/registers.factor | 12 +++++++++---
 1 file changed, 9 insertions(+), 3 deletions(-)

diff --git a/basis/compiler/cfg/registers/registers.factor b/basis/compiler/cfg/registers/registers.factor
index 71f313be5a..c5b3907153 100644
--- a/basis/compiler/cfg/registers/registers.factor
+++ b/basis/compiler/cfg/registers/registers.factor
@@ -1,11 +1,17 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors namespaces kernel arrays parser ;
+USING: accessors namespaces kernel arrays parser math math.order ;
 IN: compiler.cfg.registers
 
 ! Virtual registers, used by CFG and machine IRs
-TUPLE: vreg { reg-class read-only } { n read-only } ;
+TUPLE: vreg { reg-class read-only } { n fixnum read-only } ;
+
+M: vreg equal? over vreg? [ [ n>> ] bi@ eq? ] [ 2drop f ] if ;
+
+M: vreg hashcode* nip n>> ;
+
 SYMBOL: vreg-counter
+
 : next-vreg ( reg-class -- vreg ) \ vreg-counter counter vreg boa ;
 
 ! Stack locations -- 'n' is an index starting from the top of the stack

From 1aa6c9a0d538812370d499b274f69cdeedbc4c26 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 21 Jul 2009 22:25:19 -0500
Subject: [PATCH 3/3] compiler.cfg: Fix unit tests

---
 .../cfg/dominance/dominance-tests.factor      |  4 ++--
 .../phi-elimination-tests.factor              | 23 +++++++------------
 .../value-numbering-tests.factor              | 11 ---------
 3 files changed, 10 insertions(+), 28 deletions(-)

diff --git a/basis/compiler/cfg/dominance/dominance-tests.factor b/basis/compiler/cfg/dominance/dominance-tests.factor
index b87f668d88..210d5614c2 100644
--- a/basis/compiler/cfg/dominance/dominance-tests.factor
+++ b/basis/compiler/cfg/dominance/dominance-tests.factor
@@ -36,8 +36,8 @@ V{ } 5 test-bb
 
 [ { 4 } ] [ 1 get dom-frontier [ number>> ] map ] unit-test
 [ { 4 } ] [ 2 get dom-frontier [ number>> ] map ] unit-test
-[ f ] [ 0 get dom-frontier ] unit-test
-[ f ] [ 4 get dom-frontier ] unit-test
+[ { } ] [ 0 get dom-frontier ] unit-test
+[ { } ] [ 4 get dom-frontier ] unit-test
 
 ! Example from the paper
 V{ } 0 test-bb
diff --git a/basis/compiler/cfg/phi-elimination/phi-elimination-tests.factor b/basis/compiler/cfg/phi-elimination/phi-elimination-tests.factor
index 79d1797720..22afc0b32b 100644
--- a/basis/compiler/cfg/phi-elimination/phi-elimination-tests.factor
+++ b/basis/compiler/cfg/phi-elimination/phi-elimination-tests.factor
@@ -36,27 +36,20 @@ V{
 
 test-diamond
 
+3 vreg-counter set-global
+
 [ ] [ cfg new 0 get >>entry eliminate-phis drop ] unit-test
 
-[let | n! [ f ] |
-
-[ ] [ 2 get successors>> first instructions>> first dst>> n>> n! ] unit-test
-
-[ t ] [
-    T{ ##copy f V int-regs n V int-regs 1 }
-    2 get successors>> first instructions>> first =
+[ T{ ##copy f V int-regs 4 V int-regs 1 } ] [
+    2 get successors>> first instructions>> first
 ] unit-test
 
-[ t ] [
-    T{ ##copy f V int-regs n V int-regs 2 }
-    3 get successors>> first instructions>> first =
+[ T{ ##copy f V int-regs 4 V int-regs 2 } ] [
+    3 get successors>> first instructions>> first
 ] unit-test
 
-[ t ] [
-    T{ ##copy f V int-regs 3 V int-regs n }
-    4 get instructions>> first =
+[ T{ ##copy f V int-regs 3 V int-regs 4 } ] [
+    4 get instructions>> first
 ] unit-test
 
-]
-
 [ 3 ] [ 4 get instructions>> length ] unit-test
diff --git a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
index 62ed4a7eb3..bd2bb692b7 100644
--- a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
+++ b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
@@ -1218,17 +1218,6 @@ test-diamond
 
 [ t ] [ 1 get successors>> first 3 get eq? ] unit-test
 
-[let | n! [ f ] |
-
-[ ] [ 2 get successors>> first instructions>> first src>> n>> n! ] unit-test
-
-[ t ] [
-    T{ ##copy f V int-regs n V int-regs 2 }
-    3 get successors>> first instructions>> first =
-] unit-test
-
-]
-
 [ 3 ] [ 4 get instructions>> length ] unit-test
 
 V{