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