[MLton-devel] cvs commit: heirarchichal naming of profiled functions
Stephen Weeks
MLton@mlton.org
Tue, 25 Feb 2003 16:17:36 -0800
sweeks 03/02/25 16:17:36
Modified: doc/user-guide profiling.tex
mlprof main.sml
mlton/atoms source-info.fun source-info.sig
mlton/elaborate elaborate-core.fun elaborate-core.sig
elaborate-env.fun elaborate-env.sig elaborate.fun
Log:
Added support for heirarchichal naming of profiled functions. For
example, in the following code, g would appear as S.f.g.
structure S =
struct
fun f = ... fun g ...
end
I used "." as the separator for both nesting of structures as well as
functions. It looks OK to me.
There is also an expert mlprof option, -long-name {true|false}, to get
the old short names if you want.
Revision Changes Path
1.24 +11 -0 mlton/doc/user-guide/profiling.tex
Index: profiling.tex
===================================================================
RCS file: /cvsroot/mlton/mlton/doc/user-guide/profiling.tex,v
retrieving revision 1.23
retrieving revision 1.24
diff -u -r1.23 -r1.24
--- profiling.tex 25 Feb 2003 20:44:19 -0000 1.23
+++ profiling.tex 26 Feb 2003 00:17:34 -0000 1.24
@@ -261,6 +261,17 @@
\subsection{Profiling details}
+Function names are displayed as sequence of period-separated names,
+indicated the structures and functions in which the function
+definition is nested. For example, {\tt g} in the following code
+would appear as {\tt S.f.g}.
+\begin{verbatim}
+structure S =
+ struct
+ fun f = ... fun g ...
+ end
+\end{verbatim}
+
{\mlton}'s optimizer may duplicate source functions for any of a
number of reasons (functor duplication, monomorphisation,
polyvariance, inlining). By default, duplicates arising from functor
1.46 +15 -1 mlton/mlprof/main.sml
Index: main.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlprof/main.sml,v
retrieving revision 1.45
retrieving revision 1.46
diff -u -r1.45 -r1.46
--- main.sml 12 Feb 2003 05:11:24 -0000 1.45
+++ main.sml 26 Feb 2003 00:17:34 -0000 1.46
@@ -17,6 +17,7 @@
val gray: bool ref = ref false
val ignore: Regexp.t ref = ref Regexp.none
+val longName: bool ref = ref true
val mlmonFiles: string list ref = ref []
val raw = ref false
val showLine = ref false
@@ -44,7 +45,17 @@
fun fromString s =
case String.tokens (s, fn c => Char.equals (c, #"\t")) of
[s] => Simple s
- | [name, pos] => NamePos {name = name, pos = pos}
+ | [name, pos] =>
+ let
+ val name =
+ if !longName
+ then name
+ else
+ List.last
+ (String.tokens (name, fn c => Char.equals (c, #".")))
+ in
+ NamePos {name = name, pos = pos}
+ end
| _ => Error.bug "strange source"
fun toDotLabel s =
@@ -806,6 +817,9 @@
case Regexp.fromString s of
NONE => usage (concat ["invalid -ignore regexp: ", s])
| SOME (r, _) => ignore := Regexp.or [r, !ignore])),
+ (Expert, "long-name", " {true|false}",
+ " show long names of functions",
+ boolRef longName),
(Normal, "mlmon", " <file>", "proces mlmon files listed in <file>",
SpaceString (fn s =>
mlmonFiles :=
1.8 +4 -2 mlton/mlton/atoms/source-info.fun
Index: source-info.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/source-info.fun,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- source-info.fun 25 Feb 2003 20:44:20 -0000 1.7
+++ source-info.fun 26 Feb 2003 00:17:35 -0000 1.8
@@ -34,7 +34,7 @@
datatype info =
Anonymous of Pos.t
| C of string
- | Function of {name: string,
+ | Function of {name: string list,
pos: Pos.t}
datatype t = T of {hash: word,
@@ -82,7 +82,9 @@
case info si of
Anonymous p => Pos.toString p
| C s => concat ["<", s, ">"]
- | Function {name, pos} => concat [name, sep, Pos.toString pos]
+ | Function {name, pos} =>
+ concat [concat (List.separate (List.rev name, ".")),
+ sep, Pos.toString pos]
fun toString si = toString' (si, " ")
1.6 +2 -1 mlton/mlton/atoms/source-info.sig
Index: source-info.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/source-info.sig,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- source-info.sig 25 Feb 2003 20:44:22 -0000 1.5
+++ source-info.sig 26 Feb 2003 00:17:35 -0000 1.6
@@ -17,7 +17,8 @@
val gcArrayAllocate: t
val hash: t -> word
val fromC: string -> t
- val function: {name: string, region: Region.t} -> t
+ val function: {name: string list,
+ region: Region.t} -> t
val isBasis: t -> bool
val isC: t -> bool
val layout: t -> Layout.t
1.16 +65 -60 mlton/mlton/elaborate/elaborate-core.fun
Index: elaborate-core.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-core.fun,v
retrieving revision 1.15
retrieving revision 1.16
diff -u -r1.15 -r1.16
--- elaborate-core.fun 30 Jan 2003 06:06:24 -0000 1.15
+++ elaborate-core.fun 26 Feb 2003 00:17:35 -0000 1.16
@@ -312,22 +312,18 @@
(*---------------------------------------------------*)
(* Declarations *)
(*---------------------------------------------------*)
-
-local
- fun make name =
- Aexp.longvid (Ast.Longvid.long
- ([Strid.fromString ("Primitive", Region.bogus),
- Strid.fromString ("Debug", Region.bogus)],
- Ast.Vid.fromString (name, Region.bogus)))
-in
- val enterDebug = make "enter"
- val leaveDebug = make "leave"
-end
+
+structure Nest =
+ struct
+ type t = string list
+
+ val layout = List.layout String.layout
+ end
val info = Trace.info "elaborateDec"
val elabExpInfo = Trace.info "elaborateExp"
-fun elaborateDec (d, E) =
+fun elaborateDec (d, nest, E) =
let
fun elabType t = elaborateType (t, Lookup.fromEnv E)
fun elabTypeOpt t = elaborateTypeOpt (t, Lookup.fromEnv E)
@@ -386,12 +382,16 @@
decs = Decs.single (Cdec.makeRegion (Cdec.Datatype datatypes,
region))}
end
- fun elabDec d =
- Trace.traceInfo (info, Ast.Dec.layout, Layout.ignore, Trace.assertTrue)
- (fn d =>
+ fun elabDec arg =
+ Trace.traceInfo (info,
+ Layout.tuple2 (Ast.Dec.layout, Nest.layout),
+ Layout.ignore, Trace.assertTrue)
+ (fn (d, nest) =>
let
val region = Adec.region d
fun doit n = Cexp.makeRegion (n, region)
+ val elabDec' = elabDec
+ fun elabDec (d: Adec.t) = elabDec' (d, nest)
in
case Adec.node d of
Adec.Abstype {datBind, body} => (* rule 19 and p.57 *)
@@ -400,14 +400,17 @@
val (_, decs') =
Env.localCore
(E,
- fn () => (Vector.foreach (cons, fn {name, con} =>
- Env.extendCon (E, name, con))
- ; Vector.foreach (tycons, fn (t, s) =>
- Env.extendTycon (E, t, s))),
+ fn () =>
+ (Vector.foreach (cons, fn {name, con} =>
+ Env.extendCon (E, name, con))
+ ; Vector.foreach (tycons, fn (t, s) =>
+ Env.extendTycon (E, t, s))),
fn () => elabDec body)
- val _ = Vector.foreach (tycons, fn (t, s) =>
- Env.extendTycon (E, t, TypeStr.abs s))
- in Decs.append (decs, decs')
+ val _ =
+ Vector.foreach (tycons, fn (t, s) =>
+ Env.extendTycon (E, t, TypeStr.abs s))
+ in
+ Decs.append (decs, decs')
end
| Adec.Datatype rhs =>
let
@@ -427,7 +430,8 @@
Env.extendCon (E, name, con))
val _ = Vector.foreach (tycons, fn (t, s) =>
Env.extendTycon (E, t, s))
- in decs
+ in
+ decs
end
| Adec.Exception ebs =>
Vector.fold
@@ -450,7 +454,8 @@
in decs
end)
| Adec.Fix {ops, fixity} =>
- (Vector.foreach (ops, fn op' => Env.extendFix (E, op', fixity))
+ (Vector.foreach (ops, fn op' =>
+ Env.extendFix (E, op', fixity))
; Decs.empty)
| Adec.Fun (tyvars, fbs) =>
let
@@ -486,9 +491,10 @@
else
let
val {func, args, ...} = Vector.sub (clauses, 0)
+ val nest = Avar.toString func :: nest
val profile =
SourceInfo.function
- {name = Avar.toString func,
+ {name = nest,
region = Avar.region func}
val numVars = Vector.length args
val match =
@@ -502,7 +508,7 @@
Env.scope
(E, fn () =>
(elaboratePatsV (args, E),
- elabExp body))
+ elabExp' (body, nest)))
in (Cpat.tuple (pats, region),
constrain (body,
elabTypeOpt resultType,
@@ -611,8 +617,13 @@
(* Must do all the es and rvbs pefore the ps because of
* scoping rules.
*)
- val es = Vector.map (vbs, fn {pat, exp, ...} =>
- elabExp' (exp, Apat.getName pat))
+ val es =
+ Vector.map (vbs, fn {pat, exp, ...} =>
+ elabExp'
+ (exp,
+ case Apat.getName pat of
+ NONE => "<anon>" :: nest
+ | SOME s => s :: nest))
fun varsAndTypes (p: Apat.t, vars, types)
: Avar.t list * Atype.t list =
let
@@ -657,7 +668,7 @@
val (vars, types) = varsAndTypes (pat, [], [])
val (name, var) =
case vars of
- [] => ("<anon>", Cvar.newNoname ())
+ [] => ("<anon>" :: nest, Cvar.newNoname ())
| x :: _ =>
let
val x' = Cvar.fromAst x
@@ -666,10 +677,10 @@
(vars, fn y =>
Env.extendVar (E, y, x'))
in
- (Avar.toString x, x')
+ (Avar.toString x :: nest, x')
end
in
- {name = name,
+ {nest = nest,
types = (Vector.fromListMap
(types, Scheme.ty o elabType)),
var = var}
@@ -677,10 +688,10 @@
val rvbs =
Vector.map2
(rvbs, vts,
- fn ({pat, match, ...}, {name, types, var}) =>
- {match = elabMatch (match, SOME name),
+ fn ({pat, match, ...}, {nest, types, var}) =>
+ {match = elabMatch (match, nest),
profile = SOME (SourceInfo.function
- {name = name,
+ {name = nest,
region = Apat.region pat}),
types = types,
var = var})
@@ -722,20 +733,17 @@
tyvars = Vector.new0 ()},
region))]
end
- end) d
- and elabExps (es: Ast.Exp.t list): Cexp.t list =
- List.map (es, elabExp)
- and elabExp e = elabExp' (e, NONE)
- and elabExp' (arg: Aexp.t * string option): Cexp.t =
+ end) arg
+ and elabExp' (arg: Aexp.t * Nest.t): Cexp.t =
Trace.traceInfo (elabExpInfo,
- Layout.tuple2 (Aexp.layout,
- Option.layout String.layout),
+ Layout.tuple2 (Aexp.layout, Nest.layout),
Cexp.layout,
Trace.assertTrue)
- (fn (e: Aexp.t, name: string option) =>
+ (fn (e: Aexp.t, nest) =>
let
val region = Aexp.region e
fun doit n = Cexp.makeRegion (n, region)
+ fun elabExp e = elabExp' (e, nest)
in
case Aexp.node e of
Aexp.Andalso (e, e') =>
@@ -743,32 +751,28 @@
| Aexp.App (e1, e2) =>
doit (Cexp.App (elabExp e1, elabExp e2))
| Aexp.Case (e, m) =>
- Cexp.casee (elabExp e, elabMatch (m, NONE), region)
+ Cexp.casee (elabExp e, elabMatch (m, nest), region)
| Aexp.Const c => doit (Cexp.Const c)
| Aexp.Constraint (e, t) =>
- doit (Cexp.Constraint (elabExp' (e, name),
+ doit (Cexp.Constraint (elabExp e,
Scheme.ty (elabType t)))
| Aexp.FlatApp items => elabExp (Parse.parseExp (items, E))
| Aexp.Fn m =>
- let
- val profile =
- case name of
- NONE => SourceInfo.anonymous region
- | SOME s => SourceInfo.function {name = s,
- region = region}
- in
- doit (Cexp.Fn {match = elabMatch (m, name),
- profile = SOME profile})
- end
+ doit
+ (Cexp.Fn
+ {match = elabMatch (m, nest),
+ profile = SOME (SourceInfo.function {name = nest,
+ region = region})})
| Aexp.Handle (try, match) =>
- doit (Cexp.Handle (elabExp try, elabMatch (match, NONE)))
+ doit (Cexp.Handle (elabExp try, elabMatch (match, nest)))
| Aexp.If (a, b, c) =>
Cexp.iff (elabExp a, elabExp b, elabExp c, region)
| Aexp.Let (d, e) =>
Env.scope
(E, fn () =>
- doit (Cexp.Let (Decs.toVector (elabDec d), elabExp e)))
- | Aexp.List es => Cexp.list (elabExps es, region)
+ doit (Cexp.Let (Decs.toVector (elabDec (d, nest)),
+ elabExp e)))
+ | Aexp.List es => Cexp.list (List.map (es, elabExp), region)
| Aexp.Orelse (e, e') =>
Cexp.orElse (elabExp e, elabExp e', region)
| Aexp.Prim {kind, name, ty} =>
@@ -804,13 +808,14 @@
expr = elabExp expr,
region = region}
end) arg
- and elabMatch (Amatch.T {filePos, rules}, name: string option) =
+ and elabMatch (Amatch.T {filePos, rules}, nest: Nest.t) =
Cmatch.new {filePos = filePos,
rules =
Vector.map (rules, fn (pat, exp) =>
Env.scope (E, fn () => (elaboratePat (pat, E),
- elabExp' (exp, name))))}
- in elabDec d
+ elabExp' (exp, nest))))}
+ in
+ elabDec (d, nest)
end
end
1.3 +1 -1 mlton/mlton/elaborate/elaborate-core.sig
Index: elaborate-core.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-core.sig,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- elaborate-core.sig 10 Apr 2002 07:02:20 -0000 1.2
+++ elaborate-core.sig 26 Feb 2003 00:17:35 -0000 1.3
@@ -20,5 +20,5 @@
include ELABORATE_CORE_STRUCTS
(* Elaborate dec in env, returning Core ML decs. *)
- val elaborateDec: Ast.Dec.t * Env.t -> Decs.t
+ val elaborateDec: Ast.Dec.t * string list * Env.t -> Decs.t
end
1.10 +19 -13 mlton/mlton/elaborate/elaborate-env.fun
Index: elaborate-env.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-env.fun,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- elaborate-env.fun 7 Dec 2002 02:21:53 -0000 1.9
+++ elaborate-env.fun 26 Feb 2003 00:17:36 -0000 1.10
@@ -568,13 +568,15 @@
structure FunctorClosure =
struct
- datatype t = T of {apply: Structure.t * Region.t -> Decs.t * Structure.t,
- sizeMessage: unit -> Layout.t}
+ datatype t =
+ T of {apply: (Structure.t * string list * Region.t
+ -> Decs.t * Structure.t),
+ sizeMessage: unit -> Layout.t}
val bogus = T {apply = fn _ => (Decs.empty, Structure.bogus),
sizeMessage = fn _ => Layout.str "<bogus>"}
- fun apply (T {apply, ...}, s, r) = apply (s, r)
+ fun apply (T {apply, ...}, s, nest, r) = apply (s, nest, r)
fun sizeMessage (T {sizeMessage, ...}) = sizeMessage ()
@@ -713,11 +715,13 @@
let
val size = MLton.size
open Layout
- in record [("total", Int.layout (size E)),
- ("fcts", NameSpace.sizeMessage (fcts, Ast.Fctid.layout,
- FunctorClosure.sizeMessage)),
- ("sigs", NameSpace.sizeMessage (sigs, Ast.Sigid.layout, layoutSize)),
- ("strs", NameSpace.sizeMessage (strs, Ast.Strid.layout, layoutSize))]
+ in
+ record
+ [("total", Int.layout (size E)),
+ ("fcts", NameSpace.sizeMessage (fcts, Ast.Fctid.layout,
+ FunctorClosure.sizeMessage)),
+ ("sigs", NameSpace.sizeMessage (sigs, Ast.Sigid.layout, layoutSize)),
+ ("strs", NameSpace.sizeMessage (strs, Ast.Strid.layout, layoutSize))]
end
fun empty () =
@@ -867,18 +871,20 @@
end
end
-fun functorClosure (E: t,
- argInt: Interface.t,
- makeBody: Structure.t -> Decs.t * Structure.t) =
+fun functorClosure
+ (E: t,
+ argInt: Interface.t,
+ makeBody: Structure.t * string list -> Decs.t * Structure.t) =
let
val restore = snapshot E
- fun apply (arg, region) =
+ fun apply (arg, nest, region) =
let
val actual = Structure.cut {str = arg,
interface = argInt,
opaque = false,
region = region}
- in restore (fn () => makeBody actual)
+ in
+ restore (fn () => makeBody (actual, nest))
end
val apply =
Trace.trace ("functorApply",
1.5 +4 -2 mlton/mlton/elaborate/elaborate-env.sig
Index: elaborate-env.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-env.sig,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- elaborate-env.sig 24 Nov 2002 01:19:44 -0000 1.4
+++ elaborate-env.sig 26 Feb 2003 00:17:36 -0000 1.5
@@ -84,7 +84,9 @@
sig
type t
- val apply: t * Structure.t * Region.t -> Decs.t * Structure.t
+ val apply:
+ t * Structure.t * string list * Region.t
+ -> Decs.t * Structure.t
end
type t
@@ -102,7 +104,7 @@
val extendTycon: t * Ast.Tycon.t * TypeStr.t -> unit
val extendVar: t * Ast.Var.t * CoreML.Var.t -> unit
val functorClosure:
- t * Interface.t * (Structure.t -> Decs.t * Structure.t)
+ t * Interface.t * (Structure.t * string list -> Decs.t * Structure.t)
-> FunctorClosure.t
val layout: t -> Layout.t
val layoutPretty: t -> Layout.t
1.5 +75 -59 mlton/mlton/elaborate/elaborate.fun
Index: elaborate.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate.fun,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- elaborate.fun 10 Apr 2002 07:02:20 -0000 1.4
+++ elaborate.fun 26 Feb 2003 00:17:36 -0000 1.5
@@ -50,9 +50,9 @@
structure Interface = Interface)
structure ElaborateCore = ElaborateCore (structure Ast = Ast
- structure CoreML = CoreML
- structure Decs = Decs
- structure Env = Env)
+ structure CoreML = CoreML
+ structure Decs = Decs
+ structure Env = Env)
val info = Trace.info "elaborateStrdec"
val info' = Trace.info "elaborateTopdec"
@@ -74,63 +74,78 @@
| SigConst.Transparent sigexp => s (sigexp, false)
| SigConst.Opaque sigexp => s (sigexp, true)
end
-
- fun elabStrdec arg: Decs.t =
- Trace.traceInfo' (info, Strdec.layout, Layout.ignore)
- (fn d: Strdec.t =>
- case Strdec.node d of
- Strdec.Core d => (* rule 56 *)
- ElaborateCore.elaborateDec (d, E)
- | Strdec.Local (d, d') => (* rule 58 *)
- Decs.append (Env.localModule (E,
- fn () => elabStrdec d,
- fn () => elabStrdec d'))
- | Strdec.Seq ds => (* rule 60 *)
- List.fold
- (ds, Decs.empty, fn (d, decs) =>
- Decs.append (decs, elabStrdec d))
- | Strdec.Structure strbinds => (* rules 57, 61 *)
- List.fold
- (strbinds, Decs.empty, fn ({name, def, constraint}, decs) =>
- let val (decs', S) = elabStrexp def
- val _ =
- Env.extendStrid
- (E, name, elabSigexpConstraint (constraint, S))
- in Decs.append (decs, decs')
- end)
- ) arg
-
- and elabStrexp (e: Strexp.t): Decs.t * Structure.t =
- case Strexp.node e of
- Strexp.App (fctid, strexp) => (* rules 54, 154 *)
- let
- val (decs, S) = elabStrexp strexp
- val (decs', S) =
- FunctorClosure.apply (Env.lookupFctid (E, fctid),
- S, Strexp.region strexp)
- in (Decs.append (decs, decs'), S)
- end
- | Strexp.Constrained (e, c) => (* rules 52, 53 *)
- let val (decs, S) = elabStrexp e
- in (decs, elabSigexpConstraint (c, S))
- end
- | Strexp.Let (d, e) => (* rule 55 *)
- Env.scope
- (E, fn () =>
- let val decs = elabStrdec d
- val (decs', S) = elabStrexp e
- in (Decs.append (decs, decs'), S)
- end)
- | Strexp.Struct d => (* rule 50 *)
- Env.makeStructure (E, fn () => elabStrdec d)
- | Strexp.Var p => (* rule 51 *)
- (Decs.empty, Env.lookupLongstrid (E, p))
-
+ fun elabStrdec (arg: Strdec.t * string list): Decs.t =
+ Trace.traceInfo' (info,
+ Layout.tuple2 (Strdec.layout,
+ List.layout String.layout),
+ Layout.ignore)
+ (fn (d: Strdec.t, nest: string list) =>
+ let
+ val elabStrdec = fn d => elabStrdec (d, nest)
+ in
+ case Strdec.node d of
+ Strdec.Core d => (* rule 56 *)
+ ElaborateCore.elaborateDec (d, nest, E)
+ | Strdec.Local (d, d') => (* rule 58 *)
+ Decs.append (Env.localModule (E,
+ fn () => elabStrdec d,
+ fn () => elabStrdec d'))
+ | Strdec.Seq ds => (* rule 60 *)
+ List.fold
+ (ds, Decs.empty, fn (d, decs) =>
+ Decs.append (decs, elabStrdec d))
+ | Strdec.Structure strbinds => (* rules 57, 61 *)
+ List.fold
+ (strbinds, Decs.empty, fn ({name, def, constraint}, decs) =>
+ let
+ val (decs', S) = elabStrexp (def,
+ Strid.toString name :: nest)
+ val _ =
+ Env.extendStrid
+ (E, name, elabSigexpConstraint (constraint, S))
+ in
+ Decs.append (decs, decs')
+ end)
+ end) arg
+ and elabStrexp (e: Strexp.t, nest: string list): Decs.t * Structure.t =
+ let
+ val elabStrexp = fn e => elabStrexp (e, nest)
+ in
+ case Strexp.node e of
+ Strexp.App (fctid, strexp) => (* rules 54, 154 *)
+ let
+ val (decs, S) = elabStrexp strexp
+ val (decs', S) =
+ FunctorClosure.apply (Env.lookupFctid (E, fctid),
+ S, nest, Strexp.region strexp)
+ in
+ (Decs.append (decs, decs'), S)
+ end
+ | Strexp.Constrained (e, c) => (* rules 52, 53 *)
+ let
+ val (decs, S) = elabStrexp e
+ in
+ (decs, elabSigexpConstraint (c, S))
+ end
+ | Strexp.Let (d, e) => (* rule 55 *)
+ Env.scope
+ (E, fn () =>
+ let
+ val decs = elabStrdec (d, nest)
+ val (decs', S) = elabStrexp e
+ in
+ (Decs.append (decs, decs'), S)
+ end)
+ | Strexp.Struct d => (* rule 50 *)
+ Env.makeStructure (E, fn () => elabStrdec (d, nest))
+ | Strexp.Var p => (* rule 51 *)
+ (Decs.empty, Env.lookupLongstrid (E, p))
+ end
fun elabTopdec arg: Decs.t =
Trace.traceInfo' (info', Topdec.layout, Decs.layout)
(fn (d: Topdec.t) =>
case Topdec.node d of
- Topdec.Strdec d => elabStrdec d
+ Topdec.Strdec d => elabStrdec (d, [])
| Topdec.Signature sigbinds =>
(List.foreach
(sigbinds, fn (sigid, sigexp) =>
@@ -162,13 +177,14 @@
val closure =
Env.functorClosure
(E, argInt,
- fn formal => (Env.extendStrid (E, arg, formal)
- ; elabStrexp body))
+ fn (formal, nest) => (Env.extendStrid (E, arg, formal)
+ ; elabStrexp (body, nest)))
in Env.extendFctid (E, name, closure)
end)
; Decs.empty)
) arg
- in List.fold (decs, Decs.empty, fn (d, decs) =>
+ in
+ List.fold (decs, Decs.empty, fn (d, decs) =>
Decs.append (decs, elabTopdec d))
end
-------------------------------------------------------
This sf.net email is sponsored by:ThinkGeek
Welcome to geek heaven.
http://thinkgeek.com/sf
_______________________________________________
MLton-devel mailing list
MLton-devel@lists.sourceforge.net
https://lists.sourceforge.net/lists/listinfo/mlton-devel