[MLton] cvs commit: bugfix: Bug with polymorphic exns
Stephen Weeks
sweeks@mlton.org
Wed, 26 Jan 2005 12:29:55 -0800
sweeks 05/01/26 12:29:51
Modified: doc changelog
mlton/defunctorize defunctorize.fun
mlton/elaborate decs.sig elaborate-core.fun type-env.fun
type-env.sig
Added: regression expansive-valbind.sml
Log:
MAIL bugfix: Bug with "polymorphic" exns
Fixed a front end bug that incorrectly disallowed expansive valbinds
that bind type variables (implicitly or explicitly, it doesn't matter)
when the type variable doesn't occur in the type of the value being
bound. For example, the following were incorrectly rejected.
val x = let exception E of 'a in () end
val 'a x = let exception E of 'a in () end
The elaborator had simply checked if the right-hand side was
expansive, and if so, and there were bound type variables, then it
reported an error. Now, it only reports an error if bound type
variables occur in the type of the right hand side.
I left the output of the elaborator unchanged. The conversion from
CoreML to Xml handles rearranging the type variable binding. For
example, it turns
val 'a x = let exception E of 'a in () end
into
val x = let
val 'a f = fn () => let exception E of 'a in () end
in
f[unit] ()
end
This effectively implements Matthew's suggestion to instantiate the
unused type variables with unit.
In making this change, I noticed and fixed a bug in unification of
flex records. I couldn't think of a program that would tickle it
though.
There are still some programs that are incorrectly rejected. For
example, although
val 'a f = let exception E of 'a in E end
should be rejected and is rejected,
val 'a _ = let exception E of 'a in E end
should be accepted, but is rejected. The reason it should be accepted
is that even though the bound type variable ('a) appears in the type
of the right-hand side ('a -> exn), it doesn't appear in the type of
any of the variables bound by the left-hand side. I think a simple
fix will get this too, but I wanted to go ahead and commit, since the
current fix passes all regressions, including a new one that tests
this stuff: expansive-valbind.sml.
Revision Changes Path
1.145 +4 -0 mlton/doc/changelog
Index: changelog
===================================================================
RCS file: /cvsroot/mlton/mlton/doc/changelog,v
retrieving revision 1.144
retrieving revision 1.145
diff -u -r1.144 -r1.145
--- changelog 22 Jan 2005 16:33:32 -0000 1.144
+++ changelog 26 Jan 2005 20:29:48 -0000 1.145
@@ -1,5 +1,9 @@
Here are the changes since version 20041109.
+* 2005-01-26
+ - Fixed a front end bug that incorrectly rejected expansive valbinds
+ with useless bound type variables.
+
* 2005-01-22
- Fixed x86 codegen bug which failed to account for the possibility that
a 64-bit move could interfere with itself (as simulated by 32-bit
1.30 +46 -2 mlton/mlton/defunctorize/defunctorize.fun
Index: defunctorize.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/defunctorize/defunctorize.fun,v
retrieving revision 1.29
retrieving revision 1.30
diff -u -r1.29 -r1.30
--- defunctorize.fun 14 Jan 2005 14:51:29 -0000 1.29
+++ defunctorize.fun 26 Jan 2005 20:29:49 -0000 1.30
@@ -707,12 +707,56 @@
region = r,
test = (e, NestedPat.ty p),
tyconCons = tyconCons}
+ val isExpansive = Cexp.isExpansive exp
val (exp, expType) = loopExp exp
val pat = loopPat pat
fun vd (x: Var.t) = valDec (tyvars, x, exp, expType, e)
in
- if Vector.isEmpty tyvars
- then patDec (pat, exp, patRegion, e, bodyType, true)
+ if Vector.isEmpty tyvars orelse isExpansive
+ then
+ let
+ val exp =
+ if Vector.isEmpty tyvars
+ then exp
+ else
+ let
+ val x = Var.newNoname ()
+ val thunk =
+ let
+ open Xexp
+ in
+ toExp
+ (lambda
+ {arg = Var.newNoname (),
+ argType = Xtype.unit,
+ body = exp,
+ bodyType = expType,
+ mayInline = true})
+ end
+ val thunkTy =
+ Xtype.arrow (Xtype.unit, expType)
+ val body =
+ Xexp.app
+ {arg = Xexp.unit (),
+ func =
+ Xexp.var
+ {targs = (Vector.map
+ (tyvars, fn _ =>
+ Xtype.unit)),
+ ty = thunkTy,
+ var = x},
+ ty = expType}
+ val decs =
+ [Xdec.PolyVal {exp = thunk,
+ ty = thunkTy,
+ tyvars = tyvars,
+ var = x}]
+ in
+ Xexp.lett {body = body, decs = decs}
+ end
+ in
+ patDec (pat, exp, patRegion, e, bodyType, true)
+ end
else
case NestedPat.node pat of
NestedPat.Wild => vd (Var.newNoname ())
1.5 +1 -0 mlton/mlton/elaborate/decs.sig
Index: decs.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/decs.sig,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- decs.sig 3 Mar 2004 18:35:43 -0000 1.4
+++ decs.sig 26 Jan 2005 20:29:49 -0000 1.5
@@ -22,6 +22,7 @@
val append: t * t -> t
val appends: t list -> t
val appendsV: t vector -> t
+ val cons: dec * t -> t
val empty: t
val fold: t * 'a * (dec * 'a -> 'a) -> 'a
val foreach: t * (dec -> unit) -> unit
1.139 +46 -53 mlton/mlton/elaborate/elaborate-core.fun
Index: elaborate-core.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-core.fun,v
retrieving revision 1.138
retrieving revision 1.139
diff -u -r1.138 -r1.139
--- elaborate-core.fun 14 Jan 2005 01:23:36 -0000 1.138
+++ elaborate-core.fun 26 Jan 2005 20:29:49 -0000 1.139
@@ -1321,10 +1321,13 @@
in
Control.error
(region,
- seq [str "unable to generalize ",
- seq (List.separate (Vector.toListMap (unable,
- Tyvar.layout),
- str ", "))],
+ seq [str (concat
+ ["can't bind type variable",
+ if Vector.length unable > 1 then "s" else "",
+ ": "]),
+ seq (List.separate
+ (Vector.toListMap (unable, Tyvar.layout),
+ str ", "))],
lay ())
end
fun useBeforeDef (c: Tycon.t) =
@@ -1344,7 +1347,7 @@
align [seq [str "type: ", Tycon.layout c],
lay ()])
end
- val _ = TypeEnv.tick {useBeforeDef = useBeforeDef}
+ val () = TypeEnv.tick {useBeforeDef = useBeforeDef}
val unify = fn (t, t', f) => unify (t, t', preError, f)
fun checkSchemes (v: (Var.t * Scheme.t) vector): unit =
if isTop
@@ -1486,7 +1489,7 @@
lay = lay,
resultType = resultType}
end))
- val {close, ...} = TypeEnv.close tyvars
+ val close = TypeEnv.close tyvars
val {markFunc, setBound, unmarkFunc} = recursiveFun ()
val fbs =
Vector.map
@@ -1747,7 +1750,10 @@
var = var}
end)
val {bound, schemes, unable} =
- close (Vector.map (decs, #ty))
+ close {expansives = Vector.new0 (),
+ varTypes = Vector.map (decs, fn {ty, ...} =>
+ {isExpansive = false,
+ ty = ty})}
val () = reportUnable unable
val _ = checkSchemes (Vector.zip
(Vector.map (decs, #var),
@@ -1814,7 +1820,7 @@
; Decs.empty)
| Adec.Val {tyvars, rvbs, vbs} =>
let
- val {close, dontClose} = TypeEnv.close tyvars
+ val close = TypeEnv.close tyvars
(* Must do all the es and rvbs before the ps because of
* scoping rules.
*)
@@ -1841,36 +1847,6 @@
pat = pat,
patRegion = Apat.region pat}
end)
- val close =
- case Vector.peek (vbs, Cexp.isExpansive o #exp) of
- NONE => close
- | SOME {expRegion, ...} =>
- let
- val _ =
- if Vector.isEmpty tyvars
- then ()
- else
- Control.error
- (expRegion,
- seq [str
- (concat
- ["can't bind type variable",
- if Vector.length tyvars > 1
- then "s"
- else "",
- ": "]),
- seq (Layout.separateRight
- (Vector.toListMap (tyvars, Tyvar.layout),
- ", "))],
- lay ())
- in
- fn tys =>
- (dontClose ()
- ; {bound = fn () => Vector.new0 (),
- schemes = (Vector.map
- (tys, Scheme.fromType)),
- unable = Vector.new0 ()})
- end
val {markFunc, setBound, unmarkFunc} = recursiveFun ()
val elaboratePat = elaboratePat ()
val rvbs =
@@ -1953,7 +1929,8 @@
val boundVars =
Vector.map
(Vector.concatV (Vector.map (rvbs, #bound)),
- fn x => (x, {isRebind = true}))
+ fn x => (x, {isExpansive = false,
+ isRebind = true}))
val rvbs =
Vector.map
(rvbs, fn {bound, lambda, var} =>
@@ -1987,36 +1964,52 @@
val boundVars =
Vector.concat
[boundVars,
- Vector.map
- (Vector.concatV (Vector.map (vbs, #bound)),
- fn x => (x, {isRebind = false}))]
+ Vector.concatV
+ (Vector.map
+ (vbs, fn {bound, exp, ...} =>
+ (Vector.map
+ (bound, fn z =>
+ (z, {isExpansive = Cexp.isExpansive exp,
+ isRebind = false})))))]
val {bound, schemes, unable} =
- close (Vector.map (boundVars, #3 o #1))
+ 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}))}
val () = reportUnable unable
- val _ = checkSchemes (Vector.zip
+ val () = checkSchemes (Vector.zip
(Vector.map (boundVars, #2 o #1),
schemes))
- val _ = setBound bound
- val _ =
+ val () = setBound bound
+ val () =
Vector.foreach2
- (boundVars, schemes, fn (((x, x', _), ir), scheme) =>
- Env.extendVar (E, x, x', scheme, ir))
+ (boundVars, schemes,
+ fn (((x, x', _), {isRebind, ...}), scheme) =>
+ Env.extendVar (E, x, x', scheme,
+ {isRebind = isRebind}))
val vbs =
Vector.map (vbs, fn {exp, lay, pat, patRegion, ...} =>
{exp = exp,
lay = lay,
pat = pat,
patRegion = patRegion})
- in
(* According to page 28 of the Definition, we should
* issue warnings for nonexhaustive valdecs only when it's
* not a top level dec. It seems harmless enough to go
* ahead and always issue them.
*)
- Decs.single (Cdec.Val {rvbs = rvbs,
- tyvars = bound,
- vbs = vbs,
- warnMatch = warnMatch ()})
+ in
+ Decs.single
+ (Cdec.Val {rvbs = rvbs,
+ tyvars = bound,
+ vbs = vbs,
+ warnMatch = warnMatch ()})
end
end) arg
and elabExp (arg: Aexp.t * Nest.t * string option): Cexp.t =
1.49 +137 -115 mlton/mlton/elaborate/type-env.fun
Index: type-env.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/type-env.fun,v
retrieving revision 1.48
retrieving revision 1.49
diff -u -r1.48 -r1.49
--- type-env.fun 14 Jan 2005 01:23:36 -0000 1.48
+++ type-env.fun 26 Jan 2005 20:29:49 -0000 1.49
@@ -875,6 +875,9 @@
()
end
+ val minTime =
+ Trace.trace2 ("minTime", layout, Time.layout, Unit.layout) minTime
+
datatype z = datatype UnifyResult.t
val traceUnify = Trace.trace2 ("unify", layout, layout, UnifyResult.layout)
@@ -1072,7 +1075,9 @@
let
fun yes () =
let
- val _ = Spine.unify (s, s')
+ val () = Spine.unify (s, s')
+ val () = minTime (outer, !time')
+ val () = minTime (outer', !time)
val fields =
List.fold
(fields, fields', fn ((f, t), ac) =>
@@ -1127,17 +1132,17 @@
| Unified =>
let
val res = Equality.unify (e, e')
- val _ =
+ val () =
case res of
NotUnifiable _ => ()
| Unified =>
let
- val _ = Set.union (s, s')
- val _ =
+ val () = Set.union (s, s')
+ val () =
if Time.<= (!time, !time')
then ()
else time := !time'
- val _ =
+ val () =
Set.:= (s, {equality = e,
plist = plist,
time = time,
@@ -1569,30 +1574,47 @@
fun close (ensure: Tyvar.t vector) =
let
+ val beforeGen = Time.now ()
+ val () = Time.tick {useBeforeDef = fn _ => Error.bug "close useBeforeDef"}
val genTime = Time.now ()
- val _ = Vector.foreach (ensure, fn a => ignore (tyvarTime a))
+ val () = Vector.foreach (ensure, fn a => ignore (tyvarTime a))
val savedCloses = !Type.newCloses
- val _ = Type.newCloses := []
- fun dontClose () =
- Type.newCloses := List.fold (!Type.newCloses, savedCloses, op ::)
- fun close tys =
- let
- val unable =
- Vector.keepAll (ensure, fn a =>
- not (Time.<= (genTime, !(tyvarTime a))))
- val flexes = ref []
- val tyvars = ref (Vector.toList ensure)
- (* Convert all the unknown types bound at this level into tyvars.
- * Convert all the FlexRecords bound at this level into
- * GenFlexRecords.
- *)
- val newCloses =
- List.fold
- (!Type.newCloses, savedCloses, fn (t as Type.T s, ac) =>
- let
- val {equality, plist, time, ty, ...} = Set.! s
- val _ =
- if true then () else
+ val () = Type.newCloses := []
+ in
+ Trace.trace
+ ("close",
+ 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)]
+ end,
+ Layout.ignore)
+ (fn {expansives, varTypes} =>
+ let
+ val () = Vector.foreach (expansives, fn t =>
+ Type.minTime (t, beforeGen))
+ val unable = Vector.keepAll (ensure, fn a =>
+ not (Time.<= (genTime, !(tyvarTime a))))
+ val flexes = ref []
+ val tyvars = ref (Vector.toList ensure)
+ (* Convert all the unknown types bound at this level into tyvars.
+ * Convert all the FlexRecords bound at this level into
+ * GenFlexRecords.
+ *)
+ val newCloses =
+ List.fold
+ (!Type.newCloses, savedCloses, fn (t as Type.T s, ac) =>
+ let
+ val {equality, plist, time, ty, ...} = Set.! s
+ val _ =
+ if true then () else
let
open Layout
in
@@ -1604,98 +1626,98 @@
Time.layout genTime],
Out.standard)
end
- in
- if not (Time.<= (genTime, !time))
- then t :: ac
- else
- case ty of
- Type.FlexRecord {fields, spine, ...} =>
+ in
+ if not (Time.<= (genTime, !time))
+ then t :: ac
+ else
+ case ty of
+ Type.FlexRecord {fields, spine, ...} =>
+ let
+ val extra =
+ Promise.lazy
+ (fn () =>
+ Spine.foldOverNew
+ (spine, fields, [], fn (f, ac) =>
+ {field = f,
+ tyvar = Tyvar.newNoname {equality = false}}
+ :: ac))
+ val gfr = {extra = extra,
+ fields = fields,
+ spine = spine}
+ val _ = List.push (flexes, gfr)
+ val _ =
+ Set.:=
+ (s, {equality = equality,
+ plist = plist,
+ time = time,
+ ty = Type.GenFlexRecord gfr})
+ in
+ ac
+ end
+ | Type.Unknown (Unknown.T {canGeneralize, ...}) =>
+ if not canGeneralize
+ then t :: ac
+ else
let
- val extra =
- Promise.lazy
- (fn () =>
- Spine.foldOverNew
- (spine, fields, [], fn (f, ac) =>
- {field = f,
- tyvar = Tyvar.newNoname {equality = false}}
- :: ac))
- val gfr = {extra = extra,
- fields = fields,
- spine = spine}
- val _ = List.push (flexes, gfr)
- val _ =
- Set.:=
- (s, {equality = equality,
- plist = plist,
- time = time,
- ty = Type.GenFlexRecord gfr})
+ val b =
+ case Equality.toBoolOpt equality of
+ NONE =>
+ let
+ val _ =
+ Equality.unify
+ (equality, Equality.falsee)
+ in
+ false
+ end
+ | SOME b => b
+ val a = Tyvar.newNoname {equality = b}
+ val _ = List.push (tyvars, a)
+ val _ =
+ Set.:= (s, {equality = equality,
+ plist = PropertyList.new (),
+ time = time,
+ ty = Type.Var a})
in
ac
end
- | Type.Unknown (Unknown.T {canGeneralize, ...}) =>
- if not canGeneralize
- then t :: ac
- else
- let
- val b =
- case Equality.toBoolOpt equality of
- NONE =>
- let
- val _ =
- Equality.unify
- (equality, Equality.falsee)
- in
- false
- end
- | SOME b => b
- val a = Tyvar.newNoname {equality = b}
- val _ = List.push (tyvars, a)
- val _ =
- Set.:= (s, {equality = equality,
- plist = PropertyList.new (),
- time = time,
- ty = Type.Var a})
- in
- ac
- end
- | _ => ac
- end)
- val _ = Type.newCloses := newCloses
- val flexes = !flexes
- val tyvars = !tyvars
- (* For all fields that were added to the generalized flex records,
- * add a type variable.
- *)
- fun bound () =
- Vector.fromList
- (List.fold
- (flexes, tyvars, fn ({extra, fields, spine}, ac) =>
- let
- val extra = extra ()
- in
- Spine.foldOverNew
- (spine, fields, ac, fn (f, ac) =>
- case List.peek (extra, fn {field, ...} =>
- Field.equals (f, field)) of
- NONE => Error.bug "GenFlex missing field"
- | SOME {tyvar, ...} => tyvar :: ac)
- end))
- val schemes =
- Vector.map
- (tys, fn ty =>
- Scheme.General {bound = bound,
- canGeneralize = true,
- flexes = flexes,
- tyvars = Vector.fromList tyvars,
- ty = ty})
- in
- {bound = bound,
- schemes = schemes,
- unable = unable}
- end
- in
- {close = close,
- dontClose = dontClose}
+ | _ => ac
+ end)
+ val _ = Type.newCloses := newCloses
+ val flexes = !flexes
+ val tyvars = !tyvars
+ (* For all fields that were added to the generalized flex records,
+ * add a type variable.
+ *)
+ fun bound () =
+ Vector.fromList
+ (List.fold
+ (flexes, tyvars, fn ({extra, fields, spine}, ac) =>
+ let
+ val extra = extra ()
+ in
+ Spine.foldOverNew
+ (spine, fields, ac, fn (f, ac) =>
+ case List.peek (extra, fn {field, ...} =>
+ Field.equals (f, field)) of
+ NONE => Error.bug "GenFlex missing field"
+ | SOME {tyvar, ...} => tyvar :: ac)
+ end))
+ val schemes =
+ Vector.map
+ (varTypes, fn {isExpansive, ty} =>
+ if isExpansive
+ then Scheme.Type ty
+ else Scheme.General {bound = bound,
+ canGeneralize = true,
+ flexes = flexes,
+ tyvars = Vector.fromList tyvars,
+ ty = ty})
+ in
+ {bound = bound,
+ schemes = schemes,
+ unable = unable}
+ end
+ )
end
structure Type =
1.26 +5 -11 mlton/mlton/elaborate/type-env.sig
Index: type-env.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/type-env.sig,v
retrieving revision 1.25
retrieving revision 1.26
diff -u -r1.25 -r1.26
--- type-env.sig 11 Dec 2004 06:26:13 -0000 1.25
+++ type-env.sig 26 Jan 2005 20:29:49 -0000 1.26
@@ -82,19 +82,13 @@
val ty: t -> Type.t
end
- (* close (e, t, ts, r) = {bound, scheme} close type
- * t with respect to environment e, including all the tyvars in ts
- * and ensuring than no tyvar in ts occurs free in e. bound returns
- * the vector of type variables in t that do not occur in e, which
- * isn't known until all flexible record fields are determined,
- * after unification is complete.
- *)
val close:
Tyvar.t vector
- -> {close: Type.t vector -> {bound: unit -> Tyvar.t vector,
- schemes: Scheme.t vector,
- unable: Tyvar.t vector},
- dontClose: unit -> unit}
+ -> {expansives: Type.t vector,
+ varTypes: {isExpansive: bool, ty: Type.t} vector}
+ -> {bound: unit -> Tyvar.t vector,
+ schemes: Scheme.t vector,
+ unable: Tyvar.t vector}
val generalize: Tyvar.t vector -> unit -> {unable: Tyvar.t vector}
val initAdmitsEquality: Tycon.t * Tycon.AdmitsEquality.t -> unit
val setOpaqueTyconExpansion: Tycon.t * (Type.t vector -> Type.t) -> unit
1.1 mlton/regression/expansive-valbind.sml
Index: expansive-valbind.sml
===================================================================
val f = fn x => x
and r = ref 13
val _ = (f 1; f true)
val () = r := !r + 1
val () = print (concat [Int.toString (!r), "\n"])
val () = r := !r + 1
val () = print (concat [Int.toString (!r), "\n"])
val x = let exception E of 'a in () end
val 'a x = let exception E of 'a in () end
val 'a id = fn x: 'a => x
and x = let exception E of 'a in () end
;