1 (* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh
2 * Jagannathan, and Stephen Weeks.
3 * Copyright (C) 1997-2000 NEC Research Institute.
5 * MLton is released under a BSD-style license.
6 * See the file MLton-LICENSE for details.
9 functor LocalFlatten (S: SSA_TRANSFORM_STRUCTS): SSA_TRANSFORM =
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.
21 datatype t = T of {fromTuple: bool ref,
22 fromForce: t list ref,
26 fun isFlat (T {fromTuple, toSelect, ...}) =
27 !fromTuple andalso !toSelect
29 val isTupled = not o isFlat
31 fun layout (i: t): Layout.t =
32 Layout.str (if isFlat i then "flat" else "tupled")
34 fun new () = T {fromTuple = ref false,
39 fun tuple (T {fromTuple = f, fromForce, ...}) =
42 else (f := true; List.foreach (!fromForce, tuple))
44 fun nonSelect (T {toSelect = t, toForce, ...}) =
46 then (t := false; List.foreach (!toForce, nonSelect))
50 fn (lhs as T {fromTuple = f, fromForce, ...},
51 rhs as T {toSelect = t, toForce, ...}) =>
56 else List.push (fromForce, rhs)
59 then List.push (toForce, lhs)
74 fun transform (Program.T {globals, datatypes, functions, main}) =
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}
89 val {args, blocks, mayInline, name, raises, returns, start} =
93 (blocks, fn Block.T {label, args, ...} =>
100 val i = ArgInfo.new ()
101 val _ = setVarInfo (x, VarInfo.Arg i)
107 fun force (x: Var.t): unit =
109 VarInfo.Arg i => ArgInfo.nonSelect i
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,
116 | SOME (i, _) => ArgInfo.nonSelect i)
118 fun visit (Block.T {statements, transfer, ...}): unit -> unit =
122 (statements, fn Statement.T {var, exp, ...} =>
124 ConApp {args, ...} => forces args
125 | PrimApp {args, ...} => forces args
126 | Tuple args => (setVarInfo (valOf var, VarInfo.Tuple)
132 Arith {args, overflow, success, ...} =>
137 | Call {args, return, ...} =>
139 ; Return.foreachLabel (return, forceArgs))
140 | Case {cases, default, ...} =>
141 (Cases.foreach (cases, forceArgs)
142 ; Option.app (default, forceArgs))
143 | Goto {dst, args} =>
145 (args, labelArgs dst,
147 | (x, SOME (i, _)) =>
149 VarInfo.Arg i' => ArgInfo.<= (i', i)
151 | VarInfo.Tuple => ArgInfo.tuple i))
152 | Raise xs => forces xs
153 | Return xs => forces xs
154 | Runtime {args, return, ...} =>
160 val _ = Function.dfs (f, visit)
167 VarInfo.Arg i => display (let open Layout
168 in seq [Var.layout x,
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))))
181 fun makeTuple (formals: (Var.t * Type.t) vector,
183 : (Var.t * Type.t) vector * Statement.t list =
187 (formals, reps, [], fn ((x, ty), rep, stmts) =>
189 NONE => (Vector.new1 (x, ty), stmts)
191 if ArgInfo.isTupled i
192 then (Vector.new1 (x, ty), stmts)
195 val vars = Vector.map
196 (Type.deTuple ty, fn ty =>
197 (Var.newNoname (), ty))
203 exp = Tuple (Vector.map (vars, #1))}
206 in (Vector.concatV argss, stmts)
208 fun makeSelects (args: Var.t vector,
210 : Var.t vector * Statement.t list =
214 (args, formals, [], fn (x, formal, stmts) =>
216 NONE => (Vector.new1 x, stmts)
218 if ArgInfo.isTupled i
219 then (Vector.new1 x, stmts)
224 (Type.deTuple t, ([], stmts),
225 fn (i, ty, (vars, stmts)) =>
226 let val var = Var.newNoname ()
231 exp = Select {tuple = x,
235 in (Vector.fromListRev vars, stmts)
237 in (Vector.concatV argss, stmts)
239 fun anyFlat (v: argsInfo): bool =
242 | SOME (i, _) => ArgInfo.isFlat i)
245 (blocks, fn Block.T {label, args, statements, transfer} =>
249 val formals = labelArgs label
252 then makeTuple (args, formals)
255 val (post, transfer) =
259 val formals = labelArgs dst
265 makeSelects (args, formals)
267 (stmts, Goto {dst = dst, args = args})
271 | _ => ([], transfer)
274 (Vector.new3 (Vector.fromList pre,
276 Vector.fromList post))
278 Block.T {label = label,
280 statements = statements,
284 shrink (Function.new {args = args,
286 mayInline = mayInline,
292 val program = Program.T {datatypes = datatypes,
294 functions = functions,
296 val _ = Program.clearTop program