compiler.cfg.ssa.construction: Use TDMSC algorithm to compute Phi placement
Slava Pestov
parent
5fe3bcff4d
commit
62fe308776
|
|
@ -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
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -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
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue