[MLton-devel] cvs commit: source-level profiling

Stephen Weeks sweeks@users.sourceforge.net
Sun, 12 Jan 2003 17:14:28 -0800


sweeks      03/01/12 17:14:28

  Modified:    mlprof   main.sml
               mlton/ast wrapped.sig
               mlton/atoms source-info.fun source-info.sig
               mlton/backend profile.fun
               mlton/control control.sig control.sml
               mlton/core-ml core-ml.fun core-ml.sig lookup-constant.fun
               mlton/elaborate elaborate-core.fun
               mlton/main main.sml
               mlton/ssa ssa-tree.fun
               mlton/type-inference infer.fun scope.fun
               mlton/xml xml-tree.fun
  Log:
  Display function name instead of <file>: <line> in profiling, except
  with anonymous functions.
  
  Also, fixed problems with the source information being incorrect for
  mutually recursive functions and with extra source information being
  created for compiler-generated functions.
  
  Changed -profile xml to -profile source, which seems like a better
  name to me from a user perspective.
  
  Added option to mlprof: -show-line {false|true}.  This allows you to
  see the line numbers in addition to the function names if you want.

Revision  Changes    Path
1.25      +47 -8     mlton/mlprof/main.sml

Index: main.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlprof/main.sml,v
retrieving revision 1.24
retrieving revision 1.25
diff -u -r1.24 -r1.25
--- main.sml	7 Jan 2003 16:23:51 -0000	1.24
+++ main.sml	13 Jan 2003 01:14:25 -0000	1.25
@@ -20,21 +20,56 @@
 
 val graphShow = ref GraphShow.Above
 val raw = ref false
+val showLine = ref false
 val thresh: int ref = ref 0
 
 val die = Process.fail
-   
+
+structure Source =
+   struct
+      datatype t =
+	 NamePos of {name: string,
+		     pos: string}
+       | Simple of string
+
+      fun toString n =
+	 case n of
+	    NamePos {name, pos} =>
+	       if !showLine
+		  then concat [name, " ", pos]
+	       else name
+	  | Simple s => s
+
+      val layout = Layout.str o toString
+
+      fun fromString s =
+	 case String.tokens (s, fn c => Char.equals (c, #"\t")) of
+	    [s] => Simple s
+	  | [name, pos] => NamePos {name = name, pos = pos}
+	  | _ => die "strange source"
+
+      fun toDotLabel s =
+	 case s of
+	    NamePos {name, pos} =>
+	       if !showLine
+		  then [(name, Dot.Center),
+			(pos, Dot.Center)]
+	       else [(name, Dot.Center)]
+	  | Simple s =>
+	       [(s, Dot.Center)]
+   end
+
 structure AFile =
    struct
       datatype t = T of {magic: word,
 			 name: string,
 			 sourceSuccessors: int vector vector,
-			 sources: string vector}
+			 sources: Source.t vector}
 
       fun layout (T {magic, name, sourceSuccessors, sources}) =
 	 Layout.record [("name", String.layout name),
 			("magic", Word.layout magic),
-			("sources", Vector.layout String.layout sources),
+			("sources", Vector.layout Source.layout sources),
 			("sourceSuccessors",
 			 Vector.layout (Vector.layout Int.layout)
 			 sourceSuccessors)]
@@ -49,7 +84,8 @@
 	     val sourcesLength = valOf (Int.fromString (line ()))
 	     val sources =
 		Vector.tabulate (sourcesLength, fn _ =>
-				 String.dropSuffix (line (), 1))
+				 Source.fromString
+				 (String.dropSuffix (line (), 1)))
 	     val sourceSuccessors =
 		Vector.tabulate
 		(sourcesLength, fn _ =>
@@ -266,7 +302,7 @@
 	     val showInTable =
 		(per > 0.0 andalso per >= thresh)
 		orelse (not profileStack andalso i = sourcesIndexGC)
-	     val name = Vector.sub (sources, i)
+	     val source = Vector.sub (sources, i)
 	     val node =
 		if (not profileStack orelse i <> sourcesIndexGC)
 		   andalso (case !graphShow of
@@ -280,8 +316,9 @@
 			    List.push
 			    (no,
 			     Dot.NodeOption.Label
-			     [(name, Dot.Center),
-			      (concat (List.separate (row, " ")), Dot.Center)])
+			     (Source.toDotLabel source
+			      @ [(concat (List.separate (row, " ")),
+				  Dot.Center)]))
 			 val _ =
 			    List.push (no, Dot.NodeOption.Shape Dot.Box)
 		      in
@@ -291,7 +328,7 @@
 	  in
 	     {node = node,
 	      per = per,
-	      row = name :: row,
+	      row = Source.toString source :: row,
 	      showInTable = showInTable}
 	  end)
       val counts =
@@ -400,6 +437,8 @@
 		       | _ => usage "invalid -graph arg")),
 	(Normal, "raw", " {false|true}", "show raw counts",
 	 boolRef raw),
