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.
6 * MLton is released under a BSD-style license.
7 * See the file MLton-LICENSE for details.
10 functor SsaTree (S: SSA_TREE_STRUCTS): SSA_TREE =
19 plist: PropertyList.t,
35 fun make f (T r) = f r
38 val plist = make #plist
42 datatype dest = datatype tree
46 fun equals (t, t') = PropertyList.equals (plist t, plist t')
49 fun make (sel : dest -> 'a option) =
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
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)
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)
81 val table: t HashSet.t = HashSet.new {hash = hash}
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 (),
92 in align [seq [str "num types in hash table = ",
93 Int.layout (HashSet.size table)],
94 Control.sizeMessage ("types hash table", lookup)]
98 val newHash = Random.word
101 fun make f : t -> t =
105 fn t => lookup (Word.xorb (w, hash t), f t)
108 val array = make Array
110 val vector = make Vector
114 val datatypee: Tycon.t -> t =
115 fn t => lookup (Tycon.hash t, Datatype t)
117 val bool = datatypee Tycon.bool
120 fun make (tycon, tree) = lookup (Tycon.hash tycon, tree)
122 val cpointer = make (Tycon.cpointer, CPointer)
123 val intInf = make (Tycon.intInf, IntInf)
124 val thread = make (Tycon.thread, Thread)
127 val real: RealSize.t -> t =
128 fn s => lookup (Tycon.hash (Tycon.real s), Real s)
130 val word: WordSize.t -> t =
131 fn s => lookup (Tycon.hash (Tycon.word s), Word s)
135 val generator: Word.t = 0wx5555
139 if 1 = Vector.length ts
141 else lookup (Vector.fold (ts, w, fn (t, w) =>
142 Word.xorb (w * generator, hash t)),
148 datatype z = datatype Const.t
153 | Real r => real (RealX.size r)
154 | Word w => word (WordX.size w)
155 | WordVector v => vector (word (WordXVector.elementSize v))
158 val unit: t = tuple (Vector.new0 ())
160 val isUnit: t -> bool =
163 SOME ts => Vector.isEmpty ts
169 val {get = layout, ...} =
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"
186 (mayAlign o separateRight)
187 (Vector.toListMap (ts, layout), " *"),
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])))
194 fun checkPrimApp {args, prim, result, targs}: bool =
203 typeOps = {array = array,
204 arrow = fn _ => raise BadPrimApp,
217 val default = fn () =>
218 (default ()) handle BadPrimApp => false
220 datatype z = datatype Prim.Name.t
222 case Prim.name prim of
230 Con of (Con.t * Label.t) vector
231 | Word of WordSize.t * (WordX.t * Label.t) vector
233 fun equals (c1: t, c2: t): bool =
235 fun doit (l1, l2, eq') =
237 (l1, l2, fn ((x1, a1), (x2, a2)) =>
238 eq' (x1, x2) andalso Label.equals (a1, a2))
241 (Con l1, Con l2) => doit (l1, l2, Con.equals)
242 | (Word (_, l1), Word (_, l2)) => doit (l1, l2, WordX.equals)
246 fun hd (c: t): Label.t =
249 if Vector.length v >= 1
250 then let val (_, a) = Vector.first v
253 else Error.bug "SsaTree.Cases.hd"
257 | Word (_, cs) => doit cs
260 fun isEmpty (c: t): bool =
262 fun doit v = Vector.isEmpty v
266 | Word (_, cs) => doit cs
269 fun fold (c: t, b, f) =
271 fun doit l = Vector.fold (l, b, fn ((_, a), b) => f (a, b))
275 | Word (_, l) => doit l
278 fun map (c: t, f): t =
280 fun doit l = Vector.map (l, fn (i, x) => (i, f x))
283 Con l => Con (doit l)
284 | Word (s, l) => Word (s, doit l)
287 fun forall (c: t, f: Label.t -> bool): bool =
289 fun doit l = Vector.forall (l, fn (_, x) => f x)
293 | Word (_, l) => doit l
296 fun length (c: t): int = fold (c, 0, fn (_, i) => i + 1)
298 fun foreach (c, f) = fold (c, (), fn (x, ()) => f x)
303 val check: int * int option -> int *bool =
304 fn (size, NONE) => (size,false)
305 | (size, SOME max) => (size,size > max)
311 ConApp of {con: Con.t,
314 | PrimApp of {prim: Type.t Prim.t,
315 targs: Type.t vector,
317 | Profile of ProfileExp.t
318 | Select of {tuple: Var.t,
320 | Tuple of Var.t vector
323 val unit = Tuple (Vector.new0 ())
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
329 | PrimApp {args, ...} => 1 + Vector.length args
332 | Tuple xs => 1 + Vector.length xs
335 fun foreachVar (e, v) =
337 fun vs xs = Vector.foreach (xs, v)
340 ConApp {args, ...} => vs args
342 | PrimApp {args, ...} => vs args
344 | Select {tuple, ...} => v tuple
349 fun replaceVar (e, fx) =
351 fun fxs xs = Vector.map (xs, fx)
354 ConApp {con, args} => ConApp {con = con, args = fxs args}
356 | PrimApp {prim, targs, args} =>
357 PrimApp {prim = prim, targs = targs, args = fxs args}
359 | Select {tuple, offset} =>
360 Select {tuple = fx tuple, offset = offset}
361 | Tuple xs => Tuple (fxs xs)
362 | Var x => Var (fx x)
365 fun layout' (e, layoutVar) =
368 fun layoutArgs xs = Vector.layout layoutVar xs
371 ConApp {con, args} =>
373 if Vector.isEmpty args
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
382 else Vector.layout Type.layout targs
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
393 fun layout e = layout' (e, Var.layout)
395 fun maySideEffect (e: t): bool =
399 | PrimApp {prim,...} => Prim.maySideEffect prim
405 fun varsEquals (xs, xs') = Vector.equals (xs, xs', Var.equals)
407 fun equals (e: t, e': t): bool =
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')
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))
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
442 val hash = Trace.trace ("SsaTree.Exp.hash", layout, Word.layout) hash
444 datatype z = datatype Exp.t
446 structure Statement =
448 datatype t = T of {var: Var.t option,
453 fun make f (T r) = f r
459 fun sizeAux (T {exp, ...}, acc, max, sizeExp) =
460 Size.check (sizeExp exp + acc, max)
462 fun layout' (T {var, ty, exp}, layoutVar) =
466 if !Control.showTypes
467 then (str ":", indent (seq [Type.layout ty, str " ="], 2))
468 else (str " =", empty)
470 mayAlign [mayAlign [seq [case var of
472 | SOME var => Var.layout var,
475 indent (Exp.layout' (exp, layoutVar), 2)]
477 fun layout e = layout' (e, Var.layout)
485 val profile = make Exp.Profile
488 fun clear s = Option.app (var s, Var.clear)
490 fun prettifyGlobals (v: t vector): Var.t -> Layout.t =
492 val {get = global: Var.t -> Layout.t, set = setGlobal, ...} =
493 Property.getSet (Var.plist, Property.initFun Var.layout)
496 (v, fn T {var, exp, ...} =>
502 val s = Layout.toString (Exp.layout' (exp, global))
505 val dotsSize = String.size dots
506 val frontSize = 2 * (maxSize - dotsSize) div 3
507 val backSize = maxSize - dotsSize - frontSize
509 if String.size s > maxSize
510 then concat [String.prefix (s, frontSize),
512 String.suffix (s, backSize)]
515 setGlobal (var, Layout.seq [Var.layout var,
516 Layout.str (" (*" ^ s ^ "*)")])
522 | Tuple xs => if Vector.isEmpty xs then set () else ()
532 structure Label = Label
539 fun layout (h: t): Layout.t =
544 Caller => str "Caller"
546 | Handle l => seq [str "Handle ", Label.layout l]
550 fn (Caller, Caller) => true
551 | (Dead, Dead) => true
552 | (Handle l, Handle l') => Label.equals (l, l')
555 fun foldLabel (h: t, a: 'a, f: Label.t * 'a -> 'a): 'a =
559 | Handle l => f (l, a)
561 fun foreachLabel (h, f) = foldLabel (h, (), f o #1)
567 | Handle l => Handle (f l)
570 val newHash = Random.word
571 val caller = newHash ()
572 val dead = newHash ()
573 val handlee = newHash ()
575 fun hash (h: t): word =
579 | Handle l => Word.xorb (handlee, Label.hash l)
585 structure Label = Label
586 structure Handler = Handler
590 | NonTail of {cont: Label.t,
600 | NonTail {cont, handler} =>
603 [("cont", Label.layout cont),
604 ("handler", Handler.layout handler)]]
608 fun equals (r, r'): bool =
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
617 fun foldLabel (r: t, a, f) =
620 | NonTail {cont, handler} =>
621 Handler.foldLabel (handler, f (cont, a), f)
624 fun foreachLabel (r, f) = foldLabel (r, (), f o #1)
626 fun foreachHandler (r, f) =
629 | NonTail {handler, ...} => Handler.foreachLabel (handler, f)
635 | NonTail {cont, handler} =>
636 NonTail {cont = f cont,
637 handler = Handler.map (handler, f)}
640 fun compose (r, r') =
643 | NonTail {cont, handler} =>
646 handler = (case handler of
649 Dead => Handler.Caller
650 | NonTail {handler, ...} => handler
651 | Tail => Handler.Caller)
652 | Handler.Dead => handler
653 | Handler.Handle _ => handler)}
657 val newHash = Random.word
658 val dead = newHash ()
659 val nonTail = newHash ()
660 val tail = newHash ()
665 | NonTail {cont, handler} =>
666 Word.xorb (Word.xorb (nonTail, Label.hash cont),
667 Handler.hash handler)
675 Arith of {prim: Type.t Prim.t,
677 overflow: Label.t, (* Must be nullary. *)
678 success: Label.t, (* Must be unary. *)
680 | Bug (* MLton thought control couldn't reach here. *)
681 | Call of {args: Var.t vector,
684 | Case of {test: Var.t,
686 default: Label.t option} (* Must be nullary. *)
687 | Goto of {dst: Label.t,
689 | Raise of Var.t vector
690 | Return of Var.t vector
691 | Runtime of {prim: Type.t Prim.t,
693 return: Label.t} (* Must be nullary. *)
695 (* Vals to determine the size for inline.fun and loop optimization*)
697 fn Arith {args, ...} => 1 + Vector.length args
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
706 fun foreachFuncLabelVar (t, func: Func.t -> unit, label: Label.t -> unit, var) =
708 fun vars xs = Vector.foreach (xs, var)
711 Arith {args, overflow, success, ...} =>
716 | Call {func = f, args, return, ...} =>
718 ; Return.foreachLabel (return, label)
720 | Case {test, cases, default, ...} =>
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, ...} =>
732 fun foreachFunc (t, func) =
733 foreachFuncLabelVar (t, func, fn _ => (), fn _ => ())
735 fun foreachLabelVar (t, label, var) =
736 foreachFuncLabelVar (t, fn _ => (), label, var)
738 fun foreachLabel (t, j) = foreachLabelVar (t, j, fn _ => ())
739 fun foreachVar (t, v) = foreachLabelVar (t, fn _ => (), v)
741 fun replaceLabelVar (t, fl, fx) =
743 fun fxs xs = Vector.map (xs, fx)
746 Arith {prim, args, overflow, success, ty} =>
749 overflow = fl overflow,
750 success = fl success,
753 | Call {func, args, return} =>
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} =>
764 | Raise xs => Raise (fxs xs)
765 | Return xs => Return (fxs xs)
766 | Runtime {prim, args, return} =>
767 Runtime {prim = prim,
772 fun replaceLabel (t, f) = replaceLabelVar (t, f, fn x => x)
773 fun replaceVar (t, f) = replaceLabelVar (t, fn l => l, f)
776 fun layoutCase ({test, cases, default}, layoutVar) =
779 fun doit (l, layout) =
782 seq [layout i, str " => ", Label.layout l])
783 datatype z = datatype Cases.t
786 Con l => doit (l, Con.layout)
787 | Word (_, l) => doit (l, WordX.layout)
792 cases @ [seq [str "_ => ", Label.layout j]]
794 align [seq [str "case ", layoutVar test, str " of"],
795 indent (alignPrefix (cases, "| "), 2)]
798 fun layout' (t, layoutVar) =
801 fun layoutArgs xs = Vector.layout layoutVar xs
802 fun layoutPrim {prim, args} =
804 (Exp.PrimApp {prim = prim,
805 targs = Vector.new0 (),
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]
815 | Call {func, args, return} =>
817 val call = seq [Func.layout func, str " ", layoutArgs args]
820 Return.Dead => seq [str "dead ", paren call]
821 | Return.NonTail {cont, handler} =>
822 seq [Label.layout cont, str " ",
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]
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}]]
841 fun layout t = layout' (t, Var.layout)
843 fun varsEquals (xs, xs') = Vector.equals (xs, xs', Var.equals)
845 fun equals (e: t, e': t): bool =
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')
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')
878 val newHash = Random.word
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)
886 val hash: t -> Word.t =
887 fn Arith {args, overflow, success, ...} =>
888 hashVars (args, hash2 (Label.hash overflow,
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,
898 (default, 0wx55555555,
900 hash2 (Label.hash 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)
910 val hash = Trace.trace ("SsaTree.Transfer.hash", layout, Word.layout) hash
913 datatype z = datatype Transfer.t
918 fun layoutFormals (xts: (Var.t * Type.t) vector) =
919 Vector.layout (fn (x, t) =>
921 if !Control.showTypes
922 then seq [str ": ", Type.layout t]
930 T of {args: (Var.t * Type.t) vector,
932 statements: Statement.t vector,
933 transfer: Transfer.t}
936 fun make f (T r) = f r
938 val args = make #args
939 val label = make #label
940 val statements = make #statements
941 val transfer = make #transfer
944 fun sizeAux (T {statements, transfer, ...},
945 acc, max, sizeExp, sizeTransfer) =
949 (statements, Size.check (acc + sizeTransfer transfer, max),
950 fn (stmt, (acc, chk)) =>
952 then escape (acc, chk)
953 else Statement.sizeAux (stmt, acc, max, sizeExp)))
955 fun sizeAuxV (bs, acc, max, sizeExp, sizeTransfer) =
959 (bs, (acc, false), fn (b, (acc, chk)) =>
961 then escape (acc, chk)
962 else sizeAux (b, acc, max, sizeExp, sizeTransfer)))
964 fun sizeV (bs, {sizeExp, sizeTransfer}) =
965 #1 (sizeAuxV (bs, 0, NONE, sizeExp, sizeTransfer))
967 fun layout' (T {label, args, statements, transfer}, layoutVar) =
970 fun layoutStatement s = Statement.layout' (s, layoutVar)
971 fun layoutTransfer t = Transfer.layout' (t, layoutVar)
973 align [seq [Label.layout label, str " ",
977 (Vector.toListMap (statements, layoutStatement)),
978 layoutTransfer transfer],
981 fun layout b = layout' (b, Var.layout)
983 fun clear (T {label, args, statements, ...}) =
985 ; Vector.foreach (args, Var.clear o #1)
986 ; Vector.foreach (statements, Statement.clear))
995 args: Type.t vector} vector
998 fun layout (T {tycon, cons}) =
1002 seq [Tycon.layout tycon,
1006 (cons, fn {con, args} =>
1007 seq [Con.layout con,
1008 if Vector.isEmpty args
1010 else seq [str " of ",
1011 Vector.layout Type.layout args]]),
1015 fun clear (T {tycon, cons}) =
1017 ; Vector.foreach (cons, Con.clear o #con))
1020 structure Function =
1022 structure CPromise = ClearablePromise
1024 type dest = {args: (Var.t * Type.t) vector,
1025 blocks: Block.t vector,
1028 raises: Type.t vector option,
1029 returns: Type.t vector option,
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.
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,
1049 fun make f (T {dest, ...}) = f dest
1051 val blocks = make #blocks
1052 val dest = make (fn d => d)
1053 val mayInline = make #mayInline
1054 val name = make #name
1057 fun sizeAux (f, acc, max, sizeExp, sizeTransfer) =
1058 Block.sizeAuxV (blocks f, acc, max, sizeExp, sizeTransfer)
1060 fun size (f, {sizeExp, sizeTransfer}) =
1061 #1 (sizeAux (f, 0, NONE, sizeExp, sizeTransfer))
1063 fun sizeMax (f, {max, sizeExp, sizeTransfer}) =
1065 val (s, chk) = sizeAux (f, 0, max, sizeExp, sizeTransfer)
1072 fun foreachVar (f: t, fx: Var.t * Type.t -> unit): unit =
1074 val {args, blocks, ...} = dest f
1075 val _ = Vector.foreach (args, fx)
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)))))
1086 fun controlFlow (T {controlFlow, ...}) =
1088 val {graph, labelNode, nodeBlock, ...} = CPromise.force controlFlow
1090 {graph = graph, labelNode = labelNode, nodeBlock = nodeBlock}
1095 fn T {controlFlow, ...} => sel (CPromise.force controlFlow) ()
1097 val dominatorTree = make #dominatorTree
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 =
1112 val i = labelIndex l
1114 if Array.sub (visited, i)
1118 val _ = Array.update (visited, i, true)
1119 val b as Block.T {transfer, ...} =
1120 Vector.sub (blocks, i)
1122 val _ = Transfer.foreachLabel (transfer, visit)
1129 val _ = Vector.foreach (blocks, rem o Block.label)
1135 structure Graph = DirectedGraph
1136 structure Node = Graph.Node
1137 structure Edge = Graph.Edge
1139 fun determineControlFlow ({blocks, start, ...}: dest) =
1142 val g = Graph.new ()
1143 fun newNode () = Graph.newNode g
1144 val {get = labelNode, ...} =
1146 (Label.plist, Property.initFun (fn _ => newNode ()))
1147 val {get = nodeInfo: unit Node.t -> {block: Block.t},
1148 set = setNodeInfo, ...} =
1150 (Node.plist, Property.initRaise ("info", Node.layout))
1153 (blocks, fn b as Block.T {label, transfer, ...} =>
1155 val from = labelNode label
1156 val _ = setNodeInfo (from, {block = b})
1158 Transfer.foreachLabel
1160 (ignore o Graph.addEdge)
1161 (g, {from = from, to = labelNode to}))
1165 val root = labelNode start
1169 Graph.dfsTree (g, {root = root,
1170 nodeValue = #block o nodeInfo}))
1174 Graph.dominatorTree (g, {root = root,
1175 nodeValue = #block o nodeInfo}))
1178 dominatorTree = dominatorTree,
1180 labelNode = labelNode,
1181 nodeBlock = #block o nodeInfo}
1184 fun layoutDot (f, layoutVar) =
1186 fun toStringStatement s = Layout.toString (Statement.layout' (s, layoutVar))
1187 fun toStringTransfer t =
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
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 =
1210 val e = Graph.addEdge (graph, {from = from,
1212 val _ = setEdgeOptions (e, [EdgeOption.label label,
1213 EdgeOption.Style style])
1219 (blocks, fn Block.T {label, args, statements, transfer} =>
1221 val from = labelNode label
1222 val edge = fn (to, label, style) =>
1223 edge (from, labelNode to, label, style)
1226 Arith {overflow, success, ...} =>
1227 (edge (success, "", Solid)
1228 ; edge (overflow, "Overflow", Dashed))
1230 | Call {return, ...} =>
1235 | Return.NonTail {cont, handler} =>
1236 (edge (cont, "", Dotted)
1237 ; (Handler.foreachLabel
1239 edge (l, "Handle", Dashed))))
1244 | Case {cases, default, ...} =>
1246 fun doit (v, toString) =
1249 edge (j, toString x, Solid))
1253 doit (v, Con.toString)
1254 | Cases.Word (_, v) =>
1255 doit (v, WordX.toString)
1260 edge (j, "Default", Solid)
1264 | Goto {dst, ...} => edge (dst, "", Solid)
1267 | Runtime {return, ...} => edge (return, "", Dotted)
1269 [(toStringTransfer transfer, Left)]
1272 (statements, lab, fn (s, ac) =>
1273 (toStringStatement s, Left) :: ac)
1275 (toStringHeader (Label.toString label, args), Left)::lab
1276 val _ = setNodeText (from, lab)
1280 val startNode = labelNode start
1283 val funNode = newNode ()
1284 val _ = edge (funNode, startNode, "Start", Solid)
1286 [(toStringTransfer (Transfer.Goto {dst = start, args = Vector.new0 ()}), Left)]
1288 if !Control.showTypes
1289 then ((Layout.toString o Layout.seq)
1291 Layout.record [("returns",
1293 (Vector.layout Type.layout)
1297 (Vector.layout Type.layout)
1302 (toStringHeader ("fun " ^ Func.toString name, args), Left)::
1304 val _ = setNodeText (funNode, lab)
1308 val controlFlowGraphLayout =
1310 (graph, fn {nodeName} =>
1311 {title = concat [Func.toString name, " control-flow graph"],
1312 options = [GraphOption.Rank (Min, [{nodeName = nodeName funNode}])],
1313 edgeOptions = edgeOptions,
1316 val l = ! (nodeOptions n)
1318 in FontColor Black :: Shape Box :: l
1320 val () = Graph.removeNode (graph, funNode)
1321 fun dominatorTreeLayout () =
1323 val {get = nodeOptions, set = setNodeOptions, ...} =
1324 Property.getSetOnce (Node.plist, Property.initConst [])
1327 (blocks, fn Block.T {label, ...} =>
1328 setNodeOptions (labelNode label,
1329 [NodeOption.label (Label.toString label)]))
1330 val dominatorTreeLayout =
1332 (Graph.dominatorTree (graph,
1334 nodeValue = fn n => n}),
1335 {title = concat [Func.toString name, " dominator tree"],
1337 nodeOptions = nodeOptions})
1341 fun loopForestLayout () =
1343 val {get = nodeName, set = setNodeName, ...} =
1344 Property.getSetOnce (Node.plist, Property.initConst "")
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"],
1355 nodeName = nodeName})
1361 controlFlowGraph = controlFlowGraphLayout,
1362 dominatorTree = dominatorTreeLayout,
1363 loopForest = loopForestLayout}
1367 fun new (dest: dest) =
1369 val controlFlow = CPromise.delay (fn () => determineControlFlow dest)
1371 T {controlFlow = controlFlow,
1375 fun clear (T {controlFlow, dest, ...}) =
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
1385 fun layoutHeader (f: t): Layout.t =
1387 val {args, name, raises, returns, start, ...} = dest f
1390 if !Control.showTypes
1392 indent (seq [record [("returns",
1394 (Vector.layout Type.layout)
1398 (Vector.layout Type.layout)
1402 else (str " =", empty)
1404 mayAlign [mayAlign [seq [str "fun ",
1410 Transfer.layout (Transfer.Goto {dst = start, args = Vector.new0 ()})]
1413 fun layout' (f: t, layoutVar) =
1415 val {blocks, ...} = dest f
1417 fun layoutBlock b = Block.layout' (b, layoutVar)
1419 align [layoutHeader f,
1420 indent (align (Vector.toListMap (blocks, layoutBlock)), 2)]
1422 fun layout f = layout' (f, Var.layout)
1424 fun layouts (f: t, layoutVar, output: Layout.t -> unit): unit =
1426 val {blocks, name, ...} = dest f
1427 val _ = output (layoutHeader f)
1431 output (Layout.indent (Block.layout' (b, layoutVar), 2)))
1433 if not (!Control.keepDot)
1437 val {destroy, controlFlowGraph, dominatorTree, loopForest} =
1438 layoutDot (f, layoutVar)
1439 val name = Func.toString name
1445 ({suffix = concat [name, ".", s, ".dot"]},
1446 Dot, (), Layout (fn () => g))
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"
1465 fun make (new, plist) =
1467 val {get, set, destroy, ...} =
1468 Property.destGetSetOnce (plist, Property.initConst NONE)
1472 val _ = set (x, SOME x')
1480 in (bind, lookup, destroy)
1483 val (bindVar, lookupVar, destroyVar) =
1484 make (Var.new, Var.plist)
1485 val (bindLabel, lookupLabel, destroyLabel) =
1486 make (Label.new, Label.plist)
1488 val {args, blocks, mayInline, name, raises, returns, start, ...} =
1490 val args = Vector.map (args, fn (x, ty) => (bindVar x, ty))
1491 val bindLabel = ignore o bindLabel
1492 val bindVar = ignore o bindVar
1495 (blocks, fn Block.T {label, args, statements, ...} =>
1497 ; Vector.foreach (args, fn (x, _) => bindVar x)
1498 ; Vector.foreach (statements,
1499 fn Statement.T {var, ...} =>
1500 Option.app (var, bindVar))))
1503 (blocks, fn Block.T {label, args, statements, transfer} =>
1504 Block.T {label = lookupLabel label,
1505 args = Vector.map (args, fn (x, ty) =>
1507 statements = Vector.map
1509 fn Statement.T {var, ty, exp} =>
1511 {var = Option.map (var, lookupVar),
1513 exp = Exp.replaceVar
1515 transfer = Transfer.replaceLabelVar
1516 (transfer, lookupLabel, lookupVar)})
1517 val start = lookupLabel start
1518 val _ = destroyVar ()
1519 val _ = destroyLabel ()
1523 mayInline = mayInline,
1530 fun profile (f: t, sourceInfo): t =
1531 if !Control.profile = Control.ProfileNone
1532 orelse !Control.profileIL <> Control.ProfileSource
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} =
1541 (Label.plist, Property.initRaise ("block", Label.layout))
1544 (blocks, fn block as Block.T {label, ...} =>
1545 setLabelBlock (label, block))
1548 (blocks, fn Block.T {args, label, statements, transfer} =>
1550 fun make (exp: Exp.t): Statement.t =
1551 Statement.T {exp = exp,
1555 if Label.equals (label, start)
1559 (ProfileExp.Enter sourceInfo))),
1563 make (Exp.Profile (ProfileExp.Leave sourceInfo))
1564 fun prefix (l: Label.t,
1565 statements: Statement.t vector): Label.t =
1567 val Block.T {args, ...} = labelBlock l
1568 val c = Label.newNoname ()
1569 val xs = Vector.map (args, fn (x, _) => Var.new x)
1574 {args = Vector.map2 (xs, args, fn (x, (_, t)) =>
1577 statements = statements,
1578 transfer = Goto {args = xs,
1583 fun genHandler (cont: Label.t)
1584 : Statement.t vector * Label.t * Handler.t =
1586 NONE => (statements, cont, Handler.Caller)
1589 val xs = Vector.map (ts, fn _ => Var.newNoname ())
1590 val l = Label.newNoname ()
1595 {args = Vector.zip (xs, ts),
1597 statements = Vector.new1 (leave ()),
1598 transfer = Transfer.Raise xs})
1601 prefix (cont, Vector.new0 ()),
1605 (Vector.concat [statements,
1606 Vector.new1 (leave ())],
1608 val (statements, transfer) =
1610 Call {args, func, return} =>
1612 datatype z = datatype Return.t
1615 Dead => (statements, transfer)
1616 | NonTail {cont, handler} =>
1618 Handler.Dead => (statements, transfer)
1621 val (statements, cont, handler) =
1633 | Handler.Handle _ =>
1634 (statements, transfer))
1635 | Tail => addLeave ()
1637 | Raise _ => addLeave ()
1638 | Return _ => addLeave ()
1639 | _ => (statements, transfer)
1641 Block.T {args = args,
1643 statements = statements,
1644 transfer = transfer}
1646 val _ = Vector.foreach (blocks, rem o Block.label)
1647 val blocks = Vector.concat [Vector.fromList (!extraBlocks), blocks]
1651 mayInline = mayInline,
1656 val _ = Control.diagnostic (fn () => layout f)
1662 Trace.trace2 ("SsaTree.Function.profile", layout, SourceInfo.layout, layout)
1670 datatypes: Datatype.t vector,
1671 globals: Statement.t vector,
1672 functions: Function.t list,
1682 structure Graph = DirectedGraph
1683 structure Node = Graph.Node
1684 structure Edge = Graph.Edge
1686 fun layoutCallGraph (T {functions, main, ...},
1687 title: string): Layout.t =
1690 val graph = Graph.new ()
1691 val {get = nodeOptions, set = setNodeOptions, ...} =
1693 (Node.plist, Property.initRaise ("options", Node.layout))
1694 val {get = funcNode, destroy} =
1696 (Func.plist, Property.initFun
1699 val n = Graph.newNode graph
1704 in [FontColor Black, label (Func.toString f)]
1709 val {get = edgeOptions, set = setEdgeOptions, ...} =
1710 Property.getSetOnce (Edge.plist, Property.initConst [])
1715 val {name, blocks, ...} = Function.dest f
1716 val from = funcNode name
1717 val {get, destroy} =
1720 Property.initFun (fn _ => {nontail = ref false,
1724 (blocks, fn Block.T {transfer, ...} =>
1726 Call {func, return, ...} =>
1728 val to = funcNode func
1729 val {tail, nontail} = get to
1730 datatype z = datatype Return.t
1736 val r = if is then nontail else tail
1743 (graph, {from = from, to = to}),
1746 else [EdgeOption.Style Dotted])))
1753 val root = funcNode main
1756 (graph, fn {nodeName} =>
1758 options = [GraphOption.Rank (Min, [{nodeName = nodeName root}])],
1759 edgeOptions = edgeOptions,
1760 nodeOptions = nodeOptions})
1767 fun layouts (p as T {datatypes, globals, functions, main},
1768 output': Layout.t -> unit) =
1770 val layoutVar = Statement.prettifyGlobals globals
1772 (* Layout includes an output function, so we need to rebind output
1775 val output = output'
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)
1792 ({suffix = "call-graph.dot"},
1793 Dot, (), Layout (fn () =>
1794 layoutCallGraph (p, !Control.inputFile)))
1798 fun layoutStats (T {datatypes, globals, functions, main, ...}) =
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"
1807 val _ = Function.foreachVar (f, fn _ => Int.inc numVars)
1808 val {blocks, ...} = Function.dest f
1809 val numBlocks = Vector.length blocks
1811 (!numVars, numBlocks)
1813 val numTypes = ref 0
1814 val {get = countType, destroy} =
1818 (fn (t, countType) =>
1820 datatype z = datatype Type.dest
1823 Array t => countType t
1828 | Ref t => countType t
1830 | Tuple ts => Vector.foreach (ts, countType)
1831 | Vector t => countType t
1832 | Weak t => countType t
1834 val _ = Int.inc numTypes
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
1849 val {args, blocks, ...} = Function.dest f
1850 val _ = Vector.foreach (args, countType o #2)
1853 (blocks, fn Block.T {args, statements, ...} =>
1855 val _ = Int.inc numBlocks
1856 val _ = Vector.foreach (args, countType o #2)
1859 (statements, fn Statement.T {ty, ...} =>
1861 val _ = Int.inc numStatements
1862 val _ = countType ty
1866 val numFunctions = List.length functions
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)],
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
1885 Vector.foreach (datatypes, Datatype.clear)
1886 ; Vector.foreach (globals, Statement.clear)
1887 ; List.foreach (functions, Function.clear))
1889 fun clearGlobals (T {globals, ...}) =
1890 Vector.foreach (globals, Statement.clear)
1892 fun clearTop (p as T {datatypes, functions, ...}) =
1893 (Vector.foreach (datatypes, Datatype.clear)
1894 ; List.foreach (functions, Func.clear o Function.name)
1897 fun foreachVar (T {globals, functions, ...}, f) =
1898 (Vector.foreach (globals, fn Statement.T {var, ty, ...} =>
1900 ; List.foreach (functions, fn g => Function.foreachVar (g, f)))
1902 fun foreachPrim (T {globals, functions, ...}, f) =
1904 fun loopStatement (Statement.T {exp, ...}) =
1906 PrimApp {prim, ...} => f prim
1908 fun loopTransfer t =
1910 Arith {prim, ...} => f prim
1911 | Runtime {prim, ...} => f prim
1913 val _ = Vector.foreach (globals, loopStatement)
1918 (Function.blocks f, fn Block.T {statements, transfer, ...} =>
1919 (Vector.foreach (statements, loopStatement);
1920 loopTransfer transfer)))
1925 fun hasPrim (p, f) =
1928 (foreachPrim (p, fn prim => if f prim then escape true else ())
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"
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 =
1952 if Array.sub (visited, i)
1956 val _ = Array.update (visited, i, true)
1957 val f = Vector.sub (functions, i)
1959 val _ = Function.dfs
1960 (f, fn Block.T {transfer, ...} =>
1961 (Transfer.foreachFunc (transfer, visit)
1969 val _ = Vector.foreach (functions, rem o Function.name)