Merge branch 'master' of git://factorcode.org/git/factor

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

@@ -0,0 +1,77 @@
+IN: compiler.cfg.dominance.tests
+USING: tools.test sequences vectors namespaces kernel accessors assocs sets
+math.ranges arrays compiler.cfg compiler.cfg.dominance compiler.cfg.debugger
+compiler.cfg.predecessors ;
+
+: test-dominance ( -- )
+    cfg new 0 get >>entry
+    compute-predecessors
+    compute-dominance
+    drop ;
+
+! Example with no back edges
+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-dominance ] unit-test
+
+[ t ] [ 0 get dom-parent 0 get eq? ] unit-test
+[ t ] [ 1 get dom-parent 0 get eq? ] unit-test
+[ t ] [ 2 get dom-parent 0 get eq? ] unit-test
+[ t ] [ 4 get dom-parent 0 get eq? ] unit-test
+[ t ] [ 3 get dom-parent 1 get eq? ] unit-test
+[ t ] [ 5 get dom-parent 4 get eq? ] unit-test
+
+[ 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
+
+! Example from the paper
+V{ } 0 test-bb
+V{ } 1 test-bb
+V{ } 2 test-bb
+V{ } 3 test-bb
+V{ } 4 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 3 get 1vector >>successors drop
+
+[ ] [ test-dominance ] unit-test
+
+[ t ] [ 0 4 [a,b] [ get dom-parent 0 get eq? ] all? ] unit-test
+
+! The other example from the paper
+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 5 get 1vector >>successors drop
+2 get 4 get 3 get V{ } 2sequence >>successors drop
+5 get 4 get 1vector >>successors drop
+4 get 5 get 3 get V{ } 2sequence >>successors drop
+3 get 4 get 1vector >>successors drop
+
+[ ] [ test-dominance ] unit-test
+
+[ t ] [ 0 5 [a,b] [ get dom-parent 0 get eq? ] all? ] unit-test

basis/compiler/cfg/dominance/dominance.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs combinators compiler.cfg.rpo
+USING: accessors assocs combinators sets math compiler.cfg.rpo
 compiler.cfg.stack-analysis fry kernel math.order namespaces
 sequences ;
 IN: compiler.cfg.dominance
@@ -11,31 +11,83 @@ IN: compiler.cfg.dominance
 ! Keith D. Cooper, Timothy J. Harvey, and Ken Kennedy
 ! http://www.cs.rice.edu/~keith/EMBED/dom.pdf
 
-SYMBOL: idoms
+! Also, a nice overview is given in these lecture notes:
-
+! http://llvm.cs.uiuc.edu/~vadve/CS526/public_html/Notes/4ssa.4up.pdf
-: idom ( bb -- bb' ) idoms get at ;
 
 <PRIVATE
 
-: set-idom ( idom bb -- changed? ) idoms get maybe-set-at ;
+! Maps bb -> idom(bb)
+SYMBOL: dom-parents
+
+PRIVATE>
+
+: dom-parent ( bb -- bb' ) dom-parents get at ;
+
+<PRIVATE
+
+: set-idom ( idom bb -- changed? )
+    dom-parents get maybe-set-at ;
 
 : intersect ( finger1 finger2 -- bb )
     2dup [ number>> ] compare {
-        { +lt+ [ [ idom ] dip intersect ] }
+        { +gt+ [ [ dom-parent ] dip intersect ] }
-        { +gt+ [ idom intersect ] }
+        { +lt+ [ dom-parent intersect ] }
         [ 2drop ]
     } case ;
 
 : compute-idom ( bb -- idom )
-    predecessors>> [ idom ] map sift
+    predecessors>> [ dom-parent ] filter
     [ ] [ intersect ] map-reduce ;
 
 : iterate ( rpo -- changed? )
     [ [ compute-idom ] keep set-idom ] map [ ] any? ;
 
+: compute-dom-parents ( cfg -- )
+    H{ } clone dom-parents set
+    reverse-post-order
+    unclip dup set-idom drop '[ _ iterate ] loop ;
+
+! Maps bb -> {bb' | idom(bb') = bb}
+SYMBOL: dom-childrens
+
 PRIVATE>
 
-: compute-dominance ( cfg -- cfg )
+: dom-children ( bb -- seq ) dom-childrens get at ;
-    H{ } clone idoms set
+
-    dup reverse-post-order
+<PRIVATE
-    unclip dup set-idom drop '[ _ iterate ] loop ;
+
+: compute-dom-children ( -- )
+    dom-parents get H{ } clone
+    [ '[ 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 ;
+
+<PRIVATE
+
+: compute-dom-frontier ( bb pred -- )
+    2dup [ dom-parent ] dip eq? [ 2drop ] [
+        [ dom-frontiers get conjoin-at ]
+        [ dom-parent compute-dom-frontier ] 2bi
+    ] if ;
+
+: 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>
+
+: compute-dominance ( cfg -- cfg' )
+    [ compute-dom-parents compute-dom-children ]
+    [ compute-dom-frontiers ]
+    [ ]
+    tri ;

basis/compiler/cfg/liveness/liveness.factor

@@ -43,9 +43,6 @@ SYMBOL: work-list
     [ nip kill-set ]
     2bi assoc-diff ;
 
-: conjoin-at ( value key assoc -- )
-    [ dupd ?set-at ] change-at ;
-
 : compute-phi-live-in ( basic-block -- phi-live-in )
     instructions>> [ ##phi? ] filter [ f ] [
         H{ } clone [

core/sets/sets-docs.factor

@@ -23,6 +23,7 @@ $nl
 "Adding elements to sets:"
 { $subsection adjoin }
 { $subsection conjoin }
+{ $subsection conjoin-at }
 { $see-also member? memq? any? all? "assocs-sets" } ;
 
 ABOUT: "sets"
@@ -54,6 +55,10 @@ HELP: conjoin
 }
 { $side-effects "assoc" } ;
 
+HELP: conjoin-at
+{ $values { "value" object } { "key" object } { "assoc" assoc } }
+{ $description "Adds " { $snippet "value" } " to the set stored at " { $snippet "key" } " of " { $snippet "assoc" } "." } ;
+
 HELP: unique
 { $values { "seq" "a sequence" } { "assoc" assoc } }
 { $description "Outputs a new assoc where the keys and values are equal." }

core/sets/sets.factor

@@ -7,6 +7,9 @@ IN: sets
 
 : conjoin ( elt assoc -- ) dupd set-at ;
 
+: conjoin-at ( value key assoc -- )
+    [ dupd ?set-at ] change-at ;
+
 : (prune) ( elt hash vec -- )
     3dup drop key? [ 3drop ] [
         [ drop conjoin ] [ nip push ] 3bi