basis/compiler/cfg/dominance/dominance.factor

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