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.
10 * Flatten arguments to jumps, constructors, and functions.
11 * If a tuple is explicitly available at all uses of a jump (resp. function)
13 * - The formals and call sites are changed so that the components of the
15 * - The tuple is reconstructed at the beginning of the body of the jump.
17 * Similarly, if a tuple is explicitly available at all uses of a constructor,
18 * - The constructor argument type is changed to flatten the tuple type.
19 * - The tuple is passed flat at each ConApp.
20 * - The tuple is reconstructed at each Case target.
23 functor Flatten (S: SSA_TRANSFORM_STRUCTS): SSA_TRANSFORM =
31 structure L = TwoPointLattice (val bottom = "flatten"
32 val top = "don't flatten")
36 val isFlat = not o isTop
39 case Type.deTupleOpt t of
40 NONE => let val r = new () in makeTop r; r end
43 fun fromTypes (ts: Type.t vector): t vector =
44 Vector.map (ts, fromType)
46 val tuplize: t -> unit = makeTop
50 fun coerces (rs, rs') = Vector.foreach2 (rs, rs', coerce)
54 fun unifys (rs, rs') = Vector.foreach2 (rs, rs', unify)
57 fun transform (Program.T {datatypes, globals, functions, main}) =
59 val {get = conInfo: Con.t -> {argsTypes: Type.t vector,
61 set = setConInfo, ...} =
63 (Con.plist, Property.initRaise ("Flatten.conInfo", Con.layout))
64 val conArgs = #args o conInfo
65 val {get = funcInfo: Func.t -> {args: Rep.t vector,
66 returns: Rep.t vector option,
67 raises: Rep.t vector option},
68 set = setFuncInfo, ...} =
70 (Func.plist, Property.initRaise ("Flatten.funcInfo", Func.layout))
71 val funcArgs = #args o funcInfo
72 val {get = labelInfo: Label.t -> {args: Rep.t vector},
73 set = setLabelInfo, ...} =
75 (Label.plist, Property.initRaise ("Flatten.labelInfo", Label.layout))
76 val labelArgs = #args o labelInfo
77 val {get = varInfo: Var.t -> {rep: Rep.t,
78 tuple: Var.t vector option ref},
79 set = setVarInfo, ...} =
81 (Var.plist, Property.initFun
82 (fn _ => {rep = let val r = Rep.new ()
86 val fromFormal = fn (x, ty) => let val r = Rep.fromType ty
88 setVarInfo (x, {rep = r,
92 val fromFormals = fn xtys => Vector.map (xtys, fromFormal)
93 val varRep = #rep o varInfo
94 val varTuple = #tuple o varInfo
95 fun coerce (x: Var.t, r: Rep.t) =
96 Rep.coerce (varRep x, r)
97 fun coerces (xs: Var.t vector, rs: Rep.t vector) =
98 Vector.foreach2 (xs, rs, coerce)
102 (datatypes, fn Datatype.T {cons, ...} =>
104 (cons, fn {con, args} =>
105 setConInfo (con, {argsTypes = args,
106 args = Vector.map (args, Rep.fromType)})))
110 let val {args, name, raises, returns, ...} = Function.dest f
112 setFuncInfo (name, {args = fromFormals args,
113 returns = Option.map (returns, Rep.fromTypes),
114 raises = Option.map (raises, Rep.fromTypes)})
117 fun doitStatement (Statement.T {exp, var, ...}) =
122 setVarInfo (var, {rep = Rep.new (),
123 tuple = ref (SOME xs)}))
124 | ConApp {con, args} => coerces (args, conArgs con)
125 | Var x => setVarInfo (valOf var, varInfo x)
127 val _ = Vector.foreach (globals, doitStatement)
132 val {blocks, name, ...} = Function.dest f
133 val {raises, returns, ...} = funcInfo name
136 (blocks, fn Block.T {label, args, statements, ...} =>
137 (setLabelInfo (label, {args = fromFormals args})
138 ; Vector.foreach (statements, doitStatement)))
140 (blocks, fn Block.T {transfer, ...} =>
144 NONE => Error.bug "Flatten.flatten: return mismatch"
145 | SOME rs => coerces (xs, rs))
148 NONE => Error.bug "Flatten.flatten: raise mismatch"
149 | SOME rs => coerces (xs, rs))
150 | Call {func, args, return} =>
152 val {args = funcArgs,
153 returns = funcReturns,
154 raises = funcRaises} =
156 val _ = coerces (args, funcArgs)
157 fun unifyReturns () =
158 case (funcReturns, returns) of
159 (SOME rs, SOME rs') => Rep.unifys (rs, rs')
162 case (funcRaises, raises) of
163 (SOME rs, SOME rs') => Rep.unifys (rs, rs')
168 | Return.NonTail {cont, handler} =>
170 (funcReturns, fn rs =>
171 Rep.unifys (rs, labelArgs cont))
173 Handler.Caller => unifyRaises ()
175 | Handler.Handle handler =>
177 (funcRaises, fn rs =>
178 Rep.unifys (rs, labelArgs handler)))
179 | Return.Tail => (unifyReturns (); unifyRaises ())
181 | Goto {dst, args} => coerces (args, labelArgs dst)
182 | Case {cases = Cases.Con cases, ...} =>
184 (cases, fn (con, label) =>
185 Rep.coerces (conArgs con, labelArgs label))
194 val name = Function.name f
195 val {args, raises, returns} = funcInfo name
199 (seq [Func.layout name,
202 [("args", Vector.layout Rep.layout args),
203 ("returns", Option.layout (Vector.layout Rep.layout) returns),
204 ("raises", Option.layout (Vector.layout Rep.layout) raises)]])
206 fun flattenTypes (ts: Type.t vector, rs: Rep.t vector): Type.t vector =
208 (Vector.fold2 (ts, rs, [], fn (t, r, ts) =>
210 then Vector.fold (Type.deTuple t, ts, op ::)
214 (datatypes, fn Datatype.T {tycon, cons} =>
215 Datatype.T {tycon = tycon,
217 (cons, fn {con, args} =>
219 args = flattenTypes (args, conArgs con)}))})
220 fun flattens (xs as xsX: Var.t vector, rs: Rep.t vector) =
222 (Vector.fold2 (xs, rs, [],
225 then (case !(varTuple x) of
226 SOME ys => Vector.fold (ys, xs, op ::)
229 ["Flatten.flattens: tuple unavailable: ",
230 (Var.toString x), " ",
232 (Vector.layout Var.layout xsX))])))
234 fun doitStatement (stmt as Statement.T {var, ty, exp}) =
236 ConApp {con, args} =>
237 Statement.T {var = var,
239 exp = ConApp {con = con,
240 args = flattens (args, conArgs con)}}
242 val globals = Vector.map (globals, doitStatement)
245 val {args, mayInline, name, raises, returns, start, ...} =
247 val {args = argsReps, returns = returnsReps, raises = raisesReps} =
250 val newBlocks = ref []
252 fun doitArgs (args, reps) =
256 (args, reps, ([], []), fn ((x, ty), r, (args, stmts)) =>
259 val tys = Type.deTuple ty
260 val xs = Vector.map (tys, fn _ => Var.newNoname ())
261 val _ = varTuple x := SOME xs
264 (xs, tys, args, fn (x, ty, args) =>
268 Statement.T {var = SOME x,
273 else ((x, ty) :: args, stmts))
275 (Vector.fromList args, Vector.fromList stmts)
278 fun doitCaseCon {test, cases, default} =
284 val {args, argsTypes} = conInfo c
285 val actualReps = labelArgs l
287 (args, actualReps, fn (r, r') =>
288 Rep.isFlat r = Rep.isFlat r')
291 (* Coerce from the constructor representation to the
292 * formals the jump expects.
295 val l' = Label.newNoname ()
296 (* The formals need to match the type of the con.
297 * The actuals need to match the type of l.
299 val (stmts, formals, actuals) =
301 (args, actualReps, argsTypes,
303 fn (r, r', ty, (stmts, formals, actuals)) =>
306 (* The con is flat *)
310 (Type.deTuple ty, fn ty =>
311 (Var.newNoname (), ty))
312 val xs = Vector.map (xts, #1)
314 Vector.fold (xts, formals, op ::)
315 val (stmts, actuals) =
319 (xs, actuals, op ::))
322 val x = Var.newNoname ()
324 (Statement.T {var = SOME x,
330 in (stmts, formals, actuals)
333 (* The con is tupled *)
335 val tuple = Var.newNoname ()
336 val formals = (tuple, ty) :: formals
337 val (stmts, actuals) =
343 (Type.deTuple ty, fn ty =>
344 (Var.newNoname (), ty))
345 val xs = Vector.map (xts, #1)
352 fn (i, (x, ty), stmts) =>
356 exp = Select {tuple = tuple,
361 else (stmts, tuple :: actuals)
362 in (stmts, formals, actuals)
369 args = Vector.fromList formals,
370 statements = Vector.fromList stmts,
371 transfer = Goto {dst = l,
372 args = Vector.fromList actuals}})
377 in Case {test = test,
378 cases = Cases.Con cases,
381 fun doitTransfer transfer =
383 Call {func, args, return} =>
385 args = flattens (args, funcArgs func),
387 | Case {test, cases = Cases.Con cases, default} =>
388 doitCaseCon {test = test,
391 | Goto {dst, args} =>
393 args = flattens (args, labelArgs dst)}
394 | Raise xs => Raise (flattens (xs, valOf raisesReps))
395 | Return xs => Return (flattens (xs, valOf returnsReps))
398 fun doitBlock (Block.T {label, args, statements, transfer}) =
400 val (args, stmts) = doitArgs (args, labelArgs label)
401 val statements = Vector.map (statements, doitStatement)
402 val statements = Vector.concat [stmts, statements]
403 val transfer = doitTransfer transfer
405 Block.T {label = label,
407 statements = statements,
411 val (args, stmts) = doitArgs (args, argsReps)
412 val start' = Label.newNoname ()
415 Block.T {label = start',
416 args = Vector.new0 (),
418 transfer = Goto {dst = start,
419 args = Vector.new0 ()}})
422 (f, fn b => let val _ = List.push (newBlocks, doitBlock b)
425 val blocks = Vector.fromList (!newBlocks)
429 flattenTypes (ts, valOf returnsReps))
433 flattenTypes (ts, valOf raisesReps))
435 Function.new {args = args,
437 mayInline = mayInline,
444 val shrink = shrinkFunction {globals = globals}
445 val functions = List.revMap (functions, shrink o doitFunction)
447 Program.T {datatypes = datatypes,
449 functions = functions,
451 val _ = Program.clearTop program