1 (* Copyright (C) 2009,2017 Matthew Fluet.
2 * Copyright (C) 1999-2008 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 Useless (S: SSA_TRANSFORM_STRUCTS): SSA_TRANSFORM =
14 (* useless thing elimination
15 * remove components of tuples that are constants (use unification)
16 * remove function arguments that are constants
17 * build some kind of dependence graph where
18 * - a value of ground type is useful if it is an arg to a primitive
19 * - a tuple is useful if it contains a useful component
20 * - a conapp is useful if it contains a useful component
21 * or is used in a case
23 * If a useful tuple is coerced to another useful tuple,
24 * then all of their components must agree (exactly).
25 * It is trivial to convert a useful value to a useless one.
27 * It is also trivial to convert a useful tuple to one of its
28 * useful components -- but this seems hard
31 (* Suppose that you have a ref/array/vector that is useful, but the
32 * components aren't -- then the components are converted to type unit, and
33 * any primapp args must be as well.
36 (* Weirdness with raise/handle.
37 * There must be a uniform "calling convention" for raise and handle.
38 * Hence, just because some of a handlers args are useless, that doesn't mean
39 * that it can drop them, since they may be useful to another handler, and
40 * hence every raise will pass them along. The problem is that it is not
41 * possible to tell solely from looking at a function declaration whether it is
42 * a handler or not, and in fact, there is nothing preventing a jump being used
43 * in both ways. So, maybe the right thing is for the handler wrapper to
45 * Another solution would be to unify all handler args.
50 structure Set = DisjointSet
54 structure L = TwoPointLattice (val bottom = "not exists"
57 val mustExist = makeTop
63 structure L = TwoPointLattice (val bottom = "useless"
66 val makeUseful = makeTop
71 T of {new: (Type.t * bool) option ref,
81 | Tuple of slot vector
82 | Vector of {elt: slot,
86 withtype slot = t * Exists.t
89 fun make sel (T s) = sel (Set.! s)
91 val value = make #value
100 val {value, ...} = Set.! s
103 Array {elt, length, ...} =>
104 seq [str "array", tuple [layout length, layoutSlot elt]]
105 | Ground g => seq [str "ground ", Useful.layout g]
106 | Ref {arg, useful, ...} =>
108 record [("useful", Useful.layout useful),
109 ("slot", layoutSlot arg)]]
110 | Tuple vs => Vector.layout layoutSlot vs
111 | Vector {elt, length} =>
112 seq [str "vector", tuple [layout length, layoutSlot elt]]
113 | Weak {arg, useful} =>
115 record [("useful", Useful.layout useful),
116 ("slot", layoutSlot arg)]]
118 and layoutSlot (v, e) =
119 tuple [Exists.layout e, layout v]
122 fun unify (T s, T s') =
123 if Set.equals (s, s')
127 val {value = v, ...} = Set.! s
128 val {value = v', ...} = Set.! s'
129 val _ = Set.union (s, s')
132 (Array {length = n, elt = e, ...},
133 Array {length = n', elt = e', ...}) =>
134 (unify (n, n'); unifySlot (e, e'))
135 | (Ground g, Ground g') => Useful.== (g, g')
136 | (Ref {useful = u, arg = a},
137 Ref {useful = u', arg = a'}) =>
138 (Useful.== (u, u'); unifySlot (a, a'))
139 | (Tuple vs, Tuple vs') =>
140 Vector.foreach2 (vs, vs', unifySlot)
141 | (Vector {length = n, elt = e},
142 Vector {length = n', elt = e'}) =>
143 (unify (n, n'); unifySlot (e, e'))
144 | (Weak {useful = u, arg = a}, Weak {useful = u', arg = a'}) =>
145 (Useful.== (u, u'); unifySlot (a, a'))
146 | _ => Error.bug "Useless.Value.unify: strange"
148 and unifySlot ((v, e), (v', e')) = (unify (v, v'); Exists.== (e, e'))
150 fun coerce {from = from as T sfrom, to = to as T sto}: unit =
151 if Set.equals (sfrom, sto)
155 fun coerceSlot ((v, e), (v', e')) =
156 (coerce {from = v, to = v'}
159 case (value from, value to) of
160 (Array _, Array _) => unify (from, to)
161 | (Ground from, Ground to) => Useful.<= (to, from)
162 | (Ref _, Ref _) => unify (from, to)
163 | (Tuple vs, Tuple vs') =>
164 Vector.foreach2 (vs, vs', coerceSlot)
165 | (Vector {length = n, elt = e},
166 Vector {length = n', elt = e'}) =>
167 (coerce {from = n, to = n'}
168 ; coerceSlot (e, e'))
169 | (Weak _, Weak _) => unify (from, to)
170 | _ => Error.bug "Useless.Value.coerce: strange"
174 Trace.trace ("Useless.Value.coerce",
175 fn {from, to} => let open Layout
176 in record [("from", layout from),
182 fun coerces {from, to} =
183 Vector.foreach2 (from, to, fn (from, to) =>
184 coerce {from = from, to = to})
186 fun foreach (v: t, f: Useful.t -> unit): unit =
188 fun loop (v: t): unit =
190 Array {length, elt, useful} =>
191 (f useful; loop length; slot elt)
193 | Tuple vs => Vector.foreach (vs, slot)
194 | Ref {arg, useful} => (f useful; slot arg)
195 | Vector {length, elt} => (loop length; slot elt)
196 | Weak {arg, useful} => (f useful; slot arg)
197 and slot (v, _) = loop v
202 (* Coerce every ground value in v to u. *)
203 fun deepCoerce (v: t, u: Useful.t): unit =
204 foreach (v, fn u' => Useful.<= (u', u))
207 Trace.trace2 ("Useless.deepCoerce", layout, Useful.layout, Unit.layout)
210 fun deground (v: t): Useful.t =
213 | _ => Error.bug "Useless.deground"
215 fun someUseful (v: t): Useful.t option =
217 Array {useful = u, ...} => SOME u
219 | Ref {useful = u, ...} => SOME u
220 | Tuple slots => Vector.peekMap (slots, someUseful o #1)
221 | Vector {length, ...} => SOME (deground length)
222 | Weak {useful = u, ...} => SOME u
224 fun allOrNothing (v: t): Useful.t option =
227 | SOME u => (foreach (v, fn u' => Useful.== (u, u'))
230 fun fromType (t: Type.t): t =
232 fun loop (t: Type.t, es: Exists.t list): t =
235 let val u = Useful.new ()
237 (u, fn () => List.foreach (es, Exists.mustExist))
241 let val e = Exists.new ()
242 in (loop (t, e :: es), e)
244 val loop = fn t => loop (t, es)
248 let val elt as (_, e) = slot t
249 val length = loop (Type.word (WordSize.seqIndex ()))
251 (e, fn () => Useful.makeUseful (deground length))
252 ; Array {useful = useful (),
256 | Type.Ref t => Ref {arg = slot t,
258 | Type.Tuple ts => Tuple (Vector.map (ts, slot))
260 Vector {length = loop (Type.word (WordSize.seqIndex ())),
262 | Type.Weak t => Weak {arg = slot t,
264 | _ => Ground (useful ())
266 T (Set.singleton {ty = t,
274 fun const (c: Const.t): t =
276 val v = fromType (Type.ofConst c)
277 (* allOrNothing v because constants are not transformed and their
278 * type cannot change. So they must either be completely eliminated
279 * or completely kept.
281 val _ = allOrNothing v
286 fun detupleSlots (v: t): slot vector =
289 | _ => Error.bug "Useless.detupleSlots"
290 fun detuple v = Vector.map (detupleSlots v, #1)
291 fun tuple (vs: t vector): t =
293 val t = Type.tuple (Vector.map (vs, ty))
296 Vector.foreach2 (vs, detuple v, fn (v, v') =>
297 coerce {from = v, to = v'})
301 fun select {tuple, offset, resultType} =
303 val v = fromType resultType
304 val _ = coerce {from = Vector.sub (detuple tuple, offset), to = v}
309 fun make (err, sel) v =
314 val devector = make ("Useless.devector", #1 o #elt)
315 val vectorLength = make ("Useless.vectorLength", #length)
318 fun make (err, sel) v =
323 val dearray: t -> t = make ("Useless.dearray", #1 o #elt)
324 val arrayLength = make ("Useless.arrayLength", #length)
327 fun deref (r: t): t =
329 Ref {arg, ...} => #1 arg
330 | _ => Error.bug "Useless.deref"
332 fun deweak (v: t): t =
334 Weak {arg, ...} => #1 arg
335 | _ => Error.bug "Useless.deweak"
337 fun newType (v: t): Type.t = #1 (getNew v)
338 and isUseful (v: t): bool = #2 (getNew v)
339 and getNew (T s): Type.t * bool =
341 val {value, ty, new, ...} = Set.! s
346 fun slot (arg: t, e: Exists.t) =
347 let val (t, b) = getNew arg
348 in (if Exists.doesExist e then t else Type.unit, b)
350 fun wrap ((t, b), f) = (f t, b)
351 fun or ((t, b), b') = (t, b orelse b')
352 fun maybe (u: Useful.t, s: slot, make: Type.t -> Type.t) =
353 wrap (or (slot s, Useful.isUseful u), make)
356 Array {useful, elt, length, ...} =>
357 or (wrap (slot elt, Type.array),
358 Useful.isUseful useful orelse isUseful length)
359 | Ground u => (ty, Useful.isUseful u)
360 | Ref {arg, useful, ...} =>
361 maybe (useful, arg, Type.reff)
366 (vs, false, fn ((v, e), useful) =>
368 val (t, u) = getNew v
370 if Exists.doesExist e
373 in (t, u orelse useful)
375 val v = Vector.keepAllMap (v, fn t => t)
379 | Vector {elt, length, ...} =>
380 or (wrap (slot elt, Type.vector), isUseful length)
381 | Weak {arg, useful} =>
382 maybe (useful, arg, Type.weak)
387 Trace.trace ("Useless.getNew", layout, Layout.tuple2 (Type.layout, Bool.layout))
390 val isUseful = Trace.trace ("Useless.isUseful", layout, Bool.layout) isUseful
392 val newType = Trace.trace ("Useless.newType", layout, Type.layout) newType
394 fun newTypes (vs: t vector): Type.t vector =
395 Vector.keepAllMap (vs, fn v =>
396 let val (t, b) = getNew v
397 in if b then SOME t else NONE
401 structure Exists = Value.Exists
403 fun transform (program: Program.t): Program.t =
405 val program as Program.T {datatypes, globals, functions, main} =
406 eliminateDeadBlocks program
407 val {get = conInfo: Con.t -> {args: Value.t vector,
408 argTypes: Type.t vector,
409 value: unit -> Value.t},
410 set = setConInfo, ...} =
412 (Con.plist, Property.initRaise ("conInfo", Con.layout))
413 val {get = tyconInfo: Tycon.t -> {useful: bool ref,
415 set = setTyconInfo, ...} =
417 (Tycon.plist, Property.initRaise ("tyconInfo", Tycon.layout))
422 (datatypes, fn Datatype.T {tycon, cons} =>
425 setTyconInfo (tycon, {useful = ref false,
426 cons = Vector.map (cons, #con)})
427 fun value () = fromType (Type.datatypee tycon)
429 (cons, fn {con, args} =>
430 setConInfo (con, {value = value,
432 args = Vector.map (args, fromType)}))
434 val conArgs = #args o conInfo
435 fun conApp {con: Con.t,
436 args: Value.t vector} =
437 let val {args = args', value, ...} = conInfo con
438 in coerces {from = args, to = args'}
441 fun filter (v: Value.t, con: Con.t, to: Value.t vector): unit =
445 ; coerces {from = conArgs con, to = to})
446 | _ => Error.bug "Useless.filter: non ground"
447 fun filterGround (v: Value.t): unit =
449 Ground g => Useful.makeUseful g
450 | _ => Error.bug "Useless.filterGround: non ground"
452 Trace.trace3 ("Useless.filter",
455 Vector.layout Value.layout,
458 (* This is used for primitive args, since we have no idea what
459 * components of its args that a primitive will look at.
461 fun deepMakeUseful v =
463 val slot = deepMakeUseful o #1
466 Array {useful, length, elt} =>
467 (Useful.makeUseful useful
468 ; deepMakeUseful length
472 (* Make all constructor args of this tycon useful *)
473 ; (case Type.dest (ty v) of
474 Type.Datatype tycon =>
475 let val {useful, cons} = tyconInfo tycon
479 ; Vector.foreach (cons, fn con =>
481 (#args (conInfo con),
485 | Ref {arg, useful} => (Useful.makeUseful useful; slot arg)
486 | Tuple vs => Vector.foreach (vs, slot)
487 | Vector {length, elt} => (deepMakeUseful length; slot elt)
488 | Weak {arg, useful} => (Useful.makeUseful useful; slot arg)
491 fun primApp {args: t vector, prim, resultVar = _, resultType,
494 val result = fromType resultType
495 fun return v = coerce {from = v, to = result}
497 fun v1 dependsOn v2 = deepCoerce (v2, deground v1)
498 fun arg i = Vector.sub (args, i)
500 (arg 1 dependsOn result
501 ; return (dearray (arg 0)))
504 val a = dearray (arg 0)
506 ; coerce {from = arg 2, to = a}
508 datatype z = datatype Prim.Name.t
510 case Prim.name prim of
512 coerce {from = arg 0, to = arrayLength result}
515 val a = dearray (arg 0)
520 ; case (value (arg 0), value (arg 2)) of
521 (Array {elt = e, ...}, Array {elt = e', ...}) =>
523 | _ => Error.bug "Useless.primApp: Array_copyArray"
525 | Array_copyVector =>
527 val a = dearray (arg 0)
532 ; case (value (arg 0), value (arg 2)) of
533 (Array {elt = e, ...}, Vector {elt = e', ...}) =>
535 | _ => Error.bug "Useless.primApp: Array_copyVector"
537 | Array_length => return (arrayLength (arg 0))
538 | Array_sub => sub ()
540 (case (value (arg 0), value result) of
541 (Array {length = l, elt = e, ...},
542 Array {length = l', elt = e', ...}) =>
543 (unify (l, l'); unifySlot (e, e'))
544 | _ => Error.bug "Useless.primApp: Array_toArray")
546 (case (value (arg 0), value result) of
547 (Array {length = l, elt = e, ...},
548 Vector {length = l', elt = e', ...}) =>
549 (unify (l, l'); unifySlot (e, e'))
550 | _ => Error.bug "Useless.primApp: Array_toVector")
553 val a = dearray (arg 0)
557 | Array_uninitIsNop =>
558 (* Array_uninitIsNop is Functional, but
559 * performing Useless.<= (allOrNothing result,
560 * allOrNothing (arg 0)) would effectively
561 * make the whole array useful, inhibiting the
562 * Useless optimization.
565 | Array_update => update ()
567 (Vector.foreach (args, deepMakeUseful);
568 deepMakeUseful result)
569 | MLton_equal => Vector.foreach (args, deepMakeUseful)
570 | MLton_hash => Vector.foreach (args, deepMakeUseful)
571 | Ref_assign => coerce {from = arg 1, to = deref (arg 0)}
572 | Ref_deref => return (deref (arg 0))
573 | Ref_ref => coerce {from = arg 0, to = deref result}
574 | Vector_length => return (vectorLength (arg 0))
575 | Vector_sub => (arg 1 dependsOn result
576 ; return (devector (arg 0)))
580 (const o S.Const.word o WordX.fromIntInf)
581 (IntInf.fromInt (Vector.length args),
582 WordSize.seqIndex ())
584 (coerce {from = l, to = vectorLength result}
587 coerce {from = arg, to = devector result}))
589 | Weak_get => return (deweak (arg 0))
590 | Weak_new => coerce {from = arg 0, to = deweak result}
591 | WordArray_subWord _ => sub ()
592 | WordArray_updateWord _ => update ()
594 let (* allOrNothing so the type doesn't change *)
595 val res = allOrNothing result
596 in if Prim.maySideEffect prim
597 then Vector.foreach (args, deepMakeUseful)
599 Vector.foreach (args, fn a =>
600 case (allOrNothing a, res) of
602 | (SOME u, SOME u') =>
612 fn {prim, args, ...} =>
613 Layout.seq [Prim.layout prim,
614 Vector.layout layout args],
618 val {value, func, label, ...} =
620 coerce = Value.coerce,
624 filterWord = filterGround o #1,
625 fromType = Value.fromType,
626 layout = Value.layout,
629 select = Value.select,
631 useFromTypeOnBinds = true
634 (* Unify all handler args so that raise/handle has a consistent calling
641 val {raises = fraisevs, ...} = func (Function.name f)
642 fun coerce (x, y) = Value.coerce {from = x, to = y}
645 (Function.blocks f, fn Block.T {transfer, ...} =>
647 Call {func = g, return, ...} =>
649 val {raises = graisevs, ...} = func g
651 case (graisevs, fraisevs) of
653 | (NONE, SOME _) => ()
655 Error.bug "Useless.useless: raise mismatch at Caller"
656 | (SOME vs, SOME vs') =>
657 Vector.foreach2 (vs', vs, coerce)
661 | Return.NonTail {handler, ...} =>
663 Handler.Caller => coerceRaise ()
665 | Handler.Handle h =>
667 (graisevs, fn graisevs =>
669 (label h, graisevs, coerce)))
670 | Return.Tail => coerceRaise ()
681 (datatypes, fn Datatype.T {tycon, cons} =>
685 indent (Vector.layout
687 seq [Con.layout con, str " ",
688 Vector.layout Value.layout (conArgs con)])
695 val {name, ...} = Function.dest f
696 val _ = display (seq [str "Useless info for ",
698 val {args, returns, raises} = func name
701 (record [("args", Vector.layout Value.layout args),
703 Option.layout (Vector.layout Value.layout)
706 Option.layout (Vector.layout Value.layout)
711 display (seq [Var.layout x,
712 str " ", Value.layout (value x)]))
719 val varExists = Value.isUseful o value
720 val unitVar = Var.newString "unit"
721 val bogusGlobals: Statement.t list ref = ref []
722 val {get = bogus, destroy, ...} =
727 let val var = Var.newString "bogus"
728 in List.push (bogusGlobals,
732 exp = PrimApp {prim = Prim.bogus,
733 targs = Vector.new1 ty,
734 args = Vector.new0 ()}})
737 fun keepUseful (xs: Var.t vector, vs: Value.t vector): Var.t vector =
739 (xs, vs, fn (x, v) =>
740 let val (t, b) = Value.getNew v
742 then SOME (if varExists x then x else bogus t)
745 fun keepUsefulArgs (xts: (Var.t * Type.t) vector) =
748 let val (t, b) = Value.getNew (value x)
754 Trace.trace ("Useless.keepUsefulArgs",
755 Vector.layout (Layout.tuple2 (Var.layout, Type.layout)),
756 Vector.layout (Layout.tuple2 (Var.layout, Type.layout)))
758 fun dropUseless (vs: Value.t vector,
760 makeTrans: Var.t vector -> Transfer.t): Label.t * Block.t =
762 val l = Label.newNoname ()
763 val (formals, actuals) =
766 (vs, vs', fn (v, v') =>
768 then let val x = Var.newNoname ()
769 in (SOME (x, Value.newType v),
775 in (l, Block.T {label = l,
776 args = Vector.keepAllSome formals,
777 statements = Vector.new0 (),
778 transfer = makeTrans (Vector.keepAllSome actuals)})
780 (* Returns true if the component is the only component of the tuple
783 fun newOffset (bs: bool vector, n: int): int * bool =
785 val len = Vector.length bs
786 fun loop (pos, n, i) =
787 let val b = Vector.sub (bs, pos)
790 andalso not (Int.exists (pos + 1, len, fn i =>
791 Vector.sub (bs, i)))))
792 else loop (pos + 1, n - 1, if b then i + 1 else i)
797 fun doitExp (e: Exp.t, resultType: Type.t, resultValue: Value.t option) =
799 ConApp {con, args} =>
801 args = keepUseful (args, conArgs con)}
803 | PrimApp {prim, args, ...} =>
807 val (args, argTypes) =
809 (Vector.map (args, fn x =>
811 val (t, b) = Value.getNew (value x)
815 else (unitVar, Type.unit)
821 targs = (Prim.extractTargs
825 typeOps = {deArray = Type.deArray,
826 deArrow = fn _ => Error.bug "Useless.doitExp: deArrow",
828 deVector = Type.deVector,
829 deWeak = Type.deWeak}}))}
831 datatype z = datatype Prim.Name.t
833 case Prim.name prim of
835 if varExists (Vector.sub (args, 0))
837 else ConApp {args = Vector.new0 (),
841 | Select {tuple, offset} =>
843 val (offset, isOne) =
844 newOffset (Vector.map (Value.detupleSlots (value tuple),
845 Exists.doesExist o #2),
849 else Select {tuple = tuple,
854 val slots = Value.detupleSlots (valOf resultValue)
857 (xs, slots, fn (x, (v, e)) =>
858 if Exists.doesExist e
859 then SOME (if varExists x then x
860 else bogus (Value.newType v))
863 if 1 = Vector.length xs
864 then Var (Vector.first xs)
870 Trace.trace3 ("Useless.doitExp",
871 Exp.layout, Layout.ignore, Layout.ignore,
874 fun doitStatement (Statement.T {var, exp, ty}) =
876 val v = Option.map (var, value)
880 | SOME v => Value.getNew v
885 exp = doitExp (exp, ty, v)})
891 PrimApp {prim, args, ...} =>
892 if Prim.maySideEffect prim
894 fun arg i = Vector.sub (args, i)
897 (Value.dearray (value (arg 0)))
898 datatype z = datatype Prim.Name.t
900 case Prim.name prim of
901 Array_copyArray => array ()
902 | Array_copyVector => array ()
903 | Array_uninit => array ()
904 | Array_update => array ()
907 (Value.deref (value (arg 0)))
908 | WordArray_updateWord _ => array ()
913 | Profile _ => yes ty
917 Trace.trace ("Useless.doitStatement",
918 Statement.layout, Option.layout Statement.layout)
920 fun agree (v: Value.t, v': Value.t): bool =
921 Value.isUseful v = Value.isUseful v'
922 fun agrees (vs, vs') = Vector.forall2 (vs, vs', agree)
924 Trace.trace2 ("Useless.agrees",
925 Vector.layout Value.layout,
926 Vector.layout Value.layout,
929 fun doitTransfer (t: Transfer.t,
930 returns: Value.t vector option,
931 raises: Value.t vector option)
932 : Block.t list * Transfer.t =
934 Arith {prim, args, overflow, success, ty} =>
936 val v = Value.fromType ty
937 val _ = Value.Useful.makeUseful (Value.deground v)
938 val res = Vector.new1 v
939 val sargs = label success
941 if agree (v, Vector.first sargs)
944 val (l, b) = dropUseless
945 (res, sargs, fn args =>
946 Goto {dst = success, args = args})
957 | Call {func = f, args, return} =>
959 val {args = fargs, returns = freturns, ...} = func f
960 val (blocks, return) =
962 Return.Dead => ([], return)
964 (case (returns, freturns) of
965 (NONE, NONE) => ([], Return.Tail)
966 | (NONE, SOME _) => Error.bug "Useless.doitTransfer: return mismatch"
967 | (SOME _, NONE) => ([], Return.Tail)
968 | (SOME returns, SOME freturns) =>
969 if agrees (freturns, returns)
970 then ([], Return.Tail)
975 (freturns, returns, Return)
979 handler = Handler.Caller})
981 | Return.NonTail {cont, handler} =>
985 let val returns = label cont
986 in if agrees (freturns, returns)
991 (freturns, returns, fn args =>
992 Goto {dst = cont, args = args})
995 {cont = l, handler = handler})
1000 args = keepUseful (args, fargs),
1003 | Case {test, cases, default} =>
1005 datatype z = datatype Cases.t
1009 (case (Vector.length cases, default) of
1010 (0, NONE) => ([], Bug)
1013 val (cases, blocks) =
1015 (cases, [], fn ((c, l), blocks) =>
1018 in if Vector.forall (args, Value.isUseful)
1019 then ((c, l), blocks)
1024 (conArgs c, args, fn args =>
1025 Goto {dst = l, args = args})
1026 in ((c, l'), b :: blocks)
1031 cases = Cases.Con cases,
1035 (* The test may be useless if there are no cases or
1036 * default, thus we must eliminate the case.
1038 case (Vector.length cs, default) of
1039 (0, NONE) => ([], Bug)
1042 | Goto {dst, args} =>
1043 ([], Goto {dst = dst, args = keepUseful (args, label dst)})
1044 | Raise xs => ([], Raise (keepUseful (xs, valOf raises)))
1045 | Return xs => ([], Return (keepUseful (xs, valOf returns)))
1046 | Runtime {prim, args, return} =>
1047 ([], Runtime {prim = prim, args = args, return = return})
1049 Trace.trace3 ("Useless.doitTransfer",
1051 Option.layout (Vector.layout Value.layout),
1052 Option.layout (Vector.layout Value.layout),
1053 Layout.tuple2 (List.layout (Label.layout o Block.label),
1056 fun doitBlock (Block.T {label, args, statements, transfer},
1057 returns: Value.t vector option,
1058 raises: Value.t vector option)
1059 : Block.t list * Block.t =
1061 val args = keepUsefulArgs args
1062 val statements = Vector.keepAllMap (statements, doitStatement)
1063 val (blocks, transfer) = doitTransfer (transfer, returns, raises)
1065 (blocks, Block.T {label = label,
1067 statements = statements,
1068 transfer = transfer})
1071 Trace.trace3 ("Useless.doitBlock",
1072 Label.layout o Block.label,
1073 Option.layout (Vector.layout Value.layout),
1074 Option.layout (Vector.layout Value.layout),
1075 Layout.tuple2 (List.layout (Label.layout o Block.label),
1076 (Label.layout o Block.label)))
1078 fun doitFunction f =
1080 val {args, blocks, mayInline, name, start, ...} = Function.dest f
1081 val {returns = returnvs, raises = raisevs, ...} = func name
1082 val args = keepUsefulArgs args
1083 val (blocks, blocks') =
1085 (blocks, [], fn (block, blocks') =>
1086 let val (blocks'', block) = doitBlock (block, returnvs, raisevs)
1087 in (block, blocks''::blocks')
1090 Vector.concat (blocks :: List.map (blocks', Vector.fromList))
1091 val returns = Option.map (returnvs, Value.newTypes)
1092 val raises = Option.map (raisevs, Value.newTypes)
1094 Function.new {args = args,
1096 mayInline = mayInline,
1104 (datatypes, fn Datatype.T {tycon, cons} =>
1105 Datatype.T {tycon = tycon,
1106 cons = Vector.map (cons, fn {con, ...} =>
1108 args = Value.newTypes (conArgs con)})})
1111 [Vector.new1 (Statement.T {var = SOME unitVar,
1114 Vector.keepAllMap (globals, doitStatement)]
1115 val shrink = shrinkFunction {globals = globals}
1116 val functions = List.map (functions, shrink o doitFunction)
1117 val globals = Vector.concat [Vector.fromList (!bogusGlobals),
1119 val program = Program.T {datatypes = datatypes,
1121 functions = functions,
1124 val _ = Program.clearTop program