| 1 | (* Copyright (C) 2009,2011,2017 Matthew Fluet. |
| 2 | * Copyright (C) 1999-2008 Henry Cejtin, Matthew Fluet, Suresh |
| 3 | * Jagannathan, and Stephen Weeks. |
| 4 | * Copyright (C) 1997-2000 NEC Research Institute. |
| 5 | * |
| 6 | * MLton is released under a BSD-style license. |
| 7 | * See the file MLton-LICENSE for details. |
| 8 | *) |
| 9 | |
| 10 | functor Shrink (S: SHRINK_STRUCTS): SHRINK = |
| 11 | struct |
| 12 | |
| 13 | open S |
| 14 | |
| 15 | structure Exp = |
| 16 | struct |
| 17 | open Exp |
| 18 | |
| 19 | val isProfile = |
| 20 | fn Profile _ => true |
| 21 | | _ => false |
| 22 | end |
| 23 | |
| 24 | structure Statement = |
| 25 | struct |
| 26 | open Statement |
| 27 | |
| 28 | fun isProfile (T {exp, ...}) = Exp.isProfile exp |
| 29 | end |
| 30 | |
| 31 | structure Array = |
| 32 | struct |
| 33 | open Array |
| 34 | |
| 35 | fun inc (a: int t, i: int): unit = update (a, i, 1 + sub (a, i)) |
| 36 | fun dec (a: int t, i: int): unit = update (a, i, sub (a, i) - 1) |
| 37 | end |
| 38 | |
| 39 | datatype z = datatype Exp.t |
| 40 | datatype z = datatype Transfer.t |
| 41 | |
| 42 | structure VarInfo = |
| 43 | struct |
| 44 | datatype t = T of {isUsed: bool ref, |
| 45 | numOccurrences: int ref, |
| 46 | ty: Type.t option, |
| 47 | value: value option ref, |
| 48 | var: Var.t} |
| 49 | and value = |
| 50 | Con of {con: Con.t, |
| 51 | args: t vector} |
| 52 | | Const of Const.t |
| 53 | | Select of {tuple: t, offset: int} |
| 54 | | Tuple of t vector |
| 55 | |
| 56 | fun equals (T {var = x, ...}, T {var = y, ...}) = Var.equals (x, y) |
| 57 | |
| 58 | fun layout (T {isUsed, numOccurrences, ty, value, var}) = |
| 59 | let open Layout |
| 60 | in record [("isUsed", Bool.layout (!isUsed)), |
| 61 | ("numOccurrences", Int.layout (!numOccurrences)), |
| 62 | ("ty", Option.layout Type.layout ty), |
| 63 | ("value", Option.layout layoutValue (!value)), |
| 64 | ("var", Var.layout var)] |
| 65 | end |
| 66 | and layoutValue v = |
| 67 | let open Layout |
| 68 | in case v of |
| 69 | Con {con, args} => seq [Con.layout con, |
| 70 | Vector.layout layout args] |
| 71 | | Const c => Const.layout c |
| 72 | | Select {tuple, offset} => seq [str "#", Int.layout (offset + 1), |
| 73 | str " ", layout tuple] |
| 74 | | Tuple vis => Vector.layout layout vis |
| 75 | end |
| 76 | |
| 77 | fun new (x: Var.t, ty: Type.t option) = T {isUsed = ref false, |
| 78 | numOccurrences = ref 0, |
| 79 | ty = ty, |
| 80 | value = ref NONE, |
| 81 | var = x} |
| 82 | |
| 83 | fun setValue (T {value, ...}, v) = |
| 84 | (Assert.assert ("Ssa.Shrink.VarInfo.setValue", fn () => Option.isNone (!value)) |
| 85 | ; value := SOME v) |
| 86 | |
| 87 | |
| 88 | fun numOccurrences (T {numOccurrences = r, ...}) = r |
| 89 | fun ty (T {ty, ...}): Type.t option = ty |
| 90 | fun value (T {value, ...}): value option = !value |
| 91 | fun var (T {var, ...}): Var.t = var |
| 92 | end |
| 93 | |
| 94 | structure Value = |
| 95 | struct |
| 96 | datatype t = datatype VarInfo.value |
| 97 | end |
| 98 | |
| 99 | structure Position = |
| 100 | struct |
| 101 | datatype t = |
| 102 | Formal of int |
| 103 | | Free of Var.t |
| 104 | |
| 105 | fun layout (p: t) = |
| 106 | case p of |
| 107 | Formal i => Int.layout i |
| 108 | | Free x => Var.layout x |
| 109 | |
| 110 | val equals = |
| 111 | fn (Formal i, Formal i') => i = i' |
| 112 | | (Free x, Free x') => Var.equals (x, x') |
| 113 | | _ => false |
| 114 | end |
| 115 | |
| 116 | structure Positions = MonoVector (Position) |
| 117 | |
| 118 | structure LabelMeaning = |
| 119 | struct |
| 120 | datatype t = T of {aux: aux, |
| 121 | blockIndex: int, (* The index of the block *) |
| 122 | label: Label.t} (* redundant, the label of the block *) |
| 123 | |
| 124 | and aux = |
| 125 | Block |
| 126 | | Bug |
| 127 | | Case of {canMove: Statement.t list, |
| 128 | cases: Cases.t, |
| 129 | default: Label.t option} |
| 130 | | Goto of {canMove: Statement.t list, |
| 131 | dst: t, |
| 132 | args: Positions.t} |
| 133 | | Raise of {args: Positions.t, |
| 134 | canMove: Statement.t list} |
| 135 | | Return of {args: Positions.t, |
| 136 | canMove: Statement.t list} |
| 137 | |
| 138 | local |
| 139 | fun make f (T r) = f r |
| 140 | in |
| 141 | val aux = make #aux |
| 142 | val blockIndex = make #blockIndex |
| 143 | end |
| 144 | |
| 145 | fun layout (T {aux, label, ...}) = |
| 146 | let |
| 147 | open Layout |
| 148 | in |
| 149 | seq [Label.layout label, |
| 150 | str " ", |
| 151 | case aux of |
| 152 | Block => str "Block " |
| 153 | | Bug => str "Bug" |
| 154 | | Case _ => str "Case" |
| 155 | | Goto {dst, args, ...} => |
| 156 | seq [str "Goto ", |
| 157 | tuple [layout dst, Positions.layout args]] |
| 158 | | Raise {args, ...} => |
| 159 | seq [str "Raise ", Positions.layout args] |
| 160 | | Return {args, ...} => |
| 161 | seq [str "Return ", Positions.layout args]] |
| 162 | end |
| 163 | end |
| 164 | |
| 165 | structure State = |
| 166 | struct |
| 167 | datatype state = |
| 168 | Unvisited |
| 169 | | Visited of LabelMeaning.t |
| 170 | | Visiting |
| 171 | |
| 172 | val layout = |
| 173 | let |
| 174 | open Layout |
| 175 | in |
| 176 | fn Unvisited => str "Unvisited" |
| 177 | | Visited m => LabelMeaning.layout m |
| 178 | | Visiting => str "Visiting" |
| 179 | end |
| 180 | end |
| 181 | |
| 182 | val traceApplyInfo = Trace.info "Ssa.Shrink.Prim.apply" |
| 183 | |
| 184 | fun shrinkFunction {globals: Statement.t vector} = |
| 185 | let |
| 186 | fun use (VarInfo.T {isUsed, var, ...}): Var.t = |
| 187 | (isUsed := true |
| 188 | ; var) |
| 189 | fun uses (vis: VarInfo.t vector): Var.t vector = Vector.map (vis, use) |
| 190 | (* varInfo can't be getSetOnce because of setReplacement. *) |
| 191 | val {get = varInfo: Var.t -> VarInfo.t, set = setVarInfo, ...} = |
| 192 | Property.getSet (Var.plist, |
| 193 | Property.initFun (fn x => VarInfo.new (x, NONE))) |
| 194 | (* Property.getSet (Var.plist, Property.initFun VarInfo.new) *) |
| 195 | val setVarInfo = |
| 196 | Trace.trace2 ("Ssa.Shrink.setVarInfo", |
| 197 | Var.layout, VarInfo.layout, Unit.layout) |
| 198 | setVarInfo |
| 199 | fun varInfos xs = Vector.map (xs, varInfo) |
| 200 | fun simplifyVar (x: Var.t) = use (varInfo x) |
| 201 | val simplifyVar = |
| 202 | Trace.trace ("Ssa.Shrink.simplifyVar", Var.layout, Var.layout) simplifyVar |
| 203 | fun simplifyVars xs = Vector.map (xs, simplifyVar) |
| 204 | fun incVarInfo (x: VarInfo.t): unit = |
| 205 | Int.inc (VarInfo.numOccurrences x) |
| 206 | fun incVar (x: Var.t): unit = incVarInfo (varInfo x) |
| 207 | fun incVars xs = Vector.foreach (xs, incVar) |
| 208 | fun numVarOccurrences (x: Var.t): int = |
| 209 | ! (VarInfo.numOccurrences (varInfo x)) |
| 210 | val _ = |
| 211 | Vector.foreach |
| 212 | (globals, fn Statement.T {var, exp, ty} => |
| 213 | let |
| 214 | val _ = Option.app |
| 215 | (var, fn x => |
| 216 | setVarInfo (x, VarInfo.new (x, SOME ty))) |
| 217 | fun construct v = |
| 218 | Option.app (var, fn x => VarInfo.setValue (varInfo x, v)) |
| 219 | in case exp of |
| 220 | ConApp {con, args} => |
| 221 | construct (Value.Con {con = con, |
| 222 | args = Vector.map (args, varInfo)}) |
| 223 | | Const c => construct (Value.Const c) |
| 224 | | Select {tuple, offset} => |
| 225 | construct (Value.Select {tuple = varInfo tuple, |
| 226 | offset = offset}) |
| 227 | | Tuple xs => construct (Value.Tuple (Vector.map (xs, varInfo))) |
| 228 | | Var y => Option.app (var, fn x => setVarInfo (x, varInfo y)) |
| 229 | | _ => () |
| 230 | end) |
| 231 | in |
| 232 | fn f: Function.t => |
| 233 | let |
| 234 | val _ = Function.clear f |
| 235 | val {args, blocks, mayInline, name, raises, returns, start, ...} = |
| 236 | Function.dest f |
| 237 | val _ = Vector.foreach |
| 238 | (args, fn (x, ty) => |
| 239 | setVarInfo (x, VarInfo.new (x, SOME ty))) |
| 240 | (* Index the labels by their defining block in blocks. *) |
| 241 | val {get = labelIndex, set = setLabelIndex, ...} = |
| 242 | Property.getSetOnce (Label.plist, |
| 243 | Property.initRaise ("index", Label.layout)) |
| 244 | val _ = Vector.foreachi (blocks, fn (i, Block.T {label, ...}) => |
| 245 | setLabelIndex (label, i)) |
| 246 | val numBlocks = Vector.length blocks |
| 247 | (* Do a DFS to compute occurrence counts and set label meanings *) |
| 248 | val states = Array.array (numBlocks, State.Unvisited) |
| 249 | val inDegree = Array.array (numBlocks, 0) |
| 250 | fun addLabelIndex i = Array.inc (inDegree, i) |
| 251 | val isHeader = Array.array (numBlocks, false) |
| 252 | val numHandlerUses = Array.array (numBlocks, 0) |
| 253 | fun layoutLabel (l: Label.t): Layout.t = |
| 254 | let |
| 255 | val i = labelIndex l |
| 256 | in |
| 257 | Layout.record [("label", Label.layout l), |
| 258 | ("inDegree", Int.layout (Array.sub (inDegree, i)))] |
| 259 | end |
| 260 | fun incAux aux = |
| 261 | case aux of |
| 262 | LabelMeaning.Goto {dst, ...} => |
| 263 | addLabelIndex (LabelMeaning.blockIndex dst) |
| 264 | | _ => () |
| 265 | fun incLabel (l: Label.t): unit = |
| 266 | incLabelMeaning (labelMeaning l) |
| 267 | and incLabelMeaning (LabelMeaning.T {aux, blockIndex, ...}): unit = |
| 268 | let |
| 269 | val i = blockIndex |
| 270 | val n = Array.sub (inDegree, i) |
| 271 | val _ = Array.update (inDegree, i, 1 + n) |
| 272 | in |
| 273 | if n = 0 |
| 274 | then incAux aux |
| 275 | else () |
| 276 | end |
| 277 | and labelMeaning (l: Label.t): LabelMeaning.t = |
| 278 | let |
| 279 | val i = labelIndex l |
| 280 | in |
| 281 | case Array.sub (states, i) of |
| 282 | State.Visited m => m |
| 283 | | State.Visiting => |
| 284 | (Array.update (isHeader, i, true) |
| 285 | ; (LabelMeaning.T |
| 286 | {aux = LabelMeaning.Block, |
| 287 | blockIndex = i, |
| 288 | label = Block.label (Vector.sub (blocks, i))})) |
| 289 | | State.Unvisited => |
| 290 | let |
| 291 | val _ = Array.update (states, i, State.Visiting) |
| 292 | val m = computeMeaning i |
| 293 | val _ = Array.update (states, i, State.Visited m) |
| 294 | in |
| 295 | m |
| 296 | end |
| 297 | end |
| 298 | and computeMeaning (i: int): LabelMeaning.t = |
| 299 | let |
| 300 | val Block.T {args, statements, transfer, ...} = |
| 301 | Vector.sub (blocks, i) |
| 302 | val _ = |
| 303 | Vector.foreach (args, fn (x, ty) => |
| 304 | setVarInfo (x, VarInfo.new (x, SOME ty))) |
| 305 | val _ = |
| 306 | Vector.foreach |
| 307 | (statements, fn s => Exp.foreachVar (Statement.exp s, incVar)) |
| 308 | fun extract (actuals: Var.t vector): Positions.t = |
| 309 | let |
| 310 | val {get: Var.t -> Position.t, set, destroy} = |
| 311 | Property.destGetSetOnce |
| 312 | (Var.plist, Property.initFun Position.Free) |
| 313 | val _ = Vector.foreachi (args, fn (i, (x, _)) => |
| 314 | set (x, Position.Formal i)) |
| 315 | val ps = Vector.map (actuals, get) |
| 316 | val _ = destroy () |
| 317 | in ps |
| 318 | end |
| 319 | fun doit aux = |
| 320 | LabelMeaning.T {aux = aux, |
| 321 | blockIndex = i, |
| 322 | label = Block.label (Vector.sub (blocks, i))} |
| 323 | fun normal () = doit LabelMeaning.Block |
| 324 | fun canMove () = |
| 325 | Vector.toListMap |
| 326 | (statements, fn Statement.T {exp, ty, ...} => |
| 327 | Statement.T {exp = exp, ty = ty, var = NONE}) |
| 328 | fun rr (xs: Var.t vector, make) = |
| 329 | let |
| 330 | val _ = incVars xs |
| 331 | (* |
| 332 | val n = Vector.length statements |
| 333 | fun loop (i, ac) = |
| 334 | if i = n |
| 335 | then |
| 336 | if 0 = Vector.length xs |
| 337 | orelse 0 < Vector.length args |
| 338 | then doit (make {args = extract xs, |
| 339 | canMove = rev ac}) |
| 340 | else normal () |
| 341 | else |
| 342 | let |
| 343 | val Statement.T {exp, ty, ...} = |
| 344 | Vector.sub (statements, i) |
| 345 | in |
| 346 | if Exp.isProfile exp |
| 347 | then loop (i + 1, |
| 348 | Statement.T {exp = exp, |
| 349 | ty = ty, |
| 350 | var = NONE} :: ac) |
| 351 | else normal () |
| 352 | end |
| 353 | in |
| 354 | loop (0, []) |
| 355 | end |
| 356 | *) |
| 357 | in |
| 358 | if Vector.forall (statements, Statement.isProfile) |
| 359 | andalso (0 = Vector.length xs |
| 360 | orelse 0 < Vector.length args) |
| 361 | then doit (make {args = extract xs, |
| 362 | canMove = canMove ()}) |
| 363 | else normal () |
| 364 | end |
| 365 | in |
| 366 | case transfer of |
| 367 | Arith {args, overflow, success, ...} => |
| 368 | (incVars args |
| 369 | ; incLabel overflow |
| 370 | ; incLabel success |
| 371 | ; normal ()) |
| 372 | | Bug => |
| 373 | if Vector.forall (statements, Statement.isProfile) |
| 374 | andalso (case returns of |
| 375 | NONE => true |
| 376 | | SOME ts => |
| 377 | Vector.equals |
| 378 | (ts, args, fn (t, (_, t')) => |
| 379 | Type.equals (t, t'))) |
| 380 | then doit LabelMeaning.Bug |
| 381 | else normal () |
| 382 | | Call {args, return, ...} => |
| 383 | let |
| 384 | val _ = incVars args |
| 385 | val _ = |
| 386 | Return.foreachHandler |
| 387 | (return, fn l => |
| 388 | Array.inc (numHandlerUses, labelIndex l)) |
| 389 | val _ = Return.foreachLabel (return, incLabel) |
| 390 | in |
| 391 | normal () |
| 392 | end |
| 393 | | Case {test, cases, default} => |
| 394 | let |
| 395 | val _ = incVar test |
| 396 | val _ = Cases.foreach (cases, incLabel) |
| 397 | val _ = Option.app (default, incLabel) |
| 398 | in |
| 399 | if Vector.forall (statements, Statement.isProfile) |
| 400 | andalso not (Array.sub (isHeader, i)) |
| 401 | andalso 1 = Vector.length args |
| 402 | andalso 1 = numVarOccurrences test |
| 403 | andalso Var.equals (test, #1 (Vector.first args)) |
| 404 | then |
| 405 | doit (LabelMeaning.Case {canMove = canMove (), |
| 406 | cases = cases, |
| 407 | default = default}) |
| 408 | else |
| 409 | normal () |
| 410 | end |
| 411 | | Goto {dst, args = actuals} => |
| 412 | let |
| 413 | val _ = incVars actuals |
| 414 | val m = labelMeaning dst |
| 415 | in |
| 416 | if Vector.exists (statements, not o Statement.isProfile) |
| 417 | orelse Array.sub (isHeader, i) |
| 418 | then (incLabelMeaning m |
| 419 | ; normal ()) |
| 420 | else |
| 421 | if Vector.isEmpty statements |
| 422 | andalso |
| 423 | Vector.equals (args, actuals, fn ((x, _), x') => |
| 424 | Var.equals (x, x') |
| 425 | andalso 1 = numVarOccurrences x) |
| 426 | then m (* It's an eta. *) |
| 427 | else |
| 428 | let |
| 429 | val ps = extract actuals |
| 430 | val n = |
| 431 | Vector.fold (args, 0, fn ((x, _), n) => |
| 432 | n + numVarOccurrences x) |
| 433 | val n' = |
| 434 | Vector.fold (ps, 0, fn (p, n) => |
| 435 | case p of |
| 436 | Position.Formal _ => n + 1 |
| 437 | | _ => n) |
| 438 | datatype z = datatype LabelMeaning.aux |
| 439 | in |
| 440 | if n <> n' |
| 441 | then (incLabelMeaning m |
| 442 | ; normal ()) |
| 443 | else |
| 444 | let |
| 445 | fun extract (ps': Positions.t) |
| 446 | : Positions.t = |
| 447 | Vector.map |
| 448 | (ps', fn p => |
| 449 | let |
| 450 | datatype z = datatype Position.t |
| 451 | in |
| 452 | case p of |
| 453 | Free x => Free x |
| 454 | | Formal i => Vector.sub (ps, i) |
| 455 | end) |
| 456 | val canMove' = canMove () |
| 457 | val a = |
| 458 | case LabelMeaning.aux m of |
| 459 | Block => |
| 460 | Goto {canMove = canMove', |
| 461 | dst = m, |
| 462 | args = ps} |
| 463 | | Bug => |
| 464 | if (case returns of |
| 465 | NONE => true |
| 466 | | SOME ts => |
| 467 | Vector.equals |
| 468 | (ts, args, fn (t, (_, t')) => |
| 469 | Type.equals (t, t'))) |
| 470 | then Bug |
| 471 | else Goto {canMove = canMove', |
| 472 | dst = m, |
| 473 | args = ps} |
| 474 | | Case _ => |
| 475 | Goto {canMove = canMove', |
| 476 | dst = m, |
| 477 | args = ps} |
| 478 | | Goto {canMove, dst, args} => |
| 479 | Goto {canMove = canMove' @ canMove, |
| 480 | dst = dst, |
| 481 | args = extract args} |
| 482 | | Raise {args, canMove} => |
| 483 | Raise {args = extract args, |
| 484 | canMove = canMove' @ canMove} |
| 485 | | Return {args, canMove} => |
| 486 | Return {args = extract args, |
| 487 | canMove = canMove' @ canMove} |
| 488 | in |
| 489 | doit a |
| 490 | end |
| 491 | end |
| 492 | end |
| 493 | | Raise xs => rr (xs, LabelMeaning.Raise) |
| 494 | | Return xs => rr (xs, LabelMeaning.Return) |
| 495 | | Runtime {args, return, ...} => |
| 496 | (incVars args |
| 497 | ; incLabel return |
| 498 | ; normal ()) |
| 499 | end |
| 500 | val _ = incLabel start |
| 501 | fun indexMeaning i = |
| 502 | case Array.sub (states, i) of |
| 503 | State.Visited m => m |
| 504 | | _ => Error.bug "Ssa.Shrink.indexMeaning: not computed" |
| 505 | val indexMeaning = |
| 506 | Trace.trace ("Ssa.Shrink.indexMeaning", Int.layout, LabelMeaning.layout) |
| 507 | indexMeaning |
| 508 | val labelMeaning = indexMeaning o labelIndex |
| 509 | val labelMeaning = |
| 510 | Trace.trace ("Ssa.Shrink.labelMeaning", |
| 511 | Label.layout, LabelMeaning.layout) |
| 512 | labelMeaning |
| 513 | fun meaningLabel m = |
| 514 | Block.label (Vector.sub (blocks, LabelMeaning.blockIndex m)) |
| 515 | fun labelArgs l = |
| 516 | Block.args (Vector.sub (blocks, labelIndex l)) |
| 517 | fun meaningArgs m = |
| 518 | Block.args (Vector.sub (blocks, LabelMeaning.blockIndex m)) |
| 519 | fun save (f, s) = |
| 520 | let |
| 521 | val {destroy, controlFlowGraph, ...} = |
| 522 | Function.layoutDot (f, Var.layout) |
| 523 | in |
| 524 | File.withOut |
| 525 | (concat ["/tmp/", Func.toString (Function.name f), |
| 526 | ".", s, ".dot"], |
| 527 | fn out => Layout.outputl (controlFlowGraph, out)) |
| 528 | ; destroy () |
| 529 | end |
| 530 | val _ = if true then () else save (f, "pre") |
| 531 | (* *) |
| 532 | val _ = |
| 533 | if true |
| 534 | then () |
| 535 | else |
| 536 | Layout.outputl |
| 537 | (Vector.layout |
| 538 | (fn i => |
| 539 | (Layout.record |
| 540 | [("label", |
| 541 | Label.layout (Block.label (Vector.sub (blocks, i)))), |
| 542 | ("inDegree", Int.layout (Array.sub (inDegree, i))), |
| 543 | ("state", State.layout (Array.sub (states, i)))])) |
| 544 | (Vector.tabulate (numBlocks, fn i => i)), |
| 545 | Out.error) |
| 546 | val _ = |
| 547 | Assert.assert |
| 548 | ("Ssa.Shrink.labelMeanings", fn () => |
| 549 | let |
| 550 | val inDegree' = Array.array (numBlocks, 0) |
| 551 | fun bumpIndex i = Array.inc (inDegree', i) |
| 552 | fun bumpMeaning m = bumpIndex (LabelMeaning.blockIndex m) |
| 553 | val bumpLabel = bumpMeaning o labelMeaning |
| 554 | fun doit (LabelMeaning.T {aux, blockIndex, ...}) = |
| 555 | let |
| 556 | datatype z = datatype LabelMeaning.aux |
| 557 | in |
| 558 | case aux of |
| 559 | Block => |
| 560 | Transfer.foreachLabel |
| 561 | (Block.transfer (Vector.sub (blocks, blockIndex)), |
| 562 | bumpLabel) |
| 563 | | Bug => () |
| 564 | | Case {cases, default, ...} => |
| 565 | (Cases.foreach (cases, bumpLabel) |
| 566 | ; Option.app (default, bumpLabel)) |
| 567 | | Goto {dst, ...} => bumpMeaning dst |
| 568 | | Raise _ => () |
| 569 | | Return _ => () |
| 570 | end |
| 571 | val _ = |
| 572 | Array.foreachi |
| 573 | (states, fn (i, s) => |
| 574 | if Array.sub (inDegree, i) > 0 |
| 575 | then |
| 576 | (case s of |
| 577 | State.Visited m => doit m |
| 578 | | _ => ()) |
| 579 | else ()) |
| 580 | val _ = bumpMeaning (labelMeaning start) |
| 581 | in |
| 582 | Array.equals (inDegree, inDegree', Int.equals) |
| 583 | orelse |
| 584 | let |
| 585 | val _ = |
| 586 | Layout.outputl |
| 587 | (Vector.layout |
| 588 | (fn i => |
| 589 | (Layout.record |
| 590 | [("label", |
| 591 | Label.layout (Block.label (Vector.sub (blocks, i)))), |
| 592 | ("inDegree", Int.layout (Array.sub (inDegree, i))), |
| 593 | ("inDegree'", Int.layout (Array.sub (inDegree', i))), |
| 594 | ("state", State.layout (Array.sub (states, i)))])) |
| 595 | (Vector.tabulate (numBlocks, fn i => i)), |
| 596 | Out.error) |
| 597 | in |
| 598 | false |
| 599 | end |
| 600 | end) |
| 601 | val isBlock = Array.array (numBlocks, false) |
| 602 | (* Functions for maintaining inDegree. *) |
| 603 | val addLabelIndex = |
| 604 | fn i => |
| 605 | (Assert.assert ("Ssa.Shrink.addLabelIndex", fn () => |
| 606 | Array.sub (inDegree, i) > 0) |
| 607 | ; addLabelIndex i) |
| 608 | val addLabelMeaning = addLabelIndex o LabelMeaning.blockIndex |
| 609 | fun layoutLabelMeaning m = |
| 610 | Layout.record |
| 611 | [("inDegree", Int.layout (Array.sub |
| 612 | (inDegree, LabelMeaning.blockIndex m))), |
| 613 | ("meaning", LabelMeaning.layout m)] |
| 614 | val traceDeleteLabelMeaning = |
| 615 | Trace.trace ("SSa.Shrink.deleteLabelMeaning", |
| 616 | layoutLabelMeaning, Unit.layout) |
| 617 | fun deleteLabel l = deleteLabelMeaning (labelMeaning l) |
| 618 | and deleteLabelMeaning arg: unit = |
| 619 | traceDeleteLabelMeaning |
| 620 | (fn (m: LabelMeaning.t) => |
| 621 | let |
| 622 | val i = LabelMeaning.blockIndex m |
| 623 | val n = Array.sub (inDegree, i) - 1 |
| 624 | val _ = Array.update (inDegree, i, n) |
| 625 | val _ = Assert.assert ("Ssa.Shrink.deleteLabelMeaning", fn () => n >= 0) |
| 626 | in |
| 627 | if n = 0 (* andalso not (Array.sub (isBlock, i)) *) |
| 628 | then |
| 629 | let |
| 630 | datatype z = datatype LabelMeaning.aux |
| 631 | in |
| 632 | case LabelMeaning.aux m of |
| 633 | Block => |
| 634 | let |
| 635 | val t = Block.transfer (Vector.sub (blocks, i)) |
| 636 | val _ = Transfer.foreachLabel (t, deleteLabel) |
| 637 | val _ = |
| 638 | case t of |
| 639 | Transfer.Call {return, ...} => |
| 640 | Return.foreachHandler |
| 641 | (return, fn l => |
| 642 | Array.dec (numHandlerUses, |
| 643 | (LabelMeaning.blockIndex |
| 644 | (labelMeaning l)))) |
| 645 | | _ => () |
| 646 | in |
| 647 | () |
| 648 | end |
| 649 | | Bug => () |
| 650 | | Case {cases, default, ...} => |
| 651 | (Cases.foreach (cases, deleteLabel) |
| 652 | ; Option.app (default, deleteLabel)) |
| 653 | | Goto {dst, ...} => deleteLabelMeaning dst |
| 654 | | Raise _ => () |
| 655 | | Return _ => () |
| 656 | end |
| 657 | else () |
| 658 | end) arg |
| 659 | fun primApp (prim: Type.t Prim.t, args: VarInfo.t vector) |
| 660 | : (Type.t, VarInfo.t) Prim.ApplyResult.t = |
| 661 | let |
| 662 | val args' = |
| 663 | Vector.map |
| 664 | (args, fn vi => |
| 665 | case vi of |
| 666 | VarInfo.T {value = ref (SOME v), ...} => |
| 667 | (case v of |
| 668 | Value.Con {con, args} => |
| 669 | if Vector.isEmpty args |
| 670 | then Prim.ApplyArg.Con {con = con, |
| 671 | hasArg = false} |
| 672 | else Prim.ApplyArg.Var vi |
| 673 | | Value.Const c => Prim.ApplyArg.Const c |
| 674 | | _ => Prim.ApplyArg.Var vi) |
| 675 | | _ => Prim.ApplyArg.Var vi) |
| 676 | in |
| 677 | Trace.traceInfo' |
| 678 | (traceApplyInfo, |
| 679 | fn (p, args, _) => |
| 680 | let |
| 681 | open Layout |
| 682 | in |
| 683 | seq [Prim.layout p, str " ", |
| 684 | List.layout (Prim.ApplyArg.layout |
| 685 | (Var.layout o VarInfo.var)) args] |
| 686 | end, |
| 687 | Prim.ApplyResult.layout (Var.layout o VarInfo.var)) |
| 688 | Prim.apply |
| 689 | (prim, Vector.toList args', VarInfo.equals) |
| 690 | end |
| 691 | (* Another DFS, this time accumulating the new blocks. *) |
| 692 | val traceForceMeaningBlock = |
| 693 | Trace.trace ("Ssa.Shrink.forceMeaningBlock", |
| 694 | layoutLabelMeaning, Unit.layout) |
| 695 | val traceSimplifyBlock = |
| 696 | Trace.trace2 ("Ssa.Shrink.simplifyBlock", |
| 697 | List.layout Statement.layout, |
| 698 | layoutLabel o Block.label, |
| 699 | Layout.tuple2 (List.layout Statement.layout, |
| 700 | Transfer.layout)) |
| 701 | val traceGotoMeaning = |
| 702 | Trace.trace3 |
| 703 | ("Ssa.Shrink.gotoMeaning", |
| 704 | List.layout Statement.layout, |
| 705 | layoutLabelMeaning, |
| 706 | Vector.layout VarInfo.layout, |
| 707 | Layout.tuple2 (List.layout Statement.layout, Transfer.layout)) |
| 708 | val traceEvalStatement = |
| 709 | Trace.trace |
| 710 | ("Ssa.Shrink.evalStatement", |
| 711 | Statement.layout, |
| 712 | Layout.ignore: (Statement.t list -> Statement.t list) -> Layout.t) |
| 713 | val traceSimplifyTransfer = |
| 714 | Trace.trace ("Ssa.Shrink.simplifyTransfer", |
| 715 | Transfer.layout, |
| 716 | Layout.tuple2 (List.layout Statement.layout, |
| 717 | Transfer.layout)) |
| 718 | val traceSimplifyCase = |
| 719 | Trace.trace |
| 720 | ("Ssa.Shrink2.simplifyCase", |
| 721 | fn {canMove, cases, default, test, ...} => |
| 722 | Layout.record [("canMove", List.layout Statement.layout canMove), |
| 723 | ("cantSimplify", Layout.str "fn () => ..."), |
| 724 | ("gone", Layout.str "fn () => ..."), |
| 725 | ("test", VarInfo.layout test), |
| 726 | ("cases/default", |
| 727 | (Transfer.layout o Transfer.Case) |
| 728 | {cases = cases, |
| 729 | default = default, |
| 730 | test = VarInfo.var test})], |
| 731 | Layout.tuple2 (List.layout Statement.layout, Transfer.layout)) |
| 732 | val newBlocks = ref [] |
| 733 | fun simplifyLabel l = |
| 734 | let |
| 735 | val m = labelMeaning l |
| 736 | val _ = forceMeaningBlock m |
| 737 | in |
| 738 | meaningLabel m |
| 739 | end |
| 740 | and forceMeaningBlock arg = |
| 741 | traceForceMeaningBlock |
| 742 | (fn (LabelMeaning.T {aux, blockIndex = i, ...}) => |
| 743 | if Array.sub (isBlock, i) |
| 744 | then () |
| 745 | else |
| 746 | let |
| 747 | val _ = Array.update (isBlock, i, true) |
| 748 | val block as Block.T {label, args, ...} = |
| 749 | Vector.sub (blocks, i) |
| 750 | fun extract (p: Position.t): VarInfo.t = |
| 751 | varInfo (case p of |
| 752 | Position.Formal n => #1 (Vector.sub (args, n)) |
| 753 | | Position.Free x => x) |
| 754 | val (statements, transfer) = |
| 755 | let |
| 756 | fun rr ({args, canMove}, make) = |
| 757 | (canMove, |
| 758 | make (Vector.map (args, use o extract))) |
| 759 | datatype z = datatype LabelMeaning.aux |
| 760 | in |
| 761 | case aux of |
| 762 | Block => simplifyBlock ([], block) |
| 763 | | Bug => ([], Transfer.Bug) |
| 764 | | Case _ => simplifyBlock ([], block) |
| 765 | | Goto {canMove, dst, args} => |
| 766 | gotoMeaning |
| 767 | (canMove, |
| 768 | dst, |
| 769 | Vector.map (args, extract)) |
| 770 | | Raise z => rr (z, Transfer.Raise) |
| 771 | | Return z => rr (z, Transfer.Return) |
| 772 | end |
| 773 | val _ = |
| 774 | List.push |
| 775 | (newBlocks, |
| 776 | Block.T {label = label, |
| 777 | args = args, |
| 778 | statements = Vector.fromList statements, |
| 779 | transfer = transfer}) |
| 780 | in |
| 781 | () |
| 782 | end) arg |
| 783 | and simplifyBlock arg : Statement.t list * Transfer.t = |
| 784 | traceSimplifyBlock |
| 785 | (fn (canMoveIn, Block.T {statements, transfer, ...}) => |
| 786 | let |
| 787 | val f = evalStatements statements |
| 788 | val (ss, transfer) = simplifyTransfer transfer |
| 789 | in |
| 790 | (canMoveIn @ (f ss), transfer) |
| 791 | end) arg |
| 792 | and evalStatements (ss: Statement.t vector) |
| 793 | : Statement.t list -> Statement.t list = |
| 794 | let |
| 795 | val fs = Vector.map (ss, evalStatement) |
| 796 | in |
| 797 | fn ss => Vector.foldr (fs, ss, fn (f, ss) => f ss) |
| 798 | end |
| 799 | and simplifyTransfer arg : Statement.t list * Transfer.t = |
| 800 | traceSimplifyTransfer |
| 801 | (fn (t: Transfer.t) => |
| 802 | case t of |
| 803 | Arith {prim, args, overflow, success, ty} => |
| 804 | let |
| 805 | val args = varInfos args |
| 806 | in |
| 807 | case primApp (prim, args) of |
| 808 | Prim.ApplyResult.Const c => |
| 809 | let |
| 810 | val _ = deleteLabel overflow |
| 811 | val x = Var.newNoname () |
| 812 | val isUsed = ref false |
| 813 | val vi = |
| 814 | VarInfo.T {isUsed = isUsed, |
| 815 | numOccurrences = ref 0, |
| 816 | ty = SOME ty, |
| 817 | value = ref (SOME (Value.Const c)), |
| 818 | var = x} |
| 819 | val (ss, t) = goto (success, Vector.new1 vi) |
| 820 | val ss = |
| 821 | if !isUsed |
| 822 | then Statement.T {var = SOME x, |
| 823 | ty = Type.ofConst c, |
| 824 | exp = Exp.Const c} |
| 825 | :: ss |
| 826 | else ss |
| 827 | in |
| 828 | (ss, t) |
| 829 | end |
| 830 | | Prim.ApplyResult.Var x => |
| 831 | let |
| 832 | val _ = deleteLabel overflow |
| 833 | in |
| 834 | goto (success, Vector.new1 x) |
| 835 | end |
| 836 | | Prim.ApplyResult.Overflow => |
| 837 | let |
| 838 | val _ = deleteLabel success |
| 839 | in |
| 840 | goto (overflow, Vector.new0 ()) |
| 841 | end |
| 842 | | Prim.ApplyResult.Apply (prim, args) => |
| 843 | let val args = Vector.fromList args |
| 844 | in |
| 845 | ([], Arith {prim = prim, |
| 846 | args = uses args, |
| 847 | overflow = simplifyLabel overflow, |
| 848 | success = simplifyLabel success, |
| 849 | ty = ty}) |
| 850 | end |
| 851 | | _ => |
| 852 | ([], Arith {prim = prim, |
| 853 | args = uses args, |
| 854 | overflow = simplifyLabel overflow, |
| 855 | success = simplifyLabel success, |
| 856 | ty = ty}) |
| 857 | end |
| 858 | | Bug => ([], Bug) |
| 859 | | Call {func, args, return} => |
| 860 | let |
| 861 | val (statements, return) = |
| 862 | case return of |
| 863 | Return.NonTail {cont, handler} => |
| 864 | let |
| 865 | fun isEta (m: LabelMeaning.t, |
| 866 | ps: Position.t vector): bool = |
| 867 | Vector.length ps = Vector.length (meaningArgs m) |
| 868 | andalso |
| 869 | Vector.foralli |
| 870 | (ps, |
| 871 | fn (i, Position.Formal i') => i = i' |
| 872 | | _ => false) |
| 873 | val m = labelMeaning cont |
| 874 | fun nonTail () = |
| 875 | let |
| 876 | val _ = forceMeaningBlock m |
| 877 | val handler = |
| 878 | Handler.map |
| 879 | (handler, fn l => |
| 880 | let |
| 881 | val m = labelMeaning l |
| 882 | val _ = forceMeaningBlock m |
| 883 | in |
| 884 | meaningLabel m |
| 885 | end) |
| 886 | in |
| 887 | ([], |
| 888 | Return.NonTail {cont = meaningLabel m, |
| 889 | handler = handler}) |
| 890 | end |
| 891 | fun tail statements = |
| 892 | (deleteLabelMeaning m |
| 893 | ; (statements, Return.Tail)) |
| 894 | fun cont handlerEta = |
| 895 | case LabelMeaning.aux m of |
| 896 | LabelMeaning.Bug => |
| 897 | (case handlerEta of |
| 898 | NONE => nonTail () |
| 899 | | SOME canMove => tail canMove) |
| 900 | | LabelMeaning.Return {args, canMove} => |
| 901 | if isEta (m, args) |
| 902 | then tail canMove |
| 903 | else nonTail () |
| 904 | | _ => nonTail () |
| 905 | |
| 906 | in |
| 907 | case handler of |
| 908 | Handler.Caller => cont NONE |
| 909 | | Handler.Dead => cont NONE |
| 910 | | Handler.Handle l => |
| 911 | let |
| 912 | val m = labelMeaning l |
| 913 | in |
| 914 | case LabelMeaning.aux m of |
| 915 | LabelMeaning.Bug => cont NONE |
| 916 | | LabelMeaning.Raise {args, canMove} => |
| 917 | if isEta (m, args) |
| 918 | then cont (SOME canMove) |
| 919 | else nonTail () |
| 920 | | _ => nonTail () |
| 921 | end |
| 922 | end |
| 923 | | _ => ([], return) |
| 924 | in |
| 925 | (statements, |
| 926 | Call {func = func, |
| 927 | args = simplifyVars args, |
| 928 | return = return}) |
| 929 | end |
| 930 | | Case {test, cases, default} => |
| 931 | let |
| 932 | val test = varInfo test |
| 933 | fun cantSimplify () = |
| 934 | ([], |
| 935 | Case {test = use test, |
| 936 | cases = Cases.map (cases, simplifyLabel), |
| 937 | default = Option.map (default, simplifyLabel)}) |
| 938 | in |
| 939 | simplifyCase |
| 940 | {canMove = [], |
| 941 | cantSimplify = cantSimplify, |
| 942 | cases = cases, |
| 943 | default = default, |
| 944 | gone = fn () => (Cases.foreach (cases, deleteLabel) |
| 945 | ; Option.app (default, deleteLabel)), |
| 946 | test = test} |
| 947 | end |
| 948 | | Goto {dst, args} => goto (dst, varInfos args) |
| 949 | | Raise xs => ([], Raise (simplifyVars xs)) |
| 950 | | Return xs => ([], Return (simplifyVars xs)) |
| 951 | | Runtime {prim, args, return} => |
| 952 | ([], Runtime {prim = prim, |
| 953 | args = simplifyVars args, |
| 954 | return = simplifyLabel return}) |
| 955 | ) arg |
| 956 | and simplifyCase arg : Statement.t list * Transfer.t = |
| 957 | traceSimplifyCase |
| 958 | (fn {canMove, cantSimplify, |
| 959 | cases, default, gone, test: VarInfo.t} => |
| 960 | let |
| 961 | (* tryToEliminate makes sure that the destination meaning |
| 962 | * hasn't already been simplified. If it has, then we can't |
| 963 | * simplify the case. |
| 964 | *) |
| 965 | fun tryToEliminate m = |
| 966 | let |
| 967 | val i = LabelMeaning.blockIndex m |
| 968 | in |
| 969 | if Array.sub (inDegree, i) = 0 |
| 970 | then cantSimplify () |
| 971 | else |
| 972 | let |
| 973 | val _ = addLabelIndex i |
| 974 | val _ = gone () |
| 975 | in |
| 976 | gotoMeaning (canMove, m, Vector.new0 ()) |
| 977 | end |
| 978 | end |
| 979 | in |
| 980 | if Cases.isEmpty cases |
| 981 | then (case default of |
| 982 | NONE => (canMove, Bug) |
| 983 | | SOME l => tryToEliminate (labelMeaning l)) |
| 984 | else |
| 985 | let |
| 986 | val l = Cases.hd cases |
| 987 | fun isOk (l': Label.t): bool = Label.equals (l, l') |
| 988 | in |
| 989 | if Vector.isEmpty (labelArgs l) |
| 990 | andalso Cases.forall (cases, isOk) |
| 991 | andalso (case default of |
| 992 | NONE => true |
| 993 | | SOME l => isOk l) |
| 994 | then |
| 995 | (* All cases the same -- eliminate the case. *) |
| 996 | tryToEliminate (labelMeaning l) |
| 997 | else |
| 998 | let |
| 999 | fun findCase (cases, isCon, args) = |
| 1000 | let |
| 1001 | val n = Vector.length cases |
| 1002 | fun doit (l, args) = |
| 1003 | let |
| 1004 | val m = labelMeaning l |
| 1005 | val _ = addLabelMeaning m |
| 1006 | val _ = gone () |
| 1007 | in |
| 1008 | gotoMeaning (canMove, m, args) |
| 1009 | end |
| 1010 | fun loop k = |
| 1011 | if k = n |
| 1012 | then |
| 1013 | (case default of |
| 1014 | NONE => (gone (); ([], Bug)) |
| 1015 | | SOME l => doit (l, Vector.new0 ())) |
| 1016 | else |
| 1017 | let |
| 1018 | val (con, l) = Vector.sub (cases, k) |
| 1019 | in |
| 1020 | if isCon con |
| 1021 | then doit (l, args) |
| 1022 | else loop (k + 1) |
| 1023 | end |
| 1024 | in |
| 1025 | loop 0 |
| 1026 | end |
| 1027 | in |
| 1028 | case (VarInfo.value test, cases) of |
| 1029 | (SOME (Value.Const c), _) => |
| 1030 | (case (cases, c) of |
| 1031 | (Cases.Word (_, cs), Const.Word w) => |
| 1032 | findCase (cs, |
| 1033 | fn w' => WordX.equals (w, w'), |
| 1034 | Vector.new0 ()) |
| 1035 | | _ => |
| 1036 | Error.bug "Ssa.Shrink.simplifyCases: strange constant") |
| 1037 | | (SOME (Value.Con {con, args}), Cases.Con cases) => |
| 1038 | findCase (cases, |
| 1039 | fn c => Con.equals (con, c), |
| 1040 | args) |
| 1041 | | _ => cantSimplify () |
| 1042 | end |
| 1043 | end |
| 1044 | end) arg |
| 1045 | and goto (dst: Label.t, args: VarInfo.t vector) |
| 1046 | : Statement.t list * Transfer.t = |
| 1047 | gotoMeaning ([], labelMeaning dst, args) |
| 1048 | and gotoMeaning arg : Statement.t list * Transfer.t = |
| 1049 | traceGotoMeaning |
| 1050 | (fn (canMoveIn, |
| 1051 | m as LabelMeaning.T {aux, blockIndex = i, ...}, |
| 1052 | args: VarInfo.t vector) => |
| 1053 | let |
| 1054 | val n = Array.sub (inDegree, i) |
| 1055 | val _ = Assert.assert ("Ssa.Shrink.gotoMeaning", fn () => n >= 1) |
| 1056 | fun normal () = |
| 1057 | if n = 1 |
| 1058 | then |
| 1059 | let |
| 1060 | val _ = Array.update (inDegree, i, 0) |
| 1061 | val b = Vector.sub (blocks, i) |
| 1062 | val _ = |
| 1063 | Vector.foreach2 |
| 1064 | (Block.args b, args, fn ((x, _), vi) => |
| 1065 | setVarInfo (x, vi)) |
| 1066 | in |
| 1067 | simplifyBlock (canMoveIn, b) |
| 1068 | end |
| 1069 | else |
| 1070 | let |
| 1071 | val _ = forceMeaningBlock m |
| 1072 | in |
| 1073 | (canMoveIn, |
| 1074 | Goto {dst = Block.label (Vector.sub (blocks, i)), |
| 1075 | args = uses args}) |
| 1076 | end |
| 1077 | fun extract p = |
| 1078 | case p of |
| 1079 | Position.Formal n => Vector.sub (args, n) |
| 1080 | | Position.Free x => varInfo x |
| 1081 | fun rr ({args, canMove}, make) = |
| 1082 | (canMoveIn @ canMove, |
| 1083 | make (Vector.map (args, use o extract))) |
| 1084 | datatype z = datatype LabelMeaning.aux |
| 1085 | in |
| 1086 | case aux of |
| 1087 | Block => normal () |
| 1088 | | Bug => ((*canMoveIn*)[], Transfer.Bug) |
| 1089 | | Case {canMove, cases, default} => |
| 1090 | simplifyCase {canMove = canMoveIn @ canMove, |
| 1091 | cantSimplify = normal, |
| 1092 | cases = cases, |
| 1093 | default = default, |
| 1094 | gone = fn () => deleteLabelMeaning m, |
| 1095 | test = Vector.first args} |
| 1096 | | Goto {canMove, dst, args} => |
| 1097 | if Array.sub (isHeader, i) |
| 1098 | orelse Array.sub (isBlock, i) |
| 1099 | then normal () |
| 1100 | else |
| 1101 | let |
| 1102 | val n' = n - 1 |
| 1103 | val _ = Array.update (inDegree, i, n') |
| 1104 | val _ = |
| 1105 | if n' > 0 |
| 1106 | then addLabelMeaning dst |
| 1107 | else () |
| 1108 | in |
| 1109 | gotoMeaning (canMoveIn @ canMove, |
| 1110 | dst, |
| 1111 | Vector.map (args, extract)) |
| 1112 | end |
| 1113 | | Raise z => rr (z, Transfer.Raise) |
| 1114 | | Return z => rr (z, Transfer.Return) |
| 1115 | end) arg |
| 1116 | and evalStatement arg : Statement.t list -> Statement.t list = |
| 1117 | traceEvalStatement |
| 1118 | (fn (Statement.T {var, ty, exp}) => |
| 1119 | let |
| 1120 | val _ = Option.app |
| 1121 | (var, fn x => |
| 1122 | setVarInfo (x, VarInfo.new (x, SOME ty))) |
| 1123 | fun delete ss = ss |
| 1124 | fun doit {makeExp: unit -> Exp.t, |
| 1125 | sideEffect: bool, |
| 1126 | value: Value.t option} = |
| 1127 | let |
| 1128 | fun make var = |
| 1129 | Statement.T {var = var, |
| 1130 | ty = ty, |
| 1131 | exp = makeExp ()} |
| 1132 | in |
| 1133 | case var of |
| 1134 | NONE => |
| 1135 | if sideEffect |
| 1136 | then (fn ss => make NONE :: ss) |
| 1137 | else delete |
| 1138 | | SOME x => |
| 1139 | let |
| 1140 | val VarInfo.T {isUsed, value = r, ...} = varInfo x |
| 1141 | val _ = r := value |
| 1142 | in |
| 1143 | fn ss => |
| 1144 | if !isUsed |
| 1145 | then make (SOME x) :: ss |
| 1146 | else if sideEffect |
| 1147 | then make NONE :: ss |
| 1148 | else ss |
| 1149 | end |
| 1150 | end |
| 1151 | fun setVar vi = |
| 1152 | (Option.app (var, fn x => setVarInfo (x, vi)) |
| 1153 | ; delete) |
| 1154 | fun construct (v: Value.t, makeExp) = |
| 1155 | doit {makeExp = makeExp, |
| 1156 | sideEffect = false, |
| 1157 | value = SOME v} |
| 1158 | in |
| 1159 | case exp of |
| 1160 | ConApp {con, args} => |
| 1161 | let |
| 1162 | val args = varInfos args |
| 1163 | in |
| 1164 | construct (Value.Con {con = con, args = args}, |
| 1165 | fn () => ConApp {con = con, |
| 1166 | args = uses args}) |
| 1167 | end |
| 1168 | | Const c => construct (Value.Const c, fn () => exp) |
| 1169 | | PrimApp {prim, targs, args} => |
| 1170 | let |
| 1171 | val args = varInfos args |
| 1172 | fun apply {prim, targs, args} = |
| 1173 | doit {sideEffect = Prim.maySideEffect prim, |
| 1174 | makeExp = fn () => PrimApp {prim = prim, |
| 1175 | targs = targs, |
| 1176 | args = uses args}, |
| 1177 | value = NONE} |
| 1178 | datatype z = datatype Prim.ApplyResult.t |
| 1179 | in |
| 1180 | case primApp (prim, args) of |
| 1181 | Apply (prim, args) => |
| 1182 | apply {prim = prim, targs = Vector.new0 (), |
| 1183 | args = Vector.fromList args} |
| 1184 | | Bool b => |
| 1185 | let |
| 1186 | val con = Con.fromBool b |
| 1187 | in |
| 1188 | construct (Value.Con {con = con, |
| 1189 | args = Vector.new0 ()}, |
| 1190 | fn () => |
| 1191 | ConApp {con = con, |
| 1192 | args = Vector.new0 ()}) |
| 1193 | end |
| 1194 | | Const c => construct (Value.Const c, |
| 1195 | fn () => Exp.Const c) |
| 1196 | | Var vi => setVar vi |
| 1197 | | _ => apply {prim = prim, |
| 1198 | targs = targs, |
| 1199 | args = args} |
| 1200 | end |
| 1201 | | Select {tuple, offset} => |
| 1202 | let |
| 1203 | val tuple as VarInfo.T {value, ...} = varInfo tuple |
| 1204 | in |
| 1205 | case !value of |
| 1206 | SOME (Value.Tuple vs) => |
| 1207 | setVar (Vector.sub (vs, offset)) |
| 1208 | | _ => |
| 1209 | construct (Value.Select {tuple = tuple, |
| 1210 | offset = offset}, |
| 1211 | fn () => Select {tuple = use tuple, |
| 1212 | offset = offset}) |
| 1213 | end |
| 1214 | | Tuple xs => |
| 1215 | let |
| 1216 | val xs = varInfos xs |
| 1217 | in |
| 1218 | case Exn.withEscape |
| 1219 | (fn escape => |
| 1220 | Vector.foldri |
| 1221 | (xs, NONE, |
| 1222 | fn (i, VarInfo.T {value, ...}, tuple') => |
| 1223 | case !value of |
| 1224 | SOME (Value.Select {offset, tuple}) => |
| 1225 | if offset = i |
| 1226 | then case tuple' of |
| 1227 | NONE => |
| 1228 | (case VarInfo.ty tuple of |
| 1229 | SOME ty => |
| 1230 | (case Type.deTupleOpt ty of |
| 1231 | SOME ts => |
| 1232 | if Vector.length xs = |
| 1233 | Vector.length ts |
| 1234 | then SOME tuple |
| 1235 | else escape NONE |
| 1236 | | NONE => escape NONE) |
| 1237 | | NONE => escape NONE) |
| 1238 | | SOME tuple'' => |
| 1239 | if VarInfo.equals (tuple'', tuple) |
| 1240 | then tuple' |
| 1241 | else escape NONE |
| 1242 | else escape NONE |
| 1243 | | _ => escape NONE)) of |
| 1244 | SOME tuple => setVar tuple |
| 1245 | | NONE => construct (Value.Tuple xs, |
| 1246 | fn () => Tuple (uses xs)) |
| 1247 | end |
| 1248 | | Var x => setVar (varInfo x) |
| 1249 | | _ => doit {makeExp = fn () => exp, |
| 1250 | sideEffect = true, |
| 1251 | value = NONE} |
| 1252 | end) arg |
| 1253 | val start = labelMeaning start |
| 1254 | val _ = forceMeaningBlock start |
| 1255 | val f = |
| 1256 | Function.new {args = args, |
| 1257 | blocks = Vector.fromList (!newBlocks), |
| 1258 | mayInline = mayInline, |
| 1259 | name = name, |
| 1260 | raises = raises, |
| 1261 | returns = returns, |
| 1262 | start = meaningLabel start} |
| 1263 | val _ = if true then () else save (f, "post") |
| 1264 | val _ = Function.clear f |
| 1265 | in |
| 1266 | f |
| 1267 | end |
| 1268 | end |
| 1269 | |
| 1270 | fun eliminateUselessProfile (f: Function.t): Function.t = |
| 1271 | if !Control.profile = Control.ProfileNone |
| 1272 | then f |
| 1273 | else |
| 1274 | let |
| 1275 | fun eliminateInBlock (b as Block.T {args, label, statements, transfer}) |
| 1276 | : Block.t = |
| 1277 | if not (Vector.exists (statements, Statement.isProfile)) |
| 1278 | then b |
| 1279 | else |
| 1280 | let |
| 1281 | datatype z = datatype Exp.t |
| 1282 | datatype z = datatype ProfileExp.t |
| 1283 | val stack = |
| 1284 | Vector.fold |
| 1285 | (statements, [], fn (s as Statement.T {exp, ...}, stack) => |
| 1286 | case exp of |
| 1287 | Profile (Leave si) => |
| 1288 | (case stack of |
| 1289 | Statement.T {exp = Profile (Enter si'), ...} |
| 1290 | :: rest => |
| 1291 | if SourceInfo.equals (si, si') |
| 1292 | then rest |
| 1293 | else Error.bug "Ssa.Shrink.eliminateUselessProfile: mismatched Leave" |
| 1294 | | _ => s :: stack) |
| 1295 | | _ => s :: stack) |
| 1296 | val statements = Vector.fromListRev stack |
| 1297 | in |
| 1298 | Block.T {args = args, |
| 1299 | label = label, |
| 1300 | statements = statements, |
| 1301 | transfer = transfer} |
| 1302 | end |
| 1303 | val {args, blocks, mayInline, name, raises, returns, start} = |
| 1304 | Function.dest f |
| 1305 | val blocks = Vector.map (blocks, eliminateInBlock) |
| 1306 | in |
| 1307 | Function.new {args = args, |
| 1308 | blocks = blocks, |
| 1309 | mayInline = mayInline, |
| 1310 | name = name, |
| 1311 | raises = raises, |
| 1312 | returns = returns, |
| 1313 | start = start} |
| 1314 | end |
| 1315 | |
| 1316 | val traceShrinkFunction = |
| 1317 | Trace.trace ("Ssa.Shrink.shrinkFunction", Function.layout, Function.layout) |
| 1318 | |
| 1319 | val shrinkFunction = |
| 1320 | fn g => |
| 1321 | let |
| 1322 | val s = shrinkFunction g |
| 1323 | in |
| 1324 | fn f => traceShrinkFunction s (eliminateUselessProfile f) |
| 1325 | end |
| 1326 | |
| 1327 | fun shrink (Program.T {datatypes, globals, functions, main}) |
| 1328 | = let |
| 1329 | val s = shrinkFunction {globals = globals} |
| 1330 | in |
| 1331 | Program.T {datatypes = datatypes, |
| 1332 | globals = globals, |
| 1333 | functions = List.revMap (functions, s), |
| 1334 | main = main} |
| 1335 | end |
| 1336 | |
| 1337 | end |