[MLton-devel] cvs commit: profiling C functions
Stephen Weeks
sweeks@users.sourceforge.net
Sun, 05 Jan 2003 17:17:09 -0800
sweeks 03/01/05 17:17:09
Modified: mlton/backend profile.fun
mlton/ssa source-info.fun source-info.sig
runtime gc.c
Log:
Profiling now correctly handles C functions. This is done by
explicitly setting gcState.currentSources before calling a C function
and, in the case of time profiling, unsetting gcState.currentSources
upon CReturn. The time profiling signal handler now checks if
currentSources is set, and if so, uses it. Otherwise, it computes
currentSources using the profile labels.
Revision Changes Path
1.9 +128 -104 mlton/mlton/backend/profile.fun
Index: profile.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/profile.fun,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- profile.fun 4 Jan 2003 02:00:35 -0000 1.8
+++ profile.fun 6 Jan 2003 01:17:07 -0000 1.9
@@ -29,6 +29,14 @@
if List.exists (!successors, fn n => equals (n, to))
then ()
else List.push (successors, to)
+
+ val call =
+ Trace.trace ("InfoNode.call",
+ fn {from, to} =>
+ Layout.record [("from", layout from),
+ ("to", layout to)],
+ Unit.layout)
+ call
end
structure FuncInfo =
@@ -113,7 +121,7 @@
val unknownInfoNode = sourceInfoNode SourceInfo.unknown
val unknownIndex = InfoNode.index unknownInfoNode
(* gc must be 1 which == SOURCES_INDEX_GC from gc.h *)
- val gcIndex = sourceInfoIndex SourceInfo.gc
+ val _ = sourceInfoIndex SourceInfo.gc
val mainIndex = sourceInfoIndex SourceInfo.main
local
val table: {hash: word,
@@ -166,13 +174,6 @@
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
- | SOME (InfoNode.T {index, ...}) =>
- not (SourceInfo.isBasis si)
- orelse index = mainIndex
- orelse index = unknownIndex
local
val {get: Func.t -> FuncInfo.t, ...} =
Property.get (Func.plist, Property.initFun (fn _ => FuncInfo.new ()))
@@ -215,15 +216,22 @@
let
val {args, blocks, name, raises, returns, start} = Function.dest f
val FuncInfo.T {enters, tailCalls, ...} = funcInfo name
- fun enter (si: SourceInfo.t, ps: Push.t list) =
+ fun enter (ps: Push.t list, si: SourceInfo.t): Push.t list * bool =
let
val node = sourceInfoNode si
- val _ =
- case firstEnter ps of
- NONE => List.push (enters, node)
- | SOME node' => InfoNode.call {from = node', to = node}
+ fun yes () = (Push.Enter node :: ps, true)
in
- Push.Enter node :: ps
+ case firstEnter ps of
+ NONE => (List.push (enters, node)
+ ; yes ())
+ | SOME (node' as InfoNode.T {index, ...}) =>
+ if not (SourceInfo.equals (si, SourceInfo.unknown))
+ andalso (not (SourceInfo.isBasis si)
+ orelse index = mainIndex
+ orelse index = unknownIndex)
+ then (InfoNode.call {from = node', to = node}
+ ; yes ())
+ else (Push.Skip si :: ps, false)
end
val _ =
Vector.foreach
@@ -233,11 +241,15 @@
val blocks = ref []
datatype z = datatype Statement.t
datatype z = datatype ProfileExp.t
+ fun setCurrentSource (n: int): Statement.t =
+ Statement.Move
+ {dst = Operand.Runtime Runtime.GCField.CurrentSource,
+ src = Operand.word (Word.fromInt n)}
fun backward {args,
kind,
label,
needsCurrentSource,
- sourceSeq,
+ sourceSeq: int list,
statements: Statement.t list,
transfer: Transfer.t}: unit =
let
@@ -266,14 +278,8 @@
| 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
+ then (setCurrentSource
+ (sourceSeqIndex sourceSeq) :: ss)
else ss
in
(false, false, sourceSeq', ss)
@@ -332,7 +338,34 @@
List.layout Statement.layout statements],
Unit.layout)
backward
- fun goto (l: Label.t, sourceSeq: Push.t list): unit =
+ fun profileEnter (sourceSeq: int list,
+ transfer: Transfer.t): Transfer.t =
+ let
+ val func = CFunction.profileEnter
+ val newLabel = Label.newNoname ()
+ val index = sourceSeqIndex sourceSeq
+ val statements =
+ if profileTime
+ then Vector.new1 (profileLabelIndex index)
+ else Vector.new0 ()
+ val _ =
+ List.push
+ (blocks,
+ Block.T {args = Vector.new0 (),
+ kind = Kind.CReturn {func = func},
+ label = newLabel,
+ statements = statements,
+ transfer = transfer})
+ in
+ Transfer.CCall
+ {args = Vector.new1 (Operand.word (Word.fromInt index)),
+ func = func,
+ return = SOME newLabel}
+ end
+ fun needsCurrentSource (f: CFunction.t): bool =
+ (profileAlloc andalso CFunction.needsCurrentSource f)
+ orelse profileTime
+ fun goto (l: Label.t, pushes: Push.t list): unit =
let
val _ =
if not debug
@@ -344,7 +377,7 @@
outputl (seq [str "goto (",
Label.layout l,
str ", ",
- List.layout Push.layout sourceSeq,
+ List.layout Push.layout pushes,
str ")"],
Out.error)
end
@@ -362,10 +395,10 @@
then List.push (frameProfileIndices,
(label,
sourceSeqIndex
- (Push.toSources sourceSeq)))
+ (Push.toSources pushes)))
else ()
fun maybeSplit {args, bytesAllocated, kind, label,
- sourceSeq: Push.t list,
+ pushes: Push.t list,
statements} =
if profileAlloc andalso bytesAllocated > 0
then
@@ -379,7 +412,7 @@
(Word.fromInt bytesAllocated))),
func = func,
return = SOME newLabel}
- val sourceSeq = Push.toSources sourceSeq
+ val sourceSeq = Push.toSources pushes
val _ =
backward {args = args,
kind = kind,
@@ -400,18 +433,26 @@
kind = kind,
label = label,
statements = statements}
- val {args, bytesAllocated, kind, label, sourceSeq,
+ val statements = Vector.toList statements
+ val statements =
+ if (case kind of
+ Kind.CReturn {func, ...} =>
+ needsCurrentSource func
+ | _ => false)
+ then setCurrentSource ~1 :: statements
+ else statements
+ val {args, bytesAllocated, kind, label, pushes,
statements} =
- Vector.fold
+ List.fold
(statements,
{args = args,
bytesAllocated = 0,
kind = kind,
label = label,
- sourceSeq = sourceSeq,
+ pushes = pushes,
statements = []},
fn (s, {args, bytesAllocated, kind, label,
- sourceSeq: Push.t list,
+ pushes: Push.t list,
statements}) =>
(if not debug
then ()
@@ -420,7 +461,7 @@
open Layout
in
outputl
- (seq [List.layout Push.layout sourceSeq,
+ (seq [List.layout Push.layout pushes,
str " ",
Statement.layout s],
Out.error)
@@ -432,7 +473,7 @@
bytesAllocated = bytesAllocated + size,
kind = kind,
label = label,
- sourceSeq = sourceSeq,
+ pushes = pushes,
statements = s :: statements}
| Profile ps =>
let
@@ -443,22 +484,17 @@
bytesAllocated = bytesAllocated,
kind = kind,
label = label,
- sourceSeq = sourceSeq,
+ pushes = pushes,
statements = statements}
datatype z = datatype ProfileExp.t
- val (keep, sourceSeq) =
+ val (pushes, keep) =
case ps of
- Enter si =>
- if shouldPush (si, sourceSeq)
- then (true,
- enter (si, sourceSeq))
- else (false,
- Push.Skip si :: sourceSeq)
+ Enter si => enter (pushes, si)
| Leave si =>
- (case sourceSeq of
+ (case pushes of
[] =>
Error.bug "unmatched Leave"
- | p :: sourceSeq' =>
+ | p :: pushes' =>
let
val (keep, isOk) =
case p of
@@ -472,7 +508,7 @@
SourceInfo.equals (si, si'))
in
if isOk
- then (keep, sourceSeq')
+ then (pushes', keep)
else Error.bug "mismatched Leave"
end)
val statements =
@@ -484,7 +520,7 @@
bytesAllocated = bytesAllocated,
kind = kind,
label = label,
- sourceSeq = sourceSeq,
+ pushes = pushes,
statements = statements}
end
| _ =>
@@ -492,81 +528,69 @@
bytesAllocated = bytesAllocated,
kind = kind,
label = label,
- sourceSeq = sourceSeq,
+ pushes = pushes,
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
- Transfer.Call {func, return, ...} =>
- let
- val fi as FuncInfo.T {callers, ...} =
- funcInfo func
- in
- case return of
- Return.NonTail _ =>
- Option.app
- (firstEnter sourceSeq,
- fn n => List.push (callers, n))
- | _ =>
- List.push (tailCalls, fi)
- end
- | _ => ()
+ (transfer, fn l => goto (l, pushes))
val {args, kind, label, statements, ...} =
maybeSplit {args = args,
bytesAllocated = bytesAllocated,
kind = kind,
label = label,
- sourceSeq = sourceSeq,
+ pushes = pushes,
statements = statements}
- val sourceSeq = Push.toSources sourceSeq
- val transfer =
- if profileStack
- andalso
- (case transfer of
- Transfer.Call {return = Return.NonTail _, ...} =>
- true
- | _ => false)
- then
+ val sourceSeq = Push.toSources pushes
+ val (statements, transfer) =
+ case transfer of
+ Transfer.CCall {func, ...} =>
+ if needsCurrentSource func
+ then
+ let
+ val si =
+ SourceInfo.fromString
+ (concat ["<",
+ CFunction.name func,
+ ">"])
+ val set =
+ setCurrentSource
+ (sourceSeqIndex
+ (Push.toSources
+ (#1 (enter (pushes, si)))))
+ in
+ (set :: statements, transfer)
+ end
+ else (statements, transfer)
+ | Transfer.Call {func, return, ...} =>
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})
+ val fi as FuncInfo.T {callers, ...} =
+ funcInfo func
in
- Transfer.CCall
- {args = (Vector.new1
- (Operand.word
- (Word.fromInt index))),
- func = func,
- return = SOME newLabel}
+ case return of
+ Return.NonTail _ =>
+ let
+ val _ =
+ Option.app
+ (firstEnter pushes,
+ fn n => List.push (callers, n))
+ in
+ (statements,
+ if profileStack
+ then (profileEnter
+ (sourceSeq, transfer))
+ else transfer)
+ end
+ | _ =>
+ (List.push (tailCalls, fi)
+ ; (statements, transfer))
end
- else transfer
+ | _ => (statements, transfer)
in
backward {args = args,
kind = kind,
label = label,
- needsCurrentSource = ncs,
+ needsCurrentSource = false,
sourceSeq = sourceSeq,
statements = statements,
transfer = transfer}
1.5 +2 -0 mlton/mlton/ssa/source-info.fun
Index: source-info.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/source-info.fun,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- source-info.fun 2 Jan 2003 17:45:21 -0000 1.4
+++ source-info.fun 6 Jan 2003 01:17:08 -0000 1.5
@@ -9,6 +9,8 @@
val equals: t * t -> bool = op =
+val fromString = fn s => s
+
val hash = String.hash
val gc = "<gc>"
1.5 +1 -0 mlton/mlton/ssa/source-info.sig
Index: source-info.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/source-info.sig,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- source-info.sig 2 Jan 2003 17:45:21 -0000 1.4
+++ source-info.sig 6 Jan 2003 01:17:08 -0000 1.5
@@ -14,6 +14,7 @@
val equals: t * t -> bool
val gc: t
val fromRegion: Region.t -> t
+ val fromString: string -> t
val hash: t -> word
val isBasis: t -> bool
val layout: t -> Layout.t
1.113 +8 -4 mlton/runtime/gc.c
Index: gc.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/gc.c,v
retrieving revision 1.112
retrieving revision 1.113
diff -u -r1.112 -r1.113
--- gc.c 4 Jan 2003 02:00:39 -0000 1.112
+++ gc.c 6 Jan 2003 01:17:08 -0000 1.113
@@ -62,6 +62,7 @@
BOGUS_EXN_STACK = 0xFFFFFFFF,
BOGUS_POINTER = 0x1,
COPY_CHUNK_SIZE = 0x800000,
+ CURRENT_SOURCE_UNDEFINED = 0xFFFFFFFF,
DEBUG = FALSE,
DEBUG_ARRAY = FALSE,
DEBUG_CARD_MARKING = FALSE,
@@ -2921,10 +2922,12 @@
#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;
+ if (CURRENT_SOURCE_UNDEFINED == s->currentSource) {
+ 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);
}
@@ -2966,6 +2969,7 @@
uint sourceSeqsIndex;
s->profile = GC_profileNew (s);
+ s->currentSource = CURRENT_SOURCE_UNDEFINED;
/* Sort sourceLabels by address. */
qsort (s->sourceLabels, s->sourceLabelsSize, sizeof(*s->sourceLabels),
compareProfileLabels);
-------------------------------------------------------
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