[MLton-devel] cvs commit: stack profiling
Stephen Weeks
sweeks@users.sourceforge.net
Thu, 02 Jan 2003 22:14:17 -0800
sweeks 03/01/02 22:14:17
Modified: basis-library/libs build
basis-library/misc primitive.sml
basis-library/mlton itimer.sml mlton.sig mlton.sml
profile.sig signal.sml
include ccodegen.h codegen.h x86codegen.h
mlton/backend backend.fun c-function.fun c-function.sig
limit-check.fun profile.fun runtime.fun runtime.sig
ssa-to-rssa.fun
mlton/codegen/c-codegen c-codegen.fun
mlton/codegen/x86-codegen x86-mlton-basic.fun
x86-mlton-basic.sig x86-translate.fun
mlton/control control.sig control.sml
mlton/core-ml lookup-constant.fun
mlton/main compile.sml main.sml
runtime Makefile gc.c gc.h mlton-basis.h
Added: basis-library/mlton profile.sml
runtime/basis/MLton profile.c
Removed: basis-library/mlton profile-alloc.sml profile-data.sig
profile-time.sml profile.fun
runtime/basis/MLton profile-alloc.c profile-time.c
Log:
Here's the latest attempt a source-level stack profiling, this time
implemented by wrapping a C call before and after each RSSA nontail
call to keep track of which functions are on the stack and to bump the
counter for a function when it is removed from the stack. So, for
time profiling, the interrupt handler no longer has to walk the stack,
it only has to look at the "local stack", i.e. the sourceSeq at the
current pc in the current RSSA function.
One nice thing is that time and allocation profiling use the same
infrastructure, which makes debugging easier. I also combined
MLton.ProfileTime and MLton.ProfileAlloc back into a single structure,
MLton.Profile, so that one can do selective profiling in one way, and
control which is done with -profile.
Added switch "-profile-stack {false|true}" so that you can control
whether or not the stack is going to be profiled at compile time.
This lets MLton omit the C calls at RSSA nontails with -profile-stack
false.
Below are the benchmark results. My conclusions from them are
1. The performance impact of -profile-stack false is fine both with
-profile alloc and -profile time, with peek as the only notable
exception.
2. The performance impact of -profile alloc -profile-stack true may be
acceptable.
3. The performance impace of -profile time -profile-stack true is
usually acceptable, with exceptions fib, knuth-bendix, lexgen, md5,
peek, simple, tak. Fortunately, for all of those (except for peek,
which clearly has other problems), the previous approach of walking
the entire stack at each interrupt was acceptable. So, one solution
may be to allow a compile time switch to specify whether the profiling
is to be done with enter/leave at nontail or by walking the stack at
each interrupt.
I'll try out self compiles tomorrow and see what happens.
MLton0 -- mlton -profile no
MLton1 -- mlton -profile alloc -profile-stack false
MLton2 -- mlton -profile alloc -profile-stack true
MLton3 -- mlton -profile time -profile-stack false
MLton4 -- mlton -profile time -profile-stack true
run time ratio
benchmark MLton1 MLton2 MLton3 MLton4
barnes-hut 1.12 1.66 1.03 1.20
boyer 0.98 1.89 0.83 1.37
checksum 1.00 1.00 1.00 1.00
count-graphs 1.43 2.54 1.07 1.59
DLXSimulator 1.19 1.46 1.02 1.05
fft 1.00 1.00 1.03 1.05
fib 1.42 4.54 1.42 4.63
hamlet 1.24 2.65 1.09 1.75
imp-for 1.00 1.00 0.99 0.99
knuth-bendix 1.18 3.37 1.13 3.09
lexgen 1.12 2.53 1.07 2.12
life 1.32 2.19 1.16 1.18
logic 1.09 1.87 1.05 1.59
mandelbrot 1.00 1.00 1.00 1.00
matrix-multiply 1.05 1.05 1.06 1.06
md5 1.10 4.71 1.25 4.20
merge 1.10 1.50 0.99 1.15
mlyacc 1.15 1.85 1.19 1.46
model-elimination 1.18 2.00 0.98 1.40
mpuz 1.07 1.37 1.09 1.40
nucleic 1.16 1.64 1.10 1.36
peek 4.33 4.33 4.67 4.67
psdes-random 1.00 1.00 0.96 0.97
ratio-regions 1.06 1.40 1.03 1.31
ray 1.13 1.78 1.02 1.44
raytrace 1.05 1.75 1.00 1.62
simple 1.26 3.07 1.08 2.33
smith-normal-form 0.98 1.02 1.03 1.02
tailfib 0.99 0.99 0.84 0.86
tak 1.39 3.50 1.39 3.61
tensor 0.98 0.98 0.98 0.98
tsp 1.01 1.04 1.02 1.05
tyan 1.29 2.30 1.02 1.33
vector-concat 1.07 1.06 1.08 1.06
vector-rev 1.02 1.00 0.99 1.00
vliw 1.24 2.17 1.04 1.53
wc-input1 1.07 1.07 1.06 1.05
wc-scanStream 1.14 1.13 1.15 1.35
zebra 1.35 1.97 0.95 0.96
zern 0.96 0.96 0.96 0.95
size
benchmark MLton0 MLton1 MLton2 MLton3 MLton4
barnes-hut 115,673 126,155 127,915 138,323 140,779
boyer 138,664 161,114 165,146 184,786 193,090
checksum 49,328 53,418 53,546 55,466 55,658
count-graphs 67,416 76,250 77,914 85,218 87,450
DLXSimulator 106,345 147,979 163,147 177,915 199,131
fft 58,108 63,462 63,590 70,486 70,678
fib 49,368 53,738 54,042 55,818 56,250
hamlet 1,240,041 1,788,473 2,038,953 2,273,553 2,608,401
imp-for 49,336 53,258 53,386 55,658 55,850
knuth-bendix 90,889 108,971 116,955 127,531 138,131
lexgen 170,246 218,998 245,054 267,502 307,710
life 69,464 74,042 74,890 80,450 81,762
logic 111,072 124,594 129,554 138,242 146,546
mandelbrot 49,472 53,450 53,578 55,546 55,738
matrix-multiply 49,888 53,938 54,066 56,290 56,482
md5 58,257 64,475 66,331 71,043 73,779
merge 50,720 54,962 55,250 57,330 57,730
mlyacc 515,238 615,510 702,758 763,654 882,758
model-elimination 629,273 823,587 918,819 1,027,195 1,158,275
mpuz 54,336 59,386 59,642 63,738 64,122
nucleic 196,888 204,354 206,642 209,794 212,986
peek 56,225 61,659 62,027 66,179 66,715
psdes-random 50,088 54,170 54,298 56,426 56,618
ratio-regions 67,896 84,450 86,002 105,994 108,098
ray 111,193 126,985 131,041 150,273 156,433
raytrace 283,110 299,166 309,886 334,894 350,270
simple 205,748 305,158 358,470 366,726 448,726
smith-normal-form 190,213 195,871 196,639 205,743 206,815
tailfib 49,144 53,098 53,226 55,130 55,322
tak 49,520 53,874 54,226 55,970 56,498
tensor 113,636 123,190 125,462 141,046 143,750
tsp 63,385 70,059 71,003 80,067 81,355
tyan 110,505 135,051 142,219 164,059 174,459
vector-concat 50,512 54,922 55,050 57,354 57,546
vector-rev 49,704 53,850 53,978 55,962 56,154
vliw 325,538 524,834 610,114 683,858 806,658
wc-input1 71,158 73,638 74,310 81,238 82,254
wc-scanStream 71,910 74,454 75,126 82,030 83,046
zebra 158,001 163,995 164,891 215,307 216,547
zern 55,299 61,565 61,709 66,389 66,581
Revision Changes Path
1.8 +1 -4 mlton/basis-library/libs/build
Index: build
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/libs/build,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- build 29 Dec 2002 01:22:57 -0000 1.7
+++ build 3 Jan 2003 06:14:13 -0000 1.8
@@ -200,11 +200,8 @@
mlton/int-inf.sig
mlton/proc-env.sig
mlton/proc-env.sml
-mlton/profile-data.sig
mlton/profile.sig
-mlton/profile.fun
-mlton/profile-alloc.sml
-mlton/profile-time.sml
+mlton/profile.sml
mlton/ptrace.sig
mlton/ptrace.sml
mlton/rlimit.sig
1.45 +9 -39 mlton/basis-library/misc/primitive.sml
Index: primitive.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/misc/primitive.sml,v
retrieving revision 1.44
retrieving revision 1.45
diff -u -r1.44 -r1.45
--- primitive.sml 2 Jan 2003 17:45:08 -0000 1.44
+++ primitive.sml 3 Jan 2003 06:14:13 -0000 1.45
@@ -299,56 +299,26 @@
val native = _build_const "MLton_native": bool;
- structure ProfileAlloc =
+ structure Profile =
struct
- val isOn = _build_const "MLton_profile_alloc": bool;
+ val isOn = _build_const "MLton_profile_isOn": bool;
structure Data =
struct
type t = word
val dummy:t = 0w0
- val free =
- _ffi "MLton_ProfileAlloc_Data_free": t -> unit;
- val malloc =
- _ffi "MLton_ProfileAlloc_Data_malloc": unit -> t;
- val reset =
- _ffi "MLton_ProfileAlloc_Data_reset": t -> unit;
+ val free = _ffi "MLton_Profile_Data_free": t -> unit;
+ val malloc = _ffi "MLton_Profile_Data_malloc": unit -> t;
val write =
- _ffi "MLton_ProfileAlloc_Data_write"
+ _ffi "MLton_Profile_Data_write"
: t * word (* fd *) -> unit;
end
- val current =
- _ffi "MLton_ProfileAlloc_current": unit -> Data.t;
- val done = _ffi "MLton_ProfileAlloc_done": unit -> unit;
+ val current = _ffi "MLton_Profile_current": unit -> Data.t;
+ val done = _ffi "MLton_Profile_done": unit -> unit;
val setCurrent =
- _ffi "MLton_ProfileAlloc_setCurrent": Data.t -> unit;
+ _ffi "MLton_Profile_setCurrent": Data.t -> unit;
end
-
- structure ProfileTime =
- struct
- val isOn = _build_const "MLton_profile_time": bool;
- structure Data =
- struct
- type t = word
-
- val dummy:t = 0w0
- val free =
- _ffi "MLton_ProfileTime_Data_free": t -> unit;
- val malloc =
- _ffi "MLton_ProfileTime_Data_malloc": unit -> t;
- val reset =
- _ffi "MLton_ProfileTime_Data_reset": t -> unit;
- val write =
- _ffi "MLton_ProfileTime_Data_write"
- : t * word (* fd *) -> unit;
- end
- val current =
- _ffi "MLton_ProfileTime_current": unit -> Data.t;
- val init = _ffi "MLton_ProfileTime_init": unit -> unit;
- val setCurrent =
- _ffi "MLton_ProfileTime_setCurrent": Data.t -> unit;
- end
-
+
structure Rlimit =
struct
type rlim = word
1.7 +1 -1 mlton/basis-library/mlton/itimer.sml
Index: itimer.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/mlton/itimer.sml,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- itimer.sml 29 Dec 2002 01:22:58 -0000 1.6
+++ itimer.sml 3 Jan 2003 06:14:13 -0000 1.7
@@ -19,7 +19,7 @@
Prim.set (toInt t, s1, u1, s2, u2)
fun set (z as (t, _)) =
- if Primitive.MLton.ProfileTime.isOn
+ if Primitive.MLton.Profile.isOn
andalso t = Prof
then let
open PosixError
1.17 +1 -2 mlton/basis-library/mlton/mlton.sig
Index: mlton.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/mlton/mlton.sig,v
retrieving revision 1.16
retrieving revision 1.17
diff -u -r1.16 -r1.17
--- mlton.sig 2 Nov 2002 03:37:34 -0000 1.16
+++ mlton.sig 3 Jan 2003 06:14:13 -0000 1.17
@@ -33,8 +33,7 @@
structure Itimer: MLTON_ITIMER
structure ProcEnv: MLTON_PROC_ENV
structure Process: MLTON_PROCESS
- structure ProfileAlloc: MLTON_PROFILE
- structure ProfileTime: MLTON_PROFILE
+ structure Profile: MLTON_PROFILE
structure Ptrace: MLTON_PTRACE
structure Random: MLTON_RANDOM
structure Rlimit: MLTON_RLIMIT
1.17 +1 -2 mlton/basis-library/mlton/mlton.sml
Index: mlton.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/mlton/mlton.sml,v
retrieving revision 1.16
retrieving revision 1.17
diff -u -r1.16 -r1.17
--- mlton.sml 29 Dec 2002 01:22:58 -0000 1.16
+++ mlton.sml 3 Jan 2003 06:14:13 -0000 1.17
@@ -58,8 +58,7 @@
structure ProcEnv = MLtonProcEnv
structure Process = MLtonProcess
structure Ptrace = MLtonPtrace
-structure ProfileAlloc = MLtonProfileAlloc
-structure ProfileTime = MLtonProfileTime
+structure Profile = MLtonProfile
structure Random = MLtonRandom
structure Rlimit = MLtonRlimit
structure Rusage = MLtonRusage
1.5 +9 -1 mlton/basis-library/mlton/profile.sig
Index: profile.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/mlton/profile.sig,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- profile.sig 29 Dec 2002 01:22:58 -0000 1.4
+++ profile.sig 3 Jan 2003 06:14:14 -0000 1.5
@@ -3,7 +3,15 @@
signature MLTON_PROFILE =
sig
- structure Data: MLTON_PROFILE_DATA
+ structure Data:
+ sig
+ type t
+
+ val equals: t * t -> bool
+ val free: t -> unit
+ val malloc: unit -> t
+ val write: t * string -> unit
+ end
val current: unit -> Data.t
val isOn: bool (* a compile-time constant *)
1.17 +1 -1 mlton/basis-library/mlton/signal.sml
Index: signal.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/mlton/signal.sml,v
retrieving revision 1.16
retrieving revision 1.17
diff -u -r1.16 -r1.17
--- signal.sml 29 Dec 2002 01:22:58 -0000 1.16
+++ signal.sml 3 Jan 2003 06:14:14 -0000 1.17
@@ -89,7 +89,7 @@
Array.modifyi (defaultOrIgnore o #1) handlers)
in
(fn s => Array.sub (handlers, s),
- fn (s, h) => if Primitive.MLton.ProfileTime.isOn andalso s = prof
+ fn (s, h) => if Primitive.MLton.Profile.isOn andalso s = prof
then
let
open PosixError
1.7 +46 -83 mlton/basis-library/mlton/profile.sml
1.47 +2 -2 mlton/include/ccodegen.h
Index: ccodegen.h
===================================================================
RCS file: /cvsroot/mlton/mlton/include/ccodegen.h,v
retrieving revision 1.46
retrieving revision 1.47
diff -u -r1.46 -r1.47
--- ccodegen.h 2 Jan 2003 17:45:08 -0000 1.46
+++ ccodegen.h 3 Jan 2003 06:14:14 -0000 1.47
@@ -90,11 +90,11 @@
/* main */
/* ------------------------------------------------- */
-#define Main(cs, mmc, mfs, mg, mc, ml) \
+#define Main(cs, mmc, mfs, mg, ps, mc, ml) \
int main (int argc, char **argv) { \
struct cont cont; \
gcState.native = FALSE; \
- Initialize(cs, mmc, mfs, mg); \
+ Initialize(cs, mmc, mfs, mg, ps); \
if (gcState.isOriginal) { \
real_Init(); \
PrepFarJump(mc, ml); \
1.3 +2 -1 mlton/include/codegen.h
Index: codegen.h
===================================================================
RCS file: /cvsroot/mlton/mlton/include/codegen.h,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- codegen.h 2 Jan 2003 17:45:09 -0000 1.2
+++ codegen.h 3 Jan 2003 06:14:14 -0000 1.3
@@ -37,7 +37,7 @@
sfread (globaluint, sizeof(uint), u, file); \
}
-#define Initialize(cs, mmc, mfs, mg) \
+#define Initialize(cs, mmc, mfs, mg, ps) \
gcState.cardSizeLog2 = cs; \
gcState.frameLayouts = frameLayouts; \
gcState.frameLayoutsSize = cardof(frameLayouts); \
@@ -52,6 +52,7 @@
gcState.mutatorMarksCards = mmc; \
gcState.objectTypes = objectTypes; \
gcState.objectTypesSize = cardof(objectTypes); \
+ gcState.profileStack = ps; \
gcState.sourceLabels = sourceLabels; \
gcState.sourceLabelsSize = cardof(sourceLabels); \
gcState.saveGlobals = saveGlobals; \
1.24 +2 -2 mlton/include/x86codegen.h
Index: x86codegen.h
===================================================================
RCS file: /cvsroot/mlton/mlton/include/x86codegen.h,v
retrieving revision 1.23
retrieving revision 1.24
diff -u -r1.23 -r1.24
--- x86codegen.h 2 Jan 2003 17:45:09 -0000 1.23
+++ x86codegen.h 3 Jan 2003 06:14:14 -0000 1.24
@@ -34,12 +34,12 @@
pointer localpointer[p]; \
uint localuint[u]
-#define Main(cs, mmc, mfs, mg, ml, reserveEsp) \
+#define Main(cs, mmc, mfs, mg, ps, ml, reserveEsp) \
int main (int argc, char **argv) { \
pointer jump; \
extern pointer ml; \
gcState.native = TRUE; \
- Initialize(cs, mmc, mfs, mg); \
+ Initialize(cs, mmc, mfs, mg, ps); \
if (gcState.isOriginal) { \
real_Init(); \
jump = (pointer)&ml; \
1.45 +5 -2 mlton/mlton/backend/backend.fun
Index: backend.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/backend.fun,v
retrieving revision 1.44
retrieving revision 1.45
diff -u -r1.44 -r1.45
--- backend.fun 2 Jan 2003 17:45:10 -0000 1.44
+++ backend.fun 3 Jan 2003 06:14:14 -0000 1.45
@@ -151,6 +151,7 @@
val program = pass ("ssaToRssa", SsaToRssa.convert, program)
val program = pass ("insertLimitChecks", LimitCheck.insert, program)
val program = pass ("insertSignalChecks", SignalCheck.insert, program)
+ val program = pass ("implementHandlers", ImplementHandlers.doit, program)
val {frameProfileIndices, labels = profileLabels, program, sources,
sourceSeqs} =
Control.passTypeCheck
@@ -161,7 +162,6 @@
suffix = "rssa",
thunk = fn () => Profile.profile program,
typeCheck = R.Program.typeCheck o #program}
- val program = pass ("implementHandlers", ImplementHandlers.doit, program)
val _ = R.Program.checkHandlers program
val frameProfileIndex =
if !Control.profile = Control.ProfileNone
@@ -927,7 +927,10 @@
s as M.Statement.ProfileLabel _ =>
SOME s
| _ => NONE)) of
- NONE => Error.bug "missing ProfileLabel"
+ NONE =>
+ Error.bug
+ (concat ["missing ProfileLabel in ",
+ Label.toString label])
| SOME s =>
(Vector.new1 s,
Vector.dropPrefix (statements, 1))
1.7 +23 -8 mlton/mlton/backend/c-function.fun
Index: c-function.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/c-function.fun,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- c-function.fun 2 Jan 2003 17:45:13 -0000 1.6
+++ c-function.fun 3 Jan 2003 06:14:15 -0000 1.7
@@ -15,11 +15,13 @@
maySwitchThreads: bool,
modifiesFrontier: bool,
modifiesStackTop: bool,
+ needsCurrentSource: bool,
name: string,
returnTy: Type.t option}
fun layout (T {bytesNeeded, ensuresBytesFree, mayGC, maySwitchThreads,
- modifiesFrontier, modifiesStackTop, name, returnTy}) =
+ modifiesFrontier, modifiesStackTop, name, needsCurrentSource,
+ returnTy}) =
Layout.record
[("bytesNeeded", Option.layout Int.layout bytesNeeded),
("ensuresBytesFree", Bool.layout ensuresBytesFree),
@@ -28,6 +30,7 @@
("modifiesFrontier", Bool.layout modifiesFrontier),
("modifiesStackTop", Bool.layout modifiesStackTop),
("name", String.layout name),
+ ("needsCurrentSource", Bool.layout needsCurrentSource),
("returnTy", Option.layout Type.layout returnTy)]
local
@@ -40,6 +43,7 @@
val modifiesFrontier = make #modifiesFrontier
val modifiesStackTop = make #modifiesStackTop
val name = make #name
+ val needsCurrentSource = make #needsCurrentSource
val returnTy = make #returnTy
end
@@ -75,6 +79,7 @@
modifiesFrontier = true,
modifiesStackTop = true,
name = "GC_gc",
+ needsCurrentSource = false,
returnTy = NONE}
val t = make true
val f = make false
@@ -90,20 +95,30 @@
modifiesFrontier = false,
modifiesStackTop = false,
name = name,
+ needsCurrentSource = false,
returnTy = returnTy}
val bug = vanilla {name = "MLton_bug",
returnTy = NONE}
+val profileEnter = vanilla {name = "MLton_Profile_enter",
+ returnTy = NONE}
+
+val profileLeave = vanilla {name = "MLton_Profile_leave",
+ returnTy = NONE}
+
val size = vanilla {name = "MLton_size",
returnTy = SOME Type.int}
-val profileAllocIncLeaveEnter =
- vanilla {name = "MLton_ProfileAlloc_incLeaveEnter",
- returnTy = NONE}
-
-val profileAllocSetCurrentSource =
- vanilla {name = "MLton_ProfileAlloc_setCurrentSource",
- returnTy = NONE}
+val profileInc =
+ T {bytesNeeded = NONE,
+ ensuresBytesFree = false,
+ mayGC = false,
+ maySwitchThreads = false,
+ modifiesFrontier = false,
+ modifiesStackTop = false,
+ name = "MLton_Profile_inc",
+ needsCurrentSource = true,
+ returnTy = NONE}
end
1.6 +5 -2 mlton/mlton/backend/c-function.sig
Index: c-function.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/c-function.sig,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- c-function.sig 2 Jan 2003 17:45:13 -0000 1.5
+++ c-function.sig 3 Jan 2003 06:14:15 -0000 1.6
@@ -31,6 +31,7 @@
mayGC: bool,
maySwitchThreads: bool,
name: string,
+ needsCurrentSource: bool,
returnTy: Type.t option}
val bug: t
@@ -44,9 +45,11 @@
val maySwitchThreads: t -> bool
val modifiesFrontier: t -> bool
val modifiesStackTop: t -> bool
+ val needsCurrentSource: t -> bool
val name: t -> string
- val profileAllocIncLeaveEnter: t
- val profileAllocSetCurrentSource: t
+ val profileEnter: t
+ val profileInc: t
+ val profileLeave: t
val returnTy: t -> Type.t option
val size: t
val vanilla: {name: string, returnTy: Type.t option} -> t
1.34 +1 -0 mlton/mlton/backend/limit-check.fun
Index: limit-check.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/limit-check.fun,v
retrieving revision 1.33
retrieving revision 1.34
diff -u -r1.33 -r1.34
--- limit-check.fun 2 Jan 2003 17:45:14 -0000 1.33
+++ limit-check.fun 3 Jan 2003 06:14:15 -0000 1.34
@@ -133,6 +133,7 @@
modifiesFrontier = false,
modifiesStackTop = false,
name = "MLton_allocTooLarge",
+ needsCurrentSource = false,
returnTy = NONE}
val _ =
newBlocks :=
1.7 +244 -252 mlton/mlton/backend/profile.fun
Index: profile.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/profile.fun,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- profile.fun 2 Jan 2003 17:45:15 -0000 1.6
+++ profile.fun 3 Jan 2003 06:14:15 -0000 1.7
@@ -3,6 +3,7 @@
open S
open Rssa
+
structure Graph = DirectedGraph
local
open Graph
@@ -67,6 +68,7 @@
val debug = false
val profile = !Control.profile
val profileAlloc: bool = profile = Control.ProfileAlloc
+ val profileStack: bool = !Control.profileStack
val profileTime: bool = profile = Control.ProfileTime
val frameProfileIndices = ref []
local
@@ -136,7 +138,7 @@
in
fun sourceSeqIndex (s: sourceSeq): int =
let
- val s = Vector.fromList s
+ val s = Vector.fromListRev s
val hash =
Vector.fold (s, 0w0, fn (i, w) =>
w * 0w31 + Word.fromInt i)
@@ -158,7 +160,7 @@
(* Ensure that SourceInfo unknown is index 0. *)
val unknownSourceSeq = sourceSeqIndex [sourceInfoIndex SourceInfo.unknown]
(* Treat the empty source sequence as unknown. *)
- val sourceSeqIndexSafe =
+ val sourceSeqIndex =
fn [] => unknownSourceSeq
| s => sourceSeqIndex s
val {get = labelInfo: Label.t -> {block: Block.t,
@@ -167,15 +169,16 @@
Property.getSetOnce
(Label.plist, Property.initRaise ("info", Label.layout))
val labels = ref []
- fun profileLabel (sourceSeq: int list): Statement.t =
+ fun profileLabelIndex (sourceSeqsIndex: int): Statement.t =
let
- val index = sourceSeqIndexSafe sourceSeq
val l = ProfileLabel.new ()
val _ = List.push (labels, {label = l,
- sourceSeqsIndex = index})
+ sourceSeqsIndex = sourceSeqsIndex})
in
Statement.ProfileLabel l
end
+ fun profileLabel (sourceSeq: int list): Statement.t =
+ profileLabelIndex (sourceSeqIndex sourceSeq)
fun shouldPush (si: SourceInfo.t, ps: Push.t list): bool =
case firstEnter ps of
NONE => true
@@ -207,6 +210,17 @@
let
val {args, blocks, name, raises, returns, start} = Function.dest f
val {callees, ...} = funcInfo name
+ fun enter (si: SourceInfo.t, ps: Push.t list) =
+ let
+ val n as InfoNode.T {node, ...} = sourceInfoNode si
+ val _ =
+ case firstEnter ps of
+ NONE => List.push (callees, node)
+ | SOME (InfoNode.T {node = node', ...}) =>
+ addEdge {from = node', to = node}
+ in
+ Push.Enter n :: ps
+ end
val _ =
Vector.foreach
(blocks, fn block as Block.T {label, ...} =>
@@ -218,16 +232,19 @@
fun backward {args,
kind,
label,
+ needsCurrentSource,
sourceSeq,
statements: Statement.t list,
transfer: Transfer.t}: unit =
let
- val (npl, sourceSeq, statements) =
+ val (_, npl, sourceSeq, statements) =
List.fold
(statements,
- (true, sourceSeq, []), fn (s, (npl, sourceSeq, ss)) =>
+ (needsCurrentSource, true, sourceSeq, []),
+ fn (s, (ncs, npl, sourceSeq, ss)) =>
case s of
- Profile ps =>
+ Object _ => (true, true, sourceSeq, s :: ss)
+ | Profile ps =>
let
val ss =
if profileTime andalso npl
@@ -243,28 +260,31 @@
then sis
else Error.bug "mismatched Enter")
| Leave si => sourceInfoIndex si :: sourceSeq
+ val ss =
+ if profileAlloc andalso needsCurrentSource
+ then
+ Statement.Move
+ {dst = (Operand.Runtime
+ Runtime.GCField.CurrentSource),
+ src = (Operand.word
+ (Word.fromInt
+ (sourceSeqIndex sourceSeq)))}
+ :: ss
+ else ss
in
- (false, sourceSeq', ss)
+ (false, false, sourceSeq', ss)
end
- | _ => (true, sourceSeq, s :: ss))
- val statements =
- if profileTime andalso npl
- then profileLabel sourceSeq :: statements
- else statements
- val (args, kind, label) =
- if profileAlloc
- andalso (case kind of
- Kind.Cont _ => true
- | Kind.Handler => true
- | _ => false)
+ | _ => (ncs, true, sourceSeq, s :: ss))
+ val {args, kind, label} =
+ if profileStack andalso (case kind of
+ Kind.Cont _ => true
+ | Kind.Handler => true
+ | _ => false)
then
let
+ val func = CFunction.profileLeave
val newLabel = Label.newNoname ()
- val func = CFunction.profileAllocSetCurrentSource
- val sourceIndex =
- case sourceSeq of
- [] => unknownIndex
- | n :: _ => n
+ val index = sourceSeqIndex sourceSeq
val _ =
List.push
(blocks,
@@ -272,20 +292,26 @@
{args = args,
kind = kind,
label = label,
- statements = Vector.new0 (),
- transfer =
- Transfer.CCall {args = (Vector.new1
- (Operand.word
- (Word.fromInt
- sourceIndex))),
- func = func,
- return = SOME newLabel}})
+ statements =
+ if profileTime
+ then Vector.new1 (profileLabelIndex index)
+ else Vector.new0 (),
+ transfer =
+ Transfer.CCall
+ {args = (Vector.new1
+ (Operand.word (Word.fromInt index))),
+ func = func,
+ return = SOME newLabel}})
in
- (Vector.new0 (),
- Kind.CReturn {func = func},
- newLabel)
+ {args = Vector.new0 (),
+ kind = Kind.CReturn {func = func},
+ label = newLabel}
end
- else (args, kind, label)
+ else {args = args, kind = kind, label = label}
+ val statements =
+ if profileTime andalso npl
+ then profileLabel sourceSeq :: statements
+ else statements
in
List.push (blocks,
Block.T {args = args,
@@ -302,202 +328,6 @@
List.layout Statement.layout statements],
Unit.layout)
backward
- fun maybeSplit {args,
- bytesAllocated,
- enters: InfoNode.t list,
- kind,
- label,
- leaves: InfoNode.t list,
- maybe: bool,
- sourceSeq,
- statements} =
- if profileAlloc
- andalso (not (List.isEmpty enters)
- orelse not (List.isEmpty leaves)
- orelse maybe)
- then
- let
- val newLabel = Label.newNoname ()
- val func = CFunction.profileAllocIncLeaveEnter
- fun ssi (ns: InfoNode.t list): int =
- sourceSeqIndex (List.revMap (ns, InfoNode.index))
- val enters =
- (* add the current source to the enters *)
- (case firstEnter sourceSeq of
- NONE => unknownInfoNode
- | SOME n => n) :: enters
- val transfer =
- Transfer.CCall
- {args = (Vector.new3
- (Operand.word (Word.fromInt bytesAllocated),
- Operand.word (Word.fromInt (ssi leaves)),
- Operand.word (Word.fromInt (ssi enters)))),
- func = func,
- return = SOME newLabel}
- val sourceSeq = Push.toSources sourceSeq
- val _ =
- backward {args = args,
- kind = kind,
- label = label,
- sourceSeq = sourceSeq,
- statements = statements,
- transfer = transfer}
- in
- {args = Vector.new0 (),
- bytesAllocated = 0,
- enters = [],
- kind = Kind.CReturn {func = func},
- label = newLabel,
- leaves = [],
- statements = []}
- end
- else
- {args = args,
- bytesAllocated = bytesAllocated,
- enters = enters,
- kind = kind,
- label = label,
- leaves = leaves,
- statements = statements}
- val maybeSplit =
- Trace.trace
- ("Profile.maybeSplit",
- fn {enters, leaves, sourceSeq, ...} =>
- Layout.record [("enters", List.layout InfoNode.layout enters),
- ("leaves", List.layout InfoNode.layout leaves),
- ("sourceSeq", List.layout Push.layout sourceSeq)],
- Layout.ignore)
- maybeSplit
- fun forward {args, kind, label, sourceSeq, statements} =
- Vector.fold
- (statements,
- {args = args,
- bytesAllocated = 0,
- enters = [],
- kind = kind,
- label = label,
- leaves = [],
- sourceSeq = sourceSeq,
- statements = []},
- fn (s, {args, bytesAllocated, enters, kind, label, leaves,
- sourceSeq, statements}) =>
- (
- if debug
- then
- let
- open Layout
- in
- outputl (record
- [("statement", Statement.layout s),
- ("enters", List.layout InfoNode.layout enters),
- ("leaves", List.layout InfoNode.layout leaves)],
- Out.error)
- end
- else ()
- ;
- case s of
- Object {size, ...} =>
- let
- val {args, bytesAllocated, enters, kind, label,
- leaves, statements} =
- maybeSplit {args = args,
- bytesAllocated = bytesAllocated,
- enters = enters,
- kind = kind,
- label = label,
- leaves = leaves,
- maybe = false,
- sourceSeq = sourceSeq,
- statements = statements}
- in
- {args = args,
- bytesAllocated = bytesAllocated + size,
- enters = enters,
- kind = kind,
- label = label,
- leaves = leaves,
- sourceSeq = sourceSeq,
- statements = s :: statements}
- end
- | Profile ps =>
- let
- val (enters, leaves, sourceSeq, statements) =
- case ps of
- Enter si =>
- (if shouldPush (si, sourceSeq)
- then
- let
- val n
- as InfoNode.T {node, ...} =
- sourceInfoNode si
- val _ =
- case firstEnter sourceSeq of
- NONE =>
- List.push (callees, node)
- | SOME
- (InfoNode.T
- {node = node', ...}) =>
- addEdge {from = node',
- to = node}
- in
- (n :: enters,
- leaves,
- Push.Enter n :: sourceSeq,
- s :: statements)
- end
- else (enters,
- leaves,
- Push.Skip si :: sourceSeq,
- statements))
- | Leave si =>
- (case sourceSeq of
- [] => Error.bug "unmatched Leave"
- | p :: sourceSeq' =>
- (case p of
- Push.Enter (n as InfoNode.T {index, ...}) =>
- if index = sourceInfoIndex si
- then
- let
- val (enters, leaves) =
- case enters of
- [] =>
- ([],
- n :: leaves)
- | _ :: enters =>
- (enters, leaves)
- in
- (enters,
- leaves,
- sourceSeq',
- s :: statements)
- end
- else Error.bug "mismatched leave"
- | Push.Skip si' =>
- if SourceInfo.equals (si, si')
- then (enters,
- leaves,
- sourceSeq',
- statements)
- else Error.bug "mismatched leave"))
- in
- {args = args,
- bytesAllocated = bytesAllocated,
- enters = enters,
- kind = kind,
- label = label,
- leaves = leaves,
- sourceSeq = sourceSeq,
- statements = statements}
- end
- | _ => {args = args,
- bytesAllocated = bytesAllocated,
- enters = enters,
- kind = kind,
- label = label,
- leaves = leaves,
- sourceSeq = sourceSeq,
- statements = s :: statements})
- )
fun goto (l: Label.t, sourceSeq: Push.t list): unit =
let
val _ =
@@ -527,29 +357,148 @@
if Kind.isFrame kind
then List.push (frameProfileIndices,
(label,
- sourceSeqIndexSafe
+ sourceSeqIndex
(Push.toSources sourceSeq)))
else ()
- val {args, bytesAllocated, enters, kind, label, leaves,
- sourceSeq, statements} =
- forward {args = args,
- kind = kind,
- label = label,
- sourceSeq = sourceSeq,
- statements = statements}
- val {args, kind, label, statements, ...} =
- maybeSplit {args = args,
- bytesAllocated = bytesAllocated,
- enters = enters,
- kind = kind,
- label = label,
- leaves = leaves,
- maybe = bytesAllocated > 0,
- sourceSeq = sourceSeq,
- statements = statements}
+ fun maybeSplit {args, bytesAllocated, kind, label,
+ sourceSeq: Push.t list,
+ statements} =
+ if profileAlloc andalso bytesAllocated > 0
+ then
+ let
+ val newLabel = Label.newNoname ()
+ val func = CFunction.profileInc
+ val transfer =
+ Transfer.CCall
+ {args = (Vector.new1
+ (Operand.word
+ (Word.fromInt bytesAllocated))),
+ func = func,
+ return = SOME newLabel}
+ val sourceSeq = Push.toSources sourceSeq
+ val _ =
+ backward {args = args,
+ kind = kind,
+ label = label,
+ needsCurrentSource = true,
+ sourceSeq = sourceSeq,
+ statements = statements,
+ transfer = transfer}
+ in
+ {args = Vector.new0 (),
+ bytesAllocated = 0,
+ kind = Kind.CReturn {func = func},
+ label = newLabel,
+ statements = []}
+ end
+ else {args = args,
+ bytesAllocated = 0,
+ kind = kind,
+ label = label,
+ statements = statements}
+ val {args, bytesAllocated, kind, label, sourceSeq,
+ statements} =
+ Vector.fold
+ (statements,
+ {args = args,
+ bytesAllocated = 0,
+ kind = kind,
+ label = label,
+ sourceSeq = sourceSeq,
+ statements = []},
+ fn (s, {args, bytesAllocated, kind, label,
+ sourceSeq: Push.t list,
+ statements}) =>
+ (if not debug
+ then ()
+ else
+ let
+ open Layout
+ in
+ outputl
+ (seq [List.layout Push.layout sourceSeq,
+ str " ",
+ Statement.layout s],
+ Out.error)
+ end
+ ;
+ case s of
+ Object {size, ...} =>
+ {args = args,
+ bytesAllocated = bytesAllocated + size,
+ kind = kind,
+ label = label,
+ sourceSeq = sourceSeq,
+ statements = s :: statements}
+ | Profile ps =>
+ let
+ val {args, bytesAllocated, kind, label,
+ statements} =
+ maybeSplit
+ {args = args,
+ bytesAllocated = bytesAllocated,
+ kind = kind,
+ label = label,
+ sourceSeq = sourceSeq,
+ statements = statements}
+ datatype z = datatype ProfileExp.t
+ val (keep, sourceSeq) =
+ case ps of
+ Enter si =>
+ if shouldPush (si, sourceSeq)
+ then (true,
+ enter (si, sourceSeq))
+ else (false,
+ Push.Skip si :: sourceSeq)
+ | Leave si =>
+ (case sourceSeq of
+ [] =>
+ Error.bug "unmatched Leave"
+ | p :: sourceSeq' =>
+ let
+ val (keep, isOk) =
+ case p of
+ Push.Enter
+ (InfoNode.T
+ {index, ...}) =>
+ (true,
+ index = sourceInfoIndex si)
+ | Push.Skip si' =>
+ (false,
+ SourceInfo.equals (si, si'))
+ in
+ if isOk
+ then (keep, sourceSeq')
+ else Error.bug "mismatched Leave"
+ end)
+ val statements =
+ if keep
+ then s :: statements
+ else statements
+ in
+ {args = args,
+ bytesAllocated = bytesAllocated,
+ kind = kind,
+ label = label,
+ sourceSeq = sourceSeq,
+ statements = statements}
+ end
+ | _ =>
+ {args = args,
+ bytesAllocated = bytesAllocated,
+ kind = kind,
+ label = label,
+ sourceSeq = sourceSeq,
+ statements = s :: statements})
+ )
val _ =
Transfer.foreachLabel
(transfer, fn l => goto (l, sourceSeq))
+ val ncs =
+ case transfer of
+ Transfer.CCall {func, ...} =>
+ CFunction.needsCurrentSource func
+ | _ => false
(* Record the call for the call graph. *)
val _ =
case transfer of
@@ -559,11 +508,54 @@
fn InfoNode.T {node, ...} =>
List.push (#callers (funcInfo func), node))
| _ => ()
+ val {args, kind, label, statements, ...} =
+ maybeSplit {args = args,
+ bytesAllocated = bytesAllocated,
+ kind = kind,
+ label = label,
+ sourceSeq = sourceSeq,
+ statements = statements}
+ val sourceSeq = Push.toSources sourceSeq
+ val transfer =
+ if profileStack
+ andalso
+ (case transfer of
+ Transfer.Call {return = Return.NonTail _, ...} =>
+ true
+ | _ => false)
+ then
+ let
+ val func = CFunction.profileEnter
+ val newLabel = Label.newNoname ()
+ val index = sourceSeqIndex sourceSeq
+ val _ =
+ List.push
+ (blocks,
+ Block.T
+ {args = Vector.new0 (),
+ kind = Kind.CReturn {func = func},
+ label = newLabel,
+ statements =
+ if profileTime
+ then (Vector.new1
+ (profileLabelIndex index))
+ else Vector.new0 (),
+ transfer = transfer})
+ in
+ Transfer.CCall
+ {args = (Vector.new1
+ (Operand.word
+ (Word.fromInt index))),
+ func = func,
+ return = SOME newLabel}
+ end
+ else transfer
in
backward {args = args,
kind = kind,
label = label,
- sourceSeq = Push.toSources sourceSeq,
+ needsCurrentSource = ncs,
+ sourceSeq = sourceSeq,
statements = statements,
transfer = transfer}
end
1.10 +9 -3 mlton/mlton/backend/runtime.fun
Index: runtime.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/runtime.fun,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- runtime.fun 2 Jan 2003 17:45:15 -0000 1.9
+++ runtime.fun 3 Jan 2003 06:14:15 -0000 1.10
@@ -18,6 +18,7 @@
datatype t =
CanHandle
| CardMap
+ | CurrentSource
| CurrentThread
| ExnStack
| Frontier
@@ -34,6 +35,7 @@
val ty =
fn CanHandle => Type.int
| CardMap => Type.pointer
+ | CurrentSource => Type.word
| CurrentThread => Type.pointer
| ExnStack => Type.word
| Frontier => Type.pointer
@@ -47,6 +49,7 @@
val canHandleOffset: int ref = ref 0
val cardMapOffset: int ref = ref 0
+ val currentSourceOffset: int ref = ref 0
val currentThreadOffset: int ref = ref 0
val frontierOffset: int ref = ref 0
val limitOffset: int ref = ref 0
@@ -57,11 +60,12 @@
val stackLimitOffset: int ref = ref 0
val stackTopOffset: int ref = ref 0
- fun setOffsets {canHandle, cardMap, currentThread, frontier, limit,
- limitPlusSlop, maxFrameSize, signalIsPending, stackBottom,
- stackLimit, stackTop} =
+ fun setOffsets {canHandle, cardMap, currentSource, currentThread, frontier,
+ limit, limitPlusSlop, maxFrameSize, signalIsPending,
+ stackBottom, stackLimit, stackTop} =
(canHandleOffset := canHandle
; cardMapOffset := cardMap
+ ; currentSourceOffset := currentSource
; currentThreadOffset := currentThread
; frontierOffset := frontier
; limitOffset := limit
@@ -75,6 +79,7 @@
val offset =
fn CanHandle => !canHandleOffset
| CardMap => !cardMapOffset
+ | CurrentSource => !currentSourceOffset
| CurrentThread => !currentThreadOffset
| ExnStack => Error.bug "exn stack offset not defined"
| Frontier => !frontierOffset
@@ -89,6 +94,7 @@
val toString =
fn CanHandle => "CanHandle"
| CardMap => "CardMap"
+ | CurrentSource => "CurrentSource"
| CurrentThread => "CurrentThread"
| ExnStack => "ExnStack"
| Frontier => "Frontier"
1.19 +2 -0 mlton/mlton/backend/runtime.sig
Index: runtime.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/runtime.sig,v
retrieving revision 1.18
retrieving revision 1.19
diff -u -r1.18 -r1.19
--- runtime.sig 2 Jan 2003 17:45:15 -0000 1.18
+++ runtime.sig 3 Jan 2003 06:14:15 -0000 1.19
@@ -24,6 +24,7 @@
datatype t =
CanHandle
| CardMap
+ | CurrentSource
| CurrentThread
| ExnStack
| Frontier (* The place where the next object is allocated. *)
@@ -40,6 +41,7 @@
val offset: t -> int (* Field offset in struct GC_state. *)
val setOffsets: {canHandle: int,
cardMap: int,
+ currentSource: int,
currentThread: int,
frontier: int,
limit: int,
1.33 +9 -1 mlton/mlton/backend/ssa-to-rssa.fun
Index: ssa-to-rssa.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/ssa-to-rssa.fun,v
retrieving revision 1.32
retrieving revision 1.33
diff -u -r1.32 -r1.33
--- ssa-to-rssa.fun 2 Jan 2003 17:45:15 -0000 1.32
+++ ssa-to-rssa.fun 3 Jan 2003 06:14:15 -0000 1.33
@@ -49,6 +49,7 @@
modifiesFrontier = true,
modifiesStackTop = false,
name = name,
+ needsCurrentSource = true,
returnTy = SOME Type.pointer}
in
val intInfAdd = make ("IntInf_do_add", 2)
@@ -83,6 +84,7 @@
modifiesFrontier = true,
modifiesStackTop = true,
name = "GC_copyCurrentThread",
+ needsCurrentSource = false,
returnTy = NONE}
val copyThread =
@@ -93,6 +95,7 @@
modifiesFrontier = true,
modifiesStackTop = true,
name = "GC_copyThread",
+ needsCurrentSource = false,
returnTy = SOME Type.pointer}
val exit =
@@ -103,6 +106,7 @@
modifiesFrontier = true,
modifiesStackTop = true,
name = "MLton_exit",
+ needsCurrentSource = false,
returnTy = NONE}
val gcArrayAllocate =
@@ -113,6 +117,7 @@
modifiesFrontier = true,
modifiesStackTop = true,
name = "GC_arrayAllocate",
+ needsCurrentSource = true,
returnTy = SOME Type.pointer}
local
@@ -124,6 +129,7 @@
modifiesFrontier = true,
modifiesStackTop = true,
name = name,
+ needsCurrentSource = true,
returnTy = NONE}
in
val pack = make "GC_pack"
@@ -138,6 +144,7 @@
modifiesFrontier = true,
modifiesStackTop = true,
name = "Thread_switchTo",
+ needsCurrentSource = false,
returnTy = NONE}
val worldSave =
@@ -148,6 +155,7 @@
modifiesFrontier = true,
modifiesStackTop = true,
name = "GC_saveWorld",
+ needsCurrentSource = false,
returnTy = NONE}
end
@@ -1265,7 +1273,7 @@
return =
S.Return.NonTail
{cont = bug,
- handler = S.Handler.Caller}})},
+ handler = S.Handler.Dead}})},
S.Block.T
{label = bug,
args = Vector.new0 (),
1.41 +3 -1 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.40
retrieving revision 1.41
diff -u -r1.40 -r1.41
--- c-codegen.fun 2 Jan 2003 17:45:16 -0000 1.40
+++ c-codegen.fun 3 Jan 2003 06:14:16 -0000 1.41
@@ -237,7 +237,8 @@
[C.int (!Control.cardSizeLog2),
C.bool (!Control.markCards),
C.int maxFrameSize,
- magic]
+ magic,
+ C.bool (!Control.profileStack)]
@ additionalMainArgs,
print)
; print "\n"
@@ -403,6 +404,7 @@
case r of
CanHandle => "gcState.canHandle"
| CardMap => "gcState.cardMapForMutator"
+ | CurrentSource => "gcState.currentSource"
| CurrentThread => "gcState.currentThread"
| ExnStack => "ExnStack"
| Frontier => "frontier"
1.12 +4 -1 mlton/mlton/codegen/x86-codegen/x86-mlton-basic.fun
Index: x86-mlton-basic.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-mlton-basic.fun,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- x86-mlton-basic.fun 2 Jan 2003 17:45:18 -0000 1.11
+++ x86-mlton-basic.fun 3 Jan 2003 06:14:16 -0000 1.12
@@ -355,7 +355,10 @@
val (_, _, gcState_cardMapContentsOperand) =
make (Field.CardMap, wordSize, Classes.GCState)
- val (gcState_currentThread, gcState_currentThreadContents,
+ val (_, _, gcState_currentSourceContentsOperand) =
+ make (Field.CurrentSource, wordSize, Classes.GCState)
+
+ val (gcState_currentThread, gcState_currentThreadContents,
gcState_currentThreadContentsOperand) =
make (Field.CurrentThread, pointerSize, Classes.GCState)
1.21 +1 -0 mlton/mlton/codegen/x86-codegen/x86-mlton-basic.sig
Index: x86-mlton-basic.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-mlton-basic.sig,v
retrieving revision 1.20
retrieving revision 1.21
diff -u -r1.20 -r1.21
--- x86-mlton-basic.sig 2 Jan 2003 17:45:18 -0000 1.20
+++ x86-mlton-basic.sig 3 Jan 2003 06:14:16 -0000 1.21
@@ -104,6 +104,7 @@
(* gcState relative locations defined in gc.h *)
val gcState_canHandleContentsOperand: unit -> x86.Operand.t
val gcState_cardMapContentsOperand: unit -> x86.Operand.t
+ val gcState_currentSourceContentsOperand: unit -> x86.Operand.t
val gcState_currentThreadContentsOperand: unit -> x86.Operand.t
val gcState_currentThread_exnStackContents: unit -> x86.MemLoc.t
val gcState_currentThread_exnStackContentsOperand: unit -> x86.Operand.t
1.37 +1 -0 mlton/mlton/codegen/x86-codegen/x86-translate.fun
Index: x86-translate.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-translate.fun,v
retrieving revision 1.36
retrieving revision 1.37
diff -u -r1.36 -r1.37
--- x86-translate.fun 2 Jan 2003 17:45:18 -0000 1.36
+++ x86-translate.fun 3 Jan 2003 06:14:16 -0000 1.37
@@ -166,6 +166,7 @@
case oper of
CanHandle => gcState_canHandleContentsOperand ()
| CardMap => gcState_cardMapContentsOperand ()
+ | CurrentSource => gcState_currentSourceContentsOperand ()
| CurrentThread => gcState_currentThreadContentsOperand ()
| ExnStack =>
gcState_currentThread_exnStackContentsOperand ()
1.59 +2 -0 mlton/mlton/control/control.sig
Index: control.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/control/control.sig,v
retrieving revision 1.58
retrieving revision 1.59
diff -u -r1.58 -r1.59
--- control.sig 19 Dec 2002 23:43:34 -0000 1.58
+++ control.sig 3 Jan 2003 06:14:16 -0000 1.59
@@ -196,6 +196,8 @@
datatype profile = ProfileNone | ProfileAlloc | ProfileTime
val profile: profile ref
+ val profileStack: bool ref
+
(* Array bounds checking. *)
val safe: bool ref
1.75 +4 -0 mlton/mlton/control/control.sml
Index: control.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/control/control.sml,v
retrieving revision 1.74
retrieving revision 1.75
diff -u -r1.74 -r1.75
--- control.sml 19 Dec 2002 23:43:35 -0000 1.74
+++ control.sml 3 Jan 2003 06:14:16 -0000 1.75
@@ -342,6 +342,10 @@
default = ProfileNone,
toString = Profile.toString}
+val profileStack = control {name = "profile stack",
+ default = false,
+ toString = Bool.toString}
+
val safe = control {name = "safe",
default = true,
toString = Bool.toString}
1.17 +1 -0 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.16
retrieving revision 1.17
diff -u -r1.16 -r1.17
--- lookup-constant.fun 2 Jan 2003 17:45:19 -0000 1.16
+++ lookup-constant.fun 3 Jan 2003 06:14:16 -0000 1.17
@@ -122,6 +122,7 @@
val gcFields =
[
"canHandle",
+ "currentSource",
"currentThread",
"frontier",
"cardMapForMutator",
1.45 +2 -2 mlton/mlton/main/compile.sml
Index: compile.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/main/compile.sml,v
retrieving revision 1.44
retrieving revision 1.45
diff -u -r1.44 -r1.45
--- compile.sml 2 Jan 2003 17:45:19 -0000 1.44
+++ compile.sml 3 Jan 2003 06:14:16 -0000 1.45
@@ -350,8 +350,7 @@
[("Exn_keepHistory", Bool (!exnHistory)),
("MLton_detectOverflow", Bool (!detectOverflow)),
("MLton_native", Bool (!Native.native)),
- ("MLton_profile_alloc", Bool (!profile = ProfileAlloc)),
- ("MLton_profile_time", Bool (!profile = ProfileTime)),
+ ("MLton_profile_isOn", Bool (!profile <> ProfileNone)),
("MLton_safe", Bool (!safe)),
("TextIO_bufSize", Int (!textIOBufSize))]
end
@@ -375,6 +374,7 @@
{
canHandle = get "canHandle",
cardMap = get "cardMapForMutator",
+ currentSource = get "currentSource",
currentThread = get "currentThread",
frontier = get "frontier",
limit = get "limit",
1.106 +3 -0 mlton/mlton/main/main.sml
Index: main.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/main/main.sml,v
retrieving revision 1.105
retrieving revision 1.106
diff -u -r1.105 -r1.106
--- main.sml 2 Jan 2003 17:45:19 -0000 1.105
+++ main.sml 3 Jan 2003 06:14:16 -0000 1.106
@@ -253,6 +253,9 @@
| "alloc" => ProfileAlloc
| "time" => ProfileTime
| _ => usage (concat ["invalid -profile arg: ", s])))),
+ (Normal, "profile-stack", " {false|true}",
+ "profile the stack",
+ boolRef profileStack),
(Expert, "print-at-fun-entry", " {false|true}",
"print debugging message at every call",
boolRef printAtFunEntry),
1.47 +3 -5 mlton/runtime/Makefile
Index: Makefile
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/Makefile,v
retrieving revision 1.46
retrieving revision 1.47
diff -u -r1.46 -r1.47
--- Makefile 2 Jan 2003 17:45:22 -0000 1.46
+++ Makefile 3 Jan 2003 06:14:16 -0000 1.47
@@ -33,8 +33,7 @@
basis/MLton/bug.o \
basis/MLton/errno.o \
basis/MLton/exit.o \
- basis/MLton/profile-alloc.o \
- basis/MLton/profile-time.o \
+ basis/MLton/profile.o \
basis/MLton/rlimit.o \
basis/MLton/rusage.o \
basis/MLton/spawne.o \
@@ -195,8 +194,7 @@
basis/MLton/bug-gdb.o \
basis/MLton/errno-gdb.o \
basis/MLton/exit-gdb.o \
- basis/MLton/profile-alloc.o \
- basis/MLton/profile-time-gdb.o \
+ basis/MLton/profile-gdb.o \
basis/MLton/rlimit-gdb.o \
basis/MLton/rusage-gdb.o \
basis/MLton/spawne-gdb.o \
@@ -339,7 +337,7 @@
%-gdb.o: %.c
$(CC) $(DEBUGFLAGS) -DASSERT=1 -c -o $@ $<
-%.o: %.c gc.h
+%.o: %.c
$(CC) $(CFLAGS) -c -o $@ $<
%-gdb.o: %.S
1.111 +186 -144 mlton/runtime/gc.c
Index: gc.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/gc.c,v
retrieving revision 1.110
retrieving revision 1.111
diff -u -r1.110 -r1.111
--- gc.c 2 Jan 2003 17:45:22 -0000 1.110
+++ gc.c 3 Jan 2003 06:14:16 -0000 1.111
@@ -13,7 +13,6 @@
#include <string.h>
#if (defined (__FreeBSD__))
-#include <sys/types.h>
#include <sys/sysctl.h>
#endif
@@ -37,6 +36,14 @@
#include <limits.h>
#endif
+#if (defined (__linux__) || defined (__FreeBSD__))
+#include <signal.h>
+#include <sys/stat.h>
+#include <sys/time.h>
+#include <sys/types.h>
+#include <ucontext.h>
+#endif
+
#include "IntInf.h"
#define METER FALSE /* Displays distribution of object sizes at program exit. */
@@ -62,6 +69,7 @@
DEBUG_GENERATIONAL = FALSE,
DEBUG_MARK_COMPACT = FALSE,
DEBUG_MEM = FALSE,
+ DEBUG_PROFILE = FALSE,
DEBUG_RESIZING = FALSE,
DEBUG_SIGNALS = FALSE,
DEBUG_STACKS = FALSE,
@@ -2774,6 +2782,10 @@
/* Profiling */
/* ---------------------------------------------------------------- */
+static void enterFrame (GC_state s, uint i) {
+ MLton_Profile_enter (s->frameSources[i]);
+}
+
void GC_foreachStackFrame (GC_state s, void (*f) (GC_state s, uint i)) {
pointer bottom;
word index;
@@ -2781,17 +2793,17 @@
word returnAddress;
pointer top;
- if (DEBUG_PROFILE_TIME)
+ if (DEBUG_PROFILE)
fprintf (stderr, "walking stack");
assert (s->native);
bottom = stackBottom (s->currentThread->stack);
- if (DEBUG_PROFILE_TIME)
+ if (DEBUG_PROFILE)
fprintf (stderr, " bottom = 0x%08x top = 0x%08x.\n",
(uint)bottom, (uint)s->stackTop);
for (top = s->stackTop; top > bottom; top -= layout->numBytes) {
returnAddress = *(word*)(top - WORD_SIZE);
index = *(word*)(returnAddress - WORD_SIZE);
- if (DEBUG_PROFILE_TIME)
+ if (DEBUG_PROFILE)
fprintf (stderr, "top = 0x%08x index = %u\n",
(uint)top, index);
unless (0 <= index and index < s->frameLayoutsSize)
@@ -2801,13 +2813,14 @@
layout = &(s->frameLayouts[index]);
assert (layout->numBytes > 0);
}
- if (DEBUG_PROFILE_TIME)
+ if (DEBUG_PROFILE)
fprintf (stderr, "done walking stack\n");
}
+/* s->currentSource must be set. */
void GC_incProfileAlloc (GC_state s, W32 amount) {
- if (s->profileAllocIsOn)
- MLton_ProfileAlloc_inc (amount);
+ if (s->profilingIsOn and (PROFILE_ALLOC == s->profileKind))
+ MLton_Profile_inc (amount);
}
static void showProf (GC_state s) {
@@ -2818,13 +2831,28 @@
fprintf (stdout, "%s\n", s->sources[i]);
}
-static int compareProfileLabels (const void *v1, const void *v2) {
- GC_profileLabel l1;
- GC_profileLabel l2;
-
- l1 = (GC_profileLabel)v1;
- l2 = (GC_profileLabel)v2;
- return (int)l1->label - (int)l2->label;
+void GC_profileFree (GC_state s, GC_profile p) {
+ free (p->count);
+ if (s->profileStack) {
+ free (p->lastTotal);
+ free (p->stackCount);
+ }
+ free (p);
+}
+
+GC_profile GC_profileNew (GC_state s) {
+ GC_profile p;
+
+ NEW(p);
+ p->total = 0;
+ ARRAY (p->count, s->sourcesSize);
+ if (s->profileStack) {
+ ARRAY (p->lastTotal, s->sourcesSize);
+ ARRAY (p->stackCount, s->sourcesSize);
+ }
+ if (DEBUG_PROFILE)
+ fprintf (stderr, "0x%08x = GC_profileNew ()\n", (uint)p);
+ return p;
}
static void writeString (int fd, string s) {
@@ -2832,13 +2860,6 @@
swrite (fd, "\n", 1);
}
-static void writeUint (int fd, uint w) {
- char buf[20];
-
- sprintf (buf, "%u", w);
- writeString (fd, buf);
-}
-
static void writeUllong (int fd, ullong u) {
char buf[20];
@@ -2853,86 +2874,156 @@
writeString (fd, buf);
}
-static void profileHeaderWrite (GC_state s, string kind, int fd, ullong total) {
+void GC_profileWrite (GC_state s, GC_profile p, int fd) {
+ int i;
+
writeString (fd, "MLton prof");
- writeString (fd, kind);
- switch (s->profileStyle) {
- case PROFILE_CUMULATIVE:
- writeString (fd, "cumulative");
- break;
- case PROFILE_CURRENT:
- writeString (fd, "current");
- break;
- }
+ writeString (fd, (PROFILE_ALLOC == s->profileKind) ? "alloc" : "time");
+ writeString (fd, s->profileStack ? "cumulative" : "current");
writeWord (fd, s->magic);
- writeUllong (fd, total);
+ writeUllong (fd, p->total + p->count[SOURCES_INDEX_GC]);
+ for (i = 0; i < s->sourcesSize; ++i)
+ writeUllong (fd, p->count[i]);
}
-void GC_profileAllocFree (GC_state s, GC_profileAlloc pa) {
- free (pa->bytesAllocated);
- switch (s->profileStyle) {
- case PROFILE_CUMULATIVE:
- free (pa->lastTotal);
- free (pa->stackCount);
- break;
- case PROFILE_CURRENT:
- break;
- }
- free (pa);
-}
-
-GC_profileAlloc GC_profileAllocNew (GC_state s) {
- GC_profileAlloc pa;
-
- NEW(pa);
- pa->totalBytesAllocated = 0;
- ARRAY (pa->bytesAllocated, s->sourcesSize);
- switch (s->profileStyle) {
- case PROFILE_CUMULATIVE:
- ARRAY (pa->lastTotal, s->sourcesSize);
- ARRAY (pa->stackCount, s->sourcesSize);
- break;
- case PROFILE_CURRENT:
- break;
- }
- if (DEBUG_PROFILE_ALLOC)
- fprintf (stderr, "0x%08x = GC_profileAllocNew()\n",
- (uint)pa);
- return pa;
+#if (defined (__linux__) || defined (__FreeBSD__))
+
+#ifndef EIP
+#define EIP 14
+#endif
+
+static GC_state catcherState;
+
+/*
+ * Called on each SIGPROF interrupt.
+ */
+static void catcher (int sig, siginfo_t *sip, ucontext_t *ucp) {
+ GC_state s;
+ pointer pc;
+
+ s = catcherState;
+#if (defined (__linux__))
+ pc = (pointer) ucp->uc_mcontext.gregs[EIP];
+#elif (defined (__FreeBSD__))
+ pc = (pointer) ucp->uc_mcontext.mc_eip;
+#else
+#error pc not defined
+#endif
+ if (DEBUG_PROFILE)
+ fprintf (stderr, "pc = 0x%08x\n", (uint)pc);
+ if (s->textStart <= pc and pc < s->textEnd)
+ s->currentSource = s->textSources [pc - s->textStart];
+ else
+ s->currentSource = SOURCE_SEQ_UNKNOWN;
+ MLton_Profile_inc (1);
}
-void GC_profileAllocWrite (GC_state s, GC_profileAlloc pa, int fd) {
- int i;
+/* To get the beginning and end of the text segment. */
+extern void _start(void),
+ etext(void);
- profileHeaderWrite (s, "alloc", fd,
- pa->totalBytesAllocated
- + pa->bytesAllocated[SOURCES_INDEX_GC]);
- for (i = 0; i < s->sourcesSize; ++i)
- writeUllong (fd, pa->bytesAllocated[i]);
+static int compareProfileLabels (const void *v1, const void *v2) {
+ GC_profileLabel l1;
+ GC_profileLabel l2;
+
+ l1 = (GC_profileLabel)v1;
+ l2 = (GC_profileLabel)v2;
+ return (int)l1->label - (int)l2->label;
}
-void GC_profileTimeFree (GC_state s, GC_profileTime pt) {
- free (pt->ticks);
- free (pt);
+static void setProfTimer (long usec) {
+ struct itimerval iv;
+
+ iv.it_interval.tv_sec = 0;
+ iv.it_interval.tv_usec = 10000;
+ iv.it_value.tv_sec = 0;
+ iv.it_value.tv_usec = 10000;
+ unless (0 == setitimer (ITIMER_PROF, &iv, NULL))
+ die ("setProfTimer failed");
}
-GC_profileTime GC_profileTimeNew (GC_state s) {
- GC_profileTime pt;
-
- NEW(pt);
- ARRAY(pt->ticks, s->sourcesSize);
- pt->totalTicks = 0;
- return pt;
+void GC_profileDone (GC_state s) {
+ assert (s->profilingIsOn);
+ if (PROFILE_TIME == s->profileKind)
+ setProfTimer (0);
+ s->profilingIsOn = FALSE;
}
-void GC_profileTimeWrite (GC_state s, GC_profileTime pt, int fd) {
+static void profileTimeInit (GC_state s) {
int i;
+ pointer p;
+ struct sigaction sa;
+ uint sourceSeqsIndex;
- profileHeaderWrite (s, "time", fd, pt->totalTicks);
- for (i = 0; i < s->sourcesSize; ++i)
- writeUint (fd, pt->ticks[i]);
+ s->profile = GC_profileNew (s);
+ /* Sort sourceLabels by address. */
+ qsort (s->sourceLabels, s->sourceLabelsSize, sizeof(*s->sourceLabels),
+ compareProfileLabels);
+ if (DEBUG_PROFILE)
+ for (i = 0; i < s->sourceLabelsSize; ++i)
+ fprintf (stderr, "0x%08x %u\n",
+ (uint)s->sourceLabels[i].label,
+ s->sourceLabels[i].sourceSeqsIndex);
+ if (ASSERT)
+ for (i = 1; i < s->sourceLabelsSize; ++i)
+ assert (s->sourceLabels[i-1].label
+ <= s->sourceLabels[i].label);
+ /* Initialize s->textSources. */
+ s->textEnd = (pointer)&etext;
+ s->textStart = (pointer)&_start;
+ if (ASSERT)
+ for (i = 0; i < s->sourceLabelsSize; ++i)
+ assert (s->textStart <= s->sourceLabels[i].label
+ and s->sourceLabels[i].label < s->textEnd);
+ ARRAY (s->textSources, s->textEnd - s->textStart);
+ p = s->textStart;
+ sourceSeqsIndex = SOURCE_SEQ_UNKNOWN;
+ for (i = 0; i < s->sourceLabelsSize; ++i) {
+ for ( ; p < s->sourceLabels[i].label; ++p)
+ s->textSources[p - s->textStart] = sourceSeqsIndex;
+ sourceSeqsIndex = s->sourceLabels[i].sourceSeqsIndex;
+ }
+ for ( ; p < s->textEnd; ++p)
+ s->textSources[p - s->textStart] = sourceSeqsIndex;
+ /*
+ * Install catcher, which handles SIGPROF and calls MLton_Profile_inc.
+ *
+ * One thing I should point out that I discovered the hard way: If
+ * the call to sigaction does NOT specify the SA_ONSTACK flag, then
+ * even if you have called sigaltstack(), it will NOT switch stacks,
+ * so you will probably die. Worse, if the call to sigaction DOES
+ * have SA_ONSTACK and you have NOT called sigaltstack(), it still
+ * switches stacks (to location 0) and you die of a SEGV. Thus the
+ * sigaction() call MUST occur after the call to sigaltstack(), and
+ * in order to have profiling cover as much as possible, you want it
+ * to occur right after the sigaltstack() call.
+ */
+ catcherState = s;
+ sa.sa_handler = (void (*)(int))catcher;
+ sigemptyset (&sa.sa_mask);
+ sa.sa_flags = SA_ONSTACK | SA_RESTART | SA_SIGINFO;
+ unless (sigaction (SIGPROF, &sa, NULL) == 0)
+ diee ("sigaction() failed");
+ /* Start the SIGPROF timer. */
+ setProfTimer (10000);
+}
+
+#elif (defined (__CYGWIN__))
+
+/* No time profiling on Cygwin.
+ * There is a check in mlton/main/main.sml to make sure that time profiling is
+ * never turned on on Cygwin.
+ */
+static void profileTimeInit (GC_state s) {
+ die ("no time profiling on Cygwin");
}
+#else
+
+#error time profiling not implemented
+
+#endif
+
/* ---------------------------------------------------------------- */
/* Initialization */
/* ---------------------------------------------------------------- */
@@ -3336,10 +3427,6 @@
/* GC_init */
/* ---------------------------------------------------------------- */
-/* To get the beginning and end of the text segment. */
-extern void _start(void),
- etext(void);
-
int GC_init (GC_state s, int argc, char **argv) {
char *worldFile;
int i;
@@ -3376,8 +3463,6 @@
s->numMinorsSinceLastMajor = 0;
s->nurseryRatio = 10.0;
s->oldGenArraySize = 0x100000;
- s->profileStyle = PROFILE_CURRENT;
- s->profileStyle = PROFILE_CUMULATIVE;
s->pageSize = getpagesize ();
s->ramSlop = 0.80;
s->savedThread = BOGUS_THREAD;
@@ -3401,62 +3486,16 @@
die ("page size must be a multiple of card size");
/* Initialize profiling. */
if (s->sourcesSize > 0) {
+ s->profilingIsOn = TRUE;
if (s->sourceLabelsSize > 0) {
- s->profileAllocIsOn = FALSE;
- s->profileTimeIsOn = TRUE;
+ s->profileKind = PROFILE_TIME;
+ profileTimeInit (s);
} else {
- s->profileAllocIsOn = TRUE;
- s->profileTimeIsOn = FALSE;
- }
- }
- if (s->profileAllocIsOn) {
- s->profileAlloc = GC_profileAllocNew (s);
- }
- if (s->profileTimeIsOn) {
- pointer p;
- uint sourceSeqsIndex;
-
- if (PROFILE_CUMULATIVE == s->profileStyle)
- ARRAY (s->sourceIsOnStack, s->sourcesSize);
- /* Sort profileLabels by address. */
- qsort (s->sourceLabels,
- s->sourceLabelsSize,
- sizeof(*s->sourceLabels),
- compareProfileLabels);
- if (DEBUG_PROFILE_TIME)
- for (i = 0; i < s->sourceLabelsSize; ++i)
- fprintf (stderr, "0x%08x %u\n",
- (uint)s->sourceLabels[i].label,
- s->sourceLabels[i].sourceSeqsIndex);
- if (ASSERT)
- for (i = 1; i < s->sourceLabelsSize; ++i)
- assert (s->sourceLabels[i-1].label
- <= s->sourceLabels[i].label);
- /* Initialize s->textSources. */
- s->textEnd = (pointer)&etext;
- s->textStart = (pointer)&_start;
- if (DEBUG)
- for (i = 0; i < s->sourceLabelsSize; ++i)
- assert (s->textStart <= s->sourceLabels[i].label
- and s->sourceLabels[i].label < s->textEnd);
- s->textSources =
- (uint*)malloc ((s->textEnd - s->textStart)
- * sizeof(*s->textSources));
- if (NULL == s->textSources)
- die ("Out of memory: unable to allocate textSources");
- p = s->textStart;
- sourceSeqsIndex = SOURCE_SEQ_UNKNOWN;
- for (i = 0; i < s->sourceLabelsSize; ++i) {
- while (p < s->sourceLabels[i].label) {
- s->textSources[p - s->textStart]
- = sourceSeqsIndex;
- ++p;
- }
- sourceSeqsIndex = s->sourceLabels[i].sourceSeqsIndex;
+ s->profileKind = PROFILE_ALLOC;
+ s->profile = GC_profileNew (s);
}
- for ( ; p < s->textEnd; ++p)
- s->textSources[p - s->textStart] = sourceSeqsIndex;
- }
+ } else
+ s->profilingIsOn = FALSE;
/* Process command-line arguments. */
i = 1;
if (argc > 1 and (0 == strcmp (argv [1], "@MLton"))) {
@@ -3572,8 +3611,11 @@
uintToCommaString (s->ram));
if (s->isOriginal)
newWorld (s);
- else
+ else {
loadWorld (s, worldFile);
+ if (s->profilingIsOn and s->profileStack)
+ GC_foreachStackFrame (s, enterFrame);
+ }
s->amInGC = FALSE;
assert (mutatorInvariant (s));
return i;
1.50 +34 -61 mlton/runtime/gc.h
Index: gc.h
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/gc.h,v
retrieving revision 1.49
retrieving revision 1.50
diff -u -r1.49 -r1.50
--- gc.h 2 Jan 2003 17:45:22 -0000 1.49
+++ gc.h 3 Jan 2003 06:14:17 -0000 1.50
@@ -63,8 +63,6 @@
/* Sizes are (almost) always measured in bytes. */
enum {
- DEBUG_PROFILE_ALLOC = FALSE,
- DEBUG_PROFILE_TIME = FALSE,
WORD_SIZE = 4,
COUNTER_MASK = 0x7FF00000,
COUNTER_SHIFT = 20,
@@ -87,11 +85,6 @@
#define TWOPOWER(n) (1 << (n))
-typedef enum {
- PROFILE_CURRENT,
- PROFILE_CUMULATIVE,
-} ProfileStyle;
-
/* ------------------------------------------------- */
/* object type */
/* ------------------------------------------------- */
@@ -203,47 +196,41 @@
/* Profiling */
/* ------------------------------------------------- */
+typedef enum {
+ PROFILE_ALLOC,
+ PROFILE_TIME,
+} ProfileKind;
+
typedef struct GC_sourceLabel {
pointer label;
uint sourceSeqsIndex;
} *GC_profileLabel;
-typedef struct GC_profileAlloc {
- /* bytesAllocated is an array of length sourcesSize that counts for
- * each function the number of bytes that have been allocated.
- * If profileStyle == PROFILE_CURRENT, then it is the number while
- * that function was current. If profileStyle == PROFILE_CUMULATIVE,
- * then it is the number while the function was on the stack.
+/* GC_profile is used for both time and allocation profiling.
+ */
+typedef struct GC_profile {
+ /* count is an array of length sourcesSize that counts for each function
+ * the number of bytes that have been allocated or the number of clock
+ * ticks that have occurred while the function was on top of the stack.
+ * If profileStack, then it is the number while the function was
+ * anywhere on the stack.
*/
- ullong *bytesAllocated;
+ ullong *count;
/* lastTotal is an array of length sourcesSize that for each function,
- * f, stores the value of totalBytesAllocated when the oldest occurrence
- * of f on the stack was pushed, i.e., the most recent time that
- * stackCount[f] was changed from 0 to 1. lastTotal is used to compute
- * the number of bytes to attribute to f when the oldest occurrence is
- * finally popped. lastTotal is only used if
- * profileStyle == PROFILE_CUMULATIVE.
+ * f, stores the value of total when the oldest occurrence of f on the
+ * stack was pushed, i.e., the most recent time that stackCount[f] was
+ * changed from 0 to 1. lastTotal is used to compute the amount to
+ * attribute to f when the oldest occurrence is finally popped.
+ * lastTotal is only used if profileStack.
*/
ullong *lastTotal;
/* stackCount is an array of length sourcesSize that counts the number
* of times each function is on the stack. It is only used if
- * profileStyle == PROFILE_CUMULATIVE.
+ * profileStack.
*/
uint *stackCount;
- ullong totalBytesAllocated;
-} *GC_profileAlloc;
-
-typedef struct GC_profileTime {
- /* ticks is an array of length sourcesSize that counts for each function
- * the number of clock ticks that have happened while the function was
- * on top of the stack (if profileStyle == PROFILE_CURRENT) or anywhere
- * on the stack (if profileStyle == PROFILE_CUMULATIVE).
- * With a 32 bits, a counter cannot overflow for 2^32 / 100 seconds,
- * or a bit over 1 CPU year.
- */
- uint *ticks;
- uint totalTicks;
-} *GC_profileTime;
+ ullong total;
+} *GC_profile;
/* ------------------------------------------------- */
/* GC_heap */
@@ -307,8 +294,7 @@
pointer crossMap;
uint crossMapSize;
/* currentSource is the index in sources of the currently executing
- * function. This is only used when allocation profiling with
- * profileStyle = PROFILE_CURRENT;
+ * function.
*/
uint currentSource;
GC_thread currentThread; /* This points to a thread in the heap. */
@@ -379,11 +365,10 @@
W32 oldGenArraySize;
uint oldGenSize;
uint pageSize; /* bytes */
- GC_profileAlloc profileAlloc;
- bool profileAllocIsOn;
- ProfileStyle profileStyle;
- GC_profileTime profileTime;
- bool profileTimeIsOn;
+ GC_profile profile;
+ ProfileKind profileKind;
+ bool profileStack;
+ bool profilingIsOn;
W32 ram; /* ramSlop * totalRam */
float ramSlop;
struct rusage ru_gc; /* total resource usage spent in gc */
@@ -412,12 +397,6 @@
* signal handler.
*/
sigset_t signalsPending;
- /* sourceIsOnStack is an array of bools of length sourcesSize. It is
- * used during stack walking (when time profiling with
- * profileStyle == PROFILE_CUMULATIVE) to count each source function
- * only once no matter how many times it appears on the stack.
- */
- char *sourceIsOnStack;
struct GC_sourceLabel *sourceLabels;
uint sourceLabelsSize;
/* sources is an array of strings identifying source positions. */
@@ -584,18 +563,6 @@
and slot < s->stackBottom + s->currentThread->stack->reserved;
}
-/* Write a profile data array out to a file descriptor.
- *
- * The `unknown ticks' is a count of the number of times that the monitored
- * program counter was not in the range of a bin. This almost certainly
- * corresponds to times when it was pointing at shared library code.
- */
-void GC_profileAllocFree (GC_state s, GC_profileAlloc pa);
-GC_profileAlloc GC_profileAllocNew (GC_state s);
-void GC_profileAllocWrite (GC_state s, GC_profileAlloc pa, int fd);
-void GC_profileTimeFree (GC_state s, GC_profileTime pt);
-GC_profileTime GC_profileTimeNew (GC_state s);
-void GC_profileTimeWrite (GC_state s, GC_profileTime pt, int fd);
/*
* Build the header for an object, given the index to its type info.
@@ -608,7 +575,13 @@
/* Pack the heap into a small amount of RAM. */
void GC_pack (GC_state s);
-void GC_profile (GC_state s, uint sourceSeqsIndex);
+void GC_profileDone (GC_state s);
+
+void GC_profileFree (GC_state s, GC_profile p);
+
+GC_profile GC_profileNew (GC_state s);
+
+void GC_profileWrite (GC_state s, GC_profile p, int fd);
/* Write out the current world to the file descriptor. */
void GC_saveWorld (GC_state s, int fd);
1.19 +9 -19 mlton/runtime/mlton-basis.h
Index: mlton-basis.h
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/mlton-basis.h,v
retrieving revision 1.18
retrieving revision 1.19
diff -u -r1.18 -r1.19
--- mlton-basis.h 29 Dec 2002 01:23:00 -0000 1.18
+++ mlton-basis.h 3 Jan 2003 06:14:17 -0000 1.19
@@ -129,26 +129,16 @@
Word MLton_random ();
Word MLton_size (Pointer p);
-enum {
- MLPROF_KIND_ALLOC = 0,
- MLPROF_KIND_TIME = 1,
-};
+void MLton_Profile_Data_free (Pointer d);
+Pointer MLton_Profile_Data_malloc (void);
+void MLton_Profile_Data_write (Pointer data, Word fd);
-void MLton_ProfileAlloc_Data_free (Pointer d);
-Pointer MLton_ProfileAlloc_Data_malloc (void);
-void MLton_ProfileAlloc_Data_reset (Pointer d);
-void MLton_ProfileAlloc_Data_write (Pointer d, Word fd);
-Pointer MLton_ProfileAlloc_current (void);
-void MLton_ProfileAlloc_inc (Word amount);
-void MLton_ProfileAlloc_setCurrent (Pointer d);
-
-void MLton_ProfileTime_Data_free (Pointer d);
-Pointer MLton_ProfileTime_Data_malloc (void);
-void MLton_ProfileTime_Data_reset (Pointer data);
-void MLton_ProfileTime_Data_write (Pointer data, Cstring name);
-Pointer MLton_ProfileTime_current (void);
-void MLton_ProfileTime_init (void);
-void MLton_ProfileTime_setCurrent (Pointer d);
+Pointer MLton_Profile_current (void);
+void MLton_Profile_enter (Word sourceSeqsIndex);
+/* Must set s->currentSource before calling MLton_Profile_inc. */
+void MLton_Profile_inc (Word amount);
+void MLton_Profile_leave (Word sourceSeqsIndex);
+void MLton_Profile_setCurrent (Pointer d);
#if (defined (__CYGWIN__))
Int MLton_Process_spawne (NullString p, Pointer a, Pointer e);
1.6 +137 -151 mlton/runtime/basis/MLton/profile.c
-------------------------------------------------------
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