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 deques dlists fry kernel
8 math namespaces sequences sets ;
9 IN: compiler.cfg.ssa.construction
17 GENERIC: compute-insn-defs ( bb insn -- )
19 M: insn compute-insn-defs 2drop ;
21 M: vreg-insn compute-insn-defs
23 defs get [ adjoin-at ] [ drop ] [ at cardinality 1 > ] 2tri
24 [ defs-multi get adjoin ] [ drop ] if
27 : compute-defs ( cfg -- )
29 HS{ } clone defs-multi set
31 [ basic-block get ] dip
32 [ compute-insn-defs ] with each
35 SYMBOL: inserting-phis
37 : <##phi> ( vreg bb -- ##phi )
38 predecessors>> over '[ _ ] H{ } map>assoc ##phi new-insn ;
40 : insert-phi-later ( vreg bb -- )
41 [ <##phi> ] keep inserting-phis get push-at ;
43 : compute-phis-for ( vreg bbs -- )
44 members merge-set [ insert-phi-later ] with each ;
47 H{ } clone inserting-phis set
48 defs-multi get members
49 defs get '[ dup _ at compute-phis-for ] each ;
55 SYMBOLS: stacks pushed ;
57 : init-renaming ( -- )
59 <hashed-dlist> used-vregs set
60 H{ } clone stacks set ;
62 : gen-name ( vreg -- vreg' )
64 dup pushed get ?adjoin
65 [ stacks get push-at ]
66 [ stacks get at set-last ]
69 : (top-name) ( vreg -- vreg' )
72 : top-name ( vreg -- vreg' )
74 dup [ dup used-vregs get push-front ] when ;
76 RENAMING: ssa-rename [ gen-name ] [ top-name ] [ ]
78 GENERIC: rename-insn ( insn -- )
80 M: insn rename-insn drop ;
82 M: vreg-insn rename-insn
83 [ ssa-rename-insn-uses ]
84 [ ssa-rename-insn-defs ]
87 : rename-phis ( bb -- )
88 inserting-phis get at [
90 [ ssa-rename-insn-defs ]
91 [ dup dst>> phis get set-at ] bi
95 : rename-insns ( bb -- )
96 instructions>> [ rename-insn ] each ;
98 : rename-successor-phi ( phi bb -- )
99 swap inputs>> [ (top-name) ] change-at ;
101 : rename-successor-phis ( succ bb -- )
102 [ inserting-phis get at ] dip
103 '[ _ rename-successor-phi ] each ;
105 : rename-successors-phis ( bb -- )
106 [ successors>> ] keep '[ _ rename-successor-phis ] each ;
109 pushed get members stacks get '[ _ at pop* ] each ;
111 : rename-in-block ( bb -- )
112 HS{ } clone pushed set
116 [ rename-successors-phis ]
119 [ dom-children [ rename-in-block ] each ] dip
126 init-renaming entry>> rename-in-block ;
131 : live-phi? ( ##phi -- ? )
132 dst>> live-phis get in? ;
134 : compute-live-phis ( -- )
135 HS{ } clone live-phis set
140 [ live-phis get adjoin ]
141 [ phis get delete-at ]
144 [ inputs>> [ nip used-vregs get push-front ] assoc-each ] bi
148 : insert-phis-in ( phis bb -- )
149 [ [ live-phi? ] filter! ] dip
150 [ append ] change-instructions drop ;
152 : insert-phis ( inserting-phis -- )
153 [ swap insert-phis-in ] assoc-each ;
157 : construct-ssa ( cfg -- )
158 [ compute-merge-sets ]
159 [ compute-defs compute-phis ]
160 [ rename compute-live-phis inserting-phis get insert-phis ] tri ;