[MLton] cvs commit: bugfix: Bug with polymorphic exns
Stephen Weeks
sweeks@mlton.org
Wed, 26 Jan 2005 15:57:29 -0800
sweeks 05/01/26 15:57:26
Modified: mlton/defunctorize defunctorize.fun
mlton/elaborate elaborate-core.fun type-env.fun type-env.sig
mlton/match-compile nested-pat.fun
regression expansive-valbind.sml
Log:
MAIL bugfix: Bug with "polymorphic" exns
Fixed the last known bug in the front end's handling of expansive
valbinds that bind type variables. Now, the following is correctly
accepted.
val 'a _ = let exception E of 'a in E end
And so is the following.
val 'a (f: int -> int, _) = (fn x => x, let exception E of 'a in E end);
Please stress test and report any bugs.
Revision Changes Path
1.31 +10 -5 mlton/mlton/defunctorize/defunctorize.fun
Index: defunctorize.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/defunctorize/defunctorize.fun,v
retrieving revision 1.30
retrieving revision 1.31
diff -u -r1.30 -r1.31
--- defunctorize.fun 26 Jan 2005 20:29:49 -0000 1.30
+++ defunctorize.fun 26 Jan 2005 23:57:25 -0000 1.31
@@ -715,9 +715,9 @@
if Vector.isEmpty tyvars orelse isExpansive
then
let
- val exp =
+ val (pat, exp) =
if Vector.isEmpty tyvars
- then exp
+ then (pat, exp)
else
let
val x = Var.newNoname ()
@@ -735,6 +735,10 @@
end
val thunkTy =
Xtype.arrow (Xtype.unit, expType)
+ fun subst t =
+ Xtype.substitute
+ (t, Vector.map (tyvars, fn a =>
+ (a, Xtype.unit)))
val body =
Xexp.app
{arg = Xexp.unit (),
@@ -743,16 +747,17 @@
{targs = (Vector.map
(tyvars, fn _ =>
Xtype.unit)),
- ty = thunkTy,
+ ty = subst thunkTy,
var = x},
- ty = expType}
+ ty = subst expType}
val decs =
[Xdec.PolyVal {exp = thunk,
ty = thunkTy,
tyvars = tyvars,
var = x}]
in
- Xexp.lett {body = body, decs = decs}
+ (NestedPat.replaceTypes (pat, subst),
+ Xexp.lett {body = body, decs = decs})
end
in
patDec (pat, exp, patRegion, e, bodyType, true)
1.140 +6 -13 mlton/mlton/elaborate/elaborate-core.fun
Index: elaborate-core.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-core.fun,v
retrieving revision 1.139
retrieving revision 1.140
diff -u -r1.139 -r1.140
--- elaborate-core.fun 26 Jan 2005 20:29:49 -0000 1.139
+++ elaborate-core.fun 26 Jan 2005 23:57:25 -0000 1.140
@@ -1750,10 +1750,9 @@
var = var}
end)
val {bound, schemes, unable} =
- close {expansives = Vector.new0 (),
- varTypes = Vector.map (decs, fn {ty, ...} =>
- {isExpansive = false,
- ty = ty})}
+ close (Vector.map (decs, fn {ty, ...} =>
+ {isExpansive = false,
+ ty = ty}))
val () = reportUnable unable
val _ = checkSchemes (Vector.zip
(Vector.map (decs, #var),
@@ -1973,15 +1972,9 @@
isRebind = false})))))]
val {bound, schemes, unable} =
close
- {expansives = (Vector.keepAllMap
- (vbs, fn {exp, ...} =>
- if Cexp.isExpansive exp
- then SOME (Cexp.ty exp)
- else NONE)),
- varTypes = (Vector.map
- (boundVars,
- fn ((_, _, ty), {isExpansive, ...}) =>
- {isExpansive = isExpansive, ty = ty}))}
+ (Vector.map
+ (boundVars, fn ((_, _, ty), {isExpansive, ...}) =>
+ {isExpansive = isExpansive, ty = ty}))
val () = reportUnable unable
val () = checkSchemes (Vector.zip
(Vector.map (boundVars, #2 o #1),
1.50 +11 -11 mlton/mlton/elaborate/type-env.fun
Index: type-env.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/type-env.fun,v
retrieving revision 1.49
retrieving revision 1.50
diff -u -r1.49 -r1.50
--- type-env.fun 26 Jan 2005 20:29:49 -0000 1.49
+++ type-env.fun 26 Jan 2005 23:57:25 -0000 1.50
@@ -1586,20 +1586,20 @@
let
open Layout
in
- fn {expansives, varTypes} =>
- record [("expansives", Vector.layout Type.layout expansives),
- ("varTypes",
- Vector.layout
- (fn {isExpansive, ty} =>
- Layout.record [("isExpansive", Bool.layout isExpansive),
- ("ty", Type.layout ty)])
- varTypes)]
+ Vector.layout
+ (fn {isExpansive, ty} =>
+ Layout.record [("isExpansive", Bool.layout isExpansive),
+ ("ty", Type.layout ty)])
end,
Layout.ignore)
- (fn {expansives, varTypes} =>
+ (fn varTypes =>
let
- val () = Vector.foreach (expansives, fn t =>
- Type.minTime (t, beforeGen))
+ val () =
+ Vector.foreach
+ (varTypes, fn {isExpansive, ty} =>
+ if isExpansive
+ then Type.minTime (ty, beforeGen)
+ else ())
val unable = Vector.keepAll (ensure, fn a =>
not (Time.<= (genTime, !(tyvarTime a))))
val flexes = ref []
1.27 +1 -2 mlton/mlton/elaborate/type-env.sig
Index: type-env.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/type-env.sig,v
retrieving revision 1.26
retrieving revision 1.27
diff -u -r1.26 -r1.27
--- type-env.sig 26 Jan 2005 20:29:49 -0000 1.26
+++ type-env.sig 26 Jan 2005 23:57:25 -0000 1.27
@@ -84,8 +84,7 @@
val close:
Tyvar.t vector
- -> {expansives: Type.t vector,
- varTypes: {isExpansive: bool, ty: Type.t} vector}
+ -> {isExpansive: bool, ty: Type.t} vector
-> {bound: unit -> Tyvar.t vector,
schemes: Scheme.t vector,
unable: Tyvar.t vector}
1.5 +2 -2 mlton/mlton/match-compile/nested-pat.fun
Index: nested-pat.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/match-compile/nested-pat.fun,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- nested-pat.fun 23 Jul 2004 23:26:50 -0000 1.4
+++ nested-pat.fun 26 Jan 2005 23:57:25 -0000 1.5
@@ -141,8 +141,8 @@
| Const _ => pat
| Layered (x, p) => Layered (x, loop p)
| Tuple ps => Tuple (Vector.map (ps, loop))
- | Var x => Var x
- | Wild => Wild
+ | Var _ => pat
+ | Wild => pat
in
T {pat = pat, ty = f ty}
end
1.2 +4 -1 mlton/regression/expansive-valbind.sml
Index: expansive-valbind.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/regression/expansive-valbind.sml,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- expansive-valbind.sml 26 Jan 2005 20:29:50 -0000 1.1
+++ expansive-valbind.sml 26 Jan 2005 23:57:26 -0000 1.2
@@ -12,4 +12,7 @@
val 'a id = fn x: 'a => x
and x = let exception E of 'a in () end
-;
+
+val 'a _ = let exception E of 'a in E end
+
+val 'a (f: int -> int, _) = (fn x => x, let exception E of 'a in E end);