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