Commit | Line | Data |
---|---|---|
7f918cf1 CE |
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. | |
5 | * | |
6 | * MLton is released under a BSD-style license. | |
7 | * See the file MLton-LICENSE for details. | |
8 | *) | |
9 | ||
10 | functor Useless (S: SSA_TRANSFORM_STRUCTS): SSA_TRANSFORM = | |
11 | struct | |
12 | ||
13 | open S | |
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 | |
22 | * | |
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. | |
26 | * | |
27 | * It is also trivial to convert a useful tuple to one of its | |
28 | * useful components -- but this seems hard | |
29 | *) | |
30 | ||
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. | |
34 | *) | |
35 | ||
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 | |
44 | * do | |
45 | * Another solution would be to unify all handler args. | |
46 | *) | |
47 | ||
48 | structure Value = | |
49 | struct | |
50 | structure Set = DisjointSet | |
51 | ||
52 | structure Exists = | |
53 | struct | |
54 | structure L = TwoPointLattice (val bottom = "not exists" | |
55 | val top = "exists") | |
56 | open L | |
57 | val mustExist = makeTop | |
58 | val doesExist = isTop | |
59 | end | |
60 | ||
61 | structure Useful = | |
62 | struct | |
63 | structure L = TwoPointLattice (val bottom = "useless" | |
64 | val top = "useful") | |
65 | open L | |
66 | val makeUseful = makeTop | |
67 | val isUseful = isTop | |
68 | end | |
69 | ||
70 | datatype t = | |
71 | T of {new: (Type.t * bool) option ref, | |
72 | ty: Type.t, | |
73 | value: value} Set.t | |
74 | and value = | |
75 | Array of {elt: slot, | |
76 | length: t, | |
77 | useful: Useful.t} | |
78 | | Ground of Useful.t | |
79 | | Ref of {arg: slot, | |
80 | useful: Useful.t} | |
81 | | Tuple of slot vector | |
82 | | Vector of {elt: slot, | |
83 | length: t} | |
84 | | Weak of {arg: slot, | |
85 | useful: Useful.t} | |
86 | withtype slot = t * Exists.t | |
87 | ||
88 | local | |
89 | fun make sel (T s) = sel (Set.! s) | |
90 | in | |
91 | val value = make #value | |
92 | val ty = make #ty | |
93 | end | |
94 | ||
95 | local | |
96 | open Layout | |
97 | in | |
98 | fun layout (T s) = | |
99 | let | |
100 | val {value, ...} = Set.! s | |
101 | in | |
102 | case value of | |
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, ...} => | |
107 | seq [str "ref ", | |
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} => | |
114 | seq [str "weak ", | |
115 | record [("useful", Useful.layout useful), | |
116 | ("slot", layoutSlot arg)]] | |
117 | end | |
118 | and layoutSlot (v, e) = | |
119 | tuple [Exists.layout e, layout v] | |
120 | end | |
121 | ||
122 | fun unify (T s, T s') = | |
123 | if Set.equals (s, s') | |
124 | then () | |
125 | else | |
126 | let | |
127 | val {value = v, ...} = Set.! s | |
128 | val {value = v', ...} = Set.! s' | |
129 | val _ = Set.union (s, s') | |
130 | in | |
131 | case (v, v') of | |
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" | |
147 | end | |
148 | and unifySlot ((v, e), (v', e')) = (unify (v, v'); Exists.== (e, e')) | |
149 | ||
150 | fun coerce {from = from as T sfrom, to = to as T sto}: unit = | |
151 | if Set.equals (sfrom, sto) | |
152 | then () | |
153 | else | |
154 | let | |
155 | fun coerceSlot ((v, e), (v', e')) = | |
156 | (coerce {from = v, to = v'} | |
157 | ; Exists.== (e, e')) | |
158 | in | |
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" | |
171 | end | |
172 | ||
173 | val coerce = | |
174 | Trace.trace ("Useless.Value.coerce", | |
175 | fn {from, to} => let open Layout | |
176 | in record [("from", layout from), | |
177 | ("to", layout to)] | |
178 | end, | |
179 | Unit.layout) | |
180 | coerce | |
181 | ||
182 | fun coerces {from, to} = | |
183 | Vector.foreach2 (from, to, fn (from, to) => | |
184 | coerce {from = from, to = to}) | |
185 | ||
186 | fun foreach (v: t, f: Useful.t -> unit): unit = | |
187 | let | |
188 | fun loop (v: t): unit = | |
189 | case value v of | |
190 | Array {length, elt, useful} => | |
191 | (f useful; loop length; slot elt) | |
192 | | Ground u => f u | |
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 | |
198 | in | |
199 | loop v | |
200 | end | |
201 | ||
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)) | |
205 | ||
206 | val deepCoerce = | |
207 | Trace.trace2 ("Useless.deepCoerce", layout, Useful.layout, Unit.layout) | |
208 | deepCoerce | |
209 | ||
210 | fun deground (v: t): Useful.t = | |
211 | case value v of | |
212 | Ground g => g | |
213 | | _ => Error.bug "Useless.deground" | |
214 | ||
215 | fun someUseful (v: t): Useful.t option = | |
216 | case value v of | |
217 | Array {useful = u, ...} => SOME u | |
218 | | Ground 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 | |
223 | ||
224 | fun allOrNothing (v: t): Useful.t option = | |
225 | case someUseful v of | |
226 | NONE => NONE | |
227 | | SOME u => (foreach (v, fn u' => Useful.== (u, u')) | |
228 | ; SOME u) | |
229 | ||
230 | fun fromType (t: Type.t): t = | |
231 | let | |
232 | fun loop (t: Type.t, es: Exists.t list): t = | |
233 | let | |
234 | fun useful () = | |
235 | let val u = Useful.new () | |
236 | in Useful.addHandler | |
237 | (u, fn () => List.foreach (es, Exists.mustExist)) | |
238 | ; u | |
239 | end | |
240 | fun slot t = | |
241 | let val e = Exists.new () | |
242 | in (loop (t, e :: es), e) | |
243 | end | |
244 | val loop = fn t => loop (t, es) | |
245 | val value = | |
246 | case Type.dest t of | |
247 | Type.Array t => | |
248 | let val elt as (_, e) = slot t | |
249 | val length = loop (Type.word (WordSize.seqIndex ())) | |
250 | in Exists.addHandler | |
251 | (e, fn () => Useful.makeUseful (deground length)) | |
252 | ; Array {useful = useful (), | |
253 | length = length, | |
254 | elt = elt} | |
255 | end | |
256 | | Type.Ref t => Ref {arg = slot t, | |
257 | useful = useful ()} | |
258 | | Type.Tuple ts => Tuple (Vector.map (ts, slot)) | |
259 | | Type.Vector t => | |
260 | Vector {length = loop (Type.word (WordSize.seqIndex ())), | |
261 | elt = slot t} | |
262 | | Type.Weak t => Weak {arg = slot t, | |
263 | useful = useful ()} | |
264 | | _ => Ground (useful ()) | |
265 | in | |
266 | T (Set.singleton {ty = t, | |
267 | new = ref NONE, | |
268 | value = value}) | |
269 | end | |
270 | in | |
271 | loop (t, []) | |
272 | end | |
273 | ||
274 | fun const (c: Const.t): t = | |
275 | let | |
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. | |
280 | *) | |
281 | val _ = allOrNothing v | |
282 | in | |
283 | v | |
284 | end | |
285 | ||
286 | fun detupleSlots (v: t): slot vector = | |
287 | case value v of | |
288 | Tuple ss => ss | |
289 | | _ => Error.bug "Useless.detupleSlots" | |
290 | fun detuple v = Vector.map (detupleSlots v, #1) | |
291 | fun tuple (vs: t vector): t = | |
292 | let | |
293 | val t = Type.tuple (Vector.map (vs, ty)) | |
294 | val v = fromType t | |
295 | val _ = | |
296 | Vector.foreach2 (vs, detuple v, fn (v, v') => | |
297 | coerce {from = v, to = v'}) | |
298 | in | |
299 | v | |
300 | end | |
301 | fun select {tuple, offset, resultType} = | |
302 | let | |
303 | val v = fromType resultType | |
304 | val _ = coerce {from = Vector.sub (detuple tuple, offset), to = v} | |
305 | in | |
306 | v | |
307 | end | |
308 | local | |
309 | fun make (err, sel) v = | |
310 | case value v of | |
311 | Vector fs => sel fs | |
312 | | _ => Error.bug err | |
313 | in | |
314 | val devector = make ("Useless.devector", #1 o #elt) | |
315 | val vectorLength = make ("Useless.vectorLength", #length) | |
316 | end | |
317 | local | |
318 | fun make (err, sel) v = | |
319 | case value v of | |
320 | Array fs => sel fs | |
321 | | _ => Error.bug err | |
322 | in | |
323 | val dearray: t -> t = make ("Useless.dearray", #1 o #elt) | |
324 | val arrayLength = make ("Useless.arrayLength", #length) | |
325 | end | |
326 | ||
327 | fun deref (r: t): t = | |
328 | case value r of | |
329 | Ref {arg, ...} => #1 arg | |
330 | | _ => Error.bug "Useless.deref" | |
331 | ||
332 | fun deweak (v: t): t = | |
333 | case value v of | |
334 | Weak {arg, ...} => #1 arg | |
335 | | _ => Error.bug "Useless.deweak" | |
336 | ||
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 = | |
340 | let | |
341 | val {value, ty, new, ...} = Set.! s | |
342 | in | |
343 | Ref.memoize | |
344 | (new, fn () => | |
345 | let | |
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) | |
349 | end | |
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) | |
354 | in | |
355 | case value of | |
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) | |
362 | | Tuple vs => | |
363 | let | |
364 | val (v, b) = | |
365 | Vector.mapAndFold | |
366 | (vs, false, fn ((v, e), useful) => | |
367 | let | |
368 | val (t, u) = getNew v | |
369 | val t = | |
370 | if Exists.doesExist e | |
371 | then SOME t | |
372 | else NONE | |
373 | in (t, u orelse useful) | |
374 | end) | |
375 | val v = Vector.keepAllMap (v, fn t => t) | |
376 | in | |
377 | (Type.tuple v, b) | |
378 | end | |
379 | | Vector {elt, length, ...} => | |
380 | or (wrap (slot elt, Type.vector), isUseful length) | |
381 | | Weak {arg, useful} => | |
382 | maybe (useful, arg, Type.weak) | |
383 | end) | |
384 | end | |
385 | ||
386 | val getNew = | |
387 | Trace.trace ("Useless.getNew", layout, Layout.tuple2 (Type.layout, Bool.layout)) | |
388 | getNew | |
389 | ||
390 | val isUseful = Trace.trace ("Useless.isUseful", layout, Bool.layout) isUseful | |
391 | ||
392 | val newType = Trace.trace ("Useless.newType", layout, Type.layout) newType | |
393 | ||
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 | |
398 | end) | |
399 | end | |
400 | ||
401 | structure Exists = Value.Exists | |
402 | ||
403 | fun transform (program: Program.t): Program.t = | |
404 | let | |
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, ...} = | |
411 | Property.getSetOnce | |
412 | (Con.plist, Property.initRaise ("conInfo", Con.layout)) | |
413 | val {get = tyconInfo: Tycon.t -> {useful: bool ref, | |
414 | cons: Con.t vector}, | |
415 | set = setTyconInfo, ...} = | |
416 | Property.getSetOnce | |
417 | (Tycon.plist, Property.initRaise ("tyconInfo", Tycon.layout)) | |
418 | local open Value | |
419 | in | |
420 | val _ = | |
421 | Vector.foreach | |
422 | (datatypes, fn Datatype.T {tycon, cons} => | |
423 | let | |
424 | val _ = | |
425 | setTyconInfo (tycon, {useful = ref false, | |
426 | cons = Vector.map (cons, #con)}) | |
427 | fun value () = fromType (Type.datatypee tycon) | |
428 | in Vector.foreach | |
429 | (cons, fn {con, args} => | |
430 | setConInfo (con, {value = value, | |
431 | argTypes = args, | |
432 | args = Vector.map (args, fromType)})) | |
433 | end) | |
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'} | |
439 | ; value () | |
440 | end | |
441 | fun filter (v: Value.t, con: Con.t, to: Value.t vector): unit = | |
442 | case value v of | |
443 | Ground g => | |
444 | (Useful.makeUseful g | |
445 | ; coerces {from = conArgs con, to = to}) | |
446 | | _ => Error.bug "Useless.filter: non ground" | |
447 | fun filterGround (v: Value.t): unit = | |
448 | case value v of | |
449 | Ground g => Useful.makeUseful g | |
450 | | _ => Error.bug "Useless.filterGround: non ground" | |
451 | val filter = | |
452 | Trace.trace3 ("Useless.filter", | |
453 | Value.layout, | |
454 | Con.layout, | |
455 | Vector.layout Value.layout, | |
456 | Unit.layout) | |
457 | filter | |
458 | (* This is used for primitive args, since we have no idea what | |
459 | * components of its args that a primitive will look at. | |
460 | *) | |
461 | fun deepMakeUseful v = | |
462 | let | |
463 | val slot = deepMakeUseful o #1 | |
464 | in | |
465 | case value v of | |
466 | Array {useful, length, elt} => | |
467 | (Useful.makeUseful useful | |
468 | ; deepMakeUseful length | |
469 | ; slot elt) | |
470 | | Ground u => | |
471 | (Useful.makeUseful u | |
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 | |
476 | in if !useful | |
477 | then () | |
478 | else (useful := true | |
479 | ; Vector.foreach (cons, fn con => | |
480 | Vector.foreach | |
481 | (#args (conInfo con), | |
482 | deepMakeUseful))) | |
483 | end | |
484 | | _ => ())) | |
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) | |
489 | end | |
490 | ||
491 | fun primApp {args: t vector, prim, resultVar = _, resultType, | |
492 | targs = _} = | |
493 | let | |
494 | val result = fromType resultType | |
495 | fun return v = coerce {from = v, to = result} | |
496 | infix dependsOn | |
497 | fun v1 dependsOn v2 = deepCoerce (v2, deground v1) | |
498 | fun arg i = Vector.sub (args, i) | |
499 | fun sub () = | |
500 | (arg 1 dependsOn result | |
501 | ; return (dearray (arg 0))) | |
502 | fun update () = | |
503 | let | |
504 | val a = dearray (arg 0) | |
505 | in arg 1 dependsOn a | |
506 | ; coerce {from = arg 2, to = a} | |
507 | end | |
508 | datatype z = datatype Prim.Name.t | |
509 | val _ = | |
510 | case Prim.name prim of | |
511 | Array_alloc _ => | |
512 | coerce {from = arg 0, to = arrayLength result} | |
513 | | Array_copyArray => | |
514 | let | |
515 | val a = dearray (arg 0) | |
516 | in | |
517 | arg 1 dependsOn a | |
518 | ; arg 3 dependsOn a | |
519 | ; arg 4 dependsOn a | |
520 | ; case (value (arg 0), value (arg 2)) of | |
521 | (Array {elt = e, ...}, Array {elt = e', ...}) => | |
522 | unifySlot (e, e') | |
523 | | _ => Error.bug "Useless.primApp: Array_copyArray" | |
524 | end | |
525 | | Array_copyVector => | |
526 | let | |
527 | val a = dearray (arg 0) | |
528 | in | |
529 | arg 1 dependsOn a | |
530 | ; arg 3 dependsOn a | |
531 | ; arg 4 dependsOn a | |
532 | ; case (value (arg 0), value (arg 2)) of | |
533 | (Array {elt = e, ...}, Vector {elt = e', ...}) => | |
534 | unifySlot (e, e') | |
535 | | _ => Error.bug "Useless.primApp: Array_copyVector" | |
536 | end | |
537 | | Array_length => return (arrayLength (arg 0)) | |
538 | | Array_sub => sub () | |
539 | | Array_toArray => | |
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") | |
545 | | Array_toVector => | |
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") | |
551 | | Array_uninit => | |
552 | let | |
553 | val a = dearray (arg 0) | |
554 | in | |
555 | arg 1 dependsOn a | |
556 | end | |
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. | |
563 | *) | |
564 | () | |
565 | | Array_update => update () | |
566 | | FFI _ => | |
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))) | |
577 | | Vector_vector => | |
578 | let | |
579 | val l = | |
580 | (const o S.Const.word o WordX.fromIntInf) | |
581 | (IntInf.fromInt (Vector.length args), | |
582 | WordSize.seqIndex ()) | |
583 | in | |
584 | (coerce {from = l, to = vectorLength result} | |
585 | ; Vector.foreach | |
586 | (args, fn arg => | |
587 | coerce {from = arg, to = devector result})) | |
588 | end | |
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 () | |
593 | | _ => | |
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) | |
598 | else | |
599 | Vector.foreach (args, fn a => | |
600 | case (allOrNothing a, res) of | |
601 | (NONE, _) => () | |
602 | | (SOME u, SOME u') => | |
603 | Useful.<= (u', u) | |
604 | | _ => ()) | |
605 | end | |
606 | in | |
607 | result | |
608 | end | |
609 | val primApp = | |
610 | Trace.trace | |
611 | ("Useless.primApp", | |
612 | fn {prim, args, ...} => | |
613 | Layout.seq [Prim.layout prim, | |
614 | Vector.layout layout args], | |
615 | layout) | |
616 | primApp | |
617 | end | |
618 | val {value, func, label, ...} = | |
619 | analyze { | |
620 | coerce = Value.coerce, | |
621 | conApp = conApp, | |
622 | const = Value.const, | |
623 | filter = filter, | |
624 | filterWord = filterGround o #1, | |
625 | fromType = Value.fromType, | |
626 | layout = Value.layout, | |
627 | primApp = primApp, | |
628 | program = program, | |
629 | select = Value.select, | |
630 | tuple = Value.tuple, | |
631 | useFromTypeOnBinds = true | |
632 | } | |
633 | open Exp Transfer | |
634 | (* Unify all handler args so that raise/handle has a consistent calling | |
635 | * convention. | |
636 | *) | |
637 | val _ = | |
638 | List.foreach | |
639 | (functions, fn f => | |
640 | let | |
641 | val {raises = fraisevs, ...} = func (Function.name f) | |
642 | fun coerce (x, y) = Value.coerce {from = x, to = y} | |
643 | in | |
644 | Vector.foreach | |
645 | (Function.blocks f, fn Block.T {transfer, ...} => | |
646 | case transfer of | |
647 | Call {func = g, return, ...} => | |
648 | let | |
649 | val {raises = graisevs, ...} = func g | |
650 | fun coerceRaise () = | |
651 | case (graisevs, fraisevs) of | |
652 | (NONE, NONE) => () | |
653 | | (NONE, SOME _) => () | |
654 | | (SOME _, NONE) => | |
655 | Error.bug "Useless.useless: raise mismatch at Caller" | |
656 | | (SOME vs, SOME vs') => | |
657 | Vector.foreach2 (vs', vs, coerce) | |
658 | in | |
659 | case return of | |
660 | Return.Dead => () | |
661 | | Return.NonTail {handler, ...} => | |
662 | (case handler of | |
663 | Handler.Caller => coerceRaise () | |
664 | | Handler.Dead => () | |
665 | | Handler.Handle h => | |
666 | Option.app | |
667 | (graisevs, fn graisevs => | |
668 | Vector.foreach2 | |
669 | (label h, graisevs, coerce))) | |
670 | | Return.Tail => coerceRaise () | |
671 | end | |
672 | | _ => ()) | |
673 | end) | |
674 | val _ = | |
675 | Control.diagnostics | |
676 | (fn display => | |
677 | let | |
678 | open Layout | |
679 | val _ = | |
680 | Vector.foreach | |
681 | (datatypes, fn Datatype.T {tycon, cons} => | |
682 | display | |
683 | (align | |
684 | [Tycon.layout tycon, | |
685 | indent (Vector.layout | |
686 | (fn {con, ...} => | |
687 | seq [Con.layout con, str " ", | |
688 | Vector.layout Value.layout (conArgs con)]) | |
689 | cons, | |
690 | 2)])) | |
691 | val _ = | |
692 | List.foreach | |
693 | (functions, fn f => | |
694 | let | |
695 | val {name, ...} = Function.dest f | |
696 | val _ = display (seq [str "Useless info for ", | |
697 | Func.layout name]) | |
698 | val {args, returns, raises} = func name | |
699 | val _ = | |
700 | display | |
701 | (record [("args", Vector.layout Value.layout args), | |
702 | ("returns", | |
703 | Option.layout (Vector.layout Value.layout) | |
704 | returns), | |
705 | ("raises", | |
706 | Option.layout (Vector.layout Value.layout) | |
707 | raises)]) | |
708 | val _ = | |
709 | Function.foreachVar | |
710 | (f, fn (x, _) => | |
711 | display (seq [Var.layout x, | |
712 | str " ", Value.layout (value x)])) | |
713 | in | |
714 | () | |
715 | end) | |
716 | in | |
717 | () | |
718 | end) | |
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, ...} = | |
723 | Property.destGet | |
724 | (Type.plist, | |
725 | Property.initFun | |
726 | (fn ty => | |
727 | let val var = Var.newString "bogus" | |
728 | in List.push (bogusGlobals, | |
729 | Statement.T | |
730 | {var = SOME var, | |
731 | ty = ty, | |
732 | exp = PrimApp {prim = Prim.bogus, | |
733 | targs = Vector.new1 ty, | |
734 | args = Vector.new0 ()}}) | |
735 | ; var | |
736 | end)) | |
737 | fun keepUseful (xs: Var.t vector, vs: Value.t vector): Var.t vector = | |
738 | Vector.keepAllMap2 | |
739 | (xs, vs, fn (x, v) => | |
740 | let val (t, b) = Value.getNew v | |
741 | in if b | |
742 | then SOME (if varExists x then x else bogus t) | |
743 | else NONE | |
744 | end) | |
745 | fun keepUsefulArgs (xts: (Var.t * Type.t) vector) = | |
746 | Vector.keepAllMap | |
747 | (xts, fn (x, _) => | |
748 | let val (t, b) = Value.getNew (value x) | |
749 | in if b | |
750 | then SOME (x, t) | |
751 | else NONE | |
752 | end) | |
753 | val keepUsefulArgs = | |
754 | Trace.trace ("Useless.keepUsefulArgs", | |
755 | Vector.layout (Layout.tuple2 (Var.layout, Type.layout)), | |
756 | Vector.layout (Layout.tuple2 (Var.layout, Type.layout))) | |
757 | keepUsefulArgs | |
758 | fun dropUseless (vs: Value.t vector, | |
759 | vs': Value.t vector, | |
760 | makeTrans: Var.t vector -> Transfer.t): Label.t * Block.t = | |
761 | let | |
762 | val l = Label.newNoname () | |
763 | val (formals, actuals) = | |
764 | Vector.unzip | |
765 | (Vector.map2 | |
766 | (vs, vs', fn (v, v') => | |
767 | if Value.isUseful v | |
768 | then let val x = Var.newNoname () | |
769 | in (SOME (x, Value.newType v), | |
770 | if Value.isUseful v' | |
771 | then SOME x | |
772 | else NONE) | |
773 | end | |
774 | else (NONE, NONE))) | |
775 | in (l, Block.T {label = l, | |
776 | args = Vector.keepAllSome formals, | |
777 | statements = Vector.new0 (), | |
778 | transfer = makeTrans (Vector.keepAllSome actuals)}) | |
779 | end | |
780 | (* Returns true if the component is the only component of the tuple | |
781 | * that exists. | |
782 | *) | |
783 | fun newOffset (bs: bool vector, n: int): int * bool = | |
784 | let | |
785 | val len = Vector.length bs | |
786 | fun loop (pos, n, i) = | |
787 | let val b = Vector.sub (bs, pos) | |
788 | in if n = 0 | |
789 | then (i, (i = 0 | |
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) | |
793 | end | |
794 | in loop (0, n, 0) | |
795 | end | |
796 | ||
797 | fun doitExp (e: Exp.t, resultType: Type.t, resultValue: Value.t option) = | |
798 | case e of | |
799 | ConApp {con, args} => | |
800 | ConApp {con = con, | |
801 | args = keepUseful (args, conArgs con)} | |
802 | | Const _ => e | |
803 | | PrimApp {prim, args, ...} => | |
804 | let | |
805 | fun doit () = | |
806 | let | |
807 | val (args, argTypes) = | |
808 | Vector.unzip | |
809 | (Vector.map (args, fn x => | |
810 | let | |
811 | val (t, b) = Value.getNew (value x) | |
812 | in | |
813 | if b | |
814 | then (x, t) | |
815 | else (unitVar, Type.unit) | |
816 | end)) | |
817 | in | |
818 | PrimApp | |
819 | {prim = prim, | |
820 | args = args, | |
821 | targs = (Prim.extractTargs | |
822 | (prim, | |
823 | {args = argTypes, | |
824 | result = resultType, | |
825 | typeOps = {deArray = Type.deArray, | |
826 | deArrow = fn _ => Error.bug "Useless.doitExp: deArrow", | |
827 | deRef = Type.deRef, | |
828 | deVector = Type.deVector, | |
829 | deWeak = Type.deWeak}}))} | |
830 | end | |
831 | datatype z = datatype Prim.Name.t | |
832 | in | |
833 | case Prim.name prim of | |
834 | Array_uninitIsNop => | |
835 | if varExists (Vector.sub (args, 0)) | |
836 | then doit () | |
837 | else ConApp {args = Vector.new0 (), | |
838 | con = Con.falsee} | |
839 | | _ => doit () | |
840 | end | |
841 | | Select {tuple, offset} => | |
842 | let | |
843 | val (offset, isOne) = | |
844 | newOffset (Vector.map (Value.detupleSlots (value tuple), | |
845 | Exists.doesExist o #2), | |
846 | offset) | |
847 | in if isOne | |
848 | then Var tuple | |
849 | else Select {tuple = tuple, | |
850 | offset = offset} | |
851 | end | |
852 | | Tuple xs => | |
853 | let | |
854 | val slots = Value.detupleSlots (valOf resultValue) | |
855 | val xs = | |
856 | Vector.keepAllMap2 | |
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)) | |
861 | else NONE) | |
862 | in | |
863 | if 1 = Vector.length xs | |
864 | then Var (Vector.first xs) | |
865 | else Tuple xs | |
866 | end | |
867 | | Var _ => e | |
868 | | _ => e | |
869 | val doitExp = | |
870 | Trace.trace3 ("Useless.doitExp", | |
871 | Exp.layout, Layout.ignore, Layout.ignore, | |
872 | Exp.layout) | |
873 | doitExp | |
874 | fun doitStatement (Statement.T {var, exp, ty}) = | |
875 | let | |
876 | val v = Option.map (var, value) | |
877 | val (ty, b) = | |
878 | case v of | |
879 | NONE => (ty, false) | |
880 | | SOME v => Value.getNew v | |
881 | fun yes ty = | |
882 | SOME (Statement.T | |
883 | {var = var, | |
884 | ty = ty, | |
885 | exp = doitExp (exp, ty, v)}) | |
886 | in | |
887 | if b | |
888 | then yes ty | |
889 | else | |
890 | case exp of | |
891 | PrimApp {prim, args, ...} => | |
892 | if Prim.maySideEffect prim | |
893 | andalso let | |
894 | fun arg i = Vector.sub (args, i) | |
895 | fun array () = | |
896 | Value.isUseful | |
897 | (Value.dearray (value (arg 0))) | |
898 | datatype z = datatype Prim.Name.t | |
899 | in | |
900 | case Prim.name prim of | |
901 | Array_copyArray => array () | |
902 | | Array_copyVector => array () | |
903 | | Array_uninit => array () | |
904 | | Array_update => array () | |
905 | | Ref_assign => | |
906 | Value.isUseful | |
907 | (Value.deref (value (arg 0))) | |
908 | | WordArray_updateWord _ => array () | |
909 | | _ => true | |
910 | end | |
911 | then yes ty | |
912 | else NONE | |
913 | | Profile _ => yes ty | |
914 | | _ => NONE | |
915 | end | |
916 | val doitStatement = | |
917 | Trace.trace ("Useless.doitStatement", | |
918 | Statement.layout, Option.layout Statement.layout) | |
919 | doitStatement | |
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) | |
923 | val agrees = | |
924 | Trace.trace2 ("Useless.agrees", | |
925 | Vector.layout Value.layout, | |
926 | Vector.layout Value.layout, | |
927 | Bool.layout) | |
928 | agrees | |
929 | fun doitTransfer (t: Transfer.t, | |
930 | returns: Value.t vector option, | |
931 | raises: Value.t vector option) | |
932 | : Block.t list * Transfer.t = | |
933 | case t of | |
934 | Arith {prim, args, overflow, success, ty} => | |
935 | let | |
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 | |
940 | in | |
941 | if agree (v, Vector.first sargs) | |
942 | then ([], t) | |
943 | else let | |
944 | val (l, b) = dropUseless | |
945 | (res, sargs, fn args => | |
946 | Goto {dst = success, args = args}) | |
947 | in | |
948 | ([b], | |
949 | Arith {prim = prim, | |
950 | args = args, | |
951 | overflow = overflow, | |
952 | success = l, | |
953 | ty = ty}) | |
954 | end | |
955 | end | |
956 | | Bug => ([], Bug) | |
957 | | Call {func = f, args, return} => | |
958 | let | |
959 | val {args = fargs, returns = freturns, ...} = func f | |
960 | val (blocks, return) = | |
961 | case return of | |
962 | Return.Dead => ([], return) | |
963 | | Return.Tail => | |
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) | |
971 | else | |
972 | let | |
973 | val (l, b) = | |
974 | dropUseless | |
975 | (freturns, returns, Return) | |
976 | in ([b], | |
977 | Return.NonTail | |
978 | {cont = l, | |
979 | handler = Handler.Caller}) | |
980 | end) | |
981 | | Return.NonTail {cont, handler} => | |
982 | (case freturns of | |
983 | NONE => ([], return) | |
984 | | SOME freturns => | |
985 | let val returns = label cont | |
986 | in if agrees (freturns, returns) | |
987 | then ([], return) | |
988 | else let | |
989 | val (l, b) = | |
990 | dropUseless | |
991 | (freturns, returns, fn args => | |
992 | Goto {dst = cont, args = args}) | |
993 | in ([b], | |
994 | Return.NonTail | |
995 | {cont = l, handler = handler}) | |
996 | end | |
997 | end) | |
998 | in (blocks, | |
999 | Call {func = f, | |
1000 | args = keepUseful (args, fargs), | |
1001 | return = return}) | |
1002 | end | |
1003 | | Case {test, cases, default} => | |
1004 | let | |
1005 | datatype z = datatype Cases.t | |
1006 | in | |
1007 | case cases of | |
1008 | Con cases => | |
1009 | (case (Vector.length cases, default) of | |
1010 | (0, NONE) => ([], Bug) | |
1011 | | _ => | |
1012 | let | |
1013 | val (cases, blocks) = | |
1014 | Vector.mapAndFold | |
1015 | (cases, [], fn ((c, l), blocks) => | |
1016 | let | |
1017 | val args = label l | |
1018 | in if Vector.forall (args, Value.isUseful) | |
1019 | then ((c, l), blocks) | |
1020 | else | |
1021 | let | |
1022 | val (l', b) = | |
1023 | dropUseless | |
1024 | (conArgs c, args, fn args => | |
1025 | Goto {dst = l, args = args}) | |
1026 | in ((c, l'), b :: blocks) | |
1027 | end | |
1028 | end) | |
1029 | in (blocks, | |
1030 | Case {test = test, | |
1031 | cases = Cases.Con cases, | |
1032 | default = default}) | |
1033 | end) | |
1034 | | Word (_, cs) => | |
1035 | (* The test may be useless if there are no cases or | |
1036 | * default, thus we must eliminate the case. | |
1037 | *) | |
1038 | case (Vector.length cs, default) of | |
1039 | (0, NONE) => ([], Bug) | |
1040 | | _ => ([], t) | |
1041 | end | |
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}) | |
1048 | val doitTransfer = | |
1049 | Trace.trace3 ("Useless.doitTransfer", | |
1050 | Transfer.layout, | |
1051 | Option.layout (Vector.layout Value.layout), | |
1052 | Option.layout (Vector.layout Value.layout), | |
1053 | Layout.tuple2 (List.layout (Label.layout o Block.label), | |
1054 | Transfer.layout)) | |
1055 | doitTransfer | |
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 = | |
1060 | let | |
1061 | val args = keepUsefulArgs args | |
1062 | val statements = Vector.keepAllMap (statements, doitStatement) | |
1063 | val (blocks, transfer) = doitTransfer (transfer, returns, raises) | |
1064 | in | |
1065 | (blocks, Block.T {label = label, | |
1066 | args = args, | |
1067 | statements = statements, | |
1068 | transfer = transfer}) | |
1069 | end | |
1070 | val doitBlock = | |
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))) | |
1077 | doitBlock | |
1078 | fun doitFunction f = | |
1079 | let | |
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') = | |
1084 | Vector.mapAndFold | |
1085 | (blocks, [], fn (block, blocks') => | |
1086 | let val (blocks'', block) = doitBlock (block, returnvs, raisevs) | |
1087 | in (block, blocks''::blocks') | |
1088 | end) | |
1089 | val 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) | |
1093 | in | |
1094 | Function.new {args = args, | |
1095 | blocks = blocks, | |
1096 | mayInline = mayInline, | |
1097 | name = name, | |
1098 | raises = raises, | |
1099 | returns = returns, | |
1100 | start = start} | |
1101 | end | |
1102 | val datatypes = | |
1103 | Vector.map | |
1104 | (datatypes, fn Datatype.T {tycon, cons} => | |
1105 | Datatype.T {tycon = tycon, | |
1106 | cons = Vector.map (cons, fn {con, ...} => | |
1107 | {con = con, | |
1108 | args = Value.newTypes (conArgs con)})}) | |
1109 | val globals = | |
1110 | Vector.concat | |
1111 | [Vector.new1 (Statement.T {var = SOME unitVar, | |
1112 | ty = Type.unit, | |
1113 | exp = Exp.unit}), | |
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), | |
1118 | globals] | |
1119 | val program = Program.T {datatypes = datatypes, | |
1120 | globals = globals, | |
1121 | functions = functions, | |
1122 | main = main} | |
1123 | val _ = destroy () | |
1124 | val _ = Program.clearTop program | |
1125 | in | |
1126 | program | |
1127 | end | |
1128 | end |