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.
6 * MLton is released under a BSD-style license.
7 * See the file MLton-LICENSE for details.
10 functor Redundant (S: SSA_TRANSFORM_STRUCTS): SSA_TRANSFORM =
15 datatype z = datatype Exp.t
16 datatype z = datatype Transfer.t
24 val plist: t -> PropertyList.t
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
34 val refine: {coarse: t, fine: t} vector -> unit
37 datatype t = T of {class: class ref}
38 and class = Class of {plist: PropertyList.t}
39 withtype refinement = {coarse: t, fine: t} vector
43 datatype t = datatype t
48 datatype t = datatype class
51 fun make f (Class r) = f r
53 val plist = make #plist
57 Class {plist = PropertyList.new ()}
61 fun make f (T r) = f r
63 val class = ! o make #class
66 fun setClass (T {class, ...}, c) = class := c
68 fun 'a new (elements: 'a vector, plist: 'a -> PropertyList.t): t vector =
70 val {destroy, get = class: 'a -> Class.t, ...} =
72 (plist, Property.initFun (fn _ => Class.new ()))
74 Vector.map (elements, fn elt => T {class = ref (class elt)})
82 val elt = T {class = ref (Class.new ())}
87 fun forceDistinct (es: t vector): unit =
89 (es, fn e => setClass (e, Class.new ()))
91 structure Refinement =
95 fun group (v: t, sel): t list =
98 val {destroy, get: Class.t -> {coarse: Element.t,
99 fine: Element.t} list ref,
103 Property.initFun (fn _ =>
106 val () = List.push (classes, r)
112 (v, fn cf => List.push (get (class (sel cf)), cf))
115 List.fold (!classes, [], fn (r, ac) =>
116 Vector.fromList (!r) :: ac)
120 fun refine (v: Refinement.t): {change: bool, keep: bool} =
122 val fineGroups = Refinement.group (v, #fine)
124 if Vector.length v = List.length fineGroups
125 then {change = false, keep = false}
128 val change = ref false
131 (fineGroups, 0, fn (v, n) =>
132 case Refinement.group (v, #coarse) of
137 val () = change := true
140 (classes, n, fn (v, n) =>
142 val elements = Vector.map (v, #fine)
146 (elements, fn e => setClass (e, c))
155 keep = Vector.length v <> numClasses}
169 display (seq [str "List.length rs = ",
170 Int.layout (List.length rs)])
176 (rs, ([], false), fn (r, (rs, change)) =>
178 val {keep = keep', change = change'} =
181 (if keep' then r :: rs else rs,
182 change orelse change')
194 val todo: Refinement.t list ref = ref []
196 if Vector.length r > 1 then List.push (todo, r) else ()
197 val fixedPoint = fn () =>
201 structure Class = Element.Class
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
218 datatype t = T of Element.t vector
222 fun elements (T v) = v
224 fun element (r, i) = Vector.sub (elements r, i)
226 fun forceDistinct (T v) = Element.forceDistinct v
228 fun fromTypes ts = T (Element.new (ts, Type.plist))
230 fun refine {coarse = T cv, fine = T fv} =
232 (Vector.map2 (cv, fv, fn (c, f) => {coarse = c, fine = f}))
235 (refine {coarse = r, fine = r'}
236 ; refine {coarse = r', fine = r})
241 val {get = classIndices: Class.t -> int list ref, destroy, ...} =
242 Property.destGet (Class.plist,
247 val () = List.push (classes, r)
254 List.push (classIndices (Element.class e), i))
257 List.fold (!classes, [], fn (r, ac) => !r :: ac)
260 val layout = (List.layout (List.layout Int.layout)) o classes
263 fun transform (Program.T {datatypes, globals, functions, main}) =
265 val {get = funcInfo: Func.t -> {arg: Eqrel.t, return: Eqrel.t option},
266 set = setFuncInfo, ...} =
268 (Func.plist, Property.initRaise ("Redundant.info", Func.layout))
269 val {get = labelInfo: Label.t -> Eqrel.t,
270 set = setLabelInfo, ...} =
272 (Label.plist, Property.initRaise ("Redundant.info", Label.layout))
273 val {get = varInfo : Var.t -> Element.t,
274 set = setVarInfo, ...} =
276 (Var.plist, Property.initFun (fn _ => Element.new1 ()))
277 fun varEquiv xs = Eqrel.make (Vector.map (xs, varInfo))
278 (* compute the fixed point *)
281 fun makeFormalsRel (xs: (Var.t * Type.t) vector): Eqrel.t =
283 val eqrel = Eqrel.fromTypes (Vector.map (xs, #2))
286 (xs, fn (i, (x, _)) =>
287 setVarInfo (x, Eqrel.element (eqrel, i)))
291 (* initialize all funcInfo and labelInfo *)
296 val {name, args, returns, blocks, ...} = Function.dest f
298 setFuncInfo (name, {arg = makeFormalsRel args,
299 return = Option.map (returns, Eqrel.fromTypes)})
301 Vector.foreach (blocks, fn Block.T {label, args, ...} =>
302 setLabelInfo (label, makeFormalsRel args))
306 (* Add the calls to all the funcInfos and labelInfos *)
311 val {name, blocks, ...} = Function.dest f
312 val {return, ...} = funcInfo name
315 (blocks, fn Block.T {transfer, ...} =>
317 Call {func, args, return = ret, ...} =>
319 val {arg = arg', return = return'} = funcInfo func
320 val _ = Eqrel.refine {coarse = varEquiv args,
325 | Return.NonTail {cont, ...} =>
326 Option.app (return', fn e =>
327 Eqrel.unify (e, labelInfo cont))
329 (case (return, return') of
330 (SOME e, SOME e') => Eqrel.unify (e, e')
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.
338 Vector.foreach (cases, fn (_, l) =>
339 Eqrel.forceDistinct (labelInfo l))
341 | Goto {dst, args, ...} =>
342 Eqrel.refine {coarse = varEquiv args,
343 fine = labelInfo dst}
345 Eqrel.refine {coarse = varEquiv xs,
349 val _ = Element.fixedPoint ()
359 val {name, blocks, ...} = Function.dest f
360 val {arg, return} = funcInfo name
362 display (seq [Func.layout name,
366 Option.layout Eqrel.layout return])
369 (blocks, fn Block.T {label, ...} =>
371 val arg = labelInfo label
373 display (seq [str "\t",
381 val {get = replacement : Var.t -> Var.t option,
382 set = setReplacement, ...} =
383 Property.getSetOnce (Var.plist, Property.initConst NONE)
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.
390 fun makeReds (r: Eqrel.t): red vector =
392 val {get = rep: Class.t -> int option ref, destroy, ...} =
393 Property.destGet (Class.plist,
394 Property.initFun (fn _ => ref NONE))
397 (Eqrel.elements r, fn (i, e) =>
399 val r = rep (Element.class e)
402 NONE => (r := SOME i; Useful)
403 | SOME i => Redundant i
409 fun redundantFormals (xs: (Var.t * Type.t) vector, r: Eqrel.t)
410 : red vector * (Var.t * Type.t) vector =
412 val reds = makeReds r
415 (xs, reds, fn (x, red) =>
419 (setReplacement (#1 x, SOME (#1 (Vector.sub (xs, i))))
424 fun keepUseful (reds: red vector, xs: 'a vector): 'a vector =
425 Vector.keepAllMap2 (reds, xs, fn (r, x) =>
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))
445 val {name, args, blocks, returns, ...} = Function.dest f
446 val {arg, return} = funcInfo name
447 val (returnsRed, returns) =
448 (case (returns, return) of
451 val returnsRed = makeReds r'
452 val returns = keepUseful (returnsRed, r)
454 (SOME returnsRed, SOME returns)
457 val (argsRed, args) = redundantFormals (args, arg)
459 setFuncReds (name, {args = args,
462 returnsRed = returnsRed}) ;
464 (blocks, fn Block.T {label, args, ...} =>
466 val (argsRed, args) = redundantFormals (args, labelInfo label)
468 setLabelReds (label, {args = args,
473 case replacement x of
476 fun loopVars xs = Vector.map (xs, loopVar)
481 val {blocks, mayInline, name, raises, start, ...} = Function.dest f
482 val {args, returns, returnsRed, ...} = funcReds name
485 (blocks, fn Block.T {label, statements, transfer, ...} =>
487 val {args, ...} = labelReds label
490 (statements, fn Statement.T {var, ty, exp} =>
491 Statement.T {var = var,
493 exp = Exp.replaceVar (exp, loopVar)})
496 Arith {prim, args, overflow, success, ty} =>
498 args = loopVars args,
503 | Call {func, args, return} =>
505 args = loopVars (keepUseful
506 (#argsRed (funcReds func),
509 | Case {test, cases, default} =>
510 Case {test = loopVar test,
513 | Goto {dst, args} =>
515 args = loopVars (keepUseful
516 (#argsRed (labelReds dst),
518 | Raise xs => Raise (loopVars xs)
521 (keepUseful (valOf returnsRed, xs)))
522 | Runtime {prim, args, return} =>
523 Runtime {prim = prim,
524 args = loopVars args,
527 Block.T {label = label,
529 statements = statements,
532 val f = Function.new {args = args,
534 mayInline = mayInline,
539 val _ = Function.clear f
543 val p = Program.T {datatypes = datatypes,
545 functions = functions,
547 val _ = Program.clearTop p