compiler.cfg.ssa.construction: Use TDMSC algorithm to compute Phi placement

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

@@ -6,9 +6,7 @@ compiler.cfg.predecessors ;
 : test-dominance ( -- )
     cfg new 0 get >>entry
     compute-predecessors
-    dup compute-dominance
+    compute-dominance ;
-    dup compute-dom-frontiers
-    compute-dfs ;
 
 ! Example with no back edges
 V{ } 0 test-bb
@@ -35,11 +33,6 @@ V{ } 5 test-bb
 
 [ t ] [ 0 get dom-children 1 get 2 get 4 get 3array set= ] unit-test
 
-[ { 4 } ] [ 1 get dom-frontier [ number>> ] map ] unit-test
-[ { 4 } ] [ 2 get dom-frontier [ number>> ] map ] unit-test
-[ { } ] [ 0 get dom-frontier ] unit-test
-[ { } ] [ 4 get dom-frontier ] unit-test
-
 [ t ] [ 0 get 3 get dominates? ] unit-test
 [ f ] [ 3 get 4 get dominates? ] unit-test
 [ f ] [ 1 get 4 get dominates? ] unit-test
@@ -81,25 +74,3 @@ V{ } 5 test-bb
 [ ] [ test-dominance ] unit-test
 
 [ t ] [ 0 5 [a,b] [ get dom-parent 0 get eq? ] all? ] unit-test
-
-V{ } 0 test-bb
-V{ } 1 test-bb
-V{ } 2 test-bb
-V{ } 3 test-bb
-V{ } 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-dominance ] unit-test
-
-[ t ] [
-    2 get 3 get 2array iterated-dom-frontier
-    4 get 6 get 2array set=
-] unit-test

basis/compiler/cfg/dominance/dominance.factor

@@ -1,7 +1,8 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors assocs combinators sets math fry kernel math.order
-dlists deques namespaces sequences sorting compiler.cfg.rpo ;
+dlists deques vectors namespaces sequences sorting locals
+compiler.cfg.rpo ;
 IN: compiler.cfg.dominance
 
 ! Reference:
