HCoop / hcoop / debian / mlton.git / blob
? search:
summary | shortlog | log | commit | commitdiff | tree
blame | history | raw | HEAD
Import Debian changes 20180207-1
[hcoop/debian/mlton.git] / mlprof / main.sml
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 print
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
mlton packaging