Commit | Line | Data |
---|---|---|
7f918cf1 CE |
1 | (* Copyright (C) 2009,2014,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 SsaTree2 (S: SSA_TREE2_STRUCTS): SSA_TREE2 = | |
11 | struct | |
12 | ||
13 | open S | |
14 | ||
15 | structure Prod = | |
16 | struct | |
17 | datatype 'a t = T of {elt: 'a, isMutable: bool} vector | |
18 | ||
19 | fun dest (T p) = p | |
20 | ||
21 | val make = T | |
22 | ||
23 | fun empty () = T (Vector.new0 ()) | |
24 | ||
25 | fun fold (p, b, f) = | |
26 | Vector.fold (dest p, b, fn ({elt, ...}, b) => f (elt, b)) | |
27 | ||
28 | fun foreach (p, f) = Vector.foreach (dest p, f o #elt) | |
29 | ||
30 | fun isEmpty p = Vector.isEmpty (dest p) | |
31 | ||
32 | fun allAreImmutable (T v) = Vector.forall (v, not o #isMutable) | |
33 | fun allAreMutable (T v) = Vector.forall (v, #isMutable) | |
34 | fun someIsImmutable (T v) = Vector.exists (v, not o #isMutable) | |
35 | fun someIsMutable (T v) = Vector.exists (v, #isMutable) | |
36 | ||
37 | fun sub (T p, i) = Vector.sub (p, i) | |
38 | ||
39 | fun elt (p, i) = #elt (sub (p, i)) | |
40 | ||
41 | fun length p = Vector.length (dest p) | |
42 | ||
43 | val equals: 'a t * 'a t * ('a * 'a -> bool) -> bool = | |
44 | fn (p1, p2, equals) => | |
45 | Vector.equals (dest p1, dest p2, | |
46 | fn ({elt = e1, isMutable = m1}, | |
47 | {elt = e2, isMutable = m2}) => | |
48 | m1 = m2 andalso equals (e1, e2)) | |
49 | ||
50 | fun layout (p, layout) = | |
51 | if isEmpty p | |
52 | then Layout.str "unit" | |
53 | else let | |
54 | open Layout | |
55 | in | |
56 | seq [str "(", | |
57 | (mayAlign o separateRight) | |
58 | (Vector.toListMap (dest p, fn {elt, isMutable} => | |
59 | if isMutable | |
60 | then seq [layout elt, str " ref"] | |
61 | else layout elt), | |
62 | " *"), | |
63 | str ")"] | |
64 | end | |
65 | ||
66 | val map: 'a t * ('a -> 'b) -> 'b t = | |
67 | fn (p, f) => | |
68 | make (Vector.map (dest p, fn {elt, isMutable} => | |
69 | {elt = f elt, | |
70 | isMutable = isMutable})) | |
71 | ||
72 | val keepAllMap: 'a t * ('a -> 'b option) -> 'b t = | |
73 | fn (p, f) => | |
74 | make (Vector.keepAllMap (dest p, fn {elt, isMutable} => | |
75 | Option.map (f elt, fn elt => | |
76 | {elt = elt, | |
77 | isMutable = isMutable}))) | |
78 | end | |
79 | ||
80 | structure ObjectCon = | |
81 | struct | |
82 | datatype t = | |
83 | Con of Con.t | |
84 | | Tuple | |
85 | | Vector | |
86 | ||
87 | val equals: t * t -> bool = | |
88 | fn (Con c, Con c') => Con.equals (c, c') | |
89 | | (Tuple, Tuple) => true | |
90 | | (Vector, Vector) => true | |
91 | | _ => false | |
92 | ||
93 | val isVector: t -> bool = | |
94 | fn Vector => true | |
95 | | _ => false | |
96 | ||
97 | val layout: t -> Layout.t = | |
98 | fn oc => | |
99 | let | |
100 | open Layout | |
101 | in | |
102 | case oc of | |
103 | Con c => Con.layout c | |
104 | | Tuple => str "Tuple" | |
105 | | Vector => str "Vector" | |
106 | end | |
107 | end | |
108 | ||
109 | datatype z = datatype ObjectCon.t | |
110 | ||
111 | structure Type = | |
112 | struct | |
113 | datatype t = | |
114 | T of {hash: Word.t, | |
115 | plist: PropertyList.t, | |
116 | tree: tree} | |
117 | and tree = | |
118 | CPointer | |
119 | | Datatype of Tycon.t | |
120 | | IntInf | |
121 | | Object of {args: t Prod.t, | |
122 | con: ObjectCon.t} | |
123 | | Real of RealSize.t | |
124 | | Thread | |
125 | | Weak of t | |
126 | | Word of WordSize.t | |
127 | ||
128 | local | |
129 | fun make f (T r) = f r | |
130 | in | |
131 | val hash = make #hash | |
132 | val plist = make #plist | |
133 | val tree = make #tree | |
134 | end | |
135 | ||
136 | datatype dest = datatype tree | |
137 | ||
138 | val dest = tree | |
139 | ||
140 | fun equals (t, t') = PropertyList.equals (plist t, plist t') | |
141 | ||
142 | val deVectorOpt: t -> t Prod.t option = | |
143 | fn t => | |
144 | case dest t of | |
145 | Object {args, con = Vector} => SOME args | |
146 | | _ => NONE | |
147 | ||
148 | val deVector1: t -> t = | |
149 | fn t => | |
150 | case deVectorOpt t of | |
151 | SOME args => | |
152 | if Prod.length args = 1 | |
153 | then Prod.elt (args, 0) | |
154 | else Error.bug "SsaTree2.Type.deVector1" | |
155 | | _ => Error.bug "SsaTree2.Type.deVector1" | |
156 | ||
157 | val isVector: t -> bool = isSome o deVectorOpt | |
158 | ||
159 | val deWeakOpt: t -> t option = | |
160 | fn t => | |
161 | case dest t of | |
162 | Weak t => SOME t | |
163 | | _ => NONE | |
164 | ||
165 | val deWeak: t -> t = valOf o deWeakOpt | |
166 | ||
167 | local | |
168 | val same: tree * tree -> bool = | |
169 | fn (CPointer, CPointer) => true | |
170 | | (Datatype t1, Datatype t2) => Tycon.equals (t1, t2) | |
171 | | (IntInf, IntInf) => true | |
172 | | (Object {args = a1, con = c1}, Object {args = a2, con = c2}) => | |
173 | ObjectCon.equals (c1, c2) | |
174 | andalso Prod.equals (a1, a2, equals) | |
175 | | (Real s1, Real s2) => RealSize.equals (s1, s2) | |
176 | | (Thread, Thread) => true | |
177 | | (Weak t1, Weak t2) => equals (t1, t2) | |
178 | | (Word s1, Word s2) => WordSize.equals (s1, s2) | |
179 | | _ => false | |
180 | val table: t HashSet.t = HashSet.new {hash = hash} | |
181 | in | |
182 | fun lookup (hash, tr) = | |
183 | HashSet.lookupOrInsert (table, hash, | |
184 | fn t => same (tr, tree t), | |
185 | fn () => T {hash = hash, | |
186 | plist = PropertyList.new (), | |
187 | tree = tr}) | |
188 | ||
189 | fun stats () = | |
190 | let open Layout | |
191 | in align [seq [str "num types in hash table = ", | |
192 | Int.layout (HashSet.size table)], | |
193 | Control.sizeMessage ("types hash table", lookup)] | |
194 | end | |
195 | end | |
196 | ||
197 | val newHash = Random.word | |
198 | ||
199 | local | |
200 | fun make f : t -> t = | |
201 | let | |
202 | val w = newHash () | |
203 | in | |
204 | fn t => lookup (Word.xorb (w, hash t), f t) | |
205 | end | |
206 | in | |
207 | val weak = make Weak | |
208 | end | |
209 | ||
210 | val datatypee: Tycon.t -> t = | |
211 | fn t => lookup (Tycon.hash t, Datatype t) | |
212 | ||
213 | val bool = datatypee Tycon.bool | |
214 | ||
215 | val isBool: t -> bool = | |
216 | fn t => | |
217 | case dest t of | |
218 | Datatype t => Tycon.equals (t, Tycon.bool) | |
219 | | _ => false | |
220 | ||
221 | local | |
222 | fun make (tycon, tree) = lookup (Tycon.hash tycon, tree) | |
223 | in | |
224 | val cpointer = make (Tycon.cpointer, CPointer) | |
225 | val intInf = make (Tycon.intInf, IntInf) | |
226 | val thread = make (Tycon.thread, Thread) | |
227 | end | |
228 | ||
229 | val real: RealSize.t -> t = | |
230 | fn s => lookup (Tycon.hash (Tycon.real s), Real s) | |
231 | ||
232 | val word: WordSize.t -> t = | |
233 | fn s => lookup (Tycon.hash (Tycon.word s), Word s) | |
234 | ||
235 | local | |
236 | val generator: Word.t = 0wx5555 | |
237 | val tuple = newHash () | |
238 | val vector = newHash () | |
239 | fun hashProd (p, base) = | |
240 | Vector.fold (Prod.dest p, base, fn ({elt, ...}, w) => | |
241 | Word.xorb (w * generator, hash elt)) | |
242 | in | |
243 | fun object {args, con}: t = | |
244 | let | |
245 | val base = | |
246 | case con of | |
247 | Con c => Con.hash c | |
248 | | Tuple => tuple | |
249 | | Vector => vector | |
250 | val hash = hashProd (args, base) | |
251 | in | |
252 | lookup (hash, Object {args = args, con = con}) | |
253 | end | |
254 | end | |
255 | ||
256 | fun vector p = object {args = p, con = Vector} | |
257 | ||
258 | local | |
259 | fun make isMutable t = | |
260 | vector (Prod.make (Vector.new1 {elt = t, isMutable = isMutable})) | |
261 | in | |
262 | val array1 = make true | |
263 | val vector1 = make false | |
264 | end | |
265 | ||
266 | fun ofConst c = | |
267 | let | |
268 | datatype z = datatype Const.t | |
269 | in | |
270 | case c of | |
271 | IntInf _ => intInf | |
272 | | Null => cpointer | |
273 | | Real r => real (RealX.size r) | |
274 | | Word w => word (WordX.size w) | |
275 | | WordVector v => vector1 (word (WordXVector.elementSize v)) | |
276 | end | |
277 | ||
278 | fun conApp (con, args) = object {args = args, con = Con con} | |
279 | ||
280 | fun tuple ts = object {args = ts, con = Tuple} | |
281 | ||
282 | fun reff1 t = | |
283 | object {args = Prod.make (Vector.new1 {elt = t, isMutable = true}), | |
284 | con = Tuple} | |
285 | ||
286 | val unit: t = tuple (Prod.empty ()) | |
287 | ||
288 | val isUnit: t -> bool = | |
289 | fn t => | |
290 | case dest t of | |
291 | Object {args, con = Tuple} => Prod.isEmpty args | |
292 | | _ => false | |
293 | ||
294 | local | |
295 | open Layout | |
296 | in | |
297 | val {get = layout, ...} = | |
298 | Property.get | |
299 | (plist, | |
300 | Property.initRec | |
301 | (fn (t, layout) => | |
302 | case dest t of | |
303 | CPointer => str "cpointer" | |
304 | | Datatype t => Tycon.layout t | |
305 | | IntInf => str "intInf" | |
306 | | Object {args, con} => | |
307 | if isUnit t | |
308 | then str "unit" | |
309 | else | |
310 | let | |
311 | val args = Prod.layout (args, layout) | |
312 | in | |
313 | case con of | |
314 | Con c => seq [Con.layout c, str " of ", args] | |
315 | | Tuple => args | |
316 | | Vector => seq [args, str " vector"] | |
317 | end | |
318 | | Real s => str (concat ["real", RealSize.toString s]) | |
319 | | Thread => str "thread" | |
320 | | Weak t => seq [layout t, str " weak"] | |
321 | | Word s => str (concat ["word", WordSize.toString s]))) | |
322 | end | |
323 | ||
324 | fun checkPrimApp {args, prim, result}: bool = | |
325 | let | |
326 | exception BadPrimApp | |
327 | fun default () = | |
328 | let | |
329 | val targs = | |
330 | Prim.extractTargs | |
331 | (prim, | |
332 | {args = args, | |
333 | result = result, | |
334 | typeOps = {deArray = fn _ => raise BadPrimApp, | |
335 | deArrow = fn _ => raise BadPrimApp, | |
336 | deRef = fn _ => raise BadPrimApp, | |
337 | deVector = fn _ => raise BadPrimApp, | |
338 | deWeak = deWeak}}) | |
339 | in | |
340 | Prim.checkApp | |
341 | (prim, | |
342 | {args = args, | |
343 | result = result, | |
344 | targs = targs, | |
345 | typeOps = {array = array1, | |
346 | arrow = fn _ => raise BadPrimApp, | |
347 | bool = bool, | |
348 | cpointer = cpointer, | |
349 | equals = equals, | |
350 | exn = unit, | |
351 | intInf = intInf, | |
352 | real = real, | |
353 | reff = fn _ => raise BadPrimApp, | |
354 | thread = thread, | |
355 | unit = unit, | |
356 | vector = vector1, | |
357 | weak = weak, | |
358 | word = word}}) | |
359 | end | |
360 | val default = fn () => | |
361 | (default ()) handle BadPrimApp => false | |
362 | ||
363 | datatype z = datatype Prim.Name.t | |
364 | fun arg i = Vector.sub (args, i) | |
365 | fun oneArg f = 1 = Vector.length args andalso f (arg 0) | |
366 | fun twoArgs f = 2 = Vector.length args andalso f (arg 0, arg 1) | |
367 | fun fiveArgs f = 5 = Vector.length args andalso f (arg 0, arg 1, arg 2, arg 3, arg 4) | |
368 | val seqIndex = word (WordSize.seqIndex ()) | |
369 | in | |
370 | case Prim.name prim of | |
371 | Array_alloc _ => | |
372 | oneArg | |
373 | (fn n => | |
374 | case deVectorOpt result of | |
375 | SOME resp => | |
376 | Prod.allAreMutable resp | |
377 | andalso equals (n, seqIndex) | |
378 | | _ => false) | |
379 | | Array_copyArray => | |
380 | fiveArgs | |
381 | (fn (dst, di, src, si, len) => | |
382 | case (deVectorOpt dst, deVectorOpt src) of | |
383 | (SOME dstp, SOME srcp) => | |
384 | Vector.equals (Prod.dest dstp, Prod.dest srcp, | |
385 | fn ({elt = dstElt, isMutable = dstIsMutable}, | |
386 | {elt = srcElt, isMutable = srcIsMutable}) => | |
387 | dstIsMutable andalso srcIsMutable | |
388 | andalso equals (dstElt, srcElt)) | |
389 | andalso equals (di, seqIndex) | |
390 | andalso equals (si, seqIndex) | |
391 | andalso equals (len, seqIndex) | |
392 | andalso isUnit result | |
393 | | _ => false) | |
394 | | Array_copyVector => | |
395 | fiveArgs | |
396 | (fn (dst, di, src, si, len) => | |
397 | case (deVectorOpt dst, deVectorOpt src) of | |
398 | (SOME dstp, SOME srcp) => | |
399 | Vector.equals (Prod.dest dstp, Prod.dest srcp, | |
400 | fn ({elt = dstElt, isMutable = dstIsMutable}, | |
401 | {elt = srcElt, ...}) => | |
402 | dstIsMutable | |
403 | andalso equals (dstElt, srcElt)) | |
404 | andalso equals (di, seqIndex) | |
405 | andalso equals (si, seqIndex) | |
406 | andalso equals (len, seqIndex) | |
407 | andalso isUnit result | |
408 | | _ => false) | |
409 | | Array_length => | |
410 | oneArg | |
411 | (fn a => | |
412 | isVector a andalso equals (result, seqIndex)) | |
413 | | Array_toArray => | |
414 | oneArg | |
415 | (fn arr => | |
416 | case (deVectorOpt arr, deVectorOpt result) of | |
417 | (SOME arrp, SOME resp) => | |
418 | Vector.equals (Prod.dest arrp, Prod.dest resp, | |
419 | fn ({elt = arrElt, isMutable = arrIsMutable}, | |
420 | {elt = resElt, isMutable = resIsMutable}) => | |
421 | arrIsMutable andalso resIsMutable | |
422 | andalso equals (arrElt, resElt)) | |
423 | | _ => false) | |
424 | | Array_toVector => | |
425 | oneArg | |
426 | (fn arr => | |
427 | case (deVectorOpt arr, deVectorOpt result) of | |
428 | (SOME arrp, SOME resp) => | |
429 | Vector.equals (Prod.dest arrp, Prod.dest resp, | |
430 | fn ({elt = arrElt, isMutable = arrIsMutable}, | |
431 | {elt = resElt, ...}) => | |
432 | arrIsMutable | |
433 | andalso equals (arrElt, resElt)) | |
434 | | _ => false) | |
435 | | Array_uninit => | |
436 | twoArgs | |
437 | (fn (arr, i) => | |
438 | case deVectorOpt arr of | |
439 | SOME arrp => | |
440 | Prod.allAreMutable arrp | |
441 | andalso equals (i, seqIndex) | |
442 | andalso isUnit result | |
443 | | _ => false) | |
444 | | Array_uninitIsNop => | |
445 | oneArg | |
446 | (fn arr => | |
447 | case deVectorOpt arr of | |
448 | SOME arrp => | |
449 | Prod.allAreMutable arrp | |
450 | andalso isBool result | |
451 | | _ => false) | |
452 | | _ => default () | |
453 | end | |
454 | end | |
455 | ||
456 | structure Cases = | |
457 | struct | |
458 | datatype t = | |
459 | Con of (Con.t * Label.t) vector | |
460 | | Word of WordSize.t * (WordX.t * Label.t) vector | |
461 | ||
462 | fun equals (c1: t, c2: t): bool = | |
463 | let | |
464 | fun doit (l1, l2, eq') = | |
465 | Vector.equals | |
466 | (l1, l2, fn ((x1, a1), (x2, a2)) => | |
467 | eq' (x1, x2) andalso Label.equals (a1, a2)) | |
468 | in | |
469 | case (c1, c2) of | |
470 | (Con l1, Con l2) => doit (l1, l2, Con.equals) | |
471 | | (Word (_, l1), Word (_, l2)) => doit (l1, l2, WordX.equals) | |
472 | | _ => false | |
473 | end | |
474 | ||
475 | fun hd (c: t): Label.t = | |
476 | let | |
477 | fun doit v = | |
478 | if Vector.length v >= 1 | |
479 | then let val (_, a) = Vector.first v | |
480 | in a | |
481 | end | |
482 | else Error.bug "SsaTree2.Cases.hd" | |
483 | in | |
484 | case c of | |
485 | Con cs => doit cs | |
486 | | Word (_, cs) => doit cs | |
487 | end | |
488 | ||
489 | fun isEmpty (c: t): bool = | |
490 | let | |
491 | fun doit v = Vector.isEmpty v | |
492 | in | |
493 | case c of | |
494 | Con cs => doit cs | |
495 | | Word (_, cs) => doit cs | |
496 | end | |
497 | ||
498 | fun fold (c: t, b, f) = | |
499 | let | |
500 | fun doit l = Vector.fold (l, b, fn ((_, a), b) => f (a, b)) | |
501 | in | |
502 | case c of | |
503 | Con l => doit l | |
504 | | Word (_, l) => doit l | |
505 | end | |
506 | ||
507 | fun map (c: t, f): t = | |
508 | let | |
509 | fun doit l = Vector.map (l, fn (i, x) => (i, f x)) | |
510 | in | |
511 | case c of | |
512 | Con l => Con (doit l) | |
513 | | Word (s, l) => Word (s, doit l) | |
514 | end | |
515 | ||
516 | fun forall (c: t, f: Label.t -> bool): bool = | |
517 | let | |
518 | fun doit l = Vector.forall (l, fn (_, x) => f x) | |
519 | in | |
520 | case c of | |
521 | Con l => doit l | |
522 | | Word (_, l) => doit l | |
523 | end | |
524 | ||
525 | fun foreach (c, f) = fold (c, (), fn (x, ()) => f x) | |
526 | end | |
527 | ||
528 | structure Base = | |
529 | struct | |
530 | datatype 'a t = | |
531 | Object of 'a | |
532 | | VectorSub of {index: 'a, | |
533 | vector: 'a} | |
534 | ||
535 | fun layout (b: 'a t, layoutX: 'a -> Layout.t): Layout.t = | |
536 | let | |
537 | open Layout | |
538 | in | |
539 | case b of | |
540 | Object x => layoutX x | |
541 | | VectorSub {index, vector} => | |
542 | seq [str "$", Vector.layout layoutX (Vector.new2 (vector, index))] | |
543 | end | |
544 | ||
545 | val equals: 'a t * 'a t * ('a * 'a -> bool) -> bool = | |
546 | fn (b1, b2, equalsX) => | |
547 | case (b1, b2) of | |
548 | (Object x1, Object x2) => equalsX (x1, x2) | |
549 | | (VectorSub {index = i1, vector = v1}, | |
550 | VectorSub {index = i2, vector = v2}) => | |
551 | equalsX (i1, i2) andalso equalsX (v1, v2) | |
552 | | _ => false | |
553 | ||
554 | fun object (b: 'a t): 'a = | |
555 | case b of | |
556 | Object x => x | |
557 | | VectorSub {vector = x, ...} => x | |
558 | ||
559 | local | |
560 | val newHash = Random.word | |
561 | val object = newHash () | |
562 | val vectorSub = newHash () | |
563 | in | |
564 | val hash: 'a t * ('a -> word) -> word = | |
565 | fn (b, hashX) => | |
566 | case b of | |
567 | Object x => Word.xorb (object, hashX x) | |
568 | | VectorSub {index, vector} => | |
569 | Word.xorb (Word.xorb (hashX index, hashX vector), | |
570 | vectorSub) | |
571 | end | |
572 | ||
573 | fun foreach (b: 'a t, f: 'a -> unit): unit = | |
574 | case b of | |
575 | Object x => f x | |
576 | | VectorSub {index, vector} => (f index; f vector) | |
577 | ||
578 | fun map (b: 'a t, f: 'a -> 'b): 'b t = | |
579 | case b of | |
580 | Object x => Object (f x) | |
581 | | VectorSub {index, vector} => VectorSub {index = f index, | |
582 | vector = f vector} | |
583 | end | |
584 | ||
585 | structure Exp = | |
586 | struct | |
587 | datatype t = | |
588 | Const of Const.t | |
589 | | Inject of {sum: Tycon.t, | |
590 | variant: Var.t} | |
591 | | Object of {con: Con.t option, | |
592 | args: Var.t vector} | |
593 | | PrimApp of {prim: Type.t Prim.t, | |
594 | args: Var.t vector} | |
595 | | Select of {base: Var.t Base.t, | |
596 | offset: int} | |
597 | | Var of Var.t | |
598 | ||
599 | val unit = Object {con = NONE, args = Vector.new0 ()} | |
600 | ||
601 | fun foreachVar (e, v) = | |
602 | let | |
603 | fun vs xs = Vector.foreach (xs, v) | |
604 | in | |
605 | case e of | |
606 | Const _ => () | |
607 | | Inject {variant, ...} => v variant | |
608 | | Object {args, ...} => vs args | |
609 | | PrimApp {args, ...} => vs args | |
610 | | Select {base, ...} => Base.foreach (base, v) | |
611 | | Var x => v x | |
612 | end | |
613 | ||
614 | fun replaceVar (e, fx) = | |
615 | let | |
616 | fun fxs xs = Vector.map (xs, fx) | |
617 | in | |
618 | case e of | |
619 | Const _ => e | |
620 | | Inject {sum, variant} => Inject {sum = sum, variant = fx variant} | |
621 | | Object {con, args} => Object {con = con, args = fxs args} | |
622 | | PrimApp {prim, args} => PrimApp {args = fxs args, prim = prim} | |
623 | | Select {base, offset} => | |
624 | Select {base = Base.map (base, fx), offset = offset} | |
625 | | Var x => Var (fx x) | |
626 | end | |
627 | ||
628 | fun layout' (e, layoutVar) = | |
629 | let | |
630 | open Layout | |
631 | fun layoutArgs xs = Vector.layout layoutVar xs | |
632 | in | |
633 | case e of | |
634 | Const c => Const.layout c | |
635 | | Inject {sum, variant} => | |
636 | seq [paren (layoutVar variant), str ": ", Tycon.layout sum] | |
637 | | Object {con, args} => | |
638 | seq [(case con of | |
639 | NONE => empty | |
640 | | SOME c => seq [Con.layout c, str " "]), | |
641 | layoutArgs args] | |
642 | | PrimApp {args, prim} => | |
643 | seq [Prim.layout prim, str " ", layoutArgs args] | |
644 | | Select {base, offset} => | |
645 | seq [str "#", Int.layout offset, str " ", | |
646 | paren (Base.layout (base, layoutVar))] | |
647 | | Var x => layoutVar x | |
648 | end | |
649 | ||
650 | fun layout e = layout' (e, Var.layout) | |
651 | ||
652 | fun maySideEffect (e: t): bool = | |
653 | case e of | |
654 | Const _ => false | |
655 | | Inject _ => false | |
656 | | Object _ => false | |
657 | | PrimApp {prim,...} => Prim.maySideEffect prim | |
658 | | Select _ => false | |
659 | | Var _ => false | |
660 | ||
661 | fun varsEquals (xs, xs') = Vector.equals (xs, xs', Var.equals) | |
662 | ||
663 | fun equals (e: t, e': t): bool = | |
664 | case (e, e') of | |
665 | (Const c, Const c') => Const.equals (c, c') | |
666 | | (Object {con, args}, Object {con = con', args = args'}) => | |
667 | Option.equals (con, con', Con.equals) | |
668 | andalso varsEquals (args, args') | |
669 | | (PrimApp {prim, args, ...}, | |
670 | PrimApp {prim = prim', args = args', ...}) => | |
671 | Prim.equals (prim, prim') andalso varsEquals (args, args') | |
672 | | (Select {base = b1, offset = i1}, Select {base = b2, offset = i2}) => | |
673 | Base.equals (b1, b2, Var.equals) andalso i1 = i2 | |
674 | | (Var x, Var x') => Var.equals (x, x') | |
675 | | _ => false | |
676 | (* quell unused warning *) | |
677 | val _ = equals | |
678 | ||
679 | local | |
680 | val newHash = Random.word | |
681 | val inject = newHash () | |
682 | val primApp = newHash () | |
683 | val select = newHash () | |
684 | val tuple = newHash () | |
685 | fun hashVars (xs: Var.t vector, w: Word.t): Word.t = | |
686 | Vector.fold (xs, w, fn (x, w) => Word.xorb (w, Var.hash x)) | |
687 | in | |
688 | val hash: t -> Word.t = | |
689 | fn Const c => Const.hash c | |
690 | | Inject {sum, variant} => | |
691 | Word.xorb (inject, | |
692 | Word.xorb (Tycon.hash sum, Var.hash variant)) | |
693 | | Object {con, args, ...} => | |
694 | hashVars (args, | |
695 | case con of | |
696 | NONE => tuple | |
697 | | SOME c => Con.hash c) | |
698 | | PrimApp {args, ...} => hashVars (args, primApp) | |
699 | | Select {base, offset} => | |
700 | Word.xorb (select, | |
701 | Base.hash (base, Var.hash) + Word.fromInt offset) | |
702 | | Var x => Var.hash x | |
703 | end | |
704 | (* quell unused warning *) | |
705 | val _ = hash | |
706 | end | |
707 | datatype z = datatype Exp.t | |
708 | ||
709 | structure Statement = | |
710 | struct | |
711 | datatype t = | |
712 | Bind of {var: Var.t option, | |
713 | ty: Type.t, | |
714 | exp: Exp.t} | |
715 | | Profile of ProfileExp.t | |
716 | | Update of {base: Var.t Base.t, | |
717 | offset: int, | |
718 | value: Var.t} | |
719 | ||
720 | fun layout' (s: t, layoutVar): Layout.t = | |
721 | let | |
722 | open Layout | |
723 | in | |
724 | case s of | |
725 | Bind {var, ty, exp} => | |
726 | let | |
727 | val (sep, ty) = | |
728 | if !Control.showTypes | |
729 | then (str ":", indent (seq [Type.layout ty, str " ="], 2)) | |
730 | else (str " =", empty) | |
731 | in | |
732 | mayAlign [mayAlign [seq [case var of | |
733 | NONE => str "_" | |
734 | | SOME var => Var.layout var, | |
735 | sep], | |
736 | ty], | |
737 | indent (Exp.layout' (exp, layoutVar), 2)] | |
738 | end | |
739 | | Profile p => ProfileExp.layout p | |
740 | | Update {base, offset, value} => | |
741 | mayAlign [seq [Exp.layout' (Exp.Select {base = base, | |
742 | offset = offset}, | |
743 | layoutVar), | |
744 | str " :="], | |
745 | layoutVar value] | |
746 | end | |
747 | fun layout s = layout' (s, Var.layout) | |
748 | ||
749 | val profile = Profile | |
750 | ||
751 | fun foreachDef (s: t, f: Var.t * Type.t -> unit): unit = | |
752 | case s of | |
753 | Bind {ty, var, ...} => Option.app (var, fn x => f (x, ty)) | |
754 | | _ => () | |
755 | ||
756 | fun clear s = foreachDef (s, Var.clear o #1) | |
757 | ||
758 | fun prettifyGlobals (v: t vector): Var.t -> Layout.t = | |
759 | let | |
760 | val {get = global: Var.t -> Layout.t, set = setGlobal, ...} = | |
761 | Property.getSet (Var.plist, Property.initFun Var.layout) | |
762 | val _ = | |
763 | Vector.foreach | |
764 | (v, fn s => | |
765 | case s of | |
766 | Bind {var, exp, ...} => | |
767 | Option.app | |
768 | (var, fn var => | |
769 | let | |
770 | fun set () = | |
771 | let | |
772 | val s = Layout.toString (Exp.layout' (exp, global)) | |
773 | val maxSize = 20 | |
774 | val dots = " ... " | |
775 | val dotsSize = String.size dots | |
776 | val frontSize = 2 * (maxSize - dotsSize) div 3 | |
777 | val backSize = maxSize - dotsSize - frontSize | |
778 | val s = | |
779 | if String.size s > maxSize | |
780 | then concat [String.prefix (s, frontSize), | |
781 | dots, | |
782 | String.suffix (s, backSize)] | |
783 | else s | |
784 | in | |
785 | setGlobal (var, Layout.seq [Var.layout var, | |
786 | Layout.str (" (*" ^ s ^ "*)")]) | |
787 | end | |
788 | in | |
789 | case exp of | |
790 | Const _ => set () | |
791 | | Object {con, args, ...} => | |
792 | (case con of | |
793 | NONE => if Vector.isEmpty args then set () else () | |
794 | | SOME _ => set ()) | |
795 | | _ => () | |
796 | end) | |
797 | | _ => ()) | |
798 | in | |
799 | global | |
800 | end | |
801 | ||
802 | fun foreachUse (s: t, f: Var.t -> unit): unit = | |
803 | case s of | |
804 | Bind {exp, ...} => Exp.foreachVar (exp, f) | |
805 | | Profile _ => () | |
806 | | Update {base, value, ...} => (Base.foreach (base, f); f value) | |
807 | ||
808 | fun replaceDefsUses (s: t, {def: Var.t -> Var.t, use: Var.t -> Var.t}): t = | |
809 | case s of | |
810 | Bind {exp, ty, var} => | |
811 | Bind {exp = Exp.replaceVar (exp, use), | |
812 | ty = ty, | |
813 | var = Option.map (var, def)} | |
814 | | Profile _ => s | |
815 | | Update {base, offset, value} => | |
816 | Update {base = Base.map (base, use), | |
817 | offset = offset, | |
818 | value = use value} | |
819 | ||
820 | fun replaceUses (s, f) = replaceDefsUses (s, {def = fn x => x, use = f}) | |
821 | end | |
822 | ||
823 | datatype z = datatype Statement.t | |
824 | ||
825 | structure Handler = | |
826 | struct | |
827 | structure Label = Label | |
828 | ||
829 | datatype t = | |
830 | Caller | |
831 | | Dead | |
832 | | Handle of Label.t | |
833 | ||
834 | fun layout (h: t): Layout.t = | |
835 | let | |
836 | open Layout | |
837 | in | |
838 | case h of | |
839 | Caller => str "Caller" | |
840 | | Dead => str "Dead" | |
841 | | Handle l => seq [str "Handle ", Label.layout l] | |
842 | end | |
843 | ||
844 | val equals = | |
845 | fn (Caller, Caller) => true | |
846 | | (Dead, Dead) => true | |
847 | | (Handle l, Handle l') => Label.equals (l, l') | |
848 | | _ => false | |
849 | ||
850 | fun foldLabel (h: t, a: 'a, f: Label.t * 'a -> 'a): 'a = | |
851 | case h of | |
852 | Caller => a | |
853 | | Dead => a | |
854 | | Handle l => f (l, a) | |
855 | ||
856 | fun foreachLabel (h, f) = foldLabel (h, (), f o #1) | |
857 | ||
858 | fun map (h, f) = | |
859 | case h of | |
860 | Caller => Caller | |
861 | | Dead => Dead | |
862 | | Handle l => Handle (f l) | |
863 | ||
864 | local | |
865 | val newHash = Random.word | |
866 | val caller = newHash () | |
867 | val dead = newHash () | |
868 | val handlee = newHash () | |
869 | in | |
870 | fun hash (h: t): word = | |
871 | case h of | |
872 | Caller => caller | |
873 | | Dead => dead | |
874 | | Handle l => Word.xorb (handlee, Label.hash l) | |
875 | end | |
876 | end | |
877 | ||
878 | structure Return = | |
879 | struct | |
880 | structure Label = Label | |
881 | structure Handler = Handler | |
882 | ||
883 | datatype t = | |
884 | Dead | |
885 | | NonTail of {cont: Label.t, | |
886 | handler: Handler.t} | |
887 | | Tail | |
888 | ||
889 | fun layout r = | |
890 | let | |
891 | open Layout | |
892 | in | |
893 | case r of | |
894 | Dead => str "Dead" | |
895 | | NonTail {cont, handler} => | |
896 | seq [str "NonTail ", | |
897 | Layout.record | |
898 | [("cont", Label.layout cont), | |
899 | ("handler", Handler.layout handler)]] | |
900 | | Tail => str "Tail" | |
901 | end | |
902 | ||
903 | fun equals (r, r'): bool = | |
904 | case (r, r') of | |
905 | (Dead, Dead) => true | |
906 | | (NonTail {cont = c, handler = h}, | |
907 | NonTail {cont = c', handler = h'}) => | |
908 | Label.equals (c, c') andalso Handler.equals (h, h') | |
909 | | (Tail, Tail) => true | |
910 | | _ => false | |
911 | ||
912 | fun foldLabel (r: t, a, f) = | |
913 | case r of | |
914 | Dead => a | |
915 | | NonTail {cont, handler} => | |
916 | Handler.foldLabel (handler, f (cont, a), f) | |
917 | | Tail => a | |
918 | ||
919 | fun foreachLabel (r, f) = foldLabel (r, (), f o #1) | |
920 | ||
921 | fun foreachHandler (r, f) = | |
922 | case r of | |
923 | Dead => () | |
924 | | NonTail {handler, ...} => Handler.foreachLabel (handler, f) | |
925 | | Tail => () | |
926 | ||
927 | fun map (r, f) = | |
928 | case r of | |
929 | Dead => Dead | |
930 | | NonTail {cont, handler} => | |
931 | NonTail {cont = f cont, | |
932 | handler = Handler.map (handler, f)} | |
933 | | Tail => Tail | |
934 | ||
935 | fun compose (r, r') = | |
936 | case r' of | |
937 | Dead => Dead | |
938 | | NonTail {cont, handler} => | |
939 | NonTail | |
940 | {cont = cont, | |
941 | handler = (case handler of | |
942 | Handler.Caller => | |
943 | (case r of | |
944 | Dead => Handler.Caller | |
945 | | NonTail {handler, ...} => handler | |
946 | | Tail => Handler.Caller) | |
947 | | Handler.Dead => handler | |
948 | | Handler.Handle _ => handler)} | |
949 | | Tail => r | |
950 | (* quell unused warning *) | |
951 | val _ = compose | |
952 | ||
953 | local | |
954 | val newHash = Random.word | |
955 | val dead = newHash () | |
956 | val nonTail = newHash () | |
957 | val tail = newHash () | |
958 | in | |
959 | fun hash r = | |
960 | case r of | |
961 | Dead => dead | |
962 | | NonTail {cont, handler} => | |
963 | Word.xorb (Word.xorb (nonTail, Label.hash cont), | |
964 | Handler.hash handler) | |
965 | | Tail => tail | |
966 | end | |
967 | end | |
968 | ||
969 | structure Transfer = | |
970 | struct | |
971 | datatype t = | |
972 | Arith of {prim: Type.t Prim.t, | |
973 | args: Var.t vector, | |
974 | overflow: Label.t, (* Must be nullary. *) | |
975 | success: Label.t, (* Must be unary. *) | |
976 | ty: Type.t} | |
977 | | Bug (* MLton thought control couldn't reach here. *) | |
978 | | Call of {args: Var.t vector, | |
979 | func: Func.t, | |
980 | return: Return.t} | |
981 | | Case of {test: Var.t, | |
982 | cases: Cases.t, | |
983 | default: Label.t option} (* Must be nullary. *) | |
984 | | Goto of {dst: Label.t, | |
985 | args: Var.t vector} | |
986 | | Raise of Var.t vector | |
987 | | Return of Var.t vector | |
988 | | Runtime of {prim: Type.t Prim.t, | |
989 | args: Var.t vector, | |
990 | return: Label.t} (* Must be nullary. *) | |
991 | ||
992 | fun foreachFuncLabelVar (t, func: Func.t -> unit, label: Label.t -> unit, var) = | |
993 | let | |
994 | fun vars xs = Vector.foreach (xs, var) | |
995 | in | |
996 | case t of | |
997 | Arith {args, overflow, success, ...} => | |
998 | (vars args | |
999 | ; label overflow | |
1000 | ; label success) | |
1001 | | Bug => () | |
1002 | | Call {func = f, args, return, ...} => | |
1003 | (func f | |
1004 | ; Return.foreachLabel (return, label) | |
1005 | ; vars args) | |
1006 | | Case {test, cases, default, ...} => | |
1007 | (var test | |
1008 | ; Cases.foreach (cases, label) | |
1009 | ; Option.app (default, label)) | |
1010 | | Goto {dst, args, ...} => (vars args; label dst) | |
1011 | | Raise xs => vars xs | |
1012 | | Return xs => vars xs | |
1013 | | Runtime {args, return, ...} => | |
1014 | (vars args | |
1015 | ; label return) | |
1016 | end | |
1017 | ||
1018 | fun foreachFunc (t, func) = | |
1019 | foreachFuncLabelVar (t, func, fn _ => (), fn _ => ()) | |
1020 | (* quell unused warning *) | |
1021 | val _ = foreachFunc | |
1022 | ||
1023 | fun foreachLabelVar (t, label, var) = | |
1024 | foreachFuncLabelVar (t, fn _ => (), label, var) | |
1025 | ||
1026 | fun foreachLabel (t, j) = foreachLabelVar (t, j, fn _ => ()) | |
1027 | fun foreachVar (t, v) = foreachLabelVar (t, fn _ => (), v) | |
1028 | ||
1029 | fun replaceLabelVar (t, fl, fx) = | |
1030 | let | |
1031 | fun fxs xs = Vector.map (xs, fx) | |
1032 | in | |
1033 | case t of | |
1034 | Arith {prim, args, overflow, success, ty} => | |
1035 | Arith {prim = prim, | |
1036 | args = fxs args, | |
1037 | overflow = fl overflow, | |
1038 | success = fl success, | |
1039 | ty = ty} | |
1040 | | Bug => Bug | |
1041 | | Call {func, args, return} => | |
1042 | Call {func = func, | |
1043 | args = fxs args, | |
1044 | return = Return.map (return, fl)} | |
1045 | | Case {test, cases, default} => | |
1046 | Case {test = fx test, | |
1047 | cases = Cases.map(cases, fl), | |
1048 | default = Option.map(default, fl)} | |
1049 | | Goto {dst, args} => | |
1050 | Goto {dst = fl dst, | |
1051 | args = fxs args} | |
1052 | | Raise xs => Raise (fxs xs) | |
1053 | | Return xs => Return (fxs xs) | |
1054 | | Runtime {prim, args, return} => | |
1055 | Runtime {prim = prim, | |
1056 | args = fxs args, | |
1057 | return = fl return} | |
1058 | end | |
1059 | ||
1060 | fun replaceLabel (t, f) = replaceLabelVar (t, f, fn x => x) | |
1061 | (* quell unused warning *) | |
1062 | val _ = replaceLabel | |
1063 | fun replaceVar (t, f) = replaceLabelVar (t, fn l => l, f) | |
1064 | ||
1065 | local | |
1066 | fun layoutCase ({test, cases, default}, layoutVar) = | |
1067 | let | |
1068 | open Layout | |
1069 | fun doit (l, layout) = | |
1070 | Vector.toListMap | |
1071 | (l, fn (i, l) => | |
1072 | seq [layout i, str " => ", Label.layout l]) | |
1073 | datatype z = datatype Cases.t | |
1074 | val cases = | |
1075 | case cases of | |
1076 | Con l => doit (l, Con.layout) | |
1077 | | Word (_, l) => doit (l, WordX.layout) | |
1078 | val cases = | |
1079 | case default of | |
1080 | NONE => cases | |
1081 | | SOME j => | |
1082 | cases @ [seq [str "_ => ", Label.layout j]] | |
1083 | in | |
1084 | align [seq [str "case ", layoutVar test, str " of"], | |
1085 | indent (alignPrefix (cases, "| "), 2)] | |
1086 | end | |
1087 | in | |
1088 | fun layout' (t, layoutVar) = | |
1089 | let | |
1090 | open Layout | |
1091 | fun layoutArgs xs = Vector.layout layoutVar xs | |
1092 | fun layoutPrim {prim, args} = | |
1093 | Exp.layout' | |
1094 | (Exp.PrimApp {prim = prim, | |
1095 | args = args}, | |
1096 | layoutVar) | |
1097 | in | |
1098 | case t of | |
1099 | Arith {prim, args, overflow, success, ...} => | |
1100 | seq [Label.layout success, str " ", | |
1101 | tuple [layoutPrim {prim = prim, args = args}], | |
1102 | str " handle Overflow => ", Label.layout overflow] | |
1103 | | Bug => str "Bug" | |
1104 | | Call {func, args, return} => | |
1105 | let | |
1106 | val call = seq [Func.layout func, str " ", layoutArgs args] | |
1107 | in | |
1108 | case return of | |
1109 | Return.Dead => seq [str "dead ", paren call] | |
1110 | | Return.NonTail {cont, handler} => | |
1111 | seq [Label.layout cont, str " ", | |
1112 | paren call, | |
1113 | str " handle _ => ", | |
1114 | case handler of | |
1115 | Handler.Caller => str "raise" | |
1116 | | Handler.Dead => str "dead" | |
1117 | | Handler.Handle l => Label.layout l] | |
1118 | | Return.Tail => seq [str "return ", paren call] | |
1119 | end | |
1120 | | Case arg => layoutCase (arg, layoutVar) | |
1121 | | Goto {dst, args} => | |
1122 | seq [Label.layout dst, str " ", layoutArgs args] | |
1123 | | Raise xs => seq [str "raise ", layoutArgs xs] | |
1124 | | Return xs => seq [str "return ", layoutArgs xs] | |
1125 | | Runtime {prim, args, return} => | |
1126 | seq [Label.layout return, str " ", | |
1127 | tuple [layoutPrim {prim = prim, args = args}]] | |
1128 | end | |
1129 | end | |
1130 | fun layout t = layout' (t, Var.layout) | |
1131 | ||
1132 | fun varsEquals (xs, xs') = Vector.equals (xs, xs', Var.equals) | |
1133 | ||
1134 | fun equals (e: t, e': t): bool = | |
1135 | case (e, e') of | |
1136 | (Arith {prim, args, overflow, success, ...}, | |
1137 | Arith {prim = prim', args = args', | |
1138 | overflow = overflow', success = success', ...}) => | |
1139 | Prim.equals (prim, prim') andalso | |
1140 | varsEquals (args, args') andalso | |
1141 | Label.equals (overflow, overflow') andalso | |
1142 | Label.equals (success, success') | |
1143 | | (Bug, Bug) => true | |
1144 | | (Call {func, args, return}, | |
1145 | Call {func = func', args = args', return = return'}) => | |
1146 | Func.equals (func, func') andalso | |
1147 | varsEquals (args, args') andalso | |
1148 | Return.equals (return, return') | |
1149 | | (Case {test, cases, default}, | |
1150 | Case {test = test', cases = cases', default = default'}) => | |
1151 | Var.equals (test, test') | |
1152 | andalso Cases.equals (cases, cases') | |
1153 | andalso Option.equals (default, default', Label.equals) | |
1154 | | (Goto {dst, args}, Goto {dst = dst', args = args'}) => | |
1155 | Label.equals (dst, dst') andalso | |
1156 | varsEquals (args, args') | |
1157 | | (Raise xs, Raise xs') => varsEquals (xs, xs') | |
1158 | | (Return xs, Return xs') => varsEquals (xs, xs') | |
1159 | | (Runtime {prim, args, return}, | |
1160 | Runtime {prim = prim', args = args', return = return'}) => | |
1161 | Prim.equals (prim, prim') andalso | |
1162 | varsEquals (args, args') andalso | |
1163 | Label.equals (return, return') | |
1164 | | _ => false | |
1165 | (* quell unused warning *) | |
1166 | val _ = equals | |
1167 | ||
1168 | local | |
1169 | val newHash = Random.word | |
1170 | val bug = newHash () | |
1171 | val raisee = newHash () | |
1172 | val return = newHash () | |
1173 | fun hashVars (xs: Var.t vector, w: Word.t): Word.t = | |
1174 | Vector.fold (xs, w, fn (x, w) => Word.xorb (w, Var.hash x)) | |
1175 | fun hash2 (w1: Word.t, w2: Word.t) = Word.xorb (w1, w2) | |
1176 | in | |
1177 | val hash: t -> Word.t = | |
1178 | fn Arith {args, overflow, success, ...} => | |
1179 | hashVars (args, hash2 (Label.hash overflow, | |
1180 | Label.hash success)) | |
1181 | | Bug => bug | |
1182 | | Call {func, args, return} => | |
1183 | hashVars (args, hash2 (Func.hash func, Return.hash return)) | |
1184 | | Case {test, cases, default} => | |
1185 | hash2 (Var.hash test, | |
1186 | Cases.fold | |
1187 | (cases, | |
1188 | Option.fold | |
1189 | (default, 0wx55555555, | |
1190 | fn (l, w) => | |
1191 | hash2 (Label.hash l, w)), | |
1192 | fn (l, w) => | |
1193 | hash2 (Label.hash l, w))) | |
1194 | | Goto {dst, args} => | |
1195 | hashVars (args, Label.hash dst) | |
1196 | | Raise xs => hashVars (xs, raisee) | |
1197 | | Return xs => hashVars (xs, return) | |
1198 | | Runtime {args, return, ...} => hashVars (args, Label.hash return) | |
1199 | end | |
1200 | (* quell unused warning *) | |
1201 | val _ = hash | |
1202 | end | |
1203 | datatype z = datatype Transfer.t | |
1204 | ||
1205 | local | |
1206 | open Layout | |
1207 | in | |
1208 | fun layoutFormals (xts: (Var.t * Type.t) vector) = | |
1209 | Vector.layout (fn (x, t) => | |
1210 | seq [Var.layout x, | |
1211 | if !Control.showTypes | |
1212 | then seq [str ": ", Type.layout t] | |
1213 | else empty]) | |
1214 | xts | |
1215 | end | |
1216 | ||
1217 | structure Block = | |
1218 | struct | |
1219 | datatype t = | |
1220 | T of {args: (Var.t * Type.t) vector, | |
1221 | label: Label.t, | |
1222 | statements: Statement.t vector, | |
1223 | transfer: Transfer.t} | |
1224 | ||
1225 | local | |
1226 | fun make f (T r) = f r | |
1227 | in | |
1228 | val args = make #args | |
1229 | val label = make #label | |
1230 | val transfer = make #transfer | |
1231 | end | |
1232 | ||
1233 | fun layout' (T {label, args, statements, transfer}, layoutVar) = | |
1234 | let | |
1235 | open Layout | |
1236 | fun layoutStatement s = Statement.layout' (s, layoutVar) | |
1237 | fun layoutTransfer t = Transfer.layout' (t, layoutVar) | |
1238 | in | |
1239 | align [seq [Label.layout label, str " ", | |
1240 | layoutFormals args], | |
1241 | indent (align | |
1242 | [align | |
1243 | (Vector.toListMap (statements, layoutStatement)), | |
1244 | layoutTransfer transfer], | |
1245 | 2)] | |
1246 | end | |
1247 | fun layout b = layout' (b, Var.layout) | |
1248 | ||
1249 | fun clear (T {label, args, statements, ...}) = | |
1250 | (Label.clear label | |
1251 | ; Vector.foreach (args, Var.clear o #1) | |
1252 | ; Vector.foreach (statements, Statement.clear)) | |
1253 | end | |
1254 | ||
1255 | structure Datatype = | |
1256 | struct | |
1257 | datatype t = | |
1258 | T of {cons: {args: Type.t Prod.t, | |
1259 | con: Con.t} vector, | |
1260 | tycon: Tycon.t} | |
1261 | ||
1262 | fun layout (T {cons, tycon}) = | |
1263 | let | |
1264 | open Layout | |
1265 | in | |
1266 | seq [Tycon.layout tycon, | |
1267 | str " = ", | |
1268 | alignPrefix | |
1269 | (Vector.toListMap | |
1270 | (cons, fn {con, args} => | |
1271 | seq [Con.layout con, str " of ", | |
1272 | Prod.layout (args, Type.layout)]), | |
1273 | "| ")] | |
1274 | end | |
1275 | ||
1276 | fun clear (T {cons, tycon}) = | |
1277 | (Tycon.clear tycon | |
1278 | ; Vector.foreach (cons, Con.clear o #con)) | |
1279 | end | |
1280 | ||
1281 | structure Function = | |
1282 | struct | |
1283 | structure CPromise = ClearablePromise | |
1284 | ||
1285 | type dest = {args: (Var.t * Type.t) vector, | |
1286 | blocks: Block.t vector, | |
1287 | mayInline: bool, | |
1288 | name: Func.t, | |
1289 | raises: Type.t vector option, | |
1290 | returns: Type.t vector option, | |
1291 | start: Label.t} | |
1292 | ||
1293 | (* There is a messy interaction between the laziness used in controlFlow | |
1294 | * and the property lists on labels because the former stores | |
1295 | * stuff on the property lists. So, if you force the laziness, then | |
1296 | * clear the property lists, then try to use the lazy stuff, you will | |
1297 | * get screwed with undefined properties. The right thing to do is reset | |
1298 | * the laziness when the properties are cleared. | |
1299 | *) | |
1300 | datatype t = | |
1301 | T of {controlFlow: | |
1302 | {dfsTree: unit -> Block.t Tree.t, | |
1303 | dominatorTree: unit -> Block.t Tree.t, | |
1304 | graph: unit DirectedGraph.t, | |
1305 | labelNode: Label.t -> unit DirectedGraph.Node.t, | |
1306 | nodeBlock: unit DirectedGraph.Node.t -> Block.t} CPromise.t, | |
1307 | dest: dest} | |
1308 | ||
1309 | local | |
1310 | fun make f (T {dest, ...}) = f dest | |
1311 | in | |
1312 | val blocks = make #blocks | |
1313 | val dest = make (fn d => d) | |
1314 | val name = make #name | |
1315 | end | |
1316 | ||
1317 | fun foreachVar (f: t, fx: Var.t * Type.t -> unit): unit = | |
1318 | let | |
1319 | val {args, blocks, ...} = dest f | |
1320 | val _ = Vector.foreach (args, fx) | |
1321 | val _ = | |
1322 | Vector.foreach | |
1323 | (blocks, fn Block.T {args, statements, ...} => | |
1324 | (Vector.foreach (args, fx) | |
1325 | ; Vector.foreach (statements, fn s => | |
1326 | Statement.foreachDef (s, fx)))) | |
1327 | in | |
1328 | () | |
1329 | end | |
1330 | ||
1331 | fun controlFlow (T {controlFlow, ...}) = | |
1332 | let | |
1333 | val {graph, labelNode, nodeBlock, ...} = CPromise.force controlFlow | |
1334 | in | |
1335 | {graph = graph, labelNode = labelNode, nodeBlock = nodeBlock} | |
1336 | end | |
1337 | ||
1338 | local | |
1339 | fun make sel = | |
1340 | fn T {controlFlow, ...} => sel (CPromise.force controlFlow) () | |
1341 | in | |
1342 | val dominatorTree = make #dominatorTree | |
1343 | end | |
1344 | ||
1345 | fun dfs (f, v) = | |
1346 | let | |
1347 | val {blocks, start, ...} = dest f | |
1348 | val numBlocks = Vector.length blocks | |
1349 | val {get = labelIndex, set = setLabelIndex, rem, ...} = | |
1350 | Property.getSetOnce (Label.plist, | |
1351 | Property.initRaise ("index", Label.layout)) | |
1352 | val _ = Vector.foreachi (blocks, fn (i, Block.T {label, ...}) => | |
1353 | setLabelIndex (label, i)) | |
1354 | val visited = Array.array (numBlocks, false) | |
1355 | fun visit (l: Label.t): unit = | |
1356 | let | |
1357 | val i = labelIndex l | |
1358 | in | |
1359 | if Array.sub (visited, i) | |
1360 | then () | |
1361 | else | |
1362 | let | |
1363 | val _ = Array.update (visited, i, true) | |
1364 | val b as Block.T {transfer, ...} = | |
1365 | Vector.sub (blocks, i) | |
1366 | val v' = v b | |
1367 | val _ = Transfer.foreachLabel (transfer, visit) | |
1368 | val _ = v' () | |
1369 | in | |
1370 | () | |
1371 | end | |
1372 | end | |
1373 | val _ = visit start | |
1374 | val _ = Vector.foreach (blocks, rem o Block.label) | |
1375 | in | |
1376 | () | |
1377 | end | |
1378 | ||
1379 | local | |
1380 | structure Graph = DirectedGraph | |
1381 | structure Node = Graph.Node | |
1382 | structure Edge = Graph.Edge | |
1383 | in | |
1384 | fun determineControlFlow ({blocks, start, ...}: dest) = | |
1385 | let | |
1386 | open Dot | |
1387 | val g = Graph.new () | |
1388 | fun newNode () = Graph.newNode g | |
1389 | val {get = labelNode, ...} = | |
1390 | Property.get | |
1391 | (Label.plist, Property.initFun (fn _ => newNode ())) | |
1392 | val {get = nodeInfo: unit Node.t -> {block: Block.t}, | |
1393 | set = setNodeInfo, ...} = | |
1394 | Property.getSetOnce | |
1395 | (Node.plist, Property.initRaise ("info", Node.layout)) | |
1396 | val _ = | |
1397 | Vector.foreach | |
1398 | (blocks, fn b as Block.T {label, transfer, ...} => | |
1399 | let | |
1400 | val from = labelNode label | |
1401 | val _ = setNodeInfo (from, {block = b}) | |
1402 | val _ = | |
1403 | Transfer.foreachLabel | |
1404 | (transfer, fn to => | |
1405 | (ignore o Graph.addEdge) | |
1406 | (g, {from = from, to = labelNode to})) | |
1407 | in | |
1408 | () | |
1409 | end) | |
1410 | val root = labelNode start | |
1411 | val dfsTree = | |
1412 | Promise.lazy | |
1413 | (fn () => | |
1414 | Graph.dfsTree (g, {root = root, | |
1415 | nodeValue = #block o nodeInfo})) | |
1416 | val dominatorTree = | |
1417 | Promise.lazy | |
1418 | (fn () => | |
1419 | Graph.dominatorTree (g, {root = root, | |
1420 | nodeValue = #block o nodeInfo})) | |
1421 | in | |
1422 | {dfsTree = dfsTree, | |
1423 | dominatorTree = dominatorTree, | |
1424 | graph = g, | |
1425 | labelNode = labelNode, | |
1426 | nodeBlock = #block o nodeInfo} | |
1427 | end | |
1428 | ||
1429 | fun layoutDot (f, layoutVar) = | |
1430 | let | |
1431 | fun toStringStatement s = Layout.toString (Statement.layout' (s, layoutVar)) | |
1432 | fun toStringTransfer t = | |
1433 | Layout.toString | |
1434 | (case t of | |
1435 | Case {test, ...} => | |
1436 | Layout.seq [Layout.str "case ", layoutVar test] | |
1437 | | _ => Transfer.layout' (t, layoutVar)) | |
1438 | fun toStringFormals args = Layout.toString (layoutFormals args) | |
1439 | fun toStringHeader (name, args) = concat [name, " ", toStringFormals args] | |
1440 | val {name, args, start, blocks, returns, raises, ...} = dest f | |
1441 | open Dot | |
1442 | val graph = Graph.new () | |
1443 | val {get = nodeOptions, ...} = | |
1444 | Property.get (Node.plist, Property.initFun (fn _ => ref [])) | |
1445 | fun setNodeText (n: unit Node.t, l): unit = | |
1446 | List.push (nodeOptions n, NodeOption.Label l) | |
1447 | fun newNode () = Graph.newNode graph | |
1448 | val {destroy, get = labelNode} = | |
1449 | Property.destGet (Label.plist, | |
1450 | Property.initFun (fn _ => newNode ())) | |
1451 | val {get = edgeOptions, set = setEdgeOptions, ...} = | |
1452 | Property.getSetOnce (Edge.plist, Property.initConst []) | |
1453 | fun edge (from, to, label: string, style: style): unit = | |
1454 | let | |
1455 | val e = Graph.addEdge (graph, {from = from, | |
1456 | to = to}) | |
1457 | val _ = setEdgeOptions (e, [EdgeOption.label label, | |
1458 | EdgeOption.Style style]) | |
1459 | in | |
1460 | () | |
1461 | end | |
1462 | val _ = | |
1463 | Vector.foreach | |
1464 | (blocks, fn Block.T {label, args, statements, transfer} => | |
1465 | let | |
1466 | val from = labelNode label | |
1467 | val edge = fn (to, label, style) => | |
1468 | edge (from, labelNode to, label, style) | |
1469 | val () = | |
1470 | case transfer of | |
1471 | Arith {overflow, success, ...} => | |
1472 | (edge (success, "", Solid) | |
1473 | ; edge (overflow, "Overflow", Dashed)) | |
1474 | | Bug => () | |
1475 | | Call {return, ...} => | |
1476 | let | |
1477 | val _ = | |
1478 | case return of | |
1479 | Return.Dead => () | |
1480 | | Return.NonTail {cont, handler} => | |
1481 | (edge (cont, "", Dotted) | |
1482 | ; (Handler.foreachLabel | |
1483 | (handler, fn l => | |
1484 | edge (l, "Handle", Dashed)))) | |
1485 | | Return.Tail => () | |
1486 | in | |
1487 | () | |
1488 | end | |
1489 | | Case {cases, default, ...} => | |
1490 | let | |
1491 | fun doit (v, toString) = | |
1492 | Vector.foreach | |
1493 | (v, fn (x, j) => | |
1494 | edge (j, toString x, Solid)) | |
1495 | val _ = | |
1496 | case cases of | |
1497 | Cases.Con v => | |
1498 | doit (v, Con.toString) | |
1499 | | Cases.Word (_, v) => | |
1500 | doit (v, WordX.toString) | |
1501 | val _ = | |
1502 | case default of | |
1503 | NONE => () | |
1504 | | SOME j => | |
1505 | edge (j, "Default", Solid) | |
1506 | in | |
1507 | () | |
1508 | end | |
1509 | | Goto {dst, ...} => edge (dst, "", Solid) | |
1510 | | Raise _ => () | |
1511 | | Return _ => () | |
1512 | | Runtime {return, ...} => edge (return, "", Dotted) | |
1513 | val lab = | |
1514 | [(toStringTransfer transfer, Left)] | |
1515 | val lab = | |
1516 | Vector.foldr | |
1517 | (statements, lab, fn (s, ac) => | |
1518 | (toStringStatement s, Left) :: ac) | |
1519 | val lab = | |
1520 | (toStringHeader (Label.toString label, args), Left)::lab | |
1521 | val _ = setNodeText (from, lab) | |
1522 | in | |
1523 | () | |
1524 | end) | |
1525 | val startNode = labelNode start | |
1526 | val funNode = | |
1527 | let | |
1528 | val funNode = newNode () | |
1529 | val _ = edge (funNode, startNode, "Start", Solid) | |
1530 | val lab = | |
1531 | [(toStringTransfer (Transfer.Goto {dst = start, args = Vector.new0 ()}), Left)] | |
1532 | val lab = | |
1533 | if !Control.showTypes | |
1534 | then ((Layout.toString o Layout.seq) | |
1535 | [Layout.str ": ", | |
1536 | Layout.record [("returns", | |
1537 | Option.layout | |
1538 | (Vector.layout Type.layout) | |
1539 | returns), | |
1540 | ("raises", | |
1541 | Option.layout | |
1542 | (Vector.layout Type.layout) | |
1543 | raises)]], | |
1544 | Left)::lab | |
1545 | else lab | |
1546 | val lab = | |
1547 | (toStringHeader ("fun " ^ Func.toString name, args), Left):: | |
1548 | lab | |
1549 | val _ = setNodeText (funNode, lab) | |
1550 | in | |
1551 | funNode | |
1552 | end | |
1553 | val controlFlowGraphLayout = | |
1554 | Graph.layoutDot | |
1555 | (graph, fn {nodeName} => | |
1556 | {title = concat [Func.toString name, " control-flow graph"], | |
1557 | options = [GraphOption.Rank (Min, [{nodeName = nodeName funNode}])], | |
1558 | edgeOptions = edgeOptions, | |
1559 | nodeOptions = | |
1560 | fn n => let | |
1561 | val l = ! (nodeOptions n) | |
1562 | open NodeOption | |
1563 | in FontColor Black :: Shape Box :: l | |
1564 | end}) | |
1565 | val () = Graph.removeNode (graph, funNode) | |
1566 | fun dominatorTreeLayout () = | |
1567 | let | |
1568 | val {get = nodeOptions, set = setNodeOptions, ...} = | |
1569 | Property.getSetOnce (Node.plist, Property.initConst []) | |
1570 | val _ = | |
1571 | Vector.foreach | |
1572 | (blocks, fn Block.T {label, ...} => | |
1573 | setNodeOptions (labelNode label, | |
1574 | [NodeOption.label (Label.toString label)])) | |
1575 | val dominatorTreeLayout = | |
1576 | Tree.layoutDot | |
1577 | (Graph.dominatorTree (graph, | |
1578 | {root = startNode, | |
1579 | nodeValue = fn n => n}), | |
1580 | {title = concat [Func.toString name, " dominator tree"], | |
1581 | options = [], | |
1582 | nodeOptions = nodeOptions}) | |
1583 | in | |
1584 | dominatorTreeLayout | |
1585 | end | |
1586 | fun loopForestLayout () = | |
1587 | let | |
1588 | val {get = nodeName, set = setNodeName, ...} = | |
1589 | Property.getSetOnce (Node.plist, Property.initConst "") | |
1590 | val _ = | |
1591 | Vector.foreach | |
1592 | (blocks, fn Block.T {label, ...} => | |
1593 | setNodeName (labelNode label, Label.toString label)) | |
1594 | val loopForestLayout = | |
1595 | Graph.LoopForest.layoutDot | |
1596 | (Graph.loopForestSteensgaard (graph, | |
1597 | {root = startNode}), | |
1598 | {title = concat [Func.toString name, " loop forest"], | |
1599 | options = [], | |
1600 | nodeName = nodeName}) | |
1601 | in | |
1602 | loopForestLayout | |
1603 | end | |
1604 | in | |
1605 | {destroy = destroy, | |
1606 | controlFlowGraph = controlFlowGraphLayout, | |
1607 | dominatorTree = dominatorTreeLayout, | |
1608 | loopForest = loopForestLayout} | |
1609 | end | |
1610 | end | |
1611 | ||
1612 | fun new (dest: dest) = | |
1613 | let | |
1614 | val controlFlow = CPromise.delay (fn () => determineControlFlow dest) | |
1615 | in | |
1616 | T {controlFlow = controlFlow, | |
1617 | dest = dest} | |
1618 | end | |
1619 | ||
1620 | fun clear (T {controlFlow, dest, ...}) = | |
1621 | let | |
1622 | val {args, blocks, ...} = dest | |
1623 | val _ = (Vector.foreach (args, Var.clear o #1) | |
1624 | ; Vector.foreach (blocks, Block.clear)) | |
1625 | val _ = CPromise.clear controlFlow | |
1626 | in | |
1627 | () | |
1628 | end | |
1629 | ||
1630 | fun layoutHeader (f: t): Layout.t = | |
1631 | let | |
1632 | val {args, name, raises, returns, start, ...} = dest f | |
1633 | open Layout | |
1634 | val (sep, rty) = | |
1635 | if !Control.showTypes | |
1636 | then (str ":", | |
1637 | indent (seq [record [("returns", | |
1638 | Option.layout | |
1639 | (Vector.layout Type.layout) | |
1640 | returns), | |
1641 | ("raises", | |
1642 | Option.layout | |
1643 | (Vector.layout Type.layout) | |
1644 | raises)], | |
1645 | str " ="], | |
1646 | 2)) | |
1647 | else (str " =", empty) | |
1648 | in | |
1649 | mayAlign [mayAlign [seq [str "fun ", | |
1650 | Func.layout name, | |
1651 | str " ", | |
1652 | layoutFormals args, | |
1653 | sep], | |
1654 | rty], | |
1655 | Transfer.layout (Transfer.Goto {dst = start, args = Vector.new0 ()})] | |
1656 | end | |
1657 | ||
1658 | fun layout' (f: t, layoutVar) = | |
1659 | let | |
1660 | val {blocks, ...} = dest f | |
1661 | open Layout | |
1662 | fun layoutBlock b = Block.layout' (b, layoutVar) | |
1663 | in | |
1664 | align [layoutHeader f, | |
1665 | indent (align (Vector.toListMap (blocks, layoutBlock)), 2)] | |
1666 | end | |
1667 | fun layout f = layout' (f, Var.layout) | |
1668 | ||
1669 | fun layouts (f: t, layoutVar, output: Layout.t -> unit): unit = | |
1670 | let | |
1671 | val {blocks, name, ...} = dest f | |
1672 | val _ = output (layoutHeader f) | |
1673 | val _ = | |
1674 | Vector.foreach | |
1675 | (blocks, fn b => | |
1676 | output (Layout.indent (Block.layout' (b, layoutVar), 2))) | |
1677 | val _ = | |
1678 | if not (!Control.keepDot) | |
1679 | then () | |
1680 | else | |
1681 | let | |
1682 | val {destroy, controlFlowGraph, dominatorTree, loopForest} = | |
1683 | layoutDot (f, layoutVar) | |
1684 | val name = Func.toString name | |
1685 | fun doit (s, g) = | |
1686 | let | |
1687 | open Control | |
1688 | in | |
1689 | saveToFile | |
1690 | ({suffix = concat [name, ".", s, ".dot"]}, | |
1691 | Dot, (), Layout (fn () => g)) | |
1692 | end | |
1693 | val _ = doit ("cfg", controlFlowGraph) | |
1694 | handle _ => Error.warning "SsaTree2.layouts: couldn't layout cfg" | |
1695 | val _ = doit ("dom", dominatorTree ()) | |
1696 | handle _ => Error.warning "SsaTree2.layouts: couldn't layout dom" | |
1697 | val _ = doit ("lf", loopForest ()) | |
1698 | handle _ => Error.warning "SsaTree2.layouts: couldn't layout lf" | |
1699 | val () = destroy () | |
1700 | in | |
1701 | () | |
1702 | end | |
1703 | in | |
1704 | () | |
1705 | end | |
1706 | ||
1707 | fun alphaRename f = | |
1708 | let | |
1709 | local | |
1710 | fun make (new, plist) = | |
1711 | let | |
1712 | val {get, set, destroy, ...} = | |
1713 | Property.destGetSetOnce (plist, Property.initConst NONE) | |
1714 | fun bind x = | |
1715 | let | |
1716 | val x' = new x | |
1717 | val _ = set (x, SOME x') | |
1718 | in | |
1719 | x' | |
1720 | end | |
1721 | fun lookup x = | |
1722 | case get x of | |
1723 | NONE => x | |
1724 | | SOME y => y | |
1725 | in (bind, lookup, destroy) | |
1726 | end | |
1727 | in | |
1728 | val (bindVar, lookupVar, destroyVar) = | |
1729 | make (Var.new, Var.plist) | |
1730 | val (bindLabel, lookupLabel, destroyLabel) = | |
1731 | make (Label.new, Label.plist) | |
1732 | end | |
1733 | val {args, blocks, mayInline, name, raises, returns, start, ...} = | |
1734 | dest f | |
1735 | val args = Vector.map (args, fn (x, ty) => (bindVar x, ty)) | |
1736 | val bindLabel = ignore o bindLabel | |
1737 | val bindVar = ignore o bindVar | |
1738 | val _ = | |
1739 | Vector.foreach | |
1740 | (blocks, fn Block.T {label, args, statements, ...} => | |
1741 | (bindLabel label | |
1742 | ; Vector.foreach (args, fn (x, _) => bindVar x) | |
1743 | ; Vector.foreach (statements, fn s => | |
1744 | Statement.foreachDef (s, bindVar o #1)))) | |
1745 | val blocks = | |
1746 | Vector.map | |
1747 | (blocks, fn Block.T {label, args, statements, transfer} => | |
1748 | Block.T {label = lookupLabel label, | |
1749 | args = Vector.map (args, fn (x, ty) => | |
1750 | (lookupVar x, ty)), | |
1751 | statements = (Vector.map | |
1752 | (statements, fn s => | |
1753 | Statement.replaceDefsUses | |
1754 | (s, {def = lookupVar, | |
1755 | use = lookupVar}))), | |
1756 | transfer = Transfer.replaceLabelVar | |
1757 | (transfer, lookupLabel, lookupVar)}) | |
1758 | val start = lookupLabel start | |
1759 | val _ = destroyVar () | |
1760 | val _ = destroyLabel () | |
1761 | in | |
1762 | new {args = args, | |
1763 | blocks = blocks, | |
1764 | mayInline = mayInline, | |
1765 | name = name, | |
1766 | raises = raises, | |
1767 | returns = returns, | |
1768 | start = start} | |
1769 | end | |
1770 | (* quell unused warning *) | |
1771 | val _ = alphaRename | |
1772 | ||
1773 | fun profile (f: t, sourceInfo): t = | |
1774 | if !Control.profile = Control.ProfileNone | |
1775 | orelse !Control.profileIL <> Control.ProfileSource | |
1776 | then f | |
1777 | else | |
1778 | let | |
1779 | val _ = Control.diagnostic (fn () => layout f) | |
1780 | val {args, blocks, mayInline, name, raises, returns, start} = dest f | |
1781 | val extraBlocks = ref [] | |
1782 | val {get = labelBlock, set = setLabelBlock, rem} = | |
1783 | Property.getSetOnce | |
1784 | (Label.plist, Property.initRaise ("block", Label.layout)) | |
1785 | val _ = | |
1786 | Vector.foreach | |
1787 | (blocks, fn block as Block.T {label, ...} => | |
1788 | setLabelBlock (label, block)) | |
1789 | val blocks = | |
1790 | Vector.map | |
1791 | (blocks, fn Block.T {args, label, statements, transfer} => | |
1792 | let | |
1793 | val statements = | |
1794 | if Label.equals (label, start) | |
1795 | then (Vector.concat | |
1796 | [Vector.new1 | |
1797 | (Profile (ProfileExp.Enter sourceInfo)), | |
1798 | statements]) | |
1799 | else statements | |
1800 | fun leave () = Profile (ProfileExp.Leave sourceInfo) | |
1801 | fun prefix (l: Label.t, | |
1802 | statements: Statement.t vector): Label.t = | |
1803 | let | |
1804 | val Block.T {args, ...} = labelBlock l | |
1805 | val c = Label.newNoname () | |
1806 | val xs = Vector.map (args, fn (x, _) => Var.new x) | |
1807 | val _ = | |
1808 | List.push | |
1809 | (extraBlocks, | |
1810 | Block.T | |
1811 | {args = Vector.map2 (xs, args, fn (x, (_, t)) => | |
1812 | (x, t)), | |
1813 | label = c, | |
1814 | statements = statements, | |
1815 | transfer = Goto {args = xs, | |
1816 | dst = l}}) | |
1817 | in | |
1818 | c | |
1819 | end | |
1820 | fun genHandler (cont: Label.t) | |
1821 | : Statement.t vector * Label.t * Handler.t = | |
1822 | case raises of | |
1823 | NONE => (statements, cont, Handler.Caller) | |
1824 | | SOME ts => | |
1825 | let | |
1826 | val xs = Vector.map (ts, fn _ => Var.newNoname ()) | |
1827 | val l = Label.newNoname () | |
1828 | val _ = | |
1829 | List.push | |
1830 | (extraBlocks, | |
1831 | Block.T | |
1832 | {args = Vector.zip (xs, ts), | |
1833 | label = l, | |
1834 | statements = Vector.new1 (leave ()), | |
1835 | transfer = Transfer.Raise xs}) | |
1836 | in | |
1837 | (statements, | |
1838 | prefix (cont, Vector.new0 ()), | |
1839 | Handler.Handle l) | |
1840 | end | |
1841 | fun addLeave () = | |
1842 | (Vector.concat [statements, | |
1843 | Vector.new1 (leave ())], | |
1844 | transfer) | |
1845 | val (statements, transfer) = | |
1846 | case transfer of | |
1847 | Call {args, func, return} => | |
1848 | let | |
1849 | datatype z = datatype Return.t | |
1850 | in | |
1851 | case return of | |
1852 | Dead => (statements, transfer) | |
1853 | | NonTail {cont, handler} => | |
1854 | (case handler of | |
1855 | Handler.Dead => (statements, transfer) | |
1856 | | Handler.Caller => | |
1857 | let | |
1858 | val (statements, cont, handler) = | |
1859 | genHandler cont | |
1860 | val return = | |
1861 | Return.NonTail | |
1862 | {cont = cont, | |
1863 | handler = handler} | |
1864 | in | |
1865 | (statements, | |
1866 | Call {args = args, | |
1867 | func = func, | |
1868 | return = return}) | |
1869 | end | |
1870 | | Handler.Handle _ => | |
1871 | (statements, transfer)) | |
1872 | | Tail => addLeave () | |
1873 | end | |
1874 | | Raise _ => addLeave () | |
1875 | | Return _ => addLeave () | |
1876 | | _ => (statements, transfer) | |
1877 | in | |
1878 | Block.T {args = args, | |
1879 | label = label, | |
1880 | statements = statements, | |
1881 | transfer = transfer} | |
1882 | end) | |
1883 | val _ = Vector.foreach (blocks, rem o Block.label) | |
1884 | val blocks = Vector.concat [Vector.fromList (!extraBlocks), blocks] | |
1885 | val f = | |
1886 | new {args = args, | |
1887 | blocks = blocks, | |
1888 | mayInline = mayInline, | |
1889 | name = name, | |
1890 | raises = raises, | |
1891 | returns = returns, | |
1892 | start = start} | |
1893 | val _ = Control.diagnostic (fn () => layout f) | |
1894 | in | |
1895 | f | |
1896 | end | |
1897 | ||
1898 | val profile = | |
1899 | Trace.trace2 ("SsaTree2.Function.profile", layout, SourceInfo.layout, layout) | |
1900 | profile | |
1901 | end | |
1902 | ||
1903 | structure Program = | |
1904 | struct | |
1905 | datatype t = | |
1906 | T of { | |
1907 | datatypes: Datatype.t vector, | |
1908 | globals: Statement.t vector, | |
1909 | functions: Function.t list, | |
1910 | main: Func.t | |
1911 | } | |
1912 | end | |
1913 | ||
1914 | structure Program = | |
1915 | struct | |
1916 | open Program | |
1917 | ||
1918 | local | |
1919 | structure Graph = DirectedGraph | |
1920 | structure Node = Graph.Node | |
1921 | structure Edge = Graph.Edge | |
1922 | in | |
1923 | fun layoutCallGraph (T {functions, main, ...}, | |
1924 | title: string): Layout.t = | |
1925 | let | |
1926 | open Dot | |
1927 | val graph = Graph.new () | |
1928 | val {get = nodeOptions, set = setNodeOptions, ...} = | |
1929 | Property.getSetOnce | |
1930 | (Node.plist, Property.initRaise ("options", Node.layout)) | |
1931 | val {get = funcNode, destroy} = | |
1932 | Property.destGet | |
1933 | (Func.plist, Property.initFun | |
1934 | (fn f => | |
1935 | let | |
1936 | val n = Graph.newNode graph | |
1937 | val _ = | |
1938 | setNodeOptions | |
1939 | (n, | |
1940 | let open NodeOption | |
1941 | in [FontColor Black, label (Func.toString f)] | |
1942 | end) | |
1943 | in | |
1944 | n | |
1945 | end)) | |
1946 | val {get = edgeOptions, set = setEdgeOptions, ...} = | |
1947 | Property.getSetOnce (Edge.plist, Property.initConst []) | |
1948 | val _ = | |
1949 | List.foreach | |
1950 | (functions, fn f => | |
1951 | let | |
1952 | val {name, blocks, ...} = Function.dest f | |
1953 | val from = funcNode name | |
1954 | val {get, destroy} = | |
1955 | Property.destGet | |
1956 | (Node.plist, | |
1957 | Property.initFun (fn _ => {nontail = ref false, | |
1958 | tail = ref false})) | |
1959 | val _ = | |
1960 | Vector.foreach | |
1961 | (blocks, fn Block.T {transfer, ...} => | |
1962 | case transfer of | |
1963 | Call {func, return, ...} => | |
1964 | let | |
1965 | val to = funcNode func | |
1966 | val {tail, nontail} = get to | |
1967 | datatype z = datatype Return.t | |
1968 | val is = | |
1969 | case return of | |
1970 | Dead => false | |
1971 | | NonTail _ => true | |
1972 | | Tail => false | |
1973 | val r = if is then nontail else tail | |
1974 | in | |
1975 | if !r | |
1976 | then () | |
1977 | else (r := true | |
1978 | ; (setEdgeOptions | |
1979 | (Graph.addEdge | |
1980 | (graph, {from = from, to = to}), | |
1981 | if is | |
1982 | then [] | |
1983 | else [EdgeOption.Style Dotted]))) | |
1984 | end | |
1985 | | _ => ()) | |
1986 | val _ = destroy () | |
1987 | in | |
1988 | () | |
1989 | end) | |
1990 | val root = funcNode main | |
1991 | val l = | |
1992 | Graph.layoutDot | |
1993 | (graph, fn {nodeName} => | |
1994 | {title = title, | |
1995 | options = [GraphOption.Rank (Min, [{nodeName = nodeName root}])], | |
1996 | edgeOptions = edgeOptions, | |
1997 | nodeOptions = nodeOptions}) | |
1998 | val _ = destroy () | |
1999 | in | |
2000 | l | |
2001 | end | |
2002 | end | |
2003 | ||
2004 | fun layouts (p as T {datatypes, globals, functions, main}, | |
2005 | output': Layout.t -> unit) = | |
2006 | let | |
2007 | val layoutVar = Statement.prettifyGlobals globals | |
2008 | open Layout | |
2009 | (* Layout includes an output function, so we need to rebind output | |
2010 | * to the one above. | |
2011 | *) | |
2012 | val output = output' | |
2013 | in | |
2014 | output (str "\n\nDatatypes:") | |
2015 | ; Vector.foreach (datatypes, output o Datatype.layout) | |
2016 | ; output (str "\n\nGlobals:") | |
2017 | ; Vector.foreach (globals, output o (fn s => Statement.layout' (s, layoutVar))) | |
2018 | ; output (seq [str "\n\nMain: ", Func.layout main]) | |
2019 | ; output (str "\n\nFunctions:") | |
2020 | ; List.foreach (functions, fn f => | |
2021 | Function.layouts (f, layoutVar, output)) | |
2022 | ; if not (!Control.keepDot) | |
2023 | then () | |
2024 | else | |
2025 | let | |
2026 | open Control | |
2027 | in | |
2028 | saveToFile | |
2029 | ({suffix = "call-graph.dot"}, | |
2030 | Dot, (), Layout (fn () => | |
2031 | layoutCallGraph (p, !Control.inputFile))) | |
2032 | end | |
2033 | end | |
2034 | ||
2035 | fun layoutStats (T {datatypes, globals, functions, main, ...}) = | |
2036 | let | |
2037 | val (mainNumVars, mainNumBlocks) = | |
2038 | case List.peek (functions, fn f => | |
2039 | Func.equals (main, Function.name f)) of | |
2040 | NONE => Error.bug "SsaTree2.Program.layoutStats: no main" | |
2041 | | SOME f => | |
2042 | let | |
2043 | val numVars = ref 0 | |
2044 | val _ = Function.foreachVar (f, fn _ => Int.inc numVars) | |
2045 | val {blocks, ...} = Function.dest f | |
2046 | val numBlocks = Vector.length blocks | |
2047 | in | |
2048 | (!numVars, numBlocks) | |
2049 | end | |
2050 | val numTypes = ref 0 | |
2051 | val {get = countType, destroy} = | |
2052 | Property.destGet | |
2053 | (Type.plist, | |
2054 | Property.initRec | |
2055 | (fn (t, countType) => | |
2056 | let | |
2057 | datatype z = datatype Type.dest | |
2058 | val _ = | |
2059 | case Type.dest t of | |
2060 | CPointer => () | |
2061 | | Datatype _ => () | |
2062 | | IntInf => () | |
2063 | | Object {args, ...} => Prod.foreach (args, countType) | |
2064 | | Real _ => () | |
2065 | | Thread => () | |
2066 | | Weak t => countType t | |
2067 | | Word _ => () | |
2068 | val _ = Int.inc numTypes | |
2069 | in | |
2070 | () | |
2071 | end)) | |
2072 | val _ = | |
2073 | Vector.foreach | |
2074 | (datatypes, fn Datatype.T {cons, ...} => | |
2075 | Vector.foreach (cons, fn {args, ...} => | |
2076 | Prod.foreach (args, countType))) | |
2077 | val numStatements = ref (Vector.length globals) | |
2078 | val numBlocks = ref 0 | |
2079 | val _ = | |
2080 | List.foreach | |
2081 | (functions, fn f => | |
2082 | let | |
2083 | val {args, blocks, ...} = Function.dest f | |
2084 | val _ = Vector.foreach (args, countType o #2) | |
2085 | val _ = | |
2086 | Vector.foreach | |
2087 | (blocks, fn Block.T {args, statements, ...} => | |
2088 | let | |
2089 | val _ = Int.inc numBlocks | |
2090 | val _ = Vector.foreach (args, countType o #2) | |
2091 | val _ = | |
2092 | Vector.foreach | |
2093 | (statements, fn stmt => | |
2094 | let | |
2095 | val _ = Int.inc numStatements | |
2096 | datatype z = datatype Statement.t | |
2097 | val _ = | |
2098 | case stmt of | |
2099 | Bind {ty, ...} => countType ty | |
2100 | | _ => () | |
2101 | in () end) | |
2102 | in () end) | |
2103 | in () end) | |
2104 | val numFunctions = List.length functions | |
2105 | val _ = destroy () | |
2106 | open Layout | |
2107 | in | |
2108 | align | |
2109 | [seq [str "num vars in main = ", Int.layout mainNumVars], | |
2110 | seq [str "num blocks in main = ", Int.layout mainNumBlocks], | |
2111 | seq [str "num functions in program = ", Int.layout numFunctions], | |
2112 | seq [str "num blocks in program = ", Int.layout (!numBlocks)], | |
2113 | seq [str "num statements in program = ", Int.layout (!numStatements)], | |
2114 | seq [str "num types in program = ", Int.layout (!numTypes)], | |
2115 | Type.stats ()] | |
2116 | end | |
2117 | ||
2118 | (* clear all property lists reachable from program *) | |
2119 | fun clear (T {datatypes, globals, functions, ...}) = | |
2120 | ((* Can't do Type.clear because it clears out the info needed for | |
2121 | * Type.dest. | |
2122 | *) | |
2123 | Vector.foreach (datatypes, Datatype.clear) | |
2124 | ; Vector.foreach (globals, Statement.clear) | |
2125 | ; List.foreach (functions, Function.clear)) | |
2126 | ||
2127 | fun clearGlobals (T {globals, ...}) = | |
2128 | Vector.foreach (globals, Statement.clear) | |
2129 | ||
2130 | fun clearTop (p as T {datatypes, functions, ...}) = | |
2131 | (Vector.foreach (datatypes, Datatype.clear) | |
2132 | ; List.foreach (functions, Func.clear o Function.name) | |
2133 | ; clearGlobals p) | |
2134 | ||
2135 | fun foreachVar (T {globals, functions, ...}, f) = | |
2136 | (Vector.foreach (globals, fn s => Statement.foreachDef (s, f)) | |
2137 | ; List.foreach (functions, fn g => Function.foreachVar (g, f))) | |
2138 | ||
2139 | fun foreachPrimApp (T {globals, functions, ...}, f) = | |
2140 | let | |
2141 | fun loopStatement (s: Statement.t) = | |
2142 | case s of | |
2143 | Bind {exp = PrimApp {args, prim}, ...} => | |
2144 | f {args = args, prim = prim} | |
2145 | | _ => () | |
2146 | fun loopTransfer t = | |
2147 | case t of | |
2148 | Arith {args, prim, ...} => f {args = args, prim = prim} | |
2149 | | Runtime {args, prim, ...} => f {args = args, prim = prim} | |
2150 | | _ => () | |
2151 | val _ = Vector.foreach (globals, loopStatement) | |
2152 | val _ = | |
2153 | List.foreach | |
2154 | (functions, fn f => | |
2155 | Vector.foreach | |
2156 | (Function.blocks f, fn Block.T {statements, transfer, ...} => | |
2157 | (Vector.foreach (statements, loopStatement); | |
2158 | loopTransfer transfer))) | |
2159 | in | |
2160 | () | |
2161 | end | |
2162 | ||
2163 | fun hasPrim (p, f) = | |
2164 | Exn.withEscape | |
2165 | (fn escape => | |
2166 | (foreachPrimApp (p, fn {prim, ...} => | |
2167 | if f prim then escape true else ()) | |
2168 | ; false)) | |
2169 | ||
2170 | fun dfs (p, v) = | |
2171 | let | |
2172 | val T {functions, main, ...} = p | |
2173 | val functions = Vector.fromList functions | |
2174 | val numFunctions = Vector.length functions | |
2175 | val {get = funcIndex, set = setFuncIndex, rem, ...} = | |
2176 | Property.getSetOnce (Func.plist, | |
2177 | Property.initRaise ("index", Func.layout)) | |
2178 | val _ = Vector.foreachi (functions, fn (i, f) => | |
2179 | setFuncIndex (#name (Function.dest f), i)) | |
2180 | val visited = Array.array (numFunctions, false) | |
2181 | fun visit (f: Func.t): unit = | |
2182 | let | |
2183 | val i = funcIndex f | |
2184 | in | |
2185 | if Array.sub (visited, i) | |
2186 | then () | |
2187 | else | |
2188 | let | |
2189 | val _ = Array.update (visited, i, true) | |
2190 | val f = Vector.sub (functions, i) | |
2191 | val v' = v f | |
2192 | val _ = Function.dfs | |
2193 | (f, fn Block.T {transfer, ...} => | |
2194 | (Transfer.foreachFunc (transfer, visit) | |
2195 | ; fn () => ())) | |
2196 | val _ = v' () | |
2197 | in | |
2198 | () | |
2199 | end | |
2200 | end | |
2201 | val _ = visit main | |
2202 | val _ = Vector.foreach (functions, rem o Function.name) | |
2203 | in | |
2204 | () | |
2205 | end | |
2206 | ||
2207 | end | |
2208 | ||
2209 | end |