Commit | Line | Data |
---|---|---|
7f918cf1 CE |
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 |