Commit | Line | Data |
---|---|---|
7f918cf1 CE |
1 | (* Copyright (C) 2009 Matthew Fluet. |
2 | * Copyright (C) 2004-2006, 2008 Henry Cejtin, Matthew Fluet, Suresh | |
3 | * Jagannathan, and Stephen Weeks. | |
4 | * | |
5 | * MLton is released under a BSD-style license. | |
6 | * See the file MLton-LICENSE for details. | |
7 | *) | |
8 | ||
9 | functor Zone (S: SSA2_TRANSFORM_STRUCTS): SSA2_TRANSFORM = | |
10 | struct | |
11 | ||
12 | open S | |
13 | ||
14 | structure Graph = DirectedGraph | |
15 | local | |
16 | open Graph | |
17 | in | |
18 | structure Node = Node | |
19 | end | |
20 | ||
21 | structure Scope = UniqueId () | |
22 | ||
23 | fun zoneFunction f = | |
24 | let | |
25 | val {args, mayInline, name, raises, returns, start, ...} = Function.dest f | |
26 | datatype z = datatype Exp.t | |
27 | datatype z = datatype Statement.t | |
28 | val {get = labelInfo: Label.t -> {isInLoop: bool ref, | |
29 | isCut: bool ref}, ...} = | |
30 | Property.get (Label.plist, | |
31 | Property.initFun (fn _ => {isCut = ref false, | |
32 | isInLoop = ref false})) | |
33 | (* Mark nodes that are in loops so that we can avoid inserting tuple | |
34 | * constructions there. | |
35 | *) | |
36 | val {graph, nodeBlock, ...} = Function.controlFlow f | |
37 | val () = | |
38 | List.foreach | |
39 | (Graph.stronglyConnectedComponents graph, fn ns => | |
40 | let | |
41 | fun doit () = | |
42 | List.foreach | |
43 | (ns, fn n => | |
44 | #isInLoop (labelInfo (Block.label (nodeBlock n))) := true) | |
45 | in | |
46 | case ns of | |
47 | [n] => if Node.hasEdge {from = n, to = n} | |
48 | then doit () | |
49 | else () | |
50 | | _ => doit () | |
51 | end) | |
52 | val dominatorTree = Function.dominatorTree f | |
53 | (* Decide which labels to cut at. *) | |
54 | val cutDepth = !Control.zoneCutDepth | |
55 | fun addCuts (Tree.T (b, ts), depth: int) = | |
56 | let | |
57 | val depth = | |
58 | if depth = 0 | |
59 | then | |
60 | let | |
61 | val Block.T {label, ...} = b | |
62 | val {isCut, isInLoop, ...} = labelInfo label | |
63 | val () = | |
64 | if !isInLoop | |
65 | then | |
66 | Control.diagnostic | |
67 | (fn () => | |
68 | let | |
69 | open Layout | |
70 | in | |
71 | seq [str "skipping cut at ", | |
72 | Label.layout label] | |
73 | end) | |
74 | else isCut := true | |
75 | in | |
76 | cutDepth | |
77 | end | |
78 | else depth - 1 | |
79 | in | |
80 | Vector.foreach (ts, fn t => addCuts (t, depth)) | |
81 | end | |
82 | val () = addCuts (dominatorTree, cutDepth) | |
83 | (* Build a tuple of lives at each cut node. *) | |
84 | type info = {componentsRev: Var.t list ref, | |
85 | numComponents: int ref, | |
86 | scope: Scope.t, | |
87 | tuple: Var.t} | |
88 | fun newInfo () = | |
89 | {componentsRev = ref [], | |
90 | numComponents = ref 0, | |
91 | scope = Scope.new (), | |
92 | tuple = Var.newNoname ()} | |
93 | datatype varInfo = | |
94 | Global | |
95 | | Local of {blockCache: Var.t option ref, | |
96 | defScope: Scope.t, | |
97 | ty: Type.t, | |
98 | uses: {exp: Exp.t, | |
99 | scope: Scope.t} list ref} | |
100 | val {get = varInfo: Var.t -> varInfo, | |
101 | set = setVarInfo, ...} = | |
102 | Property.getSetOnce (Var.plist, | |
103 | Property.initFun (fn _ => Global)) | |
104 | val blockSelects: {blockCache: Var.t option ref, | |
105 | statement: Statement.t} list ref = ref [] | |
106 | fun addBlockSelects (ss: Statement.t vector): Statement.t vector = | |
107 | let | |
108 | val blockSelectsV = Vector.fromList (!blockSelects) | |
109 | val () = Vector.foreach (blockSelectsV, fn {blockCache, ...} => | |
110 | blockCache := NONE) | |
111 | val () = blockSelects := [] | |
112 | in | |
113 | Vector.concat [Vector.map (blockSelectsV, #statement), ss] | |
114 | end | |
115 | fun define (x: Var.t, ty: Type.t, info: info): unit = | |
116 | setVarInfo (x, Local {blockCache = ref NONE, | |
117 | defScope = #scope info, | |
118 | ty = ty, | |
119 | uses = ref []}) | |
120 | fun replaceVar (x: Var.t, | |
121 | {componentsRev, numComponents, scope, tuple}: info) | |
122 | : Var.t = | |
123 | case varInfo x of | |
124 | Global => x | |
125 | | Local {blockCache, defScope, ty, uses, ...} => | |
126 | case !blockCache of | |
127 | SOME y => y | |
128 | | _ => | |
129 | if Scope.equals (defScope, scope) | |
130 | then x | |
131 | else | |
132 | let | |
133 | fun new () = | |
134 | let | |
135 | val offset = !numComponents | |
136 | val () = List.push (componentsRev, x) | |
137 | val () = numComponents := 1 + offset | |
138 | val exp = Select {base = Base.Object tuple, | |
139 | offset = offset} | |
140 | val () = List.push (uses, {exp = exp, | |
141 | scope = scope}) | |
142 | in | |
143 | exp | |
144 | end | |
145 | val exp = | |
146 | case !uses of | |
147 | [] => new () | |
148 | | {exp, scope = scope'} :: _ => | |
149 | if Scope.equals (scope, scope') | |
150 | then exp | |
151 | else new () | |
152 | val y = Var.new x | |
153 | val () = blockCache := SOME y | |
154 | val () = | |
155 | List.push | |
156 | (blockSelects, | |
157 | {blockCache = blockCache, | |
158 | statement = Bind {exp = exp, | |
159 | ty = ty, | |
160 | var = SOME y}}) | |
161 | in | |
162 | y | |
163 | end | |
164 | val blocks = ref [] | |
165 | fun loop (Tree.T (b, ts), info: info) = | |
166 | let | |
167 | val Block.T {args, label, statements, transfer} = b | |
168 | val {isCut = ref isCut, ...} = labelInfo label | |
169 | val info' = | |
170 | if isCut | |
171 | then newInfo () | |
172 | else info | |
173 | val define = fn (x, t) => define (x, t, info') | |
174 | val () = Vector.foreach (args, define) | |
175 | val statements = | |
176 | Vector.map | |
177 | (statements, fn s => | |
178 | let | |
179 | val s = Statement.replaceUses (s, fn x => | |
180 | replaceVar (x, info')) | |
181 | val () = Statement.foreachDef (s, define) | |
182 | in | |
183 | s | |
184 | end) | |
185 | val transfer = | |
186 | Transfer.replaceVar (transfer, fn x => replaceVar (x, info')) | |
187 | val statements = addBlockSelects statements | |
188 | val () = Vector.foreach (ts, fn t => loop (t, info')) | |
189 | val statements = | |
190 | if not isCut | |
191 | then statements | |
192 | else | |
193 | let | |
194 | val {componentsRev, tuple, ...} = info' | |
195 | val components = Vector.fromListRev (!componentsRev) | |
196 | in | |
197 | if Vector.isEmpty components | |
198 | then statements | |
199 | else | |
200 | let | |
201 | val componentTys = | |
202 | Vector.map | |
203 | (components, fn x => | |
204 | case varInfo x of | |
205 | Global => Error.bug "Zone.zoneFunction: global component" | |
206 | | Local {ty, uses, ...} => | |
207 | (ignore (List.pop uses) | |
208 | ; {elt = ty, | |
209 | isMutable = false})) | |
210 | val components = | |
211 | Vector.map (components, fn x => | |
212 | replaceVar (x, info)) | |
213 | val s = | |
214 | Bind | |
215 | {exp = Object {args = components, con = NONE}, | |
216 | ty = Type.tuple (Prod.make componentTys), | |
217 | var = SOME tuple} | |
218 | in | |
219 | addBlockSelects (Vector.concat [Vector.new1 s, | |
220 | statements]) | |
221 | end | |
222 | end | |
223 | val () = List.push (blocks, | |
224 | Block.T {args = args, | |
225 | label = label, | |
226 | statements = statements, | |
227 | transfer = transfer}) | |
228 | in | |
229 | () | |
230 | end | |
231 | val () = loop (dominatorTree, newInfo ()) | |
232 | val blocks = Vector.fromList (!blocks) | |
233 | in | |
234 | Function.new {args = args, | |
235 | blocks = blocks, | |
236 | mayInline = mayInline, | |
237 | name = name, | |
238 | raises = raises, | |
239 | returns = returns, | |
240 | start = start} | |
241 | end | |
242 | ||
243 | fun maybeZoneFunction (f, ac) = | |
244 | let | |
245 | val {blocks, name, ...} = Function.dest f | |
246 | val () = | |
247 | Control.diagnostic | |
248 | (fn () => | |
249 | let | |
250 | open Layout | |
251 | in | |
252 | seq [Func.layout name, str " has ", str " blocks."] | |
253 | end) | |
254 | in | |
255 | if Vector.length blocks <= !Control.maxFunctionSize | |
256 | then f :: ac | |
257 | else zoneFunction f :: ac | |
258 | end | |
259 | ||
260 | fun transform2 (Program.T {datatypes, globals, functions, main}) = | |
261 | Program.T {datatypes = datatypes, | |
262 | globals = globals, | |
263 | functions = List.fold (functions, [], maybeZoneFunction), | |
264 | main = main} | |
265 | ||
266 | end |