[MLton] cvs commit: new front end
sweeks@mlton.org
sweeks@mlton.org
Thu, 13 Nov 2003 19:48:19 -0800
sweeks 03/11/13 19:48:18
Modified: basis-library/libs/basis-2002/top-level basis.sig basis.sml
top-level.sml
mlton/ast admits-equality.fun admits-equality.sig
mlton/defunctorize defunctorize.fun
mlton/elaborate elaborate-core.fun elaborate-env.fun
elaborate-env.sig elaborate-sigexp.fun
elaborate.fun interface.fun interface.sig
type-env.fun type-env.sig type-str.fun type-str.sig
mlton/main compile.fun
Log:
The next phase in the new front end: opaque signature constraints.
This is implemented by building a dummy structure realized from the
signature, just as we would for a functor argument when type checking
a functor. The dummy structure contains exactly the type information
that is in the signature, which is what opacity requires. We then
replace the variables (and constructors) in the dummy structure with
the corresponding variables (and constructors) from the actual
structure so that the translation to CoreML uses the right stuff. For
each tycon in the dummy structure, we keep track of the corresponding
type structure in the actual structure. This is used when producing
the CoreML types (see expandOpaque in type-env.{fun,sig})
Another way to look at things is that an opaque signature constraint
is equivalent to viewing the rest of the program as a functor
parameterized by a structure matching the signature being matched
opaquely.
The most annoying bit about all of this was getting the opacity of the
basis library right. There were several problems. The first stems
from free types in signatures. For example, in BYTE we have
signature BYTE =
sig
...
val unpackString: Word8ArraySlice.slice -> string
end
Here, Word8ArraySlice.slice is a free type. Then, in BASIS_2002 we have
signature BASIS_2002 =
sig
...
structure Byte: BYTE
...
structure Word8ArraySlice: MONO_ARRAY_SLICE
end
The problem is that this signature establishes no connection between
the Word8ArraySlice.slice in Byte the slice Word8ArraySlice. And we
cannot use a sharing constraint to make them the same, since the
Word8ArraySlice.slice in BYTE is not flexible. So, we end up adding a
new where type to BASIS_2002
where type Word8ArraySlice.slice = Word8ArraySlice.slice
This is a bit annoying, because it exposes the type of
Word8ArraySlice.slice, which is probably some record type. To really
fix this, we need to add some opaque constraints earlier in the basis
library.
Another problem stems from the fact that we had the non-standard
structures (MLton, SMLofNJ, ...) outside of the opaque constraint on
Basis2002. This meant that types that they used (e.g. MLton.Signal.t)
were not known to be the same as the basis library types
(e.g. Posix.Signal.signal). One fix would be to add yet more where
constraints to BASIS_2002, but that would expose even more types. So,
I decided a better fix was to move the non-standard structures into
BASIS_2002 and Basis2002.
I am beginning to wonder if using the :> for Basis2002 is the right
approach. The problem is that this approach introduces lots of
potential bugs where we reject valid programs because two types are
not equal that should be, because we haven't added the appropriate
sharing or where. If instead we were to use :, then we might accept
some programs because two types are equal that shouldn't be. But that
seems more benign. And when we learn it, we can use a :> somewhere
earlier in the basis library code to patch stuff up. Although maybe
it's just a question of how quickly we can get to a correct BASIS_2002
so that the single big :> works.
I also think this would be an excellent time to drop support for
-basis 1997 and Basis1997. Why, because it will be a whole lot of
additional work to get the opacity right there. And, with the new
front end, it is much easier for people to migrate to the new basis.
Anyways, with all this, we now have a front end that works on all our
usual tests. I am certain there are still many problems both in the
type checker and in missing sharing and wheres. So, I am ready to
start getting some feedback. Please start testing. Soon, I will
revisit how type errors are displayed.
Revision Changes Path
1.21 +45 -13 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.20
retrieving revision 1.21
diff -u -r1.20 -r1.21
--- basis.sig 7 Nov 2003 00:21:27 -0000 1.20
+++ basis.sig 14 Nov 2003 03:48:17 -0000 1.21
@@ -255,6 +255,14 @@
structure Word64Vector : MONO_VECTOR
structure Word64VectorSlice : MONO_VECTOR_SLICE
+ (* Non-standard structures *)
+ structure MLton: MLTON
+ structure SMLofNJ: SML_OF_NJ
+ structure Unsafe: UNSAFE
+
+ sharing type MLton.IntInf.int = IntInf.int
+ sharing type MLton.Signal.t = Posix.Signal.signal
+
(* ************************************************** *)
(* ************************************************** *)
@@ -318,6 +326,8 @@
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
sharing type TextPrimIO.elem = Char.char
sharing type TextPrimIO.array = CharArray.array
sharing type TextPrimIO.vector = CharVector.vector
@@ -333,7 +343,11 @@
sharing type Word8Array2.elem = Word8.word
sharing type Word8Array2.vector = Word8Vector.vector
- (* Optional structures *)
+ (* Optional structures *)
+ sharing IntArray = Int32Array
+ sharing RealArray = Real64Array
+ sharing WordArray = Word32Array
+
sharing type BoolArray.elem = bool
sharing type BoolArray.vector = BoolVector.vector
sharing type BoolArraySlice.elem = bool
@@ -437,14 +451,15 @@
sharing type LargeWordArray2.vector = LargeWordVector.vector
sharing type PackRealBig.real = real
sharing type PackRealLittle.real = real
- sharing type PackReal32Big.real = Real64.real
- sharing type PackReal32Little.real = Real64.real
+ sharing type PackReal32Big.real = Real32.real
+ sharing type PackReal32Little.real = Real32.real
sharing type PackReal64Big.real = Real64.real
sharing type PackReal64Little.real = Real64.real
sharing type Posix.Error.syserror = OS.syserror
- sharing type Posix.Process.exit_status = Unix.exit_status
+ sharing type Posix.IO.file_desc = Posix.ProcEnv.file_desc
sharing type Posix.FileSys.dirstream = OS.FileSys.dirstream
sharing type Posix.FileSys.access_mode = OS.FileSys.access_mode
+ sharing type Posix.Process.exit_status = Unix.exit_status
sharing type RealArray.elem = real
sharing type RealArray.vector = RealVector.vector
sharing type RealArraySlice.elem = real
@@ -501,6 +516,7 @@
sharing type Word16VectorSlice.vector = Word16Vector.vector
sharing type Word16Array2.elem = Word16.word
sharing type Word16Array2.vector = Word16Vector.vector
+ sharing type Word32.word = Word.word
sharing type Word32Array.elem = Word32.word
sharing type Word32Array.vector = Word32Vector.vector
sharing type Word32ArraySlice.elem = Word32.word
@@ -514,19 +530,21 @@
sharing type Word32Array2.vector = Word32Vector.vector
end
(* Top-level types *)
- where type unit = unit
- where type int = int
- where type word = word
- where type real = real
- where type char = char
- where type exn = exn
where type 'a array = 'a array
- where type 'a vector = 'a vector
+ where type 'a list = 'a list
+ where type 'a option = 'a option
where type 'a ref = 'a ref
+ where type 'a vector = 'a vector
where type bool = bool
- where type 'a option = 'a option
+ where type char = char
+ where type exn = exn
+ where type int = int
where type order = order
- where type 'a list = 'a list
+ where type real = real
+ where type string = string
+ where type substring = substring
+ where type unit = unit
+ where type word = word
(* Types referenced in signatures by structure name *)
(*
@@ -537,6 +555,7 @@
where type BinPrimIO.writer = BinPrimIO.writer
where type Char.char = Char.char
where type Int.int = Int.int
+ where type IntInf.int = IntInf.int
where type LargeInt.int = LargeInt.int
where type LargeReal.real = LargeReal.real
where type LargeWord.word = LargeWord.word
@@ -548,23 +567,36 @@
where type OS.IO.iodesc = OS.IO.iodesc
where type OS.Process.status = OS.Process.status
where type Position.int = Position.int
+ where type Posix.IO.file_desc = Posix.IO.file_desc
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 ('a, 'b) Socket.sock = ('a, 'b) Socket.sock
+ where type 'a Socket.sock_addr = 'a Socket.sock_addr
+ where type 'a Socket.stream = 'a Socket.stream
where type StringCvt.radix = StringCvt.radix
where type StringCvt.realfmt = StringCvt.realfmt
(*
where type ('a, 'b) StringCvt.reader = ('a, 'b) StringCvt.reader
*)
where type SysWord.word = SysWord.word
+ where type TextIO.instream = TextIO.instream
+ where type TextIO.outstream = TextIO.outstream
where type TextPrimIO.reader = TextPrimIO.reader
where type TextPrimIO.writer = TextPrimIO.writer
where type Time.time = Time.time
where type Word.word = Word.word
where type Word8.word = Word8.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 Vector.vector = 'a Vector.vector
*)
where type 'a VectorSlice.slice = 'a VectorSlice.slice
+ where type 'a MLton.Thread.t = 'a MLton.Thread.t
1.18 +4 -0 mlton/basis-library/libs/basis-2002/top-level/basis.sml
Index: basis.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/libs/basis-2002/top-level/basis.sml,v
retrieving revision 1.17
retrieving revision 1.18
diff -u -r1.17 -r1.18
--- basis.sml 11 Sep 2003 00:51:06 -0000 1.17
+++ basis.sml 14 Nov 2003 03:48:17 -0000 1.18
@@ -174,6 +174,10 @@
structure Word64Vector = Word64Vector
structure Word64VectorSlice = Word64VectorSlice
+ structure MLton = MLton
+ structure SMLofNJ = SMLofNJ
+ structure Unsafe = Unsafe
+
open ArrayGlobal
BoolGlobal
CharGlobal
1.8 +0 -7 mlton/basis-library/libs/basis-2002/top-level/top-level.sml
Index: top-level.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/libs/basis-2002/top-level/top-level.sml,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- top-level.sml 9 Oct 2003 18:17:30 -0000 1.7
+++ top-level.sml 14 Nov 2003 03:48:17 -0000 1.8
@@ -37,13 +37,6 @@
signature SML_OF_NJ = SML_OF_NJ
signature UNSAFE = UNSAFE
-(* Non-standard structures *)
-structure Primitive = Primitive
-structure Basis1997 = Basis1997
-structure MLton = MLton
-structure SMLofNJ = SMLofNJ
-structure Unsafe = Unsafe
-
open Basis2002
val op = = op =
1.3 +7 -0 mlton/mlton/ast/admits-equality.fun
Index: admits-equality.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/admits-equality.fun,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- admits-equality.fun 7 Nov 2003 00:21:27 -0000 1.2
+++ admits-equality.fun 14 Nov 2003 03:48:17 -0000 1.3
@@ -12,6 +12,13 @@
val layout = Layout.str o toString
+val op <= =
+ fn (Never, _) => true
+ | (Sometimes, Never) => false
+ | (Sometimes, _) => true
+ | (Always, Always) => true
+ | (Always, _) => false
+
val or =
fn (Always, _) => Always
| (_, Always) => Always
1.3 +1 -0 mlton/mlton/ast/admits-equality.sig
Index: admits-equality.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/admits-equality.sig,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- admits-equality.sig 7 Nov 2003 00:21:28 -0000 1.2
+++ admits-equality.sig 14 Nov 2003 03:48:17 -0000 1.3
@@ -8,6 +8,7 @@
datatype t = Always | Never | Sometimes
+ val <= : t * t -> bool
val layout: t -> Layout.t
val or: t * t -> t
val toString: t -> string
1.6 +1 -4 mlton/mlton/defunctorize/defunctorize.fun
Index: defunctorize.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/defunctorize/defunctorize.fun,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- defunctorize.fun 13 Oct 2003 23:24:30 -0000 1.5
+++ defunctorize.fun 14 Nov 2003 03:48:17 -0000 1.6
@@ -316,10 +316,7 @@
fun defunctorize (CoreML.Program.T {decs}) =
let
val {destroy, hom = loopTy} =
- Ctype.makeHom {con = fn (c, ts) => if Tycon.equals (c, Tycon.char)
- then Xtype.word8
- else Xtype.con (c, ts),
- var = Xtype.var}
+ Ctype.makeHom {con = Xtype.con, var = Xtype.var}
val {get = conTycon, set = setConTycon, ...} =
Property.getSetOnce (Con.plist,
Property.initRaise ("conTycon", Con.layout))
1.48 +1 -0 mlton/mlton/elaborate/elaborate-core.fun
Index: elaborate-core.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-core.fun,v
retrieving revision 1.47
retrieving revision 1.48
diff -u -r1.47 -r1.48
--- elaborate-core.fun 11 Nov 2003 21:26:34 -0000 1.47
+++ elaborate-core.fun 14 Nov 2003 03:48:17 -0000 1.48
@@ -215,6 +215,7 @@
val {hom = typeTycon: Type.t -> Tycon.t option, ...} =
Type.makeHom {con = fn (c, _) => SOME c,
+ expandOpaque = Type.Never,
var = fn _ => NONE}
fun resolveConst (c: Aconst.t, ty: Type.t): Const.t =
1.21 +1051 -947 mlton/mlton/elaborate/elaborate-env.fun
Index: elaborate-env.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-env.fun,v
retrieving revision 1.20
retrieving revision 1.21
diff -u -r1.20 -r1.21
--- elaborate-env.fun 11 Nov 2003 21:26:34 -0000 1.20
+++ elaborate-env.fun 14 Nov 2003 03:48:18 -0000 1.21
@@ -37,7 +37,12 @@
structure Var = Var
end
-structure Kind = Tycon.Kind
+local
+ open Tycon
+in
+ structure AdmitsEquality = AdmitsEquality
+ structure Kind = Kind
+end
local
open TypeEnv
@@ -150,7 +155,8 @@
fn T {ranges, ...} => List.pop ranges
end
-structure TypeStr = TypeStr (structure Con = Con
+structure TypeStr = TypeStr (structure AdmitsEquality = AdmitsEquality
+ structure Con = Con
structure Kind = Tycon.Kind
structure Name = Ast.Con
structure Record = SortedRecord
@@ -178,6 +184,12 @@
open Type
val bogus = new ()
+
+ fun hom (t, {con, record, var}) =
+ Type.hom (t, {con = con,
+ expandOpaque = Type.Never,
+ record = record,
+ var = var})
end
structure Tyvar = Tyvar)
@@ -244,29 +256,25 @@
{isUsed = ref false,
range = f range,
values = values}))
+
+ val map2: ('a, 'b) t * ('a, 'b) t * ('b * 'b -> 'b) -> ('a, 'b) t =
+ fn (T a, T a', f) =>
+ T (Array.map2
+ (a, a', fn ({range = r, values, ...}, {range = r', ...}) =>
+ {isUsed = ref false,
+ range = f (r, r'),
+ values = values}))
end
-(* pre: arities are equal. *)
-fun equalSchemes (s: Scheme.t, s': Scheme.t, name: unit -> Layout.t, r: Region.t)
- : unit =
+val newTycons: (Tycon.t * Kind.t) list ref = ref []
+
+val newTycon: string * Kind.t -> Tycon.t =
+ fn (s, k) =>
let
- val (tyvars, ty) = Scheme.dest s
- val (_, ty') = Scheme.dest s'
- val tyvars =
- Vector.tabulate (Vector.length tyvars, fn _ =>
- Type.var (Tyvar.newNoname {equality = false}))
+ val c = Tycon.fromString s
+ val _ = List.push (newTycons, (c, k))
in
- Type.unify
- (Scheme.apply (s, tyvars), Scheme.apply (s', tyvars), fn (l1, l2) =>
- let
- open Layout
- in
- (r,
- seq [str "type ", name (),
- str " in structure disagrees with signature"],
- align [seq [str "structure: ", l1],
- seq [str "signature: ", l2]])
- end)
+ c
end
(* ------------------------------------------------- *)
@@ -287,6 +295,8 @@
val plist = make #plist
end
+ fun eq (s: t, s': t): bool = PropertyList.equals (plist s, plist s')
+
fun layoutUsed (T {strs, types, vals, ...}) =
let
open Layout
@@ -446,308 +456,6 @@
addVal = addVal,
finish = finish}
end
-
- (* section 5.3, 5.5, 5.6 and rules 52, 53 *)
- fun cut (str: t, {interface, opaque: bool, region}): t * Decs.t =
- let
- val decs = ref []
- fun error (name, l) =
- let
- open Layout
- in
- Control.error
- (region,
- seq [str (concat [name, " "]), l,
- str " in signature but not in structure"],
- empty)
- end
- fun checkCons (Cons.T v, Cons.T v', strids): unit =
- let
- fun lay (c: Ast.Con.t) =
- Longcon.layout (Longcon.long (rev strids, c))
- val extraStr =
- Vector.keepAllMap
- (v, fn {name = n, scheme = s, ...} =>
- case Vector.peek (v', fn {name = n', ...} =>
- Ast.Con.equals (n, n')) of
- NONE => SOME n
- | SOME {scheme = s', ...} =>
- let
- val _ =
- equalSchemes
- (s, s', fn () =>
- let
- open Layout
- in
- seq [str "of ", lay n]
- end,
- region)
- in
- NONE
- end)
- fun extras (v, name) =
- if 0 = Vector.length v
- then ()
- else
- let
- open Layout
- in
- Control.error
- (region,
- seq [str (concat ["constructors in ", name, " only: "]),
- seq (List.separate (Vector.toListMap (v, lay),
- str ", "))],
- empty)
- end
- val _ = extras (extraStr, "structure")
- val extraSig =
- Vector.keepAllMap
- (v', fn {name = n', ...} =>
- if Vector.exists (v, fn {name = n, ...} =>
- Ast.Con.equals (n, n'))
- then NONE
- else SOME n')
- val _ = extras (extraSig, "signature")
- in
- ()
- end
- val interface =
- Interface.realize
- (interface, fn (c, a, k) =>
- case peekLongtycon (str, c) of
- NONE => (error ("type", Longtycon.layout c)
- ; TypeStr.bogus k)
- | SOME typeStr =>
- let
- val k' = TypeStr.kind typeStr
- in
- if Kind.equals (k, k')
- then typeStr
- else
- let
- open Layout
- val _ =
- Control.error
- (Longtycon.region c,
- seq [str "type ", Longtycon.layout c,
- str "has arity ", Kind.layout k',
- str "in structure but arity ",
- Kind.layout k, str " in signature"],
- empty)
- in
- TypeStr.bogus k
- end
- end)
- fun cut (S as T {shapeId, ...}, I, strids) =
- let
- val {addStr, addType, addVal, finish} = maker ()
- val shapeId' = Interface.shapeId I
- fun doit () =
- let
- fun handleStr {name, interface = I} =
- case peekStrid' (S, name) of
- NONE =>
- error
- ("structure",
- Longstrid.layout
- (Longstrid.long (rev strids, name)))
- | SOME {range, values, ...} =>
- addStr {range = cut (range, I, name :: strids),
- values = values}
- fun handleType {name: Ast.Tycon.t,
- typeStr: TypeStr.t} =
- let
- fun layoutName () =
- Longtycon.layout
- (Longtycon.long (rev strids, name))
- in
- case peekTycon' (S, name) of
- NONE => error ("type", layoutName ())
- | SOME {range = typeStr', values, ...} =>
- let
- fun tyconScheme (c: Tycon.t): Scheme.t =
- let
- val tyvars =
- case TypeStr.kind typeStr' of
- Kind.Arity n =>
- Vector.tabulate
- (n, fn _ =>
- Tyvar.newNoname
- {equality = false})
- | _ => Error.bug "Nary tycon"
- in
- Scheme.make
- {canGeneralize = true,
- ty = Type.con (c, Vector.map (tyvars, Type.var)),
- tyvars = tyvars}
- end
- datatype z = datatype TypeStr.node
- val k = TypeStr.kind typeStr
- val k' = TypeStr.kind typeStr'
- fun typeStrScheme (s: TypeStr.t) =
- case TypeStr.node s of
- Datatype {tycon, ...} =>
- tyconScheme tycon
- | Scheme s => s
- | Tycon c' => tyconScheme c'
- val typeStr =
- if not (Kind.equals (k, k'))
- then
- let
- open Layout
- in
- Control.error
- (region,
- seq [str "type ", layoutName (),
- str " has arity ", Kind.layout k',
- str " in structure but arity ", Kind.layout k,
- str " in signature"],
- empty)
- ; typeStr
- end
- else
- case TypeStr.node typeStr of
- Datatype {cons = c, ...} =>
- (case TypeStr.node typeStr' of
- Datatype {cons = c', ...} =>
- (checkCons (c', c,
- strids)
- ; typeStr')
- | _ =>
- let
- open Layout
- in
- Control.error
- (region,
- seq [str "type ",
- layoutName (),
- str " is a datatype in signature but not in structure"],
- Layout.empty)
- ; typeStr
- end)
- | Scheme s =>
- (equalSchemes
- (typeStrScheme typeStr',
- s, layoutName, region)
- ; typeStr)
- | Tycon c =>
- (equalSchemes
- (typeStrScheme typeStr',
- tyconScheme c,
- layoutName, region)
- ; typeStr)
- in
- addType {range = typeStr,
- values = values}
- end
- end
- fun handleVal {name, scheme = s, status} =
- case peekVid' (S, name) of
- NONE =>
- error ("variable",
- Longvid.layout (Longvid.long
- (rev strids, name)))
- | SOME {range = (vid, s'), values, ...} =>
- let
- val (tyvars, t) = Scheme.dest s
- val {args, instance = t'} =
- Scheme.instantiate s'
- val _ =
- Type.unify
- (t, t', fn (l, l') =>
- let
- open Layout
- in
- (region,
- seq [str "type of ",
- Longvid.layout
- (Longvid.long
- (rev strids, name)),
- str " in structure disagrees with signature"],
- align [seq [str "structure: ", l'],
- seq [str "signature: ", l]])
- end)
- fun addDec (n: Exp.node): Vid.t =
- let
- val x = Var.newNoname ()
- val e = Exp.make (n, t')
- val _ =
- List.push
- (decs,
- Dec.Val
- {rvbs = Vector.new0 (),
- tyvars = fn () => tyvars,
- vbs = (Vector.new1
- {exp = e,
- lay = fn _ => Layout.empty,
- pat = Pat.var (x, t'),
- patRegion = region})})
- in
- Vid.Var x
- end
- fun con (c: Con.t): Vid.t =
- addDec (Exp.Con (c, args ()))
- val vid =
- case (vid, status) of
- (Vid.Con c, Status.Var) => con c
- | (Vid.Exn c, Status.Var) => con c
- | (Vid.Var x, Status.Var) =>
- if 0 < Vector.length tyvars
- orelse 0 < Vector.length (args ())
- then
- addDec
- (Exp.Var (fn () => x, args))
- else vid
- | (Vid.Con _, Status.Con) => vid
- | (Vid.Exn _, Status.Exn) => vid
- | _ =>
- (Control.error
- (region,
- Layout.str
- (concat
- ["identifier ",
- Longvid.toString
- (Longvid.long (rev strids,
- name)),
- " is ",
- Vid.statusPretty vid,
- " in the structure but ",
- Status.pretty status,
- " in the signature "]),
- Layout.empty)
- ; vid)
- in
- addVal {range = (vid, s),
- values = values}
- end
- val _ =
- Interface.foreach
- (I, {handleStr = handleStr,
- handleType = handleType,
- handleVal = handleVal})
- in
- finish (SOME shapeId')
- end
- in
- case shapeId of
- NONE => doit ()
- | SOME shapeId =>
- if ShapeId.equals (shapeId, shapeId')
- then S
- else doit ()
- end
- val str = cut (str, interface, [])
- in
- (str, Decs.fromList (!decs))
- end
-
- val cut =
- Trace.trace ("cut",
- fn (str, {interface, ...}) =>
- Layout.tuple [layoutPretty str,
- Interface.layout interface],
- layout o #1)
- cut
val ffi: t option ref = ref NONE
end
@@ -984,442 +692,97 @@
align [seq [str "structure ", Ast.Strid.layout d],
indent (Structure.layoutUsed r, 3)])]
end
-
-fun dummyStructure (T {strs, types, vals, ...}, I: Interface.t): Structure.t =
- let
- val I =
- Interface.realize
- (I, fn (c, a, k) =>
- let
- val c = Tycon.fromString (Longtycon.toString c)
- val _ = TypeEnv.tyconAdmitsEquality c := a
- in
- TypeStr.tycon (c, k)
- end)
- val {get, ...} =
- Property.get
- (Interface.plist,
- Property.initRec
- (fn (I, get) =>
- let
- val {addStr, addType, addVal, finish} = Structure.maker ()
- fun handleStr {name, interface = I} =
- addStr {range = get I,
- values = NameSpace.values (strs, name)}
- fun handleType {name, typeStr} =
- addType {range = typeStr,
- values = NameSpace.values (types, name)}
- fun handleVal {name, scheme, status} =
- let
- val con = CoreML.Con.fromString o Ast.Vid.toString
- val var = CoreML.Var.fromString o Ast.Vid.toString
- val vid =
- case status of
- Status.Con => Vid.Con (con name)
- | Status.Exn => Vid.Exn (con name)
- | Status.Var => Vid.Var (var name)
- in
- addVal {range = (vid, scheme),
- values = NameSpace.values (vals, name)}
- end
- val _ =
- Interface.foreach
- (I, {handleStr = handleStr,
- handleType = handleType,
- handleVal = handleVal})
- in
- finish (SOME (Interface.shapeId I))
- end))
- in
- get I
- end
-
-val dummyStructure =
- Trace.trace ("dummyStructure",
- Interface.layout o #2,
- Structure.layoutPretty)
- dummyStructure
(* ------------------------------------------------- *)
-(* functorClosure *)
+(* peek *)
(* ------------------------------------------------- *)
-fun snapshot (T {currentScope, fcts, fixs, sigs, strs, types, vals}):
- (unit -> 'a) -> 'a =
- let
- fun m l = Layout.outputl (l, Out.error)
- open Layout
- fun doit (NameSpace.T {current, table, ...}, lay) =
- let
- val all =
- HashSet.fold
- (table, [], fn (vs as Values.T {ranges, ...}, ac) =>
- case !ranges of
- [] => ac
- | z :: _ => (z, vs) :: ac)
- in
- fn s0 =>
- let
- val current0 = !current
- val _ =
- current :=
- List.fold
- (all, [], fn (({isUsed, value, ...},
- vs as Values.T {ranges, ...}), ac) =>
- (List.push (ranges, {isUsed = isUsed,
- scope = s0,
- value = value})
- ; vs :: ac))
- val removed =
- HashSet.fold
- (table, [], fn (Values.T {ranges, ...}, ac) =>
- let
- val r = !ranges
- in
- case r of
- [] => ac
- | {scope, ...} :: _ =>
- if Scope.equals (s0, scope)
- then ac
- else (ranges := []
- ; (ranges, r) :: ac)
- end)
- in fn () => (List.foreach (!current, fn v => (Values.pop v; ()))
- ; current := current0
- ; List.foreach (removed, op :=))
- end
- end
- val fcts = doit (fcts, Ast.Fctid.layout)
- val fixs = doit (fixs, Ast.Vid.layout)
- val sigs = doit (sigs, Ast.Sigid.layout)
- val strs = doit (strs, Ast.Strid.layout)
- val types = doit (types, Ast.Tycon.layout)
- val vals = doit (vals, Ast.Vid.layout)
- in
- fn th =>
+local
+ fun 'a make field (T fields, a) = NameSpace.peek (field fields, a)
+in
+ val peekFctid = make #fcts
+ val peekFix = make #fixs
+ val peekFix =
+ Trace.trace
+ ("peekFix", Ast.Vid.layout o #2, Option.layout Ast.Fixity.layout)
+ peekFix
+ val peekSigid = make #sigs
+ val peekStrid = make #strs
+ val peekTycon = make #types
+ val peekVid = make #vals
+ fun peekVar (E, x) =
+ case peekVid (E, Ast.Vid.fromVar x) of
+ NONE => NONE
+ | SOME (vid, s) => Option.map (Vid.deVar vid, fn x => (x, s))
+end
+
+fun peekCon (E: t, c: Ast.Con.t): (Con.t * Scheme.t) option =
+ case peekVid (E, Ast.Vid.fromCon c) of
+ NONE => NONE
+ | SOME (vid, s) => Option.map (Vid.deCon vid, fn c => (c, s))
+
+fun layoutStrids (ss: Strid.t list): Layout.t =
+ Layout.str (concat (List.separate (List.map (ss, Strid.toString), ".")))
+
+structure PeekResult =
+ struct
+ datatype 'a t =
+ Found of 'a
+ | UndefinedStructure of Strid.t list
+ | Undefined
+
+ fun layout lay =
+ fn Found z => lay z
+ | UndefinedStructure ss => layoutStrids ss
+ | Undefined => Layout.str "Undefined"
+
+ val toOption: 'a t -> 'a option =
+ fn Found z => SOME z
+ | _ => NONE
+ end
+
+local
+ datatype z = datatype PeekResult.t
+ fun make (split: 'a -> Strid.t list * 'b,
+ peek: t * 'b -> 'c option,
+ strPeek: Structure.t * 'b -> 'c option) (E, x) =
let
- val s0 = Scope.new ()
- val fcts = fcts s0
- val fixs = fixs s0
- val sigs = sigs s0
- val strs = strs s0
- val types = types s0
- val vals = vals s0
- val s1 = !currentScope
- val _ = currentScope := s0
- val res = th ()
- val _ = currentScope := s1
- val _ = (fcts (); fixs (); sigs (); strs (); types (); vals ())
+ val (strids, x) = split x
in
- res
+ case strids of
+ [] => (case peek (E, x) of
+ NONE => Undefined
+ | SOME z => Found z)
+ | strid :: strids =>
+ case peekStrid (E, strid) of
+ NONE => UndefinedStructure [strid]
+ | SOME S =>
+ case Structure.peekStrids (S, strids) of
+ Structure.Found S =>
+ (case strPeek (S, x) of
+ NONE => Undefined
+ | SOME z => Found z)
+ | Structure.UndefinedStructure ss =>
+ UndefinedStructure (strid :: ss)
end
- end
+in
+ val peekLongstrid =
+ make (Ast.Longstrid.split, peekStrid, Structure.peekStrid)
+ val peekLongtycon =
+ make (Ast.Longtycon.split, peekTycon, Structure.peekTycon)
+ val peekLongvar = make (Ast.Longvar.split, peekVar, Structure.peekVar)
+ val peekLongvid = make (Ast.Longvid.split, peekVid, Structure.peekVid)
+ val peekLongcon = make (Ast.Longcon.split, peekCon, Structure.peekCon)
+end
-val useFunctorSummary = ref false
-val newTycons: (Tycon.t * Kind.t) list ref = ref []
-
-val newTycon: string * Kind.t -> Tycon.t =
- fn (s, k) =>
- let
- val c = Tycon.fromString s
- val _ = List.push (newTycons, (c, k))
- in
- c
- end
-
-val propertyFun:
- ('a -> PropertyList.t) * ('a * 'b * ('a * 'b -> 'c) -> 'c)
- -> ('a * 'b -> 'c) * {destroy: unit -> unit} =
- fn (plist, f) =>
- let
- fun uncurry g (a, b) = g a b
- val {destroy, get: 'a -> 'b -> 'c, ...} =
- Property.destGet
- (plist,
- Property.initRec
- (fn (a, get) =>
- let
- val done = ref NONE
- in
- fn b =>
- case !done of
- NONE =>
- let
- val c = f (a, b, uncurry get)
- val _ = done := SOME c
- in
- c
- end
- | SOME c => c
- end))
- in
- (uncurry get, {destroy = destroy})
- end
-
-fun functorClosure
- (E: t,
- argInt: Interface.t,
- makeBody: Structure.t * string list -> Decs.t * Structure.t) =
- let
- val formal = dummyStructure (E, argInt)
- val _ = useFunctorSummary := true
- (* Keep track of all tycons created during the instantiation of the
- * functor. These will later become the generative tycons that will need
- * to be recreated for each functor application.
- *)
- val _ = newTycons := []
- val (_, res) = makeBody (formal, [])
- val generative = !newTycons
- val _ = newTycons := []
- val _ = useFunctorSummary := false
- val restore = snapshot E
- fun apply (arg, nest, region) =
- let
- val (actual, decs) =
- Structure.cut (arg, {interface = argInt,
- opaque = false,
- region = region})
- in
- if !useFunctorSummary
- then
- let
- val {destroy = destroy1,
- get = tyconTypeStr: Tycon.t -> TypeStr.t option,
- set = setTyconTypeStr, ...} =
- Property.destGetSet (Tycon.plist,
- Property.initConst NONE)
- (* Match the actual against the formal, to set the
- * tycons. Then duplicate the res, replacing tycons.
- * Want to generate new tycons just like the functor body
- * did.
- * Need to treat the formal as a DAG.
- *)
- val (setTycons, {destroy}) =
- propertyFun
- (Structure.plist,
- (fn (formal, actual, setTycons) =>
- let
- val Structure.T {strs = Info.T s,
- types = Info.T t, ...} =
- formal
- val Structure.T {strs = Info.T s',
- types = Info.T t', ...} =
- actual
- val _ =
- Array.foreach2
- (t, t',
- fn ({range = r, ...},
- {range = r', ...}) =>
- let
- fun doit tycon =
- setTyconTypeStr (tycon, SOME r')
- in
- case TypeStr.node r of
- TypeStr.Datatype {tycon, ...} =>
- doit tycon
- | TypeStr.Scheme _ => ()
- | TypeStr.Tycon tycon => doit tycon
- end)
- val _ =
- Array.foreach2
- (s, s', fn ({range = s, ...},
- {range = s', ...}) =>
- setTycons (s, s'))
- in
- ()
- end))
- val _ = setTycons (formal, actual)
- val _ = destroy ()
- val _ =
- List.foreach
- (generative, fn (c, k) =>
- setTyconTypeStr
- (c, SOME (TypeStr.tycon
- (newTycon (Tycon.originalName c, k),
- k))))
- fun replaceType (t: Type.t): Type.t =
- let
- fun con (c, ts) =
- case tyconTypeStr c of
- NONE => Type.con (c, ts)
- | SOME s => TypeStr.apply (s, ts)
- in
- Type.hom (t, {con = con,
- record = Type.record,
- var = Type.var})
- end
- fun replaceScheme (s: Scheme.t): Scheme.t =
- let
- val (tyvars, ty) = Scheme.dest s
- in
- Scheme.make {canGeneralize = true,
- ty = replaceType ty,
- tyvars = tyvars}
- end
- fun replaceCons (Cons.T v): Cons.t =
- Cons.T
- (Vector.map
- (v, fn {con, name, scheme} =>
- {con = con,
- name = name,
- scheme = replaceScheme scheme}))
- fun replaceTypeStr (s: TypeStr.t): TypeStr.t =
- let
- val k = TypeStr.kind s
- datatype z = datatype TypeStr.node
- in
- case TypeStr.node s of
- Datatype {cons, tycon} =>
- let
- val tycon =
- case tyconTypeStr tycon of
- NONE => tycon
- | SOME s =>
- (case TypeStr.node s of
- Datatype {tycon, ...} => tycon
- | Scheme _ =>
- Error.bug "bad datatype"
- | Tycon c => c)
- in
- TypeStr.data (tycon, k, replaceCons cons)
- end
- | Scheme s => TypeStr.def (replaceScheme s, k)
- | Tycon c =>
- (case tyconTypeStr c of
- NONE => s
- | SOME s' => s')
- end
- val {destroy = destroy2,
- get = replacement: Structure.t -> Structure.t, ...} =
- Property.destGet
- (Structure.plist,
- Property.initRec
- (fn (Structure.T {shapeId, strs, types, vals, ... },
- replacement) =>
- Structure.T
- {plist = PropertyList.new (),
- shapeId = shapeId,
- strs = Info.map (strs, replacement),
- types = Info.map (types, replaceTypeStr),
- vals = Info.map (vals, fn (v, s) =>
- (v, replaceScheme s))}))
- val res = replacement res
- val _ = destroy1 ()
- val _ = destroy2 ()
- in
- (Decs.empty, res)
- end
- else
- let
- val (decs', str) = restore (fn () => makeBody (actual, nest))
- in
- (Decs.append (decs, decs'),
- str)
- end
- end
- val apply =
- Trace.trace ("functorApply",
- Structure.layout o #1,
- Layout.tuple2 (Layout.ignore, Structure.layout))
- apply
- fun sizeMessage () = layoutSize apply
- val fc =
- FunctorClosure.T {apply = apply,
- sizeMessage = sizeMessage}
- in
- fc
- end
-
-(* ------------------------------------------------- *)
-(* peek *)
-(* ------------------------------------------------- *)
-
-local
- fun 'a make field (T fields, a) = NameSpace.peek (field fields, a)
-in
- val peekFctid = make #fcts
- val peekFix = make #fixs
- val peekFix =
- Trace.trace
- ("peekFix", Ast.Vid.layout o #2, Option.layout Ast.Fixity.layout)
- peekFix
- val peekSigid = make #sigs
- val peekStrid = make #strs
- val peekTycon = make #types
- val peekVid = make #vals
- fun peekVar (E, x) =
- case peekVid (E, Ast.Vid.fromVar x) of
- NONE => NONE
- | SOME (vid, s) => Option.map (Vid.deVar vid, fn x => (x, s))
-end
-
-fun peekCon (E: t, c: Ast.Con.t): (Con.t * Scheme.t) option =
- case peekVid (E, Ast.Vid.fromCon c) of
- NONE => NONE
- | SOME (vid, s) => Option.map (Vid.deCon vid, fn c => (c, s))
-
-fun layoutStrids (ss: Strid.t list): Layout.t =
- Layout.str (concat (List.separate (List.map (ss, Strid.toString), ".")))
-
-structure PeekResult =
- struct
- datatype 'a t =
- Found of 'a
- | UndefinedStructure of Strid.t list
- | Undefined
-
- fun layout lay =
- fn Found z => lay z
- | UndefinedStructure ss => layoutStrids ss
- | Undefined => Layout.str "Undefined"
-
- val toOption: 'a t -> 'a option =
- fn Found z => SOME z
- | _ => NONE
- end
-
-local
- datatype z = datatype PeekResult.t
- fun make (split: 'a -> Strid.t list * 'b,
- peek: t * 'b -> 'c option,
- strPeek: Structure.t * 'b -> 'c option) (E, x) =
- let
- val (strids, x) = split x
- in
- case strids of
- [] => (case peek (E, x) of
- NONE => Undefined
- | SOME z => Found z)
- | strid :: strids =>
- case peekStrid (E, strid) of
- NONE => UndefinedStructure [strid]
- | SOME S =>
- case Structure.peekStrids (S, strids) of
- Structure.Found S =>
- (case strPeek (S, x) of
- NONE => Undefined
- | SOME z => Found z)
- | Structure.UndefinedStructure ss =>
- UndefinedStructure (strid :: ss)
- end
-in
- val peekLongstrid =
- make (Ast.Longstrid.split, peekStrid, Structure.peekStrid)
- val peekLongtycon =
- make (Ast.Longtycon.split, peekTycon, Structure.peekTycon)
- val peekLongvar = make (Ast.Longvar.split, peekVar, Structure.peekVar)
- val peekLongvid = make (Ast.Longvid.split, peekVid, Structure.peekVid)
- val peekLongcon = make (Ast.Longcon.split, peekCon, Structure.peekCon)
-end
-
-val peekLongcon =
- Trace.trace2 ("peekLongcon", Layout.ignore, Ast.Longcon.layout,
- PeekResult.layout (Layout.tuple2
- (CoreML.Con.layout, TypeScheme.layout)))
- peekLongcon
-(* ------------------------------------------------- *)
-(* lookup *)
-(* ------------------------------------------------- *)
+val peekLongcon =
+ Trace.trace2 ("peekLongcon", Layout.ignore, Ast.Longcon.layout,
+ PeekResult.layout (Layout.tuple2
+ (CoreML.Con.layout, TypeScheme.layout)))
+ peekLongcon
+(* ------------------------------------------------- *)
+(* lookup *)
+(* ------------------------------------------------- *)
fun unbound (r: Region.t, className, x: Layout.t): unit =
Control.error
@@ -1505,219 +868,960 @@
(* extend *)
(* ------------------------------------------------- *)
-local
- fun make get (T (fields as {currentScope, ...}), domain, range) =
- let
- val ns = get fields
- in
- NameSpace.update (ns, !currentScope,
- {isUsed = ref false,
- range = range,
- values = NameSpace.values (ns, domain)})
- end
-in
- val extendFctid = make #fcts
- val extendFix = make #fixs
- val extendFix =
- Trace.trace ("extendFix",
- fn (_, x, f) => Layout.tuple [Ast.Vid.layout x,
- Ast.Fixity.layout f],
- Unit.layout)
- extendFix
- val extendSigid = make #sigs
- val extendStrid = make #strs
- val extendTycon = make #types
- val extendVals = make #vals
-end
+local
+ fun make get (T (fields as {currentScope, ...}), domain, range) =
+ let
+ val ns = get fields
+ in
+ NameSpace.update (ns, !currentScope,
+ {isUsed = ref false,
+ range = range,
+ values = NameSpace.values (ns, domain)})
+ end
+in
+ val extendFctid = make #fcts
+ val extendFix = make #fixs
+ val extendFix =
+ Trace.trace ("extendFix",
+ fn (_, x, f) => Layout.tuple [Ast.Vid.layout x,
+ Ast.Fixity.layout f],
+ Unit.layout)
+ extendFix
+ val extendSigid = make #sigs
+ val extendStrid = make #strs
+ val extendTycon = make #types
+ val extendVals = make #vals
+end
+
+val extendTycon =
+ Trace.trace3 ("extendTycon", layout, Ast.Tycon.layout, TypeStr.layout,
+ Unit.layout)
+ extendTycon
+
+fun extendCon (E, c, c', s) =
+ extendVals (E, Ast.Vid.fromCon c, (Vid.Con c', s))
+
+fun extendExn (E, c, c', s) =
+ extendVals (E, Ast.Vid.fromCon c, (Vid.Exn c', s))
+
+fun extendVar (E, x, x', s) =
+ extendVals (E, Ast.Vid.fromVar x, (Vid.Var x', s))
+
+fun extendOverload (E, x, yts, s) =
+ extendVals (E, Ast.Vid.fromVar x, (Vid.Overload yts, s))
+
+val extendVar =
+ Trace.trace4
+ ("extendVar", Layout.ignore, Ast.Var.layout, Var.layout, Scheme.layoutPretty,
+ Unit.layout)
+ extendVar
+
+(* ------------------------------------------------- *)
+(* local *)
+(* ------------------------------------------------- *)
+
+local
+ fun doit (info as NameSpace.T {current, ...}, s0) =
+ let
+ val old = !current
+ val _ = current := []
+ in
+ fn () =>
+ let
+ val c1 = !current
+ val _ = current := []
+ in
+ fn () =>
+ let
+ val c2 = !current
+ val lift = List.map (c2, Values.pop)
+ val _ = List.foreach (c1, fn v => (Values.pop v; ()))
+ val _ = current := old
+ val _ =
+ List.foreach2 (lift, c2, fn ({isUsed, value, ...}, values) =>
+ NameSpace.update
+ (info, s0, {isUsed = isUsed,
+ range = value,
+ values = values}))
+ in
+ ()
+ end
+ end
+ end
+in
+ fun localTop (T {currentScope, fcts, fixs, sigs, strs, types, vals, ...}, f) =
+ let
+ val s0 = !currentScope
+ val fcts = doit (fcts, s0)
+ val fixs = doit (fixs, s0)
+ val sigs = doit (sigs, s0)
+ val strs = doit (strs, s0)
+ val types = doit (types, s0)
+ val vals = doit (vals, s0)
+ val _ = currentScope := Scope.new ()
+ val a = f ()
+ val fcts = fcts ()
+ val fixs = fixs ()
+ val sigs = sigs ()
+ val strs = strs ()
+ val types = types ()
+ val vals = vals ()
+ fun finish g =
+ let
+ val _ = currentScope := Scope.new ()
+ val b = g ()
+ val _ = (fcts (); fixs (); sigs (); strs (); types (); vals ())
+ val _ = currentScope := s0
+ in
+ b
+ end
+ in (a, finish)
+ end
+
+ fun localModule (T {currentScope, fixs, strs, types, vals, ...},
+ f1, f2) =
+ let
+ val s0 = !currentScope
+ val fixs = doit (fixs, s0)
+ val strs = doit (strs, s0)
+ val types = doit (types, s0)
+ val vals = doit (vals, s0)
+ val _ = currentScope := Scope.new ()
+ val a1 = f1 ()
+ val fixs = fixs ()
+ val strs = strs ()
+ val types = types ()
+ val vals = vals ()
+ val _ = currentScope := Scope.new ()
+ val a2 = f2 a1
+ val _ = (fixs (); strs (); types (); vals ())
+ val _ = currentScope := s0
+ in
+ a2
+ end
+
+ (* Can't eliminate the use of strs in localCore, because openn still modifies
+ * module level constructs.
+ *)
+ val localCore = localModule
+end
+
+fun makeStructure (T {currentScope, fixs, strs, types, vals, ...}, make) =
+ let
+ val f = NameSpace.collect (fixs, Ast.Vid.<=)
+ val s = NameSpace.collect (strs, Ast.Strid.<=)
+ val t = NameSpace.collect (types, Ast.Tycon.<=)
+ val v = NameSpace.collect (vals, Ast.Vid.<=)
+ val s0 = !currentScope
+ val _ = currentScope := Scope.new ()
+ val res = make ()
+ val _ = f ()
+ val S = Structure.T {plist = PropertyList.new (),
+ shapeId = NONE,
+ strs = s (),
+ types = t (),
+ vals = v ()}
+ val _ = currentScope := s0
+ in (res, S)
+ end
+
+fun scope (T {currentScope, fixs, strs, types, vals, ...}, th) =
+ let
+ fun doit (NameSpace.T {current, ...}) =
+ let
+ val old = !current
+ val _ = current := []
+ in fn () => (List.foreach (!current, fn v => (Values.pop v; ()))
+ ; current := old)
+ end
+ val s0 = !currentScope
+ val _ = currentScope := Scope.new ()
+ val f = doit fixs
+ val s = doit strs
+ val t = doit types
+ val v = doit vals
+ val res = th ()
+ val _ = (f (); s (); t (); v ())
+ val _ = currentScope := s0
+ in res
+ end
+
+fun scopeAll (T {currentScope, fcts, fixs, sigs, strs, types, vals, ...}, th) =
+ let
+ fun doit (NameSpace.T {current, ...}) =
+ let
+ val old = !current
+ val _ = current := []
+ in fn () => (List.foreach (!current, fn v => (Values.pop v; ()))
+ ; current := old)
+ end
+ val s0 = !currentScope
+ val _ = currentScope := Scope.new ()
+ val fc = doit fcts
+ val f = doit fixs
+ val si = doit sigs
+ val s = doit strs
+ val t = doit types
+ val v = doit vals
+ val res = th ()
+ val _ = (fc (); f (); si (); s (); t (); v ())
+ val _ = currentScope := s0
+ in
+ res
+ end
+
+fun openStructure (T {currentScope, strs, vals, types, ...},
+ Structure.T {strs = strs',
+ vals = vals',
+ types = types', ...}): unit =
+ let
+ val scope = !currentScope
+ fun doit (info, Info.T a) =
+ Array.foreach (a, fn z => NameSpace.update (info, scope, z))
+ in doit (strs, strs')
+ ; doit (vals, vals')
+ ; doit (types, types')
+ end
+
-val extendTycon =
- Trace.trace3 ("extendTycon", layout, Ast.Tycon.layout, TypeStr.layout,
- Unit.layout)
- extendTycon
+val propertyFun:
+ ('a -> PropertyList.t) * ('a * 'b * ('a * 'b -> 'c) -> 'c)
+ -> ('a * 'b -> 'c) * {destroy: unit -> unit} =
+ fn (plist, f) =>
+ let
+ fun uncurry g (a, b) = g a b
+ val {destroy, get: 'a -> 'b -> 'c, ...} =
+ Property.destGet
+ (plist,
+ Property.initRec
+ (fn (a, get) =>
+ let
+ val done = ref NONE
+ in
+ fn b =>
+ case !done of
+ NONE =>
+ let
+ val c = f (a, b, uncurry get)
+ val _ = done := SOME c
+ in
+ c
+ end
+ | SOME c => c
+ end))
+ in
+ (uncurry get, {destroy = destroy})
+ end
-fun extendCon (E, c, c', s) =
- extendVals (E, Ast.Vid.fromCon c, (Vid.Con c', s))
-
-fun extendExn (E, c, c', s) =
- extendVals (E, Ast.Vid.fromCon c, (Vid.Exn c', s))
-
-fun extendVar (E, x, x', s) =
- extendVals (E, Ast.Vid.fromVar x, (Vid.Var x', s))
+fun dummyStructure (T {strs, types, vals, ...}, I: Interface.t)
+ : Structure.t * (Structure.t * (Tycon.t * TypeStr.t -> unit) -> unit) =
+ let
+ val tycons: (Longtycon.t * Tycon.t) list ref = ref []
+ val I =
+ Interface.realize
+ (I, fn (c, a, k) =>
+ let
+ val c' = newTycon (Longtycon.toString c, k)
+ val _ = TypeEnv.tyconAdmitsEquality c' := a
+ val _ = List.push (tycons, (c, c'))
+ in
+ TypeStr.tycon (c', k)
+ end)
+ val tycons = !tycons
+ val {get, ...} =
+ Property.get
+ (Interface.plist,
+ Property.initRec
+ (fn (I, get) =>
+ let
+ val {addStr, addType, addVal, finish} = Structure.maker ()
+ fun handleStr {name, interface = I} =
+ addStr {range = get I,
+ values = NameSpace.values (strs, name)}
+ fun handleType {name, typeStr} =
+ addType {range = typeStr,
+ values = NameSpace.values (types, name)}
+ fun handleVal {name, scheme, status} =
+ let
+ val con = CoreML.Con.fromString o Ast.Vid.toString
+ val var = CoreML.Var.fromString o Ast.Vid.toString
+ val vid =
+ case status of
+ Status.Con => Vid.Con (con name)
+ | Status.Exn => Vid.Exn (con name)
+ | Status.Var => Vid.Var (var name)
+ in
+ addVal {range = (vid, scheme),
+ values = NameSpace.values (vals, name)}
+ end
+ val _ =
+ Interface.foreach
+ (I, {handleStr = handleStr,
+ handleType = handleType,
+ handleVal = handleVal})
+ in
+ finish (SOME (Interface.shapeId I))
+ end))
+ val S = get I
+ fun instantiate (S', f) =
+ List.foreach (tycons, fn (long, c) =>
+ case Structure.peekLongtycon (S', long) of
+ NONE => Error.bug "structure missing longtycon"
+ | SOME s=> f (c, s))
+ in
+ (S, instantiate)
+ end
-fun extendOverload (E, x, yts, s) =
- extendVals (E, Ast.Vid.fromVar x, (Vid.Overload yts, s))
+val dummyStructure =
+ Trace.trace ("dummyStructure",
+ Interface.layout o #2,
+ Structure.layoutPretty o #1)
+ dummyStructure
+
+(* section 5.3, 5.5, 5.6 and rules 52, 53 *)
+fun cut (E: t, S: Structure.t, I: Interface.t, {opaque: bool}, region)
+ : Structure.t * Decs.t =
+ let
+ val decs = ref []
+ fun error (name, l) =
+ let
+ open Layout
+ in
+ Control.error
+ (region,
+ seq [str (concat [name, " "]), l,
+ str " in signature but not in structure"],
+ empty)
+ end
+ (* pre: arities are equal. *)
+ fun equalSchemes (s: Scheme.t, s': Scheme.t,
+ name: unit -> Layout.t,
+ r: Region.t): unit =
+ let
+ val (tyvars', ty') = Scheme.dest s'
+ val tyvars =
+ Vector.tabulate
+ (Vector.length tyvars', fn _ =>
+ Type.var (Tyvar.newNoname {equality = false}))
+ in
+ Type.unify
+ (Scheme.apply (s, tyvars),
+ Scheme.apply (Scheme.make {canGeneralize = true,
+ ty = ty',
+ tyvars = tyvars'},
+ tyvars),
+ fn (l1, l2) =>
+ let
+ open Layout
+ in
+ (r,
+ seq [str "type ", name (),
+ str " in structure disagrees with signature"],
+ align [seq [str "structure: ", l1],
+ seq [str "signature: ", l2]])
+ end)
+ end
+ val equalSchemes =
+ Trace.trace
+ ("equalSchemes",
+ fn (s, s', _, _) => Layout.tuple [Scheme.layout s,
+ Scheme.layout s'],
+ Unit.layout)
+ equalSchemes
+ fun checkCons (Cons.T v, Cons.T v', strids): unit =
+ let
+ fun lay (c: Ast.Con.t) =
+ Longcon.layout (Longcon.long (rev strids, c))
+ val extraStr =
+ Vector.keepAllMap
+ (v, fn {name = n, scheme = s, ...} =>
+ case Vector.peek (v', fn {name = n', ...} =>
+ Ast.Con.equals (n, n')) of
+ NONE => SOME n
+ | SOME {scheme = s', ...} =>
+ let
+ val _ =
+ equalSchemes
+ (s, s', fn () =>
+ let
+ open Layout
+ in
+ seq [str "of ", lay n]
+ end,
+ region)
+ in
+ NONE
+ end)
+ fun extras (v, name) =
+ if 0 = Vector.length v
+ then ()
+ else
+ let
+ open Layout
+ in
+ Control.error
+ (region,
+ seq [str (concat ["constructors in ", name, " only: "]),
+ seq (List.separate (Vector.toListMap (v, lay),
+ str ", "))],
+ empty)
+ end
+ val _ = extras (extraStr, "structure")
+ val extraSig =
+ Vector.keepAllMap
+ (v', fn {name = n', ...} =>
+ if Vector.exists (v, fn {name = n, ...} =>
+ Ast.Con.equals (n, n'))
+ then NONE
+ else SOME n')
+ val _ = extras (extraSig, "signature")
+ in
+ ()
+ end
+ val I' =
+ Interface.realize
+ (I, fn (c, a, k) =>
+ case Structure.peekLongtycon (S, c) of
+ NONE => (error ("type", Longtycon.layout c)
+ ; TypeStr.bogus k)
+ | SOME typeStr =>
+ let
+ val _ =
+ if AdmitsEquality.<= (a, TypeStr.admitsEquality typeStr)
+ then ()
+ else
+ let
+ open Layout
+ in
+ Control.error
+ (region,
+ seq [str "type ", Longtycon.layout c,
+ str " admits equality in signature but not in structure"],
+ empty)
+ end
+ val k' = TypeStr.kind typeStr
+ val typeStr =
+ if Kind.equals (k, k')
+ then typeStr
+ else
+ let
+ open Layout
+ val _ =
+ Control.error
+ (region,
+ seq [str "type ", Longtycon.layout c,
+ str "has arity ", Kind.layout k',
+ str "in structure but arity ",
+ Kind.layout k, str " in signature"],
+ empty)
+ in
+ TypeStr.bogus k
+ end
+ in
+ typeStr
+ end)
+ fun cut (S as Structure.T {shapeId, ...}, I, strids) =
+ let
+ val {addStr, addType, addVal, finish} = Structure.maker ()
+ val shapeId' = Interface.shapeId I
+ fun doit () =
+ let
+ fun handleStr {name, interface = I} =
+ case Structure.peekStrid' (S, name) of
+ NONE =>
+ error
+ ("structure",
+ Longstrid.layout
+ (Longstrid.long (rev strids, name)))
+ | SOME {range, values, ...} =>
+ addStr {range = cut (range, I, name :: strids),
+ values = values}
+ fun handleType {name: Ast.Tycon.t,
+ typeStr: TypeStr.t} =
+ let
+ fun layoutName () =
+ Longtycon.layout
+ (Longtycon.long (rev strids, name))
+ in
+ case Structure.peekTycon' (S, name) of
+ NONE => error ("type", layoutName ())
+ | SOME {range = typeStr', values, ...} =>
+ let
+ fun tyconScheme (c: Tycon.t): Scheme.t =
+ let
+ val tyvars =
+ case TypeStr.kind typeStr' of
+ Kind.Arity n =>
+ Vector.tabulate
+ (n, fn _ =>
+ Tyvar.newNoname
+ {equality = false})
+ | _ => Error.bug "Nary tycon"
+ in
+ Scheme.make
+ {canGeneralize = true,
+ ty = Type.con (c, Vector.map (tyvars, Type.var)),
+ tyvars = tyvars}
+ end
+ datatype z = datatype TypeStr.node
+ val k = TypeStr.kind typeStr
+ val k' = TypeStr.kind typeStr'
+ fun typeStrScheme (s: TypeStr.t) =
+ case TypeStr.node s of
+ Datatype {tycon, ...} =>
+ tyconScheme tycon
+ | Scheme s => s
+ | Tycon c' => tyconScheme c'
+ val typeStr =
+ if not (Kind.equals (k, k'))
+ then
+ let
+ open Layout
+ in
+ Control.error
+ (region,
+ seq [str "type ", layoutName (),
+ str " has arity ", Kind.layout k',
+ str " in structure but arity ", Kind.layout k,
+ str " in signature"],
+ empty)
+ ; typeStr
+ end
+ else
+ case TypeStr.node typeStr of
+ Datatype {cons = c, ...} =>
+ (case TypeStr.node typeStr' of
+ Datatype {cons = c', ...} =>
+ (checkCons (c', c,
+ strids)
+ ; typeStr')
+ | _ =>
+ let
+ open Layout
+ in
+ Control.error
+ (region,
+ seq [str "type ",
+ layoutName (),
+ str " is a datatype in signature but not in structure"],
+ Layout.empty)
+ ; typeStr
+ end)
+ | Scheme s =>
+ (equalSchemes
+ (typeStrScheme typeStr',
+ s, layoutName, region)
+ ; typeStr)
+ | Tycon c =>
+ (equalSchemes
+ (typeStrScheme typeStr',
+ tyconScheme c,
+ layoutName, region)
+ ; typeStr)
+ in
+ addType {range = typeStr,
+ values = values}
+ end
+ end
+ fun handleVal {name, scheme = s, status} =
+ case Structure.peekVid' (S, name) of
+ NONE =>
+ error ("variable",
+ Longvid.layout (Longvid.long
+ (rev strids, name)))
+ | SOME {range = (vid, s'), values, ...} =>
+ let
+ val (tyvars, t) = Scheme.dest s
+ val {args, instance = t'} =
+ Scheme.instantiate s'
+ val _ =
+ Type.unify
+ (t, t', fn (l, l') =>
+ let
+ open Layout
+ in
+ (region,
+ seq [str "type in structure disagrees with signature"],
+ align [seq [str "variable: ",
+ Longvid.layout
+ (Longvid.long
+ (rev strids, name))],
+ seq [str "structure: ", l'],
+ seq [str "signature: ", l]])
+ end)
+ fun addDec (n: Exp.node): Vid.t =
+ let
+ val x = Var.newNoname ()
+ val e = Exp.make (n, t')
+ val _ =
+ List.push
+ (decs,
+ Dec.Val
+ {rvbs = Vector.new0 (),
+ tyvars = fn () => tyvars,
+ vbs = (Vector.new1
+ {exp = e,
+ lay = fn _ => Layout.empty,
+ pat = Pat.var (x, t'),
+ patRegion = region})})
+ in
+ Vid.Var x
+ end
+ fun con (c: Con.t): Vid.t =
+ addDec (Exp.Con (c, args ()))
+ val vid =
+ case (vid, status) of
+ (Vid.Con c, Status.Var) => con c
+ | (Vid.Exn c, Status.Var) => con c
+ | (Vid.Var x, Status.Var) =>
+ if 0 < Vector.length tyvars
+ orelse 0 < Vector.length (args ())
+ then
+ addDec
+ (Exp.Var (fn () => x, args))
+ else vid
+ | (Vid.Con _, Status.Con) => vid
+ | (Vid.Exn _, Status.Exn) => vid
+ | _ =>
+ (Control.error
+ (region,
+ Layout.str
+ (concat
+ ["identifier ",
+ Longvid.toString
+ (Longvid.long (rev strids,
+ name)),
+ " is ",
+ Vid.statusPretty vid,
+ " in the structure but ",
+ Status.pretty status,
+ " in the signature "]),
+ Layout.empty)
+ ; vid)
+ in
+ addVal {range = (vid, s),
+ values = values}
+ end
+ val _ =
+ Interface.foreach
+ (I, {handleStr = handleStr,
+ handleType = handleType,
+ handleVal = handleVal})
+ in
+ finish (SOME shapeId')
+ end
+ in
+ case shapeId of
+ NONE => doit ()
+ | SOME shapeId =>
+ if ShapeId.equals (shapeId, shapeId')
+ then S
+ else doit ()
+ end
+ val S = cut (S, I', [])
+ val S =
+ if not opaque
+ then S
+ else
+ let
+ fun fixCons (Cons.T cs, Cons.T cs') =
+ Cons.T
+ (Vector.map
+ (cs', fn {con, name, scheme} =>
+ let
+ val con =
+ case Vector.peek (cs, fn {name = n, ...} =>
+ Ast.Con.equals (n, name)) of
+ NONE => Con.bogus
+ | SOME {con, ...} => con
+ in
+ {con = con, name = name, scheme = scheme}
+ end))
+ val (S', instantiate) = dummyStructure (E, I)
+ val _ = instantiate (S, fn (c, s) =>
+ TypeEnv.setOpaqueTyconExpansion
+ (c, fn ts => TypeStr.apply (s, ts)))
+ val {destroy,
+ get = replacements: (Structure.t
+ -> {formal: Structure.t,
+ new: Structure.t} list ref), ...} =
+ Property.destGet (Structure.plist,
+ Property.initFun (fn _ => ref []))
+ fun loop (S, S'): Structure.t =
+ let
+ val rs = replacements S
+ in
+ case List.peek (!rs, fn {formal, ...} =>
+ Structure.eq (S', formal)) of
+ NONE =>
+ let
+ val Structure.T {shapeId, strs, types, vals,
+ ...} = S
+ val Structure.T {strs = strs',
+ types = types',
+ vals = vals', ...} = S'
+ val strs = Info.map2 (strs, strs', loop)
+ val types =
+ Info.map2
+ (types, types', fn (s, s') =>
+ let
+ datatype z = datatype TypeStr.node
+ in
+ case TypeStr.node s' of
+ Datatype {cons = cs', tycon} =>
+ (case TypeStr.node s of
+ Datatype {cons = cs, ...} =>
+ TypeStr.data
+ (tycon, TypeStr.kind s',
+ fixCons (cs, cs'))
+ | _ => s')
+ | Scheme _ => s'
+ | Tycon _ => s'
+ end)
+ val vals =
+ Info.map2 (vals, vals', fn ((v, _), (_, s)) =>
+ (v, s))
+ val new =
+ Structure.T {plist = PropertyList.new (),
+ shapeId = shapeId,
+ strs = strs,
+ types = types,
+ vals = vals}
+ val _ = List.push (rs, {formal = S', new = new})
+ in
+ new
+ end
+ | SOME {new, ...} => new
+ end
+ val S'' = loop (S, S')
+ val _ = destroy ()
+ in
+ S''
+ end
+ in
+ (S, Decs.fromList (!decs))
+ end
-val extendVar =
- Trace.trace4
- ("extendVar", Layout.ignore, Ast.Var.layout, Var.layout, Scheme.layoutPretty,
- Unit.layout)
- extendVar
+val cut =
+ Trace.trace ("cut",
+ fn (_, S, I, _, _) =>
+ Layout.tuple [Structure.layoutPretty S, Interface.layout I],
+ Structure.layoutPretty o #1)
+ cut
-(* ------------------------------------------------- *)
-(* local *)
+(* ------------------------------------------------- *)
+(* functorClosure *)
(* ------------------------------------------------- *)
-local
- fun doit (info as NameSpace.T {current, ...}, s0) =
- let
- val old = !current
- val _ = current := []
- in
- fn () =>
+fun snapshot (T {currentScope, fcts, fixs, sigs, strs, types, vals}):
+ (unit -> 'a) -> 'a =
+ let
+ fun m l = Layout.outputl (l, Out.error)
+ open Layout
+ fun doit (NameSpace.T {current, table, ...}, lay) =
let
- val c1 = !current
- val _ = current := []
+ val all =
+ HashSet.fold
+ (table, [], fn (vs as Values.T {ranges, ...}, ac) =>
+ case !ranges of
+ [] => ac
+ | z :: _ => (z, vs) :: ac)
in
- fn () =>
+ fn s0 =>
let
- val c2 = !current
- val lift = List.map (c2, Values.pop)
- val _ = List.foreach (c1, fn v => (Values.pop v; ()))
- val _ = current := old
+ val current0 = !current
val _ =
- List.foreach2 (lift, c2, fn ({isUsed, value, ...}, values) =>
- NameSpace.update
- (info, s0, {isUsed = isUsed,
- range = value,
- values = values}))
- in
- ()
- end
- end
- end
-in
- fun localTop (T {currentScope, fcts, fixs, sigs, strs, types, vals, ...}, f) =
- let
- val s0 = !currentScope
- val fcts = doit (fcts, s0)
- val fixs = doit (fixs, s0)
- val sigs = doit (sigs, s0)
- val strs = doit (strs, s0)
- val types = doit (types, s0)
- val vals = doit (vals, s0)
- val _ = currentScope := Scope.new ()
- val a = f ()
- val fcts = fcts ()
- val fixs = fixs ()
- val sigs = sigs ()
- val strs = strs ()
- val types = types ()
- val vals = vals ()
- fun finish g =
- let
- val _ = currentScope := Scope.new ()
- val b = g ()
- val _ = (fcts (); fixs (); sigs (); strs (); types (); vals ())
- val _ = currentScope := s0
- in
- b
+ current :=
+ List.fold
+ (all, [], fn (({isUsed, value, ...},
+ vs as Values.T {ranges, ...}), ac) =>
+ (List.push (ranges, {isUsed = isUsed,
+ scope = s0,
+ value = value})
+ ; vs :: ac))
+ val removed =
+ HashSet.fold
+ (table, [], fn (Values.T {ranges, ...}, ac) =>
+ let
+ val r = !ranges
+ in
+ case r of
+ [] => ac
+ | {scope, ...} :: _ =>
+ if Scope.equals (s0, scope)
+ then ac
+ else (ranges := []
+ ; (ranges, r) :: ac)
+ end)
+ in fn () => (List.foreach (!current, fn v => (Values.pop v; ()))
+ ; current := current0
+ ; List.foreach (removed, op :=))
end
- in (a, finish)
- end
-
- fun localModule (T {currentScope, fixs, strs, types, vals, ...},
- f1, f2) =
+ end
+ val fcts = doit (fcts, Ast.Fctid.layout)
+ val fixs = doit (fixs, Ast.Vid.layout)
+ val sigs = doit (sigs, Ast.Sigid.layout)
+ val strs = doit (strs, Ast.Strid.layout)
+ val types = doit (types, Ast.Tycon.layout)
+ val vals = doit (vals, Ast.Vid.layout)
+ in
+ fn th =>
let
- val s0 = !currentScope
- val fixs = doit (fixs, s0)
- val strs = doit (strs, s0)
- val types = doit (types, s0)
- val vals = doit (vals, s0)
- val _ = currentScope := Scope.new ()
- val a1 = f1 ()
- val fixs = fixs ()
- val strs = strs ()
- val types = types ()
- val vals = vals ()
- val _ = currentScope := Scope.new ()
- val a2 = f2 a1
- val _ = (fixs (); strs (); types (); vals ())
+ val s0 = Scope.new ()
+ val fcts = fcts s0
+ val fixs = fixs s0
+ val sigs = sigs s0
+ val strs = strs s0
+ val types = types s0
+ val vals = vals s0
+ val s1 = !currentScope
val _ = currentScope := s0
+ val res = th ()
+ val _ = currentScope := s1
+ val _ = (fcts (); fixs (); sigs (); strs (); types (); vals ())
in
- a2
+ res
end
-
- (* Can't eliminate the use of strs in localCore, because openn still modifies
- * module level constructs.
- *)
- val localCore = localModule
-end
-
-fun makeStructure (T {currentScope, fixs, strs, types, vals, ...}, make) =
- let
- val f = NameSpace.collect (fixs, Ast.Vid.<=)
- val s = NameSpace.collect (strs, Ast.Strid.<=)
- val t = NameSpace.collect (types, Ast.Tycon.<=)
- val v = NameSpace.collect (vals, Ast.Vid.<=)
- val s0 = !currentScope
- val _ = currentScope := Scope.new ()
- val res = make ()
- val _ = f ()
- val S = Structure.T {plist = PropertyList.new (),
- shapeId = NONE,
- strs = s (),
- types = t (),
- vals = v ()}
- val _ = currentScope := s0
- in (res, S)
- end
-
-fun scope (T {currentScope, fixs, strs, types, vals, ...}, th) =
- let
- fun doit (NameSpace.T {current, ...}) =
- let
- val old = !current
- val _ = current := []
- in fn () => (List.foreach (!current, fn v => (Values.pop v; ()))
- ; current := old)
- end
- val s0 = !currentScope
- val _ = currentScope := Scope.new ()
- val f = doit fixs
- val s = doit strs
- val t = doit types
- val v = doit vals
- val res = th ()
- val _ = (f (); s (); t (); v ())
- val _ = currentScope := s0
- in res
end
-fun scopeAll (T {currentScope, fcts, fixs, sigs, strs, types, vals, ...}, th) =
+val useFunctorSummary = ref false
+
+fun functorClosure
+ (E: t,
+ argInt: Interface.t,
+ makeBody: Structure.t * string list -> Decs.t * Structure.t) =
let
- fun doit (NameSpace.T {current, ...}) =
+ val (formal, instantiate) = dummyStructure (E, argInt)
+ val _ = useFunctorSummary := true
+ (* Keep track of all tycons created during the instantiation of the
+ * functor. These will later become the generative tycons that will need
+ * to be recreated for each functor application.
+ *)
+ val _ = newTycons := []
+ val (_, res) = makeBody (formal, [])
+ val generative = !newTycons
+ val _ = newTycons := []
+ val _ = useFunctorSummary := false
+ val restore = snapshot E
+ fun apply (arg, nest, region) =
let
- val old = !current
- val _ = current := []
- in fn () => (List.foreach (!current, fn v => (Values.pop v; ()))
- ; current := old)
+ val (actual, decs) = cut (E, arg, argInt, {opaque = false}, region)
+ in
+ if !useFunctorSummary
+ then
+ let
+ val {destroy = destroy1,
+ get = tyconTypeStr: Tycon.t -> TypeStr.t option,
+ set = setTyconTypeStr, ...} =
+ Property.destGetSet (Tycon.plist,
+ Property.initConst NONE)
+ (* Match the actual against the formal, to set the tycons.
+ * Then duplicate the res, replacing tycons.
+ * Want to generate new tycons just like the functor body
+ * did.
+ *)
+ val _ =
+ instantiate (actual, fn (c, s) =>
+ setTyconTypeStr (c, SOME s))
+ val _ =
+ List.foreach
+ (generative, fn (c, k) =>
+ setTyconTypeStr
+ (c, SOME (TypeStr.tycon
+ (newTycon (Tycon.originalName c, k),
+ k))))
+ fun replaceType (t: Type.t): Type.t =
+ let
+ fun con (c, ts) =
+ case tyconTypeStr c of
+ NONE => Type.con (c, ts)
+ | SOME s => TypeStr.apply (s, ts)
+ in
+ Type.hom (t, {con = con,
+ expandOpaque = Type.Never,
+ record = Type.record,
+ var = Type.var})
+ end
+ fun replaceScheme (s: Scheme.t): Scheme.t =
+ let
+ val (tyvars, ty) = Scheme.dest s
+ in
+ Scheme.make {canGeneralize = true,
+ ty = replaceType ty,
+ tyvars = tyvars}
+ end
+ fun replaceCons (Cons.T v): Cons.t =
+ Cons.T
+ (Vector.map
+ (v, fn {con, name, scheme} =>
+ {con = con,
+ name = name,
+ scheme = replaceScheme scheme}))
+ fun replaceTypeStr (s: TypeStr.t): TypeStr.t =
+ let
+ val k = TypeStr.kind s
+ datatype z = datatype TypeStr.node
+ in
+ case TypeStr.node s of
+ Datatype {cons, tycon} =>
+ let
+ val tycon =
+ case tyconTypeStr tycon of
+ NONE => tycon
+ | SOME s =>
+ (case TypeStr.node s of
+ Datatype {tycon, ...} => tycon
+ | Scheme _ =>
+ Error.bug "bad datatype"
+ | Tycon c => c)
+ in
+ TypeStr.data (tycon, k, replaceCons cons)
+ end
+ | Scheme s => TypeStr.def (replaceScheme s, k)
+ | Tycon c =>
+ (case tyconTypeStr c of
+ NONE => s
+ | SOME s' => s')
+ end
+ val {destroy = destroy2,
+ get = replacement: Structure.t -> Structure.t, ...} =
+ Property.destGet
+ (Structure.plist,
+ Property.initRec
+ (fn (Structure.T {shapeId, strs, types, vals, ... },
+ replacement) =>
+ Structure.T
+ {plist = PropertyList.new (),
+ shapeId = shapeId,
+ strs = Info.map (strs, replacement),
+ types = Info.map (types, replaceTypeStr),
+ vals = Info.map (vals, fn (v, s) =>
+ (v, replaceScheme s))}))
+ val res = replacement res
+ val _ = destroy1 ()
+ val _ = destroy2 ()
+ in
+ (Decs.empty, res)
+ end
+ else
+ let
+ val (decs', str) = restore (fn () => makeBody (actual, nest))
+ in
+ (Decs.append (decs, decs'),
+ str)
+ end
end
- val s0 = !currentScope
- val _ = currentScope := Scope.new ()
- val fc = doit fcts
- val f = doit fixs
- val si = doit sigs
- val s = doit strs
- val t = doit types
- val v = doit vals
- val res = th ()
- val _ = (fc (); f (); si (); s (); t (); v ())
- val _ = currentScope := s0
+ val apply =
+ Trace.trace ("functorApply",
+ Structure.layout o #1,
+ Layout.tuple2 (Layout.ignore, Structure.layout))
+ apply
+ fun sizeMessage () = layoutSize apply
+ val fc =
+ FunctorClosure.T {apply = apply,
+ sizeMessage = sizeMessage}
in
- res
- end
-
-fun openStructure (T {currentScope, strs, vals, types, ...},
- Structure.T {strs = strs',
- vals = vals',
- types = types', ...}): unit =
- let
- val scope = !currentScope
- fun doit (info, Info.T a) =
- Array.foreach (a, fn z => NameSpace.update (info, scope, z))
- in doit (strs, strs')
- ; doit (vals, vals')
- ; doit (types, types')
+ fc
end
end
1.12 +6 -6 mlton/mlton/elaborate/elaborate-env.sig
Index: elaborate-env.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-env.sig,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- elaborate-env.sig 11 Nov 2003 21:26:34 -0000 1.11
+++ elaborate-env.sig 14 Nov 2003 03:48:18 -0000 1.12
@@ -67,12 +67,6 @@
sig
type t
- (* cut keeps only those bindings in the structure that also appear
- * in the interface. It proceeds recursively on substructures.
- *)
- val cut: t * {interface: Interface.t,
- opaque: bool,
- region: Region.t} -> t * Decs.t
(* ffi represents MLtonFFI, which is built by the basis library
* and is set in compile.sml after processing the basis.
*)
@@ -90,6 +84,12 @@
(* Remove unnecessary entries. *)
val clean: t -> unit
+ (* cut keeps only those bindings in the structure that also appear
+ * in the interface. It proceeds recursively on substructures.
+ *)
+ val cut:
+ t * Structure.t * Interface.t * {opaque: bool} * Region.t
+ -> Structure.t * Decs.t
val empty: unit -> t
val extendCon: t * Ast.Con.t * CoreML.Con.t * Scheme.t -> unit
val extendExn: t * Ast.Con.t * CoreML.Con.t * Scheme.t -> unit
1.5 +160 -168 mlton/mlton/elaborate/elaborate-sigexp.fun
Index: elaborate-sigexp.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-sigexp.fun,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- elaborate-sigexp.fun 7 Nov 2003 23:45:22 -0000 1.4
+++ elaborate-sigexp.fun 14 Nov 2003 03:48:18 -0000 1.5
@@ -45,6 +45,7 @@
local
open TypeStr
in
+ structure AdmitsEquality = AdmitsEquality
structure Cons = Cons
structure Kind = Kind
structure Scheme = Scheme
@@ -52,12 +53,6 @@
structure Type = Type
end
-local
- open Tycon
-in
- structure AdmitsEquality = AdmitsEquality
-end
-
fun lookupLongtycon (E: Env.t,
I: Interface.t,
c: Ast.Longtycon.t): TypeStr.t =
@@ -307,169 +302,166 @@
(* rule 65 *)
fun elaborateSigexp (sigexp: Sigexp.t, E: Env.t): Interface.t =
- case Sigexp.node sigexp of
- Sigexp.Var s => Env.lookupSigid (E, s)
- | _ =>
- let
- fun elaborateSigexp arg : Interface.t =
- Trace.traceInfo' (info,
- Layout.tuple2 (Sigexp.layout,
- Interface.layout),
- Interface.layout)
- (fn (sigexp: Sigexp.t, I: Interface.t) =>
- case Sigexp.node sigexp of
- Sigexp.Spec spec => (* rule 62 *)
- elaborateSpec (spec, I)
- | Sigexp.Var x => (* rule 63 *)
- Interface.copy (Env.lookupSigid (E, x))
- | Sigexp.Where (sigexp, wheres) => (* rule 64 *)
- let
- val I' = elaborateSigexp (sigexp, I)
- val _ =
- Interface.wheres
- (I',
- Vector.fromListMap
- (wheres, fn {tyvars, longtycon, ty} =>
- (longtycon,
- TypeStr.def
- (Scheme.make (elaborateType (ty, E, I)),
- Kind.Arity (Vector.length tyvars)))))
- in
- I'
- end) arg
- and elaborateSpec arg : Interface.t =
- Trace.traceInfo' (info',
- Layout.tuple2 (Ast.Spec.layout, Layout.ignore),
- Layout.ignore)
- (fn (spec: Ast.Spec.t, I: Interface.t) =>
- case Spec.node spec of
- Spec.Datatype rhs => (* rules 71, 72 *)
- (case DatatypeRhs.node rhs of
- DatatypeRhs.DatBind b => elaborateDatBind (b, E, I)
- | DatatypeRhs.Repl {lhs, rhs} =>
- let
- val s = lookupLongtycon (E, I, rhs)
- in
- Interface.+
- (Interface.types (Vector.new1 {name = lhs,
- typeStr = s}),
- Interface.cons (TypeStr.cons s))
- end)
- | Spec.Empty => (* rule 76 *)
- Interface.empty
- | Spec.Eqtype typedescs => (* rule 70 *)
- elaborateTypedescs (typedescs, {equality = true})
- | Spec.Exception cons => (* rule 73 *)
- Interface.excons
- (Cons.T
- (Vector.fromListMap
- (cons, fn (name: TypeStr.Name.t,
- arg: Ast.Type.t option) =>
- let
- val con = Con.newNoname ()
- val (arg, ty) =
- case arg of
- NONE => (NONE, Type.exn)
- | SOME t =>
- let
- val t =
- Scheme.ty
- (elaborateScheme (Vector.new0 (),
- t, E, I))
- in
- (SOME t, Type.arrow (t, Type.exn))
- end
- in
- {con = con: TypeStr.Con.t,
- name= name: TypeStr.Name.t,
- scheme = Scheme.make (Vector.new0 (), ty)}
- end)))
- | Spec.IncludeSigexp sigexp => (* rule 75 *)
- elaborateSigexp (sigexp, I)
- | Spec.IncludeSigids sigids => (* Appendix A, p.59 *)
- List.fold
- (sigids, Interface.empty, fn (sigid, I) =>
- Interface.+
- (I, Interface.copy (Env.lookupSigid (E, sigid))))
- | Spec.Seq (s, s') => (* rule 77 *)
- let
- val I' = elaborateSpec (s, I)
- val I'' = elaborateSpec (s', Interface.+ (I', I))
- in
- Interface.+ (I', I'')
- end
- | Spec.Sharing {equations, spec} =>
- (* rule 78 and section G.3.3 *)
- let
- val I' = elaborateSpec (spec, I)
- fun share eqn =
- case Equation.node eqn of
- Equation.Structure ss =>
- let
- fun loop ss =
- case ss of
- [] => ()
- | s :: ss =>
- (List.foreach
- (ss, fn s' =>
- Interface.share (I', s, s'))
- ; loop ss)
- in
- loop ss
- end
- | Equation.Type cs =>
- case cs of
+ let
+ fun elaborateSigexp arg : Interface.t =
+ Trace.traceInfo' (info,
+ Layout.tuple2 (Sigexp.layout,
+ Interface.layout),
+ Interface.layout)
+ (fn (sigexp: Sigexp.t, I: Interface.t) =>
+ case Sigexp.node sigexp of
+ Sigexp.Spec spec => (* rule 62 *)
+ elaborateSpec (spec, I)
+ | Sigexp.Var x => (* rule 63 *)
+ Interface.copy (Env.lookupSigid (E, x))
+ | Sigexp.Where (sigexp, wheres) => (* rule 64 *)
+ let
+ val I' = elaborateSigexp (sigexp, I)
+ val _ =
+ Interface.wheres
+ (I',
+ Vector.fromListMap
+ (wheres, fn {tyvars, longtycon, ty} =>
+ (longtycon,
+ TypeStr.def
+ (Scheme.make (elaborateType (ty, E, I)),
+ Kind.Arity (Vector.length tyvars)))))
+ in
+ I'
+ end) arg
+ and elaborateSpec arg : Interface.t =
+ Trace.traceInfo' (info',
+ Layout.tuple2 (Ast.Spec.layout, Layout.ignore),
+ Layout.ignore)
+ (fn (spec: Ast.Spec.t, I: Interface.t) =>
+ case Spec.node spec of
+ Spec.Datatype rhs => (* rules 71, 72 *)
+ (case DatatypeRhs.node rhs of
+ DatatypeRhs.DatBind b => elaborateDatBind (b, E, I)
+ | DatatypeRhs.Repl {lhs, rhs} =>
+ let
+ val s = lookupLongtycon (E, I, rhs)
+ in
+ Interface.+
+ (Interface.types (Vector.new1 {name = lhs,
+ typeStr = s}),
+ Interface.cons (TypeStr.cons s))
+ end)
+ | Spec.Empty => (* rule 76 *)
+ Interface.empty
+ | Spec.Eqtype typedescs => (* rule 70 *)
+ elaborateTypedescs (typedescs, {equality = true})
+ | Spec.Exception cons => (* rule 73 *)
+ Interface.excons
+ (Cons.T
+ (Vector.fromListMap
+ (cons, fn (name: TypeStr.Name.t,
+ arg: Ast.Type.t option) =>
+ let
+ val con = Con.newNoname ()
+ val (arg, ty) =
+ case arg of
+ NONE => (NONE, Type.exn)
+ | SOME t =>
+ let
+ val t =
+ Scheme.ty
+ (elaborateScheme (Vector.new0 (),
+ t, E, I))
+ in
+ (SOME t, Type.arrow (t, Type.exn))
+ end
+ in
+ {con = con: TypeStr.Con.t,
+ name= name: TypeStr.Name.t,
+ scheme = Scheme.make (Vector.new0 (), ty)}
+ end)))
+ | Spec.IncludeSigexp sigexp => (* rule 75 *)
+ elaborateSigexp (sigexp, I)
+ | Spec.IncludeSigids sigids => (* Appendix A, p.59 *)
+ List.fold
+ (sigids, Interface.empty, fn (sigid, I) =>
+ Interface.+
+ (I, Interface.copy (Env.lookupSigid (E, sigid))))
+ | Spec.Seq (s, s') => (* rule 77 *)
+ let
+ val I' = elaborateSpec (s, I)
+ val I'' = elaborateSpec (s', Interface.+ (I', I))
+ in
+ Interface.+ (I', I'')
+ end
+ | Spec.Sharing {equations, spec} =>
+ (* rule 78 and section G.3.3 *)
+ let
+ val I' = elaborateSpec (spec, I)
+ fun share eqn =
+ case Equation.node eqn of
+ Equation.Structure ss =>
+ let
+ fun loop ss =
+ case ss of
[] => ()
- | c :: cs =>
- List.foreach
- (cs, fn c' =>
- Interface.shareType (I', c, c'))
- val _ = List.foreach (equations, share)
- in
- I'
- end
- | Spec.Structure ss => (* rules 74, 84 *)
- Interface.strs
- (Vector.fromListMap
- (ss, fn (strid, sigexp) =>
- {interface = elaborateSigexp (sigexp, I),
- name = strid}))
- | Spec.Type typedescs => (* rule 69 *)
- elaborateTypedescs (typedescs, {equality = false})
- | Spec.TypeDefs typBind =>
- (* Abbreviation on page 59,
- * combined with rules 77 and 80.
- *)
- let
- val TypBind.T ds = TypBind.node typBind
- in
- #2
- (List.fold
- (ds, (I, Interface.empty),
- fn ({def, tycon, tyvars}, (I, I')) =>
- let
- val I'' =
- Interface.types
- (Vector.new1
- {name = tycon,
- typeStr = (TypeStr.def
- (elaborateScheme (tyvars, def, E, I),
- Kind.Arity (Vector.length tyvars)))})
- in
- (Interface.+ (I, I''), Interface.+ (I', I''))
- end))
- end
- | Spec.Val xts => (* rules 68, 79 *)
- Interface.vals
- (Vector.fromListMap
- (xts, fn (x, t) =>
- {name = Ast.Vid.fromVar x,
- scheme = Scheme.make (elaborateType (t, E, I)),
- status = Status.Var}))
- ) arg
- in
- elaborateSigexp (sigexp, Interface.empty)
- end
+ | s :: ss =>
+ (List.foreach
+ (ss, fn s' =>
+ Interface.share (I', s, s'))
+ ; loop ss)
+ in
+ loop ss
+ end
+ | Equation.Type cs =>
+ case cs of
+ [] => ()
+ | c :: cs =>
+ List.foreach
+ (cs, fn c' =>
+ Interface.shareType (I', c, c'))
+ val _ = List.foreach (equations, share)
+ in
+ I'
+ end
+ | Spec.Structure ss => (* rules 74, 84 *)
+ Interface.strs
+ (Vector.fromListMap
+ (ss, fn (strid, sigexp) =>
+ {interface = elaborateSigexp (sigexp, I),
+ name = strid}))
+ | Spec.Type typedescs => (* rule 69 *)
+ elaborateTypedescs (typedescs, {equality = false})
+ | Spec.TypeDefs typBind =>
+ (* Abbreviation on page 59,
+ * combined with rules 77 and 80.
+ *)
+ let
+ val TypBind.T ds = TypBind.node typBind
+ in
+ #2
+ (List.fold
+ (ds, (I, Interface.empty),
+ fn ({def, tycon, tyvars}, (I, I')) =>
+ let
+ val I'' =
+ Interface.types
+ (Vector.new1
+ {name = tycon,
+ typeStr = (TypeStr.def
+ (elaborateScheme (tyvars, def, E, I),
+ Kind.Arity (Vector.length tyvars)))})
+ in
+ (Interface.+ (I, I''), Interface.+ (I', I''))
+ end))
+ end
+ | Spec.Val xts => (* rules 68, 79 *)
+ Interface.vals
+ (Vector.fromListMap
+ (xts, fn (x, t) =>
+ {name = Ast.Vid.fromVar x,
+ scheme = Scheme.make (elaborateType (t, E, I)),
+ status = Status.Var}))
+ ) arg
+ in
+ elaborateSigexp (sigexp, Interface.empty)
+ end
val elaborateSigexp =
Trace.trace2 ("elaborateSigexp",
1.10 +2 -3 mlton/mlton/elaborate/elaborate.fun
Index: elaborate.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate.fun,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- elaborate.fun 10 Nov 2003 23:01:59 -0000 1.9
+++ elaborate.fun 14 Nov 2003 03:48:18 -0000 1.10
@@ -86,9 +86,8 @@
fun s (sigexp, opaque) =
let
val (S, decs) =
- Structure.cut (S, {interface = elabSigexp sigexp,
- opaque = opaque,
- region = Sigexp.region sigexp})
+ Env.cut (E, S, elabSigexp sigexp, {opaque = opaque},
+ Sigexp.region sigexp)
in
(decs, S)
end
1.3 +3 -3 mlton/mlton/elaborate/interface.fun
Index: interface.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/interface.fun,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- interface.fun 7 Nov 2003 23:45:22 -0000 1.2
+++ interface.fun 14 Nov 2003 03:48:18 -0000 1.3
@@ -26,6 +26,7 @@
local
open EtypeStr
in
+ structure AdmitsEquality = AdmitsEquality
structure Con = Con
structure Econs = Cons
structure Kind = Kind
@@ -34,8 +35,6 @@
structure Etype = Type
end
-structure AdmitsEquality = Etycon.AdmitsEquality
-
structure Set = DisjointSet
structure ShapeId = UniqueId ()
@@ -422,7 +421,8 @@
end
end
-structure TypeStr = TypeStr (structure Con = Con
+structure TypeStr = TypeStr (structure AdmitsEquality = AdmitsEquality
+ structure Con = Con
structure Kind = Kind
structure Name = Ast.Con
structure Record = Record
1.3 +1 -1 mlton/mlton/elaborate/interface.sig
Index: interface.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/interface.sig,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- interface.sig 7 Nov 2003 23:45:22 -0000 1.2
+++ interface.sig 14 Nov 2003 03:48:18 -0000 1.3
@@ -99,7 +99,7 @@
val plist: t -> PropertyList.t
(* realize makes a copy, and instantiate longtycons *)
val realize: t * (Ast.Longtycon.t
- * TypeStr.Tycon.AdmitsEquality.t
+ * TypeStr.AdmitsEquality.t
* TypeStr.Kind.t -> EnvTypeStr.t) -> t
val shapeId: t -> ShapeId.t
val share: t * Ast.Longstrid.t * Ast.Longstrid.t -> unit
1.11 +59 -9 mlton/mlton/elaborate/type-env.fun
Index: type-env.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/type-env.fun,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- type-env.fun 7 Nov 2003 00:21:28 -0000 1.10
+++ type-env.fun 14 Nov 2003 03:48:18 -0000 1.11
@@ -460,8 +460,23 @@
fun union (T s, T s') = Set.union (s, s')
fun set (T s, v) = Set.setValue (s, v)
-
- fun makeHom {con, flexRecord, genFlexRecord, int, real,
+
+ val {get = opaqueTyconExpansion: Tycon.t -> (t vector -> t) option,
+ set = setOpaqueTyconExpansion, ...} =
+ Property.getSet (Tycon.plist, Property.initConst NONE)
+
+ val opaqueTyconExpansion =
+ Trace.trace ("opaqueTyconExpansion",
+ Tycon.layout,
+ Layout.ignore)
+ opaqueTyconExpansion
+
+ datatype expandOpaque =
+ Always
+ | Never
+ | Sometimes of Tycon.t -> bool
+
+ fun makeHom {con, expandOpaque, flexRecord, genFlexRecord, int, real,
record, recursive, unknown, var, word} =
let
datatype status = Processing | Seen | Unseen
@@ -486,7 +501,20 @@
val res =
case toType t of
Con (c, ts) =>
- con (t, c, Vector.map (ts, get))
+ let
+ fun no () =
+ con (t, c, Vector.map (ts, get))
+ fun yes () =
+ (case opaqueTyconExpansion c of
+ NONE => no ()
+ | SOME f => get (f ts))
+ in
+ case expandOpaque of
+ Always => yes ()
+ | Never => no ()
+ | Sometimes f =>
+ if f c then yes () else no ()
+ end
| Int => int t
| FlexRecord {fields, spine, time} =>
flexRecord (t, {fields = loopFields fields,
@@ -576,6 +604,7 @@
fun word _ = simple (str "word")
val (res, _) =
hom (t, {con = con,
+ expandOpaque = Never,
flexRecord = flexRecord,
genFlexRecord = genFlexRecord,
int = int,
@@ -669,6 +698,9 @@
fun var a = newTy (Var a, Equality.fromBool (Tyvar.isEquality a))
end
+fun setOpaqueTyconExpansion (c, f) =
+ Type.setOpaqueTyconExpansion (c, SOME f)
+
structure Ops = TypeOps (structure IntSize = IntSize
structure Tycon = Tycon
structure WordSize = WordSize
@@ -773,6 +805,7 @@
val {destroy, hom} =
makeHom
{con = fn _ => (),
+ expandOpaque = Never,
flexRecord = fn (_, {time = r, ...}) => doit r,
genFlexRecord = fn _ => (),
int = fn _ => (),
@@ -1115,15 +1148,16 @@
| UnifyResult.Unified => Unified
val word8 = word WordSize.W8
-
+
fun 'a simpleHom {con: t * Tycon.t * 'a vector -> 'a,
+ expandOpaque: expandOpaque,
record: t * (Field.t * 'a) vector -> 'a,
replaceCharWithWord8: bool,
var: t * Tyvar.t -> 'a} =
let
val con =
fn (t, c, ts) =>
- if replaceCharWithWord8 andalso Tycon.equals (c, Tycon.char)
+ if replaceCharWithWord8 andalso Tycon.equals (c, Tycon.char)
then con (word8, Tycon.word WordSize.W8, Vector.new0 ())
else con (t, c, ts)
val unit = con (unit, Tycon.tuple, Vector.new0 ())
@@ -1160,6 +1194,7 @@
con (word WordSize.default, Tycon.defaultWord, Vector.new0 ())
in
makeHom {con = con,
+ expandOpaque = expandOpaque,
int = fn _ => int,
flexRecord = flexRecord,
genFlexRecord = genFlexRecord,
@@ -1281,9 +1316,10 @@
| SOME ty => {isNew = true, ty = ty}
val {ty: Type.t, ...} =
Type.hom (ty, {con = con,
- int = keep,
+ expandOpaque = Never,
flexRecord = keep o #1,
genFlexRecord = genFlexRecord,
+ int = keep,
real = keep,
record = record,
recursive = recursive,
@@ -1365,6 +1401,7 @@
exception Yes
val {destroy, hom} =
Type.makeHom {con = fn _ => (),
+ expandOpaque = Type.Never,
flexRecord = fn _ => (),
genFlexRecord = fn _ => (),
int = fn _ => (),
@@ -1534,7 +1571,7 @@
struct
open Type
- fun homConVar {con, var} =
+ fun homConVar {con, expandOpaque, var} =
let
fun tuple (t, ts) =
if 1 = Vector.length ts
@@ -1542,13 +1579,15 @@
else con (t, Tycon.tuple, ts)
in
simpleHom {con = con,
+ expandOpaque = expandOpaque,
record = fn (t, fs) => tuple (t, Vector.map (fs, #2)),
replaceCharWithWord8 = true,
var = var}
end
- fun makeHom {con, var} =
+ fun makeHom {con, expandOpaque, var} =
homConVar {con = fn (_, c, ts) => con (c, ts),
+ expandOpaque = expandOpaque,
var = fn (_, a) => var a}
fun deRecord t =
@@ -1556,6 +1595,7 @@
val {hom, destroy} =
simpleHom
{con = fn (t, _, _) => (t, NONE),
+ expandOpaque = Never,
record = fn (t, fs) => (t,
SOME (Vector.map (fs, fn (f, (t, _)) =>
(f, t)))),
@@ -1578,6 +1618,7 @@
if Tycon.equals (c, Tycon.tuple)
then SOME (Vector.map (ts, #1))
else NONE),
+ expandOpaque = Never,
var = fn (t, _) => (t, NONE)}
val res = #2 (hom t)
val _ = destroy ()
@@ -1592,10 +1633,11 @@
val deTuple = valOf o deTupleOpt
- fun hom (t, {con, record, var}) =
+ fun hom (t, {con, expandOpaque, record, var}) =
let
val {hom, destroy} =
simpleHom {con = fn (_, c, v) => con (c, v),
+ expandOpaque = expandOpaque,
record = fn (_, fs) => record (Srecord.fromVector fs),
replaceCharWithWord8 = false,
var = fn (_, a) => var a}
@@ -1605,6 +1647,13 @@
res
end
+ fun expandOpaque (t: t, e): t =
+ hom (t, {con = con, expandOpaque = e, record = record, var = var})
+
+ val expandOpaque =
+ Trace.trace ("expandOpaque", layoutPretty o #1, layoutPretty)
+ expandOpaque
+
val unify =
fn (t1: t, t2: t,
f: Layout.t * Layout.t -> Region.t * Layout.t * Layout.t) =>
@@ -1612,4 +1661,5 @@
NotUnifiable z => Control.error (f z)
| Unified => ()
end
+
end
1.6 +8 -0 mlton/mlton/elaborate/type-env.sig
Index: type-env.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/type-env.sig,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- type-env.sig 7 Nov 2003 00:21:28 -0000 1.5
+++ type-env.sig 14 Nov 2003 03:48:18 -0000 1.6
@@ -26,10 +26,17 @@
val deEta: t * Tyvar.t vector -> Tycon.t option
val deRecord: t -> (Record.Field.t * t) vector
val flexRecord: t SortedRecord.t -> t * (unit -> bool)
+ datatype expandOpaque =
+ Always
+ | Never
+ | Sometimes of Tycon.t -> bool
+ val expandOpaque: t * expandOpaque -> t
val hom: t * {con: Tycon.t * 'a vector -> 'a,
+ expandOpaque: expandOpaque,
record: 'a SortedRecord.t -> 'a,
var: Tyvar.t -> 'a} -> 'a
val makeHom: {con: Tycon.t * 'a vector -> 'a,
+ expandOpaque: expandOpaque,
var: Tyvar.t -> 'a} -> {destroy: unit -> unit,
hom: t -> 'a}
val isUnit: t -> bool
@@ -84,6 +91,7 @@
-> {bound: unit -> Tyvar.t vector,
schemes: Scheme.t vector}
val closeTop: Region.t -> unit
+ val setOpaqueTyconExpansion: Tycon.t * (Type.t vector -> Type.t) -> unit
val tyconAdmitsEquality: Tycon.t -> Tycon.AdmitsEquality.t ref
end
1.2 +14 -0 mlton/mlton/elaborate/type-str.fun
Index: type-str.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/type-str.fun,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- type-str.fun 7 Nov 2003 00:21:28 -0000 1.1
+++ type-str.fun 14 Nov 2003 03:48:18 -0000 1.2
@@ -10,6 +10,12 @@
open S
+local
+ open Tycon
+in
+ structure AdmitsEquality = AdmitsEquality
+end
+
structure Cons =
struct
datatype t = T of {con: Con.t,
@@ -55,6 +61,14 @@
| Scheme s => Scheme.layout s
| Tycon t => seq [str "Tycon ", Tycon.layout t]
end
+
+fun admitsEquality (s: t): AdmitsEquality.t =
+ case node s of
+ Datatype {tycon = c, ...} => ! (Tycon.admitsEquality c)
+ | Scheme s => if Scheme.admitsEquality s
+ then AdmitsEquality.Sometimes
+ else AdmitsEquality.Never
+ | Tycon c => ! (Tycon.admitsEquality c)
fun bogus (k: Kind.t): t =
T {kind = k,
1.3 +2 -2 mlton/mlton/elaborate/type-str.sig
Index: type-str.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/type-str.sig,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- type-str.sig 7 Nov 2003 23:45:22 -0000 1.2
+++ type-str.sig 14 Nov 2003 03:48:18 -0000 1.3
@@ -7,6 +7,7 @@
*)
signature TYPE_STR_STRUCTS =
sig
+ structure AdmitsEquality: ADMITS_EQUALITY
structure Con:
sig
type t
@@ -23,8 +24,6 @@
end
structure Tycon:
sig
- structure AdmitsEquality: ADMITS_EQUALITY
-
type t
val admitsEquality: t -> AdmitsEquality.t ref
@@ -93,6 +92,7 @@
| Tycon of Tycon.t
val abs: t -> t
+ val admitsEquality: t -> AdmitsEquality.t
val apply: t * Type.t vector -> Type.t
val bogus: Kind.t -> t
val cons: t -> Cons.t
1.10 +6 -0 mlton/mlton/main/compile.fun
Index: compile.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/main/compile.fun,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- compile.fun 11 Nov 2003 21:25:57 -0000 1.9
+++ compile.fun 14 Nov 2003 03:48:18 -0000 1.10
@@ -49,6 +49,12 @@
struct
open TypeEnv.Type
+ val makeHom =
+ fn {con, var} =>
+ makeHom {con = con,
+ expandOpaque = Always,
+ var = var}
+
val layout = layoutPretty
end)
structure Xml = Xml (open Atoms)