From 62fe3087769f299d4b17f475551345c978f40dc8 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 28 Jul 2009 11:16:10 -0500
Subject: [PATCH] compiler.cfg.ssa.construction: Use TDMSC algorithm to compute
Phi placement
---
.../cfg/dominance/dominance-tests.factor | 31 +----
basis/compiler/cfg/dominance/dominance.factor | 77 +++----------
.../cfg/ssa/construction/construction.factor | 9 +-
.../ssa/construction/tdmsc/tdmsc-tests.factor | 75 ++++++++++++
.../cfg/ssa/construction/tdmsc/tdmsc.factor | 109 ++++++++++++++++++
.../cfg/ssa/destruction/destruction.factor | 1 -
.../destruction/forest/forest-tests.factor | 3 +-
.../cfg/ssa/destruction/forest/forest.factor | 3 +-
8 files changed, 210 insertions(+), 98 deletions(-)
create mode 100644 basis/compiler/cfg/ssa/construction/tdmsc/tdmsc-tests.factor
create mode 100644 basis/compiler/cfg/ssa/construction/tdmsc/tdmsc.factor
diff --git a/basis/compiler/cfg/dominance/dominance-tests.factor b/basis/compiler/cfg/dominance/dominance-tests.factor
index 3da98a5e87..07bcd7bc84 100644
--- a/basis/compiler/cfg/dominance/dominance-tests.factor
+++ b/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
- dup compute-dom-frontiers
- compute-dfs ;
+ compute-dominance ;
! 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
\ No newline at end of file
diff --git a/basis/compiler/cfg/dominance/dominance.factor b/basis/compiler/cfg/dominance/dominance.factor
index ebd3a981d7..325bed74ff 100644
--- a/basis/compiler/cfg/dominance/dominance.factor
+++ b/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? ;
\ No newline at end of file
+ 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 ;
\ No newline at end of file
diff --git a/basis/compiler/cfg/ssa/construction/construction.factor b/basis/compiler/cfg/ssa/construction/construction.factor
index 23bed8bce0..3f131f4782 100644
--- a/basis/compiler/cfg/ssa/construction/construction.factor
+++ b/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 ;
\ No newline at end of file
diff --git a/basis/compiler/cfg/ssa/construction/tdmsc/tdmsc-tests.factor b/basis/compiler/cfg/ssa/construction/tdmsc/tdmsc-tests.factor
new file mode 100644
index 0000000000..7691d0e6ce
--- /dev/null
+++ b/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
\ No newline at end of file
diff --git a/basis/compiler/cfg/ssa/construction/tdmsc/tdmsc.factor b/basis/compiler/cfg/ssa/construction/tdmsc/tdmsc.factor
new file mode 100644
index 0000000000..1c1abefe1b
--- /dev/null
+++ b/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 ;
\ No newline at end of file
diff --git a/basis/compiler/cfg/ssa/destruction/destruction.factor b/basis/compiler/cfg/ssa/destruction/destruction.factor
index 2d0cd26798..00f461d6f2 100644
--- a/basis/compiler/cfg/ssa/destruction/destruction.factor
+++ b/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
diff --git a/basis/compiler/cfg/ssa/destruction/forest/forest-tests.factor b/basis/compiler/cfg/ssa/destruction/forest/forest-tests.factor
index a74947e5df..64c04b79f2 100644
--- a/basis/compiler/cfg/ssa/destruction/forest/forest-tests.factor
+++ b/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-dfs
+ compute-def-use
compute-dom-forest
clean-up-forest ;
diff --git a/basis/compiler/cfg/ssa/destruction/forest/forest.factor b/basis/compiler/cfg/ssa/destruction/forest/forest.factor
index fa0aa6e6d3..8226e2787b 100644
--- a/basis/compiler/cfg/ssa/destruction/forest/forest.factor
+++ b/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