[MLton] cvs commit: -profile count

Stephen Weeks sweeks@mlton.org
Thu, 13 May 2004 09:38:42 -0700


sweeks      04/05/13 09:38:41

  Modified:    include  c-main.h main.h x86-main.h
               mlprof   main.sml
               mlton/atoms prim.fun prim.sig
               mlton/backend profile.fun
               mlton/codegen/c-codegen c-codegen.fun
               mlton/control control.sig control.sml
               mlton/elaborate elaborate-core.fun
               mlton/main main.fun
               mlton/xml xml-tree.fun
               runtime  gc.c gc.h
  Log:
  MAIL -profile count
  
  Added to the profiling infrastructure the ability to count function
  calls and case branches.  This is enabled with the new flag
  
  	-profile count
  
  There is also an expert flag that controls whether branches are
  profiled.
  
  	-profile-branch {true|false}
  
  This is implemented as with the rest of the profiling stuff by
  inserting ProfileEnter and ProfileLeave annotations in the front end,
  and letting the profile pass at the very end of the backend turn these
  annotations into the appropriate calls.  -profile count is very much
  like -profile alloc.  It inserts a call to GC_profileInc just after
  each ProfileEnter.  One difference is that because I want to record
  every count and the simplifier is allowed to simplify ProfileEnter
  immediately followed by ProfileLeave, with -profile count the front
  end also inserts a call to touch just after every ProfileEnter.  This
  is sufficient to ensure that the annotations are never simplified
  away.  Of course, it can affect program performance, but getting
  accurate counts is more important.
  
  One nice use of -profile count is as a code coverage tool.  With it,
  you can run your programs on lots of different inputs, feed all the
  mlmon.out files to mlprof, and see which branches were never taken and
  which functions were never called.

Revision  Changes    Path
1.10      +2 -2      mlton/include/c-main.h

Index: c-main.h
===================================================================
RCS file: /cvsroot/mlton/mlton/include/c-main.h,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- c-main.h	7 Apr 2004 00:47:47 -0000	1.9
+++ c-main.h	13 May 2004 16:38:37 -0000	1.10
@@ -4,7 +4,7 @@
 #include "main.h"
 #include "c-common.h"
 
-#define Main(al, cs, mg, mfs, mmc, ps, mc, ml)				\
+#define Main(al, cs, mg, mfs, mmc, pk, ps, mc, ml)			\
 /* Globals */								\
 int nextFun;								\
 bool returnToC;								\
