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-sets compiler.cfg
   4 compiler.cfg.dominance compiler.cfg.rpo compiler.cfg.utilities
   5 fry hashtables kernel locals math namespaces sequences sets ;
   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: merge-sets levels again? ;
  16
  17 : init-merge-sets ( cfg -- )
  18     post-order dup length '[ _ <bit-set> ] H{ } map>assoc
  19     merge-sets namespaces: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 namespaces: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 over '[
  35         _
  36         [ _ at union ]
  37         [ number>> over adjoin ]
  38         bi
  39     ] change-at ;
  40
  41 :: walk ( tmp to lnode -- lnode )
  42     tmp level to level >= [
  43         tmp to update-merge-set
  44         tmp dom-parent to tmp walk
  45     ] [ lnode ] if ;
  46
  47 : each-incoming-j-edge ( ... bb quot: ( ... from to -- ... ) -- ... )
  48     [ [ predecessors>> ] keep ] dip
  49     '[ _ 2dup j-edge? _ [ 2drop ] if ] each ; inline
  50
  51 : consistent? ( snode lnode -- ? )
  52     merge-sets get '[ _ at ] bi@ subset? ;
  53
  54 : (process-edge) ( from to visited -- )
  55     [ f walk ] dip '[
  56         2dup 2array _ in? [
  57             consistent? [ again? on ] unless
  58         ] [ 2drop ] if
  59     ] each-incoming-j-edge ;
  60
  61 : process-edge ( from to visited -- )
  62     [ 2over 2array swap ?adjoin ] keep
  63     '[ _ (process-edge) ] [ 2drop ] if ;
  64
  65 : process-block ( bb visited -- )
  66     '[ _ process-edge ] each-incoming-j-edge ;
  67
  68 : compute-merge-set-step ( bfo -- )
  69     HS{ } clone '[ _ process-block ] each ;
  70
  71 : compute-merge-set-loop ( cfg -- )
  72     breadth-first-order
  73     '[ again? off _ compute-merge-set-step again? get ]
  74     loop ;
  75
  76 : (merge-set) ( bbs -- flags rpo )
  77     merge-sets get '[ _ at ] [ union ] map-reduce
  78     cfg get reverse-post-order ; inline
  79
  80 PRIVATE>
  81
  82 : compute-merge-sets ( cfg -- )
  83     {
  84         needs-dominance
  85         compute-levels
  86         init-merge-sets
  87         compute-merge-set-loop
  88     } apply-passes ;
  89
  90 : merge-set ( bbs -- bbs' )
  91      (merge-set) [ members ] dip nths ;