[MLton-commit] r6747
Matthew Fluet
fluet at mlton.org
Tue Aug 19 15:14:05 PDT 2008
Make implementExceptions robust against an un-shrinked input program.
The implementExceptions pass previously required a shrink of the input
program. The initial extra value was extracted from the argument to
the Exn_setInitExtra primitive. However, if the input program was not
shrunk, then the variable might not be bound to a primitive
expression. (Furthermore, even if it were bound to a primitive
expression, the expression may have free variables, and so could not
be lifted to the beginning of the program.) Similarly, if the input
program was not shrunk, then the Exn_extra and Exn_setExtendExtra
primitives might not be eliminated from the input program.
This commit eliminates the Exn_setInitExtra primitive. To determine
the extra type, we search the program for the type argument to the
Exn_extra and Exn_setExtendExtra primitives. The extra type should
correspond to a datatype with a nullary constructor, which is used as
the initial extra value. (In the absence of the primitives, as likely
happens with a shrunk program compiled with 'Exn.keepHistory false',
the extra type is set to unit.)
----------------------------------------------------------------------
U mlton/trunk/basis-library/mlton/exn.sml
U mlton/trunk/basis-library/primitive/prim-mlton.sml
U mlton/trunk/mlton/atoms/prim.fun
U mlton/trunk/mlton/atoms/prim.sig
U mlton/trunk/mlton/xml/implement-exceptions.fun
U mlton/trunk/mlton/xml/sxml-simplify.fun
----------------------------------------------------------------------
Modified: mlton/trunk/basis-library/mlton/exn.sml
===================================================================
--- mlton/trunk/basis-library/mlton/exn.sml 2008-08-19 22:13:52 UTC (rev 6746)
+++ mlton/trunk/basis-library/mlton/exn.sml 2008-08-19 22:13:59 UTC (rev 6747)
@@ -15,11 +15,10 @@
val history: t -> string list =
if keepHistory then
- (setInitExtra (NONE: extra)
- ; setExtendExtra (fn e =>
- case e of
- NONE => SOME (MLtonCallStack.current ())
- | SOME _ => e)
+ (setExtendExtra (fn e =>
+ case e of
+ NONE => SOME (MLtonCallStack.current ())
+ | SOME _ => e)
; (fn e =>
case extra e of
NONE => []
Modified: mlton/trunk/basis-library/primitive/prim-mlton.sml
===================================================================
--- mlton/trunk/basis-library/primitive/prim-mlton.sml 2008-08-19 22:13:52 UTC (rev 6746)
+++ mlton/trunk/basis-library/primitive/prim-mlton.sml 2008-08-19 22:13:59 UTC (rev 6747)
@@ -92,19 +92,12 @@
val keepHistory = _command_line_const "Exn.keepHistory": bool = false;
val setExtendExtra = _prim "Exn_setExtendExtra": ('a -> 'a) -> unit;
val setExtendExtra: (extra -> extra) -> unit = setExtendExtra
- val setInitExtra = _prim "Exn_setInitExtra": 'a -> unit;
- val setInitExtra: extra -> unit = setInitExtra
- (* Ensure that setInitExtra and setExtendExtra are initialized.
+ (* Ensure that setExtendExtra is initialized.
* Important for -const 'Exn.keepHistory true', so that
* exceptions can be raised (and handled) during Basis Library
* initialization.
*)
- val setInitExtra : extra -> unit =
- if keepHistory
- then (setInitExtra (NONE: extra)
- ; fn _ => ())
- else fn _ => ()
val setExtendExtra : (extra -> extra) -> unit =
if keepHistory
then (setExtendExtra (fn _ => NONE)
Modified: mlton/trunk/mlton/atoms/prim.fun
===================================================================
--- mlton/trunk/mlton/atoms/prim.fun 2008-08-19 22:13:52 UTC (rev 6746)
+++ mlton/trunk/mlton/atoms/prim.fun 2008-08-19 22:13:59 UTC (rev 6747)
@@ -58,7 +58,6 @@
| Exn_extra (* implement exceptions *)
| Exn_name (* implement exceptions *)
| Exn_setExtendExtra (* implement exceptions *)
- | Exn_setInitExtra (* implement exceptions *)
| FFI of 'a CFunction.t (* ssa to rssa *)
| FFI_Symbol of {name: string,
cty: CType.t option,
@@ -245,7 +244,6 @@
| Exn_extra => "Exn_extra"
| Exn_name => "Exn_name"
| Exn_setExtendExtra => "Exn_setExtendExtra"
- | Exn_setInitExtra => "Exn_setInitExtra"
| FFI f => (CFunction.Target.toString o CFunction.target) f
| FFI_Symbol {name, ...} => name
| GC_collect => "GC_collect"
@@ -387,7 +385,6 @@
| (Exn_extra, Exn_extra) => true
| (Exn_name, Exn_name) => true
| (Exn_setExtendExtra, Exn_setExtendExtra) => true
- | (Exn_setInitExtra, Exn_setInitExtra) => true
| (FFI f, FFI f') => CFunction.equals (f, f')
| (FFI_Symbol {name = n, ...}, FFI_Symbol {name = n', ...}) => n = n'
| (GC_collect, GC_collect) => true
@@ -551,7 +548,6 @@
| Exn_extra => Exn_extra
| Exn_name => Exn_name
| Exn_setExtendExtra => Exn_setExtendExtra
- | Exn_setInitExtra => Exn_setInitExtra
| FFI func => FFI (CFunction.map (func, f))
| FFI_Symbol {name, cty, symbolScope} =>
FFI_Symbol {name = name, cty = cty, symbolScope = symbolScope}
@@ -802,7 +798,6 @@
| Exn_extra => Functional
| Exn_name => Functional
| Exn_setExtendExtra => SideEffect
- | Exn_setInitExtra => SideEffect
| FFI _ => Kind.SideEffect
| FFI_Symbol _ => Functional
| GC_collect => SideEffect
@@ -1005,7 +1000,6 @@
Exn_extra,
Exn_name,
Exn_setExtendExtra,
- Exn_setInitExtra,
GC_collect,
IntInf_add,
IntInf_andb,
@@ -1260,7 +1254,6 @@
| Exn_extra => oneTarg (fn t => (oneArg exn, t))
| Exn_name => noTargs (fn () => (oneArg exn, string))
| Exn_setExtendExtra => oneTarg (fn t => (oneArg (arrow (t, t)), unit))
- | Exn_setInitExtra => oneTarg (fn t => (oneArg t, unit))
| FFI f =>
noTargs (fn () => (nArgs (CFunction.args f), CFunction.return f))
| FFI_Symbol _ => noTargs (fn () => (noArgs, cpointer))
@@ -1421,7 +1414,6 @@
| CPointer_setObjptr => one (arg 2)
| Exn_extra => one result
| Exn_setExtendExtra => one (#2 (deArrow (arg 0)))
- | Exn_setInitExtra => one (arg 0)
| MLton_bogus => one result
| MLton_deserialize => one result
| MLton_eq => one (arg 0)
Modified: mlton/trunk/mlton/atoms/prim.sig
===================================================================
--- mlton/trunk/mlton/atoms/prim.sig 2008-08-19 22:13:52 UTC (rev 6746)
+++ mlton/trunk/mlton/atoms/prim.sig 2008-08-19 22:13:59 UTC (rev 6747)
@@ -49,7 +49,6 @@
| Exn_extra (* implement exceptions *)
| Exn_name (* implement exceptions *)
| Exn_setExtendExtra (* implement exceptions *)
- | Exn_setInitExtra (* implement exceptions *)
| FFI of 'a CFunction.t (* ssa to rssa *)
| FFI_Symbol of {name: string, (* codegen *)
cty: CType.t option,
Modified: mlton/trunk/mlton/xml/implement-exceptions.fun
===================================================================
--- mlton/trunk/mlton/xml/implement-exceptions.fun 2008-08-19 22:13:52 UTC (rev 6746)
+++ mlton/trunk/mlton/xml/implement-exceptions.fun 2008-08-19 22:13:59 UTC (rev 6747)
@@ -20,111 +20,89 @@
(* topLevelHandler holds the ref cell containing the function of
* type exn -> unit that should be called on unhandled exceptions.
*)
- val topLevelHandler = Var.newNoname ()
+ val topLevelHandlerType = Type.arrow (Type.exn, Type.unit)
+ val topLevelHandlerVar = Var.newNoname ()
+ val extraType =
+ Exn.withEscape
+ (fn escape =>
+ let
+ val _ =
+ Exp.foreachPrimExp
+ (body, fn (_, _, e) =>
+ case e of
+ PrimApp {prim, targs, ...} =>
+ (case Prim.name prim of
+ Prim.Name.Exn_extra =>
+ escape (Vector.sub (targs, 0))
+ | Prim.Name.Exn_setExtendExtra =>
+ escape (Vector.sub (targs, 0))
+ | _ => ())
+ | _ => ())
+ in
+ Type.unit
+ end)
+ val dfltExtraVar = Var.newNoname ()
+ val dfltExtraExp =
+ if Type.isUnit extraType
+ then Dexp.unit ()
+ else let
+ val extraTycon = Type.tycon extraType
+ val extraCon =
+ Exn.withEscape
+ (fn escape =>
+ let
+ val _ =
+ Vector.foreach
+ (datatypes, fn {cons, tycon, ...} =>
+ if Tycon.equals (tycon, extraTycon)
+ then Vector.foreach
+ (cons, fn {arg, con, ...} =>
+ case arg of
+ NONE => escape con
+ | _ => ())
+ else ())
+ in
+ Error.bug "ImplementExceptions: can't find extraCon"
+ end)
+ in
+ Dexp.conApp {arg = NONE,
+ con = extraCon,
+ targs = Vector.new0 (),
+ ty = extraType}
+ end
+ val extendExtraType = Type.arrow (extraType, extraType)
val extendExtraVar = Var.newNoname ()
- val exnName = Var.newString "exnName"
+ val exnNameVar = Var.newString "exnName"
(* sumType is the type of the datatype with all of the exn constructors. *)
- val {dropVar,
- extendExtraType,
- extra,
- extraDatatypes,
- extract,
- extractSum,
- inject,
+ val {extraDatatypes,
+ injectSum,
+ projectExtra,
+ projectSum,
raisee,
sumTycon,
- sumType,
- wrapBody
+ sumType
} =
if not (!Control.exnHistory)
- then {dropVar = fn _ => false,
- extendExtraType = Type.unit,
- extra = fn _ => Error.bug "ImplementExceptions: no extra",
- extraDatatypes = Vector.new0 (),
- extract = fn (exn, _, f) => f (Dexp.monoVar (exn, Type.exn)),
- extractSum = fn e => e,
- inject = fn e => e,
+ then {extraDatatypes = Vector.new0 (),
+ injectSum = fn e => e,
+ projectExtra = fn _ => Dexp.monoVar (dfltExtraVar, extraType),
+ projectSum = fn x => Dexp.monoVar (x, Type.exn),
raisee = (fn {exn, extend, ty, var} =>
[MonoVal {var = var, ty = ty,
exp = Raise {exn = exn,
extend = extend}}]),
sumTycon = Tycon.exn,
- sumType = Type.exn,
- wrapBody = Dexp.toExp}
+ sumType = Type.exn}
else
let
val sumTycon = Tycon.newNoname ()
val sumType = Type.con (sumTycon, Vector.new0 ())
- fun find (nameString: string, isName: Type.t Prim.Name.t -> bool)
- : Var.t * Type.t * PrimExp.t =
- let
- val var =
- Exn.withEscape
- (fn escape =>
- let
- val _ =
- Exp.foreachPrimExp
- (body, fn (_, _, e) =>
- case e of
- PrimApp {args, prim, ...} =>
- if isName (Prim.name prim)
- then escape (VarExp.var
- (Vector.sub (args, 0)))
- else ()
- | _ => ())
- in
- Error.bug
- (concat ["ImplmentExceptions: can't find var for",
- nameString])
- end)
- val (ty, exp) =
- Exn.withEscape
- (fn escape =>
- let
- val _ = Exp.foreachPrimExp (body, fn (x, t, e) =>
- if Var.equals (x, var)
- then escape (t, e)
- else ())
- in
- Error.bug
- (concat ["ImplementExceptions: can't find ",
- Var.toString var])
- end)
- in
- (var, ty, exp)
- end
- val (initExtraVar, initExtraType, initExtraExp) =
- find ("Exn_setInitExtra",
- fn Prim.Name.Exn_setInitExtra => true | _ => false)
- val extraType = initExtraType
- val extendExtraType = Type.arrow (extraType, extraType)
local
open Type
in
val exnCon = Con.newNoname ()
val exnConArgType = tuple (Vector.new2 (extraType, sumType))
- val seType = tuple (Vector.new2 (string, extraType))
end
- fun wrapBody body =
- let
- val body =
- Dexp.let1
- {body = body,
- exp = (Dexp.reff
- (Dexp.lambda
- {arg = Var.newNoname (),
- argType = extraType,
- body = Dexp.bug ("extendExtra unimplemented",
- extraType),
- bodyType = extraType,
- mayInline = true})),
- var = extendExtraVar}
- in
- Exp.prefix (Dexp.toExp body,
- Dec.MonoVal {var = initExtraVar,
- ty = initExtraType,
- exp = initExtraExp})
- end
fun makeExn {exn, extra} =
let
open Dexp
@@ -136,9 +114,11 @@
arg = SOME (tuple {exps = Vector.new2 (extra, exn),
ty = exnConArgType})}
end
- fun inject (exn: Dexp.t): Dexp.t =
+ fun injectSum (exn: Dexp.t): Dexp.t =
makeExn {exn = exn,
- extra = Dexp.monoVar (initExtraVar, initExtraType)}
+ extra = Dexp.monoVar (dfltExtraVar, extraType)}
+ fun extractExtra x =
+ Dexp.select {tuple = x, offset = 0, ty = extraType}
fun extractSum x =
Dexp.select {tuple = x, offset = 1, ty = sumType}
fun extract (exn: Var.t, ty, f: Dexp.t -> Dexp.t): Dexp.t =
@@ -157,11 +137,10 @@
arg = SOME (tuple, exnConArgType)},
f (monoVar (tuple, exnConArgType))))}
end
- fun extra (x: Var.t) =
- extract (x, extraType, fn tuple =>
- Dexp.select {tuple = tuple,
- offset = 0,
- ty = extraType})
+ fun projectExtra (x: Var.t) =
+ extract (x, extraType, extractExtra)
+ fun projectSum (x: Var.t) =
+ extract (x, sumType, extractSum)
fun raisee {exn: VarExp.t,
extend: bool,
ty: Type.t,
@@ -177,19 +156,13 @@
(VarExp.var exn, ty, fn tup =>
raisee
{exn = makeExn
- {exn = select {tuple = tup,
- offset = 1,
- ty = sumType},
+ {exn = extractSum tup,
extra =
app
{func = deref (monoVar
(extendExtraVar,
Type.reff extendExtraType)),
- arg = tuple {exps = (Vector.new1
- (select {tuple = tup,
- offset = 0,
- ty = extraType})),
- ty = seType},
+ arg = extractExtra tup,
ty = extraType}},
extend = false,
ty = ty})
@@ -201,19 +174,14 @@
tyvars = Vector.new0 (),
cons = Vector.new1 {con = exnCon,
arg = SOME exnConArgType}}
- fun dropVar x = Var.equals (x, initExtraVar)
in
- {dropVar = dropVar,
- extendExtraType = extendExtraType,
- extra = extra,
- extraDatatypes = extraDatatypes,
- extract = extract,
- extractSum = extractSum,
- inject = inject,
+ {extraDatatypes = extraDatatypes,
+ injectSum = injectSum,
+ projectExtra = projectExtra,
+ projectSum = projectSum,
raisee = raisee,
sumTycon = sumTycon,
- sumType = sumType,
- wrapBody = wrapBody}
+ sumType = sumType}
end
val {get = exconInfo: Con.t -> {refVar: Var.t,
make: VarExp.t option -> Dexp.t} option,
@@ -264,10 +232,10 @@
val r = Var.newString "exnRef"
val uniq = monoVar (r, Type.unitRef)
fun conApp arg =
- inject (Dexp.conApp {con = con,
- targs = Vector.new0 (),
- ty = sumType,
- arg = SOME arg})
+ injectSum (Dexp.conApp {con = con,
+ targs = Vector.new0 (),
+ ty = sumType,
+ arg = SOME arg})
val (arg, decs, make) =
case arg of
NONE =>
@@ -291,12 +259,11 @@
Type.tuple (Vector.new2 (Type.unitRef, t))
in (tupleType,
[],
- fn SOME x =>
- conApp (tuple {exps = Vector.new2 (uniq,
- varExp (x, t)),
- ty = tupleType})
- | _ =>
- Error.bug "ImplmentExceptions: unary excon not applied to arg")
+ fn SOME x => (conApp o tuple)
+ {exps = Vector.new2
+ (uniq, varExp (x, t)),
+ ty = tupleType}
+ | _ => Error.bug "ImplmentExceptions: unary excon not applied to arg")
end
in setExconInfo (con, SOME {refVar = r, make = make})
; List.push (exnValCons, {con = con, arg = arg})
@@ -304,9 +271,6 @@
end
| _ => Error.bug "ImplementExceptions: saw unexpected dec") arg
and loopMonoVal {var, ty, exp} : Dec.t list =
- if dropVar var
- then []
- else
let
fun primExp e = [MonoVal {var = var, ty = ty, exp = e}]
fun keep () = primExp exp
@@ -364,54 +328,52 @@
(lett
{decs = decs,
body =
- extract
- (VarExp.var test, ty, fn tuple =>
- casee
- {test = extractSum tuple,
- ty = ty,
- default = SOME (callDefault (),
- region),
- cases =
- Cases.Con
- (Vector.map
- (cases, fn (Pat.T {con, arg, ...}, e) =>
- let
- val refVar = Var.newNoname ()
- val body =
- iff {test =
- equal
- (monoVar
- (refVar, Type.unitRef),
- monoVar
- (#refVar (valOf (exconInfo con)),
- Type.unitRef)),
- ty = ty,
- thenn = (fromExp
- (loop e, ty)),
- elsee = callDefault ()}
- fun make (arg, body) =
- (Pat.T
- {con = con,
- targs = Vector.new0 (),
- arg = SOME arg},
- body)
- in case arg of
- NONE => make ((refVar, Type.unitRef), body)
- | SOME (x, t) =>
- let
- val tuple =
- (Var.newNoname (),
- Type.tuple (Vector.new2
- (Type.unitRef, t)))
- in
- make (tuple,
- detupleBind
- {tuple = monoVar tuple,
- components =
- Vector.new2 (refVar, x),
- body = body})
- end
- end))})})
+ casee
+ {test = projectSum (VarExp.var test),
+ ty = ty,
+ default = SOME (callDefault (),
+ region),
+ cases =
+ Cases.Con
+ (Vector.map
+ (cases, fn (Pat.T {con, arg, ...}, e) =>
+ let
+ val refVar = Var.newNoname ()
+ val body =
+ iff {test =
+ equal
+ (monoVar
+ (refVar, Type.unitRef),
+ monoVar
+ (#refVar (valOf (exconInfo con)),
+ Type.unitRef)),
+ ty = ty,
+ thenn = (fromExp
+ (loop e, ty)),
+ elsee = callDefault ()}
+ fun make (arg, body) =
+ (Pat.T
+ {con = con,
+ targs = Vector.new0 (),
+ arg = SOME arg},
+ body)
+ in case arg of
+ NONE => make ((refVar, Type.unitRef), body)
+ | SOME (x, t) =>
+ let
+ val tuple =
+ (Var.newNoname (),
+ Type.tuple (Vector.new2
+ (Type.unitRef, t)))
+ in
+ make (tuple,
+ detupleBind
+ {tuple = monoVar tuple,
+ components =
+ Vector.new2 (refVar, x),
+ body = body})
+ end
+ end))}})
end
end
| _ => normal ()
@@ -441,20 +403,22 @@
Vector.sub (args, 0))})
in
case Prim.name prim of
- Exn_extra => makeExp (extra (VarExp.var
- (Vector.sub (args, 0))))
+ Exn_extra =>
+ (makeExp o projectExtra)
+ (VarExp.var (Vector.sub (args, 0)))
| Exn_name =>
- primExp (App {func = VarExp.mono exnName,
- arg = Vector.sub (args, 0)})
+ (primExp o App)
+ {func = VarExp.mono exnNameVar,
+ arg = Vector.sub (args, 0)}
| Exn_setExtendExtra =>
- assign (extendExtraVar, extendExtraType)
- | Exn_setInitExtra => primExp (Tuple (Vector.new0 ()))
+ assign (extendExtraVar,
+ extendExtraType)
| TopLevel_getHandler =>
- deref (topLevelHandler,
- Type.arrow (Type.exn, Type.unit))
+ deref (topLevelHandlerVar,
+ topLevelHandlerType)
| TopLevel_setHandler =>
- assign (topLevelHandler,
- Type.arrow (Type.exn, Type.unit))
+ assign (topLevelHandlerVar,
+ topLevelHandlerType)
| _ => primExp exp
end
| Raise {exn, extend} =>
@@ -470,26 +434,77 @@
body = loop body,
mayInline = mayInline}
end
+ val body = Dexp.fromExp (loop body, Type.unit)
+ val exnValCons = Vector.fromList (!exnValCons)
+ val datatypes =
+ Vector.concat
+ [Vector.new1
+ {tycon = sumTycon,
+ tyvars = Vector.new0 (),
+ cons = Vector.map (exnValCons, fn {con, arg} =>
+ {con = con, arg = SOME arg})},
+ extraDatatypes,
+ datatypes]
val body =
+ Dexp.let1
+ {body = body,
+ exp = let
+ val exn = Var.newNoname ()
+ in
+ Dexp.lambda
+ {arg = exn,
+ argType = Type.exn,
+ body = (Dexp.casee
+ {test = projectSum exn,
+ cases =
+ Cases.Con
+ (Vector.map
+ (exnValCons, fn {con, arg} =>
+ (Pat.T {con = con,
+ targs = Vector.new0 (),
+ arg = SOME (Var.newNoname (), arg)},
+ Dexp.const (Const.string (Con.originalName con))))),
+ default = NONE,
+ ty = Type.string}),
+ bodyType = Type.string,
+ mayInline = true}
+ end,
+ var = exnNameVar}
+ val body =
+ Dexp.let1
+ {body = body,
+ exp = (Dexp.reff
+ (Dexp.lambda
+ {arg = Var.newNoname (),
+ argType = extraType,
+ body = Dexp.bug ("extendExtra unimplemented",
+ extraType),
+ bodyType = extraType,
+ mayInline = true})),
+ var = extendExtraVar}
+ val body =
+ Dexp.let1
+ {body = body,
+ exp = dfltExtraExp,
+ var = dfltExtraVar}
+ val body =
let
val x = (Var.newNoname (), Type.exn)
in
Dexp.handlee
- {try = Dexp.fromExp (loop body, Type.unit),
+ {try = body,
ty = Type.unit,
catch = x,
handler = Dexp.app {func = (Dexp.deref
(Dexp.monoVar
- (topLevelHandler,
- let open Type
- in reff (arrow (exn, unit))
- end))),
+ (topLevelHandlerVar,
+ Type.reff topLevelHandlerType))),
arg = Dexp.monoVar x,
ty = Type.unit}}
end
val body =
Dexp.let1
- {var = topLevelHandler,
+ {var = topLevelHandlerVar,
exp = Dexp.reff (Dexp.lambda
{arg = Var.newNoname (),
argType = Type.exn,
@@ -498,78 +513,19 @@
bodyType = Type.unit,
mayInline = true}),
body = body}
- val body = wrapBody body
- val (datatypes, body) =
- case !exnValCons of
- [] => (datatypes, body)
- | cons =>
- let
- val cons = Vector.fromList cons
- val exnNameDec =
- MonoVal
- {var = exnName,
- ty = Type.arrow (Type.exn, Type.string),
- exp =
- let
- val exn = Var.newNoname ()
- in
- Lambda
- (Lambda.make
- {arg = exn,
- argType = Type.exn,
- mayInline = true,
- body =
- let
- open Dexp
- in toExp
- (extract
- (exn, Type.string, fn tuple =>
- casee
- {test = extractSum tuple,
- cases =
- Cases.Con
- (Vector.map
- (cons, fn {con, arg} =>
- (Pat.T {con = con,
- targs = Vector.new0 (),
- arg = SOME (Var.newNoname (), arg)},
- const
- (Const.string
- (Con.originalName con))))),
- default = NONE,
- ty = Type.string}))
- end})
- end}
- in
- (Vector.concat
- [Vector.new1
- {tycon = sumTycon,
- tyvars = Vector.new0 (),
- cons = Vector.map (cons, fn {con, arg} =>
- {con = con, arg = SOME arg})},
- extraDatatypes,
- datatypes],
- Exp.prefix (body, exnNameDec))
- end
val body =
- Exp.fromPrimExp
- (Handle {try = body,
- catch = (Var.newNoname (), Type.exn),
- handler =
- let
- val s = Var.newNoname ()
- in Exp.prefix
- (Exp.fromPrimExp
- (PrimApp {prim = Prim.bug,
- targs = Vector.new0 (),
- args = Vector.new1 (VarExp.mono s)},
- Type.unit),
- MonoVal {var = s,
- ty = Type.string,
- exp = Const (Const.string
- "toplevel handler not installed")})
- end},
- Type.unit)
+ Dexp.handlee
+ {try = body,
+ ty = Type.unit,
+ catch = (Var.newNoname (), Type.exn),
+ handler = (Dexp.primApp
+ {prim = Prim.bug,
+ targs = Vector.new0 (),
+ args = Vector.new1
+ (Dexp.string
+ "toplevel handler not installed"),
+ ty = Type.unit})}
+ val body = Dexp.toExp body
val program =
Program.T {datatypes = datatypes,
body = body,
Modified: mlton/trunk/mlton/xml/sxml-simplify.fun
===================================================================
--- mlton/trunk/mlton/xml/sxml-simplify.fun 2008-08-19 22:13:52 UTC (rev 6746)
+++ mlton/trunk/mlton/xml/sxml-simplify.fun 2008-08-19 22:13:59 UTC (rev 6747)
@@ -61,8 +61,6 @@
val sxmlPassesMinimal =
{name = "implementSuffix",
enable = fn () => true, doit = ImplementSuffix.doit} ::
- {name = "sxmlShrink2",
- enable = fn () => true, doit = S.shrink} ::
{name = "implementExceptions",
enable = fn () => true, doit = ImplementExceptions.doit} ::
nil
More information about the MLton-commit
mailing list