@@ -60,60 +61,6 @@ PRIVATE>
     [ '[ 2dup eq? [ 2drop ] [ _ push-at ] if ] assoc-each ] keep
     dom-childrens set ;
 
-PRIVATE>
-
-: compute-dominance ( cfg -- )
-    compute-dom-parents compute-dom-children ;
-
-<PRIVATE
-
-! Maps bb -> DF(bb)
-SYMBOL: dom-frontiers
-
-: compute-dom-frontier ( bb pred -- )
-    2dup [ dom-parent ] dip eq? [ 2drop ] [
-        [ dom-frontiers get conjoin-at ]
-        [ dom-parent compute-dom-frontier ] 2bi
-    ] if ;
-
-PRIVATE>
-
-: dom-frontier ( bb -- set ) dom-frontiers get at keys ;
-
-: compute-dom-frontiers ( cfg -- )
-    H{ } clone dom-frontiers set
-    [
-        dup predecessors>> dup length 2 >= [
-            [ compute-dom-frontier ] with each
-        ] [ 2drop ] if
-    ] each-basic-block ;
-
-<PRIVATE
-
-SYMBOLS: work-list visited ;
-
-: add-to-work-list ( bb -- )
-    dom-frontier work-list get push-all-front ;
-
-: iterated-dom-frontier-step ( bb -- )
-    dup visited get key? [ drop ] [
-        [ visited get conjoin ]
-        [ add-to-work-list ] bi
-    ] if ;
-
-PRIVATE>
-
-: iterated-dom-frontier ( bbs -- bbs' )
-    [
-        <dlist> work-list set
-        H{ } clone visited set
-        [ add-to-work-list ] each
-        work-list get [ iterated-dom-frontier-step ] slurp-deque
-        visited get keys
-    ] with-scope ;
-
-<PRIVATE
-
 SYMBOLS: preorder maxpreorder ;
 
 PRIVATE>
@@ -131,13 +78,25 @@ PRIVATE>
     [ dupd maxpreorder get set-at ]
     tri ;
 
-PRIVATE>
-
 : compute-dfs ( cfg -- )
     H{ } clone preorder set
     H{ } clone maxpreorder set
     [ 0 ] dip entry>> (compute-dfs) drop ;
 
+PRIVATE>
+
+: compute-dominance ( cfg -- )
+    [ compute-dom-parents compute-dom-children ] [ compute-dfs ] bi ;
+
 : dominates? ( bb1 bb2 -- ? )
-    ! Requires DFS to be computed
+    swap [ pre-of ] [ [ pre-of ] [ maxpre-of ] bi ] bi* between? ;
-    swap [ pre-of ] [ [ pre-of ] [ maxpre-of ] bi ] bi* between? ;
+
+:: breadth-first-order ( cfg -- bfo )
+    <dlist> :> work-list
+    cfg post-order length <vector> :> accum
+    cfg entry>> work-list push-front
+    work-list [
+        [ accum push ]
+        [ dom-children work-list push-all-front ] bi
+    ] slurp-deque
+    accum ;

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

@@ -9,7 +9,8 @@ compiler.cfg.renaming
 compiler.cfg.liveness
 compiler.cfg.registers
 compiler.cfg.dominance
-compiler.cfg.instructions ;
+compiler.cfg.instructions
+compiler.cfg.ssa.construction.tdmsc ;
 IN: compiler.cfg.ssa.construction
 
 ! SSA construction. Predecessors must be computed first.
@@ -34,9 +35,9 @@ SYMBOL: inserting-phi-nodes
 
 : compute-phi-nodes-for ( vreg bbs -- )
     dup length 2 >= [
-        iterated-dom-frontier [
+        [
             insert-phi-node-later
-        ] with each
+        ] with merge-set-each
     ] [ 2drop ] if ;
 
 : compute-phi-nodes ( -- )
@@ -113,7 +114,7 @@ PRIVATE>
         [ ]
         [ compute-live-sets ]
         [ compute-dominance ]
-        [ compute-dom-frontiers ]
+        [ compute-merge-sets ]
         [ compute-defs compute-phi-nodes insert-phi-nodes ]
         [ rename ]
     } cleave ;

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

@@ -0,0 +1,75 @@
+USING: accessors arrays compiler.cfg compiler.cfg.debugger
+compiler.cfg.dominance compiler.cfg.predecessors
+compiler.cfg.ssa.construction.tdmsc kernel namespaces sequences
+tools.test vectors sets ;
+IN: compiler.cfg.ssa.construction.tdmsc.tests
+
+: test-tdmsc ( -- )
+    cfg new 0 get >>entry
+    compute-predecessors
+    dup compute-dominance
+    compute-merge-sets ;
+
+V{ } 0 test-bb
+V{ } 1 test-bb
+V{ } 2 test-bb
+V{ } 3 test-bb
+V{ } 4 test-bb
+V{ } 5 test-bb
+
+0 get 1 get 2 get V{ } 2sequence >>successors drop
+1 get 3 get 1vector >>successors drop
+2 get 4 get 1vector >>successors drop
+3 get 4 get 1vector >>successors drop
+4 get 5 get 1vector >>successors drop
+
+[ ] [ test-tdmsc ] unit-test
+
+[ V{ 4 } ] [ 1 get 1array merge-set [ number>> ] map ] unit-test
+[ V{ 4 } ] [ 2 get 1array merge-set [ number>> ] map ] unit-test
+[ V{ } ] [ 0 get 1array merge-set ] unit-test
+[ V{ } ] [ 4 get 1array merge-set ] unit-test
+
+V{ } 0 test-bb
+V{ } 1 test-bb
+V{ } 2 test-bb
+V{ } 3 test-bb
+V{ } 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-tdmsc ] unit-test
+
+[ t ] [
+    2 get 3 get 2array merge-set
+    4 get 6 get 2array set=
+] unit-test
+
+V{ } 0 test-bb
+V{ } 1 test-bb
+V{ } 2 test-bb
+V{ } 3 test-bb
+V{ } 4 test-bb
+V{ } 5 test-bb
+V{ } 6 test-bb
+V{ } 7 test-bb
+
+0 get 1 get 1vector >>successors drop
+1 get 2 get 1vector >>successors drop
+2 get 3 get 6 get V{ } 2sequence >>successors drop
+3 get 4 get 1vector >>successors drop
+6 get 7 get 1vector >>successors drop
+4 get 5 get 1vector >>successors drop
+5 get 2 get 1vector >>successors drop
+
+[ ] [ test-tdmsc ] unit-test
+
+[ V{ 2 } ] [ { 2 3 4 5 } [ get ] map merge-set [ number>> ] map ] unit-test
+[ V{ } ] [ { 0 1 6 7 } [ get ] map merge-set ] unit-test

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

