[MLton-devel] cvs commit: -exn-history reimplemted

Stephen Weeks sweeks@users.sourceforge.net
Sun, 25 Aug 2002 15:23:58 -0700


sweeks      02/08/25 15:23:58

  Modified:    doc      CHANGES
               mlton/atoms prim.fun prim.sig
               mlton/closure-convert closure-convert.fun
               mlton/xml implement-exceptions.fun xml-tree.fun xml-tree.sig
               basis-library/misc primitive.sml
               basis-library/mlton exn.sml
  Added:       regression exnHistory3.ok exnHistory3.sml
  Log:
  Changed the implementation of exception history to be completely functional.
  Now, the extra field in exceptions (when compiling -exn-history true) is a
  string list instead of a string list ref, and raise conses a new exception
  with a new element in the list instead of assigning to the list.  This
  changes the semantics of exception history (for the better) on some
  programs. See regression/exnHistory3.sml for an example.  It also
  significantly improves performance when compiling -exn-history true.

Revision  Changes    Path
1.75      +9 -0      mlton/doc/CHANGES

Index: CHANGES
===================================================================
RCS file: /cvsroot/mlton/mlton/doc/CHANGES,v
retrieving revision 1.74
retrieving revision 1.75
diff -u -r1.74 -r1.75
--- CHANGES	21 Aug 2002 04:50:43 -0000	1.74
+++ CHANGES	25 Aug 2002 22:23:57 -0000	1.75
@@ -1,5 +1,14 @@
 Here are the changes from version 20020410 to version VERSION.
 
+* 2002-08-25
+  - Changed the implementation of exception history to be completely functional.
+    Now, the extra field in exceptions (when compiling -exn-history true) is a
+    string list instead of a string list ref, and raise conses a new exception
+    with a new element in the list instead of assigning to the list.  This 
+    changes the semantics of exception history (for the better) on some
+    programs. See regression/exnHistory3.sml for an example.  It also
+    significantly improves performance when compiling -exn-history true.
+
 * 2002-07 and 2002-08
   - Added generational GC, and code to the runtime that automatically turns it
     on and off.



1.36      +4 -3      mlton/mlton/atoms/prim.fun

Index: prim.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/prim.fun,v
retrieving revision 1.35
retrieving revision 1.36
diff -u -r1.35 -r1.36
--- prim.fun	7 Aug 2002 01:02:42 -0000	1.35
+++ prim.fun	25 Aug 2002 22:23:57 -0000	1.36
@@ -55,8 +55,8 @@
        | Exn_extra
        | Exn_keepHistory
        | Exn_name
+       | Exn_setExtendExtra
        | Exn_setInitExtra
-       | Exn_setRaise
        | Exn_setTopLevelHandler
        | FFI of string
        | GC_collect
@@ -276,8 +276,8 @@
 	  (Cpointer_isNull, Functional, "Cpointer_isNull"),
 	  (Exn_extra, Functional, "Exn_extra"),
 	  (Exn_name, Functional, "Exn_name"),
+	  (Exn_setExtendExtra, SideEffect, "Exn_setExtendExtra"),
 	  (Exn_setInitExtra, SideEffect, "Exn_setInitExtra"),
-	  (Exn_setRaise, SideEffect, "Exn_setRaise"),
 	  (Exn_setTopLevelHandler, SideEffect, "Exn_setTopLevelHandler"),
 	  (Exn_setTopLevelHandler, SideEffect, "Exn_setTopLevelHandler"),
 	  (GC_collect, SideEffect, "GC_collect"),
@@ -688,7 +688,8 @@
        | Array_update => one (arg 2)
        | Array_length => one (dearray (arg 0))
        | Exn_extra => one result
-       | Exn_setInitExtra => one (#2 (dearrow (arg 0)))
+       | 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)



1.30      +1 -1      mlton/mlton/atoms/prim.sig

