1 (* Copyright (C) 1999-2008 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 ImplementExceptions (S: XML_TRANSFORM_STRUCTS): XML_TRANSFORM =
13 datatype z = datatype Dec.t
14 datatype z = datatype PrimExp.t
15 structure Dexp = DirectExp
17 fun transform (Program.T {datatypes, body, ...}): Program.t =
19 (* topLevelHandler holds the ref cell containing the function of
20 * type exn -> unit that should be called on unhandled exceptions.
22 val topLevelHandlerType = Type.arrow (Type.exn, Type.unit)
23 val topLevelHandlerVar = Var.newNoname ()
30 (body, fn (_, _, e) =>
32 PrimApp {prim, targs, ...} =>
33 (case Prim.name prim of
34 Prim.Name.Exn_extra =>
35 escape (Vector.first targs)
36 | Prim.Name.Exn_setExtendExtra =>
37 escape (Vector.first targs)
43 val dfltExtraVar = Var.newNoname ()
45 if Type.isUnit extraType
48 val extraTycon = Type.tycon extraType
55 (datatypes, fn {cons, tycon, ...} =>
56 if Tycon.equals (tycon, extraTycon)
58 (cons, fn {arg, con, ...} =>
64 Error.bug "ImplementExceptions: can't find extraCon"
67 Dexp.conApp {arg = NONE,
69 targs = Vector.new0 (),
72 val extendExtraType = Type.arrow (extraType, extraType)
73 val extendExtraVar = Var.newNoname ()
74 val exnNameVar = Var.newString "exnName"
75 (* sumType is the type of the datatype with all of the exn constructors. *)
84 if not (!Control.exnHistory)
85 then {extraDatatypes = Vector.new0 (),
86 injectSum = fn e => e,
87 projectExtra = fn _ => Dexp.monoVar (dfltExtraVar, extraType),
88 projectSum = fn x => Dexp.monoVar (x, Type.exn),
89 raisee = (fn {exn, extend, ty, var} =>
90 [MonoVal {var = var, ty = ty,
91 exp = Raise {exn = exn,
97 val sumTycon = Tycon.newNoname ()
98 val sumType = Type.con (sumTycon, Vector.new0 ())
102 val exnCon = Con.newNoname ()
103 val exnConArgType = tuple (Vector.new2 (extraType, sumType))
105 fun makeExn {exn, extra} =
111 targs = Vector.new0 (),
113 arg = SOME (tuple {exps = Vector.new2 (extra, exn),
114 ty = exnConArgType})}
116 fun injectSum (exn: Dexp.t): Dexp.t =
118 extra = Dexp.monoVar (dfltExtraVar, extraType)}
120 Dexp.select {tuple = x, offset = 0, ty = extraType}
122 Dexp.select {tuple = x, offset = 1, ty = sumType}
123 fun extract (exn: Var.t, ty, f: Dexp.t -> Dexp.t): Dexp.t =
126 val tuple = Var.newNoname ()
129 {test = monoVar (exn, Type.exn),
133 Cases.Con (Vector.new1
134 (Pat.T {con = exnCon,
135 targs = Vector.new0 (),
136 arg = SOME (tuple, exnConArgType)},
137 f (monoVar (tuple, exnConArgType))))}
139 fun projectExtra (x: Var.t) =
140 extract (x, extraType, extractExtra)
141 fun projectSum (x: Var.t) =
142 extract (x, sumType, extractSum)
143 fun raisee {exn: VarExp.t,
146 var = x : Var.t}: Dec.t list =
151 then raisee {exn = varExp (exn, Type.exn),
152 extend = false, ty = ty}
155 (VarExp.var exn, ty, fn tup =>
158 {exn = extractSum tup,
161 {func = deref (monoVar
163 Type.reff extendExtraType)),
164 arg = extractExtra tup,
169 vall {exp = exp, var = x}
172 Vector.new1 {tycon = Tycon.exn,
173 tyvars = Vector.new0 (),
174 cons = Vector.new1 {con = exnCon,
175 arg = SOME exnConArgType}}
177 {extraDatatypes = extraDatatypes,
178 injectSum = injectSum,
179 projectExtra = projectExtra,
180 projectSum = projectSum,
185 val {get = exconInfo: Con.t -> {refVar: Var.t,
186 make: VarExp.t option -> Dexp.t} option,
187 set = setExconInfo, destroy} =
188 Property.destGetSetOnce (Con.plist, Property.initConst NONE)
191 ("ImplementExceptions.setExconInfo",
192 Con.layout, Layout.ignore, Unit.layout)
196 ("ImplementExceptions.exconInfo",
197 Con.layout, Layout.ignore)
203 val exnValCons: {con: Con.t, arg: Type.t} list ref = ref []
204 val overflow = ref NONE
207 ("ImplementExceptions.loopDec", Dec.layout, List.layout Dec.layout)
208 fun loop (e: Exp.t): Exp.t =
210 val {decs, result} = Exp.dest e
211 val decs = List.concatRev (List.fold (decs, [], fn (d, ds) =>
214 Exp.make {decs = decs,
217 and loopDec arg: Dec.t list =
221 MonoVal b => loopMonoVal b
223 [Fun {tyvars = Vector.new0 (),
224 decs = Vector.map (decs, fn {var, ty, lambda} =>
227 lambda = loopLambda lambda})}]
228 | Exception {con, arg} =>
231 val r = Var.newString "exnRef"
232 val uniq = monoVar (r, Type.unitRef)
234 injectSum (Dexp.conApp {con = con,
235 targs = Vector.new0 (),
238 val (arg, decs, make) =
241 (* If the exception is not value carrying, then go
242 * ahead and make it now.
245 val exn = Var.newNoname ()
247 if Con.equals (con, Con.overflow)
248 then overflow := SOME exn
251 Dexp.vall {var = exn, exp = conApp uniq},
252 fn NONE => monoVar (exn, Type.exn)
253 | _ => Error.bug "ImplementExceptions: nullary excon applied to arg")
258 Type.tuple (Vector.new2 (Type.unitRef, t))
261 fn SOME x => (conApp o tuple)
263 (uniq, varExp (x, t)),
265 | _ => Error.bug "ImplmentExceptions: unary excon not applied to arg")
267 in setExconInfo (con, SOME {refVar = r, make = make})
268 ; List.push (exnValCons, {con = con, arg = arg})
269 ; vall {var = r, exp = reff (unit ())} @ decs
271 | _ => Error.bug "ImplementExceptions: saw unexpected dec") arg
272 and loopMonoVal {var, ty, exp} : Dec.t list =
274 fun primExp e = [MonoVal {var = var, ty = ty, exp = e}]
275 fun keep () = primExp exp
276 fun makeExp e = Dexp.vall {var = var, exp = e}
279 Case {test, cases, default} =>
282 primExp (Case {cases = Cases.map (cases, loop),
283 default = (Option.map
284 (default, fn (e, r) =>
290 if Vector.isEmpty cases
294 val (Pat.T {con, ...}, _) =
299 else (* convert to an exception match *)
302 val defaultVar = Var.newString "default"
310 val unit = Var.newString "unit"
314 Error.bug "ImplementExceptions: no default for exception case"
316 (fromExp (loop e, ty), r)
320 exp = lambda {arg = unit,
331 {test = projectSum (VarExp.var test),
333 default = SOME (callDefault (),
338 (cases, fn (Pat.T {con, arg, ...}, e) =>
340 val refVar = Var.newNoname ()
345 (refVar, Type.unitRef),
347 (#refVar (valOf (exconInfo con)),
352 elsee = callDefault ()}
353 fun make (arg, body) =
356 targs = Vector.new0 (),
360 NONE => make ((refVar, Type.unitRef), body)
365 Type.tuple (Vector.new2
370 {tuple = monoVar tuple,
372 Vector.new2 (refVar, x),
380 | ConApp {con, arg, ...} =>
381 (case exconInfo con of
383 | SOME {make, ...} => makeExp (make arg))
384 | Handle {try, catch = (catch, ty), handler} =>
385 primExp (Handle {try = loop try,
387 handler = loop handler})
388 | Lambda l => primExp (Lambda (loopLambda l))
389 | PrimApp {args, prim, ...} =>
391 datatype z = datatype Prim.Name.t
392 fun deref (var, ty) =
394 (PrimApp {prim = Prim.deref,
395 targs = Vector.new1 ty,
396 args = Vector.new1 (VarExp.mono var)})
397 fun assign (var, ty) =
399 (PrimApp {prim = Prim.assign,
400 targs = Vector.new1 ty,
401 args = Vector.new2 (VarExp.mono var,
404 case Prim.name prim of
406 (makeExp o projectExtra)
407 (VarExp.var (Vector.first args))
410 {func = VarExp.mono exnNameVar,
411 arg = Vector.first args}
412 | Exn_setExtendExtra =>
413 assign (extendExtraVar,
415 | TopLevel_getHandler =>
416 deref (topLevelHandlerVar,
418 | TopLevel_setHandler =>
419 assign (topLevelHandlerVar,
423 | Raise {exn, extend} =>
424 raisee {exn = exn, extend = extend, ty = ty, var = var}
429 val {arg, argType, body, mayInline} = Lambda.dest l
431 Lambda.make {arg = arg,
434 mayInline = mayInline}
436 val body = Dexp.fromExp (loop body, Type.unit)
437 val exnValCons = Vector.fromList (!exnValCons)
442 tyvars = Vector.new0 (),
443 cons = Vector.map (exnValCons, fn {con, arg} =>
444 {con = con, arg = SOME arg})},
451 val exn = Var.newNoname ()
457 {test = projectSum exn,
461 (exnValCons, fn {con, arg} =>
463 targs = Vector.new0 (),
464 arg = SOME (Var.newNoname (), arg)},
465 Dexp.const (Const.string (Con.originalName con))))),
468 bodyType = Type.string,
477 {arg = Var.newNoname (),
479 body = (Dexp.sequence o Vector.new2)
480 (Dexp.bug "extendExtra unimplemented",
481 Dexp.monoVar (dfltExtraVar, extraType)),
482 bodyType = extraType,
484 var = extendExtraVar}
492 val x = (Var.newNoname (), Type.exn)
498 handler = Dexp.app {func = (Dexp.deref
501 Type.reff topLevelHandlerType))),
502 arg = Dexp.monoVar x,
507 {var = topLevelHandlerVar,
508 exp = Dexp.reff (Dexp.lambda
509 {arg = Var.newNoname (),
511 body = Dexp.bug "toplevel handler not installed",
512 bodyType = Type.unit,
519 catch = (Var.newNoname (), Type.exn),
520 handler = Dexp.bug "toplevel handler not installed"}
521 val body = Dexp.toExp body
523 Program.T {datatypes = datatypes,
525 overflow = !overflow}