[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