Index: prim.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/prim.sig,v
retrieving revision 1.29
retrieving revision 1.30
diff -u -r1.29 -r1.30
--- prim.sig	7 Aug 2002 01:02:42 -0000	1.29
+++ prim.sig	25 Aug 2002 22:23:57 -0000	1.30
@@ -45,8 +45,8 @@
 	     | Exn_extra (* implemented in implement-exceptions.fun *)
 	     | Exn_keepHistory (* a compile-time boolean *)
 	     | Exn_name (* implemented in implement-exceptions.fun *)
+	     | Exn_setExtendExtra (* implemented in implement-exceptions.fun *)
 	     | Exn_setInitExtra (* implemented in implement-exceptions.fun *)
-	     | Exn_setRaise (* implemented in implement-exceptions.fun *)
 	     | Exn_setTopLevelHandler (* implemented in implement-exceptions.fun *)
 	     | FFI of string
 	     | GC_collect



1.17      +1 -1      mlton/mlton/closure-convert/closure-convert.fun

Index: closure-convert.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/closure-convert/closure-convert.fun,v
retrieving revision 1.16
retrieving revision 1.17
diff -u -r1.16 -r1.17
--- closure-convert.fun	10 Apr 2002 07:02:19 -0000	1.16
+++ closure-convert.fun	25 Aug 2002 22:23:58 -0000	1.17
@@ -666,7 +666,7 @@
 	    exception Yes of Type.t vector
 	 in
 	    (Sexp.foreachPrimExp
-	     (body, fn (_, e) =>
+	     (body, fn (_, _, e) =>
 	      case e of
 		 SprimExp.Handle {catch = (x, _), ...} =>
 		    raise (Yes (Vector.new1 (varInfoType (varInfo x))))



1.4       +97 -93    mlton/mlton/xml/implement-exceptions.fun

Index: implement-exceptions.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/xml/implement-exceptions.fun,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- implement-exceptions.fun	10 Apr 2002 07:02:21 -0000	1.3
+++ implement-exceptions.fun	25 Aug 2002 22:23:58 -0000	1.4
@@ -22,21 +22,20 @@
       val exnName = Var.newString "exnName"
       (* sumType is the type of the datatype with all of the exn constructors. *)
       val {
-	   dropLambda,
+	   dropVar,
 	   extra,
 	   extraDatatypes,
 	   extract,
 	   extractSum,
 	   inject,
 	   raisee,
-	   setRaise,
 	   sumTycon,
 	   sumType,
 	   wrapBody
 	   } =
 	 if not (!Control.exnHistory)
 	    then {
-		  dropLambda = fn _ => false,
+		  dropVar = fn _ => false,
 		  extra = fn _ => Error.bug "no extra",
 		  extraDatatypes = Vector.new0 (),
 		  extract = fn (exn, _, f) => f (Dexp.monoVar (exn, Type.exn)),
@@ -46,91 +45,85 @@
 			    [MonoVal {var = var, ty = ty,
 				      exp = Raise {exn = exn,
 						   filePos = filePos}}]),
-		  setRaise = fn _ => Error.bug "no setRaise",
 		  sumTycon = Tycon.exn,
 		  sumType = Type.exn,
 		  wrapBody = Dexp.toExp
 		  }
 	 else
 	    let
-	       val setRaiseVar = Var.newNoname ()
 	       val sumTycon = Tycon.newNoname ()
 	       val sumType = Type.con (sumTycon, Vector.new0 ())
-	       val (extraType: Type.t, extraVar: Var.t) =
-		  DynamicWind.withEscape
-		  (fn escape =>
-		   let
-		      val _ =
-			 Exp.foreachPrimExp
-			 (body, fn (_, e) =>
-			  case e of
-			     PrimApp {prim, targs, args, ...} =>
-				if Prim.name prim = Prim.Name.Exn_setInitExtra
-				   then (escape
-					 (Vector.sub (targs, 0),
-					  VarExp.var (Vector.sub (args, 0))))
-				else ()
-			   | _ => ())
-		   in
-		      Error.bug "no Exn_setInitExtra primitive"
-		   end)
+	       fun find (name: Prim.Name.t): Var.t * Type.t * PrimExp.t =
+		  let
+		     val (var, ty) =
+			DynamicWind.withEscape
+			(fn escape =>
+			 let
+			    val _ =
+			       Exp.foreachPrimExp
+			       (body, fn (_, _, e) =>
+				case e of
+				   PrimApp {args, prim, targs, ...} =>
+				      if Prim.name prim = name 
+					 then escape (VarExp.var
+						      (Vector.sub (args, 0)),
+						      Vector.sub (targs, 0))
+				      else ()
+				 | _ => ())
+			 in
+			    Error.bug
+			    (concat ["can't find ", Prim.Name.toString name])
+			 end)
+		     val (ty, exp) =
+			DynamicWind.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 ["can't find ", Var.toString var])
+			 end)
+		  in
+		     (var, ty, exp)
+		  end
+	       val (initExtraVar, initExtraType, initExtraExp) =
+		  find Prim.Name.Exn_setInitExtra
+	       val extraType = initExtraType
+	       val (extendExtraVar, extendExtraType, extendExtraExp) =
+		  find Prim.Name.Exn_setExtendExtra
 	       local
 		  open Type
 	       in
