Commit | Line | Data |
---|---|---|
7f918cf1 CE |
1 | (* Copyright (C) 2009 Matthew Fluet. |
2 | * Copyright (C) 1999-2005, 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 | (* This pass must happen before polymorphic equality is implemented because | |
11 | * 1. it will make polymorphic equality faster because some types are simpler | |
12 | * 2. it removes uses of polymorphic equality that must return true | |
13 | * | |
14 | * This pass computes a "cardinality" of each datatype, which is an | |
15 | * abstraction of the number of values of the datatype. | |
16 | * Zero means the datatype has no values (except for bottom). | |
17 | * One means the datatype has one values (except for bottom). | |
18 | * Many means the datatype has many values. | |
19 | * | |
20 | * This pass removes all datatypes whose cardinality is Zero or One | |
21 | * and removes | |
22 | * components of tuples | |
23 | * function args | |
24 | * constructor args | |
25 | * which are such datatypes. | |
26 | * | |
27 | * This pass marks constructors as one of | |
28 | * Useless: it never appears in a ConApp. | |
29 | * Transparent: it is the only variant in its datatype | |
30 | * and its argument type does not contain any uses of | |
31 | * Tycon.array or Tycon.vector. | |
32 | * Useful: otherwise | |
33 | * This pass also removes Useless and Transparent constructors. | |
34 | * | |
35 | * We must keep track of Transparent constructors whose argument type | |
36 | * uses Tycon.array because of datatypes like the following: | |
37 | * datatype t = T of t array | |
38 | * Such a datatype has Cardinality.Many, but we cannot eliminate | |
39 | * the datatype and replace the lhs by the rhs, i.e. we must keep the | |
40 | * circularity around. | |
41 | * Must do similar things for vectors. | |
42 | * | |
43 | * Also, to eliminate as many Transparent constructors as possible, for | |
44 | * something like the following, | |
45 | * datatype t = T of u array | |
46 | * and u = U of t vector | |
47 | * we (arbitrarily) expand one of the datatypes first. | |
48 | * The result will be something like | |
49 | * datatype u = U of u array array | |
50 | * where all uses of t are replaced by u array. | |
51 | *) | |
52 | ||
53 | functor SimplifyTypes (S: SSA_TRANSFORM_STRUCTS): SSA_TRANSFORM = | |
54 | struct | |
55 | ||
56 | open S | |
57 | open Exp Transfer | |
58 | structure Cardinality = | |
59 | struct | |
60 | datatype t = Zero | One | Many | |
61 | ||
62 | fun layout c = | |
63 | Layout.str (case c of | |
64 | Zero => "zero" | |
65 | | One => "one" | |
66 | | Many => "many") | |
67 | ||
68 | val equals: t * t -> bool = op = | |
69 | end | |
70 | ||
71 | structure ConRep = | |
72 | struct | |
73 | datatype t = | |
74 | Useless | |
75 | | Transparent | |
76 | | Useful | |
77 | ||
78 | val isUseful = | |
79 | fn Useful => true | |
80 | | _ => false | |
81 | ||
82 | val isUseless = | |
83 | fn Useless => true | |
84 | | _ => false | |
85 | ||
86 | val toString = | |
87 | fn Useless => "useless" | |
88 | | Transparent => "transparent" | |
89 | | Useful => "useful" | |
90 | ||
91 | val layout = Layout.str o toString | |
92 | end | |
93 | ||
94 | structure Result = | |
95 | struct | |
96 | datatype 'a t = | |
97 | Bugg | |
98 | | Delete | |
99 | | Keep of 'a | |
100 | ||
101 | fun layout layoutX = | |
102 | let open Layout | |
103 | in fn Bugg => str "Bug" | |
104 | | Delete => str "Delete" | |
105 | | Keep x => seq [str "Keep ", layoutX x] | |
106 | end | |
107 | end | |
108 | ||
109 | fun transform (Program.T {datatypes, globals, functions, main}) = | |
110 | let | |
111 | val {get = conInfo: Con.t -> {rep: ConRep.t ref, | |
112 | args: Type.t vector}, | |
113 | set = setConInfo, ...} = | |
114 | Property.getSetOnce | |
115 | (Con.plist, Property.initRaise ("SimplifyTypes.conInfo", Con.layout)) | |
116 | val conInfo = | |
117 | Trace.trace ("SimplifyTypes.conInfo", | |
118 | Con.layout, | |
119 | fn {rep, args} => | |
120 | Layout.record [("rep", ConRep.layout (!rep)), | |
121 | ("args", Vector.layout Type.layout args)]) | |
122 | conInfo | |
123 | val conRep = ! o #rep o conInfo | |
124 | val conArgs = #args o conInfo | |
125 | fun setConRep (con, r) = #rep (conInfo con) := r | |
126 | val setConRep = | |
127 | Trace.trace2 | |
128 | ("SimplifyTypes.setConRep", Con.layout, ConRep.layout, Unit.layout) | |
129 | setConRep | |
130 | val conIsUseful = ConRep.isUseful o conRep | |
131 | val conIsUseful = | |
132 | Trace.trace | |
133 | ("SimplifyTypes.conIsUseful", Con.layout, Bool.layout) | |
134 | conIsUseful | |
135 | (* Initialize conInfo *) | |
136 | val _ = | |
137 | Vector.foreach | |
138 | (datatypes, fn Datatype.T {cons, ...} => | |
139 | Vector.foreach (cons, fn {con, args} => | |
140 | setConInfo (con, {rep = ref ConRep.Useless, | |
141 | args = args}))) | |
142 | val {get = tyconReplacement: Tycon.t -> Type.t option, | |
143 | set = setTyconReplacement, ...} = | |
144 | Property.getSet (Tycon.plist, Property.initConst NONE) | |
145 | val setTyconReplacement = fn (c, t) => setTyconReplacement (c, SOME t) | |
146 | val {get = tyconInfo: Tycon.t -> { | |
147 | cardinality: Cardinality.t ref, | |
148 | cons: { | |
149 | con: Con.t, | |
150 | args: Type.t vector | |
151 | } vector ref, | |
152 | numCons: int ref, | |
153 | (* tycons whose cardinality depends on mine *) | |
154 | dependents: Tycon.t list ref, | |
155 | isOnWorklist: bool ref | |
156 | }, | |
157 | set = setTyconInfo, ...} = | |
158 | Property.getSetOnce | |
159 | (Tycon.plist, Property.initRaise ("SimplifyTypes.tyconInfo", Tycon.layout)) | |
160 | ||
161 | local | |
162 | fun make sel = (! o sel o tyconInfo, | |
163 | fn (t, x) => sel (tyconInfo t) := x) | |
164 | in | |
165 | val (tyconNumCons, setTyconNumCons) = make #numCons | |
166 | val (tyconCardinality, _) = make #cardinality | |
167 | end | |
168 | val _ = | |
169 | Vector.foreach | |
170 | (datatypes, fn Datatype.T {tycon, cons} => | |
171 | setTyconInfo (tycon, { | |
172 | cardinality = ref Cardinality.Zero, | |
173 | numCons = ref 0, | |
174 | cons = ref cons, | |
175 | dependents = ref [], | |
176 | isOnWorklist = ref false | |
177 | })) | |
178 | (* Tentatively mark all constructors appearing in a ConApp as Useful | |
179 | * (some may later be marked as Transparent). | |
180 | *) | |
181 | val _ = | |
182 | let | |
183 | fun handleStatement (Statement.T {exp, ...}) = | |
184 | case exp of | |
185 | ConApp {con, ...} => setConRep (con, ConRep.Useful) | |
186 | | _ => () | |
187 | (* Booleans are special because they are generated by primitives. *) | |
188 | val _ = | |
189 | List.foreach ([Con.truee, Con.falsee], fn c => | |
190 | setConRep (c, ConRep.Useful)) | |
191 | val _ = Vector.foreach (globals, handleStatement) | |
192 | val _ = List.foreach | |
193 | (functions, fn f => | |
194 | Vector.foreach | |
195 | (Function.blocks f, fn Block.T {statements, ...} => | |
196 | Vector.foreach (statements, handleStatement))) | |
197 | in () | |
198 | end | |
199 | ||
200 | (* Remove useless constructors from datatypes. | |
201 | * Remove datatypes which have no cons. | |
202 | *) | |
203 | val datatypes = | |
204 | Vector.keepAllMap | |
205 | (datatypes, fn Datatype.T {tycon, cons} => | |
206 | let | |
207 | val cons = Vector.keepAll (cons, conIsUseful o #con) | |
208 | in | |
209 | if Vector.isEmpty cons | |
210 | then (setTyconReplacement (tycon, Type.unit) | |
211 | ; NONE) | |
212 | else (#cons (tyconInfo tycon) := cons | |
213 | ; SOME (Datatype.T {tycon = tycon, cons = cons})) | |
214 | end) | |
215 | (* Build the dependents for each tycon. *) | |
216 | val _ = | |
217 | Vector.foreach | |
218 | (datatypes, fn Datatype.T {tycon, cons} => | |
219 | let | |
220 | datatype z = datatype Type.dest | |
221 | val {get = setTypeDependents, destroy = destroyTypeDependents} = | |
222 | Property.destGet | |
223 | (Type.plist, | |
224 | Property.initRec | |
225 | (fn (t, setTypeDependents) => | |
226 | case Type.dest t of | |
227 | Array t => setTypeDependents t | |
228 | | CPointer => () | |
229 | | Datatype tycon' => | |
230 | List.push (#dependents (tyconInfo tycon'), tycon) | |
231 | | IntInf => () | |
232 | | Real _ => () | |
233 | | Ref t => setTypeDependents t | |
234 | | Thread => () | |
235 | | Tuple ts => Vector.foreach (ts, setTypeDependents) | |
236 | | Vector t => setTypeDependents t | |
237 | | Weak t => setTypeDependents t | |
238 | | Word _ => ())) | |
239 | val _ = | |
240 | Vector.foreach (cons, fn {args, ...} => | |
241 | Vector.foreach (args, setTypeDependents)) | |
242 | val _ = destroyTypeDependents () | |
243 | in () | |
244 | end) | |
245 | (* diagnostic *) | |
246 | val _ = | |
247 | Control.diagnostics | |
248 | (fn display => | |
249 | let open Layout | |
250 | in Vector.foreach | |
251 | (datatypes, fn Datatype.T {tycon, ...} => | |
252 | display (seq [str "dependents of ", | |
253 | Tycon.layout tycon, | |
254 | str " = ", | |
255 | List.layout Tycon.layout | |
256 | (!(#dependents (tyconInfo tycon)))])) | |
257 | end) | |
258 | ||
259 | local open Type Cardinality | |
260 | in | |
261 | fun typeCardinality t = | |
262 | case dest t of | |
263 | Datatype tycon => tyconCardinality tycon | |
264 | | Ref t => pointerCardinality t | |
265 | | Tuple ts => tupleCardinality ts | |
266 | | Weak t => pointerCardinality t | |
267 | | _ => Many | |
268 | and pointerCardinality (t: Type.t) = | |
269 | case typeCardinality t of | |
270 | Zero => Zero | |
271 | | _ => Many | |
272 | and tupleCardinality (ts: Type.t vector) = | |
273 | Exn.withEscape | |
274 | (fn escape => | |
275 | (Vector.foreach (ts, fn t => | |
276 | let val c = typeCardinality t | |
277 | in case c of | |
278 | Many => escape Many | |
279 | | One => () | |
280 | | Zero => escape Zero | |
281 | end) | |
282 | ; One)) | |
283 | end | |
284 | fun conCardinality {args, con = _} = tupleCardinality args | |
285 | (* Compute the tycon cardinalities with a fixed point, | |
286 | * initially assuming every datatype tycon cardinality is Zero. | |
287 | *) | |
288 | val _ = | |
289 | let | |
290 | (* list of datatype tycons whose cardinality has not yet stabilized *) | |
291 | val worklist = | |
292 | ref (Vector.fold | |
293 | (datatypes, [], fn (Datatype.T {tycon, ...}, ac) => | |
294 | tycon :: ac)) | |
295 | fun loop () = | |
296 | case !worklist of | |
297 | [] => () | |
298 | | tycon :: tycons => | |
299 | (worklist := tycons | |
300 | ; let | |
301 | val {cons, cardinality, dependents, isOnWorklist, | |
302 | ...} = tyconInfo tycon | |
303 | val c = | |
304 | Exn.withEscape | |
305 | (fn escape => | |
306 | let datatype z = datatype Cardinality.t | |
307 | in Vector.fold | |
308 | (!cons, Zero, fn (c, ac) => | |
309 | case conCardinality c of | |
310 | Many => escape Many | |
311 | | One => (case ac of | |
312 | Many => Error.bug "SimplifyTypes.simplify: Many" | |
313 | | One => escape Many | |
314 | | Zero => One) | |
315 | | Zero => ac) | |
316 | end) | |
317 | in isOnWorklist := false | |
318 | ; if Cardinality.equals (c, !cardinality) | |
319 | then () | |
320 | else (cardinality := c | |
321 | ; (List.foreach | |
322 | (!dependents, fn tycon => | |
323 | let | |
324 | val {isOnWorklist, ...} = | |
325 | tyconInfo tycon | |
326 | in if !isOnWorklist | |
327 | then () | |
328 | else (isOnWorklist := true | |
329 | ; List.push (worklist, tycon)) | |
330 | end))) | |
331 | end | |
332 | ; loop ()) | |
333 | in loop () | |
334 | end | |
335 | (* diagnostic *) | |
336 | val _ = | |
337 | Control.diagnostics | |
338 | (fn display => | |
339 | let open Layout | |
340 | in Vector.foreach | |
341 | (datatypes, fn Datatype.T {tycon, ...} => | |
342 | display (seq [str "cardinality of ", | |
343 | Tycon.layout tycon, | |
344 | str " = ", | |
345 | Cardinality.layout (tyconCardinality tycon)])) | |
346 | end) | |
347 | fun transparent (tycon, con, args) = | |
348 | (setTyconReplacement (tycon, Type.tuple args) | |
349 | ; setConRep (con, ConRep.Transparent) | |
350 | ; setTyconNumCons (tycon, 1)) | |
351 | (* "unary" is datatypes with one constructor whose rhs contains an | |
352 | * array (or vector) type. | |
353 | * For datatypes with one variant not containing an array type, eliminate | |
354 | * the datatype. | |
355 | *) | |
356 | fun containsArrayOrVector (ty: Type.t): bool = | |
357 | let | |
358 | datatype z = datatype Type.dest | |
359 | fun loop t = | |
360 | case Type.dest t of | |
361 | Array _ => true | |
362 | | Ref t => loop t | |
363 | | Tuple ts => Vector.exists (ts, loop) | |
364 | | Vector _ => true | |
365 | | Weak t => loop t | |
366 | | _ => false | |
367 | in loop ty | |
368 | end | |
369 | val (datatypes, unary) = | |
370 | Vector.fold | |
371 | (datatypes, ([], []), fn (Datatype.T {tycon, cons}, (datatypes, unary)) => | |
372 | let | |
373 | (* remove all cons with zero cardinality and mark them as useless *) | |
374 | val cons = | |
375 | Vector.keepAllMap | |
376 | (cons, fn c as {con, ...} => | |
377 | case conCardinality c of | |
378 | Cardinality.Zero => (setConRep (con, ConRep.Useless) | |
379 | ; NONE) | |
380 | | _ => SOME c) | |
381 | in case Vector.length cons of | |
382 | 0 => (setTyconNumCons (tycon, 0) | |
383 | ; setTyconReplacement (tycon, Type.unit) | |
384 | ; (datatypes, unary)) | |
385 | | 1 => | |
386 | let | |
387 | val {con, args} = Vector.first cons | |
388 | in | |
389 | if Vector.exists (args, containsArrayOrVector) | |
390 | then (datatypes, | |
391 | {tycon = tycon, con = con, args = args} :: unary) | |
392 | else (transparent (tycon, con, args) | |
393 | ; (datatypes, unary)) | |
394 | end | |
395 | | _ => (Datatype.T {tycon = tycon, cons = cons} :: datatypes, | |
396 | unary) | |
397 | end) | |
398 | fun containsTycon (ty: Type.t, tyc: Tycon.t): bool = | |
399 | let | |
400 | datatype z = datatype Type.dest | |
401 | val {get = containsTycon, destroy = destroyContainsTycon} = | |
402 | Property.destGet | |
403 | (Type.plist, | |
404 | Property.initRec | |
405 | (fn (t, containsTycon) => | |
406 | case Type.dest t of | |
407 | Array t => containsTycon t | |
408 | | Datatype tyc' => | |
409 | (case tyconReplacement tyc' of | |
410 | NONE => Tycon.equals (tyc, tyc') | |
411 | | SOME t => containsTycon t) | |
412 | | Tuple ts => Vector.exists (ts, containsTycon) | |
413 | | Ref t => containsTycon t | |
414 | | Vector t => containsTycon t | |
415 | | Weak t => containsTycon t | |
416 | | _ => false)) | |
417 | val res = containsTycon ty | |
418 | val () = destroyContainsTycon () | |
419 | in res | |
420 | end | |
421 | (* Keep the circular transparent tycons, ditch the rest. *) | |
422 | val datatypes = | |
423 | List.fold | |
424 | (unary, datatypes, fn ({tycon, con, args}, accum) => | |
425 | if Vector.exists (args, fn arg => containsTycon (arg, tycon)) | |
426 | then Datatype.T {tycon = tycon, | |
427 | cons = Vector.new1 {con = con, args = args}} | |
428 | :: accum | |
429 | else (transparent (tycon, con, args) | |
430 | ; accum)) | |
431 | fun makeKeepSimplifyTypes simplifyType ts = | |
432 | Vector.keepAllMap (ts, fn t => | |
433 | let | |
434 | val t = simplifyType t | |
435 | in | |
436 | if Type.isUnit t | |
437 | then NONE | |
438 | else SOME t | |
439 | end) | |
440 | val {get = simplifyType, destroy = destroySimplifyType} = | |
441 | Property.destGet | |
442 | (Type.plist, | |
443 | Property.initRec | |
444 | (fn (t, simplifyType) => | |
445 | let | |
446 | val keepSimplifyTypes = makeKeepSimplifyTypes simplifyType | |
447 | open Type | |
448 | in case dest t of | |
449 | Array t => array (simplifyType t) | |
450 | | Datatype tycon => | |
451 | (case tyconReplacement tycon of | |
452 | SOME t => | |
453 | let | |
454 | val t = simplifyType t | |
455 | val _ = setTyconReplacement (tycon, t) | |
456 | in | |
457 | t | |
458 | end | |
459 | | NONE => t) | |
460 | | Ref t => reff (simplifyType t) | |
461 | | Tuple ts => Type.tuple (keepSimplifyTypes ts) | |
462 | | Vector t => vector (simplifyType t) | |
463 | | Weak t => weak (simplifyType t) | |
464 | | _ => t | |
465 | end)) | |
466 | val simplifyType = | |
467 | Trace.trace ("SimplifyTypes.simplifyType", Type.layout, Type.layout) | |
468 | simplifyType | |
469 | fun simplifyTypes ts = Vector.map (ts, simplifyType) | |
470 | val keepSimplifyTypes = makeKeepSimplifyTypes simplifyType | |
471 | (* Simplify constructor argument types. *) | |
472 | val datatypes = | |
473 | Vector.fromListMap | |
474 | (datatypes, fn Datatype.T {tycon, cons} => | |
475 | (setTyconNumCons (tycon, Vector.length cons) | |
476 | ; Datatype.T {tycon = tycon, | |
477 | cons = Vector.map (cons, fn {con, args} => | |
478 | {con = con, | |
479 | args = keepSimplifyTypes args})})) | |
480 | val unitVar = Var.newNoname () | |
481 | val {get = varInfo: Var.t -> Type.t, set = setVarInfo, ...} = | |
482 | Property.getSetOnce | |
483 | (Var.plist, Property.initRaise ("varInfo", Var.layout)) | |
484 | fun simplifyVarType (x: Var.t, t: Type.t): Type.t = | |
485 | (setVarInfo (x, t) | |
486 | ; simplifyType t) | |
487 | fun simplifyMaybeVarType (x: Var.t option, t: Type.t): Type.t = | |
488 | case x of | |
489 | SOME x => simplifyVarType (x, t) | |
490 | | NONE => simplifyType t | |
491 | val oldVarType = varInfo | |
492 | val newVarType = simplifyType o oldVarType | |
493 | fun simplifyVar (x: Var.t): Var.t = | |
494 | if Type.isUnit (newVarType x) | |
495 | then unitVar | |
496 | else x | |
497 | val varIsUseless = Type.isUnit o newVarType | |
498 | fun removeUselessVars xs = Vector.keepAll (xs, not o varIsUseless) | |
499 | fun tuple xs = | |
500 | let | |
501 | val xs = removeUselessVars xs | |
502 | in if 1 = Vector.length xs | |
503 | then Var (Vector.first xs) | |
504 | else Tuple xs | |
505 | end | |
506 | fun simplifyFormals xts = | |
507 | Vector.keepAllMap | |
508 | (xts, fn (x, t) => | |
509 | let val t = simplifyVarType (x, t) | |
510 | in if Type.isUnit t | |
511 | then NONE | |
512 | else SOME (x, t) | |
513 | end) | |
514 | val typeIsUseful = not o Type.isUnit o simplifyType | |
515 | datatype result = datatype Result.t | |
516 | fun simplifyExp (e: Exp.t): Exp.t result = | |
517 | case e of | |
518 | ConApp {con, args} => | |
519 | (case conRep con of | |
520 | ConRep.Transparent => Keep (tuple args) | |
521 | | ConRep.Useful => | |
522 | Keep (ConApp {con = con, | |
523 | args = removeUselessVars args}) | |
524 | | ConRep.Useless => Bugg) | |
525 | | PrimApp {prim, targs, args} => | |
526 | Keep | |
527 | (let | |
528 | fun normal () = | |
529 | PrimApp {prim = prim, | |
530 | targs = simplifyTypes targs, | |
531 | args = Vector.map (args, simplifyVar)} | |
532 | fun equal () = | |
533 | if 2 = Vector.length args | |
534 | then | |
535 | if varIsUseless (Vector.first args) | |
536 | then ConApp {con = Con.truee, | |
537 | args = Vector.new0 ()} | |
538 | else normal () | |
539 | else Error.bug "SimplifyTypes.simplifyExp: strange eq/equal PrimApp" | |
540 | open Prim.Name | |
541 | in case Prim.name prim of | |
542 | MLton_eq => equal () | |
543 | | MLton_equal => equal () | |
544 | | _ => normal () | |
545 | end) | |
546 | | Select {tuple, offset} => | |
547 | let | |
548 | val ts = Type.deTuple (oldVarType tuple) | |
549 | in Vector.fold' | |
550 | (ts, 0, (offset, 0), fn (pos, t, (n, offset)) => | |
551 | if n = 0 | |
552 | then (Vector.Done | |
553 | (Keep | |
554 | (if offset = 0 | |
555 | andalso not (Vector.existsR | |
556 | (ts, pos + 1, Vector.length ts, | |
557 | typeIsUseful)) | |
558 | then Var tuple | |
559 | else Select {tuple = tuple, | |
560 | offset = offset}))) | |
561 | else Vector.Continue (n - 1, | |
562 | if typeIsUseful t | |
563 | then offset + 1 | |
564 | else offset), | |
565 | fn _ => Error.bug "SimplifyTypes.simplifyExp: Select:newOffset") | |
566 | end | |
567 | | Tuple xs => Keep (tuple xs) | |
568 | | _ => Keep e | |
569 | val simplifyExp = | |
570 | Trace.trace ("SimplifyTypes.simplifyExp", | |
571 | Exp.layout, Result.layout Exp.layout) | |
572 | simplifyExp | |
573 | fun simplifyTransfer (t : Transfer.t): Statement.t vector * Transfer.t = | |
574 | case t of | |
575 | Arith {prim, args, overflow, success, ty} => | |
576 | (Vector.new0 (), Arith {prim = prim, | |
577 | args = Vector.map (args, simplifyVar), | |
578 | overflow = overflow, | |
579 | success = success, | |
580 | ty = ty}) | |
581 | | Bug => (Vector.new0 (), t) | |
582 | | Call {func, args, return} => | |
583 | (Vector.new0 (), | |
584 | Call {func = func, return = return, | |
585 | args = removeUselessVars args}) | |
586 | | Case {test, cases = Cases.Con cases, default} => | |
587 | let | |
588 | val cases = | |
589 | Vector.keepAll (cases, fn (con, _) => | |
590 | not (ConRep.isUseless (conRep con))) | |
591 | val default = | |
592 | case (Vector.length cases, default) of | |
593 | (_, NONE) => NONE | |
594 | | (0, SOME l) => SOME l | |
595 | | (n, SOME l) => | |
596 | if n = tyconNumCons (Type.deDatatype (oldVarType test)) | |
597 | then NONE | |
598 | else SOME l | |
599 | fun normal () = | |
600 | (Vector.new0 (), | |
601 | Case {test = test, | |
602 | cases = Cases.Con cases, | |
603 | default = default}) | |
604 | in case (Vector.length cases, default) of | |
605 | (0, NONE) => (Vector.new0 (), Bug) | |
606 | | (0, SOME l) => | |
607 | (Vector.new0 (), Goto {dst = l, args = Vector.new0 ()}) | |
608 | | (1, NONE) => | |
609 | let | |
610 | val (con, l) = Vector.first cases | |
611 | in | |
612 | if ConRep.isUseful (conRep con) | |
613 | then | |
614 | (* This case can occur because an array or vector | |
615 | * tycon was kept around. | |
616 | *) | |
617 | normal () | |
618 | else (* The type has become a tuple. Do the selects. *) | |
619 | let | |
620 | val ts = keepSimplifyTypes (conArgs con) | |
621 | val (args, stmts) = | |
622 | if 1 = Vector.length ts | |
623 | then (Vector.new1 test, Vector.new0 ()) | |
624 | else | |
625 | Vector.unzip | |
626 | (Vector.mapi | |
627 | (ts, fn (i, ty) => | |
628 | let val x = Var.newNoname () | |
629 | in (x, | |
630 | Statement.T | |
631 | {var = SOME x, | |
632 | ty = ty, | |
633 | exp = Select {tuple = test, | |
634 | offset = i}}) | |
635 | end)) | |
636 | in (stmts, Goto {dst = l, args = args}) | |
637 | end | |
638 | end | |
639 | | _ => normal () | |
640 | end | |
641 | | Case _ => (Vector.new0 (), t) | |
642 | | Goto {dst, args} => | |
643 | (Vector.new0 (), Goto {dst = dst, args = removeUselessVars args}) | |
644 | | Raise xs => (Vector.new0 (), Raise (removeUselessVars xs)) | |
645 | | Return xs => (Vector.new0 (), Return (removeUselessVars xs)) | |
646 | | Runtime {prim, args, return} => | |
647 | (Vector.new0 (), Runtime {prim = prim, | |
648 | args = Vector.map (args, simplifyVar), | |
649 | return = return}) | |
650 | val simplifyTransfer = | |
651 | Trace.trace | |
652 | ("SimplifyTypes.simplifyTransfer", Transfer.layout, | |
653 | Layout.tuple2 (Vector.layout Statement.layout, Transfer.layout)) | |
654 | simplifyTransfer | |
655 | fun simplifyStatement (Statement.T {var, ty, exp}) = | |
656 | let | |
657 | val ty = simplifyMaybeVarType (var, ty) | |
658 | in | |
659 | (* It is wrong to omit calling simplifyExp when var = NONE because | |
660 | * targs in a PrimApp may still need to be simplified. | |
661 | *) | |
662 | if not (Type.isUnit ty) | |
663 | orelse Exp.maySideEffect exp | |
664 | orelse (case exp of | |
665 | Profile _ => true | |
666 | | _ => false) | |
667 | then | |
668 | (case simplifyExp exp of | |
669 | Bugg => Bugg | |
670 | | Delete => Delete | |
671 | | Keep exp => | |
672 | Keep (Statement.T {var = var, ty = ty, exp = exp})) | |
673 | else Delete | |
674 | end | |
675 | fun simplifyBlock (Block.T {label, args, statements, transfer}) = | |
676 | let | |
677 | val args = simplifyFormals args | |
678 | val statements = | |
679 | Vector.fold' | |
680 | (statements, 0, [], fn (_, statement, statements) => | |
681 | case simplifyStatement statement of | |
682 | Bugg => Vector.Done NONE | |
683 | | Delete => Vector.Continue statements | |
684 | | Keep s => Vector.Continue (s :: statements), | |
685 | SOME o Vector.fromListRev) | |
686 | in | |
687 | case statements of | |
688 | NONE => Block.T {label = label, | |
689 | args = args, | |
690 | statements = Vector.new0 (), | |
691 | transfer = Bug} | |
692 | | SOME statements => | |
693 | let | |
694 | val (stmts, transfer) = simplifyTransfer transfer | |
695 | val statements = Vector.concat [statements, stmts] | |
696 | in | |
697 | Block.T {label = label, | |
698 | args = args, | |
699 | statements = statements, | |
700 | transfer = transfer} | |
701 | end | |
702 | end | |
703 | fun simplifyFunction f = | |
704 | let | |
705 | val {args, mayInline, name, raises, returns, start, ...} = | |
706 | Function.dest f | |
707 | val args = simplifyFormals args | |
708 | val blocks = ref [] | |
709 | val _ = | |
710 | Function.dfs (f, fn block => | |
711 | (List.push (blocks, simplifyBlock block) | |
712 | ; fn () => ())) | |
713 | val returns = Option.map (returns, keepSimplifyTypes) | |
714 | val raises = Option.map (raises, keepSimplifyTypes) | |
715 | in | |
716 | Function.new {args = args, | |
717 | blocks = Vector.fromList (!blocks), | |
718 | mayInline = mayInline, | |
719 | name = name, | |
720 | raises = raises, | |
721 | returns = returns, | |
722 | start = start} | |
723 | end | |
724 | val globals = | |
725 | Vector.concat | |
726 | [Vector.new1 (Statement.T {var = SOME unitVar, | |
727 | ty = Type.unit, | |
728 | exp = Exp.unit}), | |
729 | Vector.keepAllMap (globals, fn s => | |
730 | case simplifyStatement s of | |
731 | Bugg => Error.bug "SimplifyTypes.globals: bind can't fail" | |
732 | | Delete => NONE | |
733 | | Keep b => SOME b)] | |
734 | val shrink = shrinkFunction {globals = globals} | |
735 | val functions = List.revMap (functions, shrink o simplifyFunction) | |
736 | val program = | |
737 | Program.T {datatypes = datatypes, | |
738 | globals = globals, | |
739 | functions = functions, | |
740 | main = main} | |
741 | val _ = destroySimplifyType () | |
742 | val _ = Program.clearTop program | |
743 | in | |
744 | program | |
745 | end | |
746 | ||
747 | end |