| 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 |