Commit | Line | Data |
---|---|---|
7f918cf1 CE |
1 | (* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh |
2 | * Jagannathan, and Stephen Weeks. | |
3 | * Copyright (C) 1997-2000 NEC Research Institute. | |
4 | * | |
5 | * MLton is released under a BSD-style license. | |
6 | * See the file MLton-LICENSE for details. | |
7 | *) | |
8 | ||
9 | structure Main : sig val main : unit -> unit end = | |
10 | struct | |
11 | ||
12 | type int = Int.t | |
13 | type word = Word.t | |
14 | ||
15 | val debug = false | |
16 | ||
17 | val callGraphFile: File.t option ref = ref NONE | |
18 | val gray: bool ref = ref false | |
19 | val longName: bool ref = ref true | |
20 | val mlmonFiles: string list ref = ref [] | |
21 | val raw = ref false | |
22 | val showLine = ref false | |
23 | val splitReg: Regexp.t ref = ref Regexp.none | |
24 | val title: string option ref = ref NONE | |
25 | val tolerant: bool ref = ref false | |
26 | ||
27 | structure Source = | |
28 | struct | |
29 | datatype t = | |
30 | NamePos of {name: string, | |
31 | pos: string} | |
32 | | Simple of string | |
33 | ||
34 | fun toString n = | |
35 | case n of | |
36 | NamePos {name, pos} => concat [name, " ", pos] | |
37 | | Simple s => s | |
38 | ||
39 | fun toStringMaybeLine n = | |
40 | case n of | |
41 | NamePos {name, pos} => | |
42 | if !showLine | |
43 | then concat [name, " ", pos] | |
44 | else name | |
45 | | Simple s => s | |
46 | ||
47 | val layout = Layout.str o toString | |
48 | ||
49 | fun fromString s = | |
50 | case String.tokens (s, fn c => Char.equals (c, #"\t")) of | |
51 | [s] => Simple s | |
52 | | [name, pos] => | |
53 | let | |
54 | val name = | |
55 | if !longName | |
56 | then name | |
57 | else | |
58 | List.last | |
59 | (String.tokens (name, fn c => Char.equals (c, #"."))) | |
60 | in | |
61 | NamePos {name = name, pos = pos} | |
62 | end | |
63 | | _ => Error.bug "strange source" | |
64 | ||
65 | fun toDotLabel s = | |
66 | case s of | |
67 | NamePos {name, pos} => | |
68 | if !showLine | |
69 | then [(name, Dot.Center), | |
70 | (pos, Dot.Center)] | |
71 | else [(name, Dot.Center)] | |
72 | | Simple s => | |
73 | [(s, Dot.Center)] | |
74 | end | |
75 | ||
76 | structure Graph = DirectedGraph | |
77 | local | |
78 | open Graph | |
79 | in | |
80 | structure Edge = Edge | |
81 | structure Node = Node | |
82 | end | |
83 | local | |
84 | open Dot | |
85 | in | |
86 | structure EdgeOption = EdgeOption | |
87 | structure NodeOption = NodeOption | |
88 | end | |
89 | ||
90 | structure AFile = | |
91 | struct | |
92 | datatype t = T of {callGraph: unit Graph.t, | |
93 | magic: word, | |
94 | master: {isSplit: bool, | |
95 | source: Source.t} vector, | |
96 | name: string, | |
97 | split: {masterIndex: int, | |
98 | node: unit Node.t} vector} | |
99 | ||
100 | fun layout (T {magic, name, master, ...}) = | |
101 | Layout.record | |
102 | [("name", String.layout name), | |
103 | ("magic", Word.layout magic), | |
104 | ("master", | |
105 | Vector.layout (fn {isSplit, source} => | |
106 | Layout.record [("isSplit", Bool.layout isSplit), | |
107 | ("source", Source.layout source)]) | |
108 | master)] | |
109 | ||
110 | fun new {afile: File.t}: t = | |
111 | let | |
112 | fun userBug m = | |
113 | Error.bug (concat ["Error: executable '", afile, "' ", m, "."]) | |
114 | in | |
115 | if not (File.doesExist afile) then | |
116 | userBug "does not exist" | |
117 | else if not (File.canRun afile) then | |
118 | userBug "does not run" | |
119 | else | |
120 | Process.callWithIn | |
121 | (OS.Path.mkAbsolute {path = afile, | |
122 | relativeTo = OS.FileSys.getDir ()}, | |
123 | ["@MLton", "show-sources"], | |
124 | fn ins => | |
125 | let | |
126 | fun line () = | |
127 | case In.inputLine ins of | |
128 | NONE => Error.bug "unexpected end of show-sources data" | |
129 | | SOME l => l | |
130 | val magic = | |
131 | case Word.fromString (line ()) of | |
132 | NONE => Error.bug "expected magic" | |
133 | | SOME w => w | |
134 | fun vector (f: string -> 'a): 'a vector = | |
135 | Vector.tabulate (valOf (Int.fromString (line ())), | |
136 | fn _ => f (line ())) | |
137 | val rc = Regexp.compileNFA (!splitReg) | |
138 | val master = | |
139 | vector | |
140 | (fn s => | |
141 | let | |
142 | val source = Source.fromString (String.dropSuffix (s, 1)) | |
143 | val isSplit = | |
144 | Regexp.Compiled.matchesPrefix | |
145 | (rc, Source.toString source) | |
146 | in | |
147 | {isSplit = isSplit, | |
148 | source = source} | |
149 | end) | |
150 | val _ = | |
151 | if 0 = Vector.length master then | |
152 | userBug "is not compiled for profiling" | |
153 | else () | |
154 | val sources = | |
155 | vector | |
156 | (fn s => | |
157 | case String.tokens (s, Char.isSpace) of | |
158 | [masterIndex, successorsIndex] => | |
159 | {masterIndex = valOf (Int.fromString masterIndex), | |
160 | successorsIndex = valOf (Int.fromString | |
161 | successorsIndex)} | |
162 | | _ => Error.bug "AFile.new") | |
163 | val sourceSeqs = | |
164 | vector | |
165 | (fn s => | |
166 | Vector.fromListMap | |
167 | (String.tokens (s, Char.isSpace), fn s => | |
168 | valOf (Int.fromString s))) | |
169 | val graph = Graph.new () | |
170 | val split = | |
171 | Vector.map | |
172 | (sources, fn {masterIndex, ...} => | |
173 | let | |
174 | val n = Graph.newNode graph | |
175 | in | |
176 | {masterIndex = masterIndex, | |
177 | node = n} | |
178 | end) | |
179 | val _ = | |
180 | Vector.foreach2 | |
181 | (sources, split, | |
182 | fn ({successorsIndex, ...}, {node = from, ...}) => | |
183 | Vector.foreach | |
184 | (Vector.sub (sourceSeqs, successorsIndex), | |
185 | fn to => | |
186 | (ignore o Graph.addEdge) | |
187 | (graph, {from = from, | |
188 | to = #node (Vector.sub (split, to))}))) | |
189 | val _ = | |
190 | case In.inputLine ins of | |
191 | NONE => () | |
192 | | SOME _ => Error.bug "expected end of file" | |
193 | in | |
194 | T {callGraph = graph, | |
195 | magic = magic, | |
196 | master = master, | |
197 | name = afile, | |
198 | split = split} | |
199 | end) | |
200 | end | |
201 | end | |
202 | ||
203 | structure Kind = | |
204 | struct | |
205 | datatype t = Alloc | Count | Empty | Time | |
206 | ||
207 | val toString = | |
208 | fn Alloc => "Alloc" | |
209 | | Count => "Count" | |
210 | | Empty => "Empty" | |
211 | | Time => "Time" | |
212 | ||
213 | val layout = Layout.str o toString | |
214 | ||
215 | val merge: t * t -> t = | |
216 | fn (k, k') => | |
217 | case (k, k') of | |
218 | (Alloc, Alloc) => Alloc | |
219 | | (Count, Count) => Count | |
220 | | (_, Empty) => k | |
221 | | (Empty, _) => k' | |
222 | | (Time, Time) => Time | |
223 | | _ => Error.bug "Kind.merge" | |
224 | end | |
225 | ||
226 | structure Style = | |
227 | struct | |
228 | datatype t = Current | Stack | |
229 | ||
230 | (* val toString = fn Current => "Current" | Stack => "Stack" *) | |
231 | ||
232 | (* val layout = Layout.str o toString *) | |
233 | end | |
234 | ||
235 | structure Counts = | |
236 | struct | |
237 | datatype t = | |
238 | Current of {master: IntInf.t vector, | |
239 | split: IntInf.t vector} | |
240 | | Empty | |
241 | | Stack of {master: {current: IntInf.t, | |
242 | stack: IntInf.t, | |
243 | stackGC: IntInf.t} vector, | |
244 | split: {current: IntInf.t, | |
245 | stack: IntInf.t, | |
246 | stackGC: IntInf.t} vector} | |
247 | ||
248 | val layout = | |
249 | fn Current {master, split} => | |
250 | Layout.record [("master", Vector.layout IntInf.layout master), | |
251 | ("split", Vector.layout IntInf.layout split)] | |
252 | | Empty => Layout.str "empty" | |
253 | | Stack {master, split} => | |
254 | let | |
255 | fun lay v = | |
256 | Vector.layout | |
257 | (fn {current, stack, stackGC} => | |
258 | Layout.record [("current", IntInf.layout current), | |
259 | ("stack", IntInf.layout stack), | |
260 | ("stackGC", IntInf.layout stackGC)]) | |
261 | v | |
262 | in | |
263 | Layout.record [("master", lay master), | |
264 | ("split", lay split)] | |
265 | end | |
266 | ||
267 | fun merge (c: t, c': t): t = | |
268 | case (c, c') of | |
269 | (Current {master = m, split = s}, | |
270 | Current {master = m', split = s'}) => | |
271 | let | |
272 | fun merge (v, v') = Vector.map2 (v, v', op +) | |
273 | in | |
274 | Current {master = merge (m, m'), | |
275 | split = merge (s, s')} | |
276 | end | |
277 | | (Empty, _) => c' | |
278 | | (_, Empty) => c | |
279 | | (Stack {master = m, split = s}, Stack {master = m', split = s'}) => | |
280 | let | |
281 | fun merge (v, v') = | |
282 | Vector.map2 | |
283 | (v, v', fn ({current = c, stack = s, stackGC = g}, | |
284 | {current = c', stack = s', stackGC = g'}) => | |
285 | {current = c + c', | |
286 | stack = s + s', | |
287 | stackGC = g + g'}) | |
288 | in | |
289 | Stack {master = merge (m, m'), | |
290 | split = merge (s, s')} | |
291 | end | |
292 | | _ => | |
293 | Error.bug | |
294 | "cannot merge -profile-stack false with -profile-stack true" | |
295 | end | |
296 | ||
297 | structure ProfFile = | |
298 | struct | |
299 | datatype t = T of {counts: Counts.t, | |
300 | kind: Kind.t, | |
301 | magic: word, | |
302 | total: IntInf.t, | |
303 | totalGC: IntInf.t} | |
304 | ||
305 | fun empty (AFile.T {magic, ...}) = | |
306 | T {counts = Counts.Empty, | |
307 | kind = Kind.Empty, | |
308 | magic = magic, | |
309 | total = 0, | |
310 | totalGC = 0} | |
311 | ||
312 | fun layout (T {counts, kind, magic, total, totalGC}) = | |
313 | Layout.record [("kind", Kind.layout kind), | |
314 | ("magic", Word.layout magic), | |
315 | ("total", IntInf.layout total), | |
316 | ("totalGC", IntInf.layout totalGC), | |
317 | ("counts", Counts.layout counts)] | |
318 | ||
319 | fun new {mlmonfile: File.t}: t = | |
320 | File.withIn | |
321 | (mlmonfile, fn ins => | |
322 | let | |
323 | fun line () = | |
324 | case In.inputLine ins of | |
325 | NONE => Error.bug "unexpected end of mlmon file" | |
326 | | SOME s => String.dropSuffix (s, 1) | |
327 | val _ = | |
328 | if "MLton prof" = line () | |
329 | then () | |
330 | else Error.bug "bad header" | |
331 | val kind = | |
332 | case line () of | |
333 | "alloc" => Kind.Alloc | |
334 | | "count" => Kind.Count | |
335 | | "time" => Kind.Time | |
336 | | _ => Error.bug "invalid profile kind" | |
337 | val style = | |
338 | case line () of | |
339 | "current" => Style.Current | |
340 | | "stack" => Style.Stack | |
341 | | _ => Error.bug "invalid profile style" | |
342 | val magic = | |
343 | case Word.fromString (line ()) of | |
344 | NONE => Error.bug "invalid magic" | |
345 | | SOME w => w | |
346 | fun s2i s = | |
347 | case IntInf.fromString s of | |
348 | NONE => Error.bug "invalid count" | |
349 | | SOME i => i | |
350 | val (total, totalGC) = | |
351 | case String.tokens (line (), Char.isSpace) of | |
352 | [total, totalGC] => (s2i total, s2i totalGC) | |
353 | | _ => Error.bug "invalid totals" | |
354 | fun getCounts (f: string -> 'a): {master: 'a vector, | |
355 | split: 'a vector} = | |
356 | let | |
357 | fun vector () = | |
358 | Vector.tabulate (valOf (Int.fromString (line ())), | |
359 | fn _ => f (line ())) | |
360 | val split = vector () | |
361 | val master = vector () | |
362 | in | |
363 | {master = master, split = split} | |
364 | end | |
365 | val counts = | |
366 | case style of | |
367 | Style.Current => Counts.Current (getCounts s2i) | |
368 | | Style.Stack => | |
369 | Counts.Stack | |
370 | (getCounts | |
371 | (fn s => | |
372 | case String.tokens (s, Char.isSpace) of | |
373 | [c, s, sGC] => | |
374 | {current = s2i c, | |
375 | stack = s2i s, | |
376 | stackGC = s2i sGC} | |
377 | | _ => | |
378 | Error.bug | |
379 | (concat ["strange line: ", | |
380 | String.dropSuffix (s, 1)]))) | |
381 | in | |
382 | T {counts = counts, | |
383 | kind = kind, | |
384 | magic = magic, | |
385 | total = total, | |
386 | totalGC = totalGC} | |
387 | end) | |
388 | ||
389 | fun merge (T {counts = c, kind = k, magic = m, total = t, totalGC = g}, | |
390 | T {counts = c', kind = k', magic = m', total = t', | |
391 | totalGC = g'}): t = | |
392 | if m <> m' | |
393 | then Error.bug "wrong magic number" | |
394 | else | |
395 | T {counts = Counts.merge (c, c'), | |
396 | kind = Kind.merge (k, k'), | |
397 | magic = m, | |
398 | total = t + t', | |
399 | totalGC = g + g'} | |
400 | end | |
401 | ||
402 | structure Atomic = | |
403 | struct | |
404 | datatype t = | |
405 | Name of string * Regexp.Compiled.t | |
406 | | Thresh of real | |
407 | | ThreshGC of real | |
408 | | ThreshStack of real | |
409 | ||
410 | val toSexp: t -> Sexp.t = | |
411 | fn a => | |
412 | let | |
413 | datatype z = datatype Sexp.t | |
414 | in | |
415 | case a of | |
416 | Name (s, _) => String s | |
417 | | Thresh x => List [Atom "thresh", Atom (Real.toString x)] | |
418 | | ThreshGC x => List [Atom "thresh-gc", Atom (Real.toString x)] | |
419 | | ThreshStack x => | |
420 | List [Atom "thresh-stack", Atom (Real.toString x)] | |
421 | end | |
422 | end | |
423 | ||
424 | structure NodePred = | |
425 | struct | |
426 | datatype t = | |
427 | All | |
428 | | And of t vector | |
429 | | Atomic of Atomic.t | |
430 | | Not of t | |
431 | | Or of t vector | |
432 | | PathFrom of t | |
433 | | PathTo of t | |
434 | | Pred of t | |
435 | | Succ of t | |
436 | ||
437 | val rec toSexp: t -> Sexp.t = | |
438 | fn p => | |
439 | let | |
440 | datatype z = datatype Sexp.t | |
441 | fun nAry (name, ps) = | |
442 | List (Atom name :: Vector.toListMap (ps, toSexp)) | |
443 | fun unary (name, p) = | |
444 | List [Atom name, toSexp p] | |
445 | in | |
446 | case p of | |
447 | All => Sexp.Atom "all" | |
448 | | And ps => nAry ("and", ps) | |
449 | | Atomic a => Atomic.toSexp a | |
450 | | Not p => unary ("not", p) | |
451 | | Or ps => nAry ("or", ps) | |
452 | | PathFrom p => unary ("from", p) | |
453 | | PathTo p => unary ("to", p) | |
454 | | Pred p => unary ("pred", p) | |
455 | | Succ p => unary ("succ", p) | |
456 | end | |
457 | ||
458 | (* val layout = Sexp.layout o toSexp *) | |
459 | ||
460 | val fromString: string -> t = | |
461 | fn s => | |
462 | case Sexp.fromString s of | |
463 | Sexp.Eof => Error.bug "empty" | |
464 | | Sexp.Error s => Error.bug s | |
465 | | Sexp.Sexp s => | |
466 | let | |
467 | fun parse (s: Sexp.t): t = | |
468 | let | |
469 | fun err () = Error.bug (Sexp.toString s) | |
470 | in | |
471 | case s of | |
472 | Sexp.Atom s => | |
473 | (case s of | |
474 | "all" => All | |
475 | | _ => err ()) | |
476 | | Sexp.List ss => | |
477 | (case ss of | |
478 | [] => err () | |
479 | | s :: ss => | |
480 | let | |
481 | fun nAry f = | |
482 | f (Vector.fromListMap (ss, parse)) | |
483 | fun unary f = | |
484 | case ss of | |
485 | [s] => f (parse s) | |
486 | | _ => err () | |
487 | fun thresh f = | |
488 | case ss of | |
489 | [Sexp.Atom x] => | |
490 | (case Real.fromString x of | |
491 | NONE => err () | |
492 | | SOME x => | |
493 | if 0.0 <= x | |
494 | andalso x <= 100.0 | |
495 | then Atomic (f x) | |
496 | else err ()) | |
497 | | _ => err () | |
498 | datatype z = datatype Atomic.t | |
499 | in | |
500 | case s of | |
501 | Sexp.Atom s => | |
502 | (case s of | |
503 | "and" => nAry And | |
504 | | "from" => unary PathFrom | |
505 | | "not" => unary Not | |
506 | | "or" => nAry Or | |
507 | | "pred" => unary Pred | |
508 | | "succ" => unary Succ | |
509 | | "thresh" => thresh Thresh | |
510 | | "thresh-gc" => thresh ThreshGC | |
511 | | "thresh-stack" => | |
512 | thresh ThreshStack | |
513 | | "to" => unary PathTo | |
514 | | _ => err ()) | |
515 | | _ => err () | |
516 | end) | |
517 | | Sexp.String s => | |
518 | (case Regexp.fromString s of | |
519 | NONE => err () | |
520 | | SOME (r, _) => | |
521 | Atomic | |
522 | (Atomic.Name (s, Regexp.compileNFA r))) | |
523 | end | |
524 | in | |
525 | parse s | |
526 | end | |
527 | ||
528 | fun nodes (p: t, g: 'a Graph.t, | |
529 | atomic: 'a Node.t * Atomic.t -> bool): 'a Node.t vector = | |
530 | let | |
531 | val {get = nodeIndex: 'a Node.t -> int, | |
532 | set = setNodeIndex, ...} = | |
533 | Property.getSet (Node.plist, | |
534 | Property.initRaise ("index", Node.layout)) | |
535 | val nodes = Vector.fromList (Graph.nodes g) | |
536 | val numNodes = Vector.length nodes | |
537 | val _ = Vector.foreachi (nodes, fn (i, n) => setNodeIndex (n, i)) | |
538 | val transpose = | |
539 | Promise.lazy | |
540 | (fn () => | |
541 | let | |
542 | val {get = nodeIndex': 'a Graph.u Node.t -> int, | |
543 | set = setNodeIndex, ...} = | |
544 | Property.getSet (Node.plist, | |
545 | Property.initRaise ("index", Node.layout)) | |
546 | val (transpose, {newNode, ...}) = Graph.transpose g | |
547 | val _ = | |
548 | Graph.foreachNode | |
549 | (g, fn n => setNodeIndex (newNode n, nodeIndex n)) | |
550 | in | |
551 | (transpose, newNode, nodeIndex') | |
552 | end) | |
553 | fun vectorToNodes (v: bool vector): 'a Node.t vector = | |
554 | Vector.keepAllMapi | |
555 | (v, fn (i, b) => | |
556 | if b | |
557 | then SOME (Vector.sub (nodes, i)) | |
558 | else NONE) | |
559 | val all = Promise.lazy (fn () => | |
560 | Vector.tabulate (numNodes, fn _ => true)) | |
561 | val none = Promise.lazy (fn () => | |
562 | Vector.tabulate (numNodes, fn _ => false)) | |
563 | fun path (v: bool vector, | |
564 | (g: 'b Graph.t, | |
565 | getNode: 'a Node.t -> 'b Node.t, | |
566 | nodeIndex: 'b Node.t -> int)): bool vector = | |
567 | let | |
568 | val roots = vectorToNodes v | |
569 | val a = Array.array (numNodes, false) | |
570 | val _ = | |
571 | Graph.dfsNodes | |
572 | (g, | |
573 | Vector.toListMap (roots, getNode), | |
574 | Graph.DfsParam.startNode (fn n => | |
575 | Array.update | |
576 | (a, nodeIndex n, true))) | |
577 | in | |
578 | Vector.fromArray a | |
579 | end | |
580 | fun loop (p: t): bool vector = | |
581 | case p of | |
582 | All => all () | |
583 | | And ps => | |
584 | Vector.fold (ps, all (), fn (p, v) => | |
585 | Vector.map2 (v, loop p, fn (b, b') => | |
586 | b andalso b')) | |
587 | | Atomic a => Vector.map (nodes, fn n => atomic (n, a)) | |
588 | | Not p => Vector.map (loop p, not) | |
589 | | Or ps => | |
590 | Vector.fold (ps, none (), fn (p, v) => | |
591 | Vector.map2 (v, loop p, fn (b, b') => | |
592 | b orelse b')) | |
593 | | PathFrom p => path (loop p, (g, fn n => n, nodeIndex)) | |
594 | | PathTo p => path (loop p, transpose ()) | |
595 | | Pred p => | |
596 | let | |
597 | val ns = vectorToNodes (loop p) | |
598 | val {destroy, get, set, ...} = | |
599 | Property.destGetSetOnce | |
600 | (Node.plist, Property.initConst false) | |
601 | val _ = Vector.foreach (ns, fn n => set (n, true)) | |
602 | val v = | |
603 | Vector.map | |
604 | (nodes, fn n => | |
605 | get n orelse | |
606 | List.exists (Node.successors n, get o Edge.to)) | |
607 | val _ = destroy () | |
608 | in | |
609 | v | |
610 | end | |
611 | | Succ p => | |
612 | let | |
613 | val a = Array.array (numNodes, false) | |
614 | fun yes n = Array.update (a, nodeIndex n, true) | |
615 | val _ = | |
616 | Vector.foreach | |
617 | (vectorToNodes (loop p), fn n => | |
618 | (yes n | |
619 | ; List.foreach (Node.successors n, yes o Edge.to))) | |
620 | in | |
621 | Vector.fromArray a | |
622 | end | |
623 | val v = loop p | |
624 | in | |
625 | vectorToNodes v | |
626 | end | |
627 | end | |
628 | ||
629 | val keep: NodePred.t ref = ref NodePred.All | |
630 | ||
631 | val ticksPerSecond = 100.0 | |
632 | ||
633 | fun display (AFile.T {callGraph, master, name = aname, split, ...}, | |
634 | ProfFile.T {counts, kind, total, totalGC, ...}): unit = | |
635 | let | |
636 | val {get = nodeInfo: (unit Node.t | |
637 | -> {index: int, | |
638 | keep: bool ref, | |
639 | mayKeep: (Atomic.t -> bool) ref}), | |
640 | set = setNodeInfo, ...} = | |
641 | Property.getSetOnce (Node.plist, | |
642 | Property.initRaise ("info", Node.layout)) | |
643 | val _ = | |
644 | Vector.foreachi (split, fn (i, {node, ...}) => | |
645 | setNodeInfo (node, | |
646 | {index = i, | |
647 | keep = ref false, | |
648 | mayKeep = ref (fn _ => false)})) | |
649 | val profileStack = | |
650 | case counts of | |
651 | Counts.Current _ => false | |
652 | | Counts.Empty => false | |
653 | | Counts.Stack _ => true | |
654 | val totalReal = Real.fromIntInf (total + totalGC) | |
655 | val per: IntInf.t -> real = | |
656 | if Real.equals (0.0, totalReal) | |
657 | then fn _ => 0.0 | |
658 | else | |
659 | fn ticks => 100.0 * Real.fromIntInf ticks / totalReal | |
660 | fun doit ({master = masterCount: 'a vector, | |
661 | split = splitCount: 'a vector}, | |
662 | f: 'a -> {current: IntInf.t, | |
663 | stack: IntInf.t, | |
664 | stackGC: IntInf.t}) = | |
665 | let | |
666 | val _ = | |
667 | Vector.foreachi | |
668 | (split, fn (i, {masterIndex, node, ...}) => | |
669 | let | |
670 | val {mayKeep, ...} = nodeInfo node | |
671 | val {isSplit, source, ...} = Vector.sub (master, masterIndex) | |
672 | val name = Source.toString source | |
673 | in | |
674 | mayKeep := | |
675 | (fn a => | |
676 | let | |
677 | fun thresh (x: real, sel) = | |
678 | let | |
679 | val (v, i) = | |
680 | if isSplit | |
681 | then (splitCount, i) | |
682 | else (masterCount, masterIndex) | |
683 | in | |
684 | per (sel (f (Vector.sub (v, i)))) >= x | |
685 | end | |
686 | datatype z = datatype Atomic.t | |
687 | in | |
688 | case a of | |
689 | Name (_, rc) => | |
690 | Regexp.Compiled.matchesPrefix (rc, name) | |
691 | | Thresh x => thresh (x, #current) | |
692 | | ThreshGC x => thresh (x, #stackGC) | |
693 | | ThreshStack x => thresh (x, #stack) | |
694 | end) | |
695 | end) | |
696 | fun row (ticks: IntInf.t): string list = | |
697 | (concat [Real.format (per ticks, Real.Format.fix (SOME 1)), "%"]) | |
698 | :: (if !raw | |
699 | then | |
700 | [concat | |
701 | (case kind of | |
702 | Kind.Alloc => | |
703 | ["(", IntInf.toCommaString ticks, ")"] | |
704 | | Kind.Count => | |
705 | ["(", IntInf.toCommaString ticks, ")"] | |
706 | | Kind.Empty => [] | |
707 | | Kind.Time => | |
708 | ["(", | |
709 | Real.format | |
710 | (Real.fromIntInf ticks / ticksPerSecond, | |
711 | Real.Format.fix (SOME 2)), | |
712 | "s)"])] | |
713 | else []) | |
714 | fun info (source: Source.t, a: 'a) = | |
715 | let | |
716 | val {current, stack, stackGC} = f a | |
717 | val row = | |
718 | row current | |
719 | @ (if profileStack | |
720 | then row stack @ row stackGC | |
721 | else []) | |
722 | val pc = per current | |
723 | val isNonZero = current > 0 orelse stack > 0 orelse stackGC > 0 | |
724 | val tableInfo = | |
725 | if isNonZero orelse (kind = Kind.Count | |
726 | andalso (case source of | |
727 | Source.NamePos _ => true | |
728 | | _ => false)) | |
729 | then SOME {per = pc, | |
730 | row = Source.toStringMaybeLine source :: row} | |
731 | else NONE | |
732 | val nodeOptions = | |
733 | [Dot.NodeOption.Shape Dot.Box, | |
734 | Dot.NodeOption.Label | |
735 | (Source.toDotLabel source | |
736 | @ (if isNonZero | |
737 | then [(concat (List.separate (row, " ")), | |
738 | Dot.Center)] | |
739 | else [])), | |
740 | Dot.NodeOption.Color | |
741 | (if !gray | |
742 | then DotColor.gray (100 - Real.round (per stack)) | |
743 | else DotColor.Black)] | |
744 | in | |
745 | {nodeOptions = nodeOptions, | |
746 | tableInfo = tableInfo} | |
747 | end | |
748 | val masterOptions = | |
749 | Vector.map2 | |
750 | (master, masterCount, fn ({source, ...}, a) => | |
751 | info (source, a)) | |
752 | val splitOptions = | |
753 | Vector.map2 | |
754 | (split, splitCount, fn ({masterIndex, ...}, a) => | |
755 | info (#source (Vector.sub (master, masterIndex)), a)) | |
756 | in | |
757 | (masterOptions, splitOptions) | |
758 | end | |
759 | val (masterInfo, splitInfo) = | |
760 | case counts of | |
761 | Counts.Current ms => | |
762 | doit (ms, fn z => {current = z, | |
763 | stack = 0, | |
764 | stackGC = 0}) | |
765 | | Counts.Empty => | |
766 | doit ({master = Vector.new (Vector.length master, ()), | |
767 | split = Vector.new (Vector.length split, ())}, | |
768 | fn () => {current = 0, | |
769 | stack = 0, | |
770 | stackGC = 0}) | |
771 | | Counts.Stack ms => | |
772 | doit (ms, fn z => z) | |
773 | val keep = !keep | |
774 | val keepNodes = | |
775 | NodePred.nodes | |
776 | (keep, callGraph, fn (n, a) => (! (#mayKeep (nodeInfo n))) a) | |
777 | val _ = Vector.foreach (keepNodes, fn n => | |
778 | #keep (nodeInfo n) := true) | |
779 | (* keep a master node if it is not split and some copy of it is kept. *) | |
780 | val keepMaster = Array.new (Vector.length master, false) | |
781 | val _ = | |
782 | Vector.foreach | |
783 | (split, fn {masterIndex, node, ...} => | |
784 | let | |
785 | val {keep, ...} = nodeInfo node | |
786 | val {isSplit, ...} = Vector.sub (master, masterIndex) | |
787 | in | |
788 | if !keep andalso not isSplit | |
789 | then Array.update (keepMaster, masterIndex, true) | |
790 | else () | |
791 | end) | |
792 | datatype keep = T | |
793 | val keepGraph: keep Graph.t = Graph.new () | |
794 | val {get = nodeOptions: keep Node.t -> NodeOption.t list, | |
795 | set = setNodeOptions, ...} = | |
796 | Property.getSetOnce (Node.plist, | |
797 | Property.initRaise ("options", Node.layout)) | |
798 | val tableInfos = ref [] | |
799 | fun newNode {nodeOptions: NodeOption.t list, | |
800 | tableInfo} = | |
801 | let | |
802 | val _ = Option.app (tableInfo, fn z => List.push (tableInfos, z)) | |
803 | val n = Graph.newNode keepGraph | |
804 | val _ = setNodeOptions (n, nodeOptions) | |
805 | in | |
806 | n | |
807 | end | |
808 | val masterNodes = | |
809 | Vector.tabulate | |
810 | (Vector.length master, fn i => | |
811 | if Array.sub (keepMaster, i) | |
812 | then SOME (newNode (Vector.sub (masterInfo, i))) | |
813 | else NONE) | |
814 | val splitNodes = | |
815 | Vector.mapi | |
816 | (split, fn (i, {masterIndex, node, ...}) => | |
817 | let | |
818 | val {keep, ...} = nodeInfo node | |
819 | val {isSplit, ...} = Vector.sub (master, masterIndex) | |
820 | in | |
821 | if isSplit | |
822 | then | |
823 | if !keep | |
824 | then SOME (newNode (Vector.sub (splitInfo, i))) | |
825 | else NONE | |
826 | else Vector.sub (masterNodes, masterIndex) | |
827 | end) | |
828 | val _ = | |
829 | Graph.foreachEdge | |
830 | (callGraph, fn (from, e) => | |
831 | let | |
832 | val to = Edge.to e | |
833 | fun f n = Vector.sub (splitNodes, #index (nodeInfo n)) | |
834 | in | |
835 | case (f from, f to) of | |
836 | (SOME from, SOME to) => | |
837 | (ignore o Graph.addEdge) | |
838 | (keepGraph, {from = from, to = to}) | |
839 | | _ => () | |
840 | end) | |
841 | val {get = edgeOptions: keep Edge.t -> EdgeOption.t list ref, ...} = | |
842 | Property.get (Edge.plist, Property.initFun (fn _ => ref [])) | |
843 | (* Add a dashed edge from A to B if there is path from A to B of length | |
844 | * >= 2 going through only ignored nodes. | |
845 | *) | |
846 | fun newNode (n: unit Node.t): keep Node.t option = | |
847 | Vector.sub (splitNodes, #index (nodeInfo n)) | |
848 | fun reach (root: unit Node.t, f: keep Node.t -> unit): unit = | |
849 | let | |
850 | val {get = isKept: keep Node.t -> bool ref, ...} = | |
851 | Property.get (Node.plist, Property.initFun (fn _ => ref false)) | |
852 | val {get = isSeen: unit Node.t -> bool ref, ...} = | |
853 | Property.get (Node.plist, Property.initFun (fn _ => ref false)) | |
854 | fun loop n = | |
855 | List.foreach | |
856 | (Node.successors n, fn e => | |
857 | let | |
858 | val n = Edge.to e | |
859 | val s = isSeen n | |
860 | in | |
861 | if !s | |
862 | then () | |
863 | else | |
864 | let | |
865 | val _ = s := true | |
866 | in | |
867 | case newNode n of | |
868 | NONE => loop n | |
869 | | SOME keepN => | |
870 | let | |
871 | val r = isKept keepN | |
872 | in | |
873 | if !r | |
874 | then () | |
875 | else (r := true; f keepN) | |
876 | end | |
877 | end | |
878 | end) | |
879 | val _ = | |
880 | List.foreach (Node.successors root, fn e => | |
881 | let | |
882 | val n = Edge.to e | |
883 | in | |
884 | if Option.isNone (newNode n) | |
885 | then loop n | |
886 | else () | |
887 | end) | |
888 | in | |
889 | () | |
890 | end | |
891 | val _ = | |
892 | Vector.foreach2 | |
893 | (split, splitNodes, fn ({node = from, ...}, z) => | |
894 | Option.app | |
895 | (z, fn from' => | |
896 | (reach (from, fn to => | |
897 | let | |
898 | val e = Graph.addEdge (keepGraph, {from = from', to = to}) | |
899 | val _ = List.push (edgeOptions e, | |
900 | EdgeOption.Style Dot.Dashed) | |
901 | in | |
902 | () | |
903 | end)))) | |
904 | val _ = Graph.removeDuplicateEdges keepGraph | |
905 | val title = | |
906 | case !title of | |
907 | NONE => concat [aname, " call-stack graph"] | |
908 | | SOME s => s | |
909 | val _ = | |
910 | Option.app | |
911 | (!callGraphFile, fn f => | |
912 | File.withOut | |
913 | (f, fn out => | |
914 | Layout.output | |
915 | (Graph.layoutDot (keepGraph, | |
916 | fn _ => {edgeOptions = ! o edgeOptions, | |
917 | nodeOptions = nodeOptions, | |
918 | options = [], | |
919 | title = title}), | |
920 | out))) | |
921 | (* Display the table. *) | |
922 | val tableRows = | |
923 | QuickSort.sortVector | |
924 | (Vector.fromList (!tableInfos), fn (z, z') => #per z >= #per z') | |
925 | val _ = | |
926 | ||
927 | (concat | |
928 | (case kind of | |
929 | Kind.Alloc => | |
930 | [IntInf.toCommaString total, " bytes allocated (", | |
931 | IntInf.toCommaString totalGC, " bytes by GC)\n"] | |
932 | | Kind.Count => | |
933 | [IntInf.toCommaString total, " ticks\n"] | |
934 | | Kind.Empty => [] | |
935 | | Kind.Time => | |
936 | let | |
937 | fun t2s i = | |
938 | Real.format (Real.fromIntInf i / ticksPerSecond, | |
939 | Real.Format.fix (SOME 2)) | |
940 | in | |
941 | [t2s total, " seconds of CPU time (", | |
942 | t2s totalGC, " seconds GC)\n"] | |
943 | end)) | |
944 | val columnHeads = | |
945 | "function" | |
946 | :: let | |
947 | val pers = | |
948 | if profileStack | |
949 | then ["cur", "stack", "GC"] | |
950 | else ["cur"] | |
951 | in | |
952 | if !raw | |
953 | then List.concatMap (pers, fn p => [p, "raw"]) | |
954 | else pers | |
955 | end | |
956 | val cols = | |
957 | (if profileStack then 3 else 1) * (if !raw then 2 else 1) | |
958 | val _ = | |
959 | let | |
960 | open Justify | |
961 | in | |
962 | outputTable | |
963 | (table {columnHeads = SOME columnHeads, | |
964 | justs = Left :: List.duplicate (cols, fn () => Right), | |
965 | rows = Vector.toListMap (tableRows, #row)}, | |
966 | Out.standard) | |
967 | end | |
968 | in | |
969 | () | |
970 | end | |
971 | ||
972 | fun makeOptions {usage} = | |
973 | let | |
974 | open Popt | |
975 | in | |
976 | List.map | |
977 | ([(Normal, "call-graph", " <file>", "write call graph to dot file", | |
978 | SpaceString (fn s => callGraphFile := SOME s)), | |
979 | (Normal, "graph-title", " <string>", "set call-graph title", | |
980 | SpaceString (fn s => title := SOME s)), | |
981 | (Normal, "gray", " {false|true}", "gray nodes according to stack %", | |
982 | boolRef gray), | |
983 | (Normal, "keep", " <exp>", "which functions to display", | |
984 | SpaceString (fn s => | |
985 | keep := NodePred.fromString s | |
986 | handle e => usage (concat ["invalid -keep arg: ", | |
987 | Exn.toString e]))), | |
988 | (Expert, "long-name", " {true|false}", | |
989 | " show long names of functions", | |
990 | boolRef longName), | |
991 | (Normal, "mlmon", " <file>", "process mlmon files listed in <file>", | |
992 | SpaceString (fn s => | |
993 | mlmonFiles := | |
994 | List.concat [String.tokens (File.contents s, Char.isSpace), | |
995 | !mlmonFiles])), | |
996 | (Normal, "raw", " {false|true}", "show raw counts", | |
997 | boolRef raw), | |
998 | (Normal, "show-line", " {false|true}", "show line numbers", | |
999 | boolRef showLine), | |
1000 | (Normal, "split", " <regexp>", "split matching functions", | |
1001 | SpaceString (fn s => | |
1002 | case Regexp.fromString s of | |
1003 | NONE => usage (concat ["invalid -split regexp: ", s]) | |
1004 | | SOME (r, _) => splitReg := Regexp.or [r, !splitReg])), | |
1005 | (Normal, "thresh", " [0.0,100.0]", "-keep (thresh x)", | |
1006 | Real (fn x => if x < 0.0 orelse x > 100.0 | |
1007 | then usage "invalid -thresh" | |
1008 | else keep := NodePred.Atomic (Atomic.Thresh x))), | |
1009 | (Normal, "tolerant", " {false|true}", "ignore broken mlmon files", | |
1010 | boolRef tolerant)], | |
1011 | fn (style, name, arg, desc, opt) => | |
1012 | {arg = arg, desc = desc, name = name, opt = opt, style = style}) | |
1013 | end | |
1014 | ||
1015 | val mainUsage = "mlprof [option ...] a.out [mlmon.out ...]" | |
1016 | val {parse, usage} = | |
1017 | Popt.makeUsage {mainUsage = mainUsage, | |
1018 | makeOptions = makeOptions, | |
1019 | showExpert = fn () => false} | |
1020 | ||
1021 | val die = Process.fail | |
1022 | ||
1023 | fun commandLine args = | |
1024 | let | |
1025 | val rest = parse args | |
1026 | in | |
1027 | case rest of | |
1028 | Result.No msg => usage msg | |
1029 | | Result.Yes (afile :: files) => | |
1030 | let | |
1031 | val mlmonFiles = files @ !mlmonFiles | |
1032 | val aInfo = AFile.new {afile = afile} | |
1033 | val _ = | |
1034 | if debug | |
1035 | then | |
1036 | (print "AFile:\n" | |
1037 | ; Layout.outputl (AFile.layout aInfo, Out.standard)) | |
1038 | else () | |
1039 | val profFile = | |
1040 | List.fold | |
1041 | (mlmonFiles, ProfFile.empty aInfo, | |
1042 | fn (mlmonfile, profFile) => | |
1043 | ProfFile.merge | |
1044 | (profFile, ProfFile.new {mlmonfile = mlmonfile}) | |
1045 | handle e => | |
1046 | let | |
1047 | val msg = | |
1048 | concat ["Error loading mlmon file '", mlmonfile, | |
1049 | "': ", Exn.toString e] | |
1050 | in | |
1051 | if !tolerant | |
1052 | then | |
1053 | (Out.outputl (Out.error, msg) | |
1054 | ; profFile) | |
1055 | else die msg | |
1056 | end) | |
1057 | val _ = | |
1058 | if debug | |
1059 | then | |
1060 | (print "ProfFile:\n" | |
1061 | ; Layout.outputl (ProfFile.layout profFile, | |
1062 | Out.standard)) | |
1063 | else () | |
1064 | val _ = display (aInfo, profFile) | |
1065 | in | |
1066 | () | |
1067 | end | |
1068 | | Result.Yes _ => usage "wrong number of args" | |
1069 | end | |
1070 | ||
1071 | val main = Process.makeMain commandLine | |
1072 | ||
1073 | end |