-		  val initExtraType = arrow (unit, extraType)
 		  val exnCon = Con.newNoname ()
 		  val exnConArgType = tuple (Vector.new2 (extraType, sumType))
-		  val seType = tuple (Vector.new2 (string, exn))
-		  val seuType = arrow (seType, unit)
+		  val seType = tuple (Vector.new2 (string, extraType))
 	       end
-	       val extraLambda =
-		  DynamicWind.withEscape
-		  (fn escape =>
-		   let
-		      val _ =
-			 Exp.foreachPrimExp
-			 (body, fn (x, e) =>
-			  if Var.equals (x, extraVar)
-			     then escape e
-			  else ())
-		   in
-		      Error.bug "couldn't find extraLambda"
-		   end)
-	       fun dropLambda x = Var.equals (x, extraVar)
-	       val initExtra = Var.newNoname ()
 	       fun wrapBody body =
-		   let
-		      val body =
-			 Dexp.let1
-			 {var = setRaiseVar,
-			  exp = (Dexp.reff
-				 (Dexp.lambda
-				  {arg = Var.newNoname (),
-				   argType = seType,
-				   bodyType = Type.unit,
-				   body = Dexp.unit ()})),
-			  body = body}
-		   in Exp.prefix (Dexp.toExp body,
-				  Dec.MonoVal {var = initExtra,
-					       ty = initExtraType,
-					       exp = extraLambda})
-		   end
-	       fun inject (e: Dexp.t): Dexp.t =
+		  Exp.prefix
+		  (Exp.prefix (Dexp.toExp body,
+			       Dec.MonoVal {var = initExtraVar,
+					    ty = initExtraType,
+					    exp = initExtraExp}),
+		   Dec.MonoVal {var = extendExtraVar,
+				ty = extendExtraType,
+				exp = extendExtraExp})
+	       fun makeExn {exn, extra} =
 		  let
 		     open Dexp
-		     val extra =
-			app {func = monoVar (initExtra, initExtraType),
-			     arg = unit (),
-			     ty = extraType}
 		  in
 		     conApp
 		     {con = exnCon,
 		      targs = Vector.new0 (),
 		      ty = Type.exn,
-		      arg = SOME (tuple
-				  {exps = Vector.new2 (extra, e),
-				   ty = exnConArgType})}
+		      arg = SOME (tuple {exps = Vector.new2 (extra, exn),
+					 ty = exnConArgType})}
 		  end
+	       fun inject (exn: Dexp.t): Dexp.t =
+		  makeExn {exn = exn,
+			   extra = Dexp.monoVar (initExtraVar, initExtraType)}
 	       fun extractSum x =
 		  Dexp.select {tuple = x, offset = 1, ty = sumType}
 	       fun extract (exn: Var.t, ty, f: Dexp.t -> Dexp.t): Dexp.t =
