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 RemoveUnused (S: SSA_TRANSFORM_STRUCTS): SSA_TRANSFORM = | |
11 | struct | |
12 | ||
13 | open S | |
14 | open Exp 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) vector, | |
91 | coned: Coned.t, | |
92 | deconed: Deconed.t, | |
93 | dummy: {con: Con.t, args: Type.t vector, | |
94 | exp: Exp.t}} | |
95 | ||
96 | fun layout (T {args, coned, deconed, ...}) = | |
97 | Layout.record [("args", Vector.layout (VarInfo.layout o #1) args), | |
98 | ("coned", Coned.layout coned), | |
99 | ("deconed", Deconed.layout deconed)] | |
100 | ||
101 | local | |
102 | fun make f (T r) = f r | |
103 | in | |
104 | val args = make #args | |
105 | val coned = make #coned | |
106 | val deconed = make #deconed | |
107 | val dummy = make #dummy | |
108 | end | |
109 | ||
110 | val con = Coned.con o coned | |
111 | val isConed = Coned.isConed o coned | |
112 | fun whenConed (ci, th) = Coned.whenConed (coned ci, th) | |
113 | ||
114 | val decon = Deconed.decon o deconed | |
115 | val isDeconed = Deconed.isDeconed o deconed | |
116 | ||
117 | fun new {args: Type.t vector, | |
118 | dummy: {con: Con.t, args: Type.t vector | |
119 | , exp: Exp.t}}: t = | |
120 | T {args = Vector.map (args, fn ty => (VarInfo.new ty, ty)), | |
121 | coned = Coned.new (), | |
122 | deconed = Deconed.new (), | |
123 | dummy = dummy} | |
124 | end | |
125 | ||
126 | structure TyconInfo = | |
127 | struct | |
128 | datatype t = T of {cons: Con.t vector, | |
129 | dummy: {con: Con.t, args: Type.t vector}, | |
130 | numCons: int ref, | |
131 | used: Used.t} | |
132 | ||
133 | fun layout (T {used, ...}) = | |
134 | Layout.record [("used", Used.layout used)] | |
135 | ||
136 | local | |
137 | fun make f (T r) = f r | |
138 | fun make' f = (make f, ! o (make f)) | |
139 | in | |
140 | val cons = make #cons | |
141 | val dummy = make #dummy | |
142 | val (numCons', numCons) = make' #numCons | |
143 | val used = make #used | |
144 | end | |
145 | ||
146 | fun new {cons: Con.t vector, | |
147 | dummy: {con: Con.t, args: Type.t vector}}: t = | |
148 | T {cons = cons, | |
149 | dummy = dummy, | |
150 | numCons = ref ~1, | |
151 | used = Used.new ()} | |
152 | end | |
153 | ||
154 | structure TypeInfo = | |
155 | struct | |
156 | datatype t = T of {deconed: bool ref, | |
157 | simplify: Type.t option ref, | |
158 | used: bool ref} | |
159 | ||
160 | local | |
161 | fun make f (T r) = f r | |
162 | fun make' f = (make f, ! o (make f)) | |
163 | in | |
164 | val (deconed', _) = make' #deconed | |
165 | val (simplify', _) = make' #simplify | |
166 | val (used', _) = make' #used | |
167 | end | |
168 | ||
169 | fun new (): t = T {deconed = ref false, | |
170 | simplify = ref NONE, | |
171 | used = ref false} | |
172 | end | |
173 | ||
174 | structure FuncInfo = | |
175 | struct | |
176 | datatype t = T of {args: (VarInfo.t * Type.t) vector, | |
177 | bugLabel: Label.t option ref, | |
178 | mayRaise: MayRaise.t, | |
179 | mayReturn: MayReturn.t, | |
180 | raiseLabel: Label.t option ref, | |
181 | raises: (VarInfo.t * Type.t) vector option, | |
182 | returnLabel: Label.t option ref, | |
183 | returns: (VarInfo.t * Type.t) vector option, | |
184 | used: Used.t, | |
185 | wrappers: Block.t list ref} | |
186 | ||
187 | fun layout (T {args, | |
188 | mayRaise, mayReturn, | |
189 | raises, returns, | |
190 | used, | |
191 | ...}) = | |
192 | Layout.record [("args", Vector.layout | |
193 | (Layout.tuple2 (VarInfo.layout, Type.layout)) | |
194 | args), | |
195 | ("mayRaise", MayRaise.layout mayRaise), | |
196 | ("mayReturn", MayReturn.layout mayReturn), | |
197 | ("raises", Option.layout | |
198 | (Vector.layout | |
199 | (Layout.tuple2 (VarInfo.layout, Type.layout))) | |
200 | raises), | |
201 | ("returns", Option.layout | |
202 | (Vector.layout | |
203 | (Layout.tuple2 (VarInfo.layout, Type.layout))) | |
204 | returns), | |
205 | ("used", Used.layout used)] | |
206 | ||
207 | local | |
208 | fun make f (T r) = f r | |
209 | fun make' f = (make f, ! o (make f)) | |
210 | in | |
211 | val args = make #args | |
212 | val mayRaise' = make #mayRaise | |
213 | val mayReturn' = make #mayReturn | |
214 | val raiseLabel = make #raiseLabel | |
215 | val raises = make #raises | |
216 | val returnLabel = make #returnLabel | |
217 | val returns = make #returns | |
218 | val used = make #used | |
219 | val (wrappers', wrappers) = make' #wrappers | |
220 | end | |
221 | ||
222 | val raisee = MayRaise.raisee o mayRaise' | |
223 | val mayRaise = MayRaise.mayRaise o mayRaise' | |
224 | fun whenRaises (fi, th) = MayRaise.whenRaises (mayRaise' fi, th) | |
225 | fun flowRaises (fi, fi') = MayRaise.<= (mayRaise' fi, mayRaise' fi') | |
226 | ||
227 | val return = MayReturn.return o mayReturn' | |
228 | fun whenReturns (fi, th) = MayReturn.whenReturns (mayReturn' fi, th) | |
229 | val mayReturn = MayReturn.mayReturn o mayReturn' | |
230 | fun flowReturns (fi, fi') = MayReturn.<= (mayReturn' fi, mayReturn' fi') | |
231 | ||
232 | val use = Used.use o used | |
233 | val isUsed = Used.isUsed o used | |
234 | fun whenUsed (fi, th) = Used.whenUsed (used fi, th) | |
235 | ||
236 | fun new {args: (VarInfo.t * Type.t) vector, | |
237 | raises: (VarInfo.t * Type.t) vector option, | |
238 | returns: (VarInfo.t * Type.t) vector option}: t = | |
239 | T {args = args, | |
240 | bugLabel = ref NONE, | |
241 | mayRaise = MayRaise.new (), | |
242 | mayReturn = MayReturn.new (), | |
243 | raiseLabel = ref NONE, | |
244 | raises = raises, | |
245 | returnLabel = ref NONE, | |
246 | returns = returns, | |
247 | used = Used.new (), | |
248 | wrappers = ref []} | |
249 | end | |
250 | ||
251 | structure LabelInfo = | |
252 | struct | |
253 | datatype t = T of {args: (VarInfo.t * Type.t) vector, | |
254 | func: FuncInfo.t, | |
255 | used: Used.t, | |
256 | wrappers: (Type.t vector * Label.t) list ref} | |
257 | ||
258 | fun layout (T {args, used, ...}) = | |
259 | Layout.record [("args", Vector.layout (VarInfo.layout o #1) args), | |
260 | ("used", Used.layout used)] | |
261 | ||
262 | fun new {args: (VarInfo.t * Type.t) vector, func: FuncInfo.t}: t = | |
263 | T {args = args, | |
264 | func = func, | |
265 | used = Used.new (), | |
266 | wrappers = ref []} | |
267 | ||
268 | local | |
269 | fun make f (T r) = f r | |
270 | fun make' f = (make f, ! o (make f)) | |
271 | in | |
272 | val args = make #args | |
273 | val func = make #func | |
274 | val used = make #used | |
275 | val (wrappers', wrappers) = make' #wrappers | |
276 | end | |
277 | ||
278 | val use = Used.use o used | |
279 | val isUsed = Used.isUsed o used | |
280 | fun whenUsed (li, th) = Used.whenUsed (used li, th) | |
281 | end | |
282 | ||
283 | ||
284 | fun transform (Program.T {datatypes, globals, functions, main}) = | |
285 | let | |
286 | val {get = conInfo: Con.t -> ConInfo.t, | |
287 | set = setConInfo, ...} = | |
288 | Property.getSetOnce | |
289 | (Con.plist, | |
290 | Property.initRaise ("RemoveUnused.conInfo", Con.layout)) | |
291 | fun newConInfo (con, args, dummy) = | |
292 | setConInfo (con, ConInfo.new {args = args, dummy = dummy}) | |
293 | ||
294 | val {get = tyconInfo: Tycon.t -> TyconInfo.t, | |
295 | set = setTyconInfo, ...} = | |
296 | Property.getSetOnce | |
297 | (Tycon.plist, | |
298 | Property.initRaise ("RemoveUnused.tyconInfo", Tycon.layout)) | |
299 | fun newTyconInfo (tycon, cons, dummy) = | |
300 | setTyconInfo (tycon, TyconInfo.new {cons = cons, dummy = dummy}) | |
301 | ||
302 | val {get = typeInfo: Type.t -> TypeInfo.t, | |
303 | destroy, ...} = | |
304 | Property.destGet | |
305 | (Type.plist, | |
306 | Property.initFun (fn _ => TypeInfo.new ())) | |
307 | ||
308 | val {get = varInfo: Var.t -> VarInfo.t, | |
309 | set = setVarInfo, ...} = | |
310 | Property.getSetOnce | |
311 | (Var.plist, | |
312 | Property.initRaise ("RemoveUnused.varInfo", Var.layout)) | |
313 | fun newVarInfo (var, ty) = | |
314 | setVarInfo (var, VarInfo.new ty) | |
315 | ||
316 | val {get = labelInfo: Label.t -> LabelInfo.t, | |
317 | set = setLabelInfo, ...} = | |
318 | Property.getSetOnce | |
319 | (Label.plist, | |
320 | Property.initRaise ("RemoveUnused.labelInfo", Label.layout)) | |
321 | ||
322 | val {get = funcInfo: Func.t -> FuncInfo.t, | |
323 | set = setFuncInfo, ...} = | |
324 | Property.getSetOnce | |
325 | (Func.plist, | |
326 | Property.initRaise ("RemoveUnused.funcInfo", Func.layout)) | |
327 | ||
328 | val usedTycon = TyconInfo.used o tyconInfo | |
329 | val useTycon = Used.use o usedTycon | |
330 | fun visitTycon (tycon: Tycon.t) = useTycon tycon | |
331 | val isUsedTycon = Used.isUsed o usedTycon | |
332 | ||
333 | fun visitType (ty: Type.t) = | |
334 | let | |
335 | val ti = typeInfo ty | |
336 | val used = TypeInfo.used' ti | |
337 | in | |
338 | if !used | |
339 | then () | |
340 | else let | |
341 | val () = used := true | |
342 | datatype z = datatype Type.dest | |
343 | val () = | |
344 | case Type.dest ty of | |
345 | Array ty => visitType ty | |
346 | | Datatype tycon => visitTycon tycon | |
347 | | Ref ty => visitType ty | |
348 | | Tuple tys => Vector.foreach (tys, visitType) | |
349 | | Vector ty => visitType ty | |
350 | | Weak ty => visitType ty | |
351 | | _ => () | |
352 | in | |
353 | () | |
354 | end | |
355 | end | |
356 | val visitTypeTh = fn ty => fn () => visitType ty | |
357 | ||
358 | val tyVar = VarInfo.ty o varInfo | |
359 | val usedVar = VarInfo.used o varInfo | |
360 | val useVar = Used.use o usedVar | |
361 | val isUsedVar = Used.isUsed o usedVar | |
362 | val whenUsedVar = fn (var, th) => VarInfo.whenUsed (varInfo var, th) | |
363 | fun flowVarInfoTyVarInfoTy ((vi, _), (vi', _)) = | |
364 | Used.<= (VarInfo.used vi, VarInfo.used vi') | |
365 | fun flowVarInfoTysVarInfoTys (xs, ys) = | |
366 | Vector.foreach2 (xs, ys, flowVarInfoTyVarInfoTy) | |
367 | fun flowVarInfoTyVar ((vi, _), x) = | |
368 | Used.<= (VarInfo.used vi, usedVar x) | |
369 | fun flowVarInfoTysVars (xs, ys) = | |
370 | Vector.foreach2 (xs, ys, flowVarInfoTyVar) | |
371 | ||
372 | val newVarInfo = fn (var, ty) => | |
373 | (newVarInfo (var, ty) | |
374 | ; whenUsedVar (var, visitTypeTh ty)) | |
375 | ||
376 | val visitLabelInfo = LabelInfo.use | |
377 | val visitLabelInfoTh = fn li => fn () => visitLabelInfo li | |
378 | val visitLabel = visitLabelInfo o labelInfo | |
379 | val visitLabelTh = fn l => fn () => visitLabel l | |
380 | val visitFuncInfo = FuncInfo.use | |
381 | val visitFunc = visitFuncInfo o funcInfo | |
382 | ||
383 | fun visitVar (x: Var.t) = useVar x | |
384 | fun visitVars (xs: Var.t Vector.t) = Vector.foreach (xs, visitVar) | |
385 | fun visitExp (e: Exp.t) = | |
386 | case e of | |
387 | ConApp {con, args} => | |
388 | let | |
389 | val ci = conInfo con | |
390 | val () = ConInfo.con ci | |
391 | val () = flowVarInfoTysVars (ConInfo.args ci, args) | |
392 | in | |
393 | () | |
394 | end | |
395 | | Const _ => () | |
396 | | PrimApp {prim, args, ...} => | |
397 | let | |
398 | val () = visitVars args | |
399 | datatype z = datatype Type.dest | |
400 | fun deconType (ty: Type.t) = | |
401 | let | |
402 | val ti = typeInfo ty | |
403 | val deconed = TypeInfo.deconed' ti | |
404 | in | |
405 | if !deconed | |
406 | then () | |
407 | else let | |
408 | val () = deconed := true | |
409 | val () = | |
410 | case Type.dest ty of | |
411 | Datatype t => | |
412 | Vector.foreach | |
413 | (TyconInfo.cons (tyconInfo t), | |
414 | fn con => deconCon con) | |
415 | | Tuple ts => Vector.foreach (ts, deconType) | |
416 | | Vector t => deconType t | |
417 | | _ => () | |
418 | in | |
419 | () | |
420 | end | |
421 | end | |
422 | and deconCon con = | |
423 | let | |
424 | val ci = conInfo con | |
425 | val () = ConInfo.decon ci | |
426 | val () = | |
427 | Vector.foreach | |
428 | (ConInfo.args ci, fn (x, t) => | |
429 | (VarInfo.use x | |
430 | ; deconType t)) | |
431 | in | |
432 | () | |
433 | end | |
434 | val () = | |
435 | case Prim.name prim of | |
436 | Prim.Name.MLton_eq => | |
437 | (* MLton_eq may be used on datatypes used as enums. *) | |
438 | deconType (tyVar (Vector.first args)) | |
439 | | Prim.Name.MLton_equal => | |
440 | (* MLton_equal will be expanded by poly-equal into uses | |
441 | * of constructors as patterns. | |
442 | *) | |
443 | deconType (tyVar (Vector.first args)) | |
444 | | Prim.Name.MLton_hash => | |
445 | (* MLton_hash will be expanded by poly-hash into uses | |
446 | * of constructors as patterns. | |
447 | *) | |
448 | deconType (tyVar (Vector.first args)) | |
449 | (* | |
450 | | Prim.Name.MLton_size => | |
451 | deconType (tyVar (Vector.first args)) | |
452 | *) | |
453 | | _ => () | |
454 | in | |
455 | () | |
456 | end | |
457 | | Profile _ => () | |
458 | | Select {tuple, ...} => visitVar tuple | |
459 | | Tuple xs => visitVars xs | |
460 | | Var x => visitVar x | |
461 | val visitExpTh = fn e => fn () => visitExp e | |
462 | fun maybeVisitVarExp (var, exp) = | |
463 | Option.app (var, fn var => | |
464 | VarInfo.whenUsed (varInfo var, visitExpTh exp)) | |
465 | fun visitStatement (Statement.T {exp, var, ty, ...}) = | |
466 | (Option.app (var, fn var => newVarInfo (var, ty)) | |
467 | ; if Exp.maySideEffect exp | |
468 | then (visitType ty | |
469 | ; visitExp exp) | |
470 | else maybeVisitVarExp (var, exp)) | |
471 | fun visitTransfer (t: Transfer.t, fi: FuncInfo.t) = | |
472 | case t of | |
473 | Arith {args, overflow, success, ty, ...} => | |
474 | (visitVars args | |
475 | ; visitLabel overflow | |
476 | ; visitLabel success | |
477 | ; visitType ty) | |
478 | | Bug => () | |
479 | | Call {args, func, return} => | |
480 | let | |
481 | datatype u = None | |
482 | | Caller | |
483 | | Some of Label.t | |
484 | val (cont, handler) = | |
485 | case return of | |
486 | Return.Dead => (None, None) | |
487 | | Return.NonTail {cont, handler} => | |
488 | (Some cont, | |
489 | case handler of | |
490 | Handler.Caller => Caller | |
491 | | Handler.Dead => None | |
492 | | Handler.Handle h => Some h) | |
493 | | Return.Tail => (Caller, Caller) | |
494 | val fi' = funcInfo func | |
495 | val () = flowVarInfoTysVars (FuncInfo.args fi', args) | |
496 | val () = | |
497 | case cont of | |
498 | None => () | |
499 | | Caller => | |
500 | let | |
501 | val () = | |
502 | case (FuncInfo.returns fi, | |
503 | FuncInfo.returns fi') of | |
504 | (SOME xts, SOME xts') => | |
505 | flowVarInfoTysVarInfoTys (xts, xts') | |
506 | | _ => () | |
507 | val () = FuncInfo.flowReturns (fi', fi) | |
508 | in | |
509 | () | |
510 | end | |
511 | | Some l => | |
512 | let | |
513 | val li = labelInfo l | |
514 | val () = | |
515 | Option.app | |
516 | (FuncInfo.returns fi', fn xts => | |
517 | flowVarInfoTysVarInfoTys | |
518 | (LabelInfo.args li, xts)) | |
519 | val () = | |
520 | FuncInfo.whenReturns | |
521 | (fi', visitLabelInfoTh li) | |
522 | in | |
523 | () | |
524 | end | |
525 | val () = | |
526 | case handler of | |
527 | None => () | |
528 | | Caller => | |
529 | let | |
530 | val () = | |
531 | case (FuncInfo.raises fi, | |
532 | FuncInfo.raises fi') of | |
533 | (SOME xts, SOME xts') => | |
534 | flowVarInfoTysVarInfoTys (xts, xts') | |
535 | | _ => () | |
536 | val () = FuncInfo.flowRaises (fi', fi) | |
537 | in | |
538 | () | |
539 | end | |
540 | | Some l => | |
541 | let | |
542 | val li = labelInfo l | |
543 | val () = | |
544 | Option.app | |
545 | (FuncInfo.raises fi', fn xts => | |
546 | flowVarInfoTysVarInfoTys | |
547 | (LabelInfo.args li, xts)) | |
548 | val () = | |
549 | FuncInfo.whenRaises (fi', visitLabelInfoTh li) | |
550 | in | |
551 | () | |
552 | end | |
553 | val () = visitFuncInfo fi' | |
554 | in | |
555 | () | |
556 | end | |
557 | | Case {test, cases, default} => | |
558 | let | |
559 | val () = visitVar test | |
560 | in | |
561 | case cases of | |
562 | Cases.Word (_, cs) => | |
563 | (Vector.foreach (cs, visitLabel o #2) | |
564 | ; Option.app (default, visitLabel)) | |
565 | | Cases.Con cases => | |
566 | if Vector.isEmpty cases | |
567 | then Option.app (default, visitLabel) | |
568 | else let | |
569 | val () = | |
570 | Vector.foreach | |
571 | (cases, fn (con, l) => | |
572 | let | |
573 | val ci = conInfo con | |
574 | val () = ConInfo.decon ci | |
575 | val li = labelInfo l | |
576 | val () = | |
577 | flowVarInfoTysVarInfoTys | |
578 | (LabelInfo.args li, ConInfo.args ci) | |
579 | val () = | |
580 | ConInfo.whenConed | |
581 | (ci, visitLabelTh l) | |
582 | in | |
583 | () | |
584 | end) | |
585 | val tycon = | |
586 | case Type.dest (tyVar test) of | |
587 | Type.Datatype tycon => tycon | |
588 | | _ => Error.bug "RemoveUnused.visitTransfer: Case:non-Datatype" | |
589 | val cons = TyconInfo.cons (tyconInfo tycon) | |
590 | in | |
591 | case default of | |
592 | NONE => () | |
593 | | SOME l => | |
594 | Vector.foreach | |
595 | (cons, fn con => | |
596 | if Vector.exists | |
597 | (cases, fn (c, _) => | |
598 | Con.equals(c, con)) | |
599 | then () | |
600 | else | |
601 | ConInfo.whenConed | |
602 | (conInfo con, visitLabelTh l)) | |
603 | end | |
604 | end | |
605 | | Goto {dst, args} => | |
606 | let | |
607 | val li = labelInfo dst | |
608 | val () = flowVarInfoTysVars (LabelInfo.args li, args) | |
609 | val () = visitLabelInfo li | |
610 | in | |
611 | () | |
612 | end | |
613 | | Raise xs => | |
614 | (FuncInfo.raisee fi | |
615 | ; flowVarInfoTysVars (valOf (FuncInfo.raises fi), xs)) | |
616 | | Return xs => | |
617 | (FuncInfo.return fi | |
618 | ; flowVarInfoTysVars (valOf (FuncInfo.returns fi), xs)) | |
619 | | Runtime {args, return, ...} => | |
620 | (visitVars args | |
621 | ; visitLabel return) | |
622 | fun visitBlock (Block.T {statements, transfer, ...}, fi: FuncInfo.t) = | |
623 | (Vector.foreach (statements, visitStatement) | |
624 | ; visitTransfer (transfer, fi)) | |
625 | val visitBlockTh = fn (b, fi) => fn () => visitBlock (b, fi) | |
626 | (* Visit all reachable expressions. *) | |
627 | val () = | |
628 | Vector.foreach | |
629 | (datatypes, fn Datatype.T {tycon, cons} => | |
630 | let | |
631 | val dummyCon = Con.newString "dummy" | |
632 | val dummyArgs = Vector.new0 () | |
633 | val dummy = {con = dummyCon, args = dummyArgs} | |
634 | val () = | |
635 | newTyconInfo | |
636 | (tycon, Vector.map (cons, fn {con, ...} => con), dummy) | |
637 | val dummyExp = ConApp {args = Vector.new0 (), | |
638 | con = dummyCon} | |
639 | val dummy = {con = dummyCon, args = dummyArgs, exp = dummyExp} | |
640 | val () = | |
641 | Vector.foreach | |
642 | (cons, fn {con, args} => | |
643 | newConInfo (con, args, dummy)) | |
644 | in | |
645 | () | |
646 | end) | |
647 | val () = | |
648 | let | |
649 | fun doitCon c = | |
650 | let | |
651 | val ci = conInfo c | |
652 | in | |
653 | ConInfo.con ci | |
654 | ; ConInfo.decon ci | |
655 | end | |
656 | in | |
657 | useTycon Tycon.bool | |
658 | ; doitCon Con.truee | |
659 | ; doitCon Con.falsee | |
660 | end | |
661 | val () = | |
662 | Vector.foreach (globals, visitStatement) | |
663 | val () = | |
664 | List.foreach | |
665 | (functions, fn function => | |
666 | let | |
667 | val {name, args, raises, returns, start, blocks, ...} = | |
668 | Function.dest function | |
669 | val () = Vector.foreach (args, newVarInfo) | |
670 | local | |
671 | fun doitVarTys vts = | |
672 | Vector.map (vts, fn (x, t) => (varInfo x, t)) | |
673 | fun doitTys ts = | |
674 | Vector.map (ts, fn t => (VarInfo.new t, t)) | |
675 | fun doitTys' ts = | |
676 | Option.map (ts, doitTys) | |
677 | in | |
678 | val fi = | |
679 | FuncInfo.new | |
680 | {args = doitVarTys args, | |
681 | raises = doitTys' raises, | |
682 | returns = doitTys' returns} | |
683 | end | |
684 | val () = setFuncInfo (name, fi) | |
685 | val () = FuncInfo.whenUsed (fi, visitLabelTh start) | |
686 | val () = | |
687 | Vector.foreach | |
688 | (blocks, fn block as Block.T {label, args, ...} => | |
689 | let | |
690 | val () = Vector.foreach (args, newVarInfo) | |
691 | local | |
692 | fun doitVarTys vts = | |
693 | Vector.map (vts, fn (x, t) => (varInfo x, t)) | |
694 | in | |
695 | val li = | |
696 | LabelInfo.new | |
697 | {args = doitVarTys args, | |
698 | func = fi} | |
699 | end | |
700 | val () = setLabelInfo (label, li) | |
701 | val () = LabelInfo.whenUsed (li, visitBlockTh (block, fi)) | |
702 | in | |
703 | () | |
704 | end) | |
705 | in | |
706 | () | |
707 | end) | |
708 | val () = visitFunc main | |
709 | ||
710 | (* Diagnostics *) | |
711 | val () = | |
712 | Control.diagnostics | |
713 | (fn display => | |
714 | let open Layout | |
715 | in | |
716 | Vector.foreach | |
717 | (datatypes, fn Datatype.T {tycon, cons} => | |
718 | display (seq [Tycon.layout tycon, | |
719 | str ": ", | |
720 | TyconInfo.layout (tyconInfo tycon), | |
721 | str ": ", | |
722 | Vector.layout | |
723 | (fn {con, ...} => | |
724 | seq [Con.layout con, | |
725 | str " ", | |
726 | ConInfo.layout (conInfo con)]) | |
727 | cons])); | |
728 | display (str "\n"); | |
729 | List.foreach | |
730 | (functions, fn f => | |
731 | let | |
732 | val {name, blocks, ...} = Function.dest f | |
733 | in | |
734 | display (seq [Func.layout name, | |
735 | str ": ", | |
736 | FuncInfo.layout (funcInfo name)]); | |
737 | Vector.foreach | |
738 | (blocks, fn Block.T {label, ...} => | |
739 | display (seq [Label.layout label, | |
740 | str ": ", | |
741 | LabelInfo.layout (labelInfo label)])); | |
742 | display (str "\n") | |
743 | end) | |
744 | end) | |
745 | ||
746 | (* Analysis is done, Now build the resulting program. *) | |
747 | fun getWrapperLabel (l: Label.t, | |
748 | args: (VarInfo.t * Type.t) vector) = | |
749 | let | |
750 | val li = labelInfo l | |
751 | in | |
752 | if Vector.forall2 (args, LabelInfo.args li, fn ((x, _), (y, _)) => | |
753 | VarInfo.isUsed x = VarInfo.isUsed y) | |
754 | then l | |
755 | else let | |
756 | val tys = | |
757 | Vector.keepAllMap (args, fn (x, ty) => | |
758 | if VarInfo.isUsed x | |
759 | then SOME ty | |
760 | else NONE) | |
761 | in | |
762 | case List.peek | |
763 | (LabelInfo.wrappers li, fn (args', _) => | |
764 | Vector.length args' = Vector.length tys | |
765 | andalso | |
766 | Vector.forall2 (args', tys, fn (ty', ty) => | |
767 | Type.equals (ty', ty))) of | |
768 | NONE => | |
769 | let | |
770 | val liArgs = LabelInfo.args li | |
771 | val l' = Label.newNoname () | |
772 | val (args', args'') = | |
773 | Vector.unzip | |
774 | (Vector.map2 | |
775 | (args, liArgs, fn ((x, ty), (y, _)) => | |
776 | let | |
777 | val z = Var.newNoname () | |
778 | in | |
779 | (if VarInfo.isUsed x | |
780 | then SOME (z, ty) else NONE, | |
781 | if VarInfo.isUsed y | |
782 | then SOME z else NONE) | |
783 | end)) | |
784 | val args' = | |
785 | Vector.keepAllMap (args', fn x => x) | |
786 | val (_, tys') = Vector.unzip args' | |
787 | val args'' = | |
788 | Vector.keepAllMap (args'', fn x => x) | |
789 | val block = | |
790 | Block.T {label = l', | |
791 | args = args', | |
792 | statements = Vector.new0 (), | |
793 | transfer = Goto {dst = l, | |
794 | args = args''}} | |
795 | val () = | |
796 | List.push (LabelInfo.wrappers' li, | |
797 | (tys', l')) | |
798 | val () = | |
799 | List.push (FuncInfo.wrappers' (LabelInfo.func li), | |
800 | block) | |
801 | in | |
802 | l' | |
803 | end | |
804 | | SOME (_, l') => l' | |
805 | end | |
806 | end | |
807 | val getConWrapperLabel = getWrapperLabel | |
808 | val getContWrapperLabel = getWrapperLabel | |
809 | val getHandlerWrapperLabel = getWrapperLabel | |
810 | fun getOriginalWrapperLabel l = | |
811 | getWrapperLabel | |
812 | (l, Vector.map (LabelInfo.args (labelInfo l), fn (_, t) => | |
813 | let | |
814 | val x = VarInfo.new t | |
815 | val () = VarInfo.use x | |
816 | in | |
817 | (x, t) | |
818 | end)) | |
819 | val getArithOverflowWrapperLabel = getOriginalWrapperLabel | |
820 | val getArithSuccessWrapperLabel = getOriginalWrapperLabel | |
821 | val getRuntimeWrapperLabel = getOriginalWrapperLabel | |
822 | fun getBugFunc (fi: FuncInfo.t): Label.t = | |
823 | (* Can't share the Bug block across different places because the | |
824 | * profile sourceInfo stack might be different. | |
825 | *) | |
826 | let | |
827 | val l = Label.newNoname () | |
828 | val block = Block.T {label = l, | |
829 | args = Vector.new0 (), | |
830 | statements = Vector.new0 (), | |
831 | transfer = Bug} | |
832 | val () = List.push (FuncInfo.wrappers' fi, block) | |
833 | in | |
834 | l | |
835 | end | |
836 | fun getReturnFunc (fi: FuncInfo.t): Label.t = | |
837 | let | |
838 | val r = FuncInfo.returnLabel fi | |
839 | in | |
840 | case !r of | |
841 | NONE => | |
842 | let | |
843 | val l = Label.newNoname () | |
844 | val returns = valOf (FuncInfo.returns fi) | |
845 | val args = | |
846 | Vector.keepAllMap | |
847 | (returns, fn (vi, ty) => | |
848 | if VarInfo.isUsed vi | |
849 | then SOME (Var.newNoname (), ty) | |
850 | else NONE) | |
851 | val xs = Vector.map (args, #1) | |
852 | val block = Block.T {label = l, | |
853 | args = args, | |
854 | statements = Vector.new0 (), | |
855 | transfer = Return xs} | |
856 | val () = r := SOME l | |
857 | val () = List.push (FuncInfo.wrappers' fi, block) | |
858 | val () = setLabelInfo (l, LabelInfo.new {func = fi, | |
859 | args = returns}) | |
860 | in | |
861 | l | |
862 | end | |
863 | | SOME l => l | |
864 | end | |
865 | fun getReturnContFunc (fi, args) = | |
866 | getWrapperLabel (getReturnFunc fi, args) | |
867 | fun getRaiseFunc (fi: FuncInfo.t): Label.t = | |
868 | let | |
869 | val r = FuncInfo.raiseLabel fi | |
870 | in | |
871 | case !r of | |
872 | NONE => | |
873 | let | |
874 | val l = Label.newNoname () | |
875 | val raises = valOf (FuncInfo.raises fi) | |
876 | val args = | |
877 | Vector.keepAllMap | |
878 | (raises, fn (vi, ty) => | |
879 | if VarInfo.isUsed vi | |
880 | then SOME (Var.newNoname (), ty) | |
881 | else NONE) | |
882 | val xs = Vector.map (args, #1) | |
883 | val block = Block.T {label = l, | |
884 | args = args, | |
885 | statements = Vector.new0 (), | |
886 | transfer = Raise xs} | |
887 | val () = r := SOME l | |
888 | val () = List.push (FuncInfo.wrappers' fi, block) | |
889 | val () = setLabelInfo (l, LabelInfo.new {func = fi, | |
890 | args = raises}) | |
891 | in | |
892 | l | |
893 | end | |
894 | | SOME l => l | |
895 | end | |
896 | fun getRaiseHandlerFunc (fi, args) = | |
897 | getWrapperLabel (getRaiseFunc fi, args) | |
898 | ||
899 | fun simplifyType (ty: Type.t): Type.t = | |
900 | let | |
901 | val ti = typeInfo ty | |
902 | val simplify = TypeInfo.simplify' ti | |
903 | in | |
904 | case !simplify of | |
905 | NONE => let | |
906 | datatype z = datatype Type.dest | |
907 | val ty = | |
908 | case Type.dest ty of | |
909 | Array ty => Type.array (simplifyType ty) | |
910 | | Ref ty => Type.reff (simplifyType ty) | |
911 | | Tuple tys => Type.tuple (Vector.map (tys, simplifyType)) | |
912 | | Vector ty => Type.vector (simplifyType ty) | |
913 | | Weak ty => Type.weak (simplifyType ty) | |
914 | | _ => ty | |
915 | in | |
916 | simplify := SOME ty | |
917 | ; ty | |
918 | end | |
919 | | SOME ty => ty | |
920 | end | |
921 | ||
922 | val datatypes = | |
923 | Vector.keepAllMap | |
924 | (datatypes, fn Datatype.T {tycon, cons} => | |
925 | if isUsedTycon tycon | |
926 | then let | |
927 | val needsDummy : bool ref = ref false | |
928 | val cons = | |
929 | Vector.keepAllMap | |
930 | (cons, fn {con, ...} => | |
931 | let | |
932 | val ci = conInfo con | |
933 | fun addDummy () = | |
934 | if !needsDummy | |
935 | then NONE | |
936 | else let | |
937 | val () = needsDummy := true | |
938 | in | |
939 | SOME (TyconInfo.dummy (tyconInfo tycon)) | |
940 | end | |
941 | in | |
942 | case (ConInfo.isConed ci, | |
943 | ConInfo.isDeconed ci) of | |
944 | (false, _) => NONE | |
945 | | (true, true) => | |
946 | SOME {args = Vector.keepAllMap | |
947 | (ConInfo.args ci, fn (x, ty) => | |
948 | if VarInfo.isUsed x | |
949 | then SOME (simplifyType ty) | |
950 | else NONE), | |
951 | con = con} | |
952 | | (true, false) => | |
953 | addDummy () | |
954 | end) | |
955 | val num = Vector.length cons | |
956 | val () = TyconInfo.numCons' (tyconInfo tycon) := num | |
957 | in | |
958 | SOME (Datatype.T {tycon = tycon, cons = cons}) | |
959 | end | |
960 | else NONE) | |
961 | ||
962 | fun simplifyExp (e: Exp.t): Exp.t = | |
963 | case e of | |
964 | ConApp {con, args} => | |
965 | let | |
966 | val ci = conInfo con | |
967 | in | |
968 | if ConInfo.isDeconed ci | |
969 | then let | |
970 | val ciArgs = | |
971 | ConInfo.args ci | |
972 | in | |
973 | ConApp {args = (Vector.keepAllMap2 | |
974 | (args, ciArgs, | |
975 | fn (x, (y, _)) => | |
976 | if VarInfo.isUsed y | |
977 | then SOME x | |
978 | else NONE)), | |
979 | con = con} | |
980 | end | |
981 | else #exp (ConInfo.dummy ci) | |
982 | end | |
983 | | PrimApp {prim, targs, args} => | |
984 | PrimApp {prim = prim, | |
985 | targs = Vector.map (targs, simplifyType), | |
986 | args = args} | |
987 | | _ => e | |
988 | fun simplifyStatement (s as Statement.T {var, ty, exp}) : Statement.t option = | |
989 | case exp of | |
990 | Profile _ => SOME s | |
991 | | _ => let | |
992 | fun doit' var = | |
993 | SOME (Statement.T | |
994 | {var = var, | |
995 | ty = simplifyType ty, | |
996 | exp = simplifyExp exp}) | |
997 | fun doit var' = | |
998 | if Exp.maySideEffect exp | |
999 | then doit' var | |
1000 | else if isSome var' | |
1001 | then doit' var' | |
1002 | else NONE | |
1003 | in | |
1004 | case var of | |
1005 | SOME var => if isUsedVar var | |
1006 | then doit (SOME var) | |
1007 | else doit NONE | |
1008 | | NONE => doit NONE | |
1009 | end | |
1010 | fun simplifyStatements (ss: Statement.t Vector.t) : Statement.t Vector.t = | |
1011 | Vector.keepAllMap (ss, simplifyStatement) | |
1012 | fun simplifyTransfer (t: Transfer.t, fi: FuncInfo.t): Transfer.t = | |
1013 | case t of | |
1014 | Arith {prim, args, overflow, success, ty} => | |
1015 | Arith {prim = prim, | |
1016 | args = args, | |
1017 | overflow = getArithOverflowWrapperLabel overflow, | |
1018 | success = getArithSuccessWrapperLabel success, | |
1019 | ty = simplifyType ty} | |
1020 | | Bug => Bug | |
1021 | | Call {func, args, return} => | |
1022 | let | |
1023 | val fi' = funcInfo func | |
1024 | datatype u = None | |
1025 | | Caller | |
1026 | | Some of Label.t | |
1027 | val (cont, handler) = | |
1028 | case return of | |
1029 | Return.Dead => (None, None) | |
1030 | | Return.NonTail {cont, handler} => | |
1031 | (Some cont, | |
1032 | case handler of | |
1033 | Handler.Caller => Caller | |
1034 | | Handler.Dead => None | |
1035 | | Handler.Handle h => Some h) | |
1036 | | Return.Tail => (Caller, Caller) | |
1037 | val cont = | |
1038 | if FuncInfo.mayReturn fi' | |
1039 | then case cont of | |
1040 | None => | |
1041 | Error.bug "RemoveUnused.simplifyTransfer: cont:None" | |
1042 | | Caller => | |
1043 | (if (case (FuncInfo.returns fi, | |
1044 | FuncInfo.returns fi') of | |
1045 | (SOME xts, SOME yts) => | |
1046 | Vector.forall2 | |
1047 | (xts, yts, fn ((x, _), (y, _)) => | |
1048 | VarInfo.isUsed x = VarInfo.isUsed y) | |
1049 | | _ => Error.bug "RemoveUnused.simplifyTransfer: cont:Caller") | |
1050 | then Caller | |
1051 | else Some (getReturnContFunc | |
1052 | (fi, valOf (FuncInfo.returns fi')))) | |
1053 | | Some l => | |
1054 | Some (getContWrapperLabel | |
1055 | (l, valOf (FuncInfo.returns fi'))) | |
1056 | else None | |
1057 | val handler = | |
1058 | if FuncInfo.mayRaise fi' | |
1059 | then (case handler of | |
1060 | None => | |
1061 | Error.bug "RemoveUnused.simplifyTransfer: handler:None" | |
1062 | | Caller => | |
1063 | (if (case (FuncInfo.raises fi, | |
1064 | FuncInfo.raises fi') of | |
1065 | (SOME xts, SOME yts) => | |
1066 | Vector.forall2 | |
1067 | (xts, yts, fn ((x, _), (y, _)) => | |
1068 | VarInfo.isUsed x = VarInfo.isUsed y) | |
1069 | | _ => Error.bug "RemoveUnused.simplifyTransfer: handler:Caller") | |
1070 | then Caller | |
1071 | else Some (getRaiseHandlerFunc | |
1072 | (fi, valOf (FuncInfo.raises fi')))) | |
1073 | | Some l => | |
1074 | Some (getHandlerWrapperLabel | |
1075 | (l, valOf (FuncInfo.raises fi')))) | |
1076 | else None | |
1077 | val return = | |
1078 | case (cont, handler) of | |
1079 | (None, None) => Return.Dead | |
1080 | | (None, Caller) => Return.Tail | |
1081 | | (None, Some h) => | |
1082 | Return.NonTail | |
1083 | {cont = getBugFunc fi, | |
1084 | handler = Handler.Handle h} | |
1085 | | (Caller, None) => Return.Tail | |
1086 | | (Caller, Caller) => Return.Tail | |
1087 | | (Caller, Some h) => | |
1088 | Return.NonTail | |
1089 | {cont = getReturnContFunc | |
1090 | (fi, valOf (FuncInfo.returns fi')), | |
1091 | handler = Handler.Handle h} | |
1092 | | (Some c, None) => | |
1093 | Return.NonTail | |
1094 | {cont = c, | |
1095 | handler = Handler.Dead} | |
1096 | | (Some c, Caller) => | |
1097 | Return.NonTail | |
1098 | {cont = c, | |
1099 | handler = Handler.Caller} | |
1100 | | (Some c, Some h) => | |
1101 | Return.NonTail | |
1102 | {cont = c, | |
1103 | handler = Handler.Handle h} | |
1104 | ||
1105 | val args = | |
1106 | Vector.keepAllMap2 | |
1107 | (args, FuncInfo.args fi', fn (x, (y, _)) => | |
1108 | if VarInfo.isUsed y | |
1109 | then SOME x | |
1110 | else NONE) | |
1111 | in | |
1112 | Call {func = func, | |
1113 | args = args, | |
1114 | return = return} | |
1115 | end | |
1116 | | Case {test, cases = Cases.Con cases, default} => | |
1117 | let | |
1118 | val cases = | |
1119 | Vector.keepAllMap | |
1120 | (cases, fn (con, l) => | |
1121 | let | |
1122 | val ci = conInfo con | |
1123 | in | |
1124 | if ConInfo.isConed ci | |
1125 | then SOME (con, getConWrapperLabel (l, ConInfo.args ci)) | |
1126 | else NONE | |
1127 | end) | |
1128 | fun keep default = Case {test = test, | |
1129 | cases = Cases.Con cases, | |
1130 | default = default} | |
1131 | fun none () = keep NONE | |
1132 | in | |
1133 | case default of | |
1134 | NONE => none () | |
1135 | | SOME l => if Vector.isEmpty cases | |
1136 | then if LabelInfo.isUsed (labelInfo l) | |
1137 | then Goto {dst = l, args = Vector.new0 ()} | |
1138 | else Bug | |
1139 | else let | |
1140 | val tycon = | |
1141 | case Type.dest (tyVar test) of | |
1142 | Type.Datatype tycon => tycon | |
1143 | | _ => Error.bug "RemoveUnused.simplifyTransfer: Case:non-Datatype" | |
1144 | val numCons = TyconInfo.numCons (tyconInfo tycon) | |
1145 | in | |
1146 | if Vector.length cases = numCons | |
1147 | then none () | |
1148 | else keep (SOME l) | |
1149 | end | |
1150 | end | |
1151 | | Case {test, cases, default} => | |
1152 | Case {test = test, | |
1153 | cases = cases, | |
1154 | default = default} | |
1155 | | Goto {dst, args} => | |
1156 | Goto {dst = dst, | |
1157 | args = (Vector.keepAllMap2 | |
1158 | (args, LabelInfo.args (labelInfo dst), | |
1159 | fn (x, (y, _)) => if VarInfo.isUsed y | |
1160 | then SOME x | |
1161 | else NONE))} | |
1162 | | Raise xs => | |
1163 | Raise (Vector.keepAllMap2 | |
1164 | (xs, valOf (FuncInfo.raises fi), | |
1165 | fn (x, (y, _)) => if VarInfo.isUsed y | |
1166 | then SOME x | |
1167 | else NONE)) | |
1168 | | Return xs => | |
1169 | Return (Vector.keepAllMap2 | |
1170 | (xs, valOf (FuncInfo.returns fi), | |
1171 | fn (x, (y, _)) => if VarInfo.isUsed y | |
1172 | then SOME x | |
1173 | else NONE)) | |
1174 | | Runtime {prim, args, return} => | |
1175 | Runtime {prim = prim, | |
1176 | args = args, | |
1177 | return = getRuntimeWrapperLabel return} | |
1178 | val simplifyTransfer = | |
1179 | Trace.trace | |
1180 | ("RemoveUnused.simplifyTransfer", | |
1181 | Layout.tuple2 (Transfer.layout, FuncInfo.layout), Transfer.layout) | |
1182 | simplifyTransfer | |
1183 | fun simplifyBlock (Block.T {label, args, statements, transfer}): Block.t option = | |
1184 | let | |
1185 | val li = labelInfo label | |
1186 | in | |
1187 | if LabelInfo.isUsed li | |
1188 | then let | |
1189 | val args = | |
1190 | Vector.keepAllMap2 | |
1191 | (LabelInfo.args li, args, fn ((vi, _), (x, ty)) => | |
1192 | if VarInfo.isUsed vi | |
1193 | then SOME (x, simplifyType ty) | |
1194 | else NONE) | |
1195 | val statements = simplifyStatements statements | |
1196 | val transfer = | |
1197 | simplifyTransfer (transfer, LabelInfo.func li) | |
1198 | in | |
1199 | SOME (Block.T {label = label, | |
1200 | args = args, | |
1201 | statements = statements, | |
1202 | transfer = transfer}) | |
1203 | end | |
1204 | else NONE | |
1205 | end | |
1206 | fun simplifyBlocks (bs: Block.t Vector.t): Block.t Vector.t = | |
1207 | Vector.keepAllMap (bs, simplifyBlock) | |
1208 | val globals = simplifyStatements globals | |
1209 | val shrink = shrinkFunction {globals = globals} | |
1210 | fun simplifyFunction (f: Function.t): Function.t option = | |
1211 | let | |
1212 | val {args, blocks, mayInline, name, start, ...} = Function.dest f | |
1213 | val fi = funcInfo name | |
1214 | in | |
1215 | if FuncInfo.isUsed fi | |
1216 | then let | |
1217 | val args = | |
1218 | Vector.keepAllMap2 | |
1219 | (FuncInfo.args fi, args, fn ((vi, _), (x, ty)) => | |
1220 | if VarInfo.isUsed vi | |
1221 | then SOME (x, simplifyType ty) | |
1222 | else NONE) | |
1223 | val blocks = simplifyBlocks blocks | |
1224 | val wrappers = Vector.fromList (FuncInfo.wrappers fi) | |
1225 | val blocks = Vector.concat [wrappers, blocks] | |
1226 | val returns = | |
1227 | case FuncInfo.returns fi of | |
1228 | NONE => NONE | |
1229 | | SOME xts => | |
1230 | if FuncInfo.mayReturn fi | |
1231 | then SOME (Vector.keepAllMap | |
1232 | (xts, fn (x, ty) => | |
1233 | if VarInfo.isUsed x | |
1234 | then SOME (simplifyType ty) | |
1235 | else NONE)) | |
1236 | else NONE | |
1237 | val raises = | |
1238 | case FuncInfo.raises fi of | |
1239 | NONE => NONE | |
1240 | | SOME xts => | |
1241 | if FuncInfo.mayRaise fi | |
1242 | then SOME (Vector.keepAllMap | |
1243 | (xts, fn (x, ty) => | |
1244 | if VarInfo.isUsed x | |
1245 | then SOME (simplifyType ty) | |
1246 | else NONE)) | |
1247 | else NONE | |
1248 | in | |
1249 | SOME (shrink (Function.new {args = args, | |
1250 | blocks = blocks, | |
1251 | mayInline = mayInline, | |
1252 | name = name, | |
1253 | raises = raises, | |
1254 | returns = returns, | |
1255 | start = start})) | |
1256 | end | |
1257 | else NONE | |
1258 | end | |
1259 | fun simplifyFunctions (fs: Function.t List.t): Function.t List.t = | |
1260 | List.keepAllMap (fs, simplifyFunction) | |
1261 | val functions = simplifyFunctions functions | |
1262 | val program = Program.T {datatypes = datatypes, | |
1263 | globals = globals, | |
1264 | functions = functions, | |
1265 | main = main} | |
1266 | val () = destroy () | |
1267 | val () = Program.clearTop program | |
1268 | in | |
1269 | program | |
1270 | end | |
1271 | ||
1272 | end |