summaryrefslogtreecommitdiff
path: root/src/cmd/prof/gopprof
diff options
context:
space:
mode:
Diffstat (limited to 'src/cmd/prof/gopprof')
-rwxr-xr-xsrc/cmd/prof/gopprof4975
1 files changed, 0 insertions, 4975 deletions
diff --git a/src/cmd/prof/gopprof b/src/cmd/prof/gopprof
deleted file mode 100755
index be5f84e9e..000000000
--- a/src/cmd/prof/gopprof
+++ /dev/null
@@ -1,4975 +0,0 @@
-#! /usr/bin/env perl
-
-# This is a copy of http://google-perftools.googlecode.com/svn/trunk/src/pprof
-# with local modifications to handle generation of SVG images and
-# the Go-style pprof paths. These modifications will probably filter
-# back into the official source before long.
-# It's convenient to have a copy here because we need just the one
-# Perl script, not all the C++ libraries that surround it.
-
-# Copyright (c) 1998-2007, Google Inc.
-# All rights reserved.
-#
-# Redistribution and use in source and binary forms, with or without
-# modification, are permitted provided that the following conditions are
-# met:
-#
-# * Redistributions of source code must retain the above copyright
-# notice, this list of conditions and the following disclaimer.
-# * Redistributions in binary form must reproduce the above
-# copyright notice, this list of conditions and the following disclaimer
-# in the documentation and/or other materials provided with the
-# distribution.
-# * Neither the name of Google Inc. nor the names of its
-# contributors may be used to endorse or promote products derived from
-# this software without specific prior written permission.
-#
-# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-# "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-# LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-# A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-# OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-# SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-# LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-# DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-# THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-# (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-# OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
-# ---
-# Program for printing the profile generated by common/profiler.cc,
-# or by the heap profiler (common/debugallocation.cc)
-#
-# The profile contains a sequence of entries of the form:
-# <count> <stack trace>
-# This program parses the profile, and generates user-readable
-# output.
-#
-# Examples:
-#
-# % tools/pprof "program" "profile"
-# Enters "interactive" mode
-#
-# % tools/pprof --text "program" "profile"
-# Generates one line per procedure
-#
-# % tools/pprof --gv "program" "profile"
-# Generates annotated call-graph and displays via "gv"
-#
-# % tools/pprof --gv --focus=Mutex "program" "profile"
-# Restrict to code paths that involve an entry that matches "Mutex"
-#
-# % tools/pprof --gv --focus=Mutex --ignore=string "program" "profile"
-# Restrict to code paths that involve an entry that matches "Mutex"
-# and does not match "string"
-#
-# % tools/pprof --list=IBF_CheckDocid "program" "profile"
-# Generates disassembly listing of all routines with at least one
-# sample that match the --list=<regexp> pattern. The listing is
-# annotated with the flat and cumulative sample counts at each line.
-#
-# % tools/pprof --disasm=IBF_CheckDocid "program" "profile"
-# Generates disassembly listing of all routines with at least one
-# sample that match the --disasm=<regexp> pattern. The listing is
-# annotated with the flat and cumulative sample counts at each PC value.
-#
-# TODO: Use color to indicate files?
-
-use strict;
-use warnings;
-use Getopt::Long;
-
-my $PPROF_VERSION = "1.5";
-
-# These are the object tools we use which can come from a
-# user-specified location using --tools, from the PPROF_TOOLS
-# environment variable, or from the environment.
-my %obj_tool_map = (
- "objdump" => "objdump",
- "nm" => "nm",
- "addr2line" => "addr2line",
- "c++filt" => "c++filt",
- ## ConfigureObjTools may add architecture-specific entries:
- #"nm_pdb" => "nm-pdb", # for reading windows (PDB-format) executables
- #"addr2line_pdb" => "addr2line-pdb", # ditto
- #"otool" => "otool", # equivalent of objdump on OS X
-);
-my $DOT = "dot"; # leave non-absolute, since it may be in /usr/local
-my $GV = "gv";
-my $KCACHEGRIND = "kcachegrind";
-my $PS2PDF = "ps2pdf";
-# These are used for dynamic profiles
-my $CURL = "curl";
-
-# These are the web pages that servers need to support for dynamic profiles
-my $HEAP_PAGE = "/pprof/heap";
-my $PROFILE_PAGE = "/pprof/profile"; # must support cgi-param "?seconds=#"
-my $PMUPROFILE_PAGE = "/pprof/pmuprofile(?:\\?.*)?"; # must support cgi-param
- # ?seconds=#&event=x&period=n
-my $GROWTH_PAGE = "/pprof/growth";
-my $CONTENTION_PAGE = "/pprof/contention";
-my $WALL_PAGE = "/pprof/wall(?:\\?.*)?"; # accepts options like namefilter
-my $FILTEREDPROFILE_PAGE = "/pprof/filteredprofile(?:\\?.*)?";
-my $SYMBOL_PAGE = "/pprof/symbol"; # must support symbol lookup via POST
-my $PROGRAM_NAME_PAGE = "/pprof/cmdline";
-
-# default binary name
-my $UNKNOWN_BINARY = "(unknown)";
-
-# There is a pervasive dependency on the length (in hex characters,
-# i.e., nibbles) of an address, distinguishing between 32-bit and
-# 64-bit profiles. To err on the safe size, default to 64-bit here:
-my $address_length = 16;
-
-# A list of paths to search for shared object files
-my @prefix_list = ();
-
-# Special routine name that should not have any symbols.
-# Used as separator to parse "addr2line -i" output.
-my $sep_symbol = '_fini';
-my $sep_address = undef;
-
-##### Argument parsing #####
-
-sub usage_string {
- return <<EOF;
-Usage:
-pprof [options] <program> <profiles>
- <profiles> is a space separated list of profile names.
-pprof [options] <symbolized-profiles>
- <symbolized-profiles> is a list of profile files where each file contains
- the necessary symbol mappings as well as profile data (likely generated
- with --raw).
-pprof [options] <profile>
- <profile> is a remote form. Symbols are obtained from host:port$SYMBOL_PAGE
-
- Each name can be:
- /path/to/profile - a path to a profile file
- host:port[/<service>] - a location of a service to get profile from
-
- The /<service> can be $HEAP_PAGE, $PROFILE_PAGE, /pprof/pmuprofile,
- $GROWTH_PAGE, $CONTENTION_PAGE, /pprof/wall,
- or /pprof/filteredprofile.
- For instance:
- pprof http://myserver.com:80$HEAP_PAGE
- If /<service> is omitted, the service defaults to $PROFILE_PAGE (cpu profiling).
-pprof --symbols <program>
- Maps addresses to symbol names. In this mode, stdin should be a
- list of library mappings, in the same format as is found in the heap-
- and cpu-profile files (this loosely matches that of /proc/self/maps
- on linux), followed by a list of hex addresses to map, one per line.
-
- For more help with querying remote servers, including how to add the
- necessary server-side support code, see this filename (or one like it):
-
- /usr/doc/google-perftools-$PPROF_VERSION/pprof_remote_servers.html
-
-Options:
- --cum Sort by cumulative data
- --base=<base> Subtract <base> from <profile> before display
- --interactive Run in interactive mode (interactive "help" gives help) [default]
- --seconds=<n> Length of time for dynamic profiles [default=30 secs]
- --add_lib=<file> Read additional symbols and line info from the given library
- --lib_prefix=<dir> Comma separated list of library path prefixes
-
-Reporting Granularity:
- --addresses Report at address level
- --lines Report at source line level
- --functions Report at function level [default]
- --files Report at source file level
-
-Output type:
- --text Generate text report
- --callgrind Generate callgrind format to stdout
- --gv Generate Postscript and display
- --web Generate SVG and display
- --list=<regexp> Generate source listing of matching routines
- --disasm=<regexp> Generate disassembly of matching routines
- --symbols Print demangled symbol names found at given addresses
- --dot Generate DOT file to stdout
- --ps Generate Postcript to stdout
- --pdf Generate PDF to stdout
- --svg Generate SVG to stdout
- --gif Generate GIF to stdout
- --raw Generate symbolized pprof data (useful with remote fetch)
-
-Heap-Profile Options:
- --inuse_space Display in-use (mega)bytes [default]
- --inuse_objects Display in-use objects
- --alloc_space Display allocated (mega)bytes
- --alloc_objects Display allocated objects
- --show_bytes Display space in bytes
- --drop_negative Ignore negative differences
-
-Contention-profile options:
- --total_delay Display total delay at each region [default]
- --contentions Display number of delays at each region
- --mean_delay Display mean delay at each region
-
-Call-graph Options:
- --nodecount=<n> Show at most so many nodes [default=80]
- --nodefraction=<f> Hide nodes below <f>*total [default=.005]
- --edgefraction=<f> Hide edges below <f>*total [default=.001]
- --focus=<regexp> Focus on nodes matching <regexp>
- --ignore=<regexp> Ignore nodes matching <regexp>
- --scale=<n> Set GV scaling [default=0]
- --heapcheck Make nodes with non-0 object counts
- (i.e. direct leak generators) more visible
-
-Miscellaneous:
- --tools=<prefix> Prefix for object tool pathnames
- --test Run unit tests
- --help This message
- --version Version information
-
-Environment Variables:
- PPROF_TMPDIR Profiles directory. Defaults to \$HOME/pprof
- PPROF_TOOLS Prefix for object tools pathnames
-
-Examples:
-
-pprof /bin/ls ls.prof
- Enters "interactive" mode
-pprof --text /bin/ls ls.prof
- Outputs one line per procedure
-pprof --web /bin/ls ls.prof
- Displays annotated call-graph in web browser
-pprof --gv /bin/ls ls.prof
- Displays annotated call-graph via 'gv'
-pprof --gv --focus=Mutex /bin/ls ls.prof
- Restricts to code paths including a .*Mutex.* entry
-pprof --gv --focus=Mutex --ignore=string /bin/ls ls.prof
- Code paths including Mutex but not string
-pprof --list=getdir /bin/ls ls.prof
- (Per-line) annotated source listing for getdir()
-pprof --disasm=getdir /bin/ls ls.prof
- (Per-PC) annotated disassembly for getdir()
-
-pprof http://localhost:1234/
- Enters "interactive" mode
-pprof --text localhost:1234
- Outputs one line per procedure for localhost:1234
-pprof --raw localhost:1234 > ./local.raw
-pprof --text ./local.raw
- Fetches a remote profile for later analysis and then
- analyzes it in text mode.
-EOF
-}
-
-sub version_string {
- return <<EOF
-pprof (part of google-perftools $PPROF_VERSION)
-
-Copyright 1998-2007 Google Inc.
-
-This is BSD licensed software; see the source for copying conditions
-and license information.
-There is NO warranty; not even for MERCHANTABILITY or FITNESS FOR A
-PARTICULAR PURPOSE.
-EOF
-}
-
-sub usage {
- my $msg = shift;
- print STDERR "$msg\n\n";
- print STDERR usage_string();
- print STDERR "\nFATAL ERROR: $msg\n"; # just as a reminder
- exit(1);
-}
-
-sub Init() {
- # Setup tmp-file name and handler to clean it up.
- # We do this in the very beginning so that we can use
- # error() and cleanup() function anytime here after.
- $main::tmpfile_sym = "/tmp/pprof$$.sym";
- $main::tmpfile_ps = "/tmp/pprof$$";
- $main::next_tmpfile = 0;
- $SIG{'INT'} = \&sighandler;
-
- # Cache from filename/linenumber to source code
- $main::source_cache = ();
-
- $main::opt_help = 0;
- $main::opt_version = 0;
-
- $main::opt_cum = 0;
- $main::opt_base = '';
- $main::opt_addresses = 0;
- $main::opt_lines = 0;
- $main::opt_functions = 0;
- $main::opt_files = 0;
- $main::opt_lib_prefix = "";
-
- $main::opt_text = 0;
- $main::opt_callgrind = 0;
- $main::opt_list = "";
- $main::opt_disasm = "";
- $main::opt_symbols = 0;
- $main::opt_gv = 0;
- $main::opt_web = 0;
- $main::opt_dot = 0;
- $main::opt_ps = 0;
- $main::opt_pdf = 0;
- $main::opt_gif = 0;
- $main::opt_svg = 0;
- $main::opt_raw = 0;
-
- $main::opt_nodecount = 80;
- $main::opt_nodefraction = 0.005;
- $main::opt_edgefraction = 0.001;
- $main::opt_focus = '';
- $main::opt_ignore = '';
- $main::opt_scale = 0;
- $main::opt_heapcheck = 0;
- $main::opt_seconds = 30;
- $main::opt_lib = "";
-
- $main::opt_inuse_space = 0;
- $main::opt_inuse_objects = 0;
- $main::opt_alloc_space = 0;
- $main::opt_alloc_objects = 0;
- $main::opt_show_bytes = 0;
- $main::opt_drop_negative = 0;
- $main::opt_interactive = 0;
-
- $main::opt_total_delay = 0;
- $main::opt_contentions = 0;
- $main::opt_mean_delay = 0;
-
- $main::opt_tools = "";
- $main::opt_debug = 0;
- $main::opt_test = 0;
-
- # These are undocumented flags used only by unittests.
- $main::opt_test_stride = 0;
-
- # Are we using $SYMBOL_PAGE?
- $main::use_symbol_page = 0;
-
- # Files returned by TempName.
- %main::tempnames = ();
-
- # Type of profile we are dealing with
- # Supported types:
- # cpu
- # heap
- # growth
- # contention
- $main::profile_type = ''; # Empty type means "unknown"
-
- GetOptions("help!" => \$main::opt_help,
- "version!" => \$main::opt_version,
- "cum!" => \$main::opt_cum,
- "base=s" => \$main::opt_base,
- "seconds=i" => \$main::opt_seconds,
- "add_lib=s" => \$main::opt_lib,
- "lib_prefix=s" => \$main::opt_lib_prefix,
- "functions!" => \$main::opt_functions,
- "lines!" => \$main::opt_lines,
- "addresses!" => \$main::opt_addresses,
- "files!" => \$main::opt_files,
- "text!" => \$main::opt_text,
- "callgrind!" => \$main::opt_callgrind,
- "list=s" => \$main::opt_list,
- "disasm=s" => \$main::opt_disasm,
- "symbols!" => \$main::opt_symbols,
- "gv!" => \$main::opt_gv,
- "web!" => \$main::opt_web,
- "dot!" => \$main::opt_dot,
- "ps!" => \$main::opt_ps,
- "pdf!" => \$main::opt_pdf,
- "svg!" => \$main::opt_svg,
- "gif!" => \$main::opt_gif,
- "raw!" => \$main::opt_raw,
- "interactive!" => \$main::opt_interactive,
- "nodecount=i" => \$main::opt_nodecount,
- "nodefraction=f" => \$main::opt_nodefraction,
- "edgefraction=f" => \$main::opt_edgefraction,
- "focus=s" => \$main::opt_focus,
- "ignore=s" => \$main::opt_ignore,
- "scale=i" => \$main::opt_scale,
- "heapcheck" => \$main::opt_heapcheck,
- "inuse_space!" => \$main::opt_inuse_space,
- "inuse_objects!" => \$main::opt_inuse_objects,
- "alloc_space!" => \$main::opt_alloc_space,
- "alloc_objects!" => \$main::opt_alloc_objects,
- "show_bytes!" => \$main::opt_show_bytes,
- "drop_negative!" => \$main::opt_drop_negative,
- "total_delay!" => \$main::opt_total_delay,
- "contentions!" => \$main::opt_contentions,
- "mean_delay!" => \$main::opt_mean_delay,
- "tools=s" => \$main::opt_tools,
- "test!" => \$main::opt_test,
- "debug!" => \$main::opt_debug,
- # Undocumented flags used only by unittests:
- "test_stride=i" => \$main::opt_test_stride,
- ) || usage("Invalid option(s)");
-
- # Deal with the standard --help and --version
- if ($main::opt_help) {
- print usage_string();
- exit(0);
- }
-
- if ($main::opt_version) {
- print version_string();
- exit(0);
- }
-
- # Disassembly/listing/symbols mode requires address-level info
- if ($main::opt_disasm || $main::opt_list || $main::opt_symbols) {
- $main::opt_functions = 0;
- $main::opt_lines = 0;
- $main::opt_addresses = 1;
- $main::opt_files = 0;
- }
-
- # Check heap-profiling flags
- if ($main::opt_inuse_space +
- $main::opt_inuse_objects +
- $main::opt_alloc_space +
- $main::opt_alloc_objects > 1) {
- usage("Specify at most on of --inuse/--alloc options");
- }
-
- # Check output granularities
- my $grains =
- $main::opt_functions +
- $main::opt_lines +
- $main::opt_addresses +
- $main::opt_files +
- 0;
- if ($grains > 1) {
- usage("Only specify one output granularity option");
- }
- if ($grains == 0) {
- $main::opt_functions = 1;
- }
-
- # Check output modes
- my $modes =
- $main::opt_text +
- $main::opt_callgrind +
- ($main::opt_list eq '' ? 0 : 1) +
- ($main::opt_disasm eq '' ? 0 : 1) +
- ($main::opt_symbols == 0 ? 0 : 1) +
- $main::opt_gv +
- $main::opt_web +
- $main::opt_dot +
- $main::opt_ps +
- $main::opt_pdf +
- $main::opt_svg +
- $main::opt_gif +
- $main::opt_raw +
- $main::opt_interactive +
- 0;
- if ($modes > 1) {
- usage("Only specify one output mode");
- }
- if ($modes == 0) {
- if (-t STDOUT) { # If STDOUT is a tty, activate interactive mode
- $main::opt_interactive = 1;
- } else {
- $main::opt_text = 1;
- }
- }
-
- if ($main::opt_test) {
- RunUnitTests();
- # Should not return
- exit(1);
- }
-
- # Binary name and profile arguments list
- $main::prog = "";
- @main::pfile_args = ();
-
- # Remote profiling without a binary (using $SYMBOL_PAGE instead)
- if (IsProfileURL($ARGV[0])) {
- $main::use_symbol_page = 1;
- } elsif (IsSymbolizedProfileFile($ARGV[0])) {
- $main::use_symbolized_profile = 1;
- $main::prog = $UNKNOWN_BINARY; # will be set later from the profile file
- }
-
- if ($main::use_symbol_page || $main::use_symbolized_profile) {
- # We don't need a binary!
- my %disabled = ('--lines' => $main::opt_lines,
- '--disasm' => $main::opt_disasm);
- for my $option (keys %disabled) {
- usage("$option cannot be used without a binary") if $disabled{$option};
- }
- # Set $main::prog later...
- scalar(@ARGV) || usage("Did not specify profile file");
- } elsif ($main::opt_symbols) {
- # --symbols needs a binary-name (to run nm on, etc) but not profiles
- $main::prog = shift(@ARGV) || usage("Did not specify program");
- } else {
- $main::prog = shift(@ARGV) || usage("Did not specify program");
- scalar(@ARGV) || usage("Did not specify profile file");
- }
-
- # Parse profile file/location arguments
- foreach my $farg (@ARGV) {
- if ($farg =~ m/(.*)\@([0-9]+)(|\/.*)$/ ) {
- my $machine = $1;
- my $num_machines = $2;
- my $path = $3;
- for (my $i = 0; $i < $num_machines; $i++) {
- unshift(@main::pfile_args, "$i.$machine$path");
- }
- } else {
- unshift(@main::pfile_args, $farg);
- }
- }
-
- if ($main::use_symbol_page) {
- unless (IsProfileURL($main::pfile_args[0])) {
- error("The first profile should be a remote form to use $SYMBOL_PAGE\n");
- }
- CheckSymbolPage();
- $main::prog = FetchProgramName();
- } elsif (!$main::use_symbolized_profile) { # may not need objtools!
- ConfigureObjTools($main::prog)
- }
-
- # Break the opt_lib_prefix into the prefix_list array
- @prefix_list = split (',', $main::opt_lib_prefix);
-
- # Remove trailing / from the prefixes, in the list to prevent
- # searching things like /my/path//lib/mylib.so
- foreach (@prefix_list) {
- s|/+$||;
- }
-}
-
-sub Main() {
- Init();
- $main::collected_profile = undef;
- @main::profile_files = ();
- $main::op_time = time();
-
- # Printing symbols is special and requires a lot less info that most.
- if ($main::opt_symbols) {
- PrintSymbols(*STDIN); # Get /proc/maps and symbols output from stdin
- return;
- }
-
- # Fetch all profile data
- FetchDynamicProfiles();
-
- # this will hold symbols that we read from the profile files
- my $symbol_map = {};
-
- # Read one profile, pick the last item on the list
- my $data = ReadProfile($main::prog, pop(@main::profile_files));
- my $profile = $data->{profile};
- my $pcs = $data->{pcs};
- my $libs = $data->{libs}; # Info about main program and shared libraries
- $symbol_map = MergeSymbols($symbol_map, $data->{symbols});
-
- # Add additional profiles, if available.
- if (scalar(@main::profile_files) > 0) {
- foreach my $pname (@main::profile_files) {
- my $data2 = ReadProfile($main::prog, $pname);
- $profile = AddProfile($profile, $data2->{profile});
- $pcs = AddPcs($pcs, $data2->{pcs});
- $symbol_map = MergeSymbols($symbol_map, $data2->{symbols});
- }
- }
-
- # Subtract base from profile, if specified
- if ($main::opt_base ne '') {
- my $base = ReadProfile($main::prog, $main::opt_base);
- $profile = SubtractProfile($profile, $base->{profile});
- $pcs = AddPcs($pcs, $base->{pcs});
- $symbol_map = MergeSymbols($symbol_map, $base->{symbols});
- }
-
- # Get total data in profile
- my $total = TotalProfile($profile);
-
- # Collect symbols
- my $symbols;
- if ($main::use_symbolized_profile) {
- $symbols = FetchSymbols($pcs, $symbol_map);
- } elsif ($main::use_symbol_page) {
- $symbols = FetchSymbols($pcs);
- } else {
- $symbols = ExtractSymbols($libs, $pcs);
- }
-
- # Remove uniniteresting stack items
- $profile = RemoveUninterestingFrames($symbols, $profile);
-
- # Focus?
- if ($main::opt_focus ne '') {
- $profile = FocusProfile($symbols, $profile, $main::opt_focus);
- }
-
- # Ignore?
- if ($main::opt_ignore ne '') {
- $profile = IgnoreProfile($symbols, $profile, $main::opt_ignore);
- }
-
- my $calls = ExtractCalls($symbols, $profile);
-
- # Reduce profiles to required output granularity, and also clean
- # each stack trace so a given entry exists at most once.
- my $reduced = ReduceProfile($symbols, $profile);
-
- # Get derived profiles
- my $flat = FlatProfile($reduced);
- my $cumulative = CumulativeProfile($reduced);
-
- # Print
- if (!$main::opt_interactive) {
- if ($main::opt_disasm) {
- PrintDisassembly($libs, $flat, $cumulative, $main::opt_disasm, $total);
- } elsif ($main::opt_list) {
- PrintListing($total, $libs, $flat, $cumulative, $main::opt_list, 0);
- } elsif ($main::opt_text) {
- # Make sure the output is empty when have nothing to report
- # (only matters when --heapcheck is given but we must be
- # compatible with old branches that did not pass --heapcheck always):
- if ($total != 0) {
- printf("Total: %s %s\n", Unparse($total), Units());
- }
- PrintText($symbols, $flat, $cumulative, $total, -1);
- } elsif ($main::opt_raw) {
- PrintSymbolizedProfile($symbols, $profile, $main::prog);
- } elsif ($main::opt_callgrind) {
- PrintCallgrind($calls);
- } else {
- if (PrintDot($main::prog, $symbols, $profile, $flat, $cumulative, $total)) {
- if ($main::opt_gv) {
- RunGV(TempName($main::next_tmpfile, "ps"), "");
- } elsif ($main::opt_web) {
- my $tmp = TempName($main::next_tmpfile, "svg");
- RunWeb($tmp);
- # The command we run might hand the file name off
- # to an already running browser instance and then exit.
- # Normally, we'd remove $tmp on exit (right now),
- # but fork a child to remove $tmp a little later, so that the
- # browser has time to load it first.
- delete $main::tempnames{$tmp};
- if (fork() == 0) {
- sleep 5;
- unlink($tmp);
- exit(0);
- }
- }
- } else {
- exit(1);
- }
- }
- } else {
- InteractiveMode($profile, $symbols, $libs, $total);
- }
-
- cleanup();
- exit(0);
-}
-
-##### Entry Point #####
-
-Main();
-
-# Temporary code to detect if we're running on a Goobuntu system.
-# These systems don't have the right stuff installed for the special
-# Readline libraries to work, so as a temporary workaround, we default
-# to using the normal stdio code, rather than the fancier readline-based
-# code
-sub ReadlineMightFail {
- if (-e '/lib/libtermcap.so.2') {
- return 0; # libtermcap exists, so readline should be okay
- } else {
- return 1;
- }
-}
-
-sub RunGV {
- my $fname = shift;
- my $bg = shift; # "" or " &" if we should run in background
- if (!system("$GV --version >/dev/null 2>&1")) {
- # Options using double dash are supported by this gv version.
- # Also, turn on noantialias to better handle bug in gv for
- # postscript files with large dimensions.
- # TODO: Maybe we should not pass the --noantialias flag
- # if the gv version is known to work properly without the flag.
- system("$GV --scale=$main::opt_scale --noantialias " . $fname . $bg);
- } else {
- # Old gv version - only supports options that use single dash.
- print STDERR "$GV -scale $main::opt_scale\n";
- system("$GV -scale $main::opt_scale " . $fname . $bg);
- }
-}
-
-sub RunWeb {
- my $fname = shift;
- print STDERR "Loading web page file:///$fname\n";
-
- if (`uname` =~ /Darwin/) {
- # OS X: open will use standard preference for SVG files.
- system("/usr/bin/open", $fname);
- return;
- }
-
- # Some kind of Unix; try generic symlinks, then specific browsers.
- # (Stop once we find one.)
- # Works best if the browser is already running.
- my @alt = (
- "/etc/alternatives/gnome-www-browser",
- "/etc/alternatives/x-www-browser",
- "google-chrome",
- "firefox",
- );
- foreach my $b (@alt) {
- if (-f $b) {
- if (system($b, $fname) == 0) {
- return;
- }
- }
- }
-
- print STDERR "Could not load web browser.\n";
-}
-
-sub RunKcachegrind {
- my $fname = shift;
- my $bg = shift; # "" or " &" if we should run in background
- print STDERR "Starting '$KCACHEGRIND " . $fname . $bg . "'\n";
- system("$KCACHEGRIND " . $fname . $bg);
-}
-
-
-##### Interactive helper routines #####
-
-sub InteractiveMode {
- $| = 1; # Make output unbuffered for interactive mode
- my ($orig_profile, $symbols, $libs, $total) = @_;
-
- print STDERR "Welcome to pprof! For help, type 'help'.\n";
-
- # Use ReadLine if it's installed and input comes from a console.
- if ( -t STDIN &&
- !ReadlineMightFail() &&
- defined(eval {require Term::ReadLine}) ) {
- my $term = new Term::ReadLine 'pprof';
- while ( defined ($_ = $term->readline('(pprof) '))) {
- $term->addhistory($_) if /\S/;
- if (!InteractiveCommand($orig_profile, $symbols, $libs, $total, $_)) {
- last; # exit when we get an interactive command to quit
- }
- }
- } else { # don't have readline
- while (1) {
- print STDERR "(pprof) ";
- $_ = <STDIN>;
- last if ! defined $_ ;
- s/\r//g; # turn windows-looking lines into unix-looking lines
-
- # Save some flags that might be reset by InteractiveCommand()
- my $save_opt_lines = $main::opt_lines;
-
- if (!InteractiveCommand($orig_profile, $symbols, $libs, $total, $_)) {
- last; # exit when we get an interactive command to quit
- }
-
- # Restore flags
- $main::opt_lines = $save_opt_lines;
- }
- }
-}
-
-# Takes two args: orig profile, and command to run.
-# Returns 1 if we should keep going, or 0 if we were asked to quit
-sub InteractiveCommand {
- my($orig_profile, $symbols, $libs, $total, $command) = @_;
- $_ = $command; # just to make future m//'s easier
- if (!defined($_)) {
- print STDERR "\n";
- return 0;
- }
- if (m/^\s*quit/) {
- return 0;
- }
- if (m/^\s*help/) {
- InteractiveHelpMessage();
- return 1;
- }
- # Clear all the mode options -- mode is controlled by "$command"
- $main::opt_text = 0;
- $main::opt_callgrind = 0;
- $main::opt_disasm = 0;
- $main::opt_list = 0;
- $main::opt_gv = 0;
- $main::opt_cum = 0;
-
- if (m/^\s*(text|top)(\d*)\s*(.*)/) {
- $main::opt_text = 1;
-
- my $line_limit = ($2 ne "") ? int($2) : 10;
-
- my $routine;
- my $ignore;
- ($routine, $ignore) = ParseInteractiveArgs($3);
-
- my $profile = ProcessProfile($total, $orig_profile, $symbols, "", $ignore);
- my $reduced = ReduceProfile($symbols, $profile);
-
- # Get derived profiles
- my $flat = FlatProfile($reduced);
- my $cumulative = CumulativeProfile($reduced);
-
- PrintText($symbols, $flat, $cumulative, $total, $line_limit);
- return 1;
- }
- if (m/^\s*callgrind\s*([^ \n]*)/) {
- $main::opt_callgrind = 1;
-
- # Get derived profiles
- my $calls = ExtractCalls($symbols, $orig_profile);
- my $filename = $1;
- if ( $1 eq '' ) {
- $filename = TempName($main::next_tmpfile, "callgrind");
- }
- PrintCallgrind($calls, $filename);
- if ( $1 eq '' ) {
- RunKcachegrind($filename, " & ");
- $main::next_tmpfile++;
- }
-
- return 1;
- }
- if (m/^\s*(web)?list\s*(.+)/) {
- my $html = (defined($1) && ($1 eq "web"));
- $main::opt_list = 1;
-
- my $routine;
- my $ignore;
- ($routine, $ignore) = ParseInteractiveArgs($2);
-
- my $profile = ProcessProfile($total, $orig_profile, $symbols, "", $ignore);
- my $reduced = ReduceProfile($symbols, $profile);
-
- # Get derived profiles
- my $flat = FlatProfile($reduced);
- my $cumulative = CumulativeProfile($reduced);
-
- PrintListing($total, $libs, $flat, $cumulative, $routine, $html);
- return 1;
- }
- if (m/^\s*disasm\s*(.+)/) {
- $main::opt_disasm = 1;
-
- my $routine;
- my $ignore;
- ($routine, $ignore) = ParseInteractiveArgs($1);
-
- # Process current profile to account for various settings
- my $profile = ProcessProfile($total, $orig_profile, $symbols, "", $ignore);
- my $reduced = ReduceProfile($symbols, $profile);
-
- # Get derived profiles
- my $flat = FlatProfile($reduced);
- my $cumulative = CumulativeProfile($reduced);
-
- PrintDisassembly($libs, $flat, $cumulative, $routine, $total);
- return 1;
- }
- if (m/^\s*(gv|web)\s*(.*)/) {
- $main::opt_gv = 0;
- $main::opt_web = 0;
- if ($1 eq "gv") {
- $main::opt_gv = 1;
- } elsif ($1 eq "web") {
- $main::opt_web = 1;
- }
-
- my $focus;
- my $ignore;
- ($focus, $ignore) = ParseInteractiveArgs($2);
-
- # Process current profile to account for various settings
- my $profile = ProcessProfile($total, $orig_profile, $symbols, $focus, $ignore);
- my $reduced = ReduceProfile($symbols, $profile);
-
- # Get derived profiles
- my $flat = FlatProfile($reduced);
- my $cumulative = CumulativeProfile($reduced);
-
- if (PrintDot($main::prog, $symbols, $profile, $flat, $cumulative, $total)) {
- if ($main::opt_gv) {
- RunGV(TempName($main::next_tmpfile, "ps"), " &");
- } elsif ($main::opt_web) {
- RunWeb(TempName($main::next_tmpfile, "svg"));
- }
- $main::next_tmpfile++;
- }
- return 1;
- }
- if (m/^\s*$/) {
- return 1;
- }
- print STDERR "Unknown command: try 'help'.\n";
- return 1;
-}
-
-
-sub ProcessProfile {
- my $total_count = shift;
- my $orig_profile = shift;
- my $symbols = shift;
- my $focus = shift;
- my $ignore = shift;
-
- # Process current profile to account for various settings
- my $profile = $orig_profile;
- printf("Total: %s %s\n", Unparse($total_count), Units());
- if ($focus ne '') {
- $profile = FocusProfile($symbols, $profile, $focus);
- my $focus_count = TotalProfile($profile);
- printf("After focusing on '%s': %s %s of %s (%0.1f%%)\n",
- $focus,
- Unparse($focus_count), Units(),
- Unparse($total_count), ($focus_count*100.0) / $total_count);
- }
- if ($ignore ne '') {
- $profile = IgnoreProfile($symbols, $profile, $ignore);
- my $ignore_count = TotalProfile($profile);
- printf("After ignoring '%s': %s %s of %s (%0.1f%%)\n",
- $ignore,
- Unparse($ignore_count), Units(),
- Unparse($total_count),
- ($ignore_count*100.0) / $total_count);
- }
-
- return $profile;
-}
-
-sub InteractiveHelpMessage {
- print STDERR <<ENDOFHELP;
-Interactive pprof mode
-
-Commands:
- gv
- gv [focus] [-ignore1] [-ignore2]
- Show graphical hierarchical display of current profile. Without
- any arguments, shows all samples in the profile. With the optional
- "focus" argument, restricts the samples shown to just those where
- the "focus" regular expression matches a routine name on the stack
- trace.
-
- web
- web [focus] [-ignore1] [-ignore2]
- Like GV, but displays profile in your web browser instead of using
- Ghostview. Works best if your web browser is already running.
- To change the browser that gets used:
- On Linux, set the /etc/alternatives/gnome-www-browser symlink.
- On OS X, change the Finder association for SVG files.
-
- list [routine_regexp] [-ignore1] [-ignore2]
- Show source listing of routines whose names match "routine_regexp"
-
- weblist [routine_regexp] [-ignore1] [-ignore2]
- Displays a source listing of routines whose names match "routine_regexp"
- in a web browser. You can click on source lines to view the
- corresponding disassembly.
-
- top [--cum] [-ignore1] [-ignore2]
- top20 [--cum] [-ignore1] [-ignore2]
- top37 [--cum] [-ignore1] [-ignore2]
- Show top lines ordered by flat profile count, or cumulative count
- if --cum is specified. If a number is present after 'top', the
- top K routines will be shown (defaults to showing the top 10)
-
- disasm [routine_regexp] [-ignore1] [-ignore2]
- Show disassembly of routines whose names match "routine_regexp",
- annotated with sample counts.
-
- callgrind
- callgrind [filename]
- Generates callgrind file. If no filename is given, kcachegrind is called.
-
- help - This listing
- quit or ^D - End pprof
-
-For commands that accept optional -ignore tags, samples where any routine in
-the stack trace matches the regular expression in any of the -ignore
-parameters will be ignored.
-
-Further pprof details are available at this location (or one similar):
-
- /usr/doc/google-perftools-$PPROF_VERSION/cpu_profiler.html
- /usr/doc/google-perftools-$PPROF_VERSION/heap_profiler.html
-
-ENDOFHELP
-}
-sub ParseInteractiveArgs {
- my $args = shift;
- my $focus = "";
- my $ignore = "";
- my @x = split(/ +/, $args);
- foreach $a (@x) {
- if ($a =~ m/^(--|-)lines$/) {
- $main::opt_lines = 1;
- } elsif ($a =~ m/^(--|-)cum$/) {
- $main::opt_cum = 1;
- } elsif ($a =~ m/^-(.*)/) {
- $ignore .= (($ignore ne "") ? "|" : "" ) . $1;
- } else {
- $focus .= (($focus ne "") ? "|" : "" ) . $a;
- }
- }
- if ($ignore ne "") {
- print STDERR "Ignoring samples in call stacks that match '$ignore'\n";
- }
- return ($focus, $ignore);
-}
-
-##### Output code #####
-
-sub TempName {
- my $fnum = shift;
- my $ext = shift;
- my $file = "$main::tmpfile_ps.$fnum.$ext";
- $main::tempnames{$file} = 1;
- return $file;
-}
-
-# Print profile data in packed binary format (64-bit) to standard out
-sub PrintProfileData {
- my $profile = shift;
-
- # print header (64-bit style)
- # (zero) (header-size) (version) (sample-period) (zero)
- print pack('L*', 0, 0, 3, 0, 0, 0, 1, 0, 0, 0);
-
- foreach my $k (keys(%{$profile})) {
- my $count = $profile->{$k};
- my @addrs = split(/\n/, $k);
- if ($#addrs >= 0) {
- my $depth = $#addrs + 1;
- # int(foo / 2**32) is the only reliable way to get rid of bottom
- # 32 bits on both 32- and 64-bit systems.
- print pack('L*', $count & 0xFFFFFFFF, int($count / 2**32));
- print pack('L*', $depth & 0xFFFFFFFF, int($depth / 2**32));
-
- foreach my $full_addr (@addrs) {
- my $addr = $full_addr;
- $addr =~ s/0x0*//; # strip off leading 0x, zeroes
- if (length($addr) > 16) {
- print STDERR "Invalid address in profile: $full_addr\n";
- next;
- }
- my $low_addr = substr($addr, -8); # get last 8 hex chars
- my $high_addr = substr($addr, -16, 8); # get up to 8 more hex chars
- print pack('L*', hex('0x' . $low_addr), hex('0x' . $high_addr));
- }
- }
- }
-}
-
-# Print symbols and profile data
-sub PrintSymbolizedProfile {
- my $symbols = shift;
- my $profile = shift;
- my $prog = shift;
-
- $SYMBOL_PAGE =~ m,[^/]+$,; # matches everything after the last slash
- my $symbol_marker = $&;
-
- print '--- ', $symbol_marker, "\n";
- if (defined($prog)) {
- print 'binary=', $prog, "\n";
- }
- while (my ($pc, $name) = each(%{$symbols})) {
- my $sep = ' ';
- print '0x', $pc;
- # We have a list of function names, which include the inlined
- # calls. They are separated (and terminated) by --, which is
- # illegal in function names.
- for (my $j = 2; $j <= $#{$name}; $j += 3) {
- print $sep, $name->[$j];
- $sep = '--';
- }
- print "\n";
- }
- print '---', "\n";
-
- $PROFILE_PAGE =~ m,[^/]+$,; # matches everything after the last slash
- my $profile_marker = $&;
- print '--- ', $profile_marker, "\n";
- if (defined($main::collected_profile)) {
- # if used with remote fetch, simply dump the collected profile to output.
- open(SRC, "<$main::collected_profile");
- while (<SRC>) {
- print $_;
- }
- close(SRC);
- } else {
- # dump a cpu-format profile to standard out
- PrintProfileData($profile);
- }
-}
-
-# Print text output
-sub PrintText {
- my $symbols = shift;
- my $flat = shift;
- my $cumulative = shift;
- my $total = shift;
- my $line_limit = shift;
-
- # Which profile to sort by?
- my $s = $main::opt_cum ? $cumulative : $flat;
-
- my $running_sum = 0;
- my $lines = 0;
- foreach my $k (sort { GetEntry($s, $b) <=> GetEntry($s, $a) || $a cmp $b }
- keys(%{$cumulative})) {
- my $f = GetEntry($flat, $k);
- my $c = GetEntry($cumulative, $k);
- $running_sum += $f;
-
- my $sym = $k;
- if (exists($symbols->{$k})) {
- $sym = $symbols->{$k}->[0] . " " . $symbols->{$k}->[1];
- if ($main::opt_addresses) {
- $sym = $k . " " . $sym;
- }
- }
-
- if ($f != 0 || $c != 0) {
- printf("%8s %6s %6s %8s %6s %s\n",
- Unparse($f),
- Percent($f, $total),
- Percent($running_sum, $total),
- Unparse($c),
- Percent($c, $total),
- $sym);
- }
- $lines++;
- last if ($line_limit >= 0 && $lines >= $line_limit);
- }
-}
-
-# Print the call graph in a way that's suiteable for callgrind.
-sub PrintCallgrind {
- my $calls = shift;
- my $filename;
- if ($main::opt_interactive) {
- $filename = shift;
- print STDERR "Writing callgrind file to '$filename'.\n"
- } else {
- $filename = "&STDOUT";
- }
- open(CG, ">".$filename );
- printf CG ("events: Hits\n\n");
- foreach my $call ( map { $_->[0] }
- sort { $a->[1] cmp $b ->[1] ||
- $a->[2] <=> $b->[2] }
- map { /([^:]+):(\d+):([^ ]+)( -> ([^:]+):(\d+):(.+))?/;
- [$_, $1, $2] }
- keys %$calls ) {
- my $count = int($calls->{$call});
- $call =~ /([^:]+):(\d+):([^ ]+)( -> ([^:]+):(\d+):(.+))?/;
- my ( $caller_file, $caller_line, $caller_function,
- $callee_file, $callee_line, $callee_function ) =
- ( $1, $2, $3, $5, $6, $7 );
-
- printf CG ("fl=$caller_file\nfn=$caller_function\n");
- if (defined $6) {
- printf CG ("cfl=$callee_file\n");
- printf CG ("cfn=$callee_function\n");
- printf CG ("calls=$count $callee_line\n");
- }
- printf CG ("$caller_line $count\n\n");
- }
-}
-
-# Print disassembly for all all routines that match $main::opt_disasm
-sub PrintDisassembly {
- my $libs = shift;
- my $flat = shift;
- my $cumulative = shift;
- my $disasm_opts = shift;
- my $total = shift;
-
- foreach my $lib (@{$libs}) {
- my $symbol_table = GetProcedureBoundaries($lib->[0], $disasm_opts);
- my $offset = AddressSub($lib->[1], $lib->[3]);
- foreach my $routine (sort ByName keys(%{$symbol_table})) {
- my $start_addr = $symbol_table->{$routine}->[0];
- my $end_addr = $symbol_table->{$routine}->[1];
- # See if there are any samples in this routine
- my $length = hex(AddressSub($end_addr, $start_addr));
- my $addr = AddressAdd($start_addr, $offset);
- for (my $i = 0; $i < $length; $i++) {
- if (defined($cumulative->{$addr})) {
- PrintDisassembledFunction($lib->[0], $offset,
- $routine, $flat, $cumulative,
- $start_addr, $end_addr, $total);
- last;
- }
- $addr = AddressInc($addr);
- }
- }
- }
-}
-
-# Return reference to array of tuples of the form:
-# [start_address, filename, linenumber, instruction, limit_address]
-# E.g.,
-# ["0x806c43d", "/foo/bar.cc", 131, "ret", "0x806c440"]
-sub Disassemble {
- my $prog = shift;
- my $offset = shift;
- my $start_addr = shift;
- my $end_addr = shift;
-
- my $objdump = $obj_tool_map{"objdump"};
- my $cmd = sprintf("$objdump -C -d -l --no-show-raw-insn " .
- "--start-address=0x$start_addr " .
- "--stop-address=0x$end_addr $prog");
- open(OBJDUMP, "$cmd |") || error("$objdump: $!\n");
- my @result = ();
- my $filename = "";
- my $linenumber = -1;
- my $last = ["", "", "", ""];
- while (<OBJDUMP>) {
- s/\r//g; # turn windows-looking lines into unix-looking lines
- chop;
- if (m|\s*([^:\s]+):(\d+)\s*$|) {
- # Location line of the form:
- # <filename>:<linenumber>
- $filename = $1;
- $linenumber = $2;
- } elsif (m/^ +([0-9a-f]+):\s*(.*)/) {
- # Disassembly line -- zero-extend address to full length
- my $addr = HexExtend($1);
- my $k = AddressAdd($addr, $offset);
- $last->[4] = $k; # Store ending address for previous instruction
- $last = [$k, $filename, $linenumber, $2, $end_addr];
- push(@result, $last);
- }
- }
- close(OBJDUMP);
- return @result;
-}
-
-# The input file should contain lines of the form /proc/maps-like
-# output (same format as expected from the profiles) or that looks
-# like hex addresses (like "0xDEADBEEF"). We will parse all
-# /proc/maps output, and for all the hex addresses, we will output
-# "short" symbol names, one per line, in the same order as the input.
-sub PrintSymbols {
- my $maps_and_symbols_file = shift;
-
- # ParseLibraries expects pcs to be in a set. Fine by us...
- my @pclist = (); # pcs in sorted order
- my $pcs = {};
- my $map = "";
- foreach my $line (<$maps_and_symbols_file>) {
- $line =~ s/\r//g; # turn windows-looking lines into unix-looking lines
- if ($line =~ /\b(0x[0-9a-f]+)\b/i) {
- push(@pclist, HexExtend($1));
- $pcs->{$pclist[-1]} = 1;
- } else {
- $map .= $line;
- }
- }
-
- my $libs = ParseLibraries($main::prog, $map, $pcs);
- my $symbols = ExtractSymbols($libs, $pcs);
-
- foreach my $pc (@pclist) {
- # ->[0] is the shortname, ->[2] is the full name
- print(($symbols->{$pc}->[0] || "??") . "\n");
- }
-}
-
-
-# For sorting functions by name
-sub ByName {
- return ShortFunctionName($a) cmp ShortFunctionName($b);
-}
-
-# Print source-listing for all all routines that match $main::opt_list
-sub PrintListing {
- my $total = shift;
- my $libs = shift;
- my $flat = shift;
- my $cumulative = shift;
- my $list_opts = shift;
- my $html = shift;
-
- my $output = \*STDOUT;
- my $fname = "";
-
-
- if ($html) {
- # Arrange to write the output to a temporary file
- $fname = TempName($main::next_tmpfile, "html");
- $main::next_tmpfile++;
- if (!open(TEMP, ">$fname")) {
- print STDERR "$fname: $!\n";
- return;
- }
- $output = \*TEMP;
- print $output HtmlListingHeader();
- printf $output ("<div class=\"legend\">%s<br>Total: %s %s</div>\n",
- $main::prog, Unparse($total), Units());
- }
-
- my $listed = 0;
- foreach my $lib (@{$libs}) {
- my $symbol_table = GetProcedureBoundaries($lib->[0], $list_opts);
- my $offset = AddressSub($lib->[1], $lib->[3]);
- foreach my $routine (sort ByName keys(%{$symbol_table})) {
- # Print if there are any samples in this routine
- my $start_addr = $symbol_table->{$routine}->[0];
- my $end_addr = $symbol_table->{$routine}->[1];
- my $length = hex(AddressSub($end_addr, $start_addr));
- my $addr = AddressAdd($start_addr, $offset);
- for (my $i = 0; $i < $length; $i++) {
- if (defined($cumulative->{$addr})) {
- $listed += PrintSource(
- $lib->[0], $offset,
- $routine, $flat, $cumulative,
- $start_addr, $end_addr,
- $html,
- $output);
- last;
- }
- $addr = AddressInc($addr);
- }
- }
- }
-
- if ($html) {
- if ($listed > 0) {
- print $output HtmlListingFooter();
- close($output);
- RunWeb($fname);
- } else {
- close($output);
- unlink($fname);
- }
- }
-}
-
-sub HtmlListingHeader {
- return <<'EOF';
-<DOCTYPE html>
-<html>
-<head>
-<title>Pprof listing</title>
-<style type="text/css">
-body {
- font-family: sans-serif;
-}
-h1 {
- font-size: 1.5em;
- margin-bottom: 4px;
-}
-.legend {
- font-size: 1.25em;
-}
-.line {
- color: #aaaaaa;
-}
-.livesrc {
- color: #0000ff;
- cursor: pointer;
-}
-.livesrc:hover {
- background-color: #cccccc;
-}
-.asm {
- color: #888888;
- display: none;
-}
-</style>
-<script type="text/javascript">
-function pprof_toggle_asm(e) {
- var target;
- if (!e) e = window.event;
- if (e.target) target = e.target;
- else if (e.srcElement) target = e.srcElement;
-
- if (target && target.className == "livesrc") {
- var asm = target.nextSibling;
- if (asm && asm.className == "asm") {
- asm.style.display = (asm.style.display == "block" ? "none" : "block");
- e.preventDefault();
- return false;
- }
- }
-}
-</script>
-</head>
-<body>
-EOF
-}
-
-sub HtmlListingFooter {
- return <<'EOF';
-</body>
-</html>
-EOF
-}
-
-sub HtmlEscape {
- my $text = shift;
- $text =~ s/&/&amp;/g;
- $text =~ s/</&lt;/g;
- $text =~ s/>/&gt;/g;
- return $text;
-}
-
-# Returns the indentation of the line, if it has any non-whitespace
-# characters. Otherwise, returns -1.
-sub Indentation {
- my $line = shift;
- if (m/^(\s*)\S/) {
- return length($1);
- } else {
- return -1;
- }
-}
-
-# Print source-listing for one routine
-sub PrintSource {
- my $prog = shift;
- my $offset = shift;
- my $routine = shift;
- my $flat = shift;
- my $cumulative = shift;
- my $start_addr = shift;
- my $end_addr = shift;
- my $html = shift;
- my $output = shift;
-
- # Disassemble all instructions (just to get line numbers)
- my @instructions = Disassemble($prog, $offset, $start_addr, $end_addr);
-
- # Hack 1: assume that the first source file encountered in the
- # disassembly contains the routine
- my $filename = undef;
- for (my $i = 0; $i <= $#instructions; $i++) {
- if ($instructions[$i]->[2] >= 0) {
- $filename = $instructions[$i]->[1];
- last;
- }
- }
- if (!defined($filename)) {
- print STDERR "no filename found in $routine\n";
- return 0;
- }
-
- # Hack 2: assume that the largest line number from $filename is the
- # end of the procedure. This is typically safe since if P1 contains
- # an inlined call to P2, then P2 usually occurs earlier in the
- # source file. If this does not work, we might have to compute a
- # density profile or just print all regions we find.
- my $lastline = 0;
- for (my $i = 0; $i <= $#instructions; $i++) {
- my $f = $instructions[$i]->[1];
- my $l = $instructions[$i]->[2];
- if (($f eq $filename) && ($l > $lastline)) {
- $lastline = $l;
- }
- }
-
- # Hack 3: assume the first source location from "filename" is the start of
- # the source code.
- my $firstline = 1;
- for (my $i = 0; $i <= $#instructions; $i++) {
- if ($instructions[$i]->[1] eq $filename) {
- $firstline = $instructions[$i]->[2];
- last;
- }
- }
-
- # Hack 4: Extend last line forward until its indentation is less than
- # the indentation we saw on $firstline
- my $oldlastline = $lastline;
- {
- if (!open(FILE, "<$filename")) {
- print STDERR "$filename: $!\n";
- return 0;
- }
- my $l = 0;
- my $first_indentation = -1;
- while (<FILE>) {
- s/\r//g; # turn windows-looking lines into unix-looking lines
- $l++;
- my $indent = Indentation($_);
- if ($l >= $firstline) {
- if ($first_indentation < 0 && $indent >= 0) {
- $first_indentation = $indent;
- last if ($first_indentation == 0);
- }
- }
- if ($l >= $lastline && $indent >= 0) {
- if ($indent >= $first_indentation) {
- $lastline = $l+1;
- } else {
- last;
- }
- }
- }
- close(FILE);
- }
-
- # Assign all samples to the range $firstline,$lastline,
- # Hack 4: If an instruction does not occur in the range, its samples
- # are moved to the next instruction that occurs in the range.
- my $samples1 = {}; # Map from line number to flat count
- my $samples2 = {}; # Map from line number to cumulative count
- my $running1 = 0; # Unassigned flat counts
- my $running2 = 0; # Unassigned cumulative counts
- my $total1 = 0; # Total flat counts
- my $total2 = 0; # Total cumulative counts
- my %disasm = (); # Map from line number to disassembly
- my $running_disasm = ""; # Unassigned disassembly
- my $skip_marker = "---\n";
- if ($html) {
- $skip_marker = "";
- for (my $l = $firstline; $l <= $lastline; $l++) {
- $disasm{$l} = "";
- }
- }
- foreach my $e (@instructions) {
- # Add up counts for all address that fall inside this instruction
- my $c1 = 0;
- my $c2 = 0;
- for (my $a = $e->[0]; $a lt $e->[4]; $a = AddressInc($a)) {
- $c1 += GetEntry($flat, $a);
- $c2 += GetEntry($cumulative, $a);
- }
-
- if ($html) {
- $running_disasm .= sprintf(" %6s %6s \t\t%8s: %s\n",
- HtmlPrintNumber($c1),
- HtmlPrintNumber($c2),
- $e->[0],
- CleanDisassembly($e->[3]));
- }
-
- $running1 += $c1;
- $running2 += $c2;
- $total1 += $c1;
- $total2 += $c2;
- my $file = $e->[1];
- my $line = $e->[2];
- if (($file eq $filename) &&
- ($line >= $firstline) &&
- ($line <= $lastline)) {
- # Assign all accumulated samples to this line
- AddEntry($samples1, $line, $running1);
- AddEntry($samples2, $line, $running2);
- $running1 = 0;
- $running2 = 0;
- if ($html) {
- $disasm{$line} .= $running_disasm;
- $running_disasm = '';
- }
- }
- }
-
- # Assign any leftover samples to $lastline
- AddEntry($samples1, $lastline, $running1);
- AddEntry($samples2, $lastline, $running2);
-
- if ($html) {
- printf $output (
- "<h1>%s</h1>%s\n<pre onClick=\"pprof_toggle_asm()\">\n" .
- "Total:%6s %6s (flat / cumulative %s)\n",
- HtmlEscape(ShortFunctionName($routine)),
- HtmlEscape($filename),
- Unparse($total1),
- Unparse($total2),
- Units());
- } else {
- printf $output (
- "ROUTINE ====================== %s in %s\n" .
- "%6s %6s Total %s (flat / cumulative)\n",
- ShortFunctionName($routine),
- $filename,
- Unparse($total1),
- Unparse($total2),
- Units());
- }
- if (!open(FILE, "<$filename")) {
- print STDERR "$filename: $!\n";
- return 0;
- }
- my $l = 0;
- while (<FILE>) {
- s/\r//g; # turn windows-looking lines into unix-looking lines
- $l++;
- if ($l >= $firstline - 5 &&
- (($l <= $oldlastline + 5) || ($l <= $lastline))) {
- chop;
- my $text = $_;
- if ($l == $firstline) { print $output $skip_marker; }
- my $n1 = GetEntry($samples1, $l);
- my $n2 = GetEntry($samples2, $l);
- if ($html) {
- my $dis = $disasm{$l};
- if (!defined($dis) || $n1 + $n2 == 0) {
- # No samples/disassembly for this source line
- printf $output (
- "<span class=\"line\">%5d</span> " .
- "<span class=\"deadsrc\">%6s %6s %s</span>\n",
- $l,
- HtmlPrintNumber($n1),
- HtmlPrintNumber($n2),
- HtmlEscape($text));
- } else {
- printf $output (
- "<span class=\"line\">%5d</span> " .
- "<span class=\"livesrc\">%6s %6s %s</span>" .
- "<span class=\"asm\">%s</span>\n",
- $l,
- HtmlPrintNumber($n1),
- HtmlPrintNumber($n2),
- HtmlEscape($text),
- HtmlEscape($dis));
- }
- } else {
- printf $output(
- "%6s %6s %4d: %s\n",
- UnparseAlt($n1),
- UnparseAlt($n2),
- $l,
- $text);
- }
- if ($l == $lastline) { print $output $skip_marker; }
- };
- }
- close(FILE);
- if ($html) {
- print $output "</pre>\n";
- }
- return 1;
-}
-
-# Return the source line for the specified file/linenumber.
-# Returns undef if not found.
-sub SourceLine {
- my $file = shift;
- my $line = shift;
-
- # Look in cache
- if (!defined($main::source_cache{$file})) {
- if (100 < scalar keys(%main::source_cache)) {
- # Clear the cache when it gets too big
- $main::source_cache = ();
- }
-
- # Read all lines from the file
- if (!open(FILE, "<$file")) {
- print STDERR "$file: $!\n";
- $main::source_cache{$file} = []; # Cache the negative result
- return undef;
- }
- my $lines = [];
- push(@{$lines}, ""); # So we can use 1-based line numbers as indices
- while (<FILE>) {
- push(@{$lines}, $_);
- }
- close(FILE);
-
- # Save the lines in the cache
- $main::source_cache{$file} = $lines;
- }
-
- my $lines = $main::source_cache{$file};
- if (($line < 0) || ($line > $#{$lines})) {
- return undef;
- } else {
- return $lines->[$line];
- }
-}
-
-# Print disassembly for one routine with interspersed source if available
-sub PrintDisassembledFunction {
- my $prog = shift;
- my $offset = shift;
- my $routine = shift;
- my $flat = shift;
- my $cumulative = shift;
- my $start_addr = shift;
- my $end_addr = shift;
- my $total = shift;
-
- # Disassemble all instructions
- my @instructions = Disassemble($prog, $offset, $start_addr, $end_addr);
-
- # Make array of counts per instruction
- my @flat_count = ();
- my @cum_count = ();
- my $flat_total = 0;
- my $cum_total = 0;
- foreach my $e (@instructions) {
- # Add up counts for all address that fall inside this instruction
- my $c1 = 0;
- my $c2 = 0;
- for (my $a = $e->[0]; $a lt $e->[4]; $a = AddressInc($a)) {
- $c1 += GetEntry($flat, $a);
- $c2 += GetEntry($cumulative, $a);
- }
- push(@flat_count, $c1);
- push(@cum_count, $c2);
- $flat_total += $c1;
- $cum_total += $c2;
- }
-
- # Print header with total counts
- printf("ROUTINE ====================== %s\n" .
- "%6s %6s %s (flat, cumulative) %.1f%% of total\n",
- ShortFunctionName($routine),
- Unparse($flat_total),
- Unparse($cum_total),
- Units(),
- ($cum_total * 100.0) / $total);
-
- # Process instructions in order
- my $current_file = "";
- for (my $i = 0; $i <= $#instructions; ) {
- my $e = $instructions[$i];
-
- # Print the new file name whenever we switch files
- if ($e->[1] ne $current_file) {
- $current_file = $e->[1];
- my $fname = $current_file;
- $fname =~ s|^\./||; # Trim leading "./"
-
- # Shorten long file names
- if (length($fname) >= 58) {
- $fname = "..." . substr($fname, -55);
- }
- printf("-------------------- %s\n", $fname);
- }
-
- # TODO: Compute range of lines to print together to deal with
- # small reorderings.
- my $first_line = $e->[2];
- my $last_line = $first_line;
- my %flat_sum = ();
- my %cum_sum = ();
- for (my $l = $first_line; $l <= $last_line; $l++) {
- $flat_sum{$l} = 0;
- $cum_sum{$l} = 0;
- }
-
- # Find run of instructions for this range of source lines
- my $first_inst = $i;
- while (($i <= $#instructions) &&
- ($instructions[$i]->[2] >= $first_line) &&
- ($instructions[$i]->[2] <= $last_line)) {
- $e = $instructions[$i];
- $flat_sum{$e->[2]} += $flat_count[$i];
- $cum_sum{$e->[2]} += $cum_count[$i];
- $i++;
- }
- my $last_inst = $i - 1;
-
- # Print source lines
- for (my $l = $first_line; $l <= $last_line; $l++) {
- my $line = SourceLine($current_file, $l);
- if (!defined($line)) {
- $line = "?\n";
- next;
- } else {
- $line =~ s/^\s+//;
- }
- printf("%6s %6s %5d: %s",
- UnparseAlt($flat_sum{$l}),
- UnparseAlt($cum_sum{$l}),
- $l,
- $line);
- }
-
- # Print disassembly
- for (my $x = $first_inst; $x <= $last_inst; $x++) {
- my $e = $instructions[$x];
- my $address = $e->[0];
- $address = AddressSub($address, $offset); # Make relative to section
- $address =~ s/^0x//;
- $address =~ s/^0*//;
-
- printf("%6s %6s %8s: %6s\n",
- UnparseAlt($flat_count[$x]),
- UnparseAlt($cum_count[$x]),
- $address,
- CleanDisassembly($e->[3]));
- }
- }
-}
-
-# Print DOT graph
-sub PrintDot {
- my $prog = shift;
- my $symbols = shift;
- my $raw = shift;
- my $flat = shift;
- my $cumulative = shift;
- my $overall_total = shift;
-
- # Get total
- my $local_total = TotalProfile($flat);
- my $nodelimit = int($main::opt_nodefraction * $local_total);
- my $edgelimit = int($main::opt_edgefraction * $local_total);
- my $nodecount = $main::opt_nodecount;
-
- # Find nodes to include
- my @list = (sort { abs(GetEntry($cumulative, $b)) <=>
- abs(GetEntry($cumulative, $a))
- || $a cmp $b }
- keys(%{$cumulative}));
- my $last = $nodecount - 1;
- if ($last > $#list) {
- $last = $#list;
- }
- while (($last >= 0) &&
- (abs(GetEntry($cumulative, $list[$last])) <= $nodelimit)) {
- $last--;
- }
- if ($last < 0) {
- print STDERR "No nodes to print\n";
- cleanup();
- return 0;
- }
-
- if ($nodelimit > 0 || $edgelimit > 0) {
- printf STDERR ("Dropping nodes with <= %s %s; edges with <= %s abs(%s)\n",
- Unparse($nodelimit), Units(),
- Unparse($edgelimit), Units());
- }
-
- # Open DOT output file
- my $output;
- if ($main::opt_gv) {
- $output = "| $DOT -Tps2 >" . TempName($main::next_tmpfile, "ps");
- } elsif ($main::opt_ps) {
- $output = "| $DOT -Tps2";
- } elsif ($main::opt_pdf) {
- $output = "| $DOT -Tps2 | $PS2PDF - -";
- } elsif ($main::opt_web || $main::opt_svg) {
- # We need to post-process the SVG, so write to a temporary file always.
- $output = "| $DOT -Tsvg >" . TempName($main::next_tmpfile, "svg");
- } elsif ($main::opt_gif) {
- $output = "| $DOT -Tgif";
- } else {
- $output = ">&STDOUT";
- }
- open(DOT, $output) || error("$output: $!\n");
-
- # Title
- printf DOT ("digraph \"%s; %s %s\" {\n",
- $prog,
- Unparse($overall_total),
- Units());
- if ($main::opt_pdf) {
- # The output is more printable if we set the page size for dot.
- printf DOT ("size=\"8,11\"\n");
- }
- printf DOT ("node [width=0.375,height=0.25];\n");
-
- # Print legend
- printf DOT ("Legend [shape=box,fontsize=24,shape=plaintext," .
- "label=\"%s\\l%s\\l%s\\l%s\\l%s\\l\"];\n",
- $prog,
- sprintf("Total %s: %s", Units(), Unparse($overall_total)),
- sprintf("Focusing on: %s", Unparse($local_total)),
- sprintf("Dropped nodes with <= %s abs(%s)",
- Unparse($nodelimit), Units()),
- sprintf("Dropped edges with <= %s %s",
- Unparse($edgelimit), Units())
- );
-
- # Print nodes
- my %node = ();
- my $nextnode = 1;
- foreach my $a (@list[0..$last]) {
- # Pick font size
- my $f = GetEntry($flat, $a);
- my $c = GetEntry($cumulative, $a);
-
- my $fs = 8;
- if ($local_total > 0) {
- $fs = 8 + (50.0 * sqrt(abs($f * 1.0 / $local_total)));
- }
-
- $node{$a} = $nextnode++;
- my $sym = $a;
- $sym =~ s/\s+/\\n/g;
- $sym =~ s/::/\\n/g;
-
- # Extra cumulative info to print for non-leaves
- my $extra = "";
- if ($f != $c) {
- $extra = sprintf("\\rof %s (%s)",
- Unparse($c),
- Percent($c, $overall_total));
- }
- my $style = "";
- if ($main::opt_heapcheck) {
- if ($f > 0) {
- # make leak-causing nodes more visible (add a background)
- $style = ",style=filled,fillcolor=gray"
- } elsif ($f < 0) {
- # make anti-leak-causing nodes (which almost never occur)
- # stand out as well (triple border)
- $style = ",peripheries=3"
- }
- }
-
- printf DOT ("N%d [label=\"%s\\n%s (%s)%s\\r" .
- "\",shape=box,fontsize=%.1f%s];\n",
- $node{$a},
- $sym,
- Unparse($f),
- Percent($f, $overall_total),
- $extra,
- $fs,
- $style,
- );
- }
-
- # Get edges and counts per edge
- my %edge = ();
- my $n;
- foreach my $k (keys(%{$raw})) {
- # TODO: omit low %age edges
- $n = $raw->{$k};
- my @translated = TranslateStack($symbols, $k);
- for (my $i = 1; $i <= $#translated; $i++) {
- my $src = $translated[$i];
- my $dst = $translated[$i-1];
- #next if ($src eq $dst); # Avoid self-edges?
- if (exists($node{$src}) && exists($node{$dst})) {
- my $edge_label = "$src\001$dst";
- if (!exists($edge{$edge_label})) {
- $edge{$edge_label} = 0;
- }
- $edge{$edge_label} += $n;
- }
- }
- }
-
- # Print edges
- foreach my $e (keys(%edge)) {
- my @x = split(/\001/, $e);
- $n = $edge{$e};
-
- if (abs($n) > $edgelimit) {
- # Compute line width based on edge count
- my $fraction = abs($local_total ? (3 * ($n / $local_total)) : 0);
- if ($fraction > 1) { $fraction = 1; }
- my $w = $fraction * 2;
- if ($w < 1 && ($main::opt_web || $main::opt_svg)) {
- # SVG output treats line widths < 1 poorly.
- $w = 1;
- }
-
- # Dot sometimes segfaults if given edge weights that are too large, so
- # we cap the weights at a large value
- my $edgeweight = abs($n) ** 0.7;
- if ($edgeweight > 100000) { $edgeweight = 100000; }
- $edgeweight = int($edgeweight);
-
- my $style = sprintf("setlinewidth(%f)", $w);
- if ($x[1] =~ m/\(inline\)/) {
- $style .= ",dashed";
- }
-
- # Use a slightly squashed function of the edge count as the weight
- printf DOT ("N%s -> N%s [label=%s, weight=%d, style=\"%s\"];\n",
- $node{$x[0]},
- $node{$x[1]},
- Unparse($n),
- $edgeweight,
- $style);
- }
- }
-
- print DOT ("}\n");
- close(DOT);
-
- if ($main::opt_web || $main::opt_svg) {
- # Rewrite SVG to be more usable inside web browser.
- RewriteSvg(TempName($main::next_tmpfile, "svg"));
- }
-
- return 1;
-}
-
-sub RewriteSvg {
- my $svgfile = shift;
-
- open(SVG, $svgfile) || die "open temp svg: $!";
- my @svg = <SVG>;
- close(SVG);
- unlink $svgfile;
- my $svg = join('', @svg);
-
- # Dot's SVG output is
- #
- # <svg width="___" height="___"
- # viewBox="___" xmlns=...>
- # <g id="graph0" transform="...">
- # ...
- # </g>
- # </svg>
- #
- # Change it to
- #
- # <svg width="100%" height="100%"
- # xmlns=...>
- # $svg_javascript
- # <g id="viewport" transform="translate(0,0)">
- # <g id="graph0" transform="...">
- # ...
- # </g>
- # </g>
- # </svg>
-
- # Fix width, height; drop viewBox.
- $svg =~ s/(?s)<svg width="[^"]+" height="[^"]+"(.*?)viewBox="[^"]+"/<svg width="100%" height="100%"$1/;
-
- # Insert script, viewport <g> above first <g>
- my $svg_javascript = SvgJavascript();
- my $viewport = "<g id=\"viewport\" transform=\"translate(0,0)\">\n";
- $svg =~ s/<g id="graph\d"/$svg_javascript$viewport$&/;
-
- # Insert final </g> above </svg>.
- $svg =~ s/(.*)(<\/svg>)/$1<\/g>$2/;
- $svg =~ s/<g id="graph\d"(.*?)/<g id="viewport"$1/;
-
- if ($main::opt_svg) {
- # --svg: write to standard output.
- print $svg;
- } else {
- # Write back to temporary file.
- open(SVG, ">$svgfile") || die "open $svgfile: $!";
- print SVG $svg;
- close(SVG);
- }
-}
-
-sub SvgJavascript {
- return <<'EOF';
-<script type="text/ecmascript"><![CDATA[
-// SVGPan
-// http://www.cyberz.org/blog/2009/12/08/svgpan-a-javascript-svg-panzoomdrag-library/
-// Local modification: if(true || ...) below to force panning, never moving.
-// Local modification: add clamping to fix bug in handleMouseWheel.
-
-/**
- * SVGPan library 1.2
- * ====================
- *
- * Given an unique existing element with id "viewport", including the
- * the library into any SVG adds the following capabilities:
- *
- * - Mouse panning
- * - Mouse zooming (using the wheel)
- * - Object dargging
- *
- * Known issues:
- *
- * - Zooming (while panning) on Safari has still some issues
- *
- * Releases:
- *
- * 1.2, Sat Mar 20 08:42:50 GMT 2010, Zeng Xiaohui
- * Fixed a bug with browser mouse handler interaction
- *
- * 1.1, Wed Feb 3 17:39:33 GMT 2010, Zeng Xiaohui
- * Updated the zoom code to support the mouse wheel on Safari/Chrome
- *
- * 1.0, Andrea Leofreddi
- * First release
- *
- * This code is licensed under the following BSD license:
- *
- * Copyright 2009-2010 Andrea Leofreddi <a.leofreddi@itcharm.com>. All rights reserved.
- *
- * Redistribution and use in source and binary forms, with or without modification, are
- * permitted provided that the following conditions are met:
- *
- * 1. Redistributions of source code must retain the above copyright notice, this list of
- * conditions and the following disclaimer.
- *
- * 2. Redistributions in binary form must reproduce the above copyright notice, this list
- * of conditions and the following disclaimer in the documentation and/or other materials
- * provided with the distribution.
- *
- * THIS SOFTWARE IS PROVIDED BY Andrea Leofreddi ``AS IS'' AND ANY EXPRESS OR IMPLIED
- * WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
- * FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL Andrea Leofreddi OR
- * CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
- * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
- * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
- * ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
- * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
- * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
- *
- * The views and conclusions contained in the software and documentation are those of the
- * authors and should not be interpreted as representing official policies, either expressed
- * or implied, of Andrea Leofreddi.
- */
-
-var root = document.documentElement;
-
-var state = 'none', stateTarget, stateOrigin, stateTf;
-
-setupHandlers(root);
-
-/**
- * Register handlers
- */
-function setupHandlers(root){
- setAttributes(root, {
- "onmouseup" : "add(evt)",
- "onmousedown" : "handleMouseDown(evt)",
- "onmousemove" : "handleMouseMove(evt)",
- "onmouseup" : "handleMouseUp(evt)",
- //"onmouseout" : "handleMouseUp(evt)", // Decomment this to stop the pan functionality when dragging out of the SVG element
- });
-
- if(navigator.userAgent.toLowerCase().indexOf('webkit') >= 0)
- window.addEventListener('mousewheel', handleMouseWheel, false); // Chrome/Safari
- else
- window.addEventListener('DOMMouseScroll', handleMouseWheel, false); // Others
-
- var g = svgDoc.getElementById("svg");
- g.width = "100%";
- g.height = "100%";
-}
-
-/**
- * Instance an SVGPoint object with given event coordinates.
- */
-function getEventPoint(evt) {
- var p = root.createSVGPoint();
-
- p.x = evt.clientX;
- p.y = evt.clientY;
-
- return p;
-}
-
-/**
- * Sets the current transform matrix of an element.
- */
-function setCTM(element, matrix) {
- var s = "matrix(" + matrix.a + "," + matrix.b + "," + matrix.c + "," + matrix.d + "," + matrix.e + "," + matrix.f + ")";
-
- element.setAttribute("transform", s);
-}
-
-/**
- * Dumps a matrix to a string (useful for debug).
- */
-function dumpMatrix(matrix) {
- var s = "[ " + matrix.a + ", " + matrix.c + ", " + matrix.e + "\n " + matrix.b + ", " + matrix.d + ", " + matrix.f + "\n 0, 0, 1 ]";
-
- return s;
-}
-
-/**
- * Sets attributes of an element.
- */
-function setAttributes(element, attributes){
- for (i in attributes)
- element.setAttributeNS(null, i, attributes[i]);
-}
-
-/**
- * Handle mouse move event.
- */
-function handleMouseWheel(evt) {
- if(evt.preventDefault)
- evt.preventDefault();
-
- evt.returnValue = false;
-
- var svgDoc = evt.target.ownerDocument;
-
- var delta;
-
- if(evt.wheelDelta)
- delta = evt.wheelDelta / 3600; // Chrome/Safari
- else
- delta = evt.detail / -90; // Mozilla
-
- var z = 1 + delta; // Zoom factor: 0.9/1.1
-
- // Clamp to reasonable values.
- // The 0.1 check is important because
- // a very large scroll can turn into a
- // negative z, which rotates the image 180 degrees.
- if(z < 0.1)
- z = 0.1;
- if(z > 10.0)
- z = 10.0;
-
- var g = svgDoc.getElementById("viewport");
-
- var p = getEventPoint(evt);
-
- p = p.matrixTransform(g.getCTM().inverse());
-
- // Compute new scale matrix in current mouse position
- var k = root.createSVGMatrix().translate(p.x, p.y).scale(z).translate(-p.x, -p.y);
-
- setCTM(g, g.getCTM().multiply(k));
-
- stateTf = stateTf.multiply(k.inverse());
-}
-
-/**
- * Handle mouse move event.
- */
-function handleMouseMove(evt) {
- if(evt.preventDefault)
- evt.preventDefault();
-
- evt.returnValue = false;
-
- var svgDoc = evt.target.ownerDocument;
-
- var g = svgDoc.getElementById("viewport");
-
- if(state == 'pan') {
- // Pan mode
- var p = getEventPoint(evt).matrixTransform(stateTf);
-
- setCTM(g, stateTf.inverse().translate(p.x - stateOrigin.x, p.y - stateOrigin.y));
- } else if(state == 'move') {
- // Move mode
- var p = getEventPoint(evt).matrixTransform(g.getCTM().inverse());
-
- setCTM(stateTarget, root.createSVGMatrix().translate(p.x - stateOrigin.x, p.y - stateOrigin.y).multiply(g.getCTM().inverse()).multiply(stateTarget.getCTM()));
-
- stateOrigin = p;
- }
-}
-
-/**
- * Handle click event.
- */
-function handleMouseDown(evt) {
- if(evt.preventDefault)
- evt.preventDefault();
-
- evt.returnValue = false;
-
- var svgDoc = evt.target.ownerDocument;
-
- var g = svgDoc.getElementById("viewport");
-
- if(true || evt.target.tagName == "svg") {
- // Pan mode
- state = 'pan';
-
- stateTf = g.getCTM().inverse();
-
- stateOrigin = getEventPoint(evt).matrixTransform(stateTf);
- } else {
- // Move mode
- state = 'move';
-
- stateTarget = evt.target;
-
- stateTf = g.getCTM().inverse();
-
- stateOrigin = getEventPoint(evt).matrixTransform(stateTf);
- }
-}
-
-/**
- * Handle mouse button release event.
- */
-function handleMouseUp(evt) {
- if(evt.preventDefault)
- evt.preventDefault();
-
- evt.returnValue = false;
-
- var svgDoc = evt.target.ownerDocument;
-
- if(state == 'pan' || state == 'move') {
- // Quit pan mode
- state = '';
- }
-}
-
-]]></script>
-EOF
-}
-
-# Translate a stack of addresses into a stack of symbols
-sub TranslateStack {
- my $symbols = shift;
- my $k = shift;
-
- my @addrs = split(/\n/, $k);
- my @result = ();
- for (my $i = 0; $i <= $#addrs; $i++) {
- my $a = $addrs[$i];
-
- # Skip large addresses since they sometimes show up as fake entries on RH9
- if (length($a) > 8 && $a gt "7fffffffffffffff") {
- next;
- }
-
- if ($main::opt_disasm || $main::opt_list) {
- # We want just the address for the key
- push(@result, $a);
- next;
- }
-
- my $symlist = $symbols->{$a};
- if (!defined($symlist)) {
- $symlist = [$a, "", $a];
- }
-
- # We can have a sequence of symbols for a particular entry
- # (more than one symbol in the case of inlining). Callers
- # come before callees in symlist, so walk backwards since
- # the translated stack should contain callees before callers.
- for (my $j = $#{$symlist}; $j >= 2; $j -= 3) {
- my $func = $symlist->[$j-2];
- my $fileline = $symlist->[$j-1];
- my $fullfunc = $symlist->[$j];
- if ($j > 2) {
- $func = "$func (inline)";
- }
- if ($main::opt_addresses) {
- push(@result, "$a $func $fileline");
- } elsif ($main::opt_lines) {
- if ($func eq '??' && $fileline eq '??:0') {
- push(@result, "$a");
- } else {
- push(@result, "$func $fileline");
- }
- } elsif ($main::opt_functions) {
- if ($func eq '??') {
- push(@result, "$a");
- } else {
- push(@result, $func);
- }
- } elsif ($main::opt_files) {
- if ($fileline eq '??:0' || $fileline eq '') {
- push(@result, "$a");
- } else {
- my $f = $fileline;
- $f =~ s/:\d+$//;
- push(@result, $f);
- }
- } else {
- push(@result, $a);
- last; # Do not print inlined info
- }
- }
- }
-
- # print join(",", @addrs), " => ", join(",", @result), "\n";
- return @result;
-}
-
-# Generate percent string for a number and a total
-sub Percent {
- my $num = shift;
- my $tot = shift;
- if ($tot != 0) {
- return sprintf("%.1f%%", $num * 100.0 / $tot);
- } else {
- return ($num == 0) ? "nan" : (($num > 0) ? "+inf" : "-inf");
- }
-}
-
-# Generate pretty-printed form of number
-sub Unparse {
- my $num = shift;
- if ($main::profile_type eq 'heap' || $main::profile_type eq 'growth') {
- if ($main::opt_inuse_objects || $main::opt_alloc_objects) {
- return sprintf("%d", $num);
- } else {
- if ($main::opt_show_bytes) {
- return sprintf("%d", $num);
- } else {
- return sprintf("%.1f", $num / 1048576.0);
- }
- }
- } elsif ($main::profile_type eq 'contention' && !$main::opt_contentions) {
- return sprintf("%.3f", $num / 1e9); # Convert nanoseconds to seconds
- } else {
- return sprintf("%d", $num);
- }
-}
-
-# Alternate pretty-printed form: 0 maps to "."
-sub UnparseAlt {
- my $num = shift;
- if ($num == 0) {
- return ".";
- } else {
- return Unparse($num);
- }
-}
-
-# Alternate pretty-printed form: 0 maps to ""
-sub HtmlPrintNumber {
- my $num = shift;
- if ($num == 0) {
- return "";
- } else {
- return Unparse($num);
- }
-}
-
-# Return output units
-sub Units {
- if ($main::profile_type eq 'heap' || $main::profile_type eq 'growth') {
- if ($main::opt_inuse_objects || $main::opt_alloc_objects) {
- return "objects";
- } else {
- if ($main::opt_show_bytes) {
- return "B";
- } else {
- return "MB";
- }
- }
- } elsif ($main::profile_type eq 'contention' && !$main::opt_contentions) {
- return "seconds";
- } else {
- return "samples";
- }
-}
-
-##### Profile manipulation code #####
-
-# Generate flattened profile:
-# If count is charged to stack [a,b,c,d], in generated profile,
-# it will be charged to [a]
-sub FlatProfile {
- my $profile = shift;
- my $result = {};
- foreach my $k (keys(%{$profile})) {
- my $count = $profile->{$k};
- my @addrs = split(/\n/, $k);
- if ($#addrs >= 0) {
- AddEntry($result, $addrs[0], $count);
- }
- }
- return $result;
-}
-
-# Generate cumulative profile:
-# If count is charged to stack [a,b,c,d], in generated profile,
-# it will be charged to [a], [b], [c], [d]
-sub CumulativeProfile {
- my $profile = shift;
- my $result = {};
- foreach my $k (keys(%{$profile})) {
- my $count = $profile->{$k};
- my @addrs = split(/\n/, $k);
- foreach my $a (@addrs) {
- AddEntry($result, $a, $count);
- }
- }
- return $result;
-}
-
-# If the second-youngest PC on the stack is always the same, returns
-# that pc. Otherwise, returns undef.
-sub IsSecondPcAlwaysTheSame {
- my $profile = shift;
-
- my $second_pc = undef;
- foreach my $k (keys(%{$profile})) {
- my @addrs = split(/\n/, $k);
- if ($#addrs < 1) {
- return undef;
- }
- if (not defined $second_pc) {
- $second_pc = $addrs[1];
- } else {
- if ($second_pc ne $addrs[1]) {
- return undef;
- }
- }
- }
- return $second_pc;
-}
-
-sub ExtractSymbolLocation {
- my $symbols = shift;
- my $address = shift;
- # 'addr2line' outputs "??:0" for unknown locations; we do the
- # same to be consistent.
- my $location = "??:0:unknown";
- if (exists $symbols->{$address}) {
- my $file = $symbols->{$address}->[1];
- if ($file eq "?") {
- $file = "??:0"
- }
- $location = $file . ":" . $symbols->{$address}->[0];
- }
- return $location;
-}
-
-# Extracts a graph of calls.
-sub ExtractCalls {
- my $symbols = shift;
- my $profile = shift;
-
- my $calls = {};
- while( my ($stack_trace, $count) = each %$profile ) {
- my @address = split(/\n/, $stack_trace);
- my $destination = ExtractSymbolLocation($symbols, $address[0]);
- AddEntry($calls, $destination, $count);
- for (my $i = 1; $i <= $#address; $i++) {
- my $source = ExtractSymbolLocation($symbols, $address[$i]);
- my $call = "$source -> $destination";
- AddEntry($calls, $call, $count);
- $destination = $source;
- }
- }
-
- return $calls;
-}
-
-sub RemoveUninterestingFrames {
- my $symbols = shift;
- my $profile = shift;
-
- # List of function names to skip
- my %skip = ();
- my $skip_regexp = 'NOMATCH';
- if ($main::profile_type eq 'heap' || $main::profile_type eq 'growth') {
- foreach my $name ('calloc',
- 'cfree',
- 'malloc',
- 'free',
- 'memalign',
- 'posix_memalign',
- 'pvalloc',
- 'valloc',
- 'realloc',
- 'tc_calloc',
- 'tc_cfree',
- 'tc_malloc',
- 'tc_free',
- 'tc_memalign',
- 'tc_posix_memalign',
- 'tc_pvalloc',
- 'tc_valloc',
- 'tc_realloc',
- 'tc_new',
- 'tc_delete',
- 'tc_newarray',
- 'tc_deletearray',
- 'tc_new_nothrow',
- 'tc_newarray_nothrow',
- 'do_malloc',
- '::do_malloc', # new name -- got moved to an unnamed ns
- '::do_malloc_or_cpp_alloc',
- 'DoSampledAllocation',
- 'simple_alloc::allocate',
- '__malloc_alloc_template::allocate',
- '__builtin_delete',
- '__builtin_new',
- '__builtin_vec_delete',
- '__builtin_vec_new',
- 'operator new',
- 'operator new[]',
- # Go
- 'catstring',
- 'copyin',
- 'gostring',
- 'gostringsize',
- 'growslice1',
- 'appendslice1',
- 'hash_init',
- 'hash_subtable_new',
- 'hash_conv',
- 'hash_grow',
- 'hash_insert_internal',
- 'hash_insert',
- 'mapassign',
- 'runtime.mapassign',
- 'runtime.appendslice',
- 'runtime.mapassign1',
- 'makechan',
- 'makemap',
- 'mal',
- 'runtime.new',
- 'makeslice1',
- 'runtime.gostringsize',
- 'runtime.malloc',
- 'unsafe.New',
- 'runtime.mallocgc',
- 'runtime.catstring',
- 'runtime.growslice',
- 'runtime.ifaceT2E',
- 'runtime.ifaceT2I',
- 'runtime.makechan',
- 'runtime.makechan_c',
- 'runtime.makemap',
- 'runtime.makemap_c',
- 'runtime.makeslice',
- 'runtime.mal',
- 'runtime.slicebytetostring',
- 'runtime.sliceinttostring',
- 'runtime.stringtoslicebyte',
- 'runtime.stringtosliceint',
- # These mark the beginning/end of our custom sections
- '__start_google_malloc',
- '__stop_google_malloc',
- '__start_malloc_hook',
- '__stop_malloc_hook') {
- $skip{$name} = 1;
- $skip{"_" . $name} = 1; # Mach (OS X) adds a _ prefix to everything
- }
- # TODO: Remove TCMalloc once everything has been
- # moved into the tcmalloc:: namespace and we have flushed
- # old code out of the system.
- $skip_regexp = "TCMalloc|^tcmalloc::";
- } elsif ($main::profile_type eq 'contention') {
- foreach my $vname ('Mutex::Unlock', 'Mutex::UnlockSlow') {
- $skip{$vname} = 1;
- }
- } elsif ($main::profile_type eq 'cpu') {
- # Drop signal handlers used for CPU profile collection
- # TODO(dpeng): this should not be necessary; it's taken
- # care of by the general 2nd-pc mechanism below.
- foreach my $name ('ProfileData::Add', # historical
- 'ProfileData::prof_handler', # historical
- 'CpuProfiler::prof_handler',
- '__FRAME_END__',
- '__pthread_sighandler',
- '__restore') {
- $skip{$name} = 1;
- }
- } else {
- # Nothing skipped for unknown types
- }
-
- # Go doesn't have the problem that this heuristic tries to fix. Disable.
- if (0 && $main::profile_type eq 'cpu') {
- # If all the second-youngest program counters are the same,
- # this STRONGLY suggests that it is an artifact of measurement,
- # i.e., stack frames pushed by the CPU profiler signal handler.
- # Hence, we delete them.
- # (The topmost PC is read from the signal structure, not from
- # the stack, so it does not get involved.)
- while (my $second_pc = IsSecondPcAlwaysTheSame($profile)) {
- my $result = {};
- my $func = '';
- if (exists($symbols->{$second_pc})) {
- $second_pc = $symbols->{$second_pc}->[0];
- }
- print STDERR "Removing $second_pc from all stack traces.\n";
- foreach my $k (keys(%{$profile})) {
- my $count = $profile->{$k};
- my @addrs = split(/\n/, $k);
- splice @addrs, 1, 1;
- my $reduced_path = join("\n", @addrs);
- AddEntry($result, $reduced_path, $count);
- }
- $profile = $result;
- }
- }
-
- my $result = {};
- foreach my $k (keys(%{$profile})) {
- my $count = $profile->{$k};
- my @addrs = split(/\n/, $k);
- my @path = ();
- foreach my $a (@addrs) {
- if (exists($symbols->{$a})) {
- my $func = $symbols->{$a}->[0];
- if ($skip{$func} || ($func =~ m/$skip_regexp/)) {
- next;
- }
- }
- push(@path, $a);
- }
- my $reduced_path = join("\n", @path);
- AddEntry($result, $reduced_path, $count);
- }
- return $result;
-}
-
-# Reduce profile to granularity given by user
-sub ReduceProfile {
- my $symbols = shift;
- my $profile = shift;
- my $result = {};
- foreach my $k (keys(%{$profile})) {
- my $count = $profile->{$k};
- my @translated = TranslateStack($symbols, $k);
- my @path = ();
- my %seen = ();
- $seen{''} = 1; # So that empty keys are skipped
- foreach my $e (@translated) {
- # To avoid double-counting due to recursion, skip a stack-trace
- # entry if it has already been seen
- if (!$seen{$e}) {
- $seen{$e} = 1;
- push(@path, $e);
- }
- }
- my $reduced_path = join("\n", @path);
- AddEntry($result, $reduced_path, $count);
- }
- return $result;
-}
-
-# Does the specified symbol array match the regexp?
-sub SymbolMatches {
- my $sym = shift;
- my $re = shift;
- if (defined($sym)) {
- for (my $i = 0; $i < $#{$sym}; $i += 3) {
- if ($sym->[$i] =~ m/$re/ || $sym->[$i+1] =~ m/$re/) {
- return 1;
- }
- }
- }
- return 0;
-}
-
-# Focus only on paths involving specified regexps
-sub FocusProfile {
- my $symbols = shift;
- my $profile = shift;
- my $focus = shift;
- my $result = {};
- foreach my $k (keys(%{$profile})) {
- my $count = $profile->{$k};
- my @addrs = split(/\n/, $k);
- foreach my $a (@addrs) {
- # Reply if it matches either the address/shortname/fileline
- if (($a =~ m/$focus/) || SymbolMatches($symbols->{$a}, $focus)) {
- AddEntry($result, $k, $count);
- last;
- }
- }
- }
- return $result;
-}
-
-# Focus only on paths not involving specified regexps
-sub IgnoreProfile {
- my $symbols = shift;
- my $profile = shift;
- my $ignore = shift;
- my $result = {};
- foreach my $k (keys(%{$profile})) {
- my $count = $profile->{$k};
- my @addrs = split(/\n/, $k);
- my $matched = 0;
- foreach my $a (@addrs) {
- # Reply if it matches either the address/shortname/fileline
- if (($a =~ m/$ignore/) || SymbolMatches($symbols->{$a}, $ignore)) {
- $matched = 1;
- last;
- }
- }
- if (!$matched) {
- AddEntry($result, $k, $count);
- }
- }
- return $result;
-}
-
-# Get total count in profile
-sub TotalProfile {
- my $profile = shift;
- my $result = 0;
- foreach my $k (keys(%{$profile})) {
- $result += $profile->{$k};
- }
- return $result;
-}
-
-# Add A to B
-sub AddProfile {
- my $A = shift;
- my $B = shift;
-
- my $R = {};
- # add all keys in A
- foreach my $k (keys(%{$A})) {
- my $v = $A->{$k};
- AddEntry($R, $k, $v);
- }
- # add all keys in B
- foreach my $k (keys(%{$B})) {
- my $v = $B->{$k};
- AddEntry($R, $k, $v);
- }
- return $R;
-}
-
-# Merges symbol maps
-sub MergeSymbols {
- my $A = shift;
- my $B = shift;
-
- my $R = {};
- foreach my $k (keys(%{$A})) {
- $R->{$k} = $A->{$k};
- }
- if (defined($B)) {
- foreach my $k (keys(%{$B})) {
- $R->{$k} = $B->{$k};
- }
- }
- return $R;
-}
-
-
-# Add A to B
-sub AddPcs {
- my $A = shift;
- my $B = shift;
-
- my $R = {};
- # add all keys in A
- foreach my $k (keys(%{$A})) {
- $R->{$k} = 1
- }
- # add all keys in B
- foreach my $k (keys(%{$B})) {
- $R->{$k} = 1
- }
- return $R;
-}
-
-# Subtract B from A
-sub SubtractProfile {
- my $A = shift;
- my $B = shift;
-
- my $R = {};
- foreach my $k (keys(%{$A})) {
- my $v = $A->{$k} - GetEntry($B, $k);
- if ($v < 0 && $main::opt_drop_negative) {
- $v = 0;
- }
- AddEntry($R, $k, $v);
- }
- if (!$main::opt_drop_negative) {
- # Take care of when subtracted profile has more entries
- foreach my $k (keys(%{$B})) {
- if (!exists($A->{$k})) {
- AddEntry($R, $k, 0 - $B->{$k});
- }
- }
- }
- return $R;
-}
-
-# Get entry from profile; zero if not present
-sub GetEntry {
- my $profile = shift;
- my $k = shift;
- if (exists($profile->{$k})) {
- return $profile->{$k};
- } else {
- return 0;
- }
-}
-
-# Add entry to specified profile
-sub AddEntry {
- my $profile = shift;
- my $k = shift;
- my $n = shift;
- if (!exists($profile->{$k})) {
- $profile->{$k} = 0;
- }
- $profile->{$k} += $n;
-}
-
-# Add a stack of entries to specified profile, and add them to the $pcs
-# list.
-sub AddEntries {
- my $profile = shift;
- my $pcs = shift;
- my $stack = shift;
- my $count = shift;
- my @k = ();
-
- foreach my $e (split(/\s+/, $stack)) {
- my $pc = HexExtend($e);
- $pcs->{$pc} = 1;
- push @k, $pc;
- }
- AddEntry($profile, (join "\n", @k), $count);
-}
-
-sub IsSymbolizedProfileFile {
- my $file_name = shift;
-
- if (!(-e $file_name) || !(-r $file_name)) {
- return 0;
- }
-
- $SYMBOL_PAGE =~ m,[^/]+$,; # matches everything after the last slash
- my $symbol_marker = $&;
- # Check if the file contains a symbol-section marker.
- open(TFILE, "<$file_name");
- my @lines = <TFILE>;
- my $result = grep(/^--- *$symbol_marker/, @lines);
- close(TFILE);
- return $result > 0;
-}
-
-##### Code to profile a server dynamically #####
-
-sub CheckSymbolPage {
- my $url = SymbolPageURL();
-print STDERR "Read $url\n";
- open(SYMBOL, "$CURL -s '$url' |");
- my $line = <SYMBOL>;
- $line =~ s/\r//g; # turn windows-looking lines into unix-looking lines
- close(SYMBOL);
- unless (defined($line)) {
- error("$url doesn't exist\n");
- }
-
- if ($line =~ /^num_symbols:\s+(\d+)$/) {
- if ($1 == 0) {
- error("Stripped binary. No symbols available.\n");
- }
- } else {
- error("Failed to get the number of symbols from $url\n");
- }
-}
-
-sub IsProfileURL {
- my $profile_name = shift;
- my ($host, $port, $prefix, $path) = ParseProfileURL($profile_name);
- return defined($host) and defined($port) and defined($path);
-}
-
-sub ParseProfileURL {
- my $profile_name = shift;
- if (defined($profile_name) &&
- $profile_name =~ m,^(http://|)([^/:]+):(\d+)(|\@\d+)(|/|(.*?)($PROFILE_PAGE|$PMUPROFILE_PAGE|$HEAP_PAGE|$GROWTH_PAGE|$CONTENTION_PAGE|$WALL_PAGE|$FILTEREDPROFILE_PAGE))$,o) {
- # $7 is $PROFILE_PAGE/$HEAP_PAGE/etc. $5 is *everything* after
- # the hostname, as long as that everything is the empty string,
- # a slash, or something ending in $PROFILE_PAGE/$HEAP_PAGE/etc.
- # So "$7 || $5" is $PROFILE_PAGE/etc if there, or else it's "/" or "".
- return ($2, $3, $6, $7 || $5);
- }
- return ();
-}
-
-# We fetch symbols from the first profile argument.
-sub SymbolPageURL {
- my ($host, $port, $prefix, $path) = ParseProfileURL($main::pfile_args[0]);
- return "http://$host:$port$prefix$SYMBOL_PAGE";
-}
-
-sub FetchProgramName() {
- my ($host, $port, $prefix, $path) = ParseProfileURL($main::pfile_args[0]);
- my $url = "http://$host:$port$prefix$PROGRAM_NAME_PAGE";
- my $command_line = "$CURL -s '$url'";
- open(CMDLINE, "$command_line |") or error($command_line);
- my $cmdline = <CMDLINE>;
- $cmdline =~ s/\r//g; # turn windows-looking lines into unix-looking lines
- close(CMDLINE);
- error("Failed to get program name from $url\n") unless defined($cmdline);
- $cmdline =~ s/\x00.+//; # Remove argv[1] and latters.
- $cmdline =~ s!\n!!g; # Remove LFs.
- return $cmdline;
-}
-
-# Gee, curl's -L (--location) option isn't reliable at least
-# with its 7.12.3 version. Curl will forget to post data if
-# there is a redirection. This function is a workaround for
-# curl. Redirection happens on borg hosts.
-sub ResolveRedirectionForCurl {
- my $url = shift;
- my $command_line = "$CURL -s --head '$url'";
- open(CMDLINE, "$command_line |") or error($command_line);
- while (<CMDLINE>) {
- s/\r//g; # turn windows-looking lines into unix-looking lines
- if (/^Location: (.*)/) {
- $url = $1;
- }
- }
- close(CMDLINE);
- return $url;
-}
-
-# Reads a symbol map from the file handle name given as $1, returning
-# the resulting symbol map. Also processes variables relating to symbols.
-# Currently, the only variable processed is 'binary=<value>' which updates
-# $main::prog to have the correct program name.
-sub ReadSymbols {
- my $in = shift;
- my $map = shift;
- while (<$in>) {
- s/\r//g; # turn windows-looking lines into unix-looking lines
- # Removes all the leading zeroes from the symbols, see comment below.
- if (m/^0x0*([0-9a-f]+)\s+(.+)/) {
- $map->{$1} = $2;
- } elsif (m/^---/) {
- last;
- } elsif (m/^([a-z][^=]*)=(.*)$/ ) {
- my ($variable, $value) = ($1, $2);
- for ($variable, $value) {
- s/^\s+//;
- s/\s+$//;
- }
- if ($variable eq "binary") {
- if ($main::prog ne $UNKNOWN_BINARY && $main::prog ne $value) {
- printf STDERR ("Warning: Mismatched binary name '%s', using '%s'.\n",
- $main::prog, $value);
- }
- $main::prog = $value;
- } else {
- printf STDERR ("Ignoring unknown variable in symbols list: " .
- "'%s' = '%s'\n", $variable, $value);
- }
- }
- }
- return $map;
-}
-
-# Fetches and processes symbols to prepare them for use in the profile output
-# code. If the optional 'symbol_map' arg is not given, fetches symbols from
-# $SYMBOL_PAGE for all PC values found in profile. Otherwise, the raw symbols
-# are assumed to have already been fetched into 'symbol_map' and are simply
-# extracted and processed.
-sub FetchSymbols {
- my $pcset = shift;
- my $symbol_map = shift;
-
- my %seen = ();
- my @pcs = grep { !$seen{$_}++ } keys(%$pcset); # uniq
-
- if (!defined($symbol_map)) {
- $symbol_map = {};
- my @toask = @pcs;
- while (@toask > 0) {
- my $n = @toask;
- # NOTE(rsc): Limiting the number of PCs requested per round
- # used to be necessary, but I think it was a bug in
- # debug/pprof/symbol's implementation. Leaving here
- # in case I am wrong.
- # if ($n > 49) { $n = 49; }
- my @thisround = @toask[0..$n];
- @toask = @toask[($n+1)..(@toask-1)];
- my $post_data = join("+", sort((map {"0x" . "$_"} @thisround)));
- open(POSTFILE, ">$main::tmpfile_sym");
- print POSTFILE $post_data;
- close(POSTFILE);
-
- my $url = SymbolPageURL();
- $url = ResolveRedirectionForCurl($url);
- my $command_line = "$CURL -sd '\@$main::tmpfile_sym' '$url'";
- # We use c++filt in case $SYMBOL_PAGE gives us mangled symbols.
- my $cppfilt = $obj_tool_map{"c++filt"};
- open(SYMBOL, "$command_line | $cppfilt |") or error($command_line);
- ReadSymbols(*SYMBOL{IO}, $symbol_map);
- close(SYMBOL);
- }
- }
-
- my $symbols = {};
- foreach my $pc (@pcs) {
- my $fullname;
- # For 64 bits binaries, symbols are extracted with 8 leading zeroes.
- # Then /symbol reads the long symbols in as uint64, and outputs
- # the result with a "0x%08llx" format which get rid of the zeroes.
- # By removing all the leading zeroes in both $pc and the symbols from
- # /symbol, the symbols match and are retrievable from the map.
- my $shortpc = $pc;
- $shortpc =~ s/^0*//;
- # Each line may have a list of names, which includes the function
- # and also other functions it has inlined. They are separated
- # (in PrintSymbolizedFile), by --, which is illegal in function names.
- my $fullnames;
- if (defined($symbol_map->{$shortpc})) {
- $fullnames = $symbol_map->{$shortpc};
- } else {
- $fullnames = "0x" . $pc; # Just use addresses
- }
- my $sym = [];
- $symbols->{$pc} = $sym;
- foreach my $fullname (split("--", $fullnames)) {
- my $name = ShortFunctionName($fullname);
- push(@{$sym}, $name, "?", $fullname);
- }
- }
- return $symbols;
-}
-
-sub BaseName {
- my $file_name = shift;
- $file_name =~ s!^.*/!!; # Remove directory name
- return $file_name;
-}
-
-sub MakeProfileBaseName {
- my ($binary_name, $profile_name) = @_;
- my ($host, $port, $prefix, $path) = ParseProfileURL($profile_name);
- my $binary_shortname = BaseName($binary_name);
- return sprintf("%s.%s.%s-port%s",
- $binary_shortname, $main::op_time, $host, $port);
-}
-
-sub FetchDynamicProfile {
- my $binary_name = shift;
- my $profile_name = shift;
- my $fetch_name_only = shift;
- my $encourage_patience = shift;
-
- if (!IsProfileURL($profile_name)) {
- return $profile_name;
- } else {
- my ($host, $port, $prefix, $path) = ParseProfileURL($profile_name);
- if ($path eq "" || $path eq "/") {
- # Missing type specifier defaults to cpu-profile
- $path = $PROFILE_PAGE;
- }
-
- my $profile_file = MakeProfileBaseName($binary_name, $profile_name);
-
- my $url;
- my $curl_timeout;
- if (($path =~ m/$PROFILE_PAGE/) || ($path =~ m/$PMUPROFILE_PAGE/)) {
- if ($path =~ m/$PROFILE_PAGE/) {
- $url = sprintf("http://$host:$port$prefix$path?seconds=%d",
- $main::opt_seconds);
- } else {
- if ($profile_name =~ m/[?]/) {
- $profile_name .= "&"
- } else {
- $profile_name .= "?"
- }
- $url = sprintf("http://$profile_name" . "seconds=%d",
- $main::opt_seconds);
- }
- $curl_timeout = sprintf("--max-time %d",
- int($main::opt_seconds * 1.01 + 60));
- } else {
- # For non-CPU profiles, we add a type-extension to
- # the target profile file name.
- my $suffix = $path;
- $suffix =~ s,/,.,g;
- $profile_file .= "$suffix";
- $url = "http://$host:$port$prefix$path";
- $curl_timeout = "";
- }
-
- my $profile_dir = $ENV{"PPROF_TMPDIR"} || ($ENV{HOME} . "/pprof");
- if (!(-d $profile_dir)) {
- mkdir($profile_dir)
- || die("Unable to create profile directory $profile_dir: $!\n");
- }
- my $tmp_profile = "$profile_dir/.tmp.$profile_file";
- my $real_profile = "$profile_dir/$profile_file";
-
- if ($fetch_name_only > 0) {
- return $real_profile;
- }
-
- my $cmd = "$CURL $curl_timeout -s -o $tmp_profile '$url'";
- if (($path =~ m/$PROFILE_PAGE/) || ($path =~ m/$PMUPROFILE_PAGE/)){
- print STDERR "Gathering CPU profile from $url for $main::opt_seconds seconds to\n ${real_profile}\n";
- if ($encourage_patience) {
- print STDERR "Be patient...\n";
- }
- } else {
- print STDERR "Fetching $path profile from $host:$port to\n ${real_profile}\n";
- }
-
- (system($cmd) == 0) || error("Failed to get profile: $cmd: $!\n");
- (system("mv $tmp_profile $real_profile") == 0) || error("Unable to rename profile\n");
- print STDERR "Wrote profile to $real_profile\n";
- $main::collected_profile = $real_profile;
- return $main::collected_profile;
- }
-}
-
-# Collect profiles in parallel
-sub FetchDynamicProfiles {
- my $items = scalar(@main::pfile_args);
- my $levels = log($items) / log(2);
-
- if ($items == 1) {
- $main::profile_files[0] = FetchDynamicProfile($main::prog, $main::pfile_args[0], 0, 1);
- } else {
- # math rounding issues
- if ((2 ** $levels) < $items) {
- $levels++;
- }
- my $count = scalar(@main::pfile_args);
- for (my $i = 0; $i < $count; $i++) {
- $main::profile_files[$i] = FetchDynamicProfile($main::prog, $main::pfile_args[$i], 1, 0);
- }
- print STDERR "Fetching $count profiles, Be patient...\n";
- FetchDynamicProfilesRecurse($levels, 0, 0);
- $main::collected_profile = join(" \\\n ", @main::profile_files);
- }
-}
-
-# Recursively fork a process to get enough processes
-# collecting profiles
-sub FetchDynamicProfilesRecurse {
- my $maxlevel = shift;
- my $level = shift;
- my $position = shift;
-
- if (my $pid = fork()) {
- $position = 0 | ($position << 1);
- TryCollectProfile($maxlevel, $level, $position);
- wait;
- } else {
- $position = 1 | ($position << 1);
- TryCollectProfile($maxlevel, $level, $position);
- exit(0);
- }
-}
-
-# Collect a single profile
-sub TryCollectProfile {
- my $maxlevel = shift;
- my $level = shift;
- my $position = shift;
-
- if ($level >= ($maxlevel - 1)) {
- if ($position < scalar(@main::pfile_args)) {
- FetchDynamicProfile($main::prog, $main::pfile_args[$position], 0, 0);
- }
- } else {
- FetchDynamicProfilesRecurse($maxlevel, $level+1, $position);
- }
-}
-
-##### Parsing code #####
-
-# Provide a small streaming-read module to handle very large
-# cpu-profile files. Stream in chunks along a sliding window.
-# Provides an interface to get one 'slot', correctly handling
-# endian-ness differences. A slot is one 32-bit or 64-bit word
-# (depending on the input profile). We tell endianness and bit-size
-# for the profile by looking at the first 8 bytes: in cpu profiles,
-# the second slot is always 3 (we'll accept anything that's not 0).
-BEGIN {
- package CpuProfileStream;
-
- sub new {
- my ($class, $file, $fname) = @_;
- my $self = { file => $file,
- base => 0,
- stride => 512 * 1024, # must be a multiple of bitsize/8
- slots => [],
- unpack_code => "", # N for big-endian, V for little
- };
- bless $self, $class;
- # Let unittests adjust the stride
- if ($main::opt_test_stride > 0) {
- $self->{stride} = $main::opt_test_stride;
- }
- # Read the first two slots to figure out bitsize and endianness.
- my $slots = $self->{slots};
- my $str;
- read($self->{file}, $str, 8);
- # Set the global $address_length based on what we see here.
- # 8 is 32-bit (8 hexadecimal chars); 16 is 64-bit (16 hexadecimal chars).
- $address_length = ($str eq (chr(0)x8)) ? 16 : 8;
- if ($address_length == 8) {
- if (substr($str, 6, 2) eq chr(0)x2) {
- $self->{unpack_code} = 'V'; # Little-endian.
- } elsif (substr($str, 4, 2) eq chr(0)x2) {
- $self->{unpack_code} = 'N'; # Big-endian
- } else {
- ::error("$fname: header size >= 2**16\n");
- }
- @$slots = unpack($self->{unpack_code} . "*", $str);
- } else {
- # If we're a 64-bit profile, make sure we're a 64-bit-capable
- # perl. Otherwise, each slot will be represented as a float
- # instead of an int64, losing precision and making all the
- # 64-bit addresses right. We *could* try to handle this with
- # software emulation of 64-bit ints, but that's added complexity
- # for no clear benefit (yet). We use 'Q' to test for 64-bit-ness;
- # perl docs say it's only available on 64-bit perl systems.
- my $has_q = 0;
- eval { $has_q = pack("Q", "1") ? 1 : 1; };
- if (!$has_q) {
- ::error("$fname: need a 64-bit perl to process this 64-bit profile.\n");
- }
- read($self->{file}, $str, 8);
- if (substr($str, 4, 4) eq chr(0)x4) {
- # We'd love to use 'Q', but it's a) not universal, b) not endian-proof.
- $self->{unpack_code} = 'V'; # Little-endian.
- } elsif (substr($str, 0, 4) eq chr(0)x4) {
- $self->{unpack_code} = 'N'; # Big-endian
- } else {
- ::error("$fname: header size >= 2**32\n");
- }
- my @pair = unpack($self->{unpack_code} . "*", $str);
- # Since we know one of the pair is 0, it's fine to just add them.
- @$slots = (0, $pair[0] + $pair[1]);
- }
- return $self;
- }
-
- # Load more data when we access slots->get(X) which is not yet in memory.
- sub overflow {
- my ($self) = @_;
- my $slots = $self->{slots};
- $self->{base} += $#$slots + 1; # skip over data we're replacing
- my $str;
- read($self->{file}, $str, $self->{stride});
- if ($address_length == 8) { # the 32-bit case
- # This is the easy case: unpack provides 32-bit unpacking primitives.
- @$slots = unpack($self->{unpack_code} . "*", $str);
- } else {
- # We need to unpack 32 bits at a time and combine.
- my @b32_values = unpack($self->{unpack_code} . "*", $str);
- my @b64_values = ();
- for (my $i = 0; $i < $#b32_values; $i += 2) {
- # TODO(csilvers): if this is a 32-bit perl, the math below
- # could end up in a too-large int, which perl will promote
- # to a double, losing necessary precision. Deal with that.
- if ($self->{unpack_code} eq 'V') { # little-endian
- push(@b64_values, $b32_values[$i] + $b32_values[$i+1] * (2**32));
- } else {
- push(@b64_values, $b32_values[$i] * (2**32) + $b32_values[$i+1]);
- }
- }
- @$slots = @b64_values;
- }
- }
-
- # Access the i-th long in the file (logically), or -1 at EOF.
- sub get {
- my ($self, $idx) = @_;
- my $slots = $self->{slots};
- while ($#$slots >= 0) {
- if ($idx < $self->{base}) {
- # The only time we expect a reference to $slots[$i - something]
- # after referencing $slots[$i] is reading the very first header.
- # Since $stride > |header|, that shouldn't cause any lookback
- # errors. And everything after the header is sequential.
- print STDERR "Unexpected look-back reading CPU profile";
- return -1; # shrug, don't know what better to return
- } elsif ($idx > $self->{base} + $#$slots) {
- $self->overflow();
- } else {
- return $slots->[$idx - $self->{base}];
- }
- }
- # If we get here, $slots is [], which means we've reached EOF
- return -1; # unique since slots is supposed to hold unsigned numbers
- }
-}
-
-# Parse profile generated by common/profiler.cc and return a reference
-# to a map:
-# $result->{version} Version number of profile file
-# $result->{period} Sampling period (in microseconds)
-# $result->{profile} Profile object
-# $result->{map} Memory map info from profile
-# $result->{pcs} Hash of all PC values seen, key is hex address
-sub ReadProfile {
- my $prog = shift;
- my $fname = shift;
-
- if (IsSymbolizedProfileFile($fname) && !$main::use_symbolized_profile) {
- # we have both a binary and symbolized profiles, abort
- usage("Symbolized profile '$fname' cannot be used with a binary arg. " .
- "Try again without passing '$prog'.");
- }
-
- $main::profile_type = '';
-
- $CONTENTION_PAGE =~ m,[^/]+$,; # matches everything after the last slash
- my $contention_marker = $&;
- $GROWTH_PAGE =~ m,[^/]+$,; # matches everything after the last slash
- my $growth_marker = $&;
- $SYMBOL_PAGE =~ m,[^/]+$,; # matches everything after the last slash
- my $symbol_marker = $&;
- $PROFILE_PAGE =~ m,[^/]+$,; # matches everything after the last slash
- my $profile_marker = $&;
-
- # Look at first line to see if it is a heap or a CPU profile.
- # CPU profile may start with no header at all, and just binary data
- # (starting with \0\0\0\0) -- in that case, don't try to read the
- # whole firstline, since it may be gigabytes(!) of data.
- open(PROFILE, "<$fname") || error("$fname: $!\n");
- binmode PROFILE; # New perls do UTF-8 processing
- my $firstchar = "";
- my $header = "";
- read(PROFILE, $firstchar, 1);
- seek(PROFILE, -1, 1); # unread the firstchar
- if ($firstchar ne "\0") {
- $header = <PROFILE>;
- if (!defined($header)) {
- error("Profile is empty.\n");
- }
- $header =~ s/\r//g; # turn windows-looking lines into unix-looking lines
- }
-
- my $symbols;
- if ($header =~ m/^--- *$symbol_marker/o) {
- # read the symbol section of the symbolized profile file
- $symbols = ReadSymbols(*PROFILE{IO});
-
- # read the next line to get the header for the remaining profile
- $header = "";
- read(PROFILE, $firstchar, 1);
- seek(PROFILE, -1, 1); # unread the firstchar
- if ($firstchar ne "\0") {
- $header = <PROFILE>;
- $header =~ s/\r//g;
- }
- }
-
- my $result;
-
- if ($header =~ m/^heap profile:.*$growth_marker/o) {
- $main::profile_type = 'growth';
- $result = ReadHeapProfile($prog, $fname, $header);
- } elsif ($header =~ m/^heap profile:/) {
- $main::profile_type = 'heap';
- $result = ReadHeapProfile($prog, $fname, $header);
- } elsif ($header =~ m/^--- *$contention_marker/o) {
- $main::profile_type = 'contention';
- $result = ReadSynchProfile($prog, $fname);
- } elsif ($header =~ m/^--- *Stacks:/) {
- print STDERR
- "Old format contention profile: mistakenly reports " .
- "condition variable signals as lock contentions.\n";
- $main::profile_type = 'contention';
- $result = ReadSynchProfile($prog, $fname);
- } elsif ($header =~ m/^--- *$profile_marker/) {
- # the binary cpu profile data starts immediately after this line
- $main::profile_type = 'cpu';
- $result = ReadCPUProfile($prog, $fname);
- } else {
- if (defined($symbols)) {
- # a symbolized profile contains a format we don't recognize, bail out
- error("$fname: Cannot recognize profile section after symbols.\n");
- }
- # no ascii header present -- must be a CPU profile
- $main::profile_type = 'cpu';
- $result = ReadCPUProfile($prog, $fname);
- }
-
- # if we got symbols along with the profile, return those as well
- if (defined($symbols)) {
- $result->{symbols} = $symbols;
- }
-
- return $result;
-}
-
-# Subtract one from caller pc so we map back to call instr.
-# However, don't do this if we're reading a symbolized profile
-# file, in which case the subtract-one was done when the file
-# was written.
-#
-# We apply the same logic to all readers, though ReadCPUProfile uses an
-# independent implementation.
-sub FixCallerAddresses {
- my $stack = shift;
- if ($main::use_symbolized_profile) {
- return $stack;
- } else {
- $stack =~ /(\s)/;
- my $delimiter = $1;
- my @addrs = split(' ', $stack);
- my @fixedaddrs;
- $#fixedaddrs = $#addrs;
- if ($#addrs >= 0) {
- $fixedaddrs[0] = $addrs[0];
- }
- for (my $i = 1; $i <= $#addrs; $i++) {
- $fixedaddrs[$i] = AddressSub($addrs[$i], "0x1");
- }
- return join $delimiter, @fixedaddrs;
- }
-}
-
-# CPU profile reader
-sub ReadCPUProfile {
- my $prog = shift;
- my $fname = shift;
- my $version;
- my $period;
- my $i;
- my $profile = {};
- my $pcs = {};
-
- # Parse string into array of slots.
- my $slots = CpuProfileStream->new(*PROFILE, $fname);
-
- # Read header. The current header version is a 5-element structure
- # containing:
- # 0: header count (always 0)
- # 1: header "words" (after this one: 3)
- # 2: format version (0)
- # 3: sampling period (usec)
- # 4: unused padding (always 0)
- if ($slots->get(0) != 0 ) {
- error("$fname: not a profile file, or old format profile file\n");
- }
- $i = 2 + $slots->get(1);
- $version = $slots->get(2);
- $period = $slots->get(3);
- # Do some sanity checking on these header values.
- if ($version > (2**32) || $period > (2**32) || $i > (2**32) || $i < 5) {
- error("$fname: not a profile file, or corrupted profile file\n");
- }
-
- # Parse profile
- while ($slots->get($i) != -1) {
- my $n = $slots->get($i++);
- my $d = $slots->get($i++);
- if ($d > (2**16)) { # TODO(csilvers): what's a reasonable max-stack-depth?
- my $addr = sprintf("0%o", $i * ($address_length == 8 ? 4 : 8));
- print STDERR "At index $i (address $addr):\n";
- error("$fname: stack trace depth >= 2**32\n");
- }
- if ($slots->get($i) == 0) {
- # End of profile data marker
- $i += $d;
- last;
- }
-
- # Make key out of the stack entries
- my @k = ();
- for (my $j = 0; $j < $d; $j++) {
- my $pc = $slots->get($i+$j);
- # Subtract one from caller pc so we map back to call instr.
- # However, don't do this if we're reading a symbolized profile
- # file, in which case the subtract-one was done when the file
- # was written.
- if ($j > 0 && !$main::use_symbolized_profile) {
- $pc--;
- }
- $pc = sprintf("%0*x", $address_length, $pc);
- $pcs->{$pc} = 1;
- push @k, $pc;
- }
-
- AddEntry($profile, (join "\n", @k), $n);
- $i += $d;
- }
-
- # Parse map
- my $map = '';
- seek(PROFILE, $i * 4, 0);
- read(PROFILE, $map, (stat PROFILE)[7]);
- close(PROFILE);
-
- my $r = {};
- $r->{version} = $version;
- $r->{period} = $period;
- $r->{profile} = $profile;
- $r->{libs} = ParseLibraries($prog, $map, $pcs);
- $r->{pcs} = $pcs;
-
- return $r;
-}
-
-sub ReadHeapProfile {
- my $prog = shift;
- my $fname = shift;
- my $header = shift;
-
- my $index = 1;
- if ($main::opt_inuse_space) {
- $index = 1;
- } elsif ($main::opt_inuse_objects) {
- $index = 0;
- } elsif ($main::opt_alloc_space) {
- $index = 3;
- } elsif ($main::opt_alloc_objects) {
- $index = 2;
- }
-
- # Find the type of this profile. The header line looks like:
- # heap profile: 1246: 8800744 [ 1246: 8800744] @ <heap-url>/266053
- # There are two pairs <count: size>, the first inuse objects/space, and the
- # second allocated objects/space. This is followed optionally by a profile
- # type, and if that is present, optionally by a sampling frequency.
- # For remote heap profiles (v1):
- # The interpretation of the sampling frequency is that the profiler, for
- # each sample, calculates a uniformly distributed random integer less than
- # the given value, and records the next sample after that many bytes have
- # been allocated. Therefore, the expected sample interval is half of the
- # given frequency. By default, if not specified, the expected sample
- # interval is 128KB. Only remote-heap-page profiles are adjusted for
- # sample size.
- # For remote heap profiles (v2):
- # The sampling frequency is the rate of a Poisson process. This means that
- # the probability of sampling an allocation of size X with sampling rate Y
- # is 1 - exp(-X/Y)
- # For version 2, a typical header line might look like this:
- # heap profile: 1922: 127792360 [ 1922: 127792360] @ <heap-url>_v2/524288
- # the trailing number (524288) is the sampling rate. (Version 1 showed
- # double the 'rate' here)
- my $sampling_algorithm = 0;
- my $sample_adjustment = 0;
- chomp($header);
- my $type = "unknown";
- if ($header =~ m"^heap profile:\s*(\d+):\s+(\d+)\s+\[\s*(\d+):\s+(\d+)\](\s*@\s*([^/]*)(/(\d+))?)?") {
- if (defined($6) && ($6 ne '')) {
- $type = $6;
- my $sample_period = $8;
- # $type is "heapprofile" for profiles generated by the
- # heap-profiler, and either "heap" or "heap_v2" for profiles
- # generated by sampling directly within tcmalloc. It can also
- # be "growth" for heap-growth profiles. The first is typically
- # found for profiles generated locally, and the others for
- # remote profiles.
- if (($type eq "heapprofile") || ($type !~ /heap/) ) {
- # No need to adjust for the sampling rate with heap-profiler-derived data
- $sampling_algorithm = 0;
- } elsif ($type =~ /_v2/) {
- $sampling_algorithm = 2; # version 2 sampling
- if (defined($sample_period) && ($sample_period ne '')) {
- $sample_adjustment = int($sample_period);
- }
- } else {
- $sampling_algorithm = 1; # version 1 sampling
- if (defined($sample_period) && ($sample_period ne '')) {
- $sample_adjustment = int($sample_period)/2;
- }
- }
- } else {
- # We detect whether or not this is a remote-heap profile by checking
- # that the total-allocated stats ($n2,$s2) are exactly the
- # same as the in-use stats ($n1,$s1). It is remotely conceivable
- # that a non-remote-heap profile may pass this check, but it is hard
- # to imagine how that could happen.
- # In this case it's so old it's guaranteed to be remote-heap version 1.
- my ($n1, $s1, $n2, $s2) = ($1, $2, $3, $4);
- if (($n1 == $n2) && ($s1 == $s2)) {
- # This is likely to be a remote-heap based sample profile
- $sampling_algorithm = 1;
- }
- }
- }
-
- if ($sampling_algorithm > 0) {
- # For remote-heap generated profiles, adjust the counts and sizes to
- # account for the sample rate (we sample once every 128KB by default).
- if ($sample_adjustment == 0) {
- # Turn on profile adjustment.
- $sample_adjustment = 128*1024;
- print STDERR "Adjusting heap profiles for 1-in-128KB sampling rate\n";
- } else {
- printf STDERR ("Adjusting heap profiles for 1-in-%d sampling rate\n",
- $sample_adjustment);
- }
- if ($sampling_algorithm > 1) {
- # We don't bother printing anything for the original version (version 1)
- printf STDERR "Heap version $sampling_algorithm\n";
- }
- }
-
- my $profile = {};
- my $pcs = {};
- my $map = "";
-
- while (<PROFILE>) {
- s/\r//g; # turn windows-looking lines into unix-looking lines
- if (/^MAPPED_LIBRARIES:/) {
- # Read the /proc/self/maps data
- while (<PROFILE>) {
- s/\r//g; # turn windows-looking lines into unix-looking lines
- $map .= $_;
- }
- last;
- }
-
- if (/^--- Memory map:/) {
- # Read /proc/self/maps data as formatted by DumpAddressMap()
- my $buildvar = "";
- while (<PROFILE>) {
- s/\r//g; # turn windows-looking lines into unix-looking lines
- # Parse "build=<dir>" specification if supplied
- if (m/^\s*build=(.*)\n/) {
- $buildvar = $1;
- }
-
- # Expand "$build" variable if available
- $_ =~ s/\$build\b/$buildvar/g;
-
- $map .= $_;
- }
- last;
- }
-
- # Read entry of the form:
- # <count1>: <bytes1> [<count2>: <bytes2>] @ a1 a2 a3 ... an
- s/^\s*//;
- s/\s*$//;
- if (m/^\s*(\d+):\s+(\d+)\s+\[\s*(\d+):\s+(\d+)\]\s+@\s+(.*)$/) {
- my $stack = $5;
- my ($n1, $s1, $n2, $s2) = ($1, $2, $3, $4);
-
- if ($sample_adjustment) {
- if ($sampling_algorithm == 2) {
- # Remote-heap version 2
- # The sampling frequency is the rate of a Poisson process.
- # This means that the probability of sampling an allocation of
- # size X with sampling rate Y is 1 - exp(-X/Y)
- my $ratio;
- $ratio = (($s1*1.0)/$n1)/($sample_adjustment);
- my $scale_factor;
- $scale_factor = 1/(1 - exp(-$ratio));
- $n1 *= $scale_factor;
- $s1 *= $scale_factor;
- $ratio = (($s2*1.0)/$n2)/($sample_adjustment);
- $scale_factor = 1/(1 - exp(-$ratio));
- $n2 *= $scale_factor;
- $s2 *= $scale_factor;
- } else {
- # Remote-heap version 1
- my $ratio;
- $ratio = (($s1*1.0)/$n1)/($sample_adjustment);
- if ($ratio < 1) {
- $n1 /= $ratio;
- $s1 /= $ratio;
- }
- $ratio = (($s2*1.0)/$n2)/($sample_adjustment);
- if ($ratio < 1) {
- $n2 /= $ratio;
- $s2 /= $ratio;
- }
- }
- }
-
- my @counts = ($n1, $s1, $n2, $s2);
- AddEntries($profile, $pcs, FixCallerAddresses($stack), $counts[$index]);
- }
- }
-
- my $r = {};
- $r->{version} = "heap";
- $r->{period} = 1;
- $r->{profile} = $profile;
- $r->{libs} = ParseLibraries($prog, $map, $pcs);
- $r->{pcs} = $pcs;
- return $r;
-}
-
-sub ReadSynchProfile {
- my ($prog, $fname, $header) = @_;
-
- my $map = '';
- my $profile = {};
- my $pcs = {};
- my $sampling_period = 1;
- my $cyclespernanosec = 2.8; # Default assumption for old binaries
- my $seen_clockrate = 0;
- my $line;
-
- my $index = 0;
- if ($main::opt_total_delay) {
- $index = 0;
- } elsif ($main::opt_contentions) {
- $index = 1;
- } elsif ($main::opt_mean_delay) {
- $index = 2;
- }
-
- while ( $line = <PROFILE> ) {
- $line =~ s/\r//g; # turn windows-looking lines into unix-looking lines
- if ( $line =~ /^\s*(\d+)\s+(\d+) \@\s*(.*?)\s*$/ ) {
- my ($cycles, $count, $stack) = ($1, $2, $3);
-
- # Convert cycles to nanoseconds
- $cycles /= $cyclespernanosec;
-
- # Adjust for sampling done by application
- $cycles *= $sampling_period;
- $count *= $sampling_period;
-
- my @values = ($cycles, $count, $cycles / $count);
- AddEntries($profile, $pcs, FixCallerAddresses($stack), $values[$index]);
-
- } elsif ( $line =~ /^(slow release).*thread \d+ \@\s*(.*?)\s*$/ ||
- $line =~ /^\s*(\d+) \@\s*(.*?)\s*$/ ) {
- my ($cycles, $stack) = ($1, $2);
- if ($cycles !~ /^\d+$/) {
- next;
- }
-
- # Convert cycles to nanoseconds
- $cycles /= $cyclespernanosec;
-
- # Adjust for sampling done by application
- $cycles *= $sampling_period;
-
- AddEntries($profile, $pcs, FixCallerAddresses($stack), $cycles);
-
- } elsif ( $line =~ m/^([a-z][^=]*)=(.*)$/ ) {
- my ($variable, $value) = ($1,$2);
- for ($variable, $value) {
- s/^\s+//;
- s/\s+$//;
- }
- if ($variable eq "cycles/second") {
- $cyclespernanosec = $value / 1e9;
- $seen_clockrate = 1;
- } elsif ($variable eq "sampling period") {
- $sampling_period = $value;
- } elsif ($variable eq "ms since reset") {
- # Currently nothing is done with this value in pprof
- # So we just silently ignore it for now
- } elsif ($variable eq "discarded samples") {
- # Currently nothing is done with this value in pprof
- # So we just silently ignore it for now
- } else {
- printf STDERR ("Ignoring unnknown variable in /contention output: " .
- "'%s' = '%s'\n",$variable,$value);
- }
- } else {
- # Memory map entry
- $map .= $line;
- }
- }
- close PROFILE;
-
- if (!$seen_clockrate) {
- printf STDERR ("No cycles/second entry in profile; Guessing %.1f GHz\n",
- $cyclespernanosec);
- }
-
- my $r = {};
- $r->{version} = 0;
- $r->{period} = $sampling_period;
- $r->{profile} = $profile;
- $r->{libs} = ParseLibraries($prog, $map, $pcs);
- $r->{pcs} = $pcs;
- return $r;
-}
-
-# Given a hex value in the form "0x1abcd" return "0001abcd" or
-# "000000000001abcd", depending on the current address length.
-# There's probably a more idiomatic (or faster) way to do this...
-sub HexExtend {
- my $addr = shift;
-
- $addr =~ s/^0x//;
-
- if (length $addr > $address_length) {
- printf STDERR "Warning: address $addr is longer than address length $address_length\n";
- }
-
- return substr("000000000000000".$addr, -$address_length);
-}
-
-##### Symbol extraction #####
-
-# Aggressively search the lib_prefix values for the given library
-# If all else fails, just return the name of the library unmodified.
-# If the lib_prefix is "/my/path,/other/path" and $file is "/lib/dir/mylib.so"
-# it will search the following locations in this order, until it finds a file:
-# /my/path/lib/dir/mylib.so
-# /other/path/lib/dir/mylib.so
-# /my/path/dir/mylib.so
-# /other/path/dir/mylib.so
-# /my/path/mylib.so
-# /other/path/mylib.so
-# /lib/dir/mylib.so (returned as last resort)
-sub FindLibrary {
- my $file = shift;
- my $suffix = $file;
-
- # Search for the library as described above
- do {
- foreach my $prefix (@prefix_list) {
- my $fullpath = $prefix . $suffix;
- if (-e $fullpath) {
- return $fullpath;
- }
- }
- } while ($suffix =~ s|^/[^/]+/|/|);
- return $file;
-}
-
-# Return path to library with debugging symbols.
-# For libc libraries, the copy in /usr/lib/debug contains debugging symbols
-sub DebuggingLibrary {
- my $file = shift;
- if ($file =~ m|^/| && -f "/usr/lib/debug$file") {
- return "/usr/lib/debug$file";
- }
- return undef;
-}
-
-# Parse text section header of a library using objdump
-sub ParseTextSectionHeaderFromObjdump {
- my $lib = shift;
-
- my $size = undef;
- my $vma;
- my $file_offset;
- # Get objdump output from the library file to figure out how to
- # map between mapped addresses and addresses in the library.
- my $objdump = $obj_tool_map{"objdump"};
- open(OBJDUMP, "$objdump -h $lib |")
- || error("$objdump $lib: $!\n");
- while (<OBJDUMP>) {
- s/\r//g; # turn windows-looking lines into unix-looking lines
- # Idx Name Size VMA LMA File off Algn
- # 10 .text 00104b2c 420156f0 420156f0 000156f0 2**4
- # For 64-bit objects, VMA and LMA will be 16 hex digits, size and file
- # offset may still be 8. But AddressSub below will still handle that.
- my @x = split;
- if (($#x >= 6) && ($x[1] eq '.text')) {
- $size = $x[2];
- $vma = $x[3];
- $file_offset = $x[5];
- last;
- }
- }
- close(OBJDUMP);
-
- if (!defined($size)) {
- return undef;
- }
-
- my $r = {};
- $r->{size} = $size;
- $r->{vma} = $vma;
- $r->{file_offset} = $file_offset;
-
- return $r;
-}
-
-# Parse text section header of a library using otool (on OS X)
-sub ParseTextSectionHeaderFromOtool {
- my $lib = shift;
-
- my $size = undef;
- my $vma = undef;
- my $file_offset = undef;
- # Get otool output from the library file to figure out how to
- # map between mapped addresses and addresses in the library.
- my $otool = $obj_tool_map{"otool"};
- open(OTOOL, "$otool -l $lib |")
- || error("$otool $lib: $!\n");
- my $cmd = "";
- my $sectname = "";
- my $segname = "";
- foreach my $line (<OTOOL>) {
- $line =~ s/\r//g; # turn windows-looking lines into unix-looking lines
- # Load command <#>
- # cmd LC_SEGMENT
- # [...]
- # Section
- # sectname __text
- # segname __TEXT
- # addr 0x000009f8
- # size 0x00018b9e
- # offset 2552
- # align 2^2 (4)
- # We will need to strip off the leading 0x from the hex addresses,
- # and convert the offset into hex.
- if ($line =~ /Load command/) {
- $cmd = "";
- $sectname = "";
- $segname = "";
- } elsif ($line =~ /Section/) {
- $sectname = "";
- $segname = "";
- } elsif ($line =~ /cmd (\w+)/) {
- $cmd = $1;
- } elsif ($line =~ /sectname (\w+)/) {
- $sectname = $1;
- } elsif ($line =~ /segname (\w+)/) {
- $segname = $1;
- } elsif (!(($cmd eq "LC_SEGMENT" || $cmd eq "LC_SEGMENT_64") &&
- $sectname eq "__text" &&
- $segname eq "__TEXT")) {
- next;
- } elsif ($line =~ /\baddr 0x([0-9a-fA-F]+)/) {
- $vma = $1;
- } elsif ($line =~ /\bsize 0x([0-9a-fA-F]+)/) {
- $size = $1;
- } elsif ($line =~ /\boffset ([0-9]+)/) {
- $file_offset = sprintf("%016x", $1);
- }
- if (defined($vma) && defined($size) && defined($file_offset)) {
- last;
- }
- }
- close(OTOOL);
-
- if (!defined($vma) || !defined($size) || !defined($file_offset)) {
- return undef;
- }
-
- my $r = {};
- $r->{size} = $size;
- $r->{vma} = $vma;
- $r->{file_offset} = $file_offset;
-
- return $r;
-}
-
-sub ParseTextSectionHeader {
- # obj_tool_map("otool") is only defined if we're in a Mach-O environment
- if (defined($obj_tool_map{"otool"})) {
- my $r = ParseTextSectionHeaderFromOtool(@_);
- if (defined($r)){
- return $r;
- }
- }
- # If otool doesn't work, or we don't have it, fall back to objdump
- return ParseTextSectionHeaderFromObjdump(@_);
-}
-
-# Split /proc/pid/maps dump into a list of libraries
-sub ParseLibraries {
- return if $main::use_symbol_page; # We don't need libraries info.
- my $prog = shift;
- my $map = shift;
- my $pcs = shift;
-
- my $result = [];
- my $h = "[a-f0-9]+";
- my $zero_offset = HexExtend("0");
-
- my $buildvar = "";
- foreach my $l (split("\n", $map)) {
- if ($l =~ m/^\s*build=(.*)$/) {
- $buildvar = $1;
- }
-
- my $start;
- my $finish;
- my $offset;
- my $lib;
- 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) {
- # Full line from /proc/self/maps. Example:
- # 40000000-40015000 r-xp 00000000 03:01 12845071 /lib/ld-2.3.2.so
- $start = HexExtend($1);
- $finish = HexExtend($2);
- $offset = HexExtend($3);
- $lib = $4;
- $lib =~ s|\\|/|g; # turn windows-style paths into unix-style paths
- } elsif ($l =~ /^\s*($h)-($h):\s*(\S+\.so(\.\d+)*)/) {
- # Cooked line from DumpAddressMap. Example:
- # 40000000-40015000: /lib/ld-2.3.2.so
- $start = HexExtend($1);
- $finish = HexExtend($2);
- $offset = $zero_offset;
- $lib = $3;
- } else {
- next;
- }
-
- # Expand "$build" variable if available
- $lib =~ s/\$build\b/$buildvar/g;
-
- $lib = FindLibrary($lib);
-
- # Check for pre-relocated libraries, which use pre-relocated symbol tables
- # and thus require adjusting the offset that we'll use to translate
- # VM addresses into symbol table addresses.
- # Only do this if we're not going to fetch the symbol table from a
- # debugging copy of the library.
- if (!DebuggingLibrary($lib)) {
- my $text = ParseTextSectionHeader($lib);
- if (defined($text)) {
- my $vma_offset = AddressSub($text->{vma}, $text->{file_offset});
- $offset = AddressAdd($offset, $vma_offset);
- }
- }
-
- push(@{$result}, [$lib, $start, $finish, $offset]);
- }
-
- # Append special entry for additional library (not relocated)
- if ($main::opt_lib ne "") {
- my $text = ParseTextSectionHeader($main::opt_lib);
- if (defined($text)) {
- my $start = $text->{vma};
- my $finish = AddressAdd($start, $text->{size});
-
- push(@{$result}, [$main::opt_lib, $start, $finish, $start]);
- }
- }
-
- # Append special entry for the main program. This covers
- # 0..max_pc_value_seen, so that we assume pc values not found in one
- # of the library ranges will be treated as coming from the main
- # program binary.
- my $min_pc = HexExtend("0");
- my $max_pc = $min_pc; # find the maximal PC value in any sample
- foreach my $pc (keys(%{$pcs})) {
- if (HexExtend($pc) gt $max_pc) { $max_pc = HexExtend($pc); }
- }
- push(@{$result}, [$prog, $min_pc, $max_pc, $zero_offset]);
-
- return $result;
-}
-
-# Add two hex addresses of length $address_length.
-# Run pprof --test for unit test if this is changed.
-sub AddressAdd {
- my $addr1 = shift;
- my $addr2 = shift;
- my $sum;
-
- if ($address_length == 8) {
- # Perl doesn't cope with wraparound arithmetic, so do it explicitly:
- $sum = (hex($addr1)+hex($addr2)) % (0x10000000 * 16);
- return sprintf("%08x", $sum);
-
- } else {
- # Do the addition in 7-nibble chunks to trivialize carry handling.
-
- if ($main::opt_debug and $main::opt_test) {
- print STDERR "AddressAdd $addr1 + $addr2 = ";
- }
-
- my $a1 = substr($addr1,-7);
- $addr1 = substr($addr1,0,-7);
- my $a2 = substr($addr2,-7);
- $addr2 = substr($addr2,0,-7);
- $sum = hex($a1) + hex($a2);
- my $c = 0;
- if ($sum > 0xfffffff) {
- $c = 1;
- $sum -= 0x10000000;
- }
- my $r = sprintf("%07x", $sum);
-
- $a1 = substr($addr1,-7);
- $addr1 = substr($addr1,0,-7);
- $a2 = substr($addr2,-7);
- $addr2 = substr($addr2,0,-7);
- $sum = hex($a1) + hex($a2) + $c;
- $c = 0;
- if ($sum > 0xfffffff) {
- $c = 1;
- $sum -= 0x10000000;
- }
- $r = sprintf("%07x", $sum) . $r;
-
- $sum = hex($addr1) + hex($addr2) + $c;
- if ($sum > 0xff) { $sum -= 0x100; }
- $r = sprintf("%02x", $sum) . $r;
-
- if ($main::opt_debug and $main::opt_test) { print STDERR "$r\n"; }
-
- return $r;
- }
-}
-
-
-# Subtract two hex addresses of length $address_length.
-# Run pprof --test for unit test if this is changed.
-sub AddressSub {
- my $addr1 = shift;
- my $addr2 = shift;
- my $diff;
-
- if ($address_length == 8) {
- # Perl doesn't cope with wraparound arithmetic, so do it explicitly:
- $diff = (hex($addr1)-hex($addr2)) % (0x10000000 * 16);
- return sprintf("%08x", $diff);
-
- } else {
- # Do the addition in 7-nibble chunks to trivialize borrow handling.
- # if ($main::opt_debug) { print STDERR "AddressSub $addr1 - $addr2 = "; }
-
- my $a1 = hex(substr($addr1,-7));
- $addr1 = substr($addr1,0,-7);
- my $a2 = hex(substr($addr2,-7));
- $addr2 = substr($addr2,0,-7);
- my $b = 0;
- if ($a2 > $a1) {
- $b = 1;
- $a1 += 0x10000000;
- }
- $diff = $a1 - $a2;
- my $r = sprintf("%07x", $diff);
-
- $a1 = hex(substr($addr1,-7));
- $addr1 = substr($addr1,0,-7);
- $a2 = hex(substr($addr2,-7)) + $b;
- $addr2 = substr($addr2,0,-7);
- $b = 0;
- if ($a2 > $a1) {
- $b = 1;
- $a1 += 0x10000000;
- }
- $diff = $a1 - $a2;
- $r = sprintf("%07x", $diff) . $r;
-
- $a1 = hex($addr1);
- $a2 = hex($addr2) + $b;
- if ($a2 > $a1) { $a1 += 0x100; }
- $diff = $a1 - $a2;
- $r = sprintf("%02x", $diff) . $r;
-
- # if ($main::opt_debug) { print STDERR "$r\n"; }
-
- return $r;
- }
-}
-
-# Increment a hex addresses of length $address_length.
-# Run pprof --test for unit test if this is changed.
-sub AddressInc {
- my $addr = shift;
- my $sum;
-
- if ($address_length == 8) {
- # Perl doesn't cope with wraparound arithmetic, so do it explicitly:
- $sum = (hex($addr)+1) % (0x10000000 * 16);
- return sprintf("%08x", $sum);
-
- } else {
- # Do the addition in 7-nibble chunks to trivialize carry handling.
- # We are always doing this to step through the addresses in a function,
- # and will almost never overflow the first chunk, so we check for this
- # case and exit early.
-
- # if ($main::opt_debug) { print STDERR "AddressInc $addr1 = "; }
-
- my $a1 = substr($addr,-7);
- $addr = substr($addr,0,-7);
- $sum = hex($a1) + 1;
- my $r = sprintf("%07x", $sum);
- if ($sum <= 0xfffffff) {
- $r = $addr . $r;
- # if ($main::opt_debug) { print STDERR "$r\n"; }
- return HexExtend($r);
- } else {
- $r = "0000000";
- }
-
- $a1 = substr($addr,-7);
- $addr = substr($addr,0,-7);
- $sum = hex($a1) + 1;
- $r = sprintf("%07x", $sum) . $r;
- if ($sum <= 0xfffffff) {
- $r = $addr . $r;
- # if ($main::opt_debug) { print STDERR "$r\n"; }
- return HexExtend($r);
- } else {
- $r = "00000000000000";
- }
-
- $sum = hex($addr) + 1;
- if ($sum > 0xff) { $sum -= 0x100; }
- $r = sprintf("%02x", $sum) . $r;
-
- # if ($main::opt_debug) { print STDERR "$r\n"; }
- return $r;
- }
-}
-
-# Extract symbols for all PC values found in profile
-sub ExtractSymbols {
- my $libs = shift;
- my $pcset = shift;
-
- my $symbols = {};
-
- # Map each PC value to the containing library
- my %seen = ();
- foreach my $lib (@{$libs}) {
- my $libname = $lib->[0];
- my $start = $lib->[1];
- my $finish = $lib->[2];
- my $offset = $lib->[3];
-
- # Get list of pcs that belong in this library.
- my $contained = [];
- foreach my $pc (keys(%{$pcset})) {
- if (!$seen{$pc} && ($pc ge $start) && ($pc le $finish)) {
- $seen{$pc} = 1;
- push(@{$contained}, $pc);
- }
- }
- # Map to symbols
- MapToSymbols($libname, AddressSub($start, $offset), $contained, $symbols);
- }
-
- return $symbols;
-}
-
-# Map list of PC values to symbols for a given image
-sub MapToSymbols {
- my $image = shift;
- my $offset = shift;
- my $pclist = shift;
- my $symbols = shift;
-
- my $debug = 0;
-
- # Ignore empty binaries
- if ($#{$pclist} < 0) { return; }
-
- # Figure out the addr2line command to use
- my $addr2line = $obj_tool_map{"addr2line"};
- my $cmd = "$addr2line -f -C -e $image";
- if (exists $obj_tool_map{"addr2line_pdb"}) {
- $addr2line = $obj_tool_map{"addr2line_pdb"};
- $cmd = "$addr2line --demangle -f -C -e $image";
- }
-
- # If "addr2line" isn't installed on the system at all, just use
- # nm to get what info we can (function names, but not line numbers).
- if (system("$addr2line --help >/dev/null 2>&1") != 0) {
- MapSymbolsWithNM($image, $offset, $pclist, $symbols);
- return;
- }
-
- # "addr2line -i" can produce a variable number of lines per input
- # address, with no separator that allows us to tell when data for
- # the next address starts. So we find the address for a special
- # symbol (_fini) and interleave this address between all real
- # addresses passed to addr2line. The name of this special symbol
- # can then be used as a separator.
- $sep_address = undef; # May be filled in by MapSymbolsWithNM()
- my $nm_symbols = {};
- MapSymbolsWithNM($image, $offset, $pclist, $nm_symbols);
- # TODO(csilvers): only add '-i' if addr2line supports it.
- if (defined($sep_address)) {
- # Only add " -i" to addr2line if the binary supports it.
- # addr2line --help returns 0, but not if it sees an unknown flag first.
- if (system("$cmd -i --help >/dev/null 2>&1") == 0) {
- $cmd .= " -i";
- } else {
- $sep_address = undef; # no need for sep_address if we don't support -i
- }
- }
-
- # Make file with all PC values with intervening 'sep_address' so
- # that we can reliably detect the end of inlined function list
- open(ADDRESSES, ">$main::tmpfile_sym") || error("$main::tmpfile_sym: $!\n");
- if ($debug) { print("---- $image ---\n"); }
- for (my $i = 0; $i <= $#{$pclist}; $i++) {
- # addr2line always reads hex addresses, and does not need '0x' prefix.
- if ($debug) { printf STDERR ("%s\n", $pclist->[$i]); }
- printf ADDRESSES ("%s\n", AddressSub($pclist->[$i], $offset));
- if (defined($sep_address)) {
- printf ADDRESSES ("%s\n", $sep_address);
- }
- }
- close(ADDRESSES);
- if ($debug) {
- print("----\n");
- system("cat $main::tmpfile_sym");
- print("----\n");
- system("$cmd <$main::tmpfile_sym");
- print("----\n");
- }
-
- open(SYMBOLS, "$cmd <$main::tmpfile_sym |") || error("$cmd: $!\n");
- my $count = 0; # Index in pclist
- while (<SYMBOLS>) {
- # Read fullfunction and filelineinfo from next pair of lines
- s/\r?\n$//g;
- my $fullfunction = $_;
- $_ = <SYMBOLS>;
- s/\r?\n$//g;
- my $filelinenum = $_;
-
- if (defined($sep_address) && $fullfunction eq $sep_symbol) {
- # Terminating marker for data for this address
- $count++;
- next;
- }
-
- $filelinenum =~ s|\\|/|g; # turn windows-style paths into unix-style paths
-
- my $pcstr = $pclist->[$count];
- my $function = ShortFunctionName($fullfunction);
- if ($fullfunction eq '??') {
- # See if nm found a symbol
- my $nms = $nm_symbols->{$pcstr};
- if (defined($nms)) {
- $function = $nms->[0];
- $fullfunction = $nms->[2];
- }
- }
-
- # Prepend to accumulated symbols for pcstr
- # (so that caller comes before callee)
- my $sym = $symbols->{$pcstr};
- if (!defined($sym)) {
- $sym = [];
- $symbols->{$pcstr} = $sym;
- }
- unshift(@{$sym}, $function, $filelinenum, $fullfunction);
- if ($debug) { printf STDERR ("%s => [%s]\n", $pcstr, join(" ", @{$sym})); }
- if (!defined($sep_address)) {
- # Inlining is off, se this entry ends immediately
- $count++;
- }
- }
- close(SYMBOLS);
-}
-
-# Use nm to map the list of referenced PCs to symbols. Return true iff we
-# are able to read procedure information via nm.
-sub MapSymbolsWithNM {
- my $image = shift;
- my $offset = shift;
- my $pclist = shift;
- my $symbols = shift;
-
- # Get nm output sorted by increasing address
- my $symbol_table = GetProcedureBoundaries($image, ".");
- if (!%{$symbol_table}) {
- return 0;
- }
- # Start addresses are already the right length (8 or 16 hex digits).
- my @names = sort { $symbol_table->{$a}->[0] cmp $symbol_table->{$b}->[0] }
- keys(%{$symbol_table});
-
- if ($#names < 0) {
- # No symbols: just use addresses
- foreach my $pc (@{$pclist}) {
- my $pcstr = "0x" . $pc;
- $symbols->{$pc} = [$pcstr, "?", $pcstr];
- }
- return 0;
- }
-
- # Sort addresses so we can do a join against nm output
- my $index = 0;
- my $fullname = $names[0];
- my $name = ShortFunctionName($fullname);
- foreach my $pc (sort { $a cmp $b } @{$pclist}) {
- # Adjust for mapped offset
- my $mpc = AddressSub($pc, $offset);
- while (($index < $#names) && ($mpc ge $symbol_table->{$fullname}->[1])){
- $index++;
- $fullname = $names[$index];
- $name = ShortFunctionName($fullname);
- }
- if ($mpc lt $symbol_table->{$fullname}->[1]) {
- $symbols->{$pc} = [$name, "?", $fullname];
- } else {
- my $pcstr = "0x" . $pc;
- $symbols->{$pc} = [$pcstr, "?", $pcstr];
- }
- }
- return 1;
-}
-
-sub ShortFunctionName {
- my $function = shift;
- while ($function =~ s/\([^()]*\)(\s*const)?//g) { } # Argument types
- while ($function =~ s/<[^<>]*>//g) { } # Remove template arguments
- $function =~ s/^.*\s+(\w+::)/$1/; # Remove leading type
- return $function;
-}
-
-# Trim overly long symbols found in disassembler output
-sub CleanDisassembly {
- my $d = shift;
- while ($d =~ s/\([^()%]*\)(\s*const)?//g) { } # Argument types, not (%rax)
- while ($d =~ s/(\w+)<[^<>]*>/$1/g) { } # Remove template arguments
- return $d;
-}
-
-##### Miscellaneous #####
-
-# Find the right versions of the above object tools to use. The
-# argument is the program file being analyzed, and should be an ELF
-# 32-bit or ELF 64-bit executable file. The location of the tools
-# is determined by considering the following options in this order:
-# 1) --tools option, if set
-# 2) PPROF_TOOLS environment variable, if set
-# 3) the environment
-sub ConfigureObjTools {
- my $prog_file = shift;
-
- # Check for the existence of $prog_file because /usr/bin/file does not
- # predictably return error status in prod.
- (-e $prog_file) || error("$prog_file does not exist.\n");
-
- # Follow symlinks (at least for systems where "file" supports that)
- my $file_type = `/usr/bin/file -L $prog_file 2>/dev/null || /usr/bin/file $prog_file`;
- if ($file_type =~ /64-bit/) {
- # Change $address_length to 16 if the program file is ELF 64-bit.
- # We can't detect this from many (most?) heap or lock contention
- # profiles, since the actual addresses referenced are generally in low
- # memory even for 64-bit programs.
- $address_length = 16;
- }
-
- if ($file_type =~ /MS Windows/) {
- # For windows, we provide a version of nm and addr2line as part of
- # the opensource release, which is capable of parsing
- # Windows-style PDB executables. It should live in the path, or
- # in the same directory as pprof.
- $obj_tool_map{"nm_pdb"} = "nm-pdb";
- $obj_tool_map{"addr2line_pdb"} = "addr2line-pdb";
- }
-
- if ($file_type =~ /Mach-O/) {
- # OS X uses otool to examine Mach-O files, rather than objdump.
- $obj_tool_map{"otool"} = "otool";
- $obj_tool_map{"addr2line"} = "false"; # no addr2line
- $obj_tool_map{"objdump"} = "false"; # no objdump
- }
-
- # Go fill in %obj_tool_map with the pathnames to use:
- foreach my $tool (keys %obj_tool_map) {
- $obj_tool_map{$tool} = ConfigureTool($obj_tool_map{$tool});
- }
-}
-
-# Returns the path of a caller-specified object tool. If --tools or
-# PPROF_TOOLS are specified, then returns the full path to the tool
-# with that prefix. Otherwise, returns the path unmodified (which
-# means we will look for it on PATH).
-sub ConfigureTool {
- my $tool = shift;
- my $path;
-
- if ($main::opt_tools ne "") {
- # Use a prefix specified by the --tools option...
- $path = $main::opt_tools . $tool;
- if (!-x $path) {
- error("No '$tool' found with prefix specified by --tools $main::opt_tools\n");
- }
- } elsif (exists $ENV{"PPROF_TOOLS"} &&
- $ENV{"PPROF_TOOLS"} ne "") {
- #... or specified with the PPROF_TOOLS environment variable...
- $path = $ENV{"PPROF_TOOLS"} . $tool;
- if (!-x $path) {
- error("No '$tool' found with prefix specified by PPROF_TOOLS=$ENV{PPROF_TOOLS}\n");
- }
- } else {
- # ... otherwise use the version that exists in the same directory as
- # pprof. If there's nothing there, use $PATH.
- $0 =~ m,[^/]*$,; # this is everything after the last slash
- my $dirname = $`; # this is everything up to and including the last slash
- if (-x "$dirname$tool") {
- $path = "$dirname$tool";
- } else {
- $path = $tool;
- }
- }
- if ($main::opt_debug) { print STDERR "Using '$path' for '$tool'.\n"; }
- return $path;
-}
-
-sub cleanup {
- unlink($main::tmpfile_sym);
- unlink(keys %main::tempnames);
-
- # We leave any collected profiles in $HOME/pprof in case the user wants
- # to look at them later. We print a message informing them of this.
- if ((scalar(@main::profile_files) > 0) &&
- defined($main::collected_profile)) {
- if (scalar(@main::profile_files) == 1) {
- print STDERR "Dynamically gathered profile is in $main::collected_profile\n";
- }
- print STDERR "If you want to investigate this profile further, you can do:\n";
- print STDERR "\n";
- print STDERR " pprof \\\n";
- print STDERR " $main::prog \\\n";
- print STDERR " $main::collected_profile\n";
- print STDERR "\n";
- }
-}
-
-sub sighandler {
- cleanup();
- exit(1);
-}
-
-sub error {
- my $msg = shift;
- print STDERR $msg;
- cleanup();
- exit(1);
-}
-
-
-# Run $nm_command and get all the resulting procedure boundaries whose
-# names match "$regexp" and returns them in a hashtable mapping from
-# procedure name to a two-element vector of [start address, end address]
-sub GetProcedureBoundariesViaNm {
- my $nm_command = shift;
- my $regexp = shift;
-
- my $symbol_table = {};
- open(NM, "$nm_command |") || error("$nm_command: $!\n");
- my $last_start = "0";
- my $routine = "";
- while (<NM>) {
- s/\r//g; # turn windows-looking lines into unix-looking lines
- if (m/^\s*([0-9a-f]+) (.) (..*)/) {
- my $start_val = $1;
- my $type = $2;
- my $this_routine = $3;
-
- # It's possible for two symbols to share the same address, if
- # one is a zero-length variable (like __start_google_malloc) or
- # one symbol is a weak alias to another (like __libc_malloc).
- # In such cases, we want to ignore all values except for the
- # actual symbol, which in nm-speak has type "T". The logic
- # below does this, though it's a bit tricky: what happens when
- # we have a series of lines with the same address, is the first
- # one gets queued up to be processed. However, it won't
- # *actually* be processed until later, when we read a line with
- # a different address. That means that as long as we're reading
- # lines with the same address, we have a chance to replace that
- # item in the queue, which we do whenever we see a 'T' entry --
- # that is, a line with type 'T'. If we never see a 'T' entry,
- # we'll just go ahead and process the first entry (which never
- # got touched in the queue), and ignore the others.
- if ($start_val eq $last_start && $type =~ /t/i) {
- # We are the 'T' symbol at this address, replace previous symbol.
- $routine = $this_routine;
- next;
- } elsif ($start_val eq $last_start) {
- # We're not the 'T' symbol at this address, so ignore us.
- next;
- }
-
- if ($this_routine eq $sep_symbol) {
- $sep_address = HexExtend($start_val);
- }
-
- # Tag this routine with the starting address in case the image
- # has multiple occurrences of this routine. We use a syntax
- # that resembles template paramters that are automatically
- # stripped out by ShortFunctionName()
- $this_routine .= "<$start_val>";
-
- if (defined($routine) && $routine =~ m/$regexp/) {
- $symbol_table->{$routine} = [HexExtend($last_start),
- HexExtend($start_val)];
- }
- $last_start = $start_val;
- $routine = $this_routine;
- } elsif (m/^Loaded image name: (.+)/) {
- # The win32 nm workalike emits information about the binary it is using.
- if ($main::opt_debug) { print STDERR "Using Image $1\n"; }
- } elsif (m/^PDB file name: (.+)/) {
- # The win32 nm workalike emits information about the pdb it is using.
- if ($main::opt_debug) { print STDERR "Using PDB $1\n"; }
- }
- }
- close(NM);
- # Handle the last line in the nm output. Unfortunately, we don't know
- # how big this last symbol is, because we don't know how big the file
- # is. For now, we just give it a size of 0.
- # TODO(csilvers): do better here.
- if (defined($routine) && $routine =~ m/$regexp/) {
- $symbol_table->{$routine} = [HexExtend($last_start),
- HexExtend($last_start)];
- }
- return $symbol_table;
-}
-
-# Gets the procedure boundaries for all routines in "$image" whose names
-# match "$regexp" and returns them in a hashtable mapping from procedure
-# name to a two-element vector of [start address, end address].
-# Will return an empty map if nm is not installed or not working properly.
-sub GetProcedureBoundaries {
- my $image = shift;
- my $regexp = shift;
-
- # For libc libraries, the copy in /usr/lib/debug contains debugging symbols
- my $debugging = DebuggingLibrary($image);
- if ($debugging) {
- $image = $debugging;
- }
-
- my $nm = $obj_tool_map{"nm"};
- my $cppfilt = $obj_tool_map{"c++filt"};
-
- # nm can fail for two reasons: 1) $image isn't a debug library; 2) nm
- # binary doesn't support --demangle. In addition, for OS X we need
- # to use the -f flag to get 'flat' nm output (otherwise we don't sort
- # properly and get incorrect results). Unfortunately, GNU nm uses -f
- # in an incompatible way. So first we test whether our nm supports
- # --demangle and -f.
- my $demangle_flag = "";
- my $cppfilt_flag = "";
- if (system("$nm --demangle $image >/dev/null 2>&1") == 0) {
- # In this mode, we do "nm --demangle <foo>"
- $demangle_flag = "--demangle";
- $cppfilt_flag = "";
- } elsif (system("$cppfilt $image >/dev/null 2>&1") == 0) {
- # In this mode, we do "nm <foo> | c++filt"
- $cppfilt_flag = " | $cppfilt";
- };
- my $flatten_flag = "";
- if (system("$nm -f $image >/dev/null 2>&1") == 0) {
- $flatten_flag = "-f";
- }
-
- # Finally, in the case $imagie isn't a debug library, we try again with
- # -D to at least get *exported* symbols. If we can't use --demangle,
- # we use c++filt instead, if it exists on this system.
- my @nm_commands = ("$nm -n $flatten_flag $demangle_flag" .
- " $image 2>/dev/null $cppfilt_flag",
- "$nm -D -n $flatten_flag $demangle_flag" .
- " $image 2>/dev/null $cppfilt_flag",
- # 6nm is for Go binaries
- "6nm $image 2>/dev/null | sort");
-
- # If the executable is an MS Windows PDB-format executable, we'll
- # have set up obj_tool_map("nm_pdb"). In this case, we actually
- # want to use both unix nm and windows-specific nm_pdb, since
- # PDB-format executables can apparently include dwarf .o files.
- if (exists $obj_tool_map{"nm_pdb"}) {
- my $nm_pdb = $obj_tool_map{"nm_pdb"};
- push(@nm_commands, "$nm_pdb --demangle $image 2>/dev/null");
- }
-
- foreach my $nm_command (@nm_commands) {
- my $symbol_table = GetProcedureBoundariesViaNm($nm_command, $regexp);
- return $symbol_table if (%{$symbol_table});
- }
- my $symbol_table = {};
- return $symbol_table;
-}
-
-
-# The test vectors for AddressAdd/Sub/Inc are 8-16-nibble hex strings.
-# To make them more readable, we add underscores at interesting places.
-# This routine removes the underscores, producing the canonical representation
-# used by pprof to represent addresses, particularly in the tested routines.
-sub CanonicalHex {
- my $arg = shift;
- return join '', (split '_',$arg);
-}
-
-
-# Unit test for AddressAdd:
-sub AddressAddUnitTest {
- my $test_data_8 = shift;
- my $test_data_16 = shift;
- my $error_count = 0;
- my $fail_count = 0;
- my $pass_count = 0;
- # print STDERR "AddressAddUnitTest: ", 1+$#{$test_data_8}, " tests\n";
-
- # First a few 8-nibble addresses. Note that this implementation uses
- # plain old arithmetic, so a quick sanity check along with verifying what
- # happens to overflow (we want it to wrap):
- $address_length = 8;
- foreach my $row (@{$test_data_8}) {
- if ($main::opt_debug and $main::opt_test) { print STDERR "@{$row}\n"; }
- my $sum = AddressAdd ($row->[0], $row->[1]);
- if ($sum ne $row->[2]) {
- printf STDERR "ERROR: %s != %s + %s = %s\n", $sum,
- $row->[0], $row->[1], $row->[2];
- ++$fail_count;
- } else {
- ++$pass_count;
- }
- }
- printf STDERR "AddressAdd 32-bit tests: %d passes, %d failures\n",
- $pass_count, $fail_count;
- $error_count = $fail_count;
- $fail_count = 0;
- $pass_count = 0;
-
- # Now 16-nibble addresses.
- $address_length = 16;
- foreach my $row (@{$test_data_16}) {
- if ($main::opt_debug and $main::opt_test) { print STDERR "@{$row}\n"; }
- my $sum = AddressAdd (CanonicalHex($row->[0]), CanonicalHex($row->[1]));
- my $expected = join '', (split '_',$row->[2]);
- if ($sum ne CanonicalHex($row->[2])) {
- printf STDERR "ERROR: %s != %s + %s = %s\n", $sum,
- $row->[0], $row->[1], $row->[2];
- ++$fail_count;
- } else {
- ++$pass_count;
- }
- }
- printf STDERR "AddressAdd 64-bit tests: %d passes, %d failures\n",
- $pass_count, $fail_count;
- $error_count += $fail_count;
-
- return $error_count;
-}
-
-
-# Unit test for AddressSub:
-sub AddressSubUnitTest {
- my $test_data_8 = shift;
- my $test_data_16 = shift;
- my $error_count = 0;
- my $fail_count = 0;
- my $pass_count = 0;
- # print STDERR "AddressSubUnitTest: ", 1+$#{$test_data_8}, " tests\n";
-
- # First a few 8-nibble addresses. Note that this implementation uses
- # plain old arithmetic, so a quick sanity check along with verifying what
- # happens to overflow (we want it to wrap):
- $address_length = 8;
- foreach my $row (@{$test_data_8}) {
- if ($main::opt_debug and $main::opt_test) { print STDERR "@{$row}\n"; }
- my $sum = AddressSub ($row->[0], $row->[1]);
- if ($sum ne $row->[3]) {
- printf STDERR "ERROR: %s != %s - %s = %s\n", $sum,
- $row->[0], $row->[1], $row->[3];
- ++$fail_count;
- } else {
- ++$pass_count;
- }
- }
- printf STDERR "AddressSub 32-bit tests: %d passes, %d failures\n",
- $pass_count, $fail_count;
- $error_count = $fail_count;
- $fail_count = 0;
- $pass_count = 0;
-
- # Now 16-nibble addresses.
- $address_length = 16;
- foreach my $row (@{$test_data_16}) {
- if ($main::opt_debug and $main::opt_test) { print STDERR "@{$row}\n"; }
- my $sum = AddressSub (CanonicalHex($row->[0]), CanonicalHex($row->[1]));
- if ($sum ne CanonicalHex($row->[3])) {
- printf STDERR "ERROR: %s != %s - %s = %s\n", $sum,
- $row->[0], $row->[1], $row->[3];
- ++$fail_count;
- } else {
- ++$pass_count;
- }
- }
- printf STDERR "AddressSub 64-bit tests: %d passes, %d failures\n",
- $pass_count, $fail_count;
- $error_count += $fail_count;
-
- return $error_count;
-}
-
-
-# Unit test for AddressInc:
-sub AddressIncUnitTest {
- my $test_data_8 = shift;
- my $test_data_16 = shift;
- my $error_count = 0;
- my $fail_count = 0;
- my $pass_count = 0;
- # print STDERR "AddressIncUnitTest: ", 1+$#{$test_data_8}, " tests\n";
-
- # First a few 8-nibble addresses. Note that this implementation uses
- # plain old arithmetic, so a quick sanity check along with verifying what
- # happens to overflow (we want it to wrap):
- $address_length = 8;
- foreach my $row (@{$test_data_8}) {
- if ($main::opt_debug and $main::opt_test) { print STDERR "@{$row}\n"; }
- my $sum = AddressInc ($row->[0]);
- if ($sum ne $row->[4]) {
- printf STDERR "ERROR: %s != %s + 1 = %s\n", $sum,
- $row->[0], $row->[4];
- ++$fail_count;
- } else {
- ++$pass_count;
- }
- }
- printf STDERR "AddressInc 32-bit tests: %d passes, %d failures\n",
- $pass_count, $fail_count;
- $error_count = $fail_count;
- $fail_count = 0;
- $pass_count = 0;
-
- # Now 16-nibble addresses.
- $address_length = 16;
- foreach my $row (@{$test_data_16}) {
- if ($main::opt_debug and $main::opt_test) { print STDERR "@{$row}\n"; }
- my $sum = AddressInc (CanonicalHex($row->[0]));
- if ($sum ne CanonicalHex($row->[4])) {
- printf STDERR "ERROR: %s != %s + 1 = %s\n", $sum,
- $row->[0], $row->[4];
- ++$fail_count;
- } else {
- ++$pass_count;
- }
- }
- printf STDERR "AddressInc 64-bit tests: %d passes, %d failures\n",
- $pass_count, $fail_count;
- $error_count += $fail_count;
-
- return $error_count;
-}
-
-
-# Driver for unit tests.
-# Currently just the address add/subtract/increment routines for 64-bit.
-sub RunUnitTests {
- my $error_count = 0;
-
- # This is a list of tuples [a, b, a+b, a-b, a+1]
- my $unit_test_data_8 = [
- [qw(aaaaaaaa 50505050 fafafafa 5a5a5a5a aaaaaaab)],
- [qw(50505050 aaaaaaaa fafafafa a5a5a5a6 50505051)],
- [qw(ffffffff aaaaaaaa aaaaaaa9 55555555 00000000)],
- [qw(00000001 ffffffff 00000000 00000002 00000002)],
- [qw(00000001 fffffff0 fffffff1 00000011 00000002)],
- ];
- my $unit_test_data_16 = [
- # The implementation handles data in 7-nibble chunks, so those are the
- # interesting boundaries.
- [qw(aaaaaaaa 50505050
- 00_000000f_afafafa 00_0000005_a5a5a5a 00_000000a_aaaaaab)],
- [qw(50505050 aaaaaaaa
- 00_000000f_afafafa ff_ffffffa_5a5a5a6 00_0000005_0505051)],
- [qw(ffffffff aaaaaaaa
- 00_000001a_aaaaaa9 00_0000005_5555555 00_0000010_0000000)],
- [qw(00000001 ffffffff
- 00_0000010_0000000 ff_ffffff0_0000002 00_0000000_0000002)],
- [qw(00000001 fffffff0
- 00_000000f_ffffff1 ff_ffffff0_0000011 00_0000000_0000002)],
-
- [qw(00_a00000a_aaaaaaa 50505050
- 00_a00000f_afafafa 00_a000005_a5a5a5a 00_a00000a_aaaaaab)],
- [qw(0f_fff0005_0505050 aaaaaaaa
- 0f_fff000f_afafafa 0f_ffefffa_5a5a5a6 0f_fff0005_0505051)],
- [qw(00_000000f_fffffff 01_800000a_aaaaaaa
- 01_800001a_aaaaaa9 fe_8000005_5555555 00_0000010_0000000)],
- [qw(00_0000000_0000001 ff_fffffff_fffffff
- 00_0000000_0000000 00_0000000_0000002 00_0000000_0000002)],
- [qw(00_0000000_0000001 ff_fffffff_ffffff0
- ff_fffffff_ffffff1 00_0000000_0000011 00_0000000_0000002)],
- ];
-
- $error_count += AddressAddUnitTest($unit_test_data_8, $unit_test_data_16);
- $error_count += AddressSubUnitTest($unit_test_data_8, $unit_test_data_16);
- $error_count += AddressIncUnitTest($unit_test_data_8, $unit_test_data_16);
- if ($error_count > 0) {
- print STDERR $error_count, " errors: FAILED\n";
- } else {
- print STDERR "PASS\n";
- }
- exit ($error_count);
-}
generated by cgit v1.2.3 (git 2.39.1) at 2025-02-16 11:47:06 +0000