github.com/varialus/godfly@v0.0.0-20130904042352-1934f9f095ab/misc/pprof (about)

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