[MLton] cvs commit: where and sharing in signatures
Stephen Weeks
sweeks@mlton.org
Sat, 3 Jan 2004 21:40:09 -0800
sweeks 04/01/03 21:40:09
Modified: basis-library/io fast-imperative-io.fun imperative-io.fun
basis-library/libs/basis-2002/top-level basis.sig
mlton/elaborate elaborate-sigexp.fun interface.fun
interface.sig
regression modules.sml
Added: regression/fail modules.36.sml modules.37.sml modules.38.sml
modules.39.sml modules.40.sml modules.41.sml
Log:
MAIL where and sharing in signatures
Improved the implementation of flexible tycons, where clauses, and
sharing. MLton now enforces the side conditions (t \not \in T of B)
on rule 63 and (t_i \not \in T of B) on rule 78. This means that
signatures that in the past would have been accepted are now rejected.
I've added several regression tests to check for these failures. I
had to update a few places in the basis library that incorrectly used
where or sharing, mostly attempting to redefine rigid tycons.
The implementation is much cleaner than before, because where clauses
now explicitly associate the type structure with the flexible tycon
being defined. There was a slight trick to handle the mutual
recursion between the definition of flexible tycons and the TypeStr
functor, which I handled with an exn.
Revision Changes Path
1.10 +2 -14 mlton/basis-library/io/fast-imperative-io.fun
Index: fast-imperative-io.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/io/fast-imperative-io.fun,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- fast-imperative-io.fun 21 Nov 2003 21:47:53 -0000 1.9
+++ fast-imperative-io.fun 4 Jan 2004 05:40:08 -0000 1.10
@@ -16,20 +16,14 @@
FAST_IMPERATIVE_IO_EXTRA where type elem = S.StreamIO.elem
where type vector = S.StreamIO.vector
where type vector_slice = S.StreamIO.vector_slice
- where type StreamIO.elem = S.StreamIO.elem
- where type StreamIO.vector = S.StreamIO.vector
where type StreamIO.instream = S.StreamIO.instream
where type StreamIO.outstream = S.StreamIO.outstream
where type StreamIO.out_pos = S.StreamIO.out_pos
where type StreamIO.reader = S.StreamIO.reader
where type StreamIO.writer = S.StreamIO.writer
where type StreamIO.pos = S.StreamIO.pos
- where type BufferI.elem = S.BufferI.elem
- where type BufferI.vector = S.BufferI.vector
where type BufferI.inbuffer = S.BufferI.inbuffer
- where type BufferI.instream = S.BufferI.instream
- where type BufferI.reader = S.BufferI.reader
- where type BufferI.pos = S.BufferI.pos =
+ =
struct
open S
@@ -180,20 +174,14 @@
FAST_IMPERATIVE_IO_EXTRA_FILE where type elem = S.StreamIO.elem
where type vector = S.StreamIO.vector
where type vector_slice = S.StreamIO.vector_slice
- where type StreamIO.elem = S.StreamIO.elem
- where type StreamIO.vector = S.StreamIO.vector
where type StreamIO.instream = S.StreamIO.instream
where type StreamIO.outstream = S.StreamIO.outstream
where type StreamIO.out_pos = S.StreamIO.out_pos
where type StreamIO.reader = S.StreamIO.reader
where type StreamIO.writer = S.StreamIO.writer
where type StreamIO.pos = S.StreamIO.pos
- where type BufferI.elem = S.BufferI.elem
- where type BufferI.vector = S.BufferI.vector
where type BufferI.inbuffer = S.BufferI.inbuffer
- where type BufferI.instream = S.BufferI.instream
- where type BufferI.reader = S.BufferI.reader
- where type BufferI.pos = S.BufferI.pos =
+ =
struct
structure ImperativeIO = FastImperativeIOExtra(open S)
open ImperativeIO
1.11 +0 -6 mlton/basis-library/io/imperative-io.fun
Index: imperative-io.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/io/imperative-io.fun,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- imperative-io.fun 21 Nov 2003 21:47:53 -0000 1.10
+++ imperative-io.fun 4 Jan 2004 05:40:08 -0000 1.11
@@ -12,8 +12,6 @@
IMPERATIVE_IO_EXTRA where type elem = S.StreamIO.elem
where type vector = S.StreamIO.vector
where type vector_slice = S.StreamIO.vector_slice
- where type StreamIO.elem = S.StreamIO.elem
- where type StreamIO.vector = S.StreamIO.vector
where type StreamIO.instream = S.StreamIO.instream
where type StreamIO.outstream = S.StreamIO.outstream
where type StreamIO.out_pos = S.StreamIO.out_pos
@@ -108,8 +106,6 @@
(S: IMPERATIVE_IO_ARG) :>
IMPERATIVE_IO where type elem = S.StreamIO.elem
where type vector = S.StreamIO.vector
- where type StreamIO.elem = S.StreamIO.elem
- where type StreamIO.vector = S.StreamIO.vector
where type StreamIO.instream = S.StreamIO.instream
where type StreamIO.outstream = S.StreamIO.outstream
where type StreamIO.out_pos = S.StreamIO.out_pos
@@ -167,8 +163,6 @@
IMPERATIVE_IO_EXTRA_FILE where type elem = S.StreamIO.elem
where type vector = S.StreamIO.vector
where type vector_slice = S.StreamIO.vector_slice
- where type StreamIO.elem = S.StreamIO.elem
- where type StreamIO.vector = S.StreamIO.vector
where type StreamIO.instream = S.StreamIO.instream
where type StreamIO.outstream = S.StreamIO.outstream
where type StreamIO.out_pos = S.StreamIO.out_pos
1.32 +3 -7 mlton/basis-library/libs/basis-2002/top-level/basis.sig
Index: basis.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/libs/basis-2002/top-level/basis.sig,v
retrieving revision 1.31
retrieving revision 1.32
diff -u -r1.31 -r1.32
--- basis.sig 27 Dec 2003 07:59:06 -0000 1.31
+++ basis.sig 4 Jan 2004 05:40:08 -0000 1.32
@@ -328,8 +328,9 @@
sharing type Text.Substring.substring = Substring.substring
sharing type Text.CharVector.vector = CharVector.vector
sharing type Text.CharArray.array = CharArray.array
- sharing type TextIO.elem = char
- sharing type TextIO.vector = string
+(* redundant *)
+(* sharing type TextIO.elem = char *)
+(* sharing type TextIO.vector = string *)
sharing type TextPrimIO.array = CharArray.array
sharing type TextPrimIO.array_slice = CharArraySlice.slice
sharing type TextPrimIO.elem = Char.char
@@ -563,11 +564,9 @@
where type BinIO.outstream = BinIO.outstream
where type BinPrimIO.reader = BinPrimIO.reader
where type BinPrimIO.writer = BinPrimIO.writer
- where type Char.char = Char.char
where type FixedInt.int = FixedInt.int
where type Int8.int = Int8.int
where type Int16.int = Int16.int
- where type Int32.int = Int32.int
where type Int64.int = Int64.int
where type IntInf.int = IntInf.int
where type IO.buffer_mode = IO.buffer_mode
@@ -586,7 +585,6 @@
where type Posix.Process.pid = Posix.Process.pid
where type Posix.Signal.signal = Posix.Signal.signal
where type Real32.real = Real32.real
- where type Real64.real = Real64.real
where type Real64Array.array = Real64Array.array
where type Socket.dgram = Socket.dgram
where type ('a, 'b) Socket.sock = ('a, 'b) Socket.sock
@@ -609,12 +607,10 @@
where type 'a VectorSlice.slice = 'a VectorSlice.slice
where type Word8.word = Word8.word
where type Word16.word = Word16.word
- where type Word32.word = Word32.word
where type Word64.word = Word64.word
where type Word8Array.array = Word8Array.array
where type Word8ArraySlice.slice = Word8ArraySlice.slice
where type Word8ArraySlice.vector_slice = Word8ArraySlice.vector_slice
where type Word8Vector.vector = Word8Vector.vector
- where type Word8VectorSlice.vector = Word8VectorSlice.vector
where type 'a MLton.Thread.t = 'a MLton.Thread.t
1.11 +6 -3 mlton/mlton/elaborate/elaborate-sigexp.fun
Index: elaborate-sigexp.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-sigexp.fun,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- elaborate-sigexp.fun 18 Dec 2003 23:08:24 -0000 1.10
+++ elaborate-sigexp.fun 4 Jan 2004 05:40:08 -0000 1.11
@@ -328,6 +328,7 @@
Interface.copy (Env.lookupSigid (E, x))
| Sigexp.Where (sigexp, wheres) => (* rule 64 *)
let
+ val time = Interface.Time.tick ()
val I' = elaborateSigexp (sigexp, I)
val _ =
Interface.wheres
@@ -337,7 +338,8 @@
(longtycon,
TypeStr.def
(elaborateScheme (tyvars, ty, E, I),
- Kind.Arity (Vector.length tyvars)))))
+ Kind.Arity (Vector.length tyvars)))),
+ time)
in
I'
end) arg
@@ -405,6 +407,7 @@
| Spec.Sharing {equations, spec} =>
(* rule 78 and section G.3.3 *)
let
+ val time = Interface.Time.tick ()
val I' = elaborateSpec (spec, I)
fun share eqn =
case Equation.node eqn of
@@ -416,7 +419,7 @@
| s :: ss =>
(List.foreach
(ss, fn s' =>
- Interface.share (I', s, s'))
+ Interface.share (I', s, s', time))
; loop ss)
in
loop ss
@@ -427,7 +430,7 @@
| c :: cs =>
List.foreach
(cs, fn c' =>
- Interface.shareType (I', c, c'))
+ Interface.shareType (I', c, c', time))
val _ = List.foreach (equations, share)
in
I'
1.9 +458 -477 mlton/mlton/elaborate/interface.fun
Index: interface.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/interface.fun,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- interface.fun 19 Dec 2003 00:40:56 -0000 1.8
+++ interface.fun 4 Jan 2004 05:40:08 -0000 1.9
@@ -59,158 +59,88 @@
(* only needed for debugging *)
structure TyconId = IntUniqueId()
-
-structure FlexibleTycon =
+
+structure Defn =
struct
- structure TypeFcn =
- struct
- datatype t =
- Forced of EtypeStr.t
- | Fun
- | Tycon
+ type t = exn
+ end
- fun layout f =
- let
- open Layout
- in
- case f of
- Forced f => paren (seq [str "forced ", EtypeStr.layout f])
- | Fun => str "<flexible def>"
- | Tycon => str "<flexible tycon>"
- end
+structure Time:>
+ sig
+ type t
+
+ val < : t * t -> bool
+ val current: unit -> t
+ val layout: t -> Layout.t
+ val min: t * t -> t
+ val tick: unit -> t
+ end =
+ struct
+ type t = int
- fun layoutApp (f: t, v: (Layout.t * {isChar: bool,
- needsParen: bool}) vector) =
- let
- open Layout
- in
- (seq [paren (layout f), tuple (Vector.toListMap (v, #1))],
- {isChar = false, needsParen = true})
- end
+ val op < = Int.<
+
+ val layout = Int.layout
+
+ val min = Int.min
+
+ val currentTime: int ref = ref 0
+
+ fun current () = !currentTime
- val toEnv: t -> EtypeStr.t =
- fn Forced f => f
- | _ => Error.bug "impossible force of FlexibleTycon"
+ fun tick () =
+ let
+ val n = 1 + !currentTime
+ val _ = currentTime := n
+ in
+ n
end
-
+ end
+
+structure FlexibleTycon =
+ struct
datatype t = T of {admitsEquality: AdmitsEquality.t ref,
copy: copy,
+ creationTime: Time.t,
+ defn: exn ref,
hasCons: bool,
- id: TyconId.t,
- typeFcn: TypeFcn.t} Set.t
+ id: TyconId.t} Set.t
withtype copy = t option ref
- val equals = fn (T s, T s') => Set.equals (s, s')
-
fun dest (T s) = Set.value s
- fun setValue (T s, r) = Set.setValue (s, r)
+ local
+ fun make f = f o dest
+ in
+ val defn = ! o make #defn
+ end
fun admitsEquality t = #admitsEquality (dest t)
- fun isFlexible (T s) =
- case #typeFcn (Set.value s) of
- TypeFcn.Tycon => true
- | _ => false
+ val equals = fn (T s, T s') => Set.equals (s, s')
fun layout (T s) =
let
open Layout
- val {admitsEquality, hasCons, id, typeFcn, ...} = Set.value s
+ val {admitsEquality, creationTime, hasCons, id, ...} = Set.value s
in
record [("admitsEquality", AdmitsEquality.layout (!admitsEquality)),
+ ("creationTime", Time.layout creationTime),
("hasCons", Bool.layout hasCons),
- ("id", TyconId.layout id),
- ("typeFcn", TypeFcn.layout typeFcn)]
+ ("id", TyconId.layout id)]
end
- fun setTypeStr (T s, e: EtypeStr.t): unit =
- let
- val {admitsEquality, copy, id, hasCons, ...} = Set.value s
- in
- Set.setValue (s, {admitsEquality = admitsEquality,
- copy = copy,
- hasCons = hasCons,
- id = id,
- typeFcn = TypeFcn.Forced e})
- end
+ fun layoutApp (t, v) = (layout t, {isChar = false, needsParen = false})
- fun new {hasCons: bool, typeFcn: TypeFcn.t}: t =
+ val copies: copy list ref = ref []
+
+ fun new {defn: Defn.t, hasCons: bool}: t =
T (Set.singleton {admitsEquality = ref AdmitsEquality.Sometimes,
copy = ref NONE,
+ creationTime = Time.current (),
+ defn = ref defn,
hasCons = hasCons,
- id = TyconId.new (),
- typeFcn = typeFcn})
-
- fun make {hasCons} = new {hasCons = hasCons, typeFcn = TypeFcn.Tycon}
-
- val bogus = make {hasCons = false}
-
- fun toTypeFcn (T s) = #typeFcn (Set.value s)
-
- fun layoutApp (t, v) =
- TypeFcn.layoutApp (toTypeFcn t, v)
-
- val copies: copy list ref = ref []
-
- fun copy (T s): t =
- let
- val {admitsEquality = a, copy, hasCons, typeFcn, ...} = Set.value s
- in
- case !copy of
- NONE =>
- let
- val c = new {hasCons = hasCons,
- typeFcn = typeFcn}
- val _ = admitsEquality c := !a
- val _ = List.push (copies, copy)
- val _ = copy := SOME c
- in
- c
- end
- | SOME c => c
- end
-
- fun shareOK (T s, T s') =
- let
- val {admitsEquality = a, hasCons = h, id, typeFcn = f, ...} =
- Set.value s
- val {admitsEquality = a', hasCons = h', typeFcn = f', ...} =
- Set.value s'
- val _ = Set.union (s, s')
- val _ =
- Set.setValue
- (s, {admitsEquality = ref (AdmitsEquality.or (!a, !a')),
- copy = ref NONE,
- id = id,
- hasCons = h orelse h',
- typeFcn = TypeFcn.Tycon})
- in
- ()
- end
-
- fun share (f, z, f', z'): unit =
- let
- fun error (reg, lay) =
- let
- open Layout
- in
- Control.error
- (reg,
- seq [str "type ", lay (),
- str " is a definition and cannot be shared"],
- empty)
- end
- in
- case (toTypeFcn f, toTypeFcn f') of
- (TypeFcn.Fun, _) => error z
- | (_, TypeFcn.Fun) => error z'
- | (TypeFcn.Tycon, TypeFcn.Tycon) => shareOK (f, f')
- | _ => Error.bug "type sharing on Forced typeFcn"
- end
-
- fun toEnv (T s): EtypeStr.t =
- TypeFcn.toEnv (#typeFcn (Set.value s))
+ id = TyconId.new ()})
end
structure Tycon =
@@ -221,11 +151,14 @@
Flexible of FlexibleTycon.t
| Rigid of Etycon.t * Kind.t
- val tuple = Rigid (Etycon.tuple, Kind.Nary)
+ fun admitsEquality (t: t): AdmitsEquality.t ref =
+ case t of
+ Flexible f => FlexibleTycon.admitsEquality f
+ | Rigid (e, _) => Etycon.admitsEquality e
- val layout =
- fn Flexible c => FlexibleTycon.layout c
- | Rigid (c, _) => Etycon.layout c
+ val fromEnv: Etycon.t * Kind.t -> t = Rigid
+
+ val arrow = fromEnv (Etycon.arrow, Kind.Arity 2)
val equals =
fn (Flexible f, Flexible f') => FlexibleTycon.equals (f, f')
@@ -234,38 +167,16 @@
val exn = Rigid (Etycon.exn, Kind.Arity 0)
- fun admitsEquality (t: t): AdmitsEquality.t ref =
- case t of
- Flexible f => FlexibleTycon.admitsEquality f
- | Rigid (e, _) => Etycon.admitsEquality e
-
- val fromEnv: Etycon.t * Kind.t -> t = Rigid
+ val layout =
+ fn Flexible c => FlexibleTycon.layout c
+ | Rigid (c, _) => Etycon.layout c
fun layoutApp (t: t, v) =
case t of
Flexible f => FlexibleTycon.layoutApp (f, v)
| Rigid (c, _) => Etycon.layoutApp (c, v)
- val make = Flexible o FlexibleTycon.make
-
- fun copy (t: t): t =
- case t of
- Flexible c => Flexible(FlexibleTycon.copy c)
- | Rigid _ => t
-
- fun toEnv (t: t): EtypeStr.t =
- case t of
- Flexible c => FlexibleTycon.toEnv c
- | Rigid (c, k) => EtypeStr.tycon (c, k)
-
- val arrow = fromEnv (Etycon.arrow, Kind.Arity 2)
-
- val exn = fromEnv (Etycon.exn, Kind.Arity 0)
-
- fun toFlexible (c: t): FlexibleTycon.t option =
- case c of
- Flexible c => SOME c
- | Rigid _ => NONE
+ val tuple = Rigid (Etycon.tuple, Kind.Nary)
end
structure Type =
@@ -275,12 +186,11 @@
| Record of t Record.t
| Var of Tyvar.t
+ fun arrow (t1, t2) = Con (Tycon.arrow, Vector.new2 (t1, t2))
+
val bogus = Con (Tycon.exn, Vector.new0 ())
- val con = Con
- val record = Record
- val var = Var
- val exn = Con (Tycon.exn, Vector.new0 ())
+ val con = Con
fun deArrowOpt (t: t): (t * t) option =
case t of
@@ -294,7 +204,23 @@
case deArrowOpt t of
NONE => Error.bug "Type.deArrow"
| SOME z => z
-
+
+ fun deEta (t: t, tyvars: Tyvar.t vector): Tycon.t option =
+ case t of
+ Con (c, ts) =>
+ if Vector.length ts = Vector.length tyvars
+ andalso Vector.foralli (ts, fn (i, t) =>
+ case t of
+ Var a =>
+ Tyvar.equals
+ (a, Vector.sub (tyvars, i))
+ | _ => false)
+ then SOME c
+ else NONE
+ | _ => NONE
+
+ val exn = Con (Tycon.exn, Vector.new0 ())
+
fun hom (t, {con, record, var}) =
let
val rec loop =
@@ -334,27 +260,7 @@
val layout = #1 o loop
end
- fun toEnv t =
- hom (t, {con = fn (c, ts) => EtypeStr.apply (Tycon.toEnv c, ts),
- record = Etype.record,
- var = Etype.var})
-
- fun fromEnv (t: Etype.t): t =
- let
- fun con (c, ts) =
- Con (Tycon.fromEnv (c, Kind.Arity (Vector.length ts)), ts)
- in
- Etype.hom (t, {con = con,
- record = Record,
- var = Var})
- end
-
- fun copy (t: t): t =
- hom (t, {con = fn (c, ts) => Con (Tycon.copy c, ts),
- record = Record,
- var = Var})
-
- fun arrow (t1, t2) = Con (Tycon.arrow, Vector.new2 (t1, t2))
+ val record = Record
fun substitute (t: t, sub: (Tyvar.t * t) vector): t =
let
@@ -368,40 +274,16 @@
var = var})
end
- fun deEta (t: t, tyvars: Tyvar.t vector): Tycon.t option =
- case t of
- Con (c, ts) =>
- if Vector.length ts = Vector.length tyvars
- andalso Vector.foralli (ts, fn (i, t) =>
- case t of
- Var a =>
- Tyvar.equals
- (a, Vector.sub (tyvars, i))
- | _ => false)
- then SOME c
- else NONE
- | _ => NONE
+ val var = Var
end
structure Scheme = GenericScheme (structure Type = Type
structure Tyvar = Tyvar)
-
+
structure Scheme =
struct
open Scheme
-
- fun copy (T {tyvars, ty}): t =
- T {ty = Type.copy ty, tyvars = tyvars}
-
- fun dest (T {ty, tyvars}) = (tyvars, ty)
- fun make (tyvars, ty) = T {ty = ty, tyvars = tyvars}
-
- fun bogus () = T {ty = Type.bogus, tyvars = Vector.new0 ()}
-
- fun toEnv (Scheme.T {ty, tyvars}) =
- Escheme.make (tyvars, Type.toEnv ty)
-
fun admitsEquality (s: t): bool =
let
fun con (c, bs) =
@@ -419,12 +301,11 @@
var = fn _ => true})
end
- fun fromEnv (s: Escheme.t): t =
- let
- val (tyvars, ty) = Escheme.dest s
- in
- make (tyvars, Type.fromEnv ty)
- end
+ fun bogus () = T {ty = Type.bogus, tyvars = Vector.new0 ()}
+
+ fun dest (T {ty, tyvars}) = (tyvars, ty)
+
+ fun make (tyvars, ty) = T {ty = ty, tyvars = tyvars}
end
structure TypeStr = TypeStr (structure AdmitsEquality = AdmitsEquality
@@ -437,21 +318,232 @@
structure Type = Type
structure Tyvar = Tyvar)
-structure Cons =
+structure Cons = TypeStr.Cons
+
+structure Defn =
struct
- open TypeStr.Cons
+ open Defn
- fun copy (T v): t =
- T (Vector.map (v, fn {con, name, scheme} =>
+ datatype dest =
+ Realized of EtypeStr.t
+ | TypeStr of TypeStr.t
+ | Undefined
+
+ exception U of dest
+
+ val realized = U o Realized
+ val typeStr = U o TypeStr
+ val undefined = U Undefined
+
+ fun dest (d: t): dest =
+ case d of
+ U u => u
+ | _ => Error.bug "Defn.dest"
+ end
+
+fun copyCons (Cons.T v): Cons.t =
+ Cons.T (Vector.map (v, fn {con, name, scheme} =>
+ {con = con,
+ name = name,
+ scheme = copyScheme scheme}))
+and copyDefn (d: Defn.t): Defn.t =
+ let
+ open Defn
+ in
+ case dest d of
+ Realized _ => Error.bug "copyDefn"
+ | TypeStr s => Defn.typeStr (copyTypeStr s)
+ | Undefined => Defn.undefined
+ end
+and copyFlexibleTycon (FlexibleTycon.T s): FlexibleTycon.t =
+ let
+ open FlexibleTycon
+ val {admitsEquality = a, copy, defn, hasCons, ...} = Set.value s
+ in
+ case !copy of
+ NONE =>
+ let
+ val c = new {defn = copyDefn (!defn), hasCons = hasCons}
+ val _ = admitsEquality c := !a
+ val _ = List.push (copies, copy)
+ val _ = copy := SOME c
+ in
+ c
+ end
+ | SOME c => c
+ end
+and copyTycon (t: Tycon.t): Tycon.t =
+ let
+ open Tycon
+ in
+ case t of
+ Flexible c => Flexible (copyFlexibleTycon c)
+ | Rigid _ => t
+ end
+and copyType (t: Type.t): Type.t =
+ let
+ open Type
+ in
+ hom (t, {con = fn (c, ts) => Con (copyTycon c, ts),
+ record = Record,
+ var = Var})
+ end
+and copyScheme (Scheme.T {tyvars, ty}): Scheme.t =
+ Scheme.T {ty = copyType ty, tyvars = tyvars}
+and copyTypeStr (s: TypeStr.t): TypeStr.t =
+ let
+ open TypeStr
+ val kind = kind s
+ in
+ case node s of
+ Datatype {cons, tycon} => data (copyTycon tycon, kind, copyCons cons)
+ | Scheme s => def (copyScheme s, kind)
+ | Tycon c => tycon (copyTycon c, kind)
+ end
+
+fun flexibleTyconToEnv (c: FlexibleTycon.t): EtypeStr.t =
+ let
+ open FlexibleTycon
+ in
+ case Defn.dest (defn c) of
+ Defn.Realized s => s
+ | Defn.TypeStr s => typeStrToEnv s
+ | _ => Error.bug "FlexiblTycon.toEnv"
+ end
+and tyconToEnv (t: Tycon.t): EtypeStr.t =
+ let
+ open Tycon
+ in
+ case t of
+ Flexible c => flexibleTyconToEnv c
+ | Rigid (c, k) => EtypeStr.tycon (c, k)
+ end
+and typeToEnv (t: Type.t): Etype.t =
+ Type.hom (t, {con = fn (c, ts) => EtypeStr.apply (tyconToEnv c, ts),
+ record = Etype.record,
+ var = Etype.var})
+and schemeToEnv (Scheme.T {ty, tyvars}): Escheme.t =
+ Escheme.make (tyvars, typeToEnv ty)
+and consToEnv (Cons.T v): Econs.t =
+ Econs.T (Vector.map (v, fn {con, name, scheme} =>
{con = con,
name = name,
- scheme = Scheme.copy scheme}))
+ scheme = schemeToEnv scheme}))
+and typeStrToEnv (s: TypeStr.t): EtypeStr.t =
+ let
+ val k = TypeStr.kind s
+ datatype z = datatype TypeStr.node
+ in
+ case TypeStr.node s of
+ Datatype {cons, tycon} =>
+ let
+ val tycon: Etycon.t =
+ case tycon of
+ Tycon.Flexible c =>
+ let
+ val typeStr = flexibleTyconToEnv c
+ in
+ case EtypeStr.node typeStr of
+ EtypeStr.Datatype {tycon, ...} => tycon
+ | EtypeStr.Tycon c => c
+ | _ =>
+ let
+ open Layout
+ in
+ Error.bug
+ (toString
+ (seq [str "datatype ",
+ TypeStr.layout s,
+ str " realized with scheme ",
+ EtypeStr.layout typeStr]))
+ end
+ end
+ | Tycon.Rigid (c, _) => c
+ in
+ EtypeStr.data (tycon, k, consToEnv cons)
+ end
+ | Scheme s => EtypeStr.def (schemeToEnv s, k)
+ | Tycon c => EtypeStr.abs (tyconToEnv c)
+ end
+
+structure FlexibleTycon =
+ struct
+ open FlexibleTycon
+
+ fun realize (T s, e: EtypeStr.t): unit =
+ let
+ val {defn, ...} = Set.value s
+ in
+ defn := Defn.realized e
+ end
+
+ val bogus = new {defn = Defn.undefined, hasCons = false}
+
+ fun share (T s, T s') =
+ let
+ val {admitsEquality = a, creationTime = t, hasCons = h, id, ...} =
+ Set.value s
+ val {admitsEquality = a', creationTime = t', hasCons = h', ...} =
+ Set.value s'
+ val _ = Set.union (s, s')
+ val _ =
+ Set.setValue
+ (s, {admitsEquality = ref (AdmitsEquality.or (!a, !a')),
+ copy = ref NONE,
+ creationTime = Time.min (t, t'),
+ defn = ref Defn.undefined,
+ hasCons = h orelse h',
+ id = id})
+ in
+ ()
+ end
+ end
+
+structure Tycon =
+ struct
+ open Tycon
- fun toEnv (T v): Econs.t =
- Econs.T (Vector.map (v, fn {con, name, scheme} =>
- {con = con,
- name = name,
- scheme = Scheme.toEnv scheme}))
+ fun make {hasCons} =
+ Flexible (FlexibleTycon.new {defn = Defn.undefined,
+ hasCons = hasCons})
+
+ val exn = fromEnv (Etycon.exn, Kind.Arity 0)
+ end
+
+structure Type =
+ struct
+ open Type
+
+ fun fromEnv (t: Etype.t): t =
+ let
+ fun con (c, ts) =
+ Con (Tycon.fromEnv (c, Kind.Arity (Vector.length ts)), ts)
+ in
+ Etype.hom (t, {con = con,
+ record = Record,
+ var = Var})
+ end
+ end
+
+structure Scheme =
+ struct
+ open Scheme
+
+ val copy = copyScheme
+
+ val toEnv = schemeToEnv
+
+ fun fromEnv (s: Escheme.t): t =
+ let
+ val (tyvars, ty) = Escheme.dest s
+ in
+ make (tyvars, Type.fromEnv ty)
+ end
+ end
+
+structure Cons =
+ struct
+ open TypeStr.Cons
fun fromEnv (Econs.T v): t =
T (Vector.map (v, fn {con, name, scheme} =>
@@ -472,62 +564,10 @@
structure Tycon = Tycon'
structure Type = Type'
- fun toFlexible (s: t): FlexibleTycon.t option =
- case node s of
- Datatype {tycon, ...} => Tycon.toFlexible tycon
- | Tycon c => Tycon.toFlexible c
- | _ => NONE
-
- fun copy (s: t): t =
- let
- val kind = kind s
- in
- case node s of
- Datatype {cons, tycon} => data (Tycon.copy tycon,
- kind,
- Cons.copy cons)
- | Scheme s => def (Scheme.copy s, kind)
- | Tycon c => tycon (Tycon.copy c, kind)
- end
-
- fun toEnv (s: t): EtypeStr.t =
- let
- val k = kind s
- in
- case node s of
- Datatype {cons, tycon} =>
- let
- val tycon: Etycon.t =
- case tycon of
- Tycon.Flexible c =>
- let
- val typeStr = FlexibleTycon.toEnv c
- in
- case EtypeStr.node typeStr of
- EtypeStr.Datatype {tycon, ...} => tycon
- | EtypeStr.Tycon c => c
- | _ =>
- let
- open Layout
- in
- Error.bug
- (toString
- (seq [str "datatype ",
- layout s,
- str " realized with scheme ",
- EtypeStr.layout typeStr]))
- end
- end
- | Tycon.Rigid (c, _) => c
- in
- EtypeStr.data (tycon, k, Cons.toEnv cons)
- end
- | Scheme s => EtypeStr.def (Scheme.toEnv s, k)
- | Tycon c => EtypeStr.abs (Tycon.toEnv c)
- end
-
- val toEnv = Trace.trace ("TypeStr.toEnv", layout, EtypeStr.layout) toEnv
+ val copy = copyTypeStr
+ val toEnv = typeStrToEnv
+
fun fromEnv (s: EtypeStr.t) =
let
val kind = EtypeStr.kind s
@@ -545,32 +585,49 @@
val fromEnv =
Trace.trace ("TypeStr.fromEnv", EtypeStr.layout, layout) fromEnv
- fun share (s: t, z, s': t, z'): unit =
+ fun getFlex (s: t, time, oper, (reg, lay)): FlexibleTycon.t option =
let
- fun getFlex (s: t, (reg, lay),
- continue: FlexibleTycon.t -> unit): unit =
+ fun error what =
let
- fun error what =
- let
- open Layout
- in
- Control.error
- (reg,
- seq [str "type ", lay (),
- str (concat [" is ", what,
- " and cannot be shared"])],
- empty)
- end
- fun get c =
- case c of
- Tycon.Flexible f => continue f
- | Tycon.Rigid _ => error "a toplevel type"
+ open Layout
+ val _ =
+ Control.error
+ (reg,
+ seq [str "type ", lay (),
+ str (concat [" is ", what, " and cannot be ", oper])],
+ empty)
in
- case node s of
- Datatype {tycon, ...} => get tycon
- | Scheme _ => error "a definition"
- | Tycon c => get c
+ NONE
end
+ fun loop (s: t): FlexibleTycon.t option =
+ case toTyconOpt s of
+ NONE => error "a definition"
+ | SOME c =>
+ case c of
+ Tycon.Flexible c =>
+ let
+ val {creationTime, defn, ...} =
+ FlexibleTycon.dest c
+ in
+ case Defn.dest (!defn) of
+ Defn.Realized _ =>
+ Error.bug "getFlex of realized"
+ | Defn.TypeStr s => loop s
+ | Defn.Undefined =>
+ if Time.< (creationTime, time)
+ then error "not local"
+ else SOME c
+ end
+ | Tycon.Rigid (c, _) =>
+ error (concat ["already defined as ",
+ Layout.toString (Etycon.layout c)])
+ in
+ loop s
+ end
+
+ fun share (s: t, z, s': t, z', time: Time.t): unit =
+ let
+ val oper = "shared"
val k = kind s
val k' = kind s'
in
@@ -591,9 +648,9 @@
empty)
end
else
- getFlex (s, z, fn c =>
- getFlex (s', z', fn c' =>
- FlexibleTycon.share (c, z, c', z')))
+ case (getFlex (s, time, oper, z), getFlex (s', time, oper, z')) of
+ (SOME f, SOME f') => FlexibleTycon.share (f, f')
+ | _ => ()
end
end
@@ -606,8 +663,7 @@
datatype t = T of {copy: copy,
elements: element list,
plist: PropertyList.t,
- shapeId: ShapeId.t,
- wheres: (FlexibleTycon.t * TypeStr.t) list ref} Set.t
+ shapeId: ShapeId.t} Set.t
and element =
Str of {interface: t,
name: Ast.Strid.t}
@@ -676,13 +732,9 @@
in
fun layout(T s) =
let
- val {elements, wheres, ...} = Set.value s
+ val {elements, ...} = Set.value s
in
- record[("elements", list (List.map (elements, layoutElement))),
- ("wheres", list (List.map (!wheres, fn (c, f) =>
- tuple [FlexibleTycon.layout c,
- TypeStr.layout f])))]
-
+ record [("elements", list (List.map (elements, layoutElement)))]
end
and layoutElement (e: element) =
let
@@ -705,8 +757,7 @@
T (Set.singleton {copy = ref NONE,
elements = elements,
plist = PropertyList.new (),
- shapeId = ShapeId.new (),
- wheres = ref []})
+ shapeId = ShapeId.new ()})
val empty = explicit []
@@ -735,14 +786,13 @@
fun (T s) + (T s') =
let
- val {elements = es, wheres = ws, ...} = Set.value s
- val {elements = es', wheres = ws', ...} = Set.value s'
+ val {elements = es, ...} = Set.value s
+ val {elements = es', ...} = Set.value s'
in
T (Set.singleton {copy = ref NONE,
elements = es @ es',
plist = PropertyList.new (),
- shapeId = ShapeId.new (),
- wheres = ref (!ws @ !ws')})
+ shapeId = ShapeId.new ()})
end
fun peekTyconElements (elements: element list, tycon): TypeStr.t option =
@@ -854,17 +904,18 @@
| _ => NONE
end
-fun shareType (I: t, c: Longtycon.t, c': Longtycon.t) =
+fun shareType (I: t, c: Longtycon.t, c': Longtycon.t, time) =
lookupLongtycon
(I, c, fn s =>
lookupLongtycon
(I, c', fn s' =>
TypeStr.share (s, (Longtycon.region c, fn () => Longtycon.layout c),
- s', (Longtycon.region c', fn () => Longtycon.layout c'))))
+ s', (Longtycon.region c', fn () => Longtycon.layout c'),
+ time)))
fun sameShape (m, m') = ShapeId.equals (shapeId m, shapeId m')
-fun share (I as T s, reg: Region.t, I' as T s', reg', strids): unit =
+fun share (I as T s, reg: Region.t, I' as T s', reg', strids, time): unit =
if Set.equals (s, s')
then ()
else
@@ -894,7 +945,8 @@
(Ast.Longtycon.long (rev strids, name))
in
TypeStr.share (s, (reg, lay),
- s', (reg', lay))
+ s', (reg', lay),
+ time)
end
| _ => ())
in
@@ -914,7 +966,7 @@
Str {name, interface = I} =>
(case peekStridElements (es', name) of
NONE => ()
- | SOME I' => share (I, reg, I', reg', name :: strids))
+ | SOME I' => share (I, reg, I', reg', name :: strids, time))
| Type {name, typeStr = s} =>
(case peekTyconElements (es',name) of
NONE => ()
@@ -924,137 +976,94 @@
Ast.Longtycon.layout
(Ast.Longtycon.long (rev strids, name))
in
- TypeStr.share (s, (reg, lay), s', (reg', lay))
+ TypeStr.share (s, (reg, lay), s', (reg', lay), time)
end)
| _ => ())
end
val share =
- fn (m, s: Longstrid.t, s': Longstrid.t) =>
+ fn (m, s: Longstrid.t, s': Longstrid.t, time) =>
share (lookupLongstrid (m, s),
Longstrid.region s,
lookupLongstrid (m, s'),
Longstrid.region s',
- [])
+ [],
+ time)
-structure TypeFcn = FlexibleTycon.TypeFcn
-
-fun wheres (I as T s, v: (Longtycon.t * TypeStr.t) vector): unit =
- let
- val {wheres, ...} = Set.value s
- in
- Vector.foreach
- (v, fn (c, s: TypeStr.t) =>
- let
- val reg = Longtycon.region c
- fun noRedefine () =
- let
- open Layout
- in
- Control.error (reg,
- seq [str "type ",
- Longtycon.layout c,
- str " cannot be redefined"],
- empty)
- end
- in
- lookupLongtycon
- (I, c, fn s' =>
- case TypeStr.toFlexible s' of
- NONE => noRedefine ()
- | SOME flex =>
- let
- val k = TypeStr.kind s
- val k' = TypeStr.kind s'
- in
- if not (Kind.equals (k, k'))
- then
- let
- open Layout
- in
- Control.error
- (reg,
- seq [str "type ",
- Longtycon.layout c,
- str " has arity ", Kind.layout k',
- str " and cannot be redefined to have arity ",
- Kind.layout k],
- empty)
- end
- else if (TypeStr.admitsEquality s' = AdmitsEquality.Sometimes
- andalso TypeStr.admitsEquality s = AdmitsEquality.Never)
- then
- let
- open Layout
- in
- Control.error
- (reg,
- seq [str "eqtype ",
- Longtycon.layout c,
- str " cannot be redefined as a non-equality type"],
- empty)
- end
- else
+fun wheres (I as T s, v: (Longtycon.t * TypeStr.t) vector, time): unit =
+ Vector.foreach
+ (v, fn (c, s: TypeStr.t) =>
+ let
+ val reg = Longtycon.region c
+ in
+ lookupLongtycon
+ (I, c, fn s' =>
+ case TypeStr.getFlex (s', time, "redefined",
+ (reg, fn () => Longtycon.layout c)) of
+ NONE => ()
+ | SOME flex =>
+ let
+ val k = TypeStr.kind s
+ val k' = TypeStr.kind s'
+ in
+ if not (Kind.equals (k, k'))
+ then
let
- val {admitsEquality, copy, hasCons, id, typeFcn} =
- FlexibleTycon.dest flex
+ open Layout
in
- if hasCons andalso (case TypeStr.node s of
- TypeStr.Scheme _ => true
- | _ => false)
- then
- let
- open Layout
- in
- Control.error
- (reg,
- seq [str "type ",
- Longtycon.layout c,
- str " is a datatype and cannot be redefined as a complex type"],
- empty)
- end
- else
- let
- datatype z = datatype TypeFcn.t
- in
- case typeFcn of
- Forced _ =>
- Error.bug "where type on forced flexible tycon"
- | Fun => noRedefine ()
- | Tycon =>
- let
- fun doWhere () =
- (List.push (wheres, (flex, s))
- ;
- FlexibleTycon.setValue
- (flex, {admitsEquality = admitsEquality,
- copy = copy,
- hasCons = hasCons,
- id = id,
- typeFcn = typeFcn}))
- fun doTycon c =
- case c of
- Tycon.Flexible flex' =>
- FlexibleTycon.shareOK (flex, flex')
- | Tycon.Rigid (c, _) => doWhere ()
- in
- case TypeStr.node s of
- TypeStr.Datatype {tycon, ...} =>
- doTycon tycon
- | TypeStr.Scheme _ => doWhere ()
- | TypeStr.Tycon c => doTycon c
- end
- end
+ Control.error
+ (reg,
+ seq [str "type ",
+ Longtycon.layout c,
+ str " has arity ", Kind.layout k',
+ str " and cannot be redefined to have arity ",
+ Kind.layout k],
+ empty)
end
- end)
- end)
- end
+ else if (TypeStr.admitsEquality s' = AdmitsEquality.Sometimes
+ andalso TypeStr.admitsEquality s = AdmitsEquality.Never)
+ then
+ let
+ open Layout
+ in
+ Control.error
+ (reg,
+ seq [str "eqtype ",
+ Longtycon.layout c,
+ str " cannot be redefined as a non-equality type"],
+ empty)
+ end
+ else
+ let
+ val {admitsEquality, defn, hasCons, ...} =
+ FlexibleTycon.dest flex
+ in
+ if hasCons andalso (case TypeStr.node s of
+ TypeStr.Scheme _ => true
+ | _ => false)
+ then
+ let
+ open Layout
+ in
+ Control.error
+ (reg,
+ seq [str "type ",
+ Longtycon.layout c,
+ str " is a datatype and cannot be redefined as a complex type"],
+ empty)
+ end
+ else
+ defn := Defn.typeStr s
+ end
+ end)
+ end)
val wheres =
- Trace.trace2 ("Interface.wheres",
+ Trace.trace3 ("Interface.wheres",
layout,
Vector.layout (Layout.tuple2 (Longtycon.layout,
TypeStr.layout)),
+ Time.layout,
Unit.layout)
wheres
@@ -1066,26 +1075,11 @@
val copies: copy list ref = ref []
fun loop (T s, strids: Ast.Strid.t list): t =
let
- val {copy, shapeId, elements, wheres, ...} = Set.value s
+ val {copy, shapeId, elements, ...} = Set.value s
in
case !copy of
NONE =>
let
- val wheres =
- List.map
- (!wheres, fn (c, s) =>
- let
- val c = FlexibleTycon.copy c
- val s = TypeStr.copy s
- val _ =
- if isSome getTypeFcnOpt
- then
- FlexibleTycon.setTypeStr
- (c, TypeStr.toEnv s)
- else ()
- in
- (c, s)
- end)
val elements =
List.map
(elements, fn e =>
@@ -1098,32 +1092,20 @@
getTypeFcnOpt) of
(SOME (Tycon.Flexible c), SOME f) =>
let
- fun get () =
- f
- (Longtycon.long (strids, name),
- ! (FlexibleTycon.admitsEquality
- c),
- TypeStr.kind typeStr)
- fun doit (s: EtypeStr.t): unit =
- FlexibleTycon.setTypeStr (c, s)
+ val FlexibleTycon.T s = c
+ val {admitsEquality, defn, ...} =
+ Set.value s
in
- case FlexibleTycon.toTypeFcn c of
- TypeFcn.Fun => ()
- | TypeFcn.Tycon => doit (get ())
- | TypeFcn.Forced s =>
- let
- val s' = get ()
- in
- case (EtypeStr.node s,
- EtypeStr.node s') of
- (EtypeStr.Tycon c,
- EtypeStr.Datatype
- {tycon = c', ...}) =>
- if Etycon.equals (c, c')
- then doit s'
- else ()
- | _ => ()
- end
+ case Defn.dest (!defn) of
+ Defn.Realized _ => ()
+ | Defn.TypeStr _ => ()
+ | Defn.Undefined =>
+ FlexibleTycon.realize
+ (c,
+ f
+ (Longtycon.long (strids, name),
+ !admitsEquality,
+ TypeStr.kind typeStr))
end
| _ => ()
in
@@ -1147,8 +1129,7 @@
val I = T (Set.singleton {copy = ref NONE,
elements = elements,
plist = PropertyList.new (),
- shapeId = shapeId,
- wheres = ref wheres})
+ shapeId = shapeId})
val _ = List.push (copies, copy)
val _ = copy := SOME I
in
1.7 +11 -4 mlton/mlton/elaborate/interface.sig
Index: interface.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/interface.sig,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- interface.sig 18 Dec 2003 22:10:40 -0000 1.6
+++ interface.sig 4 Jan 2004 05:40:08 -0000 1.7
@@ -79,7 +79,14 @@
sharing TypeStr.Tycon = Tycon
sharing TypeStr.Type = Type
sharing TypeStr.Tyvar = EnvTypeStr.Tyvar = Tyvar
-
+
+ structure Time:
+ sig
+ type t
+
+ val tick: unit -> t
+ end
+
type t
val + : t * t -> t
@@ -108,12 +115,12 @@
* TypeStr.Kind.t -> EnvTypeStr.t) -> t
val reportDuplicates: t * Region.t -> unit
val shapeId: t -> ShapeId.t
- val share: t * Ast.Longstrid.t * Ast.Longstrid.t -> unit
- val shareType: t * Ast.Longtycon.t * Ast.Longtycon.t -> unit
+ val share: t * Ast.Longstrid.t * Ast.Longstrid.t * Time.t -> unit
+ val shareType: t * Ast.Longtycon.t * Ast.Longtycon.t * Time.t -> unit
val strs: {name: Ast.Strid.t, interface: t} vector -> t
val types: {name: Ast.Tycon.t, typeStr: TypeStr.t} vector -> t
val vals: {name: Ast.Vid.t,
scheme: Scheme.t,
status: Status.t} vector -> t
- val wheres: t * (Ast.Longtycon.t * TypeStr.t) vector -> unit
+ val wheres: t * (Ast.Longtycon.t * TypeStr.t) vector * Time.t -> unit
end
1.2 +11 -0 mlton/regression/modules.sml
Index: modules.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/regression/modules.sml,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- modules.sml 18 Dec 2003 20:36:01 -0000 1.1
+++ modules.sml 4 Jan 2004 05:40:09 -0000 1.2
@@ -277,3 +277,14 @@
type t = S.t
end
val _: T.t -> S.t = fn x => x
+
+signature SIG =
+ sig
+ type u
+ type v = u
+ end where type v = int
+structure S: SIG =
+ struct
+ type u = int
+ type v = int
+ end
1.1 mlton/regression/fail/modules.36.sml
Index: modules.36.sml
===================================================================
signature SIG =
sig
include sig type t end where type t = int
end where type t = bool
1.1 mlton/regression/fail/modules.37.sml
Index: modules.37.sml
===================================================================
signature SIG =
sig
structure S: sig type t end where type t = int
end where type S.t = bool
1.1 mlton/regression/fail/modules.38.sml
Index: modules.38.sml
===================================================================
structure S:
sig
type t
end where type t = int * int
=
struct
type t = int
end
1.1 mlton/regression/fail/modules.39.sml
Index: modules.39.sml
===================================================================
signature SIG =
sig
type u
type v = u
end where type v = int
structure S: SIG =
struct
type u = real
type v = real
end
1.1 mlton/regression/fail/modules.40.sml
Index: modules.40.sml
===================================================================
signature SIG =
sig
type t
structure S:
sig
type u = t
type v
sharing type u = v
end
end
1.1 mlton/regression/fail/modules.41.sml
Index: modules.41.sml
===================================================================
signature SIG =
sig
type t
structure S: sig type u = t end where type u = t * t
end