@@ -149,7 +142,15 @@
 					 arg = SOME (tuple, exnConArgType)},
 				  f (monoVar (tuple, exnConArgType))))}
 		  end
-	       fun raisee {var = x, ty, exn, filePos} =
+	       fun extra (x: Var.t) =
+		  extract (x, extraType, fn tuple =>
+			   Dexp.select {tuple = tuple,
+					offset = 0,
+					ty = extraType})
+	       fun raisee {exn: VarExp.t,
+			   filePos: string,
+			   ty: Type.t,
+			   var = x : Var.t} =
 		  let
 		     val exn = VarExp.var exn
 		     open Dexp
@@ -157,41 +158,43 @@
 		     vall
 		     {var = x,
 		      exp = 
-		      sequence
-		      (Vector.new2
-		       (app {func = deref (monoVar (setRaiseVar,
-						    Type.reff seuType)),
-			     arg = tuple {exps = (Vector.new2
-						  (string filePos,
-						   monoVar (exn, Type.exn))),
-					  ty = seType},
-			     ty = Type.unit},
-			raisee ({exn = monoVar (exn, Type.exn),
-				 filePos = filePos},
-				ty)))}
+		      extract
+		      (exn, ty, fn tup =>
+		       raisee
+		       ({exn =
+			 makeExn
+			 {exn = select {tuple = tup,
+					offset = 1,
+					ty = sumType},
+			  extra =
+			  app {func = monoVar (extendExtraVar, extendExtraType),
+			       arg = tuple {exps = (Vector.new2
+						    (string filePos,
+						     select {tuple = tup,
+							     offset = 0,
+							     ty = extraType})),
+					    ty = seType},
+			       ty = extraType}},
+			 filePos = filePos},
+			ty))}
 		  end
 	       val extraDatatypes =
 		  Vector.new1 {tycon = Tycon.exn,
 			       tyvars = Vector.new0 (),
 			       cons = Vector.new1 {con = exnCon,
 						   arg = SOME exnConArgType}}
