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