Commit | Line | Data |
---|---|---|
7f918cf1 CE |
1 | (* Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh |
2 | * Jagannathan, and Stephen Weeks. | |
3 | * Copyright (C) 1997-2000 NEC Research Institute. | |
4 | * | |
5 | * MLton is released under a BSD-style license. | |
6 | * See the file MLton-LICENSE for details. | |
7 | *) | |
8 | ||
9 | functor Peephole(T : PEEPHOLE_TYPES): PEEPHOLE = | |
10 | struct | |
11 | open T | |
12 | ||
13 | datatype statement_border = Empty | |
14 | | EmptyOrNonEmpty | |
15 | type statement_element = (int * int option) * (statement_type -> bool) | |
16 | type transfer_element = transfer_type -> bool | |
17 | ||
18 | val One : (statement_type -> bool) -> statement_element | |
19 | = fn p => ((1, SOME 1), p) | |
20 | val All : (statement_type -> bool) -> statement_element | |
21 | = fn p => ((0, NONE), p) | |
22 | ||
23 | type template = {start: statement_border, | |
24 | statements: statement_element list, | |
25 | finish: statement_border, | |
26 | transfer: transfer_element} | |
27 | ||
28 | type match = {entry: entry_type, | |
29 | profileLabel: profileLabel_type, | |
30 | start: statement_type list, | |
31 | statements: statement_type list list, | |
32 | finish: statement_type list, | |
33 | transfer: transfer_type} | |
34 | ||
35 | type rewriter = match -> block option | |
36 | ||
37 | type callback = bool -> unit | |
38 | ||
39 | type optimization = {template: template, | |
40 | rewriter: rewriter, | |
41 | callback: callback} | |
42 | ||
43 | datatype match_state | |
44 | = Start of {block: block} | |
45 | | Continue of {remaining: optimization list, | |
46 | match: match} | |
47 | | Done of {block: block} | |
48 | ||
49 | type find_state = {remaining: optimization list, | |
50 | state: {entry: entry_type, | |
51 | profileLabel: profileLabel_type, | |
52 | start: statement_type list, | |
53 | finish: statement_type list, | |
54 | transfer: transfer_type}} | |
55 | ||
56 | fun split (l, p) | |
57 | = case l | |
58 | of [] => ([],[]) | |
59 | | l as h::t => if p h | |
60 | then let | |
61 | val (tt,ff) = split (t, p) | |
62 | in | |
63 | (h::tt,ff) | |
64 | end | |
65 | else ([],l) | |
66 | ||
67 | val rec matcher' : {template_statement: statement_element, | |
68 | statement: statement_type list, | |
69 | finish: statement_type list} -> | |
70 | {statement: statement_type list, | |
71 | finish: statement_type list} option | |
72 | = fn (* Zero *) | |
73 | {template_statement = ((0, SOME 0), _), | |
74 | statement, | |
75 | finish} | |
76 | => SOME {statement = List.rev statement, | |
77 | finish = finish} | |
78 | | (* ZeroOrOne *) | |
79 | {template_statement = ((0, SOME 1), p), | |
80 | statement, | |
81 | finish} | |
82 | => (case finish | |
83 | of [] => SOME {statement = List.rev statement, | |
84 | finish = finish} | |
85 | | (statement'::finish') | |
86 | => if p statement' | |
87 | then SOME {statement = List.rev (statement'::statement), | |
88 | finish = finish'} | |
89 | else SOME {statement = List.rev statement, | |
90 | finish = finish}) | |
91 | | (* One *) | |
92 | {template_statement = ((1, SOME 1), p), | |
93 | statement, | |
94 | finish} | |
95 | => (case finish | |
96 | of [] => NONE | |
97 | | (statement'::finish') | |
98 | => if p statement' | |
99 | then SOME {statement = List.rev (statement'::statement), | |
100 | finish = finish'} | |
101 | else NONE) | |
102 | | (* *) | |
103 | {template_statement = ((0, SOME i), p), | |
104 | statement, | |
105 | finish} | |
106 | => (case finish | |
107 | of [] => SOME {statement = List.rev statement, | |
108 | finish = finish} | |
109 | | (statement'::finish') | |
110 | => if p statement' | |
111 | then matcher' {template_statement = ((0, SOME (i-1)), p), | |
112 | statement = statement'::statement, | |
113 | finish = finish'} | |
114 | else SOME {statement = List.rev statement, | |
115 | finish = finish}) | |
116 | | (* All *) | |
117 | {template_statement = ((0, NONE), p), | |
118 | statement, | |
119 | finish} | |
120 | => let | |
121 | val (statement',finish') = split (finish, p) | |
122 | in | |
123 | SOME {statement = List.fold(statement, | |
124 | statement', | |
125 | op ::), | |
126 | finish = finish'} | |
127 | end | |
128 | | {template_statement = ((min, max), p), | |
129 | statement, | |
130 | finish = (statement'::finish')} | |
131 | => if p statement' | |
132 | then matcher' {template_statement | |
133 | = ((Int.max(min-1,0), | |
134 | Option.map(max,fn i => i - 1)), p), | |
135 | statement = statement'::statement, | |
136 | finish = finish'} | |
137 | else NONE | |
138 | | _ => NONE | |
139 | ||
140 | val rec matcher : {template_statements: statement_element list, | |
141 | statements: statement_type list list, | |
142 | finish: statement_type list} -> | |
143 | {statements: statement_type list list, | |
144 | finish: statement_type list} option | |
145 | = fn {template_statements = [], | |
146 | statements, | |
147 | finish} | |
148 | => SOME {statements = List.rev statements, | |
149 | finish = finish} | |
150 | | {template_statements = (template_statement::template_statements), | |
151 | statements, | |
152 | finish} | |
153 | => (case matcher' {template_statement = template_statement, | |
154 | statement = [], | |
155 | finish = finish} | |
156 | of NONE => NONE | |
157 | | SOME {statement, finish} | |
158 | => matcher {template_statements = template_statements, | |
159 | statements = statement::statements, | |
160 | finish = finish}) | |
161 | ||
162 | fun peepholeBlock' {optimizations: optimization list, | |
163 | match_state: match_state} | |
164 | = let | |
165 | fun next {remaining: optimization list, | |
166 | state as {entry, profileLabel, start, finish, transfer}} : | |
167 | find_state option | |
168 | = (case remaining | |
169 | of [] => NONE | |
170 | | _::nil | |
171 | => (case finish | |
172 | of [] => NONE | |
173 | | statement::finish | |
174 | => SOME {remaining = optimizations, | |
175 | state = {entry = entry, | |
176 | profileLabel = profileLabel, | |
177 | start = statement::start, | |
178 | finish = finish, | |
179 | transfer = transfer}}) | |
180 | | _::remaining | |
181 | => SOME {remaining = remaining, | |
182 | state = state}) | |
183 | ||
184 | fun findMatch' (find_state | |
185 | as {remaining as {template = {start | |
186 | = template_start, | |
187 | statements | |
188 | = template_statements, | |
189 | finish | |
190 | = template_finish, | |
191 | transfer | |
192 | = template_transfer}, | |
193 | ...}::_, | |
194 | state = {entry, | |
195 | profileLabel, | |
196 | start, | |
197 | finish, | |
198 | transfer}}) : | |
199 | match_state | |
200 | = let | |
201 | fun loop () | |
202 | = (case next find_state | |
203 | of SOME find_state => findMatch' find_state | |
204 | | NONE | |
205 | => Done {block = T {entry = entry, | |
206 | profileLabel = profileLabel, | |
207 | statements = List.fold(start, | |
208 | finish, | |
209 | op ::), | |
210 | transfer = transfer}}) | |
211 | in | |
212 | if not (template_transfer transfer) | |
213 | then loop () | |
214 | else if template_start = Empty | |
215 | andalso | |
216 | not (List.isEmpty start) | |
217 | then loop () | |
218 | else case matcher {template_statements = template_statements, | |
219 | statements = [], | |
220 | finish = finish} | |
221 | of NONE => loop () | |
222 | | SOME {statements, finish} | |
223 | => if template_finish = Empty | |
224 | andalso | |
225 | not (List.isEmpty finish) | |
226 | then loop () | |
227 | else Continue {remaining = remaining, | |
228 | match | |
229 | = {entry = entry, | |
230 | profileLabel = profileLabel, | |
231 | start = start, | |
232 | statements = statements, | |
233 | finish = finish, | |
234 | transfer = transfer}} | |
235 | end | |
236 | | findMatch' _ = Error.bug "Peephole.peepholeBlock'.findMatch'" | |
237 | ||
238 | fun findMatch (match_state: match_state) : match_state | |
239 | = case match_state | |
240 | of Start {block = T {entry, profileLabel, | |
241 | statements, transfer}} | |
242 | => let | |
243 | val find_state | |
244 | = {remaining = optimizations, | |
245 | state = {entry = entry, | |
246 | profileLabel = profileLabel, | |
247 | start = [], | |
248 | finish = statements, | |
249 | transfer = transfer}} | |
250 | in | |
251 | findMatch' find_state | |
252 | end | |
253 | | Continue {remaining, | |
254 | match = {entry, | |
255 | profileLabel, | |
256 | start, | |
257 | statements, | |
258 | finish, | |
259 | transfer}, | |
260 | ...} | |
261 | => let | |
262 | val finish = List.foldr(statements, | |
263 | finish, | |
264 | op @) | |
265 | val find_state | |
266 | = {remaining = remaining, | |
267 | state = {entry = entry, | |
268 | profileLabel = profileLabel, | |
269 | start = start, | |
270 | finish = finish, | |
271 | transfer = transfer}} | |
272 | in | |
273 | case next find_state | |
274 | of NONE => Done {block | |
275 | = T {entry = entry, | |
276 | profileLabel = profileLabel, | |
277 | statements = List.fold(start, | |
278 | finish, | |
279 | op ::), | |
280 | transfer = transfer}} | |
281 | | SOME find_state => findMatch' find_state | |
282 | end | |
283 | | Done _ => match_state | |
284 | ||
285 | fun peepholeBlock'' {match_state: match_state, | |
286 | changed: bool} | |
287 | = case findMatch match_state | |
288 | of match_state as Continue {remaining = {rewriter, | |
289 | callback, | |
290 | ...}::_, | |
291 | match} | |
292 | => (case rewriter match | |
293 | of SOME block | |
294 | => (callback true; | |
295 | peepholeBlock'' {match_state | |
296 | = Start {block = block}, | |
297 | changed = true}) | |
298 | | NONE | |
299 | => (callback false; | |
300 | peepholeBlock'' {match_state = match_state, | |
301 | changed = changed})) | |
302 | | Done {block} => {block = block, changed = changed} | |
303 | | _ => Error.bug "Peephole.peepholeBlock''" | |
304 | in | |
305 | case optimizations | |
306 | of [] => (case match_state | |
307 | of Start {block = block} => {block = block, | |
308 | changed = false} | |
309 | | _ => Error.bug "Peephole.peepholeBlock'") | |
310 | | _ => peepholeBlock'' {match_state = match_state, | |
311 | changed = false} | |
312 | end | |
313 | ||
314 | fun peepholeBlock {block: block, | |
315 | optimizations: optimization list} | |
316 | = peepholeBlock' {optimizations = optimizations, | |
317 | match_state = Start {block = block}} | |
318 | ||
319 | fun peepholeBlocks {blocks: block list, | |
320 | optimizations: optimization list} | |
321 | = let | |
322 | val {blocks, changed} | |
323 | = List.foldr | |
324 | (blocks, | |
325 | {blocks = [], changed = false}, | |
326 | fn (block,{blocks,changed}) | |
327 | => let | |
328 | val {block = block', | |
329 | changed = changed'} | |
330 | = peepholeBlock' {optimizations = optimizations, | |
331 | match_state = Start {block = block}} | |
332 | in | |
333 | {blocks = block'::blocks, | |
334 | changed = changed orelse changed'} | |
335 | end) | |
336 | in | |
337 | {blocks = blocks, | |
338 | changed = changed} | |
339 | end | |
340 | end |