Commit | Line | Data |
---|---|---|
7f918cf1 CE |
1 | (* Copyright (C) 2009,2017 Matthew Fluet. |
2 | * Copyright (C) 2004-2008 Henry Cejtin, Matthew Fluet, Suresh | |
3 | * Jagannathan, and Stephen Weeks. | |
4 | * | |
5 | * MLton is released under a BSD-style license. | |
6 | * See the file MLton-LICENSE for details. | |
7 | *) | |
8 | ||
9 | functor DeepFlatten (S: SSA2_TRANSFORM_STRUCTS): SSA2_TRANSFORM = | |
10 | struct | |
11 | ||
12 | open S | |
13 | ||
14 | datatype z = datatype Exp.t | |
15 | datatype z = datatype Statement.t | |
16 | datatype z = datatype Transfer.t | |
17 | ||
18 | structure Tree = Tree (structure Seq = Prod) | |
19 | ||
20 | structure TypeTree = | |
21 | struct | |
22 | datatype t = datatype Tree.t | |
23 | ||
24 | datatype info = | |
25 | Flat | |
26 | | NotFlat of {ty: Type.t, | |
27 | var: Var.t option} | |
28 | ||
29 | type t = info Tree.t | |
30 | ||
31 | fun layout (t: t): Layout.t = | |
32 | Tree.layout | |
33 | (t, | |
34 | let | |
35 | open Layout | |
36 | in | |
37 | fn Flat => str "Flat" | |
38 | | NotFlat {ty, var} => | |
39 | seq [str "NotFlat ", | |
40 | record [("ty", Type.layout ty), | |
41 | ("var", Option.layout Var.layout var)]] | |
42 | end) | |
43 | ||
44 | val isFlat: t -> bool = | |
45 | fn T (i, _) => | |
46 | case i of | |
47 | Flat => true | |
48 | | NotFlat _ => false | |
49 | end | |
50 | ||
51 | structure VarTree = | |
52 | struct | |
53 | open TypeTree | |
54 | ||
55 | val labelRoot: t * Var.t -> t = | |
56 | fn (t as T (info, ts), x) => | |
57 | case info of | |
58 | Flat => t | |
59 | | NotFlat {ty, ...} => T (NotFlat {ty = ty, var = SOME x}, ts) | |
60 | ||
61 | val fromTypeTree: TypeTree.t -> t = fn t => t | |
62 | ||
63 | val foldRoots: t * 'a * (Var.t * 'a -> 'a) -> 'a = | |
64 | fn (t, a, f) => | |
65 | let | |
66 | fun loop (T (info, children), a: 'a): 'a = | |
67 | case info of | |
68 | Flat => Prod.fold (children, a, loop) | |
69 | | NotFlat {var, ...} => | |
70 | case var of | |
71 | NONE => Error.bug "DeepFlatten.VarTree.foldRoots" | |
72 | | SOME x => f (x, a) | |
73 | in | |
74 | loop (t, a) | |
75 | end | |
76 | ||
77 | fun foreachRoot (t, f) = foldRoots (t, (), f o #1) | |
78 | ||
79 | val rootsOnto: t * Var.t list -> Var.t list = | |
80 | fn (t, ac) => | |
81 | List.appendRev (foldRoots (t, [], op ::), ac) | |
82 | ||
83 | val rec dropVars: t -> t = | |
84 | fn T (info, ts) => | |
85 | let | |
86 | val info = | |
87 | case info of | |
88 | Flat => Flat | |
89 | | NotFlat {ty, ...} => NotFlat {ty = ty, var = NONE} | |
90 | in | |
91 | T (info, Prod.map (ts, dropVars)) | |
92 | end | |
93 | ||
94 | fun fillInRoots (t: t, {base: Var.t Base.t, offset: int}) | |
95 | : t * Statement.t list = | |
96 | let | |
97 | fun loop (t as T (info, ts), offset, ac) = | |
98 | case info of | |
99 | Flat => | |
100 | let | |
101 | val (ts, (offset, ac)) = | |
102 | Vector.mapAndFold | |
103 | (Prod.dest ts, (offset, ac), | |
104 | fn ({elt = t, isMutable}, (offset, ac)) => | |
105 | let | |
106 | val (t, offset, ac) = loop (t, offset, ac) | |
107 | in | |
108 | ({elt = t, isMutable = isMutable}, | |
109 | (offset, ac)) | |
110 | end) | |
111 | in | |
112 | (T (Flat, Prod.make ts), offset, ac) | |
113 | end | |
114 | | NotFlat {ty, var} => | |
115 | let | |
116 | val (t, ac) = | |
117 | case var of | |
118 | NONE => | |
119 | let | |
120 | val var = Var.newNoname () | |
121 | in | |
122 | (T (NotFlat {ty = ty, var = SOME var}, ts), | |
123 | Bind | |
124 | {exp = Select {base = base, | |
125 | offset = offset}, | |
126 | ty = ty, | |
127 | var = SOME var} :: ac) | |
128 | end | |
129 | | SOME _ => (t, ac) | |
130 | in | |
131 | (t, offset + 1, ac) | |
132 | end | |
133 | val (t, _, ac) = loop (t, offset, []) | |
134 | in | |
135 | (t, ac) | |
136 | end | |
137 | ||
138 | val fillInRoots = | |
139 | Trace.trace2 ("DeepFlatten.VarTree.fillInRoots", | |
140 | layout, | |
141 | fn {base, offset} => | |
142 | Layout.record [("base", Base.layout (base, Var.layout)), | |
143 | ("offset", Int.layout offset)], | |
144 | Layout.tuple2 (layout, List.layout Statement.layout)) | |
145 | fillInRoots | |
146 | end | |
147 | ||
148 | fun flatten {base: Var.t Base.t option, | |
149 | from: VarTree.t, | |
150 | offset: int, | |
151 | to: TypeTree.t}: {offset: int} * VarTree.t * Statement.t list = | |
152 | let | |
153 | val Tree.T (from, fs) = from | |
154 | in | |
155 | case from of | |
156 | VarTree.Flat => | |
157 | if TypeTree.isFlat to | |
158 | then flattensAt {base = base, | |
159 | froms = fs, | |
160 | offset = offset, | |
161 | tos = Tree.children to} | |
162 | else Error.bug "DeepFlatten.flatten: cannot flatten from Flat to NotFlat" | |
163 | | VarTree.NotFlat {ty, var} => | |
164 | let | |
165 | val (var, ss) = | |
166 | case var of | |
167 | NONE => | |
168 | let | |
169 | val base = | |
170 | case base of | |
171 | NONE => Error.bug "DeepFlatten.flatten: flatten missing base" | |
172 | | SOME base => base | |
173 | val result = Var.newNoname () | |
174 | in | |
175 | (result, | |
176 | [Bind {exp = Select {base = base, | |
177 | offset = offset}, | |
178 | ty = ty, | |
179 | var = SOME result}]) | |
180 | end | |
181 | | SOME var => (var, []) | |
182 | val (r, ss) = | |
183 | if TypeTree.isFlat to | |
184 | then | |
185 | let | |
186 | val (_, r, ss') = | |
187 | flattensAt {base = SOME (Base.Object var), | |
188 | froms = fs, | |
189 | offset = 0, | |
190 | tos = Tree.children to} | |
191 | in | |
192 | (r, ss @ ss') | |
193 | end | |
194 | else (Tree.T (VarTree.NotFlat {ty = ty, var = SOME var}, | |
195 | fs), | |
196 | ss) | |
197 | in | |
198 | ({offset = 1 + offset}, r, ss) | |
199 | end | |
200 | end | |
201 | and flattensAt {base: Var.t Base.t option, | |
202 | froms: VarTree.t Prod.t, | |
203 | offset: int, | |
204 | tos: TypeTree.t Prod.t} = | |
205 | let | |
206 | val (ts, (off, ss)) = | |
207 | Vector.map2AndFold | |
208 | (Prod.dest froms, Prod.dest tos, ({offset = offset}, []), | |
209 | fn ({elt = f, isMutable}, {elt = t, ...}, ({offset}, ss)) => | |
210 | let | |
211 | val () = | |
212 | if isMutable | |
213 | then Error.bug "DeepFlatten.flattensAt: mutable" | |
214 | else () | |
215 | val ({offset}, t, ss') = | |
216 | flatten {base = base, | |
217 | from = f, | |
218 | offset = offset, | |
219 | to = t} | |
220 | in | |
221 | ({elt = t, isMutable = false}, | |
222 | ({offset = offset}, ss' @ ss)) | |
223 | end) | |
224 | in | |
225 | (off, Tree.T (VarTree.Flat, Prod.make ts), ss) | |
226 | end | |
227 | ||
228 | fun coerceTree {from: VarTree.t, to: TypeTree.t}: VarTree.t * Statement.t list = | |
229 | let | |
230 | val (_, r, ss) = | |
231 | flatten {base = NONE, | |
232 | from = from, | |
233 | offset = 0, | |
234 | to = to} | |
235 | in | |
236 | (r, ss) | |
237 | end | |
238 | ||
239 | val coerceTree = | |
240 | let | |
241 | open Layout | |
242 | in | |
243 | Trace.trace ("DeepFlatten.coerceTree", | |
244 | fn {from, to} => | |
245 | record [("from", VarTree.layout from), | |
246 | ("to", TypeTree.layout to)], | |
247 | fn (vt, ss) => | |
248 | tuple [VarTree.layout vt, | |
249 | List.layout Statement.layout ss]) | |
250 | coerceTree | |
251 | end | |
252 | ||
253 | structure Flat = | |
254 | struct | |
255 | datatype t = Flat | NotFlat | |
256 | ||
257 | val toString: t -> string = | |
258 | fn Flat => "Flat" | |
259 | | NotFlat => "NotFlat" | |
260 | ||
261 | val layout = Layout.str o toString | |
262 | end | |
263 | ||
264 | datatype z = datatype Flat.t | |
265 | ||
266 | structure Value = | |
267 | struct | |
268 | datatype t = | |
269 | Ground of Type.t | |
270 | | Object of object Equatable.t | |
271 | | Weak of {arg: t} | |
272 | withtype object = {args: t Prod.t, | |
273 | coercedFrom: t AppendList.t ref, | |
274 | con: ObjectCon.t, | |
275 | finalOffsets: int vector option ref, | |
276 | finalTree: TypeTree.t option ref, | |
277 | finalType: Type.t option ref, | |
278 | finalTypes: Type.t Prod.t option ref, | |
279 | flat: Flat.t ref} | |
280 | ||
281 | fun layout (v: t): Layout.t = | |
282 | let | |
283 | open Layout | |
284 | in | |
285 | case v of | |
286 | Ground t => Type.layout t | |
287 | | Object e => | |
288 | Equatable.layout | |
289 | (e, fn {args, con, flat, ...} => | |
290 | seq [str "Object ", | |
291 | record [("args", Prod.layout (args, layout)), | |
292 | ("con", ObjectCon.layout con), | |
293 | ("flat", Flat.layout (! flat))]]) | |
294 | | Weak {arg, ...} => seq [str "Weak ", layout arg] | |
295 | end | |
296 | ||
297 | val ground = Ground | |
298 | ||
299 | val traceCoerce = | |
300 | Trace.trace ("DeepFlatten.Value.coerce", | |
301 | fn {from, to} => | |
302 | Layout.record [("from", layout from), | |
303 | ("to", layout to)], | |
304 | Unit.layout) | |
305 | ||
306 | val traceUnify = | |
307 | Trace.trace2 ("DeepFlatten.Value.unify", layout, layout, Unit.layout) | |
308 | ||
309 | val rec unify: t * t -> unit = | |
310 | fn arg => | |
311 | traceUnify | |
312 | (fn (v, v') => | |
313 | case (v, v') of | |
314 | (Ground _, Ground _) => () | |
315 | | (Object e, Object e') => | |
316 | let | |
317 | val callDont = ref false | |
318 | val () = | |
319 | Equatable.equate | |
320 | (e, e', | |
321 | fn (z as {args = a, coercedFrom = c, flat = f, ...}, | |
322 | z' as {args = a', coercedFrom = c', flat = f', ...}) => | |
323 | let | |
324 | val () = unifyProd (a, a') | |
325 | in | |
326 | case (!f, !f') of | |
327 | (Flat, Flat) => | |
328 | (c := AppendList.append (!c', !c); z) | |
329 | | (Flat, NotFlat) => | |
330 | (callDont := true; z) | |
331 | | (NotFlat, Flat) => | |
332 | (callDont := true; z') | |
333 | | (NotFlat, NotFlat) => z | |
334 | end) | |
335 | in | |
336 | if !callDont | |
337 | then dontFlatten v | |
338 | else () | |
339 | end | |
340 | | (Weak {arg = a, ...}, Weak {arg = a', ...}) => | |
341 | unify (a, a') | |
342 | | _ => Error.bug "DeepFlatten.unify: strange") arg | |
343 | and unifyProd = | |
344 | fn (p, p') => | |
345 | Vector.foreach2 | |
346 | (Prod.dest p, Prod.dest p', | |
347 | fn ({elt = e, ...}, {elt = e', ...}) => unify (e, e')) | |
348 | and dontFlatten: t -> unit = | |
349 | fn v => | |
350 | case v of | |
351 | Object e => | |
352 | let | |
353 | val {coercedFrom, flat, ...} = Equatable.value e | |
354 | in | |
355 | case ! flat of | |
356 | Flat => | |
357 | let | |
358 | val () = flat := NotFlat | |
359 | val from = !coercedFrom | |
360 | val () = coercedFrom := AppendList.empty | |
361 | in | |
362 | AppendList.foreach (from, fn v' => unify (v, v')) | |
363 | end | |
364 | | NotFlat => () | |
365 | end | |
366 | | _ => () | |
367 | ||
368 | val rec coerce = | |
369 | fn arg as {from, to} => | |
370 | traceCoerce | |
371 | (fn _ => | |
372 | case (from, to) of | |
373 | (Ground _, Ground _) => () | |
374 | | (Object e, Object e') => | |
375 | if Equatable.equals (e, e') | |
376 | then () | |
377 | else | |
378 | Equatable.whenComputed | |
379 | (e', fn {args = a', coercedFrom = c', flat = f', ...} => | |
380 | let | |
381 | val {args = a, con, ...} = Equatable.value e | |
382 | in | |
383 | if Prod.someIsMutable a orelse ObjectCon.isVector con | |
384 | then unify (from, to) | |
385 | else | |
386 | case !f' of | |
387 | Flat => (AppendList.push (c', from) | |
388 | ; coerceProd {from = a, to = a'}) | |
389 | | NotFlat => unify (from, to) | |
390 | end) | |
391 | | (Weak _, Weak _) => unify (from, to) | |
392 | | _ => Error.bug "DeepFlatten.coerce: strange") arg | |
393 | and coerceProd = | |
394 | fn {from = p, to = p'} => | |
395 | Vector.foreach2 | |
396 | (Prod.dest p, Prod.dest p', fn ({elt = e, ...}, {elt = e', ...}) => | |
397 | coerce {from = e, to = e'}) | |
398 | ||
399 | fun mayFlatten {args, con}: bool = | |
400 | (* Don't flatten constructors, since they are part of a sum type. | |
401 | * Don't flatten unit. | |
402 | * Don't flatten vectors (of course their components can be | |
403 | * flattened). | |
404 | * Don't flatten objects with mutable fields, since sharing must be | |
405 | * preserved. | |
406 | *) | |
407 | not (Prod.isEmpty args) | |
408 | andalso Prod.allAreImmutable args | |
409 | andalso (case con of | |
410 | ObjectCon.Con _ => false | |
411 | | ObjectCon.Tuple => true | |
412 | | ObjectCon.Vector => false) | |
413 | ||
414 | fun objectFields {args, con} = | |
415 | let | |
416 | (* Don't flatten object components that are immutable fields. Those | |
417 | * have already had a chance to be flattened by other passes. | |
418 | *) | |
419 | val _ = | |
420 | if (case con of | |
421 | ObjectCon.Con _ => true | |
422 | | ObjectCon.Tuple => true | |
423 | | ObjectCon.Vector => false) | |
424 | then Vector.foreach (Prod.dest args, fn {elt, isMutable} => | |
425 | if isMutable | |
426 | then () | |
427 | else dontFlatten elt) | |
428 | else () | |
429 | val flat = | |
430 | if mayFlatten {args = args, con = con} | |
431 | then Flat.Flat | |
432 | else Flat.NotFlat | |
433 | in | |
434 | {args = args, | |
435 | coercedFrom = ref AppendList.empty, | |
436 | con = con, | |
437 | finalOffsets = ref NONE, | |
438 | finalTree = ref NONE, | |
439 | finalType = ref NONE, | |
440 | finalTypes = ref NONE, | |
441 | flat = ref flat} | |
442 | end | |
443 | ||
444 | fun object f = | |
445 | Object (Equatable.delay (fn () => objectFields (f ()))) | |
446 | ||
447 | val tuple: t Prod.t -> t = | |
448 | fn vs => | |
449 | Object (Equatable.new (objectFields {args = vs, con = ObjectCon.Tuple})) | |
450 | ||
451 | val tuple = | |
452 | Trace.trace ("DeepFlatten.Value.tuple", | |
453 | fn p => Prod.layout (p, layout), | |
454 | layout) | |
455 | tuple | |
456 | ||
457 | fun weak (arg: t) = Weak {arg = arg} | |
458 | ||
459 | val deObject: t -> object option = | |
460 | fn v => | |
461 | case v of | |
462 | Object e => SOME (Equatable.value e) | |
463 | | _ => NONE | |
464 | ||
465 | val traceFinalType = | |
466 | Trace.trace ("DeepFlatten.Value.finalType", layout, Type.layout) | |
467 | val traceFinalTypes = | |
468 | Trace.trace ("DeepFlatten.Value.finalTypes", | |
469 | layout, | |
470 | fn p => Prod.layout (p, Type.layout)) | |
471 | ||
472 | fun finalTree (v: t): TypeTree.t = | |
473 | let | |
474 | fun notFlat (): TypeTree.info = | |
475 | TypeTree.NotFlat {ty = finalType v, var = NONE} | |
476 | in | |
477 | case deObject v of | |
478 | NONE => Tree.T (notFlat (), Prod.empty ()) | |
479 | | SOME {args, finalTree = r, flat, ...} => | |
480 | Ref.memoize | |
481 | (r, fn () => | |
482 | let | |
483 | val info = | |
484 | case !flat of | |
485 | Flat => TypeTree.Flat | |
486 | | NotFlat => notFlat () | |
487 | in | |
488 | Tree.T (info, Prod.map (args, finalTree)) | |
489 | end) | |
490 | end | |
491 | and finalType arg: Type.t = | |
492 | traceFinalType | |
493 | (fn v => | |
494 | case v of | |
495 | Ground t => t | |
496 | | Object e => | |
497 | let | |
498 | val {finalType = r, ...} = Equatable.value e | |
499 | in | |
500 | Ref.memoize (r, fn () => Prod.elt (finalTypes v, 0)) | |
501 | end | |
502 | | Weak {arg, ...} => Type.weak (finalType arg)) arg | |
503 | and finalTypes arg: Type.t Prod.t = | |
504 | traceFinalTypes | |
505 | (fn v => | |
506 | case deObject v of | |
507 | NONE => | |
508 | Prod.make (Vector.new1 {elt = finalType v, | |
509 | isMutable = false}) | |
510 | | SOME {args, con, finalTypes, flat, ...} => | |
511 | Ref.memoize | |
512 | (finalTypes, fn () => | |
513 | let | |
514 | val args = prodFinalTypes args | |
515 | in | |
516 | case !flat of | |
517 | Flat => args | |
518 | | NotFlat => | |
519 | Prod.make | |
520 | (Vector.new1 | |
521 | {elt = Type.object {args = args, con = con}, | |
522 | isMutable = false}) | |
523 | end)) arg | |
524 | and prodFinalTypes (p: t Prod.t): Type.t Prod.t = | |
525 | Prod.make | |
526 | (Vector.fromList | |
527 | (Vector.foldr | |
528 | (Prod.dest p, [], fn ({elt, isMutable = i}, ac) => | |
529 | Vector.foldr | |
530 | (Prod.dest (finalTypes elt), ac, fn ({elt, isMutable = i'}, ac) => | |
531 | {elt = elt, isMutable = i orelse i'} :: ac)))) | |
532 | end | |
533 | ||
534 | structure Object = | |
535 | struct | |
536 | type t = Value.object | |
537 | ||
538 | fun select ({args, ...}: t, offset): Value.t = | |
539 | Prod.elt (args, offset) | |
540 | ||
541 | fun finalOffsets ({args, finalOffsets = r, ...}: t): int vector = | |
542 | Ref.memoize | |
543 | (r, fn () => | |
544 | Vector.fromListRev | |
545 | (#2 (Prod.fold | |
546 | (args, (0, []), fn (elt, (offset, offsets)) => | |
547 | (offset + Prod.length (Value.finalTypes elt), | |
548 | offset :: offsets))))) | |
549 | ||
550 | fun finalOffset (object, offset) = | |
551 | Vector.sub (finalOffsets object, offset) | |
552 | end | |
553 | ||
554 | fun transform2 (program as Program.T {datatypes, functions, globals, main}) = | |
555 | let | |
556 | val {get = conValue: Con.t -> Value.t option ref, ...} = | |
557 | Property.get (Con.plist, Property.initFun (fn _ => ref NONE)) | |
558 | val conValue = | |
559 | Trace.trace ("DeepFlatten.conValue", | |
560 | Con.layout, Ref.layout (Option.layout Value.layout)) | |
561 | conValue | |
562 | datatype 'a make = | |
563 | Const of 'a | |
564 | | Make of unit -> 'a | |
565 | val traceMakeTypeValue = | |
566 | Trace.trace ("DeepFlatten.makeTypeValue", | |
567 | Type.layout o #1, | |
568 | Layout.ignore) | |
569 | fun makeValue m = | |
570 | case m of | |
571 | Const v => v | |
572 | | Make f => f () | |
573 | fun needToMakeProd p = | |
574 | Vector.exists (Prod.dest p, fn {elt, ...} => | |
575 | case elt of | |
576 | Const _ => false | |
577 | | Make _ => true) | |
578 | fun makeProd p = Prod.map (p, makeValue) | |
579 | val {get = makeTypeValue: Type.t -> Value.t make, ...} = | |
580 | Property.get | |
581 | (Type.plist, | |
582 | Property.initRec | |
583 | (traceMakeTypeValue | |
584 | (fn (t, makeTypeValue) => | |
585 | let | |
586 | fun const () = Const (Value.ground t) | |
587 | datatype z = datatype Type.dest | |
588 | in | |
589 | case Type.dest t of | |
590 | Object {args, con} => | |
591 | let | |
592 | val args = Prod.map (args, makeTypeValue) | |
593 | fun doit () = | |
594 | if needToMakeProd args | |
595 | orelse Value.mayFlatten {args = args, con = con} | |
596 | then | |
597 | Make | |
598 | (fn () => | |
599 | Value.object (fn () => {args = makeProd args, | |
600 | con = con})) | |
601 | else const () | |
602 | datatype z = datatype ObjectCon.t | |
603 | in | |
604 | case con of | |
605 | Con c => | |
606 | Const (Ref.memoize | |
607 | (conValue c, fn () => | |
608 | makeValue (doit ()))) | |
609 | | Tuple => doit () | |
610 | | Vector => doit () | |
611 | end | |
612 | | Weak t => | |
613 | (case makeTypeValue t of | |
614 | Const _ => const () | |
615 | | Make f => Make (fn () => Value.weak (f ()))) | |
616 | | _ => const () | |
617 | end))) | |
618 | fun typeValue (t: Type.t): Value.t = | |
619 | makeValue (makeTypeValue t) | |
620 | val typeValue = | |
621 | Trace.trace ("DeepFlatten.typeValue", Type.layout, Value.layout) | |
622 | typeValue | |
623 | val (coerce, coerceProd) = (Value.coerce, Value.coerceProd) | |
624 | fun inject {sum, variant = _} = typeValue (Type.datatypee sum) | |
625 | fun object {args, con, resultType} = | |
626 | let | |
627 | val m = makeTypeValue resultType | |
628 | in | |
629 | case con of | |
630 | NONE => | |
631 | (case m of | |
632 | Const v => v | |
633 | | Make _ => Value.tuple args) | |
634 | | SOME _ => | |
635 | (case m of | |
636 | Const v => | |
637 | let | |
638 | val () = | |
639 | case Value.deObject v of | |
640 | NONE => () | |
641 | | SOME {args = args', ...} => | |
642 | coerceProd {from = args, to = args'} | |
643 | in | |
644 | v | |
645 | end | |
646 | | _ => Error.bug "DeepFlatten.object: strange con value") | |
647 | end | |
648 | val object = | |
649 | Trace.trace | |
650 | ("DeepFlatten.object", | |
651 | fn {args, con, ...} => | |
652 | Layout.record [("args", Prod.layout (args, Value.layout)), | |
653 | ("con", Option.layout Con.layout con)], | |
654 | Value.layout) | |
655 | object | |
656 | val deWeak : Value.t -> Value.t = | |
657 | fn v => | |
658 | case v of | |
659 | Value.Ground t => | |
660 | typeValue (case Type.dest t of | |
661 | Type.Weak t => t | |
662 | | _ => Error.bug "DeepFlatten.primApp: deWeak") | |
663 | | Value.Weak {arg, ...} => arg | |
664 | | _ => Error.bug "DeepFlatten.primApp: Value.deWeak" | |
665 | fun primApp {args, prim, resultVar = _, resultType} = | |
666 | let | |
667 | fun weak v = | |
668 | case makeTypeValue resultType of | |
669 | Const v => v | |
670 | | Make _ => Value.weak v | |
671 | fun arg i = Vector.sub (args, i) | |
672 | fun result () = typeValue resultType | |
673 | datatype z = datatype Prim.Name.t | |
674 | fun dontFlatten () = | |
675 | (Vector.foreach (args, Value.dontFlatten) | |
676 | ; result ()) | |
677 | fun equal () = | |
678 | (Value.unify (arg 0, arg 1) | |
679 | ; Value.dontFlatten (arg 0) | |
680 | ; result ()) | |
681 | in | |
682 | case Prim.name prim of | |
683 | Array_toArray => | |
684 | let | |
685 | val res = result () | |
686 | val () = | |
687 | case (Value.deObject (arg 0), Value.deObject res) of | |
688 | (NONE, NONE) => () | |
689 | | (SOME {args = a, ...}, SOME {args = a', ...}) => | |
690 | Vector.foreach2 | |
691 | (Prod.dest a, Prod.dest a', | |
692 | fn ({elt = v, ...}, {elt = v', ...}) => | |
693 | Value.unify (v, v')) | |
694 | | _ => Error.bug "DeepFlatten.primApp: Array_toArray" | |
695 | in | |
696 | res | |
697 | end | |
698 | | Array_toVector => | |
699 | let | |
700 | val res = result () | |
701 | val () = | |
702 | case (Value.deObject (arg 0), Value.deObject res) of | |
703 | (NONE, NONE) => () | |
704 | | (SOME {args = a, ...}, SOME {args = a', ...}) => | |
705 | Vector.foreach2 | |
706 | (Prod.dest a, Prod.dest a', | |
707 | fn ({elt = v, ...}, {elt = v', ...}) => | |
708 | Value.unify (v, v')) | |
709 | | _ => Error.bug "DeepFlatten.primApp: Array_toVector" | |
710 | in | |
711 | res | |
712 | end | |
713 | | FFI _ => | |
714 | (* Some imports, like Real64.modf, take ref cells that can not | |
715 | * be flattened. | |
716 | *) | |
717 | dontFlatten () | |
718 | | MLton_eq => equal () | |
719 | | MLton_equal => equal () | |
720 | | MLton_size => dontFlatten () | |
721 | | MLton_share => dontFlatten () | |
722 | | Weak_get => deWeak (arg 0) | |
723 | | Weak_new => | |
724 | let val a = arg 0 | |
725 | in (Value.dontFlatten a; weak a) | |
726 | end | |
727 | | _ => result () | |
728 | end | |
729 | fun base b = | |
730 | case b of | |
731 | Base.Object obj => obj | |
732 | | Base.VectorSub {vector, ...} => vector | |
733 | fun select {base, offset} = | |
734 | let | |
735 | datatype z = datatype Value.t | |
736 | in | |
737 | case base of | |
738 | Ground t => | |
739 | (case Type.dest t of | |
740 | Type.Object {args, ...} => | |
741 | typeValue (Prod.elt (args, offset)) | |
742 | | _ => Error.bug "DeepFlatten.select: Ground") | |
743 | | Object e => Object.select (Equatable.value e, offset) | |
744 | | _ => Error.bug "DeepFlatten.select:" | |
745 | end | |
746 | fun update {base, offset, value} = | |
747 | coerce {from = value, | |
748 | to = select {base = base, offset = offset}} | |
749 | fun const c = typeValue (Type.ofConst c) | |
750 | val {func, value = varValue, ...} = | |
751 | analyze {base = base, | |
752 | coerce = coerce, | |
753 | const = const, | |
754 | filter = fn _ => (), | |
755 | filterWord = fn _ => (), | |
756 | fromType = typeValue, | |
757 | inject = inject, | |
758 | layout = Value.layout, | |
759 | object = object, | |
760 | primApp = primApp, | |
761 | program = program, | |
762 | select = fn {base, offset, ...} => select {base = base, | |
763 | offset = offset}, | |
764 | update = update, | |
765 | useFromTypeOnBinds = false} | |
766 | (* Don't flatten outermost part of formal parameters. *) | |
767 | fun dontFlattenFormals (xts: (Var.t * Type.t) vector): unit = | |
768 | Vector.foreach (xts, fn (x, _) => Value.dontFlatten (varValue x)) | |
769 | val () = | |
770 | List.foreach | |
771 | (functions, fn f => | |
772 | let | |
773 | val {args, blocks, ...} = Function.dest f | |
774 | val () = dontFlattenFormals args | |
775 | val () = Vector.foreach (blocks, fn Block.T {args, ...} => | |
776 | dontFlattenFormals args) | |
777 | in | |
778 | () | |
779 | end) | |
780 | val () = | |
781 | Control.diagnostics | |
782 | (fn display => | |
783 | let | |
784 | open Layout | |
785 | val () = | |
786 | Vector.foreach | |
787 | (datatypes, fn Datatype.T {cons, ...} => | |
788 | Vector.foreach | |
789 | (cons, fn {con, ...} => | |
790 | display (Option.layout Value.layout (! (conValue con))))) | |
791 | val () = | |
792 | Program.foreachVar | |
793 | (program, fn (x, _) => | |
794 | display | |
795 | (seq [Var.layout x, str " ", Value.layout (varValue x)])) | |
796 | in | |
797 | () | |
798 | end) | |
799 | (* Transform the program. *) | |
800 | val datatypes = | |
801 | Vector.map | |
802 | (datatypes, fn Datatype.T {cons, tycon} => | |
803 | let | |
804 | val cons = | |
805 | Vector.map | |
806 | (cons, fn {con, args} => | |
807 | let | |
808 | val args = | |
809 | case ! (conValue con) of | |
810 | NONE => args | |
811 | | SOME v => | |
812 | case Type.dest (Value.finalType v) of | |
813 | Type.Object {args, ...} => args | |
814 | | _ => Error.bug "DeepFlatten.datatypes: strange con" | |
815 | in | |
816 | {args = args, con = con} | |
817 | end) | |
818 | in | |
819 | Datatype.T {cons = cons, tycon = tycon} | |
820 | end) | |
821 | val valueType = Value.finalType | |
822 | fun valuesTypes vs = Vector.map (vs, Value.finalType) | |
823 | val {get = varTree: Var.t -> VarTree.t, set = setVarTree, ...} = | |
824 | Property.getSetOnce (Var.plist, | |
825 | Property.initRaise ("tree", Var.layout)) | |
826 | val setVarTree = | |
827 | Trace.trace2 ("DeepFlatten.setVarTree", | |
828 | Var.layout, VarTree.layout, Unit.layout) | |
829 | setVarTree | |
830 | fun simpleVarTree (x: Var.t): unit = | |
831 | setVarTree | |
832 | (x, VarTree.labelRoot (VarTree.fromTypeTree | |
833 | (Value.finalTree (varValue x)), | |
834 | x)) | |
835 | fun transformFormals xts = | |
836 | Vector.map (xts, fn (x, _) => | |
837 | let | |
838 | val () = simpleVarTree x | |
839 | in | |
840 | (x, Value.finalType (varValue x)) | |
841 | end) | |
842 | fun replaceVar (x: Var.t): Var.t = | |
843 | let | |
844 | fun bug () = Error.bug (concat ["DeepFlatten.replaceVar ", Var.toString x]) | |
845 | val Tree.T (info, _) = varTree x | |
846 | in | |
847 | case info of | |
848 | VarTree.Flat => bug () | |
849 | | VarTree.NotFlat {var, ...} => | |
850 | case var of | |
851 | NONE => bug () | |
852 | | SOME y => y | |
853 | end | |
854 | fun transformBind {exp, ty, var}: Statement.t list = | |
855 | let | |
856 | fun simpleTree () = Option.app (var, simpleVarTree) | |
857 | fun doit (e: Exp.t) = | |
858 | let | |
859 | val ty = | |
860 | case var of | |
861 | NONE => ty | |
862 | | SOME var => valueType (varValue var) | |
863 | in | |
864 | [Bind {exp = e, ty = ty, var = var}] | |
865 | end | |
866 | fun simple () = | |
867 | (simpleTree () | |
868 | ; doit (Exp.replaceVar (exp, replaceVar))) | |
869 | fun none () = [] | |
870 | in | |
871 | case exp of | |
872 | Exp.Const _ => simple () | |
873 | | Inject _ => simple () | |
874 | | Object {args, con} => | |
875 | (case var of | |
876 | NONE => none () | |
877 | | SOME var => | |
878 | let | |
879 | val v = varValue var | |
880 | in | |
881 | case Value.deObject v of | |
882 | NONE => simple () | |
883 | | SOME {args = expects, flat, ...} => | |
884 | let | |
885 | val z = | |
886 | Vector.map2 | |
887 | (args, Prod.dest expects, | |
888 | fn (arg, {elt, isMutable}) => | |
889 | let | |
890 | val (vt, ss) = | |
891 | coerceTree | |
892 | {from = varTree arg, | |
893 | to = Value.finalTree elt} | |
894 | in | |
895 | ({elt = vt, | |
896 | isMutable = isMutable}, | |
897 | ss) | |
898 | end) | |
899 | val vts = Vector.map (z, #1) | |
900 | fun set info = | |
901 | setVarTree (var, | |
902 | Tree.T (info, | |
903 | Prod.make vts)) | |
904 | in | |
905 | case !flat of | |
906 | Flat => (set VarTree.Flat; none ()) | |
907 | | NotFlat => | |
908 | let | |
909 | val ty = Value.finalType v | |
910 | val () = | |
911 | set (VarTree.NotFlat | |
912 | {ty = ty, | |
913 | var = SOME var}) | |
914 | val args = | |
915 | Vector.fromList | |
916 | (Vector.foldr | |
917 | (vts, [], | |
918 | fn ({elt = vt, ...}, ac) => | |
919 | VarTree.rootsOnto (vt, ac))) | |
920 | val obj = | |
921 | Bind | |
922 | {exp = Object {args = args, | |
923 | con = con}, | |
924 | ty = ty, | |
925 | var = SOME var} | |
926 | in | |
927 | Vector.foldr | |
928 | (z, [obj], | |
929 | fn ((_, ss), ac) => ss @ ac) | |
930 | end | |
931 | end | |
932 | end) | |
933 | | PrimApp _ => simple () | |
934 | | Select {base, offset} => | |
935 | (case var of | |
936 | NONE => none () | |
937 | | SOME var => | |
938 | let | |
939 | val baseVar = Base.object base | |
940 | in | |
941 | case Value.deObject (varValue baseVar) of | |
942 | NONE => simple () | |
943 | | SOME obj => | |
944 | let | |
945 | val Tree.T (info, children) = | |
946 | varTree baseVar | |
947 | val {elt = child, isMutable} = | |
948 | Prod.sub (children, offset) | |
949 | val (child, ss) = | |
950 | case info of | |
951 | VarTree.Flat => (child, []) | |
952 | | VarTree.NotFlat _ => | |
953 | let | |
954 | val child = | |
955 | (* Don't simplify a select out | |
956 | * of a mutable field. | |
957 | * Something may have mutated | |
958 | * it. | |
959 | *) | |
960 | if isMutable | |
961 | then VarTree.dropVars child | |
962 | else child | |
963 | in | |
964 | VarTree.fillInRoots | |
965 | (child, | |
966 | {base = Base.map (base, replaceVar), | |
967 | offset = (Object.finalOffset | |
968 | (obj, offset))}) | |
969 | end | |
970 | val () = setVarTree (var, child) | |
971 | in | |
972 | ss | |
973 | end | |
974 | end) | |
975 | | Var x => | |
976 | (Option.app (var, fn y => setVarTree (y, varTree x)) | |
977 | ; none ()) | |
978 | end | |
979 | fun transformStatement (s: Statement.t): Statement.t list = | |
980 | let | |
981 | fun simple () = [Statement.replaceUses (s, replaceVar)] | |
982 | in | |
983 | case s of | |
984 | Bind b => transformBind b | |
985 | | Profile _ => simple () | |
986 | | Update {base, offset, value} => | |
987 | let | |
988 | val baseVar = | |
989 | case base of | |
990 | Base.Object x => x | |
991 | | Base.VectorSub {vector = x, ...} => x | |
992 | in | |
993 | case Value.deObject (varValue baseVar) of | |
994 | NONE => simple () | |
995 | | SOME object => | |
996 | let | |
997 | val ss = ref [] | |
998 | val child = | |
999 | Value.finalTree (Object.select (object, offset)) | |
1000 | val offset = Object.finalOffset (object, offset) | |
1001 | val base = Base.map (base, replaceVar) | |
1002 | val us = | |
1003 | if not (TypeTree.isFlat child) | |
1004 | then [Update {base = base, | |
1005 | offset = offset, | |
1006 | value = replaceVar value}] | |
1007 | else | |
1008 | let | |
1009 | val (vt, ss') = | |
1010 | coerceTree {from = varTree value, | |
1011 | to = child} | |
1012 | val () = ss := ss' @ (!ss) | |
1013 | val r = ref offset | |
1014 | val us = ref [] | |
1015 | val () = | |
1016 | VarTree.foreachRoot | |
1017 | (vt, fn var => | |
1018 | let | |
1019 | val offset = !r | |
1020 | val () = r := 1 + !r | |
1021 | in | |
1022 | List.push (us, | |
1023 | Update {base = base, | |
1024 | offset = offset, | |
1025 | value = var}) | |
1026 | end) | |
1027 | in | |
1028 | !us | |
1029 | end | |
1030 | in | |
1031 | !ss @ us | |
1032 | end | |
1033 | end | |
1034 | end | |
1035 | val transformStatement = | |
1036 | Trace.trace ("DeepFlatten.transformStatement", | |
1037 | Statement.layout, | |
1038 | List.layout Statement.layout) | |
1039 | transformStatement | |
1040 | fun transformStatements ss = | |
1041 | Vector.concatV | |
1042 | (Vector.map (ss, Vector.fromList o transformStatement)) | |
1043 | fun transformTransfer t = Transfer.replaceVar (t, replaceVar) | |
1044 | val transformTransfer = | |
1045 | Trace.trace ("DeepFlatten.transformTransfer", | |
1046 | Transfer.layout, Transfer.layout) | |
1047 | transformTransfer | |
1048 | fun transformBlock (Block.T {args, label, statements, transfer}) = | |
1049 | Block.T {args = transformFormals args, | |
1050 | label = label, | |
1051 | statements = transformStatements statements, | |
1052 | transfer = transformTransfer transfer} | |
1053 | fun transformFunction (f: Function.t): Function.t = | |
1054 | let | |
1055 | val {args, mayInline, name, start, ...} = Function.dest f | |
1056 | val {raises, returns, ...} = func name | |
1057 | val args = transformFormals args | |
1058 | val raises = Option.map (raises, valuesTypes) | |
1059 | val returns = Option.map (returns, valuesTypes) | |
1060 | val blocks = ref [] | |
1061 | val () = | |
1062 | Function.dfs (f, fn b => | |
1063 | (List.push (blocks, transformBlock b) | |
1064 | ; fn () => ())) | |
1065 | in | |
1066 | Function.new {args = args, | |
1067 | blocks = Vector.fromList (!blocks), | |
1068 | mayInline = mayInline, | |
1069 | name = name, | |
1070 | raises = raises, | |
1071 | returns = returns, | |
1072 | start = start} | |
1073 | end | |
1074 | val globals = transformStatements globals | |
1075 | val functions = List.revMap (functions, transformFunction) | |
1076 | val program = | |
1077 | Program.T {datatypes = datatypes, | |
1078 | functions = functions, | |
1079 | globals = globals, | |
1080 | main = main} | |
1081 | val () = Program.clear program | |
1082 | in | |
1083 | shrink program | |
1084 | end | |
1085 | ||
1086 | end |