HCoop / hcoop / debian / mlton.git / blame
| Commit | Line | Data |
|---|---|---|
| 7f918cf1 CE |
1 | (* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh |
| 2 | * Jagannathan, and Stephen Weeks. | |
| 3 | * Copyright (C) 1997-2000 NEC Research Institute. | |
| 4 | * | |
| 5 | * MLton is released under a BSD-style license. | |
| 6 | * See the file MLton-LICENSE for details. | |
| 7 | *) | |
| 8 | ||
| 9 | functor LocalFlatten (S: SSA_TRANSFORM_STRUCTS): SSA_TRANSFORM = | |
| 10 | struct | |
| 11 | ||
| 12 | open S | |
| 13 | open Exp Transfer | |
| 14 | ||
| 15 | (* Flatten a jump arg as long as it is only flows to selects and there is | |
| 16 | * some tuple constructed in this function that flows to it. | |
| 17 | *) | |
| 18 | ||
| 19 | structure ArgInfo = | |
| 20 | struct | |
| 21 | datatype t = T of {fromTuple: bool ref, | |
| 22 | fromForce: t list ref, | |
| 23 | toSelect: bool ref, | |
| 24 | toForce: t list ref} | |
| 25 | ||
| 26 | fun isFlat (T {fromTuple, toSelect, ...}) = | |
| 27 | !fromTuple andalso !toSelect | |
| 28 | ||
| 29 | val isTupled = not o isFlat | |
| 30 | ||
| 31 | fun layout (i: t): Layout.t = | |
| 32 | Layout.str (if isFlat i then "flat" else "tupled") | |
| 33 | ||
| 34 | fun new () = T {fromTuple = ref false, | |
| 35 | fromForce = ref [], | |
| 36 | toSelect = ref true, | |
| 37 | toForce = ref []} | |
| 38 | ||
| 39 | fun tuple (T {fromTuple = f, fromForce, ...}) = | |
| 40 | if !f | |
| 41 | then () | |
| 42 | else (f := true; List.foreach (!fromForce, tuple)) | |
| 43 | ||
| 44 | fun nonSelect (T {toSelect = t, toForce, ...}) = | |
| 45 | if !t | |
| 46 | then (t := false; List.foreach (!toForce, nonSelect)) | |
| 47 | else () | |
| 48 | ||
| 49 | val op <= = | |
| 50 | fn (lhs as T {fromTuple = f, fromForce, ...}, | |
| 51 | rhs as T {toSelect = t, toForce, ...}) => | |
| 52 | let | |
| 53 | val _ = | |
| 54 | if !f | |
| 55 | then tuple rhs | |
| 56 | else List.push (fromForce, rhs) | |
| 57 | val _ = | |
| 58 | if !t | |
| 59 | then List.push (toForce, lhs) | |
| 60 | else nonSelect lhs | |
| 61 | in | |
| 62 | () | |
| 63 | end | |
| 64 | end | |
| 65 | ||
| 66 | structure VarInfo = | |
| 67 | struct | |
| 68 | datatype t = | |
| 69 | None | |
| 70 | | Arg of ArgInfo.t | |
| 71 | | Tuple | |
| 72 | end | |
| 73 | ||
| 74 | fun transform (Program.T {globals, datatypes, functions, main}) = | |
| 75 | let | |
| 76 | val {get = varInfo: Var.t -> VarInfo.t, | |
| 77 | set = setVarInfo, ...} = | |
| 78 | Property.getSetOnce (Var.plist, Property.initConst VarInfo.None) | |
| 79 | type argsInfo = (ArgInfo.t * Type.t) option vector | |
| 80 | val {get = labelArgs: Label.t -> argsInfo, | |
| 81 | set = setLabelArgs, ...} = | |
| 82 | Property.getSetOnce (Label.plist, | |
| 83 | Property.initRaise ("args", Label.layout)) | |
| 84 | val shrink = shrinkFunction {globals = globals} | |
| 85 | val functions = | |
| 86 | List.revMap | |
| 87 | (functions, fn f => | |
| 88 | let | |
| 89 | val {args, blocks, mayInline, name, raises, returns, start} = | |
| 90 | Function.dest f | |
| 91 | val _ = | |
| 92 | Vector.foreach | |
| 93 | (blocks, fn Block.T {label, args, ...} => | |
| 94 | setLabelArgs (label, | |
| 95 | Vector.map | |
| 96 | (args, fn (x, t) => | |
| 97 | if Type.isTuple t | |
| 98 | then | |
| 99 | let | |
| 100 | val i = ArgInfo.new () | |
| 101 | val _ = setVarInfo (x, VarInfo.Arg i) | |
| 102 | in | |
| 103 | SOME (i, t) | |
| 104 | end | |
| 105 | else NONE))) | |
| 106 | ||
| 107 | fun force (x: Var.t): unit = | |
| 108 | case varInfo x of | |
| 109 | VarInfo.Arg i => ArgInfo.nonSelect i | |
| 110 | | _ => () | |
| 111 | fun forces (xs: Var.t vector): unit = | |
| 112 | Vector.foreach (xs, force) | |
| 113 | fun forceArgs (l: Label.t): unit = | |
| 114 | Vector.foreach (labelArgs l, | |
| 115 | fn NONE => () | |
| 116 | | SOME (i, _) => ArgInfo.nonSelect i) | |
| 117 | ||
| 118 | fun visit (Block.T {statements, transfer, ...}): unit -> unit = | |
| 119 | let | |
| 120 | val _ = | |
| 121 | Vector.foreach | |
| 122 | (statements, fn Statement.T {var, exp, ...} => | |
| 123 | case exp of | |
| 124 | ConApp {args, ...} => forces args | |
| 125 | | PrimApp {args, ...} => forces args | |
| 126 | | Tuple args => (setVarInfo (valOf var, VarInfo.Tuple) | |
| 127 | ; forces args) | |
| 128 | | Var x => force x | |
| 129 | | _ => ()) | |
| 130 | val _ = | |
| 131 | case transfer of | |
| 132 | Arith {args, overflow, success, ...} => | |
| 133 | (forces args | |
| 134 | ; forceArgs overflow | |
| 135 | ; forceArgs success) | |
| 136 | | Bug => () | |
| 137 | | Call {args, return, ...} => | |
| 138 | (forces args | |
| 139 | ; Return.foreachLabel (return, forceArgs)) | |
| 140 | | Case {cases, default, ...} => | |
| 141 | (Cases.foreach (cases, forceArgs) | |
| 142 | ; Option.app (default, forceArgs)) | |
| 143 | | Goto {dst, args} => | |
| 144 | Vector.foreach2 | |
| 145 | (args, labelArgs dst, | |
| 146 | fn (_, NONE) => () | |
| 147 | | (x, SOME (i, _)) => | |
| 148 | (case varInfo x of | |
| 149 | VarInfo.Arg i' => ArgInfo.<= (i', i) | |
| 150 | | VarInfo.None => () | |
| 151 | | VarInfo.Tuple => ArgInfo.tuple i)) | |
| 152 | | Raise xs => forces xs | |
| 153 | | Return xs => forces xs | |
| 154 | | Runtime {args, return, ...} => | |
| 155 | (forces args | |
| 156 | ; forceArgs return) | |
| 157 | in | |
| 158 | fn () => () | |
| 159 | end | |
| 160 | val _ = Function.dfs (f, visit) | |
| 161 | val _ = | |
| 162 | Control.diagnostics | |
| 163 | (fn display => | |
| 164 | let | |
| 165 | fun doit x = | |
| 166 | case varInfo x of | |
| 167 | VarInfo.Arg i => display (let open Layout | |
| 168 | in seq [Var.layout x, | |
| 169 | str " ", | |
| 170 | ArgInfo.layout i] | |
| 171 | end) | |
| 172 | | _ => () | |
| 173 | in | |
| 174 | Vector.foreach | |
| 175 | (blocks, fn Block.T {args, statements, ...} => | |
| 176 | (Vector.foreach(args, doit o #1); | |
| 177 | Vector.foreach(statements, fn Statement.T {var, ...} => | |
| 178 | Option.app(var, doit)))) | |
| 179 | end) | |
| 180 | ||
| 181 | fun makeTuple (formals: (Var.t * Type.t) vector, | |
| 182 | reps: argsInfo) | |
| 183 | : (Var.t * Type.t) vector * Statement.t list = | |
| 184 | let | |
| 185 | val (argss, stmts) = | |
| 186 | Vector.map2AndFold | |
| 187 | (formals, reps, [], fn ((x, ty), rep, stmts) => | |
| 188 | case rep of | |
| 189 | NONE => (Vector.new1 (x, ty), stmts) | |
| 190 | | SOME (i, _) => | |
| 191 | if ArgInfo.isTupled i | |
| 192 | then (Vector.new1 (x, ty), stmts) | |
| 193 | else | |
| 194 | let | |
| 195 | val vars = Vector.map | |
| 196 | (Type.deTuple ty, fn ty => | |
| 197 | (Var.newNoname (), ty)) | |
| 198 | in | |
| 199 | (vars, | |
| 200 | Statement.T | |
| 201 | {var = SOME x, | |
| 202 | ty = ty, | |
| 203 | exp = Tuple (Vector.map (vars, #1))} | |
| 204 | :: stmts) | |
| 205 | end) | |
| 206 | in (Vector.concatV argss, stmts) | |
| 207 | end | |
| 208 | fun makeSelects (args: Var.t vector, | |
| 209 | formals: argsInfo) | |
| 210 | : Var.t vector * Statement.t list = | |
| 211 | let | |
| 212 | val (argss, stmts) = | |
| 213 | Vector.map2AndFold | |
| 214 | (args, formals, [], fn (x, formal, stmts) => | |
| 215 | case formal of | |
| 216 | NONE => (Vector.new1 x, stmts) | |
| 217 | | SOME (i, t) => | |
| 218 | if ArgInfo.isTupled i | |
| 219 | then (Vector.new1 x, stmts) | |
| 220 | else | |
| 221 | let | |
| 222 | val (vars, stmts) = | |
| 223 | Vector.foldi | |
| 224 | (Type.deTuple t, ([], stmts), | |
| 225 | fn (i, ty, (vars, stmts)) => | |
| 226 | let val var = Var.newNoname () | |
| 227 | in (var :: vars, | |
| 228 | Statement.T | |
| 229 | {var = SOME var, | |
| 230 | ty = ty, | |
| 231 | exp = Select {tuple = x, | |
| 232 | offset = i}} | |
| 233 | :: stmts) | |
| 234 | end) | |
| 235 | in (Vector.fromListRev vars, stmts) | |
| 236 | end) | |
| 237 | in (Vector.concatV argss, stmts) | |
| 238 | end | |
| 239 | fun anyFlat (v: argsInfo): bool = | |
| 240 | Vector.exists (v, | |
| 241 | fn NONE => false | |
| 242 | | SOME (i, _) => ArgInfo.isFlat i) | |
| 243 | val blocks = | |
| 244 | Vector.map | |
| 245 | (blocks, fn Block.T {label, args, statements, transfer} => | |
| 246 | let | |
| 247 | val (args, pre) = | |
| 248 | let | |
| 249 | val formals = labelArgs label | |
| 250 | in | |
| 251 | if anyFlat formals | |
| 252 | then makeTuple (args, formals) | |
| 253 | else (args, []) | |
| 254 | end | |
| 255 | val (post, transfer) = | |
| 256 | case transfer of | |
| 257 | Goto {dst, args} => | |
| 258 | let | |
| 259 | val formals = labelArgs dst | |
| 260 | in | |
| 261 | if anyFlat formals | |
| 262 | then | |
| 263 | let | |
| 264 | val (args, stmts) = | |
| 265 | makeSelects (args, formals) | |
| 266 | in | |
| 267 | (stmts, Goto {dst = dst, args = args}) | |
| 268 | end | |
| 269 | else ([], transfer) | |
| 270 | end | |
| 271 | | _ => ([], transfer) | |
| 272 | val statements = | |
| 273 | Vector.concatV | |
| 274 | (Vector.new3 (Vector.fromList pre, | |
| 275 | statements, | |
| 276 | Vector.fromList post)) | |
| 277 | in | |
| 278 | Block.T {label = label, | |
| 279 | args = args, | |
| 280 | statements = statements, | |
| 281 | transfer = transfer} | |
| 282 | end) | |
| 283 | in | |
| 284 | shrink (Function.new {args = args, | |
| 285 | blocks = blocks, | |
| 286 | mayInline = mayInline, | |
| 287 | name = name, | |
| 288 | raises = raises, | |
| 289 | returns = returns, | |
| 290 | start = start}) | |
| 291 | end) | |
| 292 | val program = Program.T {datatypes = datatypes, | |
| 293 | globals = globals, | |
| 294 | functions = functions, | |
| 295 | main = main} | |
| 296 | val _ = Program.clearTop program | |
| 297 | in | |
| 298 | program | |
| 299 | end | |
| 300 | end |