compiler.cfg.ssa.construction: use the baller method for pruned SSA

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

@@ -10,6 +10,16 @@ IN: compiler.cfg.ssa.construction.tests
     0 vreg-counter set-global
     0 basic-block set-global ;
 
+: test-ssa ( -- )
+    cfg new 0 get >>entry
+    dup cfg set
+    construct-ssa
+    drop ;
+
+: clean-up-phis ( insns -- insns' )
+    [ dup ##phi? [ [ [ [ number>> ] dip ] assoc-map ] change-inputs ] when ] map ;
+
+! Test 1
 reset-counters
 
 V{
@@ -38,12 +48,6 @@ V{
 1 3 edge
 2 3 edge
 
-: test-ssa ( -- )
-    cfg new 0 get >>entry
-    dup cfg set
-    construct-ssa
-    drop ;
-
 [ ] [ test-ssa ] unit-test
 
 [
@@ -69,9 +73,6 @@ 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 6 H{ { 1 4 } { 2 5 } } }
@@ -83,6 +84,7 @@ V{
     clean-up-phis
 ] unit-test
 
+! Test 2
 reset-counters
 
 V{ } 0 test-bb
@@ -110,4 +112,89 @@ V{ } 6 test-bb
 ] [
     4 get instructions>>
     clean-up-phis
-] unit-test
+] unit-test
+
+! Test 3
+reset-counters
+
+V{
+    T{ ##branch }
+} 0 test-bb
+
+V{
+    T{ ##load-integer f 3 3 }
+    T{ ##branch }
+} 1 test-bb
+
+V{
+    T{ ##load-integer f 3 4 }
+    T{ ##branch }
+} 2 test-bb
+
+V{
+    T{ ##branch }
+} 3 test-bb
+
+V{
+    T{ ##return }
+} 4 test-bb
+
+0 { 1 2 3 } edges
+1 4 edge
+2 4 edge
+3 4 edge
+
+[ ] [ test-ssa ] unit-test
+
+[ V{ } ] [ 4 get instructions>> [ ##phi? ] filter ] unit-test
+
+! Test 4
+reset-counters
+
+V{
+    T{ ##branch }
+} 0 test-bb
+
+V{
+    T{ ##branch }
+} 1 test-bb
+
+V{
+    T{ ##load-integer f 0 4 }
+    T{ ##branch }
+} 2 test-bb
+
+V{
+    T{ ##load-integer f 0 4 }
+    T{ ##branch }
+} 3 test-bb
+
+V{
+    T{ ##branch }
+} 4 test-bb
+
+V{
+    T{ ##branch }
+} 5 test-bb
+
+V{
+    T{ ##branch }
+} 6 test-bb
+
+V{
+    T{ ##return }
+} 7 test-bb
+
+0 { 1 6 } edges
+1 { 2 3 4 } edges
+2 5 edge
+3 5 edge
+4 5 edge
+5 7 edge
+6 7 edge
+
+[ ] [ test-ssa ] unit-test
+
+[ V{ } ] [ 5 get instructions>> [ ##phi? ] filter ] unit-test
+
+[ V{ } ] [ 7 get instructions>> [ ##phi? ] filter ] unit-test

basis/compiler/cfg/ssa/construction/construction.factor

@@ -1,11 +1,10 @@
 ! Copyright (C) 2009, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: namespaces kernel accessors sequences fry assocs
-sets math combinators
+sets math combinators deques dlists
 compiler.cfg
 compiler.cfg.rpo
 compiler.cfg.def-use
-compiler.cfg.liveness
 compiler.cfg.registers
 compiler.cfg.dominance
 compiler.cfg.instructions
@@ -15,12 +14,18 @@ compiler.cfg.ssa.construction.tdmsc ;
 FROM: namespaces => set ;
 IN: compiler.cfg.ssa.construction
 
-! The phi placement algorithm is implemented in
+! Iterated dominance frontiers are computed using the DJ Graph
-! compiler.cfg.ssa.construction.tdmsc.
+! method in compiler.cfg.ssa.construction.tdmsc.
 
 ! The renaming algorithm is based on "Practical Improvements to
-! the Construction and Destruction of Static Single Assignment Form",
+! the Construction and Destruction of Static Single Assignment
-! however we construct pruned SSA, not semi-pruned SSA.
+! Form".
+
+! We construct pruned SSA without computing live sets, by
+! building a dependency graph for phi instructions, marking the
+! transitive closure of a vertex as live if it is referenced by
+! some non-phi instruction. Thanks to Cameron Zwarich for the
+! trick.
 
 ! http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.49.9683
 
@@ -50,31 +55,32 @@ M: vreg-insn compute-insn-defs
         [ compute-insn-defs ] with each
     ] simple-analysis ;
 
-! Maps basic blocks to sequences of vregs
+! Maps basic blocks to sequences of ##phi instructions
-SYMBOL: inserting-phi-nodes
+SYMBOL: inserting-phis
 
-: insert-phi-node-later ( vreg bb -- )
+: insert-phi-later ( vreg bb -- )
-    2dup live-in key? [
+    [ predecessors>> over '[ _ ] H{ } map>assoc \ ##phi new-insn ] keep
-        [ predecessors>> over '[ _ ] H{ } map>assoc \ ##phi new-insn ] keep
+    inserting-phis get push-at ;
-        inserting-phi-nodes get push-at
-    ] [ 2drop ] if ;
 
-: compute-phi-nodes-for ( vreg bbs -- )
+: compute-phis-for ( vreg bbs -- )
-    keys merge-set [ insert-phi-node-later ] with each ;
+    keys merge-set [ insert-phi-later ] with each ;
 
-: compute-phi-nodes ( -- )
+: compute-phis ( -- )
-    H{ } clone inserting-phi-nodes set
+    H{ } clone inserting-phis set
-    defs-multi get defs get '[ _ at compute-phi-nodes-for ] assoc-each ;
+    defs-multi get defs get '[ _ at compute-phis-for ] assoc-each ;
 
-: insert-phi-nodes-in ( phis bb -- )
+! Maps vregs to ##phi instructions
-    [ append ] change-instructions drop ;
+SYMBOL: phis
 
-: insert-phi-nodes ( -- )
+! Worklist of used vregs, to calculate used phis
-    inserting-phi-nodes get [ swap insert-phi-nodes-in ] assoc-each ;
+SYMBOL: used-vregs
 
+! Maps vregs to renaming stacks
 SYMBOLS: stacks pushed ;
 
 : init-renaming ( -- )
+    H{ } clone phis set
+    <hashed-dlist>  used-vregs set
     H{ } clone stacks set ;
 
 : gen-name ( vreg -- vreg' )
@@ -84,8 +90,12 @@ SYMBOLS: stacks pushed ;
     [ conjoin stacks get push-at ]
     if ;
 
+: (top-name) ( vreg -- vreg' )
+    stacks get at [ f ] [ last ] if-empty ;
+
 : top-name ( vreg -- vreg' )
-    stacks get at last ;
+    (top-name)
+    dup [ dup used-vregs get push-front ] when ;
 
 RENAMING: ssa-rename [ gen-name ] [ top-name ] [ ]
 
@@ -98,17 +108,22 @@ M: vreg-insn rename-insn
     [ ssa-rename-insn-defs ]
     bi ;
 
-M: ##phi rename-insn
+: rename-phis ( bb -- )
-    ssa-rename-insn-defs ;
+    inserting-phis get at [
+        [
+            [ ssa-rename-insn-defs ]
+            [ dup dst>> phis get set-at ] bi
+        ] each
+    ] when* ;
 
 : rename-insns ( bb -- )
     instructions>> [ rename-insn ] each ;
 
 : rename-successor-phi ( phi bb -- )
-    swap inputs>> [ top-name ] change-at ;
+    swap inputs>> [ (top-name) ] change-at ;
 
 : rename-successor-phis ( succ bb -- )
-    [ inserting-phi-nodes get at ] dip
+    [ inserting-phis get at ] dip
     '[ _ rename-successor-phi ] each ;
 
 : rename-successors-phis ( bb -- )
@@ -119,26 +134,56 @@ M: ##phi rename-insn
 
 : rename-in-block ( bb -- )
     H{ } clone pushed set
-    [ rename-insns ]
+    {
-    [ rename-successors-phis ]
+        [ rename-phis ]
-    [
+        [ rename-insns ]
-        pushed get
+        [ rename-successors-phis ]
-        [ dom-children [ rename-in-block ] each ] dip
+        [
-        pushed set
+            pushed get
-    ] tri
+            [ dom-children [ rename-in-block ] each ] dip
+            pushed set
+        ]
+    } cleave
     pop-stacks ;
 
 : rename ( cfg -- )
     init-renaming
     entry>> rename-in-block ;
 
+! Live phis
+SYMBOL: live-phis
+
+: live-phi? ( ##phi -- ? )
+    dst>> live-phis get key? ;
+
+: compute-live-phis ( -- )
+    H{ } clone live-phis set
+    used-vregs get [
+        phis get at [
+            [
+                dst>>
+                [ live-phis get conjoin ]
+                [ phis get delete-at ]
+                bi
+            ]
+            [ inputs>> [ nip used-vregs get push-front ] assoc-each ] bi
+        ] when*
+    ] slurp-deque ;
+
+: insert-phis-in ( phis bb -- )
+    [ [ live-phi? ] filter! ] dip
+    [ append ] change-instructions drop ;
+
+: insert-phis ( -- )
+    inserting-phis get
+    [ swap insert-phis-in ] assoc-each ;
+
 PRIVATE>
 
 : construct-ssa ( cfg -- cfg' )
     {
-        [ compute-live-sets ]
         [ compute-merge-sets ]
-        [ compute-defs compute-phi-nodes insert-phi-nodes ]
+        [ compute-defs compute-phis ]
-        [ rename ]
+        [ rename compute-live-phis insert-phis ]
         [ ]
     } cleave ;