github.com/xushiwei/go@v0.0.0-20130601165731-2b9d83f45bc9/misc/pprof (about) 1 #! /usr/bin/env perl 2 3 # This is a copy of http://google-perftools.googlecode.com/svn/trunk/src/pprof 4 # with local modifications to handle generation of SVG images and 5 # the Go-style pprof paths. These modifications will probably filter 6 # back into the official source before long. 7 # It's convenient to have a copy here because we need just the one 8 # Perl script, not all the C++ libraries that surround it. 9 10 # Copyright (c) 1998-2007, Google Inc. 11 # All rights reserved. 12 # 13 # Redistribution and use in source and binary forms, with or without 14 # modification, are permitted provided that the following conditions are 15 # met: 16 # 17 # * Redistributions of source code must retain the above copyright 18 # notice, this list of conditions and the following disclaimer. 19 # * Redistributions in binary form must reproduce the above 20 # copyright notice, this list of conditions and the following disclaimer 21 # in the documentation and/or other materials provided with the 22 # distribution. 23 # * Neither the name of Google Inc. nor the names of its 24 # contributors may be used to endorse or promote products derived from 25 # this software without specific prior written permission. 26 # 27 # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 28 # "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 29 # LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 30 # A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 31 # OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 32 # SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 33 # LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 34 # DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 35 # THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 36 # (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 37 # OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 38 39 # --- 40 # Program for printing the profile generated by common/profiler.cc, 41 # or by the heap profiler (common/debugallocation.cc) 42 # 43 # The profile contains a sequence of entries of the form: 44 # <count> <stack trace> 45 # This program parses the profile, and generates user-readable 46 # output. 47 # 48 # Examples: 49 # 50 # % tools/pprof "program" "profile" 51 # Enters "interactive" mode 52 # 53 # % tools/pprof --text "program" "profile" 54 # Generates one line per procedure 55 # 56 # % tools/pprof --gv "program" "profile" 57 # Generates annotated call-graph and displays via "gv" 58 # 59 # % tools/pprof --gv --focus=Mutex "program" "profile" 60 # Restrict to code paths that involve an entry that matches "Mutex" 61 # 62 # % tools/pprof --gv --focus=Mutex --ignore=string "program" "profile" 63 # Restrict to code paths that involve an entry that matches "Mutex" 64 # and does not match "string" 65 # 66 # % tools/pprof --list=IBF_CheckDocid "program" "profile" 67 # Generates disassembly listing of all routines with at least one 68 # sample that match the --list=<regexp> pattern. The listing is 69 # annotated with the flat and cumulative sample counts at each line. 70 # 71 # % tools/pprof --disasm=IBF_CheckDocid "program" "profile" 72 # Generates disassembly listing of all routines with at least one 73 # sample that match the --disasm=<regexp> pattern. The listing is 74 # annotated with the flat and cumulative sample counts at each PC value. 75 # 76 # TODO: Use color to indicate files? 77 78 use strict; 79 use warnings; 80 use Getopt::Long; 81 82 my $PPROF_VERSION = "1.5"; 83 84 # NOTE: All mentions of c++filt have been expunged from this script 85 # because (1) we don't use C++, and (2) the copy of c++filt that ships 86 # on OS X is from 2007 and destroys nm output by "demangling" the 87 # first two columns (address and symbol type). 88 89 # These are the object tools we use which can come from a 90 # user-specified location using --tools, from the PPROF_TOOLS 91 # environment variable, or from the environment. 92 my %obj_tool_map = ( 93 "objdump" => "objdump", 94 "nm" => "nm", 95 "addr2line" => "addr2line", 96 ## ConfigureObjTools may add architecture-specific entries: 97 #"nm_pdb" => "nm-pdb", # for reading windows (PDB-format) executables 98 #"addr2line_pdb" => "addr2line-pdb", # ditto 99 #"otool" => "otool", # equivalent of objdump on OS X 100 ); 101 my $DOT = "dot"; # leave non-absolute, since it may be in /usr/local 102 my $GV = "gv"; 103 my $KCACHEGRIND = "kcachegrind"; 104 my $PS2PDF = "ps2pdf"; 105 # These are used for dynamic profiles 106 my $CURL = "curl"; 107 108 # These are the web pages that servers need to support for dynamic profiles 109 my $HEAP_PAGE = "/pprof/heap"; 110 my $THREAD_PAGE = "/pprof/thread"; 111 my $PROFILE_PAGE = "/pprof/profile"; # must support cgi-param "?seconds=#" 112 my $PMUPROFILE_PAGE = "/pprof/pmuprofile(?:\\?.*)?"; # must support cgi-param 113 # ?seconds=#&event=x&period=n 114 my $GROWTH_PAGE = "/pprof/growth"; 115 my $CONTENTION_PAGE = "/pprof/contention"; 116 my $WALL_PAGE = "/pprof/wall(?:\\?.*)?"; # accepts options like namefilter 117 my $FILTEREDPROFILE_PAGE = "/pprof/filteredprofile(?:\\?.*)?"; 118 my $SYMBOL_PAGE = "/pprof/symbol"; # must support symbol lookup via POST 119 my $PROGRAM_NAME_PAGE = "/pprof/cmdline"; 120 121 # default binary name 122 my $UNKNOWN_BINARY = "(unknown)"; 123 124 # There is a pervasive dependency on the length (in hex characters, 125 # i.e., nibbles) of an address, distinguishing between 32-bit and 126 # 64-bit profiles. To err on the safe size, default to 64-bit here: 127 my $address_length = 16; 128 129 # A list of paths to search for shared object files 130 my @prefix_list = (); 131 132 # Special routine name that should not have any symbols. 133 # Used as separator to parse "addr2line -i" output. 134 my $sep_symbol = '_fini'; 135 my $sep_address = undef; 136 137 ##### Argument parsing ##### 138 139 sub usage_string { 140 return <<EOF; 141 Usage: 142 pprof [options] <program> <profiles> 143 <profiles> is a space separated list of profile names. 144 pprof [options] <symbolized-profiles> 145 <symbolized-profiles> is a list of profile files where each file contains 146 the necessary symbol mappings as well as profile data (likely generated 147 with --raw). 148 pprof [options] <profile> 149 <profile> is a remote form. Symbols are obtained from host:port$SYMBOL_PAGE 150 151 Each name can be: 152 /path/to/profile - a path to a profile file 153 host:port[/<service>] - a location of a service to get profile from 154 155 The /<service> can be $HEAP_PAGE, $PROFILE_PAGE, /pprof/pmuprofile, 156 $GROWTH_PAGE, $CONTENTION_PAGE, /pprof/wall, 157 $THREAD_PAGE, or /pprof/filteredprofile. 158 For instance: 159 pprof http://myserver.com:80$HEAP_PAGE 160 If /<service> is omitted, the service defaults to $PROFILE_PAGE (cpu profiling). 161 pprof --symbols <program> 162 Maps addresses to symbol names. In this mode, stdin should be a 163 list of library mappings, in the same format as is found in the heap- 164 and cpu-profile files (this loosely matches that of /proc/self/maps 165 on linux), followed by a list of hex addresses to map, one per line. 166 167 For more help with querying remote servers, including how to add the 168 necessary server-side support code, see this filename (or one like it): 169 170 /usr/doc/google-perftools-$PPROF_VERSION/pprof_remote_servers.html 171 172 Options: 173 --cum Sort by cumulative data 174 --base=<base> Subtract <base> from <profile> before display 175 --interactive Run in interactive mode (interactive "help" gives help) [default] 176 --seconds=<n> Length of time for dynamic profiles [default=30 secs] 177 --add_lib=<file> Read additional symbols and line info from the given library 178 --lib_prefix=<dir> Comma separated list of library path prefixes 179 180 Reporting Granularity: 181 --addresses Report at address level 182 --lines Report at source line level 183 --functions Report at function level [default] 184 --files Report at source file level 185 186 Output type: 187 --text Generate text report 188 --callgrind Generate callgrind format to stdout 189 --gv Generate Postscript and display 190 --web Generate SVG and display 191 --list=<regexp> Generate source listing of matching routines 192 --disasm=<regexp> Generate disassembly of matching routines 193 --symbols Print demangled symbol names found at given addresses 194 --dot Generate DOT file to stdout 195 --ps Generate Postcript to stdout 196 --pdf Generate PDF to stdout 197 --svg Generate SVG to stdout 198 --gif Generate GIF to stdout 199 --raw Generate symbolized pprof data (useful with remote fetch) 200 201 Heap-Profile Options: 202 --inuse_space Display in-use (mega)bytes [default] 203 --inuse_objects Display in-use objects 204 --alloc_space Display allocated (mega)bytes 205 --alloc_objects Display allocated objects 206 --show_bytes Display space in bytes 207 --drop_negative Ignore negative differences 208 209 Contention-profile options: 210 --total_delay Display total delay at each region [default] 211 --contentions Display number of delays at each region 212 --mean_delay Display mean delay at each region 213 214 Call-graph Options: 215 --nodecount=<n> Show at most so many nodes [default=80] 216 --nodefraction=<f> Hide nodes below <f>*total [default=.005] 217 --edgefraction=<f> Hide edges below <f>*total [default=.001] 218 --focus=<regexp> Focus on nodes matching <regexp> 219 --ignore=<regexp> Ignore nodes matching <regexp> 220 --scale=<n> Set GV scaling [default=0] 221 --heapcheck Make nodes with non-0 object counts 222 (i.e. direct leak generators) more visible 223 224 Miscellaneous: 225 --tools=<prefix> Prefix for object tool pathnames 226 --test Run unit tests 227 --help This message 228 --version Version information 229 230 Environment Variables: 231 PPROF_TMPDIR Profiles directory. Defaults to \$HOME/pprof 232 PPROF_TOOLS Prefix for object tools pathnames 233 234 Examples: 235 236 pprof /bin/ls ls.prof 237 Enters "interactive" mode 238 pprof --text /bin/ls ls.prof 239 Outputs one line per procedure 240 pprof --web /bin/ls ls.prof 241 Displays annotated call-graph in web browser 242 pprof --gv /bin/ls ls.prof 243 Displays annotated call-graph via 'gv' 244 pprof --gv --focus=Mutex /bin/ls ls.prof 245 Restricts to code paths including a .*Mutex.* entry 246 pprof --gv --focus=Mutex --ignore=string /bin/ls ls.prof 247 Code paths including Mutex but not string 248 pprof --list=getdir /bin/ls ls.prof 249 (Per-line) annotated source listing for getdir() 250 pprof --disasm=getdir /bin/ls ls.prof 251 (Per-PC) annotated disassembly for getdir() 252 253 pprof http://localhost:1234/ 254 Enters "interactive" mode 255 pprof --text localhost:1234 256 Outputs one line per procedure for localhost:1234 257 pprof --raw localhost:1234 > ./local.raw 258 pprof --text ./local.raw 259 Fetches a remote profile for later analysis and then 260 analyzes it in text mode. 261 EOF 262 } 263 264 sub version_string { 265 return <<EOF 266 pprof (part of google-perftools $PPROF_VERSION) 267 268 Copyright 1998-2007 Google Inc. 269 270 This is BSD licensed software; see the source for copying conditions 271 and license information. 272 There is NO warranty; not even for MERCHANTABILITY or FITNESS FOR A 273 PARTICULAR PURPOSE. 274 EOF 275 } 276 277 sub usage { 278 my $msg = shift; 279 print STDERR "$msg\n\n"; 280 print STDERR usage_string(); 281 print STDERR "\nFATAL ERROR: $msg\n"; # just as a reminder 282 exit(1); 283 } 284 285 sub Init() { 286 # Setup tmp-file name and handler to clean it up. 287 # We do this in the very beginning so that we can use 288 # error() and cleanup() function anytime here after. 289 $main::tmpfile_sym = "/tmp/pprof$$.sym"; 290 $main::tmpfile_ps = "/tmp/pprof$$"; 291 $main::next_tmpfile = 0; 292 $SIG{'INT'} = \&sighandler; 293 294 # Cache from filename/linenumber to source code 295 $main::source_cache = (); 296 297 $main::opt_help = 0; 298 $main::opt_version = 0; 299 300 $main::opt_cum = 0; 301 $main::opt_base = ''; 302 $main::opt_addresses = 0; 303 $main::opt_lines = 0; 304 $main::opt_functions = 0; 305 $main::opt_files = 0; 306 $main::opt_lib_prefix = ""; 307 308 $main::opt_text = 0; 309 $main::opt_callgrind = 0; 310 $main::opt_list = ""; 311 $main::opt_disasm = ""; 312 $main::opt_symbols = 0; 313 $main::opt_gv = 0; 314 $main::opt_web = 0; 315 $main::opt_dot = 0; 316 $main::opt_ps = 0; 317 $main::opt_pdf = 0; 318 $main::opt_gif = 0; 319 $main::opt_svg = 0; 320 $main::opt_raw = 0; 321 322 $main::opt_nodecount = 80; 323 $main::opt_nodefraction = 0.005; 324 $main::opt_edgefraction = 0.001; 325 $main::opt_focus = ''; 326 $main::opt_ignore = ''; 327 $main::opt_scale = 0; 328 $main::opt_heapcheck = 0; 329 $main::opt_seconds = 30; 330 $main::opt_lib = ""; 331 332 $main::opt_inuse_space = 0; 333 $main::opt_inuse_objects = 0; 334 $main::opt_alloc_space = 0; 335 $main::opt_alloc_objects = 0; 336 $main::opt_show_bytes = 0; 337 $main::opt_drop_negative = 0; 338 $main::opt_interactive = 0; 339 340 $main::opt_total_delay = 0; 341 $main::opt_contentions = 0; 342 $main::opt_mean_delay = 0; 343 344 $main::opt_tools = ""; 345 $main::opt_debug = 0; 346 $main::opt_test = 0; 347 348 # These are undocumented flags used only by unittests. 349 $main::opt_test_stride = 0; 350 351 # Are we using $SYMBOL_PAGE? 352 $main::use_symbol_page = 0; 353 354 # Files returned by TempName. 355 %main::tempnames = (); 356 357 # Type of profile we are dealing with 358 # Supported types: 359 # cpu 360 # heap 361 # growth 362 # contention 363 $main::profile_type = ''; # Empty type means "unknown" 364 365 GetOptions("help!" => \$main::opt_help, 366 "version!" => \$main::opt_version, 367 "cum!" => \$main::opt_cum, 368 "base=s" => \$main::opt_base, 369 "seconds=i" => \$main::opt_seconds, 370 "add_lib=s" => \$main::opt_lib, 371 "lib_prefix=s" => \$main::opt_lib_prefix, 372 "functions!" => \$main::opt_functions, 373 "lines!" => \$main::opt_lines, 374 "addresses!" => \$main::opt_addresses, 375 "files!" => \$main::opt_files, 376 "text!" => \$main::opt_text, 377 "callgrind!" => \$main::opt_callgrind, 378 "list=s" => \$main::opt_list, 379 "disasm=s" => \$main::opt_disasm, 380 "symbols!" => \$main::opt_symbols, 381 "gv!" => \$main::opt_gv, 382 "web!" => \$main::opt_web, 383 "dot!" => \$main::opt_dot, 384 "ps!" => \$main::opt_ps, 385 "pdf!" => \$main::opt_pdf, 386 "svg!" => \$main::opt_svg, 387 "gif!" => \$main::opt_gif, 388 "raw!" => \$main::opt_raw, 389 "interactive!" => \$main::opt_interactive, 390 "nodecount=i" => \$main::opt_nodecount, 391 "nodefraction=f" => \$main::opt_nodefraction, 392 "edgefraction=f" => \$main::opt_edgefraction, 393 "focus=s" => \$main::opt_focus, 394 "ignore=s" => \$main::opt_ignore, 395 "scale=i" => \$main::opt_scale, 396 "heapcheck" => \$main::opt_heapcheck, 397 "inuse_space!" => \$main::opt_inuse_space, 398 "inuse_objects!" => \$main::opt_inuse_objects, 399 "alloc_space!" => \$main::opt_alloc_space, 400 "alloc_objects!" => \$main::opt_alloc_objects, 401 "show_bytes!" => \$main::opt_show_bytes, 402 "drop_negative!" => \$main::opt_drop_negative, 403 "total_delay!" => \$main::opt_total_delay, 404 "contentions!" => \$main::opt_contentions, 405 "mean_delay!" => \$main::opt_mean_delay, 406 "tools=s" => \$main::opt_tools, 407 "test!" => \$main::opt_test, 408 "debug!" => \$main::opt_debug, 409 # Undocumented flags used only by unittests: 410 "test_stride=i" => \$main::opt_test_stride, 411 ) || usage("Invalid option(s)"); 412 413 # Deal with the standard --help and --version 414 if ($main::opt_help) { 415 print usage_string(); 416 exit(0); 417 } 418 419 if ($main::opt_version) { 420 print version_string(); 421 exit(0); 422 } 423 424 # Disassembly/listing/symbols mode requires address-level info 425 if ($main::opt_disasm || $main::opt_list || $main::opt_symbols) { 426 $main::opt_functions = 0; 427 $main::opt_lines = 0; 428 $main::opt_addresses = 1; 429 $main::opt_files = 0; 430 } 431 432 # Check heap-profiling flags 433 if ($main::opt_inuse_space + 434 $main::opt_inuse_objects + 435 $main::opt_alloc_space + 436 $main::opt_alloc_objects > 1) { 437 usage("Specify at most on of --inuse/--alloc options"); 438 } 439 440 # Check output granularities 441 my $grains = 442 $main::opt_functions + 443 $main::opt_lines + 444 $main::opt_addresses + 445 $main::opt_files + 446 0; 447 if ($grains > 1) { 448 usage("Only specify one output granularity option"); 449 } 450 if ($grains == 0) { 451 $main::opt_functions = 1; 452 } 453 454 # Check output modes 455 my $modes = 456 $main::opt_text + 457 $main::opt_callgrind + 458 ($main::opt_list eq '' ? 0 : 1) + 459 ($main::opt_disasm eq '' ? 0 : 1) + 460 ($main::opt_symbols == 0 ? 0 : 1) + 461 $main::opt_gv + 462 $main::opt_web + 463 $main::opt_dot + 464 $main::opt_ps + 465 $main::opt_pdf + 466 $main::opt_svg + 467 $main::opt_gif + 468 $main::opt_raw + 469 $main::opt_interactive + 470 0; 471 if ($modes > 1) { 472 usage("Only specify one output mode"); 473 } 474 if ($modes == 0) { 475 if (-t STDOUT) { # If STDOUT is a tty, activate interactive mode 476 $main::opt_interactive = 1; 477 } else { 478 $main::opt_text = 1; 479 } 480 } 481 482 if ($main::opt_test) { 483 RunUnitTests(); 484 # Should not return 485 exit(1); 486 } 487 488 # Binary name and profile arguments list 489 $main::prog = ""; 490 @main::pfile_args = (); 491 492 # Remote profiling without a binary (using $SYMBOL_PAGE instead) 493 if (IsProfileURL($ARGV[0])) { 494 $main::use_symbol_page = 1; 495 } elsif (IsSymbolizedProfileFile($ARGV[0])) { 496 $main::use_symbolized_profile = 1; 497 $main::prog = $UNKNOWN_BINARY; # will be set later from the profile file 498 } 499 500 if ($main::use_symbol_page || $main::use_symbolized_profile) { 501 # We don't need a binary! 502 my %disabled = ('--lines' => $main::opt_lines, 503 '--disasm' => $main::opt_disasm); 504 for my $option (keys %disabled) { 505 usage("$option cannot be used without a binary") if $disabled{$option}; 506 } 507 # Set $main::prog later... 508 scalar(@ARGV) || usage("Did not specify profile file"); 509 } elsif ($main::opt_symbols) { 510 # --symbols needs a binary-name (to run nm on, etc) but not profiles 511 $main::prog = shift(@ARGV) || usage("Did not specify program"); 512 } else { 513 $main::prog = shift(@ARGV) || usage("Did not specify program"); 514 scalar(@ARGV) || usage("Did not specify profile file"); 515 } 516 517 # Parse profile file/location arguments 518 foreach my $farg (@ARGV) { 519 if ($farg =~ m/(.*)\@([0-9]+)(|\/.*)$/ ) { 520 my $machine = $1; 521 my $num_machines = $2; 522 my $path = $3; 523 for (my $i = 0; $i < $num_machines; $i++) { 524 unshift(@main::pfile_args, "$i.$machine$path"); 525 } 526 } else { 527 unshift(@main::pfile_args, $farg); 528 } 529 } 530 531 if ($main::use_symbol_page) { 532 unless (IsProfileURL($main::pfile_args[0])) { 533 error("The first profile should be a remote form to use $SYMBOL_PAGE\n"); 534 } 535 CheckSymbolPage(); 536 $main::prog = FetchProgramName(); 537 } elsif (!$main::use_symbolized_profile) { # may not need objtools! 538 ConfigureObjTools($main::prog) 539 } 540 541 # Break the opt_lib_prefix into the prefix_list array 542 @prefix_list = split (',', $main::opt_lib_prefix); 543 544 # Remove trailing / from the prefixes, in the list to prevent 545 # searching things like /my/path//lib/mylib.so 546 foreach (@prefix_list) { 547 s|/+$||; 548 } 549 } 550 551 sub Main() { 552 Init(); 553 $main::collected_profile = undef; 554 @main::profile_files = (); 555 $main::op_time = time(); 556 557 # Printing symbols is special and requires a lot less info that most. 558 if ($main::opt_symbols) { 559 PrintSymbols(*STDIN); # Get /proc/maps and symbols output from stdin 560 return; 561 } 562 563 # Fetch all profile data 564 FetchDynamicProfiles(); 565 566 # this will hold symbols that we read from the profile files 567 my $symbol_map = {}; 568 569 # Read one profile, pick the last item on the list 570 my $data = ReadProfile($main::prog, pop(@main::profile_files)); 571 my $profile = $data->{profile}; 572 my $pcs = $data->{pcs}; 573 my $libs = $data->{libs}; # Info about main program and shared libraries 574 $symbol_map = MergeSymbols($symbol_map, $data->{symbols}); 575 576 # Add additional profiles, if available. 577 if (scalar(@main::profile_files) > 0) { 578 foreach my $pname (@main::profile_files) { 579 my $data2 = ReadProfile($main::prog, $pname); 580 $profile = AddProfile($profile, $data2->{profile}); 581 $pcs = AddPcs($pcs, $data2->{pcs}); 582 $symbol_map = MergeSymbols($symbol_map, $data2->{symbols}); 583 } 584 } 585 586 # Subtract base from profile, if specified 587 if ($main::opt_base ne '') { 588 my $base = ReadProfile($main::prog, $main::opt_base); 589 $profile = SubtractProfile($profile, $base->{profile}); 590 $pcs = AddPcs($pcs, $base->{pcs}); 591 $symbol_map = MergeSymbols($symbol_map, $base->{symbols}); 592 } 593 594 # Get total data in profile 595 my $total = TotalProfile($profile); 596 597 # Collect symbols 598 my $symbols; 599 if ($main::use_symbolized_profile) { 600 $symbols = FetchSymbols($pcs, $symbol_map); 601 } elsif ($main::use_symbol_page) { 602 $symbols = FetchSymbols($pcs); 603 } else { 604 $symbols = ExtractSymbols($libs, $pcs); 605 } 606 607 # Remove uniniteresting stack items 608 $profile = RemoveUninterestingFrames($symbols, $profile); 609 610 # Focus? 611 if ($main::opt_focus ne '') { 612 $profile = FocusProfile($symbols, $profile, $main::opt_focus); 613 } 614 615 # Ignore? 616 if ($main::opt_ignore ne '') { 617 $profile = IgnoreProfile($symbols, $profile, $main::opt_ignore); 618 } 619 620 my $calls = ExtractCalls($symbols, $profile); 621 622 # Reduce profiles to required output granularity, and also clean 623 # each stack trace so a given entry exists at most once. 624 my $reduced = ReduceProfile($symbols, $profile); 625 626 # Get derived profiles 627 my $flat = FlatProfile($reduced); 628 my $cumulative = CumulativeProfile($reduced); 629 630 # Print 631 if (!$main::opt_interactive) { 632 if ($main::opt_disasm) { 633 PrintDisassembly($libs, $flat, $cumulative, $main::opt_disasm, $total); 634 } elsif ($main::opt_list) { 635 PrintListing($total, $libs, $flat, $cumulative, $main::opt_list, 0); 636 } elsif ($main::opt_text) { 637 # Make sure the output is empty when have nothing to report 638 # (only matters when --heapcheck is given but we must be 639 # compatible with old branches that did not pass --heapcheck always): 640 if ($total != 0) { 641 Infof("Total: %s %s\n", Unparse($total), Units()); 642 } 643 PrintText($symbols, $flat, $cumulative, $total, -1); 644 } elsif ($main::opt_raw) { 645 PrintSymbolizedProfile($symbols, $profile, $main::prog); 646 } elsif ($main::opt_callgrind) { 647 PrintCallgrind($calls); 648 } else { 649 if (PrintDot($main::prog, $symbols, $profile, $flat, $cumulative, $total)) { 650 if ($main::opt_gv) { 651 RunGV(TempName($main::next_tmpfile, "ps"), ""); 652 } elsif ($main::opt_web) { 653 my $tmp = TempName($main::next_tmpfile, "svg"); 654 RunWeb($tmp); 655 # The command we run might hand the file name off 656 # to an already running browser instance and then exit. 657 # Normally, we'd remove $tmp on exit (right now), 658 # but fork a child to remove $tmp a little later, so that the 659 # browser has time to load it first. 660 delete $main::tempnames{$tmp}; 661 if (fork() == 0) { 662 sleep 5; 663 unlink($tmp); 664 exit(0); 665 } 666 } 667 } else { 668 exit(1); 669 } 670 } 671 } else { 672 InteractiveMode($profile, $symbols, $libs, $total); 673 } 674 675 cleanup(); 676 exit(0); 677 } 678 679 ##### Entry Point ##### 680 681 Main(); 682 683 # Temporary code to detect if we're running on a Goobuntu system. 684 # These systems don't have the right stuff installed for the special 685 # Readline libraries to work, so as a temporary workaround, we default 686 # to using the normal stdio code, rather than the fancier readline-based 687 # code 688 sub ReadlineMightFail { 689 if (-e '/lib/libtermcap.so.2') { 690 return 0; # libtermcap exists, so readline should be okay 691 } else { 692 return 1; 693 } 694 } 695 696 sub RunGV { 697 my $fname = shift; 698 my $bg = shift; # "" or " &" if we should run in background 699 if (!system("$GV --version >/dev/null 2>&1")) { 700 # Options using double dash are supported by this gv version. 701 # Also, turn on noantialias to better handle bug in gv for 702 # postscript files with large dimensions. 703 # TODO: Maybe we should not pass the --noantialias flag 704 # if the gv version is known to work properly without the flag. 705 system("$GV --scale=$main::opt_scale --noantialias " . $fname . $bg); 706 } else { 707 # Old gv version - only supports options that use single dash. 708 print STDERR "$GV -scale $main::opt_scale\n"; 709 system("$GV -scale $main::opt_scale " . $fname . $bg); 710 } 711 } 712 713 sub RunWeb { 714 my $fname = shift; 715 print STDERR "Loading web page file:///$fname\n"; 716 717 if (`uname` =~ /Darwin/) { 718 # OS X: open will use standard preference for SVG files. 719 system("/usr/bin/open", $fname); 720 return; 721 } 722 723 # Some kind of Unix; try generic symlinks, then specific browsers. 724 # (Stop once we find one.) 725 # Works best if the browser is already running. 726 my @alt = ( 727 "/etc/alternatives/gnome-www-browser", 728 "/etc/alternatives/x-www-browser", 729 "google-chrome", 730 "firefox", 731 ); 732 foreach my $b (@alt) { 733 if (system($b, $fname) == 0) { 734 return; 735 } 736 } 737 738 print STDERR "Could not load web browser.\n"; 739 } 740 741 sub RunKcachegrind { 742 my $fname = shift; 743 my $bg = shift; # "" or " &" if we should run in background 744 print STDERR "Starting '$KCACHEGRIND " . $fname . $bg . "'\n"; 745 system("$KCACHEGRIND " . $fname . $bg); 746 } 747 748 749 ##### Interactive helper routines ##### 750 751 sub InteractiveMode { 752 $| = 1; # Make output unbuffered for interactive mode 753 my ($orig_profile, $symbols, $libs, $total) = @_; 754 755 print STDERR "Welcome to pprof! For help, type 'help'.\n"; 756 757 # Use ReadLine if it's installed and input comes from a console. 758 if ( -t STDIN && 759 !ReadlineMightFail() && 760 defined(eval {require Term::ReadLine}) ) { 761 my $term = new Term::ReadLine 'pprof'; 762 while ( defined ($_ = $term->readline('(pprof) '))) { 763 $term->addhistory($_) if /\S/; 764 if (!InteractiveCommand($orig_profile, $symbols, $libs, $total, $_)) { 765 last; # exit when we get an interactive command to quit 766 } 767 } 768 } else { # don't have readline 769 while (1) { 770 print STDERR "(pprof) "; 771 $_ = <STDIN>; 772 last if ! defined $_ ; 773 s/\r//g; # turn windows-looking lines into unix-looking lines 774 775 # Save some flags that might be reset by InteractiveCommand() 776 my $save_opt_lines = $main::opt_lines; 777 778 if (!InteractiveCommand($orig_profile, $symbols, $libs, $total, $_)) { 779 last; # exit when we get an interactive command to quit 780 } 781 782 # Restore flags 783 $main::opt_lines = $save_opt_lines; 784 } 785 } 786 } 787 788 # Takes two args: orig profile, and command to run. 789 # Returns 1 if we should keep going, or 0 if we were asked to quit 790 sub InteractiveCommand { 791 my($orig_profile, $symbols, $libs, $total, $command) = @_; 792 $_ = $command; # just to make future m//'s easier 793 if (!defined($_)) { 794 print STDERR "\n"; 795 return 0; 796 } 797 if (m/^\s*quit/) { 798 return 0; 799 } 800 if (m/^\s*help/) { 801 InteractiveHelpMessage(); 802 return 1; 803 } 804 # Clear all the mode options -- mode is controlled by "$command" 805 $main::opt_text = 0; 806 $main::opt_callgrind = 0; 807 $main::opt_disasm = 0; 808 $main::opt_list = 0; 809 $main::opt_gv = 0; 810 $main::opt_cum = 0; 811 812 if (m/^\s*(text|top)(\d*)\s*(.*)/) { 813 $main::opt_text = 1; 814 815 my $line_limit = ($2 ne "") ? int($2) : 10; 816 817 my $routine; 818 my $ignore; 819 ($routine, $ignore) = ParseInteractiveArgs($3); 820 821 my $profile = ProcessProfile($total, $orig_profile, $symbols, "", $ignore); 822 my $reduced = ReduceProfile($symbols, $profile); 823 824 # Get derived profiles 825 my $flat = FlatProfile($reduced); 826 my $cumulative = CumulativeProfile($reduced); 827 828 PrintText($symbols, $flat, $cumulative, $total, $line_limit); 829 return 1; 830 } 831 if (m/^\s*callgrind\s*([^ \n]*)/) { 832 $main::opt_callgrind = 1; 833 834 # Get derived profiles 835 my $calls = ExtractCalls($symbols, $orig_profile); 836 my $filename = $1; 837 if ( $1 eq '' ) { 838 $filename = TempName($main::next_tmpfile, "callgrind"); 839 } 840 PrintCallgrind($calls, $filename); 841 if ( $1 eq '' ) { 842 RunKcachegrind($filename, " & "); 843 $main::next_tmpfile++; 844 } 845 846 return 1; 847 } 848 if (m/^\s*(web)?list\s*(.+)/) { 849 my $html = (defined($1) && ($1 eq "web")); 850 $main::opt_list = 1; 851 852 my $routine; 853 my $ignore; 854 ($routine, $ignore) = ParseInteractiveArgs($2); 855 856 my $profile = ProcessProfile($total, $orig_profile, $symbols, "", $ignore); 857 my $reduced = ReduceProfile($symbols, $profile); 858 859 # Get derived profiles 860 my $flat = FlatProfile($reduced); 861 my $cumulative = CumulativeProfile($reduced); 862 863 PrintListing($total, $libs, $flat, $cumulative, $routine, $html); 864 return 1; 865 } 866 if (m/^\s*disasm\s*(.+)/) { 867 $main::opt_disasm = 1; 868 869 my $routine; 870 my $ignore; 871 ($routine, $ignore) = ParseInteractiveArgs($1); 872 873 # Process current profile to account for various settings 874 my $profile = ProcessProfile($total, $orig_profile, $symbols, "", $ignore); 875 my $reduced = ReduceProfile($symbols, $profile); 876 877 # Get derived profiles 878 my $flat = FlatProfile($reduced); 879 my $cumulative = CumulativeProfile($reduced); 880 881 PrintDisassembly($libs, $flat, $cumulative, $routine, $total); 882 return 1; 883 } 884 if (m/^\s*(gv|web)\s*(.*)/) { 885 $main::opt_gv = 0; 886 $main::opt_web = 0; 887 if ($1 eq "gv") { 888 $main::opt_gv = 1; 889 } elsif ($1 eq "web") { 890 $main::opt_web = 1; 891 } 892 893 my $focus; 894 my $ignore; 895 ($focus, $ignore) = ParseInteractiveArgs($2); 896 897 # Process current profile to account for various settings 898 my $profile = ProcessProfile($total, $orig_profile, $symbols, $focus, $ignore); 899 my $reduced = ReduceProfile($symbols, $profile); 900 901 # Get derived profiles 902 my $flat = FlatProfile($reduced); 903 my $cumulative = CumulativeProfile($reduced); 904 905 if (PrintDot($main::prog, $symbols, $profile, $flat, $cumulative, $total)) { 906 if ($main::opt_gv) { 907 RunGV(TempName($main::next_tmpfile, "ps"), " &"); 908 } elsif ($main::opt_web) { 909 RunWeb(TempName($main::next_tmpfile, "svg")); 910 } 911 $main::next_tmpfile++; 912 } 913 return 1; 914 } 915 if (m/^\s*$/) { 916 return 1; 917 } 918 print STDERR "Unknown command: try 'help'.\n"; 919 return 1; 920 } 921 922 923 sub ProcessProfile { 924 my $total_count = shift; 925 my $orig_profile = shift; 926 my $symbols = shift; 927 my $focus = shift; 928 my $ignore = shift; 929 930 # Process current profile to account for various settings 931 my $profile = $orig_profile; 932 printf("Total: %s %s\n", Unparse($total_count), Units()); 933 if ($focus ne '') { 934 $profile = FocusProfile($symbols, $profile, $focus); 935 my $focus_count = TotalProfile($profile); 936 Infof("After focusing on '%s': %s %s of %s (%0.1f%%)\n", 937 $focus, 938 Unparse($focus_count), Units(), 939 Unparse($total_count), ($focus_count*100.0) / $total_count); 940 } 941 if ($ignore ne '') { 942 $profile = IgnoreProfile($symbols, $profile, $ignore); 943 my $ignore_count = TotalProfile($profile); 944 Infof("After ignoring '%s': %s %s of %s (%0.1f%%)\n", 945 $ignore, 946 Unparse($ignore_count), Units(), 947 Unparse($total_count), 948 ($ignore_count*100.0) / $total_count); 949 } 950 951 return $profile; 952 } 953 954 sub InteractiveHelpMessage { 955 print STDERR <<ENDOFHELP; 956 Interactive pprof mode 957 958 Commands: 959 gv 960 gv [focus] [-ignore1] [-ignore2] 961 Show graphical hierarchical display of current profile. Without 962 any arguments, shows all samples in the profile. With the optional 963 "focus" argument, restricts the samples shown to just those where 964 the "focus" regular expression matches a routine name on the stack 965 trace. 966 967 web 968 web [focus] [-ignore1] [-ignore2] 969 Like GV, but displays profile in your web browser instead of using 970 Ghostview. Works best if your web browser is already running. 971 To change the browser that gets used: 972 On Linux, set the /etc/alternatives/gnome-www-browser symlink. 973 On OS X, change the Finder association for SVG files. 974 975 list [routine_regexp] [-ignore1] [-ignore2] 976 Show source listing of routines whose names match "routine_regexp" 977 978 weblist [routine_regexp] [-ignore1] [-ignore2] 979 Displays a source listing of routines whose names match "routine_regexp" 980 in a web browser. You can click on source lines to view the 981 corresponding disassembly. 982 983 top [--cum] [-ignore1] [-ignore2] 984 top20 [--cum] [-ignore1] [-ignore2] 985 top37 [--cum] [-ignore1] [-ignore2] 986 Show top lines ordered by flat profile count, or cumulative count 987 if --cum is specified. If a number is present after 'top', the 988 top K routines will be shown (defaults to showing the top 10) 989 990 disasm [routine_regexp] [-ignore1] [-ignore2] 991 Show disassembly of routines whose names match "routine_regexp", 992 annotated with sample counts. 993 994 callgrind 995 callgrind [filename] 996 Generates callgrind file. If no filename is given, kcachegrind is called. 997 998 help - This listing 999 quit or ^D - End pprof 1000 1001 For commands that accept optional -ignore tags, samples where any routine in 1002 the stack trace matches the regular expression in any of the -ignore 1003 parameters will be ignored. 1004 1005 Further pprof details are available at this location (or one similar): 1006 1007 /usr/doc/google-perftools-$PPROF_VERSION/cpu_profiler.html 1008 /usr/doc/google-perftools-$PPROF_VERSION/heap_profiler.html 1009 1010 ENDOFHELP 1011 } 1012 sub ParseInteractiveArgs { 1013 my $args = shift; 1014 my $focus = ""; 1015 my $ignore = ""; 1016 my @x = split(/ +/, $args); 1017 foreach $a (@x) { 1018 if ($a =~ m/^(--|-)lines$/) { 1019 $main::opt_lines = 1; 1020 } elsif ($a =~ m/^(--|-)cum$/) { 1021 $main::opt_cum = 1; 1022 } elsif ($a =~ m/^-(.*)/) { 1023 $ignore .= (($ignore ne "") ? "|" : "" ) . $1; 1024 } else { 1025 $focus .= (($focus ne "") ? "|" : "" ) . $a; 1026 } 1027 } 1028 if ($ignore ne "") { 1029 print STDERR "Ignoring samples in call stacks that match '$ignore'\n"; 1030 } 1031 return ($focus, $ignore); 1032 } 1033 1034 ##### Output code ##### 1035 1036 sub TempName { 1037 my $fnum = shift; 1038 my $ext = shift; 1039 my $file = "$main::tmpfile_ps.$fnum.$ext"; 1040 $main::tempnames{$file} = 1; 1041 return $file; 1042 } 1043 1044 # Print profile data in packed binary format (64-bit) to standard out 1045 sub PrintProfileData { 1046 my $profile = shift; 1047 1048 # print header (64-bit style) 1049 # (zero) (header-size) (version) (sample-period) (zero) 1050 print pack('L*', 0, 0, 3, 0, 0, 0, 1, 0, 0, 0); 1051 1052 foreach my $k (keys(%{$profile})) { 1053 my $count = $profile->{$k}; 1054 my @addrs = split(/\n/, $k); 1055 if ($#addrs >= 0) { 1056 my $depth = $#addrs + 1; 1057 # int(foo / 2**32) is the only reliable way to get rid of bottom 1058 # 32 bits on both 32- and 64-bit systems. 1059 print pack('L*', $count & 0xFFFFFFFF, int($count / 2**32)); 1060 print pack('L*', $depth & 0xFFFFFFFF, int($depth / 2**32)); 1061 1062 foreach my $full_addr (@addrs) { 1063 my $addr = $full_addr; 1064 $addr =~ s/0x0*//; # strip off leading 0x, zeroes 1065 if (length($addr) > 16) { 1066 print STDERR "Invalid address in profile: $full_addr\n"; 1067 next; 1068 } 1069 my $low_addr = substr($addr, -8); # get last 8 hex chars 1070 my $high_addr = substr($addr, -16, 8); # get up to 8 more hex chars 1071 print pack('L*', hex('0x' . $low_addr), hex('0x' . $high_addr)); 1072 } 1073 } 1074 } 1075 } 1076 1077 # Print symbols and profile data 1078 sub PrintSymbolizedProfile { 1079 my $symbols = shift; 1080 my $profile = shift; 1081 my $prog = shift; 1082 1083 $SYMBOL_PAGE =~ m,[^/]+$,; # matches everything after the last slash 1084 my $symbol_marker = $&; 1085 1086 print '--- ', $symbol_marker, "\n"; 1087 if (defined($prog)) { 1088 print 'binary=', $prog, "\n"; 1089 } 1090 while (my ($pc, $name) = each(%{$symbols})) { 1091 my $sep = ' '; 1092 print '0x', $pc; 1093 # We have a list of function names, which include the inlined 1094 # calls. They are separated (and terminated) by --, which is 1095 # illegal in function names. 1096 for (my $j = 2; $j <= $#{$name}; $j += 3) { 1097 print $sep, $name->[$j]; 1098 $sep = '--'; 1099 } 1100 print "\n"; 1101 } 1102 print '---', "\n"; 1103 1104 $PROFILE_PAGE =~ m,[^/]+$,; # matches everything after the last slash 1105 my $profile_marker = $&; 1106 print '--- ', $profile_marker, "\n"; 1107 if (defined($main::collected_profile)) { 1108 # if used with remote fetch, simply dump the collected profile to output. 1109 open(SRC, "<$main::collected_profile"); 1110 while (<SRC>) { 1111 print $_; 1112 } 1113 close(SRC); 1114 } else { 1115 # dump a cpu-format profile to standard out 1116 PrintProfileData($profile); 1117 } 1118 } 1119 1120 # Print information conditionally filtered out depending on the output 1121 # format. 1122 sub Infof { 1123 my $format = shift; 1124 my @args = @_; 1125 return if $main::opt_svg; 1126 printf($format, @args); 1127 } 1128 1129 # Print text output 1130 sub PrintText { 1131 my $symbols = shift; 1132 my $flat = shift; 1133 my $cumulative = shift; 1134 my $total = shift; 1135 my $line_limit = shift; 1136 1137 # Which profile to sort by? 1138 my $s = $main::opt_cum ? $cumulative : $flat; 1139 1140 my $running_sum = 0; 1141 my $lines = 0; 1142 foreach my $k (sort { GetEntry($s, $b) <=> GetEntry($s, $a) || $a cmp $b } 1143 keys(%{$cumulative})) { 1144 my $f = GetEntry($flat, $k); 1145 my $c = GetEntry($cumulative, $k); 1146 $running_sum += $f; 1147 1148 my $sym = $k; 1149 if (exists($symbols->{$k})) { 1150 $sym = $symbols->{$k}->[0] . " " . $symbols->{$k}->[1]; 1151 if ($main::opt_addresses) { 1152 $sym = $k . " " . $sym; 1153 } 1154 } 1155 1156 if ($f != 0 || $c != 0) { 1157 printf("%8s %6s %6s %8s %6s %s\n", 1158 Unparse($f), 1159 Percent($f, $total), 1160 Percent($running_sum, $total), 1161 Unparse($c), 1162 Percent($c, $total), 1163 $sym); 1164 } 1165 $lines++; 1166 last if ($line_limit >= 0 && $lines >= $line_limit); 1167 } 1168 } 1169 1170 # Print the call graph in a way that's suiteable for callgrind. 1171 sub PrintCallgrind { 1172 my $calls = shift; 1173 my $filename; 1174 if ($main::opt_interactive) { 1175 $filename = shift; 1176 print STDERR "Writing callgrind file to '$filename'.\n" 1177 } else { 1178 $filename = "&STDOUT"; 1179 } 1180 open(CG, ">".$filename ); 1181 printf CG ("events: Hits\n\n"); 1182 foreach my $call ( map { $_->[0] } 1183 sort { $a->[1] cmp $b ->[1] || 1184 $a->[2] <=> $b->[2] } 1185 map { /([^:]+):(\d+):([^ ]+)( -> ([^:]+):(\d+):(.+))?/; 1186 [$_, $1, $2] } 1187 keys %$calls ) { 1188 my $count = int($calls->{$call}); 1189 $call =~ /([^:]+):(\d+):([^ ]+)( -> ([^:]+):(\d+):(.+))?/; 1190 my ( $caller_file, $caller_line, $caller_function, 1191 $callee_file, $callee_line, $callee_function ) = 1192 ( $1, $2, $3, $5, $6, $7 ); 1193 1194 printf CG ("fl=$caller_file\nfn=$caller_function\n"); 1195 if (defined $6) { 1196 printf CG ("cfl=$callee_file\n"); 1197 printf CG ("cfn=$callee_function\n"); 1198 printf CG ("calls=$count $callee_line\n"); 1199 } 1200 printf CG ("$caller_line $count\n\n"); 1201 } 1202 } 1203 1204 # Print disassembly for all all routines that match $main::opt_disasm 1205 sub PrintDisassembly { 1206 my $libs = shift; 1207 my $flat = shift; 1208 my $cumulative = shift; 1209 my $disasm_opts = shift; 1210 my $total = shift; 1211 1212 foreach my $lib (@{$libs}) { 1213 my $symbol_table = GetProcedureBoundaries($lib->[0], $disasm_opts); 1214 my $offset = AddressSub($lib->[1], $lib->[3]); 1215 foreach my $routine (sort ByName keys(%{$symbol_table})) { 1216 my $start_addr = $symbol_table->{$routine}->[0]; 1217 my $end_addr = $symbol_table->{$routine}->[1]; 1218 # See if there are any samples in this routine 1219 my $length = hex(AddressSub($end_addr, $start_addr)); 1220 my $addr = AddressAdd($start_addr, $offset); 1221 for (my $i = 0; $i < $length; $i++) { 1222 if (defined($cumulative->{$addr})) { 1223 PrintDisassembledFunction($lib->[0], $offset, 1224 $routine, $flat, $cumulative, 1225 $start_addr, $end_addr, $total); 1226 last; 1227 } 1228 $addr = AddressInc($addr); 1229 } 1230 } 1231 } 1232 } 1233 1234 # Return reference to array of tuples of the form: 1235 # [start_address, filename, linenumber, instruction, limit_address] 1236 # E.g., 1237 # ["0x806c43d", "/foo/bar.cc", 131, "ret", "0x806c440"] 1238 sub Disassemble { 1239 my $prog = shift; 1240 my $offset = shift; 1241 my $start_addr = shift; 1242 my $end_addr = shift; 1243 1244 my $objdump = $obj_tool_map{"objdump"}; 1245 my $cmd = sprintf("$objdump -C -d -l --no-show-raw-insn " . 1246 "--start-address=0x$start_addr " . 1247 "--stop-address=0x$end_addr $prog"); 1248 1249 if (system("$objdump --help >/dev/null 2>&1") != 0) { 1250 # objdump must not exist. Fall back to go tool objdump. 1251 $objdump = "go tool objdump"; 1252 $cmd = "$objdump $prog 0x$start_addr 0x$end_addr"; 1253 } 1254 1255 open(OBJDUMP, "$cmd |") || error("$objdump: $!\n"); 1256 my @result = (); 1257 my $filename = ""; 1258 my $linenumber = -1; 1259 my $last = ["", "", "", ""]; 1260 while (<OBJDUMP>) { 1261 s/\r//g; # turn windows-looking lines into unix-looking lines 1262 chop; 1263 if (m|\s*(.+):(\d+)\s*$|) { 1264 # Location line of the form: 1265 # <filename>:<linenumber> 1266 $filename = $1; 1267 $linenumber = $2; 1268 } elsif (m/^ +([0-9a-f]+):\s*(.*)/) { 1269 # Disassembly line -- zero-extend address to full length 1270 my $addr = HexExtend($1); 1271 my $k = AddressAdd($addr, $offset); 1272 $last->[4] = $k; # Store ending address for previous instruction 1273 $last = [$k, $filename, $linenumber, $2, $end_addr]; 1274 push(@result, $last); 1275 } 1276 } 1277 close(OBJDUMP); 1278 return @result; 1279 } 1280 1281 # The input file should contain lines of the form /proc/maps-like 1282 # output (same format as expected from the profiles) or that looks 1283 # like hex addresses (like "0xDEADBEEF"). We will parse all 1284 # /proc/maps output, and for all the hex addresses, we will output 1285 # "short" symbol names, one per line, in the same order as the input. 1286 sub PrintSymbols { 1287 my $maps_and_symbols_file = shift; 1288 1289 # ParseLibraries expects pcs to be in a set. Fine by us... 1290 my @pclist = (); # pcs in sorted order 1291 my $pcs = {}; 1292 my $map = ""; 1293 foreach my $line (<$maps_and_symbols_file>) { 1294 $line =~ s/\r//g; # turn windows-looking lines into unix-looking lines 1295 if ($line =~ /\b(0x[0-9a-f]+)\b/i) { 1296 push(@pclist, HexExtend($1)); 1297 $pcs->{$pclist[-1]} = 1; 1298 } else { 1299 $map .= $line; 1300 } 1301 } 1302 1303 my $libs = ParseLibraries($main::prog, $map, $pcs); 1304 my $symbols = ExtractSymbols($libs, $pcs); 1305 1306 foreach my $pc (@pclist) { 1307 # ->[0] is the shortname, ->[2] is the full name 1308 print(($symbols->{$pc}->[0] || "??") . "\n"); 1309 } 1310 } 1311 1312 1313 # For sorting functions by name 1314 sub ByName { 1315 return ShortFunctionName($a) cmp ShortFunctionName($b); 1316 } 1317 1318 # Print source-listing for all all routines that match $main::opt_list 1319 sub PrintListing { 1320 my $total = shift; 1321 my $libs = shift; 1322 my $flat = shift; 1323 my $cumulative = shift; 1324 my $list_opts = shift; 1325 my $html = shift; 1326 1327 my $output = \*STDOUT; 1328 my $fname = ""; 1329 1330 1331 if ($html) { 1332 # Arrange to write the output to a temporary file 1333 $fname = TempName($main::next_tmpfile, "html"); 1334 $main::next_tmpfile++; 1335 if (!open(TEMP, ">$fname")) { 1336 print STDERR "$fname: $!\n"; 1337 return; 1338 } 1339 $output = \*TEMP; 1340 print $output HtmlListingHeader(); 1341 printf $output ("<div class=\"legend\">%s<br>Total: %s %s</div>\n", 1342 $main::prog, Unparse($total), Units()); 1343 } 1344 1345 my $listed = 0; 1346 foreach my $lib (@{$libs}) { 1347 my $symbol_table = GetProcedureBoundaries($lib->[0], $list_opts); 1348 my $offset = AddressSub($lib->[1], $lib->[3]); 1349 foreach my $routine (sort ByName keys(%{$symbol_table})) { 1350 # Print if there are any samples in this routine 1351 my $start_addr = $symbol_table->{$routine}->[0]; 1352 my $end_addr = $symbol_table->{$routine}->[1]; 1353 my $length = hex(AddressSub($end_addr, $start_addr)); 1354 my $addr = AddressAdd($start_addr, $offset); 1355 for (my $i = 0; $i < $length; $i++) { 1356 if (defined($cumulative->{$addr})) { 1357 $listed += PrintSource( 1358 $lib->[0], $offset, 1359 $routine, $flat, $cumulative, 1360 $start_addr, $end_addr, 1361 $html, 1362 $output); 1363 last; 1364 } 1365 $addr = AddressInc($addr); 1366 } 1367 } 1368 } 1369 1370 if ($html) { 1371 if ($listed > 0) { 1372 print $output HtmlListingFooter(); 1373 close($output); 1374 RunWeb($fname); 1375 } else { 1376 close($output); 1377 unlink($fname); 1378 } 1379 } 1380 } 1381 1382 sub HtmlListingHeader { 1383 return <<'EOF'; 1384 <DOCTYPE html> 1385 <html> 1386 <head> 1387 <title>Pprof listing</title> 1388 <style type="text/css"> 1389 body { 1390 font-family: sans-serif; 1391 } 1392 h1 { 1393 font-size: 1.5em; 1394 margin-bottom: 4px; 1395 } 1396 .legend { 1397 font-size: 1.25em; 1398 } 1399 .line { 1400 color: #aaaaaa; 1401 } 1402 .livesrc { 1403 color: #0000ff; 1404 cursor: pointer; 1405 } 1406 .livesrc:hover { 1407 background-color: #cccccc; 1408 } 1409 .asm { 1410 color: #888888; 1411 display: none; 1412 } 1413 </style> 1414 <script type="text/javascript"> 1415 function pprof_toggle_asm(e) { 1416 var target; 1417 if (!e) e = window.event; 1418 if (e.target) target = e.target; 1419 else if (e.srcElement) target = e.srcElement; 1420 1421 if (target && target.className == "livesrc") { 1422 var asm = target.nextSibling; 1423 if (asm && asm.className == "asm") { 1424 asm.style.display = (asm.style.display == "block" ? "none" : "block"); 1425 e.preventDefault(); 1426 return false; 1427 } 1428 } 1429 } 1430 </script> 1431 </head> 1432 <body> 1433 EOF 1434 } 1435 1436 sub HtmlListingFooter { 1437 return <<'EOF'; 1438 </body> 1439 </html> 1440 EOF 1441 } 1442 1443 sub HtmlEscape { 1444 my $text = shift; 1445 $text =~ s/&/&/g; 1446 $text =~ s/</</g; 1447 $text =~ s/>/>/g; 1448 return $text; 1449 } 1450 1451 # Returns the indentation of the line, if it has any non-whitespace 1452 # characters. Otherwise, returns -1. 1453 sub Indentation { 1454 my $line = shift; 1455 if (m/^(\s*)\S/) { 1456 return length($1); 1457 } else { 1458 return -1; 1459 } 1460 } 1461 1462 # Print source-listing for one routine 1463 sub PrintSource { 1464 my $prog = shift; 1465 my $offset = shift; 1466 my $routine = shift; 1467 my $flat = shift; 1468 my $cumulative = shift; 1469 my $start_addr = shift; 1470 my $end_addr = shift; 1471 my $html = shift; 1472 my $output = shift; 1473 1474 # Disassemble all instructions (just to get line numbers) 1475 my @instructions = Disassemble($prog, $offset, $start_addr, $end_addr); 1476 1477 # Hack 1: assume that the first source file encountered in the 1478 # disassembly contains the routine 1479 my $filename = undef; 1480 for (my $i = 0; $i <= $#instructions; $i++) { 1481 if ($instructions[$i]->[2] >= 0) { 1482 $filename = $instructions[$i]->[1]; 1483 last; 1484 } 1485 } 1486 if (!defined($filename)) { 1487 print STDERR "no filename found in $routine\n"; 1488 return 0; 1489 } 1490 1491 # Hack 2: assume that the largest line number from $filename is the 1492 # end of the procedure. This is typically safe since if P1 contains 1493 # an inlined call to P2, then P2 usually occurs earlier in the 1494 # source file. If this does not work, we might have to compute a 1495 # density profile or just print all regions we find. 1496 my $lastline = 0; 1497 for (my $i = 0; $i <= $#instructions; $i++) { 1498 my $f = $instructions[$i]->[1]; 1499 my $l = $instructions[$i]->[2]; 1500 if (($f eq $filename) && ($l > $lastline)) { 1501 $lastline = $l; 1502 } 1503 } 1504 1505 # Hack 3: assume the first source location from "filename" is the start of 1506 # the source code. 1507 my $firstline = 1; 1508 for (my $i = 0; $i <= $#instructions; $i++) { 1509 if ($instructions[$i]->[1] eq $filename) { 1510 $firstline = $instructions[$i]->[2]; 1511 last; 1512 } 1513 } 1514 1515 # Hack 4: Extend last line forward until its indentation is less than 1516 # the indentation we saw on $firstline 1517 my $oldlastline = $lastline; 1518 { 1519 if (!open(FILE, "<$filename")) { 1520 print STDERR "$filename: $!\n"; 1521 return 0; 1522 } 1523 my $l = 0; 1524 my $first_indentation = -1; 1525 while (<FILE>) { 1526 s/\r//g; # turn windows-looking lines into unix-looking lines 1527 $l++; 1528 my $indent = Indentation($_); 1529 if ($l >= $firstline) { 1530 if ($first_indentation < 0 && $indent >= 0) { 1531 $first_indentation = $indent; 1532 last if ($first_indentation == 0); 1533 } 1534 } 1535 if ($l >= $lastline && $indent >= 0) { 1536 if ($indent >= $first_indentation) { 1537 $lastline = $l+1; 1538 } else { 1539 last; 1540 } 1541 } 1542 } 1543 close(FILE); 1544 } 1545 1546 # Assign all samples to the range $firstline,$lastline, 1547 # Hack 4: If an instruction does not occur in the range, its samples 1548 # are moved to the next instruction that occurs in the range. 1549 my $samples1 = {}; # Map from line number to flat count 1550 my $samples2 = {}; # Map from line number to cumulative count 1551 my $running1 = 0; # Unassigned flat counts 1552 my $running2 = 0; # Unassigned cumulative counts 1553 my $total1 = 0; # Total flat counts 1554 my $total2 = 0; # Total cumulative counts 1555 my %disasm = (); # Map from line number to disassembly 1556 my $running_disasm = ""; # Unassigned disassembly 1557 my $skip_marker = "---\n"; 1558 if ($html) { 1559 $skip_marker = ""; 1560 for (my $l = $firstline; $l <= $lastline; $l++) { 1561 $disasm{$l} = ""; 1562 } 1563 } 1564 foreach my $e (@instructions) { 1565 # Add up counts for all address that fall inside this instruction 1566 my $c1 = 0; 1567 my $c2 = 0; 1568 for (my $a = $e->[0]; $a lt $e->[4]; $a = AddressInc($a)) { 1569 $c1 += GetEntry($flat, $a); 1570 $c2 += GetEntry($cumulative, $a); 1571 } 1572 1573 if ($html) { 1574 $running_disasm .= sprintf(" %6s %6s \t\t%8s: %s\n", 1575 HtmlPrintNumber($c1), 1576 HtmlPrintNumber($c2), 1577 $e->[0], 1578 CleanDisassembly($e->[3])); 1579 } 1580 1581 $running1 += $c1; 1582 $running2 += $c2; 1583 $total1 += $c1; 1584 $total2 += $c2; 1585 my $file = $e->[1]; 1586 my $line = $e->[2]; 1587 if (($file eq $filename) && 1588 ($line >= $firstline) && 1589 ($line <= $lastline)) { 1590 # Assign all accumulated samples to this line 1591 AddEntry($samples1, $line, $running1); 1592 AddEntry($samples2, $line, $running2); 1593 $running1 = 0; 1594 $running2 = 0; 1595 if ($html) { 1596 $disasm{$line} .= $running_disasm; 1597 $running_disasm = ''; 1598 } 1599 } 1600 } 1601 1602 # Assign any leftover samples to $lastline 1603 AddEntry($samples1, $lastline, $running1); 1604 AddEntry($samples2, $lastline, $running2); 1605 1606 if ($html) { 1607 printf $output ( 1608 "<h1>%s</h1>%s\n<pre onClick=\"pprof_toggle_asm()\">\n" . 1609 "Total:%6s %6s (flat / cumulative %s)\n", 1610 HtmlEscape(ShortFunctionName($routine)), 1611 HtmlEscape($filename), 1612 Unparse($total1), 1613 Unparse($total2), 1614 Units()); 1615 } else { 1616 printf $output ( 1617 "ROUTINE ====================== %s in %s\n" . 1618 "%6s %6s Total %s (flat / cumulative)\n", 1619 ShortFunctionName($routine), 1620 $filename, 1621 Unparse($total1), 1622 Unparse($total2), 1623 Units()); 1624 } 1625 if (!open(FILE, "<$filename")) { 1626 print STDERR "$filename: $!\n"; 1627 return 0; 1628 } 1629 my $l = 0; 1630 while (<FILE>) { 1631 s/\r//g; # turn windows-looking lines into unix-looking lines 1632 $l++; 1633 if ($l >= $firstline - 5 && 1634 (($l <= $oldlastline + 5) || ($l <= $lastline))) { 1635 chop; 1636 my $text = $_; 1637 if ($l == $firstline) { print $output $skip_marker; } 1638 my $n1 = GetEntry($samples1, $l); 1639 my $n2 = GetEntry($samples2, $l); 1640 if ($html) { 1641 my $dis = $disasm{$l}; 1642 if (!defined($dis) || $n1 + $n2 == 0) { 1643 # No samples/disassembly for this source line 1644 printf $output ( 1645 "<span class=\"line\">%5d</span> " . 1646 "<span class=\"deadsrc\">%6s %6s %s</span>\n", 1647 $l, 1648 HtmlPrintNumber($n1), 1649 HtmlPrintNumber($n2), 1650 HtmlEscape($text)); 1651 } else { 1652 printf $output ( 1653 "<span class=\"line\">%5d</span> " . 1654 "<span class=\"livesrc\">%6s %6s %s</span>" . 1655 "<span class=\"asm\">%s</span>\n", 1656 $l, 1657 HtmlPrintNumber($n1), 1658 HtmlPrintNumber($n2), 1659 HtmlEscape($text), 1660 HtmlEscape($dis)); 1661 } 1662 } else { 1663 printf $output( 1664 "%6s %6s %4d: %s\n", 1665 UnparseAlt($n1), 1666 UnparseAlt($n2), 1667 $l, 1668 $text); 1669 } 1670 if ($l == $lastline) { print $output $skip_marker; } 1671 }; 1672 } 1673 close(FILE); 1674 if ($html) { 1675 print $output "</pre>\n"; 1676 } 1677 return 1; 1678 } 1679 1680 # Return the source line for the specified file/linenumber. 1681 # Returns undef if not found. 1682 sub SourceLine { 1683 my $file = shift; 1684 my $line = shift; 1685 1686 # Look in cache 1687 if (!defined($main::source_cache{$file})) { 1688 if (100 < scalar keys(%main::source_cache)) { 1689 # Clear the cache when it gets too big 1690 $main::source_cache = (); 1691 } 1692 1693 # Read all lines from the file 1694 if (!open(FILE, "<$file")) { 1695 print STDERR "$file: $!\n"; 1696 $main::source_cache{$file} = []; # Cache the negative result 1697 return undef; 1698 } 1699 my $lines = []; 1700 push(@{$lines}, ""); # So we can use 1-based line numbers as indices 1701 while (<FILE>) { 1702 push(@{$lines}, $_); 1703 } 1704 close(FILE); 1705 1706 # Save the lines in the cache 1707 $main::source_cache{$file} = $lines; 1708 } 1709 1710 my $lines = $main::source_cache{$file}; 1711 if (($line < 0) || ($line > $#{$lines})) { 1712 return undef; 1713 } else { 1714 return $lines->[$line]; 1715 } 1716 } 1717 1718 # Print disassembly for one routine with interspersed source if available 1719 sub PrintDisassembledFunction { 1720 my $prog = shift; 1721 my $offset = shift; 1722 my $routine = shift; 1723 my $flat = shift; 1724 my $cumulative = shift; 1725 my $start_addr = shift; 1726 my $end_addr = shift; 1727 my $total = shift; 1728 1729 # Disassemble all instructions 1730 my @instructions = Disassemble($prog, $offset, $start_addr, $end_addr); 1731 1732 # Make array of counts per instruction 1733 my @flat_count = (); 1734 my @cum_count = (); 1735 my $flat_total = 0; 1736 my $cum_total = 0; 1737 foreach my $e (@instructions) { 1738 # Add up counts for all address that fall inside this instruction 1739 my $c1 = 0; 1740 my $c2 = 0; 1741 for (my $a = $e->[0]; $a lt $e->[4]; $a = AddressInc($a)) { 1742 $c1 += GetEntry($flat, $a); 1743 $c2 += GetEntry($cumulative, $a); 1744 } 1745 push(@flat_count, $c1); 1746 push(@cum_count, $c2); 1747 $flat_total += $c1; 1748 $cum_total += $c2; 1749 } 1750 1751 # Print header with total counts 1752 printf("ROUTINE ====================== %s\n" . 1753 "%6s %6s %s (flat, cumulative) %.1f%% of total\n", 1754 ShortFunctionName($routine), 1755 Unparse($flat_total), 1756 Unparse($cum_total), 1757 Units(), 1758 ($cum_total * 100.0) / $total); 1759 1760 # Process instructions in order 1761 my $current_file = ""; 1762 for (my $i = 0; $i <= $#instructions; ) { 1763 my $e = $instructions[$i]; 1764 1765 # Print the new file name whenever we switch files 1766 if ($e->[1] ne $current_file) { 1767 $current_file = $e->[1]; 1768 my $fname = $current_file; 1769 $fname =~ s|^\./||; # Trim leading "./" 1770 1771 # Shorten long file names 1772 if (length($fname) >= 58) { 1773 $fname = "..." . substr($fname, -55); 1774 } 1775 printf("-------------------- %s\n", $fname); 1776 } 1777 1778 # TODO: Compute range of lines to print together to deal with 1779 # small reorderings. 1780 my $first_line = $e->[2]; 1781 my $last_line = $first_line; 1782 my %flat_sum = (); 1783 my %cum_sum = (); 1784 for (my $l = $first_line; $l <= $last_line; $l++) { 1785 $flat_sum{$l} = 0; 1786 $cum_sum{$l} = 0; 1787 } 1788 1789 # Find run of instructions for this range of source lines 1790 my $first_inst = $i; 1791 while (($i <= $#instructions) && 1792 ($instructions[$i]->[2] >= $first_line) && 1793 ($instructions[$i]->[2] <= $last_line)) { 1794 $e = $instructions[$i]; 1795 $flat_sum{$e->[2]} += $flat_count[$i]; 1796 $cum_sum{$e->[2]} += $cum_count[$i]; 1797 $i++; 1798 } 1799 my $last_inst = $i - 1; 1800 1801 # Print source lines 1802 for (my $l = $first_line; $l <= $last_line; $l++) { 1803 my $line = SourceLine($current_file, $l); 1804 if (!defined($line)) { 1805 $line = "?\n"; 1806 next; 1807 } else { 1808 $line =~ s/^\s+//; 1809 } 1810 printf("%6s %6s %5d: %s", 1811 UnparseAlt($flat_sum{$l}), 1812 UnparseAlt($cum_sum{$l}), 1813 $l, 1814 $line); 1815 } 1816 1817 # Print disassembly 1818 for (my $x = $first_inst; $x <= $last_inst; $x++) { 1819 my $e = $instructions[$x]; 1820 my $address = $e->[0]; 1821 $address = AddressSub($address, $offset); # Make relative to section 1822 $address =~ s/^0x//; 1823 $address =~ s/^0*//; 1824 1825 printf("%6s %6s %8s: %6s\n", 1826 UnparseAlt($flat_count[$x]), 1827 UnparseAlt($cum_count[$x]), 1828 $address, 1829 CleanDisassembly($e->[3])); 1830 } 1831 } 1832 } 1833 1834 # Print DOT graph 1835 sub PrintDot { 1836 my $prog = shift; 1837 my $symbols = shift; 1838 my $raw = shift; 1839 my $flat = shift; 1840 my $cumulative = shift; 1841 my $overall_total = shift; 1842 1843 # Get total 1844 my $local_total = TotalProfile($flat); 1845 my $nodelimit = int($main::opt_nodefraction * $local_total); 1846 my $edgelimit = int($main::opt_edgefraction * $local_total); 1847 my $nodecount = $main::opt_nodecount; 1848 1849 # Find nodes to include 1850 my @list = (sort { abs(GetEntry($cumulative, $b)) <=> 1851 abs(GetEntry($cumulative, $a)) 1852 || $a cmp $b } 1853 keys(%{$cumulative})); 1854 my $last = $nodecount - 1; 1855 if ($last > $#list) { 1856 $last = $#list; 1857 } 1858 while (($last >= 0) && 1859 (abs(GetEntry($cumulative, $list[$last])) <= $nodelimit)) { 1860 $last--; 1861 } 1862 if ($last < 0) { 1863 print STDERR "No nodes to print\n"; 1864 cleanup(); 1865 return 0; 1866 } 1867 1868 if ($nodelimit > 0 || $edgelimit > 0) { 1869 printf STDERR ("Dropping nodes with <= %s %s; edges with <= %s abs(%s)\n", 1870 Unparse($nodelimit), Units(), 1871 Unparse($edgelimit), Units()); 1872 } 1873 1874 # Open DOT output file 1875 my $output; 1876 if ($main::opt_gv) { 1877 $output = "| $DOT -Tps2 >" . TempName($main::next_tmpfile, "ps"); 1878 } elsif ($main::opt_ps) { 1879 $output = "| $DOT -Tps2"; 1880 } elsif ($main::opt_pdf) { 1881 $output = "| $DOT -Tps2 | $PS2PDF - -"; 1882 } elsif ($main::opt_web || $main::opt_svg) { 1883 # We need to post-process the SVG, so write to a temporary file always. 1884 $output = "| $DOT -Tsvg >" . TempName($main::next_tmpfile, "svg"); 1885 } elsif ($main::opt_gif) { 1886 $output = "| $DOT -Tgif"; 1887 } else { 1888 $output = ">&STDOUT"; 1889 } 1890 open(DOT, $output) || error("$output: $!\n"); 1891 1892 # Title 1893 printf DOT ("digraph \"%s; %s %s\" {\n", 1894 $prog, 1895 Unparse($overall_total), 1896 Units()); 1897 if ($main::opt_pdf) { 1898 # The output is more printable if we set the page size for dot. 1899 printf DOT ("size=\"8,11\"\n"); 1900 } 1901 printf DOT ("node [width=0.375,height=0.25];\n"); 1902 1903 # Print legend 1904 printf DOT ("Legend [shape=box,fontsize=24,shape=plaintext," . 1905 "label=\"%s\\l%s\\l%s\\l%s\\l%s\\l\"];\n", 1906 $prog, 1907 sprintf("Total %s: %s", Units(), Unparse($overall_total)), 1908 sprintf("Focusing on: %s", Unparse($local_total)), 1909 sprintf("Dropped nodes with <= %s abs(%s)", 1910 Unparse($nodelimit), Units()), 1911 sprintf("Dropped edges with <= %s %s", 1912 Unparse($edgelimit), Units()) 1913 ); 1914 1915 # Print nodes 1916 my %node = (); 1917 my $nextnode = 1; 1918 foreach my $a (@list[0..$last]) { 1919 # Pick font size 1920 my $f = GetEntry($flat, $a); 1921 my $c = GetEntry($cumulative, $a); 1922 1923 my $fs = 8; 1924 if ($local_total > 0) { 1925 $fs = 8 + (50.0 * sqrt(abs($f * 1.0 / $local_total))); 1926 } 1927 1928 $node{$a} = $nextnode++; 1929 my $sym = $a; 1930 $sym =~ s/\s+/\\n/g; 1931 $sym =~ s/::/\\n/g; 1932 1933 # Extra cumulative info to print for non-leaves 1934 my $extra = ""; 1935 if ($f != $c) { 1936 $extra = sprintf("\\rof %s (%s)", 1937 Unparse($c), 1938 Percent($c, $overall_total)); 1939 } 1940 my $style = ""; 1941 if ($main::opt_heapcheck) { 1942 if ($f > 0) { 1943 # make leak-causing nodes more visible (add a background) 1944 $style = ",style=filled,fillcolor=gray" 1945 } elsif ($f < 0) { 1946 # make anti-leak-causing nodes (which almost never occur) 1947 # stand out as well (triple border) 1948 $style = ",peripheries=3" 1949 } 1950 } 1951 1952 printf DOT ("N%d [label=\"%s\\n%s (%s)%s\\r" . 1953 "\",shape=box,fontsize=%.1f%s];\n", 1954 $node{$a}, 1955 $sym, 1956 Unparse($f), 1957 Percent($f, $overall_total), 1958 $extra, 1959 $fs, 1960 $style, 1961 ); 1962 } 1963 1964 # Get edges and counts per edge 1965 my %edge = (); 1966 my $n; 1967 foreach my $k (keys(%{$raw})) { 1968 # TODO: omit low %age edges 1969 $n = $raw->{$k}; 1970 my @translated = TranslateStack($symbols, $k); 1971 for (my $i = 1; $i <= $#translated; $i++) { 1972 my $src = $translated[$i]; 1973 my $dst = $translated[$i-1]; 1974 #next if ($src eq $dst); # Avoid self-edges? 1975 if (exists($node{$src}) && exists($node{$dst})) { 1976 my $edge_label = "$src\001$dst"; 1977 if (!exists($edge{$edge_label})) { 1978 $edge{$edge_label} = 0; 1979 } 1980 $edge{$edge_label} += $n; 1981 } 1982 } 1983 } 1984 1985 # Print edges 1986 foreach my $e (keys(%edge)) { 1987 my @x = split(/\001/, $e); 1988 $n = $edge{$e}; 1989 1990 if (abs($n) > $edgelimit) { 1991 # Compute line width based on edge count 1992 my $fraction = abs($local_total ? (3 * ($n / $local_total)) : 0); 1993 if ($fraction > 1) { $fraction = 1; } 1994 my $w = $fraction * 2; 1995 if ($w < 1 && ($main::opt_web || $main::opt_svg)) { 1996 # SVG output treats line widths < 1 poorly. 1997 $w = 1; 1998 } 1999 2000 # Dot sometimes segfaults if given edge weights that are too large, so 2001 # we cap the weights at a large value 2002 my $edgeweight = abs($n) ** 0.7; 2003 if ($edgeweight > 100000) { $edgeweight = 100000; } 2004 $edgeweight = int($edgeweight); 2005 2006 my $style = sprintf("setlinewidth(%f)", $w); 2007 if ($x[1] =~ m/\(inline\)/) { 2008 $style .= ",dashed"; 2009 } 2010 2011 # Use a slightly squashed function of the edge count as the weight 2012 printf DOT ("N%s -> N%s [label=%s, weight=%d, style=\"%s\"];\n", 2013 $node{$x[0]}, 2014 $node{$x[1]}, 2015 Unparse($n), 2016 $edgeweight, 2017 $style); 2018 } 2019 } 2020 2021 print DOT ("}\n"); 2022 close(DOT); 2023 2024 if ($main::opt_web || $main::opt_svg) { 2025 # Rewrite SVG to be more usable inside web browser. 2026 RewriteSvg(TempName($main::next_tmpfile, "svg")); 2027 } 2028 2029 return 1; 2030 } 2031 2032 sub RewriteSvg { 2033 my $svgfile = shift; 2034 2035 open(SVG, $svgfile) || die "open temp svg: $!"; 2036 my @svg = <SVG>; 2037 close(SVG); 2038 unlink $svgfile; 2039 my $svg = join('', @svg); 2040 2041 # Dot's SVG output is 2042 # 2043 # <svg width="___" height="___" 2044 # viewBox="___" xmlns=...> 2045 # <g id="graph0" transform="..."> 2046 # ... 2047 # </g> 2048 # </svg> 2049 # 2050 # Change it to 2051 # 2052 # <svg width="100%" height="100%" 2053 # xmlns=...> 2054 # $svg_javascript 2055 # <g id="viewport" transform="translate(0,0)"> 2056 # <g id="graph0" transform="..."> 2057 # ... 2058 # </g> 2059 # </g> 2060 # </svg> 2061 2062 # Fix width, height; drop viewBox. 2063 $svg =~ s/(?s)<svg width="[^"]+" height="[^"]+"(.*?)viewBox="[^"]+"/<svg width="100%" height="100%"$1/; 2064 2065 # Insert script, viewport <g> above first <g> 2066 my $svg_javascript = SvgJavascript(); 2067 my $viewport = "<g id=\"viewport\" transform=\"translate(0,0)\">\n"; 2068 $svg =~ s/<g id="graph\d"/$svg_javascript$viewport$&/; 2069 2070 # Insert final </g> above </svg>. 2071 $svg =~ s/(.*)(<\/svg>)/$1<\/g>$2/; 2072 $svg =~ s/<g id="graph\d"(.*?)/<g id="viewport"$1/; 2073 2074 if ($main::opt_svg) { 2075 # --svg: write to standard output. 2076 print $svg; 2077 } else { 2078 # Write back to temporary file. 2079 open(SVG, ">$svgfile") || die "open $svgfile: $!"; 2080 print SVG $svg; 2081 close(SVG); 2082 } 2083 } 2084 2085 sub SvgJavascript { 2086 return <<'EOF'; 2087 <script type="text/ecmascript"><![CDATA[ 2088 // SVGPan 2089 // http://www.cyberz.org/blog/2009/12/08/svgpan-a-javascript-svg-panzoomdrag-library/ 2090 // Local modification: if(true || ...) below to force panning, never moving. 2091 // Local modification: add clamping to fix bug in handleMouseWheel. 2092 2093 /** 2094 * SVGPan library 1.2 2095 * ==================== 2096 * 2097 * Given an unique existing element with id "viewport", including the 2098 * the library into any SVG adds the following capabilities: 2099 * 2100 * - Mouse panning 2101 * - Mouse zooming (using the wheel) 2102 * - Object dargging 2103 * 2104 * Known issues: 2105 * 2106 * - Zooming (while panning) on Safari has still some issues 2107 * 2108 * Releases: 2109 * 2110 * 1.2, Sat Mar 20 08:42:50 GMT 2010, Zeng Xiaohui 2111 * Fixed a bug with browser mouse handler interaction 2112 * 2113 * 1.1, Wed Feb 3 17:39:33 GMT 2010, Zeng Xiaohui 2114 * Updated the zoom code to support the mouse wheel on Safari/Chrome 2115 * 2116 * 1.0, Andrea Leofreddi 2117 * First release 2118 * 2119 * This code is licensed under the following BSD license: 2120 * 2121 * Copyright 2009-2010 Andrea Leofreddi <a.leofreddi@itcharm.com>. All rights reserved. 2122 * 2123 * Redistribution and use in source and binary forms, with or without modification, are 2124 * permitted provided that the following conditions are met: 2125 * 2126 * 1. Redistributions of source code must retain the above copyright notice, this list of 2127 * conditions and the following disclaimer. 2128 * 2129 * 2. Redistributions in binary form must reproduce the above copyright notice, this list 2130 * of conditions and the following disclaimer in the documentation and/or other materials 2131 * provided with the distribution. 2132 * 2133 * THIS SOFTWARE IS PROVIDED BY Andrea Leofreddi ``AS IS'' AND ANY EXPRESS OR IMPLIED 2134 * WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND 2135 * FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL Andrea Leofreddi OR 2136 * CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 2137 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 2138 * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON 2139 * ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 2140 * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF 2141 * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 2142 * 2143 * The views and conclusions contained in the software and documentation are those of the 2144 * authors and should not be interpreted as representing official policies, either expressed 2145 * or implied, of Andrea Leofreddi. 2146 */ 2147 2148 var root = document.documentElement; 2149 2150 var state = 'none', stateTarget, stateOrigin, stateTf; 2151 2152 setupHandlers(root); 2153 2154 /** 2155 * Register handlers 2156 */ 2157 function setupHandlers(root){ 2158 setAttributes(root, { 2159 "onmouseup" : "add(evt)", 2160 "onmousedown" : "handleMouseDown(evt)", 2161 "onmousemove" : "handleMouseMove(evt)", 2162 "onmouseup" : "handleMouseUp(evt)", 2163 //"onmouseout" : "handleMouseUp(evt)", // Decomment this to stop the pan functionality when dragging out of the SVG element 2164 }); 2165 2166 if(navigator.userAgent.toLowerCase().indexOf('webkit') >= 0) 2167 window.addEventListener('mousewheel', handleMouseWheel, false); // Chrome/Safari 2168 else 2169 window.addEventListener('DOMMouseScroll', handleMouseWheel, false); // Others 2170 2171 var g = svgDoc.getElementById("svg"); 2172 g.width = "100%"; 2173 g.height = "100%"; 2174 } 2175 2176 /** 2177 * Instance an SVGPoint object with given event coordinates. 2178 */ 2179 function getEventPoint(evt) { 2180 var p = root.createSVGPoint(); 2181 2182 p.x = evt.clientX; 2183 p.y = evt.clientY; 2184 2185 return p; 2186 } 2187 2188 /** 2189 * Sets the current transform matrix of an element. 2190 */ 2191 function setCTM(element, matrix) { 2192 var s = "matrix(" + matrix.a + "," + matrix.b + "," + matrix.c + "," + matrix.d + "," + matrix.e + "," + matrix.f + ")"; 2193 2194 element.setAttribute("transform", s); 2195 } 2196 2197 /** 2198 * Dumps a matrix to a string (useful for debug). 2199 */ 2200 function dumpMatrix(matrix) { 2201 var s = "[ " + matrix.a + ", " + matrix.c + ", " + matrix.e + "\n " + matrix.b + ", " + matrix.d + ", " + matrix.f + "\n 0, 0, 1 ]"; 2202 2203 return s; 2204 } 2205 2206 /** 2207 * Sets attributes of an element. 2208 */ 2209 function setAttributes(element, attributes){ 2210 for (i in attributes) 2211 element.setAttributeNS(null, i, attributes[i]); 2212 } 2213 2214 /** 2215 * Handle mouse move event. 2216 */ 2217 function handleMouseWheel(evt) { 2218 if(evt.preventDefault) 2219 evt.preventDefault(); 2220 2221 evt.returnValue = false; 2222 2223 var svgDoc = evt.target.ownerDocument; 2224 2225 var delta; 2226 2227 if(evt.wheelDelta) 2228 delta = evt.wheelDelta / 3600; // Chrome/Safari 2229 else 2230 delta = evt.detail / -90; // Mozilla 2231 2232 var z = 1 + delta; // Zoom factor: 0.9/1.1 2233 2234 // Clamp to reasonable values. 2235 // The 0.1 check is important because 2236 // a very large scroll can turn into a 2237 // negative z, which rotates the image 180 degrees. 2238 if(z < 0.1) 2239 z = 0.1; 2240 if(z > 10.0) 2241 z = 10.0; 2242 2243 var g = svgDoc.getElementById("viewport"); 2244 2245 var p = getEventPoint(evt); 2246 2247 p = p.matrixTransform(g.getCTM().inverse()); 2248 2249 // Compute new scale matrix in current mouse position 2250 var k = root.createSVGMatrix().translate(p.x, p.y).scale(z).translate(-p.x, -p.y); 2251 2252 setCTM(g, g.getCTM().multiply(k)); 2253 2254 stateTf = stateTf.multiply(k.inverse()); 2255 } 2256 2257 /** 2258 * Handle mouse move event. 2259 */ 2260 function handleMouseMove(evt) { 2261 if(evt.preventDefault) 2262 evt.preventDefault(); 2263 2264 evt.returnValue = false; 2265 2266 var svgDoc = evt.target.ownerDocument; 2267 2268 var g = svgDoc.getElementById("viewport"); 2269 2270 if(state == 'pan') { 2271 // Pan mode 2272 var p = getEventPoint(evt).matrixTransform(stateTf); 2273 2274 setCTM(g, stateTf.inverse().translate(p.x - stateOrigin.x, p.y - stateOrigin.y)); 2275 } else if(state == 'move') { 2276 // Move mode 2277 var p = getEventPoint(evt).matrixTransform(g.getCTM().inverse()); 2278 2279 setCTM(stateTarget, root.createSVGMatrix().translate(p.x - stateOrigin.x, p.y - stateOrigin.y).multiply(g.getCTM().inverse()).multiply(stateTarget.getCTM())); 2280 2281 stateOrigin = p; 2282 } 2283 } 2284 2285 /** 2286 * Handle click event. 2287 */ 2288 function handleMouseDown(evt) { 2289 if(evt.preventDefault) 2290 evt.preventDefault(); 2291 2292 evt.returnValue = false; 2293 2294 var svgDoc = evt.target.ownerDocument; 2295 2296 var g = svgDoc.getElementById("viewport"); 2297 2298 if(true || evt.target.tagName == "svg") { 2299 // Pan mode 2300 state = 'pan'; 2301 2302 stateTf = g.getCTM().inverse(); 2303 2304 stateOrigin = getEventPoint(evt).matrixTransform(stateTf); 2305 } else { 2306 // Move mode 2307 state = 'move'; 2308 2309 stateTarget = evt.target; 2310 2311 stateTf = g.getCTM().inverse(); 2312 2313 stateOrigin = getEventPoint(evt).matrixTransform(stateTf); 2314 } 2315 } 2316 2317 /** 2318 * Handle mouse button release event. 2319 */ 2320 function handleMouseUp(evt) { 2321 if(evt.preventDefault) 2322 evt.preventDefault(); 2323 2324 evt.returnValue = false; 2325 2326 var svgDoc = evt.target.ownerDocument; 2327 2328 if(state == 'pan' || state == 'move') { 2329 // Quit pan mode 2330 state = ''; 2331 } 2332 } 2333 2334 ]]></script> 2335 EOF 2336 } 2337 2338 # Translate a stack of addresses into a stack of symbols 2339 sub TranslateStack { 2340 my $symbols = shift; 2341 my $k = shift; 2342 2343 my @addrs = split(/\n/, $k); 2344 my @result = (); 2345 for (my $i = 0; $i <= $#addrs; $i++) { 2346 my $a = $addrs[$i]; 2347 2348 # Skip large addresses since they sometimes show up as fake entries on RH9 2349 if (length($a) > 8 && $a gt "7fffffffffffffff") { 2350 next; 2351 } 2352 2353 if ($main::opt_disasm || $main::opt_list) { 2354 # We want just the address for the key 2355 push(@result, $a); 2356 next; 2357 } 2358 2359 my $symlist = $symbols->{$a}; 2360 if (!defined($symlist)) { 2361 $symlist = [$a, "", $a]; 2362 } 2363 2364 # We can have a sequence of symbols for a particular entry 2365 # (more than one symbol in the case of inlining). Callers 2366 # come before callees in symlist, so walk backwards since 2367 # the translated stack should contain callees before callers. 2368 for (my $j = $#{$symlist}; $j >= 2; $j -= 3) { 2369 my $func = $symlist->[$j-2]; 2370 my $fileline = $symlist->[$j-1]; 2371 my $fullfunc = $symlist->[$j]; 2372 if ($j > 2) { 2373 $func = "$func (inline)"; 2374 } 2375 if ($main::opt_addresses) { 2376 push(@result, "$a $func $fileline"); 2377 } elsif ($main::opt_lines) { 2378 if ($func eq '??' && $fileline eq '??:0') { 2379 push(@result, "$a"); 2380 } else { 2381 push(@result, "$func $fileline"); 2382 } 2383 } elsif ($main::opt_functions) { 2384 if ($func eq '??') { 2385 push(@result, "$a"); 2386 } else { 2387 push(@result, $func); 2388 } 2389 } elsif ($main::opt_files) { 2390 if ($fileline eq '??:0' || $fileline eq '') { 2391 push(@result, "$a"); 2392 } else { 2393 my $f = $fileline; 2394 $f =~ s/:\d+$//; 2395 push(@result, $f); 2396 } 2397 } else { 2398 push(@result, $a); 2399 last; # Do not print inlined info 2400 } 2401 } 2402 } 2403 2404 # print join(",", @addrs), " => ", join(",", @result), "\n"; 2405 return @result; 2406 } 2407 2408 # Generate percent string for a number and a total 2409 sub Percent { 2410 my $num = shift; 2411 my $tot = shift; 2412 if ($tot != 0) { 2413 return sprintf("%.1f%%", $num * 100.0 / $tot); 2414 } else { 2415 return ($num == 0) ? "nan" : (($num > 0) ? "+inf" : "-inf"); 2416 } 2417 } 2418 2419 # Generate pretty-printed form of number 2420 sub Unparse { 2421 my $num = shift; 2422 if ($main::profile_type eq 'heap' || $main::profile_type eq 'growth') { 2423 if ($main::opt_inuse_objects || $main::opt_alloc_objects) { 2424 return sprintf("%d", $num); 2425 } else { 2426 if ($main::opt_show_bytes) { 2427 return sprintf("%d", $num); 2428 } else { 2429 return sprintf("%.1f", $num / 1048576.0); 2430 } 2431 } 2432 } elsif ($main::profile_type eq 'contention' && !$main::opt_contentions) { 2433 return sprintf("%.3f", $num / 1e9); # Convert nanoseconds to seconds 2434 } else { 2435 return sprintf("%d", $num); 2436 } 2437 } 2438 2439 # Alternate pretty-printed form: 0 maps to "." 2440 sub UnparseAlt { 2441 my $num = shift; 2442 if ($num == 0) { 2443 return "."; 2444 } else { 2445 return Unparse($num); 2446 } 2447 } 2448 2449 # Alternate pretty-printed form: 0 maps to "" 2450 sub HtmlPrintNumber { 2451 my $num = shift; 2452 if ($num == 0) { 2453 return ""; 2454 } else { 2455 return Unparse($num); 2456 } 2457 } 2458 2459 # Return output units 2460 sub Units { 2461 if ($main::profile_type eq 'heap' || $main::profile_type eq 'growth') { 2462 if ($main::opt_inuse_objects || $main::opt_alloc_objects) { 2463 return "objects"; 2464 } else { 2465 if ($main::opt_show_bytes) { 2466 return "B"; 2467 } else { 2468 return "MB"; 2469 } 2470 } 2471 } elsif ($main::profile_type eq 'contention' && !$main::opt_contentions) { 2472 return "seconds"; 2473 } elsif ($main::profile_type eq 'thread') { 2474 return "threads"; 2475 } else { 2476 return "samples"; 2477 } 2478 } 2479 2480 ##### Profile manipulation code ##### 2481 2482 # Generate flattened profile: 2483 # If count is charged to stack [a,b,c,d], in generated profile, 2484 # it will be charged to [a] 2485 sub FlatProfile { 2486 my $profile = shift; 2487 my $result = {}; 2488 foreach my $k (keys(%{$profile})) { 2489 my $count = $profile->{$k}; 2490 my @addrs = split(/\n/, $k); 2491 if ($#addrs >= 0) { 2492 AddEntry($result, $addrs[0], $count); 2493 } 2494 } 2495 return $result; 2496 } 2497 2498 # Generate cumulative profile: 2499 # If count is charged to stack [a,b,c,d], in generated profile, 2500 # it will be charged to [a], [b], [c], [d] 2501 sub CumulativeProfile { 2502 my $profile = shift; 2503 my $result = {}; 2504 foreach my $k (keys(%{$profile})) { 2505 my $count = $profile->{$k}; 2506 my @addrs = split(/\n/, $k); 2507 foreach my $a (@addrs) { 2508 AddEntry($result, $a, $count); 2509 } 2510 } 2511 return $result; 2512 } 2513 2514 # If the second-youngest PC on the stack is always the same, returns 2515 # that pc. Otherwise, returns undef. 2516 sub IsSecondPcAlwaysTheSame { 2517 my $profile = shift; 2518 2519 my $second_pc = undef; 2520 foreach my $k (keys(%{$profile})) { 2521 my @addrs = split(/\n/, $k); 2522 if ($#addrs < 1) { 2523 return undef; 2524 } 2525 if (not defined $second_pc) { 2526 $second_pc = $addrs[1]; 2527 } else { 2528 if ($second_pc ne $addrs[1]) { 2529 return undef; 2530 } 2531 } 2532 } 2533 return $second_pc; 2534 } 2535 2536 sub ExtractSymbolLocation { 2537 my $symbols = shift; 2538 my $address = shift; 2539 # 'addr2line' outputs "??:0" for unknown locations; we do the 2540 # same to be consistent. 2541 my $location = "??:0:unknown"; 2542 if (exists $symbols->{$address}) { 2543 my $file = $symbols->{$address}->[1]; 2544 if ($file eq "?") { 2545 $file = "??:0" 2546 } 2547 $location = $file . ":" . $symbols->{$address}->[0]; 2548 } 2549 return $location; 2550 } 2551 2552 # Extracts a graph of calls. 2553 sub ExtractCalls { 2554 my $symbols = shift; 2555 my $profile = shift; 2556 2557 my $calls = {}; 2558 while( my ($stack_trace, $count) = each %$profile ) { 2559 my @address = split(/\n/, $stack_trace); 2560 my $destination = ExtractSymbolLocation($symbols, $address[0]); 2561 AddEntry($calls, $destination, $count); 2562 for (my $i = 1; $i <= $#address; $i++) { 2563 my $source = ExtractSymbolLocation($symbols, $address[$i]); 2564 my $call = "$source -> $destination"; 2565 AddEntry($calls, $call, $count); 2566 $destination = $source; 2567 } 2568 } 2569 2570 return $calls; 2571 } 2572 2573 sub RemoveUninterestingFrames { 2574 my $symbols = shift; 2575 my $profile = shift; 2576 2577 # List of function names to skip 2578 my %skip = (); 2579 my $skip_regexp = 'NOMATCH'; 2580 if ($main::profile_type eq 'heap' || $main::profile_type eq 'growth') { 2581 foreach my $name ('calloc', 2582 'cfree', 2583 'malloc', 2584 'free', 2585 'memalign', 2586 'posix_memalign', 2587 'pvalloc', 2588 'valloc', 2589 'realloc', 2590 'tc_calloc', 2591 'tc_cfree', 2592 'tc_malloc', 2593 'tc_free', 2594 'tc_memalign', 2595 'tc_posix_memalign', 2596 'tc_pvalloc', 2597 'tc_valloc', 2598 'tc_realloc', 2599 'tc_new', 2600 'tc_delete', 2601 'tc_newarray', 2602 'tc_deletearray', 2603 'tc_new_nothrow', 2604 'tc_newarray_nothrow', 2605 'do_malloc', 2606 '::do_malloc', # new name -- got moved to an unnamed ns 2607 '::do_malloc_or_cpp_alloc', 2608 'DoSampledAllocation', 2609 'simple_alloc::allocate', 2610 '__malloc_alloc_template::allocate', 2611 '__builtin_delete', 2612 '__builtin_new', 2613 '__builtin_vec_delete', 2614 '__builtin_vec_new', 2615 'operator new', 2616 'operator new[]', 2617 # Go 2618 'catstring', 2619 'copyin', 2620 'gostring', 2621 'gostringsize', 2622 'growslice1', 2623 'appendslice1', 2624 'hash_init', 2625 'hash_subtable_new', 2626 'hash_conv', 2627 'hash_grow', 2628 'hash_insert_internal', 2629 'hash_insert', 2630 'mapassign', 2631 'runtime.mapassign', 2632 'runtime.appendslice', 2633 'runtime.mapassign1', 2634 'makechan', 2635 'makemap', 2636 'mal', 2637 'runtime.new', 2638 'makeslice1', 2639 'runtime.malloc', 2640 'unsafe.New', 2641 'runtime.mallocgc', 2642 'runtime.catstring', 2643 'runtime.growslice', 2644 'runtime.ifaceT2E', 2645 'runtime.ifaceT2I', 2646 'runtime.makechan', 2647 'runtime.makechan_c', 2648 'runtime.makemap', 2649 'runtime.makemap_c', 2650 'runtime.makeslice', 2651 'runtime.mal', 2652 'runtime.settype', 2653 'runtime.settype_flush', 2654 'runtime.slicebytetostring', 2655 'runtime.sliceinttostring', 2656 'runtime.stringtoslicebyte', 2657 'runtime.stringtosliceint', 2658 # These mark the beginning/end of our custom sections 2659 '__start_google_malloc', 2660 '__stop_google_malloc', 2661 '__start_malloc_hook', 2662 '__stop_malloc_hook') { 2663 $skip{$name} = 1; 2664 $skip{"_" . $name} = 1; # Mach (OS X) adds a _ prefix to everything 2665 } 2666 # TODO: Remove TCMalloc once everything has been 2667 # moved into the tcmalloc:: namespace and we have flushed 2668 # old code out of the system. 2669 $skip_regexp = "TCMalloc|^tcmalloc::"; 2670 } elsif ($main::profile_type eq 'contention') { 2671 foreach my $vname ('Mutex::Unlock', 'Mutex::UnlockSlow') { 2672 $skip{$vname} = 1; 2673 } 2674 } elsif ($main::profile_type eq 'cpu') { 2675 # Drop signal handlers used for CPU profile collection 2676 # TODO(dpeng): this should not be necessary; it's taken 2677 # care of by the general 2nd-pc mechanism below. 2678 foreach my $name ('ProfileData::Add', # historical 2679 'ProfileData::prof_handler', # historical 2680 'CpuProfiler::prof_handler', 2681 '__FRAME_END__', 2682 '__pthread_sighandler', 2683 '__restore') { 2684 $skip{$name} = 1; 2685 } 2686 } else { 2687 # Nothing skipped for unknown types 2688 } 2689 2690 # Go doesn't have the problem that this heuristic tries to fix. Disable. 2691 if (0 && $main::profile_type eq 'cpu') { 2692 # If all the second-youngest program counters are the same, 2693 # this STRONGLY suggests that it is an artifact of measurement, 2694 # i.e., stack frames pushed by the CPU profiler signal handler. 2695 # Hence, we delete them. 2696 # (The topmost PC is read from the signal structure, not from 2697 # the stack, so it does not get involved.) 2698 while (my $second_pc = IsSecondPcAlwaysTheSame($profile)) { 2699 my $result = {}; 2700 my $func = ''; 2701 if (exists($symbols->{$second_pc})) { 2702 $second_pc = $symbols->{$second_pc}->[0]; 2703 } 2704 print STDERR "Removing $second_pc from all stack traces.\n"; 2705 foreach my $k (keys(%{$profile})) { 2706 my $count = $profile->{$k}; 2707 my @addrs = split(/\n/, $k); 2708 splice @addrs, 1, 1; 2709 my $reduced_path = join("\n", @addrs); 2710 AddEntry($result, $reduced_path, $count); 2711 } 2712 $profile = $result; 2713 } 2714 } 2715 2716 my $result = {}; 2717 foreach my $k (keys(%{$profile})) { 2718 my $count = $profile->{$k}; 2719 my @addrs = split(/\n/, $k); 2720 my @path = (); 2721 foreach my $a (@addrs) { 2722 if (exists($symbols->{$a})) { 2723 my $func = $symbols->{$a}->[0]; 2724 if ($skip{$func} || ($func =~ m/$skip_regexp/)) { 2725 next; 2726 } 2727 } 2728 push(@path, $a); 2729 } 2730 my $reduced_path = join("\n", @path); 2731 AddEntry($result, $reduced_path, $count); 2732 } 2733 return $result; 2734 } 2735 2736 # Reduce profile to granularity given by user 2737 sub ReduceProfile { 2738 my $symbols = shift; 2739 my $profile = shift; 2740 my $result = {}; 2741 foreach my $k (keys(%{$profile})) { 2742 my $count = $profile->{$k}; 2743 my @translated = TranslateStack($symbols, $k); 2744 my @path = (); 2745 my %seen = (); 2746 $seen{''} = 1; # So that empty keys are skipped 2747 foreach my $e (@translated) { 2748 # To avoid double-counting due to recursion, skip a stack-trace 2749 # entry if it has already been seen 2750 if (!$seen{$e}) { 2751 $seen{$e} = 1; 2752 push(@path, $e); 2753 } 2754 } 2755 my $reduced_path = join("\n", @path); 2756 AddEntry($result, $reduced_path, $count); 2757 } 2758 return $result; 2759 } 2760 2761 # Does the specified symbol array match the regexp? 2762 sub SymbolMatches { 2763 my $sym = shift; 2764 my $re = shift; 2765 if (defined($sym)) { 2766 for (my $i = 0; $i < $#{$sym}; $i += 3) { 2767 if ($sym->[$i] =~ m/$re/ || $sym->[$i+1] =~ m/$re/) { 2768 return 1; 2769 } 2770 } 2771 } 2772 return 0; 2773 } 2774 2775 # Focus only on paths involving specified regexps 2776 sub FocusProfile { 2777 my $symbols = shift; 2778 my $profile = shift; 2779 my $focus = shift; 2780 my $result = {}; 2781 foreach my $k (keys(%{$profile})) { 2782 my $count = $profile->{$k}; 2783 my @addrs = split(/\n/, $k); 2784 foreach my $a (@addrs) { 2785 # Reply if it matches either the address/shortname/fileline 2786 if (($a =~ m/$focus/) || SymbolMatches($symbols->{$a}, $focus)) { 2787 AddEntry($result, $k, $count); 2788 last; 2789 } 2790 } 2791 } 2792 return $result; 2793 } 2794 2795 # Focus only on paths not involving specified regexps 2796 sub IgnoreProfile { 2797 my $symbols = shift; 2798 my $profile = shift; 2799 my $ignore = shift; 2800 my $result = {}; 2801 foreach my $k (keys(%{$profile})) { 2802 my $count = $profile->{$k}; 2803 my @addrs = split(/\n/, $k); 2804 my $matched = 0; 2805 foreach my $a (@addrs) { 2806 # Reply if it matches either the address/shortname/fileline 2807 if (($a =~ m/$ignore/) || SymbolMatches($symbols->{$a}, $ignore)) { 2808 $matched = 1; 2809 last; 2810 } 2811 } 2812 if (!$matched) { 2813 AddEntry($result, $k, $count); 2814 } 2815 } 2816 return $result; 2817 } 2818 2819 # Get total count in profile 2820 sub TotalProfile { 2821 my $profile = shift; 2822 my $result = 0; 2823 foreach my $k (keys(%{$profile})) { 2824 $result += $profile->{$k}; 2825 } 2826 return $result; 2827 } 2828 2829 # Add A to B 2830 sub AddProfile { 2831 my $A = shift; 2832 my $B = shift; 2833 2834 my $R = {}; 2835 # add all keys in A 2836 foreach my $k (keys(%{$A})) { 2837 my $v = $A->{$k}; 2838 AddEntry($R, $k, $v); 2839 } 2840 # add all keys in B 2841 foreach my $k (keys(%{$B})) { 2842 my $v = $B->{$k}; 2843 AddEntry($R, $k, $v); 2844 } 2845 return $R; 2846 } 2847 2848 # Merges symbol maps 2849 sub MergeSymbols { 2850 my $A = shift; 2851 my $B = shift; 2852 2853 my $R = {}; 2854 foreach my $k (keys(%{$A})) { 2855 $R->{$k} = $A->{$k}; 2856 } 2857 if (defined($B)) { 2858 foreach my $k (keys(%{$B})) { 2859 $R->{$k} = $B->{$k}; 2860 } 2861 } 2862 return $R; 2863 } 2864 2865 2866 # Add A to B 2867 sub AddPcs { 2868 my $A = shift; 2869 my $B = shift; 2870 2871 my $R = {}; 2872 # add all keys in A 2873 foreach my $k (keys(%{$A})) { 2874 $R->{$k} = 1 2875 } 2876 # add all keys in B 2877 foreach my $k (keys(%{$B})) { 2878 $R->{$k} = 1 2879 } 2880 return $R; 2881 } 2882 2883 # Subtract B from A 2884 sub SubtractProfile { 2885 my $A = shift; 2886 my $B = shift; 2887 2888 my $R = {}; 2889 foreach my $k (keys(%{$A})) { 2890 my $v = $A->{$k} - GetEntry($B, $k); 2891 if ($v < 0 && $main::opt_drop_negative) { 2892 $v = 0; 2893 } 2894 AddEntry($R, $k, $v); 2895 } 2896 if (!$main::opt_drop_negative) { 2897 # Take care of when subtracted profile has more entries 2898 foreach my $k (keys(%{$B})) { 2899 if (!exists($A->{$k})) { 2900 AddEntry($R, $k, 0 - $B->{$k}); 2901 } 2902 } 2903 } 2904 return $R; 2905 } 2906 2907 # Get entry from profile; zero if not present 2908 sub GetEntry { 2909 my $profile = shift; 2910 my $k = shift; 2911 if (exists($profile->{$k})) { 2912 return $profile->{$k}; 2913 } else { 2914 return 0; 2915 } 2916 } 2917 2918 # Add entry to specified profile 2919 sub AddEntry { 2920 my $profile = shift; 2921 my $k = shift; 2922 my $n = shift; 2923 if (!exists($profile->{$k})) { 2924 $profile->{$k} = 0; 2925 } 2926 $profile->{$k} += $n; 2927 } 2928 2929 # Add a stack of entries to specified profile, and add them to the $pcs 2930 # list. 2931 sub AddEntries { 2932 my $profile = shift; 2933 my $pcs = shift; 2934 my $stack = shift; 2935 my $count = shift; 2936 my @k = (); 2937 2938 foreach my $e (split(/\s+/, $stack)) { 2939 my $pc = HexExtend($e); 2940 $pcs->{$pc} = 1; 2941 push @k, $pc; 2942 } 2943 AddEntry($profile, (join "\n", @k), $count); 2944 } 2945 2946 sub IsSymbolizedProfileFile { 2947 my $file_name = shift; 2948 2949 if (!(-e $file_name) || !(-r $file_name)) { 2950 return 0; 2951 } 2952 2953 $SYMBOL_PAGE =~ m,[^/]+$,; # matches everything after the last slash 2954 my $symbol_marker = $&; 2955 # Check if the file contains a symbol-section marker. 2956 open(TFILE, "<$file_name"); 2957 my @lines = <TFILE>; 2958 my $result = grep(/^--- *$symbol_marker/, @lines); 2959 close(TFILE); 2960 return $result > 0; 2961 } 2962 2963 ##### Code to profile a server dynamically ##### 2964 2965 sub CheckSymbolPage { 2966 my $url = SymbolPageURL(); 2967 print STDERR "Read $url\n"; 2968 open(SYMBOL, "$CURL -s '$url' |"); 2969 my $line = <SYMBOL>; 2970 $line =~ s/\r//g; # turn windows-looking lines into unix-looking lines 2971 close(SYMBOL); 2972 unless (defined($line)) { 2973 error("$url doesn't exist\n"); 2974 } 2975 2976 if ($line =~ /^num_symbols:\s+(\d+)$/) { 2977 if ($1 == 0) { 2978 error("Stripped binary. No symbols available.\n"); 2979 } 2980 } else { 2981 error("Failed to get the number of symbols from $url\n"); 2982 } 2983 } 2984 2985 sub IsProfileURL { 2986 my $profile_name = shift; 2987 my ($scheme, $host, $port, $prefix, $path) = ParseProfileURL($profile_name); 2988 return defined($host) and defined($port) and defined($path); 2989 } 2990 2991 sub ParseProfileURL { 2992 my $profile_name = shift; 2993 if (defined($profile_name) && 2994 $profile_name =~ m,^(?:(https?)://|)([^/:]+):(\d+)(|\@\d+)(|/|(.*?)($PROFILE_PAGE|$PMUPROFILE_PAGE|$HEAP_PAGE|$GROWTH_PAGE|$THREAD_PAGE|$CONTENTION_PAGE|$WALL_PAGE|$FILTEREDPROFILE_PAGE))$,o) { 2995 # $7 is $PROFILE_PAGE/$HEAP_PAGE/etc. $5 is *everything* after 2996 # the hostname, as long as that everything is the empty string, 2997 # a slash, or something ending in $PROFILE_PAGE/$HEAP_PAGE/etc. 2998 # So "$7 || $5" is $PROFILE_PAGE/etc if there, or else it's "/" or "". 2999 return ($1 || "http", $2, $3, $6, $7 || $5); 3000 } 3001 return (); 3002 } 3003 3004 # We fetch symbols from the first profile argument. 3005 sub SymbolPageURL { 3006 my ($scheme, $host, $port, $prefix, $path) = ParseProfileURL($main::pfile_args[0]); 3007 return "$scheme://$host:$port$prefix$SYMBOL_PAGE"; 3008 } 3009 3010 sub FetchProgramName() { 3011 my ($scheme, $host, $port, $prefix, $path) = ParseProfileURL($main::pfile_args[0]); 3012 my $url = "$scheme://$host:$port$prefix$PROGRAM_NAME_PAGE"; 3013 my $command_line = "$CURL -s '$url'"; 3014 open(CMDLINE, "$command_line |") or error($command_line); 3015 my $cmdline = <CMDLINE>; 3016 $cmdline =~ s/\r//g; # turn windows-looking lines into unix-looking lines 3017 close(CMDLINE); 3018 error("Failed to get program name from $url\n") unless defined($cmdline); 3019 $cmdline =~ s/\x00.+//; # Remove argv[1] and latters. 3020 $cmdline =~ s!\n!!g; # Remove LFs. 3021 return $cmdline; 3022 } 3023 3024 # Gee, curl's -L (--location) option isn't reliable at least 3025 # with its 7.12.3 version. Curl will forget to post data if 3026 # there is a redirection. This function is a workaround for 3027 # curl. Redirection happens on borg hosts. 3028 sub ResolveRedirectionForCurl { 3029 my $url = shift; 3030 my $command_line = "$CURL -s --head '$url'"; 3031 open(CMDLINE, "$command_line |") or error($command_line); 3032 while (<CMDLINE>) { 3033 s/\r//g; # turn windows-looking lines into unix-looking lines 3034 if (/^Location: (.*)/) { 3035 $url = $1; 3036 } 3037 } 3038 close(CMDLINE); 3039 return $url; 3040 } 3041 3042 # Reads a symbol map from the file handle name given as $1, returning 3043 # the resulting symbol map. Also processes variables relating to symbols. 3044 # Currently, the only variable processed is 'binary=<value>' which updates 3045 # $main::prog to have the correct program name. 3046 sub ReadSymbols { 3047 my $in = shift; 3048 my $map = shift; 3049 while (<$in>) { 3050 s/\r//g; # turn windows-looking lines into unix-looking lines 3051 # Removes all the leading zeroes from the symbols, see comment below. 3052 if (m/^0x0*([0-9a-f]+)\s+(.+)/) { 3053 $map->{$1} = $2; 3054 } elsif (m/^---/) { 3055 last; 3056 } elsif (m/^([a-z][^=]*)=(.*)$/ ) { 3057 my ($variable, $value) = ($1, $2); 3058 for ($variable, $value) { 3059 s/^\s+//; 3060 s/\s+$//; 3061 } 3062 if ($variable eq "binary") { 3063 if ($main::prog ne $UNKNOWN_BINARY && $main::prog ne $value) { 3064 printf STDERR ("Warning: Mismatched binary name '%s', using '%s'.\n", 3065 $main::prog, $value); 3066 } 3067 $main::prog = $value; 3068 } else { 3069 printf STDERR ("Ignoring unknown variable in symbols list: " . 3070 "'%s' = '%s'\n", $variable, $value); 3071 } 3072 } 3073 } 3074 return $map; 3075 } 3076 3077 # Fetches and processes symbols to prepare them for use in the profile output 3078 # code. If the optional 'symbol_map' arg is not given, fetches symbols from 3079 # $SYMBOL_PAGE for all PC values found in profile. Otherwise, the raw symbols 3080 # are assumed to have already been fetched into 'symbol_map' and are simply 3081 # extracted and processed. 3082 sub FetchSymbols { 3083 my $pcset = shift; 3084 my $symbol_map = shift; 3085 3086 my %seen = (); 3087 my @pcs = grep { !$seen{$_}++ } keys(%$pcset); # uniq 3088 3089 if (!defined($symbol_map)) { 3090 $symbol_map = {}; 3091 3092 my $post_data = join("+", sort((map {"0x" . "$_"} @pcs))); 3093 open(POSTFILE, ">$main::tmpfile_sym"); 3094 print POSTFILE $post_data; 3095 close(POSTFILE); 3096 3097 my $url = SymbolPageURL(); 3098 $url = ResolveRedirectionForCurl($url); 3099 my $command_line = "$CURL -sd '\@$main::tmpfile_sym' '$url'"; 3100 open(SYMBOL, "$command_line |") or error($command_line); 3101 ReadSymbols(*SYMBOL{IO}, $symbol_map); 3102 close(SYMBOL); 3103 } 3104 3105 my $symbols = {}; 3106 foreach my $pc (@pcs) { 3107 my $fullname; 3108 # For 64 bits binaries, symbols are extracted with 8 leading zeroes. 3109 # Then /symbol reads the long symbols in as uint64, and outputs 3110 # the result with a "0x%08llx" format which get rid of the zeroes. 3111 # By removing all the leading zeroes in both $pc and the symbols from 3112 # /symbol, the symbols match and are retrievable from the map. 3113 my $shortpc = $pc; 3114 $shortpc =~ s/^0*//; 3115 # Each line may have a list of names, which includes the function 3116 # and also other functions it has inlined. They are separated 3117 # (in PrintSymbolizedFile), by --, which is illegal in function names. 3118 my $fullnames; 3119 if (defined($symbol_map->{$shortpc})) { 3120 $fullnames = $symbol_map->{$shortpc}; 3121 } else { 3122 $fullnames = "0x" . $pc; # Just use addresses 3123 } 3124 my $sym = []; 3125 $symbols->{$pc} = $sym; 3126 foreach my $fullname (split("--", $fullnames)) { 3127 my $name = ShortFunctionName($fullname); 3128 push(@{$sym}, $name, "?", $fullname); 3129 } 3130 } 3131 return $symbols; 3132 } 3133 3134 sub BaseName { 3135 my $file_name = shift; 3136 $file_name =~ s!^.*/!!; # Remove directory name 3137 return $file_name; 3138 } 3139 3140 sub MakeProfileBaseName { 3141 my ($binary_name, $profile_name) = @_; 3142 my ($scheme, $host, $port, $prefix, $path) = ParseProfileURL($profile_name); 3143 my $binary_shortname = BaseName($binary_name); 3144 return sprintf("%s.%s.%s-port%s", 3145 $binary_shortname, $main::op_time, $host, $port); 3146 } 3147 3148 sub FetchDynamicProfile { 3149 my $binary_name = shift; 3150 my $profile_name = shift; 3151 my $fetch_name_only = shift; 3152 my $encourage_patience = shift; 3153 3154 if (!IsProfileURL($profile_name)) { 3155 return $profile_name; 3156 } else { 3157 my ($scheme, $host, $port, $prefix, $path) = ParseProfileURL($profile_name); 3158 if ($path eq "" || $path eq "/") { 3159 # Missing type specifier defaults to cpu-profile 3160 $path = $PROFILE_PAGE; 3161 } 3162 3163 my $profile_file = MakeProfileBaseName($binary_name, $profile_name); 3164 3165 my $url; 3166 my $curl_timeout; 3167 if (($path =~ m/$PROFILE_PAGE/) || ($path =~ m/$PMUPROFILE_PAGE/)) { 3168 if ($path =~ m/$PROFILE_PAGE/) { 3169 $url = sprintf("$scheme://$host:$port$prefix$path?seconds=%d", 3170 $main::opt_seconds); 3171 } else { 3172 if ($profile_name =~ m/[?]/) { 3173 $profile_name .= "&" 3174 } else { 3175 $profile_name .= "?" 3176 } 3177 $url = sprintf("$scheme://$profile_name" . "seconds=%d", 3178 $main::opt_seconds); 3179 } 3180 $curl_timeout = sprintf("--max-time %d", 3181 int($main::opt_seconds * 1.01 + 60)); 3182 } else { 3183 # For non-CPU profiles, we add a type-extension to 3184 # the target profile file name. 3185 my $suffix = $path; 3186 $suffix =~ s,/,.,g; 3187 $profile_file .= "$suffix"; 3188 $url = "$scheme://$host:$port$prefix$path"; 3189 $curl_timeout = ""; 3190 } 3191 3192 my $profile_dir = $ENV{"PPROF_TMPDIR"} || ($ENV{HOME} . "/pprof"); 3193 if (!(-d $profile_dir)) { 3194 mkdir($profile_dir) 3195 || die("Unable to create profile directory $profile_dir: $!\n"); 3196 } 3197 my $tmp_profile = "$profile_dir/.tmp.$profile_file"; 3198 my $real_profile = "$profile_dir/$profile_file"; 3199 3200 if ($fetch_name_only > 0) { 3201 return $real_profile; 3202 } 3203 3204 my $cmd = "$CURL $curl_timeout -s -o $tmp_profile '$url'"; 3205 if (($path =~ m/$PROFILE_PAGE/) || ($path =~ m/$PMUPROFILE_PAGE/)){ 3206 print STDERR "Gathering CPU profile from $url for $main::opt_seconds seconds to\n ${real_profile}\n"; 3207 if ($encourage_patience) { 3208 print STDERR "Be patient...\n"; 3209 } 3210 } else { 3211 print STDERR "Fetching $path profile from $host:$port to\n ${real_profile}\n"; 3212 } 3213 3214 (system($cmd) == 0) || error("Failed to get profile: $cmd: $!\n"); 3215 open(TMPPROF, "$tmp_profile") || error("Cannot open $tmp_profile: $!\n"); 3216 my $line = <TMPPROF>; 3217 close(TMPPROF); 3218 $line !~ /^Could not enable CPU profiling/ || error($line); 3219 (system("mv $tmp_profile $real_profile") == 0) || error("Unable to rename profile\n"); 3220 print STDERR "Wrote profile to $real_profile\n"; 3221 $main::collected_profile = $real_profile; 3222 return $main::collected_profile; 3223 } 3224 } 3225 3226 # Collect profiles in parallel 3227 sub FetchDynamicProfiles { 3228 my $items = scalar(@main::pfile_args); 3229 my $levels = log($items) / log(2); 3230 3231 if ($items == 1) { 3232 $main::profile_files[0] = FetchDynamicProfile($main::prog, $main::pfile_args[0], 0, 1); 3233 } else { 3234 # math rounding issues 3235 if ((2 ** $levels) < $items) { 3236 $levels++; 3237 } 3238 my $count = scalar(@main::pfile_args); 3239 for (my $i = 0; $i < $count; $i++) { 3240 $main::profile_files[$i] = FetchDynamicProfile($main::prog, $main::pfile_args[$i], 1, 0); 3241 } 3242 print STDERR "Fetching $count profiles, Be patient...\n"; 3243 FetchDynamicProfilesRecurse($levels, 0, 0); 3244 $main::collected_profile = join(" \\\n ", @main::profile_files); 3245 } 3246 } 3247 3248 # Recursively fork a process to get enough processes 3249 # collecting profiles 3250 sub FetchDynamicProfilesRecurse { 3251 my $maxlevel = shift; 3252 my $level = shift; 3253 my $position = shift; 3254 3255 if (my $pid = fork()) { 3256 $position = 0 | ($position << 1); 3257 TryCollectProfile($maxlevel, $level, $position); 3258 wait; 3259 } else { 3260 $position = 1 | ($position << 1); 3261 TryCollectProfile($maxlevel, $level, $position); 3262 exit(0); 3263 } 3264 } 3265 3266 # Collect a single profile 3267 sub TryCollectProfile { 3268 my $maxlevel = shift; 3269 my $level = shift; 3270 my $position = shift; 3271 3272 if ($level >= ($maxlevel - 1)) { 3273 if ($position < scalar(@main::pfile_args)) { 3274 FetchDynamicProfile($main::prog, $main::pfile_args[$position], 0, 0); 3275 } 3276 } else { 3277 FetchDynamicProfilesRecurse($maxlevel, $level+1, $position); 3278 } 3279 } 3280 3281 ##### Parsing code ##### 3282 3283 # Provide a small streaming-read module to handle very large 3284 # cpu-profile files. Stream in chunks along a sliding window. 3285 # Provides an interface to get one 'slot', correctly handling 3286 # endian-ness differences. A slot is one 32-bit or 64-bit word 3287 # (depending on the input profile). We tell endianness and bit-size 3288 # for the profile by looking at the first 8 bytes: in cpu profiles, 3289 # the second slot is always 3 (we'll accept anything that's not 0). 3290 BEGIN { 3291 package CpuProfileStream; 3292 3293 sub new { 3294 my ($class, $file, $fname) = @_; 3295 my $self = { file => $file, 3296 base => 0, 3297 stride => 512 * 1024, # must be a multiple of bitsize/8 3298 slots => [], 3299 unpack_code => "", # N for big-endian, V for little 3300 }; 3301 bless $self, $class; 3302 # Let unittests adjust the stride 3303 if ($main::opt_test_stride > 0) { 3304 $self->{stride} = $main::opt_test_stride; 3305 } 3306 # Read the first two slots to figure out bitsize and endianness. 3307 my $slots = $self->{slots}; 3308 my $str; 3309 read($self->{file}, $str, 8); 3310 # Set the global $address_length based on what we see here. 3311 # 8 is 32-bit (8 hexadecimal chars); 16 is 64-bit (16 hexadecimal chars). 3312 $address_length = ($str eq (chr(0)x8)) ? 16 : 8; 3313 if ($address_length == 8) { 3314 if (substr($str, 6, 2) eq chr(0)x2) { 3315 $self->{unpack_code} = 'V'; # Little-endian. 3316 } elsif (substr($str, 4, 2) eq chr(0)x2) { 3317 $self->{unpack_code} = 'N'; # Big-endian 3318 } else { 3319 ::error("$fname: header size >= 2**16\n"); 3320 } 3321 @$slots = unpack($self->{unpack_code} . "*", $str); 3322 } else { 3323 # If we're a 64-bit profile, make sure we're a 64-bit-capable 3324 # perl. Otherwise, each slot will be represented as a float 3325 # instead of an int64, losing precision and making all the 3326 # 64-bit addresses right. We *could* try to handle this with 3327 # software emulation of 64-bit ints, but that's added complexity 3328 # for no clear benefit (yet). We use 'Q' to test for 64-bit-ness; 3329 # perl docs say it's only available on 64-bit perl systems. 3330 my $has_q = 0; 3331 eval { $has_q = pack("Q", "1") ? 1 : 1; }; 3332 if (!$has_q) { 3333 ::error("$fname: need a 64-bit perl to process this 64-bit profile.\n"); 3334 } 3335 read($self->{file}, $str, 8); 3336 if (substr($str, 4, 4) eq chr(0)x4) { 3337 # We'd love to use 'Q', but it's a) not universal, b) not endian-proof. 3338 $self->{unpack_code} = 'V'; # Little-endian. 3339 } elsif (substr($str, 0, 4) eq chr(0)x4) { 3340 $self->{unpack_code} = 'N'; # Big-endian 3341 } else { 3342 ::error("$fname: header size >= 2**32\n"); 3343 } 3344 my @pair = unpack($self->{unpack_code} . "*", $str); 3345 # Since we know one of the pair is 0, it's fine to just add them. 3346 @$slots = (0, $pair[0] + $pair[1]); 3347 } 3348 return $self; 3349 } 3350 3351 # Load more data when we access slots->get(X) which is not yet in memory. 3352 sub overflow { 3353 my ($self) = @_; 3354 my $slots = $self->{slots}; 3355 $self->{base} += $#$slots + 1; # skip over data we're replacing 3356 my $str; 3357 read($self->{file}, $str, $self->{stride}); 3358 if ($address_length == 8) { # the 32-bit case 3359 # This is the easy case: unpack provides 32-bit unpacking primitives. 3360 @$slots = unpack($self->{unpack_code} . "*", $str); 3361 } else { 3362 # We need to unpack 32 bits at a time and combine. 3363 my @b32_values = unpack($self->{unpack_code} . "*", $str); 3364 my @b64_values = (); 3365 for (my $i = 0; $i < $#b32_values; $i += 2) { 3366 # TODO(csilvers): if this is a 32-bit perl, the math below 3367 # could end up in a too-large int, which perl will promote 3368 # to a double, losing necessary precision. Deal with that. 3369 if ($self->{unpack_code} eq 'V') { # little-endian 3370 push(@b64_values, $b32_values[$i] + $b32_values[$i+1] * (2**32)); 3371 } else { 3372 push(@b64_values, $b32_values[$i] * (2**32) + $b32_values[$i+1]); 3373 } 3374 } 3375 @$slots = @b64_values; 3376 } 3377 } 3378 3379 # Access the i-th long in the file (logically), or -1 at EOF. 3380 sub get { 3381 my ($self, $idx) = @_; 3382 my $slots = $self->{slots}; 3383 while ($#$slots >= 0) { 3384 if ($idx < $self->{base}) { 3385 # The only time we expect a reference to $slots[$i - something] 3386 # after referencing $slots[$i] is reading the very first header. 3387 # Since $stride > |header|, that shouldn't cause any lookback 3388 # errors. And everything after the header is sequential. 3389 print STDERR "Unexpected look-back reading CPU profile"; 3390 return -1; # shrug, don't know what better to return 3391 } elsif ($idx > $self->{base} + $#$slots) { 3392 $self->overflow(); 3393 } else { 3394 return $slots->[$idx - $self->{base}]; 3395 } 3396 } 3397 # If we get here, $slots is [], which means we've reached EOF 3398 return -1; # unique since slots is supposed to hold unsigned numbers 3399 } 3400 } 3401 3402 # Parse profile generated by common/profiler.cc and return a reference 3403 # to a map: 3404 # $result->{version} Version number of profile file 3405 # $result->{period} Sampling period (in microseconds) 3406 # $result->{profile} Profile object 3407 # $result->{map} Memory map info from profile 3408 # $result->{pcs} Hash of all PC values seen, key is hex address 3409 sub ReadProfile { 3410 my $prog = shift; 3411 my $fname = shift; 3412 3413 if (IsSymbolizedProfileFile($fname) && !$main::use_symbolized_profile) { 3414 # we have both a binary and symbolized profiles, abort 3415 usage("Symbolized profile '$fname' cannot be used with a binary arg. " . 3416 "Try again without passing '$prog'."); 3417 } 3418 3419 $main::profile_type = ''; 3420 3421 $CONTENTION_PAGE =~ m,[^/]+$,; # matches everything after the last slash 3422 my $contention_marker = $&; 3423 $GROWTH_PAGE =~ m,[^/]+$,; # matches everything after the last slash 3424 my $growth_marker = $&; 3425 $SYMBOL_PAGE =~ m,[^/]+$,; # matches everything after the last slash 3426 my $symbol_marker = $&; 3427 $PROFILE_PAGE =~ m,[^/]+$,; # matches everything after the last slash 3428 my $profile_marker = $&; 3429 3430 # Look at first line to see if it is a heap or a CPU profile. 3431 # CPU profile may start with no header at all, and just binary data 3432 # (starting with \0\0\0\0) -- in that case, don't try to read the 3433 # whole firstline, since it may be gigabytes(!) of data. 3434 open(PROFILE, "<$fname") || error("$fname: $!\n"); 3435 binmode PROFILE; # New perls do UTF-8 processing 3436 my $firstchar = ""; 3437 my $header = ""; 3438 read(PROFILE, $firstchar, 1); 3439 seek(PROFILE, -1, 1); # unread the firstchar 3440 if ($firstchar ne "\0") { 3441 $header = <PROFILE>; 3442 if (!defined($header)) { 3443 error("Profile is empty.\n"); 3444 } 3445 $header =~ s/\r//g; # turn windows-looking lines into unix-looking lines 3446 } 3447 3448 my $symbols; 3449 if ($header =~ m/^--- *$symbol_marker/o) { 3450 # read the symbol section of the symbolized profile file 3451 $symbols = ReadSymbols(*PROFILE{IO}); 3452 3453 # read the next line to get the header for the remaining profile 3454 $header = ""; 3455 read(PROFILE, $firstchar, 1); 3456 seek(PROFILE, -1, 1); # unread the firstchar 3457 if ($firstchar ne "\0") { 3458 $header = <PROFILE>; 3459 $header =~ s/\r//g; 3460 } 3461 } 3462 3463 my $result; 3464 3465 if ($header =~ m/^heap profile:.*$growth_marker/o) { 3466 $main::profile_type = 'growth'; 3467 $result = ReadHeapProfile($prog, $fname, $header); 3468 } elsif ($header =~ m/^heap profile:/) { 3469 $main::profile_type = 'heap'; 3470 $result = ReadHeapProfile($prog, $fname, $header); 3471 } elsif ($header =~ m/^--- *$contention_marker/o) { 3472 $main::profile_type = 'contention'; 3473 $result = ReadSynchProfile($prog, $fname); 3474 } elsif ($header =~ m/^--- *Stacks:/) { 3475 print STDERR 3476 "Old format contention profile: mistakenly reports " . 3477 "condition variable signals as lock contentions.\n"; 3478 $main::profile_type = 'contention'; 3479 $result = ReadSynchProfile($prog, $fname); 3480 } elsif ($header =~ m/^thread creation profile:/) { 3481 $main::profile_type = 'thread'; 3482 $result = ReadThreadProfile($prog, $fname); 3483 } elsif ($header =~ m/^--- *$profile_marker/) { 3484 # the binary cpu profile data starts immediately after this line 3485 $main::profile_type = 'cpu'; 3486 $result = ReadCPUProfile($prog, $fname); 3487 } else { 3488 if (defined($symbols)) { 3489 # a symbolized profile contains a format we don't recognize, bail out 3490 error("$fname: Cannot recognize profile section after symbols.\n"); 3491 } 3492 # no ascii header present -- must be a CPU profile 3493 $main::profile_type = 'cpu'; 3494 $result = ReadCPUProfile($prog, $fname); 3495 } 3496 3497 # if we got symbols along with the profile, return those as well 3498 if (defined($symbols)) { 3499 $result->{symbols} = $symbols; 3500 } 3501 3502 return $result; 3503 } 3504 3505 # Subtract one from caller pc so we map back to call instr. 3506 # However, don't do this if we're reading a symbolized profile 3507 # file, in which case the subtract-one was done when the file 3508 # was written. 3509 # 3510 # We apply the same logic to all readers, though ReadCPUProfile uses an 3511 # independent implementation. 3512 sub FixCallerAddresses { 3513 my $stack = shift; 3514 if ($main::use_symbolized_profile) { 3515 return $stack; 3516 } else { 3517 $stack =~ /(\s)/; 3518 my $delimiter = $1; 3519 my @addrs = split(' ', $stack); 3520 my @fixedaddrs; 3521 $#fixedaddrs = $#addrs; 3522 if ($#addrs >= 0) { 3523 $fixedaddrs[0] = $addrs[0]; 3524 } 3525 for (my $i = 1; $i <= $#addrs; $i++) { 3526 $fixedaddrs[$i] = AddressSub($addrs[$i], "0x1"); 3527 } 3528 return join $delimiter, @fixedaddrs; 3529 } 3530 } 3531 3532 # CPU profile reader 3533 sub ReadCPUProfile { 3534 my $prog = shift; 3535 my $fname = shift; 3536 my $version; 3537 my $period; 3538 my $i; 3539 my $profile = {}; 3540 my $pcs = {}; 3541 3542 # Parse string into array of slots. 3543 my $slots = CpuProfileStream->new(*PROFILE, $fname); 3544 3545 # Read header. The current header version is a 5-element structure 3546 # containing: 3547 # 0: header count (always 0) 3548 # 1: header "words" (after this one: 3) 3549 # 2: format version (0) 3550 # 3: sampling period (usec) 3551 # 4: unused padding (always 0) 3552 if ($slots->get(0) != 0 ) { 3553 error("$fname: not a profile file, or old format profile file\n"); 3554 } 3555 $i = 2 + $slots->get(1); 3556 $version = $slots->get(2); 3557 $period = $slots->get(3); 3558 # Do some sanity checking on these header values. 3559 if ($version > (2**32) || $period > (2**32) || $i > (2**32) || $i < 5) { 3560 error("$fname: not a profile file, or corrupted profile file\n"); 3561 } 3562 3563 # Parse profile 3564 while ($slots->get($i) != -1) { 3565 my $n = $slots->get($i++); 3566 my $d = $slots->get($i++); 3567 if ($d > (2**16)) { # TODO(csilvers): what's a reasonable max-stack-depth? 3568 my $addr = sprintf("0%o", $i * ($address_length == 8 ? 4 : 8)); 3569 print STDERR "At index $i (address $addr):\n"; 3570 error("$fname: stack trace depth >= 2**32\n"); 3571 } 3572 if ($slots->get($i) == 0) { 3573 # End of profile data marker 3574 $i += $d; 3575 last; 3576 } 3577 3578 # Make key out of the stack entries 3579 my @k = (); 3580 for (my $j = 0; $j < $d; $j++) { 3581 my $pc = $slots->get($i+$j); 3582 # Subtract one from caller pc so we map back to call instr. 3583 # However, don't do this if we're reading a symbolized profile 3584 # file, in which case the subtract-one was done when the file 3585 # was written. 3586 if ($j > 0 && !$main::use_symbolized_profile) { 3587 $pc--; 3588 } 3589 $pc = sprintf("%0*x", $address_length, $pc); 3590 $pcs->{$pc} = 1; 3591 push @k, $pc; 3592 } 3593 3594 AddEntry($profile, (join "\n", @k), $n); 3595 $i += $d; 3596 } 3597 3598 # Parse map 3599 my $map = ''; 3600 seek(PROFILE, $i * 4, 0); 3601 read(PROFILE, $map, (stat PROFILE)[7]); 3602 close(PROFILE); 3603 3604 my $r = {}; 3605 $r->{version} = $version; 3606 $r->{period} = $period; 3607 $r->{profile} = $profile; 3608 $r->{libs} = ParseLibraries($prog, $map, $pcs); 3609 $r->{pcs} = $pcs; 3610 3611 return $r; 3612 } 3613 3614 sub ReadHeapProfile { 3615 my $prog = shift; 3616 my $fname = shift; 3617 my $header = shift; 3618 3619 my $index = 1; 3620 if ($main::opt_inuse_space) { 3621 $index = 1; 3622 } elsif ($main::opt_inuse_objects) { 3623 $index = 0; 3624 } elsif ($main::opt_alloc_space) { 3625 $index = 3; 3626 } elsif ($main::opt_alloc_objects) { 3627 $index = 2; 3628 } 3629 3630 # Find the type of this profile. The header line looks like: 3631 # heap profile: 1246: 8800744 [ 1246: 8800744] @ <heap-url>/266053 3632 # There are two pairs <count: size>, the first inuse objects/space, and the 3633 # second allocated objects/space. This is followed optionally by a profile 3634 # type, and if that is present, optionally by a sampling frequency. 3635 # For remote heap profiles (v1): 3636 # The interpretation of the sampling frequency is that the profiler, for 3637 # each sample, calculates a uniformly distributed random integer less than 3638 # the given value, and records the next sample after that many bytes have 3639 # been allocated. Therefore, the expected sample interval is half of the 3640 # given frequency. By default, if not specified, the expected sample 3641 # interval is 128KB. Only remote-heap-page profiles are adjusted for 3642 # sample size. 3643 # For remote heap profiles (v2): 3644 # The sampling frequency is the rate of a Poisson process. This means that 3645 # the probability of sampling an allocation of size X with sampling rate Y 3646 # is 1 - exp(-X/Y) 3647 # For version 2, a typical header line might look like this: 3648 # heap profile: 1922: 127792360 [ 1922: 127792360] @ <heap-url>_v2/524288 3649 # the trailing number (524288) is the sampling rate. (Version 1 showed 3650 # double the 'rate' here) 3651 my $sampling_algorithm = 0; 3652 my $sample_adjustment = 0; 3653 chomp($header); 3654 my $type = "unknown"; 3655 if ($header =~ m"^heap profile:\s*(\d+):\s+(\d+)\s+\[\s*(\d+):\s+(\d+)\](\s*@\s*([^/]*)(/(\d+))?)?") { 3656 if (defined($6) && ($6 ne '')) { 3657 $type = $6; 3658 my $sample_period = $8; 3659 # $type is "heapprofile" for profiles generated by the 3660 # heap-profiler, and either "heap" or "heap_v2" for profiles 3661 # generated by sampling directly within tcmalloc. It can also 3662 # be "growth" for heap-growth profiles. The first is typically 3663 # found for profiles generated locally, and the others for 3664 # remote profiles. 3665 if (($type eq "heapprofile") || ($type !~ /heap/) ) { 3666 # No need to adjust for the sampling rate with heap-profiler-derived data 3667 $sampling_algorithm = 0; 3668 } elsif ($type =~ /_v2/) { 3669 $sampling_algorithm = 2; # version 2 sampling 3670 if (defined($sample_period) && ($sample_period ne '')) { 3671 $sample_adjustment = int($sample_period); 3672 } 3673 } else { 3674 $sampling_algorithm = 1; # version 1 sampling 3675 if (defined($sample_period) && ($sample_period ne '')) { 3676 $sample_adjustment = int($sample_period)/2; 3677 } 3678 } 3679 } else { 3680 # We detect whether or not this is a remote-heap profile by checking 3681 # that the total-allocated stats ($n2,$s2) are exactly the 3682 # same as the in-use stats ($n1,$s1). It is remotely conceivable 3683 # that a non-remote-heap profile may pass this check, but it is hard 3684 # to imagine how that could happen. 3685 # In this case it's so old it's guaranteed to be remote-heap version 1. 3686 my ($n1, $s1, $n2, $s2) = ($1, $2, $3, $4); 3687 if (($n1 == $n2) && ($s1 == $s2)) { 3688 # This is likely to be a remote-heap based sample profile 3689 $sampling_algorithm = 1; 3690 } 3691 } 3692 } 3693 3694 if ($sampling_algorithm > 0) { 3695 # For remote-heap generated profiles, adjust the counts and sizes to 3696 # account for the sample rate (we sample once every 128KB by default). 3697 if ($sample_adjustment == 0) { 3698 # Turn on profile adjustment. 3699 $sample_adjustment = 128*1024; 3700 print STDERR "Adjusting heap profiles for 1-in-128KB sampling rate\n"; 3701 } else { 3702 printf STDERR ("Adjusting heap profiles for 1-in-%d sampling rate\n", 3703 $sample_adjustment); 3704 } 3705 if ($sampling_algorithm > 1) { 3706 # We don't bother printing anything for the original version (version 1) 3707 printf STDERR "Heap version $sampling_algorithm\n"; 3708 } 3709 } 3710 3711 my $profile = {}; 3712 my $pcs = {}; 3713 my $map = ""; 3714 3715 while (<PROFILE>) { 3716 s/\r//g; # turn windows-looking lines into unix-looking lines 3717 if (/^MAPPED_LIBRARIES:/) { 3718 # Read the /proc/self/maps data 3719 while (<PROFILE>) { 3720 s/\r//g; # turn windows-looking lines into unix-looking lines 3721 $map .= $_; 3722 } 3723 last; 3724 } 3725 3726 if (/^--- Memory map:/) { 3727 # Read /proc/self/maps data as formatted by DumpAddressMap() 3728 my $buildvar = ""; 3729 while (<PROFILE>) { 3730 s/\r//g; # turn windows-looking lines into unix-looking lines 3731 # Parse "build=<dir>" specification if supplied 3732 if (m/^\s*build=(.*)\n/) { 3733 $buildvar = $1; 3734 } 3735 3736 # Expand "$build" variable if available 3737 $_ =~ s/\$build\b/$buildvar/g; 3738 3739 $map .= $_; 3740 } 3741 last; 3742 } 3743 3744 # Read entry of the form: 3745 # <count1>: <bytes1> [<count2>: <bytes2>] @ a1 a2 a3 ... an 3746 s/^\s*//; 3747 s/\s*$//; 3748 if (m/^\s*(\d+):\s+(\d+)\s+\[\s*(\d+):\s+(\d+)\]\s+@\s+(.*)$/) { 3749 my $stack = $5; 3750 my ($n1, $s1, $n2, $s2) = ($1, $2, $3, $4); 3751 3752 if ($sample_adjustment) { 3753 if ($sampling_algorithm == 2) { 3754 # Remote-heap version 2 3755 # The sampling frequency is the rate of a Poisson process. 3756 # This means that the probability of sampling an allocation of 3757 # size X with sampling rate Y is 1 - exp(-X/Y) 3758 my $ratio; 3759 $ratio = (($s1*1.0)/$n1)/($sample_adjustment); 3760 my $scale_factor; 3761 $scale_factor = 1/(1 - exp(-$ratio)); 3762 $n1 *= $scale_factor; 3763 $s1 *= $scale_factor; 3764 $ratio = (($s2*1.0)/$n2)/($sample_adjustment); 3765 $scale_factor = 1/(1 - exp(-$ratio)); 3766 $n2 *= $scale_factor; 3767 $s2 *= $scale_factor; 3768 } else { 3769 # Remote-heap version 1 3770 my $ratio; 3771 if ($n1 > 0) { 3772 $ratio = (($s1*1.0)/$n1)/($sample_adjustment); 3773 if ($ratio < 1) { 3774 $n1 /= $ratio; 3775 $s1 /= $ratio; 3776 } 3777 } 3778 if ($n2 > 0) { 3779 $ratio = (($s2*1.0)/$n2)/($sample_adjustment); 3780 if ($ratio < 1) { 3781 $n2 /= $ratio; 3782 $s2 /= $ratio; 3783 } 3784 } 3785 } 3786 } 3787 3788 my @counts = ($n1, $s1, $n2, $s2); 3789 AddEntries($profile, $pcs, FixCallerAddresses($stack), $counts[$index]); 3790 } 3791 } 3792 3793 my $r = {}; 3794 $r->{version} = "heap"; 3795 $r->{period} = 1; 3796 $r->{profile} = $profile; 3797 $r->{libs} = ParseLibraries($prog, $map, $pcs); 3798 $r->{pcs} = $pcs; 3799 return $r; 3800 } 3801 3802 sub ReadThreadProfile { 3803 my $prog = shift; 3804 my $fname = shift; 3805 3806 my $profile = {}; 3807 my $pcs = {}; 3808 my $map = ""; 3809 3810 while (<PROFILE>) { 3811 s/\r//g; # turn windows-looking lines into unix-looking lines 3812 if (/^MAPPED_LIBRARIES:/) { 3813 # Read the /proc/self/maps data 3814 while (<PROFILE>) { 3815 s/\r//g; # turn windows-looking lines into unix-looking lines 3816 $map .= $_; 3817 } 3818 last; 3819 } 3820 3821 if (/^--- Memory map:/) { 3822 # Read /proc/self/maps data as formatted by DumpAddressMap() 3823 my $buildvar = ""; 3824 while (<PROFILE>) { 3825 s/\r//g; # turn windows-looking lines into unix-looking lines 3826 # Parse "build=<dir>" specification if supplied 3827 if (m/^\s*build=(.*)\n/) { 3828 $buildvar = $1; 3829 } 3830 3831 # Expand "$build" variable if available 3832 $_ =~ s/\$build\b/$buildvar/g; 3833 3834 $map .= $_; 3835 } 3836 last; 3837 } 3838 3839 # Read entry of the form: 3840 # @ a1 a2 a3 ... an 3841 s/^\s*//; 3842 s/\s*$//; 3843 if (m/^@\s+(.*)$/) { 3844 AddEntries($profile, $pcs, FixCallerAddresses($1), 1); 3845 } 3846 } 3847 3848 my $r = {}; 3849 $r->{version} = "thread"; 3850 $r->{period} = 1; 3851 $r->{profile} = $profile; 3852 $r->{libs} = ParseLibraries($prog, $map, $pcs); 3853 $r->{pcs} = $pcs; 3854 return $r; 3855 } 3856 3857 sub ReadSynchProfile { 3858 my ($prog, $fname, $header) = @_; 3859 3860 my $map = ''; 3861 my $profile = {}; 3862 my $pcs = {}; 3863 my $sampling_period = 1; 3864 my $cyclespernanosec = 2.8; # Default assumption for old binaries 3865 my $seen_clockrate = 0; 3866 my $line; 3867 3868 my $index = 0; 3869 if ($main::opt_total_delay) { 3870 $index = 0; 3871 } elsif ($main::opt_contentions) { 3872 $index = 1; 3873 } elsif ($main::opt_mean_delay) { 3874 $index = 2; 3875 } 3876 3877 while ( $line = <PROFILE> ) { 3878 $line =~ s/\r//g; # turn windows-looking lines into unix-looking lines 3879 if ( $line =~ /^\s*(\d+)\s+(\d+) \@\s*(.*?)\s*$/ ) { 3880 my ($cycles, $count, $stack) = ($1, $2, $3); 3881 3882 # Convert cycles to nanoseconds 3883 $cycles /= $cyclespernanosec; 3884 3885 # Adjust for sampling done by application 3886 $cycles *= $sampling_period; 3887 $count *= $sampling_period; 3888 3889 my @values = ($cycles, $count, $cycles / $count); 3890 AddEntries($profile, $pcs, FixCallerAddresses($stack), $values[$index]); 3891 3892 } elsif ( $line =~ /^(slow release).*thread \d+ \@\s*(.*?)\s*$/ || 3893 $line =~ /^\s*(\d+) \@\s*(.*?)\s*$/ ) { 3894 my ($cycles, $stack) = ($1, $2); 3895 if ($cycles !~ /^\d+$/) { 3896 next; 3897 } 3898 3899 # Convert cycles to nanoseconds 3900 $cycles /= $cyclespernanosec; 3901 3902 # Adjust for sampling done by application 3903 $cycles *= $sampling_period; 3904 3905 AddEntries($profile, $pcs, FixCallerAddresses($stack), $cycles); 3906 3907 } elsif ( $line =~ m/^([a-z][^=]*)=(.*)$/ ) { 3908 my ($variable, $value) = ($1,$2); 3909 for ($variable, $value) { 3910 s/^\s+//; 3911 s/\s+$//; 3912 } 3913 if ($variable eq "cycles/second") { 3914 $cyclespernanosec = $value / 1e9; 3915 $seen_clockrate = 1; 3916 } elsif ($variable eq "sampling period") { 3917 $sampling_period = $value; 3918 } elsif ($variable eq "ms since reset") { 3919 # Currently nothing is done with this value in pprof 3920 # So we just silently ignore it for now 3921 } elsif ($variable eq "discarded samples") { 3922 # Currently nothing is done with this value in pprof 3923 # So we just silently ignore it for now 3924 } else { 3925 printf STDERR ("Ignoring unnknown variable in /contention output: " . 3926 "'%s' = '%s'\n",$variable,$value); 3927 } 3928 } else { 3929 # Memory map entry 3930 $map .= $line; 3931 } 3932 } 3933 close PROFILE; 3934 3935 if (!$seen_clockrate) { 3936 printf STDERR ("No cycles/second entry in profile; Guessing %.1f GHz\n", 3937 $cyclespernanosec); 3938 } 3939 3940 my $r = {}; 3941 $r->{version} = 0; 3942 $r->{period} = $sampling_period; 3943 $r->{profile} = $profile; 3944 $r->{libs} = ParseLibraries($prog, $map, $pcs); 3945 $r->{pcs} = $pcs; 3946 return $r; 3947 } 3948 3949 # Given a hex value in the form "0x1abcd" return "0001abcd" or 3950 # "000000000001abcd", depending on the current address length. 3951 # There's probably a more idiomatic (or faster) way to do this... 3952 sub HexExtend { 3953 my $addr = shift; 3954 3955 $addr =~ s/^0x//; 3956 3957 if (length $addr > $address_length) { 3958 printf STDERR "Warning: address $addr is longer than address length $address_length\n"; 3959 } 3960 3961 return substr("000000000000000".$addr, -$address_length); 3962 } 3963 3964 ##### Symbol extraction ##### 3965 3966 # Aggressively search the lib_prefix values for the given library 3967 # If all else fails, just return the name of the library unmodified. 3968 # If the lib_prefix is "/my/path,/other/path" and $file is "/lib/dir/mylib.so" 3969 # it will search the following locations in this order, until it finds a file: 3970 # /my/path/lib/dir/mylib.so 3971 # /other/path/lib/dir/mylib.so 3972 # /my/path/dir/mylib.so 3973 # /other/path/dir/mylib.so 3974 # /my/path/mylib.so 3975 # /other/path/mylib.so 3976 # /lib/dir/mylib.so (returned as last resort) 3977 sub FindLibrary { 3978 my $file = shift; 3979 my $suffix = $file; 3980 3981 # Search for the library as described above 3982 do { 3983 foreach my $prefix (@prefix_list) { 3984 my $fullpath = $prefix . $suffix; 3985 if (-e $fullpath) { 3986 return $fullpath; 3987 } 3988 } 3989 } while ($suffix =~ s|^/[^/]+/|/|); 3990 return $file; 3991 } 3992 3993 # Return path to library with debugging symbols. 3994 # For libc libraries, the copy in /usr/lib/debug contains debugging symbols 3995 sub DebuggingLibrary { 3996 my $file = shift; 3997 if ($file =~ m|^/| && -f "/usr/lib/debug$file") { 3998 return "/usr/lib/debug$file"; 3999 } 4000 return undef; 4001 } 4002 4003 # Parse text section header of a library using objdump 4004 sub ParseTextSectionHeaderFromObjdump { 4005 my $lib = shift; 4006 4007 my $size = undef; 4008 my $vma; 4009 my $file_offset; 4010 # Get objdump output from the library file to figure out how to 4011 # map between mapped addresses and addresses in the library. 4012 my $objdump = $obj_tool_map{"objdump"}; 4013 open(OBJDUMP, "$objdump -h $lib |") 4014 || error("$objdump $lib: $!\n"); 4015 while (<OBJDUMP>) { 4016 s/\r//g; # turn windows-looking lines into unix-looking lines 4017 # Idx Name Size VMA LMA File off Algn 4018 # 10 .text 00104b2c 420156f0 420156f0 000156f0 2**4 4019 # For 64-bit objects, VMA and LMA will be 16 hex digits, size and file 4020 # offset may still be 8. But AddressSub below will still handle that. 4021 my @x = split; 4022 if (($#x >= 6) && ($x[1] eq '.text')) { 4023 $size = $x[2]; 4024 $vma = $x[3]; 4025 $file_offset = $x[5]; 4026 last; 4027 } 4028 } 4029 close(OBJDUMP); 4030 4031 if (!defined($size)) { 4032 return undef; 4033 } 4034 4035 my $r = {}; 4036 $r->{size} = $size; 4037 $r->{vma} = $vma; 4038 $r->{file_offset} = $file_offset; 4039 4040 return $r; 4041 } 4042 4043 # Parse text section header of a library using otool (on OS X) 4044 sub ParseTextSectionHeaderFromOtool { 4045 my $lib = shift; 4046 4047 my $size = undef; 4048 my $vma = undef; 4049 my $file_offset = undef; 4050 # Get otool output from the library file to figure out how to 4051 # map between mapped addresses and addresses in the library. 4052 my $otool = $obj_tool_map{"otool"}; 4053 open(OTOOL, "$otool -l $lib |") 4054 || error("$otool $lib: $!\n"); 4055 my $cmd = ""; 4056 my $sectname = ""; 4057 my $segname = ""; 4058 foreach my $line (<OTOOL>) { 4059 $line =~ s/\r//g; # turn windows-looking lines into unix-looking lines 4060 # Load command <#> 4061 # cmd LC_SEGMENT 4062 # [...] 4063 # Section 4064 # sectname __text 4065 # segname __TEXT 4066 # addr 0x000009f8 4067 # size 0x00018b9e 4068 # offset 2552 4069 # align 2^2 (4) 4070 # We will need to strip off the leading 0x from the hex addresses, 4071 # and convert the offset into hex. 4072 if ($line =~ /Load command/) { 4073 $cmd = ""; 4074 $sectname = ""; 4075 $segname = ""; 4076 } elsif ($line =~ /Section/) { 4077 $sectname = ""; 4078 $segname = ""; 4079 } elsif ($line =~ /cmd (\w+)/) { 4080 $cmd = $1; 4081 } elsif ($line =~ /sectname (\w+)/) { 4082 $sectname = $1; 4083 } elsif ($line =~ /segname (\w+)/) { 4084 $segname = $1; 4085 } elsif (!(($cmd eq "LC_SEGMENT" || $cmd eq "LC_SEGMENT_64") && 4086 $sectname eq "__text" && 4087 $segname eq "__TEXT")) { 4088 next; 4089 } elsif ($line =~ /\baddr 0x([0-9a-fA-F]+)/) { 4090 $vma = $1; 4091 } elsif ($line =~ /\bsize 0x([0-9a-fA-F]+)/) { 4092 $size = $1; 4093 } elsif ($line =~ /\boffset ([0-9]+)/) { 4094 $file_offset = sprintf("%016x", $1); 4095 } 4096 if (defined($vma) && defined($size) && defined($file_offset)) { 4097 last; 4098 } 4099 } 4100 close(OTOOL); 4101 4102 if (!defined($vma) || !defined($size) || !defined($file_offset)) { 4103 return undef; 4104 } 4105 4106 my $r = {}; 4107 $r->{size} = $size; 4108 $r->{vma} = $vma; 4109 $r->{file_offset} = $file_offset; 4110 4111 return $r; 4112 } 4113 4114 sub ParseTextSectionHeader { 4115 # obj_tool_map("otool") is only defined if we're in a Mach-O environment 4116 if (defined($obj_tool_map{"otool"})) { 4117 my $r = ParseTextSectionHeaderFromOtool(@_); 4118 if (defined($r)){ 4119 return $r; 4120 } 4121 } 4122 # If otool doesn't work, or we don't have it, fall back to objdump 4123 return ParseTextSectionHeaderFromObjdump(@_); 4124 } 4125 4126 # Split /proc/pid/maps dump into a list of libraries 4127 sub ParseLibraries { 4128 return if $main::use_symbol_page; # We don't need libraries info. 4129 my $prog = shift; 4130 my $map = shift; 4131 my $pcs = shift; 4132 4133 my $result = []; 4134 my $h = "[a-f0-9]+"; 4135 my $zero_offset = HexExtend("0"); 4136 4137 my $buildvar = ""; 4138 foreach my $l (split("\n", $map)) { 4139 if ($l =~ m/^\s*build=(.*)$/) { 4140 $buildvar = $1; 4141 } 4142 4143 my $start; 4144 my $finish; 4145 my $offset; 4146 my $lib; 4147 if ($l =~ /^($h)-($h)\s+..x.\s+($h)\s+\S+:\S+\s+\d+\s+(\S+\.(so|dll|dylib|bundle)((\.\d+)+\w*(\.\d+){0,3})?)$/i) { 4148 # Full line from /proc/self/maps. Example: 4149 # 40000000-40015000 r-xp 00000000 03:01 12845071 /lib/ld-2.3.2.so 4150 $start = HexExtend($1); 4151 $finish = HexExtend($2); 4152 $offset = HexExtend($3); 4153 $lib = $4; 4154 $lib =~ s|\\|/|g; # turn windows-style paths into unix-style paths 4155 } elsif ($l =~ /^\s*($h)-($h):\s*(\S+\.so(\.\d+)*)/) { 4156 # Cooked line from DumpAddressMap. Example: 4157 # 40000000-40015000: /lib/ld-2.3.2.so 4158 $start = HexExtend($1); 4159 $finish = HexExtend($2); 4160 $offset = $zero_offset; 4161 $lib = $3; 4162 } else { 4163 next; 4164 } 4165 4166 # Expand "$build" variable if available 4167 $lib =~ s/\$build\b/$buildvar/g; 4168 4169 $lib = FindLibrary($lib); 4170 4171 # Check for pre-relocated libraries, which use pre-relocated symbol tables 4172 # and thus require adjusting the offset that we'll use to translate 4173 # VM addresses into symbol table addresses. 4174 # Only do this if we're not going to fetch the symbol table from a 4175 # debugging copy of the library. 4176 if (!DebuggingLibrary($lib)) { 4177 my $text = ParseTextSectionHeader($lib); 4178 if (defined($text)) { 4179 my $vma_offset = AddressSub($text->{vma}, $text->{file_offset}); 4180 $offset = AddressAdd($offset, $vma_offset); 4181 } 4182 } 4183 4184 push(@{$result}, [$lib, $start, $finish, $offset]); 4185 } 4186 4187 # Append special entry for additional library (not relocated) 4188 if ($main::opt_lib ne "") { 4189 my $text = ParseTextSectionHeader($main::opt_lib); 4190 if (defined($text)) { 4191 my $start = $text->{vma}; 4192 my $finish = AddressAdd($start, $text->{size}); 4193 4194 push(@{$result}, [$main::opt_lib, $start, $finish, $start]); 4195 } 4196 } 4197 4198 # Append special entry for the main program. This covers 4199 # 0..max_pc_value_seen, so that we assume pc values not found in one 4200 # of the library ranges will be treated as coming from the main 4201 # program binary. 4202 my $min_pc = HexExtend("0"); 4203 my $max_pc = $min_pc; # find the maximal PC value in any sample 4204 foreach my $pc (keys(%{$pcs})) { 4205 if (HexExtend($pc) gt $max_pc) { $max_pc = HexExtend($pc); } 4206 } 4207 push(@{$result}, [$prog, $min_pc, $max_pc, $zero_offset]); 4208 4209 return $result; 4210 } 4211 4212 # Add two hex addresses of length $address_length. 4213 # Run pprof --test for unit test if this is changed. 4214 sub AddressAdd { 4215 my $addr1 = shift; 4216 my $addr2 = shift; 4217 my $sum; 4218 4219 if ($address_length == 8) { 4220 # Perl doesn't cope with wraparound arithmetic, so do it explicitly: 4221 $sum = (hex($addr1)+hex($addr2)) % (0x10000000 * 16); 4222 return sprintf("%08x", $sum); 4223 4224 } else { 4225 # Do the addition in 7-nibble chunks to trivialize carry handling. 4226 4227 if ($main::opt_debug and $main::opt_test) { 4228 print STDERR "AddressAdd $addr1 + $addr2 = "; 4229 } 4230 4231 my $a1 = substr($addr1,-7); 4232 $addr1 = substr($addr1,0,-7); 4233 my $a2 = substr($addr2,-7); 4234 $addr2 = substr($addr2,0,-7); 4235 $sum = hex($a1) + hex($a2); 4236 my $c = 0; 4237 if ($sum > 0xfffffff) { 4238 $c = 1; 4239 $sum -= 0x10000000; 4240 } 4241 my $r = sprintf("%07x", $sum); 4242 4243 $a1 = substr($addr1,-7); 4244 $addr1 = substr($addr1,0,-7); 4245 $a2 = substr($addr2,-7); 4246 $addr2 = substr($addr2,0,-7); 4247 $sum = hex($a1) + hex($a2) + $c; 4248 $c = 0; 4249 if ($sum > 0xfffffff) { 4250 $c = 1; 4251 $sum -= 0x10000000; 4252 } 4253 $r = sprintf("%07x", $sum) . $r; 4254 4255 $sum = hex($addr1) + hex($addr2) + $c; 4256 if ($sum > 0xff) { $sum -= 0x100; } 4257 $r = sprintf("%02x", $sum) . $r; 4258 4259 if ($main::opt_debug and $main::opt_test) { print STDERR "$r\n"; } 4260 4261 return $r; 4262 } 4263 } 4264 4265 4266 # Subtract two hex addresses of length $address_length. 4267 # Run pprof --test for unit test if this is changed. 4268 sub AddressSub { 4269 my $addr1 = shift; 4270 my $addr2 = shift; 4271 my $diff; 4272 4273 if ($address_length == 8) { 4274 # Perl doesn't cope with wraparound arithmetic, so do it explicitly: 4275 $diff = (hex($addr1)-hex($addr2)) % (0x10000000 * 16); 4276 return sprintf("%08x", $diff); 4277 4278 } else { 4279 # Do the addition in 7-nibble chunks to trivialize borrow handling. 4280 # if ($main::opt_debug) { print STDERR "AddressSub $addr1 - $addr2 = "; } 4281 4282 my $a1 = hex(substr($addr1,-7)); 4283 $addr1 = substr($addr1,0,-7); 4284 my $a2 = hex(substr($addr2,-7)); 4285 $addr2 = substr($addr2,0,-7); 4286 my $b = 0; 4287 if ($a2 > $a1) { 4288 $b = 1; 4289 $a1 += 0x10000000; 4290 } 4291 $diff = $a1 - $a2; 4292 my $r = sprintf("%07x", $diff); 4293 4294 $a1 = hex(substr($addr1,-7)); 4295 $addr1 = substr($addr1,0,-7); 4296 $a2 = hex(substr($addr2,-7)) + $b; 4297 $addr2 = substr($addr2,0,-7); 4298 $b = 0; 4299 if ($a2 > $a1) { 4300 $b = 1; 4301 $a1 += 0x10000000; 4302 } 4303 $diff = $a1 - $a2; 4304 $r = sprintf("%07x", $diff) . $r; 4305 4306 $a1 = hex($addr1); 4307 $a2 = hex($addr2) + $b; 4308 if ($a2 > $a1) { $a1 += 0x100; } 4309 $diff = $a1 - $a2; 4310 $r = sprintf("%02x", $diff) . $r; 4311 4312 # if ($main::opt_debug) { print STDERR "$r\n"; } 4313 4314 return $r; 4315 } 4316 } 4317 4318 # Increment a hex addresses of length $address_length. 4319 # Run pprof --test for unit test if this is changed. 4320 sub AddressInc { 4321 my $addr = shift; 4322 my $sum; 4323 4324 if ($address_length == 8) { 4325 # Perl doesn't cope with wraparound arithmetic, so do it explicitly: 4326 $sum = (hex($addr)+1) % (0x10000000 * 16); 4327 return sprintf("%08x", $sum); 4328 4329 } else { 4330 # Do the addition in 7-nibble chunks to trivialize carry handling. 4331 # We are always doing this to step through the addresses in a function, 4332 # and will almost never overflow the first chunk, so we check for this 4333 # case and exit early. 4334 4335 # if ($main::opt_debug) { print STDERR "AddressInc $addr1 = "; } 4336 4337 my $a1 = substr($addr,-7); 4338 $addr = substr($addr,0,-7); 4339 $sum = hex($a1) + 1; 4340 my $r = sprintf("%07x", $sum); 4341 if ($sum <= 0xfffffff) { 4342 $r = $addr . $r; 4343 # if ($main::opt_debug) { print STDERR "$r\n"; } 4344 return HexExtend($r); 4345 } else { 4346 $r = "0000000"; 4347 } 4348 4349 $a1 = substr($addr,-7); 4350 $addr = substr($addr,0,-7); 4351 $sum = hex($a1) + 1; 4352 $r = sprintf("%07x", $sum) . $r; 4353 if ($sum <= 0xfffffff) { 4354 $r = $addr . $r; 4355 # if ($main::opt_debug) { print STDERR "$r\n"; } 4356 return HexExtend($r); 4357 } else { 4358 $r = "00000000000000"; 4359 } 4360 4361 $sum = hex($addr) + 1; 4362 if ($sum > 0xff) { $sum -= 0x100; } 4363 $r = sprintf("%02x", $sum) . $r; 4364 4365 # if ($main::opt_debug) { print STDERR "$r\n"; } 4366 return $r; 4367 } 4368 } 4369 4370 # Extract symbols for all PC values found in profile 4371 sub ExtractSymbols { 4372 my $libs = shift; 4373 my $pcset = shift; 4374 4375 my $symbols = {}; 4376 4377 # Map each PC value to the containing library 4378 my %seen = (); 4379 foreach my $lib (@{$libs}) { 4380 my $libname = $lib->[0]; 4381 my $start = $lib->[1]; 4382 my $finish = $lib->[2]; 4383 my $offset = $lib->[3]; 4384 4385 # Get list of pcs that belong in this library. 4386 my $contained = []; 4387 foreach my $pc (keys(%{$pcset})) { 4388 if (!$seen{$pc} && ($pc ge $start) && ($pc le $finish)) { 4389 $seen{$pc} = 1; 4390 push(@{$contained}, $pc); 4391 } 4392 } 4393 # Map to symbols 4394 MapToSymbols($libname, AddressSub($start, $offset), $contained, $symbols); 4395 } 4396 4397 return $symbols; 4398 } 4399 4400 # Map list of PC values to symbols for a given image 4401 sub MapToSymbols { 4402 my $image = shift; 4403 my $offset = shift; 4404 my $pclist = shift; 4405 my $symbols = shift; 4406 4407 my $debug = 0; 4408 4409 # Ignore empty binaries 4410 if ($#{$pclist} < 0) { return; } 4411 4412 # Figure out the addr2line command to use 4413 my $addr2line = $obj_tool_map{"addr2line"}; 4414 my $cmd = "$addr2line -f -C -e $image"; 4415 if (exists $obj_tool_map{"addr2line_pdb"}) { 4416 $addr2line = $obj_tool_map{"addr2line_pdb"}; 4417 $cmd = "$addr2line --demangle -f -C -e $image"; 4418 } 4419 4420 # Use the go version because we know it works on all platforms 4421 $addr2line = "go tool addr2line"; 4422 $cmd = "$addr2line $image"; 4423 4424 # If "addr2line" isn't installed on the system at all, just use 4425 # nm to get what info we can (function names, but not line numbers). 4426 if (system("$addr2line --help >/dev/null 2>&1") != 0) { 4427 MapSymbolsWithNM($image, $offset, $pclist, $symbols); 4428 return; 4429 } 4430 4431 # "addr2line -i" can produce a variable number of lines per input 4432 # address, with no separator that allows us to tell when data for 4433 # the next address starts. So we find the address for a special 4434 # symbol (_fini) and interleave this address between all real 4435 # addresses passed to addr2line. The name of this special symbol 4436 # can then be used as a separator. 4437 $sep_address = undef; # May be filled in by MapSymbolsWithNM() 4438 my $nm_symbols = {}; 4439 MapSymbolsWithNM($image, $offset, $pclist, $nm_symbols); 4440 # TODO(csilvers): only add '-i' if addr2line supports it. 4441 if (defined($sep_address)) { 4442 # Only add " -i" to addr2line if the binary supports it. 4443 # addr2line --help returns 0, but not if it sees an unknown flag first. 4444 if (system("$cmd -i --help >/dev/null 2>&1") == 0) { 4445 $cmd .= " -i"; 4446 } else { 4447 $sep_address = undef; # no need for sep_address if we don't support -i 4448 } 4449 } 4450 4451 # Make file with all PC values with intervening 'sep_address' so 4452 # that we can reliably detect the end of inlined function list 4453 open(ADDRESSES, ">$main::tmpfile_sym") || error("$main::tmpfile_sym: $!\n"); 4454 if ($debug) { print("---- $image ---\n"); } 4455 for (my $i = 0; $i <= $#{$pclist}; $i++) { 4456 # addr2line always reads hex addresses, and does not need '0x' prefix. 4457 if ($debug) { printf STDERR ("%s\n", $pclist->[$i]); } 4458 printf ADDRESSES ("%s\n", AddressSub($pclist->[$i], $offset)); 4459 if (defined($sep_address)) { 4460 printf ADDRESSES ("%s\n", $sep_address); 4461 } 4462 } 4463 close(ADDRESSES); 4464 if ($debug) { 4465 print("----\n"); 4466 system("cat $main::tmpfile_sym"); 4467 print("---- $cmd\n"); 4468 system("$cmd <$main::tmpfile_sym"); 4469 print("----\n"); 4470 } 4471 4472 open(SYMBOLS, "$cmd <$main::tmpfile_sym |") || error("$cmd: $!\n"); 4473 my $count = 0; # Index in pclist 4474 while (<SYMBOLS>) { 4475 # Read fullfunction and filelineinfo from next pair of lines 4476 s/\r?\n$//g; 4477 my $fullfunction = $_; 4478 $_ = <SYMBOLS>; 4479 s/\r?\n$//g; 4480 my $filelinenum = $_; 4481 4482 if (defined($sep_address) && $fullfunction eq $sep_symbol) { 4483 # Terminating marker for data for this address 4484 $count++; 4485 next; 4486 } 4487 4488 $filelinenum =~ s|\\|/|g; # turn windows-style paths into unix-style paths 4489 4490 my $pcstr = $pclist->[$count]; 4491 my $function = ShortFunctionName($fullfunction); 4492 if ($fullfunction eq '??') { 4493 # See if nm found a symbol 4494 my $nms = $nm_symbols->{$pcstr}; 4495 if (defined($nms)) { 4496 $function = $nms->[0]; 4497 $fullfunction = $nms->[2]; 4498 } 4499 } 4500 4501 # Prepend to accumulated symbols for pcstr 4502 # (so that caller comes before callee) 4503 my $sym = $symbols->{$pcstr}; 4504 if (!defined($sym)) { 4505 $sym = []; 4506 $symbols->{$pcstr} = $sym; 4507 } 4508 unshift(@{$sym}, $function, $filelinenum, $fullfunction); 4509 if ($debug) { printf STDERR ("%s => [%s]\n", $pcstr, join(" ", @{$sym})); } 4510 if (!defined($sep_address)) { 4511 # Inlining is off, se this entry ends immediately 4512 $count++; 4513 } 4514 } 4515 close(SYMBOLS); 4516 } 4517 4518 # Use nm to map the list of referenced PCs to symbols. Return true iff we 4519 # are able to read procedure information via nm. 4520 sub MapSymbolsWithNM { 4521 my $image = shift; 4522 my $offset = shift; 4523 my $pclist = shift; 4524 my $symbols = shift; 4525 4526 # Get nm output sorted by increasing address 4527 my $symbol_table = GetProcedureBoundaries($image, "."); 4528 if (!%{$symbol_table}) { 4529 return 0; 4530 } 4531 # Start addresses are already the right length (8 or 16 hex digits). 4532 my @names = sort { $symbol_table->{$a}->[0] cmp $symbol_table->{$b}->[0] } 4533 keys(%{$symbol_table}); 4534 4535 if ($#names < 0) { 4536 # No symbols: just use addresses 4537 foreach my $pc (@{$pclist}) { 4538 my $pcstr = "0x" . $pc; 4539 $symbols->{$pc} = [$pcstr, "?", $pcstr]; 4540 } 4541 return 0; 4542 } 4543 4544 # Sort addresses so we can do a join against nm output 4545 my $index = 0; 4546 my $fullname = $names[0]; 4547 my $name = ShortFunctionName($fullname); 4548 foreach my $pc (sort { $a cmp $b } @{$pclist}) { 4549 # Adjust for mapped offset 4550 my $mpc = AddressSub($pc, $offset); 4551 while (($index < $#names) && ($mpc ge $symbol_table->{$fullname}->[1])){ 4552 $index++; 4553 $fullname = $names[$index]; 4554 $name = ShortFunctionName($fullname); 4555 } 4556 if ($mpc lt $symbol_table->{$fullname}->[1]) { 4557 $symbols->{$pc} = [$name, "?", $fullname]; 4558 } else { 4559 my $pcstr = "0x" . $pc; 4560 $symbols->{$pc} = [$pcstr, "?", $pcstr]; 4561 } 4562 } 4563 return 1; 4564 } 4565 4566 sub ShortFunctionName { 4567 my $function = shift; 4568 while ($function =~ s/(?<!\.)\([^()]*\)(\s*const)?//g) { } # Argument types 4569 while ($function =~ s/<[^<>]*>//g) { } # Remove template arguments 4570 $function =~ s/^.*\s+(\w+::)/$1/; # Remove leading type 4571 return $function; 4572 } 4573 4574 # Trim overly long symbols found in disassembler output 4575 sub CleanDisassembly { 4576 my $d = shift; 4577 while ($d =~ s/(?<!\.)\([^()%A-Z]*\)(\s*const)?//g) { } # Argument types, not (%rax) 4578 while ($d =~ s/(\w+)<[^<>]*>/$1/g) { } # Remove template arguments 4579 return $d; 4580 } 4581 4582 ##### Miscellaneous ##### 4583 4584 # Find the right versions of the above object tools to use. The 4585 # argument is the program file being analyzed, and should be an ELF 4586 # 32-bit or ELF 64-bit executable file. The location of the tools 4587 # is determined by considering the following options in this order: 4588 # 1) --tools option, if set 4589 # 2) PPROF_TOOLS environment variable, if set 4590 # 3) the environment 4591 sub ConfigureObjTools { 4592 my $prog_file = shift; 4593 4594 # Check for the existence of $prog_file because /usr/bin/file does not 4595 # predictably return error status in prod. 4596 (-e $prog_file) || error("$prog_file does not exist.\n"); 4597 4598 # Follow symlinks (at least for systems where "file" supports that) 4599 my $file_type = `/usr/bin/file -L $prog_file 2>/dev/null || /usr/bin/file $prog_file`; 4600 if ($file_type =~ /64-bit/) { 4601 # Change $address_length to 16 if the program file is ELF 64-bit. 4602 # We can't detect this from many (most?) heap or lock contention 4603 # profiles, since the actual addresses referenced are generally in low 4604 # memory even for 64-bit programs. 4605 $address_length = 16; 4606 } 4607 4608 if ($file_type =~ /MS Windows/) { 4609 # For windows, we provide a version of nm and addr2line as part of 4610 # the opensource release, which is capable of parsing 4611 # Windows-style PDB executables. It should live in the path, or 4612 # in the same directory as pprof. 4613 $obj_tool_map{"nm_pdb"} = "nm-pdb"; 4614 $obj_tool_map{"addr2line_pdb"} = "addr2line-pdb"; 4615 $obj_tool_map{"is_windows"} = "true"; 4616 } 4617 4618 if ($file_type =~ /Mach-O/) { 4619 # OS X uses otool to examine Mach-O files, rather than objdump. 4620 $obj_tool_map{"otool"} = "otool"; 4621 $obj_tool_map{"addr2line"} = "false"; # no addr2line 4622 $obj_tool_map{"objdump"} = "false"; # no objdump 4623 } 4624 4625 # Go fill in %obj_tool_map with the pathnames to use: 4626 foreach my $tool (keys %obj_tool_map) { 4627 $obj_tool_map{$tool} = ConfigureTool($obj_tool_map{$tool}); 4628 } 4629 } 4630 4631 # Returns the path of a caller-specified object tool. If --tools or 4632 # PPROF_TOOLS are specified, then returns the full path to the tool 4633 # with that prefix. Otherwise, returns the path unmodified (which 4634 # means we will look for it on PATH). 4635 sub ConfigureTool { 4636 my $tool = shift; 4637 my $path; 4638 4639 if ($main::opt_tools ne "") { 4640 # Use a prefix specified by the --tools option... 4641 $path = $main::opt_tools . $tool; 4642 if (!-x $path) { 4643 error("No '$tool' found with prefix specified by --tools $main::opt_tools\n"); 4644 } 4645 } elsif (exists $ENV{"PPROF_TOOLS"} && 4646 $ENV{"PPROF_TOOLS"} ne "") { 4647 #... or specified with the PPROF_TOOLS environment variable... 4648 $path = $ENV{"PPROF_TOOLS"} . $tool; 4649 if (!-x $path) { 4650 error("No '$tool' found with prefix specified by PPROF_TOOLS=$ENV{PPROF_TOOLS}\n"); 4651 } 4652 } else { 4653 # ... otherwise use the version that exists in the same directory as 4654 # pprof. If there's nothing there, use $PATH. 4655 $0 =~ m,[^/]*$,; # this is everything after the last slash 4656 my $dirname = $`; # this is everything up to and including the last slash 4657 if (-x "$dirname$tool") { 4658 $path = "$dirname$tool"; 4659 } else { 4660 $path = $tool; 4661 } 4662 } 4663 if ($main::opt_debug) { print STDERR "Using '$path' for '$tool'.\n"; } 4664 return $path; 4665 } 4666 4667 sub cleanup { 4668 unlink($main::tmpfile_sym); 4669 unlink(keys %main::tempnames); 4670 4671 # We leave any collected profiles in $HOME/pprof in case the user wants 4672 # to look at them later. We print a message informing them of this. 4673 if ((scalar(@main::profile_files) > 0) && 4674 defined($main::collected_profile)) { 4675 if (scalar(@main::profile_files) == 1) { 4676 print STDERR "Dynamically gathered profile is in $main::collected_profile\n"; 4677 } 4678 print STDERR "If you want to investigate this profile further, you can do:\n"; 4679 print STDERR "\n"; 4680 print STDERR " pprof \\\n"; 4681 print STDERR " $main::prog \\\n"; 4682 print STDERR " $main::collected_profile\n"; 4683 print STDERR "\n"; 4684 } 4685 } 4686 4687 sub sighandler { 4688 cleanup(); 4689 exit(1); 4690 } 4691 4692 sub error { 4693 my $msg = shift; 4694 print STDERR $msg; 4695 cleanup(); 4696 exit(1); 4697 } 4698 4699 4700 # Run $nm_command and get all the resulting procedure boundaries whose 4701 # names match "$regexp" and returns them in a hashtable mapping from 4702 # procedure name to a two-element vector of [start address, end address] 4703 sub GetProcedureBoundariesViaNm { 4704 my $nm_command = shift; 4705 my $regexp = shift; 4706 4707 my $symbol_table = {}; 4708 open(NM, "$nm_command |") || error("$nm_command: $!\n"); 4709 my $last_start = "0"; 4710 my $routine = ""; 4711 while (<NM>) { 4712 s/\r//g; # turn windows-looking lines into unix-looking lines 4713 if (m/^\s*([0-9a-f]+) (.) (..*)/) { 4714 my $start_val = $1; 4715 my $type = $2; 4716 my $this_routine = $3; 4717 4718 # It's possible for two symbols to share the same address, if 4719 # one is a zero-length variable (like __start_google_malloc) or 4720 # one symbol is a weak alias to another (like __libc_malloc). 4721 # In such cases, we want to ignore all values except for the 4722 # actual symbol, which in nm-speak has type "T". The logic 4723 # below does this, though it's a bit tricky: what happens when 4724 # we have a series of lines with the same address, is the first 4725 # one gets queued up to be processed. However, it won't 4726 # *actually* be processed until later, when we read a line with 4727 # a different address. That means that as long as we're reading 4728 # lines with the same address, we have a chance to replace that 4729 # item in the queue, which we do whenever we see a 'T' entry -- 4730 # that is, a line with type 'T'. If we never see a 'T' entry, 4731 # we'll just go ahead and process the first entry (which never 4732 # got touched in the queue), and ignore the others. 4733 if ($start_val eq $last_start && $type =~ /t/i) { 4734 # We are the 'T' symbol at this address, replace previous symbol. 4735 $routine = $this_routine; 4736 next; 4737 } elsif ($start_val eq $last_start) { 4738 # We're not the 'T' symbol at this address, so ignore us. 4739 next; 4740 } 4741 4742 if ($this_routine eq $sep_symbol) { 4743 $sep_address = HexExtend($start_val); 4744 } 4745 4746 # Tag this routine with the starting address in case the image 4747 # has multiple occurrences of this routine. We use a syntax 4748 # that resembles template paramters that are automatically 4749 # stripped out by ShortFunctionName() 4750 $this_routine .= "<$start_val>"; 4751 4752 if (defined($routine) && $routine =~ m/$regexp/) { 4753 $symbol_table->{$routine} = [HexExtend($last_start), 4754 HexExtend($start_val)]; 4755 } 4756 $last_start = $start_val; 4757 $routine = $this_routine; 4758 } elsif (m/^Loaded image name: (.+)/) { 4759 # The win32 nm workalike emits information about the binary it is using. 4760 if ($main::opt_debug) { print STDERR "Using Image $1\n"; } 4761 } elsif (m/^PDB file name: (.+)/) { 4762 # The win32 nm workalike emits information about the pdb it is using. 4763 if ($main::opt_debug) { print STDERR "Using PDB $1\n"; } 4764 } 4765 } 4766 close(NM); 4767 # Handle the last line in the nm output. Unfortunately, we don't know 4768 # how big this last symbol is, because we don't know how big the file 4769 # is. For now, we just give it a size of 0. 4770 # TODO(csilvers): do better here. 4771 if (defined($routine) && $routine =~ m/$regexp/) { 4772 $symbol_table->{$routine} = [HexExtend($last_start), 4773 HexExtend($last_start)]; 4774 } 4775 return $symbol_table; 4776 } 4777 4778 # Gets the procedure boundaries for all routines in "$image" whose names 4779 # match "$regexp" and returns them in a hashtable mapping from procedure 4780 # name to a two-element vector of [start address, end address]. 4781 # Will return an empty map if nm is not installed or not working properly. 4782 sub GetProcedureBoundaries { 4783 my $image = shift; 4784 my $regexp = shift; 4785 4786 # For libc libraries, the copy in /usr/lib/debug contains debugging symbols 4787 my $debugging = DebuggingLibrary($image); 4788 if ($debugging) { 4789 $image = $debugging; 4790 } 4791 4792 my $nm = $obj_tool_map{"nm"}; 4793 4794 # nm can fail for two reasons: 1) $image isn't a debug library; 2) nm 4795 # binary doesn't support --demangle. In addition, for OS X we need 4796 # to use the -f flag to get 'flat' nm output (otherwise we don't sort 4797 # properly and get incorrect results). Unfortunately, GNU nm uses -f 4798 # in an incompatible way. So first we test whether our nm supports 4799 # --demangle and -f. 4800 my $demangle_flag = ""; 4801 if (system("$nm --demangle $image >/dev/null 2>&1") == 0) { 4802 # In this mode, we do "nm --demangle <foo>" 4803 $demangle_flag = "--demangle"; 4804 } 4805 my $flatten_flag = ""; 4806 if (system("$nm -f $image >/dev/null 2>&1") == 0) { 4807 $flatten_flag = "-f"; 4808 } 4809 4810 # Finally, in the case $image isn't a debug library, we try again with 4811 # -D to at least get *exported* symbols. If we can't use --demangle, too bad. 4812 my @nm_commands = ("$nm -n $flatten_flag $demangle_flag" . 4813 " $image 2>/dev/null", 4814 "$nm -D -n $flatten_flag $demangle_flag" . 4815 " $image 2>/dev/null", 4816 # go tool nm is for Go binaries 4817 "go tool nm $image 2>/dev/null | sort"); 4818 4819 # If the executable is an MS Windows Go executable, we'll 4820 # have set up obj_tool_map("is_windows"). 4821 if (exists $obj_tool_map{"is_windows"}) { 4822 @nm_commands = ("go tool nm $image 2>/dev/null | sort"); 4823 } 4824 4825 foreach my $nm_command (@nm_commands) { 4826 my $symbol_table = GetProcedureBoundariesViaNm($nm_command, $regexp); 4827 return $symbol_table if (%{$symbol_table}); 4828 } 4829 my $symbol_table = {}; 4830 return $symbol_table; 4831 } 4832 4833 4834 # The test vectors for AddressAdd/Sub/Inc are 8-16-nibble hex strings. 4835 # To make them more readable, we add underscores at interesting places. 4836 # This routine removes the underscores, producing the canonical representation 4837 # used by pprof to represent addresses, particularly in the tested routines. 4838 sub CanonicalHex { 4839 my $arg = shift; 4840 return join '', (split '_',$arg); 4841 } 4842 4843 4844 # Unit test for AddressAdd: 4845 sub AddressAddUnitTest { 4846 my $test_data_8 = shift; 4847 my $test_data_16 = shift; 4848 my $error_count = 0; 4849 my $fail_count = 0; 4850 my $pass_count = 0; 4851 # print STDERR "AddressAddUnitTest: ", 1+$#{$test_data_8}, " tests\n"; 4852 4853 # First a few 8-nibble addresses. Note that this implementation uses 4854 # plain old arithmetic, so a quick sanity check along with verifying what 4855 # happens to overflow (we want it to wrap): 4856 $address_length = 8; 4857 foreach my $row (@{$test_data_8}) { 4858 if ($main::opt_debug and $main::opt_test) { print STDERR "@{$row}\n"; } 4859 my $sum = AddressAdd ($row->[0], $row->[1]); 4860 if ($sum ne $row->[2]) { 4861 printf STDERR "ERROR: %s != %s + %s = %s\n", $sum, 4862 $row->[0], $row->[1], $row->[2]; 4863 ++$fail_count; 4864 } else { 4865 ++$pass_count; 4866 } 4867 } 4868 printf STDERR "AddressAdd 32-bit tests: %d passes, %d failures\n", 4869 $pass_count, $fail_count; 4870 $error_count = $fail_count; 4871 $fail_count = 0; 4872 $pass_count = 0; 4873 4874 # Now 16-nibble addresses. 4875 $address_length = 16; 4876 foreach my $row (@{$test_data_16}) { 4877 if ($main::opt_debug and $main::opt_test) { print STDERR "@{$row}\n"; } 4878 my $sum = AddressAdd (CanonicalHex($row->[0]), CanonicalHex($row->[1])); 4879 my $expected = join '', (split '_',$row->[2]); 4880 if ($sum ne CanonicalHex($row->[2])) { 4881 printf STDERR "ERROR: %s != %s + %s = %s\n", $sum, 4882 $row->[0], $row->[1], $row->[2]; 4883 ++$fail_count; 4884 } else { 4885 ++$pass_count; 4886 } 4887 } 4888 printf STDERR "AddressAdd 64-bit tests: %d passes, %d failures\n", 4889 $pass_count, $fail_count; 4890 $error_count += $fail_count; 4891 4892 return $error_count; 4893 } 4894 4895 4896 # Unit test for AddressSub: 4897 sub AddressSubUnitTest { 4898 my $test_data_8 = shift; 4899 my $test_data_16 = shift; 4900 my $error_count = 0; 4901 my $fail_count = 0; 4902 my $pass_count = 0; 4903 # print STDERR "AddressSubUnitTest: ", 1+$#{$test_data_8}, " tests\n"; 4904 4905 # First a few 8-nibble addresses. Note that this implementation uses 4906 # plain old arithmetic, so a quick sanity check along with verifying what 4907 # happens to overflow (we want it to wrap): 4908 $address_length = 8; 4909 foreach my $row (@{$test_data_8}) { 4910 if ($main::opt_debug and $main::opt_test) { print STDERR "@{$row}\n"; } 4911 my $sum = AddressSub ($row->[0], $row->[1]); 4912 if ($sum ne $row->[3]) { 4913 printf STDERR "ERROR: %s != %s - %s = %s\n", $sum, 4914 $row->[0], $row->[1], $row->[3]; 4915 ++$fail_count; 4916 } else { 4917 ++$pass_count; 4918 } 4919 } 4920 printf STDERR "AddressSub 32-bit tests: %d passes, %d failures\n", 4921 $pass_count, $fail_count; 4922 $error_count = $fail_count; 4923 $fail_count = 0; 4924 $pass_count = 0; 4925 4926 # Now 16-nibble addresses. 4927 $address_length = 16; 4928 foreach my $row (@{$test_data_16}) { 4929 if ($main::opt_debug and $main::opt_test) { print STDERR "@{$row}\n"; } 4930 my $sum = AddressSub (CanonicalHex($row->[0]), CanonicalHex($row->[1])); 4931 if ($sum ne CanonicalHex($row->[3])) { 4932 printf STDERR "ERROR: %s != %s - %s = %s\n", $sum, 4933 $row->[0], $row->[1], $row->[3]; 4934 ++$fail_count; 4935 } else { 4936 ++$pass_count; 4937 } 4938 } 4939 printf STDERR "AddressSub 64-bit tests: %d passes, %d failures\n", 4940 $pass_count, $fail_count; 4941 $error_count += $fail_count; 4942 4943 return $error_count; 4944 } 4945 4946 4947 # Unit test for AddressInc: 4948 sub AddressIncUnitTest { 4949 my $test_data_8 = shift; 4950 my $test_data_16 = shift; 4951 my $error_count = 0; 4952 my $fail_count = 0; 4953 my $pass_count = 0; 4954 # print STDERR "AddressIncUnitTest: ", 1+$#{$test_data_8}, " tests\n"; 4955 4956 # First a few 8-nibble addresses. Note that this implementation uses 4957 # plain old arithmetic, so a quick sanity check along with verifying what 4958 # happens to overflow (we want it to wrap): 4959 $address_length = 8; 4960 foreach my $row (@{$test_data_8}) { 4961 if ($main::opt_debug and $main::opt_test) { print STDERR "@{$row}\n"; } 4962 my $sum = AddressInc ($row->[0]); 4963 if ($sum ne $row->[4]) { 4964 printf STDERR "ERROR: %s != %s + 1 = %s\n", $sum, 4965 $row->[0], $row->[4]; 4966 ++$fail_count; 4967 } else { 4968 ++$pass_count; 4969 } 4970 } 4971 printf STDERR "AddressInc 32-bit tests: %d passes, %d failures\n", 4972 $pass_count, $fail_count; 4973 $error_count = $fail_count; 4974 $fail_count = 0; 4975 $pass_count = 0; 4976 4977 # Now 16-nibble addresses. 4978 $address_length = 16; 4979 foreach my $row (@{$test_data_16}) { 4980 if ($main::opt_debug and $main::opt_test) { print STDERR "@{$row}\n"; } 4981 my $sum = AddressInc (CanonicalHex($row->[0])); 4982 if ($sum ne CanonicalHex($row->[4])) { 4983 printf STDERR "ERROR: %s != %s + 1 = %s\n", $sum, 4984 $row->[0], $row->[4]; 4985 ++$fail_count; 4986 } else { 4987 ++$pass_count; 4988 } 4989 } 4990 printf STDERR "AddressInc 64-bit tests: %d passes, %d failures\n", 4991 $pass_count, $fail_count; 4992 $error_count += $fail_count; 4993 4994 return $error_count; 4995 } 4996 4997 4998 # Driver for unit tests. 4999 # Currently just the address add/subtract/increment routines for 64-bit. 5000 sub RunUnitTests { 5001 my $error_count = 0; 5002 5003 # This is a list of tuples [a, b, a+b, a-b, a+1] 5004 my $unit_test_data_8 = [ 5005 [qw(aaaaaaaa 50505050 fafafafa 5a5a5a5a aaaaaaab)], 5006 [qw(50505050 aaaaaaaa fafafafa a5a5a5a6 50505051)], 5007 [qw(ffffffff aaaaaaaa aaaaaaa9 55555555 00000000)], 5008 [qw(00000001 ffffffff 00000000 00000002 00000002)], 5009 [qw(00000001 fffffff0 fffffff1 00000011 00000002)], 5010 ]; 5011 my $unit_test_data_16 = [ 5012 # The implementation handles data in 7-nibble chunks, so those are the 5013 # interesting boundaries. 5014 [qw(aaaaaaaa 50505050 5015 00_000000f_afafafa 00_0000005_a5a5a5a 00_000000a_aaaaaab)], 5016 [qw(50505050 aaaaaaaa 5017 00_000000f_afafafa ff_ffffffa_5a5a5a6 00_0000005_0505051)], 5018 [qw(ffffffff aaaaaaaa 5019 00_000001a_aaaaaa9 00_0000005_5555555 00_0000010_0000000)], 5020 [qw(00000001 ffffffff 5021 00_0000010_0000000 ff_ffffff0_0000002 00_0000000_0000002)], 5022 [qw(00000001 fffffff0 5023 00_000000f_ffffff1 ff_ffffff0_0000011 00_0000000_0000002)], 5024 5025 [qw(00_a00000a_aaaaaaa 50505050 5026 00_a00000f_afafafa 00_a000005_a5a5a5a 00_a00000a_aaaaaab)], 5027 [qw(0f_fff0005_0505050 aaaaaaaa 5028 0f_fff000f_afafafa 0f_ffefffa_5a5a5a6 0f_fff0005_0505051)], 5029 [qw(00_000000f_fffffff 01_800000a_aaaaaaa 5030 01_800001a_aaaaaa9 fe_8000005_5555555 00_0000010_0000000)], 5031 [qw(00_0000000_0000001 ff_fffffff_fffffff 5032 00_0000000_0000000 00_0000000_0000002 00_0000000_0000002)], 5033 [qw(00_0000000_0000001 ff_fffffff_ffffff0 5034 ff_fffffff_ffffff1 00_0000000_0000011 00_0000000_0000002)], 5035 ]; 5036 5037 $error_count += AddressAddUnitTest($unit_test_data_8, $unit_test_data_16); 5038 $error_count += AddressSubUnitTest($unit_test_data_8, $unit_test_data_16); 5039 $error_count += AddressIncUnitTest($unit_test_data_8, $unit_test_data_16); 5040 if ($error_count > 0) { 5041 print STDERR $error_count, " errors: FAILED\n"; 5042 } else { 5043 print STDERR "PASS\n"; 5044 } 5045 exit ($error_count); 5046 }