1 (* Copyright (C) 1999-2005 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 SimplifyTypes (S: SIMPLIFY_TYPES_STRUCTS): SIMPLIFY_TYPES =
17 structure PowerSetLat =
19 datatype t = T of {isIn: bool ref,
20 whenIn: (unit -> unit) list ref} vector
23 ! (#isIn (Vector.sub (v, i)))
25 fun new (size: int) = T (Vector.tabulate (size, fn _ =>
31 val {isIn, whenIn, ...} = Vector.sub (v, i)
36 ; List.foreach (!whenIn, fn f => f ()))
39 fun whenIn (T v, i, f) =
41 val {isIn, whenIn, ...} = Vector.sub (v, i)
45 else List.push (whenIn, f)
49 fun simplifyTypes (I.Program.T {body, datatypes, overflow}) =
51 val {get = tyconInfo: Tycon.t -> {used: PowerSetLat.t} option,
52 set = setTyconInfo, ...} =
53 Property.getSetOnce (Tycon.plist, Property.initConst NONE)
56 (datatypes, fn {tycon, tyvars, ...} =>
58 SOME {used = PowerSetLat.new (Vector.length tyvars)}))
61 (datatypes, fn {cons, tycon, tyvars} =>
63 val {get = tyvarIndex, set = setTyvarIndex, rem, ...} =
65 (Tyvar.plist, Property.initRaise ("index", Tyvar.layout))
66 val _ = Vector.foreachi (tyvars, fn (i, a) => setTyvarIndex (a, i))
67 val {used, ...} = valOf (tyconInfo tycon)
70 {con = (fn (_, tc, ts) =>
73 NONE => Vector.foreach (ts, fn t => t ())
77 PowerSetLat.whenIn (used, i, t))),
82 fn () => PowerSetLat.add (used, i)
86 (cons, fn {arg, ...} =>
90 val _ = Vector.foreach (tyvars, rem)
95 val {get = tyconKeep: Tycon.t -> bool vector option,
96 set = setTyconKeep, ...} =
97 Property.getSetOnce (Tycon.plist, Property.initConst NONE)
98 val {get = conKeep: Con.t -> bool vector option,
99 set = setConKeep, ...} =
100 Property.getSetOnce (Con.plist, Property.initConst NONE)
103 (datatypes, fn {cons, tycon, tyvars} =>
105 val {used, ...} = valOf (tyconInfo tycon)
108 (Vector.length tyvars, fn i => PowerSetLat.isIn (used, i))
109 val _ = Vector.foreach (cons, fn {con, ...} =>
110 setConKeep (con, SOME v))
112 if Vector.forall (v, fn b => b)
115 val _ = setTyconKeep (tycon, u)
119 fun keep (v: 'a vector, bv: bool vector): 'a vector =
120 Vector.keepAllMapi (v, fn (i, a) =>
121 if Vector.sub (bv, i)
124 val {get = tyvarIsUsed: Tyvar.t -> bool ref, ...} =
125 Property.get (Tyvar.plist, Property.initFun (fn _ => ref false))
126 (* There is some mesiness with promises here for two reasons:
127 * 1. The thunk is to make sure that even though we are using a type
128 * homomorphism, a type variable is only marked as used if it appears
130 * 2. The promise is do avoid computing the same output multiple times.
131 * This is necessary because the type homomorphism only memoizes the
132 * mapping from type to thunk, *not* the thunk's output.
134 val {hom = fixType: I.Type.t -> unit -> O.Type.t, ...} =
136 {con = (fn (_, tc, ts) =>
143 | SOME bv => keep (ts, bv)
144 val ts = Vector.map (ts, fn t => t ())
150 (fn () => (tyvarIsUsed a := true; O.Type.var a)))}
151 val fixType = fn t => fixType t ()
154 ("SimplifyTypes.fixType", I.Type.layout, O.Type.layout)
156 val tyvarIsUsed = ! o tyvarIsUsed
158 Vector.map (datatypes, fn {cons, tycon, tyvars} =>
159 {cons = Vector.map (cons, fn {arg, con} =>
160 {arg = Option.map (arg, fixType),
163 tyvars = (case tyconKeep tycon of
165 | SOME bv => keep (tyvars, bv))})
166 val {get = varKeep: Var.t -> bool vector option,
167 set = setVarKeep, ...} =
168 Property.getSetOnce (Var.plist, Property.initConst NONE)
169 fun fixVarExp (I.VarExp.T {targs, var}): O.VarExp.t =
174 | SOME bv => keep (targs, bv)
176 O.VarExp.T {targs = Vector.map (targs, fixType),
181 ("SimplifyTypes.fixVarExp", I.VarExp.layout, O.VarExp.layout)
183 fun fixConTargs (con: Con.t, targs: I.Type.t vector): O.Type.t vector =
188 | SOME bv => keep (targs, bv)
190 Vector.map (targs, fixType)
192 fun fixPat (I.Pat.T {arg, con, targs}): O.Pat.t =
193 O.Pat.T {arg = Option.map (arg, fn (x, t) => (x, fixType t)),
195 targs = fixConTargs (con, targs)}
196 fun fixDec (d: I.Dec.t): O.Dec.t =
198 I.Dec.Exception {arg, con} =>
199 O.Dec.Exception {arg = Option.map (arg, fixType),
201 | I.Dec.Fun {decs, tyvars} =>
204 Vector.map (decs, fn {lambda, ty, var} =>
205 {lambda = fixLambda lambda,
208 val bv = Vector.map (tyvars, tyvarIsUsed)
209 val tyvars = keep (tyvars, bv)
212 (decs, fn {var, ...} => setVarKeep (var, SOME bv))
214 O.Dec.Fun {decs = decs,
217 | I.Dec.MonoVal {exp, ty, var} =>
218 O.Dec.MonoVal {exp = fixPrimExp exp,
221 | I.Dec.PolyVal {exp, ty, tyvars, var} =>
225 val bv = Vector.map (tyvars, tyvarIsUsed)
226 val _ = setVarKeep (var, SOME bv)
228 O.Dec.PolyVal {exp = exp,
230 tyvars = keep (tyvars, bv),
233 and fixExp (e: I.Exp.t): O.Exp.t =
235 val {decs, result} = I.Exp.dest e
237 O.Exp.make {decs = List.map (decs, fixDec),
238 result = fixVarExp result}
240 and fixLambda (l: I.Lambda.t): O.Lambda.t =
242 val {arg, argType, body, mayInline} = I.Lambda.dest l
244 O.Lambda.make {arg = arg,
245 argType = fixType argType,
247 mayInline = mayInline}
249 and fixPrimExp (e: I.PrimExp.t): O.PrimExp.t =
251 I.PrimExp.App {arg, func} => O.PrimExp.App {arg = fixVarExp arg,
252 func = fixVarExp func}
253 | I.PrimExp.Case {cases, default, test} =>
258 O.Cases.Con (Vector.map (v, fn (p, e) =>
259 (fixPat p, fixExp e)))
260 | I.Cases.Word (s, v) =>
262 (s, Vector.map (v, fn (c, e) => (c, fixExp e)))
264 O.PrimExp.Case {cases = cases,
265 default = Option.map (default, fn (e, r) =>
267 test = fixVarExp test}
269 | I.PrimExp.ConApp {arg, con, targs} =>
270 O.PrimExp.ConApp {arg = Option.map (arg, fixVarExp),
272 targs = fixConTargs (con, targs)}
273 | I.PrimExp.Const c => O.PrimExp.Const c
274 | I.PrimExp.Handle {catch = (x, t), handler, try} =>
275 O.PrimExp.Handle {catch = (x, fixType t),
276 handler = fixExp handler,
278 | I.PrimExp.Lambda l => O.PrimExp.Lambda (fixLambda l)
279 | I.PrimExp.PrimApp {args, prim, targs} =>
280 O.PrimExp.PrimApp {args = Vector.map (args, fixVarExp),
281 prim = Prim.map (prim, fixType),
282 targs = Vector.map (targs, fixType)}
283 | I.PrimExp.Profile e => O.PrimExp.Profile e
284 | I.PrimExp.Raise {exn, extend} =>
285 O.PrimExp.Raise {exn = fixVarExp exn,
287 | I.PrimExp.Select {offset, tuple} =>
288 O.PrimExp.Select {offset = offset,
289 tuple = fixVarExp tuple}
290 | I.PrimExp.Tuple xs => O.PrimExp.Tuple (Vector.map (xs, fixVarExp))
291 | I.PrimExp.Var x => O.PrimExp.Var (fixVarExp x)
292 val body = fixExp body
294 O.Program.T {datatypes = datatypes,