Commit | Line | Data |
---|---|---|
7f918cf1 CE |
1 | (* Copyright (C) 2009 Matthew Fluet. |
2 | * Copyright (C) 1999-2006 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 KnownCase (S: SSA_TRANSFORM_STRUCTS): SSA_TRANSFORM = | |
11 | struct | |
12 | ||
13 | open S | |
14 | open Exp Transfer | |
15 | ||
16 | fun mkPost () | |
17 | = let | |
18 | val post = ref [] | |
19 | in | |
20 | {addPost = fn th => List.push (post, th), | |
21 | post = fn () => List.foreach(!post, fn th => th ())} | |
22 | end | |
23 | ||
24 | structure TyconInfo = | |
25 | struct | |
26 | datatype t = T of {cons: Con.t vector} | |
27 | ||
28 | local | |
29 | fun make f (T r) = f r | |
30 | in | |
31 | val cons = make #cons | |
32 | end | |
33 | ||
34 | fun layout (T {cons, ...}) | |
35 | = Layout.record [("cons", Vector.layout Con.layout cons)] | |
36 | end | |
37 | ||
38 | structure ConInfo = | |
39 | struct | |
40 | datatype t = T of {args: Type.t vector, | |
41 | index: int, | |
42 | tycon: Tycon.t} | |
43 | ||
44 | local | |
45 | fun make f (T r) = f r | |
46 | in | |
47 | val args = make #args | |
48 | val index = make #index | |
49 | end | |
50 | ||
51 | fun layout (T {index, ...}) | |
52 | = Layout.record [("index", Int.layout index)] | |
53 | end | |
54 | ||
55 | structure ConValue = | |
56 | struct | |
57 | type w = Var.t ref vector | |
58 | type v = w option | |
59 | type u = v option | |
60 | type t = Con.t * u | |
61 | ||
62 | val equalsW : w * w -> bool | |
63 | = fn (x, y) => Vector.equals (x, y, fn (x, y) => Var.equals (!x, !y)) | |
64 | ||
65 | val layoutW = Vector.layout (Var.layout o !) | |
66 | val layoutV = Option.layout layoutW | |
67 | val layoutU = Option.layout layoutV | |
68 | val layout : t -> Layout.t = Layout.tuple2 (Con.layout, layoutU) | |
69 | ||
70 | val joinV : v * v -> v | |
71 | = fn (SOME x, SOME y) | |
72 | => if equalsW (x, y) | |
73 | then SOME x | |
74 | else NONE | |
75 | | (NONE, _) => NONE | |
76 | | (_, NONE) => NONE | |
77 | val joinU : u * u -> u | |
78 | = fn (SOME x, SOME y) => SOME (joinV (x, y)) | |
79 | | (NONE, y) => y | |
80 | | (x, NONE) => x | |
81 | val join : t * t -> t | |
82 | = fn ((conx, x), (cony, y)) => | |
83 | if Con.equals (conx, cony) | |
84 | then (conx, joinU (x, y)) | |
85 | else Error.bug "KnownCase.ConValue.join" | |
86 | ||
87 | fun newKnown (con, args) : t = (con, SOME (SOME args)) | |
88 | fun newUnknown con : t = (con, SOME NONE) | |
89 | fun new con : t = (con, NONE) | |
90 | ||
91 | fun isTop ((_, x) : t) = isSome x | |
92 | ||
93 | val con : t -> Con.t = fn (conx, _) => conx | |
94 | end | |
95 | ||
96 | structure TyconValue = | |
97 | struct | |
98 | type t = ConValue.t vector | |
99 | ||
100 | val layout : t -> Layout.t = Vector.layout ConValue.layout | |
101 | ||
102 | val join : t * t -> t | |
103 | = fn (x, y) => Vector.map2 (x, y, ConValue.join) | |
104 | ||
105 | fun newKnown (cons, con, args) | |
106 | = Vector.map | |
107 | (cons, fn con' => | |
108 | if Con.equals (con, con') | |
109 | then ConValue.newKnown (con, args) | |
110 | else ConValue.new con') | |
111 | ||
112 | fun newUnknown cons = Vector.map (cons, ConValue.newUnknown) | |
113 | ||
114 | val cons : t -> Con.t vector | |
115 | = fn x => Vector.map (x, ConValue.con) | |
116 | end | |
117 | ||
118 | structure VarInfo = | |
119 | struct | |
120 | datatype t = T of {active: bool ref, | |
121 | tyconValues: TyconValue.t list ref, | |
122 | var: Var.t} | |
123 | ||
124 | local | |
125 | fun make f (T r) = f r | |
126 | fun make' f = (make f, ! o (make f)) | |
127 | in | |
128 | val (_, active') = make' #active | |
129 | end | |
130 | ||
131 | fun layout (T {active, tyconValues, var, ...}) | |
132 | = Layout.record [("active", Bool.layout (!active)), | |
133 | ("tyconValues", List.layout TyconValue.layout (!tyconValues)), | |
134 | ("var", Var.layout var)] | |
135 | ||
136 | fun new var = T {active = ref false, | |
137 | tyconValues = ref [], | |
138 | var = var} | |
139 | ||
140 | fun deactivate (T {active, ...}) = active := false | |
141 | fun activate (T {active, ...}) = active := true | |
142 | fun activate' (vi, addPost: (unit -> unit) -> unit) | |
143 | = (addPost (fn () => deactivate vi); | |
144 | activate vi) | |
145 | val active = active' | |
146 | ||
147 | fun tyconValue (T {tyconValues, ...}) | |
148 | = case !tyconValues of h::_ => SOME h | _ => NONE | |
149 | fun popTyconValue (T {tyconValues, ...}) = ignore (List.pop tyconValues) | |
150 | fun pushTyconValue (T {tyconValues, ...}, tcv) = List.push (tyconValues, tcv) | |
151 | fun pushTyconValue' (vi, tcv, addPost) | |
152 | = let | |
153 | val _ = pushTyconValue (vi, tcv) | |
154 | val _ = addPost (fn () => popTyconValue vi) | |
155 | in | |
156 | () | |
157 | end | |
158 | fun joinActiveTyconValue (vi, tcv, addPost, addPost') | |
159 | = if active vi | |
160 | then let val tcv' = valOf (tyconValue vi) | |
161 | in | |
162 | popTyconValue vi; | |
163 | pushTyconValue (vi, TyconValue.join (tcv, tcv')) | |
164 | end | |
165 | else (activate' (vi, addPost'); | |
166 | pushTyconValue' (vi, tcv, addPost)) | |
167 | end | |
168 | ||
169 | structure ReplaceInfo = | |
170 | struct | |
171 | datatype t = T of {replaces: Var.t ref list ref} | |
172 | ||
173 | fun new var = T {replaces = ref [ref var]} | |
174 | ||
175 | fun replace (T {replaces, ...}) | |
176 | = case !replaces of h::_ => h | _ => Error.bug "KnownCase.ReplaceInfo.replace" | |
177 | fun popReplace (T {replaces, ...}) = ignore (List.pop replaces) | |
178 | fun pushReplace (T {replaces, ...}, rep) = List.push (replaces, ref rep) | |
179 | fun pushReplace' (vi, rep, addPost) | |
180 | = let | |
181 | val _ = pushReplace (vi, rep) | |
182 | val _ = addPost (fn () => popReplace vi) | |
183 | in | |
184 | () | |
185 | end | |
186 | fun flipReplace (vi, rep) | |
187 | = let val r = replace vi | |
188 | in !r before (r := rep) | |
189 | end | |
190 | fun flipReplace' (vi, rep, addPost) | |
191 | = let | |
192 | val rep = flipReplace (vi, rep) | |
193 | val _ = addPost (fn () => ignore (flipReplace (vi, rep))) | |
194 | in | |
195 | rep | |
196 | end | |
197 | fun nextReplace' (vi, rep, addPost) | |
198 | = let | |
199 | val rep = flipReplace' (vi, rep, addPost) | |
200 | val _ = pushReplace' (vi, rep, addPost) | |
201 | in | |
202 | () | |
203 | end | |
204 | end | |
205 | ||
206 | structure LabelInfo = | |
207 | struct | |
208 | datatype t = T of {activations: (VarInfo.t * TyconValue.t) list ref, | |
209 | block: Block.t, | |
210 | depth: int ref, | |
211 | pred: Label.t option option ref} | |
212 | ||
213 | local | |
214 | fun make f (T r) = f r | |
215 | fun make' f = (make f, ! o (make f)) | |
216 | in | |
217 | val block = make #block | |
218 | val (_, depth') = make' #depth | |
219 | end | |
220 | ||
221 | fun layout (T {pred, ...}) | |
222 | = Layout.record | |
223 | [("pred", Option.layout (Option.layout Label.layout) (!pred))] | |
224 | ||
225 | fun new block = T {activations = ref [], | |
226 | block = block, | |
227 | depth = ref 0, | |
228 | pred = ref NONE} | |
229 | ||
230 | fun popDepth (T {depth, ...}) = Int.dec depth | |
231 | fun pushDepth (T {depth, ...}) = Int.inc depth | |
232 | fun pushDepth' (li, addPost) | |
233 | = let | |
234 | val _ = pushDepth li | |
235 | val _ = addPost (fn () => popDepth li) | |
236 | in | |
237 | () | |
238 | end | |
239 | ||
240 | fun addPred (T {pred, ...}, l) | |
241 | = case !pred | |
242 | of NONE => pred := SOME (SOME l) | |
243 | | SOME NONE => () | |
244 | | SOME (SOME l') => if Label.equals (l, l') | |
245 | then () | |
246 | else pred := SOME NONE | |
247 | fun onePred (T {pred, ...}) | |
248 | = case !pred | |
249 | of SOME (SOME _) => true | |
250 | | _ => false | |
251 | ||
252 | fun addActivation (T {activations, ...}, activation) | |
253 | = List.push (activations, activation) | |
254 | fun activate (T {activations, ...}, addPost) | |
255 | = let | |
256 | val {addPost = addPost', post = post'} = mkPost () | |
257 | in | |
258 | List.foreach | |
259 | (!activations, fn (vi, tcv) => | |
260 | VarInfo.joinActiveTyconValue (vi, tcv, addPost, addPost')); | |
261 | post' () | |
262 | end | |
263 | val activate : t * ((unit -> unit) -> unit) -> unit | |
264 | = Trace.trace | |
265 | ("KnownCase.LabelInfo.activate", | |
266 | fn (T {activations, block = Block.T {label, ...}, ...}, _) => | |
267 | let open Layout | |
268 | in | |
269 | seq [Label.layout label, | |
270 | str " ", | |
271 | (List.layout (tuple2 (VarInfo.layout, | |
272 | TyconValue.layout)) | |
273 | (!activations))] | |
274 | end, | |
275 | Layout.ignore) | |
276 | activate | |
277 | end | |
278 | ||
279 | fun transform (Program.T {globals, datatypes, functions, main}) | |
280 | = let | |
281 | (* restore and shrink *) | |
282 | val restore = restoreFunction {globals = globals} | |
283 | val shrink = shrinkFunction {globals = globals} | |
284 | ||
285 | (* tyconInfo and conInfo *) | |
286 | val {get = tyconInfo: Tycon.t -> TyconInfo.t, | |
287 | set = setTyconInfo, ...} | |
288 | = Property.getSetOnce | |
289 | (Tycon.plist, Property.initRaise ("knownCase.tyconInfo", Tycon.layout)) | |
290 | val {get = conInfo: Con.t -> ConInfo.t, | |
291 | set = setConInfo, ...} | |
292 | = Property.getSetOnce | |
293 | (Con.plist, Property.initRaise ("knownCase.conInfo", Con.layout)) | |
294 | val _ = Vector.foreach | |
295 | (datatypes, fn Datatype.T {tycon, cons} => | |
296 | (setTyconInfo (tycon, TyconInfo.T {cons = Vector.map (cons, #con)}); | |
297 | Vector.foreachi | |
298 | (cons, fn (i, {con, args}) => | |
299 | setConInfo (con, ConInfo.T {args = args, | |
300 | index = i, | |
301 | tycon = tycon})))) | |
302 | (* Diagnostics *) | |
303 | val _ = Control.diagnostics | |
304 | (fn display => | |
305 | let open Layout | |
306 | in | |
307 | Vector.foreach | |
308 | (datatypes, fn Datatype.T {tycon, cons} => | |
309 | let val tci = tyconInfo tycon | |
310 | in | |
311 | display (seq [Tycon.layout tycon, str " ", | |
312 | TyconInfo.layout tci, | |
313 | Vector.layout | |
314 | (fn {con, ...} => | |
315 | let val ci = conInfo con | |
316 | in | |
317 | seq [Con.layout con, str " ", | |
318 | ConInfo.layout ci] | |
319 | end) | |
320 | cons]) | |
321 | end) | |
322 | end) | |
323 | fun optimizeTycon _ = true | |
324 | fun optimizeType ty = case Type.dest ty | |
325 | of Type.Datatype tycon => optimizeTycon tycon | |
326 | | _ => false | |
327 | ||
328 | (* varInfo *) | |
329 | val {get = varInfo: Var.t -> VarInfo.t, ...} | |
330 | = Property.getSetOnce | |
331 | (Var.plist, Property.initFun (fn x => VarInfo.new x)) | |
332 | (* replaceInfo *) | |
333 | val {get = replaceInfo: Var.t -> ReplaceInfo.t, ...} | |
334 | = Property.get | |
335 | (Var.plist, Property.initFun (fn x => ReplaceInfo.new x)) | |
336 | ||
337 | ||
338 | fun bindVar' (x, ty, exp, addPost) | |
339 | = case Type.dest ty | |
340 | of Type.Datatype tycon | |
341 | => if optimizeTycon tycon | |
342 | then let | |
343 | val cons = TyconInfo.cons (tyconInfo tycon) | |
344 | val tyconValue | |
345 | = case exp | |
346 | of SOME (ConApp {con, args}) | |
347 | => TyconValue.newKnown | |
348 | (cons, con, | |
349 | Vector.map | |
350 | (args, ReplaceInfo.replace o replaceInfo)) | |
351 | | _ => TyconValue.newUnknown cons | |
352 | in | |
353 | VarInfo.pushTyconValue' | |
354 | (varInfo x, tyconValue, addPost) | |
355 | end | |
356 | else () | |
357 | | _ => () | |
358 | ||
359 | fun bindVarArgs' (args, addPost) | |
360 | = Vector.foreach | |
361 | (args, fn (x, ty) => | |
362 | bindVar' (x, ty, NONE, addPost)) | |
363 | fun bindVarArgs args = bindVarArgs' (args, ignore) | |
364 | fun bindVarStatement' (Statement.T {var, ty, exp}, addPost) | |
365 | = Option.app | |
366 | (var, fn x => | |
367 | bindVar' (x, ty, SOME exp, addPost)) | |
368 | fun bindVarStatements' (statements, addPost) | |
369 | = Vector.foreach | |
370 | (statements, fn statement => | |
371 | bindVarStatement' (statement, addPost)) | |
372 | fun bindVarStatements statements = bindVarStatements' (statements, ignore) | |
373 | ||
374 | val _ = bindVarStatements globals | |
375 | (* Diagnostics *) | |
376 | val _ = Control.diagnostics | |
377 | (fn display => | |
378 | let open Layout | |
379 | in | |
380 | Vector.foreach | |
381 | (globals, fn Statement.T {var, ...} => | |
382 | Option.app | |
383 | (var, fn x => | |
384 | let val vi = varInfo x | |
385 | in | |
386 | display (seq [Var.layout x, str " ", | |
387 | VarInfo.layout vi]) | |
388 | end)) | |
389 | end) | |
390 | ||
391 | (* labelInfo *) | |
392 | val {get = labelInfo: Label.t -> LabelInfo.t, | |
393 | set = setLabelInfo, ...} | |
394 | = Property.getSetOnce | |
395 | (Label.plist, Property.initRaise ("knownCase.labelInfo", Label.layout)) | |
396 | ||
397 | val functions | |
398 | = List.revMap | |
399 | (functions, fn f => | |
400 | let | |
401 | val {args, blocks, mayInline, name, raises, returns, start} = | |
402 | Function.dest f | |
403 | val _ = Vector.foreach | |
404 | (blocks, fn block as Block.T {label, ...} => | |
405 | setLabelInfo (label, LabelInfo.new block)) | |
406 | val _ = Vector.foreach | |
407 | (blocks, fn Block.T {label, transfer, ...} => | |
408 | Transfer.foreachLabel | |
409 | (transfer, fn l => | |
410 | let val li = labelInfo l | |
411 | in LabelInfo.addPred (li, label) | |
412 | end)) | |
413 | (* Diagnostics *) | |
414 | val _ = Control.diagnostics | |
415 | (fn display => | |
416 | let open Layout | |
417 | in | |
418 | Vector.foreach | |
419 | (blocks, fn Block.T {label, ...} => | |
420 | let val li = labelInfo label | |
421 | in | |
422 | display (seq [Label.layout label, str " ", | |
423 | LabelInfo.layout li]) | |
424 | end) | |
425 | end) | |
426 | ||
427 | val newBlocks = ref [] | |
428 | fun addBlock block = List.push (newBlocks, block) | |
429 | fun addNewBlock (block as Block.T {label, ...}) | |
430 | = (setLabelInfo (label, LabelInfo.new block); | |
431 | addBlock block) | |
432 | local | |
433 | val table: {hash: word, | |
434 | transfer: Transfer.t, | |
435 | label: Label.t} HashSet.t | |
436 | = HashSet.new {hash = #hash} | |
437 | in | |
438 | fun newBlock transfer = | |
439 | let | |
440 | val label = Label.newNoname () | |
441 | val block = Block.T {label = label, | |
442 | args = Vector.new0 (), | |
443 | statements = Vector.new0 (), | |
444 | transfer = transfer} | |
445 | val _ = addNewBlock block | |
446 | in | |
447 | label | |
448 | end | |
449 | (* newBlock' isn't used, because it shares blocks that causes | |
450 | * violation of the requirements for profiling information -- | |
451 | * namely that each block correspond to a unique sequence of | |
452 | * source infos at it' start. | |
453 | * | |
454 | * I left the code in case we want to enable it when compiling | |
455 | * without profiling. | |
456 | *) | |
457 | fun newBlock' transfer | |
458 | = let | |
459 | val hash = Transfer.hash transfer | |
460 | val {label, ...} | |
461 | = HashSet.lookupOrInsert | |
462 | (table, hash, | |
463 | fn {transfer = transfer', ...} => | |
464 | Transfer.equals (transfer, transfer'), | |
465 | fn () => {hash = hash, | |
466 | label = newBlock transfer, | |
467 | transfer = transfer}) | |
468 | in | |
469 | label | |
470 | end | |
471 | val _ = newBlock' (* quell unused variable warning *) | |
472 | fun bugBlock () = newBlock Bug | |
473 | end | |
474 | ||
475 | val traceRewriteGoto | |
476 | = Trace.trace | |
477 | ("KnownCase.rewriteGoto", | |
478 | fn {dst, args} => | |
479 | Layout.record | |
480 | [("dst", Label.layout dst), | |
481 | ("args", Vector.layout Var.layout args)], | |
482 | Option.layout | |
483 | (Layout.tuple2 | |
484 | (Vector.layout Statement.layout, | |
485 | Transfer.layout))) | |
486 | val traceRewriteCase | |
487 | = Trace.trace | |
488 | ("KnownCase.rewriteCase", | |
489 | fn {test, cases, default} => | |
490 | Layout.record | |
491 | [("test", Var.layout test), | |
492 | ("cases", Vector.layout | |
493 | (Layout.tuple2 (Con.layout, Label.layout)) | |
494 | cases), | |
495 | ("default", Option.layout Label.layout default)], | |
496 | Option.layout | |
497 | (Layout.tuple2 | |
498 | (Vector.layout Statement.layout, | |
499 | Transfer.layout))) | |
500 | val traceRewriteTransfer | |
501 | = Trace.trace | |
502 | ("KnownCase.rewriteTransfer", | |
503 | Transfer.layout, | |
504 | Option.layout | |
505 | (Layout.tuple2 | |
506 | (Vector.layout Statement.layout, | |
507 | Transfer.layout))) | |
508 | ||
509 | fun rewriteGoto' {dst, args} : | |
510 | (Statement.t vector * Transfer.t) option | |
511 | = let | |
512 | val li = labelInfo dst | |
513 | val Block.T {args = argsDst, | |
514 | statements = statementsDst, | |
515 | transfer = transferDst, ...} | |
516 | = LabelInfo.block li | |
517 | val depthDst = LabelInfo.depth' li | |
518 | in | |
519 | if depthDst <= 2 | |
520 | andalso | |
521 | Vector.fold | |
522 | (statementsDst, 0, | |
523 | fn (Statement.T {exp = Profile _, ...}, i) => i | |
524 | | (_, i) => i + 1) <= 0 | |
525 | then let | |
526 | val {addPost, post} = mkPost () | |
527 | val _ = LabelInfo.pushDepth' (li, addPost) | |
528 | ||
529 | val vars = Vector.map2 | |
530 | (args, argsDst, | |
531 | fn (x, (z, ty)) => | |
532 | (x, Var.newNoname (), | |
533 | z, Var.newNoname (), ty)) | |
534 | ||
535 | val moves1 | |
536 | = if depthDst > 0 | |
537 | then Vector.map | |
538 | (vars, fn (_, _, z, t, ty) => | |
539 | (if optimizeType ty | |
540 | then let | |
541 | val zvi = varInfo z | |
542 | val tvi = varInfo t | |
543 | in | |
544 | VarInfo.pushTyconValue' | |
545 | (tvi, | |
546 | valOf (VarInfo.tyconValue zvi), | |
547 | addPost) | |
548 | end | |
549 | else (); | |
550 | ReplaceInfo.nextReplace' | |
551 | (replaceInfo z, t, addPost); | |
552 | Statement.T {var = SOME t, | |
553 | ty = ty, | |
554 | exp = Var z})) | |
555 | else Vector.new0 () | |
556 | val moves2 | |
557 | = Vector.map | |
558 | (vars, fn (x, t, _, _, ty) => | |
559 | (if optimizeType ty | |
560 | then let | |
561 | val xvi = varInfo x | |
562 | val tvi = varInfo t | |
563 | in | |
564 | VarInfo.pushTyconValue' | |
565 | (tvi, | |
566 | valOf (VarInfo.tyconValue xvi), | |
567 | addPost) | |
568 | end | |
569 | else (); | |
570 | Statement.T {var = SOME t, | |
571 | ty = ty, | |
572 | exp = Var x})) | |
573 | val moves3 | |
574 | = Vector.map | |
575 | (vars, fn (_, t, z, _, ty) => | |
576 | (if optimizeType ty | |
577 | then let | |
578 | val tvi = varInfo t | |
579 | val zvi = varInfo z | |
580 | in | |
581 | VarInfo.pushTyconValue' | |
582 | (zvi, | |
583 | valOf (VarInfo.tyconValue tvi), | |
584 | addPost) | |
585 | end | |
586 | else (); | |
587 | Statement.T {var = SOME z, | |
588 | ty = ty, | |
589 | exp = Var t})) | |
590 | val _ = bindVarStatements' (statementsDst, addPost) | |
591 | in | |
592 | (case rewriteTransfer transferDst | |
593 | of NONE => NONE | |
594 | | SOME (newStatements, newTransfer) | |
595 | => SOME (Vector.concat [moves1, moves2, moves3, | |
596 | statementsDst, | |
597 | newStatements], | |
598 | newTransfer)) | |
599 | before (post ()) | |
600 | end | |
601 | else NONE | |
602 | end | |
603 | and rewriteGoto goto = traceRewriteGoto | |
604 | rewriteGoto' | |
605 | goto | |
606 | ||
607 | and rewriteCase' {test, cases, default} : | |
608 | (Statement.t vector * Transfer.t) option | |
609 | ||
610 | = let | |
611 | val {addPost, post} = mkPost () | |
612 | ||
613 | val testvi = varInfo test | |
614 | val tyconValue as conValues | |
615 | = case VarInfo.tyconValue testvi | |
616 | of SOME tyconValue => tyconValue | |
617 | | _ => Error.bug "KnownCase.rewriteCase: tyconValue" | |
618 | val cons = TyconValue.cons tyconValue | |
619 | val numCons = Vector.length cons | |
620 | ||
621 | datatype z = None | |
622 | | One of (Con.t * ConValue.v) | |
623 | | Many | |
624 | ||
625 | fun doOneSome (con, args) | |
626 | = let | |
627 | val goto | |
628 | = case Vector.peek | |
629 | (cases, fn (con', _) => | |
630 | Con.equals (con, con')) | |
631 | of SOME (_, dst) | |
632 | => {dst = dst, args = Vector.map (args, !)} | |
633 | | NONE | |
634 | => {dst = valOf default, | |
635 | args = Vector.new0 ()} | |
636 | in | |
637 | case rewriteGoto goto | |
638 | of NONE => SOME (Vector.new0 (), Transfer.Goto goto) | |
639 | | sst => sst | |
640 | end | |
641 | val doOneSome | |
642 | = Trace.trace | |
643 | ("KnownCase.doOneSome", | |
644 | Layout.ignore, Layout.ignore) | |
645 | doOneSome | |
646 | ||
647 | fun rewriteDefault conValues' | |
648 | = let | |
649 | val _ = VarInfo.pushTyconValue' | |
650 | (testvi, conValues', addPost) | |
651 | in | |
652 | rewriteGoto {dst = valOf default, args = Vector.new0 ()} | |
653 | end | |
654 | val rewriteDefault | |
655 | = Trace.trace | |
656 | ("KnownCase.rewriteCase.rewriteDefault", | |
657 | Layout.ignore, Layout.ignore) | |
658 | rewriteDefault | |
659 | ||
660 | fun doOneNone con | |
661 | = let | |
662 | fun doit dst | |
663 | = SOME (Vector.new0 (), | |
664 | Case | |
665 | {test = test, | |
666 | cases = Cases.Con (Vector.new1 (con, dst)), | |
667 | default = if numCons = 1 | |
668 | then NONE | |
669 | else SOME (bugBlock ())}) | |
670 | in | |
671 | case Vector.peek | |
672 | (cases, fn (con', _) => | |
673 | Con.equals (con, con')) | |
674 | of SOME (_, dst) => doit dst | |
675 | | NONE | |
676 | => let | |
677 | val args | |
678 | = Vector.map | |
679 | (ConInfo.args (conInfo con), | |
680 | fn ty => | |
681 | let | |
682 | val x = Var.newNoname () | |
683 | val xvi = varInfo x | |
684 | val _ = case Type.dest ty | |
685 | of Type.Datatype tycon | |
686 | => if optimizeTycon tycon | |
687 | then VarInfo.pushTyconValue' | |
688 | (xvi, | |
689 | TyconValue.newUnknown | |
690 | (TyconInfo.cons (tyconInfo tycon)), | |
691 | addPost) | |
692 | else () | |
693 | | _ => () | |
694 | in | |
695 | (x, ty) | |
696 | end) | |
697 | val (xs, _) = Vector.unzip args | |
698 | val conValues' = TyconValue.newKnown | |
699 | (cons, con, | |
700 | Vector.map | |
701 | (xs, ReplaceInfo.replace o replaceInfo)) | |
702 | val label = Label.newNoname () | |
703 | val (statements, transfer) | |
704 | = case rewriteDefault conValues' | |
705 | of SOME sst => sst | |
706 | | NONE => (Vector.new0 (), | |
707 | Goto {dst = valOf default, | |
708 | args = Vector.new0 ()}) | |
709 | val block = Block.T | |
710 | {label = label, | |
711 | args = args, | |
712 | statements = statements, | |
713 | transfer = transfer} | |
714 | val _ = addNewBlock block | |
715 | in | |
716 | doit label | |
717 | end | |
718 | end | |
719 | val doOneNone | |
720 | = Trace.trace | |
721 | ("KnownCase.rewriteCase.doOneNone", | |
722 | Layout.ignore, Layout.ignore) | |
723 | doOneNone | |
724 | ||
725 | fun doMany () | |
726 | = let | |
727 | val usedCons = Array.new (numCons, false) | |
728 | val cases = Vector.keepAllMap | |
729 | (cases, fn (con, dst) => | |
730 | let | |
731 | val conIndex = ConInfo.index (conInfo con) | |
732 | val _ = Array.update (usedCons, conIndex, true) | |
733 | in | |
734 | if ConValue.isTop (Vector.sub (conValues, conIndex)) | |
735 | then SOME (con, dst) | |
736 | else NONE | |
737 | end) | |
738 | val (cases, default) | |
739 | = case default | |
740 | of NONE => (cases, NONE) | |
741 | | SOME dst | |
742 | => let | |
743 | val conValues' = Vector.mapi | |
744 | (cons, fn (i, con) => | |
745 | if Array.sub (usedCons, i) | |
746 | then ConValue.new con | |
747 | else Vector.sub (conValues, i)) | |
748 | ||
749 | fun route (statements, (cases, default)) | |
750 | = if Vector.isEmpty statements | |
751 | then (cases, default) | |
752 | else let | |
753 | fun route' dst | |
754 | = let | |
755 | val Block.T {args, ...} | |
756 | = LabelInfo.block (labelInfo dst) | |
757 | ||
758 | val label = Label.newNoname () | |
759 | val args = Vector.map | |
760 | (args, fn (_, ty) => | |
761 | (Var.newNoname (), ty)) | |
762 | val xs = Vector.map (args, #1) | |
763 | val block = Block.T | |
764 | {label = label, | |
765 | args = args, | |
766 | statements = statements, | |
767 | transfer = Goto {dst = dst, | |
768 | args = xs}} | |
769 | val _ = addNewBlock block | |
770 | in | |
771 | label | |
772 | end | |
773 | in | |
774 | (Vector.map (cases, fn (con, dst) => (con, route' dst)), | |
775 | Option.map (default, route')) | |
776 | end | |
777 | ||
778 | in | |
779 | case rewriteDefault conValues' | |
780 | of SOME (statements, | |
781 | Case {test = test', | |
782 | cases = Cases.Con cases', | |
783 | default = default'}) | |
784 | => if Option.equals | |
785 | (SOME test, | |
786 | Vector.foldr | |
787 | (statements, SOME test', | |
788 | fn (Statement.T _, NONE) => NONE | |
789 | | (Statement.T {var, exp, ...}, SOME test') => | |
790 | if Option.equals (var, SOME test', Var.equals) | |
791 | then case exp | |
792 | of Var test' => SOME test' | |
793 | | _ => NONE | |
794 | else SOME test'), | |
795 | Var.equals) | |
796 | then let | |
797 | val (cases', default') | |
798 | = route (statements, (cases', default')) | |
799 | in | |
800 | (Vector.concat [cases, cases'], default') | |
801 | end | |
802 | else (cases, SOME dst) | |
803 | | SOME (statements, transfer) | |
804 | => let | |
805 | val label | |
806 | = if Vector.isEmpty statements | |
807 | then newBlock transfer | |
808 | else let | |
809 | val label = Label.newNoname () | |
810 | val block = Block.T | |
811 | {label = label, | |
812 | args = Vector.new0 (), | |
813 | statements = statements, | |
814 | transfer = transfer} | |
815 | val _ = addNewBlock block | |
816 | in | |
817 | label | |
818 | end | |
819 | in | |
820 | (cases, SOME label) | |
821 | end | |
822 | | NONE => (cases, SOME dst) | |
823 | end | |
824 | val numCases = Vector.length cases | |
825 | fun doit (cases, default) | |
826 | = SOME (Vector.new0 (), | |
827 | Case {test = test, | |
828 | cases = Cases.Con cases, | |
829 | default = default}) | |
830 | in | |
831 | if numCases = numCons | |
832 | then doit (cases, NONE) | |
833 | else doit (cases, | |
834 | case default | |
835 | of SOME _ => default | |
836 | | NONE => SOME (bugBlock ())) | |
837 | end | |
838 | val doMany | |
839 | = Trace.trace | |
840 | ("KnownCase.rewriteCase.doMany", | |
841 | Layout.ignore, Layout.ignore) | |
842 | doMany | |
843 | ||
844 | in | |
845 | (* | |
846 | (if Vector.forall | |
847 | (conValues, ConValue.isTop) | |
848 | *) | |
849 | (if false | |
850 | then NONE | |
851 | else case Vector.foldi | |
852 | (conValues, None, | |
853 | fn (_, _, Many) => Many | |
854 | | (_, conValue, One ccv) | |
855 | => (case conValue | |
856 | of (_, NONE) => One ccv | |
857 | | (_, SOME _) => Many) | |
858 | | (_, conValue, None) | |
859 | => (case conValue | |
860 | of (_, NONE) => None | |
861 | | (con, SOME cv) => One (con, cv))) | |
862 | of None => SOME (Vector.new0 (), Bug) | |
863 | | One (con, SOME args) => doOneSome (con, args) | |
864 | | One (con, NONE) => doOneNone con | |
865 | | Many => doMany ()) | |
866 | before (post ()) | |
867 | end | |
868 | and rewriteCase casee = traceRewriteCase | |
869 | rewriteCase' | |
870 | casee | |
871 | ||
872 | and rewriteTransfer' (transfer: Transfer.t) : | |
873 | (Statement.t vector * Transfer.t) option | |
874 | = case transfer | |
875 | of Goto {dst, args} => rewriteGoto {dst = dst, args = args} | |
876 | | Case {test, cases = Cases.Con cases, default} | |
877 | => rewriteCase {test = test, cases = cases, default = default} | |
878 | | _ => NONE | |
879 | and rewriteTransfer transfer = traceRewriteTransfer | |
880 | rewriteTransfer' | |
881 | transfer | |
882 | ||
883 | fun activateGoto {dst, args} | |
884 | = let | |
885 | val liDst = labelInfo dst | |
886 | val Block.T {args = argsDst, ...} | |
887 | = LabelInfo.block liDst | |
888 | in | |
889 | if LabelInfo.onePred liDst | |
890 | then Vector.foreach2 | |
891 | (args, argsDst, fn (x, (y, ty)) => | |
892 | if optimizeType ty | |
893 | then let | |
894 | val xvi = varInfo x | |
895 | val yvi = varInfo y | |
896 | val conValues' | |
897 | = valOf (VarInfo.tyconValue xvi) | |
898 | in | |
899 | LabelInfo.addActivation | |
900 | (liDst, (yvi, conValues')) | |
901 | end | |
902 | else ()) | |
903 | else () | |
904 | end | |
905 | fun activateCase {test, cases, default} | |
906 | = let | |
907 | val testvi = varInfo test | |
908 | val tyconValue as conValues | |
909 | = case VarInfo.tyconValue testvi | |
910 | of NONE => Error.bug "KnownCase.activateCase: tyconValue" | |
911 | | SOME tyconValue => tyconValue | |
912 | val cons = TyconValue.cons tyconValue | |
913 | val numCons = Vector.length cons | |
914 | ||
915 | val usedCons = Array.new (numCons, false) | |
916 | in | |
917 | Vector.foreach | |
918 | (cases, fn (con, dst) => | |
919 | let | |
920 | val conIndex = ConInfo.index (conInfo con) | |
921 | val _ = Array.update (usedCons, conIndex, true) | |
922 | val liDst = labelInfo dst | |
923 | val Block.T {args = argsDst, ...} | |
924 | = LabelInfo.block liDst | |
925 | val conValues' | |
926 | = TyconValue.newKnown | |
927 | (cons, con, | |
928 | Vector.map | |
929 | (argsDst, ReplaceInfo.replace o replaceInfo o #1)) | |
930 | in | |
931 | if LabelInfo.onePred liDst | |
932 | then LabelInfo.addActivation | |
933 | (liDst, (testvi, conValues')) | |
934 | else () | |
935 | end); | |
936 | Option.app | |
937 | (default, fn dst => | |
938 | let | |
939 | val liDst = labelInfo dst | |
940 | val conValues' = Vector.mapi | |
941 | (cons, fn (i, con) => | |
942 | if Array.sub (usedCons, i) | |
943 | then ConValue.new con | |
944 | else Vector.sub (conValues, i)) | |
945 | in | |
946 | if LabelInfo.onePred liDst | |
947 | then LabelInfo.addActivation | |
948 | (liDst, (testvi, conValues')) | |
949 | else () | |
950 | end) | |
951 | end | |
952 | fun activateTransfer transfer | |
953 | = case transfer | |
954 | of Goto {dst, args} | |
955 | => activateGoto {dst = dst, args = args} | |
956 | | Case {test, cases = Cases.Con cases, default} | |
957 | => activateCase {test = test, cases = cases, default = default} | |
958 | | _ => () | |
959 | ||
960 | fun rewriteBlock (Block.T {label, args, statements, transfer}, | |
961 | addPost) | |
962 | = let | |
963 | val li = labelInfo label | |
964 | val _ = LabelInfo.pushDepth' (li, addPost) | |
965 | val _ = bindVarArgs' (args, addPost) | |
966 | val _ = LabelInfo.activate (li, addPost) | |
967 | val _ = bindVarStatements' (statements, addPost) | |
968 | val _ = activateTransfer transfer | |
969 | val (statements, transfer) | |
970 | = case rewriteTransfer transfer | |
971 | of NONE => (statements, transfer) | |
972 | | SOME (newStatements, newTransfer) | |
973 | => (Vector.concat [statements,newStatements], | |
974 | newTransfer) | |
975 | in | |
976 | Block.T {label = label, | |
977 | args = args, | |
978 | statements = statements, | |
979 | transfer = transfer} | |
980 | end | |
981 | val rewriteBlock | |
982 | = Trace.trace | |
983 | ("KnownCase.rewriteBlock", | |
984 | Layout.tuple2 (Block.layout, Layout.ignore), | |
985 | Block.layout) | |
986 | rewriteBlock | |
987 | ||
988 | fun doitTree tree | |
989 | = let | |
990 | fun loop (Tree.T (block, children)) | |
991 | = let | |
992 | val {addPost, post} = mkPost () | |
993 | val block = rewriteBlock (block, addPost) | |
994 | in | |
995 | addBlock block ; | |
996 | Vector.foreach (children, loop) ; | |
997 | post () | |
998 | end | |
999 | val _ = loop tree | |
1000 | in | |
1001 | Vector.fromListRev (!newBlocks) | |
1002 | end | |
1003 | val _ = bindVarArgs args | |
1004 | val blocks = doitTree (Function.dominatorTree f) | |
1005 | ||
1006 | val f = Function.new {args = args, | |
1007 | blocks = blocks, | |
1008 | mayInline = mayInline, | |
1009 | name = name, | |
1010 | raises = raises, | |
1011 | returns = returns, | |
1012 | start = start} | |
1013 | val _ = Control.diagnostics | |
1014 | (fn display => | |
1015 | display (Function.layout f)) | |
1016 | val f = eliminateDeadBlocksFunction f | |
1017 | val _ = Control.diagnostics | |
1018 | (fn display => | |
1019 | display (Function.layout f)) | |
1020 | val f = restore f | |
1021 | val _ = Control.diagnostics | |
1022 | (fn display => | |
1023 | display (Function.layout f)) | |
1024 | val f = shrink f | |
1025 | val _ = Control.diagnostics | |
1026 | (fn display => | |
1027 | display (Function.layout f)) | |
1028 | val _ = Function.clear f | |
1029 | in | |
1030 | f | |
1031 | end) | |
1032 | val program = Program.T {datatypes = datatypes, | |
1033 | globals = globals, | |
1034 | functions = functions, | |
1035 | main = main} | |
1036 | val _ = Program.clearTop program | |
1037 | in | |
1038 | program | |
1039 | end | |
1040 | end |