[MLton-commit] r5787
Matthew Fluet
fluet at mlton.org
Tue Jul 24 19:58:07 PDT 2007
Some cosmetic improvements to profiling
----------------------------------------------------------------------
U mlton/trunk/mlton/core-ml/core-ml.fun
U mlton/trunk/mlton/core-ml/core-ml.sig
U mlton/trunk/mlton/defunctorize/defunctorize.fun
U mlton/trunk/mlton/elaborate/elaborate-core.fun
U mlton/trunk/mlton/elaborate/elaborate-env.fun
----------------------------------------------------------------------
Modified: mlton/trunk/mlton/core-ml/core-ml.fun
===================================================================
--- mlton/trunk/mlton/core-ml/core-ml.fun 2007-07-22 15:51:14 UTC (rev 5786)
+++ mlton/trunk/mlton/core-ml/core-ml.fun 2007-07-25 02:58:05 UTC (rev 5787)
@@ -151,6 +151,7 @@
tyvars: unit -> Tyvar.t vector,
vbs: {exp: exp,
lay: unit -> Layout.t,
+ nest: string list,
pat: Pat.t,
patRegion: Region.t} vector}
and exp = Exp of {node: expNode,
@@ -159,6 +160,7 @@
App of exp * exp
| Case of {kind: string,
lay: unit -> Layout.t,
+ nest: string list,
noMatch: noMatch,
nonexhaustiveExnMatch: Control.Elaborate.DiagDI.t,
nonexhaustiveMatch: Control.Elaborate.DiagEIW.t,
@@ -365,6 +367,7 @@
fun iff (test, thenCase, elseCase): t =
casee {kind = "if",
lay = fn () => Layout.empty,
+ nest = [],
noMatch = Impossible,
nonexhaustiveExnMatch = Control.Elaborate.DiagDI.Default,
nonexhaustiveMatch = Control.Elaborate.DiagEIW.Ignore,
Modified: mlton/trunk/mlton/core-ml/core-ml.sig
===================================================================
--- mlton/trunk/mlton/core-ml/core-ml.sig 2007-07-22 15:51:14 UTC (rev 5786)
+++ mlton/trunk/mlton/core-ml/core-ml.sig 2007-07-25 02:58:05 UTC (rev 5787)
@@ -74,6 +74,7 @@
App of t * t
| Case of {kind: string,
lay: unit -> Layout.t,
+ nest: string list,
noMatch: noMatch,
nonexhaustiveExnMatch: Control.Elaborate.DiagDI.t,
nonexhaustiveMatch: Control.Elaborate.DiagEIW.t,
@@ -103,6 +104,7 @@
val andAlso: t * t -> t
val casee: {kind: string,
lay: unit -> Layout.t,
+ nest: string list,
noMatch: noMatch,
nonexhaustiveExnMatch: Control.Elaborate.DiagDI.t,
nonexhaustiveMatch: Control.Elaborate.DiagEIW.t,
@@ -166,6 +168,7 @@
tyvars: unit -> Tyvar.t vector,
vbs: {exp: Exp.t,
lay: unit -> Layout.t,
+ nest: string list,
pat: Pat.t,
patRegion: Region.t} vector}
Modified: mlton/trunk/mlton/defunctorize/defunctorize.fun
===================================================================
--- mlton/trunk/mlton/defunctorize/defunctorize.fun 2007-07-22 15:51:14 UTC (rev 5786)
+++ mlton/trunk/mlton/defunctorize/defunctorize.fun 2007-07-25 02:58:05 UTC (rev 5787)
@@ -110,6 +110,7 @@
conTycon,
kind: string,
lay: unit -> Layout.t,
+ nest: string list,
noMatch,
nonexhaustiveExnMatch: Control.Elaborate.DiagDI.t,
nonexhaustiveMatch: Control.Elaborate.DiagEIW.t,
@@ -130,17 +131,21 @@
val exp = Xexp.raisee (f e, {extend = true}, caseType)
val exp =
fn () =>
- if mayWrap andalso
- let
+ if let
open Control
in
!profile <> ProfileNone
andalso !profileIL = ProfileSource
andalso !profileRaise
end
- then enterLeave (exp, caseType,
- SourceInfo.function {name = ["raise"],
- region = region})
+ then case mayWrap of
+ NONE => exp
+ | SOME kind =>
+ enterLeave
+ (exp, caseType,
+ SourceInfo.function
+ {name = (concat ["<raise ", kind, ">"]) :: nest,
+ region = region})
else exp
in
Vector.concat
@@ -158,9 +163,9 @@
case noMatch of
Impossible => cases
| RaiseAgain =>
- raiseExn (fn e => Xexp.monoVar (e, Xtype.exn), false)
- | RaiseBind => raiseExn (fn _ => Xexp.bind, true)
- | RaiseMatch => raiseExn (fn _ => Xexp.match, true)
+ raiseExn (fn e => Xexp.monoVar (e, Xtype.exn), NONE)
+ | RaiseBind => raiseExn (fn _ => Xexp.bind, SOME "Bind")
+ | RaiseMatch => raiseExn (fn _ => Xexp.match, SOME "Match")
end
val examples = ref (fn () => Vector.new0 ())
fun matchCompile () =
@@ -730,7 +735,7 @@
val bodyType = et
val e =
Vector.foldr
- (vbs, e, fn ({exp, lay, pat, patRegion}, e) =>
+ (vbs, e, fn ({exp, lay, nest, pat, patRegion}, e) =>
let
fun patDec (p: NestedPat.t,
e: Xexp.t,
@@ -744,6 +749,7 @@
conTycon = conTycon,
kind = "declaration",
lay = lay,
+ nest = nest,
noMatch = Cexp.RaiseBind,
nonexhaustiveExnMatch = nonexhaustiveExnMatch,
nonexhaustiveMatch = if mayWarn
@@ -935,7 +941,7 @@
func = #1 (loopExp e1),
ty = ty}
end
- | Case {kind, lay, noMatch,
+ | Case {kind, lay, nest, noMatch,
nonexhaustiveExnMatch, nonexhaustiveMatch, redundantMatch,
region, rules, test, ...} =>
casee {caseType = ty,
@@ -946,6 +952,7 @@
conTycon = conTycon,
kind = kind,
lay = lay,
+ nest = nest,
noMatch = noMatch,
nonexhaustiveExnMatch = nonexhaustiveExnMatch,
nonexhaustiveMatch = nonexhaustiveMatch,
Modified: mlton/trunk/mlton/elaborate/elaborate-core.fun
===================================================================
--- mlton/trunk/mlton/elaborate/elaborate-core.fun 2007-07-22 15:51:14 UTC (rev 5786)
+++ mlton/trunk/mlton/elaborate/elaborate-core.fun 2007-07-25 02:58:05 UTC (rev 5787)
@@ -376,16 +376,28 @@
else ()
end
-fun approximate (l: Layout.t): Layout.t =
+fun approximateN (l: Layout.t, prefixMax, suffixMax): Layout.t =
let
val s = Layout.toString l
val n = String.size s
in
Layout.str
- (if n <= 60
- then s
- else concat [String.prefix (s, 35), " ... ", String.suffix (s, 25)])
+ (case suffixMax of
+ NONE =>
+ if n <= prefixMax
+ then s
+ else concat [String.prefix (s, prefixMax - 5), " ..."]
+ | SOME suffixMax =>
+ if n <= prefixMax + suffixMax
+ then s
+ else concat [String.prefix (s, prefixMax - 2),
+ " ... ",
+ String.suffix (s, suffixMax - 5)])
end
+fun approximate (l: Layout.t): Layout.t =
+ approximateN (l, 35, SOME 25)
+fun approximatePrefix (l: Layout.t): Layout.t =
+ approximateN (l, 15, NONE)
val elaboratePat:
unit
@@ -974,6 +986,7 @@
if not isBool then fetchExp else
Cexp.casee {kind = "",
lay = fn () => Layout.empty,
+ nest = [],
noMatch = Cexp.Impossible,
nonexhaustiveExnMatch = Control.Elaborate.DiagDI.Default,
nonexhaustiveMatch = Control.Elaborate.DiagEIW.Ignore,
@@ -995,6 +1008,7 @@
if not isBool then valueExp else
Cexp.casee {kind = "",
lay = fn () => Layout.empty,
+ nest = [],
noMatch = Cexp.Impossible,
nonexhaustiveExnMatch = Control.Elaborate.DiagDI.Default,
nonexhaustiveMatch = Control.Elaborate.DiagEIW.Ignore,
@@ -1869,9 +1883,22 @@
profileBody
andalso !Control.profileBranch,
fn () =>
- SourceInfo.function
- {name = "<branch>" :: nest,
- region = bodyRegion})
+ let
+ open Layout
+ val name =
+ concat ["<case ",
+ Layout.toString
+ (approximatePrefix
+ (seq
+ (separateRight
+ (Vector.toListMap
+ (args, Apat.layout), " ")))),
+ ">"]
+ in
+ SourceInfo.function
+ {name = name :: nest,
+ region = bodyRegion}
+ end)
val _ =
Option.app
(resultType, fn t =>
@@ -1941,6 +1968,7 @@
Cexp.casee
{kind = "function",
lay = lay,
+ nest = nest,
noMatch = Cexp.RaiseMatch,
nonexhaustiveExnMatch = nonexhaustiveExnMatch (),
nonexhaustiveMatch = nonexhaustiveMatch (),
@@ -2092,6 +2120,23 @@
val patRegion = Apat.region pat
val expRegion = Aexp.region exp
val exp = elabExp (exp, nest, Apat.getName pat)
+ val exp =
+ Cexp.enterLeave
+ (exp,
+ profileBody
+ andalso !Control.profileVal
+ andalso Cexp.isExpansive exp, fn () =>
+ let
+ val name =
+ concat ["<val ",
+ Layout.toString
+ (approximatePrefix
+ (Apat.layout pat)),
+ ">"]
+ in
+ SourceInfo.function {name = name :: nest,
+ region = expRegion}
+ end)
in
{exp = exp,
expRegion = expRegion,
@@ -2160,6 +2205,7 @@
Cexp.enterLeave
(Cexp.casee {kind = "function",
lay = lay,
+ nest = nest,
noMatch = Cexp.RaiseMatch,
nonexhaustiveExnMatch = nonexhaustiveExnMatch (),
nonexhaustiveMatch = nonexhaustiveMatch (),
@@ -2207,27 +2253,6 @@
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 = exp,
@@ -2266,6 +2291,7 @@
Vector.map (vbs, fn {exp, lay, pat, patRegion, ...} =>
{exp = exp,
lay = lay,
+ nest = nest,
pat = pat,
patRegion = patRegion})
(* According to page 28 of the Definition, we should
@@ -2357,6 +2383,7 @@
in
Cexp.casee {kind = "case",
lay = lay,
+ nest = nest,
noMatch = Cexp.RaiseMatch,
nonexhaustiveExnMatch = nonexhaustiveExnMatch (),
nonexhaustiveMatch = nonexhaustiveMatch (),
@@ -2462,7 +2489,7 @@
{name = name :: nest,
region = Aexp.region e})
in
- (wrap (b, b', "<true>"), wrap (c, c', "<false>"))
+ (wrap (b, b', "<case true>"), wrap (c, c', "<case false>"))
end
in
Cexp.iff (a', b', c')
@@ -2556,6 +2583,7 @@
Cexp.casee
{kind = "",
lay = fn _ => Layout.empty,
+ nest = [],
noMatch = Cexp.Impossible,
nonexhaustiveExnMatch = Control.Elaborate.DiagDI.Default,
nonexhaustiveMatch = Control.Elaborate.DiagEIW.Ignore,
@@ -3042,6 +3070,7 @@
val body =
Cexp.casee {kind = kind,
lay = lay,
+ nest = nest,
noMatch = noMatch,
nonexhaustiveExnMatch = nonexhaustiveExnMatch (),
nonexhaustiveMatch = nonexhaustiveMatch (),
@@ -3073,37 +3102,48 @@
approximate
(seq [Apat.layout pat, str " => ", Aexp.layout exp])
end
- val (p, _) =
+ val patOrig = pat
+ val (pat, _) =
elaboratePat () (pat, E, {bind = true, isRvb = false},
preError)
val _ =
unify
- (Cpat.ty p, argType, preError, fn (l1, l2) =>
- (Apat.region pat,
+ (Cpat.ty pat, argType, preError, fn (l1, l2) =>
+ (Apat.region patOrig,
str "rule patterns disagree",
align [seq [str "pattern: ", l1],
seq [str "previous: ", l2],
seq [str "in: ", lay ()]]))
- val e = elabExp (exp, nest, NONE)
+ val expOrig = exp
+ val exp = elabExp (exp, nest, NONE)
val _ =
unify
- (Cexp.ty e, resultType, preError, fn (l1, l2) =>
- (Aexp.region exp,
+ (Cexp.ty exp, resultType, preError, fn (l1, l2) =>
+ (Aexp.region expOrig,
str "rule results disagree",
align [seq [str "result: ", l1],
seq [str "previous: ", l2],
seq [str "in: ", lay ()]]))
- val e =
+ val exp =
Cexp.enterLeave
- (e,
- profileBody andalso !Control.profileBranch,
+ (exp,
+ profileBody andalso !Control.profileBranch,
fn () =>
- SourceInfo.function {name = "<branch>" :: nest,
- region = Aexp.region exp})
+ let
+ val name =
+ concat ["<case ",
+ Layout.toString
+ (approximatePrefix
+ (Apat.layout patOrig)),
+ ">"]
+ in
+ SourceInfo.function {name = name :: nest,
+ region = Aexp.region expOrig}
+ end)
in
- {exp = e,
+ {exp = exp,
lay = SOME lay,
- pat = p}
+ pat = pat}
end))
in
{argType = argType,
Modified: mlton/trunk/mlton/elaborate/elaborate-env.fun
===================================================================
--- mlton/trunk/mlton/elaborate/elaborate-env.fun 2007-07-22 15:51:14 UTC (rev 5786)
+++ mlton/trunk/mlton/elaborate/elaborate-env.fun 2007-07-25 02:58:05 UTC (rev 5787)
@@ -2917,6 +2917,7 @@
vbs = (Vector.new1
{exp = e,
lay = fn _ => Layout.empty,
+ nest = [],
pat = Pat.var (x, strType),
patRegion = region})})
in
More information about the MLton-commit
mailing list