[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