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