basis/compiler/cfg/ssa/construction/tdmsc/tdmsc.factor

   1 ! 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
   7
   8 ! TDMSC-I algorithm from "A Practical and Fast Iterative Algorithm for
   9 ! Phi-Function Computation Using DJ Graphs"
  10
  11 ! http://portal.acm.org/citation.cfm?id=1065887.1065890
  12
  13 <PRIVATE
  14
  15 SYMBOLS: visited merge-sets levels again? ;
  16
  17 : init-merge-sets ( cfg -- )
  18     post-order dup length '[ _ <bit-array> ] H{ } map>assoc merge-sets set ;
  19
  20 : compute-levels ( cfg -- )
  21     0 over entry>> associate [
  22         '[
  23             _ [ [ dom-parent ] dip at 1 + ] 2keep set-at
  24         ] each-basic-block
  25     ] keep levels set ;
  26
  27 : j-edge? ( from to -- ? )
  28     2dup eq? [ 2drop f ] [ dominates? not ] if ;
  29
  30 : level ( bb -- n ) levels get at ; inline
  31
  32 : set-bit ( bit-array n -- )
  33     [ t ] 2dip swap set-nth ;
  34
  35 : update-merge-set ( tmp to -- )
  36     [ merge-sets get ] dip
  37     '[
  38         _
  39         [ merge-sets get at bit-set-union ]
  40         [ dupd number>> set-bit ]
  41         bi
  42     ] change-at ;
  43
  44 :: walk ( tmp to lnode -- lnode )
  45     tmp level to level >= [
  46         tmp to update-merge-set
  47         tmp dom-parent to tmp walk
  48     ] [ lnode ] if ;
  49
  50 : each-incoming-j-edge ( bb quot: ( from to -- ) -- )
  51     [ [ predecessors>> ] keep ] dip
  52     '[ _ 2dup j-edge? _ [ 2drop ] if ] each ; inline
  53
  54 : visited? ( pair -- ? ) visited get key? ;
  55
  56 : consistent? ( snode lnode -- ? )
  57     [ merge-sets get at ] bi@ swap bit-set-subset? ;
  58
  59 : (process-edge) ( from to -- )
  60     f walk [
  61         2dup 2array visited? [
  62             consistent? [ again? on ] unless
  63         ] [ 2drop ] if
  64     ] each-incoming-j-edge ;
  65
  66 : process-edge ( from to -- )
  67     2dup 2array dup visited? [ 3drop ] [
  68         visited get conjoin
  69         (process-edge)
  70     ] if ;
  71
  72 : process-block ( bb -- )
  73     [ process-edge ] each-incoming-j-edge ;
  74
  75 : compute-merge-set-step ( bfo -- )
  76     visited get clear-assoc
  77     [ process-block ] each ;
  78
  79 : compute-merge-set-loop ( cfg -- )
  80     breadth-first-order
  81     '[ again? off _ compute-merge-set-step again? get ]
  82     loop ;
  83
  84 : (merge-set) ( bbs -- flags rpo )
  85     merge-sets get '[ _ at ] [ bit-set-union ] map-reduce
  86     cfg get reverse-post-order ; inline
  87
  88 : filter-by ( flags seq -- seq' )
  89     [ drop ] pusher [ 2each ] dip ;
  90
  91 HINTS: filter-by { bit-array object } ;
  92
  93 PRIVATE>
  94
  95 : compute-merge-sets ( cfg -- )
  96     needs-dominance
  97
  98     H{ } clone visited set
  99     [ compute-levels ]
 100     [ init-merge-sets ]
 101     [ compute-merge-set-loop ]
 102     tri ;
 103
 104 : merge-set-each ( bbs quot: ( bb -- ) -- )
 105     [ (merge-set) ] dip '[
 106         swap _ [ drop ] if
 107     ] 2each ; inline
 108
 109 : merge-set ( bbs -- bbs' )
 110      (merge-set) filter-by ;