[MLton-devel] cvs commit: mlprof now shows call-stack graph
Stephen Weeks
sweeks@users.sourceforge.net
Fri, 03 Jan 2003 18:00:42 -0800
sweeks 03/01/03 18:00:42
Modified: include codegen.h
mlprof main.sml
mlton/backend backend.fun machine.fun machine.sig
profile.fun profile.sig
mlton/codegen/c-codegen c-codegen.fun
runtime gc.c gc.h
Log:
Added the call-stack graph to profile info and to what is displayed by
@MLton show-prof. mlprof uses this to create the call graph (in .dot
format) with the the profiling data. Right now, mlprof only displays
nodes above the threshold, but I'll probably add an option to display
the whole graph.
I refer to it as the call-stack graph rather than the call graph
because it describes the set of possible call stacks, and differs from
the call graph in how tail calls are handled. For example if A
nontail calls B and B tail calls C, then the call-stack graph has
edges A->B A->C, while the call-graph would have A->B->C.
I removed a lot of old cruft from mlprof.
Revision Changes Path
1.4 +1 -0 mlton/include/codegen.h
Index: codegen.h
===================================================================
RCS file: /cvsroot/mlton/mlton/include/codegen.h,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- codegen.h 3 Jan 2003 06:14:14 -0000 1.3
+++ codegen.h 4 Jan 2003 02:00:20 -0000 1.4
@@ -60,6 +60,7 @@
gcState.sourcesSize = cardof(sources); \
gcState.sourceSeqs = sourceSeqs; \
gcState.sourceSeqsSize = cardof(sourceSeqs); \
+ gcState.sourceSuccessors = sourceSuccessors; \
gcState.stringInits = stringInits; \
MLton_init (argc, argv, &gcState); \
1.22 +134 -319 mlton/mlprof/main.sml
Index: main.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlprof/main.sml,v
retrieving revision 1.21
retrieving revision 1.22
diff -u -r1.21 -r1.22
--- main.sml 2 Jan 2003 17:45:09 -0000 1.21
+++ main.sml 4 Jan 2003 02:00:24 -0000 1.22
@@ -11,116 +11,51 @@
type int = Int.t
type word = Word.t
-val busy = ref false : bool ref
-val color = ref false
-val depth: int ref = ref 0
val raw = ref false
-val source = ref true
-val static = ref false (* include static C functions *)
val thresh: int ref = ref 0
val die = Process.fail
-structure Regexp =
-struct
- open Regexp
-
- val eol = seq [star (oneOf "\t "), string "\n"]
- val hexDigit = isChar Char.isHexDigit
- val hexDigits = oneOrMore hexDigit
- val identifier = seq [isChar Char.isAlpha,
- star (isChar (fn #"_" => true
- | #"'" => true
- | c => Char.isAlphaNum c))]
-end
-
-structure StringMap:
-sig
- type 'a t
-
- val foldi: 'a t * 'b * (string * 'a * 'b -> 'b) -> 'b
- val layout: ('a -> Layout.t) -> 'a t -> Layout.t
- val lookup: 'a t * string -> 'a
- val lookupOrInsert: 'a t * string * (unit -> 'a) -> 'a
- val new: unit -> 'a t
-end =
-struct
- datatype 'a t = T of (word * String.t * 'a) HashSet.t
-
- fun layout lay (T h)
- = HashSet.layout (fn (_, s, a) => Layout.tuple [String.layout s, lay a]) h
-
- fun new () = T (HashSet.new {hash = #1})
-
- fun foldi (T t, b, f)
- = HashSet.fold (t, b, fn ((_, s, a), ac) => f (s, a, ac))
-
- fun lookupOrInsert (T t, s, f)
- = let
- val w = String.hash s
- in
- #3 (HashSet.lookupOrInsert
- (t, w,
- fn (w', s', _) => w = w' andalso s = s',
- fn () => (w, s, f ())))
- end
-
- fun peek (T t, s)
- = let
- val w = String.hash s
- in
- Option.map
- (HashSet.peek (t, w, fn (w', s', _) => w = w' andalso s = s'),
- #3)
- end
-
- fun contains z = isSome (peek z)
- fun lookup z = valOf (peek z)
-end
-
-structure ProfileInfo =
-struct
- datatype 'a t = T of {data: 'a,
- minor: 'a t} list
-
- val empty = T []
-
- local
- open Layout
- in
- fun layout lay (T l)
- = List.layout
- (fn {data, minor} => seq [str "{",
- lay data,
- layout lay minor,
- str "}"])
- l
- end
-end
-
structure AFile =
struct
datatype t = T of {magic: word,
+ name: string,
+ sourceSuccessors: int vector vector,
sources: string vector}
- fun layout (T {magic, sources}) =
- Layout.record [("magic", Word.layout magic),
- ("sources", Vector.layout String.layout sources)]
+ fun layout (T {magic, name, sourceSuccessors, sources}) =
+ Layout.record [("name", String.layout name),
+ ("magic", Word.layout magic),
+ ("sources", Vector.layout String.layout sources),
+ ("sourceSuccessors",
+ Vector.layout (Vector.layout Int.layout)
+ sourceSuccessors)]
fun new {afile: File.t}: t =
Process.callWithIn
(afile, ["@MLton", "show-prof"],
fn ins =>
let
- val magic =
- valOf (Word.fromString (In.inputLine ins))
- fun loop ac =
- case In.inputLine ins of
- "" => Vector.fromListRev ac
- | s => loop (String.dropSuffix (s, 1) :: ac)
- val sources = loop []
+ fun line () = In.inputLine ins
+ val magic = valOf (Word.fromString (line ()))
+ val sourcesLength = valOf (Int.fromString (line ()))
+ val sources =
+ Vector.tabulate (sourcesLength, fn _ =>
+ String.dropSuffix (line (), 1))
+ val sourceSuccessors =
+ Vector.tabulate
+ (sourcesLength, fn _ =>
+ Vector.fromListMap
+ (String.tokens (line (), Char.isSpace), fn s =>
+ valOf (Int.fromString s)))
+ val _ =
+ case line () of
+ "" => ()
+ | _ => Error.bug "mlmon file has extra line"
in
T {magic = magic,
+ name = afile,
+ sourceSuccessors = sourceSuccessors,
sources = sources}
end)
@@ -216,215 +151,109 @@
total = IntInf.+ (t, t')}
end
-fun attribute (AFile.T {magic = m, sources},
- ProfFile.T {counts, kind, magic = m', ...})
- : {name: string,
- ticks: IntInf.t} ProfileInfo.t option =
- if m <> m'
- then NONE
- else
- SOME
- (ProfileInfo.T
- (Vector.fold2 (counts, sources, [], fn (c, s, ac) =>
- if c = IntInf.zero
- then ac
- else {data = {name = s, ticks = c},
- minor = ProfileInfo.empty} :: ac)))
-
-val replaceLine =
- Promise.lazy
- (fn () =>
- let
- open Regexp
- val beforeColor = Save.new ()
- val label = Save.new ()
- val afterColor = Save.new ()
- val nodeLine =
- seq [save (seq [anys, string "fontcolor = ", dquote], beforeColor),
- star (notOneOf String.dquote),
- save (seq [dquote,
- anys,
- string "label = ", dquote,
- save (star (notOneOf " \\"), label),
- oneOf " \\",
- anys,
- string "\n"],
- afterColor)]
- val c = compileNFA nodeLine
- val _ = if true
- then ()
- else Compiled.layoutDotToFile (c, "/tmp/z.dot")
- in
- fn (l, color) =>
- case Compiled.matchAll (c, l) of
- NONE => l
- | SOME m =>
- let
- val {lookup, ...} = Match.stringFuns m
- in
- concat [lookup beforeColor,
- color (lookup label),
- lookup afterColor]
- end
- end)
-
-fun display (ProfFile.T {kind, total, ...},
- counts: {name: string, ticks: IntInf.t} ProfileInfo.t,
- baseName: string,
- depth: int) =
+structure Graph = DirectedGraph
+local
+ open Graph
+in
+ structure Node = Node
+end
+
+fun display (AFile.T {name = aname, sources, sourceSuccessors, ...},
+ ProfFile.T {counts, kind, total, ...}): unit =
let
+ val {get = nodeOptions: Node.t -> Dot.NodeOption.t list ref, ...} =
+ Property.get (Node.plist, Property.initFun (fn _ => ref []))
+ val graph = Graph.new ()
val ticksPerSecond = 100.0
val thresh = Real.fromInt (!thresh)
- datatype t = T of {name: string,
- ticks: IntInf.t,
- row: string list,
- minor: t} array
- val mult = if !raw then 2 else 1
- fun doit (info as ProfileInfo.T profileInfo,
- n: int,
- dotFile: File.t,
- stuffing: string list,
- totals: real list) =
- let
- val totalInt = total
- val total = Real.fromIntInf totalInt
- val _ =
- if n = 0
- then
- print
- (concat
- (case kind of
- Kind.Alloc =>
- [IntInf.toCommaString totalInt,
- " bytes allocated\n"]
- | Kind.Time =>
- [Real.format (total / ticksPerSecond,
- Real.Format.fix (SOME 2)),
- " seconds of CPU time\n"]))
- else ()
- val space = String.make (5 * n, #" ")
- val profileInfo =
- List.fold
- (profileInfo, [], fn ({data = {name, ticks}, minor}, ac) =>
+ val totalReal = Real.fromIntInf total
+ val counts =
+ Vector.mapi
+ (counts, fn (i, ticks) =>
+ let
+ val rticks = Real.fromIntInf ticks
+ val per = 100.0 * rticks / totalReal
+ in
+ if per < thresh
+ then NONE
+ else
let
- val rticks = Real.fromIntInf ticks
- fun per total = 100.0 * rticks / total
+ val name = Vector.sub (sources, i)
+ val node = Graph.newNode graph
+ val per =
+ (concat [Real.format (per, Real.Format.fix (SOME 2)),
+ "%"])
+ :: (if !raw
+ then
+ [concat
+ (case kind of
+ Kind.Alloc =>
+ ["(", IntInf.toCommaString ticks, ")"]
+ | Kind.Time =>
+ ["(",
+ Real.format
+ (rticks / ticksPerSecond,
+ Real.Format.fix (SOME 2)),
+ "s)"])]
+ else [])
+ val nodeIndex =
+ List.push
+ (nodeOptions node,
+ Dot.NodeOption.Label
+ [(name, Dot.Center),
+ (concat (List.separate (per, " ")), Dot.Center)])
in
- if per total < thresh
- then ac
- else
- let
- val per =
- fn total =>
- let
- val a =
- concat [Real.format (per total,
- Real.Format.fix (SOME 2)),
- "%"]
- in
- if !raw
- then
- [a,
- concat
- (case kind of
- Kind.Alloc =>
- ["(",
- IntInf.toCommaString ticks,
- ")"]
- | Kind.Time =>
- ["(",
- Real.format
- (rticks / ticksPerSecond,
- Real.Format.fix (SOME 2)),
- "s)"])]
- else [a]
- end
- in
- {name = name,
- ticks = ticks,
- row = (List.concat
- [[concat [space, name]],
- stuffing,
- per total,
- if !busy
- then List.concatMap (totals, per)
- else (List.duplicate
- (List.length totals * mult,
- fn () => ""))]),
- minor = if n < depth
- then doit (minor, n + 1,
- concat [baseName, ".",
- name, ".cfg.dot"],
- if !raw
- then tl (tl stuffing)
- else tl stuffing,
- total :: totals)
- else T (Array.new0 ())}
- :: ac
- end
- end)
- val a = Array.fromList profileInfo
- val _ =
- QuickSort.sortArray
- (a, fn ({ticks = t1, ...}, {ticks = t2, ...}) =>
- IntInf.>= (t1, t2))
- (* Colorize. *)
- val _ =
- if n > 1 orelse not(!color) orelse 0 = Array.length a
- then ()
- else
- let
- val ticks: real =
- Real.fromIntInf (#ticks (Array.sub (a, 0)))
- fun thresh r = Real.toIntInf (Real.* (ticks, r))
- val thresh1 = thresh (2.0 / 3.0)
- val thresh2 = thresh (1.0 / 3.0)
- datatype z = datatype DotColor.t
- fun color l =
- DotColor.toString
- (case Array.peek (a, fn {name, ...} =>
- String.equals (l, name)) of
- NONE => Black
- | SOME {ticks, ...} =>
- if IntInf.>= (ticks, thresh1)
- then Red1
- else if IntInf.>= (ticks, thresh2)
- then Orange2
- else Yellow3)
- in
- if not (File.doesExist dotFile)
- then ()
- else
- let
- val replaceLine = replaceLine ()
- val lines = File.lines dotFile
- in
- File.withOut
- (dotFile, fn out =>
- List.foreach
- (lines, fn l =>
- Out.output (out, replaceLine (l, color))))
- end
- end
- in T a
- end
- fun toList (T a, ac) =
- Array.foldr (a, ac, fn ({row, minor, ...}, ac) =>
- row :: toList (minor, ac))
- val rows = toList (doit (counts, 0,
- concat [baseName, ".call-graph.dot"],
- List.duplicate (depth * mult, fn () => ""),
- []),
- [])
+ SOME {node = node,
+ row = name :: per,
+ ticks = ticks}
+ end
+ end)
+ val _ =
+ Vector.mapi
+ (counts,
+ fn (i, z) =>
+ case z of
+ NONE => ()
+ | SOME {node = from, ...} =>
+ Vector.foreach
+ (Vector.sub (sourceSuccessors, i), fn j =>
+ case Vector.sub (counts, j) of
+ NONE => ()
+ | SOME {node = to, ...} =>
+ (Graph.addEdge (graph, {from = from, to = to})
+ ; ())))
+ val _ =
+ File.withOut
+ (concat [aname, ".dot"], fn out =>
+ Layout.output
+ (Graph.layoutDot (graph,
+ fn _ => {edgeOptions = fn _ => [],
+ nodeOptions = ! o nodeOptions,
+ options = [],
+ title = "call-stack graph"}),
+ out))
+ val counts = Vector.keepAllMap (counts, fn z => z)
+ val counts =
+ QuickSort.sortVector
+ (counts, fn ({ticks = t1, ...}, {ticks = t2, ...}) =>
+ IntInf.>= (t1, t2))
+ val _ =
+ print
+ (concat
+ (case kind of
+ Kind.Alloc => [IntInf.toCommaString total, " bytes allocated\n"]
+ | Kind.Time =>
+ [Real.format (totalReal / ticksPerSecond,
+ Real.Format.fix (SOME 2)),
+ " seconds of CPU time\n"]))
val _ =
let
open Justify
in
outputTable
- (table {justs = (Left
- :: (List.duplicate ((depth + 1) * mult,
- fn () => Right))),
- rows = rows},
+ (table {justs = Left :: List.duplicate (if !raw then 2 else 1,
+ fn () => Right),
+ rows = Vector.toListMap (counts, #row)},
Out.standard)
end
in
@@ -436,20 +265,8 @@
open Popt
in
List.map
- ([(Normal, "busy", "{false|true}", "show all percentages",
- boolRef busy),
- (Normal, "color", " {false|true}", "color .dot files",
- boolRef color),
- (Expert, "depth", " {0|1|2}", "depth of detail",
- Int (fn i => if i < 0 orelse i > 2
- then usage "invalid depth"
- else depth := i)),
- (Normal, "raw", " {false|true}", "show raw counts",
+ ([(Normal, "raw", " {false|true}", "show raw counts",
boolRef raw),
- (Expert, "source", " {true|false}", "report info at source level",
- boolRef source),
- (Normal, "static", " {false|true}", "show static C functions",
- boolRef static),
(Normal, "thresh", " {0|1|...|100}", "only show counts above threshold",
Int (fn i => if i < 0 orelse i > 100
then usage "invalid -thresh"
@@ -472,10 +289,6 @@
Result.No msg => usage msg
| Result.Yes (afile::mlmonfile::mlmonfiles) =>
let
- val _ =
- if !source andalso !depth > 0
- then die "cannot report source info with depth > 0"
- else ()
val aInfo = AFile.new {afile = afile}
val _ =
if true
@@ -492,18 +305,20 @@
if true
then ()
else (print "ProfFile:\n"
- ; Layout.outputl (ProfFile.layout profFile, Out.standard))
+ ; Layout.outputl (ProfFile.layout profFile,
+ Out.standard))
val _ =
- if !depth = 2
- andalso ProfFile.kind profFile = Kind.Alloc
- then usage "-depth 2 is meaningless with allocation profiling"
- else ()
- val info =
- case attribute (aInfo, profFile) of
- NONE => die (concat [afile, " is incompatible with ",
- mlmonfile])
- | SOME z => z
- val _ = display (profFile, info, afile, !depth)
+ let
+ val AFile.T {magic = m, sources, ...} = aInfo
+ val ProfFile.T {magic = m', ...} = profFile
+ in
+ if m <> m'
+ then
+ die (concat [afile, " is incompatible with ",
+ mlmonfile])
+ else ()
+ end
+ val _ = display (aInfo, profFile)
in
()
end
1.46 +24 -17 mlton/mlton/backend/backend.fun
Index: backend.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/backend.fun,v
retrieving revision 1.45
retrieving revision 1.46
diff -u -r1.45 -r1.46
--- backend.fun 3 Jan 2003 06:14:14 -0000 1.45
+++ backend.fun 4 Jan 2003 02:00:27 -0000 1.46
@@ -153,7 +153,7 @@
val program = pass ("insertSignalChecks", SignalCheck.insert, program)
val program = pass ("implementHandlers", ImplementHandlers.doit, program)
val {frameProfileIndices, labels = profileLabels, program, sources,
- sourceSeqs} =
+ sourceSeqs, sourceSuccessors} =
Control.passTypeCheck
{display = Control.Layouts (fn ({program, ...}, output) =>
Rssa.Program.layouts (program, output)),
@@ -163,19 +163,22 @@
thunk = fn () => Profile.profile program,
typeCheck = R.Program.typeCheck o #program}
val _ = R.Program.checkHandlers program
+ val profileStack =
+ !Control.profile <> Control.ProfileNone
+ andalso !Control.profileStack
val frameProfileIndex =
- if !Control.profile = Control.ProfileNone
- then fn _ => 0
- else
- let
- val {get, set, ...} =
- Property.getSetOnce
- (Label.plist,
- Property.initRaise ("frameProfileIndex", Label.layout))
- val _ = Vector.foreach (frameProfileIndices, set)
- in
- get
- end
+ if profileStack
+ then
+ let
+ val {get, set, ...} =
+ Property.getSetOnce
+ (Label.plist,
+ Property.initRaise ("frameProfileIndex", Label.layout))
+ val _ = Vector.foreach (frameProfileIndices, set)
+ in
+ get
+ end
+ else fn _ => 0
val _ =
let
open Control
@@ -253,15 +256,18 @@
offsets: int list,
size: int}: int =
let
- val profileIndex = frameProfileIndex label
val foi = frameOffsetsIndex (IntSet.fromList offsets)
+ val profileIndex = frameProfileIndex label
fun new () =
let
val _ =
List.push (frameLayouts,
{frameOffsetsIndex = foi,
size = size})
- val _ = List.push (frameSources, profileIndex)
+ val _ =
+ if profileStack
+ then List.push (frameSources, profileIndex)
+ else ()
in
Counter.next frameLayoutsCounter
end
@@ -1056,8 +1062,9 @@
val profileInfo =
ProfileInfo.T {frameSources = frameSources,
labels = profileLabels,
- sources = sources,
- sourceSeqs = sourceSeqs}
+ sourceSeqs = sourceSeqs,
+ sourceSuccessors = sourceSuccessors,
+ sources = sources}
in
Machine.Program.T
{chunks = chunks,
1.38 +59 -35 mlton/mlton/backend/machine.fun
Index: machine.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/machine.fun,v
retrieving revision 1.37
retrieving revision 1.38
diff -u -r1.37 -r1.38
--- machine.fun 2 Jan 2003 17:45:14 -0000 1.37
+++ machine.fun 4 Jan 2003 02:00:29 -0000 1.38
@@ -628,10 +628,55 @@
labels: {label: ProfileLabel.t,
sourceSeqsIndex: int} vector,
sourceSeqs: int vector vector,
+ sourceSuccessors: int vector,
sources: SourceInfo.t vector}
fun clear (T {labels, ...}) =
Vector.foreach (labels, ProfileLabel.clear o #label)
+
+ fun layout (T {frameSources, labels, sourceSeqs, sourceSuccessors,
+ sources}) =
+ Layout.record
+ [("frameSources", Vector.layout Int.layout frameSources),
+ ("labels",
+ Vector.layout (fn {label, sourceSeqsIndex} =>
+ Layout.record
+ [("label", ProfileLabel.layout label),
+ ("sourceSeqsIndex",
+ Int.layout sourceSeqsIndex)])
+ labels),
+ ("sourceSeqs", Vector.layout (Vector.layout Int.layout) sourceSeqs),
+ ("sources", Vector.layout SourceInfo.layout sources)]
+
+ fun layouts (pi, output) = output (layout pi)
+
+ fun isOK (T {frameSources,
+ labels,
+ sourceSeqs,
+ sourceSuccessors,
+ sources}): bool =
+ let
+ val sourceSeqsLength = Vector.length sourceSeqs
+ val sourcesLength = Vector.length sources
+ in
+ !Control.profile = Control.ProfileNone
+ orelse
+ (true
+ andalso (Vector.forall
+ (frameSources, fn i =>
+ 0 <= i andalso i < sourceSeqsLength))
+ andalso (Vector.forall
+ (labels, fn {sourceSeqsIndex = i, ...} =>
+ 0 <= i andalso i < sourceSeqsLength)))
+ andalso (Vector.forall
+ (sourceSeqs, fn v =>
+ Vector.forall
+ (v, fn i => 0 <= i andalso i < sourcesLength)))
+ andalso (Vector.length sourceSuccessors = Vector.length sources)
+ andalso (Vector.forall
+ (sourceSuccessors, fn i =>
+ 0 <= i andalso i < sourceSeqsLength))
+ end
end
structure Program =
@@ -660,7 +705,7 @@
fun layouts (p as T {chunks, frameLayouts, frameOffsets, handlesSignals,
main = {label, ...},
- maxFrameSize, objectTypes, ...},
+ maxFrameSize, objectTypes, profileInfo, ...},
output': Layout.t -> unit) =
let
open Layout
@@ -678,6 +723,8 @@
Int.layout frameOffsetsIndex),
("size", Int.layout size)])
frameLayouts)])
+ ; output (str "\nProfileInfo:")
+ ; ProfileInfo.layouts (profileInfo, output)
; output (str "\nObjectTypes:")
; Vector.foreachi (objectTypes, fn (i, ty) =>
output (seq [str "pt_", Int.layout i,
@@ -728,10 +775,9 @@
fun typeCheck (program as
T {chunks, frameLayouts, frameOffsets, intInfs, main,
maxFrameSize, objectTypes,
- profileInfo = ProfileInfo.T {frameSources,
- labels = profileLabels,
- sources,
- sourceSeqs},
+ profileInfo as ProfileInfo.T {frameSources,
+ labels = profileLabels,
+ ...},
reals, strings, ...}) =
let
val _ =
@@ -752,14 +798,15 @@
else print (concat ["missing profile info: ",
Label.toString label, "\n"])))
else ()
- val maxProfileLabel = Vector.length sourceSeqs
val _ =
- Vector.foreach
- (profileLabels, fn {sourceSeqsIndex = i, ...} =>
- Err.check
- ("profileLabels",
- fn () => 0 <= i andalso i < maxProfileLabel,
- fn () => Int.layout i))
+ Err.check
+ ("frameSources length",
+ fn () => (Vector.length frameSources
+ = (if !Control.profile <> Control.ProfileNone
+ andalso !Control.profileStack
+ then Vector.length frameLayouts
+ else 0)),
+ fn () => ProfileInfo.layout profileInfo)
val {get = profileLabelCount, ...} =
Property.get
(ProfileLabel.plist, Property.initFun (fn _ => ref 0))
@@ -772,29 +819,6 @@
0 => r := 1
| _ => Error.bug "duplicate profile label"
end)
- val _ =
- let
- val maxFrameSourceSeq = Vector.length sourceSeqs
- val _ =
- Vector.foreach
- (frameSources, fn i =>
- Err.check
- ("frameSources",
- fn () => 0 <= i andalso i <= maxFrameSourceSeq,
- fn () => Int.layout i))
- val maxSource = Vector.length sources
- val _ =
- Vector.foreach
- (sourceSeqs, fn v =>
- Vector.foreach
- (v, fn i =>
- Err.check
- ("sourceSeq",
- fn () => 0 <= i andalso i < maxSource,
- fn () => Int.layout i)))
- in
- ()
- end
fun getFrameInfo (FrameInfo.T {frameLayoutsIndex, ...}) =
Vector.sub (frameLayouts, frameLayoutsIndex)
fun boolToUnitOpt b = if b then SOME () else NONE
1.29 +1 -0 mlton/mlton/backend/machine.sig
Index: machine.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/machine.sig,v
retrieving revision 1.28
retrieving revision 1.29
diff -u -r1.28 -r1.29
--- machine.sig 2 Jan 2003 17:45:14 -0000 1.28
+++ machine.sig 4 Jan 2003 02:00:33 -0000 1.29
@@ -221,6 +221,7 @@
* each given as an index into the source vector.
*)
sourceSeqs: int vector vector,
+ sourceSuccessors: int vector,
sources: SourceInfo.t vector}
end
1.8 +91 -66 mlton/mlton/backend/profile.fun
Index: profile.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/profile.fun,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- profile.fun 3 Jan 2003 06:14:15 -0000 1.7
+++ profile.fun 4 Jan 2003 02:00:35 -0000 1.8
@@ -4,33 +4,44 @@
open S
open Rssa
-structure Graph = DirectedGraph
-local
- open Graph
-in
- structure Edge = Edge
- structure Node = Node
-end
-
type sourceSeq = int list
structure InfoNode =
struct
datatype t = T of {index: int,
info: SourceInfo.t,
- node: Node.t}
+ successors: t list ref}
local
fun make f (T r) = f r
in
val index = make #index
val info = make #info
- val node = make #node
end
fun layout (T {index, info, ...}) =
Layout.record [("index", Int.layout index),
("info", SourceInfo.layout info)]
+
+ fun equals (n: t, n': t): bool = index n = index n'
+
+ fun call {from = T {successors, ...}, to} =
+ if List.exists (!successors, fn n => equals (n, to))
+ then ()
+ else List.push (successors, to)
+ end
+
+structure FuncInfo =
+ struct
+ datatype t = T of {callers: InfoNode.t list ref,
+ enters: InfoNode.t list ref,
+ seen: bool ref,
+ tailCalls: t list ref}
+
+ fun new () = T {callers = ref [],
+ enters = ref [],
+ seen = ref false,
+ tailCalls = ref []}
end
structure Push =
@@ -60,8 +71,9 @@
then {frameProfileIndices = Vector.new0 (),
labels = Vector.new0 (),
program = program,
- sources = Vector.new0 (),
- sourceSeqs = Vector.new0 ()}
+ sourceSeqs = Vector.new0 (),
+ sourceSuccessors = Vector.new0 (),
+ sources = Vector.new0 ()}
else
let
val Program.T {functions, main, objectTypes} = program
@@ -72,19 +84,11 @@
val profileTime: bool = profile = Control.ProfileTime
val frameProfileIndices = ref []
local
- val graph = Graph.new ()
- val {get = nodeOptions, ...} =
- Property.get (Node.plist, Property.initFun (fn _ => ref []))
val table: InfoNode.t HashSet.t =
HashSet.new {hash = SourceInfo.hash o InfoNode.info}
val c = Counter.new 0
val sourceInfos = ref []
in
- fun addEdge {from, to} =
- if List.exists (Node.successors from, fn e =>
- Node.equals (to, Edge.to e))
- then ()
- else (Graph.addEdge (graph, {from = from, to = to}); ())
fun sourceInfoNode (si: SourceInfo.t) =
HashSet.lookupOrInsert
(table, SourceInfo.hash si,
@@ -92,15 +96,10 @@
fn () => let
val _ = List.push (sourceInfos, si)
val index = Counter.next c
- val node = Graph.newNode graph
- val _ =
- List.push
- (nodeOptions node,
- Dot.NodeOption.label (SourceInfo.toString si))
in
InfoNode.T {index = index,
info = si,
- node = node}
+ successors = ref []}
end)
val sourceInfoIndex = InfoNode.index o sourceInfoNode
fun firstEnter (ps: Push.t list): InfoNode.t option =
@@ -108,18 +107,6 @@
case p of
Push.Enter n => SOME n
| _ => NONE)
- fun saveGraph () =
- Control.saveToFile
- ({suffix = "call-graph.dot"},
- Control.Dot,
- (),
- Control.Layout (fn () =>
- Graph.layoutDot
- (graph,
- fn _ => {edgeOptions = fn _ => [],
- nodeOptions = ! o nodeOptions,
- options = [],
- title = "call graph"})))
fun makeSources () = Vector.fromListRev (!sourceInfos)
end
(* unknown must be 0, which == SOURCES_INDEX_UNKNOWN from gc.h *)
@@ -187,39 +174,56 @@
orelse index = mainIndex
orelse index = unknownIndex
local
- val {get: Func.t -> {callees: Node.t list ref,
- callers: Node.t list ref}, ...} =
- Property.get (Func.plist,
- Property.initFun (fn _ => {callers = ref [],
- callees = ref []}))
+ val {get: Func.t -> FuncInfo.t, ...} =
+ Property.get (Func.plist, Property.initFun (fn _ => FuncInfo.new ()))
in
val funcInfo = get
fun addFuncEdges () =
(* Don't need to add edges for main because no one calls it. *)
- List.foreach (functions, fn f =>
- let
- val {callers, callees} = get (Function.name f)
- in
+ List.foreach
+ (functions, fn f =>
+ let
+ val allSeen: bool ref list ref = ref []
+ val func = Function.name f
+ val fi as FuncInfo.T {callers, ...} = get func
+ (* Add edges from all the callers to the enters in f and all
+ * functions that f tail calls.
+ *)
+ fun call (FuncInfo.T {enters, seen, tailCalls, ...}): unit =
+ if !seen
+ then ()
+ else
+ let
+ val _ = seen := true
+ val _ = List.push (allSeen, seen)
+ val _ =
+ List.foreach
+ (!callers, fn from =>
List.foreach
- (!callers, fn from =>
- List.foreach (!callees, fn to =>
- addEdge {from = from, to = to}))
- end)
+ (!enters, fn to =>
+ InfoNode.call {from = from, to = to}))
+ in
+ List.foreach (!tailCalls, call)
+ end
+ val _ = call fi
+ val _ = List.foreach (!allSeen, fn r => r := false)
+ in
+ ()
+ end)
end
fun doFunction (f: Function.t): Function.t =
let
val {args, blocks, name, raises, returns, start} = Function.dest f
- val {callees, ...} = funcInfo name
+ val FuncInfo.T {enters, tailCalls, ...} = funcInfo name
fun enter (si: SourceInfo.t, ps: Push.t list) =
let
- val n as InfoNode.T {node, ...} = sourceInfoNode si
+ val node = sourceInfoNode si
val _ =
case firstEnter ps of
- NONE => List.push (callees, node)
- | SOME (InfoNode.T {node = node', ...}) =>
- addEdge {from = node', to = node}
+ NONE => List.push (enters, node)
+ | SOME node' => InfoNode.call {from = node', to = node}
in
- Push.Enter n :: ps
+ Push.Enter node :: ps
end
val _ =
Vector.foreach
@@ -354,7 +358,7 @@
val Block.T {args, kind, label, statements, transfer,
...} = block
val _ =
- if Kind.isFrame kind
+ if profileStack andalso Kind.isFrame kind
then List.push (frameProfileIndices,
(label,
sourceSeqIndex
@@ -502,11 +506,19 @@
(* Record the call for the call graph. *)
val _ =
case transfer of
- Transfer.Call {func, ...} =>
- Option.app
- (firstEnter sourceSeq,
- fn InfoNode.T {node, ...} =>
- List.push (#callers (funcInfo func), node))
+ 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
| _ => ()
val {args, kind, label, statements, ...} =
maybeSplit {args = args,
@@ -574,13 +586,26 @@
main = doFunction main,
objectTypes = objectTypes}
val _ = addFuncEdges ()
- val _ = saveGraph ()
+ val sources = makeSources ()
+ val sourceSuccessors =
+ Vector.map (sources, fn si =>
+ let
+ val InfoNode.T {successors, ...} = sourceInfoNode si
+ in
+ sourceSeqIndex
+ (List.revMap (!successors, InfoNode.index))
+ end)
+ (* This must happen after making sourceSuccessors, since that creates
+ * new sourceSeqs.
+ *)
+ val sourceSeqs = makeSourceSeqs ()
in
{frameProfileIndices = Vector.fromList (!frameProfileIndices),
labels = Vector.fromList (!labels),
program = program,
- sources = makeSources (),
- sourceSeqs = makeSourceSeqs ()}
+ sourceSeqs = sourceSeqs,
+ sourceSuccessors = sourceSuccessors,
+ sources = sources}
end
end
1.2 +3 -2 mlton/mlton/backend/profile.sig
Index: profile.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/profile.sig,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- profile.sig 19 Dec 2002 23:43:32 -0000 1.1
+++ profile.sig 4 Jan 2003 02:00:36 -0000 1.2
@@ -15,6 +15,7 @@
labels: {label: Rssa.ProfileLabel.t,
sourceSeqsIndex: int} vector,
program: Rssa.Program.t,
- sources: Rssa.SourceInfo.t vector,
- sourceSeqs: int vector vector}
+ sourceSeqs: int vector vector,
+ sourceSuccessors: int vector,
+ sources: Rssa.SourceInfo.t vector}
end
1.42 +6 -3 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.41
retrieving revision 1.42
diff -u -r1.41 -r1.42
--- c-codegen.fun 3 Jan 2003 06:14:16 -0000 1.41
+++ c-codegen.fun 4 Jan 2003 02:00:37 -0000 1.42
@@ -245,7 +245,8 @@
end
fun declareProfileInfo () =
let
- val ProfileInfo.T {frameSources, labels, sourceSeqs, sources} =
+ val ProfileInfo.T {frameSources, labels, sourceSeqs,
+ sourceSuccessors, sources} =
profileInfo
in
Vector.foreach (labels, fn {label, ...} =>
@@ -267,9 +268,11 @@
(print (concat [",", C.int i])))
; print "};\n"))
- ; declareArray ("int", "*sourceSeqs", sourceSeqs, fn (i, _) =>
+ ; declareArray ("uint", "*sourceSeqs", sourceSeqs, fn (i, _) =>
concat ["sourceSeq", Int.toString i])
- ; declareArray ("int", "frameSources", frameSources, C.int o #2)
+ ; declareArray ("uint", "frameSources", frameSources, C.int o #2)
+ ; declareArray ("uint", "sourceSuccessors", sourceSuccessors,
+ C.int o #2)
end
in
print (concat ["#define ", name, "CODEGEN\n\n"])
1.112 +10 -0 mlton/runtime/gc.c
Index: gc.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/gc.c,v
retrieving revision 1.111
retrieving revision 1.112
diff -u -r1.111 -r1.112
--- gc.c 3 Jan 2003 06:14:16 -0000 1.111
+++ gc.c 4 Jan 2003 02:00:39 -0000 1.112
@@ -2825,10 +2825,20 @@
static void showProf (GC_state s) {
int i;
+ int j;
fprintf (stdout, "0x%08x\n", s->magic);
+ fprintf (stdout, "%u\n", s->sourcesSize);
for (i = 0; i < s->sourcesSize; ++i)
fprintf (stdout, "%s\n", s->sources[i]);
+ for (i = 0; i < s->sourcesSize; ++i) {
+ uint *sourceSeq;
+
+ sourceSeq = s->sourceSeqs[s->sourceSuccessors[i]];
+ for (j = 1; j <= sourceSeq[0]; ++j)
+ fprintf (stdout, "%u ", sourceSeq[j]);
+ fprintf (stdout, "\n");
+ }
}
void GC_profileFree (GC_state s, GC_profile p) {
1.51 +6 -1 mlton/runtime/gc.h
Index: gc.h
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/gc.h,v
retrieving revision 1.50
retrieving revision 1.51
diff -u -r1.50 -r1.51
--- gc.h 3 Jan 2003 06:14:17 -0000 1.50
+++ gc.h 4 Jan 2003 02:00:41 -0000 1.51
@@ -405,8 +405,13 @@
/* Each entry in sourceSeqs is a vector, whose first element is
* a length, and subsequent elements index into sources.
*/
- int **sourceSeqs;
+ uint **sourceSeqs;
uint sourceSeqsSize;
+ /* sourceSuccessors is an array of length sourcesSize. Each entry is an
+ * index into sourceSeqs that specifies the call-stack successors to this
+ * source.
+ */
+ uint *sourceSuccessors;
pointer stackBottom; /* The bottom of the stack in the current thread. */
uint startTime; /* The time when GC_init or GC_loadWorld was called. */
/* The inits array should be NULL terminated,
-------------------------------------------------------
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