compiler.cfg.ssa: now builds pruned SSA form

basis/compiler/cfg/ssa/ssa-tests.factor

@@ -5,9 +5,12 @@ 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
+: reset-counters ( -- )
-0 vreg-counter set-global
+    ! Reset counters so that results are deterministic w.r.t. hash order
-0 basic-block set-global
+    0 vreg-counter set-global
+    0 basic-block set-global ;
+
+reset-counters
 
 V{
     T{ ##load-immediate f V int-regs 1 100 }
@@ -38,7 +41,6 @@ V{
 : test-ssa ( -- )
     cfg new 0 get >>entry
     compute-predecessors
-    compute-dominance
     construct-ssa
     drop ;
 
@@ -67,6 +69,9 @@ V{
     }
 ] [ 2 get instructions>> ] unit-test
 
+: clean-up-phis ( insns -- insns' )
+    [ dup ##phi? [ [ [ [ number>> ] dip ] assoc-map ] change-inputs ] when ] map ;
+
 [
     V{
         T{ ##phi f V int-regs 6 H{ { 1 V int-regs 4 } { 2 V int-regs 5 } } }
@@ -75,5 +80,34 @@ V{
     }
 ] [
     3 get instructions>>
-    [ dup ##phi? [ [ [ [ number>> ] dip ] assoc-map ] change-inputs ] when ] map
+    clean-up-phis
+] unit-test
+
+reset-counters
+
+V{ } 0 test-bb
+V{ } 1 test-bb
+V{ T{ ##peek f V int-regs 0 D 0 } } 2 test-bb
+V{ T{ ##peek f V int-regs 0 D 0 } } 3 test-bb
+V{ T{ ##replace f V int-regs 0 D 0 } } 4 test-bb
+V{ } 5 test-bb
+V{ } 6 test-bb
+
+0 get 1 get 5 get V{ } 2sequence >>successors drop
+1 get 2 get 3 get V{ } 2sequence >>successors drop
+2 get 4 get 1vector >>successors drop
+3 get 4 get 1vector >>successors drop
+4 get 6 get 1vector >>successors drop
+5 get 6 get 1vector >>successors drop
+
+[ ] [ test-ssa ] unit-test
+
+[
+    V{
+        T{ ##phi f V int-regs 3 H{ { 2 V int-regs 1 } { 3 V int-regs 2 } } }
+        T{ ##replace f V int-regs 3 D 0 }
+    }
+] [
+    4 get instructions>>
+    clean-up-phis
 ] unit-test

basis/compiler/cfg/ssa/ssa.factor

@@ -1,19 +1,21 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces kernel accessors sequences fry dlists
+USING: namespaces kernel accessors sequences fry assocs
-deques assocs sets math combinators sorting
+sets math combinators
 compiler.cfg
 compiler.cfg.rpo
 compiler.cfg.def-use
 compiler.cfg.renaming
+compiler.cfg.liveness
 compiler.cfg.registers
 compiler.cfg.dominance
 compiler.cfg.instructions ;
 IN: compiler.cfg.ssa
 
-! SSA construction. Predecessors and dominance must be computed first.
+! SSA construction. Predecessors must be computed first.
 
-! This is the classical algorithm based on dominance frontiers:
+! This is the classical algorithm based on dominance frontiers, except
+! we consult liveness information to build pruned SSA:
 ! http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.25.8240
 
 ! Eventually might be worth trying something fancier:
@@ -32,45 +34,22 @@ SYMBOL: inserting-phi-nodes
     '[
         dup instructions>> [
             defs-vregs [
-                _ push-at
+                _ conjoin-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
+    2dup live-in key? [
-    inserting-phi-nodes get push-at ;
+        [ predecessors>> over '[ _ ] H{ } map>assoc \ ##phi new-insn ] keep
-
+        inserting-phi-nodes get push-at
-: compute-phi-node-in ( vreg bb -- )
+    ] [ 2drop ] if ;
-    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 >= [
+    keys dup length 2 >= [
-        init-insert-phi-nodes
+        iterated-dom-frontier [
-        work-list get [
+            insert-phi-node-later
-            dom-frontier [
+        ] with each
-                compute-phi-node-in
-            ] with each
-        ] with slurp-deque
     ] [ 2drop ] if ;
 
 : compute-phi-nodes ( -- )
@@ -143,4 +122,10 @@ M: ##phi rename-insn
 PRIVATE>
 
 : construct-ssa ( cfg -- cfg' )
-    dup [ compute-defs compute-phi-nodes insert-phi-nodes ] [ rename ] bi ;
+    {
+        [ ]
+        [ compute-live-sets ]
+        [ compute-dominance ]
+        [ compute-defs compute-phi-nodes insert-phi-nodes ]
+        [ rename ]
+    } cleave ;