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