-	       fun extra (x: Var.t) =
-		  extract (x, extraType, fn tuple =>
-			   Dexp.select {tuple = tuple,
-					offset = 0,
-					ty = extraType})
-	       fun setRaise assign =
-		  assign (setRaiseVar, seuType)
+	       fun dropVar x =
+		  Var.equals (x, initExtraVar)
+		  orelse Var.equals (x, extendExtraVar)
 	    in
 	       {
-		dropLambda = dropLambda,
+		dropVar = dropVar,
 		extra = extra,
 		extraDatatypes = extraDatatypes,
 		extract = extract,
 		extractSum = extractSum,
 		inject = inject,
 		raisee = raisee,
-		setRaise = setRaise,
 		sumTycon = sumTycon,
 		sumType = sumType,
 		wrapBody = wrapBody
@@ -277,15 +280,16 @@
 	       end
 	  | _ => Error.bug "implement exceptions saw unexpected dec"
       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
 	    fun makeExp e = Dexp.vall {var = var, exp = e}
-	 in case exp of
-	    Lambda l =>
-	       if dropLambda var
-		  then []
-	       else primExp (Lambda (loopLambda l))
+	 in
+	    case exp of
+	    Lambda l => primExp (Lambda (loopLambda l))
 	  | PrimApp {prim, targs, args} =>
 	       let
 		  datatype z = datatype Prim.Name.t
@@ -302,8 +306,8 @@
 		   | Exn_name =>
 			primExp (App {func = VarExp.mono exnName,
 				      arg = Vector.sub (args, 0)})
+		   | Exn_setExtendExtra => []
 		   | Exn_setInitExtra => []
-		   | Exn_setRaise => setRaise assign
 		   | Exn_setTopLevelHandler =>
 			assign (topLevelHandler,
 				Type.arrow (Type.exn, Type.unit))



1.9       +5 -5      mlton/mlton/xml/xml-tree.fun

Index: xml-tree.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/xml/xml-tree.fun,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- xml-tree.fun	10 Apr 2002 07:02:21 -0000	1.8
+++ xml-tree.fun	25 Aug 2002 22:23:58 -0000	1.9
@@ -326,7 +326,7 @@
       (*------------------------------------*)
       fun foreach {exp: t,
 		   handleExp: t -> unit,
-		   handlePrimExp: Var.t * PrimExp.t -> unit,
+		   handlePrimExp: Var.t * Type.t * PrimExp.t -> unit,
 		   handleBoundVar: Var.t * Tyvar.t vector * Type.t -> unit,
 		   handleVarExp: VarExp.t -> unit}: unit =
 	 let
@@ -338,8 +338,8 @@
 		  ; handleVarExp result
 		  ; handleExp e
 	       end
-	    and loopPrimExp (x: Var.t, e: PrimExp.t): unit =
-	       (handlePrimExp (x, e)
+	    and loopPrimExp (x: Var.t, ty: Type.t, e: PrimExp.t): unit =
+	       (handlePrimExp (x, ty, e)
 		; (case e of
 		      Const _ => ()
 		    | Var x => handleVarExp x
@@ -368,7 +368,7 @@
 	    and loopDec d =
 	       case d of
 		  MonoVal {var, ty, exp} =>
-		     (monoVar (var, ty); loopPrimExp (var, exp))
+		     (monoVar (var, ty); loopPrimExp (var, ty, exp))
 		| PolyVal {var, tyvars, ty, exp} =>
 		     (handleBoundVar (var, tyvars, ty)
 		      ; loopExp exp)
@@ -416,7 +416,7 @@
       fun hasPrim (e, f) =
 	 DynamicWind.withEscape
 	 (fn escape =>
-	  (foreachPrimExp (e, fn (_, e) =>
+	  (foreachPrimExp (e, fn (_, _, e) =>
 			   case e of
 			      PrimApp {prim, ...} => if f prim then escape true
 						     else ()



1.5       +2 -2      mlton/mlton/xml/xml-tree.sig

Index: xml-tree.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/xml/xml-tree.sig,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- xml-tree.sig	10 Apr 2002 07:02:21 -0000	1.4
+++ xml-tree.sig	25 Aug 2002 22:23:58 -0000	1.5
@@ -145,13 +145,13 @@
 	    val foreach:
 	       {exp: t,
 		handleExp: t -> unit,
-		handlePrimExp: Var.t * PrimExp.t -> unit,
+		handlePrimExp: Var.t * Type.t * PrimExp.t -> unit,
 		handleBoundVar: Var.t * Tyvar.t vector * Type.t -> unit,
 		handleVarExp: VarExp.t -> unit} -> unit
 	    val foreachBoundVar:
 	       t * (Var.t * Tyvar.t vector * Type.t -> unit) -> unit
 	    val foreachExp: t * (t -> unit) -> unit
-	    val foreachPrimExp: t * (Var.t * PrimExp.t -> unit) -> unit
+	    val foreachPrimExp: t * (Var.t * Type.t * PrimExp.t -> unit) -> unit
 	    val foreachVarExp: t * (VarExp.t -> unit) -> unit
 	    val fromPrimExp: PrimExp.t * Type.t -> t
 	    val hasPrim: t * (Prim.t -> bool) -> bool



1.35      +7 -5      mlton/basis-library/misc/primitive.sml

Index: primitive.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/misc/primitive.sml,v
retrieving revision 1.34
retrieving revision 1.35
diff -u -r1.34 -r1.35
--- primitive.sml	7 Aug 2002 01:02:42 -0000	1.34
+++ primitive.sml	25 Aug 2002 22:23:58 -0000	1.35
@@ -174,16 +174,18 @@
 	     * allows the various passes like monomorphisation to translate
 	     * the types appropriately.
 	     *)
-	    type extra = string list ref
+	    type extra = string list
 
 	    val extra = fn x => _prim "Exn_extra": exn -> 'a; x
 	    val extra: exn -> extra = extra
 	    val name = _prim "Exn_name": exn -> string;
 	    val keepHistory = _build_const "Exn_keepHistory": bool;
-	    val setInitExtra =
-	       fn x => _prim "Exn_setInitExtra": (unit -> 'a) -> unit; x
-	    val setInitExtra: (unit -> extra) -> unit = setInitExtra
-	    val setRaise = _prim "Exn_setRaise": (string * exn -> unit) -> unit;
+	    val setExtendExtra =
+	       fn x => _prim "Exn_setExtendExtra": (string * 'a -> 'a) -> unit; x
+	    val setExtendExtra: (string * extra -> extra) -> unit =
+	       setExtendExtra
+	    val setInitExtra = fn x => _prim "Exn_setInitExtra": 'a -> unit; x
+	    val setInitExtra: extra -> unit = setInitExtra
 	    val setTopLevelHandler =
 	       _prim "Exn_setTopLevelHandler": (exn -> unit) -> unit;
 	 end



1.3       +3 -13     mlton/basis-library/mlton/exn.sml

Index: exn.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/mlton/exn.sml,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- exn.sml	26 Mar 2002 17:27:30 -0000	1.2
+++ exn.sml	25 Aug 2002 22:23:58 -0000	1.3
@@ -6,19 +6,9 @@
 
       val history: t -> string list =
 	 if keepHistory
-	    then (
-		  (* In setInitExtra f, f cannot contain any free variables,
-		   * since implement-exceptions will move it to the top of the
-		   * program.
-		   *)
-		  setInitExtra (fn () => (ref []): extra)
-		  ; setRaise (fn (s, e) =>
-			      let
-				 val r = extra e
-			      in
-				 r := s :: !r
-			      end)
-		  ; ! o extra)
+	    then (setInitExtra ([]: extra)
+		  ; setExtendExtra (op ::)
+		  ; extra)
 	 else fn _ => []
 
       local



1.1                  mlton/regression/exnHistory3.ok

Index: exnHistory3.ok
===================================================================
exnHistory3.sml:6.26
exnHistory3.sml:6.26
exnHistory3.sml:6.26
exnHistory3.sml:6.26
exnHistory3.sml:6.26
exnHistory3.sml:6.26
exnHistory3.sml:6.26
exnHistory3.sml:6.26
exnHistory3.sml:6.26
exnHistory3.sml:6.26
exnHistory3.sml:5.18
ZZZ
exnHistory3.sml:6.26
exnHistory3.sml:6.26
exnHistory3.sml:6.26
exnHistory3.sml:6.26
exnHistory3.sml:6.26
exnHistory3.sml:6.26
exnHistory3.sml:6.26
exnHistory3.sml:6.26
exnHistory3.sml:6.26
exnHistory3.sml:6.26
exnHistory3.sml:5.18



1.1                  mlton/regression/exnHistory3.sml

Index: exnHistory3.sml
===================================================================
exception FOO

fun f x =
   if x = 0
      then raise FOO
   else f (x - 1) handle Overflow => 13

val _ = (f 10; ()) handle e => (List.app (fn s => print (concat [s, "\n"]))
				(SMLofNJ.exnHistory e))
val _ = print "ZZZ\n"
val _ = (f 10; ()) handle e => (List.app (fn s => print (concat [s, "\n"]))
				(SMLofNJ.exnHistory e))





-------------------------------------------------------
This sf.net email is sponsored by: OSDN - Tired of that same old
cell phone?  Get a new here for FREE!
https://www.inphonic.com/r.asp?r=sourceforge1&refcode1=vs3390
_______________________________________________
MLton-devel mailing list
MLton-devel@lists.sourceforge.net
https://lists.sourceforge.net/lists/listinfo/mlton-devel