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 | Defn: | |
11 | A label is exactly-multi-threaded if it may be executed by two | |
12 | different threads during some run of the program. The initial call to | |
13 | main counts as one thread. | |
14 | ||
15 | Defn: | |
16 | A label is actually-multi-used if it may be executed more than once | |
17 | during the execution of the program. | |
18 | *) | |
19 | ||
20 | functor Multi (S: MULTI_STRUCTS): MULTI = | |
21 | struct | |
22 | ||
23 | open S | |
24 | open Exp Transfer | |
25 | ||
26 | structure Graph = DirectedGraph | |
27 | local open Graph | |
28 | in | |
29 | structure Node = Node | |
30 | end | |
31 | ||
32 | structure Calls = | |
33 | struct | |
34 | datatype t = T of value ref | |
35 | and value = Zero | One | Many | |
36 | fun new (): t = T (ref Zero) | |
37 | fun inc (T r) | |
38 | = case !r | |
39 | of Zero => r := One | |
40 | | _ => r := Many | |
41 | val isMany | |
42 | = fn (T (ref Many)) => true | |
43 | | _ => false | |
44 | end | |
45 | ||
46 | structure ThreadCopyCurrent = | |
47 | struct | |
48 | structure L = TwoPointLattice (val bottom = "false" | |
49 | val top = "true") | |
50 | open L | |
51 | val force = makeTop | |
52 | val does = isTop | |
53 | val when = addHandler | |
54 | end | |
55 | ||
56 | structure MultiThreaded = | |
57 | struct | |
58 | structure L = TwoPointLattice (val bottom = "false" | |
59 | val top = "true") | |
60 | open L | |
61 | val force = makeTop | |
62 | val is = isTop | |
63 | val when = addHandler | |
64 | end | |
65 | ||
66 | structure MultiUsed = | |
67 | struct | |
68 | structure L = TwoPointLattice (val bottom = "false" | |
69 | val top = "true") | |
70 | open L | |
71 | val force = makeTop | |
72 | val is = isTop | |
73 | val when = addHandler | |
74 | end | |
75 | ||
76 | ||
77 | structure FuncInfo = | |
78 | struct | |
79 | datatype t = T of {calls: Calls.t, | |
80 | threadCopyCurrent: ThreadCopyCurrent.t, | |
81 | multiThreaded: MultiThreaded.t, | |
82 | multiUsed: MultiUsed.t} | |
83 | ||
84 | local | |
85 | fun make f (T r) = f r | |
86 | in | |
87 | val calls = make #calls | |
88 | val threadCopyCurrent = make #threadCopyCurrent | |
89 | val multiThreaded = make #multiThreaded | |
90 | val multiUsed = make #multiUsed | |
91 | end | |
92 | ||
93 | fun new (): t = T {calls = Calls.new (), | |
94 | threadCopyCurrent = ThreadCopyCurrent.new (), | |
95 | multiUsed = MultiUsed.new (), | |
96 | multiThreaded = MultiThreaded.new ()} | |
97 | end | |
98 | ||
99 | structure LabelInfo = | |
100 | struct | |
101 | datatype t = T of {threadCopyCurrent: ThreadCopyCurrent.t, | |
102 | multiThreaded: MultiThreaded.t, | |
103 | multiUsed: MultiUsed.t} | |
104 | ||
105 | local | |
106 | fun make f (T r) = f r | |
107 | in | |
108 | val threadCopyCurrent = make #threadCopyCurrent | |
109 | val multiThreaded = make #multiThreaded | |
110 | val multiUsed = make #multiUsed | |
111 | end | |
112 | ||
113 | fun new (): t = T {threadCopyCurrent = ThreadCopyCurrent.new (), | |
114 | multiThreaded = MultiThreaded.new (), | |
115 | multiUsed = MultiUsed.new ()} | |
116 | end | |
117 | ||
118 | structure VarInfo = | |
119 | struct | |
120 | datatype t = T of {multiThreaded: MultiThreaded.t, | |
121 | multiUsed: MultiUsed.t} | |
122 | ||
123 | local | |
124 | fun make f (T r) = f r | |
125 | in | |
126 | val multiThreaded = make #multiThreaded | |
127 | val multiUsed = make #multiUsed | |
128 | end | |
129 | ||
130 | fun new (): t = T {multiThreaded = MultiThreaded.new (), | |
131 | multiUsed = MultiUsed.new ()} | |
132 | end | |
133 | ||
134 | fun multi (p as Program.T {functions, main, ...}) | |
135 | = let | |
136 | val usesThreadsOrConts | |
137 | = Program.hasPrim (p, fn p => | |
138 | case Prim.name p of | |
139 | Prim.Name.Thread_switchTo => true | |
140 | | _ => false) | |
141 | ||
142 | (* funcNode *) | |
143 | val {get = funcNode: Func.t -> unit Node.t, | |
144 | set = setFuncNode, | |
145 | rem = remFuncNode, ...} | |
146 | = Property.getSetOnce | |
147 | (Func.plist, Property.initRaise ("Multi.funcNode", Func.layout)) | |
148 | ||
149 | (* nodeFunction *) | |
150 | val {get = nodeFunction: unit Node.t -> Function.t, | |
151 | set = setNodeFunction, ...} | |
152 | = Property.getSetOnce | |
153 | (Node.plist, Property.initRaise ("Multi.nodeFunc", Node.layout)) | |
154 | ||
155 | (* funcInfo *) | |
156 | val {get = funcInfo: Func.t -> FuncInfo.t, ...} | |
157 | = Property.get | |
158 | (Func.plist, Property.initFun (fn _ => FuncInfo.new ())) | |
159 | ||
160 | (* labelInfo *) | |
161 | val {get = labelInfo: Label.t -> LabelInfo.t, ...} | |
162 | = Property.get | |
163 | (Label.plist, Property.initFun (fn _ => LabelInfo.new ())) | |
164 | ||
165 | (* varInfo *) | |
166 | val {get = varInfo: Var.t -> VarInfo.t, ...} | |
167 | = Property.get | |
168 | (Var.plist, Property.initFun (fn _ => VarInfo.new ())) | |
169 | ||
170 | (* construct call graph | |
171 | * compute calls | |
172 | * compute threadCopyCurrent | |
173 | *) | |
174 | val G = Graph.new () | |
175 | fun newNode () = Graph.newNode G | |
176 | fun addEdge edge = ignore (Graph.addEdge (G, edge)) | |
177 | val _ = List.foreach | |
178 | (functions, fn f => | |
179 | let | |
180 | val n = newNode () | |
181 | in | |
182 | setFuncNode (Function.name f, n) ; | |
183 | setNodeFunction (n, f) | |
184 | end) | |
185 | val _ = Calls.inc (FuncInfo.calls (funcInfo main)) | |
186 | val _ = List.foreach | |
187 | (functions, fn f => | |
188 | let | |
189 | val {name = f, blocks, ...} = Function.dest f | |
190 | val fi = funcInfo f | |
191 | in | |
192 | Vector.foreach | |
193 | (blocks, fn Block.T {label, transfer, ...} => | |
194 | let | |
195 | val li = labelInfo label | |
196 | in | |
197 | case transfer | |
198 | of Call {func = g, ...} | |
199 | => let | |
200 | val gi = funcInfo g | |
201 | in | |
202 | Calls.inc (FuncInfo.calls gi) ; | |
203 | addEdge {from = funcNode f, | |
204 | to = funcNode g} ; | |
205 | if usesThreadsOrConts | |
206 | then ThreadCopyCurrent.when | |
207 | (FuncInfo.threadCopyCurrent gi, | |
208 | fn () => | |
209 | (ThreadCopyCurrent.force | |
210 | (LabelInfo.threadCopyCurrent li) ; | |
211 | ThreadCopyCurrent.force | |
212 | (FuncInfo.threadCopyCurrent fi))) | |
213 | else () | |
214 | end | |
215 | | Runtime {prim, ...} | |
216 | => if usesThreadsOrConts | |
217 | andalso | |
218 | (case Prim.name prim of | |
219 | Prim.Name.Thread_copyCurrent => true | |
220 | | _ => false) | |
221 | then (ThreadCopyCurrent.force | |
222 | (LabelInfo.threadCopyCurrent li) ; | |
223 | ThreadCopyCurrent.force | |
224 | (FuncInfo.threadCopyCurrent fi)) | |
225 | else () | |
226 | | _ => () | |
227 | end) | |
228 | end) | |
229 | val () = Graph.removeDuplicateEdges G | |
230 | val rec forceMultiThreadedVar | |
231 | = fn x => | |
232 | let | |
233 | val vi = varInfo x | |
234 | in | |
235 | MultiThreaded.force (VarInfo.multiThreaded vi) ; | |
236 | MultiUsed.force (VarInfo.multiUsed vi) | |
237 | end | |
238 | val rec forceMultiUsedVar | |
239 | = fn x => | |
240 | let | |
241 | val vi = varInfo x | |
242 | in | |
243 | MultiUsed.force (VarInfo.multiUsed vi) | |
244 | end | |
245 | val rec forceMultiThreadedFunc | |
246 | = fn f => | |
247 | let | |
248 | val fi = funcInfo f | |
249 | in | |
250 | MultiThreaded.force (FuncInfo.multiThreaded fi) ; | |
251 | MultiUsed.force (FuncInfo.multiUsed fi) | |
252 | end | |
253 | val rec forceMultiUsedFunc | |
254 | = fn f => | |
255 | let | |
256 | val fi = funcInfo f | |
257 | in | |
258 | MultiUsed.force (FuncInfo.multiUsed fi) | |
259 | end | |
260 | val rec forceMultiThreadedBlock | |
261 | = fn Block.T {label, args, statements, transfer} => | |
262 | let | |
263 | val li = labelInfo label | |
264 | in | |
265 | if MultiThreaded.is (LabelInfo.multiThreaded li) | |
266 | then () | |
267 | else (MultiThreaded.force (LabelInfo.multiThreaded li) ; | |
268 | MultiUsed.force (LabelInfo.multiUsed li) ; | |
269 | Vector.foreach (args, forceMultiThreadedVar o #1) ; | |
270 | Vector.foreach | |
271 | (statements, fn Statement.T {var, ...} => | |
272 | Option.app (var, forceMultiThreadedVar)) ; | |
273 | Transfer.foreachFunc | |
274 | (transfer, forceMultiThreadedFunc)) | |
275 | end | |
276 | val rec forceMultiThreadedBlockDFS | |
277 | = fn controlFlow as {graph = _, labelNode, nodeBlock} => | |
278 | fn block as Block.T {label, transfer, ...} => | |
279 | let | |
280 | val li = labelInfo label | |
281 | in | |
282 | if MultiThreaded.is (LabelInfo.multiThreaded li) | |
283 | then () | |
284 | else (forceMultiThreadedBlock block ; | |
285 | Transfer.foreachLabel | |
286 | (transfer, fn l => | |
287 | forceMultiThreadedBlockDFS controlFlow | |
288 | (nodeBlock (labelNode l)))) | |
289 | end | |
290 | val rec forceMultiUsedBlock | |
291 | = fn Block.T {label, args, statements, transfer} => | |
292 | let | |
293 | val li = labelInfo label | |
294 | in | |
295 | if MultiUsed.is (LabelInfo.multiUsed li) | |
296 | then () | |
297 | else (MultiUsed.force (LabelInfo.multiUsed li) ; | |
298 | Vector.foreach (args, forceMultiUsedVar o #1) ; | |
299 | Vector.foreach | |
300 | (statements, fn Statement.T {var, ...} => | |
301 | Option.app (var, forceMultiUsedVar)) ; | |
302 | Transfer.foreachFunc | |
303 | (transfer, forceMultiUsedFunc)) | |
304 | end | |
305 | val rec visitBlock | |
306 | = fn controlFlow as {graph = _, labelNode, nodeBlock} => | |
307 | fn Block.T {label, transfer, ...} => | |
308 | if ThreadCopyCurrent.does (LabelInfo.threadCopyCurrent (labelInfo label)) | |
309 | then Transfer.foreachLabel | |
310 | (transfer, fn l => | |
311 | forceMultiThreadedBlockDFS controlFlow | |
312 | (nodeBlock (labelNode l))) | |
313 | else () | |
314 | val rec visitForceMultiUsedBlock | |
315 | = fn controlFlow => | |
316 | fn block => | |
317 | (forceMultiUsedBlock block ; | |
318 | visitBlock controlFlow block) | |
319 | ||
320 | val rec forceMultiThreadedFunc | |
321 | = fn f => | |
322 | let | |
323 | val {args, blocks, ...} = Function.dest f | |
324 | in | |
325 | Vector.foreach | |
326 | (args, forceMultiThreadedVar o #1) ; | |
327 | Vector.foreach | |
328 | (blocks, forceMultiThreadedBlock) | |
329 | end | |
330 | val rec forceMultiUsedFunc | |
331 | = fn f => | |
332 | let | |
333 | val {args, blocks, ...} = Function.dest f | |
334 | in | |
335 | Vector.foreach | |
336 | (args, forceMultiUsedVar o #1) ; | |
337 | Vector.foreach | |
338 | (blocks, forceMultiUsedBlock) | |
339 | end | |
340 | ||
341 | fun visitFunc multiUsed f | |
342 | = let | |
343 | val _ = remFuncNode (Function.name f) | |
344 | ||
345 | val fi = funcInfo (Function.name f) | |
346 | val _ = if multiUsed | |
347 | orelse | |
348 | Calls.isMany (FuncInfo.calls fi) | |
349 | then MultiUsed.force (FuncInfo.multiUsed fi) | |
350 | else () | |
351 | in | |
352 | if MultiThreaded.is (FuncInfo.multiThreaded fi) | |
353 | then forceMultiThreadedFunc f | |
354 | else if MultiUsed.is (FuncInfo.multiUsed fi) | |
355 | then (forceMultiUsedFunc f ; | |
356 | if usesThreadsOrConts | |
357 | then let | |
358 | val _ = MultiThreaded.when | |
359 | (FuncInfo.multiThreaded fi, | |
360 | fn () => forceMultiThreadedFunc f) | |
361 | val controlFlow = Function.controlFlow f | |
362 | in | |
363 | Vector.foreach | |
364 | (Function.blocks f, visitBlock controlFlow) | |
365 | end | |
366 | else ()) | |
367 | else if usesThreadsOrConts | |
368 | then let | |
369 | val _ = MultiThreaded.when | |
370 | (FuncInfo.multiThreaded fi, | |
371 | fn () => forceMultiThreadedFunc f) | |
372 | val _ = MultiUsed.when | |
373 | (FuncInfo.multiUsed fi, | |
374 | fn () => forceMultiUsedFunc f) | |
375 | val controlFlow as {graph, nodeBlock, ...} | |
376 | = Function.controlFlow f | |
377 | in | |
378 | List.foreach | |
379 | (Graph.stronglyConnectedComponents graph, | |
380 | fn [] => () | |
381 | | [n] => if Node.hasEdge {from = n, to = n} | |
382 | then visitForceMultiUsedBlock controlFlow | |
383 | (nodeBlock n) | |
384 | else visitBlock controlFlow | |
385 | (nodeBlock n) | |
386 | | ns => List.foreach | |
387 | (ns, fn n => | |
388 | visitForceMultiUsedBlock controlFlow | |
389 | (nodeBlock n))) | |
390 | end | |
391 | else let | |
392 | val _ = MultiUsed.when | |
393 | (FuncInfo.multiUsed fi, | |
394 | fn () => forceMultiUsedFunc f) | |
395 | val {graph, nodeBlock, ...} = Function.controlFlow f | |
396 | in | |
397 | List.foreach | |
398 | (Graph.stronglyConnectedComponents graph, | |
399 | fn [] => () | |
400 | | [n] => if Node.hasEdge {from = n, to = n} | |
401 | then forceMultiUsedBlock (nodeBlock n) | |
402 | else () | |
403 | | ns => List.foreach | |
404 | (ns, fn n => | |
405 | forceMultiUsedBlock (nodeBlock n))) | |
406 | end | |
407 | end | |
408 | ||
409 | val _ = List.foreach | |
410 | (Graph.stronglyConnectedComponents G, | |
411 | fn [] => () | |
412 | | [n] => | |
413 | visitFunc (Node.hasEdge {from = n, to = n}) (nodeFunction n) | |
414 | | ns => List.foreach | |
415 | (ns, fn n => | |
416 | visitFunc true (nodeFunction n))) | |
417 | ||
418 | (* | |
419 | val _ = Control.diagnostics | |
420 | (fn display => | |
421 | let open Layout | |
422 | in | |
423 | display (Layout.str "\n\nMulti:") ; | |
424 | display (seq [Layout.str "usesThreadsOrConts: ", | |
425 | Bool.layout usesThreadsOrConts]) ; | |
426 | List.foreach | |
427 | (functions, fn f => | |
428 | let | |
429 | val {name = f, blocks, ...} = Function.dest f | |
430 | in | |
431 | display (seq [Func.layout f, | |
432 | str ": ", | |
433 | FuncInfo.layout (funcInfo f)]) ; | |
434 | Vector.foreach | |
435 | (blocks, fn Block.T {label, ...} => | |
436 | display (seq [Label.layout label, | |
437 | str ": ", | |
438 | LabelInfo.layout (labelInfo label)])) | |
439 | end) | |
440 | end) | |
441 | *) | |
442 | in | |
443 | { | |
444 | usesThreadsOrConts = usesThreadsOrConts, | |
445 | ||
446 | funcDoesThreadCopyCurrent | |
447 | = ThreadCopyCurrent.does o FuncInfo.threadCopyCurrent o funcInfo, | |
448 | funcIsMultiThreaded | |
449 | = MultiThreaded.is o FuncInfo.multiThreaded o funcInfo, | |
450 | funcIsMultiUsed | |
451 | = MultiUsed.is o FuncInfo.multiUsed o funcInfo, | |
452 | ||
453 | labelDoesThreadCopyCurrent | |
454 | = ThreadCopyCurrent.does o LabelInfo.threadCopyCurrent o labelInfo, | |
455 | labelIsMultiThreaded | |
456 | = MultiThreaded.is o LabelInfo.multiThreaded o labelInfo, | |
457 | labelIsMultiUsed | |
458 | = MultiUsed.is o LabelInfo.multiUsed o labelInfo, | |
459 | ||
460 | varIsMultiDefed | |
461 | = MultiUsed.is o VarInfo.multiUsed o varInfo | |
462 | } | |
463 | end | |
464 | end |