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 compiler.cfg.predecessors
   4 compiler.cfg.rpo deques dlists fry kernel locals math math.order
   5 namespaces sequences sorting vectors ;
   6 FROM: namespaces => set ;
   7 IN: compiler.cfg.dominance
   8
   9 <PRIVATE
  10
  11 SYMBOL: dom-parents
  12
  13 PRIVATE>
  14
  15 : dom-parent ( bb -- bb' ) dom-parents get at ;
  16
  17 <PRIVATE
  18
  19 : set-idom ( idom bb -- changed? )
  20     dom-parents get maybe-set-at ;
  21
  22 : intersect ( finger1 finger2 -- bb )
  23     2dup [ number>> ] compare {
  24         { +gt+ [ [ dom-parent ] dip intersect ] }
  25         { +lt+ [ dom-parent intersect ] }
  26         [ 2drop ]
  27     } case ;
  28
  29 : compute-idom ( bb -- idom )
  30     predecessors>> [ dom-parent ] filter
  31     [ ] [ intersect ] map-reduce ;
  32
  33 : iterate ( rpo -- changed? )
  34     f [ [ compute-idom ] keep set-idom or ] reduce ;
  35
  36 : compute-dom-parents ( cfg -- )
  37     H{ } clone dom-parents set
  38     reverse-post-order
  39     unclip dup set-idom drop '[ _ iterate ] loop ;
  40
  41 SYMBOL: dom-childrens
  42
  43 PRIVATE>
  44
  45 : dom-children ( bb -- seq ) dom-childrens get at ;
  46
  47 <PRIVATE
  48
  49 : compute-dom-children ( dom-parents -- dom-childrens )
  50     H{ } clone [ '[ 2dup eq? [ 2drop ] [ _ push-at ] if ] assoc-each ] keep
  51     [ [ number>> ] sort-with ] assoc-map ;
  52
  53 SYMBOLS: preorder maxpreorder ;
  54
  55 PRIVATE>
  56
  57 : pre-of ( bb -- n ) [ preorder get at ] [ -1/0. ] if* ;
  58
  59 : maxpre-of ( bb -- n ) [ maxpreorder get at ] [ 1/0. ] if* ;
  60
  61 <PRIVATE
  62
  63 : (compute-dfs) ( n bb -- n )
  64     [ 1 + ] dip
  65     [ dupd preorder get set-at ]
  66     [ dom-children [ (compute-dfs) ] each ]
  67     [ dupd maxpreorder get set-at ]
  68     tri ;
  69
  70 : compute-dfs ( cfg -- )
  71     H{ } clone preorder set
  72     H{ } clone maxpreorder set
  73     [ 0 ] dip entry>> (compute-dfs) drop ;
  74
  75 : compute-dominance ( cfg -- )
  76     [
  77         compute-dom-parents
  78         dom-parents get compute-dom-children dom-childrens set
  79     ] [ compute-dfs ] bi ;
  80
  81 PRIVATE>
  82
  83 : needs-dominance ( cfg -- )
  84     [ needs-predecessors ]
  85     [
  86         dup dominance-valid?>> [ drop ]
  87         [ t >>dominance-valid? compute-dominance ] if
  88     ] bi ;
  89
  90 : dominates? ( bb1 bb2 -- ? )
  91     swap [ pre-of ] [ [ pre-of ] [ maxpre-of ] bi ] bi* between? ;
  92
  93 :: breadth-first-order ( cfg -- bfo )
  94     <dlist> :> work-list
  95     cfg post-order length <vector> :> accum
  96     cfg entry>> work-list push-front
  97     work-list [
  98         [ accum push ]
  99         [ dom-children work-list push-all-front ] bi
 100     ] slurp-deque
 101     accum ;