HCoop / hcoop / debian / mlton.git / blob
? search:
summary | shortlog | log | commit | commitdiff | tree
blame | history | raw | HEAD
Import Debian changes 20180207-1
[hcoop/debian/mlton.git] / mlton / ssa / remove-unused2.fun
1 (* Copyright (C) 2009 Matthew Fluet.
2 * Copyright (C) 1999-2008 Henry Cejtin, Matthew Fluet, Suresh
3 * Jagannathan, and Stephen Weeks.
4 * Copyright (C) 1997-2000 NEC Research Institute.
5 *
6 * MLton is released under a BSD-style license.
7 * See the file MLton-LICENSE for details.
8 *)
9
10 functor RemoveUnused2 (S: SSA2_TRANSFORM_STRUCTS): SSA2_TRANSFORM =
11 struct
12
13 open S
14 open Exp Statement Transfer
15
16 structure Used =
17 struct
18 structure L = TwoPointLattice (val bottom = "unused"
19 val top = "used")
20 open L
21 val use = makeTop
22 val isUsed = isTop
23 val whenUsed = addHandler
24 end
25
26 structure Coned =
27 struct
28 structure L = TwoPointLattice (val bottom = "not coned"
29 val top = "coned")
30 open L
31 val con = makeTop
32 val isConed = isTop
33 val whenConed = addHandler
34 end
35
36 structure Deconed =
37 struct
38 structure L = TwoPointLattice (val bottom = "not deconed"
39 val top = "deconed")
40 open L
41 val decon = makeTop
42 val isDeconed = isTop
43 end
44
45 structure MayReturn =
46 struct
47 structure L = TwoPointLattice (val bottom = "does not return"
48 val top = "may return")
49 open L
50 val return = makeTop
51 val mayReturn = isTop
52 val whenReturns = addHandler
53 end
54
55 structure MayRaise =
56 struct
57 structure L = TwoPointLattice (val bottom = "does not raise"
58 val top = "may raise")
59 open L
60 val raisee = makeTop
61 val mayRaise = isTop
62 val whenRaises = addHandler
63 end
64
65
66 structure VarInfo =
67 struct
68 datatype t = T of {ty: Type.t,
69 used: Used.t}
70
71 fun layout (T {used, ...}) = Used.layout used
72
73 local
74 fun make f (T r) = f r
75 in
76 val ty = make #ty
77 val used = make #used
78 end
79
80 fun new (ty : Type.t): t = T {ty = ty,
81 used = Used.new ()}
82
83 val use = Used.use o used
84 val isUsed = Used.isUsed o used
85 fun whenUsed (vi, th) = Used.whenUsed (used vi, th)
86 end
87
88 structure ConInfo =
89 struct
90 datatype t = T of {args: (VarInfo.t * Type.t) Prod.t,
91 coned: Coned.t,
92 deconed: Deconed.t,
93 dummy: {con: Con.t, args: Type.t Prod.t,
94 ty: Type.t, exp: Exp.t},
95 used: Used.t}
96
97 fun layout (T {args, coned, deconed, used, ...}) =
98 Layout.record [("args", Prod.layout (args, VarInfo.layout o #1)),
99 ("coned", Coned.layout coned),
100 ("deconed", Deconed.layout deconed),
101 ("used", Used.layout used)]
102
103 local
104 fun make f (T r) = f r
105 in
106 val args = make #args
107 val coned = make #coned
108 val deconed = make #deconed
109 val dummy = make #dummy
110 val used = make #used
111 end
112
113 val con = Coned.con o coned
114 val isConed = Coned.isConed o coned
115 fun whenConed (ci, th) = Coned.whenConed (coned ci, th)
116
117 val decon = Deconed.decon o deconed
118 val isDeconed = Deconed.isDeconed o deconed
119
120 val use = Used.use o used
121 val isUsed = Used.isUsed o used
122 fun whenUsed (vi, th) = Used.whenUsed (used vi, th)
123
124 fun new {args: Type.t Prod.t,
125 dummy: {con: Con.t, args: Type.t Prod.t,
126 ty: Type.t, exp: Exp.t}}: t =
127 T {args = Prod.map (args, fn ty => (VarInfo.new ty, ty)),
128 coned = Coned.new (),
129 deconed = Deconed.new (),
130 dummy = dummy,
131 used = Used.new ()}
132 end
133
134 structure TyconInfo =
135 struct
136 datatype t = T of {cons: Con.t vector,
137 dummy: {con: Con.t, args: Type.t Prod.t},
138 numCons: int ref,
139 used: Used.t}
140
141 fun layout (T {used, ...}) =
142 Layout.record [("used", Used.layout used)]
143
144 local
145 fun make f (T r) = f r
146 fun make' f = (make f, ! o (make f))
147 in
148 val cons = make #cons
149 val dummy = make #dummy
150 val (numCons', numCons) = make' #numCons
151 val used = make #used
152 end
153
154 fun new {cons: Con.t vector,
155 dummy: {con: Con.t, args: Type.t Prod.t}}: t =
156 T {cons = cons,
157 dummy = dummy,
158 numCons = ref ~1,
159 used = Used.new ()}
160 end
161
162 structure TypeInfo =
163 struct
164 datatype t = T of {deconed: bool ref,
165 simplify: Type.t option ref,
166 used: bool ref}
167
168 local
169 fun make f (T r) = f r
170 fun make' f = (make f, ! o (make f))
171 in
172 val (deconed', _) = make' #deconed
173 val (simplify', _) = make' #simplify
174 val (used', _) = make' #used
175 end
176
177 fun new (): t = T {deconed = ref false,
178 simplify = ref NONE,
179 used = ref false}
180 end
181
182 structure FuncInfo =
183 struct
184 datatype t = T of {args: (VarInfo.t * Type.t) vector,
185 bugLabel: Label.t option ref,
186 mayRaise: MayRaise.t,
187 mayReturn: MayReturn.t,
188 raiseLabel: Label.t option ref,
189 raises: (VarInfo.t * Type.t) vector option,
190 returnLabel: Label.t option ref,
191 returns: (VarInfo.t * Type.t) vector option,
192 used: Used.t,
193 wrappers: Block.t list ref}
194
195 fun layout (T {args,
196 mayRaise, mayReturn,
197 raises, returns,
198 used,
199 ...}) =
200 Layout.record [("args", Vector.layout
201 (Layout.tuple2 (VarInfo.layout, Type.layout))
202 args),
203 ("mayRaise", MayRaise.layout mayRaise),
204 ("mayReturn", MayReturn.layout mayReturn),
205 ("raises", Option.layout
206 (Vector.layout
207 (Layout.tuple2 (VarInfo.layout, Type.layout)))
208 raises),
209 ("returns", Option.layout
210 (Vector.layout
211 (Layout.tuple2 (VarInfo.layout, Type.layout)))
212 returns),
213 ("used", Used.layout used)]
214
215 local
216 fun make f (T r) = f r
217 fun make' f = (make f, ! o (make f))
218 in
219 val args = make #args
220 val mayRaise' = make #mayRaise
221 val mayReturn' = make #mayReturn
222 val raiseLabel = make #raiseLabel
223 val raises = make #raises
224 val returnLabel = make #returnLabel
225 val returns = make #returns
226 val used = make #used
227 val (wrappers', wrappers) = make' #wrappers
228 end
229
230 val raisee = MayRaise.raisee o mayRaise'
231 val mayRaise = MayRaise.mayRaise o mayRaise'
232 fun whenRaises (fi, th) = MayRaise.whenRaises (mayRaise' fi, th)
233 fun flowRaises (fi, fi') = MayRaise.<= (mayRaise' fi, mayRaise' fi')
234
235 val return = MayReturn.return o mayReturn'
236 fun whenReturns (fi, th) = MayReturn.whenReturns (mayReturn' fi, th)
237 val mayReturn = MayReturn.mayReturn o mayReturn'
238 fun flowReturns (fi, fi') = MayReturn.<= (mayReturn' fi, mayReturn' fi')
239
240 val use = Used.use o used
241 val isUsed = Used.isUsed o used
242 fun whenUsed (fi, th) = Used.whenUsed (used fi, th)
243
244 fun new {args: (VarInfo.t * Type.t) vector,
245 raises: (VarInfo.t * Type.t) vector option,
246 returns: (VarInfo.t * Type.t) vector option}: t =
247 T {args = args,
248 bugLabel = ref NONE,
249 mayRaise = MayRaise.new (),
250 mayReturn = MayReturn.new (),
251 raiseLabel = ref NONE,
252 raises = raises,
253 returnLabel = ref NONE,
254 returns = returns,
255 used = Used.new (),
256 wrappers = ref []}
257 end
258
259 structure LabelInfo =
260 struct
261 datatype t = T of {args: (VarInfo.t * Type.t) vector,
262 func: FuncInfo.t,
263 used: Used.t,
264 wrappers: (Type.t vector * Label.t) list ref}
265
266 fun layout (T {args, used, ...}) =
267 Layout.record [("args", Vector.layout (VarInfo.layout o #1) args),
268 ("used", Used.layout used)]
269
270 fun new {args: (VarInfo.t * Type.t) vector, func: FuncInfo.t}: t =
271 T {args = args,
272 func = func,
273 used = Used.new (),
274 wrappers = ref []}
275
276 local
277 fun make f (T r) = f r
278 fun make' f = (make f, ! o (make f))
279 in
280 val args = make #args
281 val func = make #func
282 val used = make #used
283 val (wrappers', wrappers) = make' #wrappers
284 end
285
286 val use = Used.use o used
287 val isUsed = Used.isUsed o used
288 fun whenUsed (li, th) = Used.whenUsed (used li, th)
289 end
290
291
292 fun transform2 (Program.T {datatypes, globals, functions, main}) =
293 let
294 val {get = conInfo: Con.t -> ConInfo.t,
295 set = setConInfo, ...} =
296 Property.getSetOnce
297 (Con.plist,
298 Property.initRaise ("RemoveUnused2.conInfo", Con.layout))
299 fun newConInfo (con, args, dummy) =
300 setConInfo (con, ConInfo.new {args = args, dummy = dummy})
301
302 val {get = tyconInfo: Tycon.t -> TyconInfo.t,
303 set = setTyconInfo, ...} =
304 Property.getSetOnce
305 (Tycon.plist,
306 Property.initRaise ("RemoveUnused2.tyconInfo", Tycon.layout))
307 fun newTyconInfo (tycon, cons, dummy) =
308 setTyconInfo (tycon, TyconInfo.new {cons = cons, dummy = dummy})
309
310 val {get = typeInfo: Type.t -> TypeInfo.t,
311 destroy, ...} =
312 Property.destGet
313 (Type.plist,
314 Property.initFun (fn _ => TypeInfo.new ()))
315
316 val {get = varInfo: Var.t -> VarInfo.t,
317 set = setVarInfo, ...} =
318 Property.getSetOnce
319 (Var.plist,
320 Property.initRaise ("RemoveUnused2.varInfo", Var.layout))
321 fun newVarInfo (var, ty) =
322 setVarInfo (var, VarInfo.new ty)
323
324 val {get = labelInfo: Label.t -> LabelInfo.t,
325 set = setLabelInfo, ...} =
326 Property.getSetOnce
327 (Label.plist,
328 Property.initRaise ("RemoveUnused2.labelInfo", Label.layout))
329
330 val {get = funcInfo: Func.t -> FuncInfo.t,
331 set = setFuncInfo, ...} =
332 Property.getSetOnce
333 (Func.plist,
334 Property.initRaise ("RemoveUnused2.funcInfo", Func.layout))
335
336
337 val usedCon = ConInfo.used o conInfo
338 val useCon = Used.use o usedCon
339 fun visitCon (con: Con.t) = useCon con
340 val whenUsedCon = fn (con, th) => ConInfo.whenUsed (conInfo con, th)
341
342 val usedTycon = TyconInfo.used o tyconInfo
343 val useTycon = Used.use o usedTycon
344 fun visitTycon (tycon: Tycon.t) = useTycon tycon
345 val isUsedTycon = Used.isUsed o usedTycon
346
347 fun visitType (ty: Type.t) =
348 let
349 val ti = typeInfo ty
350 val used = TypeInfo.used' ti
351 in
352 if !used
353 then ()
354 else let
355 val () = used := true
356 datatype z = datatype Type.dest
357 datatype z = datatype ObjectCon.t
358 val () =
359 case Type.dest ty of
360 Datatype tycon => visitTycon tycon
361 | Object {args, con} =>
362 let
363 val () = Prod.foreach (args, visitType)
364 val () =
365 case con of
366 Con con => visitCon con
367 | Tuple => ()
368 | Vector => ()
369 in
370 ()
371 end
372 | Weak ty => visitType ty
373 | _ => ()
374 in
375 ()
376 end
377 end
378 val visitTypeTh = fn ty => fn () => visitType ty
379
380 val tyVar = VarInfo.ty o varInfo
381 val usedVar = VarInfo.used o varInfo
382 val useVar = Used.use o usedVar
383 val isUsedVar = Used.isUsed o usedVar
384 val whenUsedVar = fn (var, th) => VarInfo.whenUsed (varInfo var, th)
385 fun flowVarInfoTyVarInfoTy ((vi, _), (vi', _)) =
386 Used.<= (VarInfo.used vi, VarInfo.used vi')
387 fun flowVarInfoTysVarInfoTys (xs, ys) =
388 Vector.foreach2 (xs, ys, flowVarInfoTyVarInfoTy)
389 fun flowVarInfoTyVar ((vi, _), x) =
390 Used.<= (VarInfo.used vi, usedVar x)
391 fun flowVarInfoTysVars (xs, ys) =
392 Vector.foreach2 (xs, ys, flowVarInfoTyVar)
393
394 val newVarInfo = fn (var, ty) =>
395 (newVarInfo (var, ty)
396 ; whenUsedVar (var, visitTypeTh ty))
397
398 val visitLabelInfo = LabelInfo.use
399 val visitLabelInfoTh = fn li => fn () => visitLabelInfo li
400 val visitLabel = visitLabelInfo o labelInfo
401 val visitLabelTh = fn l => fn () => visitLabel l
402 val visitFuncInfo = FuncInfo.use
403 val visitFunc = visitFuncInfo o funcInfo
404
405 fun visitVar (x: Var.t) = useVar x
406 fun visitVars (xs: Var.t Vector.t) = Vector.foreach (xs, visitVar)
407 fun visitExp (e: Exp.t) =
408 case e of
409 Const _ => ()
410 | Inject {sum, variant} =>
411 (visitTycon sum
412 ; visitVar variant)
413 | Object {args, con} =>
414 let
415 val () =
416 case con of
417 NONE => visitVars args
418 | SOME con =>
419 let
420 val ci = conInfo con
421 val () = ConInfo.con ci
422 val ciArgs =
423 Vector.map
424 (Prod.dest (ConInfo.args ci), #elt)
425 val () = flowVarInfoTysVars (ciArgs, args)
426 in
427 ()
428 end
429 in
430 ()
431 end
432 | PrimApp {prim, args, ...} =>
433 let
434 val () = visitVars args
435 datatype z = datatype Type.dest
436 datatype z = datatype ObjectCon.t
437 fun deconType (ty: Type.t) =
438 let
439 val ti = typeInfo ty
440 val deconed = TypeInfo.deconed' ti
441 in
442 if !deconed
443 then ()
444 else let
445 val () = deconed := true
446 val () =
447 case Type.dest ty of
448 Datatype t =>
449 Vector.foreach
450 (TyconInfo.cons (tyconInfo t),
451 fn con => deconCon con)
452 | Object {args, con} =>
453 let
454 fun default () =
455 Vector.foreach
456 (Prod.dest args, fn {elt, isMutable} =>
457 if isMutable
458 then ()
459 else deconType elt)
460 val () =
461 case con of
462 Con con => deconCon con
463 | Tuple => default ()
464 | Vector => default ()
465 in
466 ()
467 end
468 | _ => ()
469 in
470 ()
471 end
472 end
473 and deconCon con =
474 let
475 val ci = conInfo con
476 val () = ConInfo.decon ci
477 val () =
478 Vector.foreach
479 (Prod.dest (ConInfo.args ci), fn {elt = (x, t), isMutable} =>
480 (VarInfo.use x
481 ; if isMutable then () else deconType t))
482 in
483 ()
484 end
485 val () =
486 case Prim.name prim of
487 Prim.Name.MLton_eq =>
488 (* MLton_eq may be used on datatypes used as enums. *)
489 deconType (tyVar (Vector.first args))
490 | Prim.Name.MLton_equal =>
491 (* MLton_equal will be expanded by poly-equal into uses
492 * of constructors as patterns.
493 *)
494 deconType (tyVar (Vector.first args))
495 | Prim.Name.MLton_hash =>
496 (* MLton_hash will be expanded by poly-hash into uses
497 * of constructors as patterns.
498 *)
499 deconType (tyVar (Vector.first args))
500 (*
501 | Prim.Name.MLton_size =>
502 deconType (tyVar (Vector.first args))
503 *)
504 | _ => ()
505 in
506 ()
507 end
508 | Select {base, offset} =>
509 let
510 datatype z = datatype Base.t
511 datatype z = datatype ObjectCon.t
512 in
513 case base of
514 Object base =>
515 let
516 val () = visitVar base
517 val () =
518 case Type.dest (tyVar base) of
519 Type.Object {con, ...} =>
520 (case con of
521 Con con =>
522 let
523 val ci = conInfo con
524 val ciArgs = ConInfo.args ci
525 val {elt = (vi, _), ...} =
526 Prod.sub (ciArgs, offset)
527
528 val () = ConInfo.decon ci
529 val () = VarInfo.use vi
530 in
531 ()
532 end
533 | Tuple => ()
534 | Vector => Error.bug "RemoveUnused2.visitExp: Select:non-Con|Tuple")
535 | _ => Error.bug "RemovUnused2.visitExp: Select:non-Object"
536 in
537 ()
538 end
539 | VectorSub {index, vector} =>
540 (visitVar index
541 ; visitVar vector)
542 end
543 | Var x => visitVar x
544 val visitExpTh = fn e => fn () => visitExp e
545 fun maybeVisitVarExp (var, exp) =
546 Option.app (var, fn var =>
547 VarInfo.whenUsed (varInfo var, visitExpTh exp))
548 fun visitStatement s =
549 case s of
550 Bind {exp, ty, var} =>
551 (Option.app (var, fn var => newVarInfo (var, ty))
552 ; if Exp.maySideEffect exp
553 then (visitType ty
554 ; visitExp exp)
555 else maybeVisitVarExp (var, exp))
556 | Profile _ => ()
557 | Update {base, offset, value} =>
558 let
559 datatype z = datatype Base.t
560 datatype z = datatype ObjectCon.t
561 in
562 case base of
563 Object base =>
564 (case Type.dest (tyVar base) of
565 Type.Object {con, ...} =>
566 (case con of
567 Con con =>
568 let
569 val ci = conInfo con
570 val ciArgs = ConInfo.args ci
571 val {elt = (vi, _), ...} =
572 Prod.sub (ciArgs, offset)
573 in
574 VarInfo.whenUsed
575 (vi, fn () =>
576 (ConInfo.decon ci
577 ; visitVar base
578 ; visitVar value))
579 end
580 | Tuple =>
581 (visitVar base
582 ; visitVar value)
583 | Vector => Error.bug "RemoveUnused2.visitStatement: Update:non-Con|Tuple")
584 | _ => Error.bug "RemoveUnused2.visitStatement: Update:non-Object")
585 | VectorSub {index, vector} =>
586 (visitVar index
587 ; visitVar vector
588 ; visitVar value)
589 end
590 fun visitTransfer (t: Transfer.t, fi: FuncInfo.t) =
591 case t of
592 Arith {args, overflow, success, ty, ...} =>
593 (visitVars args
594 ; visitLabel overflow
595 ; visitLabel success
596 ; visitType ty)
597 | Bug => ()
598 | Call {args, func, return} =>
599 let
600 datatype u = None
601 | Caller
602 | Some of Label.t
603 val (cont, handler) =
604 case return of
605 Return.Dead => (None, None)
606 | Return.NonTail {cont, handler} =>
607 (Some cont,
608 case handler of
609 Handler.Caller => Caller
610 | Handler.Dead => None
611 | Handler.Handle h => Some h)
612 | Return.Tail => (Caller, Caller)
613 val fi' = funcInfo func
614
615 val () = flowVarInfoTysVars (FuncInfo.args fi', args)
616 val () =
617 case cont of
618 None => ()
619 | Caller =>
620 let
621 val () =
622 case (FuncInfo.returns fi,
623 FuncInfo.returns fi') of
624 (SOME xts, SOME xts') =>
625 flowVarInfoTysVarInfoTys (xts, xts')
626 | _ => ()
627 val () = FuncInfo.flowReturns (fi', fi)
628 in
629 ()
630 end
631 | Some l =>
632 let
633 val li = labelInfo l
634 val () =
635 Option.app
636 (FuncInfo.returns fi', fn xts =>
637 flowVarInfoTysVarInfoTys
638 (LabelInfo.args li, xts))
639 val () =
640 FuncInfo.whenReturns
641 (fi', visitLabelInfoTh li)
642 in
643 ()
644 end
645 val () =
646 case handler of
647 None => ()
648 | Caller =>
649 let
650 val () =
651 case (FuncInfo.raises fi,
652 FuncInfo.raises fi') of
653 (SOME xts, SOME xts') =>
654 flowVarInfoTysVarInfoTys (xts, xts')
655 | _ => ()
656 val () = FuncInfo.flowRaises (fi', fi)
657 in
658 ()
659 end
660 | Some l =>
661 let
662 val li = labelInfo l
663 val () =
664 Option.app
665 (FuncInfo.raises fi', fn xts =>
666 flowVarInfoTysVarInfoTys
667 (LabelInfo.args li, xts))
668 val () =
669 FuncInfo.whenRaises (fi', visitLabelInfoTh li)
670 in
671 ()
672 end
673 val () = visitFuncInfo fi'
674 in
675 ()
676 end
677 | Case {test, cases, default} =>
678 let
679 val () = visitVar test
680 in
681 case cases of
682 Cases.Word (_, cs) =>
683 (Vector.foreach (cs, visitLabel o #2)
684 ; Option.app (default, visitLabel))
685 | Cases.Con cases =>
686 if Vector.isEmpty cases
687 then Option.app (default, visitLabel)
688 else let
689 val () =
690 Vector.foreach
691 (cases, fn (con, l) =>
692 let
693 val ci = conInfo con
694 val () = ConInfo.decon ci
695 val () =
696 ConInfo.whenConed
697 (ci, visitLabelTh l)
698 in
699 ()
700 end)
701 val tycon =
702 case Type.dest (tyVar test) of
703 Type.Datatype tycon => tycon
704 | _ => Error.bug "RemoveUnused2.visitTransfer: Case:non-Datatype"
705 val cons = TyconInfo.cons (tyconInfo tycon)
706 in
707 case default of
708 NONE => ()
709 | SOME l =>
710 Vector.foreach
711 (cons, fn con =>
712 if Vector.exists
713 (cases, fn (c, _) =>
714 Con.equals(c, con))
715 then ()
716 else
717 ConInfo.whenConed
718 (conInfo con, visitLabelTh l))
719 end
720 end
721 | Goto {dst, args} =>
722 let
723 val li = labelInfo dst
724 val () = flowVarInfoTysVars (LabelInfo.args li, args)
725 val () = visitLabelInfo li
726 in
727 ()
728 end
729 | Raise xs =>
730 (FuncInfo.raisee fi
731 ; flowVarInfoTysVars (valOf (FuncInfo.raises fi), xs))
732 | Return xs =>
733 (FuncInfo.return fi
734 ; flowVarInfoTysVars (valOf (FuncInfo.returns fi), xs))
735 | Runtime {args, return, ...} =>
736 (visitVars args
737 ; visitLabel return)
738 fun visitBlock (Block.T {statements, transfer, ...}, fi: FuncInfo.t) =
739 (Vector.foreach (statements, visitStatement)
740 ; visitTransfer (transfer, fi))
741 val visitBlockTh = fn (b, fi) => fn () => visitBlock (b, fi)
742 (* Visit all reachable expressions. *)
743 val () =
744 Vector.foreach
745 (datatypes, fn Datatype.T {tycon, cons} =>
746 let
747 val dummyCon = Con.newString "dummy"
748 val dummyArgs = Prod.empty ()
749 val dummy = {con = dummyCon, args = dummyArgs}
750 val () =
751 newTyconInfo
752 (tycon, Vector.map (cons, fn {con, ...} => con), dummy)
753 val dummyTy = Type.conApp (dummyCon, dummyArgs)
754 val dummyExp = Object {args = Vector.new0 (),
755 con = SOME dummyCon}
756 val dummy = {con = dummyCon, args = dummyArgs,
757 ty = dummyTy, exp = dummyExp}
758 val () =
759 Vector.foreach
760 (cons, fn {con, args} =>
761 (newConInfo (con, args, dummy)
762 ; whenUsedCon (con, fn () => useTycon tycon)))
763 in
764 ()
765 end)
766 val () =
767 let
768 fun doitCon c =
769 let
770 val ci = conInfo c
771 in
772 ConInfo.use ci
773 ; ConInfo.con ci
774 ; ConInfo.decon ci
775 end
776 in
777 useTycon Tycon.bool
778 ; doitCon Con.truee
779 ; doitCon Con.falsee
780 end
781 val () =
782 Vector.foreach (globals, visitStatement)
783 val () =
784 List.foreach
785 (functions, fn function =>
786 let
787 val {name, args, raises, returns, start, blocks, ...} =
788 Function.dest function
789 val () = Vector.foreach (args, newVarInfo)
790 local
791 fun doitVarTys vts =
792 Vector.map (vts, fn (x, t) => (varInfo x, t))
793 fun doitTys ts =
794 Vector.map (ts, fn t => (VarInfo.new t, t))
795 fun doitTys' ts =
796 Option.map (ts, doitTys)
797 in
798 val fi =
799 FuncInfo.new
800 {args = doitVarTys args,
801 raises = doitTys' raises,
802 returns = doitTys' returns}
803 end
804 val () = setFuncInfo (name, fi)
805 val () = FuncInfo.whenUsed (fi, visitLabelTh start)
806 val () =
807 Vector.foreach
808 (blocks, fn block as Block.T {label, args, ...} =>
809 let
810 val () = Vector.foreach (args, newVarInfo)
811 local
812 fun doitVarTys vts =
813 Vector.map (vts, fn (x, t) => (varInfo x, t))
814 in
815 val li =
816 LabelInfo.new
817 {args = doitVarTys args,
818 func = fi}
819 end
820 val () = setLabelInfo (label, li)
821 val () = LabelInfo.whenUsed (li, visitBlockTh (block, fi))
822 in
823 ()
824 end)
825 in
826 ()
827 end)
828 val () = visitFunc main
829
830 (* Diagnostics *)
831 val () =
832 Control.diagnostics
833 (fn display =>
834 let open Layout
835 in
836 Vector.foreach
837 (datatypes, fn Datatype.T {tycon, cons} =>
838 display (seq [Tycon.layout tycon,
839 str ": ",
840 TyconInfo.layout (tyconInfo tycon),
841 str ": ",
842 Vector.layout
843 (fn {con, ...} =>
844 seq [Con.layout con,
845 str " ",
846 ConInfo.layout (conInfo con)])
847 cons]));
848 display (str "\n");
849 List.foreach
850 (functions, fn f =>
851 let
852 val {name, blocks, ...} = Function.dest f
853 in
854 display (seq [Func.layout name,
855 str ": ",
856 FuncInfo.layout (funcInfo name)]);
857 Vector.foreach
858 (blocks, fn Block.T {label, ...} =>
859 display (seq [Label.layout label,
860 str ": ",
861 LabelInfo.layout (labelInfo label)]));
862 display (str "\n")
863 end)
864 end)
865
866 (* Analysis is done, Now build the resulting program. *)
867 fun getWrapperLabel (l: Label.t,
868 args: (VarInfo.t * Type.t) vector) =
869 let
870 val li = labelInfo l
871 in
872 if Vector.forall2 (args, LabelInfo.args li, fn ((x, _), (y, _)) =>
873 VarInfo.isUsed x = VarInfo.isUsed y)
874 then l
875 else let
876 val tys =
877 Vector.keepAllMap (args, fn (x, ty) =>
878 if VarInfo.isUsed x
879 then SOME ty
880 else NONE)
881 in
882 case List.peek
883 (LabelInfo.wrappers li, fn (args', _) =>
884 Vector.length args' = Vector.length tys
885 andalso
886 Vector.forall2 (args', tys, fn (ty', ty) =>
887 Type.equals (ty', ty))) of
888 NONE =>
889 let
890 val liArgs = LabelInfo.args li
891 val l' = Label.newNoname ()
892 val (args', args'') =
893 Vector.unzip
894 (Vector.map2
895 (args, liArgs, fn ((x, ty), (y, _)) =>
896 let
897 val z = Var.newNoname ()
898 in
899 (if VarInfo.isUsed x
900 then SOME (z, ty) else NONE,
901 if VarInfo.isUsed y
902 then SOME z else NONE)
903 end))
904 val args' =
905 Vector.keepAllMap (args', fn x => x)
906 val (_, tys') = Vector.unzip args'
907 val args'' =
908 Vector.keepAllMap (args'', fn x => x)
909 val block =
910 Block.T {label = l',
911 args = args',
912 statements = Vector.new0 (),
913 transfer = Goto {dst = l,
914 args = args''}}
915 val () =
916 List.push (LabelInfo.wrappers' li,
917 (tys', l'))
918 val () =
919 List.push (FuncInfo.wrappers' (LabelInfo.func li),
920 block)
921 in
922 l'
923 end
924 | SOME (_, l') => l'
925 end
926 end
927 val getContWrapperLabel = getWrapperLabel
928 val getHandlerWrapperLabel = getWrapperLabel
929 fun getOriginalWrapperLabel l =
930 getWrapperLabel
931 (l, Vector.map (LabelInfo.args (labelInfo l), fn (_, t) =>
932 let
933 val x = VarInfo.new t
934 val () = VarInfo.use x
935 in
936 (x, t)
937 end))
938 val getArithOverflowWrapperLabel = getOriginalWrapperLabel
939 val getArithSuccessWrapperLabel = getOriginalWrapperLabel
940 val getRuntimeWrapperLabel = getOriginalWrapperLabel
941 fun getBugFunc (fi: FuncInfo.t): Label.t =
942 (* Can't share the Bug block across different places because the
943 * profile sourceInfo stack might be different.
944 *)
945 let
946 val l = Label.newNoname ()
947 val block = Block.T {label = l,
948 args = Vector.new0 (),
949 statements = Vector.new0 (),
950 transfer = Bug}
951 val () = List.push (FuncInfo.wrappers' fi, block)
952 in
953 l
954 end
955 fun getReturnFunc (fi: FuncInfo.t): Label.t =
956 let
957 val r = FuncInfo.returnLabel fi
958 in
959 case !r of
960 NONE =>
961 let
962 val l = Label.newNoname ()
963 val returns = valOf (FuncInfo.returns fi)
964 val args =
965 Vector.keepAllMap
966 (returns, fn (vi, ty) =>
967 if VarInfo.isUsed vi
968 then SOME (Var.newNoname (), ty)
969 else NONE)
970 val xs = Vector.map (args, #1)
971 val block = Block.T {label = l,
972 args = args,
973 statements = Vector.new0 (),
974 transfer = Return xs}
975 val () = r := SOME l
976 val () = List.push (FuncInfo.wrappers' fi, block)
977 val () = setLabelInfo (l, LabelInfo.new {func = fi,
978 args = returns})
979 in
980 l
981 end
982 | SOME l => l
983 end
984 fun getReturnContFunc (fi, args) =
985 getWrapperLabel (getReturnFunc fi, args)
986 fun getRaiseFunc (fi: FuncInfo.t): Label.t =
987 let
988 val r = FuncInfo.raiseLabel fi
989 in
990 case !r of
991 NONE =>
992 let
993 val l = Label.newNoname ()
994 val raises = valOf (FuncInfo.raises fi)
995 val args =
996 Vector.keepAllMap
997 (raises, fn (vi, ty) =>
998 if VarInfo.isUsed vi
999 then SOME (Var.newNoname (), ty)
1000 else NONE)
1001 val xs = Vector.map (args, #1)
1002 val block = Block.T {label = l,
1003 args = args,
1004 statements = Vector.new0 (),
1005 transfer = Raise xs}
1006 val () = r := SOME l
1007 val () = List.push (FuncInfo.wrappers' fi, block)
1008 val () = setLabelInfo (l, LabelInfo.new {func = fi,
1009 args = raises})
1010 in
1011 l
1012 end
1013 | SOME l => l
1014 end
1015 fun getRaiseHandlerFunc (fi, args) =
1016 getWrapperLabel (getRaiseFunc fi, args)
1017
1018 fun simplifyType (ty: Type.t): Type.t =
1019 let
1020 val ti = typeInfo ty
1021 val simplify = TypeInfo.simplify' ti
1022 in
1023 case !simplify of
1024 NONE => let
1025 datatype z = datatype Type.dest
1026 datatype z = datatype ObjectCon.t
1027 val ty =
1028 case Type.dest ty of
1029 Object {args, con} =>
1030 (case con of
1031 Con con =>
1032 let
1033 val ci = conInfo con
1034 in
1035 case (ConInfo.isConed ci,
1036 ConInfo.isDeconed ci) of
1037 (false, _) =>
1038 #ty (ConInfo.dummy ci)
1039 | (true, true) =>
1040 Type.object
1041 {args = Prod.keepAllMap
1042 (ConInfo.args ci, fn (x,t) =>
1043 if VarInfo.isUsed x
1044 then SOME (simplifyType t)
1045 else NONE),
1046 con = Con con}
1047 | (true, false) =>
1048 #ty (ConInfo.dummy ci)
1049 end
1050 | _ =>
1051 Type.object
1052 {args = Prod.map (args, simplifyType),
1053 con = con})
1054 | Weak ty => Type.weak (simplifyType ty)
1055 | _ => ty
1056 in
1057 simplify := SOME ty
1058 ; ty
1059 end
1060 | SOME ty => ty
1061 end
1062
1063 val datatypes =
1064 Vector.keepAllMap
1065 (datatypes, fn Datatype.T {tycon, cons} =>
1066 if isUsedTycon tycon
1067 then let
1068 val needsDummy : bool ref = ref false
1069 val cons =
1070 Vector.keepAllMap
1071 (cons, fn {con, ...} =>
1072 let
1073 val ci = conInfo con
1074 fun addDummy () =
1075 if !needsDummy
1076 then NONE
1077 else let
1078 val () = needsDummy := true
1079 in
1080 SOME (TyconInfo.dummy (tyconInfo tycon))
1081 end
1082 in
1083 case (ConInfo.isConed ci,
1084 ConInfo.isDeconed ci) of
1085 (false, _) =>
1086 if ConInfo.isUsed ci
1087 then addDummy ()
1088 else NONE
1089 | (true, true) =>
1090 SOME {con = con,
1091 args = Prod.keepAllMap
1092 (ConInfo.args ci, fn (x, ty) =>
1093 if VarInfo.isUsed x
1094 then SOME (simplifyType ty)
1095 else NONE)}
1096 | (true, false) =>
1097 addDummy ()
1098 end)
1099 val num = Vector.length cons
1100 val () = TyconInfo.numCons' (tyconInfo tycon) := num
1101 in
1102 SOME (Datatype.T {tycon = tycon, cons = cons})
1103 end
1104 else NONE)
1105
1106 fun simplifyExp (e: Exp.t): Exp.t =
1107 case e of
1108 Object {con, args} =>
1109 (case con of
1110 NONE => e
1111 | SOME con =>
1112 let
1113 val ci = conInfo con
1114 in
1115 if ConInfo.isDeconed ci
1116 then let
1117 val ciArgs =
1118 Vector.map
1119 (Prod.dest (ConInfo.args ci), #elt)
1120 in
1121 Object {con = SOME con,
1122 args = (Vector.keepAllMap2
1123 (args, ciArgs,
1124 fn (x, (y, _)) =>
1125 if VarInfo.isUsed y
1126 then SOME x
1127 else NONE))}
1128 end
1129 else #exp (ConInfo.dummy ci)
1130 end)
1131 | Select {base, offset} =>
1132 let
1133 datatype z = datatype Base.t
1134 in
1135 case base of
1136 Object base =>
1137 let
1138 datatype z = datatype ObjectCon.t
1139 datatype z = datatype Type.dest
1140 in
1141 case Type.dest (tyVar base) of
1142 Object {con, ...} =>
1143 (case con of
1144 Con con =>
1145 let
1146 val ci = conInfo con
1147 val ciArgs = ConInfo.args ci
1148 val offset =
1149 Int.fold
1150 (0, offset, 0, fn (i, offset) =>
1151 if (VarInfo.isUsed o #1 o #elt)
1152 (Prod.sub (ciArgs, i))
1153 then offset + 1
1154 else offset)
1155 in
1156 Select {base = Base.Object base,
1157 offset = offset}
1158 end
1159 | Tuple => e
1160 | Vector => Error.bug "RemoveUnused2.simplifyExp: Update:non-Con|Tuple")
1161 | _ => Error.bug "RemoveUnused2.simplifyExp:Select:non-Object"
1162 end
1163 | _ => e
1164 end
1165 | _ => e
1166 fun simplifyStatement (s : Statement.t) : Statement.t option =
1167 case s of
1168 Bind {exp, ty, var} =>
1169 let
1170 fun doit' var =
1171 SOME (Statement.Bind
1172 {var = var,
1173 ty = simplifyType ty,
1174 exp = simplifyExp exp})
1175 fun doit var' =
1176 if Exp.maySideEffect exp
1177 then doit' var
1178 else if isSome var'
1179 then doit' var'
1180 else NONE
1181 in
1182 case var of
1183 SOME var => if isUsedVar var
1184 then doit (SOME var)
1185 else doit NONE
1186 | NONE => doit NONE
1187 end
1188 | Profile _ => SOME s
1189 | Update {base, offset, value} =>
1190 let
1191 datatype z = datatype Base.t
1192 in
1193 case base of
1194 Object base =>
1195 let
1196 datatype z = datatype ObjectCon.t
1197 datatype z = datatype Type.dest
1198 in
1199 case Type.dest (tyVar base) of
1200 Object {con, ...} =>
1201 (case con of
1202 Con con =>
1203 let
1204 val ci = conInfo con
1205 val ciArgs = ConInfo.args ci
1206 fun argIsUsed i =
1207 VarInfo.isUsed
1208 (#1 (#elt (Prod.sub (ciArgs, i))))
1209 in
1210 if argIsUsed offset
1211 then
1212 let
1213 val offset =
1214 Int.fold
1215 (0, offset, 0,
1216 fn (i, offset) =>
1217 if argIsUsed i
1218 then offset + 1
1219 else offset)
1220 in
1221 SOME
1222 (Update
1223 {base = Base.Object base,
1224 offset = offset,
1225 value = value})
1226 end
1227 else NONE
1228 end
1229 | Tuple => SOME s
1230 | Vector => Error.bug "RemoveUnused2.simplifyStatement: Update:non-Con|Tuple")
1231 | _ => Error.bug "RemoveUnused2.simplifyStatement: Select:non-Object"
1232 end
1233 | _ => SOME s
1234 end
1235 fun simplifyStatements (ss: Statement.t Vector.t) : Statement.t Vector.t =
1236 Vector.keepAllMap (ss, simplifyStatement)
1237 fun simplifyTransfer (t: Transfer.t, fi: FuncInfo.t): Transfer.t =
1238 case t of
1239 Arith {prim, args, overflow, success, ty} =>
1240 Arith {prim = prim,
1241 args = args,
1242 overflow = getArithOverflowWrapperLabel overflow,
1243 success = getArithSuccessWrapperLabel success,
1244 ty = simplifyType ty}
1245 | Bug => Bug
1246 | Call {func, args, return} =>
1247 let
1248 val fi' = funcInfo func
1249 datatype u = None
1250 | Caller
1251 | Some of Label.t
1252 val (cont, handler) =
1253 case return of
1254 Return.Dead => (None, None)
1255 | Return.NonTail {cont, handler} =>
1256 (Some cont,
1257 case handler of
1258 Handler.Caller => Caller
1259 | Handler.Dead => None
1260 | Handler.Handle h => Some h)
1261 | Return.Tail => (Caller, Caller)
1262 val cont =
1263 if FuncInfo.mayReturn fi'
1264 then case cont of
1265 None =>
1266 Error.bug "RemoveUnused2.simplifyTransfer: cont:None"
1267 | Caller =>
1268 (if (case (FuncInfo.returns fi,
1269 FuncInfo.returns fi') of
1270 (SOME xts, SOME yts) =>
1271 Vector.forall2
1272 (xts, yts, fn ((x, _), (y, _)) =>
1273 VarInfo.isUsed x = VarInfo.isUsed y)
1274 | _ => Error.bug "RemoveUnused2.simplifyTransfer: cont:Caller")
1275 then Caller
1276 else Some (getReturnContFunc
1277 (fi, valOf (FuncInfo.returns fi'))))
1278 | Some l =>
1279 Some (getContWrapperLabel
1280 (l, valOf (FuncInfo.returns fi')))
1281 else None
1282 val handler =
1283 if FuncInfo.mayRaise fi'
1284 then (case handler of
1285 None =>
1286 Error.bug "RemoveUnused2.simplifyTransfer: handler:None"
1287 | Caller =>
1288 (if (case (FuncInfo.raises fi,
1289 FuncInfo.raises fi') of
1290 (SOME xts, SOME yts) =>
1291 Vector.forall2
1292 (xts, yts, fn ((x, _), (y, _)) =>
1293 VarInfo.isUsed x = VarInfo.isUsed y)
1294 | _ => Error.bug "RemoveUnused2.simplifyTransfer: handler:Caller")
1295 then Caller
1296 else Some (getRaiseHandlerFunc
1297 (fi, valOf (FuncInfo.raises fi'))))
1298 | Some l =>
1299 Some (getHandlerWrapperLabel
1300 (l, valOf (FuncInfo.raises fi'))))
1301 else None
1302 val return =
1303 case (cont, handler) of
1304 (None, None) => Return.Dead
1305 | (None, Caller) => Return.Tail
1306 | (None, Some h) =>
1307 Return.NonTail
1308 {cont = getBugFunc fi,
1309 handler = Handler.Handle h}
1310 | (Caller, None) => Return.Tail
1311 | (Caller, Caller) => Return.Tail
1312 | (Caller, Some h) =>
1313 Return.NonTail
1314 {cont = getReturnContFunc
1315 (fi, valOf (FuncInfo.returns fi')),
1316 handler = Handler.Handle h}
1317 | (Some c, None) =>
1318 Return.NonTail
1319 {cont = c,
1320 handler = Handler.Dead}
1321 | (Some c, Caller) =>
1322 Return.NonTail
1323 {cont = c,
1324 handler = Handler.Caller}
1325 | (Some c, Some h) =>
1326 Return.NonTail
1327 {cont = c,
1328 handler = Handler.Handle h}
1329
1330 val args =
1331 Vector.keepAllMap2
1332 (args, FuncInfo.args fi', fn (x, (y, _)) =>
1333 if VarInfo.isUsed y
1334 then SOME x
1335 else NONE)
1336 in
1337 Call {func = func,
1338 args = args,
1339 return = return}
1340 end
1341 | Case {test, cases = Cases.Con cases, default} =>
1342 let
1343 val cases =
1344 Vector.keepAllMap
1345 (cases, fn (con, l) =>
1346 let
1347 val ci = conInfo con
1348 in
1349 if ConInfo.isConed ci
1350 then SOME (con, l)
1351 else NONE
1352 end)
1353 fun keep default = Case {test = test,
1354 cases = Cases.Con cases,
1355 default = default}
1356 fun none () = keep NONE
1357 in
1358 case default of
1359 NONE => none ()
1360 | SOME l => if Vector.isEmpty cases
1361 then if LabelInfo.isUsed (labelInfo l)
1362 then Goto {dst = l, args = Vector.new0 ()}
1363 else Bug
1364 else let
1365 val tycon =
1366 case Type.dest (tyVar test) of
1367 Type.Datatype tycon => tycon
1368 | _ => Error.bug "RemoveUnused2.simplifyTransfer: Case:non-Datatype"
1369 val numCons = TyconInfo.numCons (tyconInfo tycon)
1370 in
1371 if Vector.length cases = numCons
1372 then none ()
1373 else keep (SOME l)
1374 end
1375 end
1376 | Case {test, cases, default} =>
1377 Case {test = test,
1378 cases = cases,
1379 default = default}
1380 | Goto {dst, args} =>
1381 Goto {dst = dst,
1382 args = (Vector.keepAllMap2
1383 (args, LabelInfo.args (labelInfo dst),
1384 fn (x, (y, _)) => if VarInfo.isUsed y
1385 then SOME x
1386 else NONE))}
1387 | Raise xs =>
1388 Raise (Vector.keepAllMap2
1389 (xs, valOf (FuncInfo.raises fi),
1390 fn (x, (y, _)) => if VarInfo.isUsed y
1391 then SOME x
1392 else NONE))
1393 | Return xs =>
1394 Return (Vector.keepAllMap2
1395 (xs, valOf (FuncInfo.returns fi),
1396 fn (x, (y, _)) => if VarInfo.isUsed y
1397 then SOME x
1398 else NONE))
1399 | Runtime {prim, args, return} =>
1400 Runtime {prim = prim,
1401 args = args,
1402 return = getRuntimeWrapperLabel return}
1403 val simplifyTransfer =
1404 Trace.trace
1405 ("RemoveUnused2.simplifyTransfer",
1406 Layout.tuple2 (Transfer.layout, FuncInfo.layout), Transfer.layout)
1407 simplifyTransfer
1408 fun simplifyBlock (Block.T {label, args, statements, transfer}): Block.t option =
1409 let
1410 val li = labelInfo label
1411 in
1412 if LabelInfo.isUsed li
1413 then let
1414 val args =
1415 Vector.keepAllMap2
1416 (LabelInfo.args li, args, fn ((vi, _), (x, ty)) =>
1417 if VarInfo.isUsed vi
1418 then SOME (x, simplifyType ty)
1419 else NONE)
1420 val statements = simplifyStatements statements
1421 val transfer =
1422 simplifyTransfer (transfer, LabelInfo.func li)
1423 in
1424 SOME (Block.T {label = label,
1425 args = args,
1426 statements = statements,
1427 transfer = transfer})
1428 end
1429 else NONE
1430 end
1431 fun simplifyBlocks (bs: Block.t Vector.t): Block.t Vector.t =
1432 Vector.keepAllMap (bs, simplifyBlock)
1433 val globals = simplifyStatements globals
1434 val shrink = shrinkFunction {globals = globals}
1435 fun simplifyFunction (f: Function.t): Function.t option =
1436 let
1437 val {args, blocks, mayInline, name, start, ...} = Function.dest f
1438 val fi = funcInfo name
1439 in
1440 if FuncInfo.isUsed fi
1441 then let
1442 val args =
1443 Vector.keepAllMap2
1444 (FuncInfo.args fi, args, fn ((vi, _), (x, ty)) =>
1445 if VarInfo.isUsed vi
1446 then SOME (x, simplifyType ty)
1447 else NONE)
1448 val blocks = simplifyBlocks blocks
1449 val wrappers = Vector.fromList (FuncInfo.wrappers fi)
1450 val blocks = Vector.concat [wrappers, blocks]
1451 val returns =
1452 case FuncInfo.returns fi of
1453 NONE => NONE
1454 | SOME xts =>
1455 if FuncInfo.mayReturn fi
1456 then SOME (Vector.keepAllMap
1457 (xts, fn (x, ty) =>
1458 if VarInfo.isUsed x
1459 then SOME (simplifyType ty)
1460 else NONE))
1461 else NONE
1462 val raises =
1463 case FuncInfo.raises fi of
1464 NONE => NONE
1465 | SOME xts =>
1466 if FuncInfo.mayRaise fi
1467 then SOME (Vector.keepAllMap
1468 (xts, fn (x, ty) =>
1469 if VarInfo.isUsed x
1470 then SOME (simplifyType ty)
1471 else NONE))
1472 else NONE
1473 in
1474 SOME (shrink (Function.new {args = args,
1475 blocks = blocks,
1476 mayInline = mayInline,
1477 name = name,
1478 raises = raises,
1479 returns = returns,
1480 start = start}))
1481 end
1482 else NONE
1483 end
1484 fun simplifyFunctions (fs: Function.t List.t): Function.t List.t =
1485 List.keepAllMap (fs, simplifyFunction)
1486 val functions = simplifyFunctions functions
1487 val program = Program.T {datatypes = datatypes,
1488 globals = globals,
1489 functions = functions,
1490 main = main}
1491 val () = destroy ()
1492 val () = Program.clearTop program
1493 in
1494 program
1495 end
1496
1497 end
mlton packaging