[MLton] cvs commit: new front end
sweeks@mlton.org
sweeks@mlton.org
Mon, 10 Nov 2003 15:02:12 -0800
sweeks 03/11/10 15:02:00
Modified: mlton/elaborate elaborate-core.fun elaborate-env.fun
elaborate-env.sig elaborate.fun
Log:
The next phase in the new front end: matching value and constructor
specs in signatures. It was pretty straightforward, requiring only
some unification. Then only trickiness is that signature matching
needs to introduce value declarations to reparameterize values whose
type scheme changes. For example, if we have in a structure
val ('a, 'b) f: unit -> ('a list * 'b list) = fn () => ([], [])
and are matching that against the spec
val f: unit -> ('c list * 'c list)
then signature matching has to introduce a new value that takes one
type argument ('c) and applies f to two type arguments ('c, 'c).
This checkin also fixes the bug that Jesper and Joe ran into that I
mentioned in a prior checkin. So the following now works.
structure S:
sig
val f: 'a list -> 'a list
end =
struct
fun f _ = []
end
val z = S.f [1, 2, 3]
All that's left to get a viable new front end is:
* Opaque signature matches
* Speeding up functor checking with summaries
Revision Changes Path
1.46 +1 -2 mlton/mlton/elaborate/elaborate-core.fun
Index: elaborate-core.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-core.fun,v
retrieving revision 1.45
retrieving revision 1.46
diff -u -r1.45 -r1.46
--- elaborate-core.fun 7 Nov 2003 22:59:41 -0000 1.45
+++ elaborate-core.fun 10 Nov 2003 23:01:59 -0000 1.46
@@ -1937,8 +1937,7 @@
fun con c = Cexp.Con (c, args ())
val e =
case vid of
- Vid.ConAsVar c => con c
- | Vid.Con c => con c
+ Vid.Con c => con c
| Vid.Exn c => con c
| Vid.Overload yts =>
let
1.19 +149 -31 mlton/mlton/elaborate/elaborate-env.fun
Index: elaborate-env.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-env.fun,v
retrieving revision 1.18
retrieving revision 1.19
diff -u -r1.18 -r1.19
--- elaborate-env.fun 7 Nov 2003 23:45:22 -0000 1.18
+++ elaborate-env.fun 10 Nov 2003 23:01:59 -0000 1.19
@@ -25,13 +25,16 @@
open CoreML
in
structure Con = Con
- structure Var = Var
+ structure Dec = Dec
+ structure Exp = Exp
+ structure Pat = Pat
structure Prim = Prim
structure Record = Record
structure SortedRecord = SortedRecord
structure Tycon = Tycon
structure Tyvar = Tyvar
structure Var = Var
+ structure Var = Var
end
structure Kind = Tycon.Kind
@@ -60,14 +63,18 @@
struct
datatype t =
Con of Con.t
- | ConAsVar of Con.t
| Exn of Con.t
| Overload of (Var.t * Type.t) vector
| Var of Var.t
+ val statusPretty =
+ fn Con _ => "a constructor"
+ | Exn _ => "an exception"
+ | Overload _ => "an overload"
+ | Var _ => "a variable"
+
val statusString =
fn Con _ => "con"
- | ConAsVar _ => "var"
| Exn _ => "exn"
| Overload _ => "var"
| Var _ => "var"
@@ -80,7 +87,6 @@
val (name, l) =
case vid of
Con c => ("Con", Con.layout c)
- | ConAsVar c => ("ConAsVar", Con.layout c)
| Exn c => ("Exn", Con.layout c)
| Overload xts =>
("Overload",
@@ -175,6 +181,12 @@
end
structure Tyvar = Tyvar)
+local
+ open TypeStr
+in
+ structure Cons = Cons
+end
+
structure Interface = Interface (structure Ast = Ast
structure EnvTypeStr = TypeStr)
@@ -185,6 +197,16 @@
structure Status = Status
end
+structure Status =
+ struct
+ open Status
+
+ val pretty: t -> string =
+ fn Con => "a constructor"
+ | Exn => "an exception"
+ | Var => "a variable"
+ end
+
structure Info =
struct
(* The array is sorted by domain element. *)
@@ -234,7 +256,7 @@
in
(r,
seq [str "type ", name (),
- str " in structure and signature disagree"],
+ str " in structure disagrees with signature"],
align [seq [str "structure: ", l1],
seq [str "signature: ", l2]])
end)
@@ -292,7 +314,6 @@
in
case vid of
Con _ => simple "con"
- | ConAsVar _ => simple "val"
| Exn c =>
seq [str "exception ", Con.layout c,
case Type.deArrowOpt (Scheme.ty scheme) of
@@ -411,8 +432,9 @@
end
(* section 5.3, 5.5, 5.6 and rules 52, 53 *)
- fun cut {str, interface, opaque: bool, region}: t =
+ fun cut (str: t, {interface, opaque: bool, region}): t * Decs.t =
let
+ val decs = ref []
fun error (name, l) =
let
open Layout
@@ -423,6 +445,56 @@
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) =>
@@ -519,11 +591,12 @@
end
else
case TypeStr.node typeStr of
- Datatype _ =>
+ Datatype {cons = c, ...} =>
(case TypeStr.node typeStr' of
- Datatype _ =>
- (* need to match they cons in the structure against the signature *)
- typeStr'
+ Datatype {cons = c', ...} =>
+ (checkCons (c', c,
+ strids)
+ ; typeStr')
| _ =>
let
open Layout
@@ -552,21 +625,63 @@
values = values}
end
end
- fun handleVal {name, scheme, status} =
+ 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, ...} =>
+ | 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) =>
- Vid.ConAsVar c
- | (Vid.Exn c, Status.Var) =>
- Vid.ConAsVar c
- | (_, Status.Var) => vid
+ (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
| _ =>
@@ -578,11 +693,11 @@
Longvid.toString
(Longvid.long (rev strids,
name)),
- " has status ",
- Vid.statusString vid,
- " in structure but status ",
- Status.toString status,
- " in signature "]),
+ " is ",
+ Vid.statusPretty vid,
+ " in the structure but ",
+ Status.pretty status,
+ " in the signature "]),
Layout.empty)
; vid)
in
@@ -605,16 +720,17 @@
then S
else doit ()
end
+ val str = cut (str, interface, [])
in
- cut (str, interface, [])
+ (str, Decs.fromList (!decs))
end
val cut =
Trace.trace ("cut",
- fn {str, interface, ...} =>
+ fn (str, {interface, ...}) =>
Layout.tuple [layoutPretty str,
Interface.layout interface],
- layout)
+ layout o #1)
cut
val ffi: t option ref = ref NONE
@@ -992,12 +1108,14 @@
val restore = snapshot E
fun apply (arg, nest, region) =
let
- val actual = Structure.cut {str = arg,
- interface = argInt,
- opaque = false,
- region = region}
+ val (actual, decs) =
+ Structure.cut (arg, {interface = argInt,
+ opaque = false,
+ region = region})
+ val (decs', str) = restore (fn () => makeBody (actual, nest))
in
- restore (fn () => makeBody (actual, nest))
+ (Decs.append (decs, decs'),
+ str)
end
val apply =
Trace.trace ("functorApply",
1.10 +3 -5 mlton/mlton/elaborate/elaborate-env.sig
Index: elaborate-env.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-env.sig,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- elaborate-env.sig 7 Nov 2003 00:21:28 -0000 1.9
+++ elaborate-env.sig 10 Nov 2003 23:01:59 -0000 1.10
@@ -44,7 +44,6 @@
sig
datatype t =
Con of CoreML.Con.t
- | ConAsVar of CoreML.Con.t
| Exn of CoreML.Con.t
| Overload of (CoreML.Var.t * Type.t) vector
| Var of CoreML.Var.t
@@ -68,10 +67,9 @@
(* cut keeps only those bindings in the structure that also appear
* in the interface. It proceeds recursively on substructures.
*)
- val cut: {str: t,
- interface: Interface.t,
- opaque: bool,
- region: Region.t} -> t
+ 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.
*)
1.9 +19 -15 mlton/mlton/elaborate/elaborate.fun
Index: elaborate.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate.fun,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- elaborate.fun 7 Nov 2003 23:45:22 -0000 1.8
+++ elaborate.fun 10 Nov 2003 23:01:59 -0000 1.9
@@ -80,19 +80,23 @@
let
val Ast.Program.T decs = Ast.Program.coalesce program
fun elabSigexp s = ElaborateSigexp.elaborateSigexp (s, E)
- fun elabSigexpConstraint (cons: SigConst.t, S: Structure.t): Structure.t =
+ fun elabSigexpConstraint (cons: SigConst.t, S: Structure.t)
+ : Decs.t * Structure.t =
let
fun s (sigexp, opaque) =
- let val interface = elabSigexp sigexp
- in Structure.cut {str = S,
- interface = interface,
- opaque = opaque,
- region = Sigexp.region sigexp}
+ let
+ val (S, decs) =
+ Structure.cut (S, {interface = elabSigexp sigexp,
+ opaque = opaque,
+ region = Sigexp.region sigexp})
+ in
+ (decs, S)
end
- in case cons of
- SigConst.None => S
- | SigConst.Transparent sigexp => s (sigexp, false)
- | SigConst.Opaque sigexp => s (sigexp, true)
+ in
+ case cons of
+ SigConst.None => (Decs.empty, S)
+ | SigConst.Opaque sigexp => s (sigexp, true)
+ | SigConst.Transparent sigexp => s (sigexp, false)
end
fun elabStrdec (arg: Strdec.t * string list): Decs.t =
Trace.traceInfo' (info,
@@ -124,11 +128,10 @@
let
val (decs', S) = elabStrexp (def,
Strid.toString name :: nest)
- val _ =
- Env.extendStrid
- (E, name, elabSigexpConstraint (constraint, S))
+ val (decs'', S) = elabSigexpConstraint (constraint, S)
+ val _ = Env.extendStrid (E, name, S)
in
- Decs.append (decs, decs')
+ Decs.appends [decs, decs', decs'']
end)
end) arg
and elabStrexp (e: Strexp.t, nest: string list): Decs.t * Structure.t =
@@ -148,8 +151,9 @@
| Strexp.Constrained (e, c) => (* rules 52, 53 *)
let
val (decs, S) = elabStrexp e
+ val (decs', S) = elabSigexpConstraint (c, S)
in
- (decs, elabSigexpConstraint (c, S))
+ (Decs.append (decs, decs'), S)
end
| Strexp.Let (d, e) => (* rule 55 *)
Env.scope