HCoop / hcoop / debian / mlton.git / blob
? search:
summary | shortlog | log | commit | commitdiff | tree
blame | history | raw | HEAD
Import Upstream version 20180207
[hcoop/debian/mlton.git] / mlton / ssa / contify.fun
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
mlton packaging