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