compiler.cfg.coalescing: more or less complete, now needs debugging

basis/compiler/cfg/coalescing/coalescing.factor

@@ -1,8 +1,9 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors assocs fry kernel locals math math.order
-sequences
+sequences namespaces sets
 compiler.cfg.rpo
+compiler.cfg.def-use
 compiler.cfg.utilities
 compiler.cfg.dominance
 compiler.cfg.instructions
@@ -21,7 +22,24 @@ IN: compiler.cfg.coalescing
 : process-blocks ( cfg -- )
     [ [ process-block ] if-has-phis ] each-basic-block ;
 
-: break-interferences ( -- ) ;
+SYMBOL: seen
+
+:: visit-renaming ( dst assoc src bb -- )
+    src seen get key? [
+        src dst bb waiting-for push-at
+        src assoc delete-at
+    ] [ src seen get conjoin ] if ;
+
+:: break-interferences ( -- )
+    V{ } clone seen set
+    renaming-sets get [| dst assoc |
+        assoc [| src bb |
+            src seen get key?
+            [ dst assoc src bb visit-renaming ]
+            [ src seen get conjoin ]
+            if
+        ] assoc-each
+    ] assoc-each ;
 
 : remove-phis-from-block ( bb -- )
     instructions>> [ ##phi? not ] filter-here ;
@@ -31,9 +49,11 @@ IN: compiler.cfg.coalescing
 
 : coalesce ( cfg -- cfg' )
     init-coalescing
+    dup compute-def-use
+    dup compute-dominance
     dup compute-dfs
     dup process-blocks
     break-interferences
     dup insert-copies
-    perform-renaming
+    dup perform-renaming
     dup remove-phis ;

basis/compiler/cfg/coalescing/copies/copies.factor

@@ -1,39 +1,21 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs combinators fry kernel namespaces sequences
+USING: accessors assocs hashtables fry kernel make namespaces
-compiler.cfg.def-use compiler.cfg.dominance compiler.cfg.instructions
+sequences compiler.cfg.coalescing.state compiler.cfg.parallel-copy ;
-compiler.cfg.renaming ;
 IN: compiler.cfg.coalescing.copies
 
-SYMBOLS: stacks visited pushed ;
+: compute-copies ( assoc -- assoc' )
-
+    dup assoc-size <hashtable> [
-: compute-renaming ( insn -- assoc )
+        '[
-    uses-vregs stacks get
+            [ _ set-at ] with each
-    '[ dup dup _ at [ nip last ] unless-empty ]
+        ] assoc-each
-    H{ } map>assoc ;
+    ] keep ;
-
-: rename-operands ( bb -- )
-    instructions>> [
-        dup ##phi? [ drop ] [
-            dup compute-renaming renamings set
-            [ rename-insn-uses ] [ rename-insn-defs ] bi
-        ] if
-    ] each ;
-
-: schedule-copies ( bb -- )
-    ! FIXME
-    drop ;
-
-: pop-stacks ( -- )
-    pushed get stacks get '[ drop _ at pop* ] assoc-each ;
-
-: (insert-copies) ( bb -- )
-    H{ } clone pushed [
-        [ rename-operands ]
-        [ schedule-copies ]
-        [ dom-children [ (insert-copies) ] each ] tri
-        pop-stacks
-    ] with-variable ;
 
 : insert-copies ( cfg -- )
-    entry>> (insert-copies) ;
+    waiting get [
+        [ instructions>> building ] dip '[
+            building get pop
+            _ compute-copies parallel-copy
+            ,
+        ] with-variable
+    ] assoc-each ;

basis/compiler/cfg/coalescing/renaming/renaming.factor

@@ -1,10 +1,33 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel ;
+USING: accessors assocs fry kernel namespaces sequences
+compiler.cfg.coalescing.state compiler.cfg.renaming compiler.cfg.rpo
+disjoint-sets ;
 IN: compiler.cfg.coalescing.renaming
 
-: perform-renaming ( -- )
+: update-congruence-class ( dst assoc disjoint-set -- )
-    renaming-sets get [
+    [ keys swap ] dip
-        ! XXX
+    [ nip add-atoms ]
-        2drop
+    [ add-atom drop ]
-    ] assoc-each ;
+    [ equate-all-with ] 3tri ;
+        
+: build-congruence-classes ( -- disjoint-set )
+    renaming-sets get
+    <disjoint-set> [
+        '[
+            _ update-congruence-class
+        ] assoc-each
+    ] keep ;
+
+: compute-renaming ( disjoint-set -- assoc )
+    [ parents>> ] keep
+    '[ drop dup _ representative ] assoc-map ;
+
+: perform-renaming ( cfg -- )
+    build-congruence-classes compute-renaming renamings set
+    [
+        instructions>> [
+            [ rename-insn-defs ]
+            [ rename-insn-uses ] bi
+        ] each
+    ] each-basic-block ;

basis/compiler/cfg/dominance/dominance.factor

@@ -60,21 +60,26 @@ PRIVATE>
     [ '[ 2dup eq? [ 2drop ] [ _ push-at ] if ] assoc-each ] keep
     dom-childrens set ;
 
-! Maps bb -> DF(bb)
-SYMBOL: dom-frontiers
-
 PRIVATE>
 
-: dom-frontier ( bb -- set ) dom-frontiers get at keys ;
+: 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
     [
@@ -83,13 +88,6 @@ PRIVATE>
         ] [ 2drop ] if
     ] each-basic-block ;
 
-PRIVATE>
-
-: compute-dominance ( cfg -- )
-    [ compute-dom-parents compute-dom-children ]
-    [ compute-dom-frontiers ]
-    bi ;
-
 <PRIVATE
 
 SYMBOLS: work-list visited ;

basis/compiler/cfg/optimizer/optimizer.factor

@@ -11,7 +11,7 @@ compiler.cfg.value-numbering
 compiler.cfg.copy-prop
 compiler.cfg.dce
 compiler.cfg.write-barrier
-compiler.cfg.phi-elimination
+compiler.cfg.coalescing
 compiler.cfg.empty-blocks
 compiler.cfg.predecessors
 compiler.cfg.rpo
@@ -32,7 +32,7 @@ SYMBOL: check-optimizer?
         optimize-tail-calls
         delete-useless-conditionals
         compute-predecessors
-        split-branches
+        ! split-branches
         join-blocks
         compute-predecessors
         construct-ssa
@@ -42,7 +42,7 @@ SYMBOL: check-optimizer?
         copy-propagation
         eliminate-dead-code
         eliminate-write-barriers
-        eliminate-phis
+        coalesce
         delete-empty-blocks
         ?check
     ] with-scope ;

basis/compiler/cfg/ssa/ssa.factor

@@ -113,6 +113,7 @@ PRIVATE>
         [ ]
         [ compute-live-sets ]
         [ compute-dominance ]
+        [ compute-dom-frontiers ]
         [ compute-defs compute-phi-nodes insert-phi-nodes ]
         [ rename ]
     } cleave ;

basis/disjoint-sets/disjoint-sets.factor

@@ -35,6 +35,8 @@ TUPLE: disjoint-set
 : representative? ( a disjoint-set -- ? )
     dupd parent = ; inline
 
+PRIVATE>
+
 GENERIC: representative ( a disjoint-set -- p )
 
 M: disjoint-set representative
@@ -42,6 +44,8 @@ M: disjoint-set representative
         [ [ parent ] keep representative dup ] 2keep set-parent
     ] if ;
 
+<PRIVATE
+
 : representatives ( a b disjoint-set -- r r )
     [ representative ] curry bi@ ; inline