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 namespaces sequences sorting compiler.cfg.rpo ;
   5 IN: compiler.cfg.dominance
   6
   7 ! Reference:
   8
   9 ! A Simple, Fast Dominance Algorithm
  10 ! Keith D. Cooper, Timothy J. Harvey, and Ken Kennedy
  11 ! http://www.cs.rice.edu/~keith/EMBED/dom.pdf
  12
  13 ! Also, a nice overview is given in these lecture notes:
  14 ! http://llvm.cs.uiuc.edu/~vadve/CS526/public_html/Notes/4ssa.4up.pdf
  15
  16 <PRIVATE
  17
  18 ! Maps bb -> idom(bb)
  19 SYMBOL: dom-parents
  20
  21 PRIVATE>
  22
  23 : dom-parent ( bb -- bb' ) dom-parents get at ;
  24
  25 <PRIVATE
  26
  27 : set-idom ( idom bb -- changed? )
  28     dom-parents get maybe-set-at ;
  29
  30 : intersect ( finger1 finger2 -- bb )
  31     2dup [ number>> ] compare {
  32         { +gt+ [ [ dom-parent ] dip intersect ] }
  33         { +lt+ [ dom-parent intersect ] }
  34         [ 2drop ]
  35     } case ;
  36
  37 : compute-idom ( bb -- idom )
  38     predecessors>> [ dom-parent ] filter
  39     [ ] [ intersect ] map-reduce ;
  40
  41 : iterate ( rpo -- changed? )
  42     [ [ compute-idom ] keep set-idom ] map [ ] any? ;
  43
  44 : compute-dom-parents ( cfg -- )
  45     H{ } clone dom-parents set
  46     reverse-post-order
  47     unclip dup set-idom drop '[ _ iterate ] loop ;
  48
  49 ! Maps bb -> {bb' | idom(bb') = bb}
  50 SYMBOL: dom-childrens
  51
  52 PRIVATE>
  53
  54 : dom-children ( bb -- seq ) dom-childrens get at ;
  55
  56 <PRIVATE
  57
  58 : compute-dom-children ( -- )
  59     dom-parents get H{ } clone
  60     [ '[ 2dup eq? [ 2drop ] [ _ push-at ] if ] assoc-each ] keep
  61     dom-childrens set ;
  62
  63 ! Maps bb -> DF(bb)
  64 SYMBOL: dom-frontiers
  65
  66 PRIVATE>
  67
  68 : dom-frontier ( bb -- set ) dom-frontiers get at keys ;
  69
  70 <PRIVATE
  71
  72 : compute-dom-frontier ( bb pred -- )
  73     2dup [ dom-parent ] dip eq? [ 2drop ] [
  74         [ dom-frontiers get conjoin-at ]
  75         [ dom-parent compute-dom-frontier ] 2bi
  76     ] if ;
  77
  78 : compute-dom-frontiers ( cfg -- )
  79     H{ } clone dom-frontiers set
  80     [
  81         dup predecessors>> dup length 2 >= [
  82             [ compute-dom-frontier ] with each
  83         ] [ 2drop ] if
  84     ] each-basic-block ;
  85
  86 PRIVATE>
  87
  88 : compute-dominance ( cfg -- )
  89     [ compute-dom-parents compute-dom-children ]
  90     [ compute-dom-frontiers ]
  91     bi ;
  92
  93 <PRIVATE
  94
  95 SYMBOLS: work-list visited ;
  96
  97 : add-to-work-list ( bb -- )
  98     dom-frontier work-list get push-all-front ;
  99
 100 : iterated-dom-frontier-step ( bb -- )
 101     dup visited get key? [ drop ] [
 102         [ visited get conjoin ]
 103         [ add-to-work-list ] bi
 104     ] if ;
 105
 106 PRIVATE>
 107
 108 : iterated-dom-frontier ( bbs -- bbs' )
 109     [
 110         <dlist> work-list set
 111         H{ } clone visited set
 112         [ add-to-work-list ] each
 113         work-list get [ iterated-dom-frontier-step ] slurp-deque
 114         visited get keys
 115     ] with-scope ;