@@ -0,0 +1,109 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs bit-arrays bit-sets fry
+hashtables hints kernel locals math namespaces sequences sets
+compiler.cfg compiler.cfg.dominance compiler.cfg.rpo ;
+IN: compiler.cfg.ssa.construction.tdmsc
+
+! TDMSC-I algorithm from "A Practical and Fast Iterative Algorithm for
+! Phi-Function Computation Using DJ Graphs"
+
+! http://portal.acm.org/citation.cfm?id=1065887.1065890
+
+<PRIVATE
+
+SYMBOLS: visited merge-sets levels again? ;
+
+: init-merge-sets ( cfg -- )
+    post-order dup length '[ _ <bit-array> ] H{ } map>assoc merge-sets set ;
+
+: compute-levels ( cfg -- )
+    0 over entry>> associate [
+        '[
+            _ [ [ dom-parent ] dip at 1 + ] 2keep set-at
+        ] each-basic-block
+    ] keep levels set ;
+
+: j-edge? ( from to -- ? )
+    2dup eq? [ 2drop f ] [ dominates? not ] if ;
+
+: level ( bb -- n ) levels get at ; inline
+
+: set-bit ( bit-array n -- )
+    [ t ] 2dip swap set-nth ;
+
+: update-merge-set ( tmp to -- )
+    [ merge-sets get ] dip
+    '[
+        _
+        [ merge-sets get at bit-set-union ]
+        [ dupd number>> set-bit ]
+        bi
+    ] change-at ;
+
+:: walk ( tmp to lnode -- lnode )
+    tmp level to level >= [
+        tmp to update-merge-set
+        tmp dom-parent to tmp walk
+    ] [ lnode ] if ;
+
+: each-incoming-j-edge ( bb quot: ( from to -- ) -- )
+    [ [ predecessors>> ] keep ] dip
+    '[ _ 2dup j-edge? _ [ 2drop ] if ] each ; inline
+
+: visited? ( pair -- ? ) visited get key? ;
+
+: consistent? ( snode lnode -- ? )
+    [ merge-sets get at ] bi@ swap bit-set-subset? ;
+
+: (process-edge) ( from to -- )
+    f walk [
+        2dup 2array visited? [
+            consistent? [ again? on ] unless
+        ] [ 2drop ] if
+    ] each-incoming-j-edge ;
+
+: process-edge ( from to -- )
+    2dup 2array dup visited? [ 3drop ] [
+        visited get conjoin
+        (process-edge)
+    ] if ;
+
+: process-block ( bb -- )
+    [ process-edge ] each-incoming-j-edge ;
+
+: compute-merge-set-step ( bfo -- )
+    visited get clear-assoc
+    [ process-block ] each ;
+
+: compute-merge-set-loop ( cfg -- )
+    breadth-first-order
+    '[ again? off _ compute-merge-set-step again? get ]
+    loop ;
+
+: (merge-set) ( bbs -- flags rpo )
+    merge-sets get '[ _ at ] [ bit-set-union ] map-reduce
+    cfg get reverse-post-order ; inline
+
+: filter-by ( flags seq -- seq' )
+    [ drop ] pusher [ 2each ] dip ;
+
+HINTS: filter-by { bit-array object } ;
+
+PRIVATE>
+
+: compute-merge-sets ( cfg -- )
+    dup cfg set
+    H{ } clone visited set
+    [ compute-levels ]
+    [ init-merge-sets ]
+    [ compute-merge-set-loop ]
+    tri ;
+
+: merge-set-each ( bbs quot: ( bb -- ) -- )
+    [ (merge-set) ] dip '[
+        swap _ [ drop ] if
+    ] 2each ; inline
+
+: merge-set ( bbs -- bbs' )
+     (merge-set) filter-by ;

basis/compiler/cfg/ssa/destruction/destruction.factor

@@ -54,7 +54,6 @@ SYMBOL: seen
         dup split-critical-edges
         dup compute-def-use
         dup compute-dominance
-        dup compute-dfs
         dup compute-live-ranges
         dup process-blocks
         break-interferences

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

@@ -31,8 +31,7 @@ V{ T{ ##peek f V int-regs 6 D 0 } } clone 6 test-bb
     cfg new 0 get >>entry
     compute-predecessors
     dup compute-dominance
-    dup compute-def-use
+    compute-def-use
-    compute-dfs
     compute-dom-forest
     clean-up-forest ;
 

basis/compiler/cfg/ssa/destruction/forest/forest.factor

@@ -3,7 +3,7 @@
 USING: accessors assocs fry kernel math math.order
 namespaces sequences sorting vectors compiler.cfg.def-use
 compiler.cfg.dominance compiler.cfg.registers ;
-IN: compiler.cfg.coalescing.forest
+IN: compiler.cfg.ssa.destruction.forest
 
 TUPLE: dom-forest-node vreg bb children ;
 
@@ -31,7 +31,6 @@ TUPLE: dom-forest-node vreg bb children ;
 PRIVATE>
 
 : compute-dom-forest ( vregs -- forest )
-    ! compute-dfs must be called on the CFG first
     <virtual-root> [
         1vector
         [ sort-vregs-by-bb ] dip