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

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