[MLton-commit] r5257: added option -profile-val
Matthew Fluet
fluet at mlton.org
Sun Feb 18 17:01:24 PST 2007
MAIL added option -profile-val
Some very minor additions to the profiling infrastructure, mainly
addressing a comment raised by:
http://mlton.org/pipermail/mlton-user/2007-January/000992.html
The '-profile-val true' option instructs the compiler to push and pop
profiling information for the evaluation of (expansive) val bindings.
With the program described in the message above, we now have the
following output (with "-const 'Exn.keepHistory true' -profile-val true"):
[fluet at shadow tmp]$ ./z
unhandled exception: Uninitialized
with history:
r.<raise> z.sml 5.36
r z.sml 4.9
<val>:z z.sml 9.9
<main>
So, we get the very useful information about which top-level binding
is responsible for the exception.
With "-profile-val true -profile-stack true", it should be possible to
distinguish expensive calls to the same function.
I'm not 100% happy with the syntax, so suggestions are welcome.
I also tweaked basis-library/mlton/call-stack.sml to only ignore one
element at the bottom of the call stack; this seems to have solved the
issue with "shallow" call stacks.
----------------------------------------------------------------------
U mlton/trunk/basis-library/mlton/call-stack.sml
U mlton/trunk/doc/changelog
U mlton/trunk/mlton/control/control-flags.sig
U mlton/trunk/mlton/control/control-flags.sml
U mlton/trunk/mlton/elaborate/elaborate-core.fun
U mlton/trunk/mlton/main/main.fun
----------------------------------------------------------------------
Modified: mlton/trunk/basis-library/mlton/call-stack.sml
===================================================================
--- mlton/trunk/basis-library/mlton/call-stack.sml 2007-02-18 22:18:40 UTC (rev 5256)
+++ mlton/trunk/basis-library/mlton/call-stack.sml 2007-02-19 01:01:22 UTC (rev 5257)
@@ -30,7 +30,7 @@
then []
else
let
- val skip = Array.length a - 2
+ val skip = Array.length a - 1
in
Array.foldri
(fn (i, frameIndex, ac) =>
Modified: mlton/trunk/doc/changelog
===================================================================
--- mlton/trunk/doc/changelog 2007-02-18 22:18:40 UTC (rev 5256)
+++ mlton/trunk/doc/changelog 2007-02-19 01:01:22 UTC (rev 5257)
@@ -1,5 +1,10 @@
Here are the changes since version 20051202.
+* 2007-02-18
+ - Added command line switch -profile-val, to profile the evaluation of
+ val bindings; this is particularly useful with exception history for
+ debugging uncaught exceptions at the top-level.
+
* 2006-12-29
- Added command line switch -show {anns|path-map} and deprecated command
line switch -show-anns {false|true}. Use -show path-map to see the
Modified: mlton/trunk/mlton/control/control-flags.sig
===================================================================
--- mlton/trunk/mlton/control/control-flags.sig 2007-02-18 22:18:40 UTC (rev 5256)
+++ mlton/trunk/mlton/control/control-flags.sig 2007-02-19 01:01:22 UTC (rev 5257)
@@ -282,6 +282,8 @@
val profileStack: bool ref
+ val profileVal: bool ref
+
(* Show the basis library. *)
val showBasis: File.t option ref
Modified: mlton/trunk/mlton/control/control-flags.sml
===================================================================
--- mlton/trunk/mlton/control/control-flags.sml 2007-02-18 22:18:40 UTC (rev 5256)
+++ mlton/trunk/mlton/control/control-flags.sml 2007-02-19 01:01:22 UTC (rev 5257)
@@ -921,6 +921,10 @@
default = false,
toString = Bool.toString}
+val profileVal = control {name = "profile val",
+ default = false,
+ toString = Bool.toString}
+
val showBasis = control {name = "show basis",
default = NONE,
toString = Option.toString File.toString}
Modified: mlton/trunk/mlton/elaborate/elaborate-core.fun
===================================================================
--- mlton/trunk/mlton/elaborate/elaborate-core.fun 2007-02-18 22:18:40 UTC (rev 5256)
+++ mlton/trunk/mlton/elaborate/elaborate-core.fun 2007-02-19 01:01:22 UTC (rev 5257)
@@ -2126,12 +2126,15 @@
(seq [Apat.layout pat,
str " = ", Aexp.layout exp])]
end
+ val patRegion = Apat.region pat
+ val expRegion = Aexp.region exp
+ val exp = elabExp (exp, nest, Apat.getName pat)
in
- {exp = elabExp (exp, nest, Apat.getName pat),
- expRegion = Aexp.region exp,
+ {exp = exp,
+ expRegion = expRegion,
lay = lay,
pat = pat,
- patRegion = Apat.region pat}
+ patRegion = patRegion}
end)
val {markFunc, setBound, unmarkFunc} = recursiveFun ()
val elaboratePat = elaboratePat ()
@@ -2228,25 +2231,46 @@
val vbs =
Vector.map
(vbs,
- fn {exp = e, expRegion, lay, pat, patRegion, ...} =>
+ fn {exp, expRegion, lay, pat, patRegion, ...} =>
let
- val (p, bound) =
+ val (pat, bound) =
elaboratePat (pat, E, {bind = false,
isRvb = false}, preError)
val _ =
unify
- (Cpat.ty p, Cexp.ty e, fn (p, e) =>
- (Apat.region pat,
+ (Cpat.ty pat, Cexp.ty exp, fn (p, e) =>
+ (patRegion,
str "pattern and expression disagree",
align [seq [str "pattern: ", p],
seq [str "expression: ", e],
lay ()]))
+ val exp =
+ Cexp.enterLeave
+ (exp,
+ profileBody
+ andalso !Control.profileVal
+ andalso Cexp.isExpansive exp, fn () =>
+ let
+ val bound = Vector.map (bound, #1)
+ val name =
+ concat ["<val>:",
+ if Vector.length bound = 1
+ then (Avar.toString
+ (Vector.sub (bound, 0)))
+ else (Vector.toString
+ Avar.toString
+ bound)]
+ in
+ SourceInfo.function
+ {name = name :: nest,
+ region = expRegion}
+ end)
in
{bound = bound,
- exp = e,
+ exp = exp,
expRegion = expRegion,
lay = lay,
- pat = p,
+ pat = pat,
patRegion = patRegion}
end)
val boundVars =
@@ -2922,7 +2946,7 @@
Cexp.enterLeave
(Cexp.make (Cexp.Raise exn, resultType),
profileBody andalso !Control.profileRaise,
- fn () => SourceInfo.function {name = "raise" :: nest,
+ fn () => SourceInfo.function {name = "<raise>" :: nest,
region = region})
end
| Aexp.Record r =>
Modified: mlton/trunk/mlton/main/main.fun
===================================================================
--- mlton/trunk/mlton/main/main.fun 2007-02-18 22:18:40 UTC (rev 5256)
+++ mlton/trunk/mlton/main/main.fun 2007-02-19 01:01:22 UTC (rev 5257)
@@ -459,6 +459,9 @@
boolRef profileRaise),
(Normal, "profile-stack", " {false|true}", "profile the stack",
boolRef profileStack),
+ (Normal, "profile-val", " {false|true}",
+ "profile val bindings in addition to functions",
+ boolRef profileVal),
(Normal, "runtime", " <arg>", "pass arg to runtime via @MLton",
SpaceString (fn s => List.push (runtimeArgs, s))),
(Expert, "show", " {anns|path-map}", "print specified data and stop",
More information about the MLton-commit
mailing list