Commit | Line | Data |
---|---|---|
7f918cf1 CE |
1 | (* Copyright (C) 1999-2005, 2008 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 | (* Change any toplevel function that only calls itself in tail position | |
10 | * into one with a local loop and no self calls. | |
11 | *) | |
12 | functor IntroduceLoops (S: SSA_TRANSFORM_STRUCTS): SSA_TRANSFORM = | |
13 | struct | |
14 | ||
15 | open S | |
16 | datatype z = datatype Exp.t | |
17 | datatype z = datatype Transfer.t | |
18 | ||
19 | structure Return = | |
20 | struct | |
21 | open Return | |
22 | ||
23 | fun isTail (z: t): bool = | |
24 | case z of | |
25 | Dead => false | |
26 | | NonTail _ => false | |
27 | | Tail => true | |
28 | end | |
29 | ||
30 | fun transform (Program.T {datatypes, globals, functions, main}) = | |
31 | let | |
32 | val functions = | |
33 | List.revMap | |
34 | (functions, fn f => | |
35 | let | |
36 | val {args, blocks, mayInline, name, raises, returns, start} = | |
37 | Function.dest f | |
38 | val tailCallsItself = ref false | |
39 | val _ = | |
40 | Vector.foreach | |
41 | (blocks, fn Block.T {transfer, ...} => | |
42 | case transfer of | |
43 | Call {func, return, ...} => | |
44 | if Func.equals (name, func) | |
45 | andalso Return.isTail return | |
46 | then tailCallsItself := true | |
47 | else () | |
48 | | _ => ()) | |
49 | val (args, start, blocks) = | |
50 | if !tailCallsItself | |
51 | then | |
52 | let | |
53 | val _ = Control.diagnostics | |
54 | (fn display => | |
55 | let open Layout | |
56 | in | |
57 | display (Func.layout name) | |
58 | end) | |
59 | val newArgs = | |
60 | Vector.map (args, fn (x, t) => (Var.new x, t)) | |
61 | val loopName = Label.newString "loop" | |
62 | val loopSName = Label.newString "loopS" | |
63 | val blocks = | |
64 | Vector.toListMap | |
65 | (blocks, | |
66 | fn Block.T {label, args, statements, transfer} => | |
67 | let | |
68 | val transfer = | |
69 | case transfer of | |
70 | Call {func, args, return} => | |
71 | if Func.equals (name, func) | |
72 | andalso Return.isTail return | |
73 | then Goto {dst = loopName, | |
74 | args = args} | |
75 | else transfer | |
76 | | _ => transfer | |
77 | in | |
78 | Block.T {label = label, | |
79 | args = args, | |
80 | statements = statements, | |
81 | transfer = transfer} | |
82 | end) | |
83 | val blocks = | |
84 | Vector.fromList | |
85 | (Block.T | |
86 | {label = loopSName, | |
87 | args = Vector.new0 (), | |
88 | statements = Vector.new0 (), | |
89 | transfer = Goto {dst = loopName, | |
90 | args = Vector.map (newArgs, #1)}} :: | |
91 | Block.T | |
92 | {label = loopName, | |
93 | args = args, | |
94 | statements = Vector.new0 (), | |
95 | transfer = Goto {dst = start, | |
96 | args = Vector.new0 ()}} :: | |
97 | blocks) | |
98 | in | |
99 | (newArgs, | |
100 | loopSName, | |
101 | blocks) | |
102 | end | |
103 | else (args, start, blocks) | |
104 | in | |
105 | Function.new {args = args, | |
106 | blocks = blocks, | |
107 | mayInline = mayInline, | |
108 | name = name, | |
109 | raises = raises, | |
110 | returns = returns, | |
111 | start = start} | |
112 | end) | |
113 | in | |
114 | Program.T {datatypes = datatypes, | |
115 | globals = globals, | |
116 | functions = functions, | |
117 | main = main} | |
118 | end | |
119 | ||
120 | end |