1 !r Copyright (C) 2009 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays assocs bit-arrays bit-sets fry
4 hashtables hints kernel locals math namespaces sequences sets
5 compiler.cfg compiler.cfg.dominance compiler.cfg.rpo ;
6 IN: compiler.cfg.ssa.construction.tdmsc
8 ! TDMSC-I algorithm from "A Practical and Fast Iterative Algorithm for
9 ! Phi-Function Computation Using DJ Graphs"
11 ! http://portal.acm.org/citation.cfm?id=1065887.1065890
15 SYMBOLS: visited merge-sets levels again? ;
17 : init-merge-sets ( cfg -- )
18 post-order dup length '[ _ <bit-array> ] H{ } map>assoc merge-sets set ;
20 : compute-levels ( cfg -- )
21 0 over entry>> associate [
23 _ [ [ dom-parent ] dip at 1 + ] 2keep set-at
27 : j-edge? ( from to -- ? )
28 2dup eq? [ 2drop f ] [ dominates? not ] if ;
30 : level ( bb -- n ) levels get at ; inline
32 : set-bit ( bit-array n -- )
33 [ t ] 2dip swap set-nth ;
35 : update-merge-set ( tmp to -- )
36 [ merge-sets get ] dip
39 [ merge-sets get at bit-set-union ]
40 [ dupd number>> set-bit ]
44 :: walk ( tmp to lnode -- lnode )
45 tmp level to level >= [
46 tmp to update-merge-set
47 tmp dom-parent to tmp walk
50 : each-incoming-j-edge ( bb quot: ( from to -- ) -- )
51 [ [ predecessors>> ] keep ] dip
52 '[ _ 2dup j-edge? _ [ 2drop ] if ] each ; inline
54 : visited? ( pair -- ? ) visited get key? ;
56 : consistent? ( snode lnode -- ? )
57 [ merge-sets get at ] bi@ swap bit-set-subset? ;
59 : (process-edge) ( from to -- )
61 2dup 2array visited? [
62 consistent? [ again? on ] unless
64 ] each-incoming-j-edge ;
66 : process-edge ( from to -- )
67 2dup 2array dup visited? [ 3drop ] [
72 : process-block ( bb -- )
73 [ process-edge ] each-incoming-j-edge ;
75 : compute-merge-set-step ( bfo -- )
76 visited get clear-assoc
77 [ process-block ] each ;
79 : compute-merge-set-loop ( cfg -- )
81 '[ again? off _ compute-merge-set-step again? get ]
84 : (merge-set) ( bbs -- flags rpo )
85 merge-sets get '[ _ at ] [ bit-set-union ] map-reduce
86 cfg get reverse-post-order ; inline
88 : filter-by ( flags seq -- seq' )
89 [ drop ] selector [ 2each ] dip ;
91 HINTS: filter-by { bit-array object } ;
95 : compute-merge-sets ( cfg -- )
98 H{ } clone visited set
101 [ compute-merge-set-loop ]
104 : merge-set-each ( bbs quot: ( bb -- ) -- )
105 [ (merge-set) ] dip '[
109 : merge-set ( bbs -- bbs' )
110 (merge-set) filter-by ;