[MLton] cvs commit: new front end
sweeks@mlton.org
sweeks@mlton.org
Fri, 7 Nov 2003 15:45:25 -0800
sweeks 03/11/07 15:45:24
Modified: mlton/elaborate elaborate-env.fun elaborate-sigexp.fun
elaborate.fun interface.fun interface.sig
type-str.sig
Log:
The next phase in the new front end: checking functors at the point of
definition.
This is implemented by building a dummy structure from the argument
signature and then applying the functor to the dummy strucure just as
we would for a real functor application.
Unfortunately, the fully-functorized programming style in MLton is
maximally bad for this method, because it causes each functor to be
checked many times. For example, in the following code, the body of F
will be elaborated 4 times.
functor F () = ...
functor G () = ... F () ...
functor H () = ... G () ...
structure S = H ()
All this extra work means that elaboration of the MLton now takes
about 35 seconds.
I'll think about going to an approach where a functor summary (much
like in the Definition) is produced after elaboration of each functor,
so that the body need not be re elaborated.
Revision Changes Path
1.18 +106 -58 mlton/mlton/elaborate/elaborate-env.fun
Index: elaborate-env.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-env.fun,v
retrieving revision 1.17
retrieving revision 1.18
diff -u -r1.17 -r1.18
--- elaborate-env.fun 7 Nov 2003 00:21:28 -0000 1.17
+++ elaborate-env.fun 7 Nov 2003 23:45:22 -0000 1.18
@@ -377,6 +377,39 @@
| UndefinedStructure _ => NONE
end
+ fun maker () =
+ let
+ fun make (op <=) =
+ let
+ val r = ref []
+ fun add {range, values} =
+ List.push (r, {isUsed = ref false,
+ range = range,
+ values = values})
+ fun done () =
+ Info.T
+ (QuickSort.sortArray
+ (Array.fromList (!r),
+ fn ({values = v, ...}, {values = v', ...}) =>
+ Values.domain v <= Values.domain v'))
+ in
+ (add, done)
+ end
+ val (addStr, strs) = make Ast.Strid.<=
+ val (addType, types) = make Ast.Tycon.<=
+ val (addVal, vals) = make Ast.Vid.<=
+ fun finish shapeId =
+ T {shapeId = shapeId,
+ strs = strs (),
+ types = types (),
+ vals = vals ()}
+ in
+ {addStr = addStr,
+ addType = addType,
+ addVal = addVal,
+ finish = finish}
+ end
+
(* section 5.3, 5.5, 5.6 and rules 52, 53 *)
fun cut {str, interface, opaque: bool, region}: t =
let
@@ -392,7 +425,7 @@
end
val interface =
Interface.realize
- (interface, fn (c, k) =>
+ (interface, fn (c, a, k) =>
case peekLongtycon (str, c) of
NONE => (error ("type", Longtycon.layout c)
; TypeStr.bogus k)
@@ -419,12 +452,10 @@
end)
fun cut (S as T {shapeId, ...}, I, strids) =
let
+ val {addStr, addType, addVal, finish} = maker ()
val shapeId' = Interface.shapeId I
fun doit () =
let
- val strs = ref []
- val vals = ref []
- val types = ref []
fun handleStr {name, interface = I} =
case peekStrid' (S, name) of
NONE =>
@@ -433,11 +464,8 @@
Longstrid.layout
(Longstrid.long (rev strids, name)))
| SOME {range, values, ...} =>
- List.push
- (strs,
- {isUsed = ref false,
- range = cut (range, I, name :: strids),
- values = values})
+ addStr {range = cut (range, I, name :: strids),
+ values = values}
fun handleType {name: Ast.Tycon.t,
typeStr: TypeStr.t} =
let
@@ -520,10 +548,8 @@
layoutName, region)
; typeStr)
in
- List.push (types,
- {isUsed = ref false,
- range = typeStr,
- values = values})
+ addType {range = typeStr,
+ values = values}
end
end
fun handleVal {name, scheme, status} =
@@ -560,52 +586,16 @@
Layout.empty)
; vid)
in
- List.push (vals,
- {isUsed = ref false,
- range = (vid, s),
- values = values})
+ addVal {range = (vid, s),
+ values = values}
end
- val handleStr =
- Trace.trace ("handleStr",
- Ast.Strid.layout o #name,
- Unit.layout)
- handleStr
- val handleType =
- Trace.trace ("handleType",
- fn {name, typeStr} =>
- Layout.record [("name",
- Ast.Tycon.layout name),
- ("typeStr",
- TypeStr.layout typeStr)],
- Unit.layout)
- handleType
- val handleVal =
- Trace.trace ("handleVal",
- Ast.Vid.layout o #name,
- Unit.layout)
- handleVal
val _ =
- Interface.fold
- (I, (), fn (e, ()) =>
- let
- datatype z = datatype Interface.Element.t
- in
- case e of
- Str z => handleStr z
- | Type z => handleType z
- | Val z => handleVal z
- end)
- fun doit (elts, op <=) =
- Info.T
- (QuickSort.sortArray
- (Array.fromList (!elts),
- fn ({values = v, ...}, {values = v', ...}) =>
- Values.domain v <= Values.domain v'))
+ Interface.foreach
+ (I, {handleStr = handleStr,
+ handleType = handleType,
+ handleVal = handleVal})
in
- T {shapeId = SOME shapeId',
- strs = doit (strs, Ast.Strid.<=),
- types = doit (types, Ast.Tycon.<=),
- vals = doit (vals, Ast.Vid.<=)}
+ finish (SOME shapeId')
end
in
case shapeId of
@@ -862,6 +852,61 @@
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 *)
@@ -943,6 +988,7 @@
argInt: Interface.t,
makeBody: Structure.t * string list -> Decs.t * Structure.t) =
let
+ val _ = makeBody (dummyStructure (E, argInt), [])
val restore = snapshot E
fun apply (arg, nest, region) =
let
@@ -959,9 +1005,11 @@
Layout.tuple2 (Layout.ignore, Structure.layout))
apply
fun sizeMessage () = layoutSize apply
+ val fc =
+ FunctorClosure.T {apply = apply,
+ sizeMessage = sizeMessage}
in
- FunctorClosure.T {apply = apply,
- sizeMessage = sizeMessage}
+ fc
end
(* ------------------------------------------------- *)
1.4 +36 -21 mlton/mlton/elaborate/elaborate-sigexp.fun
Index: elaborate-sigexp.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-sigexp.fun,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- elaborate-sigexp.fun 7 Nov 2003 00:21:28 -0000 1.3
+++ elaborate-sigexp.fun 7 Nov 2003 23:45:22 -0000 1.4
@@ -60,10 +60,30 @@
fun lookupLongtycon (E: Env.t,
I: Interface.t,
- c: Ast.Longtycon.t) =
- case Interface.peekLongtycon (I, c) of
- NONE => TypeStr.fromEnv (Env.lookupLongtycon (E, c))
- | SOME s => s
+ c: Ast.Longtycon.t): TypeStr.t =
+ let
+ fun env () = TypeStr.fromEnv (Env.lookupLongtycon (E, c))
+ val (strids, t) = Ast.Longtycon.split c
+ in
+ case strids of
+ [] =>
+ (case Interface.peekLongtycon (I, c) of
+ NONE => env ()
+ | SOME s => s)
+ | s :: _ =>
+ (case Interface.peekStrid (I, s) of
+ NONE => env ()
+ | SOME s =>
+ let
+ val r = ref NONE
+ val _ =
+ Interface.lookupLongtycon (I, c, fn s => r := SOME s)
+ in
+ case !r of
+ NONE => TypeStr.bogus Kind.Nary
+ | SOME s => s
+ end)
+ end
fun elaborateType (ty: Atype.t, E: Env.t, I: Interface.t)
: Tyvar.t vector * Type.t =
@@ -214,32 +234,27 @@
(tycons, datatypes,
fn (tycon, {cons, tycon = astTycon, tyvars, ...}) =>
let
- val resultType: Type.t =
- Type.con (tycon, Vector.map (tyvars, Type.var))
+ val resultType: Atype.t =
+ Atype.con (astTycon, Vector.map (tyvars, Atype.var))
val (cons, conArgs) =
Vector.unzip
(Vector.map
(cons, fn (name, arg) =>
let
val con = Con.newNoname ()
- val (arg, ty) =
+ val (makeArg, ty) =
case arg of
- NONE => (NONE, resultType)
+ NONE => (fn _ => NONE, resultType)
| SOME t =>
- let
- (* We do the elaborateScheme here to
- * check for unbound tyvars in t.
- *)
- val t =
- Scheme.ty
- (elaborateScheme (tyvars, t, E, I2))
- in
- (SOME t, Type.arrow (t, resultType))
- end
- val scheme = Scheme.make (tyvars, ty)
+ (fn s =>
+ SOME (#1 (Type.deArrow (Scheme.ty s))),
+ Atype.arrow (t, resultType))
+ val scheme = elaborateScheme (tyvars, ty, E, I2)
in
- ({con = con: TypeStr.Con.t, name = name, scheme = scheme},
- arg)
+ ({con = con: TypeStr.Con.t,
+ name = name,
+ scheme = scheme},
+ makeArg scheme)
end))
val cons = Cons.T cons
val _ =
1.8 +8 -0 mlton/mlton/elaborate/elaborate.fun
Index: elaborate.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate.fun,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- elaborate.fun 13 Oct 2003 19:23:36 -0000 1.7
+++ elaborate.fun 7 Nov 2003 23:45:22 -0000 1.8
@@ -207,6 +207,14 @@
end)
; Decs.empty)
) arg
+ val elabTopdec =
+ fn d =>
+ let
+ val res = elabTopdec d
+ val _ = Control.checkForErrors "elaborate"
+ in
+ res
+ end
in
List.fold (decs, Decs.empty, fn (d, decs) =>
Decs.append (decs, elabTopdec d))
1.2 +49 -43 mlton/mlton/elaborate/interface.fun
Index: interface.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/interface.fun,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- interface.fun 7 Nov 2003 00:21:28 -0000 1.1
+++ interface.fun 7 Nov 2003 23:45:22 -0000 1.2
@@ -117,9 +117,10 @@
fun layout (T s) =
let
open Layout
- val {hasCons, id, typeFcn, ...} = Set.value s
+ val {admitsEquality, hasCons, id, typeFcn, ...} = Set.value s
in
- record [("hasCons", Bool.layout hasCons),
+ record [("admitsEquality", AdmitsEquality.layout (!admitsEquality)),
+ ("hasCons", Bool.layout hasCons),
("id", TyconId.layout id),
("typeFcn", TypeFcn.layout typeFcn)]
end
@@ -155,15 +156,18 @@
fun copy (T s): t =
let
- val {copy, typeFcn, hasCons, ...} = Set.value s
+ val {admitsEquality = a, copy, hasCons, typeFcn, ...} = Set.value s
in
case !copy of
NONE =>
- let val c = new {hasCons = hasCons,
- typeFcn = typeFcn}
- in List.push (copies, copy)
- ; copy := SOME c
- ; c
+ let
+ val c = new {hasCons = hasCons,
+ typeFcn = typeFcn}
+ val _ = admitsEquality c := !a
+ val _ = List.push (copies, copy)
+ val _ = copy := SOME c
+ in
+ c
end
| SOME c => c
end
@@ -276,6 +280,19 @@
val var = Var
val exn = Con (Tycon.exn, Vector.new0 ())
+
+ fun deArrowOpt (t: t): (t * t) option =
+ case t of
+ Con (c, ts) =>
+ if Tycon.equals (c, Tycon.arrow)
+ then SOME (Vector.sub (ts, 0), Vector.sub (ts, 1))
+ else NONE
+ | _ => NONE
+
+ fun deArrow t =
+ case deArrowOpt t of
+ NONE => Error.bug "Type.deArrow"
+ | SOME z => z
fun hom (t, {con, record, var}) =
let
@@ -582,6 +599,7 @@
datatype t = T of {copy: copy,
elements: element list,
+ plist: PropertyList.t,
shapeId: ShapeId.t,
wheres: (FlexibleTycon.t * TypeStr.t) list ref} Set.t
and element =
@@ -596,6 +614,12 @@
type interface = t
+local
+ fun make f (T s) = f (Set.value s)
+in
+ val plist = make #plist
+end
+
fun equals (T s, T s') = Set.equals (s, s')
local
@@ -631,6 +655,7 @@
fun explicit elements: t =
T (Set.singleton {copy = ref NONE,
elements = elements,
+ plist = PropertyList.new (),
shapeId = ShapeId.new (),
wheres = ref []})
@@ -933,20 +958,6 @@
end)
end
-structure Element =
- struct
- type interface = t
-
- datatype t =
- Str of {name: Ast.Strid.t,
- interface: interface}
- | Type of {name: Ast.Tycon.t,
- typeStr: EtypeStr.t}
- | Val of {name: Ast.Vid.t,
- scheme: Escheme.t,
- status: Status.t}
- end
-
fun copyAndRealize (I: t, getTypeFcnOpt): t =
let
(* Keep track of all nodes that have forward pointers to copies, so
@@ -994,6 +1005,8 @@
fun get () =
f
(Longtycon.long (strids, name),
+ ! (FlexibleTycon.admitsEquality
+ c),
TypeStr.kind typeStr)
fun doit (s: EtypeStr.t): unit =
FlexibleTycon.setTypeStr (c, s)
@@ -1026,8 +1039,9 @@
scheme = Scheme.copy scheme,
status = status})
val I = T (Set.singleton {copy = ref NONE,
- shapeId = shapeId,
elements = elements,
+ plist = PropertyList.new (),
+ shapeId = shapeId,
wheres = ref wheres})
val _ = List.push (copies, copy)
val _ = copy := SOME I
@@ -1052,29 +1066,21 @@
val realize = Trace.trace2 ("realize", layout, Layout.ignore, layout) realize
-fun 'a fold (T s, b: 'a, f: Element.t * 'a -> 'a): 'a =
+fun foreach (T s, {handleStr, handleType, handleVal}) =
let
val {elements, ...} = Set.value s
in
- List.fold
- (elements, b, fn (elt, b) =>
- let
- val elt =
- case elt of
- Str r => Element.Str r
- | Type {name, typeStr} =>
- Element.Type {name = name,
- typeStr = TypeStr.toEnv typeStr}
- | Val {name, scheme, status} =>
- Element.Val {name = name,
- scheme = Scheme.toEnv scheme,
- status = status}
-
- in
- f (elt, b)
- end)
+ List.foreach
+ (elements, fn elt =>
+ case elt of
+ Str r => handleStr r
+ | Type {name, typeStr} =>
+ handleType {name = name,
+ typeStr = TypeStr.toEnv typeStr}
+ | Val {name, scheme, status} =>
+ handleVal {name = name,
+ scheme = Scheme.toEnv scheme,
+ status = status})
end
-
-fun foreach (s, f) = fold (s, (), f o #1)
end
1.2 +13 -15 mlton/mlton/elaborate/interface.sig
Index: interface.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/interface.sig,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- interface.sig 7 Nov 2003 00:21:28 -0000 1.1
+++ interface.sig 7 Nov 2003 23:45:22 -0000 1.2
@@ -74,21 +74,8 @@
sharing TypeStr.Tycon = Tycon
sharing TypeStr.Type = Type
sharing TypeStr.Tyvar = EnvTypeStr.Tyvar = Tyvar
- structure Element:
- sig
- type interface
- datatype t =
- Str of {name: Ast.Strid.t,
- interface: interface}
- | Type of {name: Ast.Tycon.t,
- typeStr: EnvTypeStr.t}
- | Val of {name: Ast.Vid.t,
- scheme: EnvTypeStr.Scheme.t,
- status: Status.t}
- end
type t
- sharing type t = Element.interface
val + : t * t -> t
val bogus: t
@@ -98,11 +85,22 @@
val equals: t * t -> bool
val excons: TypeStr.Cons.t -> t
val extendTycon: t * Ast.Tycon.t * TypeStr.t -> t
- val fold: t * 'a * (Element.t * 'a -> 'a) -> 'a
+ val foreach: t * {handleStr: {name: Ast.Strid.t,
+ interface: t} -> unit,
+ handleType: {name: Ast.Tycon.t,
+ typeStr: EnvTypeStr.t} -> unit,
+ handleVal: {name: Ast.Vid.t,
+ scheme: EnvTypeStr.Scheme.t,
+ status: Status.t} -> unit} -> unit
val layout: t -> Layout.t
+ val lookupLongtycon: t * Ast.Longtycon.t * (TypeStr.t -> unit) -> unit
val peekLongtycon: t * Ast.Longtycon.t -> TypeStr.t option
+ val peekStrid: t * Ast.Strid.t -> t option
+ val plist: t -> PropertyList.t
(* realize makes a copy, and instantiate longtycons *)
- val realize: t * (Ast.Longtycon.t * TypeStr.Kind.t -> EnvTypeStr.t) -> t
+ val realize: t * (Ast.Longtycon.t
+ * TypeStr.Tycon.AdmitsEquality.t
+ * TypeStr.Kind.t -> EnvTypeStr.t) -> t
val shapeId: t -> ShapeId.t
val share: t * Ast.Longstrid.t * Ast.Longstrid.t -> unit
val shareType: t * Ast.Longtycon.t * Ast.Longtycon.t -> unit
1.2 +1 -0 mlton/mlton/elaborate/type-str.sig
Index: type-str.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/type-str.sig,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- type-str.sig 7 Nov 2003 00:21:28 -0000 1.1
+++ type-str.sig 7 Nov 2003 23:45:22 -0000 1.2
@@ -46,6 +46,7 @@
val arrow: t * t -> t
val bogus: t
val con: Tycon.t * t vector -> t
+ val deArrow: t -> t * t
val deEta: t * Tyvar.t vector -> Tycon.t option
val exn: t
val hom: t * {con: Tycon.t * 'a vector -> 'a,