@@ -33,7 +33,7 @@
 int main (int argc, char **argv) {					\
 	struct cont cont;						\
 	gcState.native = FALSE;						\
-	Initialize (al, cs, mg, mfs, mmc, ps);				\
+	Initialize (al, cs, mg, mfs, mmc, pk, ps);			\
 	if (gcState.isOriginal) {					\
 		real_Init();						\
 		PrepFarJump(mc, ml);					\



1.8       +2 -1      mlton/include/main.h

Index: main.h
===================================================================
RCS file: /cvsroot/mlton/mlton/include/main.h,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- main.h	29 Aug 2003 00:25:20 -0000	1.7
+++ main.h	13 May 2004 16:38:37 -0000	1.8
@@ -20,7 +20,7 @@
 #define LoadArray(a, f) sfread (a, sizeof(*a), cardof(a), f)
 #define SaveArray(a, fd) swrite (fd, a, sizeof(*a) * cardof(a))
 
-#define Initialize(al, cs, mg, mfs, mmc, ps)				\
+#define Initialize(al, cs, mg, mfs, mmc, pk, ps)			\
 	gcState.alignment = al;						\
 	gcState.atMLtons = atMLtons;					\
 	gcState.atMLtonsSize = cardof(atMLtons);		       	\
@@ -39,6 +39,7 @@
 	gcState.mutatorMarksCards = mmc;				\
 	gcState.objectTypes = objectTypes;				\
 	gcState.objectTypesSize = cardof(objectTypes);			\
+	gcState.profileKind = pk;					\
 	gcState.profileStack = ps;					\
 	gcState.saveGlobals = saveGlobals;				\
 	gcState.sourceLabels = sourceLabels;				\



1.13      +2 -2      mlton/include/x86-main.h

Index: x86-main.h
===================================================================
RCS file: /cvsroot/mlton/mlton/include/x86-main.h,v
retrieving revision 1.12
retrieving revision 1.13
diff -u -r1.12 -r1.13
--- x86-main.h	7 Apr 2004 00:47:47 -0000	1.12
+++ x86-main.h	13 May 2004 16:38:37 -0000	1.13
@@ -43,7 +43,7 @@
 #error ReturnToC not defined
 #endif
 
-#define Main(al, cs, mg, mfs, mmc, ps, ml, reserveEsp)			\
+#define Main(al, cs, mg, mfs, mmc, pk, ps, ml, reserveEsp)		\
 void MLton_jumpToSML (pointer jump) {					\
 	word lc_stackP;							\
 			       						\
@@ -90,7 +90,7 @@
 	pointer jump;  							\
 	extern pointer ml;						\
 	gcState.native = TRUE;						\
-	Initialize (al, cs, mg, mfs, mmc, ps);				\
+	Initialize (al, cs, mg, mfs, mmc, pk, ps);			\
 	if (gcState.isOriginal) {					\
 		real_Init();						\
 		jump = (pointer)&ml;   					\



1.61      +9 -2      mlton/mlprof/main.sml

Index: main.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlprof/main.sml,v
retrieving revision 1.60
retrieving revision 1.61
diff -u -r1.60 -r1.61
--- main.sml	28 Feb 2004 01:16:25 -0000	1.60
+++ main.sml	13 May 2004 16:38:38 -0000	1.61
@@ -200,10 +200,11 @@
 
 structure Kind =
    struct
-      datatype t = Alloc | Empty | Time
+      datatype t = Alloc | Count | Empty | Time
 
       val toString =
 	 fn Alloc => "Alloc"
+	  | Count => "Count"
 	  | Empty => "Empty"
 	  | Time => "Time"
 
@@ -213,6 +214,7 @@
 	 fn (k, k') =>
 	 case (k, k') of
 	    (Alloc, Alloc) => Alloc
+	  | (Count, Count) => Count
 	  | (_, Empty) => k
 	  | (Empty, _) => k'
 	  | (Time, Time) => Time
@@ -335,6 +337,7 @@
 	     val kind =
 		case line () of
 		   "alloc" => Kind.Alloc
+		 | "count" => Kind.Count
 		 | "time" => Kind.Time
 		 | _ => Error.bug "invalid profile kind"
 	     val style =
@@ -704,6 +707,8 @@
 			  (case kind of
 			      Kind.Alloc =>
 				 ["(", IntInf.toCommaString ticks, ")"]
+			    | Kind.Count =>
+				 ["(", IntInf.toCommaString ticks, ")"]
 			    | Kind.Empty => []
 			    | Kind.Time =>
 				 ["(",
@@ -723,7 +728,7 @@
 		  val pc = per current
 		  val isNonZero = current > 0 orelse stack > 0 orelse stackGC > 0
 		  val tableInfo = 
-		     if isNonZero
+		     if isNonZero orelse kind = Kind.Count
 			then SOME {per = pc,
 				   row = Source.toStringMaybeLine source :: row}
 		     else NONE
@@ -927,6 +932,8 @@
 	      Kind.Alloc =>
 		 [IntInf.toCommaString total, " bytes allocated (",
 		  IntInf.toCommaString totalGC, " bytes by GC)\n"]
+	    | Kind.Count =>
+		 [IntInf.toCommaString total, " ticks\n"]
 	    | Kind.Empty => []
 	    | Kind.Time =>
 		 let



1.83      +1 -0      mlton/mlton/atoms/prim.fun

Index: prim.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/prim.fun,v
retrieving revision 1.82
retrieving revision 1.83
diff -u -r1.82 -r1.83
--- prim.fun	1 May 2004 00:49:34 -0000	1.82
+++ prim.fun	13 May 2004 16:38:38 -0000	1.83
@@ -643,6 +643,7 @@
 val intInfNotb = IntInf_notb
 val reff = Ref_ref
 val serialize = MLton_serialize
+val touch = MLton_touch
 val vectorLength = Vector_length
 val vectorSub = Vector_sub
 val wordAdd = Word_add



1.63      +1 -0      mlton/mlton/atoms/prim.sig

Index: prim.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/prim.sig,v
retrieving revision 1.62
retrieving revision 1.63
diff -u -r1.62 -r1.63
--- prim.sig	1 May 2004 00:49:34 -0000	1.62
+++ prim.sig	13 May 2004 16:38:38 -0000	1.63
@@ -250,6 +250,7 @@
       val reff: 'a t
       val serialize: 'a t
       val toString: 'a t -> string
+      val touch: 'a t
       val vectorLength: 'a t
       val vectorSub: 'a t
       val wordAdd: WordSize.t -> 'a t



1.36      +132 -85   mlton/mlton/backend/profile.fun

Index: profile.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/profile.fun,v
retrieving revision 1.35
retrieving revision 1.36
diff -u -r1.35 -r1.36
--- profile.fun	27 Apr 2004 08:10:49 -0000	1.35
+++ profile.fun	13 May 2004 16:38:38 -0000	1.36
@@ -117,10 +117,14 @@
    let
       val Program.T {functions, handlesSignals, main, objectTypes} = program
       val debug = false
-      val profile = !Control.profile
-      val profileAlloc: bool = profile = Control.ProfileAlloc
+      datatype profile = Alloc | Count | Time
+      val profile =
+	 (case !Control.profile of
+	     Control.ProfileAlloc => Alloc
+	   | Control.ProfileCount => Count
+	   | Control.ProfileTime => Time
+	   | _ => Error.bug "impossible Control.profile")
       val profileStack: bool = !Control.profileStack
-      val profileTime: bool = profile = Control.ProfileTime
       val frameProfileIndices: (Label.t * int) list ref = ref []
       val infoNodes: InfoNode.t list ref = ref []
       val nameCounter = Counter.new 0
@@ -272,30 +276,38 @@
 		  val node = Promise.lazy (fn () => sourceInfoNode si)
 		  fun yes () = (Push.Enter (node ()) :: ps, true)
 		  fun no () = (Push.Skip si :: ps, false)
+		  fun countOk () =
+		     !Control.profileBasis
+		     orelse profile <> Count
+		     orelse not (SourceInfo.isBasis si orelse SourceInfo.isC si)
 	       in
 		  if SourceInfo.equals (si, SourceInfo.unknown)
 		     then no ()
 		  else
 		     case firstEnter ps of
 			NONE =>
-			   (List.push (enters, node ())
-			    ; yes ())
+			   if countOk ()
+			      then (List.push (enters, node ())
+				    ; yes ())
+			   else no ()
 		      | SOME (node' as InfoNode.T {info = si', ...}) =>
-			   if let
+			   if countOk () andalso
+			      let
 				 open SourceInfo
 			      in
-				 not (!Control.profileBasis)
-				 andalso not (equals (si', unknown))
-				 andalso
-				 (equals (si, gcArrayAllocate)
-				  orelse isBasis si
-				  orelse (isC si
-					  andalso (isBasis si'
-						   orelse equals (si', main))))
+				 (!Control.profileBasis)
+				 orelse (equals (si', unknown))
+				 orelse
+				 (not
+				  (equals (si, gcArrayAllocate)
+				   orelse isBasis si
+				   orelse (isC si
+					   andalso (isBasis si'
+						    orelse equals (si', main)))))
 			      end
-			      then no ()
-			   else (InfoNode.call {from = node', to = node ()}
-				 ; yes ())
+			      then (InfoNode.call {from = node', to = node ()}
+				    ; yes ())
+			   else no ()
 	       end
 	    val enter =
 	       Trace.trace2 ("Profile.enter",
@@ -313,7 +325,7 @@
 	     * front of the function.
 	     *)
 	    local
-	       exception Yes of Label.t * SourceInfo.t
+	       exception Yes of Label.t * Statement.t
 	       fun goto l =
 		  let
 		     val {block, ...} = labelInfo l
@@ -322,18 +334,15 @@
 			Vector.foreach
 			(statements, fn s =>
 			 case s of
-			    Statement.Profile (ProfileExp.Enter si) =>
-			       raise Yes (l, si)
+			    Statement.Profile (ProfileExp.Enter _) =>
+			       raise Yes (l, s)
 			  | _ => ())
 		     val _ = Transfer.foreachLabel (transfer, goto)
 		  in
 		     ()
 		  end
 	    in
-	       val (firstLabel, firstSource) =
-		  (goto start
-		   ; (Label.bogus, SourceInfo.unknown))
-		  handle Yes z => z
+	       val first = (goto start; NONE) handle Yes z => SOME z
 	    end
 	    val blocks = ref []
 	    datatype z = datatype Statement.t
@@ -356,13 +365,14 @@
 		       | Profile ps =>
 			    let
 			       val (npl, ss) =
-				  if profileAlloc
-				     then (false, ss)
-				  else (* profileTime *)
-				     if npl andalso not (List.isEmpty sourceSeq)
-					then (false,
-					      profileLabel sourceSeq :: ss)
-				     else (true, ss)
+				  if profile = Time
+				     then
+					if npl
+					   andalso not (List.isEmpty sourceSeq)
+					   then (false,
+						 profileLabel sourceSeq :: ss)
+					else (true, ss)
+				  else (false, ss)
 			       val (leaves, sourceSeq) = 
 				  case ps of
 				     Enter _ =>
@@ -381,7 +391,7 @@
 			    end
 		       | _ => (leaves, true, sourceSeq, s :: ss))
 		  val statements =
-		     if profileTime andalso npl
+		     if profile = Time andalso npl
 			then profileLabel sourceSeq :: statements
 		     else statements
 		  val {args, kind, label} =
@@ -397,7 +407,7 @@
 				 addFrameProfileIndex
 				 (newLabel, sourceSeqIndex sourceSeq)
 			      val statements =
-				 if profileTime
+				 if profile = Time
 				    then (Vector.new1
 					  (profileLabelIndex
 					   (sourceSeqIndex sourceSeq)))
@@ -447,7 +457,7 @@
 		  val index = sourceSeqIndex (Push.toSources pushes)
 		  val _ = addFrameProfileIndex (newLabel, index)
 		  val statements =
-		     if profileTime
+		     if profile = Time
 			then Vector.new1 (profileLabelIndex index)
 		     else Vector.new0 ()
 		  val _ =
@@ -489,14 +499,22 @@
 			val Block.T {args, kind, label, statements, transfer,
 				     ...} = block
 			val statements =
-			   if Label.equals (label, firstLabel)
-			      then
-				 Vector.removeFirst
-				 (statements, fn s =>
-				  case s of
-				     Profile (Enter _) => true
-				   | _ => false)
-			   else statements
+			   case first of
+			      NONE => statements
+			    | SOME (firstLabel, firstEnter) =>
+				 if Label.equals (label, firstLabel)
+				    then
+				       Vector.removeFirst
+				       (statements, fn s =>
+					case s of
+					   Profile (Enter _) => true
+					 | _ => false)
+				 else if Label.equals (label, start)
+					 then
+					    Vector.concat
+					    [Vector.new1 firstEnter,
+					     statements]
+				      else statements
 			val _ =
 			   let
 			      fun add pushes =
@@ -527,49 +545,53 @@
 					label,
 					leaves,
 					pushes: Push.t list,
+					shouldSplit: bool,
 					statements} =
-			   if profileAlloc
-			      andalso Bytes.> (bytesAllocated, Bytes.zero)
-			      then
-				 let
-				    val newLabel = Label.newNoname ()
-				    val _ =
-				       addFrameProfilePushes (newLabel, pushes)
-				    val func = CFunction.profileInc
-				    val transfer =
-				       Transfer.CCall
-				       {args = (Vector.new2
-						(Operand.GCState,
-						 Operand.word
-						 (WordX.fromIntInf
-						  (IntInf.fromInt
-						   (Bytes.toInt bytesAllocated),
-						   WordSize.default)))),
-					func = func,
-					return = SOME newLabel}
-				    val sourceSeq = Push.toSources pushes
-				    val _ =
-				       backward {args = args,
-						 kind = kind,
-						 label = label,
-						 leaves = leaves,
-						 sourceSeq = sourceSeq,
-						 statements = statements,
-						 transfer = transfer}
-				 in
-				    {args = Vector.new0 (),
-				     bytesAllocated = Bytes.zero,
-				     kind = Kind.CReturn {func = func},
-				     label = newLabel,
-				     leaves = [],
-				     statements = []}
-				 end
-			   else {args = args,
-				 bytesAllocated = Bytes.zero,
-				 kind = kind,
-				 label = label,
-				 leaves = leaves,
-				 statements = statements}
+			   if not shouldSplit
+			      then {args = args,
+				    bytesAllocated = Bytes.zero,
+				    kind = kind,
+				    label = label,
+				    leaves = leaves,
+				    statements = statements}
+			   else
+			      let
+				 val newLabel = Label.newNoname ()
+				 val _ =
+				    addFrameProfilePushes (newLabel, pushes)
+				 val func = CFunction.profileInc
+				 val bytesAllocated =
+				    case profile of
+				       Alloc => Bytes.toInt bytesAllocated
+				     | Count => 1
+				     | Time => Error.bug "imposible"
+				 val transfer =
+				    Transfer.CCall
+				    {args = (Vector.new2
+					     (Operand.GCState,
+					      Operand.word
+					      (WordX.fromIntInf
+					       (IntInf.fromInt bytesAllocated,
+						WordSize.default)))),
+				     func = func,
+				     return = SOME newLabel}
+				 val sourceSeq = Push.toSources pushes
+				 val _ =
+				    backward {args = args,
+					      kind = kind,
+					      label = label,
+					      leaves = leaves,
+					      sourceSeq = sourceSeq,
+					      statements = statements,
+					      transfer = transfer}
+			      in
+				 {args = Vector.new0 (),
+				  bytesAllocated = Bytes.zero,
+				  kind = Kind.CReturn {func = func},
+				  label = newLabel,
+				  leaves = [],
+				  statements = []}
+			      end
 			val {args, bytesAllocated, kind, label, leaves, pushes,
 			     statements} =
 			   Vector.fold
@@ -610,6 +632,10 @@
 				   statements = s :: statements}
 			     | Profile ps =>
 				  let
+				     val shouldSplit =
+					profile = Alloc
+					andalso Bytes.> (bytesAllocated,
+							 Bytes.zero)
 				     val {args, bytesAllocated, kind, label,
 					  leaves, statements} =
 					maybeSplit
@@ -619,6 +645,7 @@
 					 label = label,
 					 leaves = leaves,
 					 pushes = pushes,
+					 shouldSplit = shouldSplit,
 					 statements = statements}
 				     datatype z = datatype ProfileExp.t
 				     val (pushes, keep, leaves) =
@@ -654,6 +681,22 @@
 								 leaves)
 							else Error.bug "mismatched Leave"
 						     end)
+				     val shouldSplit =
+					profile = Count
+					andalso (case ps of
+						    Enter si => keep
+						  | _ => false)
+				     val {args, bytesAllocated, kind, label,
+					  leaves, statements} =
+					maybeSplit
+					{args = args,
+					 bytesAllocated = bytesAllocated,
+					 kind = kind,
+					 label = label,
+					 leaves = leaves,
+					 pushes = pushes,
+					 shouldSplit = shouldSplit,
+					 statements = statements}
 				     val statements =
 					if keep
 					   then s :: statements
@@ -676,6 +719,9 @@
 				   pushes = pushes,
 				   statements = s :: statements})
 			    )
+			val shouldSplit =
+			   profile = Alloc
+			   andalso Bytes.> (bytesAllocated, Bytes.zero)
 			val {args, kind, label, leaves, statements, ...} =
 			   maybeSplit {args = args,
 				       bytesAllocated = bytesAllocated,
@@ -683,6 +729,7 @@
 				       label = label,
 				       leaves = leaves,
 				       pushes = pushes,
+				       shouldSplit = shouldSplit,
 				       statements = statements}
 			val _ =
 			   Transfer.foreachLabel
@@ -724,7 +771,7 @@
 				  transfer = transfer}
 		     end
 	       end
-	    val _ = goto (start, #1 (enter ([], firstSource)))
+	    val _ = goto (start, [])
 	    val blocks = Vector.fromList (!blocks)
 	 in
 	    Function.new {args = args,



1.80      +7 -0      mlton/mlton/codegen/c-codegen/c-codegen.fun

Index: c-codegen.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/c-codegen/c-codegen.fun,v
retrieving revision 1.79
retrieving revision 1.80
diff -u -r1.79 -r1.80
--- c-codegen.fun	1 May 2004 00:49:36 -0000	1.79
+++ c-codegen.fun	13 May 2004 16:38:38 -0000	1.80
@@ -393,6 +393,12 @@
 	    val magic = C.word (case Random.useed () of
 				   NONE => String.hash (!Control.inputFile)
 				 | SOME w => w)
+	    val profile =
+	       case !Control.profile of
+		  Control.ProfileAlloc => "PROFILE_ALLOC"
+		| Control.ProfileCount => "PROFILE_COUNT"
+		| Control.ProfileNone => "PROFILE_NONE"
+		| Control.ProfileTime => "PROFILE_TIME"
 	 in 
 	    C.callNoSemi ("Main",
 			  [C.int align,
@@ -400,6 +406,7 @@
 			   magic,
 			   C.bytes maxFrameSize,
 			   C.bool (!Control.markCards),
+			   profile,
 			   C.bool (!Control.profileStack)]
 			  @ additionalMainArgs,
 			  print)



1.95      +3 -1      mlton/mlton/control/control.sig

Index: control.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/control/control.sig,v
retrieving revision 1.94
retrieving revision 1.95
diff -u -r1.94 -r1.95
--- control.sig	25 Apr 2004 22:02:51 -0000	1.94
+++ control.sig	13 May 2004 16:38:38 -0000	1.95
@@ -198,13 +198,15 @@
 	 } option ref
 
       (* Insert profiling information. *)
-      datatype profile = ProfileNone | ProfileAlloc | ProfileTime
+      datatype profile = ProfileNone | ProfileAlloc | ProfileCount | ProfileTime
       val profile: profile ref
 
       val profileBasis: bool ref
 
       datatype profileIL = ProfileSSA | ProfileSource
       val profileIL: profileIL ref
+
+      val profileBranch: bool ref
 
       val profileStack: bool ref
 



1.116     +10 -5     mlton/mlton/control/control.sml

Index: control.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/control/control.sml,v
retrieving revision 1.115
retrieving revision 1.116
diff -u -r1.115 -r1.116
--- control.sml	25 Apr 2004 22:02:51 -0000	1.115
+++ control.sml	13 May 2004 16:38:39 -0000	1.116
@@ -348,11 +348,12 @@
 
 structure Profile =
    struct
-      datatype t = ProfileNone | ProfileAlloc | ProfileTime
+      datatype t = ProfileNone | ProfileAlloc | ProfileCount | ProfileTime
 
       val toString =
 	 fn ProfileNone => "None"
 	  | ProfileAlloc => "Alloc"
+	  | ProfileCount => "Count"
 	  | ProfileTime => "Time"
    end
 
@@ -362,6 +363,14 @@
 		       default = ProfileNone,
 		       toString = Profile.toString}
 
+val profileBasis = control {name = "profile basis",
+			    default = false,
+			    toString = Bool.toString}
+
+val profileBranch = control {name = "profile branch",
+			     default = true,
+			     toString = Bool.toString}
+
 structure ProfileIL =
    struct
       datatype t = ProfileSSA | ProfileSource
@@ -370,10 +379,6 @@
 	 fn ProfileSSA => "ProfileSSA"
 	  | ProfileSource => "ProfileSource"
    end
-
-val profileBasis = control {name = "profile basis",
-			    default = false,
-			    toString = Bool.toString}
 
 datatype profileIL = datatype ProfileIL.t
    



1.104     +23 -0     mlton/mlton/elaborate/elaborate-core.fun

Index: elaborate-core.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-core.fun,v
retrieving revision 1.103
retrieving revision 1.104
diff -u -r1.103 -r1.104
--- elaborate-core.fun	1 May 2004 02:15:57 -0000	1.103
+++ elaborate-core.fun	13 May 2004 16:38:39 -0000	1.104
@@ -1945,6 +1945,21 @@
 			   str "then and else branches disagree",
 			   align [seq [str "then: ", l1],
 				  seq [str "else: ", l2]]))
+		      val (b', c') =
+			 if !Control.profile <> Control.ProfileCount
+			    orelse not (!Control.profileBranch)
+			    then (b', c')
+			 else
+			    let
+			       fun wrap (e, e', name) =
+				  Cexp.enterLeave
+				  (e',
+				   SourceInfo.function
+				   {name = name :: nest,
+				    region = Aexp.region e})
+			    in
+			       (wrap (b, b', "<true>"), wrap (c, c', "<false>"))
+			    end
 		   in
 		      Cexp.iff (a', b', c')
 		   end
@@ -2347,6 +2362,14 @@
 			 align [seq [str "result:   ", l1],
 				seq [str "previous: ", l2],
 				seq [str "in: ", lay ()]]))
+		    val e =
+		       if !Control.profile <> Control.ProfileCount
+			  orelse not (!Control.profileBranch)
+			  then e
+		       else
+			  Cexp.enterLeave
+			  (e, SourceInfo.function {name = "<branch>" :: nest,
+						   region = Aexp.region exp})
 		 in
 		    {exp = e,
 		     lay = SOME lay,



1.33      +5 -1      mlton/mlton/main/main.fun

Index: main.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/main/main.fun,v
retrieving revision 1.32
retrieving revision 1.33
diff -u -r1.32 -r1.33
--- main.fun	25 Apr 2004 22:02:52 -0000	1.32
+++ main.fun	13 May 2004 16:38:40 -0000	1.33
@@ -283,7 +283,7 @@
 	Bool (fn b => if b then () else polyvariance := NONE)),
        (Normal, "output", " <file>", "name of output file",
 	SpaceString (fn s => output := SOME s)),
-       (Normal, "profile", " {no|alloc|time}",
+       (Normal, "profile", " {no|alloc|count|time}",
 	"produce executable suitable for profiling",
 	SpaceString
 	(fn s =>
@@ -294,12 +294,16 @@
 	     ; profile := (case s of
 			      "no" => ProfileNone
 			    | "alloc" => ProfileAlloc
+			    | "count" => ProfileCount
 			    | "time" => ProfileTime
 			    | _ => usage (concat
 					  ["invalid -profile arg: ", s]))))),
        (Expert, "profile-basis", " {false|true}",
 	"profile the basis implementation",
 	boolRef profileBasis),
+       (Expert, "profile-branch", " {true|false}",
+	"profile branches in addition to functions",
+	boolRef profileBranch),
        (Expert, "profile-il", " {source}", "where to insert profile exps",
 	SpaceString
 	(fn s =>



1.22      +18 -0     mlton/mlton/xml/xml-tree.fun

Index: xml-tree.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/xml/xml-tree.fun,v
retrieving revision 1.21
retrieving revision 1.22
diff -u -r1.21 -r1.22
--- xml-tree.fun	1 May 2004 00:49:48 -0000	1.21
+++ xml-tree.fun	13 May 2004 16:38:40 -0000	1.22
@@ -344,9 +344,27 @@
 				      ty = ty,
 				      var = res}],
 		     result = VarExp.mono res}
+	    val touch =
+	       if !Control.profile = Control.ProfileCount
+		  then
+		     let
+			val unit = Var.newNoname ()
+		     in
+			[MonoVal {exp = Tuple (Vector.new0 ()),
+				  ty = Type.unit,
+				  var = unit},
+			 MonoVal
+			 {exp = PrimApp {args = Vector.new1 (VarExp.mono unit),
+					 prim = Prim.touch,
+					 targs = Vector.new1 Type.unit},
+			  ty = Type.unit,
+			  var = Var.newNoname ()}]
+		     end
+	       else []
 	    val {decs, result} = dest e
 	    val decs =
 	       List.concat [[prof ProfileExp.Enter],
+			    touch,
 			    decs,
 			    [prof ProfileExp.Leave]]
 	    val try = make {decs = decs, result = result}



1.182     +33 -13    mlton/runtime/gc.c

Index: gc.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/gc.c,v
retrieving revision 1.181
retrieving revision 1.182
diff -u -r1.181 -r1.182
--- gc.c	1 May 2004 00:33:44 -0000	1.181
+++ gc.c	13 May 2004 16:38:40 -0000	1.182
@@ -3677,12 +3677,27 @@
 
 void GC_profileWrite (GC_state s, GC_profile p, int fd) {
 	int i;
+	string kind;
 
 	if (DEBUG_PROFILE)
 		fprintf (stderr, "GC_profileWrite\n");
 	writeString (fd, "MLton prof\n");
-	writeString (fd, (PROFILE_ALLOC == s->profileKind) 
-				? "alloc\n" : "time\n");
+	kind = "";
+	switch (s->profileKind) {
+	case PROFILE_ALLOC:
+		kind = "alloc\n";
+	break;
+	case PROFILE_COUNT:
+		kind = "count\n";
+	break;
+	case PROFILE_NONE:
+		die ("impossible PROFILE_NONE");
+	break;
+	case PROFILE_TIME:
+		kind = "time\n";
+	break;
+	}
+	writeString (fd, kind);
 	writeString (fd, s->profileStack 
 				? "stack\n" : "current\n");
 	writeWord (fd, s->magic);
@@ -3845,7 +3860,7 @@
 #elif (defined (__CYGWIN__))
 
 /* No time profiling on Cygwin. 
- * There is a check in mlton/main/main.sml to make sure that time profiling is
+ * There is a check in mlton/main/main.fun to make sure that time profiling is
  * never turned on on Cygwin.
  */
 static void profileTimeInit (GC_state s) {
@@ -4446,31 +4461,36 @@
          * arguments, because those may just be doing a show prof, in which 
          * case we don't want to initialize the atExit.
          */
-	if (s->sourcesSize > 0) {
+	if (PROFILE_NONE == s->profileKind)
+		s->profilingIsOn = FALSE;
+	else {
 		s->profilingIsOn = TRUE;
 		assert (s->frameSourcesSize == s->frameLayoutsSize);
-		if (s->sourceLabelsSize > 0) {
-			s->profileKind = PROFILE_TIME;
-			profileTimeInit (s);
-		} else {
-			s->profileKind = PROFILE_ALLOC;
+		switch (s->profileKind) {
+		case PROFILE_ALLOC:
+		case PROFILE_COUNT:
 			s->profile = GC_profileNew (s);
+		break;
+		case PROFILE_NONE:
+			die ("impossible PROFILE_NONE");
+		case PROFILE_TIME:
+			profileTimeInit (s);
+		break;
 		}
 		profileEndState = s;
 		atexit (profileEnd);
-	} else
-		s->profilingIsOn = FALSE;
+	}
 	if (s->isOriginal) {
 		newWorld (s);
 		/* The mutator stack invariant doesn't hold,
 		 * because the mutator has yet to run.
 		 */
-		assert (mutatorInvariant(s, TRUE, FALSE));
+		assert (mutatorInvariant (s, TRUE, FALSE));
 	} else {
 		loadWorld (s, worldFile);
 		if (s->profilingIsOn and s->profileStack)
 			GC_foreachStackFrame (s, enterFrame);
-		assert (mutatorInvariant(s, TRUE, TRUE));
+		assert (mutatorInvariant (s, TRUE, TRUE));
 	}
 	s->amInGC = FALSE;
 	return i;



1.75      +2 -0      mlton/runtime/gc.h

Index: gc.h
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/gc.h,v
retrieving revision 1.74
retrieving revision 1.75
diff -u -r1.74 -r1.75
--- gc.h	29 Apr 2004 02:58:58 -0000	1.74
+++ gc.h	13 May 2004 16:38:41 -0000	1.75
@@ -221,6 +221,8 @@
 
 typedef enum {
 	PROFILE_ALLOC,
+	PROFILE_COUNT,
+	PROFILE_NONE,
 	PROFILE_TIME,
 } ProfileKind;