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

   1 ! Copyright (C) 2009, 2010 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors assocs combinators compiler.cfg
   4 compiler.cfg.def-use compiler.cfg.dominance
   5 compiler.cfg.instructions compiler.cfg.registers
   6 compiler.cfg.renaming.functor compiler.cfg.rpo
   7 compiler.cfg.ssa.construction.tdmsc compiler.cfg.utilities deques dlists fry
   8 kernel math sequences sets ;
   9 FROM: namespaces => set get ;
  10 IN: compiler.cfg.ssa.construction
  11
  12 <PRIVATE
  13
  14 SYMBOL: defs
  15
  16 SYMBOL: defs-multi
  17
  18 GENERIC: compute-insn-defs ( bb insn -- )
  19
  20 M: insn compute-insn-defs 2drop ;
  21
  22 M: vreg-insn compute-insn-defs
  23     defs-vregs [
  24         defs get [ adjoin-at ] [ drop ] [ at cardinality 1 > ] 2tri
  25         [ defs-multi get adjoin ] [ drop ] if
  26     ] with each ;
  27
  28 : compute-defs ( cfg -- )
  29     H{ } clone defs set
  30     HS{ } clone defs-multi set
  31     [
  32         [ basic-block get ] dip
  33         [ compute-insn-defs ] with each
  34     ] simple-analysis ;
  35
  36 SYMBOL: inserting-phis
  37
  38 : <##phi> ( vreg bb -- ##phi )
  39     predecessors>> over '[ _ ] H{ } map>assoc ##phi new-insn ;
  40
  41 : insert-phi-later ( vreg bb -- )
  42     [ <##phi> ] keep inserting-phis get push-at ;
  43
  44 : compute-phis-for ( vreg bbs -- )
  45     members merge-set [ insert-phi-later ] with each ;
  46
  47 : compute-phis ( -- )
  48     H{ } clone inserting-phis set
  49     defs-multi get members
  50     defs get '[ dup _ at compute-phis-for ] each ;
  51
  52 SYMBOL: phis
  53
  54 SYMBOL: used-vregs
  55
  56 SYMBOLS: stacks pushed ;
  57
  58 : init-renaming ( -- )
  59     H{ } clone phis set
  60     <hashed-dlist>  used-vregs set
  61     H{ } clone stacks set ;
  62
  63 : gen-name ( vreg -- vreg' )
  64     [ next-vreg dup ] dip
  65     dup pushed get ?adjoin
  66     [ stacks get push-at ]
  67     [ stacks get at set-last ]
  68     if ;
  69
  70 : (top-name) ( vreg -- vreg' )
  71     stacks get at ?last ;
  72
  73 : top-name ( vreg -- vreg' )
  74     (top-name)
  75     dup [ dup used-vregs get push-front ] when ;
  76
  77 RENAMING: ssa-rename [ gen-name ] [ top-name ] [ ]
  78
  79 GENERIC: rename-insn ( insn -- )
  80
  81 M: insn rename-insn drop ;
  82
  83 M: vreg-insn rename-insn
  84     [ ssa-rename-insn-uses ]
  85     [ ssa-rename-insn-defs ]
  86     bi ;
  87
  88 : rename-phis ( bb -- )
  89     inserting-phis get at [
  90         [
  91             [ ssa-rename-insn-defs ]
  92             [ dup dst>> phis get set-at ] bi
  93         ] each
  94     ] when* ;
  95
  96 : rename-insns ( bb -- )
  97     instructions>> [ rename-insn ] each ;
  98
  99 : rename-successor-phi ( phi bb -- )
 100     swap inputs>> [ (top-name) ] change-at ;
 101
 102 : rename-successor-phis ( succ bb -- )
 103     [ inserting-phis get at ] dip
 104     '[ _ rename-successor-phi ] each ;
 105
 106 : rename-successors-phis ( bb -- )
 107     [ successors>> ] keep '[ _ rename-successor-phis ] each ;
 108
 109 : pop-stacks ( -- )
 110     pushed get members stacks get '[ _ at pop* ] each ;
 111
 112 : rename-in-block ( bb -- )
 113     HS{ } clone pushed set
 114     {
 115         [ rename-phis ]
 116         [ rename-insns ]
 117         [ rename-successors-phis ]
 118         [
 119             pushed get
 120             [ dom-children [ rename-in-block ] each ] dip
 121             pushed set
 122         ]
 123     } cleave
 124     pop-stacks ;
 125
 126 : rename ( cfg -- )
 127     init-renaming entry>> rename-in-block ;
 128
 129 ! Live phis
 130 SYMBOL: live-phis
 131
 132 : live-phi? ( ##phi -- ? )
 133     dst>> live-phis get in? ;
 134
 135 : compute-live-phis ( -- )
 136     HS{ } clone live-phis set
 137     used-vregs get [
 138         phis get at [
 139             [
 140                 dst>>
 141                 [ live-phis get adjoin ]
 142                 [ phis get delete-at ]
 143                 bi
 144             ]
 145             [ inputs>> [ nip used-vregs get push-front ] assoc-each ] bi
 146         ] when*
 147     ] slurp-deque ;
 148
 149 : insert-phis-in ( phis bb -- )
 150     [ [ live-phi? ] filter! ] dip
 151     [ append ] change-instructions drop ;
 152
 153 : insert-phis ( inserting-phis -- )
 154     [ swap insert-phis-in ] assoc-each ;
 155
 156 PRIVATE>
 157
 158 : construct-ssa ( cfg -- )
 159     [ compute-merge-sets ]
 160     [ compute-defs compute-phis ]
 161     [ rename compute-live-phis inserting-phis get insert-phis ] tri ;