1 (* Copyright (C) 2009,2011,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 Shrink2 (S: SHRINK2_STRUCTS): SHRINK2 =
19 fun isProfile (s: t): bool =
29 fun inc (a: int t, i: int): unit = update (a, i, 1 + sub (a, i))
30 fun dec (a: int t, i: int): unit = update (a, i, sub (a, i) - 1)
33 datatype z = datatype Exp.t
34 datatype z = datatype Statement.t
35 datatype z = datatype Transfer.t
39 datatype t = T of {isUsed: bool ref,
40 numOccurrences: int ref,
42 value: value option ref,
46 | Inject of {sum: Tycon.t,
48 | Object of {args: t vector,
50 | Select of {object: t,
53 fun equals (T {var = x, ...}, T {var = y, ...}) = Var.equals (x, y)
55 fun layout (T {isUsed, numOccurrences, ty, value, var}) =
57 in record [("isUsed", Bool.layout (!isUsed)),
58 ("numOccurrences", Int.layout (!numOccurrences)),
59 ("ty", Option.layout Type.layout ty),
60 ("value", Option.layout layoutValue (!value)),
61 ("var", Var.layout var)]
68 Const c => Const.layout c
69 | Inject {sum, variant} =>
70 seq [layout variant, str ": ", Tycon.layout sum]
71 | Object {args, con} =>
73 val args = Vector.layout layout args
77 | SOME con => seq [Con.layout con, args]
79 | Select {object, offset} =>
80 seq [str "#", Int.layout (offset + 1),
81 str " ", layout object]
84 fun new (x: Var.t, ty: Type.t option) =
85 T {isUsed = ref false,
86 numOccurrences = ref 0,
91 fun setValue (T {value, ...}, v) =
92 (Assert.assert ("Ssa2.Shrink2.VarInfo.setValue", fn () => Option.isNone (!value))
95 fun numOccurrences (T {numOccurrences = r, ...}) = r
96 fun ty (T {ty, ...}): Type.t option = ty
97 fun value (T {value, ...}): value option = !value
98 fun var (T {var, ...}): Var.t = var
103 datatype t = datatype VarInfo.value
114 Formal i => Int.layout i
115 | Free x => Var.layout x
118 fn (Formal i, Formal i') => i = i'
119 | (Free x, Free x') => Var.equals (x, x')
123 structure Positions = MonoVector (Position)
125 structure LabelMeaning =
127 datatype t = T of {aux: aux,
128 blockIndex: int, (* The index of the block *)
129 label: Label.t} (* redundant, the label of the block *)
134 | Case of {canMove: Statement.t list,
136 default: Label.t option}
137 | Goto of {canMove: Statement.t list,
140 | Raise of {args: Positions.t,
141 canMove: Statement.t list}
142 | Return of {args: Positions.t,
143 canMove: Statement.t list}
146 fun make f (T r) = f r
149 val blockIndex = make #blockIndex
152 fun layout (T {aux, label, ...}) =
156 seq [Label.layout label,
159 Block => str "Block "
161 | Case _ => str "Case"
162 | Goto {dst, args, ...} =>
164 tuple [layout dst, Positions.layout args]]
165 | Raise {args, ...} =>
166 seq [str "Raise ", Positions.layout args]
167 | Return {args, ...} =>
168 seq [str "Return ", Positions.layout args]]
176 | Visited of LabelMeaning.t
183 fn Unvisited => str "Unvisited"
184 | Visited m => LabelMeaning.layout m
185 | Visiting => str "Visiting"
189 val traceApplyInfo = Trace.info "Ssa2.Shrink2.Prim.apply"
191 fun shrinkFunction {globals: Statement.t vector} =
193 fun use (VarInfo.T {isUsed, var, ...}): Var.t =
196 fun uses (vis: VarInfo.t vector): Var.t vector = Vector.map (vis, use)
197 (* varInfo can't be getSetOnce because of setReplacement. *)
198 val {get = varInfo: Var.t -> VarInfo.t, set = setVarInfo, ...} =
199 Property.getSet (Var.plist,
200 Property.initFun (fn x => VarInfo.new (x, NONE)))
202 Trace.trace2 ("Ssa2.Shrink2.setVarInfo",
203 Var.layout, VarInfo.layout, Unit.layout)
205 fun varInfos xs = Vector.map (xs, varInfo)
206 fun simplifyVar (x: Var.t) = use (varInfo x)
208 Trace.trace ("Ssa2.Shrink2.simplifyVar", Var.layout, Var.layout) simplifyVar
209 fun simplifyVars xs = Vector.map (xs, simplifyVar)
210 fun incVarInfo (x: VarInfo.t): unit =
211 Int.inc (VarInfo.numOccurrences x)
212 fun incVar (x: Var.t): unit = incVarInfo (varInfo x)
213 fun incVars xs = Vector.foreach (xs, incVar)
214 fun numVarOccurrences (x: Var.t): int =
215 ! (VarInfo.numOccurrences (varInfo x))
220 Bind {exp, ty, var} =>
224 setVarInfo (x, VarInfo.new (x, SOME ty)))
226 Option.app (var, fn x => VarInfo.setValue (varInfo x, v))
229 Const c => construct (Value.Const c)
230 | Object {args, con} =>
232 (Value.Object {args = Vector.map (args, varInfo),
234 | Select {base, offset} =>
237 construct (Value.Select {object = varInfo x,
241 Option.app (var, fn x => setVarInfo (x, varInfo y))
248 val () = Function.clear f
249 val {args, blocks, mayInline, name, raises, returns, start, ...} =
251 val () = Vector.foreach (args, fn (x, ty) =>
252 setVarInfo (x, VarInfo.new (x, SOME ty)))
253 (* Index the labels by their defining block in blocks. *)
254 val {get = labelIndex, set = setLabelIndex, ...} =
255 Property.getSetOnce (Label.plist,
256 Property.initRaise ("index", Label.layout))
257 val () = Vector.foreachi (blocks, fn (i, Block.T {label, ...}) =>
258 setLabelIndex (label, i))
259 val numBlocks = Vector.length blocks
260 (* Do a DFS to compute occurrence counts and set label meanings *)
261 val states = Array.array (numBlocks, State.Unvisited)
262 val inDegree = Array.array (numBlocks, 0)
263 fun addLabelIndex i = Array.inc (inDegree, i)
264 val isHeader = Array.array (numBlocks, false)
265 val numHandlerUses = Array.array (numBlocks, 0)
266 fun layoutLabel (l: Label.t): Layout.t =
270 Layout.record [("label", Label.layout l),
271 ("inDegree", Int.layout (Array.sub (inDegree, i)))]
275 LabelMeaning.Goto {dst, ...} =>
276 addLabelIndex (LabelMeaning.blockIndex dst)
278 fun incLabel (l: Label.t): unit =
279 incLabelMeaning (labelMeaning l)
280 and incLabelMeaning (LabelMeaning.T {aux, blockIndex, ...}): unit =
283 val n = Array.sub (inDegree, i)
284 val () = Array.update (inDegree, i, 1 + n)
290 and labelMeaning (l: Label.t): LabelMeaning.t =
294 case Array.sub (states, i) of
297 (Array.update (isHeader, i, true)
299 {aux = LabelMeaning.Block,
301 label = Block.label (Vector.sub (blocks, i))}))
304 val () = Array.update (states, i, State.Visiting)
305 val m = computeMeaning i
306 val () = Array.update (states, i, State.Visited m)
311 and computeMeaning (i: int): LabelMeaning.t =
313 val Block.T {args, statements, transfer, ...} =
314 Vector.sub (blocks, i)
315 val () = Vector.foreach (args, fn (x, ty) =>
316 setVarInfo (x, VarInfo.new (x, SOME ty)))
317 val () = Vector.foreach (statements, fn s =>
318 Statement.foreachUse (s, incVar))
319 fun extract (actuals: Var.t vector): Positions.t =
321 val {get: Var.t -> Position.t, set, destroy} =
322 Property.destGetSetOnce
323 (Var.plist, Property.initFun Position.Free)
324 val () = Vector.foreachi (args, fn (i, (x, _)) =>
325 set (x, Position.Formal i))
326 val ps = Vector.map (actuals, get)
331 LabelMeaning.T {aux = aux,
333 label = Block.label (Vector.sub (blocks, i))}
334 fun normal () = doit LabelMeaning.Block
336 Vector.toList statements
337 fun rr (xs: Var.t vector, make) =
341 val n = Vector.length statements
345 if 0 = Vector.length xs
346 orelse 0 < Vector.length args
347 then doit (make {args = extract xs,
352 val s = Vector.sub (statements, i)
354 if Statement.isProfile s
355 then loop (i + 1, s :: ac)
363 if Vector.forall (statements, Statement.isProfile)
364 andalso (0 = Vector.length xs
365 orelse 0 < Vector.length args)
366 then doit (make {args = extract xs,
367 canMove = canMove ()})
372 Arith {args, overflow, success, ...} =>
378 if Vector.isEmpty statements
379 andalso (case returns of
383 (ts, args, fn (t, (_, t')) =>
384 Type.equals (t, t')))
385 then doit LabelMeaning.Bug
387 | Call {args, return, ...} =>
389 val () = incVars args
391 Return.foreachHandler
393 Array.inc (numHandlerUses, labelIndex l))
394 val () = Return.foreachLabel (return, incLabel)
398 | Case {test, cases, default} =>
401 val () = Cases.foreach (cases, incLabel)
402 val () = Option.app (default, incLabel)
404 if Vector.forall(statements, Statement.isProfile)
405 andalso not (Array.sub (isHeader, i))
406 andalso 1 = Vector.length args
407 andalso 1 = numVarOccurrences test
408 andalso Var.equals (test, #1 (Vector.first args))
410 doit (LabelMeaning.Case {canMove = canMove (),
416 | Goto {dst, args = actuals} =>
418 val () = incVars actuals
419 val m = labelMeaning dst
421 if Vector.exists (statements, not o Statement.isProfile)
422 orelse Array.sub (isHeader, i)
423 then (incLabelMeaning m
426 if Vector.isEmpty statements
428 Vector.equals (args, actuals, fn ((x, _), x') =>
430 andalso 1 = numVarOccurrences x)
431 then m (* It's an eta. *)
434 val ps = extract actuals
436 Vector.fold (args, 0, fn ((x, _), n) =>
437 n + numVarOccurrences x)
439 Vector.fold (ps, 0, fn (p, n) =>
441 Position.Formal _ => n + 1
443 datatype z = datatype LabelMeaning.aux
446 then (incLabelMeaning m
450 fun extract (ps': Positions.t)
455 datatype z = datatype Position.t
459 | Formal i => Vector.sub (ps, i)
461 val canMove' = canMove ()
463 case LabelMeaning.aux m of
465 Goto {canMove = canMove',
473 (ts, args, fn (t, (_, t')) =>
474 Type.equals (t, t')))
476 else Goto {canMove = canMove',
480 Goto {canMove = canMove',
483 | Goto {canMove, dst, args} =>
484 Goto {canMove = canMove' @ canMove,
487 | Raise {args, canMove} =>
488 Raise {args = extract args,
489 canMove = canMove' @ canMove}
490 | Return {args, canMove} =>
491 Return {args = extract args,
492 canMove = canMove' @ canMove}
498 | Raise xs => rr (xs, LabelMeaning.Raise)
499 | Return xs => rr (xs, LabelMeaning.Return)
500 | Runtime {args, return, ...} =>
505 val () = incLabel start
507 case Array.sub (states, i) of
509 | _ => Error.bug "Ssa2.Shrink2.indexMeaning: not computed"
511 Trace.trace ("Ssa2.Shrink2.indexMeaning", Int.layout, LabelMeaning.layout)
513 val labelMeaning = indexMeaning o labelIndex
515 Trace.trace ("Ssa2.Shrink2.labelMeaning",
516 Label.layout, LabelMeaning.layout)
519 Block.label (Vector.sub (blocks, LabelMeaning.blockIndex m))
521 Block.args (Vector.sub (blocks, labelIndex l))
523 Block.args (Vector.sub (blocks, LabelMeaning.blockIndex m))
526 val {destroy, controlFlowGraph, ...} =
527 Function.layoutDot (f, Var.layout)
530 (concat ["/tmp/", Func.toString (Function.name f),
532 fn out => Layout.outputl (controlFlowGraph, out))
535 val () = if true then () else save (f, "pre")
546 Label.layout (Block.label (Vector.sub (blocks, i)))),
547 ("inDegree", Int.layout (Array.sub (inDegree, i))),
548 ("state", State.layout (Array.sub (states, i)))]))
549 (Vector.tabulate (numBlocks, fn i => i)),
553 ("Ssa2.Shrink2.labelMeanings", fn () =>
555 val inDegree' = Array.array (numBlocks, 0)
556 fun bumpIndex i = Array.inc (inDegree', i)
557 fun bumpMeaning m = bumpIndex (LabelMeaning.blockIndex m)
558 val bumpLabel = bumpMeaning o labelMeaning
559 fun doit (LabelMeaning.T {aux, blockIndex, ...}) =
561 datatype z = datatype LabelMeaning.aux
565 Transfer.foreachLabel
566 (Block.transfer (Vector.sub (blocks, blockIndex)),
569 | Case {cases, default, ...} =>
570 (Cases.foreach (cases, bumpLabel)
571 ; Option.app (default, bumpLabel))
572 | Goto {dst, ...} => bumpMeaning dst
578 (states, fn (i, s) =>
579 if Array.sub (inDegree, i) > 0
582 State.Visited m => doit m
585 val () = bumpMeaning (labelMeaning start)
587 Array.equals (inDegree, inDegree', Int.equals)
596 Label.layout (Block.label (Vector.sub (blocks, i)))),
597 ("inDegree", Int.layout (Array.sub (inDegree, i))),
598 ("inDegree'", Int.layout (Array.sub (inDegree', i))),
599 ("state", State.layout (Array.sub (states, i)))]))
600 (Vector.tabulate (numBlocks, fn i => i)),
606 val isBlock = Array.array (numBlocks, false)
607 (* Functions for maintaining inDegree. *)
610 (Assert.assert ("Ssa2.Shrink2.addLabelIndex", fn () =>
611 Array.sub (inDegree, i) > 0)
613 val addLabelMeaning = addLabelIndex o LabelMeaning.blockIndex
614 fun layoutLabelMeaning m =
616 [("inDegree", Int.layout (Array.sub
617 (inDegree, LabelMeaning.blockIndex m))),
618 ("meaning", LabelMeaning.layout m)]
619 val traceDeleteLabelMeaning =
620 Trace.trace ("Ssa2.Shrink2.deleteLabelMeaning",
621 layoutLabelMeaning, Unit.layout)
622 fun deleteLabel l = deleteLabelMeaning (labelMeaning l)
623 and deleteLabelMeaning arg: unit =
624 traceDeleteLabelMeaning
625 (fn (m: LabelMeaning.t) =>
627 val i = LabelMeaning.blockIndex m
628 val n = Array.sub (inDegree, i) - 1
629 val () = Array.update (inDegree, i, n)
630 val () = Assert.assert ("Ssa2.Shrink2.deleteLabelMeaning", fn () => n >= 0)
632 if n = 0 (* andalso not (Array.sub (isBlock, i)) *)
635 datatype z = datatype LabelMeaning.aux
637 case LabelMeaning.aux m of
640 val t = Block.transfer (Vector.sub (blocks, i))
641 val () = Transfer.foreachLabel (t, deleteLabel)
644 Transfer.Call {return, ...} =>
645 Return.foreachHandler
647 Array.dec (numHandlerUses,
648 (LabelMeaning.blockIndex
655 | Case {cases, default, ...} =>
656 (Cases.foreach (cases, deleteLabel)
657 ; Option.app (default, deleteLabel))
658 | Goto {dst, ...} => deleteLabelMeaning dst
664 fun primApp (prim: Type.t Prim.t, args: VarInfo.t vector)
665 : (Type.t, VarInfo.t) Prim.ApplyResult.t =
671 VarInfo.T {value = ref (SOME v), ...} =>
673 Value.Const c => Prim.ApplyArg.Const c
674 | Value.Object {args, con} =>
675 (case (con, Vector.length args) of
677 Prim.ApplyArg.Con {con = con,
679 | _ => Prim.ApplyArg.Var vi)
680 | _ => Prim.ApplyArg.Var vi)
681 | _ => Prim.ApplyArg.Var vi)
689 seq [Prim.layout p, str " ",
690 List.layout (Prim.ApplyArg.layout
691 (Var.layout o VarInfo.var)) args]
693 Prim.ApplyResult.layout (Var.layout o VarInfo.var))
695 (prim, Vector.toList args', VarInfo.equals)
697 (* Another DFS, this time accumulating the new blocks. *)
698 val traceForceMeaningBlock =
699 Trace.trace ("Ssa2.Shrink2.forceMeaningBlock",
700 layoutLabelMeaning, Unit.layout)
701 val traceSimplifyBlock =
702 Trace.trace2 ("Ssa2.Shrink2.simplifyBlock",
703 List.layout Statement.layout,
704 layoutLabel o Block.label,
705 Layout.tuple2 (List.layout Statement.layout,
707 val traceGotoMeaning =
709 ("Ssa2.Shrink2.gotoMeaning",
710 List.layout Statement.layout,
712 Vector.layout VarInfo.layout,
713 Layout.tuple2 (List.layout Statement.layout, Transfer.layout))
714 val traceEvalStatement =
716 ("Ssa2.Shrink2.evalStatement",
718 Layout.ignore: (Statement.t list -> Statement.t list) -> Layout.t)
719 val traceSimplifyTransfer =
720 Trace.trace ("Ssa2.Shrink2.simplifyTransfer",
722 Layout.tuple2 (List.layout Statement.layout,
724 val traceSimplifyCase =
726 ("Ssa2.Shrink2.simplifyCase",
727 fn {canMove, cases, default, test, ...} =>
728 Layout.record [("canMove", List.layout Statement.layout canMove),
729 ("cantSimplify", Layout.str "fn () => ..."),
730 ("gone", Layout.str "fn () => ..."),
731 ("test", VarInfo.layout test),
733 (Transfer.layout o Transfer.Case)
736 test = VarInfo.var test})],
737 Layout.tuple2 (List.layout Statement.layout, Transfer.layout))
738 val newBlocks = ref []
739 fun simplifyLabel l =
741 val m = labelMeaning l
742 val () = forceMeaningBlock m
746 and forceMeaningBlock arg =
747 traceForceMeaningBlock
748 (fn (LabelMeaning.T {aux, blockIndex = i, ...}) =>
749 if Array.sub (isBlock, i)
753 val () = Array.update (isBlock, i, true)
754 val block as Block.T {label, args, ...} =
755 Vector.sub (blocks, i)
756 fun extract (p: Position.t): VarInfo.t =
758 Position.Formal n => #1 (Vector.sub (args, n))
759 | Position.Free x => x)
760 val (statements, transfer) =
762 fun rr ({args, canMove}, make) =
763 (canMove, make (Vector.map (args, use o extract)))
764 datatype z = datatype LabelMeaning.aux
767 Block => simplifyBlock ([], block)
768 | Bug => ([], Transfer.Bug)
769 | Case _ => simplifyBlock ([], block)
770 | Goto {canMove, dst, args} =>
771 gotoMeaning (canMove,
773 Vector.map (args, extract))
774 | Raise z => rr (z, Transfer.Raise)
775 | Return z => rr (z, Transfer.Return)
780 Block.T {label = label,
782 statements = Vector.fromList statements,
783 transfer = transfer})
787 and simplifyBlock arg : Statement.t list * Transfer.t =
789 (fn (canMoveIn, Block.T {statements, transfer, ...}) =>
791 val f = evalStatements statements
792 val (ss, transfer) = simplifyTransfer transfer
794 (canMoveIn @ (f ss), transfer)
796 and evalStatements (ss: Statement.t vector)
797 : Statement.t list -> Statement.t list =
799 val fs = Vector.map (ss, evalStatement)
801 fn ss => Vector.foldr (fs, ss, fn (f, ss) => f ss)
803 and simplifyTransfer arg : Statement.t list * Transfer.t =
804 traceSimplifyTransfer
805 (fn (t: Transfer.t) =>
807 Arith {prim, args, overflow, success, ty} =>
809 val args = varInfos args
811 case primApp (prim, args) of
812 Prim.ApplyResult.Const c =>
814 val () = deleteLabel overflow
815 val x = Var.newNoname ()
816 val isUsed = ref false
818 VarInfo.T {isUsed = isUsed,
819 numOccurrences = ref 0,
821 value = ref (SOME (Value.Const c)),
823 val (ss, t) = goto (success, Vector.new1 vi)
826 then Bind {var = SOME x,
828 exp = Exp.Const c} :: ss
833 | Prim.ApplyResult.Var x =>
835 val () = deleteLabel overflow
837 goto (success, Vector.new1 x)
839 | Prim.ApplyResult.Overflow =>
841 val () = deleteLabel success
843 goto (overflow, Vector.new0 ())
845 | Prim.ApplyResult.Apply (prim, args) =>
847 val args = Vector.fromList args
849 ([], Arith {prim = prim,
851 overflow = simplifyLabel overflow,
852 success = simplifyLabel success,
856 ([], Arith {prim = prim,
858 overflow = simplifyLabel overflow,
859 success = simplifyLabel success,
863 | Call {func, args, return} =>
865 val (statements, return) =
867 Return.NonTail {cont, handler} =>
869 fun isEta (m: LabelMeaning.t,
870 ps: Position.t vector): bool =
872 = Vector.length (meaningArgs m)
876 fn (i, Position.Formal i') => i = i'
878 val m = labelMeaning cont
881 val () = forceMeaningBlock m
886 val m = labelMeaning l
887 val () = forceMeaningBlock m
893 Return.NonTail {cont = meaningLabel m,
896 fun tail statements =
897 (deleteLabelMeaning m
898 ; (statements, Return.Tail))
899 fun cont handlerEta =
900 case LabelMeaning.aux m of
904 | SOME canMove => tail canMove)
905 | LabelMeaning.Return {args, canMove} =>
913 Handler.Caller => cont NONE
914 | Handler.Dead => cont NONE
915 | Handler.Handle l =>
917 val m = labelMeaning l
919 case LabelMeaning.aux m of
920 LabelMeaning.Bug => cont NONE
921 | LabelMeaning.Raise {args, canMove} =>
923 then cont (SOME canMove)
932 args = simplifyVars args,
935 | Case {test, cases, default} =>
937 val test = varInfo test
938 fun cantSimplify () =
940 Case {test = use test,
941 cases = Cases.map (cases, simplifyLabel),
942 default = Option.map (default, simplifyLabel)})
946 cantSimplify = cantSimplify,
949 gone = fn () => (Cases.foreach (cases, deleteLabel)
950 ; Option.app (default, deleteLabel)),
953 | Goto {dst, args} => goto (dst, varInfos args)
954 | Raise xs => ([], Raise (simplifyVars xs))
955 | Return xs => ([], Return (simplifyVars xs))
956 | Runtime {prim, args, return} =>
957 ([], Runtime {prim = prim,
958 args = simplifyVars args,
959 return = simplifyLabel return})
961 and simplifyCase arg : Statement.t list * Transfer.t =
963 (fn {canMove, cantSimplify,
964 cases, default, gone, test: VarInfo.t} =>
966 (* tryToEliminate makes sure that the destination meaning
967 * hasn't already been simplified. If it has, then we can't
970 fun tryToEliminate m =
972 val i = LabelMeaning.blockIndex m
974 if Array.sub (inDegree, i) = 0
978 val () = addLabelIndex i
981 gotoMeaning (canMove, m, Vector.new0 ())
985 if Cases.isEmpty cases
986 then (case default of
988 | SOME l => tryToEliminate (labelMeaning l))
991 val l = Cases.hd cases
992 fun isOk (l': Label.t): bool = Label.equals (l, l')
994 if Vector.isEmpty (labelArgs l)
995 andalso Cases.forall (cases, isOk)
996 andalso (case default of
1000 (* All cases the same -- eliminate the case. *)
1001 tryToEliminate (labelMeaning l)
1004 fun findCase (cases, isCon, args) =
1006 val n = Vector.length cases
1007 fun doit (l, args) =
1010 if Vector.isEmpty (labelArgs l)
1013 val m = labelMeaning l
1014 val () = addLabelMeaning m
1017 gotoMeaning (canMove, m, args)
1023 NONE => (gone (); ([], Bug))
1024 | SOME l => doit (l, Vector.new0 ()))
1027 val (con, l) = Vector.sub (cases, k)
1037 case (VarInfo.value test, cases) of
1038 (SOME (Value.Const c), _) =>
1040 (Cases.Word (_, cs), Const.Word w) =>
1042 fn w' => WordX.equals (w, w'),
1045 Error.bug "Ssa2.Shrink2.simplifyCase: strange constant")
1046 | (SOME (Value.Inject {variant, ...}),
1049 val VarInfo.T {value, ...} = variant
1053 {con = SOME con, ...}) =>
1055 fn c => Con.equals (con, c),
1056 Vector.new1 variant)
1057 | _ => cantSimplify ()
1059 | _ => cantSimplify ()
1063 and goto (dst: Label.t, args: VarInfo.t vector)
1064 : Statement.t list * Transfer.t =
1065 gotoMeaning ([], labelMeaning dst, args)
1066 and gotoMeaning arg : Statement.t list * Transfer.t =
1069 m as LabelMeaning.T {aux, blockIndex = i, ...},
1070 args: VarInfo.t vector) =>
1072 val n = Array.sub (inDegree, i)
1073 val () = Assert.assert ("Ssa2.Shrink2.gotoMeaning", fn () => n >= 1)
1078 val () = Array.update (inDegree, i, 0)
1079 val b = Vector.sub (blocks, i)
1082 (Block.args b, args, fn ((x, _), vi) =>
1085 simplifyBlock (canMoveIn, b)
1089 val () = forceMeaningBlock m
1092 Goto {dst = Block.label (Vector.sub (blocks, i)),
1097 Position.Formal n => Vector.sub (args, n)
1098 | Position.Free x => varInfo x
1099 fun rr ({args, canMove}, make) =
1100 (canMoveIn @ canMove,
1101 make (Vector.map (args, use o extract)))
1102 datatype z = datatype LabelMeaning.aux
1106 | Bug => ((*canMoveIn*)[], Transfer.Bug)
1107 | Case {canMove, cases, default} =>
1108 simplifyCase {canMove = canMoveIn @ canMove,
1109 cantSimplify = normal,
1112 gone = fn () => deleteLabelMeaning m,
1113 test = Vector.first args}
1114 | Goto {canMove, dst, args} =>
1115 if Array.sub (isHeader, i)
1116 orelse Array.sub (isBlock, i)
1121 val () = Array.update (inDegree, i, n')
1124 then addLabelMeaning dst
1127 gotoMeaning (canMoveIn @ canMove,
1129 Vector.map (args, extract))
1131 | Raise z => rr (z, Transfer.Raise)
1132 | Return z => rr (z, Transfer.Return)
1134 and evalBind {exp, ty, var} =
1137 Option.app (var, fn x =>
1138 setVarInfo (x, VarInfo.new (x, SOME ty)))
1140 fun doit {makeExp: unit -> Exp.t,
1142 value: Value.t option} =
1144 fun make var = Bind {exp = makeExp (), ty = ty, var = var}
1149 then (fn ss => make NONE :: ss)
1153 val VarInfo.T {isUsed, value = r, ...} = varInfo x
1158 then make (SOME x) :: ss
1160 then make NONE :: ss
1164 fun simple {sideEffect} =
1166 fun makeExp () = Exp.replaceVar (exp, use o varInfo)
1168 doit {makeExp = makeExp,
1169 sideEffect = sideEffect,
1173 (Option.app (var, fn x => setVarInfo (x, vi))
1175 fun construct (v: Value.t, makeExp) =
1176 doit {makeExp = makeExp,
1179 fun tuple (xs: VarInfo.t vector) =
1180 case (Exn.withEscape
1183 fun no () = escape NONE
1187 fn (i, VarInfo.T {value, ...}, tuple') =>
1189 SOME (Value.Select {object, offset}) =>
1194 (case VarInfo.ty object of
1197 (case Type.dest ty of
1198 Type.Object {args, con = ObjectCon.Tuple} =>
1199 if Prod.length args = Vector.length xs
1201 Prod.allAreImmutable args
1206 if VarInfo.equals (tuple'', object)
1213 construct (Value.Object {args = xs, con = NONE},
1214 fn () => Object {args = uses xs, con = NONE})
1215 | SOME object => setVar object
1218 Const c => construct (Value.Const c, fn () => exp)
1219 | Inject {sum, variant} =>
1221 val variant = varInfo variant
1223 construct (Value.Inject {sum = sum, variant = variant},
1224 fn () => Inject {sum = sum,
1225 variant = use variant})
1227 | Object {args, con} =>
1229 val args = varInfos args
1231 case Type.dest ty of
1232 Type.Object {args, ...} => Prod.someIsMutable args
1233 | _ => Error.bug "strange Object type"
1235 (* It would be nice to improve this code to do
1236 * reconstruction when isSome con, not just for
1239 if isMutable orelse isSome con then
1240 construct (Value.Object {args = args, con = con},
1241 fn () => Object {args = uses args,
1245 | PrimApp {args, prim} =>
1247 val args = varInfos args
1248 fun apply {prim, args} =
1249 doit {makeExp = fn () => PrimApp {args = uses args,
1251 sideEffect = Prim.maySideEffect prim,
1253 datatype z = datatype Prim.ApplyResult.t
1255 case primApp (prim, args) of
1256 Apply (prim, args) =>
1257 apply {prim = prim, args = Vector.fromList args}
1260 val variant = Var.newNoname ()
1261 val con = Con.fromBool b
1265 (Bind {exp = Object {args = Vector.new0 (),
1267 ty = Type.object {args = Prod.empty (),
1268 con = ObjectCon.Con con},
1269 var = SOME variant},
1270 Bind {exp = Inject {sum = Tycon.bool,
1275 | Const c => construct (Value.Const c,
1276 fn () => Exp.Const c)
1277 | Var vi => setVar vi
1278 | _ => apply {args = args, prim = prim}
1280 | Select {base, offset} =>
1282 Base.Object object =>
1284 val object as VarInfo.T {ty, value, ...} =
1288 (Value.Select {object = object,
1291 Select {base = Base.Object (use object),
1294 case (ty, !value) of
1295 (SOME ty, SOME (Value.Object {args, ...})) =>
1296 (case Type.dest ty of
1297 Type.Object {args = targs, ...} =>
1298 (* Can't simplify the select if the
1303 (Prod.dest targs, offset)))
1305 else setVar (Vector.sub
1307 | _ => Error.bug "Ssa2.Shrink2.evalBind: Select:non object")
1308 | _ => dontChange ()
1310 | Base.VectorSub _ => simple {sideEffect = false})
1311 | Var x => setVar (varInfo x)
1313 and evalStatement arg : Statement.t list -> Statement.t list =
1318 fn ss => Statement.replaceUses (s, use o varInfo) :: ss
1321 Bind b => evalBind b
1322 | Profile _ => simple ()
1323 | Update _ => simple ()
1325 val start = labelMeaning start
1326 val () = forceMeaningBlock start
1328 Function.new {args = args,
1329 blocks = Vector.fromList (!newBlocks),
1330 mayInline = mayInline,
1334 start = meaningLabel start}
1335 val () = if true then () else save (f, "post")
1336 val () = Function.clear f
1342 fun eliminateUselessProfile (f: Function.t): Function.t =
1343 if !Control.profile = Control.ProfileNone
1347 fun eliminateInBlock (b as Block.T {args, label, statements, transfer})
1349 if not (Vector.exists (statements, Statement.isProfile))
1353 datatype z = datatype Exp.t
1354 datatype z = datatype ProfileExp.t
1357 (statements, [], fn (s, stack) =>
1359 Profile (Leave si) =>
1361 Profile (Enter si') :: rest =>
1362 if SourceInfo.equals (si, si')
1364 else Error.bug "Ssa2.Shrink2.eliminateUselessProfile: mismatched Leave"
1367 val statements = Vector.fromListRev stack
1369 Block.T {args = args,
1371 statements = statements,
1372 transfer = transfer}
1374 val {args, blocks, mayInline, name, raises, returns, start} =
1376 val blocks = Vector.map (blocks, eliminateInBlock)
1378 Function.new {args = args,
1380 mayInline = mayInline,
1387 val traceShrinkFunction =
1388 Trace.trace ("Ssa2.Shrink2.shrinkFunction", Function.layout, Function.layout)
1390 val shrinkFunction =
1393 val s = shrinkFunction g
1395 fn f => traceShrinkFunction s (eliminateUselessProfile f)
1398 fun shrink (Program.T {datatypes, globals, functions, main}) =
1400 val s = shrinkFunction {globals = globals}
1402 Program.T {datatypes = datatypes,
1404 functions = List.revMap (functions, s),
1406 val () = Program.clear program
1411 fun eliminateDeadBlocksFunction f =
1413 val {args, blocks, mayInline, name, raises, returns, start} =
1415 val {get = isLive, set = setLive, rem} =
1416 Property.getSetOnce (Label.plist, Property.initConst false)
1417 val () = Function.dfs (f, fn Block.T {label, ...} =>
1418 (setLive (label, true)
1421 if Vector.forall (blocks, isLive o Block.label)
1427 (blocks, isLive o Block.label)
1429 Function.new {args = args,
1431 mayInline = mayInline,
1437 val () = Vector.foreach (blocks, rem o Block.label)
1442 fun eliminateDeadBlocks (Program.T {datatypes, globals, functions, main}) =
1444 val functions = List.revMap (functions, eliminateDeadBlocksFunction)
1446 Program.T {datatypes = datatypes,
1448 functions = functions,