Commit | Line | Data |
---|---|---|
7f918cf1 CE |
1 | (* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh |
2 | * Jagannathan, and Stephen Weeks. | |
3 | * Copyright (C) 1997-2000 NEC Research Institute. | |
4 | * | |
5 | * MLton is released under a BSD-style license. | |
6 | * See the file MLton-LICENSE for details. | |
7 | *) | |
8 | ||
9 | (* | |
10 | * This pass is based on | |
11 | * Contification Using Dominators, by Fluet and Weeks. ICFP 2001. | |
12 | *) | |
13 | ||
14 | functor Contify (S: SSA_TRANSFORM_STRUCTS): SSA_TRANSFORM = | |
15 | struct | |
16 | ||
17 | open S | |
18 | open Transfer | |
19 | ||
20 | structure Cont = | |
21 | struct | |
22 | type t = {cont: Label.t, handler: Handler.t} | |
23 | ||
24 | fun layout {cont, handler} | |
25 | = let | |
26 | open Layout | |
27 | in | |
28 | tuple2 (Label.layout, Handler.layout) (cont, handler) | |
29 | end | |
30 | end | |
31 | ||
32 | (* Return = {Uncalled, Unknown} U Cont U Func | |
33 | *) | |
34 | structure Areturn = | |
35 | struct | |
36 | datatype t | |
37 | = Uncalled | |
38 | | Unknown | |
39 | | Cont of Cont.t | |
40 | | Func of Func.t | |
41 | ||
42 | fun layout r | |
43 | = let | |
44 | open Layout | |
45 | in | |
46 | case r | |
47 | of Uncalled => str "Uncalled" | |
48 | | Unknown => str "Unknown" | |
49 | | Cont c => Cont.layout c | |
50 | | Func f => Func.layout f | |
51 | end | |
52 | end | |
53 | ||
54 | structure ContData = | |
55 | struct | |
56 | datatype t = T of {node: unit DirectedGraph.Node.t option ref, | |
57 | rootEdge: bool ref, | |
58 | prefixes: Func.t list ref} | |
59 | ||
60 | fun new () = T {node = ref NONE, | |
61 | rootEdge = ref false, | |
62 | prefixes = ref []} | |
63 | ||
64 | local | |
65 | fun make s = let | |
66 | fun S' (T r) = s r | |
67 | val S = ! o S' | |
68 | in | |
69 | (S', S) | |
70 | end | |
71 | in | |
72 | val (node', _) = make #node | |
73 | val (rootEdge', _) = make #rootEdge | |
74 | val (prefixes', prefixes) = make #prefixes | |
75 | end | |
76 | fun nodeReset (T {node, ...}) = node := NONE | |
77 | end | |
78 | ||
79 | structure FuncData = | |
80 | struct | |
81 | datatype t = T of {node: unit DirectedGraph.Node.t option ref, | |
82 | reach: bool ref, | |
83 | callers: {nontail: (Func.t * Cont.t) list ref, | |
84 | tail: Func.t list ref}, | |
85 | callees: {nontail: (Func.t * Cont.t) list ref, | |
86 | tail: Func.t list ref}, | |
87 | A: Areturn.t ref, | |
88 | prefixes: Func.t list ref, | |
89 | finished: bool ref, | |
90 | replace: {label: Label.t, | |
91 | blocks: Block.t list} option ref, | |
92 | contified: Block.t list list ref} | |
93 | ||
94 | fun new () = T {node = ref NONE, | |
95 | reach = ref false, | |
96 | callers = {nontail = ref [], tail = ref []}, | |
97 | callees = {nontail = ref [], tail = ref []}, | |
98 | A = ref Areturn.Uncalled, | |
99 | prefixes = ref [], | |
100 | finished = ref false, | |
101 | replace = ref NONE, | |
102 | contified = ref []} | |
103 | ||
104 | local | |
105 | fun make s = let | |
106 | fun S' (T r) = s r | |
107 | val S = ! o S' | |
108 | in | |
109 | (S', S) | |
110 | end | |
111 | fun make' s = let | |
112 | fun S' (T r) = s r | |
113 | in | |
114 | S' | |
115 | end | |
116 | in | |
117 | val (node', _) = make #node | |
118 | val (reach', reach) = make #reach | |
119 | val callers' = make' #callers | |
120 | val callees' = make' #callees | |
121 | val (_, A) = make #A | |
122 | val (prefixes', prefixes) = make #prefixes | |
123 | val (finished', _) = make #finished | |
124 | val (_, replace) = make #replace | |
125 | val (contified', contified) = make #contified | |
126 | end | |
127 | fun nodeReset (T {node, ...}) = node := NONE | |
128 | end | |
129 | ||
130 | structure ContFuncGraph = | |
131 | struct | |
132 | structure Graph = DirectedGraph | |
133 | structure Node = Graph.Node | |
134 | ||
135 | datatype t = ContNode of Cont.t | |
136 | | FuncNode of Func.t | |
137 | fun newContFuncGraph {getContData: Cont.t -> ContData.t, | |
138 | getFuncData: Func.t -> FuncData.t} | |
139 | = let | |
140 | val G = Graph.new () | |
141 | fun addEdge edge | |
142 | = ignore (Graph.addEdge (G, edge)) | |
143 | val {get = getNodeInfo : unit Node.t -> t, | |
144 | set = setNodeInfo, ...} | |
145 | = Property.getSetOnce | |
146 | (Node.plist, | |
147 | Property.initRaise ("nodeInfo", Node.layout)) | |
148 | fun getFuncNode f | |
149 | = let | |
150 | val node = FuncData.node' (getFuncData f) | |
151 | in | |
152 | case !node | |
153 | of SOME n => n | |
154 | | NONE => let | |
155 | val n = Graph.newNode G | |
156 | in | |
157 | setNodeInfo (n, FuncNode f); | |
158 | node := SOME n; | |
159 | n | |
160 | end | |
161 | end | |
162 | ||
163 | fun getContNode c | |
164 | = let | |
165 | val node = ContData.node' (getContData c) | |
166 | in | |
167 | case !node | |
168 | of SOME n => n | |
169 | | NONE => let | |
170 | val n = Graph.newNode G | |
171 | in | |
172 | setNodeInfo (n, ContNode c); | |
173 | node := SOME n; | |
174 | n | |
175 | end | |
176 | end | |
177 | ||
178 | fun reset p | |
179 | = Graph.foreachNode | |
180 | (G, | |
181 | fn n => if p n | |
182 | then case getNodeInfo n | |
183 | of ContNode c | |
184 | => ContData.nodeReset (getContData c) | |
185 | | FuncNode f | |
186 | => FuncData.nodeReset (getFuncData f) | |
187 | else ()) | |
188 | in | |
189 | {G = G, | |
190 | addEdge = addEdge, | |
191 | getNodeInfo = getNodeInfo, | |
192 | getContNode = getContNode, | |
193 | getFuncNode = getFuncNode, | |
194 | reset = reset} | |
195 | end | |
196 | fun newFuncGraph {getFuncData: Func.t -> FuncData.t} | |
197 | = let | |
198 | val {G, addEdge, getNodeInfo, getFuncNode, reset, ...} | |
199 | = newContFuncGraph {getContData = fn _ => Error.bug "Contify.ContFuncGraph.newFuncGraph", | |
200 | getFuncData = getFuncData} | |
201 | in | |
202 | {G = G, | |
203 | addEdge = addEdge, | |
204 | getNodeInfo = fn n => case getNodeInfo n | |
205 | of FuncNode f => f | |
206 | | ContNode _ => Error.bug "Contify.ContFuncGraph.newFuncGraph", | |
207 | getFuncNode = getFuncNode, | |
208 | reset = reset} | |
209 | end | |
210 | end | |
211 | ||
212 | structure InitReachCallersCallees = | |
213 | struct | |
214 | structure Graph = DirectedGraph | |
215 | structure DfsParam = Graph.DfsParam | |
216 | ||
217 | (* Define Reach: Func -> Bool as follows: | |
218 | * Reach (f) iff there is a path of calls from fm to f. | |
219 | * | |
220 | * Define NontailCallers: Func -> P (Func x Cont) as follows: | |
221 | * NontailCallers (f) = {(g, c) | (g, f, c) in N} | |
222 | * Define TailCallers: Func -> P (Func) as follows: | |
223 | * Callers (f) = {g | (g, f) in T} | |
224 | * Define NontailCallees: Func -> P (Func x Cont) as follows: | |
225 | * NontailCallers (f) = {(g, c) | (f, g, c) in N} | |
226 | * Define TailCallees: Func -> P (Func) as follows: | |
227 | * Callers (f) = {g | (f, g) in T} | |
228 | * | |
229 | * Precondition: forall f in Func. (FuncData.node o getFuncData) f = NONE | |
230 | * forall f in Func. (FuncData.callers o getFuncData) f | |
231 | * = {nontail = [], tail = []} | |
232 | * forall f in Func. (FuncData.callees o getFuncData) f | |
233 | * = {nontail = [], tail = []} | |
234 | * Postcondition: FuncData.reach o getFuncData = Reach | |
235 | * #nontail (FuncData.callers o getFuncData) | |
236 | * = NontailCallers | |
237 | * #tail (FuncData.callers o getFuncData) | |
238 | * = TailCallers | |
239 | * #nontail (FuncData.callees o getFuncData) | |
240 | * = NontailCallees | |
241 | * #tail (FuncData.callees o getFuncData) | |
242 | * = TailCallees | |
243 | *) | |
244 | fun initReachCallersCallees | |
245 | {program = Program.T {functions, main = fm, ...}, | |
246 | getFuncData: Func.t -> FuncData.t} : unit | |
247 | = let | |
248 | val {G, addEdge, getNodeInfo, getFuncNode, reset, ...} | |
249 | = ContFuncGraph.newFuncGraph {getFuncData = getFuncData} | |
250 | ||
251 | val _ | |
252 | = List.foreach | |
253 | (functions, | |
254 | fn func | |
255 | => let | |
256 | val {name = f, blocks, ...} = Function.dest func | |
257 | val callees = FuncData.callees' (getFuncData f) | |
258 | val f_node = getFuncNode f | |
259 | in | |
260 | Vector.foreach | |
261 | (blocks, | |
262 | fn Block.T {transfer = Call {func = g, return, ...}, ...} | |
263 | => let | |
264 | val callers = FuncData.callers' (getFuncData g) | |
265 | val g_node = getFuncNode g | |
266 | val _ = | |
267 | case return of | |
268 | Return.NonTail c => | |
269 | (List.push (#nontail callees, (g, c)); | |
270 | List.push (#nontail callers, (f, c))) | |
271 | | _ => (List.push (#tail callees, g); | |
272 | List.push (#tail callers, f)) | |
273 | in | |
274 | addEdge {from = f_node, | |
275 | to = g_node} | |
276 | end | |
277 | | _ => ()) | |
278 | end) | |
279 | ||
280 | val dfs_param | |
281 | = DfsParam.finishNode | |
282 | (fn n => FuncData.reach' (getFuncData (getNodeInfo n)) := true) | |
283 | val fm_node = getFuncNode fm | |
284 | in | |
285 | Graph.dfsNodes (G, [fm_node], dfs_param); | |
286 | reset (fn _ => true) | |
287 | end | |
288 | val initReachCallersCallees | |
289 | = Control.trace (Control.Detail, "initReachCallerCallees") | |
290 | initReachCallersCallees | |
291 | end | |
292 | ||
293 | structure AnalyzeDom = | |
294 | struct | |
295 | structure Graph = DirectedGraph | |
296 | structure Node = Graph.Node | |
297 | ||
298 | (* Now define a directed graph G = (Node, Edge) where | |
299 | * Node = Cont U Fun U {Root} | |
300 | * Edge = {(Root, fm)} | |
301 | * U {(Root, c) | c in Cont} | |
302 | * U {(Root, f) | not (Reach (f))} | |
303 | * U {(f, g) | (f, g) in T and Reach (f)} | |
304 | * U {(c, g) | (f, g, c) in N and Reach (f)} | |
305 | * | |
306 | * Let D be the dominator tree of G rooted at Root. | |
307 | * For f in Fun, let idom (f) be the parent of f in D. | |
308 | * | |
309 | * Define an analysis, A_Dom, based on D as follows: | |
310 | * A_Dom (f) = | |
311 | * if idom (f) = Root | |
312 | * then if Reach (f) then Unknown else Uncalled | |
313 | * else the ancestor g of f in D such that idom (g) = Root | |
314 | * | |
315 | * Precondition: forall c in Cont. (ContData.node o getContData) c = NONE | |
316 | * forall c in Cont. (ContData.rootEdge o getContData) c = false | |
317 | * forall f in Func. (FuncData.node o getFuncData) f = NONE | |
318 | * forall f in Func. (FuncData.reach o getFuncData) f = Reach | |
319 | * Postcondition: FuncData.ADom o getFuncData = A_Dom | |
320 | * forall c in Cont. (ContData.node o getContData) c = NONE | |
321 | * forall f in Func. (FuncData.node o getFuncData) f = NONE | |
322 | *) | |
323 | fun analyzeDom {program as Program.T {functions, main = fm, ...}, | |
324 | getContData: Cont.t -> ContData.t, | |
325 | getFuncData: Func.t -> FuncData.t} : unit | |
326 | = let | |
327 | datatype z = datatype Areturn.t | |
328 | ||
329 | val {G, addEdge, getNodeInfo, getContNode, getFuncNode, reset, ...} | |
330 | = ContFuncGraph.newContFuncGraph {getContData = getContData, | |
331 | getFuncData = getFuncData} | |
332 | val Root = DirectedGraph.newNode G | |
333 | ||
334 | fun buildGraph () = let | |
335 | val fm_node = getFuncNode fm | |
336 | (* {(Root, fm)} *) | |
337 | val _ = addEdge {from = Root, to = fm_node} | |
338 | (* { (Root, f) | fm calls f } *) | |
339 | val () = | |
340 | if !Control.contifyIntoMain | |
341 | then () | |
342 | else | |
343 | let | |
344 | val {blocks, ...} = | |
345 | Function.dest (Program.mainFunction program) | |
346 | in | |
347 | Vector.foreach | |
348 | (blocks, fn Block.T {transfer, ...} => | |
349 | case transfer of | |
350 | Call {func, ...} => | |
351 | addEdge {from = Root, to = getFuncNode func} | |
352 | | _ => ()) | |
353 | end | |
354 | val _ | |
355 | = List.foreach | |
356 | (functions, | |
357 | fn func | |
358 | => let | |
359 | val {name = f, blocks, ...} = Function.dest func | |
360 | val f_reach = FuncData.reach (getFuncData f) | |
361 | val f_node = getFuncNode f | |
362 | in | |
363 | if f_reach | |
364 | then Vector.foreach | |
365 | (blocks, | |
366 | fn Block.T {transfer = Call {func = g, return, ...}, ...} | |
367 | => if FuncData.reach (getFuncData g) | |
368 | then let | |
369 | val g_node = getFuncNode g | |
370 | in | |
371 | case return of | |
372 | Return.Dead => | |
373 | (* When compiling with profiling, | |
374 | * Dead returns are allowed to | |
375 | * have nonempty source stacks | |
376 | * (see type-check.fun). So, we | |
377 | * can't contify functions that | |
378 | * are called with a Dead cont. | |
379 | *) | |
380 | addEdge {from = Root, | |
381 | to = g_node} | |
382 | | Return.NonTail c => | |
383 | let | |
384 | val c_node = getContNode c | |
385 | val rootEdge | |
386 | = ContData.rootEdge' | |
387 | (getContData c) | |
388 | in | |
389 | if !rootEdge | |
390 | then () | |
391 | else ((* {(Root, c) | c in Cont} *) | |
392 | addEdge {from = Root, | |
393 | to = c_node}; | |
394 | rootEdge := true); | |
395 | (* {(c, g) | (f, g, c) in N | |
396 | * and Reach (f)} *) | |
397 | addEdge {from = c_node, | |
398 | to = g_node} | |
399 | end | |
400 | | _ => | |
401 | (* {(f, g) | (f, g) in T | |
402 | * and Reach (f)} *) | |
403 | addEdge {from = f_node, | |
404 | to = g_node} | |
405 | end | |
406 | else () | |
407 | | _ => ()) | |
408 | else (* {(Root, f) | not (Reach (f))} *) | |
409 | addEdge {from = Root, | |
410 | to = f_node} | |
411 | end) | |
412 | in () end | |
413 | val buildGraph | |
414 | = Control.trace (Control.Detail, "buildGraph") buildGraph | |
415 | val _ = buildGraph () | |
416 | ||
417 | fun computeDominators () = let | |
418 | val {idom} = Graph.dominators (G, {root = Root}) | |
419 | in idom end | |
420 | val computeDominators | |
421 | = Control.trace (Control.Detail, "computeDominators") computeDominators | |
422 | val idom = computeDominators () | |
423 | ||
424 | fun computeADom () = let | |
425 | fun ancestor node = | |
426 | case idom node of | |
427 | Graph.Idom parent => | |
428 | if Node.equals (parent, Root) | |
429 | then node | |
430 | else ancestor parent | |
431 | | Graph.Root => node | |
432 | | Graph.Unreachable => Error.bug "Contify.AnalyzeDom.ancestor: unreachable" | |
433 | ||
434 | val _ | |
435 | = List.foreach | |
436 | (functions, | |
437 | fn func | |
438 | => let | |
439 | val {name = f, ...} = Function.dest func | |
440 | val FuncData.T {A, reach, node, ...} = getFuncData f | |
441 | val f_ADom = A | |
442 | val f_reach = !reach | |
443 | val f_node = valOf (!node) | |
444 | datatype z = datatype ContFuncGraph.t | |
445 | in | |
446 | if (case idom f_node of | |
447 | Graph.Idom n => Node.equals (n, Root) | |
448 | | Graph.Root => true | |
449 | | Graph.Unreachable => Error.bug "Contify.AnalyzeDom.idom: unreachable") | |
450 | then if f_reach | |
451 | then f_ADom := Unknown | |
452 | else f_ADom := Uncalled | |
453 | else let | |
454 | (* Use this for the ancestor version *) | |
455 | val l_node = ancestor f_node | |
456 | (* Use this for the parent version *) | |
457 | (* val l_node = idom f_node *) | |
458 | in | |
459 | case getNodeInfo l_node | |
460 | of FuncNode g => f_ADom := Func g | |
461 | | ContNode c => f_ADom := Cont c | |
462 | end | |
463 | end) | |
464 | in () end | |
465 | val computeADom | |
466 | = Control.trace (Control.Detail, "compute ADom") computeADom | |
467 | val _ = computeADom () | |
468 | ||
469 | val _ = reset (fn n => not (Node.equals (n, Root))) | |
470 | in | |
471 | () | |
472 | end | |
473 | val analyzeDom | |
474 | = Control.trace (Control.Detail, "analyzeDom") analyzeDom | |
475 | end | |
476 | ||
477 | structure Transform = | |
478 | struct | |
479 | (* | |
480 | * Precondition: forall c in Cont. (ContData.node o getContData) c = NONE | |
481 | * forall c in Cont. (ContData.prefixes o getContData) c = [] | |
482 | * forall f in Func. (FuncData.node o getFuncData) f = NONE | |
483 | * FuncData.A o getFuncData = A | |
484 | * where A is a safe analysis | |
485 | * FuncData.callers o getFuncData | |
486 | * = {nontail = NontailCallers, tail = TailCallers} | |
487 | * FuncData.callees o getFuncData | |
488 | * = {nontail = NontailCallees, tail = TailCallees} | |
489 | * forall f in Func. (FuncData.prefixes o getFuncData) f = [] | |
490 | * forall f in Func. (FuncData.finished o getFuncData) f = false | |
491 | * forall f in Func. (FuncData.replace o getFuncData) f = NONE | |
492 | * Postcondition: forall c in Cont. (ContData.node o getContData) c = NONE | |
493 | * forall f in Func. (FuncData.node o getFuncData) f = NONE | |
494 | *) | |
495 | fun transform {program = Program.T {datatypes, globals, functions, main}, | |
496 | getFuncData: Func.t -> FuncData.t, | |
497 | getContData: Cont.t -> ContData.t} : Program.t | |
498 | = let | |
499 | datatype z = datatype Areturn.t | |
500 | ||
501 | (* For functions turned into continuations, | |
502 | * record their args, blocks, and new name. | |
503 | *) | |
504 | val _ | |
505 | = List.foreach | |
506 | (functions, | |
507 | fn func | |
508 | => let | |
509 | val {name = f, | |
510 | args = f_args, | |
511 | blocks = f_blocks, | |
512 | start = f_start, | |
513 | ...} = Function.dest func | |
514 | val FuncData.T {A, replace, ...} = getFuncData f | |
515 | ||
516 | val _ = Control.diagnostics | |
517 | (fn display | |
518 | => let open Layout | |
519 | in display (seq [str "A(", | |
520 | Func.layout f, | |
521 | str ") = ", | |
522 | Areturn.layout (!A)]) | |
523 | end) | |
524 | ||
525 | ||
526 | fun contify prefixes | |
527 | = let | |
528 | val f_label = Label.newString (Func.originalName f) | |
529 | val _ = Control.diagnostics | |
530 | (fn display | |
531 | => let open Layout | |
532 | in display (seq [Func.layout f, | |
533 | str " -> ", | |
534 | Label.layout f_label]) | |
535 | end) | |
536 | val f_blocks | |
537 | = (Block.T {label = f_label, | |
538 | args = f_args, | |
539 | statements = Vector.new0 (), | |
540 | transfer = Goto {dst = f_start, | |
541 | args = Vector.new0 ()}}):: | |
542 | (Vector.toList f_blocks) | |
543 | in | |
544 | replace := SOME {label = f_label, | |
545 | blocks = f_blocks} ; | |
546 | List.push(prefixes, f) | |
547 | end | |
548 | in | |
549 | case !A | |
550 | of Uncalled => () | |
551 | | Unknown => () | |
552 | | Cont c => contify (ContData.prefixes' (getContData c)) | |
553 | | Func g => contify (FuncData.prefixes' (getFuncData g)) | |
554 | end) | |
555 | ||
556 | val traceAddFuncs = | |
557 | Trace.trace3 ("Contify.Transform.addFuncs", | |
558 | Func.layout, | |
559 | List.layout Func.layout, | |
560 | Return.layout, | |
561 | Unit.layout) | |
562 | val traceTransBlock = | |
563 | Trace.trace3 ("Contify.Transform.transBlock", | |
564 | Func.layout, | |
565 | Label.layout o Block.label, | |
566 | Return.layout, | |
567 | Layout.ignore) | |
568 | (* Walk over all functions, removing those that aren't top level, | |
569 | * and descening those that are, inserting local functions | |
570 | * where necessary. | |
571 | * - turn tail calls into nontail calls | |
572 | * - turn returns into gotos | |
573 | * - turn raises into gotos | |
574 | *) | |
575 | fun addFuncPrefixes (f: Func.t, | |
576 | g: Func.t, | |
577 | c: Return.t) : unit | |
578 | = let | |
579 | val prefixes = FuncData.prefixes (getFuncData g) | |
580 | val _ = Control.diagnostics | |
581 | (fn display | |
582 | => let open Layout | |
583 | in display (seq [str "addFuncPrefixes: ", | |
584 | Func.layout f, | |
585 | str " ", | |
586 | Func.layout g, | |
587 | str " ", | |
588 | List.layout Func.layout prefixes]) | |
589 | end) | |
590 | in | |
591 | addFuncs (f, prefixes, c) | |
592 | end | |
593 | and addContPrefixes (f: Func.t, | |
594 | r: Cont.t, | |
595 | c: Return.t): unit | |
596 | = let | |
597 | val prefixes = ContData.prefixes (getContData r) | |
598 | val _ = Control.diagnostics | |
599 | (fn display | |
600 | => let open Layout | |
601 | in display (seq [str "addContPrefixes: ", | |
602 | Func.layout f, | |
603 | str " ", | |
604 | Cont.layout r, | |
605 | str " ", | |
606 | List.layout Func.layout prefixes]) | |
607 | end) | |
608 | ||
609 | in | |
610 | addFuncs (f, prefixes, Return.compose (c, Return.NonTail r)) | |
611 | end | |
612 | and addFuncs arg : unit = | |
613 | traceAddFuncs | |
614 | (fn (f: Func.t, | |
615 | gs: Func.t list, | |
616 | c: Return.t) => | |
617 | List.foreach | |
618 | (gs, | |
619 | fn g => let | |
620 | val finished = FuncData.finished' (getFuncData g) | |
621 | in | |
622 | if !finished | |
623 | then () | |
624 | else (addFuncPrefixes(f, g, c); | |
625 | addBlocks | |
626 | (f, | |
627 | #blocks (valOf (FuncData.replace (getFuncData g))), | |
628 | c); | |
629 | finished := true) | |
630 | end) | |
631 | ) arg | |
632 | and addBlocks (f: Func.t, | |
633 | blocks: Block.t list, | |
634 | c: Return.t) : unit | |
635 | = let | |
636 | val contified' = List.map(blocks, | |
637 | fn block => transBlock (f, block, c)) | |
638 | val contified = FuncData.contified' (getFuncData f) | |
639 | in | |
640 | List.push(contified, contified') | |
641 | end | |
642 | and transBlock arg: Block.t = | |
643 | traceTransBlock | |
644 | (fn (f: Func.t, | |
645 | Block.T {label, args, statements, transfer}, | |
646 | c: Return.t) => | |
647 | let | |
648 | val transfer | |
649 | = case transfer | |
650 | of Call {func, args, return} | |
651 | => ((case return of | |
652 | Return.NonTail r => addContPrefixes (f, r, c) | |
653 | | _ => ()); | |
654 | case FuncData.replace (getFuncData func) of | |
655 | NONE => Call {func = func, | |
656 | args = args, | |
657 | return = Return.compose (c, return)} | |
658 | | SOME {label, ...} => | |
659 | Goto {dst = label, args = args}) | |
660 | | Return xs | |
661 | => (case c | |
662 | of Return.NonTail {cont, ...} | |
663 | => Goto {dst = cont, args = xs} | |
664 | | _ => transfer) | |
665 | | Raise xs | |
666 | => (case c | |
667 | of Return.NonTail {handler = Handler.Handle handler, ...} | |
668 | => Goto {dst = handler, args = xs} | |
669 | | _ => transfer) | |
670 | | _ => transfer | |
671 | in | |
672 | Block.T {label = label, | |
673 | args = args, | |
674 | statements = statements, | |
675 | transfer = transfer} | |
676 | end) arg | |
677 | ||
678 | val shrink = shrinkFunction {globals = globals} | |
679 | ||
680 | val functions | |
681 | = List.fold | |
682 | (functions, [], fn (func, ac) => | |
683 | let | |
684 | val {args = f_args, | |
685 | blocks = f_blocks, | |
686 | mayInline = f_mayInline, | |
687 | name = f, | |
688 | raises = f_raises, | |
689 | returns = f_returns, | |
690 | start = f_start} = Function.dest func | |
691 | in | |
692 | case FuncData.A (getFuncData f) | |
693 | of Unknown | |
694 | => let | |
695 | val _ = addFuncPrefixes (f, f, Return.Tail) | |
696 | val f_blocks = | |
697 | Vector.toListMap | |
698 | (f_blocks, fn block => | |
699 | transBlock (f, block, Return.Tail)) | |
700 | val f_blocks | |
701 | = f_blocks:: | |
702 | (FuncData.contified (getFuncData f)) | |
703 | val f_blocks | |
704 | = Vector.fromList (List.concat f_blocks) | |
705 | in | |
706 | shrink (Function.new {args = f_args, | |
707 | blocks = f_blocks, | |
708 | mayInline = f_mayInline, | |
709 | name = f, | |
710 | raises = f_raises, | |
711 | returns = f_returns, | |
712 | start = f_start}) | |
713 | :: ac | |
714 | end | |
715 | | _ => ac | |
716 | end) | |
717 | ||
718 | val program | |
719 | = Program.T {datatypes = datatypes, | |
720 | globals = globals, | |
721 | functions = functions, | |
722 | main = main} | |
723 | in | |
724 | program | |
725 | end | |
726 | val transform | |
727 | = Control.trace (Control.Detail, "transform") transform | |
728 | end | |
729 | ||
730 | fun transform (program as Program.T _) | |
731 | = let | |
732 | val {get = getLabelInfo : Label.t -> (Handler.t * ContData.t) list ref, | |
733 | ...} | |
734 | = Property.get | |
735 | (Label.plist, Property.initFun (fn _ => ref [])) | |
736 | val getContData : Cont.t -> ContData.t | |
737 | = fn {cont, handler} | |
738 | => let | |
739 | val l = getLabelInfo cont | |
740 | in | |
741 | case List.peek (!l, fn (handler', _) => | |
742 | Handler.equals (handler, handler')) | |
743 | of SOME (_, cd) => cd | |
744 | | NONE => let | |
745 | val cd = ContData.new () | |
746 | val _ = List.push(l, (handler, cd)) | |
747 | in | |
748 | cd | |
749 | end | |
750 | end | |
751 | val {get = getFuncData : Func.t -> FuncData.t, ...} | |
752 | = Property.get (Func.plist, | |
753 | Property.initFun | |
754 | (fn _ => FuncData.new ())) | |
755 | ||
756 | val _ = InitReachCallersCallees.initReachCallersCallees | |
757 | {program = program, | |
758 | getFuncData = getFuncData} | |
759 | val _ = AnalyzeDom.analyzeDom | |
760 | {program = program, | |
761 | getContData = getContData, | |
762 | getFuncData = getFuncData} | |
763 | val program = Transform.transform | |
764 | {program = program, | |
765 | getContData = getContData, | |
766 | getFuncData = getFuncData} | |
767 | val _ = Program.clearTop program | |
768 | in | |
769 | program | |
770 | end | |
771 | end |