[MLton] cvs commit: new front end
sweeks@mlton.org
sweeks@mlton.org
Tue, 11 Nov 2003 13:26:35 -0800
sweeks 03/11/11 13:26:34
Modified: mlton/elaborate elaborate-core.fun elaborate-env.fun
elaborate-env.sig
Log:
The next phase in the new front end: using functor summaries to speed
up checking of functor applications.
Now, when a functor is first type checked, we keep track of the dummy
argument structure and the dummy result structure, as well as all the
tycons that were created while elaborating the body. Then, if we
later need to type check an application of the functor (as opposed to
defunctorize an application), we pair up tycons in the dummy argument
structure with the actual argument structure and then replace the
dummy tycons with the actual tycons in the dummy result structure,
yielding the actual result structure. We also generate new tycons for
all the tycons that we created while originally elaborating the body.
With this improvement, type checking all of MLton has gone from 45s to
just under 20. That's almost livable for day-to-day use.
All that's left is opaque matching (and lots of testing).
Revision Changes Path
1.47 +5 -6 mlton/mlton/elaborate/elaborate-core.fun
Index: elaborate-core.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-core.fun,v
retrieving revision 1.46
retrieving revision 1.47
diff -u -r1.46 -r1.47
--- elaborate-core.fun 10 Nov 2003 23:01:59 -0000 1.46
+++ elaborate-core.fun 11 Nov 2003 21:26:34 -0000 1.47
@@ -885,15 +885,14 @@
Vector.map
(datatypes, fn {cons, tycon = name, tyvars} =>
let
+ val kind = Kind.Arity (Vector.length tyvars)
val tycon =
- Tycon.fromString
+ Env.newTycon
(concat (List.separate
(rev (Ast.Tycon.toString name :: nest),
- ".")))
- val _ =
- Env.extendTycon
- (E, name,
- TypeStr.tycon (tycon, Kind.Arity (Vector.length tyvars)))
+ ".")),
+ kind)
+ val _ = Env.extendTycon (E, name, TypeStr.tycon (tycon, kind))
in
tycon
end)
1.20 +210 -9 mlton/mlton/elaborate/elaborate-env.fun
Index: elaborate-env.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-env.fun,v
retrieving revision 1.19
retrieving revision 1.20
diff -u -r1.19 -r1.20
--- elaborate-env.fun 10 Nov 2003 23:01:59 -0000 1.19
+++ elaborate-env.fun 11 Nov 2003 21:26:34 -0000 1.20
@@ -237,6 +237,13 @@
in
v
end)
+
+ val map: ('a, 'b) t * ('b -> 'b) -> ('a, 'b) t =
+ fn (T a, f) =>
+ T (Array.map (a, fn {range, values, ...} =>
+ {isUsed = ref false,
+ range = f range,
+ values = values}))
end
(* pre: arities are equal. *)
@@ -268,11 +275,18 @@
structure Structure =
struct
- datatype t = T of {shapeId: ShapeId.t option,
+ datatype t = T of {plist: PropertyList.t,
+ shapeId: ShapeId.t option,
strs: (Ast.Strid.t, t) Info.t,
types: (Ast.Tycon.t, TypeStr.t) Info.t,
vals: (Ast.Vid.t, Vid.t * Scheme.t) Info.t}
+ local
+ fun make f (T r) = f r
+ in
+ val plist = make #plist
+ end
+
fun layoutUsed (T {strs, types, vals, ...}) =
let
open Layout
@@ -344,7 +358,8 @@
end
end
- val bogus = T {shapeId = NONE,
+ val bogus = T {plist = PropertyList.new (),
+ shapeId = NONE,
strs = Info.bogus (),
vals = Info.bogus (),
types = Info.bogus ()}
@@ -420,7 +435,8 @@
val (addType, types) = make Ast.Tycon.<=
val (addVal, vals) = make Ast.Vid.<=
fun finish shapeId =
- T {shapeId = shapeId,
+ T {plist = PropertyList.new (),
+ shapeId = shapeId,
strs = strs (),
types = types (),
vals = vals ()}
@@ -1098,13 +1114,64 @@
res
end
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 _ = makeBody (dummyStructure (E, argInt), [])
+ 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
@@ -1112,10 +1179,143 @@
Structure.cut (arg, {interface = argInt,
opaque = false,
region = region})
- val (decs', str) = restore (fn () => makeBody (actual, nest))
in
- (Decs.append (decs, decs'),
- str)
+ 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",
@@ -1453,7 +1653,8 @@
val _ = currentScope := Scope.new ()
val res = make ()
val _ = f ()
- val S = Structure.T {shapeId = NONE,
+ val S = Structure.T {plist = PropertyList.new (),
+ shapeId = NONE,
strs = s (),
types = t (),
vals = v ()}
1.11 +4 -0 mlton/mlton/elaborate/elaborate-env.sig
Index: elaborate-env.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-env.sig,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- elaborate-env.sig 10 Nov 2003 23:01:59 -0000 1.10
+++ elaborate-env.sig 11 Nov 2003 21:26:34 -0000 1.11
@@ -27,6 +27,8 @@
structure Decs: DECS
sharing CoreML = Decs.CoreML
+ structure Tycon: TYCON
+ sharing Tycon = TypeEnv.Tycon
structure Type:
sig
type t
@@ -52,6 +54,7 @@
end
structure TypeStr: TYPE_STR
sharing TypeStr.Con = CoreML.Con
+ sharing TypeStr.Kind = Tycon.Kind
sharing TypeStr.Name = Ast.Con
sharing TypeStr.Scheme = Scheme
sharing TypeStr.Tycon = CoreML.Tycon
@@ -116,6 +119,7 @@
val lookupLongvid: t * Ast.Longvid.t -> Vid.t * Scheme.t
val lookupSigid: t * Ast.Sigid.t -> Interface.t
val makeStructure: t * (unit -> 'a) -> 'a * Structure.t
+ val newTycon: string * Tycon.Kind.t -> Tycon.t
(* openStructure (E, S) opens S in the environment E. *)
val openStructure: t * Structure.t -> unit
val peekFix: t * Ast.Vid.t -> Ast.Fixity.t option