src/jemalloc/bin/pprof

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