Commit | Line | Data |
---|---|---|
7f918cf1 CE |
1 | (* Copyright (C) 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 | (* | |
11 | * Invariant: Created globals only refer to other globals. | |
12 | * Hence, the newly created globals may appear at the | |
13 | * beginning of the program. | |
14 | * | |
15 | * Circular abstract values can arise as a result of programs like: | |
16 | * datatype t = T of t | |
17 | * fun f () = T (f ()) | |
18 | * val _ = f () | |
19 | * There is special code in printing abstract values and in determining whether | |
20 | * they are global in order to avoid infinite loops. | |
21 | *) | |
22 | ||
23 | functor ConstantPropagation (S: SSA_TRANSFORM_STRUCTS) : SSA_TRANSFORM = | |
24 | struct | |
25 | ||
26 | open S | |
27 | ||
28 | structure Multi = Multi (S) | |
29 | structure Global = Global (S) | |
30 | ||
31 | structure Type = | |
32 | struct | |
33 | open Type | |
34 | ||
35 | fun isSmall t = | |
36 | case dest t of | |
37 | Array _ => false | |
38 | | Datatype _ => false | |
39 | | Ref t => isSmall t | |
40 | | Tuple ts => Vector.forall (ts, isSmall) | |
41 | | Vector _ => false | |
42 | | _ => true | |
43 | end | |
44 | ||
45 | structure Sconst = Const | |
46 | open Exp Transfer | |
47 | ||
48 | structure Value = | |
49 | struct | |
50 | datatype global = | |
51 | NotComputed | |
52 | | No | |
53 | | Yes of Var.t | |
54 | ||
55 | structure Const = | |
56 | struct | |
57 | datatype t = T of {const: const ref, | |
58 | coercedTo: t list ref} | |
59 | and const = | |
60 | Const of Const.t | |
61 | | Undefined (* no possible value *) | |
62 | | Unknown (* many possible values *) | |
63 | ||
64 | fun layout (T {const, ...}) = layoutConst (!const) | |
65 | and layoutConst c = | |
66 | let | |
67 | open Layout | |
68 | in | |
69 | case c of | |
70 | Const c => Const.layout c | |
71 | | Undefined => str "undefined constant" | |
72 | | Unknown => str "unknown constant" | |
73 | end | |
74 | ||
75 | fun new c = T {const = ref c, | |
76 | coercedTo = ref []} | |
77 | ||
78 | fun equals (T {const = r, ...}, T {const = r', ...}) = r = r' | |
79 | ||
80 | val equals = | |
81 | Trace.trace2 | |
82 | ("ConstantPropagation.Value.Const.equals", | |
83 | layout, layout, Bool.layout) | |
84 | equals | |
85 | ||
86 | val const = new o Const | |
87 | ||
88 | fun undefined () = new Undefined | |
89 | ||
90 | fun unknown () = new Unknown | |
91 | ||
92 | fun makeUnknown (T {const, coercedTo}): unit = | |
93 | case !const of | |
94 | Unknown => () | |
95 | | _ => (const := Unknown | |
96 | ; List.foreach (!coercedTo, makeUnknown) | |
97 | ; coercedTo := []) | |
98 | ||
99 | val makeUnknown = | |
100 | Trace.trace | |
101 | ("ConstantPropagation.Value.Const.makeUnknown", | |
102 | layout, Unit.layout) | |
103 | makeUnknown | |
104 | ||
105 | fun send (c: t, c': const): unit = | |
106 | let | |
107 | fun loop (c as T {const, coercedTo}) = | |
108 | case (c', !const) of | |
109 | (_, Unknown) => () | |
110 | | (_, Undefined) => (const := c' | |
111 | ; List.foreach (!coercedTo, loop)) | |
112 | | (Const c', Const c'') => | |
113 | if Const.equals (c', c'') | |
114 | then () | |
115 | else makeUnknown c | |
116 | | _ => makeUnknown c | |
117 | in | |
118 | loop c | |
119 | end | |
120 | ||
121 | val send = | |
122 | Trace.trace2 | |
123 | ("ConstantPropagation.Value.Const.send", | |
124 | layout, layoutConst, Unit.layout) | |
125 | send | |
126 | ||
127 | fun coerce {from = from as T {const, coercedTo}, to: t}: unit = | |
128 | if equals (from, to) | |
129 | then () | |
130 | else | |
131 | let | |
132 | fun push () = List.push (coercedTo, to) | |
133 | in | |
134 | case !const of | |
135 | c as Const _ => (push (); send (to, c)) | |
136 | | Undefined => push () | |
137 | | Unknown => makeUnknown to | |
138 | end | |
139 | ||
140 | val coerce = | |
141 | Trace.trace | |
142 | ("ConstantPropagation.Value.Const.coerce", | |
143 | fn {from, to} => Layout.record [("from", layout from), | |
144 | ("to", layout to)], | |
145 | Unit.layout) | |
146 | coerce | |
147 | ||
148 | fun unify (c, c') = | |
149 | (coerce {from = c, to = c'} | |
150 | ; coerce {from = c', to = c}) | |
151 | ||
152 | val unify = | |
153 | Trace.trace2 | |
154 | ("ConstantPropagation.Value.Const.unify", | |
155 | layout, layout, Unit.layout) | |
156 | unify | |
157 | end | |
158 | ||
159 | structure One = | |
160 | struct | |
161 | datatype 'a t = T of {extra: 'a, | |
162 | global: Var.t option ref} | |
163 | ||
164 | local | |
165 | fun make f (T r) = f r | |
166 | in | |
167 | val global = fn z => make #global z | |
168 | end | |
169 | ||
170 | fun layout (one: 'a t): Layout.t = | |
171 | Layout.record | |
172 | [("global", Option.layout Var.layout (! (global one)))] | |
173 | ||
174 | fun new (a: 'a): 'a t = T {extra = a, | |
175 | global = ref NONE} | |
176 | ||
177 | val equals: 'a t * 'a t -> bool = | |
178 | fn (n, n') => global n = global n' | |
179 | end | |
180 | ||
181 | structure Place = | |
182 | struct | |
183 | datatype 'a t = | |
184 | One of 'a One.t | |
185 | | Undefined | |
186 | | Unknown | |
187 | ||
188 | val toString = | |
189 | fn One _ => "One" | |
190 | | Undefined => "Undefined" | |
191 | | Unknown => "Unknown" | |
192 | ||
193 | fun layout b = Layout.str (toString b) | |
194 | end | |
195 | ||
196 | structure Birth = | |
197 | struct | |
198 | datatype 'a t = T of {coercedTo: 'a t list ref, | |
199 | place: 'a Place.t ref} | |
200 | ||
201 | fun layout (T {place, ...}) = Place.layout (!place) | |
202 | ||
203 | fun equals (T {place = r, ...}, T {place = r', ...}) = r = r' | |
204 | ||
205 | fun new p = T {place = ref p, | |
206 | coercedTo = ref []} | |
207 | ||
208 | fun undefined (): 'a t = new Place.Undefined | |
209 | fun unknown (): 'a t = new Place.Unknown | |
210 | fun here (a: 'a): 'a t = new (Place.One (One.new a)) | |
211 | ||
212 | val traceMakeUnknown = | |
213 | Trace.info | |
214 | "ConstantPropagation.Value.Birth.makeUnknown" | |
215 | ||
216 | fun makeUnknown arg = | |
217 | Trace.traceInfo' | |
218 | (traceMakeUnknown, layout, Unit.layout) | |
219 | (fn T {place, coercedTo, ...} => | |
220 | case !place of | |
221 | Place.Unknown => () | |
222 | | _ => (place := Place.Unknown | |
223 | ; List.foreach (!coercedTo, makeUnknown) | |
224 | ; coercedTo := [])) arg | |
225 | ||
226 | val traceSend = | |
227 | Trace.info | |
228 | "ConstantPropagation.Value.Birth.send" | |
229 | ||
230 | fun send arg = | |
231 | Trace.traceInfo' | |
232 | (traceSend, Layout.tuple2 (layout, One.layout), Unit.layout) | |
233 | (fn (b, one) => | |
234 | let | |
235 | fun loop (b as T {place, coercedTo, ...}) = | |
236 | case !place of | |
237 | Place.Undefined => (place := Place.One one | |
238 | ; List.foreach (!coercedTo, loop)) | |
239 | | Place.One one' => if One.equals (one, one') | |
240 | then () | |
241 | else makeUnknown b | |
242 | | Place.Unknown => () | |
243 | in | |
244 | loop b | |
245 | end) arg | |
246 | ||
247 | val traceCoerce = | |
248 | Trace.info | |
249 | "ConstantPropagation.Value.Birth.coerce" | |
250 | fun coerce arg = | |
251 | Trace.traceInfo' | |
252 | (traceCoerce, | |
253 | fn {from, to} => Layout.record [("from", layout from), | |
254 | ("to", layout to)], | |
255 | Unit.layout) | |
256 | (fn {from = from as T {place, coercedTo, ...}, to} => | |
257 | if equals (from, to) | |
258 | then () | |
259 | else | |
260 | let | |
261 | fun push () = List.push (coercedTo, to) | |
262 | in | |
263 | case !place of | |
264 | Place.Unknown => makeUnknown to | |
265 | | Place.One one => (push (); send (to, one)) | |
266 | | Place.Undefined => push () | |
267 | end) arg | |
268 | ||
269 | val traceUnify = | |
270 | Trace.info | |
271 | "ConstantPropagation.Value.Birth.unify" | |
272 | ||
273 | fun unify arg = | |
274 | Trace.traceInfo' | |
275 | (traceUnify, Layout.tuple2 (layout, layout), Unit.layout) | |
276 | (fn (c, c') => | |
277 | (coerce {from = c, to = c'} | |
278 | ; coerce {from = c', to = c})) arg | |
279 | end | |
280 | ||
281 | structure Set = DisjointSet | |
282 | structure Unique = UniqueId () | |
283 | ||
284 | datatype t = | |
285 | T of {global: global ref, | |
286 | ty: Type.t, | |
287 | value: value} Set.t | |
288 | and value = | |
289 | Array of {birth: unit Birth.t, | |
290 | elt: t, | |
291 | length: t, | |
292 | raw: bool option ref} | |
293 | | Const of Const.t | |
294 | | Datatype of data | |
295 | | Ref of {arg: t, | |
296 | birth: {init: t} Birth.t} | |
297 | | Tuple of t vector | |
298 | | Vector of {elt: t, | |
299 | length: t} | |
300 | | Weak of t | |
301 | and data = | |
302 | Data of {coercedTo: data list ref, | |
303 | filters: {args: t vector, | |
304 | con: Con.t} list ref, | |
305 | value: dataVal ref} | |
306 | and dataVal = | |
307 | ConApp of {args: t vector, | |
308 | con: Con.t, | |
309 | uniq: Unique.t} | |
310 | | Undefined | |
311 | | Unknown | |
312 | ||
313 | local | |
314 | fun make sel (T s) = sel (Set.! s) | |
315 | in | |
316 | val value = make #value | |
317 | val ty = make #ty | |
318 | end | |
319 | fun deConst v = | |
320 | case value v of | |
321 | Const (Const.T {const, ...}) => | |
322 | (case !const of | |
323 | Const.Const c => SOME c | |
324 | | _ => NONE) | |
325 | | _ => NONE | |
326 | ||
327 | local | |
328 | open Layout | |
329 | in | |
330 | fun layout v = | |
331 | case value v of | |
332 | Array {birth, elt, length, raw, ...} => | |
333 | seq [str "array", tuple [Birth.layout birth, | |
334 | layout length, | |
335 | layout elt, | |
336 | Option.layout Bool.layout (!raw)]] | |
337 | | Const c => Const.layout c | |
338 | | Datatype d => layoutData d | |
339 | | Ref {arg, birth, ...} => | |
340 | seq [str "ref ", tuple [layout arg, Birth.layout birth]] | |
341 | | Tuple vs => Vector.layout layout vs | |
342 | | Vector {elt, length, ...} => seq [str "vector ", | |
343 | tuple [layout elt, | |
344 | layout length]] | |
345 | | Weak v => seq [str "weak ", layout v] | |
346 | and layoutData (Data {value, ...}) = | |
347 | case !value of | |
348 | Undefined => str "undefined datatype" | |
349 | | ConApp {con, uniq, ...} => | |
350 | record [("con", Con.layout con), | |
351 | ("uniq", Unique.layout uniq)] | |
352 | (* Can't layout the args because there may be a circularity *) | |
353 | | Unknown => str "unknown datatype" | |
354 | end | |
355 | ||
356 | fun equals (T s, T s') = Set.equals (s, s') | |
357 | ||
358 | val equals = | |
359 | Trace.trace2 | |
360 | ("ConstantPropagation.Value.equals", | |
361 | layout, layout, Bool.layout) | |
362 | equals | |
363 | ||
364 | val globalsInfo = Trace.info "ConstantPropagation.Value.globals" | |
365 | val globalInfo = Trace.info "ConstantPropagation.Value.global" | |
366 | ||
367 | fun globals arg: (Var.t * Type.t) vector option = | |
368 | Trace.traceInfo | |
369 | (globalsInfo, | |
370 | (Vector.layout layout) o #1, | |
371 | Option.layout (Vector.layout | |
372 | (Layout.tuple2 (Var.layout, Type.layout))), | |
373 | Trace.assertTrue) | |
374 | (fn (vs: t vector, newGlobal) => | |
375 | Exn.withEscape | |
376 | (fn escape => | |
377 | SOME (Vector.map | |
378 | (vs, fn v => | |
379 | case global (v, newGlobal) of | |
380 | NONE => escape NONE | |
381 | | SOME g => g)))) arg | |
382 | and global arg: (Var.t * Type.t) option = | |
383 | Trace.traceInfo (globalInfo, | |
384 | layout o #1, | |
385 | Option.layout (Var.layout o #1), | |
386 | Trace.assertTrue) | |
387 | (fn (v as T s, newGlobal) => | |
388 | let val {global = r, ty, value} = Set.! s | |
389 | in case !r of | |
390 | No => NONE | |
391 | | Yes g => SOME (g, ty) | |
392 | | NotComputed => | |
393 | let | |
394 | (* avoid globalizing circular abstract values *) | |
395 | val _ = r := No | |
396 | fun yes e = Yes (newGlobal (ty, e)) | |
397 | fun unary (Birth.T {place, ...}, | |
398 | makeInit: 'a -> t, | |
399 | primApp: {targs: Type.t vector, | |
400 | args: Var.t vector} -> Exp.t, | |
401 | targ: Type.t) = | |
402 | case !place of | |
403 | Place.One (One.T {global = glob, extra, ...}) => | |
404 | let | |
405 | val init = makeInit extra | |
406 | in | |
407 | case global (init, newGlobal) of | |
408 | SOME (x, _) => | |
409 | Yes | |
410 | (case !glob of | |
411 | NONE => | |
412 | let | |
413 | val exp = | |
414 | primApp | |
415 | {targs = Vector.new1 targ, | |
416 | args = Vector.new1 x} | |
417 | val g = newGlobal (ty, exp) | |
418 | in | |
419 | glob := SOME g; g | |
420 | end | |
421 | | SOME g => g) | |
422 | | _ => No | |
423 | end | |
424 | | _ => No | |
425 | val g = | |
426 | case value of | |
427 | Array {birth, length, raw, ...} => | |
428 | unary (birth, fn _ => length, | |
429 | fn {args, targs} => | |
430 | Exp.PrimApp {args = args, | |
431 | prim = Prim.arrayAlloc | |
432 | {raw = valOf (!raw)}, | |
433 | targs = targs}, | |
434 | Type.deArray ty) | |
435 | | Const (Const.T {const, ...}) => | |
436 | (case !const of | |
437 | Const.Const c => yes (Exp.Const c) | |
438 | | _ => No) | |
439 | | Datatype (Data {value, ...}) => | |
440 | (case !value of | |
441 | ConApp {args, con, ...} => | |
442 | (case globals (args, newGlobal) of | |
443 | NONE => No | |
444 | | SOME args => | |
445 | yes (Exp.ConApp | |
446 | {con = con, | |
447 | args = Vector.map (args, #1)})) | |
448 | | _ => No) | |
449 | | Ref {birth, ...} => | |
450 | unary (birth, fn {init} => init, | |
451 | fn {args, targs} => | |
452 | Exp.PrimApp {args = args, | |
453 | prim = Prim.reff, | |
454 | targs = targs}, | |
455 | Type.deRef ty) | |
456 | | Tuple vs => | |
457 | (case globals (vs, newGlobal) of | |
458 | NONE => No | |
459 | | SOME xts => | |
460 | yes (Exp.Tuple (Vector.map (xts, #1)))) | |
461 | | Vector {elt, length} => | |
462 | (case Option.map (deConst length, S.Const.deWord) of | |
463 | NONE => No | |
464 | | SOME length => | |
465 | let | |
466 | val length = WordX.toInt length | |
467 | val eltTy = Type.deVector ty | |
468 | fun mkVec args = | |
469 | yes (Exp.PrimApp | |
470 | {args = args, | |
471 | prim = Prim.vector, | |
472 | targs = Vector.new1 eltTy}) | |
473 | fun mkConst (ws, elts) = | |
474 | yes (Exp.Const | |
475 | (S.Const.wordVector | |
476 | (WordXVector.fromList | |
477 | ({elementSize = ws}, elts)))) | |
478 | in | |
479 | case (Option.map (deConst elt, S.Const.deWordOpt), | |
480 | global (elt, newGlobal)) of | |
481 | (SOME (SOME w), _) => | |
482 | mkConst (Type.deWord eltTy, | |
483 | List.new (length, w)) | |
484 | | (_, SOME (x, _)) => | |
485 | mkVec (Vector.new (length, x)) | |
486 | | _ => | |
487 | if length = 0 | |
488 | then case Type.deWordOpt eltTy of | |
489 | SOME ws => mkConst (ws, []) | |
490 | | NONE => mkVec (Vector.new0 ()) | |
491 | else No | |
492 | end) | |
493 | | Weak _ => No | |
494 | val _ = r := g | |
495 | in | |
496 | global (v, newGlobal) | |
497 | end | |
498 | end) arg | |
499 | ||
500 | fun new (v: value, ty: Type.t): t = | |
501 | T (Set.singleton {value = v, | |
502 | ty = ty, | |
503 | global = ref NotComputed}) | |
504 | ||
505 | fun tuple vs = | |
506 | new (Tuple vs, Type.tuple (Vector.map (vs, ty))) | |
507 | ||
508 | fun const' (c, ty) = new (Const c, ty) | |
509 | ||
510 | fun const c = let val c' = Const.const c | |
511 | in new (Const c', Type.ofConst c) | |
512 | end | |
513 | ||
514 | fun constToEltLength (c, err) = | |
515 | let | |
516 | val v = | |
517 | case c of | |
518 | Sconst.WordVector v => v | |
519 | | _ => Error.bug err | |
520 | val length = WordXVector.length v | |
521 | val eltTy = Type.word (WordXVector.elementSize v) | |
522 | val elt = | |
523 | if 0 = length | |
524 | then const' (Const.unknown (), eltTy) | |
525 | else let | |
526 | val w = WordXVector.sub (v, 0) | |
527 | in | |
528 | if WordXVector.forall (v, fn w' => | |
529 | WordX.equals (w, w')) | |
530 | then const (Sconst.word w) | |
531 | else const' (Const.unknown (), eltTy) | |
532 | end | |
533 | val length = | |
534 | const (Sconst.Word (WordX.fromIntInf (IntInf.fromInt length, | |
535 | WordSize.seqIndex ()))) | |
536 | in | |
537 | {elt = elt, length = length} | |
538 | end | |
539 | ||
540 | local | |
541 | fun make (err, sel) v = | |
542 | case value v of | |
543 | Vector fs => sel fs | |
544 | | Const (Const.T {const = ref (Const.Const c), ...}) => | |
545 | sel (constToEltLength (c, err)) | |
546 | | _ => Error.bug err | |
547 | in | |
548 | val devector = make ("ConstantPropagation.Value.devector", #elt) | |
549 | val vectorLength = make ("ConstantPropagation.Value.vectorLength", #length) | |
550 | end | |
551 | ||
552 | local | |
553 | fun make (err, sel) v = | |
554 | case value v of | |
555 | Array fs => sel fs | |
556 | | _ => Error.bug err | |
557 | in val dearray = make ("ConstantPropagation.Value.dearray", #elt) | |
558 | val arrayLength = make ("ConstantPropagation.Value.arrayLength", #length) | |
559 | val arrayBirth = make ("ConstantPropagation.Value.arrayBirth", #birth) | |
560 | val arrayRaw = make ("ConstantPropagation.Value.arrayRaw", #raw) | |
561 | end | |
562 | ||
563 | fun arrayFromArray (T s: t): t = | |
564 | let | |
565 | val {value, ty, ...} = Set.! s | |
566 | in case value of | |
567 | Array {elt, length, ...} => | |
568 | new (Array {birth = Birth.unknown (), elt = elt, length = length, raw = ref (SOME false)}, ty) | |
569 | | _ => Error.bug "ConstantPropagation.Value.arrayFromArray" | |
570 | end | |
571 | ||
572 | fun vectorFromArray (T s: t): t = | |
573 | let | |
574 | val {value, ty, ...} = Set.! s | |
575 | in case value of | |
576 | Array {elt, length, ...} => | |
577 | new (Vector {elt = elt, length = length}, Type.vector (Type.deArray ty)) | |
578 | | _ => Error.bug "ConstantPropagation.Value.vectorFromArray" | |
579 | end | |
580 | ||
581 | local | |
582 | fun make (err, sel) v = | |
583 | case value v of | |
584 | Ref fs => sel fs | |
585 | | _ => Error.bug err | |
586 | in | |
587 | val deref = make ("ConstantPropagation.Value.deref", #arg) | |
588 | val refBirth = make ("ConstantPropagation.Value.refBirth", #birth) | |
589 | end | |
590 | ||
591 | fun deweak v = | |
592 | case value v of | |
593 | Weak v => v | |
594 | | _ => Error.bug "ConstantPropagation.Value.deweak" | |
595 | ||
596 | structure Data = | |
597 | struct | |
598 | datatype t = datatype data | |
599 | ||
600 | val layout = layoutData | |
601 | ||
602 | local | |
603 | fun make v () = Data {value = ref v, | |
604 | coercedTo = ref [], | |
605 | filters = ref []} | |
606 | in | |
607 | val undefined = make Undefined | |
608 | val unknown = make Unknown | |
609 | end | |
610 | end | |
611 | ||
612 | local | |
613 | (* The extra birth is because of let-style polymorphism. | |
614 | * arrayBirth is really the same as refBirth. | |
615 | *) | |
616 | fun make (const, data, refBirth, arrayBirth) = | |
617 | let | |
618 | fun loop (t: Type.t): t = | |
619 | new | |
620 | (case Type.dest t of | |
621 | Type.Array t => | |
622 | Array {birth = arrayBirth (), | |
623 | elt = loop t, | |
624 | length = loop (Type.word (WordSize.seqIndex ())), | |
625 | raw = ref NONE} | |
626 | | Type.Datatype _ => Datatype (data ()) | |
627 | | Type.Ref t => Ref {arg = loop t, | |
628 | birth = refBirth ()} | |
629 | | Type.Tuple ts => Tuple (Vector.map (ts, loop)) | |
630 | | Type.Vector t => Vector | |
631 | {elt = loop t, | |
632 | length = loop (Type.word (WordSize.seqIndex ()))} | |
633 | | Type.Weak t => Weak (loop t) | |
634 | | _ => Const (const ()), | |
635 | t) | |
636 | in loop | |
637 | end | |
638 | in | |
639 | val fromType = | |
640 | make (Const.undefined, | |
641 | Data.undefined, | |
642 | Birth.undefined, | |
643 | Birth.undefined) | |
644 | val unknown = | |
645 | make (Const.unknown, | |
646 | Data.unknown, | |
647 | Birth.unknown, | |
648 | Birth.unknown) | |
649 | end | |
650 | ||
651 | fun select {tuple, offset, resultType = _} = | |
652 | case value tuple of | |
653 | Tuple vs => Vector.sub (vs, offset) | |
654 | | _ => Error.bug "ConstantPropagation.Value.select: non-tuple" | |
655 | ||
656 | fun unit () = tuple (Vector.new0 ()) | |
657 | end | |
658 | ||
659 | val traceSendConApp = | |
660 | Trace.trace2 | |
661 | ("ConstantPropagation.sendConApp", Value.Data.layout, | |
662 | fn {con, args, uniq} => | |
663 | Layout.record [("con", Con.layout con), | |
664 | ("args", Vector.layout Value.layout args), | |
665 | ("uniq", Value.Unique.layout uniq)], | |
666 | Unit.layout) | |
667 | ||
668 | val traceSendConAppLoop = | |
669 | Trace.trace | |
670 | ("ConstantPropagation.sendConAppLoop", | |
671 | Value.Data.layout, Unit.layout) | |
672 | ||
673 | val traceMakeDataUnknown = | |
674 | Trace.trace | |
675 | ("ConstantPropagation.makeDataUnknown", | |
676 | Value.Data.layout, Unit.layout) | |
677 | ||
678 | (* ------------------------------------------------- *) | |
679 | (* simplify *) | |
680 | (* ------------------------------------------------- *) | |
681 | ||
682 | fun transform (program: Program.t): Program.t = | |
683 | let | |
684 | val program as Program.T {datatypes, globals, functions, main} = | |
685 | eliminateDeadBlocks program | |
686 | val {varIsMultiDefed, ...} = Multi.multi program | |
687 | val once = not o varIsMultiDefed | |
688 | val {get = conInfo: Con.t -> {result: Type.t, | |
689 | types: Type.t vector, | |
690 | values: Value.t vector}, | |
691 | set = setConInfo, ...} = | |
692 | Property.getSetOnce | |
693 | (Con.plist, Property.initRaise ("conInfo", Con.layout)) | |
694 | val conValues = #values o conInfo | |
695 | val _ = | |
696 | Vector.foreach | |
697 | (datatypes, fn Datatype.T {tycon, cons} => | |
698 | let | |
699 | val result = Type.datatypee tycon | |
700 | in | |
701 | Vector.foreach | |
702 | (cons, fn {con, args} => | |
703 | setConInfo (con, | |
704 | {result = result, | |
705 | types = args, | |
706 | values = Vector.map (args, Value.fromType)})) | |
707 | end) | |
708 | local | |
709 | open Value | |
710 | in | |
711 | val traceCoerce = | |
712 | Trace.trace ("ConstantPropagation.Value.coerce", | |
713 | fn {from, to} => Layout.record [("from", layout from), | |
714 | ("to", layout to)], | |
715 | Unit.layout) | |
716 | fun makeDataUnknown arg: unit = | |
717 | traceMakeDataUnknown | |
718 | (fn Data {value, coercedTo, filters, ...} => | |
719 | let | |
720 | fun doit () = | |
721 | (value := Unknown | |
722 | ; List.foreach (!coercedTo, makeDataUnknown) | |
723 | ; coercedTo := [] | |
724 | ; (List.foreach | |
725 | (!filters, fn {con, args} => | |
726 | coerces {froms = conValues con, | |
727 | tos = args}))) | |
728 | in | |
729 | case !value of | |
730 | ConApp _ => doit () | |
731 | | Undefined => doit () | |
732 | | Unknown => () | |
733 | end) arg | |
734 | and sendConApp arg: unit = | |
735 | traceSendConApp | |
736 | (fn (d: data, ca as {con, args, uniq}) => | |
737 | let | |
738 | val v = ConApp ca | |
739 | fun loop arg: unit = | |
740 | traceSendConAppLoop | |
741 | (fn Data {value, coercedTo, filters, ...} => | |
742 | case !value of | |
743 | Unknown => () | |
744 | | Undefined => | |
745 | (value := v | |
746 | ; List.foreach (!coercedTo, loop) | |
747 | ; (List.foreach | |
748 | (!filters, fn {con = con', args = args'} => | |
749 | if Con.equals (con, con') | |
750 | then coerces {froms = args, tos = args'} | |
751 | else ()))) | |
752 | | ConApp {con = con', uniq = uniq', ...} => | |
753 | if Unique.equals (uniq, uniq') | |
754 | orelse (Con.equals (con, con') | |
755 | andalso Vector.isEmpty args) | |
756 | then () | |
757 | else makeDataUnknown d) arg | |
758 | in loop d | |
759 | end) arg | |
760 | and coerces {froms: Value.t vector, tos: Value.t vector} = | |
761 | Vector.foreach2 (froms, tos, fn (from, to) => | |
762 | coerce {from = from, to = to}) | |
763 | and coerce arg = | |
764 | traceCoerce | |
765 | (fn {from, to} => | |
766 | if equals (from, to) | |
767 | then () | |
768 | else | |
769 | let | |
770 | fun error () = | |
771 | Error.bug | |
772 | (concat ["ConstantPropagation.Value.coerce: strange: from: ", | |
773 | Layout.toString (Value.layout from), | |
774 | " to: ", Layout.toString (Value.layout to)]) | |
775 | in | |
776 | case (value from, value to) of | |
777 | (Const from, Const to) => | |
778 | Const.coerce {from = from, to = to} | |
779 | | (Datatype from, Datatype to) => | |
780 | coerceData {from = from, to = to} | |
781 | | (Ref {birth, arg}, Ref {birth = b', arg = a'}) => | |
782 | (Birth.coerce {from = birth, to = b'} | |
783 | ; unify (arg, a')) | |
784 | | (Array {birth = b, length = n, elt = x, raw = r}, | |
785 | Array {birth = b', length = n', elt = x', raw = r'}) => | |
786 | (Birth.coerce {from = b, to = b'} | |
787 | ; coerce {from = n, to = n'} | |
788 | ; unify (x, x') | |
789 | ; (case (!r, !r') of | |
790 | (NONE, r') => r := r' | |
791 | | (r, NONE) => r' := r | |
792 | | (SOME b, SOME b') => | |
793 | (if b = b' | |
794 | then () | |
795 | else error ()))) | |
796 | | (Vector {length = n, elt = x}, | |
797 | Vector {length = n', elt = x'}) => | |
798 | (coerce {from = n, to = n'} | |
799 | ; coerce {from = x, to = x'}) | |
800 | | (Tuple vs, Tuple vs') => coerces {froms = vs, tos = vs'} | |
801 | | (Weak v, Weak v') => unify (v, v') | |
802 | | (Const (Const.T {const = ref (Const.Const c), ...}), | |
803 | Vector {elt, length}) => | |
804 | let | |
805 | val {elt = elt', length = length'} = | |
806 | Value.constToEltLength (c, "coerce") | |
807 | in | |
808 | coerce {from = elt', to = elt} | |
809 | ; coerce {from = length', to = length} | |
810 | end | |
811 | | (_, _) => error () | |
812 | end) arg | |
813 | and unify (T s: t, T s': t): unit = | |
814 | if Set.equals (s, s') | |
815 | then () | |
816 | else | |
817 | let | |
818 | val {value, ...} = Set.! s | |
819 | val {value = value', ...} = Set.! s' | |
820 | fun error () = | |
821 | Error.bug | |
822 | (concat ["ConstantPropagation.Value.unify: strange: value: ", | |
823 | Layout.toString (Value.layout (T s)), | |
824 | " value': ", Layout.toString (Value.layout (T s'))]) | |
825 | in Set.union (s, s') | |
826 | ; case (value, value') of | |
827 | (Const c, Const c') => Const.unify (c, c') | |
828 | | (Datatype d, Datatype d') => unifyData (d, d') | |
829 | | (Ref {birth, arg}, Ref {birth = b', arg = a'}) => | |
830 | (Birth.unify (birth, b') | |
831 | ; unify (arg, a')) | |
832 | | (Array {birth = b, length = n, elt = x, raw = r}, | |
833 | Array {birth = b', length = n', elt = x', raw = r'}) => | |
834 | (Birth.unify (b, b') | |
835 | ; unify (n, n') | |
836 | ; unify (x, x') | |
837 | ; (case (!r, !r') of | |
838 | (NONE, r') => r := r' | |
839 | | (r, NONE) => r' := r | |
840 | | (SOME b, SOME b') => | |
841 | (if b = b' | |
842 | then () | |
843 | else error ()))) | |
844 | | (Vector {length = n, elt = x}, | |
845 | Vector {length = n', elt = x'}) => | |
846 | (unify (n, n') | |
847 | ; unify (x, x')) | |
848 | | (Tuple vs, Tuple vs') => Vector.foreach2 (vs, vs', unify) | |
849 | | (Weak v, Weak v') => unify (v, v') | |
850 | | _ => error () | |
851 | end | |
852 | and unifyData (d, d') = | |
853 | (coerceData {from = d, to = d'} | |
854 | ; coerceData {from = d', to = d}) | |
855 | and coerceData {from = Data {value, coercedTo, ...}, to} = | |
856 | case !value of | |
857 | ConApp ca => (List.push (coercedTo, to) | |
858 | ; sendConApp (to, ca)) | |
859 | | Undefined => List.push (coercedTo, to) | |
860 | | Unknown => makeDataUnknown to | |
861 | fun conApp {con: Con.t, args: t vector}: t = | |
862 | let | |
863 | val {values = tos, result, ...} = conInfo con | |
864 | in | |
865 | coerces {froms = args, tos = tos} | |
866 | ; new (Datatype | |
867 | (Data {value = ref (ConApp {con = con, args = args, | |
868 | uniq = Unique.new ()}), | |
869 | coercedTo = ref [], | |
870 | filters = ref []}), | |
871 | result) | |
872 | end | |
873 | fun makeUnknown (v: t): unit = | |
874 | case value v of | |
875 | Array {length, elt, ...} => (makeUnknown length | |
876 | ; makeUnknown elt) | |
877 | | Const c => Const.makeUnknown c | |
878 | | Datatype d => makeDataUnknown d | |
879 | | Ref {arg, ...} => makeUnknown arg | |
880 | | Tuple vs => Vector.foreach (vs, makeUnknown) | |
881 | | Vector {length, elt} => (makeUnknown length | |
882 | ; makeUnknown elt) | |
883 | | Weak v => makeUnknown v | |
884 | fun sideEffect (v: t): unit = | |
885 | case value v of | |
886 | Array {elt, ...} => makeUnknown elt | |
887 | | Const _ => () | |
888 | | Datatype _ => () | |
889 | | Ref {arg, ...} => makeUnknown arg | |
890 | | Vector {elt, ...} => makeUnknown elt | |
891 | | Tuple vs => Vector.foreach (vs, sideEffect) | |
892 | | Weak v => makeUnknown v | |
893 | fun primApp {prim, | |
894 | targs = _, | |
895 | args: Value.t vector, | |
896 | resultVar, | |
897 | resultType}: t = | |
898 | let | |
899 | fun bear z = | |
900 | case resultVar of | |
901 | SOME resultVar => if once resultVar | |
902 | andalso | |
903 | Type.isSmall resultType | |
904 | then Birth.here z | |
905 | else Birth.unknown () | |
906 | | _ => Error.bug "ConstantPropagation.Value.primApp.bear" | |
907 | fun update (a, v) = | |
908 | (coerce {from = v, to = dearray a} | |
909 | ; unit ()) | |
910 | fun arg i = Vector.sub (args, i) | |
911 | datatype z = datatype Prim.Name.t | |
912 | fun array (raw, length, birth) = | |
913 | let | |
914 | val a = fromType resultType | |
915 | val _ = coerce {from = length, to = arrayLength a} | |
916 | val _ = Birth.coerce {from = birth, to = arrayBirth a} | |
917 | val _ = arrayRaw a := SOME raw | |
918 | in | |
919 | a | |
920 | end | |
921 | fun vector () = | |
922 | let | |
923 | val v = fromType resultType | |
924 | val l = | |
925 | (const o S.Const.word o WordX.fromIntInf) | |
926 | (IntInf.fromInt (Vector.length args), | |
927 | WordSize.seqIndex ()) | |
928 | val _ = coerce {from = l, to = vectorLength v} | |
929 | val _ = | |
930 | Vector.foreach | |
931 | (args, fn arg => | |
932 | coerce {from = arg, to = devector v}) | |
933 | in | |
934 | v | |
935 | end | |
936 | in | |
937 | case Prim.name prim of | |
938 | Array_alloc {raw} => array (raw, arg 0, bear ()) | |
939 | | Array_copyArray => | |
940 | update (arg 0, dearray (arg 2)) | |
941 | | Array_copyVector => | |
942 | update (arg 0, devector (arg 2)) | |
943 | | Array_length => arrayLength (arg 0) | |
944 | | Array_sub => dearray (arg 0) | |
945 | | Array_toArray => arrayFromArray (arg 0) | |
946 | | Array_toVector => vectorFromArray (arg 0) | |
947 | | Array_update => update (arg 0, arg 2) | |
948 | | Ref_assign => | |
949 | (coerce {from = arg 1, to = deref (arg 0)}; unit ()) | |
950 | | Ref_deref => deref (arg 0) | |
951 | | Ref_ref => | |
952 | let | |
953 | val v = arg 0 | |
954 | val r = fromType resultType | |
955 | val _ = coerce {from = v, to = deref r} | |
956 | val _ = Birth.coerce {from = bear {init = v}, | |
957 | to = refBirth r} | |
958 | in | |
959 | r | |
960 | end | |
961 | | Vector_length => vectorLength (arg 0) | |
962 | | Vector_sub => devector (arg 0) | |
963 | | Vector_vector => vector () | |
964 | | Weak_get => deweak (arg 0) | |
965 | | Weak_new => | |
966 | let | |
967 | val w = fromType resultType | |
968 | val _ = coerce {from = arg 0, to = deweak w} | |
969 | in | |
970 | w | |
971 | end | |
972 | | _ => (if Prim.maySideEffect prim | |
973 | then Vector.foreach (args, sideEffect) | |
974 | else () | |
975 | ; unknown resultType) | |
976 | end | |
977 | fun filter (variant, con, args) = | |
978 | case value variant of | |
979 | Datatype (Data {value, filters, ...}) => | |
980 | let | |
981 | fun save () = List.push (filters, {con = con, args = args}) | |
982 | in case !value of | |
983 | Undefined => save () | |
984 | | Unknown => coerces {froms = conValues con, tos = args} | |
985 | | ConApp {con = con', args = args', ...} => | |
986 | ((* The save () has to happen before the coerces because | |
987 | * they may loop back and change the variant, which | |
988 | * would need to then change this value. | |
989 | *) | |
990 | save () | |
991 | ; if Con.equals (con, con') | |
992 | then coerces {froms = args', tos = args} | |
993 | else ()) | |
994 | end | |
995 | | _ => Error.bug "ConstantPropagation.Value.filter: non-datatype" | |
996 | end | |
997 | fun filterIgnore _ = () | |
998 | val {value, ...} = | |
999 | Control.trace (Control.Detail, "fixed point") | |
1000 | analyze { | |
1001 | coerce = coerce, | |
1002 | conApp = conApp, | |
1003 | const = Value.const, | |
1004 | filter = filter, | |
1005 | filterWord = filterIgnore, | |
1006 | fromType = Value.fromType, | |
1007 | layout = Value.layout, | |
1008 | primApp = primApp, | |
1009 | program = program, | |
1010 | select = Value.select, | |
1011 | tuple = Value.tuple, | |
1012 | useFromTypeOnBinds = false | |
1013 | } | |
1014 | val _ = | |
1015 | Control.diagnostics | |
1016 | (fn display => | |
1017 | let open Layout | |
1018 | in | |
1019 | display (str "\n\nConstructors:") | |
1020 | ; (Vector.foreach | |
1021 | (datatypes, fn Datatype.T {tycon, cons} => | |
1022 | (display (seq [Tycon.layout tycon, str ": "]) | |
1023 | ; Vector.foreach | |
1024 | (cons, fn {con, ...} => | |
1025 | display | |
1026 | (seq [Con.layout con, str ": ", | |
1027 | Vector.layout Value.layout (conValues con)]))))) | |
1028 | ; display (str "\n\nConstants:") | |
1029 | ; (Program.foreachVar | |
1030 | (program, fn (x, _) => display (seq [Var.layout x, | |
1031 | str " ", | |
1032 | Value.layout (value x)]))) | |
1033 | end) | |
1034 | (* Walk through the program | |
1035 | * - removing declarations whose rhs is constant | |
1036 | * - replacing variables whose value is constant with globals | |
1037 | * - building up the global decs | |
1038 | *) | |
1039 | val {new = newGlobal, all = allGlobals} = Global.make () | |
1040 | fun replaceVar x = | |
1041 | case Value.global (value x, newGlobal) of | |
1042 | NONE => x | |
1043 | | SOME (g, _) => g | |
1044 | fun doitStatement (Statement.T {var, ty, exp}) = | |
1045 | let | |
1046 | fun keep () = | |
1047 | SOME (Statement.T {var = var, | |
1048 | ty = ty, | |
1049 | exp = Exp.replaceVar (exp, replaceVar)}) | |
1050 | in | |
1051 | case var of | |
1052 | NONE => keep () | |
1053 | | SOME var => | |
1054 | (case (Value.global (value var, newGlobal), exp) of | |
1055 | (NONE, _) => keep () | |
1056 | | (SOME _, PrimApp {prim, ...}) => | |
1057 | if Prim.maySideEffect prim | |
1058 | then keep () | |
1059 | else NONE | |
1060 | | _ => NONE) | |
1061 | end | |
1062 | fun doitTransfer transfer = | |
1063 | Transfer.replaceVar (transfer, replaceVar) | |
1064 | fun doitBlock (Block.T {label, args, statements, transfer}) = | |
1065 | Block.T {label = label, | |
1066 | args = args, | |
1067 | statements = Vector.keepAllMap (statements, doitStatement), | |
1068 | transfer = doitTransfer transfer} | |
1069 | fun doitFunction f = | |
1070 | let | |
1071 | val {args, blocks, mayInline, name, raises, returns, start} = | |
1072 | Function.dest f | |
1073 | in | |
1074 | Function.new {args = args, | |
1075 | blocks = Vector.map (blocks, doitBlock), | |
1076 | mayInline = mayInline, | |
1077 | name = name, | |
1078 | raises = raises, | |
1079 | returns = returns, | |
1080 | start = start} | |
1081 | end | |
1082 | val functions = List.revMap (functions, doitFunction) | |
1083 | val globals = Vector.keepAllMap (globals, doitStatement) | |
1084 | val globals = Vector.concat [allGlobals (), globals] | |
1085 | val shrink = shrinkFunction {globals = globals} | |
1086 | val program = Program.T {datatypes = datatypes, | |
1087 | globals = globals, | |
1088 | functions = List.revMap (functions, shrink), | |
1089 | main = main} | |
1090 | val _ = Program.clearTop program | |
1091 | in | |
1092 | program | |
1093 | end | |
1094 | ||
1095 | end |