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