| 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 |