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