[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;