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