basis/compiler/cfg/dominance/dominance.factor

   1 ! Copyright (C) 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors assocs combinators sets math fry kernel math.order
   4 dlists deques vectors namespaces sequences sorting locals
   5 compiler.cfg.rpo compiler.cfg.predecessors ;
   6 FROM: namespaces => set ;
   7 IN: compiler.cfg.dominance
   8
   9 ! Reference:
  10
  11 ! A Simple, Fast Dominance Algorithm
  12 ! Keith D. Cooper, Timothy J. Harvey, and Ken Kennedy
  13 ! http://www.cs.rice.edu/~keith/EMBED/dom.pdf
  14
  15 ! Also, a nice overview is given in these lecture notes:
  16 ! http://llvm.cs.uiuc.edu/~vadve/CS526/public_html/Notes/4ssa.4up.pdf
  17
  18 <PRIVATE
  19
  20 ! Maps bb -> idom(bb)
  21 SYMBOL: dom-parents
  22
  23 PRIVATE>
  24
  25 : dom-parent ( bb -- bb' ) dom-parents get at ;
  26
  27 <PRIVATE
  28
  29 : set-idom ( idom bb -- changed? )
  30     dom-parents get maybe-set-at ;
  31
  32 : intersect ( finger1 finger2 -- bb )
  33     2dup [ number>> ] compare {
  34         { +gt+ [ [ dom-parent ] dip intersect ] }
  35         { +lt+ [ dom-parent intersect ] }
  36         [ 2drop ]
  37     } case ;
  38
  39 : compute-idom ( bb -- idom )
  40     predecessors>> [ dom-parent ] filter
  41     [ ] [ intersect ] map-reduce ;
  42
  43 : iterate ( rpo -- changed? )
  44     [ [ compute-idom ] keep set-idom ] map [ ] any? ;
  45
  46 : compute-dom-parents ( cfg -- )
  47     H{ } clone dom-parents set
  48     reverse-post-order
  49     unclip dup set-idom drop '[ _ iterate ] loop ;
  50
  51 ! Maps bb -> {bb' | idom(bb') = bb}
  52 SYMBOL: dom-childrens
  53
  54 PRIVATE>
  55
  56 : dom-children ( bb -- seq ) dom-childrens get at ;
  57
  58 <PRIVATE
  59
  60 : compute-dom-children ( -- )
  61     dom-parents get H{ } clone
  62     [ '[ 2dup eq? [ 2drop ] [ _ push-at ] if ] assoc-each ] keep
  63     dom-childrens set ;
  64
  65 SYMBOLS: preorder maxpreorder ;
  66
  67 PRIVATE>
  68
  69 : pre-of ( bb -- n ) [ preorder get at ] [ -1/0. ] if* ;
  70
  71 : maxpre-of ( bb -- n ) [ maxpreorder get at ] [ 1/0. ] if* ;
  72
  73 <PRIVATE
  74
  75 : (compute-dfs) ( n bb -- n )
  76     [ 1 + ] dip
  77     [ dupd preorder get set-at ]
  78     [ dom-children [ (compute-dfs) ] each ]
  79     [ dupd maxpreorder get set-at ]
  80     tri ;
  81
  82 : compute-dfs ( cfg -- )
  83     H{ } clone preorder set
  84     H{ } clone maxpreorder set
  85     [ 0 ] dip entry>> (compute-dfs) drop ;
  86
  87 : compute-dominance ( cfg -- cfg' )
  88     [ compute-dom-parents compute-dom-children ] [ compute-dfs ] [ ] tri ;
  89
  90 PRIVATE>
  91
  92 : needs-dominance ( cfg -- cfg' )
  93     needs-predecessors
  94     dup dominance-valid?>> [ compute-dominance t >>dominance-valid? ] unless ;
  95
  96 : dominates? ( bb1 bb2 -- ? )
  97     swap [ pre-of ] [ [ pre-of ] [ maxpre-of ] bi ] bi* between? ;
  98
  99 :: breadth-first-order ( cfg -- bfo )
 100     <dlist> :> work-list
 101     cfg post-order length <vector> :> accum
 102     cfg entry>> work-list push-front
 103     work-list [
 104         [ accum push ]
 105         [ dom-children work-list push-all-front ] bi
 106     ] slurp-deque
 107     accum ;