Commit | Line | Data |
---|---|---|
7f918cf1 CE |
1 | (* Copyright (C) 2009,2012 Matthew Fluet. |
2 | * Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh | |
3 | * Jagannathan, and Stephen Weeks. | |
4 | * Copyright (C) 1997-2000 NEC Research Institute. | |
5 | * | |
6 | * MLton is released under a BSD-style license. | |
7 | * See the file MLton-LICENSE for details. | |
8 | *) | |
9 | ||
10 | functor Redundant (S: SSA_TRANSFORM_STRUCTS): SSA_TRANSFORM = | |
11 | struct | |
12 | ||
13 | open S | |
14 | ||
15 | datatype z = datatype Exp.t | |
16 | datatype z = datatype Transfer.t | |
17 | ||
18 | structure Element: | |
19 | sig | |
20 | structure Class: | |
21 | sig | |
22 | type t | |
23 | ||
24 | val plist: t -> PropertyList.t | |
25 | end | |
26 | ||
27 | type t | |
28 | ||
29 | val class: t -> Class.t | |
30 | val fixedPoint: unit -> unit | |
31 | val forceDistinct: t vector -> unit | |
32 | val new: 'a vector * ('a -> PropertyList.t) -> t vector | |
33 | val new1: unit -> t | |
34 | val refine: {coarse: t, fine: t} vector -> unit | |
35 | end = | |
36 | struct | |
37 | datatype t = T of {class: class ref} | |
38 | and class = Class of {plist: PropertyList.t} | |
39 | withtype refinement = {coarse: t, fine: t} vector | |
40 | ||
41 | structure Element = | |
42 | struct | |
43 | datatype t = datatype t | |
44 | end | |
45 | ||
46 | structure Class = | |
47 | struct | |
48 | datatype t = datatype class | |
49 | ||
50 | local | |
51 | fun make f (Class r) = f r | |
52 | in | |
53 | val plist = make #plist | |
54 | end | |
55 | ||
56 | fun new () = | |
57 | Class {plist = PropertyList.new ()} | |
58 | end | |
59 | ||
60 | local | |
61 | fun make f (T r) = f r | |
62 | in | |
63 | val class = ! o make #class | |
64 | end | |
65 | ||
66 | fun setClass (T {class, ...}, c) = class := c | |
67 | ||
68 | fun 'a new (elements: 'a vector, plist: 'a -> PropertyList.t): t vector = | |
69 | let | |
70 | val {destroy, get = class: 'a -> Class.t, ...} = | |
71 | Property.destGet | |
72 | (plist, Property.initFun (fn _ => Class.new ())) | |
73 | val elements = | |
74 | Vector.map (elements, fn elt => T {class = ref (class elt)}) | |
75 | val () = destroy () | |
76 | in | |
77 | elements | |
78 | end | |
79 | ||
80 | fun new1 () = | |
81 | let | |
82 | val elt = T {class = ref (Class.new ())} | |
83 | in | |
84 | elt | |
85 | end | |
86 | ||
87 | fun forceDistinct (es: t vector): unit = | |
88 | Vector.foreach | |
89 | (es, fn e => setClass (e, Class.new ())) | |
90 | ||
91 | structure Refinement = | |
92 | struct | |
93 | type t = refinement | |
94 | ||
95 | fun group (v: t, sel): t list = | |
96 | let | |
97 | val classes = ref [] | |
98 | val {destroy, get: Class.t -> {coarse: Element.t, | |
99 | fine: Element.t} list ref, | |
100 | ...} = | |
101 | Property.destGet | |
102 | (Class.plist, | |
103 | Property.initFun (fn _ => | |
104 | let | |
105 | val r = ref [] | |
106 | val () = List.push (classes, r) | |
107 | in | |
108 | r | |
109 | end)) | |
110 | val () = | |
111 | Vector.foreach | |
112 | (v, fn cf => List.push (get (class (sel cf)), cf)) | |
113 | val () = destroy () | |
114 | in | |
115 | List.fold (!classes, [], fn (r, ac) => | |
116 | Vector.fromList (!r) :: ac) | |
117 | end | |
118 | end | |
119 | ||
120 | fun refine (v: Refinement.t): {change: bool, keep: bool} = | |
121 | let | |
122 | val fineGroups = Refinement.group (v, #fine) | |
123 | in | |
124 | if Vector.length v = List.length fineGroups | |
125 | then {change = false, keep = false} | |
126 | else | |
127 | let | |
128 | val change = ref false | |
129 | val numClasses = | |
130 | List.fold | |
131 | (fineGroups, 0, fn (v, n) => | |
132 | case Refinement.group (v, #coarse) of | |
133 | [] => n | |
134 | | [_] => n + 1 | |
135 | | classes => | |
136 | let | |
137 | val () = change := true | |
138 | val n = | |
139 | List.fold | |
140 | (classes, n, fn (v, n) => | |
141 | let | |
142 | val elements = Vector.map (v, #fine) | |
143 | val c = Class.new () | |
144 | val () = | |
145 | Vector.foreach | |
146 | (elements, fn e => setClass (e, c)) | |
147 | in | |
148 | n + 1 | |
149 | end) | |
150 | in | |
151 | n | |
152 | end) | |
153 | in | |
154 | {change = !change, | |
155 | keep = Vector.length v <> numClasses} | |
156 | end | |
157 | end | |
158 | ||
159 | fun fixedPoint rs = | |
160 | let | |
161 | fun loop rs = | |
162 | let | |
163 | val _ = | |
164 | Control.diagnostics | |
165 | (fn display => | |
166 | let | |
167 | open Layout | |
168 | val () = | |
169 | display (seq [str "List.length rs = ", | |
170 | Int.layout (List.length rs)]) | |
171 | in | |
172 | () | |
173 | end) | |
174 | val (rs, change) = | |
175 | List.fold | |
176 | (rs, ([], false), fn (r, (rs, change)) => | |
177 | let | |
178 | val {keep = keep', change = change'} = | |
179 | refine r | |
180 | in | |
181 | (if keep' then r :: rs else rs, | |
182 | change orelse change') | |
183 | end) | |
184 | in | |
185 | if change | |
186 | then loop rs | |
187 | else () | |
188 | end | |
189 | val () = loop rs | |
190 | in | |
191 | () | |
192 | end | |
193 | ||
194 | val todo: Refinement.t list ref = ref [] | |
195 | val refine = fn r => | |
196 | if Vector.length r > 1 then List.push (todo, r) else () | |
197 | val fixedPoint = fn () => | |
198 | fixedPoint (!todo) | |
199 | end | |
200 | ||
201 | structure Class = Element.Class | |
202 | ||
203 | structure Eqrel:> | |
204 | sig | |
205 | type t | |
206 | ||
207 | val classes: t -> int list list | |
208 | val element: t * int -> Element.t | |
209 | val elements: t -> Element.t vector | |
210 | val forceDistinct: t -> unit | |
211 | val fromTypes: Type.t vector -> t | |
212 | val layout: t -> Layout.t | |
213 | val make: Element.t vector -> t | |
214 | val refine: {coarse: t, fine: t} -> unit | |
215 | val unify: t * t -> unit | |
216 | end = | |
217 | struct | |
218 | datatype t = T of Element.t vector | |
219 | ||
220 | val make = T | |
221 | ||
222 | fun elements (T v) = v | |
223 | ||
224 | fun element (r, i) = Vector.sub (elements r, i) | |
225 | ||
226 | fun forceDistinct (T v) = Element.forceDistinct v | |
227 | ||
228 | fun fromTypes ts = T (Element.new (ts, Type.plist)) | |
229 | ||
230 | fun refine {coarse = T cv, fine = T fv} = | |
231 | Element.refine | |
232 | (Vector.map2 (cv, fv, fn (c, f) => {coarse = c, fine = f})) | |
233 | ||
234 | fun unify (r, r') = | |
235 | (refine {coarse = r, fine = r'} | |
236 | ; refine {coarse = r', fine = r}) | |
237 | ||
238 | fun classes (T v) = | |
239 | let | |
240 | val classes = ref [] | |
241 | val {get = classIndices: Class.t -> int list ref, destroy, ...} = | |
242 | Property.destGet (Class.plist, | |
243 | Property.initFun | |
244 | (fn _ => | |
245 | let | |
246 | val r = ref [] | |
247 | val () = List.push (classes, r) | |
248 | in | |
249 | r | |
250 | end)) | |
251 | val () = | |
252 | Vector.foreachi | |
253 | (v, fn (i, e) => | |
254 | List.push (classIndices (Element.class e), i)) | |
255 | val () = destroy () | |
256 | in | |
257 | List.fold (!classes, [], fn (r, ac) => !r :: ac) | |
258 | end | |
259 | ||
260 | val layout = (List.layout (List.layout Int.layout)) o classes | |
261 | end | |
262 | ||
263 | fun transform (Program.T {datatypes, globals, functions, main}) = | |
264 | let | |
265 | val {get = funcInfo: Func.t -> {arg: Eqrel.t, return: Eqrel.t option}, | |
266 | set = setFuncInfo, ...} = | |
267 | Property.getSetOnce | |
268 | (Func.plist, Property.initRaise ("Redundant.info", Func.layout)) | |
269 | val {get = labelInfo: Label.t -> Eqrel.t, | |
270 | set = setLabelInfo, ...} = | |
271 | Property.getSetOnce | |
272 | (Label.plist, Property.initRaise ("Redundant.info", Label.layout)) | |
273 | val {get = varInfo : Var.t -> Element.t, | |
274 | set = setVarInfo, ...} = | |
275 | Property.getSetOnce | |
276 | (Var.plist, Property.initFun (fn _ => Element.new1 ())) | |
277 | fun varEquiv xs = Eqrel.make (Vector.map (xs, varInfo)) | |
278 | (* compute the fixed point *) | |
279 | val () = | |
280 | let | |
281 | fun makeFormalsRel (xs: (Var.t * Type.t) vector): Eqrel.t = | |
282 | let | |
283 | val eqrel = Eqrel.fromTypes (Vector.map (xs, #2)) | |
284 | val () = | |
285 | Vector.foreachi | |
286 | (xs, fn (i, (x, _)) => | |
287 | setVarInfo (x, Eqrel.element (eqrel, i))) | |
288 | in | |
289 | eqrel | |
290 | end | |
291 | (* initialize all funcInfo and labelInfo *) | |
292 | val () = | |
293 | List.foreach | |
294 | (functions, fn f => | |
295 | let | |
296 | val {name, args, returns, blocks, ...} = Function.dest f | |
297 | val _ = | |
298 | setFuncInfo (name, {arg = makeFormalsRel args, | |
299 | return = Option.map (returns, Eqrel.fromTypes)}) | |
300 | val _ = | |
301 | Vector.foreach (blocks, fn Block.T {label, args, ...} => | |
302 | setLabelInfo (label, makeFormalsRel args)) | |
303 | in | |
304 | () | |
305 | end) | |
306 | (* Add the calls to all the funcInfos and labelInfos *) | |
307 | val () = | |
308 | List.foreach | |
309 | (functions, fn f => | |
310 | let | |
311 | val {name, blocks, ...} = Function.dest f | |
312 | val {return, ...} = funcInfo name | |
313 | in | |
314 | Vector.foreach | |
315 | (blocks, fn Block.T {transfer, ...} => | |
316 | case transfer of | |
317 | Call {func, args, return = ret, ...} => | |
318 | let | |
319 | val {arg = arg', return = return'} = funcInfo func | |
320 | val _ = Eqrel.refine {coarse = varEquiv args, | |
321 | fine = arg'} | |
322 | in | |
323 | case ret of | |
324 | Return.Dead => () | |
325 | | Return.NonTail {cont, ...} => | |
326 | Option.app (return', fn e => | |
327 | Eqrel.unify (e, labelInfo cont)) | |
328 | | Return.Tail => | |
329 | (case (return, return') of | |
330 | (SOME e, SOME e') => Eqrel.unify (e, e') | |
331 | | _ => ()) | |
332 | end | |
333 | | Case {cases = Cases.Con cases, ...} => | |
334 | (* For now, assume that constructor arguments | |
335 | * are never redundant. Thus all case branches | |
336 | * need to have trivial equivalence relations. | |
337 | *) | |
338 | Vector.foreach (cases, fn (_, l) => | |
339 | Eqrel.forceDistinct (labelInfo l)) | |
340 | ||
341 | | Goto {dst, args, ...} => | |
342 | Eqrel.refine {coarse = varEquiv args, | |
343 | fine = labelInfo dst} | |
344 | | Return xs => | |
345 | Eqrel.refine {coarse = varEquiv xs, | |
346 | fine = valOf return} | |
347 | | _ => ()) | |
348 | end) | |
349 | val _ = Element.fixedPoint () | |
350 | in () | |
351 | end | |
352 | val _ = | |
353 | Control.diagnostics | |
354 | (fn display => | |
355 | List.foreach | |
356 | (functions, fn f => | |
357 | let | |
358 | open Layout | |
359 | val {name, blocks, ...} = Function.dest f | |
360 | val {arg, return} = funcInfo name | |
361 | val () = | |
362 | display (seq [Func.layout name, | |
363 | str " ", | |
364 | Eqrel.layout arg, | |
365 | str " : ", | |
366 | Option.layout Eqrel.layout return]) | |
367 | val () = | |
368 | Vector.foreach | |
369 | (blocks, fn Block.T {label, ...} => | |
370 | let | |
371 | val arg = labelInfo label | |
372 | in | |
373 | display (seq [str "\t", | |
374 | Label.layout label, | |
375 | str " ", | |
376 | Eqrel.layout arg]) | |
377 | end) | |
378 | in | |
379 | () | |
380 | end)) | |
381 | val {get = replacement : Var.t -> Var.t option, | |
382 | set = setReplacement, ...} = | |
383 | Property.getSetOnce (Var.plist, Property.initConst NONE) | |
384 | datatype red = | |
385 | Useful | |
386 | | Redundant of int (* the index it is the same as *) | |
387 | (* Turn an equivalence relation on 0 ... n - 1 into a red vector by | |
388 | * choosing a representative of each class. | |
389 | *) | |
390 | fun makeReds (r: Eqrel.t): red vector = | |
391 | let | |
392 | val {get = rep: Class.t -> int option ref, destroy, ...} = | |
393 | Property.destGet (Class.plist, | |
394 | Property.initFun (fn _ => ref NONE)) | |
395 | val reds = | |
396 | Vector.mapi | |
397 | (Eqrel.elements r, fn (i, e) => | |
398 | let | |
399 | val r = rep (Element.class e) | |
400 | in | |
401 | case !r of | |
402 | NONE => (r := SOME i; Useful) | |
403 | | SOME i => Redundant i | |
404 | end) | |
405 | val () = destroy () | |
406 | in | |
407 | reds | |
408 | end | |
409 | fun redundantFormals (xs: (Var.t * Type.t) vector, r: Eqrel.t) | |
410 | : red vector * (Var.t * Type.t) vector = | |
411 | let | |
412 | val reds = makeReds r | |
413 | val xs = | |
414 | Vector.keepAllMap2 | |
415 | (xs, reds, fn (x, red) => | |
416 | case red of | |
417 | Useful => SOME x | |
418 | | Redundant i => | |
419 | (setReplacement (#1 x, SOME (#1 (Vector.sub (xs, i)))) | |
420 | ; NONE)) | |
421 | in | |
422 | (reds, xs) | |
423 | end | |
424 | fun keepUseful (reds: red vector, xs: 'a vector): 'a vector = | |
425 | Vector.keepAllMap2 (reds, xs, fn (r, x) => | |
426 | case r of | |
427 | Useful => SOME x | |
428 | | _ => NONE) | |
429 | val {get = funcReds : Func.t -> {argsRed: red vector, | |
430 | args: (Var.t * Type.t) vector, | |
431 | returnsRed: red vector option, | |
432 | returns: Type.t vector option}, | |
433 | set = setFuncReds, ...} = | |
434 | Property.getSetOnce (Func.plist, | |
435 | Property.initRaise ("funcReds", Func.layout)) | |
436 | val {get = labelReds: Label.t -> {argsRed: red vector, | |
437 | args: (Var.t * Type.t) vector}, | |
438 | set = setLabelReds, ...} = | |
439 | Property.getSetOnce (Label.plist, | |
440 | Property.initRaise ("labelReds", Label.layout)) | |
441 | val _ = | |
442 | List.foreach | |
443 | (functions, fn f => | |
444 | let | |
445 | val {name, args, blocks, returns, ...} = Function.dest f | |
446 | val {arg, return} = funcInfo name | |
447 | val (returnsRed, returns) = | |
448 | (case (returns, return) of | |
449 | (SOME r, SOME r') => | |
450 | let | |
451 | val returnsRed = makeReds r' | |
452 | val returns = keepUseful (returnsRed, r) | |
453 | in | |
454 | (SOME returnsRed, SOME returns) | |
455 | end | |
456 | | _ => (NONE, NONE)) | |
457 | val (argsRed, args) = redundantFormals (args, arg) | |
458 | in | |
459 | setFuncReds (name, {args = args, | |
460 | argsRed = argsRed, | |
461 | returns = returns, | |
462 | returnsRed = returnsRed}) ; | |
463 | Vector.foreach | |
464 | (blocks, fn Block.T {label, args, ...} => | |
465 | let | |
466 | val (argsRed, args) = redundantFormals (args, labelInfo label) | |
467 | in | |
468 | setLabelReds (label, {args = args, | |
469 | argsRed = argsRed}) | |
470 | end) | |
471 | end) | |
472 | fun loopVar x = | |
473 | case replacement x of | |
474 | NONE => x | |
475 | | SOME y => y | |
476 | fun loopVars xs = Vector.map (xs, loopVar) | |
477 | val functions = | |
478 | List.revMap | |
479 | (functions, fn f => | |
480 | let | |
481 | val {blocks, mayInline, name, raises, start, ...} = Function.dest f | |
482 | val {args, returns, returnsRed, ...} = funcReds name | |
483 | val blocks = | |
484 | Vector.map | |
485 | (blocks, fn Block.T {label, statements, transfer, ...} => | |
486 | let | |
487 | val {args, ...} = labelReds label | |
488 | val statements = | |
489 | Vector.map | |
490 | (statements, fn Statement.T {var, ty, exp} => | |
491 | Statement.T {var = var, | |
492 | ty = ty, | |
493 | exp = Exp.replaceVar (exp, loopVar)}) | |
494 | val transfer = | |
495 | case transfer of | |
496 | Arith {prim, args, overflow, success, ty} => | |
497 | Arith {prim = prim, | |
498 | args = loopVars args, | |
499 | overflow = overflow, | |
500 | success = success, | |
501 | ty = ty} | |
502 | | Bug => Bug | |
503 | | Call {func, args, return} => | |
504 | Call {func = func, | |
505 | args = loopVars (keepUseful | |
506 | (#argsRed (funcReds func), | |
507 | args)), | |
508 | return = return} | |
509 | | Case {test, cases, default} => | |
510 | Case {test = loopVar test, | |
511 | cases = cases, | |
512 | default = default} | |
513 | | Goto {dst, args} => | |
514 | Goto {dst = dst, | |
515 | args = loopVars (keepUseful | |
516 | (#argsRed (labelReds dst), | |
517 | args))} | |
518 | | Raise xs => Raise (loopVars xs) | |
519 | | Return xs => | |
520 | Return (loopVars | |
521 | (keepUseful (valOf returnsRed, xs))) | |
522 | | Runtime {prim, args, return} => | |
523 | Runtime {prim = prim, | |
524 | args = loopVars args, | |
525 | return = return} | |
526 | in | |
527 | Block.T {label = label, | |
528 | args = args, | |
529 | statements = statements, | |
530 | transfer = transfer} | |
531 | end) | |
532 | val f = Function.new {args = args, | |
533 | blocks = blocks, | |
534 | mayInline = mayInline, | |
535 | name = name, | |
536 | raises = raises, | |
537 | returns = returns, | |
538 | start = start} | |
539 | val _ = Function.clear f | |
540 | in | |
541 | f | |
542 | end) | |
543 | val p = Program.T {datatypes = datatypes, | |
544 | globals = globals, | |
545 | functions = functions, | |
546 | main = main} | |
547 | val _ = Program.clearTop p | |
548 | in | |
549 | p | |
550 | end | |
551 | ||
552 | end |