[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