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