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: namespaces kernel accessors sequences fry assocs
   4 sets math combinators deques dlists
   5 compiler.cfg
   6 compiler.cfg.rpo
   7 compiler.cfg.def-use
   8 compiler.cfg.registers
   9 compiler.cfg.dominance
  10 compiler.cfg.instructions
  11 compiler.cfg.renaming
  12 compiler.cfg.renaming.functor
  13 compiler.cfg.ssa.construction.tdmsc ;
  14 FROM: assocs => change-at ;
  15 FROM: namespaces => set ;
  16 IN: compiler.cfg.ssa.construction
  17
  18 ! Iterated dominance frontiers are computed using the DJ Graph
  19 ! method in compiler.cfg.ssa.construction.tdmsc.
  20
  21 ! The renaming algorithm is based on "Practical Improvements to
  22 ! the Construction and Destruction of Static Single Assignment
  23 ! Form".
  24
  25 ! We construct pruned SSA without computing live sets, by
  26 ! building a dependency graph for phi instructions, marking the
  27 ! transitive closure of a vertex as live if it is referenced by
  28 ! some non-phi instruction. Thanks to Cameron Zwarich for the
  29 ! trick.
  30
  31 ! http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.49.9683
  32
  33 <PRIVATE
  34
  35 ! Maps vregs to sets of basic blocks
  36 SYMBOL: defs
  37
  38 ! Set of vregs defined in more than one basic block
  39 SYMBOL: defs-multi
  40
  41 GENERIC: compute-insn-defs ( bb insn -- )
  42
  43 M: insn compute-insn-defs 2drop ;
  44
  45 M: vreg-insn compute-insn-defs
  46     defs-vregs [
  47         defs get [ conjoin-at ] [ drop ] [ at assoc-size 1 > ] 2tri
  48         [ defs-multi get conjoin ] [ drop ] if
  49     ] with each ;
  50
  51 : compute-defs ( cfg -- )
  52     H{ } clone defs set
  53     H{ } clone defs-multi set
  54     [
  55         [ basic-block get ] dip
  56         [ compute-insn-defs ] with each
  57     ] simple-analysis ;
  58
  59 ! Maps basic blocks to sequences of ##phi instructions
  60 SYMBOL: inserting-phis
  61
  62 : insert-phi-later ( vreg bb -- )
  63     [ predecessors>> over '[ _ ] H{ } map>assoc \ ##phi new-insn ] keep
  64     inserting-phis get push-at ;
  65
  66 : compute-phis-for ( vreg bbs -- )
  67     keys merge-set [ insert-phi-later ] with each ;
  68
  69 : compute-phis ( -- )
  70     H{ } clone inserting-phis set
  71     defs-multi get defs get '[ _ at compute-phis-for ] assoc-each ;
  72
  73 ! Maps vregs to ##phi instructions
  74 SYMBOL: phis
  75
  76 ! Worklist of used vregs, to calculate used phis
  77 SYMBOL: used-vregs
  78
  79 ! Maps vregs to renaming stacks
  80 SYMBOLS: stacks pushed ;
  81
  82 : init-renaming ( -- )
  83     H{ } clone phis set
  84     <hashed-dlist>  used-vregs set
  85     H{ } clone stacks set ;
  86
  87 : gen-name ( vreg -- vreg' )
  88     [ next-vreg dup ] dip
  89     dup pushed get 2dup key?
  90     [ 2drop stacks get at set-last ]
  91     [ conjoin stacks get push-at ]
  92     if ;
  93
  94 : (top-name) ( vreg -- vreg' )
  95     stacks get at [ f ] [ last ] if-empty ;
  96
  97 : top-name ( vreg -- vreg' )
  98     (top-name)
  99     dup [ dup used-vregs get push-front ] when ;
 100
 101 RENAMING: ssa-rename [ gen-name ] [ top-name ] [ ]
 102
 103 GENERIC: rename-insn ( insn -- )
 104
 105 M: insn rename-insn drop ;
 106
 107 M: vreg-insn rename-insn
 108     [ ssa-rename-insn-uses ]
 109     [ ssa-rename-insn-defs ]
 110     bi ;
 111
 112 : rename-phis ( bb -- )
 113     inserting-phis get at [
 114         [
 115             [ ssa-rename-insn-defs ]
 116             [ dup dst>> phis get set-at ] bi
 117         ] each
 118     ] when* ;
 119
 120 : rename-insns ( bb -- )
 121     instructions>> [ rename-insn ] each ;
 122
 123 : rename-successor-phi ( phi bb -- )
 124     swap inputs>> [ (top-name) ] change-at ;
 125
 126 : rename-successor-phis ( succ bb -- )
 127     [ inserting-phis get at ] dip
 128     '[ _ rename-successor-phi ] each ;
 129
 130 : rename-successors-phis ( bb -- )
 131     [ successors>> ] keep '[ _ rename-successor-phis ] each ;
 132
 133 : pop-stacks ( -- )
 134     pushed get stacks get '[ drop _ at pop* ] assoc-each ;
 135
 136 : rename-in-block ( bb -- )
 137     H{ } clone pushed set
 138     {
 139         [ rename-phis ]
 140         [ rename-insns ]
 141         [ rename-successors-phis ]
 142         [
 143             pushed get
 144             [ dom-children [ rename-in-block ] each ] dip
 145             pushed set
 146         ]
 147     } cleave
 148     pop-stacks ;
 149
 150 : rename ( cfg -- )
 151     init-renaming
 152     entry>> rename-in-block ;
 153
 154 ! Live phis
 155 SYMBOL: live-phis
 156
 157 : live-phi? ( ##phi -- ? )
 158     dst>> live-phis get key? ;
 159
 160 : compute-live-phis ( -- )
 161     H{ } clone live-phis set
 162     used-vregs get [
 163         phis get at [
 164             [
 165                 dst>>
 166                 [ live-phis get conjoin ]
 167                 [ phis get delete-at ]
 168                 bi
 169             ]
 170             [ inputs>> [ nip used-vregs get push-front ] assoc-each ] bi
 171         ] when*
 172     ] slurp-deque ;
 173
 174 : insert-phis-in ( phis bb -- )
 175     [ [ live-phi? ] filter! ] dip
 176     [ append ] change-instructions drop ;
 177
 178 : insert-phis ( -- )
 179     inserting-phis get
 180     [ swap insert-phis-in ] assoc-each ;
 181
 182 PRIVATE>
 183
 184 : construct-ssa ( cfg -- cfg' )
 185     {
 186         [ compute-merge-sets ]
 187         [ compute-defs compute-phis ]
 188         [ rename compute-live-phis insert-phis ]
 189         [ ]
 190     } cleave ;