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