+	(Normal, "show-line", " {false|true}", " show line numbers",
+	 boolRef showLine),
 	(Normal, "thresh", " {0|1|...|100}", "only show counts above threshold",
 	 Int (fn i => if i < 0 orelse i > 100
 			 then usage "invalid -thresh"



1.5       +0 -1      mlton/mlton/ast/wrapped.sig

Index: wrapped.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/wrapped.sig,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- wrapped.sig	10 Apr 2002 07:02:18 -0000	1.4
+++ wrapped.sig	13 Jan 2003 01:14:25 -0000	1.5
@@ -13,7 +13,6 @@
       type obj
 
       val dest: obj -> node' * Region.t
-(*      val make: node' -> obj *)
       val makeRegion': node' * SourcePos.t * SourcePos.t -> obj
       val makeRegion: node' * Region.t -> obj
       val node: obj -> node'



1.3       +117 -34   mlton/mlton/atoms/source-info.fun

Index: source-info.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/source-info.fun,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- source-info.fun	11 Jan 2003 02:18:46 -0000	1.2
+++ source-info.fun	13 Jan 2003 01:14:25 -0000	1.3
@@ -1,44 +1,127 @@
 functor SourceInfo (S: SOURCE_INFO_STRUCTS): SOURCE_INFO =
 struct
 
-type t = string
-
-fun toString s = s
+structure Pos =
+   struct
+      datatype t =
+	 Known of {file: string,
+		   isBasis: bool,
+		   line: int}
+       | Unknown
+
+      fun equals (p, p') =
+	 case (p, p') of
+	    (Known {file = f, line = l, ...},
+	     Known {file = f', line = l', ...}) =>
+	       f = f' andalso l = l'
+	   | (Unknown, Unknown) => true
+	   | _ => false
+
+      fun toString p =
+	 case p of
+	    Known {file, line, ...} =>
+	       concat [file, ": ", Int.toString line]
+	  | Unknown => "<unknown>"
+
+      fun fromRegion r =
+	 case Region.left r of
+	    NONE => Unknown
+	  | SOME (SourcePos.T {file, line, ...}) =>
+	       let
+		  val s = "/basis-library/"
+		  val (file, isBasis) = 
+		     case String.findSubstring {string = file, substring = s} of
+			NONE => (file, false)
+		      | SOME i =>
+			   (concat ["<basis>/",
+				    String.dropPrefix (file, i + String.size s)],
+			    true)
+	       in
+		  Known {file = file,
+			 isBasis = isBasis,
+			 line = line}
+	       end
+
+      fun isBasis p =
+	 case p of
+	    Known {isBasis, ...} => isBasis
+	  | Unknown => false
+   end
+
+datatype info =
+   Anonymous of Pos.t
+ | C of string
+ | Function of {name: string,
+		pos: Pos.t}
+
+datatype t = T of {hash: word,
+		   info: info,
+		   plist: PropertyList.t}
+
+fun new info = T {hash = Random.word (),
+		  info = info,
+		  plist = PropertyList.new ()}
+
+local
+   fun make f (T r) = f r
+in
+   val hash = make #hash
+   val info = make #info
+   val plist = make #plist
+end
+
+fun anonymous r = new (Anonymous (Pos.fromRegion r))
+
+local
+   val set: {hash: word,
+	     name: string,
+	     sourceInfo: t} HashSet.t =
+      HashSet.new {hash = #hash}
+in   
+   fun fromC (name: string) =
+      let
+	 val hash = String.hash name
+      in
+	 #sourceInfo
+	 (HashSet.lookupOrInsert
+	  (set, hash, fn {hash = h, ...} => hash = h,
+	   fn () => {hash = hash,
+		     name = name,
+		     sourceInfo = new (C name)}))
+      end
+end
+
+fun function {name, region} =
+   new (Function {name = name,
+		  pos = Pos.fromRegion region})
+
+fun toString si =
+   case info si of
+      Anonymous p => Pos.toString p
+    | C s => concat ["<", s, ">"]
+    | Function {name, pos} => concat [name, "\t", Pos.toString pos]
 
 val layout = Layout.str o toString
 
-val equals: t * t -> bool = op =
-
-val fromString = fn s => s
-
-val hash = String.hash
-
-val gc = "<gc>"
-val gcArrayAllocate = "<GC_arrayAllocate>"
-val main = "<main>"
-val polyEqual = "<poly-equal>"
-val unknown = "<unknown>"
+val equals: t * t -> bool =
+   fn (s, s') => PropertyList.equals (plist s, plist s')
 
-val basisPrefix = "<basis>/"
+val equals =
+   Trace.trace2 ("SourceInfo.equals", layout, layout, Bool.layout) equals
    
-fun fromRegion r =
-   case Region.left r of
-      NONE => "<unknown>"
-    | SOME (SourcePos.T {file, line, ...}) =>
-	 let
-	    val s = "/basis-library/"
-	    val file = 
-	       case String.findSubstring {string = file, substring = s} of
-		  NONE => file
-		| SOME i =>
-		     concat [basisPrefix,
-			     String.dropPrefix (file, i + String.size s)]
-	 in
-	    concat [file, ":", Int.toString line]
-	 end
-
-fun isBasis s =
-   String.isPrefix {prefix = basisPrefix,
-		    string = s}
+fun isBasis (s: t): bool =
+   case info s of
+      Anonymous p => Pos.isBasis p
+    | C _ => false
+    | Function {pos, ...} => Pos.isBasis pos
+
+val isBasis =
+   Trace.trace ("SourceInfo.isBasis", layout, Bool.layout) isBasis
+
+val gc = fromC "gc"
+val gcArrayAllocate = fromC "GC_arrayAllocate>"
+val main = fromC "main"
+val polyEqual = fromC "poly-equal"
+val unknown = fromC "unknown"
 
 end



1.3       +4 -2      mlton/mlton/atoms/source-info.sig

Index: source-info.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/source-info.sig,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- source-info.sig	11 Jan 2003 02:18:47 -0000	1.2
+++ source-info.sig	13 Jan 2003 01:14:26 -0000	1.3
@@ -11,15 +11,17 @@
 	 
       type t
 
+      val anonymous: Region.t -> t
       val equals: t * t -> bool
       val gc: t
       val gcArrayAllocate: t
-      val fromRegion: Region.t -> t
-      val fromString: string -> t
       val hash: t -> word
+      val fromC: string -> t
+      val function: {name: string, region: Region.t} -> t
       val isBasis: t -> bool
       val layout: t -> Layout.t
       val main: t
+      val plist: t -> PropertyList.t
       val polyEqual: t
       val toString: t -> string
       val unknown: t



1.17      +26 -25    mlton/mlton/backend/profile.fun

Index: profile.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/profile.fun,v
retrieving revision 1.16
retrieving revision 1.17
diff -u -r1.16 -r1.17
--- profile.fun	11 Jan 2003 02:18:47 -0000	1.16
+++ profile.fun	13 Jan 2003 01:14:26 -0000	1.17
@@ -95,31 +95,29 @@
       val profileTime: bool = profile = Control.ProfileTime
       val frameProfileIndices = ref []
       local
-	 val table: InfoNode.t HashSet.t =
-	    HashSet.new {hash = SourceInfo.hash o InfoNode.info}
 	 val c = Counter.new 0
 	 val sourceInfos = ref []
       in
-	 fun sourceInfoNode (si: SourceInfo.t) =
-	    HashSet.lookupOrInsert
-	    (table, SourceInfo.hash si,
-	     fn InfoNode.T {info = si', ...} => SourceInfo.equals (si, si'),
-	     fn () => let
-			 val _ = List.push (sourceInfos, si)
-			 val index = Counter.next c
-		      in
-			 InfoNode.T {index = index,
-				     info = si,
-				     successors = ref []}
-		      end)
+	 val {get = sourceInfoNode, ...} =
+	    Property.get (SourceInfo.plist,
+			  Property.initFun
+			  (fn si =>
+			   let
+			      val _ = List.push (sourceInfos, si)
+			      val index = Counter.next c
+			   in
+			      InfoNode.T {index = index,
+					  info = si,
+					  successors = ref []}
+			   end))
 	 val sourceInfoIndex = InfoNode.index o sourceInfoNode
-	 fun firstEnter (ps: Push.t list): InfoNode.t option =
-	    List.peekMap (ps, fn p =>
-			  case p of
-			     Push.Enter n => SOME n
-			   | _ => NONE)
 	 fun makeSources () = Vector.fromListRev (!sourceInfos)
       end
+      fun firstEnter (ps: Push.t list): InfoNode.t option =
+	 List.peekMap (ps, fn p =>
+		       case p of
+			  Push.Enter n => SOME n
+			| _ => NONE)
       (* unknown must be 0, which == SOURCES_INDEX_UNKNOWN from gc.h *)
       val unknownInfoNode = sourceInfoNode SourceInfo.unknown
       val unknownIndex = InfoNode.index unknownInfoNode
@@ -243,14 +241,19 @@
 				 andalso
 				 (equals (si, gcArrayAllocate)
 				  orelse (isBasis si 
-					  andalso
-					  (equals (si, main)
-					   orelse not (equals (si', main)))))
+					  andalso not (equals (si', main))))
 			      end
 			      then no ()
 			   else (InfoNode.call {from = node', to = node ()}
 				 ; yes ())
 	       end
+	    val enter =
+	       Trace.trace2 ("Profile.enter",
+			     List.layout Push.layout,
+			     SourceInfo.layout,
+			     Layout.tuple2 (List.layout Push.layout,
+					    Bool.layout))
+	       enter
 	    val _ =
 	       Vector.foreach
 	       (blocks, fn block as Block.T {label, ...} =>
@@ -588,9 +591,7 @@
 						"GC_gc" => SourceInfo.gc
 					      | "GC_arrayAllocate" =>
 						   SourceInfo.gcArrayAllocate
-					      | _ => 
-						   SourceInfo.fromString
-						   (concat ["<", name, ">"])
+					      | _ => SourceInfo.fromC name
 					  val set =
 					     setCurrentSource
 					     (sourceSeqIndex



1.63      +1 -1      mlton/mlton/control/control.sig

Index: control.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/control/control.sig,v
retrieving revision 1.62
retrieving revision 1.63
diff -u -r1.62 -r1.63
--- control.sig	11 Jan 2003 00:34:40 -0000	1.62
+++ control.sig	13 Jan 2003 01:14:26 -0000	1.63
@@ -201,7 +201,7 @@
 
       val profileBasis: bool ref
 
-      datatype profileIL = ProfileXML | ProfileSSA
+      datatype profileIL = ProfileSSA | ProfileSource
       val profileIL: profileIL ref
 	 
       val profileStack: bool ref



1.79      +3 -3      mlton/mlton/control/control.sml

Index: control.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/control/control.sml,v
retrieving revision 1.78
retrieving revision 1.79
diff -u -r1.78 -r1.79
--- control.sml	11 Jan 2003 00:34:40 -0000	1.78
+++ control.sml	13 Jan 2003 01:14:26 -0000	1.79
@@ -359,11 +359,11 @@
 
 structure ProfileIL =
    struct
-      datatype t = ProfileSSA | ProfileXML
+      datatype t = ProfileSSA | ProfileSource
 
       val toString =
 	 fn ProfileSSA => "ProfileSSA"
-	  | ProfileXML => "ProfileXML"
+	  | ProfileSource => "ProfileSource"
    end
 
 val profileBasis = control {name = "profile basis",
@@ -373,7 +373,7 @@
 datatype profileIL = datatype ProfileIL.t
    
 val profileIL = control {name = "profile IL",
-			 default = ProfileXML,
+			 default = ProfileSource,
 			 toString = ProfileIL.toString}
    
 val profileStack = control {name = "profile stack",



1.9       +47 -43    mlton/mlton/core-ml/core-ml.fun

Index: core-ml.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/core-ml/core-ml.fun,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- core-ml.fun	10 Apr 2002 07:02:20 -0000	1.8
+++ core-ml.fun	13 Jan 2003 01:14:26 -0000	1.9
@@ -213,9 +213,10 @@
 	   pat: Pat.t,
 	   tyvars: Tyvar.t vector}
   | Fun of {tyvars: Tyvar.t vector,
-	    decs: {var: Var.t,
+	    decs: {match: match,
+		   profile: SourceInfo.t,
 		   types: Type.t vector,
-		   match: match} vector}
+		   var: Var.t} vector}
   | Datatype of {
 		 tyvars: Tyvar.t vector,
 		 tycon: Tycon.t,
@@ -237,7 +238,8 @@
   | Const of Ast.Const.t
   | Con of Con.t
   | Record of exp Record.t
-  | Fn of match
+  | Fn of {match: match,
+	   profile: SourceInfo.t option}
   | App of exp * exp
   | Let of dec vector * exp
   | Constraint of exp * Type.t
@@ -307,7 +309,7 @@
 		     {tyvars = tyvars,
 		      vbs = Vector.new0 (),
 		      rvbs = (Vector.map
-			      (decs, fn {var, types, match} =>
+			      (decs, fn {match, types, var, ...} =>
 			       {pat = (Vector.fold
 				       (types, Apat.var (Var.toAst var),
 					fn (t, p) =>
@@ -325,21 +327,20 @@
       end
    and expToAst e =
       case Wrap.node e of
-	 Var x => Exp.var (Var.toAst x)
+	 App (e1, e2) => Exp.app (expToAst e1, expToAst e2)
+       | Con c => Exp.con (Con.toAst c)
+       | Const c => Exp.const c
+       | Constraint (e, t) => Exp.constraint (expToAst e, Type.toAst t)
+       | Fn {match, ...} => Exp.fnn (matchToAst match)
+       | Handle (try, match) => Exp.handlee (expToAst try, matchToAst match)
+       | Let (ds, e) => Exp.lett (Vector.map (ds, decToAst), expToAst e)
        | Prim p => Exp.longvid (Ast.Longvid.short
 				(Ast.Longvid.Id.fromString (Prim.toString p,
 							    Region.bogus)))
-       | Const c => Exp.const c
-       | Con c => Exp.con (Con.toAst c)
+       | Raise {exn, filePos} =>
+	    Exp.raisee {exn = expToAst exn, filePos = filePos}
        | Record r => Exp.record (Record.map (r, expToAst))
-       | Fn m => Exp.fnn (matchToAst m)
-       | App (e1, e2) => Exp.app (expToAst e1, expToAst e2)
-       | Let (ds, e) => Exp.lett (Vector.map (ds, decToAst), expToAst e)
-       | Constraint (e, t) => Exp.constraint (expToAst e, Type.toAst t)
-       | Handle (try, match) =>
-	    Exp.handlee (expToAst try, matchToAst match)
-       | Raise {exn, filePos} => Exp.raisee {exn = expToAst exn,
-					     filePos = filePos}
+       | Var x => Exp.var (Var.toAst x)
 
    and matchToAst m =
       let
@@ -355,21 +356,21 @@
    let
       fun exp e =
 	 case Wrap.node e of
-	    Var x => f x
-	  | Record r => Record.foreach (r, exp)
-	  | Fn m => match m
-	  | App (e1, e2) => (exp e1; exp e2)
-	  | Let (ds, e) => (Vector.foreach (ds, dec); exp e)
+	    App (e1, e2) => (exp e1; exp e2)
 	  | Constraint (e, _) => exp e
+	  | Fn {match = m, ...} => match m
 	  | Handle (e, m) => (exp e; match m)
+	  | Let (ds, e) => (Vector.foreach (ds, dec); exp e)
 	  | Raise {exn, ...} => exp exn
+	  | Record r => Record.foreach (r, exp)
+	  | Var x => f x
 	  | _ => ()
       and match m = Vector.foreach (Match.rules m, exp o #2)
       and dec d =
 	 case Wrap.node d of
-	    Val {exp = e, ...} => exp e
-	  | Fun {decs, ...} => Vector.foreach (decs, match o #match)
+	    Fun {decs, ...} => Vector.foreach (decs, match o #match)
 	  | Overload {ovlds, ...} => Vector.foreach (ovlds, f)
+	  | Val {exp = e, ...} => exp e
 	  | _ => ()
    in
       {exp = exp, dec = dec}
@@ -392,8 +393,9 @@
       fun fnn (m, r) = makeRegion (Fn m, r)
 
       fun fn1 (p, e, r) =
-	 fnn (Match.new {filePos = "",
-			 rules = Vector.new1 (p, e)},
+	 fnn ({match = Match.new {filePos = "",
+				  rules = Vector.new1 (p, e)},
+	       profile = NONE},
 	      r)
 
       fun isExpansive e =
@@ -415,10 +417,12 @@
 	 
       fun lambda (x, e, r) = fn1 (makeRegion (Pat.Var x, r), e, r)
 
-      fun delay (e, r) = fn1 (Pat.unit r, e, r)
+(*      fun delay (e, r) = fn1 (Pat.unit r, e, r) *)
 
       fun casee (test, rules, r) =
-	 makeRegion (App (makeRegion (Fn rules, r),
+	 makeRegion (App (makeRegion (Fn {match = rules,
+					  profile = NONE},
+				      r),
 			  test),
 		     r)
 
@@ -485,24 +489,24 @@
 	 let
 	    val loop = Var.newNoname ()
 	    val call = makeRegion (App (var (loop, r), unit r), r)
+	    val match =
+	       Match.new {filePos = "",
+			  rules = (Vector.new1
+				   (Pat.tuple (Vector.new0 (), r),
+				    iff (test,
+					 seq (Vector.new2 (expr, call), r),
+					 unit r,
+					 r)))}
 	 in
 	    makeRegion
 	    (Let (Vector.new1
 		  (makeRegion
 		   (Fun {tyvars = Vector.new0 (),
 			 decs = (Vector.new1
-				 {var = loop,
+				 {match = match,
+				  profile = SourceInfo.anonymous r,
 				  types = Vector.new0 (),
-				  match = (Match.new
-					   {filePos = "",
-					    rules =
-					    Vector.new1
-					    (Pat.tuple (Vector.new0 (), r),
-					     iff (test,
-						  seq (Vector.new2 (expr, call),
-						       r),
-						  unit r,
-						  r))})})},
+				  var = loop})},
 		    r)),
 		  call),
 	     r)
@@ -550,20 +554,20 @@
 	    fun exp e =
 	       (inc ()
 		; (case Exp.node e of
-		      Fn m => match m
-		    | Record r => Record.foreach (r, exp)
-		    | App (e, e') => (exp e; exp e')
-		    | Let (ds, e) => (Vector.foreach (ds, dec); exp e)
+		      App (e, e') => (exp e; exp e')
 		    | Constraint (e, _) => exp e
+		    | Fn {match = m, ...} => match m
 		    | Handle (e, m) => (exp e; match m)
+		    | Let (ds, e) => (Vector.foreach (ds, dec); exp e)
 		    | Raise {exn, ...} => exp exn
+		    | Record r => Record.foreach (r, exp)
 		    | _ => ()))
 	    and match m = Vector.foreach (Match.rules m, exp o #2)
 	    and dec d =
 	       case Dec.node d of
-		  Val {exp = e, ...} => exp e
+		  Exception _ => inc ()
 		| Fun {decs, ...} => Vector.foreach (decs, match o #match)
-		| Exception _ => inc ()
+		| Val {exp = e, ...} => exp e
 		| _ => ()
 	    val _ = Vector.foreach (ds, dec)
 	 in



1.7       +6 -6      mlton/mlton/core-ml/core-ml.sig

Index: core-ml.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/core-ml/core-ml.sig,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- core-ml.sig	10 Apr 2002 07:02:20 -0000	1.6
+++ core-ml.sig	13 Jan 2003 01:14:26 -0000	1.7
@@ -70,7 +70,8 @@
 	     | Con of Con.t
 	     | Const of Ast.Const.t
 	     | Constraint of t * Type.t
-	     | Fn of match
+	     | Fn of {match: match,
+		      profile: SourceInfo.t option}
 	     | Handle of t * match
 	     | Let of dec vector * t
 	     | Prim of Prim.t
@@ -83,7 +84,7 @@
 
 	    val andAlso: t * t * Region.t -> t
 	    val casee: t * match * Region.t -> t
-	    val delay: t * Region.t -> t
+(*	    val delay: t * Region.t -> t *)
 	    val force: t * Region.t -> t
 	    val foreachVar: t * (Var.t -> unit) -> unit
 	    val iff: t * t * t * Region.t -> t
@@ -130,11 +131,10 @@
 			    }
 	     | Fun of {
 		       tyvars: Tyvar.t vector,
-		       decs: {
-			      var: Var.t,
+		       decs: {match: Match.t,
+			      profile: SourceInfo.t,
 			      types: Type.t vector, (* multiple constraints *)
-			      match: Match.t
-			     } vector
+			      var: Var.t} vector
 		      }
 	     | Overload of {
 			    var: Var.t,



1.18      +7 -7      mlton/mlton/core-ml/lookup-constant.fun

Index: lookup-constant.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/core-ml/lookup-constant.fun,v
retrieving revision 1.17
retrieving revision 1.18
diff -u -r1.17 -r1.18
--- lookup-constant.fun	3 Jan 2003 06:14:16 -0000	1.17
+++ lookup-constant.fun	13 Jan 2003 01:14:27 -0000	1.18
@@ -66,7 +66,12 @@
       open Exp Dec
       fun loopExp (e: Exp.t, ac: res): res =
 	 case Exp.node e of
-	    Prim p =>
+	    App (e, e') => loopExp (e, loopExp (e', ac))
+	  | Constraint (e, _) => loopExp (e, ac)
+	  | Fn {match = m, ...} => loopMatch (m, ac)
+	  | Handle (e, m) => loopMatch (m, loopExp (e, ac))
+	  | Let (ds, e) => loopDecs (ds, loopExp (e, ac))
+	  | Prim p =>
 	       (case Prim.name p of
 		   Prim.Name.Constant c =>
 		      let
@@ -96,13 +101,8 @@
 			  | _ => strange ()
 		      end
 		 | _ => ac)
-	  | Record r => Record.fold (r, ac, loopExp)
-	  | Fn m => loopMatch (m, ac)
-	  | App (e, e') => loopExp (e, loopExp (e', ac))
-	  | Let (ds, e) => loopDecs (ds, loopExp (e, ac))
-	  | Constraint (e, _) => loopExp (e, ac)
-	  | Handle (e, m) => loopMatch (m, loopExp (e, ac))
 	  | Raise {exn, ...} => loopExp (exn, ac)
+	  | Record r => Record.fold (r, ac, loopExp)
 	  | _ => ac
       and loopMatch (m, ac: res): res =
 	 Vector.fold (Match.rules m , ac, fn ((_, e), ac) => loopExp (e, ac))



1.12      +117 -61   mlton/mlton/elaborate/elaborate-core.fun

Index: elaborate-core.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-core.fun,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- elaborate-core.fun	10 Apr 2002 07:02:20 -0000	1.11
+++ elaborate-core.fun	13 Jan 2003 01:14:27 -0000	1.12
@@ -48,6 +48,7 @@
    structure Ctype = Type
    structure Cvar = Var
    structure Scheme = Scheme
+   structure SourceInfo = SourceInfo
    structure Tycon = Tycon
    structure Type = Type
    structure Tyvar = Tyvar
@@ -62,6 +63,26 @@
 structure Parse = PrecedenceParse (structure Ast = Ast
 				   structure Env = Env)
 
+structure Apat =
+   struct
+      open Apat
+
+      fun getName (p: t): string option =
+	 case node p of
+	    Var {name, ...} => SOME (Longvid.toString name)
+	  | Constraint (p, _) => getName p
+	  | FlatApp v =>
+	       if 1 = Vector.length v
+		  then getName (Vector.sub (v, 0))
+	       else NONE
+	  | Layered {var, ...} => SOME (Avar.toString var)
+	  | _ => NONE
+
+      val getName =
+	 Trace.trace ("Apat.getName", layout, Option.layout String.layout)
+	 getName
+   end
+
 structure Lookup =
    struct
       type t = Longtycon.t -> TypeStr.t
@@ -304,7 +325,7 @@
 end
 
 val info = Trace.info "elaborateDec"
-val info' = Trace.info "elaborateExp"
+val elabExpInfo = Trace.info "elaborateExp"
 
 fun elaborateDec (d, E) =
    let
@@ -442,7 +463,8 @@
 			   (clauses, fn {pats, resultType, body} =>
 			    let
 			       val {func, args} = Parse.parseClause (pats, E)
-			    in {func = func,
+			    in
+			       {func = func,
 				args = args,
 				resultType = resultType,
 				body =
@@ -488,54 +510,66 @@
 			     then Error.bug "empty clauses in fundec"
 			  else
 			     let
-				val {args, ...} = Vector.sub (clauses, 0)
+				val {func, args, ...} = Vector.sub (clauses, 0)
+				val profile =
+				   SourceInfo.function
+				   {name = Ast.Var.toString func,
+				    region = region}
 				val numVars = Vector.length args
-			     in {var = newFunc,
+				val match =
+				   let
+				      val rs =
+					 Vector.map
+					 (clauses,
+					  fn {args, resultType, body, ...} =>
+					  let
+					     val (pats, body) =
+						Env.scope
+						(E, fn () =>
+						 (elaboratePatsV (args, E),
+						  elabExp body))
+					  in (Cpat.tuple (pats, region),
+					      constrain (body,
+							 elabTypeOpt resultType,
+							 region))
+					  end)
+				      fun make (i, xs) =
+					 if i = 0
+					    then
+					       Cexp.casee
+					       (Cexp.tuple
+						(Vector.rev
+						 (Vector.fromListMap
+						  (xs, fn x =>
+						   doit (Cexp.Var x))),
+						 region),
+						Cmatch.new {filePos = filePos,
+							    rules = rs},
+						region)
+					 else 
+					    let
+					       val x = Cvar.newNoname ()
+					    in
+					       Cexp.lambda
+					       (x,
+						make (i - 1, x :: xs),
+						region)
+					    end
+				   in if numVars = 1
+					 then Cmatch.new {filePos = filePos,
+							  rules = rs}
+				      else (case Cexp.node (make (numVars, [])) of
+					       Cexp.Fn {match = m, ...} => m
+					     | _ => Error.bug "elabFbs")
+				   end
+			     in
+				{match = match,
+				 profile = profile,
 				 types = Vector.new0 (),
-				 match =
-				 let
-				    val rs =
-				       Vector.map
-				       (clauses,
-					fn {args, resultType, body, ...} =>
-					let
-					   val (pats, body) =
-					      Env.scope
-					      (E, fn () =>
-					       (elaboratePatsV (args, E),
-						elabExp body))
-					in (Cpat.tuple (pats, region),
-					    constrain (body,
-						       elabTypeOpt resultType,
-						       region))
-					end)
-				    fun make (i, xs) =
-				       if i = 0
-					  then
-					     Cexp.casee
-					     (Cexp.tuple
-					      (Vector.rev
-					       (Vector.fromListMap
-						(xs, fn x => doit (Cexp.Var x))),
-					       region),
-					      Cmatch.new {filePos = filePos,
-							  rules = rs},
-					      region)
-				       else 
-					  let val x = Cvar.newNoname ()
-					  in Cexp.lambda (x,
-							  make (i - 1, x :: xs),
-							  region)
-					  end
-				 in if numVars = 1
-				       then Cmatch.new {filePos = filePos,
-							rules = rs}
-				    else (case Cexp.node (make (numVars, [])) of
-					     Cexp.Fn m => m
-					   | _ => Error.bug "elabFbs")
-				 end}
+				 var = newFunc}
 			     end)
-		   in Decs.single (Cdec.makeRegion (Cdec.Fun {tyvars = tyvars,
+		   in
+		      Decs.single (Cdec.makeRegion (Cdec.Fun {tyvars = tyvars,
 							      decs = decs},
 						    region))
 		   end
@@ -597,7 +631,8 @@
 		      (* Must do all the es and rvbs pefore the ps because of
 		       * scoping rules.
 		       *)
-		      val es = Vector.map (vbs, elabExp o #exp)
+		      val es = Vector.map (vbs, fn {pat, exp, ...} =>
+					   elabExp' (exp, Apat.getName pat))
 		      fun varsAndTypes (p: Apat.t, vars, types)
 			 : Avar.t list * Atype.t list =
 			 let
@@ -640,9 +675,9 @@
 			 (rvbs, fn {pat, ...} =>
 			  let
 			     val (vars, types) = varsAndTypes (pat, [], [])
-			     val var =
+			     val (name, var) =
 				case vars of
-				   [] => Cvar.newNoname ()
+				   [] => ("<anon>", Cvar.newNoname ())
 				 | x :: _ =>
 				      let
 					 val x' = Cvar.fromAst x
@@ -651,18 +686,24 @@
 					    (vars, fn y =>
 					     Env.extendVar (E, y, x'))
 				      in
-					 x'
+					 (Avar.toString x, x')
 				      end
 			  in
-			     (var,
-			      Vector.fromListMap (types, Scheme.ty o elabType))
+			     {name = name,
+			      types = (Vector.fromListMap
+				       (types, Scheme.ty o elabType)),
+			      var = var}
 			  end)
 		      val rvbs =
 			 Vector.map2
-			 (rvbs, vts, fn ({match, ...}, (var, types)) =>
-			  {var = var,
+			 (rvbs, vts,
+			  fn ({pat, match, ...}, {name, types, var}) =>
+			  {match = elabMatch match,
+			   profile = (SourceInfo.function
+				      {name = name,
+				       region = Apat.region pat}),
 			   types = types,
-			   match = elabMatch match})
+			   var = var})
 		      val ps = Vector.map (vbs, fn {pat, filePos, ...} =>
 					   {pat = elaboratePat (pat, E),
 					    filePos = filePos,
@@ -704,10 +745,14 @@
 	  end) d
       and elabExps (es: Ast.Exp.t list): Cexp.t list =
 	 List.map (es, elabExp)
-      and elabExp arg: Cexp.t =
-	 Trace.traceInfo (info', Ast.Exp.layout, Cexp.layout,
+      and elabExp e = elabExp' (e, NONE)
+      and elabExp' (arg: Aexp.t * string option): Cexp.t =
+	 Trace.traceInfo (elabExpInfo,
+			  Layout.tuple2 (Aexp.layout,
+					 Option.layout String.layout),
+			  Cexp.layout,
 			  Trace.assertTrue)
-	 (fn (e: Aexp.t) =>
+	 (fn (e: Aexp.t, name) =>
 	  let
 	     val region = Aexp.region e
 	     fun doit n = Cexp.makeRegion (n, region)
@@ -721,9 +766,20 @@
 		   Cexp.casee (elabExp e, elabMatch m, region)
 	      | Aexp.Const c => doit (Cexp.Const c)
 	      | Aexp.Constraint (e, t) =>
-		   doit (Cexp.Constraint (elabExp e, Scheme.ty (elabType t)))
+		   doit (Cexp.Constraint (elabExp' (e, name),
+					  Scheme.ty (elabType t)))
 	      | Aexp.FlatApp items => elabExp (Parse.parseExp (items, E))
-	      | Aexp.Fn m => doit (Cexp.Fn (elabMatch m))
+	      | 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,
+				     profile = SOME profile})
+		   end
 	      | Aexp.Handle (try, match) =>
 		   doit (Cexp.Handle (elabExp try, elabMatch match))
 	      | Aexp.If (a, b, c) =>



1.111     +2 -2      mlton/mlton/main/main.sml

Index: main.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/main/main.sml,v
retrieving revision 1.110
retrieving revision 1.111
diff -u -r1.110 -r1.111
--- main.sml	11 Jan 2003 00:34:40 -0000	1.110
+++ main.sml	13 Jan 2003 01:14:27 -0000	1.111
@@ -263,11 +263,11 @@
        (Expert, "profile-basis", " {false|true}",
 	"profile the basis implementation",
 	boolRef profileBasis),
-       (Expert, "profile-il", " {xml}", "where to insert profile exps",
+       (Expert, "profile-il", " {source}", "where to insert profile exps",
 	SpaceString
 	(fn s =>
 	 case s of
-	    "xml" => profileIL := ProfileXML
+	    "source" => profileIL := ProfileSource
 	  | _ => usage (concat ["invalid -profile-il arg: ", s]))),
        (Normal, "profile-stack", " {false|true}",
 	"profile the stack",



1.55      +1 -1      mlton/mlton/ssa/ssa-tree.fun

Index: ssa-tree.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/ssa-tree.fun,v
retrieving revision 1.54
retrieving revision 1.55
diff -u -r1.54 -r1.55
--- ssa-tree.fun	11 Jan 2003 00:34:40 -0000	1.54
+++ ssa-tree.fun	13 Jan 2003 01:14:27 -0000	1.55
@@ -1342,7 +1342,7 @@
 
       fun profile (f: t, sourceInfo): t =
 	 if !Control.profile = Control.ProfileNone
-	    orelse !Control.profileIL <> Control.ProfileXML
+	    orelse !Control.profileIL <> Control.ProfileSource
 	    then f
 	 else 
 	 let



1.21      +18 -15    mlton/mlton/type-inference/infer.fun

Index: infer.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/type-inference/infer.fun,v
retrieving revision 1.20
retrieving revision 1.21
diff -u -r1.20 -r1.21
--- infer.fun	10 Jan 2003 20:52:49 -0000	1.20
+++ infer.fun	13 Jan 2003 01:14:27 -0000	1.21
@@ -841,7 +841,7 @@
 		      (fn () => Vector.map (valOf (!argsRef) (), Xtype.var))
 		   val (decs, env') =
 		      Vector.mapAndFold
-		      (decs, env, fn ({var, types, match}, env) =>
+		      (decs, env, fn ({match, profile, types, var}, env) =>
 		       let
 			  val argType = newType ()
 			  val resultType = newType ()
@@ -852,10 +852,11 @@
 			      Type.unify (t, Type.fromCoreML t',
 					  Cmatch.region match))
 		       in
-			  ({var = var,
-			    argType = argType,
+			  ({argType = argType,
+			    match = match,
+			    profile = profile,
 			    resultType = resultType,
-			    match = match},
+			    var = var},
 			   Env.extendVarRange
 			   (env, var,
 			    VarRange.T {scheme = Scheme.fromType t,
@@ -864,17 +865,19 @@
 		   val region = Cmatch.region (#match (Vector.sub (decs, 0)))
 		   val decs =
 		      Vector.map
-		      (decs, fn {var, match, argType, resultType} =>
+		      (decs, fn {argType, match, profile, resultType, var} =>
 		       let
 			  val saved = !currentFunction
 			  val _ = currentFunction := var :: saved
 			  val rs = inferMatchUnify (match, env',
 						    argType, resultType)
 			  val _ = currentFunction := saved
-		       in {var = var,
+		       in
+			  {profile = profile,
 			   region = Cmatch.region match,
 			   rules = rs,
-			   ty = Type.arrow (argType, resultType)}
+			   ty = Type.arrow (argType, resultType),
+			   var = var}
 		       end)
 		   val {bound, schemes} =
 		      Env.closes (env, Vector.map (decs, #ty), tyvars, region)
@@ -887,7 +890,8 @@
 			  [Xdec.Fun
 			   {tyvars = bound (),
 			    decs = (Vector.map
-				    (decs, fn {var, region, rules, ty} =>
+				    (decs,
+				     fn {var, profile, region, rules, ty} =>
 				     let
 					val ty = Type.toXml (ty, region)
 					val {arg, argType, body, ...} =
@@ -895,9 +899,7 @@
 					   (forceRulesMatch (rules, region))
 					val body =
 					   Xml.Exp.enterLeave
-					   (body,
-					    #2 (Xtype.dearrow ty),
-					    SourceInfo.fromRegion region)
+					   (body, #2 (Xtype.dearrow ty), profile)
 					val lambda =
 					   Xlambda.new
 					   {arg = arg,
@@ -986,7 +988,7 @@
 				    ty = Type.toXml (ty, region)}),
 		       ty, region)
 		   end
-	      | Cexp.Fn m =>
+	      | Cexp.Fn {match = m, profile} =>
 		   let
 		      val rs as {argType, resultType, rules, ...} =
 			 inferMatch (m, env)
@@ -997,9 +999,10 @@
 			     Xlambda.dest (forceRulesMatch (rs, region))
 			  val resultType = Type.toXml (resultType, region)
 			  val body =
-			     Xml.Exp.enterLeave (body,
-						 resultType,
-						 SourceInfo.fromRegion region)
+			     case profile of
+				NONE => body
+			      | SOME si =>
+				   Xml.Exp.enterLeave (body, resultType, si)
 		       in
 			  Xexp.lambda {arg = arg,
 				       argType = argType,



1.7       +19 -9     mlton/mlton/type-inference/scope.fun

Index: scope.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/type-inference/scope.fun,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- scope.fun	10 Apr 2002 07:02:21 -0000	1.6
+++ scope.fun	13 Jan 2003 01:14:28 -0000	1.7
@@ -141,12 +141,16 @@
 	    let
 	       val (env, tyvars) = TyvarEnv.rename (env, tyvars)
 	       val (decs, unguarded) =
-		  renames (decs, fn {var, types, match} =>
+		  renames (decs, fn {match, profile, types, var} =>
 			   let
 			      val (types, u1) = renames (types, fn t =>
 							 renameTy (t, env))
 			      val (match, u2) = renameMatch (match, env)
-			   in ({var = var, types = types, match = match},
+			   in
+			      ({match = match,
+				profile = profile,
+				types = types,
+				var = var},
 			       Tyvars.+ (u1, u2))
 			   end)
 	    in (doit (Fun {tyvars = (Vector.fromList
@@ -211,9 +215,12 @@
 	    in
 	       (doit (Constraint (e, t)), Tyvars.+ (u1, u2))
 	    end
-       | Fn m =>
-	    let val (m, unguarded) = renameMatch (m, env)
-	    in (doit (Fn m), unguarded)
+       | Fn {match = m, profile} =>
+	    let
+	       val (m, unguarded) = renameMatch (m, env)
+	    in
+	       (doit (Fn {match = m, profile = profile}),
+		unguarded)
 	    end
        | Handle (e, m) =>
 	    let
@@ -334,11 +341,12 @@
 	       doit
 	       (Fun {tyvars = tyvars,
 		     decs = (Vector.map
-			     (decs, fn {var, types, match} =>
-			      {var = var,
+			     (decs, fn {match, profile, types, var} =>
+			      {match = removeMatch (match, scope),
+			       profile = profile,
 			       types = Vector.map (types, fn t =>
 						   removeTy (t, scope)),
-			       match = removeMatch (match, scope)}))})
+			       var = var}))})
 	    end
        | Exception {con, arg} =>
 	    doit (Exception {con = con,
@@ -368,7 +376,9 @@
        | Const _ => e
        | Constraint (e, t) =>
 	    doit (Constraint (removeExp (e, scope), removeTy (t, scope)))
-       | Fn m => doit (Fn (removeMatch (m, scope)))
+       | Fn {match = m, profile} =>
+	    doit (Fn {match = removeMatch (m, scope),
+		      profile = profile})
        | Handle (e, m) =>
 	    doit (Handle (removeExp (e, scope), removeMatch (m, scope)))
        | Let (ds, e) => doit (Let (removes (ds, scope, removeDec),



1.15      +1 -1      mlton/mlton/xml/xml-tree.fun

Index: xml-tree.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/xml/xml-tree.fun,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -r1.14 -r1.15
--- xml-tree.fun	10 Jan 2003 20:52:52 -0000	1.14
+++ xml-tree.fun	13 Jan 2003 01:14:28 -0000	1.15
@@ -342,7 +342,7 @@
 
       fun enterLeave (e: t, ty: Type.t, si: SourceInfo.t): t =
 	 if !Control.profile = Control.ProfileNone
-	    orelse !Control.profileIL <> Control.ProfileXML
+	    orelse !Control.profileIL <> Control.ProfileSource
 	    then e
 	 else
 	 let





-------------------------------------------------------
This SF.NET email is sponsored by:
SourceForge Enterprise Edition + IBM + LinuxWorld = Something 2 See!
http://www.vasoftware.com
_______________________________________________
MLton-devel mailing list
MLton-devel@lists.sourceforge.net
https://lists.sourceforge.net/lists/listinfo/mlton-devel