1.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
1.2 +++ b/memory/jemalloc/src/bin/pprof Wed Dec 31 06:09:35 2014 +0100
1.3 @@ -0,0 +1,5348 @@
1.4 +#! /usr/bin/env perl
1.5 +
1.6 +# Copyright (c) 1998-2007, Google Inc.
1.7 +# All rights reserved.
1.8 +#
1.9 +# Redistribution and use in source and binary forms, with or without
1.10 +# modification, are permitted provided that the following conditions are
1.11 +# met:
1.12 +#
1.13 +# * Redistributions of source code must retain the above copyright
1.14 +# notice, this list of conditions and the following disclaimer.
1.15 +# * Redistributions in binary form must reproduce the above
1.16 +# copyright notice, this list of conditions and the following disclaimer
1.17 +# in the documentation and/or other materials provided with the
1.18 +# distribution.
1.19 +# * Neither the name of Google Inc. nor the names of its
1.20 +# contributors may be used to endorse or promote products derived from
1.21 +# this software without specific prior written permission.
1.22 +#
1.23 +# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
1.24 +# "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
1.25 +# LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
1.26 +# A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
1.27 +# OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
1.28 +# SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
1.29 +# LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
1.30 +# DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
1.31 +# THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
1.32 +# (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
1.33 +# OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
1.34 +
1.35 +# ---
1.36 +# Program for printing the profile generated by common/profiler.cc,
1.37 +# or by the heap profiler (common/debugallocation.cc)
1.38 +#
1.39 +# The profile contains a sequence of entries of the form:
1.40 +# <count> <stack trace>
1.41 +# This program parses the profile, and generates user-readable
1.42 +# output.
1.43 +#
1.44 +# Examples:
1.45 +#
1.46 +# % tools/pprof "program" "profile"
1.47 +# Enters "interactive" mode
1.48 +#
1.49 +# % tools/pprof --text "program" "profile"
1.50 +# Generates one line per procedure
1.51 +#
1.52 +# % tools/pprof --gv "program" "profile"
1.53 +# Generates annotated call-graph and displays via "gv"
1.54 +#
1.55 +# % tools/pprof --gv --focus=Mutex "program" "profile"
1.56 +# Restrict to code paths that involve an entry that matches "Mutex"
1.57 +#
1.58 +# % tools/pprof --gv --focus=Mutex --ignore=string "program" "profile"
1.59 +# Restrict to code paths that involve an entry that matches "Mutex"
1.60 +# and does not match "string"
1.61 +#
1.62 +# % tools/pprof --list=IBF_CheckDocid "program" "profile"
1.63 +# Generates disassembly listing of all routines with at least one
1.64 +# sample that match the --list=<regexp> pattern. The listing is
1.65 +# annotated with the flat and cumulative sample counts at each line.
1.66 +#
1.67 +# % tools/pprof --disasm=IBF_CheckDocid "program" "profile"
1.68 +# Generates disassembly listing of all routines with at least one
1.69 +# sample that match the --disasm=<regexp> pattern. The listing is
1.70 +# annotated with the flat and cumulative sample counts at each PC value.
1.71 +#
1.72 +# TODO: Use color to indicate files?
1.73 +
1.74 +use strict;
1.75 +use warnings;
1.76 +use Getopt::Long;
1.77 +
1.78 +my $PPROF_VERSION = "2.0";
1.79 +
1.80 +# These are the object tools we use which can come from a
1.81 +# user-specified location using --tools, from the PPROF_TOOLS
1.82 +# environment variable, or from the environment.
1.83 +my %obj_tool_map = (
1.84 + "objdump" => "objdump",
1.85 + "nm" => "nm",
1.86 + "addr2line" => "addr2line",
1.87 + "c++filt" => "c++filt",
1.88 + ## ConfigureObjTools may add architecture-specific entries:
1.89 + #"nm_pdb" => "nm-pdb", # for reading windows (PDB-format) executables
1.90 + #"addr2line_pdb" => "addr2line-pdb", # ditto
1.91 + #"otool" => "otool", # equivalent of objdump on OS X
1.92 +);
1.93 +# NOTE: these are lists, so you can put in commandline flags if you want.
1.94 +my @DOT = ("dot"); # leave non-absolute, since it may be in /usr/local
1.95 +my @GV = ("gv");
1.96 +my @EVINCE = ("evince"); # could also be xpdf or perhaps acroread
1.97 +my @KCACHEGRIND = ("kcachegrind");
1.98 +my @PS2PDF = ("ps2pdf");
1.99 +# These are used for dynamic profiles
1.100 +my @URL_FETCHER = ("curl", "-s");
1.101 +
1.102 +# These are the web pages that servers need to support for dynamic profiles
1.103 +my $HEAP_PAGE = "/pprof/heap";
1.104 +my $PROFILE_PAGE = "/pprof/profile"; # must support cgi-param "?seconds=#"
1.105 +my $PMUPROFILE_PAGE = "/pprof/pmuprofile(?:\\?.*)?"; # must support cgi-param
1.106 + # ?seconds=#&event=x&period=n
1.107 +my $GROWTH_PAGE = "/pprof/growth";
1.108 +my $CONTENTION_PAGE = "/pprof/contention";
1.109 +my $WALL_PAGE = "/pprof/wall(?:\\?.*)?"; # accepts options like namefilter
1.110 +my $FILTEREDPROFILE_PAGE = "/pprof/filteredprofile(?:\\?.*)?";
1.111 +my $CENSUSPROFILE_PAGE = "/pprof/censusprofile(?:\\?.*)?"; # must support cgi-param
1.112 + # "?seconds=#",
1.113 + # "?tags_regexp=#" and
1.114 + # "?type=#".
1.115 +my $SYMBOL_PAGE = "/pprof/symbol"; # must support symbol lookup via POST
1.116 +my $PROGRAM_NAME_PAGE = "/pprof/cmdline";
1.117 +
1.118 +# These are the web pages that can be named on the command line.
1.119 +# All the alternatives must begin with /.
1.120 +my $PROFILES = "($HEAP_PAGE|$PROFILE_PAGE|$PMUPROFILE_PAGE|" .
1.121 + "$GROWTH_PAGE|$CONTENTION_PAGE|$WALL_PAGE|" .
1.122 + "$FILTEREDPROFILE_PAGE|$CENSUSPROFILE_PAGE)";
1.123 +
1.124 +# default binary name
1.125 +my $UNKNOWN_BINARY = "(unknown)";
1.126 +
1.127 +# There is a pervasive dependency on the length (in hex characters,
1.128 +# i.e., nibbles) of an address, distinguishing between 32-bit and
1.129 +# 64-bit profiles. To err on the safe size, default to 64-bit here:
1.130 +my $address_length = 16;
1.131 +
1.132 +my $dev_null = "/dev/null";
1.133 +if (! -e $dev_null && $^O =~ /MSWin/) { # $^O is the OS perl was built for
1.134 + $dev_null = "nul";
1.135 +}
1.136 +
1.137 +# A list of paths to search for shared object files
1.138 +my @prefix_list = ();
1.139 +
1.140 +# Special routine name that should not have any symbols.
1.141 +# Used as separator to parse "addr2line -i" output.
1.142 +my $sep_symbol = '_fini';
1.143 +my $sep_address = undef;
1.144 +
1.145 +##### Argument parsing #####
1.146 +
1.147 +sub usage_string {
1.148 + return <<EOF;
1.149 +Usage:
1.150 +pprof [options] <program> <profiles>
1.151 + <profiles> is a space separated list of profile names.
1.152 +pprof [options] <symbolized-profiles>
1.153 + <symbolized-profiles> is a list of profile files where each file contains
1.154 + the necessary symbol mappings as well as profile data (likely generated
1.155 + with --raw).
1.156 +pprof [options] <profile>
1.157 + <profile> is a remote form. Symbols are obtained from host:port$SYMBOL_PAGE
1.158 +
1.159 + Each name can be:
1.160 + /path/to/profile - a path to a profile file
1.161 + host:port[/<service>] - a location of a service to get profile from
1.162 +
1.163 + The /<service> can be $HEAP_PAGE, $PROFILE_PAGE, /pprof/pmuprofile,
1.164 + $GROWTH_PAGE, $CONTENTION_PAGE, /pprof/wall,
1.165 + $CENSUSPROFILE_PAGE, or /pprof/filteredprofile.
1.166 + For instance:
1.167 + pprof http://myserver.com:80$HEAP_PAGE
1.168 + If /<service> is omitted, the service defaults to $PROFILE_PAGE (cpu profiling).
1.169 +pprof --symbols <program>
1.170 + Maps addresses to symbol names. In this mode, stdin should be a
1.171 + list of library mappings, in the same format as is found in the heap-
1.172 + and cpu-profile files (this loosely matches that of /proc/self/maps
1.173 + on linux), followed by a list of hex addresses to map, one per line.
1.174 +
1.175 + For more help with querying remote servers, including how to add the
1.176 + necessary server-side support code, see this filename (or one like it):
1.177 +
1.178 + /usr/doc/gperftools-$PPROF_VERSION/pprof_remote_servers.html
1.179 +
1.180 +Options:
1.181 + --cum Sort by cumulative data
1.182 + --base=<base> Subtract <base> from <profile> before display
1.183 + --interactive Run in interactive mode (interactive "help" gives help) [default]
1.184 + --seconds=<n> Length of time for dynamic profiles [default=30 secs]
1.185 + --add_lib=<file> Read additional symbols and line info from the given library
1.186 + --lib_prefix=<dir> Comma separated list of library path prefixes
1.187 +
1.188 +Reporting Granularity:
1.189 + --addresses Report at address level
1.190 + --lines Report at source line level
1.191 + --functions Report at function level [default]
1.192 + --files Report at source file level
1.193 +
1.194 +Output type:
1.195 + --text Generate text report
1.196 + --callgrind Generate callgrind format to stdout
1.197 + --gv Generate Postscript and display
1.198 + --evince Generate PDF and display
1.199 + --web Generate SVG and display
1.200 + --list=<regexp> Generate source listing of matching routines
1.201 + --disasm=<regexp> Generate disassembly of matching routines
1.202 + --symbols Print demangled symbol names found at given addresses
1.203 + --dot Generate DOT file to stdout
1.204 + --ps Generate Postcript to stdout
1.205 + --pdf Generate PDF to stdout
1.206 + --svg Generate SVG to stdout
1.207 + --gif Generate GIF to stdout
1.208 + --raw Generate symbolized pprof data (useful with remote fetch)
1.209 +
1.210 +Heap-Profile Options:
1.211 + --inuse_space Display in-use (mega)bytes [default]
1.212 + --inuse_objects Display in-use objects
1.213 + --alloc_space Display allocated (mega)bytes
1.214 + --alloc_objects Display allocated objects
1.215 + --show_bytes Display space in bytes
1.216 + --drop_negative Ignore negative differences
1.217 +
1.218 +Contention-profile options:
1.219 + --total_delay Display total delay at each region [default]
1.220 + --contentions Display number of delays at each region
1.221 + --mean_delay Display mean delay at each region
1.222 +
1.223 +Call-graph Options:
1.224 + --nodecount=<n> Show at most so many nodes [default=80]
1.225 + --nodefraction=<f> Hide nodes below <f>*total [default=.005]
1.226 + --edgefraction=<f> Hide edges below <f>*total [default=.001]
1.227 + --maxdegree=<n> Max incoming/outgoing edges per node [default=8]
1.228 + --focus=<regexp> Focus on nodes matching <regexp>
1.229 + --ignore=<regexp> Ignore nodes matching <regexp>
1.230 + --scale=<n> Set GV scaling [default=0]
1.231 + --heapcheck Make nodes with non-0 object counts
1.232 + (i.e. direct leak generators) more visible
1.233 +
1.234 +Miscellaneous:
1.235 + --tools=<prefix or binary:fullpath>[,...] \$PATH for object tool pathnames
1.236 + --test Run unit tests
1.237 + --help This message
1.238 + --version Version information
1.239 +
1.240 +Environment Variables:
1.241 + PPROF_TMPDIR Profiles directory. Defaults to \$HOME/pprof
1.242 + PPROF_TOOLS Prefix for object tools pathnames
1.243 +
1.244 +Examples:
1.245 +
1.246 +pprof /bin/ls ls.prof
1.247 + Enters "interactive" mode
1.248 +pprof --text /bin/ls ls.prof
1.249 + Outputs one line per procedure
1.250 +pprof --web /bin/ls ls.prof
1.251 + Displays annotated call-graph in web browser
1.252 +pprof --gv /bin/ls ls.prof
1.253 + Displays annotated call-graph via 'gv'
1.254 +pprof --gv --focus=Mutex /bin/ls ls.prof
1.255 + Restricts to code paths including a .*Mutex.* entry
1.256 +pprof --gv --focus=Mutex --ignore=string /bin/ls ls.prof
1.257 + Code paths including Mutex but not string
1.258 +pprof --list=getdir /bin/ls ls.prof
1.259 + (Per-line) annotated source listing for getdir()
1.260 +pprof --disasm=getdir /bin/ls ls.prof
1.261 + (Per-PC) annotated disassembly for getdir()
1.262 +
1.263 +pprof http://localhost:1234/
1.264 + Enters "interactive" mode
1.265 +pprof --text localhost:1234
1.266 + Outputs one line per procedure for localhost:1234
1.267 +pprof --raw localhost:1234 > ./local.raw
1.268 +pprof --text ./local.raw
1.269 + Fetches a remote profile for later analysis and then
1.270 + analyzes it in text mode.
1.271 +EOF
1.272 +}
1.273 +
1.274 +sub version_string {
1.275 + return <<EOF
1.276 +pprof (part of gperftools $PPROF_VERSION)
1.277 +
1.278 +Copyright 1998-2007 Google Inc.
1.279 +
1.280 +This is BSD licensed software; see the source for copying conditions
1.281 +and license information.
1.282 +There is NO warranty; not even for MERCHANTABILITY or FITNESS FOR A
1.283 +PARTICULAR PURPOSE.
1.284 +EOF
1.285 +}
1.286 +
1.287 +sub usage {
1.288 + my $msg = shift;
1.289 + print STDERR "$msg\n\n";
1.290 + print STDERR usage_string();
1.291 + print STDERR "\nFATAL ERROR: $msg\n"; # just as a reminder
1.292 + exit(1);
1.293 +}
1.294 +
1.295 +sub Init() {
1.296 + # Setup tmp-file name and handler to clean it up.
1.297 + # We do this in the very beginning so that we can use
1.298 + # error() and cleanup() function anytime here after.
1.299 + $main::tmpfile_sym = "/tmp/pprof$$.sym";
1.300 + $main::tmpfile_ps = "/tmp/pprof$$";
1.301 + $main::next_tmpfile = 0;
1.302 + $SIG{'INT'} = \&sighandler;
1.303 +
1.304 + # Cache from filename/linenumber to source code
1.305 + $main::source_cache = ();
1.306 +
1.307 + $main::opt_help = 0;
1.308 + $main::opt_version = 0;
1.309 +
1.310 + $main::opt_cum = 0;
1.311 + $main::opt_base = '';
1.312 + $main::opt_addresses = 0;
1.313 + $main::opt_lines = 0;
1.314 + $main::opt_functions = 0;
1.315 + $main::opt_files = 0;
1.316 + $main::opt_lib_prefix = "";
1.317 +
1.318 + $main::opt_text = 0;
1.319 + $main::opt_callgrind = 0;
1.320 + $main::opt_list = "";
1.321 + $main::opt_disasm = "";
1.322 + $main::opt_symbols = 0;
1.323 + $main::opt_gv = 0;
1.324 + $main::opt_evince = 0;
1.325 + $main::opt_web = 0;
1.326 + $main::opt_dot = 0;
1.327 + $main::opt_ps = 0;
1.328 + $main::opt_pdf = 0;
1.329 + $main::opt_gif = 0;
1.330 + $main::opt_svg = 0;
1.331 + $main::opt_raw = 0;
1.332 +
1.333 + $main::opt_nodecount = 80;
1.334 + $main::opt_nodefraction = 0.005;
1.335 + $main::opt_edgefraction = 0.001;
1.336 + $main::opt_maxdegree = 8;
1.337 + $main::opt_focus = '';
1.338 + $main::opt_ignore = '';
1.339 + $main::opt_scale = 0;
1.340 + $main::opt_heapcheck = 0;
1.341 + $main::opt_seconds = 30;
1.342 + $main::opt_lib = "";
1.343 +
1.344 + $main::opt_inuse_space = 0;
1.345 + $main::opt_inuse_objects = 0;
1.346 + $main::opt_alloc_space = 0;
1.347 + $main::opt_alloc_objects = 0;
1.348 + $main::opt_show_bytes = 0;
1.349 + $main::opt_drop_negative = 0;
1.350 + $main::opt_interactive = 0;
1.351 +
1.352 + $main::opt_total_delay = 0;
1.353 + $main::opt_contentions = 0;
1.354 + $main::opt_mean_delay = 0;
1.355 +
1.356 + $main::opt_tools = "";
1.357 + $main::opt_debug = 0;
1.358 + $main::opt_test = 0;
1.359 +
1.360 + # These are undocumented flags used only by unittests.
1.361 + $main::opt_test_stride = 0;
1.362 +
1.363 + # Are we using $SYMBOL_PAGE?
1.364 + $main::use_symbol_page = 0;
1.365 +
1.366 + # Files returned by TempName.
1.367 + %main::tempnames = ();
1.368 +
1.369 + # Type of profile we are dealing with
1.370 + # Supported types:
1.371 + # cpu
1.372 + # heap
1.373 + # growth
1.374 + # contention
1.375 + $main::profile_type = ''; # Empty type means "unknown"
1.376 +
1.377 + GetOptions("help!" => \$main::opt_help,
1.378 + "version!" => \$main::opt_version,
1.379 + "cum!" => \$main::opt_cum,
1.380 + "base=s" => \$main::opt_base,
1.381 + "seconds=i" => \$main::opt_seconds,
1.382 + "add_lib=s" => \$main::opt_lib,
1.383 + "lib_prefix=s" => \$main::opt_lib_prefix,
1.384 + "functions!" => \$main::opt_functions,
1.385 + "lines!" => \$main::opt_lines,
1.386 + "addresses!" => \$main::opt_addresses,
1.387 + "files!" => \$main::opt_files,
1.388 + "text!" => \$main::opt_text,
1.389 + "callgrind!" => \$main::opt_callgrind,
1.390 + "list=s" => \$main::opt_list,
1.391 + "disasm=s" => \$main::opt_disasm,
1.392 + "symbols!" => \$main::opt_symbols,
1.393 + "gv!" => \$main::opt_gv,
1.394 + "evince!" => \$main::opt_evince,
1.395 + "web!" => \$main::opt_web,
1.396 + "dot!" => \$main::opt_dot,
1.397 + "ps!" => \$main::opt_ps,
1.398 + "pdf!" => \$main::opt_pdf,
1.399 + "svg!" => \$main::opt_svg,
1.400 + "gif!" => \$main::opt_gif,
1.401 + "raw!" => \$main::opt_raw,
1.402 + "interactive!" => \$main::opt_interactive,
1.403 + "nodecount=i" => \$main::opt_nodecount,
1.404 + "nodefraction=f" => \$main::opt_nodefraction,
1.405 + "edgefraction=f" => \$main::opt_edgefraction,
1.406 + "maxdegree=i" => \$main::opt_maxdegree,
1.407 + "focus=s" => \$main::opt_focus,
1.408 + "ignore=s" => \$main::opt_ignore,
1.409 + "scale=i" => \$main::opt_scale,
1.410 + "heapcheck" => \$main::opt_heapcheck,
1.411 + "inuse_space!" => \$main::opt_inuse_space,
1.412 + "inuse_objects!" => \$main::opt_inuse_objects,
1.413 + "alloc_space!" => \$main::opt_alloc_space,
1.414 + "alloc_objects!" => \$main::opt_alloc_objects,
1.415 + "show_bytes!" => \$main::opt_show_bytes,
1.416 + "drop_negative!" => \$main::opt_drop_negative,
1.417 + "total_delay!" => \$main::opt_total_delay,
1.418 + "contentions!" => \$main::opt_contentions,
1.419 + "mean_delay!" => \$main::opt_mean_delay,
1.420 + "tools=s" => \$main::opt_tools,
1.421 + "test!" => \$main::opt_test,
1.422 + "debug!" => \$main::opt_debug,
1.423 + # Undocumented flags used only by unittests:
1.424 + "test_stride=i" => \$main::opt_test_stride,
1.425 + ) || usage("Invalid option(s)");
1.426 +
1.427 + # Deal with the standard --help and --version
1.428 + if ($main::opt_help) {
1.429 + print usage_string();
1.430 + exit(0);
1.431 + }
1.432 +
1.433 + if ($main::opt_version) {
1.434 + print version_string();
1.435 + exit(0);
1.436 + }
1.437 +
1.438 + # Disassembly/listing/symbols mode requires address-level info
1.439 + if ($main::opt_disasm || $main::opt_list || $main::opt_symbols) {
1.440 + $main::opt_functions = 0;
1.441 + $main::opt_lines = 0;
1.442 + $main::opt_addresses = 1;
1.443 + $main::opt_files = 0;
1.444 + }
1.445 +
1.446 + # Check heap-profiling flags
1.447 + if ($main::opt_inuse_space +
1.448 + $main::opt_inuse_objects +
1.449 + $main::opt_alloc_space +
1.450 + $main::opt_alloc_objects > 1) {
1.451 + usage("Specify at most on of --inuse/--alloc options");
1.452 + }
1.453 +
1.454 + # Check output granularities
1.455 + my $grains =
1.456 + $main::opt_functions +
1.457 + $main::opt_lines +
1.458 + $main::opt_addresses +
1.459 + $main::opt_files +
1.460 + 0;
1.461 + if ($grains > 1) {
1.462 + usage("Only specify one output granularity option");
1.463 + }
1.464 + if ($grains == 0) {
1.465 + $main::opt_functions = 1;
1.466 + }
1.467 +
1.468 + # Check output modes
1.469 + my $modes =
1.470 + $main::opt_text +
1.471 + $main::opt_callgrind +
1.472 + ($main::opt_list eq '' ? 0 : 1) +
1.473 + ($main::opt_disasm eq '' ? 0 : 1) +
1.474 + ($main::opt_symbols == 0 ? 0 : 1) +
1.475 + $main::opt_gv +
1.476 + $main::opt_evince +
1.477 + $main::opt_web +
1.478 + $main::opt_dot +
1.479 + $main::opt_ps +
1.480 + $main::opt_pdf +
1.481 + $main::opt_svg +
1.482 + $main::opt_gif +
1.483 + $main::opt_raw +
1.484 + $main::opt_interactive +
1.485 + 0;
1.486 + if ($modes > 1) {
1.487 + usage("Only specify one output mode");
1.488 + }
1.489 + if ($modes == 0) {
1.490 + if (-t STDOUT) { # If STDOUT is a tty, activate interactive mode
1.491 + $main::opt_interactive = 1;
1.492 + } else {
1.493 + $main::opt_text = 1;
1.494 + }
1.495 + }
1.496 +
1.497 + if ($main::opt_test) {
1.498 + RunUnitTests();
1.499 + # Should not return
1.500 + exit(1);
1.501 + }
1.502 +
1.503 + # Binary name and profile arguments list
1.504 + $main::prog = "";
1.505 + @main::pfile_args = ();
1.506 +
1.507 + # Remote profiling without a binary (using $SYMBOL_PAGE instead)
1.508 + if (@ARGV > 0) {
1.509 + if (IsProfileURL($ARGV[0])) {
1.510 + $main::use_symbol_page = 1;
1.511 + } elsif (IsSymbolizedProfileFile($ARGV[0])) {
1.512 + $main::use_symbolized_profile = 1;
1.513 + $main::prog = $UNKNOWN_BINARY; # will be set later from the profile file
1.514 + }
1.515 + }
1.516 +
1.517 + if ($main::use_symbol_page || $main::use_symbolized_profile) {
1.518 + # We don't need a binary!
1.519 + my %disabled = ('--lines' => $main::opt_lines,
1.520 + '--disasm' => $main::opt_disasm);
1.521 + for my $option (keys %disabled) {
1.522 + usage("$option cannot be used without a binary") if $disabled{$option};
1.523 + }
1.524 + # Set $main::prog later...
1.525 + scalar(@ARGV) || usage("Did not specify profile file");
1.526 + } elsif ($main::opt_symbols) {
1.527 + # --symbols needs a binary-name (to run nm on, etc) but not profiles
1.528 + $main::prog = shift(@ARGV) || usage("Did not specify program");
1.529 + } else {
1.530 + $main::prog = shift(@ARGV) || usage("Did not specify program");
1.531 + scalar(@ARGV) || usage("Did not specify profile file");
1.532 + }
1.533 +
1.534 + # Parse profile file/location arguments
1.535 + foreach my $farg (@ARGV) {
1.536 + if ($farg =~ m/(.*)\@([0-9]+)(|\/.*)$/ ) {
1.537 + my $machine = $1;
1.538 + my $num_machines = $2;
1.539 + my $path = $3;
1.540 + for (my $i = 0; $i < $num_machines; $i++) {
1.541 + unshift(@main::pfile_args, "$i.$machine$path");
1.542 + }
1.543 + } else {
1.544 + unshift(@main::pfile_args, $farg);
1.545 + }
1.546 + }
1.547 +
1.548 + if ($main::use_symbol_page) {
1.549 + unless (IsProfileURL($main::pfile_args[0])) {
1.550 + error("The first profile should be a remote form to use $SYMBOL_PAGE\n");
1.551 + }
1.552 + CheckSymbolPage();
1.553 + $main::prog = FetchProgramName();
1.554 + } elsif (!$main::use_symbolized_profile) { # may not need objtools!
1.555 + ConfigureObjTools($main::prog)
1.556 + }
1.557 +
1.558 + # Break the opt_lib_prefix into the prefix_list array
1.559 + @prefix_list = split (',', $main::opt_lib_prefix);
1.560 +
1.561 + # Remove trailing / from the prefixes, in the list to prevent
1.562 + # searching things like /my/path//lib/mylib.so
1.563 + foreach (@prefix_list) {
1.564 + s|/+$||;
1.565 + }
1.566 +}
1.567 +
1.568 +sub Main() {
1.569 + Init();
1.570 + $main::collected_profile = undef;
1.571 + @main::profile_files = ();
1.572 + $main::op_time = time();
1.573 +
1.574 + # Printing symbols is special and requires a lot less info that most.
1.575 + if ($main::opt_symbols) {
1.576 + PrintSymbols(*STDIN); # Get /proc/maps and symbols output from stdin
1.577 + return;
1.578 + }
1.579 +
1.580 + # Fetch all profile data
1.581 + FetchDynamicProfiles();
1.582 +
1.583 + # this will hold symbols that we read from the profile files
1.584 + my $symbol_map = {};
1.585 +
1.586 + # Read one profile, pick the last item on the list
1.587 + my $data = ReadProfile($main::prog, pop(@main::profile_files));
1.588 + my $profile = $data->{profile};
1.589 + my $pcs = $data->{pcs};
1.590 + my $libs = $data->{libs}; # Info about main program and shared libraries
1.591 + $symbol_map = MergeSymbols($symbol_map, $data->{symbols});
1.592 +
1.593 + # Add additional profiles, if available.
1.594 + if (scalar(@main::profile_files) > 0) {
1.595 + foreach my $pname (@main::profile_files) {
1.596 + my $data2 = ReadProfile($main::prog, $pname);
1.597 + $profile = AddProfile($profile, $data2->{profile});
1.598 + $pcs = AddPcs($pcs, $data2->{pcs});
1.599 + $symbol_map = MergeSymbols($symbol_map, $data2->{symbols});
1.600 + }
1.601 + }
1.602 +
1.603 + # Subtract base from profile, if specified
1.604 + if ($main::opt_base ne '') {
1.605 + my $base = ReadProfile($main::prog, $main::opt_base);
1.606 + $profile = SubtractProfile($profile, $base->{profile});
1.607 + $pcs = AddPcs($pcs, $base->{pcs});
1.608 + $symbol_map = MergeSymbols($symbol_map, $base->{symbols});
1.609 + }
1.610 +
1.611 + # Get total data in profile
1.612 + my $total = TotalProfile($profile);
1.613 +
1.614 + # Collect symbols
1.615 + my $symbols;
1.616 + if ($main::use_symbolized_profile) {
1.617 + $symbols = FetchSymbols($pcs, $symbol_map);
1.618 + } elsif ($main::use_symbol_page) {
1.619 + $symbols = FetchSymbols($pcs);
1.620 + } else {
1.621 + # TODO(csilvers): $libs uses the /proc/self/maps data from profile1,
1.622 + # which may differ from the data from subsequent profiles, especially
1.623 + # if they were run on different machines. Use appropriate libs for
1.624 + # each pc somehow.
1.625 + $symbols = ExtractSymbols($libs, $pcs);
1.626 + }
1.627 +
1.628 + # Remove uniniteresting stack items
1.629 + $profile = RemoveUninterestingFrames($symbols, $profile);
1.630 +
1.631 + # Focus?
1.632 + if ($main::opt_focus ne '') {
1.633 + $profile = FocusProfile($symbols, $profile, $main::opt_focus);
1.634 + }
1.635 +
1.636 + # Ignore?
1.637 + if ($main::opt_ignore ne '') {
1.638 + $profile = IgnoreProfile($symbols, $profile, $main::opt_ignore);
1.639 + }
1.640 +
1.641 + my $calls = ExtractCalls($symbols, $profile);
1.642 +
1.643 + # Reduce profiles to required output granularity, and also clean
1.644 + # each stack trace so a given entry exists at most once.
1.645 + my $reduced = ReduceProfile($symbols, $profile);
1.646 +
1.647 + # Get derived profiles
1.648 + my $flat = FlatProfile($reduced);
1.649 + my $cumulative = CumulativeProfile($reduced);
1.650 +
1.651 + # Print
1.652 + if (!$main::opt_interactive) {
1.653 + if ($main::opt_disasm) {
1.654 + PrintDisassembly($libs, $flat, $cumulative, $main::opt_disasm);
1.655 + } elsif ($main::opt_list) {
1.656 + PrintListing($total, $libs, $flat, $cumulative, $main::opt_list, 0);
1.657 + } elsif ($main::opt_text) {
1.658 + # Make sure the output is empty when have nothing to report
1.659 + # (only matters when --heapcheck is given but we must be
1.660 + # compatible with old branches that did not pass --heapcheck always):
1.661 + if ($total != 0) {
1.662 + printf("Total: %s %s\n", Unparse($total), Units());
1.663 + }
1.664 + PrintText($symbols, $flat, $cumulative, -1);
1.665 + } elsif ($main::opt_raw) {
1.666 + PrintSymbolizedProfile($symbols, $profile, $main::prog);
1.667 + } elsif ($main::opt_callgrind) {
1.668 + PrintCallgrind($calls);
1.669 + } else {
1.670 + if (PrintDot($main::prog, $symbols, $profile, $flat, $cumulative, $total)) {
1.671 + if ($main::opt_gv) {
1.672 + RunGV(TempName($main::next_tmpfile, "ps"), "");
1.673 + } elsif ($main::opt_evince) {
1.674 + RunEvince(TempName($main::next_tmpfile, "pdf"), "");
1.675 + } elsif ($main::opt_web) {
1.676 + my $tmp = TempName($main::next_tmpfile, "svg");
1.677 + RunWeb($tmp);
1.678 + # The command we run might hand the file name off
1.679 + # to an already running browser instance and then exit.
1.680 + # Normally, we'd remove $tmp on exit (right now),
1.681 + # but fork a child to remove $tmp a little later, so that the
1.682 + # browser has time to load it first.
1.683 + delete $main::tempnames{$tmp};
1.684 + if (fork() == 0) {
1.685 + sleep 5;
1.686 + unlink($tmp);
1.687 + exit(0);
1.688 + }
1.689 + }
1.690 + } else {
1.691 + cleanup();
1.692 + exit(1);
1.693 + }
1.694 + }
1.695 + } else {
1.696 + InteractiveMode($profile, $symbols, $libs, $total);
1.697 + }
1.698 +
1.699 + cleanup();
1.700 + exit(0);
1.701 +}
1.702 +
1.703 +##### Entry Point #####
1.704 +
1.705 +Main();
1.706 +
1.707 +# Temporary code to detect if we're running on a Goobuntu system.
1.708 +# These systems don't have the right stuff installed for the special
1.709 +# Readline libraries to work, so as a temporary workaround, we default
1.710 +# to using the normal stdio code, rather than the fancier readline-based
1.711 +# code
1.712 +sub ReadlineMightFail {
1.713 + if (-e '/lib/libtermcap.so.2') {
1.714 + return 0; # libtermcap exists, so readline should be okay
1.715 + } else {
1.716 + return 1;
1.717 + }
1.718 +}
1.719 +
1.720 +sub RunGV {
1.721 + my $fname = shift;
1.722 + my $bg = shift; # "" or " &" if we should run in background
1.723 + if (!system(ShellEscape(@GV, "--version") . " >$dev_null 2>&1")) {
1.724 + # Options using double dash are supported by this gv version.
1.725 + # Also, turn on noantialias to better handle bug in gv for
1.726 + # postscript files with large dimensions.
1.727 + # TODO: Maybe we should not pass the --noantialias flag
1.728 + # if the gv version is known to work properly without the flag.
1.729 + system(ShellEscape(@GV, "--scale=$main::opt_scale", "--noantialias", $fname)
1.730 + . $bg);
1.731 + } else {
1.732 + # Old gv version - only supports options that use single dash.
1.733 + print STDERR ShellEscape(@GV, "-scale", $main::opt_scale) . "\n";
1.734 + system(ShellEscape(@GV, "-scale", "$main::opt_scale", $fname) . $bg);
1.735 + }
1.736 +}
1.737 +
1.738 +sub RunEvince {
1.739 + my $fname = shift;
1.740 + my $bg = shift; # "" or " &" if we should run in background
1.741 + system(ShellEscape(@EVINCE, $fname) . $bg);
1.742 +}
1.743 +
1.744 +sub RunWeb {
1.745 + my $fname = shift;
1.746 + print STDERR "Loading web page file:///$fname\n";
1.747 +
1.748 + if (`uname` =~ /Darwin/) {
1.749 + # OS X: open will use standard preference for SVG files.
1.750 + system("/usr/bin/open", $fname);
1.751 + return;
1.752 + }
1.753 +
1.754 + # Some kind of Unix; try generic symlinks, then specific browsers.
1.755 + # (Stop once we find one.)
1.756 + # Works best if the browser is already running.
1.757 + my @alt = (
1.758 + "/etc/alternatives/gnome-www-browser",
1.759 + "/etc/alternatives/x-www-browser",
1.760 + "google-chrome",
1.761 + "firefox",
1.762 + );
1.763 + foreach my $b (@alt) {
1.764 + if (system($b, $fname) == 0) {
1.765 + return;
1.766 + }
1.767 + }
1.768 +
1.769 + print STDERR "Could not load web browser.\n";
1.770 +}
1.771 +
1.772 +sub RunKcachegrind {
1.773 + my $fname = shift;
1.774 + my $bg = shift; # "" or " &" if we should run in background
1.775 + print STDERR "Starting '@KCACHEGRIND " . $fname . $bg . "'\n";
1.776 + system(ShellEscape(@KCACHEGRIND, $fname) . $bg);
1.777 +}
1.778 +
1.779 +
1.780 +##### Interactive helper routines #####
1.781 +
1.782 +sub InteractiveMode {
1.783 + $| = 1; # Make output unbuffered for interactive mode
1.784 + my ($orig_profile, $symbols, $libs, $total) = @_;
1.785 +
1.786 + print STDERR "Welcome to pprof! For help, type 'help'.\n";
1.787 +
1.788 + # Use ReadLine if it's installed and input comes from a console.
1.789 + if ( -t STDIN &&
1.790 + !ReadlineMightFail() &&
1.791 + defined(eval {require Term::ReadLine}) ) {
1.792 + my $term = new Term::ReadLine 'pprof';
1.793 + while ( defined ($_ = $term->readline('(pprof) '))) {
1.794 + $term->addhistory($_) if /\S/;
1.795 + if (!InteractiveCommand($orig_profile, $symbols, $libs, $total, $_)) {
1.796 + last; # exit when we get an interactive command to quit
1.797 + }
1.798 + }
1.799 + } else { # don't have readline
1.800 + while (1) {
1.801 + print STDERR "(pprof) ";
1.802 + $_ = <STDIN>;
1.803 + last if ! defined $_ ;
1.804 + s/\r//g; # turn windows-looking lines into unix-looking lines
1.805 +
1.806 + # Save some flags that might be reset by InteractiveCommand()
1.807 + my $save_opt_lines = $main::opt_lines;
1.808 +
1.809 + if (!InteractiveCommand($orig_profile, $symbols, $libs, $total, $_)) {
1.810 + last; # exit when we get an interactive command to quit
1.811 + }
1.812 +
1.813 + # Restore flags
1.814 + $main::opt_lines = $save_opt_lines;
1.815 + }
1.816 + }
1.817 +}
1.818 +
1.819 +# Takes two args: orig profile, and command to run.
1.820 +# Returns 1 if we should keep going, or 0 if we were asked to quit
1.821 +sub InteractiveCommand {
1.822 + my($orig_profile, $symbols, $libs, $total, $command) = @_;
1.823 + $_ = $command; # just to make future m//'s easier
1.824 + if (!defined($_)) {
1.825 + print STDERR "\n";
1.826 + return 0;
1.827 + }
1.828 + if (m/^\s*quit/) {
1.829 + return 0;
1.830 + }
1.831 + if (m/^\s*help/) {
1.832 + InteractiveHelpMessage();
1.833 + return 1;
1.834 + }
1.835 + # Clear all the mode options -- mode is controlled by "$command"
1.836 + $main::opt_text = 0;
1.837 + $main::opt_callgrind = 0;
1.838 + $main::opt_disasm = 0;
1.839 + $main::opt_list = 0;
1.840 + $main::opt_gv = 0;
1.841 + $main::opt_evince = 0;
1.842 + $main::opt_cum = 0;
1.843 +
1.844 + if (m/^\s*(text|top)(\d*)\s*(.*)/) {
1.845 + $main::opt_text = 1;
1.846 +
1.847 + my $line_limit = ($2 ne "") ? int($2) : 10;
1.848 +
1.849 + my $routine;
1.850 + my $ignore;
1.851 + ($routine, $ignore) = ParseInteractiveArgs($3);
1.852 +
1.853 + my $profile = ProcessProfile($total, $orig_profile, $symbols, "", $ignore);
1.854 + my $reduced = ReduceProfile($symbols, $profile);
1.855 +
1.856 + # Get derived profiles
1.857 + my $flat = FlatProfile($reduced);
1.858 + my $cumulative = CumulativeProfile($reduced);
1.859 +
1.860 + PrintText($symbols, $flat, $cumulative, $line_limit);
1.861 + return 1;
1.862 + }
1.863 + if (m/^\s*callgrind\s*([^ \n]*)/) {
1.864 + $main::opt_callgrind = 1;
1.865 +
1.866 + # Get derived profiles
1.867 + my $calls = ExtractCalls($symbols, $orig_profile);
1.868 + my $filename = $1;
1.869 + if ( $1 eq '' ) {
1.870 + $filename = TempName($main::next_tmpfile, "callgrind");
1.871 + }
1.872 + PrintCallgrind($calls, $filename);
1.873 + if ( $1 eq '' ) {
1.874 + RunKcachegrind($filename, " & ");
1.875 + $main::next_tmpfile++;
1.876 + }
1.877 +
1.878 + return 1;
1.879 + }
1.880 + if (m/^\s*(web)?list\s*(.+)/) {
1.881 + my $html = (defined($1) && ($1 eq "web"));
1.882 + $main::opt_list = 1;
1.883 +
1.884 + my $routine;
1.885 + my $ignore;
1.886 + ($routine, $ignore) = ParseInteractiveArgs($2);
1.887 +
1.888 + my $profile = ProcessProfile($total, $orig_profile, $symbols, "", $ignore);
1.889 + my $reduced = ReduceProfile($symbols, $profile);
1.890 +
1.891 + # Get derived profiles
1.892 + my $flat = FlatProfile($reduced);
1.893 + my $cumulative = CumulativeProfile($reduced);
1.894 +
1.895 + PrintListing($total, $libs, $flat, $cumulative, $routine, $html);
1.896 + return 1;
1.897 + }
1.898 + if (m/^\s*disasm\s*(.+)/) {
1.899 + $main::opt_disasm = 1;
1.900 +
1.901 + my $routine;
1.902 + my $ignore;
1.903 + ($routine, $ignore) = ParseInteractiveArgs($1);
1.904 +
1.905 + # Process current profile to account for various settings
1.906 + my $profile = ProcessProfile($total, $orig_profile, $symbols, "", $ignore);
1.907 + my $reduced = ReduceProfile($symbols, $profile);
1.908 +
1.909 + # Get derived profiles
1.910 + my $flat = FlatProfile($reduced);
1.911 + my $cumulative = CumulativeProfile($reduced);
1.912 +
1.913 + PrintDisassembly($libs, $flat, $cumulative, $routine);
1.914 + return 1;
1.915 + }
1.916 + if (m/^\s*(gv|web|evince)\s*(.*)/) {
1.917 + $main::opt_gv = 0;
1.918 + $main::opt_evince = 0;
1.919 + $main::opt_web = 0;
1.920 + if ($1 eq "gv") {
1.921 + $main::opt_gv = 1;
1.922 + } elsif ($1 eq "evince") {
1.923 + $main::opt_evince = 1;
1.924 + } elsif ($1 eq "web") {
1.925 + $main::opt_web = 1;
1.926 + }
1.927 +
1.928 + my $focus;
1.929 + my $ignore;
1.930 + ($focus, $ignore) = ParseInteractiveArgs($2);
1.931 +
1.932 + # Process current profile to account for various settings
1.933 + my $profile = ProcessProfile($total, $orig_profile, $symbols,
1.934 + $focus, $ignore);
1.935 + my $reduced = ReduceProfile($symbols, $profile);
1.936 +
1.937 + # Get derived profiles
1.938 + my $flat = FlatProfile($reduced);
1.939 + my $cumulative = CumulativeProfile($reduced);
1.940 +
1.941 + if (PrintDot($main::prog, $symbols, $profile, $flat, $cumulative, $total)) {
1.942 + if ($main::opt_gv) {
1.943 + RunGV(TempName($main::next_tmpfile, "ps"), " &");
1.944 + } elsif ($main::opt_evince) {
1.945 + RunEvince(TempName($main::next_tmpfile, "pdf"), " &");
1.946 + } elsif ($main::opt_web) {
1.947 + RunWeb(TempName($main::next_tmpfile, "svg"));
1.948 + }
1.949 + $main::next_tmpfile++;
1.950 + }
1.951 + return 1;
1.952 + }
1.953 + if (m/^\s*$/) {
1.954 + return 1;
1.955 + }
1.956 + print STDERR "Unknown command: try 'help'.\n";
1.957 + return 1;
1.958 +}
1.959 +
1.960 +
1.961 +sub ProcessProfile {
1.962 + my $total_count = shift;
1.963 + my $orig_profile = shift;
1.964 + my $symbols = shift;
1.965 + my $focus = shift;
1.966 + my $ignore = shift;
1.967 +
1.968 + # Process current profile to account for various settings
1.969 + my $profile = $orig_profile;
1.970 + printf("Total: %s %s\n", Unparse($total_count), Units());
1.971 + if ($focus ne '') {
1.972 + $profile = FocusProfile($symbols, $profile, $focus);
1.973 + my $focus_count = TotalProfile($profile);
1.974 + printf("After focusing on '%s': %s %s of %s (%0.1f%%)\n",
1.975 + $focus,
1.976 + Unparse($focus_count), Units(),
1.977 + Unparse($total_count), ($focus_count*100.0) / $total_count);
1.978 + }
1.979 + if ($ignore ne '') {
1.980 + $profile = IgnoreProfile($symbols, $profile, $ignore);
1.981 + my $ignore_count = TotalProfile($profile);
1.982 + printf("After ignoring '%s': %s %s of %s (%0.1f%%)\n",
1.983 + $ignore,
1.984 + Unparse($ignore_count), Units(),
1.985 + Unparse($total_count),
1.986 + ($ignore_count*100.0) / $total_count);
1.987 + }
1.988 +
1.989 + return $profile;
1.990 +}
1.991 +
1.992 +sub InteractiveHelpMessage {
1.993 + print STDERR <<ENDOFHELP;
1.994 +Interactive pprof mode
1.995 +
1.996 +Commands:
1.997 + gv
1.998 + gv [focus] [-ignore1] [-ignore2]
1.999 + Show graphical hierarchical display of current profile. Without
1.1000 + any arguments, shows all samples in the profile. With the optional
1.1001 + "focus" argument, restricts the samples shown to just those where
1.1002 + the "focus" regular expression matches a routine name on the stack
1.1003 + trace.
1.1004 +
1.1005 + web
1.1006 + web [focus] [-ignore1] [-ignore2]
1.1007 + Like GV, but displays profile in your web browser instead of using
1.1008 + Ghostview. Works best if your web browser is already running.
1.1009 + To change the browser that gets used:
1.1010 + On Linux, set the /etc/alternatives/gnome-www-browser symlink.
1.1011 + On OS X, change the Finder association for SVG files.
1.1012 +
1.1013 + list [routine_regexp] [-ignore1] [-ignore2]
1.1014 + Show source listing of routines whose names match "routine_regexp"
1.1015 +
1.1016 + weblist [routine_regexp] [-ignore1] [-ignore2]
1.1017 + Displays a source listing of routines whose names match "routine_regexp"
1.1018 + in a web browser. You can click on source lines to view the
1.1019 + corresponding disassembly.
1.1020 +
1.1021 + top [--cum] [-ignore1] [-ignore2]
1.1022 + top20 [--cum] [-ignore1] [-ignore2]
1.1023 + top37 [--cum] [-ignore1] [-ignore2]
1.1024 + Show top lines ordered by flat profile count, or cumulative count
1.1025 + if --cum is specified. If a number is present after 'top', the
1.1026 + top K routines will be shown (defaults to showing the top 10)
1.1027 +
1.1028 + disasm [routine_regexp] [-ignore1] [-ignore2]
1.1029 + Show disassembly of routines whose names match "routine_regexp",
1.1030 + annotated with sample counts.
1.1031 +
1.1032 + callgrind
1.1033 + callgrind [filename]
1.1034 + Generates callgrind file. If no filename is given, kcachegrind is called.
1.1035 +
1.1036 + help - This listing
1.1037 + quit or ^D - End pprof
1.1038 +
1.1039 +For commands that accept optional -ignore tags, samples where any routine in
1.1040 +the stack trace matches the regular expression in any of the -ignore
1.1041 +parameters will be ignored.
1.1042 +
1.1043 +Further pprof details are available at this location (or one similar):
1.1044 +
1.1045 + /usr/doc/gperftools-$PPROF_VERSION/cpu_profiler.html
1.1046 + /usr/doc/gperftools-$PPROF_VERSION/heap_profiler.html
1.1047 +
1.1048 +ENDOFHELP
1.1049 +}
1.1050 +sub ParseInteractiveArgs {
1.1051 + my $args = shift;
1.1052 + my $focus = "";
1.1053 + my $ignore = "";
1.1054 + my @x = split(/ +/, $args);
1.1055 + foreach $a (@x) {
1.1056 + if ($a =~ m/^(--|-)lines$/) {
1.1057 + $main::opt_lines = 1;
1.1058 + } elsif ($a =~ m/^(--|-)cum$/) {
1.1059 + $main::opt_cum = 1;
1.1060 + } elsif ($a =~ m/^-(.*)/) {
1.1061 + $ignore .= (($ignore ne "") ? "|" : "" ) . $1;
1.1062 + } else {
1.1063 + $focus .= (($focus ne "") ? "|" : "" ) . $a;
1.1064 + }
1.1065 + }
1.1066 + if ($ignore ne "") {
1.1067 + print STDERR "Ignoring samples in call stacks that match '$ignore'\n";
1.1068 + }
1.1069 + return ($focus, $ignore);
1.1070 +}
1.1071 +
1.1072 +##### Output code #####
1.1073 +
1.1074 +sub TempName {
1.1075 + my $fnum = shift;
1.1076 + my $ext = shift;
1.1077 + my $file = "$main::tmpfile_ps.$fnum.$ext";
1.1078 + $main::tempnames{$file} = 1;
1.1079 + return $file;
1.1080 +}
1.1081 +
1.1082 +# Print profile data in packed binary format (64-bit) to standard out
1.1083 +sub PrintProfileData {
1.1084 + my $profile = shift;
1.1085 +
1.1086 + # print header (64-bit style)
1.1087 + # (zero) (header-size) (version) (sample-period) (zero)
1.1088 + print pack('L*', 0, 0, 3, 0, 0, 0, 1, 0, 0, 0);
1.1089 +
1.1090 + foreach my $k (keys(%{$profile})) {
1.1091 + my $count = $profile->{$k};
1.1092 + my @addrs = split(/\n/, $k);
1.1093 + if ($#addrs >= 0) {
1.1094 + my $depth = $#addrs + 1;
1.1095 + # int(foo / 2**32) is the only reliable way to get rid of bottom
1.1096 + # 32 bits on both 32- and 64-bit systems.
1.1097 + print pack('L*', $count & 0xFFFFFFFF, int($count / 2**32));
1.1098 + print pack('L*', $depth & 0xFFFFFFFF, int($depth / 2**32));
1.1099 +
1.1100 + foreach my $full_addr (@addrs) {
1.1101 + my $addr = $full_addr;
1.1102 + $addr =~ s/0x0*//; # strip off leading 0x, zeroes
1.1103 + if (length($addr) > 16) {
1.1104 + print STDERR "Invalid address in profile: $full_addr\n";
1.1105 + next;
1.1106 + }
1.1107 + my $low_addr = substr($addr, -8); # get last 8 hex chars
1.1108 + my $high_addr = substr($addr, -16, 8); # get up to 8 more hex chars
1.1109 + print pack('L*', hex('0x' . $low_addr), hex('0x' . $high_addr));
1.1110 + }
1.1111 + }
1.1112 + }
1.1113 +}
1.1114 +
1.1115 +# Print symbols and profile data
1.1116 +sub PrintSymbolizedProfile {
1.1117 + my $symbols = shift;
1.1118 + my $profile = shift;
1.1119 + my $prog = shift;
1.1120 +
1.1121 + $SYMBOL_PAGE =~ m,[^/]+$,; # matches everything after the last slash
1.1122 + my $symbol_marker = $&;
1.1123 +
1.1124 + print '--- ', $symbol_marker, "\n";
1.1125 + if (defined($prog)) {
1.1126 + print 'binary=', $prog, "\n";
1.1127 + }
1.1128 + while (my ($pc, $name) = each(%{$symbols})) {
1.1129 + my $sep = ' ';
1.1130 + print '0x', $pc;
1.1131 + # We have a list of function names, which include the inlined
1.1132 + # calls. They are separated (and terminated) by --, which is
1.1133 + # illegal in function names.
1.1134 + for (my $j = 2; $j <= $#{$name}; $j += 3) {
1.1135 + print $sep, $name->[$j];
1.1136 + $sep = '--';
1.1137 + }
1.1138 + print "\n";
1.1139 + }
1.1140 + print '---', "\n";
1.1141 +
1.1142 + $PROFILE_PAGE =~ m,[^/]+$,; # matches everything after the last slash
1.1143 + my $profile_marker = $&;
1.1144 + print '--- ', $profile_marker, "\n";
1.1145 + if (defined($main::collected_profile)) {
1.1146 + # if used with remote fetch, simply dump the collected profile to output.
1.1147 + open(SRC, "<$main::collected_profile");
1.1148 + while (<SRC>) {
1.1149 + print $_;
1.1150 + }
1.1151 + close(SRC);
1.1152 + } else {
1.1153 + # dump a cpu-format profile to standard out
1.1154 + PrintProfileData($profile);
1.1155 + }
1.1156 +}
1.1157 +
1.1158 +# Print text output
1.1159 +sub PrintText {
1.1160 + my $symbols = shift;
1.1161 + my $flat = shift;
1.1162 + my $cumulative = shift;
1.1163 + my $line_limit = shift;
1.1164 +
1.1165 + my $total = TotalProfile($flat);
1.1166 +
1.1167 + # Which profile to sort by?
1.1168 + my $s = $main::opt_cum ? $cumulative : $flat;
1.1169 +
1.1170 + my $running_sum = 0;
1.1171 + my $lines = 0;
1.1172 + foreach my $k (sort { GetEntry($s, $b) <=> GetEntry($s, $a) || $a cmp $b }
1.1173 + keys(%{$cumulative})) {
1.1174 + my $f = GetEntry($flat, $k);
1.1175 + my $c = GetEntry($cumulative, $k);
1.1176 + $running_sum += $f;
1.1177 +
1.1178 + my $sym = $k;
1.1179 + if (exists($symbols->{$k})) {
1.1180 + $sym = $symbols->{$k}->[0] . " " . $symbols->{$k}->[1];
1.1181 + if ($main::opt_addresses) {
1.1182 + $sym = $k . " " . $sym;
1.1183 + }
1.1184 + }
1.1185 +
1.1186 + if ($f != 0 || $c != 0) {
1.1187 + printf("%8s %6s %6s %8s %6s %s\n",
1.1188 + Unparse($f),
1.1189 + Percent($f, $total),
1.1190 + Percent($running_sum, $total),
1.1191 + Unparse($c),
1.1192 + Percent($c, $total),
1.1193 + $sym);
1.1194 + }
1.1195 + $lines++;
1.1196 + last if ($line_limit >= 0 && $lines >= $line_limit);
1.1197 + }
1.1198 +}
1.1199 +
1.1200 +# Callgrind format has a compression for repeated function and file
1.1201 +# names. You show the name the first time, and just use its number
1.1202 +# subsequently. This can cut down the file to about a third or a
1.1203 +# quarter of its uncompressed size. $key and $val are the key/value
1.1204 +# pair that would normally be printed by callgrind; $map is a map from
1.1205 +# value to number.
1.1206 +sub CompressedCGName {
1.1207 + my($key, $val, $map) = @_;
1.1208 + my $idx = $map->{$val};
1.1209 + # For very short keys, providing an index hurts rather than helps.
1.1210 + if (length($val) <= 3) {
1.1211 + return "$key=$val\n";
1.1212 + } elsif (defined($idx)) {
1.1213 + return "$key=($idx)\n";
1.1214 + } else {
1.1215 + # scalar(keys $map) gives the number of items in the map.
1.1216 + $idx = scalar(keys(%{$map})) + 1;
1.1217 + $map->{$val} = $idx;
1.1218 + return "$key=($idx) $val\n";
1.1219 + }
1.1220 +}
1.1221 +
1.1222 +# Print the call graph in a way that's suiteable for callgrind.
1.1223 +sub PrintCallgrind {
1.1224 + my $calls = shift;
1.1225 + my $filename;
1.1226 + my %filename_to_index_map;
1.1227 + my %fnname_to_index_map;
1.1228 +
1.1229 + if ($main::opt_interactive) {
1.1230 + $filename = shift;
1.1231 + print STDERR "Writing callgrind file to '$filename'.\n"
1.1232 + } else {
1.1233 + $filename = "&STDOUT";
1.1234 + }
1.1235 + open(CG, ">$filename");
1.1236 + printf CG ("events: Hits\n\n");
1.1237 + foreach my $call ( map { $_->[0] }
1.1238 + sort { $a->[1] cmp $b ->[1] ||
1.1239 + $a->[2] <=> $b->[2] }
1.1240 + map { /([^:]+):(\d+):([^ ]+)( -> ([^:]+):(\d+):(.+))?/;
1.1241 + [$_, $1, $2] }
1.1242 + keys %$calls ) {
1.1243 + my $count = int($calls->{$call});
1.1244 + $call =~ /([^:]+):(\d+):([^ ]+)( -> ([^:]+):(\d+):(.+))?/;
1.1245 + my ( $caller_file, $caller_line, $caller_function,
1.1246 + $callee_file, $callee_line, $callee_function ) =
1.1247 + ( $1, $2, $3, $5, $6, $7 );
1.1248 +
1.1249 + # TODO(csilvers): for better compression, collect all the
1.1250 + # caller/callee_files and functions first, before printing
1.1251 + # anything, and only compress those referenced more than once.
1.1252 + printf CG CompressedCGName("fl", $caller_file, \%filename_to_index_map);
1.1253 + printf CG CompressedCGName("fn", $caller_function, \%fnname_to_index_map);
1.1254 + if (defined $6) {
1.1255 + printf CG CompressedCGName("cfl", $callee_file, \%filename_to_index_map);
1.1256 + printf CG CompressedCGName("cfn", $callee_function, \%fnname_to_index_map);
1.1257 + printf CG ("calls=$count $callee_line\n");
1.1258 + }
1.1259 + printf CG ("$caller_line $count\n\n");
1.1260 + }
1.1261 +}
1.1262 +
1.1263 +# Print disassembly for all all routines that match $main::opt_disasm
1.1264 +sub PrintDisassembly {
1.1265 + my $libs = shift;
1.1266 + my $flat = shift;
1.1267 + my $cumulative = shift;
1.1268 + my $disasm_opts = shift;
1.1269 +
1.1270 + my $total = TotalProfile($flat);
1.1271 +
1.1272 + foreach my $lib (@{$libs}) {
1.1273 + my $symbol_table = GetProcedureBoundaries($lib->[0], $disasm_opts);
1.1274 + my $offset = AddressSub($lib->[1], $lib->[3]);
1.1275 + foreach my $routine (sort ByName keys(%{$symbol_table})) {
1.1276 + my $start_addr = $symbol_table->{$routine}->[0];
1.1277 + my $end_addr = $symbol_table->{$routine}->[1];
1.1278 + # See if there are any samples in this routine
1.1279 + my $length = hex(AddressSub($end_addr, $start_addr));
1.1280 + my $addr = AddressAdd($start_addr, $offset);
1.1281 + for (my $i = 0; $i < $length; $i++) {
1.1282 + if (defined($cumulative->{$addr})) {
1.1283 + PrintDisassembledFunction($lib->[0], $offset,
1.1284 + $routine, $flat, $cumulative,
1.1285 + $start_addr, $end_addr, $total);
1.1286 + last;
1.1287 + }
1.1288 + $addr = AddressInc($addr);
1.1289 + }
1.1290 + }
1.1291 + }
1.1292 +}
1.1293 +
1.1294 +# Return reference to array of tuples of the form:
1.1295 +# [start_address, filename, linenumber, instruction, limit_address]
1.1296 +# E.g.,
1.1297 +# ["0x806c43d", "/foo/bar.cc", 131, "ret", "0x806c440"]
1.1298 +sub Disassemble {
1.1299 + my $prog = shift;
1.1300 + my $offset = shift;
1.1301 + my $start_addr = shift;
1.1302 + my $end_addr = shift;
1.1303 +
1.1304 + my $objdump = $obj_tool_map{"objdump"};
1.1305 + my $cmd = ShellEscape($objdump, "-C", "-d", "-l", "--no-show-raw-insn",
1.1306 + "--start-address=0x$start_addr",
1.1307 + "--stop-address=0x$end_addr", $prog);
1.1308 + open(OBJDUMP, "$cmd |") || error("$cmd: $!\n");
1.1309 + my @result = ();
1.1310 + my $filename = "";
1.1311 + my $linenumber = -1;
1.1312 + my $last = ["", "", "", ""];
1.1313 + while (<OBJDUMP>) {
1.1314 + s/\r//g; # turn windows-looking lines into unix-looking lines
1.1315 + chop;
1.1316 + if (m|\s*([^:\s]+):(\d+)\s*$|) {
1.1317 + # Location line of the form:
1.1318 + # <filename>:<linenumber>
1.1319 + $filename = $1;
1.1320 + $linenumber = $2;
1.1321 + } elsif (m/^ +([0-9a-f]+):\s*(.*)/) {
1.1322 + # Disassembly line -- zero-extend address to full length
1.1323 + my $addr = HexExtend($1);
1.1324 + my $k = AddressAdd($addr, $offset);
1.1325 + $last->[4] = $k; # Store ending address for previous instruction
1.1326 + $last = [$k, $filename, $linenumber, $2, $end_addr];
1.1327 + push(@result, $last);
1.1328 + }
1.1329 + }
1.1330 + close(OBJDUMP);
1.1331 + return @result;
1.1332 +}
1.1333 +
1.1334 +# The input file should contain lines of the form /proc/maps-like
1.1335 +# output (same format as expected from the profiles) or that looks
1.1336 +# like hex addresses (like "0xDEADBEEF"). We will parse all
1.1337 +# /proc/maps output, and for all the hex addresses, we will output
1.1338 +# "short" symbol names, one per line, in the same order as the input.
1.1339 +sub PrintSymbols {
1.1340 + my $maps_and_symbols_file = shift;
1.1341 +
1.1342 + # ParseLibraries expects pcs to be in a set. Fine by us...
1.1343 + my @pclist = (); # pcs in sorted order
1.1344 + my $pcs = {};
1.1345 + my $map = "";
1.1346 + foreach my $line (<$maps_and_symbols_file>) {
1.1347 + $line =~ s/\r//g; # turn windows-looking lines into unix-looking lines
1.1348 + if ($line =~ /\b(0x[0-9a-f]+)\b/i) {
1.1349 + push(@pclist, HexExtend($1));
1.1350 + $pcs->{$pclist[-1]} = 1;
1.1351 + } else {
1.1352 + $map .= $line;
1.1353 + }
1.1354 + }
1.1355 +
1.1356 + my $libs = ParseLibraries($main::prog, $map, $pcs);
1.1357 + my $symbols = ExtractSymbols($libs, $pcs);
1.1358 +
1.1359 + foreach my $pc (@pclist) {
1.1360 + # ->[0] is the shortname, ->[2] is the full name
1.1361 + print(($symbols->{$pc}->[0] || "??") . "\n");
1.1362 + }
1.1363 +}
1.1364 +
1.1365 +
1.1366 +# For sorting functions by name
1.1367 +sub ByName {
1.1368 + return ShortFunctionName($a) cmp ShortFunctionName($b);
1.1369 +}
1.1370 +
1.1371 +# Print source-listing for all all routines that match $list_opts
1.1372 +sub PrintListing {
1.1373 + my $total = shift;
1.1374 + my $libs = shift;
1.1375 + my $flat = shift;
1.1376 + my $cumulative = shift;
1.1377 + my $list_opts = shift;
1.1378 + my $html = shift;
1.1379 +
1.1380 + my $output = \*STDOUT;
1.1381 + my $fname = "";
1.1382 +
1.1383 + if ($html) {
1.1384 + # Arrange to write the output to a temporary file
1.1385 + $fname = TempName($main::next_tmpfile, "html");
1.1386 + $main::next_tmpfile++;
1.1387 + if (!open(TEMP, ">$fname")) {
1.1388 + print STDERR "$fname: $!\n";
1.1389 + return;
1.1390 + }
1.1391 + $output = \*TEMP;
1.1392 + print $output HtmlListingHeader();
1.1393 + printf $output ("<div class=\"legend\">%s<br>Total: %s %s</div>\n",
1.1394 + $main::prog, Unparse($total), Units());
1.1395 + }
1.1396 +
1.1397 + my $listed = 0;
1.1398 + foreach my $lib (@{$libs}) {
1.1399 + my $symbol_table = GetProcedureBoundaries($lib->[0], $list_opts);
1.1400 + my $offset = AddressSub($lib->[1], $lib->[3]);
1.1401 + foreach my $routine (sort ByName keys(%{$symbol_table})) {
1.1402 + # Print if there are any samples in this routine
1.1403 + my $start_addr = $symbol_table->{$routine}->[0];
1.1404 + my $end_addr = $symbol_table->{$routine}->[1];
1.1405 + my $length = hex(AddressSub($end_addr, $start_addr));
1.1406 + my $addr = AddressAdd($start_addr, $offset);
1.1407 + for (my $i = 0; $i < $length; $i++) {
1.1408 + if (defined($cumulative->{$addr})) {
1.1409 + $listed += PrintSource(
1.1410 + $lib->[0], $offset,
1.1411 + $routine, $flat, $cumulative,
1.1412 + $start_addr, $end_addr,
1.1413 + $html,
1.1414 + $output);
1.1415 + last;
1.1416 + }
1.1417 + $addr = AddressInc($addr);
1.1418 + }
1.1419 + }
1.1420 + }
1.1421 +
1.1422 + if ($html) {
1.1423 + if ($listed > 0) {
1.1424 + print $output HtmlListingFooter();
1.1425 + close($output);
1.1426 + RunWeb($fname);
1.1427 + } else {
1.1428 + close($output);
1.1429 + unlink($fname);
1.1430 + }
1.1431 + }
1.1432 +}
1.1433 +
1.1434 +sub HtmlListingHeader {
1.1435 + return <<'EOF';
1.1436 +<DOCTYPE html>
1.1437 +<html>
1.1438 +<head>
1.1439 +<title>Pprof listing</title>
1.1440 +<style type="text/css">
1.1441 +body {
1.1442 + font-family: sans-serif;
1.1443 +}
1.1444 +h1 {
1.1445 + font-size: 1.5em;
1.1446 + margin-bottom: 4px;
1.1447 +}
1.1448 +.legend {
1.1449 + font-size: 1.25em;
1.1450 +}
1.1451 +.line {
1.1452 + color: #aaaaaa;
1.1453 +}
1.1454 +.nop {
1.1455 + color: #aaaaaa;
1.1456 +}
1.1457 +.unimportant {
1.1458 + color: #cccccc;
1.1459 +}
1.1460 +.disasmloc {
1.1461 + color: #000000;
1.1462 +}
1.1463 +.deadsrc {
1.1464 + cursor: pointer;
1.1465 +}
1.1466 +.deadsrc:hover {
1.1467 + background-color: #eeeeee;
1.1468 +}
1.1469 +.livesrc {
1.1470 + color: #0000ff;
1.1471 + cursor: pointer;
1.1472 +}
1.1473 +.livesrc:hover {
1.1474 + background-color: #eeeeee;
1.1475 +}
1.1476 +.asm {
1.1477 + color: #008800;
1.1478 + display: none;
1.1479 +}
1.1480 +</style>
1.1481 +<script type="text/javascript">
1.1482 +function pprof_toggle_asm(e) {
1.1483 + var target;
1.1484 + if (!e) e = window.event;
1.1485 + if (e.target) target = e.target;
1.1486 + else if (e.srcElement) target = e.srcElement;
1.1487 +
1.1488 + if (target) {
1.1489 + var asm = target.nextSibling;
1.1490 + if (asm && asm.className == "asm") {
1.1491 + asm.style.display = (asm.style.display == "block" ? "" : "block");
1.1492 + e.preventDefault();
1.1493 + return false;
1.1494 + }
1.1495 + }
1.1496 +}
1.1497 +</script>
1.1498 +</head>
1.1499 +<body>
1.1500 +EOF
1.1501 +}
1.1502 +
1.1503 +sub HtmlListingFooter {
1.1504 + return <<'EOF';
1.1505 +</body>
1.1506 +</html>
1.1507 +EOF
1.1508 +}
1.1509 +
1.1510 +sub HtmlEscape {
1.1511 + my $text = shift;
1.1512 + $text =~ s/&/&/g;
1.1513 + $text =~ s/</</g;
1.1514 + $text =~ s/>/>/g;
1.1515 + return $text;
1.1516 +}
1.1517 +
1.1518 +# Returns the indentation of the line, if it has any non-whitespace
1.1519 +# characters. Otherwise, returns -1.
1.1520 +sub Indentation {
1.1521 + my $line = shift;
1.1522 + if (m/^(\s*)\S/) {
1.1523 + return length($1);
1.1524 + } else {
1.1525 + return -1;
1.1526 + }
1.1527 +}
1.1528 +
1.1529 +# If the symbol table contains inlining info, Disassemble() may tag an
1.1530 +# instruction with a location inside an inlined function. But for
1.1531 +# source listings, we prefer to use the location in the function we
1.1532 +# are listing. So use MapToSymbols() to fetch full location
1.1533 +# information for each instruction and then pick out the first
1.1534 +# location from a location list (location list contains callers before
1.1535 +# callees in case of inlining).
1.1536 +#
1.1537 +# After this routine has run, each entry in $instructions contains:
1.1538 +# [0] start address
1.1539 +# [1] filename for function we are listing
1.1540 +# [2] line number for function we are listing
1.1541 +# [3] disassembly
1.1542 +# [4] limit address
1.1543 +# [5] most specific filename (may be different from [1] due to inlining)
1.1544 +# [6] most specific line number (may be different from [2] due to inlining)
1.1545 +sub GetTopLevelLineNumbers {
1.1546 + my ($lib, $offset, $instructions) = @_;
1.1547 + my $pcs = [];
1.1548 + for (my $i = 0; $i <= $#{$instructions}; $i++) {
1.1549 + push(@{$pcs}, $instructions->[$i]->[0]);
1.1550 + }
1.1551 + my $symbols = {};
1.1552 + MapToSymbols($lib, $offset, $pcs, $symbols);
1.1553 + for (my $i = 0; $i <= $#{$instructions}; $i++) {
1.1554 + my $e = $instructions->[$i];
1.1555 + push(@{$e}, $e->[1]);
1.1556 + push(@{$e}, $e->[2]);
1.1557 + my $addr = $e->[0];
1.1558 + my $sym = $symbols->{$addr};
1.1559 + if (defined($sym)) {
1.1560 + if ($#{$sym} >= 2 && $sym->[1] =~ m/^(.*):(\d+)$/) {
1.1561 + $e->[1] = $1; # File name
1.1562 + $e->[2] = $2; # Line number
1.1563 + }
1.1564 + }
1.1565 + }
1.1566 +}
1.1567 +
1.1568 +# Print source-listing for one routine
1.1569 +sub PrintSource {
1.1570 + my $prog = shift;
1.1571 + my $offset = shift;
1.1572 + my $routine = shift;
1.1573 + my $flat = shift;
1.1574 + my $cumulative = shift;
1.1575 + my $start_addr = shift;
1.1576 + my $end_addr = shift;
1.1577 + my $html = shift;
1.1578 + my $output = shift;
1.1579 +
1.1580 + # Disassemble all instructions (just to get line numbers)
1.1581 + my @instructions = Disassemble($prog, $offset, $start_addr, $end_addr);
1.1582 + GetTopLevelLineNumbers($prog, $offset, \@instructions);
1.1583 +
1.1584 + # Hack 1: assume that the first source file encountered in the
1.1585 + # disassembly contains the routine
1.1586 + my $filename = undef;
1.1587 + for (my $i = 0; $i <= $#instructions; $i++) {
1.1588 + if ($instructions[$i]->[2] >= 0) {
1.1589 + $filename = $instructions[$i]->[1];
1.1590 + last;
1.1591 + }
1.1592 + }
1.1593 + if (!defined($filename)) {
1.1594 + print STDERR "no filename found in $routine\n";
1.1595 + return 0;
1.1596 + }
1.1597 +
1.1598 + # Hack 2: assume that the largest line number from $filename is the
1.1599 + # end of the procedure. This is typically safe since if P1 contains
1.1600 + # an inlined call to P2, then P2 usually occurs earlier in the
1.1601 + # source file. If this does not work, we might have to compute a
1.1602 + # density profile or just print all regions we find.
1.1603 + my $lastline = 0;
1.1604 + for (my $i = 0; $i <= $#instructions; $i++) {
1.1605 + my $f = $instructions[$i]->[1];
1.1606 + my $l = $instructions[$i]->[2];
1.1607 + if (($f eq $filename) && ($l > $lastline)) {
1.1608 + $lastline = $l;
1.1609 + }
1.1610 + }
1.1611 +
1.1612 + # Hack 3: assume the first source location from "filename" is the start of
1.1613 + # the source code.
1.1614 + my $firstline = 1;
1.1615 + for (my $i = 0; $i <= $#instructions; $i++) {
1.1616 + if ($instructions[$i]->[1] eq $filename) {
1.1617 + $firstline = $instructions[$i]->[2];
1.1618 + last;
1.1619 + }
1.1620 + }
1.1621 +
1.1622 + # Hack 4: Extend last line forward until its indentation is less than
1.1623 + # the indentation we saw on $firstline
1.1624 + my $oldlastline = $lastline;
1.1625 + {
1.1626 + if (!open(FILE, "<$filename")) {
1.1627 + print STDERR "$filename: $!\n";
1.1628 + return 0;
1.1629 + }
1.1630 + my $l = 0;
1.1631 + my $first_indentation = -1;
1.1632 + while (<FILE>) {
1.1633 + s/\r//g; # turn windows-looking lines into unix-looking lines
1.1634 + $l++;
1.1635 + my $indent = Indentation($_);
1.1636 + if ($l >= $firstline) {
1.1637 + if ($first_indentation < 0 && $indent >= 0) {
1.1638 + $first_indentation = $indent;
1.1639 + last if ($first_indentation == 0);
1.1640 + }
1.1641 + }
1.1642 + if ($l >= $lastline && $indent >= 0) {
1.1643 + if ($indent >= $first_indentation) {
1.1644 + $lastline = $l+1;
1.1645 + } else {
1.1646 + last;
1.1647 + }
1.1648 + }
1.1649 + }
1.1650 + close(FILE);
1.1651 + }
1.1652 +
1.1653 + # Assign all samples to the range $firstline,$lastline,
1.1654 + # Hack 4: If an instruction does not occur in the range, its samples
1.1655 + # are moved to the next instruction that occurs in the range.
1.1656 + my $samples1 = {}; # Map from line number to flat count
1.1657 + my $samples2 = {}; # Map from line number to cumulative count
1.1658 + my $running1 = 0; # Unassigned flat counts
1.1659 + my $running2 = 0; # Unassigned cumulative counts
1.1660 + my $total1 = 0; # Total flat counts
1.1661 + my $total2 = 0; # Total cumulative counts
1.1662 + my %disasm = (); # Map from line number to disassembly
1.1663 + my $running_disasm = ""; # Unassigned disassembly
1.1664 + my $skip_marker = "---\n";
1.1665 + if ($html) {
1.1666 + $skip_marker = "";
1.1667 + for (my $l = $firstline; $l <= $lastline; $l++) {
1.1668 + $disasm{$l} = "";
1.1669 + }
1.1670 + }
1.1671 + my $last_dis_filename = '';
1.1672 + my $last_dis_linenum = -1;
1.1673 + my $last_touched_line = -1; # To detect gaps in disassembly for a line
1.1674 + foreach my $e (@instructions) {
1.1675 + # Add up counts for all address that fall inside this instruction
1.1676 + my $c1 = 0;
1.1677 + my $c2 = 0;
1.1678 + for (my $a = $e->[0]; $a lt $e->[4]; $a = AddressInc($a)) {
1.1679 + $c1 += GetEntry($flat, $a);
1.1680 + $c2 += GetEntry($cumulative, $a);
1.1681 + }
1.1682 +
1.1683 + if ($html) {
1.1684 + my $dis = sprintf(" %6s %6s \t\t%8s: %s ",
1.1685 + HtmlPrintNumber($c1),
1.1686 + HtmlPrintNumber($c2),
1.1687 + UnparseAddress($offset, $e->[0]),
1.1688 + CleanDisassembly($e->[3]));
1.1689 +
1.1690 + # Append the most specific source line associated with this instruction
1.1691 + if (length($dis) < 80) { $dis .= (' ' x (80 - length($dis))) };
1.1692 + $dis = HtmlEscape($dis);
1.1693 + my $f = $e->[5];
1.1694 + my $l = $e->[6];
1.1695 + if ($f ne $last_dis_filename) {
1.1696 + $dis .= sprintf("<span class=disasmloc>%s:%d</span>",
1.1697 + HtmlEscape(CleanFileName($f)), $l);
1.1698 + } elsif ($l ne $last_dis_linenum) {
1.1699 + # De-emphasize the unchanged file name portion
1.1700 + $dis .= sprintf("<span class=unimportant>%s</span>" .
1.1701 + "<span class=disasmloc>:%d</span>",
1.1702 + HtmlEscape(CleanFileName($f)), $l);
1.1703 + } else {
1.1704 + # De-emphasize the entire location
1.1705 + $dis .= sprintf("<span class=unimportant>%s:%d</span>",
1.1706 + HtmlEscape(CleanFileName($f)), $l);
1.1707 + }
1.1708 + $last_dis_filename = $f;
1.1709 + $last_dis_linenum = $l;
1.1710 + $running_disasm .= $dis;
1.1711 + $running_disasm .= "\n";
1.1712 + }
1.1713 +
1.1714 + $running1 += $c1;
1.1715 + $running2 += $c2;
1.1716 + $total1 += $c1;
1.1717 + $total2 += $c2;
1.1718 + my $file = $e->[1];
1.1719 + my $line = $e->[2];
1.1720 + if (($file eq $filename) &&
1.1721 + ($line >= $firstline) &&
1.1722 + ($line <= $lastline)) {
1.1723 + # Assign all accumulated samples to this line
1.1724 + AddEntry($samples1, $line, $running1);
1.1725 + AddEntry($samples2, $line, $running2);
1.1726 + $running1 = 0;
1.1727 + $running2 = 0;
1.1728 + if ($html) {
1.1729 + if ($line != $last_touched_line && $disasm{$line} ne '') {
1.1730 + $disasm{$line} .= "\n";
1.1731 + }
1.1732 + $disasm{$line} .= $running_disasm;
1.1733 + $running_disasm = '';
1.1734 + $last_touched_line = $line;
1.1735 + }
1.1736 + }
1.1737 + }
1.1738 +
1.1739 + # Assign any leftover samples to $lastline
1.1740 + AddEntry($samples1, $lastline, $running1);
1.1741 + AddEntry($samples2, $lastline, $running2);
1.1742 + if ($html) {
1.1743 + if ($lastline != $last_touched_line && $disasm{$lastline} ne '') {
1.1744 + $disasm{$lastline} .= "\n";
1.1745 + }
1.1746 + $disasm{$lastline} .= $running_disasm;
1.1747 + }
1.1748 +
1.1749 + if ($html) {
1.1750 + printf $output (
1.1751 + "<h1>%s</h1>%s\n<pre onClick=\"pprof_toggle_asm()\">\n" .
1.1752 + "Total:%6s %6s (flat / cumulative %s)\n",
1.1753 + HtmlEscape(ShortFunctionName($routine)),
1.1754 + HtmlEscape(CleanFileName($filename)),
1.1755 + Unparse($total1),
1.1756 + Unparse($total2),
1.1757 + Units());
1.1758 + } else {
1.1759 + printf $output (
1.1760 + "ROUTINE ====================== %s in %s\n" .
1.1761 + "%6s %6s Total %s (flat / cumulative)\n",
1.1762 + ShortFunctionName($routine),
1.1763 + CleanFileName($filename),
1.1764 + Unparse($total1),
1.1765 + Unparse($total2),
1.1766 + Units());
1.1767 + }
1.1768 + if (!open(FILE, "<$filename")) {
1.1769 + print STDERR "$filename: $!\n";
1.1770 + return 0;
1.1771 + }
1.1772 + my $l = 0;
1.1773 + while (<FILE>) {
1.1774 + s/\r//g; # turn windows-looking lines into unix-looking lines
1.1775 + $l++;
1.1776 + if ($l >= $firstline - 5 &&
1.1777 + (($l <= $oldlastline + 5) || ($l <= $lastline))) {
1.1778 + chop;
1.1779 + my $text = $_;
1.1780 + if ($l == $firstline) { print $output $skip_marker; }
1.1781 + my $n1 = GetEntry($samples1, $l);
1.1782 + my $n2 = GetEntry($samples2, $l);
1.1783 + if ($html) {
1.1784 + # Emit a span that has one of the following classes:
1.1785 + # livesrc -- has samples
1.1786 + # deadsrc -- has disassembly, but with no samples
1.1787 + # nop -- has no matching disasembly
1.1788 + # Also emit an optional span containing disassembly.
1.1789 + my $dis = $disasm{$l};
1.1790 + my $asm = "";
1.1791 + if (defined($dis) && $dis ne '') {
1.1792 + $asm = "<span class=\"asm\">" . $dis . "</span>";
1.1793 + }
1.1794 + my $source_class = (($n1 + $n2 > 0)
1.1795 + ? "livesrc"
1.1796 + : (($asm ne "") ? "deadsrc" : "nop"));
1.1797 + printf $output (
1.1798 + "<span class=\"line\">%5d</span> " .
1.1799 + "<span class=\"%s\">%6s %6s %s</span>%s\n",
1.1800 + $l, $source_class,
1.1801 + HtmlPrintNumber($n1),
1.1802 + HtmlPrintNumber($n2),
1.1803 + HtmlEscape($text),
1.1804 + $asm);
1.1805 + } else {
1.1806 + printf $output(
1.1807 + "%6s %6s %4d: %s\n",
1.1808 + UnparseAlt($n1),
1.1809 + UnparseAlt($n2),
1.1810 + $l,
1.1811 + $text);
1.1812 + }
1.1813 + if ($l == $lastline) { print $output $skip_marker; }
1.1814 + };
1.1815 + }
1.1816 + close(FILE);
1.1817 + if ($html) {
1.1818 + print $output "</pre>\n";
1.1819 + }
1.1820 + return 1;
1.1821 +}
1.1822 +
1.1823 +# Return the source line for the specified file/linenumber.
1.1824 +# Returns undef if not found.
1.1825 +sub SourceLine {
1.1826 + my $file = shift;
1.1827 + my $line = shift;
1.1828 +
1.1829 + # Look in cache
1.1830 + if (!defined($main::source_cache{$file})) {
1.1831 + if (100 < scalar keys(%main::source_cache)) {
1.1832 + # Clear the cache when it gets too big
1.1833 + $main::source_cache = ();
1.1834 + }
1.1835 +
1.1836 + # Read all lines from the file
1.1837 + if (!open(FILE, "<$file")) {
1.1838 + print STDERR "$file: $!\n";
1.1839 + $main::source_cache{$file} = []; # Cache the negative result
1.1840 + return undef;
1.1841 + }
1.1842 + my $lines = [];
1.1843 + push(@{$lines}, ""); # So we can use 1-based line numbers as indices
1.1844 + while (<FILE>) {
1.1845 + push(@{$lines}, $_);
1.1846 + }
1.1847 + close(FILE);
1.1848 +
1.1849 + # Save the lines in the cache
1.1850 + $main::source_cache{$file} = $lines;
1.1851 + }
1.1852 +
1.1853 + my $lines = $main::source_cache{$file};
1.1854 + if (($line < 0) || ($line > $#{$lines})) {
1.1855 + return undef;
1.1856 + } else {
1.1857 + return $lines->[$line];
1.1858 + }
1.1859 +}
1.1860 +
1.1861 +# Print disassembly for one routine with interspersed source if available
1.1862 +sub PrintDisassembledFunction {
1.1863 + my $prog = shift;
1.1864 + my $offset = shift;
1.1865 + my $routine = shift;
1.1866 + my $flat = shift;
1.1867 + my $cumulative = shift;
1.1868 + my $start_addr = shift;
1.1869 + my $end_addr = shift;
1.1870 + my $total = shift;
1.1871 +
1.1872 + # Disassemble all instructions
1.1873 + my @instructions = Disassemble($prog, $offset, $start_addr, $end_addr);
1.1874 +
1.1875 + # Make array of counts per instruction
1.1876 + my @flat_count = ();
1.1877 + my @cum_count = ();
1.1878 + my $flat_total = 0;
1.1879 + my $cum_total = 0;
1.1880 + foreach my $e (@instructions) {
1.1881 + # Add up counts for all address that fall inside this instruction
1.1882 + my $c1 = 0;
1.1883 + my $c2 = 0;
1.1884 + for (my $a = $e->[0]; $a lt $e->[4]; $a = AddressInc($a)) {
1.1885 + $c1 += GetEntry($flat, $a);
1.1886 + $c2 += GetEntry($cumulative, $a);
1.1887 + }
1.1888 + push(@flat_count, $c1);
1.1889 + push(@cum_count, $c2);
1.1890 + $flat_total += $c1;
1.1891 + $cum_total += $c2;
1.1892 + }
1.1893 +
1.1894 + # Print header with total counts
1.1895 + printf("ROUTINE ====================== %s\n" .
1.1896 + "%6s %6s %s (flat, cumulative) %.1f%% of total\n",
1.1897 + ShortFunctionName($routine),
1.1898 + Unparse($flat_total),
1.1899 + Unparse($cum_total),
1.1900 + Units(),
1.1901 + ($cum_total * 100.0) / $total);
1.1902 +
1.1903 + # Process instructions in order
1.1904 + my $current_file = "";
1.1905 + for (my $i = 0; $i <= $#instructions; ) {
1.1906 + my $e = $instructions[$i];
1.1907 +
1.1908 + # Print the new file name whenever we switch files
1.1909 + if ($e->[1] ne $current_file) {
1.1910 + $current_file = $e->[1];
1.1911 + my $fname = $current_file;
1.1912 + $fname =~ s|^\./||; # Trim leading "./"
1.1913 +
1.1914 + # Shorten long file names
1.1915 + if (length($fname) >= 58) {
1.1916 + $fname = "..." . substr($fname, -55);
1.1917 + }
1.1918 + printf("-------------------- %s\n", $fname);
1.1919 + }
1.1920 +
1.1921 + # TODO: Compute range of lines to print together to deal with
1.1922 + # small reorderings.
1.1923 + my $first_line = $e->[2];
1.1924 + my $last_line = $first_line;
1.1925 + my %flat_sum = ();
1.1926 + my %cum_sum = ();
1.1927 + for (my $l = $first_line; $l <= $last_line; $l++) {
1.1928 + $flat_sum{$l} = 0;
1.1929 + $cum_sum{$l} = 0;
1.1930 + }
1.1931 +
1.1932 + # Find run of instructions for this range of source lines
1.1933 + my $first_inst = $i;
1.1934 + while (($i <= $#instructions) &&
1.1935 + ($instructions[$i]->[2] >= $first_line) &&
1.1936 + ($instructions[$i]->[2] <= $last_line)) {
1.1937 + $e = $instructions[$i];
1.1938 + $flat_sum{$e->[2]} += $flat_count[$i];
1.1939 + $cum_sum{$e->[2]} += $cum_count[$i];
1.1940 + $i++;
1.1941 + }
1.1942 + my $last_inst = $i - 1;
1.1943 +
1.1944 + # Print source lines
1.1945 + for (my $l = $first_line; $l <= $last_line; $l++) {
1.1946 + my $line = SourceLine($current_file, $l);
1.1947 + if (!defined($line)) {
1.1948 + $line = "?\n";
1.1949 + next;
1.1950 + } else {
1.1951 + $line =~ s/^\s+//;
1.1952 + }
1.1953 + printf("%6s %6s %5d: %s",
1.1954 + UnparseAlt($flat_sum{$l}),
1.1955 + UnparseAlt($cum_sum{$l}),
1.1956 + $l,
1.1957 + $line);
1.1958 + }
1.1959 +
1.1960 + # Print disassembly
1.1961 + for (my $x = $first_inst; $x <= $last_inst; $x++) {
1.1962 + my $e = $instructions[$x];
1.1963 + printf("%6s %6s %8s: %6s\n",
1.1964 + UnparseAlt($flat_count[$x]),
1.1965 + UnparseAlt($cum_count[$x]),
1.1966 + UnparseAddress($offset, $e->[0]),
1.1967 + CleanDisassembly($e->[3]));
1.1968 + }
1.1969 + }
1.1970 +}
1.1971 +
1.1972 +# Print DOT graph
1.1973 +sub PrintDot {
1.1974 + my $prog = shift;
1.1975 + my $symbols = shift;
1.1976 + my $raw = shift;
1.1977 + my $flat = shift;
1.1978 + my $cumulative = shift;
1.1979 + my $overall_total = shift;
1.1980 +
1.1981 + # Get total
1.1982 + my $local_total = TotalProfile($flat);
1.1983 + my $nodelimit = int($main::opt_nodefraction * $local_total);
1.1984 + my $edgelimit = int($main::opt_edgefraction * $local_total);
1.1985 + my $nodecount = $main::opt_nodecount;
1.1986 +
1.1987 + # Find nodes to include
1.1988 + my @list = (sort { abs(GetEntry($cumulative, $b)) <=>
1.1989 + abs(GetEntry($cumulative, $a))
1.1990 + || $a cmp $b }
1.1991 + keys(%{$cumulative}));
1.1992 + my $last = $nodecount - 1;
1.1993 + if ($last > $#list) {
1.1994 + $last = $#list;
1.1995 + }
1.1996 + while (($last >= 0) &&
1.1997 + (abs(GetEntry($cumulative, $list[$last])) <= $nodelimit)) {
1.1998 + $last--;
1.1999 + }
1.2000 + if ($last < 0) {
1.2001 + print STDERR "No nodes to print\n";
1.2002 + return 0;
1.2003 + }
1.2004 +
1.2005 + if ($nodelimit > 0 || $edgelimit > 0) {
1.2006 + printf STDERR ("Dropping nodes with <= %s %s; edges with <= %s abs(%s)\n",
1.2007 + Unparse($nodelimit), Units(),
1.2008 + Unparse($edgelimit), Units());
1.2009 + }
1.2010 +
1.2011 + # Open DOT output file
1.2012 + my $output;
1.2013 + my $escaped_dot = ShellEscape(@DOT);
1.2014 + my $escaped_ps2pdf = ShellEscape(@PS2PDF);
1.2015 + if ($main::opt_gv) {
1.2016 + my $escaped_outfile = ShellEscape(TempName($main::next_tmpfile, "ps"));
1.2017 + $output = "| $escaped_dot -Tps2 >$escaped_outfile";
1.2018 + } elsif ($main::opt_evince) {
1.2019 + my $escaped_outfile = ShellEscape(TempName($main::next_tmpfile, "pdf"));
1.2020 + $output = "| $escaped_dot -Tps2 | $escaped_ps2pdf - $escaped_outfile";
1.2021 + } elsif ($main::opt_ps) {
1.2022 + $output = "| $escaped_dot -Tps2";
1.2023 + } elsif ($main::opt_pdf) {
1.2024 + $output = "| $escaped_dot -Tps2 | $escaped_ps2pdf - -";
1.2025 + } elsif ($main::opt_web || $main::opt_svg) {
1.2026 + # We need to post-process the SVG, so write to a temporary file always.
1.2027 + my $escaped_outfile = ShellEscape(TempName($main::next_tmpfile, "svg"));
1.2028 + $output = "| $escaped_dot -Tsvg >$escaped_outfile";
1.2029 + } elsif ($main::opt_gif) {
1.2030 + $output = "| $escaped_dot -Tgif";
1.2031 + } else {
1.2032 + $output = ">&STDOUT";
1.2033 + }
1.2034 + open(DOT, $output) || error("$output: $!\n");
1.2035 +
1.2036 + # Title
1.2037 + printf DOT ("digraph \"%s; %s %s\" {\n",
1.2038 + $prog,
1.2039 + Unparse($overall_total),
1.2040 + Units());
1.2041 + if ($main::opt_pdf) {
1.2042 + # The output is more printable if we set the page size for dot.
1.2043 + printf DOT ("size=\"8,11\"\n");
1.2044 + }
1.2045 + printf DOT ("node [width=0.375,height=0.25];\n");
1.2046 +
1.2047 + # Print legend
1.2048 + printf DOT ("Legend [shape=box,fontsize=24,shape=plaintext," .
1.2049 + "label=\"%s\\l%s\\l%s\\l%s\\l%s\\l\"];\n",
1.2050 + $prog,
1.2051 + sprintf("Total %s: %s", Units(), Unparse($overall_total)),
1.2052 + sprintf("Focusing on: %s", Unparse($local_total)),
1.2053 + sprintf("Dropped nodes with <= %s abs(%s)",
1.2054 + Unparse($nodelimit), Units()),
1.2055 + sprintf("Dropped edges with <= %s %s",
1.2056 + Unparse($edgelimit), Units())
1.2057 + );
1.2058 +
1.2059 + # Print nodes
1.2060 + my %node = ();
1.2061 + my $nextnode = 1;
1.2062 + foreach my $a (@list[0..$last]) {
1.2063 + # Pick font size
1.2064 + my $f = GetEntry($flat, $a);
1.2065 + my $c = GetEntry($cumulative, $a);
1.2066 +
1.2067 + my $fs = 8;
1.2068 + if ($local_total > 0) {
1.2069 + $fs = 8 + (50.0 * sqrt(abs($f * 1.0 / $local_total)));
1.2070 + }
1.2071 +
1.2072 + $node{$a} = $nextnode++;
1.2073 + my $sym = $a;
1.2074 + $sym =~ s/\s+/\\n/g;
1.2075 + $sym =~ s/::/\\n/g;
1.2076 +
1.2077 + # Extra cumulative info to print for non-leaves
1.2078 + my $extra = "";
1.2079 + if ($f != $c) {
1.2080 + $extra = sprintf("\\rof %s (%s)",
1.2081 + Unparse($c),
1.2082 + Percent($c, $local_total));
1.2083 + }
1.2084 + my $style = "";
1.2085 + if ($main::opt_heapcheck) {
1.2086 + if ($f > 0) {
1.2087 + # make leak-causing nodes more visible (add a background)
1.2088 + $style = ",style=filled,fillcolor=gray"
1.2089 + } elsif ($f < 0) {
1.2090 + # make anti-leak-causing nodes (which almost never occur)
1.2091 + # stand out as well (triple border)
1.2092 + $style = ",peripheries=3"
1.2093 + }
1.2094 + }
1.2095 +
1.2096 + printf DOT ("N%d [label=\"%s\\n%s (%s)%s\\r" .
1.2097 + "\",shape=box,fontsize=%.1f%s];\n",
1.2098 + $node{$a},
1.2099 + $sym,
1.2100 + Unparse($f),
1.2101 + Percent($f, $local_total),
1.2102 + $extra,
1.2103 + $fs,
1.2104 + $style,
1.2105 + );
1.2106 + }
1.2107 +
1.2108 + # Get edges and counts per edge
1.2109 + my %edge = ();
1.2110 + my $n;
1.2111 + my $fullname_to_shortname_map = {};
1.2112 + FillFullnameToShortnameMap($symbols, $fullname_to_shortname_map);
1.2113 + foreach my $k (keys(%{$raw})) {
1.2114 + # TODO: omit low %age edges
1.2115 + $n = $raw->{$k};
1.2116 + my @translated = TranslateStack($symbols, $fullname_to_shortname_map, $k);
1.2117 + for (my $i = 1; $i <= $#translated; $i++) {
1.2118 + my $src = $translated[$i];
1.2119 + my $dst = $translated[$i-1];
1.2120 + #next if ($src eq $dst); # Avoid self-edges?
1.2121 + if (exists($node{$src}) && exists($node{$dst})) {
1.2122 + my $edge_label = "$src\001$dst";
1.2123 + if (!exists($edge{$edge_label})) {
1.2124 + $edge{$edge_label} = 0;
1.2125 + }
1.2126 + $edge{$edge_label} += $n;
1.2127 + }
1.2128 + }
1.2129 + }
1.2130 +
1.2131 + # Print edges (process in order of decreasing counts)
1.2132 + my %indegree = (); # Number of incoming edges added per node so far
1.2133 + my %outdegree = (); # Number of outgoing edges added per node so far
1.2134 + foreach my $e (sort { $edge{$b} <=> $edge{$a} } keys(%edge)) {
1.2135 + my @x = split(/\001/, $e);
1.2136 + $n = $edge{$e};
1.2137 +
1.2138 + # Initialize degree of kept incoming and outgoing edges if necessary
1.2139 + my $src = $x[0];
1.2140 + my $dst = $x[1];
1.2141 + if (!exists($outdegree{$src})) { $outdegree{$src} = 0; }
1.2142 + if (!exists($indegree{$dst})) { $indegree{$dst} = 0; }
1.2143 +
1.2144 + my $keep;
1.2145 + if ($indegree{$dst} == 0) {
1.2146 + # Keep edge if needed for reachability
1.2147 + $keep = 1;
1.2148 + } elsif (abs($n) <= $edgelimit) {
1.2149 + # Drop if we are below --edgefraction
1.2150 + $keep = 0;
1.2151 + } elsif ($outdegree{$src} >= $main::opt_maxdegree ||
1.2152 + $indegree{$dst} >= $main::opt_maxdegree) {
1.2153 + # Keep limited number of in/out edges per node
1.2154 + $keep = 0;
1.2155 + } else {
1.2156 + $keep = 1;
1.2157 + }
1.2158 +
1.2159 + if ($keep) {
1.2160 + $outdegree{$src}++;
1.2161 + $indegree{$dst}++;
1.2162 +
1.2163 + # Compute line width based on edge count
1.2164 + my $fraction = abs($local_total ? (3 * ($n / $local_total)) : 0);
1.2165 + if ($fraction > 1) { $fraction = 1; }
1.2166 + my $w = $fraction * 2;
1.2167 + if ($w < 1 && ($main::opt_web || $main::opt_svg)) {
1.2168 + # SVG output treats line widths < 1 poorly.
1.2169 + $w = 1;
1.2170 + }
1.2171 +
1.2172 + # Dot sometimes segfaults if given edge weights that are too large, so
1.2173 + # we cap the weights at a large value
1.2174 + my $edgeweight = abs($n) ** 0.7;
1.2175 + if ($edgeweight > 100000) { $edgeweight = 100000; }
1.2176 + $edgeweight = int($edgeweight);
1.2177 +
1.2178 + my $style = sprintf("setlinewidth(%f)", $w);
1.2179 + if ($x[1] =~ m/\(inline\)/) {
1.2180 + $style .= ",dashed";
1.2181 + }
1.2182 +
1.2183 + # Use a slightly squashed function of the edge count as the weight
1.2184 + printf DOT ("N%s -> N%s [label=%s, weight=%d, style=\"%s\"];\n",
1.2185 + $node{$x[0]},
1.2186 + $node{$x[1]},
1.2187 + Unparse($n),
1.2188 + $edgeweight,
1.2189 + $style);
1.2190 + }
1.2191 + }
1.2192 +
1.2193 + print DOT ("}\n");
1.2194 + close(DOT);
1.2195 +
1.2196 + if ($main::opt_web || $main::opt_svg) {
1.2197 + # Rewrite SVG to be more usable inside web browser.
1.2198 + RewriteSvg(TempName($main::next_tmpfile, "svg"));
1.2199 + }
1.2200 +
1.2201 + return 1;
1.2202 +}
1.2203 +
1.2204 +sub RewriteSvg {
1.2205 + my $svgfile = shift;
1.2206 +
1.2207 + open(SVG, $svgfile) || die "open temp svg: $!";
1.2208 + my @svg = <SVG>;
1.2209 + close(SVG);
1.2210 + unlink $svgfile;
1.2211 + my $svg = join('', @svg);
1.2212 +
1.2213 + # Dot's SVG output is
1.2214 + #
1.2215 + # <svg width="___" height="___"
1.2216 + # viewBox="___" xmlns=...>
1.2217 + # <g id="graph0" transform="...">
1.2218 + # ...
1.2219 + # </g>
1.2220 + # </svg>
1.2221 + #
1.2222 + # Change it to
1.2223 + #
1.2224 + # <svg width="100%" height="100%"
1.2225 + # xmlns=...>
1.2226 + # $svg_javascript
1.2227 + # <g id="viewport" transform="translate(0,0)">
1.2228 + # <g id="graph0" transform="...">
1.2229 + # ...
1.2230 + # </g>
1.2231 + # </g>
1.2232 + # </svg>
1.2233 +
1.2234 + # Fix width, height; drop viewBox.
1.2235 + $svg =~ s/(?s)<svg width="[^"]+" height="[^"]+"(.*?)viewBox="[^"]+"/<svg width="100%" height="100%"$1/;
1.2236 +
1.2237 + # Insert script, viewport <g> above first <g>
1.2238 + my $svg_javascript = SvgJavascript();
1.2239 + my $viewport = "<g id=\"viewport\" transform=\"translate(0,0)\">\n";
1.2240 + $svg =~ s/<g id="graph\d"/$svg_javascript$viewport$&/;
1.2241 +
1.2242 + # Insert final </g> above </svg>.
1.2243 + $svg =~ s/(.*)(<\/svg>)/$1<\/g>$2/;
1.2244 + $svg =~ s/<g id="graph\d"(.*?)/<g id="viewport"$1/;
1.2245 +
1.2246 + if ($main::opt_svg) {
1.2247 + # --svg: write to standard output.
1.2248 + print $svg;
1.2249 + } else {
1.2250 + # Write back to temporary file.
1.2251 + open(SVG, ">$svgfile") || die "open $svgfile: $!";
1.2252 + print SVG $svg;
1.2253 + close(SVG);
1.2254 + }
1.2255 +}
1.2256 +
1.2257 +sub SvgJavascript {
1.2258 + return <<'EOF';
1.2259 +<script type="text/ecmascript"><![CDATA[
1.2260 +// SVGPan
1.2261 +// http://www.cyberz.org/blog/2009/12/08/svgpan-a-javascript-svg-panzoomdrag-library/
1.2262 +// Local modification: if(true || ...) below to force panning, never moving.
1.2263 +
1.2264 +/**
1.2265 + * SVGPan library 1.2
1.2266 + * ====================
1.2267 + *
1.2268 + * Given an unique existing element with id "viewport", including the
1.2269 + * the library into any SVG adds the following capabilities:
1.2270 + *
1.2271 + * - Mouse panning
1.2272 + * - Mouse zooming (using the wheel)
1.2273 + * - Object dargging
1.2274 + *
1.2275 + * Known issues:
1.2276 + *
1.2277 + * - Zooming (while panning) on Safari has still some issues
1.2278 + *
1.2279 + * Releases:
1.2280 + *
1.2281 + * 1.2, Sat Mar 20 08:42:50 GMT 2010, Zeng Xiaohui
1.2282 + * Fixed a bug with browser mouse handler interaction
1.2283 + *
1.2284 + * 1.1, Wed Feb 3 17:39:33 GMT 2010, Zeng Xiaohui
1.2285 + * Updated the zoom code to support the mouse wheel on Safari/Chrome
1.2286 + *
1.2287 + * 1.0, Andrea Leofreddi
1.2288 + * First release
1.2289 + *
1.2290 + * This code is licensed under the following BSD license:
1.2291 + *
1.2292 + * Copyright 2009-2010 Andrea Leofreddi <a.leofreddi@itcharm.com>. All rights reserved.
1.2293 + *
1.2294 + * Redistribution and use in source and binary forms, with or without modification, are
1.2295 + * permitted provided that the following conditions are met:
1.2296 + *
1.2297 + * 1. Redistributions of source code must retain the above copyright notice, this list of
1.2298 + * conditions and the following disclaimer.
1.2299 + *
1.2300 + * 2. Redistributions in binary form must reproduce the above copyright notice, this list
1.2301 + * of conditions and the following disclaimer in the documentation and/or other materials
1.2302 + * provided with the distribution.
1.2303 + *
1.2304 + * THIS SOFTWARE IS PROVIDED BY Andrea Leofreddi ``AS IS'' AND ANY EXPRESS OR IMPLIED
1.2305 + * WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
1.2306 + * FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL Andrea Leofreddi OR
1.2307 + * CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
1.2308 + * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
1.2309 + * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
1.2310 + * ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
1.2311 + * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
1.2312 + * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
1.2313 + *
1.2314 + * The views and conclusions contained in the software and documentation are those of the
1.2315 + * authors and should not be interpreted as representing official policies, either expressed
1.2316 + * or implied, of Andrea Leofreddi.
1.2317 + */
1.2318 +
1.2319 +var root = document.documentElement;
1.2320 +
1.2321 +var state = 'none', stateTarget, stateOrigin, stateTf;
1.2322 +
1.2323 +setupHandlers(root);
1.2324 +
1.2325 +/**
1.2326 + * Register handlers
1.2327 + */
1.2328 +function setupHandlers(root){
1.2329 + setAttributes(root, {
1.2330 + "onmouseup" : "add(evt)",
1.2331 + "onmousedown" : "handleMouseDown(evt)",
1.2332 + "onmousemove" : "handleMouseMove(evt)",
1.2333 + "onmouseup" : "handleMouseUp(evt)",
1.2334 + //"onmouseout" : "handleMouseUp(evt)", // Decomment this to stop the pan functionality when dragging out of the SVG element
1.2335 + });
1.2336 +
1.2337 + if(navigator.userAgent.toLowerCase().indexOf('webkit') >= 0)
1.2338 + window.addEventListener('mousewheel', handleMouseWheel, false); // Chrome/Safari
1.2339 + else
1.2340 + window.addEventListener('DOMMouseScroll', handleMouseWheel, false); // Others
1.2341 +
1.2342 + var g = svgDoc.getElementById("svg");
1.2343 + g.width = "100%";
1.2344 + g.height = "100%";
1.2345 +}
1.2346 +
1.2347 +/**
1.2348 + * Instance an SVGPoint object with given event coordinates.
1.2349 + */
1.2350 +function getEventPoint(evt) {
1.2351 + var p = root.createSVGPoint();
1.2352 +
1.2353 + p.x = evt.clientX;
1.2354 + p.y = evt.clientY;
1.2355 +
1.2356 + return p;
1.2357 +}
1.2358 +
1.2359 +/**
1.2360 + * Sets the current transform matrix of an element.
1.2361 + */
1.2362 +function setCTM(element, matrix) {
1.2363 + var s = "matrix(" + matrix.a + "," + matrix.b + "," + matrix.c + "," + matrix.d + "," + matrix.e + "," + matrix.f + ")";
1.2364 +
1.2365 + element.setAttribute("transform", s);
1.2366 +}
1.2367 +
1.2368 +/**
1.2369 + * Dumps a matrix to a string (useful for debug).
1.2370 + */
1.2371 +function dumpMatrix(matrix) {
1.2372 + var s = "[ " + matrix.a + ", " + matrix.c + ", " + matrix.e + "\n " + matrix.b + ", " + matrix.d + ", " + matrix.f + "\n 0, 0, 1 ]";
1.2373 +
1.2374 + return s;
1.2375 +}
1.2376 +
1.2377 +/**
1.2378 + * Sets attributes of an element.
1.2379 + */
1.2380 +function setAttributes(element, attributes){
1.2381 + for (i in attributes)
1.2382 + element.setAttributeNS(null, i, attributes[i]);
1.2383 +}
1.2384 +
1.2385 +/**
1.2386 + * Handle mouse move event.
1.2387 + */
1.2388 +function handleMouseWheel(evt) {
1.2389 + if(evt.preventDefault)
1.2390 + evt.preventDefault();
1.2391 +
1.2392 + evt.returnValue = false;
1.2393 +
1.2394 + var svgDoc = evt.target.ownerDocument;
1.2395 +
1.2396 + var delta;
1.2397 +
1.2398 + if(evt.wheelDelta)
1.2399 + delta = evt.wheelDelta / 3600; // Chrome/Safari
1.2400 + else
1.2401 + delta = evt.detail / -90; // Mozilla
1.2402 +
1.2403 + var z = 1 + delta; // Zoom factor: 0.9/1.1
1.2404 +
1.2405 + var g = svgDoc.getElementById("viewport");
1.2406 +
1.2407 + var p = getEventPoint(evt);
1.2408 +
1.2409 + p = p.matrixTransform(g.getCTM().inverse());
1.2410 +
1.2411 + // Compute new scale matrix in current mouse position
1.2412 + var k = root.createSVGMatrix().translate(p.x, p.y).scale(z).translate(-p.x, -p.y);
1.2413 +
1.2414 + setCTM(g, g.getCTM().multiply(k));
1.2415 +
1.2416 + stateTf = stateTf.multiply(k.inverse());
1.2417 +}
1.2418 +
1.2419 +/**
1.2420 + * Handle mouse move event.
1.2421 + */
1.2422 +function handleMouseMove(evt) {
1.2423 + if(evt.preventDefault)
1.2424 + evt.preventDefault();
1.2425 +
1.2426 + evt.returnValue = false;
1.2427 +
1.2428 + var svgDoc = evt.target.ownerDocument;
1.2429 +
1.2430 + var g = svgDoc.getElementById("viewport");
1.2431 +
1.2432 + if(state == 'pan') {
1.2433 + // Pan mode
1.2434 + var p = getEventPoint(evt).matrixTransform(stateTf);
1.2435 +
1.2436 + setCTM(g, stateTf.inverse().translate(p.x - stateOrigin.x, p.y - stateOrigin.y));
1.2437 + } else if(state == 'move') {
1.2438 + // Move mode
1.2439 + var p = getEventPoint(evt).matrixTransform(g.getCTM().inverse());
1.2440 +
1.2441 + setCTM(stateTarget, root.createSVGMatrix().translate(p.x - stateOrigin.x, p.y - stateOrigin.y).multiply(g.getCTM().inverse()).multiply(stateTarget.getCTM()));
1.2442 +
1.2443 + stateOrigin = p;
1.2444 + }
1.2445 +}
1.2446 +
1.2447 +/**
1.2448 + * Handle click event.
1.2449 + */
1.2450 +function handleMouseDown(evt) {
1.2451 + if(evt.preventDefault)
1.2452 + evt.preventDefault();
1.2453 +
1.2454 + evt.returnValue = false;
1.2455 +
1.2456 + var svgDoc = evt.target.ownerDocument;
1.2457 +
1.2458 + var g = svgDoc.getElementById("viewport");
1.2459 +
1.2460 + if(true || evt.target.tagName == "svg") {
1.2461 + // Pan mode
1.2462 + state = 'pan';
1.2463 +
1.2464 + stateTf = g.getCTM().inverse();
1.2465 +
1.2466 + stateOrigin = getEventPoint(evt).matrixTransform(stateTf);
1.2467 + } else {
1.2468 + // Move mode
1.2469 + state = 'move';
1.2470 +
1.2471 + stateTarget = evt.target;
1.2472 +
1.2473 + stateTf = g.getCTM().inverse();
1.2474 +
1.2475 + stateOrigin = getEventPoint(evt).matrixTransform(stateTf);
1.2476 + }
1.2477 +}
1.2478 +
1.2479 +/**
1.2480 + * Handle mouse button release event.
1.2481 + */
1.2482 +function handleMouseUp(evt) {
1.2483 + if(evt.preventDefault)
1.2484 + evt.preventDefault();
1.2485 +
1.2486 + evt.returnValue = false;
1.2487 +
1.2488 + var svgDoc = evt.target.ownerDocument;
1.2489 +
1.2490 + if(state == 'pan' || state == 'move') {
1.2491 + // Quit pan mode
1.2492 + state = '';
1.2493 + }
1.2494 +}
1.2495 +
1.2496 +]]></script>
1.2497 +EOF
1.2498 +}
1.2499 +
1.2500 +# Provides a map from fullname to shortname for cases where the
1.2501 +# shortname is ambiguous. The symlist has both the fullname and
1.2502 +# shortname for all symbols, which is usually fine, but sometimes --
1.2503 +# such as overloaded functions -- two different fullnames can map to
1.2504 +# the same shortname. In that case, we use the address of the
1.2505 +# function to disambiguate the two. This function fills in a map that
1.2506 +# maps fullnames to modified shortnames in such cases. If a fullname
1.2507 +# is not present in the map, the 'normal' shortname provided by the
1.2508 +# symlist is the appropriate one to use.
1.2509 +sub FillFullnameToShortnameMap {
1.2510 + my $symbols = shift;
1.2511 + my $fullname_to_shortname_map = shift;
1.2512 + my $shortnames_seen_once = {};
1.2513 + my $shortnames_seen_more_than_once = {};
1.2514 +
1.2515 + foreach my $symlist (values(%{$symbols})) {
1.2516 + # TODO(csilvers): deal with inlined symbols too.
1.2517 + my $shortname = $symlist->[0];
1.2518 + my $fullname = $symlist->[2];
1.2519 + if ($fullname !~ /<[0-9a-fA-F]+>$/) { # fullname doesn't end in an address
1.2520 + next; # the only collisions we care about are when addresses differ
1.2521 + }
1.2522 + if (defined($shortnames_seen_once->{$shortname}) &&
1.2523 + $shortnames_seen_once->{$shortname} ne $fullname) {
1.2524 + $shortnames_seen_more_than_once->{$shortname} = 1;
1.2525 + } else {
1.2526 + $shortnames_seen_once->{$shortname} = $fullname;
1.2527 + }
1.2528 + }
1.2529 +
1.2530 + foreach my $symlist (values(%{$symbols})) {
1.2531 + my $shortname = $symlist->[0];
1.2532 + my $fullname = $symlist->[2];
1.2533 + # TODO(csilvers): take in a list of addresses we care about, and only
1.2534 + # store in the map if $symlist->[1] is in that list. Saves space.
1.2535 + next if defined($fullname_to_shortname_map->{$fullname});
1.2536 + if (defined($shortnames_seen_more_than_once->{$shortname})) {
1.2537 + if ($fullname =~ /<0*([^>]*)>$/) { # fullname has address at end of it
1.2538 + $fullname_to_shortname_map->{$fullname} = "$shortname\@$1";
1.2539 + }
1.2540 + }
1.2541 + }
1.2542 +}
1.2543 +
1.2544 +# Return a small number that identifies the argument.
1.2545 +# Multiple calls with the same argument will return the same number.
1.2546 +# Calls with different arguments will return different numbers.
1.2547 +sub ShortIdFor {
1.2548 + my $key = shift;
1.2549 + my $id = $main::uniqueid{$key};
1.2550 + if (!defined($id)) {
1.2551 + $id = keys(%main::uniqueid) + 1;
1.2552 + $main::uniqueid{$key} = $id;
1.2553 + }
1.2554 + return $id;
1.2555 +}
1.2556 +
1.2557 +# Translate a stack of addresses into a stack of symbols
1.2558 +sub TranslateStack {
1.2559 + my $symbols = shift;
1.2560 + my $fullname_to_shortname_map = shift;
1.2561 + my $k = shift;
1.2562 +
1.2563 + my @addrs = split(/\n/, $k);
1.2564 + my @result = ();
1.2565 + for (my $i = 0; $i <= $#addrs; $i++) {
1.2566 + my $a = $addrs[$i];
1.2567 +
1.2568 + # Skip large addresses since they sometimes show up as fake entries on RH9
1.2569 + if (length($a) > 8 && $a gt "7fffffffffffffff") {
1.2570 + next;
1.2571 + }
1.2572 +
1.2573 + if ($main::opt_disasm || $main::opt_list) {
1.2574 + # We want just the address for the key
1.2575 + push(@result, $a);
1.2576 + next;
1.2577 + }
1.2578 +
1.2579 + my $symlist = $symbols->{$a};
1.2580 + if (!defined($symlist)) {
1.2581 + $symlist = [$a, "", $a];
1.2582 + }
1.2583 +
1.2584 + # We can have a sequence of symbols for a particular entry
1.2585 + # (more than one symbol in the case of inlining). Callers
1.2586 + # come before callees in symlist, so walk backwards since
1.2587 + # the translated stack should contain callees before callers.
1.2588 + for (my $j = $#{$symlist}; $j >= 2; $j -= 3) {
1.2589 + my $func = $symlist->[$j-2];
1.2590 + my $fileline = $symlist->[$j-1];
1.2591 + my $fullfunc = $symlist->[$j];
1.2592 + if (defined($fullname_to_shortname_map->{$fullfunc})) {
1.2593 + $func = $fullname_to_shortname_map->{$fullfunc};
1.2594 + }
1.2595 + if ($j > 2) {
1.2596 + $func = "$func (inline)";
1.2597 + }
1.2598 +
1.2599 + # Do not merge nodes corresponding to Callback::Run since that
1.2600 + # causes confusing cycles in dot display. Instead, we synthesize
1.2601 + # a unique name for this frame per caller.
1.2602 + if ($func =~ m/Callback.*::Run$/) {
1.2603 + my $caller = ($i > 0) ? $addrs[$i-1] : 0;
1.2604 + $func = "Run#" . ShortIdFor($caller);
1.2605 + }
1.2606 +
1.2607 + if ($main::opt_addresses) {
1.2608 + push(@result, "$a $func $fileline");
1.2609 + } elsif ($main::opt_lines) {
1.2610 + if ($func eq '??' && $fileline eq '??:0') {
1.2611 + push(@result, "$a");
1.2612 + } else {
1.2613 + push(@result, "$func $fileline");
1.2614 + }
1.2615 + } elsif ($main::opt_functions) {
1.2616 + if ($func eq '??') {
1.2617 + push(@result, "$a");
1.2618 + } else {
1.2619 + push(@result, $func);
1.2620 + }
1.2621 + } elsif ($main::opt_files) {
1.2622 + if ($fileline eq '??:0' || $fileline eq '') {
1.2623 + push(@result, "$a");
1.2624 + } else {
1.2625 + my $f = $fileline;
1.2626 + $f =~ s/:\d+$//;
1.2627 + push(@result, $f);
1.2628 + }
1.2629 + } else {
1.2630 + push(@result, $a);
1.2631 + last; # Do not print inlined info
1.2632 + }
1.2633 + }
1.2634 + }
1.2635 +
1.2636 + # print join(",", @addrs), " => ", join(",", @result), "\n";
1.2637 + return @result;
1.2638 +}
1.2639 +
1.2640 +# Generate percent string for a number and a total
1.2641 +sub Percent {
1.2642 + my $num = shift;
1.2643 + my $tot = shift;
1.2644 + if ($tot != 0) {
1.2645 + return sprintf("%.1f%%", $num * 100.0 / $tot);
1.2646 + } else {
1.2647 + return ($num == 0) ? "nan" : (($num > 0) ? "+inf" : "-inf");
1.2648 + }
1.2649 +}
1.2650 +
1.2651 +# Generate pretty-printed form of number
1.2652 +sub Unparse {
1.2653 + my $num = shift;
1.2654 + if ($main::profile_type eq 'heap' || $main::profile_type eq 'growth') {
1.2655 + if ($main::opt_inuse_objects || $main::opt_alloc_objects) {
1.2656 + return sprintf("%d", $num);
1.2657 + } else {
1.2658 + if ($main::opt_show_bytes) {
1.2659 + return sprintf("%d", $num);
1.2660 + } else {
1.2661 + return sprintf("%.1f", $num / 1048576.0);
1.2662 + }
1.2663 + }
1.2664 + } elsif ($main::profile_type eq 'contention' && !$main::opt_contentions) {
1.2665 + return sprintf("%.3f", $num / 1e9); # Convert nanoseconds to seconds
1.2666 + } else {
1.2667 + return sprintf("%d", $num);
1.2668 + }
1.2669 +}
1.2670 +
1.2671 +# Alternate pretty-printed form: 0 maps to "."
1.2672 +sub UnparseAlt {
1.2673 + my $num = shift;
1.2674 + if ($num == 0) {
1.2675 + return ".";
1.2676 + } else {
1.2677 + return Unparse($num);
1.2678 + }
1.2679 +}
1.2680 +
1.2681 +# Alternate pretty-printed form: 0 maps to ""
1.2682 +sub HtmlPrintNumber {
1.2683 + my $num = shift;
1.2684 + if ($num == 0) {
1.2685 + return "";
1.2686 + } else {
1.2687 + return Unparse($num);
1.2688 + }
1.2689 +}
1.2690 +
1.2691 +# Return output units
1.2692 +sub Units {
1.2693 + if ($main::profile_type eq 'heap' || $main::profile_type eq 'growth') {
1.2694 + if ($main::opt_inuse_objects || $main::opt_alloc_objects) {
1.2695 + return "objects";
1.2696 + } else {
1.2697 + if ($main::opt_show_bytes) {
1.2698 + return "B";
1.2699 + } else {
1.2700 + return "MB";
1.2701 + }
1.2702 + }
1.2703 + } elsif ($main::profile_type eq 'contention' && !$main::opt_contentions) {
1.2704 + return "seconds";
1.2705 + } else {
1.2706 + return "samples";
1.2707 + }
1.2708 +}
1.2709 +
1.2710 +##### Profile manipulation code #####
1.2711 +
1.2712 +# Generate flattened profile:
1.2713 +# If count is charged to stack [a,b,c,d], in generated profile,
1.2714 +# it will be charged to [a]
1.2715 +sub FlatProfile {
1.2716 + my $profile = shift;
1.2717 + my $result = {};
1.2718 + foreach my $k (keys(%{$profile})) {
1.2719 + my $count = $profile->{$k};
1.2720 + my @addrs = split(/\n/, $k);
1.2721 + if ($#addrs >= 0) {
1.2722 + AddEntry($result, $addrs[0], $count);
1.2723 + }
1.2724 + }
1.2725 + return $result;
1.2726 +}
1.2727 +
1.2728 +# Generate cumulative profile:
1.2729 +# If count is charged to stack [a,b,c,d], in generated profile,
1.2730 +# it will be charged to [a], [b], [c], [d]
1.2731 +sub CumulativeProfile {
1.2732 + my $profile = shift;
1.2733 + my $result = {};
1.2734 + foreach my $k (keys(%{$profile})) {
1.2735 + my $count = $profile->{$k};
1.2736 + my @addrs = split(/\n/, $k);
1.2737 + foreach my $a (@addrs) {
1.2738 + AddEntry($result, $a, $count);
1.2739 + }
1.2740 + }
1.2741 + return $result;
1.2742 +}
1.2743 +
1.2744 +# If the second-youngest PC on the stack is always the same, returns
1.2745 +# that pc. Otherwise, returns undef.
1.2746 +sub IsSecondPcAlwaysTheSame {
1.2747 + my $profile = shift;
1.2748 +
1.2749 + my $second_pc = undef;
1.2750 + foreach my $k (keys(%{$profile})) {
1.2751 + my @addrs = split(/\n/, $k);
1.2752 + if ($#addrs < 1) {
1.2753 + return undef;
1.2754 + }
1.2755 + if (not defined $second_pc) {
1.2756 + $second_pc = $addrs[1];
1.2757 + } else {
1.2758 + if ($second_pc ne $addrs[1]) {
1.2759 + return undef;
1.2760 + }
1.2761 + }
1.2762 + }
1.2763 + return $second_pc;
1.2764 +}
1.2765 +
1.2766 +sub ExtractSymbolLocation {
1.2767 + my $symbols = shift;
1.2768 + my $address = shift;
1.2769 + # 'addr2line' outputs "??:0" for unknown locations; we do the
1.2770 + # same to be consistent.
1.2771 + my $location = "??:0:unknown";
1.2772 + if (exists $symbols->{$address}) {
1.2773 + my $file = $symbols->{$address}->[1];
1.2774 + if ($file eq "?") {
1.2775 + $file = "??:0"
1.2776 + }
1.2777 + $location = $file . ":" . $symbols->{$address}->[0];
1.2778 + }
1.2779 + return $location;
1.2780 +}
1.2781 +
1.2782 +# Extracts a graph of calls.
1.2783 +sub ExtractCalls {
1.2784 + my $symbols = shift;
1.2785 + my $profile = shift;
1.2786 +
1.2787 + my $calls = {};
1.2788 + while( my ($stack_trace, $count) = each %$profile ) {
1.2789 + my @address = split(/\n/, $stack_trace);
1.2790 + my $destination = ExtractSymbolLocation($symbols, $address[0]);
1.2791 + AddEntry($calls, $destination, $count);
1.2792 + for (my $i = 1; $i <= $#address; $i++) {
1.2793 + my $source = ExtractSymbolLocation($symbols, $address[$i]);
1.2794 + my $call = "$source -> $destination";
1.2795 + AddEntry($calls, $call, $count);
1.2796 + $destination = $source;
1.2797 + }
1.2798 + }
1.2799 +
1.2800 + return $calls;
1.2801 +}
1.2802 +
1.2803 +sub RemoveUninterestingFrames {
1.2804 + my $symbols = shift;
1.2805 + my $profile = shift;
1.2806 +
1.2807 + # List of function names to skip
1.2808 + my %skip = ();
1.2809 + my $skip_regexp = 'NOMATCH';
1.2810 + if ($main::profile_type eq 'heap' || $main::profile_type eq 'growth') {
1.2811 + foreach my $name ('calloc',
1.2812 + 'cfree',
1.2813 + 'malloc',
1.2814 + 'free',
1.2815 + 'memalign',
1.2816 + 'posix_memalign',
1.2817 + 'pvalloc',
1.2818 + 'valloc',
1.2819 + 'realloc',
1.2820 + 'tc_calloc',
1.2821 + 'tc_cfree',
1.2822 + 'tc_malloc',
1.2823 + 'tc_free',
1.2824 + 'tc_memalign',
1.2825 + 'tc_posix_memalign',
1.2826 + 'tc_pvalloc',
1.2827 + 'tc_valloc',
1.2828 + 'tc_realloc',
1.2829 + 'tc_new',
1.2830 + 'tc_delete',
1.2831 + 'tc_newarray',
1.2832 + 'tc_deletearray',
1.2833 + 'tc_new_nothrow',
1.2834 + 'tc_newarray_nothrow',
1.2835 + 'do_malloc',
1.2836 + '::do_malloc', # new name -- got moved to an unnamed ns
1.2837 + '::do_malloc_or_cpp_alloc',
1.2838 + 'DoSampledAllocation',
1.2839 + 'simple_alloc::allocate',
1.2840 + '__malloc_alloc_template::allocate',
1.2841 + '__builtin_delete',
1.2842 + '__builtin_new',
1.2843 + '__builtin_vec_delete',
1.2844 + '__builtin_vec_new',
1.2845 + 'operator new',
1.2846 + 'operator new[]',
1.2847 + # The entry to our memory-allocation routines on OS X
1.2848 + 'malloc_zone_malloc',
1.2849 + 'malloc_zone_calloc',
1.2850 + 'malloc_zone_valloc',
1.2851 + 'malloc_zone_realloc',
1.2852 + 'malloc_zone_memalign',
1.2853 + 'malloc_zone_free',
1.2854 + # These mark the beginning/end of our custom sections
1.2855 + '__start_google_malloc',
1.2856 + '__stop_google_malloc',
1.2857 + '__start_malloc_hook',
1.2858 + '__stop_malloc_hook') {
1.2859 + $skip{$name} = 1;
1.2860 + $skip{"_" . $name} = 1; # Mach (OS X) adds a _ prefix to everything
1.2861 + }
1.2862 + # TODO: Remove TCMalloc once everything has been
1.2863 + # moved into the tcmalloc:: namespace and we have flushed
1.2864 + # old code out of the system.
1.2865 + $skip_regexp = "TCMalloc|^tcmalloc::";
1.2866 + } elsif ($main::profile_type eq 'contention') {
1.2867 + foreach my $vname ('base::RecordLockProfileData',
1.2868 + 'base::SubmitMutexProfileData',
1.2869 + 'base::SubmitSpinLockProfileData',
1.2870 + 'Mutex::Unlock',
1.2871 + 'Mutex::UnlockSlow',
1.2872 + 'Mutex::ReaderUnlock',
1.2873 + 'MutexLock::~MutexLock',
1.2874 + 'SpinLock::Unlock',
1.2875 + 'SpinLock::SlowUnlock',
1.2876 + 'SpinLockHolder::~SpinLockHolder') {
1.2877 + $skip{$vname} = 1;
1.2878 + }
1.2879 + } elsif ($main::profile_type eq 'cpu') {
1.2880 + # Drop signal handlers used for CPU profile collection
1.2881 + # TODO(dpeng): this should not be necessary; it's taken
1.2882 + # care of by the general 2nd-pc mechanism below.
1.2883 + foreach my $name ('ProfileData::Add', # historical
1.2884 + 'ProfileData::prof_handler', # historical
1.2885 + 'CpuProfiler::prof_handler',
1.2886 + '__FRAME_END__',
1.2887 + '__pthread_sighandler',
1.2888 + '__restore') {
1.2889 + $skip{$name} = 1;
1.2890 + }
1.2891 + } else {
1.2892 + # Nothing skipped for unknown types
1.2893 + }
1.2894 +
1.2895 + if ($main::profile_type eq 'cpu') {
1.2896 + # If all the second-youngest program counters are the same,
1.2897 + # this STRONGLY suggests that it is an artifact of measurement,
1.2898 + # i.e., stack frames pushed by the CPU profiler signal handler.
1.2899 + # Hence, we delete them.
1.2900 + # (The topmost PC is read from the signal structure, not from
1.2901 + # the stack, so it does not get involved.)
1.2902 + while (my $second_pc = IsSecondPcAlwaysTheSame($profile)) {
1.2903 + my $result = {};
1.2904 + my $func = '';
1.2905 + if (exists($symbols->{$second_pc})) {
1.2906 + $second_pc = $symbols->{$second_pc}->[0];
1.2907 + }
1.2908 + print STDERR "Removing $second_pc from all stack traces.\n";
1.2909 + foreach my $k (keys(%{$profile})) {
1.2910 + my $count = $profile->{$k};
1.2911 + my @addrs = split(/\n/, $k);
1.2912 + splice @addrs, 1, 1;
1.2913 + my $reduced_path = join("\n", @addrs);
1.2914 + AddEntry($result, $reduced_path, $count);
1.2915 + }
1.2916 + $profile = $result;
1.2917 + }
1.2918 + }
1.2919 +
1.2920 + my $result = {};
1.2921 + foreach my $k (keys(%{$profile})) {
1.2922 + my $count = $profile->{$k};
1.2923 + my @addrs = split(/\n/, $k);
1.2924 + my @path = ();
1.2925 + foreach my $a (@addrs) {
1.2926 + if (exists($symbols->{$a})) {
1.2927 + my $func = $symbols->{$a}->[0];
1.2928 + if ($skip{$func} || ($func =~ m/$skip_regexp/)) {
1.2929 + next;
1.2930 + }
1.2931 + }
1.2932 + push(@path, $a);
1.2933 + }
1.2934 + my $reduced_path = join("\n", @path);
1.2935 + AddEntry($result, $reduced_path, $count);
1.2936 + }
1.2937 + return $result;
1.2938 +}
1.2939 +
1.2940 +# Reduce profile to granularity given by user
1.2941 +sub ReduceProfile {
1.2942 + my $symbols = shift;
1.2943 + my $profile = shift;
1.2944 + my $result = {};
1.2945 + my $fullname_to_shortname_map = {};
1.2946 + FillFullnameToShortnameMap($symbols, $fullname_to_shortname_map);
1.2947 + foreach my $k (keys(%{$profile})) {
1.2948 + my $count = $profile->{$k};
1.2949 + my @translated = TranslateStack($symbols, $fullname_to_shortname_map, $k);
1.2950 + my @path = ();
1.2951 + my %seen = ();
1.2952 + $seen{''} = 1; # So that empty keys are skipped
1.2953 + foreach my $e (@translated) {
1.2954 + # To avoid double-counting due to recursion, skip a stack-trace
1.2955 + # entry if it has already been seen
1.2956 + if (!$seen{$e}) {
1.2957 + $seen{$e} = 1;
1.2958 + push(@path, $e);
1.2959 + }
1.2960 + }
1.2961 + my $reduced_path = join("\n", @path);
1.2962 + AddEntry($result, $reduced_path, $count);
1.2963 + }
1.2964 + return $result;
1.2965 +}
1.2966 +
1.2967 +# Does the specified symbol array match the regexp?
1.2968 +sub SymbolMatches {
1.2969 + my $sym = shift;
1.2970 + my $re = shift;
1.2971 + if (defined($sym)) {
1.2972 + for (my $i = 0; $i < $#{$sym}; $i += 3) {
1.2973 + if ($sym->[$i] =~ m/$re/ || $sym->[$i+1] =~ m/$re/) {
1.2974 + return 1;
1.2975 + }
1.2976 + }
1.2977 + }
1.2978 + return 0;
1.2979 +}
1.2980 +
1.2981 +# Focus only on paths involving specified regexps
1.2982 +sub FocusProfile {
1.2983 + my $symbols = shift;
1.2984 + my $profile = shift;
1.2985 + my $focus = shift;
1.2986 + my $result = {};
1.2987 + foreach my $k (keys(%{$profile})) {
1.2988 + my $count = $profile->{$k};
1.2989 + my @addrs = split(/\n/, $k);
1.2990 + foreach my $a (@addrs) {
1.2991 + # Reply if it matches either the address/shortname/fileline
1.2992 + if (($a =~ m/$focus/) || SymbolMatches($symbols->{$a}, $focus)) {
1.2993 + AddEntry($result, $k, $count);
1.2994 + last;
1.2995 + }
1.2996 + }
1.2997 + }
1.2998 + return $result;
1.2999 +}
1.3000 +
1.3001 +# Focus only on paths not involving specified regexps
1.3002 +sub IgnoreProfile {
1.3003 + my $symbols = shift;
1.3004 + my $profile = shift;
1.3005 + my $ignore = shift;
1.3006 + my $result = {};
1.3007 + foreach my $k (keys(%{$profile})) {
1.3008 + my $count = $profile->{$k};
1.3009 + my @addrs = split(/\n/, $k);
1.3010 + my $matched = 0;
1.3011 + foreach my $a (@addrs) {
1.3012 + # Reply if it matches either the address/shortname/fileline
1.3013 + if (($a =~ m/$ignore/) || SymbolMatches($symbols->{$a}, $ignore)) {
1.3014 + $matched = 1;
1.3015 + last;
1.3016 + }
1.3017 + }
1.3018 + if (!$matched) {
1.3019 + AddEntry($result, $k, $count);
1.3020 + }
1.3021 + }
1.3022 + return $result;
1.3023 +}
1.3024 +
1.3025 +# Get total count in profile
1.3026 +sub TotalProfile {
1.3027 + my $profile = shift;
1.3028 + my $result = 0;
1.3029 + foreach my $k (keys(%{$profile})) {
1.3030 + $result += $profile->{$k};
1.3031 + }
1.3032 + return $result;
1.3033 +}
1.3034 +
1.3035 +# Add A to B
1.3036 +sub AddProfile {
1.3037 + my $A = shift;
1.3038 + my $B = shift;
1.3039 +
1.3040 + my $R = {};
1.3041 + # add all keys in A
1.3042 + foreach my $k (keys(%{$A})) {
1.3043 + my $v = $A->{$k};
1.3044 + AddEntry($R, $k, $v);
1.3045 + }
1.3046 + # add all keys in B
1.3047 + foreach my $k (keys(%{$B})) {
1.3048 + my $v = $B->{$k};
1.3049 + AddEntry($R, $k, $v);
1.3050 + }
1.3051 + return $R;
1.3052 +}
1.3053 +
1.3054 +# Merges symbol maps
1.3055 +sub MergeSymbols {
1.3056 + my $A = shift;
1.3057 + my $B = shift;
1.3058 +
1.3059 + my $R = {};
1.3060 + foreach my $k (keys(%{$A})) {
1.3061 + $R->{$k} = $A->{$k};
1.3062 + }
1.3063 + if (defined($B)) {
1.3064 + foreach my $k (keys(%{$B})) {
1.3065 + $R->{$k} = $B->{$k};
1.3066 + }
1.3067 + }
1.3068 + return $R;
1.3069 +}
1.3070 +
1.3071 +
1.3072 +# Add A to B
1.3073 +sub AddPcs {
1.3074 + my $A = shift;
1.3075 + my $B = shift;
1.3076 +
1.3077 + my $R = {};
1.3078 + # add all keys in A
1.3079 + foreach my $k (keys(%{$A})) {
1.3080 + $R->{$k} = 1
1.3081 + }
1.3082 + # add all keys in B
1.3083 + foreach my $k (keys(%{$B})) {
1.3084 + $R->{$k} = 1
1.3085 + }
1.3086 + return $R;
1.3087 +}
1.3088 +
1.3089 +# Subtract B from A
1.3090 +sub SubtractProfile {
1.3091 + my $A = shift;
1.3092 + my $B = shift;
1.3093 +
1.3094 + my $R = {};
1.3095 + foreach my $k (keys(%{$A})) {
1.3096 + my $v = $A->{$k} - GetEntry($B, $k);
1.3097 + if ($v < 0 && $main::opt_drop_negative) {
1.3098 + $v = 0;
1.3099 + }
1.3100 + AddEntry($R, $k, $v);
1.3101 + }
1.3102 + if (!$main::opt_drop_negative) {
1.3103 + # Take care of when subtracted profile has more entries
1.3104 + foreach my $k (keys(%{$B})) {
1.3105 + if (!exists($A->{$k})) {
1.3106 + AddEntry($R, $k, 0 - $B->{$k});
1.3107 + }
1.3108 + }
1.3109 + }
1.3110 + return $R;
1.3111 +}
1.3112 +
1.3113 +# Get entry from profile; zero if not present
1.3114 +sub GetEntry {
1.3115 + my $profile = shift;
1.3116 + my $k = shift;
1.3117 + if (exists($profile->{$k})) {
1.3118 + return $profile->{$k};
1.3119 + } else {
1.3120 + return 0;
1.3121 + }
1.3122 +}
1.3123 +
1.3124 +# Add entry to specified profile
1.3125 +sub AddEntry {
1.3126 + my $profile = shift;
1.3127 + my $k = shift;
1.3128 + my $n = shift;
1.3129 + if (!exists($profile->{$k})) {
1.3130 + $profile->{$k} = 0;
1.3131 + }
1.3132 + $profile->{$k} += $n;
1.3133 +}
1.3134 +
1.3135 +# Add a stack of entries to specified profile, and add them to the $pcs
1.3136 +# list.
1.3137 +sub AddEntries {
1.3138 + my $profile = shift;
1.3139 + my $pcs = shift;
1.3140 + my $stack = shift;
1.3141 + my $count = shift;
1.3142 + my @k = ();
1.3143 +
1.3144 + foreach my $e (split(/\s+/, $stack)) {
1.3145 + my $pc = HexExtend($e);
1.3146 + $pcs->{$pc} = 1;
1.3147 + push @k, $pc;
1.3148 + }
1.3149 + AddEntry($profile, (join "\n", @k), $count);
1.3150 +}
1.3151 +
1.3152 +##### Code to profile a server dynamically #####
1.3153 +
1.3154 +sub CheckSymbolPage {
1.3155 + my $url = SymbolPageURL();
1.3156 + my $command = ShellEscape(@URL_FETCHER, $url);
1.3157 + open(SYMBOL, "$command |") or error($command);
1.3158 + my $line = <SYMBOL>;
1.3159 + $line =~ s/\r//g; # turn windows-looking lines into unix-looking lines
1.3160 + close(SYMBOL);
1.3161 + unless (defined($line)) {
1.3162 + error("$url doesn't exist\n");
1.3163 + }
1.3164 +
1.3165 + if ($line =~ /^num_symbols:\s+(\d+)$/) {
1.3166 + if ($1 == 0) {
1.3167 + error("Stripped binary. No symbols available.\n");
1.3168 + }
1.3169 + } else {
1.3170 + error("Failed to get the number of symbols from $url\n");
1.3171 + }
1.3172 +}
1.3173 +
1.3174 +sub IsProfileURL {
1.3175 + my $profile_name = shift;
1.3176 + if (-f $profile_name) {
1.3177 + printf STDERR "Using local file $profile_name.\n";
1.3178 + return 0;
1.3179 + }
1.3180 + return 1;
1.3181 +}
1.3182 +
1.3183 +sub ParseProfileURL {
1.3184 + my $profile_name = shift;
1.3185 +
1.3186 + if (!defined($profile_name) || $profile_name eq "") {
1.3187 + return ();
1.3188 + }
1.3189 +
1.3190 + # Split profile URL - matches all non-empty strings, so no test.
1.3191 + $profile_name =~ m,^(https?://)?([^/]+)(.*?)(/|$PROFILES)?$,;
1.3192 +
1.3193 + my $proto = $1 || "http://";
1.3194 + my $hostport = $2;
1.3195 + my $prefix = $3;
1.3196 + my $profile = $4 || "/";
1.3197 +
1.3198 + my $host = $hostport;
1.3199 + $host =~ s/:.*//;
1.3200 +
1.3201 + my $baseurl = "$proto$hostport$prefix";
1.3202 + return ($host, $baseurl, $profile);
1.3203 +}
1.3204 +
1.3205 +# We fetch symbols from the first profile argument.
1.3206 +sub SymbolPageURL {
1.3207 + my ($host, $baseURL, $path) = ParseProfileURL($main::pfile_args[0]);
1.3208 + return "$baseURL$SYMBOL_PAGE";
1.3209 +}
1.3210 +
1.3211 +sub FetchProgramName() {
1.3212 + my ($host, $baseURL, $path) = ParseProfileURL($main::pfile_args[0]);
1.3213 + my $url = "$baseURL$PROGRAM_NAME_PAGE";
1.3214 + my $command_line = ShellEscape(@URL_FETCHER, $url);
1.3215 + open(CMDLINE, "$command_line |") or error($command_line);
1.3216 + my $cmdline = <CMDLINE>;
1.3217 + $cmdline =~ s/\r//g; # turn windows-looking lines into unix-looking lines
1.3218 + close(CMDLINE);
1.3219 + error("Failed to get program name from $url\n") unless defined($cmdline);
1.3220 + $cmdline =~ s/\x00.+//; # Remove argv[1] and latters.
1.3221 + $cmdline =~ s!\n!!g; # Remove LFs.
1.3222 + return $cmdline;
1.3223 +}
1.3224 +
1.3225 +# Gee, curl's -L (--location) option isn't reliable at least
1.3226 +# with its 7.12.3 version. Curl will forget to post data if
1.3227 +# there is a redirection. This function is a workaround for
1.3228 +# curl. Redirection happens on borg hosts.
1.3229 +sub ResolveRedirectionForCurl {
1.3230 + my $url = shift;
1.3231 + my $command_line = ShellEscape(@URL_FETCHER, "--head", $url);
1.3232 + open(CMDLINE, "$command_line |") or error($command_line);
1.3233 + while (<CMDLINE>) {
1.3234 + s/\r//g; # turn windows-looking lines into unix-looking lines
1.3235 + if (/^Location: (.*)/) {
1.3236 + $url = $1;
1.3237 + }
1.3238 + }
1.3239 + close(CMDLINE);
1.3240 + return $url;
1.3241 +}
1.3242 +
1.3243 +# Add a timeout flat to URL_FETCHER. Returns a new list.
1.3244 +sub AddFetchTimeout {
1.3245 + my $timeout = shift;
1.3246 + my @fetcher = shift;
1.3247 + if (defined($timeout)) {
1.3248 + if (join(" ", @fetcher) =~ m/\bcurl -s/) {
1.3249 + push(@fetcher, "--max-time", sprintf("%d", $timeout));
1.3250 + } elsif (join(" ", @fetcher) =~ m/\brpcget\b/) {
1.3251 + push(@fetcher, sprintf("--deadline=%d", $timeout));
1.3252 + }
1.3253 + }
1.3254 + return @fetcher;
1.3255 +}
1.3256 +
1.3257 +# Reads a symbol map from the file handle name given as $1, returning
1.3258 +# the resulting symbol map. Also processes variables relating to symbols.
1.3259 +# Currently, the only variable processed is 'binary=<value>' which updates
1.3260 +# $main::prog to have the correct program name.
1.3261 +sub ReadSymbols {
1.3262 + my $in = shift;
1.3263 + my $map = {};
1.3264 + while (<$in>) {
1.3265 + s/\r//g; # turn windows-looking lines into unix-looking lines
1.3266 + # Removes all the leading zeroes from the symbols, see comment below.
1.3267 + if (m/^0x0*([0-9a-f]+)\s+(.+)/) {
1.3268 + $map->{$1} = $2;
1.3269 + } elsif (m/^---/) {
1.3270 + last;
1.3271 + } elsif (m/^([a-z][^=]*)=(.*)$/ ) {
1.3272 + my ($variable, $value) = ($1, $2);
1.3273 + for ($variable, $value) {
1.3274 + s/^\s+//;
1.3275 + s/\s+$//;
1.3276 + }
1.3277 + if ($variable eq "binary") {
1.3278 + if ($main::prog ne $UNKNOWN_BINARY && $main::prog ne $value) {
1.3279 + printf STDERR ("Warning: Mismatched binary name '%s', using '%s'.\n",
1.3280 + $main::prog, $value);
1.3281 + }
1.3282 + $main::prog = $value;
1.3283 + } else {
1.3284 + printf STDERR ("Ignoring unknown variable in symbols list: " .
1.3285 + "'%s' = '%s'\n", $variable, $value);
1.3286 + }
1.3287 + }
1.3288 + }
1.3289 + return $map;
1.3290 +}
1.3291 +
1.3292 +# Fetches and processes symbols to prepare them for use in the profile output
1.3293 +# code. If the optional 'symbol_map' arg is not given, fetches symbols from
1.3294 +# $SYMBOL_PAGE for all PC values found in profile. Otherwise, the raw symbols
1.3295 +# are assumed to have already been fetched into 'symbol_map' and are simply
1.3296 +# extracted and processed.
1.3297 +sub FetchSymbols {
1.3298 + my $pcset = shift;
1.3299 + my $symbol_map = shift;
1.3300 +
1.3301 + my %seen = ();
1.3302 + my @pcs = grep { !$seen{$_}++ } keys(%$pcset); # uniq
1.3303 +
1.3304 + if (!defined($symbol_map)) {
1.3305 + my $post_data = join("+", sort((map {"0x" . "$_"} @pcs)));
1.3306 +
1.3307 + open(POSTFILE, ">$main::tmpfile_sym");
1.3308 + print POSTFILE $post_data;
1.3309 + close(POSTFILE);
1.3310 +
1.3311 + my $url = SymbolPageURL();
1.3312 +
1.3313 + my $command_line;
1.3314 + if (join(" ", @URL_FETCHER) =~ m/\bcurl -s/) {
1.3315 + $url = ResolveRedirectionForCurl($url);
1.3316 + $command_line = ShellEscape(@URL_FETCHER, "-d", "\@$main::tmpfile_sym",
1.3317 + $url);
1.3318 + } else {
1.3319 + $command_line = (ShellEscape(@URL_FETCHER, "--post", $url)
1.3320 + . " < " . ShellEscape($main::tmpfile_sym));
1.3321 + }
1.3322 + # We use c++filt in case $SYMBOL_PAGE gives us mangled symbols.
1.3323 + my $escaped_cppfilt = ShellEscape($obj_tool_map{"c++filt"});
1.3324 + open(SYMBOL, "$command_line | $escaped_cppfilt |") or error($command_line);
1.3325 + $symbol_map = ReadSymbols(*SYMBOL{IO});
1.3326 + close(SYMBOL);
1.3327 + }
1.3328 +
1.3329 + my $symbols = {};
1.3330 + foreach my $pc (@pcs) {
1.3331 + my $fullname;
1.3332 + # For 64 bits binaries, symbols are extracted with 8 leading zeroes.
1.3333 + # Then /symbol reads the long symbols in as uint64, and outputs
1.3334 + # the result with a "0x%08llx" format which get rid of the zeroes.
1.3335 + # By removing all the leading zeroes in both $pc and the symbols from
1.3336 + # /symbol, the symbols match and are retrievable from the map.
1.3337 + my $shortpc = $pc;
1.3338 + $shortpc =~ s/^0*//;
1.3339 + # Each line may have a list of names, which includes the function
1.3340 + # and also other functions it has inlined. They are separated (in
1.3341 + # PrintSymbolizedProfile), by --, which is illegal in function names.
1.3342 + my $fullnames;
1.3343 + if (defined($symbol_map->{$shortpc})) {
1.3344 + $fullnames = $symbol_map->{$shortpc};
1.3345 + } else {
1.3346 + $fullnames = "0x" . $pc; # Just use addresses
1.3347 + }
1.3348 + my $sym = [];
1.3349 + $symbols->{$pc} = $sym;
1.3350 + foreach my $fullname (split("--", $fullnames)) {
1.3351 + my $name = ShortFunctionName($fullname);
1.3352 + push(@{$sym}, $name, "?", $fullname);
1.3353 + }
1.3354 + }
1.3355 + return $symbols;
1.3356 +}
1.3357 +
1.3358 +sub BaseName {
1.3359 + my $file_name = shift;
1.3360 + $file_name =~ s!^.*/!!; # Remove directory name
1.3361 + return $file_name;
1.3362 +}
1.3363 +
1.3364 +sub MakeProfileBaseName {
1.3365 + my ($binary_name, $profile_name) = @_;
1.3366 + my ($host, $baseURL, $path) = ParseProfileURL($profile_name);
1.3367 + my $binary_shortname = BaseName($binary_name);
1.3368 + return sprintf("%s.%s.%s",
1.3369 + $binary_shortname, $main::op_time, $host);
1.3370 +}
1.3371 +
1.3372 +sub FetchDynamicProfile {
1.3373 + my $binary_name = shift;
1.3374 + my $profile_name = shift;
1.3375 + my $fetch_name_only = shift;
1.3376 + my $encourage_patience = shift;
1.3377 +
1.3378 + if (!IsProfileURL($profile_name)) {
1.3379 + return $profile_name;
1.3380 + } else {
1.3381 + my ($host, $baseURL, $path) = ParseProfileURL($profile_name);
1.3382 + if ($path eq "" || $path eq "/") {
1.3383 + # Missing type specifier defaults to cpu-profile
1.3384 + $path = $PROFILE_PAGE;
1.3385 + }
1.3386 +
1.3387 + my $profile_file = MakeProfileBaseName($binary_name, $profile_name);
1.3388 +
1.3389 + my $url = "$baseURL$path";
1.3390 + my $fetch_timeout = undef;
1.3391 + if ($path =~ m/$PROFILE_PAGE|$PMUPROFILE_PAGE/) {
1.3392 + if ($path =~ m/[?]/) {
1.3393 + $url .= "&";
1.3394 + } else {
1.3395 + $url .= "?";
1.3396 + }
1.3397 + $url .= sprintf("seconds=%d", $main::opt_seconds);
1.3398 + $fetch_timeout = $main::opt_seconds * 1.01 + 60;
1.3399 + } else {
1.3400 + # For non-CPU profiles, we add a type-extension to
1.3401 + # the target profile file name.
1.3402 + my $suffix = $path;
1.3403 + $suffix =~ s,/,.,g;
1.3404 + $profile_file .= $suffix;
1.3405 + }
1.3406 +
1.3407 + my $profile_dir = $ENV{"PPROF_TMPDIR"} || ($ENV{HOME} . "/pprof");
1.3408 + if (! -d $profile_dir) {
1.3409 + mkdir($profile_dir)
1.3410 + || die("Unable to create profile directory $profile_dir: $!\n");
1.3411 + }
1.3412 + my $tmp_profile = "$profile_dir/.tmp.$profile_file";
1.3413 + my $real_profile = "$profile_dir/$profile_file";
1.3414 +
1.3415 + if ($fetch_name_only > 0) {
1.3416 + return $real_profile;
1.3417 + }
1.3418 +
1.3419 + my @fetcher = AddFetchTimeout($fetch_timeout, @URL_FETCHER);
1.3420 + my $cmd = ShellEscape(@fetcher, $url) . " > " . ShellEscape($tmp_profile);
1.3421 + if ($path =~ m/$PROFILE_PAGE|$PMUPROFILE_PAGE|$CENSUSPROFILE_PAGE/){
1.3422 + print STDERR "Gathering CPU profile from $url for $main::opt_seconds seconds to\n ${real_profile}\n";
1.3423 + if ($encourage_patience) {
1.3424 + print STDERR "Be patient...\n";
1.3425 + }
1.3426 + } else {
1.3427 + print STDERR "Fetching $path profile from $url to\n ${real_profile}\n";
1.3428 + }
1.3429 +
1.3430 + (system($cmd) == 0) || error("Failed to get profile: $cmd: $!\n");
1.3431 + (system("mv", $tmp_profile, $real_profile) == 0) || error("Unable to rename profile\n");
1.3432 + print STDERR "Wrote profile to $real_profile\n";
1.3433 + $main::collected_profile = $real_profile;
1.3434 + return $main::collected_profile;
1.3435 + }
1.3436 +}
1.3437 +
1.3438 +# Collect profiles in parallel
1.3439 +sub FetchDynamicProfiles {
1.3440 + my $items = scalar(@main::pfile_args);
1.3441 + my $levels = log($items) / log(2);
1.3442 +
1.3443 + if ($items == 1) {
1.3444 + $main::profile_files[0] = FetchDynamicProfile($main::prog, $main::pfile_args[0], 0, 1);
1.3445 + } else {
1.3446 + # math rounding issues
1.3447 + if ((2 ** $levels) < $items) {
1.3448 + $levels++;
1.3449 + }
1.3450 + my $count = scalar(@main::pfile_args);
1.3451 + for (my $i = 0; $i < $count; $i++) {
1.3452 + $main::profile_files[$i] = FetchDynamicProfile($main::prog, $main::pfile_args[$i], 1, 0);
1.3453 + }
1.3454 + print STDERR "Fetching $count profiles, Be patient...\n";
1.3455 + FetchDynamicProfilesRecurse($levels, 0, 0);
1.3456 + $main::collected_profile = join(" \\\n ", @main::profile_files);
1.3457 + }
1.3458 +}
1.3459 +
1.3460 +# Recursively fork a process to get enough processes
1.3461 +# collecting profiles
1.3462 +sub FetchDynamicProfilesRecurse {
1.3463 + my $maxlevel = shift;
1.3464 + my $level = shift;
1.3465 + my $position = shift;
1.3466 +
1.3467 + if (my $pid = fork()) {
1.3468 + $position = 0 | ($position << 1);
1.3469 + TryCollectProfile($maxlevel, $level, $position);
1.3470 + wait;
1.3471 + } else {
1.3472 + $position = 1 | ($position << 1);
1.3473 + TryCollectProfile($maxlevel, $level, $position);
1.3474 + cleanup();
1.3475 + exit(0);
1.3476 + }
1.3477 +}
1.3478 +
1.3479 +# Collect a single profile
1.3480 +sub TryCollectProfile {
1.3481 + my $maxlevel = shift;
1.3482 + my $level = shift;
1.3483 + my $position = shift;
1.3484 +
1.3485 + if ($level >= ($maxlevel - 1)) {
1.3486 + if ($position < scalar(@main::pfile_args)) {
1.3487 + FetchDynamicProfile($main::prog, $main::pfile_args[$position], 0, 0);
1.3488 + }
1.3489 + } else {
1.3490 + FetchDynamicProfilesRecurse($maxlevel, $level+1, $position);
1.3491 + }
1.3492 +}
1.3493 +
1.3494 +##### Parsing code #####
1.3495 +
1.3496 +# Provide a small streaming-read module to handle very large
1.3497 +# cpu-profile files. Stream in chunks along a sliding window.
1.3498 +# Provides an interface to get one 'slot', correctly handling
1.3499 +# endian-ness differences. A slot is one 32-bit or 64-bit word
1.3500 +# (depending on the input profile). We tell endianness and bit-size
1.3501 +# for the profile by looking at the first 8 bytes: in cpu profiles,
1.3502 +# the second slot is always 3 (we'll accept anything that's not 0).
1.3503 +BEGIN {
1.3504 + package CpuProfileStream;
1.3505 +
1.3506 + sub new {
1.3507 + my ($class, $file, $fname) = @_;
1.3508 + my $self = { file => $file,
1.3509 + base => 0,
1.3510 + stride => 512 * 1024, # must be a multiple of bitsize/8
1.3511 + slots => [],
1.3512 + unpack_code => "", # N for big-endian, V for little
1.3513 + perl_is_64bit => 1, # matters if profile is 64-bit
1.3514 + };
1.3515 + bless $self, $class;
1.3516 + # Let unittests adjust the stride
1.3517 + if ($main::opt_test_stride > 0) {
1.3518 + $self->{stride} = $main::opt_test_stride;
1.3519 + }
1.3520 + # Read the first two slots to figure out bitsize and endianness.
1.3521 + my $slots = $self->{slots};
1.3522 + my $str;
1.3523 + read($self->{file}, $str, 8);
1.3524 + # Set the global $address_length based on what we see here.
1.3525 + # 8 is 32-bit (8 hexadecimal chars); 16 is 64-bit (16 hexadecimal chars).
1.3526 + $address_length = ($str eq (chr(0)x8)) ? 16 : 8;
1.3527 + if ($address_length == 8) {
1.3528 + if (substr($str, 6, 2) eq chr(0)x2) {
1.3529 + $self->{unpack_code} = 'V'; # Little-endian.
1.3530 + } elsif (substr($str, 4, 2) eq chr(0)x2) {
1.3531 + $self->{unpack_code} = 'N'; # Big-endian
1.3532 + } else {
1.3533 + ::error("$fname: header size >= 2**16\n");
1.3534 + }
1.3535 + @$slots = unpack($self->{unpack_code} . "*", $str);
1.3536 + } else {
1.3537 + # If we're a 64-bit profile, check if we're a 64-bit-capable
1.3538 + # perl. Otherwise, each slot will be represented as a float
1.3539 + # instead of an int64, losing precision and making all the
1.3540 + # 64-bit addresses wrong. We won't complain yet, but will
1.3541 + # later if we ever see a value that doesn't fit in 32 bits.
1.3542 + my $has_q = 0;
1.3543 + eval { $has_q = pack("Q", "1") ? 1 : 1; };
1.3544 + if (!$has_q) {
1.3545 + $self->{perl_is_64bit} = 0;
1.3546 + }
1.3547 + read($self->{file}, $str, 8);
1.3548 + if (substr($str, 4, 4) eq chr(0)x4) {
1.3549 + # We'd love to use 'Q', but it's a) not universal, b) not endian-proof.
1.3550 + $self->{unpack_code} = 'V'; # Little-endian.
1.3551 + } elsif (substr($str, 0, 4) eq chr(0)x4) {
1.3552 + $self->{unpack_code} = 'N'; # Big-endian
1.3553 + } else {
1.3554 + ::error("$fname: header size >= 2**32\n");
1.3555 + }
1.3556 + my @pair = unpack($self->{unpack_code} . "*", $str);
1.3557 + # Since we know one of the pair is 0, it's fine to just add them.
1.3558 + @$slots = (0, $pair[0] + $pair[1]);
1.3559 + }
1.3560 + return $self;
1.3561 + }
1.3562 +
1.3563 + # Load more data when we access slots->get(X) which is not yet in memory.
1.3564 + sub overflow {
1.3565 + my ($self) = @_;
1.3566 + my $slots = $self->{slots};
1.3567 + $self->{base} += $#$slots + 1; # skip over data we're replacing
1.3568 + my $str;
1.3569 + read($self->{file}, $str, $self->{stride});
1.3570 + if ($address_length == 8) { # the 32-bit case
1.3571 + # This is the easy case: unpack provides 32-bit unpacking primitives.
1.3572 + @$slots = unpack($self->{unpack_code} . "*", $str);
1.3573 + } else {
1.3574 + # We need to unpack 32 bits at a time and combine.
1.3575 + my @b32_values = unpack($self->{unpack_code} . "*", $str);
1.3576 + my @b64_values = ();
1.3577 + for (my $i = 0; $i < $#b32_values; $i += 2) {
1.3578 + # TODO(csilvers): if this is a 32-bit perl, the math below
1.3579 + # could end up in a too-large int, which perl will promote
1.3580 + # to a double, losing necessary precision. Deal with that.
1.3581 + # Right now, we just die.
1.3582 + my ($lo, $hi) = ($b32_values[$i], $b32_values[$i+1]);
1.3583 + if ($self->{unpack_code} eq 'N') { # big-endian
1.3584 + ($lo, $hi) = ($hi, $lo);
1.3585 + }
1.3586 + my $value = $lo + $hi * (2**32);
1.3587 + if (!$self->{perl_is_64bit} && # check value is exactly represented
1.3588 + (($value % (2**32)) != $lo || int($value / (2**32)) != $hi)) {
1.3589 + ::error("Need a 64-bit perl to process this 64-bit profile.\n");
1.3590 + }
1.3591 + push(@b64_values, $value);
1.3592 + }
1.3593 + @$slots = @b64_values;
1.3594 + }
1.3595 + }
1.3596 +
1.3597 + # Access the i-th long in the file (logically), or -1 at EOF.
1.3598 + sub get {
1.3599 + my ($self, $idx) = @_;
1.3600 + my $slots = $self->{slots};
1.3601 + while ($#$slots >= 0) {
1.3602 + if ($idx < $self->{base}) {
1.3603 + # The only time we expect a reference to $slots[$i - something]
1.3604 + # after referencing $slots[$i] is reading the very first header.
1.3605 + # Since $stride > |header|, that shouldn't cause any lookback
1.3606 + # errors. And everything after the header is sequential.
1.3607 + print STDERR "Unexpected look-back reading CPU profile";
1.3608 + return -1; # shrug, don't know what better to return
1.3609 + } elsif ($idx > $self->{base} + $#$slots) {
1.3610 + $self->overflow();
1.3611 + } else {
1.3612 + return $slots->[$idx - $self->{base}];
1.3613 + }
1.3614 + }
1.3615 + # If we get here, $slots is [], which means we've reached EOF
1.3616 + return -1; # unique since slots is supposed to hold unsigned numbers
1.3617 + }
1.3618 +}
1.3619 +
1.3620 +# Reads the top, 'header' section of a profile, and returns the last
1.3621 +# line of the header, commonly called a 'header line'. The header
1.3622 +# section of a profile consists of zero or more 'command' lines that
1.3623 +# are instructions to pprof, which pprof executes when reading the
1.3624 +# header. All 'command' lines start with a %. After the command
1.3625 +# lines is the 'header line', which is a profile-specific line that
1.3626 +# indicates what type of profile it is, and perhaps other global
1.3627 +# information about the profile. For instance, here's a header line
1.3628 +# for a heap profile:
1.3629 +# heap profile: 53: 38236 [ 5525: 1284029] @ heapprofile
1.3630 +# For historical reasons, the CPU profile does not contain a text-
1.3631 +# readable header line. If the profile looks like a CPU profile,
1.3632 +# this function returns "". If no header line could be found, this
1.3633 +# function returns undef.
1.3634 +#
1.3635 +# The following commands are recognized:
1.3636 +# %warn -- emit the rest of this line to stderr, prefixed by 'WARNING:'
1.3637 +#
1.3638 +# The input file should be in binmode.
1.3639 +sub ReadProfileHeader {
1.3640 + local *PROFILE = shift;
1.3641 + my $firstchar = "";
1.3642 + my $line = "";
1.3643 + read(PROFILE, $firstchar, 1);
1.3644 + seek(PROFILE, -1, 1); # unread the firstchar
1.3645 + if ($firstchar !~ /[[:print:]]/) { # is not a text character
1.3646 + return "";
1.3647 + }
1.3648 + while (defined($line = <PROFILE>)) {
1.3649 + $line =~ s/\r//g; # turn windows-looking lines into unix-looking lines
1.3650 + if ($line =~ /^%warn\s+(.*)/) { # 'warn' command
1.3651 + # Note this matches both '%warn blah\n' and '%warn\n'.
1.3652 + print STDERR "WARNING: $1\n"; # print the rest of the line
1.3653 + } elsif ($line =~ /^%/) {
1.3654 + print STDERR "Ignoring unknown command from profile header: $line";
1.3655 + } else {
1.3656 + # End of commands, must be the header line.
1.3657 + return $line;
1.3658 + }
1.3659 + }
1.3660 + return undef; # got to EOF without seeing a header line
1.3661 +}
1.3662 +
1.3663 +sub IsSymbolizedProfileFile {
1.3664 + my $file_name = shift;
1.3665 + if (!(-e $file_name) || !(-r $file_name)) {
1.3666 + return 0;
1.3667 + }
1.3668 + # Check if the file contains a symbol-section marker.
1.3669 + open(TFILE, "<$file_name");
1.3670 + binmode TFILE;
1.3671 + my $firstline = ReadProfileHeader(*TFILE);
1.3672 + close(TFILE);
1.3673 + if (!$firstline) {
1.3674 + return 0;
1.3675 + }
1.3676 + $SYMBOL_PAGE =~ m,[^/]+$,; # matches everything after the last slash
1.3677 + my $symbol_marker = $&;
1.3678 + return $firstline =~ /^--- *$symbol_marker/;
1.3679 +}
1.3680 +
1.3681 +# Parse profile generated by common/profiler.cc and return a reference
1.3682 +# to a map:
1.3683 +# $result->{version} Version number of profile file
1.3684 +# $result->{period} Sampling period (in microseconds)
1.3685 +# $result->{profile} Profile object
1.3686 +# $result->{map} Memory map info from profile
1.3687 +# $result->{pcs} Hash of all PC values seen, key is hex address
1.3688 +sub ReadProfile {
1.3689 + my $prog = shift;
1.3690 + my $fname = shift;
1.3691 + my $result; # return value
1.3692 +
1.3693 + $CONTENTION_PAGE =~ m,[^/]+$,; # matches everything after the last slash
1.3694 + my $contention_marker = $&;
1.3695 + $GROWTH_PAGE =~ m,[^/]+$,; # matches everything after the last slash
1.3696 + my $growth_marker = $&;
1.3697 + $SYMBOL_PAGE =~ m,[^/]+$,; # matches everything after the last slash
1.3698 + my $symbol_marker = $&;
1.3699 + $PROFILE_PAGE =~ m,[^/]+$,; # matches everything after the last slash
1.3700 + my $profile_marker = $&;
1.3701 +
1.3702 + # Look at first line to see if it is a heap or a CPU profile.
1.3703 + # CPU profile may start with no header at all, and just binary data
1.3704 + # (starting with \0\0\0\0) -- in that case, don't try to read the
1.3705 + # whole firstline, since it may be gigabytes(!) of data.
1.3706 + open(PROFILE, "<$fname") || error("$fname: $!\n");
1.3707 + binmode PROFILE; # New perls do UTF-8 processing
1.3708 + my $header = ReadProfileHeader(*PROFILE);
1.3709 + if (!defined($header)) { # means "at EOF"
1.3710 + error("Profile is empty.\n");
1.3711 + }
1.3712 +
1.3713 + my $symbols;
1.3714 + if ($header =~ m/^--- *$symbol_marker/o) {
1.3715 + # Verify that the user asked for a symbolized profile
1.3716 + if (!$main::use_symbolized_profile) {
1.3717 + # we have both a binary and symbolized profiles, abort
1.3718 + error("FATAL ERROR: Symbolized profile\n $fname\ncannot be used with " .
1.3719 + "a binary arg. Try again without passing\n $prog\n");
1.3720 + }
1.3721 + # Read the symbol section of the symbolized profile file.
1.3722 + $symbols = ReadSymbols(*PROFILE{IO});
1.3723 + # Read the next line to get the header for the remaining profile.
1.3724 + $header = ReadProfileHeader(*PROFILE) || "";
1.3725 + }
1.3726 +
1.3727 + $main::profile_type = '';
1.3728 + if ($header =~ m/^heap profile:.*$growth_marker/o) {
1.3729 + $main::profile_type = 'growth';
1.3730 + $result = ReadHeapProfile($prog, *PROFILE, $header);
1.3731 + } elsif ($header =~ m/^heap profile:/) {
1.3732 + $main::profile_type = 'heap';
1.3733 + $result = ReadHeapProfile($prog, *PROFILE, $header);
1.3734 + } elsif ($header =~ m/^--- *$contention_marker/o) {
1.3735 + $main::profile_type = 'contention';
1.3736 + $result = ReadSynchProfile($prog, *PROFILE);
1.3737 + } elsif ($header =~ m/^--- *Stacks:/) {
1.3738 + print STDERR
1.3739 + "Old format contention profile: mistakenly reports " .
1.3740 + "condition variable signals as lock contentions.\n";
1.3741 + $main::profile_type = 'contention';
1.3742 + $result = ReadSynchProfile($prog, *PROFILE);
1.3743 + } elsif ($header =~ m/^--- *$profile_marker/) {
1.3744 + # the binary cpu profile data starts immediately after this line
1.3745 + $main::profile_type = 'cpu';
1.3746 + $result = ReadCPUProfile($prog, $fname, *PROFILE);
1.3747 + } else {
1.3748 + if (defined($symbols)) {
1.3749 + # a symbolized profile contains a format we don't recognize, bail out
1.3750 + error("$fname: Cannot recognize profile section after symbols.\n");
1.3751 + }
1.3752 + # no ascii header present -- must be a CPU profile
1.3753 + $main::profile_type = 'cpu';
1.3754 + $result = ReadCPUProfile($prog, $fname, *PROFILE);
1.3755 + }
1.3756 +
1.3757 + close(PROFILE);
1.3758 +
1.3759 + # if we got symbols along with the profile, return those as well
1.3760 + if (defined($symbols)) {
1.3761 + $result->{symbols} = $symbols;
1.3762 + }
1.3763 +
1.3764 + return $result;
1.3765 +}
1.3766 +
1.3767 +# Subtract one from caller pc so we map back to call instr.
1.3768 +# However, don't do this if we're reading a symbolized profile
1.3769 +# file, in which case the subtract-one was done when the file
1.3770 +# was written.
1.3771 +#
1.3772 +# We apply the same logic to all readers, though ReadCPUProfile uses an
1.3773 +# independent implementation.
1.3774 +sub FixCallerAddresses {
1.3775 + my $stack = shift;
1.3776 + if ($main::use_symbolized_profile) {
1.3777 + return $stack;
1.3778 + } else {
1.3779 + $stack =~ /(\s)/;
1.3780 + my $delimiter = $1;
1.3781 + my @addrs = split(' ', $stack);
1.3782 + my @fixedaddrs;
1.3783 + $#fixedaddrs = $#addrs;
1.3784 + if ($#addrs >= 0) {
1.3785 + $fixedaddrs[0] = $addrs[0];
1.3786 + }
1.3787 + for (my $i = 1; $i <= $#addrs; $i++) {
1.3788 + $fixedaddrs[$i] = AddressSub($addrs[$i], "0x1");
1.3789 + }
1.3790 + return join $delimiter, @fixedaddrs;
1.3791 + }
1.3792 +}
1.3793 +
1.3794 +# CPU profile reader
1.3795 +sub ReadCPUProfile {
1.3796 + my $prog = shift;
1.3797 + my $fname = shift; # just used for logging
1.3798 + local *PROFILE = shift;
1.3799 + my $version;
1.3800 + my $period;
1.3801 + my $i;
1.3802 + my $profile = {};
1.3803 + my $pcs = {};
1.3804 +
1.3805 + # Parse string into array of slots.
1.3806 + my $slots = CpuProfileStream->new(*PROFILE, $fname);
1.3807 +
1.3808 + # Read header. The current header version is a 5-element structure
1.3809 + # containing:
1.3810 + # 0: header count (always 0)
1.3811 + # 1: header "words" (after this one: 3)
1.3812 + # 2: format version (0)
1.3813 + # 3: sampling period (usec)
1.3814 + # 4: unused padding (always 0)
1.3815 + if ($slots->get(0) != 0 ) {
1.3816 + error("$fname: not a profile file, or old format profile file\n");
1.3817 + }
1.3818 + $i = 2 + $slots->get(1);
1.3819 + $version = $slots->get(2);
1.3820 + $period = $slots->get(3);
1.3821 + # Do some sanity checking on these header values.
1.3822 + if ($version > (2**32) || $period > (2**32) || $i > (2**32) || $i < 5) {
1.3823 + error("$fname: not a profile file, or corrupted profile file\n");
1.3824 + }
1.3825 +
1.3826 + # Parse profile
1.3827 + while ($slots->get($i) != -1) {
1.3828 + my $n = $slots->get($i++);
1.3829 + my $d = $slots->get($i++);
1.3830 + if ($d > (2**16)) { # TODO(csilvers): what's a reasonable max-stack-depth?
1.3831 + my $addr = sprintf("0%o", $i * ($address_length == 8 ? 4 : 8));
1.3832 + print STDERR "At index $i (address $addr):\n";
1.3833 + error("$fname: stack trace depth >= 2**32\n");
1.3834 + }
1.3835 + if ($slots->get($i) == 0) {
1.3836 + # End of profile data marker
1.3837 + $i += $d;
1.3838 + last;
1.3839 + }
1.3840 +
1.3841 + # Make key out of the stack entries
1.3842 + my @k = ();
1.3843 + for (my $j = 0; $j < $d; $j++) {
1.3844 + my $pc = $slots->get($i+$j);
1.3845 + # Subtract one from caller pc so we map back to call instr.
1.3846 + # However, don't do this if we're reading a symbolized profile
1.3847 + # file, in which case the subtract-one was done when the file
1.3848 + # was written.
1.3849 + if ($j > 0 && !$main::use_symbolized_profile) {
1.3850 + $pc--;
1.3851 + }
1.3852 + $pc = sprintf("%0*x", $address_length, $pc);
1.3853 + $pcs->{$pc} = 1;
1.3854 + push @k, $pc;
1.3855 + }
1.3856 +
1.3857 + AddEntry($profile, (join "\n", @k), $n);
1.3858 + $i += $d;
1.3859 + }
1.3860 +
1.3861 + # Parse map
1.3862 + my $map = '';
1.3863 + seek(PROFILE, $i * 4, 0);
1.3864 + read(PROFILE, $map, (stat PROFILE)[7]);
1.3865 +
1.3866 + my $r = {};
1.3867 + $r->{version} = $version;
1.3868 + $r->{period} = $period;
1.3869 + $r->{profile} = $profile;
1.3870 + $r->{libs} = ParseLibraries($prog, $map, $pcs);
1.3871 + $r->{pcs} = $pcs;
1.3872 +
1.3873 + return $r;
1.3874 +}
1.3875 +
1.3876 +sub ReadHeapProfile {
1.3877 + my $prog = shift;
1.3878 + local *PROFILE = shift;
1.3879 + my $header = shift;
1.3880 +
1.3881 + my $index = 1;
1.3882 + if ($main::opt_inuse_space) {
1.3883 + $index = 1;
1.3884 + } elsif ($main::opt_inuse_objects) {
1.3885 + $index = 0;
1.3886 + } elsif ($main::opt_alloc_space) {
1.3887 + $index = 3;
1.3888 + } elsif ($main::opt_alloc_objects) {
1.3889 + $index = 2;
1.3890 + }
1.3891 +
1.3892 + # Find the type of this profile. The header line looks like:
1.3893 + # heap profile: 1246: 8800744 [ 1246: 8800744] @ <heap-url>/266053
1.3894 + # There are two pairs <count: size>, the first inuse objects/space, and the
1.3895 + # second allocated objects/space. This is followed optionally by a profile
1.3896 + # type, and if that is present, optionally by a sampling frequency.
1.3897 + # For remote heap profiles (v1):
1.3898 + # The interpretation of the sampling frequency is that the profiler, for
1.3899 + # each sample, calculates a uniformly distributed random integer less than
1.3900 + # the given value, and records the next sample after that many bytes have
1.3901 + # been allocated. Therefore, the expected sample interval is half of the
1.3902 + # given frequency. By default, if not specified, the expected sample
1.3903 + # interval is 128KB. Only remote-heap-page profiles are adjusted for
1.3904 + # sample size.
1.3905 + # For remote heap profiles (v2):
1.3906 + # The sampling frequency is the rate of a Poisson process. This means that
1.3907 + # the probability of sampling an allocation of size X with sampling rate Y
1.3908 + # is 1 - exp(-X/Y)
1.3909 + # For version 2, a typical header line might look like this:
1.3910 + # heap profile: 1922: 127792360 [ 1922: 127792360] @ <heap-url>_v2/524288
1.3911 + # the trailing number (524288) is the sampling rate. (Version 1 showed
1.3912 + # double the 'rate' here)
1.3913 + my $sampling_algorithm = 0;
1.3914 + my $sample_adjustment = 0;
1.3915 + chomp($header);
1.3916 + my $type = "unknown";
1.3917 + if ($header =~ m"^heap profile:\s*(\d+):\s+(\d+)\s+\[\s*(\d+):\s+(\d+)\](\s*@\s*([^/]*)(/(\d+))?)?") {
1.3918 + if (defined($6) && ($6 ne '')) {
1.3919 + $type = $6;
1.3920 + my $sample_period = $8;
1.3921 + # $type is "heapprofile" for profiles generated by the
1.3922 + # heap-profiler, and either "heap" or "heap_v2" for profiles
1.3923 + # generated by sampling directly within tcmalloc. It can also
1.3924 + # be "growth" for heap-growth profiles. The first is typically
1.3925 + # found for profiles generated locally, and the others for
1.3926 + # remote profiles.
1.3927 + if (($type eq "heapprofile") || ($type !~ /heap/) ) {
1.3928 + # No need to adjust for the sampling rate with heap-profiler-derived data
1.3929 + $sampling_algorithm = 0;
1.3930 + } elsif ($type =~ /_v2/) {
1.3931 + $sampling_algorithm = 2; # version 2 sampling
1.3932 + if (defined($sample_period) && ($sample_period ne '')) {
1.3933 + $sample_adjustment = int($sample_period);
1.3934 + }
1.3935 + } else {
1.3936 + $sampling_algorithm = 1; # version 1 sampling
1.3937 + if (defined($sample_period) && ($sample_period ne '')) {
1.3938 + $sample_adjustment = int($sample_period)/2;
1.3939 + }
1.3940 + }
1.3941 + } else {
1.3942 + # We detect whether or not this is a remote-heap profile by checking
1.3943 + # that the total-allocated stats ($n2,$s2) are exactly the
1.3944 + # same as the in-use stats ($n1,$s1). It is remotely conceivable
1.3945 + # that a non-remote-heap profile may pass this check, but it is hard
1.3946 + # to imagine how that could happen.
1.3947 + # In this case it's so old it's guaranteed to be remote-heap version 1.
1.3948 + my ($n1, $s1, $n2, $s2) = ($1, $2, $3, $4);
1.3949 + if (($n1 == $n2) && ($s1 == $s2)) {
1.3950 + # This is likely to be a remote-heap based sample profile
1.3951 + $sampling_algorithm = 1;
1.3952 + }
1.3953 + }
1.3954 + }
1.3955 +
1.3956 + if ($sampling_algorithm > 0) {
1.3957 + # For remote-heap generated profiles, adjust the counts and sizes to
1.3958 + # account for the sample rate (we sample once every 128KB by default).
1.3959 + if ($sample_adjustment == 0) {
1.3960 + # Turn on profile adjustment.
1.3961 + $sample_adjustment = 128*1024;
1.3962 + print STDERR "Adjusting heap profiles for 1-in-128KB sampling rate\n";
1.3963 + } else {
1.3964 + printf STDERR ("Adjusting heap profiles for 1-in-%d sampling rate\n",
1.3965 + $sample_adjustment);
1.3966 + }
1.3967 + if ($sampling_algorithm > 1) {
1.3968 + # We don't bother printing anything for the original version (version 1)
1.3969 + printf STDERR "Heap version $sampling_algorithm\n";
1.3970 + }
1.3971 + }
1.3972 +
1.3973 + my $profile = {};
1.3974 + my $pcs = {};
1.3975 + my $map = "";
1.3976 +
1.3977 + while (<PROFILE>) {
1.3978 + s/\r//g; # turn windows-looking lines into unix-looking lines
1.3979 + if (/^MAPPED_LIBRARIES:/) {
1.3980 + # Read the /proc/self/maps data
1.3981 + while (<PROFILE>) {
1.3982 + s/\r//g; # turn windows-looking lines into unix-looking lines
1.3983 + $map .= $_;
1.3984 + }
1.3985 + last;
1.3986 + }
1.3987 +
1.3988 + if (/^--- Memory map:/) {
1.3989 + # Read /proc/self/maps data as formatted by DumpAddressMap()
1.3990 + my $buildvar = "";
1.3991 + while (<PROFILE>) {
1.3992 + s/\r//g; # turn windows-looking lines into unix-looking lines
1.3993 + # Parse "build=<dir>" specification if supplied
1.3994 + if (m/^\s*build=(.*)\n/) {
1.3995 + $buildvar = $1;
1.3996 + }
1.3997 +
1.3998 + # Expand "$build" variable if available
1.3999 + $_ =~ s/\$build\b/$buildvar/g;
1.4000 +
1.4001 + $map .= $_;
1.4002 + }
1.4003 + last;
1.4004 + }
1.4005 +
1.4006 + # Read entry of the form:
1.4007 + # <count1>: <bytes1> [<count2>: <bytes2>] @ a1 a2 a3 ... an
1.4008 + s/^\s*//;
1.4009 + s/\s*$//;
1.4010 + if (m/^\s*(\d+):\s+(\d+)\s+\[\s*(\d+):\s+(\d+)\]\s+@\s+(.*)$/) {
1.4011 + my $stack = $5;
1.4012 + my ($n1, $s1, $n2, $s2) = ($1, $2, $3, $4);
1.4013 +
1.4014 + if ($sample_adjustment) {
1.4015 + if ($sampling_algorithm == 2) {
1.4016 + # Remote-heap version 2
1.4017 + # The sampling frequency is the rate of a Poisson process.
1.4018 + # This means that the probability of sampling an allocation of
1.4019 + # size X with sampling rate Y is 1 - exp(-X/Y)
1.4020 + if ($n1 != 0) {
1.4021 + my $ratio = (($s1*1.0)/$n1)/($sample_adjustment);
1.4022 + my $scale_factor = 1/(1 - exp(-$ratio));
1.4023 + $n1 *= $scale_factor;
1.4024 + $s1 *= $scale_factor;
1.4025 + }
1.4026 + if ($n2 != 0) {
1.4027 + my $ratio = (($s2*1.0)/$n2)/($sample_adjustment);
1.4028 + my $scale_factor = 1/(1 - exp(-$ratio));
1.4029 + $n2 *= $scale_factor;
1.4030 + $s2 *= $scale_factor;
1.4031 + }
1.4032 + } else {
1.4033 + # Remote-heap version 1
1.4034 + my $ratio;
1.4035 + $ratio = (($s1*1.0)/$n1)/($sample_adjustment);
1.4036 + if ($ratio < 1) {
1.4037 + $n1 /= $ratio;
1.4038 + $s1 /= $ratio;
1.4039 + }
1.4040 + $ratio = (($s2*1.0)/$n2)/($sample_adjustment);
1.4041 + if ($ratio < 1) {
1.4042 + $n2 /= $ratio;
1.4043 + $s2 /= $ratio;
1.4044 + }
1.4045 + }
1.4046 + }
1.4047 +
1.4048 + my @counts = ($n1, $s1, $n2, $s2);
1.4049 + AddEntries($profile, $pcs, FixCallerAddresses($stack), $counts[$index]);
1.4050 + }
1.4051 + }
1.4052 +
1.4053 + my $r = {};
1.4054 + $r->{version} = "heap";
1.4055 + $r->{period} = 1;
1.4056 + $r->{profile} = $profile;
1.4057 + $r->{libs} = ParseLibraries($prog, $map, $pcs);
1.4058 + $r->{pcs} = $pcs;
1.4059 + return $r;
1.4060 +}
1.4061 +
1.4062 +sub ReadSynchProfile {
1.4063 + my $prog = shift;
1.4064 + local *PROFILE = shift;
1.4065 + my $header = shift;
1.4066 +
1.4067 + my $map = '';
1.4068 + my $profile = {};
1.4069 + my $pcs = {};
1.4070 + my $sampling_period = 1;
1.4071 + my $cyclespernanosec = 2.8; # Default assumption for old binaries
1.4072 + my $seen_clockrate = 0;
1.4073 + my $line;
1.4074 +
1.4075 + my $index = 0;
1.4076 + if ($main::opt_total_delay) {
1.4077 + $index = 0;
1.4078 + } elsif ($main::opt_contentions) {
1.4079 + $index = 1;
1.4080 + } elsif ($main::opt_mean_delay) {
1.4081 + $index = 2;
1.4082 + }
1.4083 +
1.4084 + while ( $line = <PROFILE> ) {
1.4085 + $line =~ s/\r//g; # turn windows-looking lines into unix-looking lines
1.4086 + if ( $line =~ /^\s*(\d+)\s+(\d+) \@\s*(.*?)\s*$/ ) {
1.4087 + my ($cycles, $count, $stack) = ($1, $2, $3);
1.4088 +
1.4089 + # Convert cycles to nanoseconds
1.4090 + $cycles /= $cyclespernanosec;
1.4091 +
1.4092 + # Adjust for sampling done by application
1.4093 + $cycles *= $sampling_period;
1.4094 + $count *= $sampling_period;
1.4095 +
1.4096 + my @values = ($cycles, $count, $cycles / $count);
1.4097 + AddEntries($profile, $pcs, FixCallerAddresses($stack), $values[$index]);
1.4098 +
1.4099 + } elsif ( $line =~ /^(slow release).*thread \d+ \@\s*(.*?)\s*$/ ||
1.4100 + $line =~ /^\s*(\d+) \@\s*(.*?)\s*$/ ) {
1.4101 + my ($cycles, $stack) = ($1, $2);
1.4102 + if ($cycles !~ /^\d+$/) {
1.4103 + next;
1.4104 + }
1.4105 +
1.4106 + # Convert cycles to nanoseconds
1.4107 + $cycles /= $cyclespernanosec;
1.4108 +
1.4109 + # Adjust for sampling done by application
1.4110 + $cycles *= $sampling_period;
1.4111 +
1.4112 + AddEntries($profile, $pcs, FixCallerAddresses($stack), $cycles);
1.4113 +
1.4114 + } elsif ( $line =~ m/^([a-z][^=]*)=(.*)$/ ) {
1.4115 + my ($variable, $value) = ($1,$2);
1.4116 + for ($variable, $value) {
1.4117 + s/^\s+//;
1.4118 + s/\s+$//;
1.4119 + }
1.4120 + if ($variable eq "cycles/second") {
1.4121 + $cyclespernanosec = $value / 1e9;
1.4122 + $seen_clockrate = 1;
1.4123 + } elsif ($variable eq "sampling period") {
1.4124 + $sampling_period = $value;
1.4125 + } elsif ($variable eq "ms since reset") {
1.4126 + # Currently nothing is done with this value in pprof
1.4127 + # So we just silently ignore it for now
1.4128 + } elsif ($variable eq "discarded samples") {
1.4129 + # Currently nothing is done with this value in pprof
1.4130 + # So we just silently ignore it for now
1.4131 + } else {
1.4132 + printf STDERR ("Ignoring unnknown variable in /contention output: " .
1.4133 + "'%s' = '%s'\n",$variable,$value);
1.4134 + }
1.4135 + } else {
1.4136 + # Memory map entry
1.4137 + $map .= $line;
1.4138 + }
1.4139 + }
1.4140 +
1.4141 + if (!$seen_clockrate) {
1.4142 + printf STDERR ("No cycles/second entry in profile; Guessing %.1f GHz\n",
1.4143 + $cyclespernanosec);
1.4144 + }
1.4145 +
1.4146 + my $r = {};
1.4147 + $r->{version} = 0;
1.4148 + $r->{period} = $sampling_period;
1.4149 + $r->{profile} = $profile;
1.4150 + $r->{libs} = ParseLibraries($prog, $map, $pcs);
1.4151 + $r->{pcs} = $pcs;
1.4152 + return $r;
1.4153 +}
1.4154 +
1.4155 +# Given a hex value in the form "0x1abcd" or "1abcd", return either
1.4156 +# "0001abcd" or "000000000001abcd", depending on the current (global)
1.4157 +# address length.
1.4158 +sub HexExtend {
1.4159 + my $addr = shift;
1.4160 +
1.4161 + $addr =~ s/^(0x)?0*//;
1.4162 + my $zeros_needed = $address_length - length($addr);
1.4163 + if ($zeros_needed < 0) {
1.4164 + printf STDERR "Warning: address $addr is longer than address length $address_length\n";
1.4165 + return $addr;
1.4166 + }
1.4167 + return ("0" x $zeros_needed) . $addr;
1.4168 +}
1.4169 +
1.4170 +##### Symbol extraction #####
1.4171 +
1.4172 +# Aggressively search the lib_prefix values for the given library
1.4173 +# If all else fails, just return the name of the library unmodified.
1.4174 +# If the lib_prefix is "/my/path,/other/path" and $file is "/lib/dir/mylib.so"
1.4175 +# it will search the following locations in this order, until it finds a file:
1.4176 +# /my/path/lib/dir/mylib.so
1.4177 +# /other/path/lib/dir/mylib.so
1.4178 +# /my/path/dir/mylib.so
1.4179 +# /other/path/dir/mylib.so
1.4180 +# /my/path/mylib.so
1.4181 +# /other/path/mylib.so
1.4182 +# /lib/dir/mylib.so (returned as last resort)
1.4183 +sub FindLibrary {
1.4184 + my $file = shift;
1.4185 + my $suffix = $file;
1.4186 +
1.4187 + # Search for the library as described above
1.4188 + do {
1.4189 + foreach my $prefix (@prefix_list) {
1.4190 + my $fullpath = $prefix . $suffix;
1.4191 + if (-e $fullpath) {
1.4192 + return $fullpath;
1.4193 + }
1.4194 + }
1.4195 + } while ($suffix =~ s|^/[^/]+/|/|);
1.4196 + return $file;
1.4197 +}
1.4198 +
1.4199 +# Return path to library with debugging symbols.
1.4200 +# For libc libraries, the copy in /usr/lib/debug contains debugging symbols
1.4201 +sub DebuggingLibrary {
1.4202 + my $file = shift;
1.4203 + if ($file =~ m|^/| && -f "/usr/lib/debug$file") {
1.4204 + return "/usr/lib/debug$file";
1.4205 + }
1.4206 + return undef;
1.4207 +}
1.4208 +
1.4209 +# Parse text section header of a library using objdump
1.4210 +sub ParseTextSectionHeaderFromObjdump {
1.4211 + my $lib = shift;
1.4212 +
1.4213 + my $size = undef;
1.4214 + my $vma;
1.4215 + my $file_offset;
1.4216 + # Get objdump output from the library file to figure out how to
1.4217 + # map between mapped addresses and addresses in the library.
1.4218 + my $cmd = ShellEscape($obj_tool_map{"objdump"}, "-h", $lib);
1.4219 + open(OBJDUMP, "$cmd |") || error("$cmd: $!\n");
1.4220 + while (<OBJDUMP>) {
1.4221 + s/\r//g; # turn windows-looking lines into unix-looking lines
1.4222 + # Idx Name Size VMA LMA File off Algn
1.4223 + # 10 .text 00104b2c 420156f0 420156f0 000156f0 2**4
1.4224 + # For 64-bit objects, VMA and LMA will be 16 hex digits, size and file
1.4225 + # offset may still be 8. But AddressSub below will still handle that.
1.4226 + my @x = split;
1.4227 + if (($#x >= 6) && ($x[1] eq '.text')) {
1.4228 + $size = $x[2];
1.4229 + $vma = $x[3];
1.4230 + $file_offset = $x[5];
1.4231 + last;
1.4232 + }
1.4233 + }
1.4234 + close(OBJDUMP);
1.4235 +
1.4236 + if (!defined($size)) {
1.4237 + return undef;
1.4238 + }
1.4239 +
1.4240 + my $r = {};
1.4241 + $r->{size} = $size;
1.4242 + $r->{vma} = $vma;
1.4243 + $r->{file_offset} = $file_offset;
1.4244 +
1.4245 + return $r;
1.4246 +}
1.4247 +
1.4248 +# Parse text section header of a library using otool (on OS X)
1.4249 +sub ParseTextSectionHeaderFromOtool {
1.4250 + my $lib = shift;
1.4251 +
1.4252 + my $size = undef;
1.4253 + my $vma = undef;
1.4254 + my $file_offset = undef;
1.4255 + # Get otool output from the library file to figure out how to
1.4256 + # map between mapped addresses and addresses in the library.
1.4257 + my $command = ShellEscape($obj_tool_map{"otool"}, "-l", $lib);
1.4258 + open(OTOOL, "$command |") || error("$command: $!\n");
1.4259 + my $cmd = "";
1.4260 + my $sectname = "";
1.4261 + my $segname = "";
1.4262 + foreach my $line (<OTOOL>) {
1.4263 + $line =~ s/\r//g; # turn windows-looking lines into unix-looking lines
1.4264 + # Load command <#>
1.4265 + # cmd LC_SEGMENT
1.4266 + # [...]
1.4267 + # Section
1.4268 + # sectname __text
1.4269 + # segname __TEXT
1.4270 + # addr 0x000009f8
1.4271 + # size 0x00018b9e
1.4272 + # offset 2552
1.4273 + # align 2^2 (4)
1.4274 + # We will need to strip off the leading 0x from the hex addresses,
1.4275 + # and convert the offset into hex.
1.4276 + if ($line =~ /Load command/) {
1.4277 + $cmd = "";
1.4278 + $sectname = "";
1.4279 + $segname = "";
1.4280 + } elsif ($line =~ /Section/) {
1.4281 + $sectname = "";
1.4282 + $segname = "";
1.4283 + } elsif ($line =~ /cmd (\w+)/) {
1.4284 + $cmd = $1;
1.4285 + } elsif ($line =~ /sectname (\w+)/) {
1.4286 + $sectname = $1;
1.4287 + } elsif ($line =~ /segname (\w+)/) {
1.4288 + $segname = $1;
1.4289 + } elsif (!(($cmd eq "LC_SEGMENT" || $cmd eq "LC_SEGMENT_64") &&
1.4290 + $sectname eq "__text" &&
1.4291 + $segname eq "__TEXT")) {
1.4292 + next;
1.4293 + } elsif ($line =~ /\baddr 0x([0-9a-fA-F]+)/) {
1.4294 + $vma = $1;
1.4295 + } elsif ($line =~ /\bsize 0x([0-9a-fA-F]+)/) {
1.4296 + $size = $1;
1.4297 + } elsif ($line =~ /\boffset ([0-9]+)/) {
1.4298 + $file_offset = sprintf("%016x", $1);
1.4299 + }
1.4300 + if (defined($vma) && defined($size) && defined($file_offset)) {
1.4301 + last;
1.4302 + }
1.4303 + }
1.4304 + close(OTOOL);
1.4305 +
1.4306 + if (!defined($vma) || !defined($size) || !defined($file_offset)) {
1.4307 + return undef;
1.4308 + }
1.4309 +
1.4310 + my $r = {};
1.4311 + $r->{size} = $size;
1.4312 + $r->{vma} = $vma;
1.4313 + $r->{file_offset} = $file_offset;
1.4314 +
1.4315 + return $r;
1.4316 +}
1.4317 +
1.4318 +sub ParseTextSectionHeader {
1.4319 + # obj_tool_map("otool") is only defined if we're in a Mach-O environment
1.4320 + if (defined($obj_tool_map{"otool"})) {
1.4321 + my $r = ParseTextSectionHeaderFromOtool(@_);
1.4322 + if (defined($r)){
1.4323 + return $r;
1.4324 + }
1.4325 + }
1.4326 + # If otool doesn't work, or we don't have it, fall back to objdump
1.4327 + return ParseTextSectionHeaderFromObjdump(@_);
1.4328 +}
1.4329 +
1.4330 +# Split /proc/pid/maps dump into a list of libraries
1.4331 +sub ParseLibraries {
1.4332 + return if $main::use_symbol_page; # We don't need libraries info.
1.4333 + my $prog = shift;
1.4334 + my $map = shift;
1.4335 + my $pcs = shift;
1.4336 +
1.4337 + my $result = [];
1.4338 + my $h = "[a-f0-9]+";
1.4339 + my $zero_offset = HexExtend("0");
1.4340 +
1.4341 + my $buildvar = "";
1.4342 + foreach my $l (split("\n", $map)) {
1.4343 + if ($l =~ m/^\s*build=(.*)$/) {
1.4344 + $buildvar = $1;
1.4345 + }
1.4346 +
1.4347 + my $start;
1.4348 + my $finish;
1.4349 + my $offset;
1.4350 + my $lib;
1.4351 + 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) {
1.4352 + # Full line from /proc/self/maps. Example:
1.4353 + # 40000000-40015000 r-xp 00000000 03:01 12845071 /lib/ld-2.3.2.so
1.4354 + $start = HexExtend($1);
1.4355 + $finish = HexExtend($2);
1.4356 + $offset = HexExtend($3);
1.4357 + $lib = $4;
1.4358 + $lib =~ s|\\|/|g; # turn windows-style paths into unix-style paths
1.4359 + } elsif ($l =~ /^\s*($h)-($h):\s*(\S+\.so(\.\d+)*)/) {
1.4360 + # Cooked line from DumpAddressMap. Example:
1.4361 + # 40000000-40015000: /lib/ld-2.3.2.so
1.4362 + $start = HexExtend($1);
1.4363 + $finish = HexExtend($2);
1.4364 + $offset = $zero_offset;
1.4365 + $lib = $3;
1.4366 + } else {
1.4367 + next;
1.4368 + }
1.4369 +
1.4370 + # Expand "$build" variable if available
1.4371 + $lib =~ s/\$build\b/$buildvar/g;
1.4372 +
1.4373 + $lib = FindLibrary($lib);
1.4374 +
1.4375 + # Check for pre-relocated libraries, which use pre-relocated symbol tables
1.4376 + # and thus require adjusting the offset that we'll use to translate
1.4377 + # VM addresses into symbol table addresses.
1.4378 + # Only do this if we're not going to fetch the symbol table from a
1.4379 + # debugging copy of the library.
1.4380 + if (!DebuggingLibrary($lib)) {
1.4381 + my $text = ParseTextSectionHeader($lib);
1.4382 + if (defined($text)) {
1.4383 + my $vma_offset = AddressSub($text->{vma}, $text->{file_offset});
1.4384 + $offset = AddressAdd($offset, $vma_offset);
1.4385 + }
1.4386 + }
1.4387 +
1.4388 + push(@{$result}, [$lib, $start, $finish, $offset]);
1.4389 + }
1.4390 +
1.4391 + # Append special entry for additional library (not relocated)
1.4392 + if ($main::opt_lib ne "") {
1.4393 + my $text = ParseTextSectionHeader($main::opt_lib);
1.4394 + if (defined($text)) {
1.4395 + my $start = $text->{vma};
1.4396 + my $finish = AddressAdd($start, $text->{size});
1.4397 +
1.4398 + push(@{$result}, [$main::opt_lib, $start, $finish, $start]);
1.4399 + }
1.4400 + }
1.4401 +
1.4402 + # Append special entry for the main program. This covers
1.4403 + # 0..max_pc_value_seen, so that we assume pc values not found in one
1.4404 + # of the library ranges will be treated as coming from the main
1.4405 + # program binary.
1.4406 + my $min_pc = HexExtend("0");
1.4407 + my $max_pc = $min_pc; # find the maximal PC value in any sample
1.4408 + foreach my $pc (keys(%{$pcs})) {
1.4409 + if (HexExtend($pc) gt $max_pc) { $max_pc = HexExtend($pc); }
1.4410 + }
1.4411 + push(@{$result}, [$prog, $min_pc, $max_pc, $zero_offset]);
1.4412 +
1.4413 + return $result;
1.4414 +}
1.4415 +
1.4416 +# Add two hex addresses of length $address_length.
1.4417 +# Run pprof --test for unit test if this is changed.
1.4418 +sub AddressAdd {
1.4419 + my $addr1 = shift;
1.4420 + my $addr2 = shift;
1.4421 + my $sum;
1.4422 +
1.4423 + if ($address_length == 8) {
1.4424 + # Perl doesn't cope with wraparound arithmetic, so do it explicitly:
1.4425 + $sum = (hex($addr1)+hex($addr2)) % (0x10000000 * 16);
1.4426 + return sprintf("%08x", $sum);
1.4427 +
1.4428 + } else {
1.4429 + # Do the addition in 7-nibble chunks to trivialize carry handling.
1.4430 +
1.4431 + if ($main::opt_debug and $main::opt_test) {
1.4432 + print STDERR "AddressAdd $addr1 + $addr2 = ";
1.4433 + }
1.4434 +
1.4435 + my $a1 = substr($addr1,-7);
1.4436 + $addr1 = substr($addr1,0,-7);
1.4437 + my $a2 = substr($addr2,-7);
1.4438 + $addr2 = substr($addr2,0,-7);
1.4439 + $sum = hex($a1) + hex($a2);
1.4440 + my $c = 0;
1.4441 + if ($sum > 0xfffffff) {
1.4442 + $c = 1;
1.4443 + $sum -= 0x10000000;
1.4444 + }
1.4445 + my $r = sprintf("%07x", $sum);
1.4446 +
1.4447 + $a1 = substr($addr1,-7);
1.4448 + $addr1 = substr($addr1,0,-7);
1.4449 + $a2 = substr($addr2,-7);
1.4450 + $addr2 = substr($addr2,0,-7);
1.4451 + $sum = hex($a1) + hex($a2) + $c;
1.4452 + $c = 0;
1.4453 + if ($sum > 0xfffffff) {
1.4454 + $c = 1;
1.4455 + $sum -= 0x10000000;
1.4456 + }
1.4457 + $r = sprintf("%07x", $sum) . $r;
1.4458 +
1.4459 + $sum = hex($addr1) + hex($addr2) + $c;
1.4460 + if ($sum > 0xff) { $sum -= 0x100; }
1.4461 + $r = sprintf("%02x", $sum) . $r;
1.4462 +
1.4463 + if ($main::opt_debug and $main::opt_test) { print STDERR "$r\n"; }
1.4464 +
1.4465 + return $r;
1.4466 + }
1.4467 +}
1.4468 +
1.4469 +
1.4470 +# Subtract two hex addresses of length $address_length.
1.4471 +# Run pprof --test for unit test if this is changed.
1.4472 +sub AddressSub {
1.4473 + my $addr1 = shift;
1.4474 + my $addr2 = shift;
1.4475 + my $diff;
1.4476 +
1.4477 + if ($address_length == 8) {
1.4478 + # Perl doesn't cope with wraparound arithmetic, so do it explicitly:
1.4479 + $diff = (hex($addr1)-hex($addr2)) % (0x10000000 * 16);
1.4480 + return sprintf("%08x", $diff);
1.4481 +
1.4482 + } else {
1.4483 + # Do the addition in 7-nibble chunks to trivialize borrow handling.
1.4484 + # if ($main::opt_debug) { print STDERR "AddressSub $addr1 - $addr2 = "; }
1.4485 +
1.4486 + my $a1 = hex(substr($addr1,-7));
1.4487 + $addr1 = substr($addr1,0,-7);
1.4488 + my $a2 = hex(substr($addr2,-7));
1.4489 + $addr2 = substr($addr2,0,-7);
1.4490 + my $b = 0;
1.4491 + if ($a2 > $a1) {
1.4492 + $b = 1;
1.4493 + $a1 += 0x10000000;
1.4494 + }
1.4495 + $diff = $a1 - $a2;
1.4496 + my $r = sprintf("%07x", $diff);
1.4497 +
1.4498 + $a1 = hex(substr($addr1,-7));
1.4499 + $addr1 = substr($addr1,0,-7);
1.4500 + $a2 = hex(substr($addr2,-7)) + $b;
1.4501 + $addr2 = substr($addr2,0,-7);
1.4502 + $b = 0;
1.4503 + if ($a2 > $a1) {
1.4504 + $b = 1;
1.4505 + $a1 += 0x10000000;
1.4506 + }
1.4507 + $diff = $a1 - $a2;
1.4508 + $r = sprintf("%07x", $diff) . $r;
1.4509 +
1.4510 + $a1 = hex($addr1);
1.4511 + $a2 = hex($addr2) + $b;
1.4512 + if ($a2 > $a1) { $a1 += 0x100; }
1.4513 + $diff = $a1 - $a2;
1.4514 + $r = sprintf("%02x", $diff) . $r;
1.4515 +
1.4516 + # if ($main::opt_debug) { print STDERR "$r\n"; }
1.4517 +
1.4518 + return $r;
1.4519 + }
1.4520 +}
1.4521 +
1.4522 +# Increment a hex addresses of length $address_length.
1.4523 +# Run pprof --test for unit test if this is changed.
1.4524 +sub AddressInc {
1.4525 + my $addr = shift;
1.4526 + my $sum;
1.4527 +
1.4528 + if ($address_length == 8) {
1.4529 + # Perl doesn't cope with wraparound arithmetic, so do it explicitly:
1.4530 + $sum = (hex($addr)+1) % (0x10000000 * 16);
1.4531 + return sprintf("%08x", $sum);
1.4532 +
1.4533 + } else {
1.4534 + # Do the addition in 7-nibble chunks to trivialize carry handling.
1.4535 + # We are always doing this to step through the addresses in a function,
1.4536 + # and will almost never overflow the first chunk, so we check for this
1.4537 + # case and exit early.
1.4538 +
1.4539 + # if ($main::opt_debug) { print STDERR "AddressInc $addr1 = "; }
1.4540 +
1.4541 + my $a1 = substr($addr,-7);
1.4542 + $addr = substr($addr,0,-7);
1.4543 + $sum = hex($a1) + 1;
1.4544 + my $r = sprintf("%07x", $sum);
1.4545 + if ($sum <= 0xfffffff) {
1.4546 + $r = $addr . $r;
1.4547 + # if ($main::opt_debug) { print STDERR "$r\n"; }
1.4548 + return HexExtend($r);
1.4549 + } else {
1.4550 + $r = "0000000";
1.4551 + }
1.4552 +
1.4553 + $a1 = substr($addr,-7);
1.4554 + $addr = substr($addr,0,-7);
1.4555 + $sum = hex($a1) + 1;
1.4556 + $r = sprintf("%07x", $sum) . $r;
1.4557 + if ($sum <= 0xfffffff) {
1.4558 + $r = $addr . $r;
1.4559 + # if ($main::opt_debug) { print STDERR "$r\n"; }
1.4560 + return HexExtend($r);
1.4561 + } else {
1.4562 + $r = "00000000000000";
1.4563 + }
1.4564 +
1.4565 + $sum = hex($addr) + 1;
1.4566 + if ($sum > 0xff) { $sum -= 0x100; }
1.4567 + $r = sprintf("%02x", $sum) . $r;
1.4568 +
1.4569 + # if ($main::opt_debug) { print STDERR "$r\n"; }
1.4570 + return $r;
1.4571 + }
1.4572 +}
1.4573 +
1.4574 +# Extract symbols for all PC values found in profile
1.4575 +sub ExtractSymbols {
1.4576 + my $libs = shift;
1.4577 + my $pcset = shift;
1.4578 +
1.4579 + my $symbols = {};
1.4580 +
1.4581 + # Map each PC value to the containing library. To make this faster,
1.4582 + # we sort libraries by their starting pc value (highest first), and
1.4583 + # advance through the libraries as we advance the pc. Sometimes the
1.4584 + # addresses of libraries may overlap with the addresses of the main
1.4585 + # binary, so to make sure the libraries 'win', we iterate over the
1.4586 + # libraries in reverse order (which assumes the binary doesn't start
1.4587 + # in the middle of a library, which seems a fair assumption).
1.4588 + my @pcs = (sort { $a cmp $b } keys(%{$pcset})); # pcset is 0-extended strings
1.4589 + foreach my $lib (sort {$b->[1] cmp $a->[1]} @{$libs}) {
1.4590 + my $libname = $lib->[0];
1.4591 + my $start = $lib->[1];
1.4592 + my $finish = $lib->[2];
1.4593 + my $offset = $lib->[3];
1.4594 +
1.4595 + # Get list of pcs that belong in this library.
1.4596 + my $contained = [];
1.4597 + my ($start_pc_index, $finish_pc_index);
1.4598 + # Find smallest finish_pc_index such that $finish < $pc[$finish_pc_index].
1.4599 + for ($finish_pc_index = $#pcs + 1; $finish_pc_index > 0;
1.4600 + $finish_pc_index--) {
1.4601 + last if $pcs[$finish_pc_index - 1] le $finish;
1.4602 + }
1.4603 + # Find smallest start_pc_index such that $start <= $pc[$start_pc_index].
1.4604 + for ($start_pc_index = $finish_pc_index; $start_pc_index > 0;
1.4605 + $start_pc_index--) {
1.4606 + last if $pcs[$start_pc_index - 1] lt $start;
1.4607 + }
1.4608 + # This keeps PC values higher than $pc[$finish_pc_index] in @pcs,
1.4609 + # in case there are overlaps in libraries and the main binary.
1.4610 + @{$contained} = splice(@pcs, $start_pc_index,
1.4611 + $finish_pc_index - $start_pc_index);
1.4612 + # Map to symbols
1.4613 + MapToSymbols($libname, AddressSub($start, $offset), $contained, $symbols);
1.4614 + }
1.4615 +
1.4616 + return $symbols;
1.4617 +}
1.4618 +
1.4619 +# Map list of PC values to symbols for a given image
1.4620 +sub MapToSymbols {
1.4621 + my $image = shift;
1.4622 + my $offset = shift;
1.4623 + my $pclist = shift;
1.4624 + my $symbols = shift;
1.4625 +
1.4626 + my $debug = 0;
1.4627 +
1.4628 + # Ignore empty binaries
1.4629 + if ($#{$pclist} < 0) { return; }
1.4630 +
1.4631 + # Figure out the addr2line command to use
1.4632 + my $addr2line = $obj_tool_map{"addr2line"};
1.4633 + my $cmd = ShellEscape($addr2line, "-f", "-C", "-e", $image);
1.4634 + if (exists $obj_tool_map{"addr2line_pdb"}) {
1.4635 + $addr2line = $obj_tool_map{"addr2line_pdb"};
1.4636 + $cmd = ShellEscape($addr2line, "--demangle", "-f", "-C", "-e", $image);
1.4637 + }
1.4638 +
1.4639 + # If "addr2line" isn't installed on the system at all, just use
1.4640 + # nm to get what info we can (function names, but not line numbers).
1.4641 + if (system(ShellEscape($addr2line, "--help") . " >$dev_null 2>&1") != 0) {
1.4642 + MapSymbolsWithNM($image, $offset, $pclist, $symbols);
1.4643 + return;
1.4644 + }
1.4645 +
1.4646 + # "addr2line -i" can produce a variable number of lines per input
1.4647 + # address, with no separator that allows us to tell when data for
1.4648 + # the next address starts. So we find the address for a special
1.4649 + # symbol (_fini) and interleave this address between all real
1.4650 + # addresses passed to addr2line. The name of this special symbol
1.4651 + # can then be used as a separator.
1.4652 + $sep_address = undef; # May be filled in by MapSymbolsWithNM()
1.4653 + my $nm_symbols = {};
1.4654 + MapSymbolsWithNM($image, $offset, $pclist, $nm_symbols);
1.4655 + if (defined($sep_address)) {
1.4656 + # Only add " -i" to addr2line if the binary supports it.
1.4657 + # addr2line --help returns 0, but not if it sees an unknown flag first.
1.4658 + if (system("$cmd -i --help >$dev_null 2>&1") == 0) {
1.4659 + $cmd .= " -i";
1.4660 + } else {
1.4661 + $sep_address = undef; # no need for sep_address if we don't support -i
1.4662 + }
1.4663 + }
1.4664 +
1.4665 + # Make file with all PC values with intervening 'sep_address' so
1.4666 + # that we can reliably detect the end of inlined function list
1.4667 + open(ADDRESSES, ">$main::tmpfile_sym") || error("$main::tmpfile_sym: $!\n");
1.4668 + if ($debug) { print("---- $image ---\n"); }
1.4669 + for (my $i = 0; $i <= $#{$pclist}; $i++) {
1.4670 + # addr2line always reads hex addresses, and does not need '0x' prefix.
1.4671 + if ($debug) { printf STDERR ("%s\n", $pclist->[$i]); }
1.4672 + printf ADDRESSES ("%s\n", AddressSub($pclist->[$i], $offset));
1.4673 + if (defined($sep_address)) {
1.4674 + printf ADDRESSES ("%s\n", $sep_address);
1.4675 + }
1.4676 + }
1.4677 + close(ADDRESSES);
1.4678 + if ($debug) {
1.4679 + print("----\n");
1.4680 + system("cat", $main::tmpfile_sym);
1.4681 + print("----\n");
1.4682 + system("$cmd < " . ShellEscape($main::tmpfile_sym));
1.4683 + print("----\n");
1.4684 + }
1.4685 +
1.4686 + open(SYMBOLS, "$cmd <" . ShellEscape($main::tmpfile_sym) . " |")
1.4687 + || error("$cmd: $!\n");
1.4688 + my $count = 0; # Index in pclist
1.4689 + while (<SYMBOLS>) {
1.4690 + # Read fullfunction and filelineinfo from next pair of lines
1.4691 + s/\r?\n$//g;
1.4692 + my $fullfunction = $_;
1.4693 + $_ = <SYMBOLS>;
1.4694 + s/\r?\n$//g;
1.4695 + my $filelinenum = $_;
1.4696 +
1.4697 + if (defined($sep_address) && $fullfunction eq $sep_symbol) {
1.4698 + # Terminating marker for data for this address
1.4699 + $count++;
1.4700 + next;
1.4701 + }
1.4702 +
1.4703 + $filelinenum =~ s|\\|/|g; # turn windows-style paths into unix-style paths
1.4704 +
1.4705 + my $pcstr = $pclist->[$count];
1.4706 + my $function = ShortFunctionName($fullfunction);
1.4707 + my $nms = $nm_symbols->{$pcstr};
1.4708 + if (defined($nms)) {
1.4709 + if ($fullfunction eq '??') {
1.4710 + # nm found a symbol for us.
1.4711 + $function = $nms->[0];
1.4712 + $fullfunction = $nms->[2];
1.4713 + } else {
1.4714 + # MapSymbolsWithNM tags each routine with its starting address,
1.4715 + # useful in case the image has multiple occurrences of this
1.4716 + # routine. (It uses a syntax that resembles template paramters,
1.4717 + # that are automatically stripped out by ShortFunctionName().)
1.4718 + # addr2line does not provide the same information. So we check
1.4719 + # if nm disambiguated our symbol, and if so take the annotated
1.4720 + # (nm) version of the routine-name. TODO(csilvers): this won't
1.4721 + # catch overloaded, inlined symbols, which nm doesn't see.
1.4722 + # Better would be to do a check similar to nm's, in this fn.
1.4723 + if ($nms->[2] =~ m/^\Q$function\E/) { # sanity check it's the right fn
1.4724 + $function = $nms->[0];
1.4725 + $fullfunction = $nms->[2];
1.4726 + }
1.4727 + }
1.4728 + }
1.4729 +
1.4730 + # Prepend to accumulated symbols for pcstr
1.4731 + # (so that caller comes before callee)
1.4732 + my $sym = $symbols->{$pcstr};
1.4733 + if (!defined($sym)) {
1.4734 + $sym = [];
1.4735 + $symbols->{$pcstr} = $sym;
1.4736 + }
1.4737 + unshift(@{$sym}, $function, $filelinenum, $fullfunction);
1.4738 + if ($debug) { printf STDERR ("%s => [%s]\n", $pcstr, join(" ", @{$sym})); }
1.4739 + if (!defined($sep_address)) {
1.4740 + # Inlining is off, so this entry ends immediately
1.4741 + $count++;
1.4742 + }
1.4743 + }
1.4744 + close(SYMBOLS);
1.4745 +}
1.4746 +
1.4747 +# Use nm to map the list of referenced PCs to symbols. Return true iff we
1.4748 +# are able to read procedure information via nm.
1.4749 +sub MapSymbolsWithNM {
1.4750 + my $image = shift;
1.4751 + my $offset = shift;
1.4752 + my $pclist = shift;
1.4753 + my $symbols = shift;
1.4754 +
1.4755 + # Get nm output sorted by increasing address
1.4756 + my $symbol_table = GetProcedureBoundaries($image, ".");
1.4757 + if (!%{$symbol_table}) {
1.4758 + return 0;
1.4759 + }
1.4760 + # Start addresses are already the right length (8 or 16 hex digits).
1.4761 + my @names = sort { $symbol_table->{$a}->[0] cmp $symbol_table->{$b}->[0] }
1.4762 + keys(%{$symbol_table});
1.4763 +
1.4764 + if ($#names < 0) {
1.4765 + # No symbols: just use addresses
1.4766 + foreach my $pc (@{$pclist}) {
1.4767 + my $pcstr = "0x" . $pc;
1.4768 + $symbols->{$pc} = [$pcstr, "?", $pcstr];
1.4769 + }
1.4770 + return 0;
1.4771 + }
1.4772 +
1.4773 + # Sort addresses so we can do a join against nm output
1.4774 + my $index = 0;
1.4775 + my $fullname = $names[0];
1.4776 + my $name = ShortFunctionName($fullname);
1.4777 + foreach my $pc (sort { $a cmp $b } @{$pclist}) {
1.4778 + # Adjust for mapped offset
1.4779 + my $mpc = AddressSub($pc, $offset);
1.4780 + while (($index < $#names) && ($mpc ge $symbol_table->{$fullname}->[1])){
1.4781 + $index++;
1.4782 + $fullname = $names[$index];
1.4783 + $name = ShortFunctionName($fullname);
1.4784 + }
1.4785 + if ($mpc lt $symbol_table->{$fullname}->[1]) {
1.4786 + $symbols->{$pc} = [$name, "?", $fullname];
1.4787 + } else {
1.4788 + my $pcstr = "0x" . $pc;
1.4789 + $symbols->{$pc} = [$pcstr, "?", $pcstr];
1.4790 + }
1.4791 + }
1.4792 + return 1;
1.4793 +}
1.4794 +
1.4795 +sub ShortFunctionName {
1.4796 + my $function = shift;
1.4797 + while ($function =~ s/\([^()]*\)(\s*const)?//g) { } # Argument types
1.4798 + while ($function =~ s/<[^<>]*>//g) { } # Remove template arguments
1.4799 + $function =~ s/^.*\s+(\w+::)/$1/; # Remove leading type
1.4800 + return $function;
1.4801 +}
1.4802 +
1.4803 +# Trim overly long symbols found in disassembler output
1.4804 +sub CleanDisassembly {
1.4805 + my $d = shift;
1.4806 + while ($d =~ s/\([^()%]*\)(\s*const)?//g) { } # Argument types, not (%rax)
1.4807 + while ($d =~ s/(\w+)<[^<>]*>/$1/g) { } # Remove template arguments
1.4808 + return $d;
1.4809 +}
1.4810 +
1.4811 +# Clean file name for display
1.4812 +sub CleanFileName {
1.4813 + my ($f) = @_;
1.4814 + $f =~ s|^/proc/self/cwd/||;
1.4815 + $f =~ s|^\./||;
1.4816 + return $f;
1.4817 +}
1.4818 +
1.4819 +# Make address relative to section and clean up for display
1.4820 +sub UnparseAddress {
1.4821 + my ($offset, $address) = @_;
1.4822 + $address = AddressSub($address, $offset);
1.4823 + $address =~ s/^0x//;
1.4824 + $address =~ s/^0*//;
1.4825 + return $address;
1.4826 +}
1.4827 +
1.4828 +##### Miscellaneous #####
1.4829 +
1.4830 +# Find the right versions of the above object tools to use. The
1.4831 +# argument is the program file being analyzed, and should be an ELF
1.4832 +# 32-bit or ELF 64-bit executable file. The location of the tools
1.4833 +# is determined by considering the following options in this order:
1.4834 +# 1) --tools option, if set
1.4835 +# 2) PPROF_TOOLS environment variable, if set
1.4836 +# 3) the environment
1.4837 +sub ConfigureObjTools {
1.4838 + my $prog_file = shift;
1.4839 +
1.4840 + # Check for the existence of $prog_file because /usr/bin/file does not
1.4841 + # predictably return error status in prod.
1.4842 + (-e $prog_file) || error("$prog_file does not exist.\n");
1.4843 +
1.4844 + my $file_type = undef;
1.4845 + if (-e "/usr/bin/file") {
1.4846 + # Follow symlinks (at least for systems where "file" supports that).
1.4847 + my $escaped_prog_file = ShellEscape($prog_file);
1.4848 + $file_type = `/usr/bin/file -L $escaped_prog_file 2>$dev_null ||
1.4849 + /usr/bin/file $escaped_prog_file`;
1.4850 + } elsif ($^O == "MSWin32") {
1.4851 + $file_type = "MS Windows";
1.4852 + } else {
1.4853 + print STDERR "WARNING: Can't determine the file type of $prog_file";
1.4854 + }
1.4855 +
1.4856 + if ($file_type =~ /64-bit/) {
1.4857 + # Change $address_length to 16 if the program file is ELF 64-bit.
1.4858 + # We can't detect this from many (most?) heap or lock contention
1.4859 + # profiles, since the actual addresses referenced are generally in low
1.4860 + # memory even for 64-bit programs.
1.4861 + $address_length = 16;
1.4862 + }
1.4863 +
1.4864 + if ($file_type =~ /MS Windows/) {
1.4865 + # For windows, we provide a version of nm and addr2line as part of
1.4866 + # the opensource release, which is capable of parsing
1.4867 + # Windows-style PDB executables. It should live in the path, or
1.4868 + # in the same directory as pprof.
1.4869 + $obj_tool_map{"nm_pdb"} = "nm-pdb";
1.4870 + $obj_tool_map{"addr2line_pdb"} = "addr2line-pdb";
1.4871 + }
1.4872 +
1.4873 + if ($file_type =~ /Mach-O/) {
1.4874 + # OS X uses otool to examine Mach-O files, rather than objdump.
1.4875 + $obj_tool_map{"otool"} = "otool";
1.4876 + $obj_tool_map{"addr2line"} = "false"; # no addr2line
1.4877 + $obj_tool_map{"objdump"} = "false"; # no objdump
1.4878 + }
1.4879 +
1.4880 + # Go fill in %obj_tool_map with the pathnames to use:
1.4881 + foreach my $tool (keys %obj_tool_map) {
1.4882 + $obj_tool_map{$tool} = ConfigureTool($obj_tool_map{$tool});
1.4883 + }
1.4884 +}
1.4885 +
1.4886 +# Returns the path of a caller-specified object tool. If --tools or
1.4887 +# PPROF_TOOLS are specified, then returns the full path to the tool
1.4888 +# with that prefix. Otherwise, returns the path unmodified (which
1.4889 +# means we will look for it on PATH).
1.4890 +sub ConfigureTool {
1.4891 + my $tool = shift;
1.4892 + my $path;
1.4893 +
1.4894 + # --tools (or $PPROF_TOOLS) is a comma separated list, where each
1.4895 + # item is either a) a pathname prefix, or b) a map of the form
1.4896 + # <tool>:<path>. First we look for an entry of type (b) for our
1.4897 + # tool. If one is found, we use it. Otherwise, we consider all the
1.4898 + # pathname prefixes in turn, until one yields an existing file. If
1.4899 + # none does, we use a default path.
1.4900 + my $tools = $main::opt_tools || $ENV{"PPROF_TOOLS"} || "";
1.4901 + if ($tools =~ m/(,|^)\Q$tool\E:([^,]*)/) {
1.4902 + $path = $2;
1.4903 + # TODO(csilvers): sanity-check that $path exists? Hard if it's relative.
1.4904 + } elsif ($tools ne '') {
1.4905 + foreach my $prefix (split(',', $tools)) {
1.4906 + next if ($prefix =~ /:/); # ignore "tool:fullpath" entries in the list
1.4907 + if (-x $prefix . $tool) {
1.4908 + $path = $prefix . $tool;
1.4909 + last;
1.4910 + }
1.4911 + }
1.4912 + if (!$path) {
1.4913 + error("No '$tool' found with prefix specified by " .
1.4914 + "--tools (or \$PPROF_TOOLS) '$tools'\n");
1.4915 + }
1.4916 + } else {
1.4917 + # ... otherwise use the version that exists in the same directory as
1.4918 + # pprof. If there's nothing there, use $PATH.
1.4919 + $0 =~ m,[^/]*$,; # this is everything after the last slash
1.4920 + my $dirname = $`; # this is everything up to and including the last slash
1.4921 + if (-x "$dirname$tool") {
1.4922 + $path = "$dirname$tool";
1.4923 + } else {
1.4924 + $path = $tool;
1.4925 + }
1.4926 + }
1.4927 + if ($main::opt_debug) { print STDERR "Using '$path' for '$tool'.\n"; }
1.4928 + return $path;
1.4929 +}
1.4930 +
1.4931 +sub ShellEscape {
1.4932 + my @escaped_words = ();
1.4933 + foreach my $word (@_) {
1.4934 + my $escaped_word = $word;
1.4935 + if ($word =~ m![^a-zA-Z0-9/.,_=-]!) { # check for anything not in whitelist
1.4936 + $escaped_word =~ s/'/'\\''/;
1.4937 + $escaped_word = "'$escaped_word'";
1.4938 + }
1.4939 + push(@escaped_words, $escaped_word);
1.4940 + }
1.4941 + return join(" ", @escaped_words);
1.4942 +}
1.4943 +
1.4944 +sub cleanup {
1.4945 + unlink($main::tmpfile_sym);
1.4946 + unlink(keys %main::tempnames);
1.4947 +
1.4948 + # We leave any collected profiles in $HOME/pprof in case the user wants
1.4949 + # to look at them later. We print a message informing them of this.
1.4950 + if ((scalar(@main::profile_files) > 0) &&
1.4951 + defined($main::collected_profile)) {
1.4952 + if (scalar(@main::profile_files) == 1) {
1.4953 + print STDERR "Dynamically gathered profile is in $main::collected_profile\n";
1.4954 + }
1.4955 + print STDERR "If you want to investigate this profile further, you can do:\n";
1.4956 + print STDERR "\n";
1.4957 + print STDERR " pprof \\\n";
1.4958 + print STDERR " $main::prog \\\n";
1.4959 + print STDERR " $main::collected_profile\n";
1.4960 + print STDERR "\n";
1.4961 + }
1.4962 +}
1.4963 +
1.4964 +sub sighandler {
1.4965 + cleanup();
1.4966 + exit(1);
1.4967 +}
1.4968 +
1.4969 +sub error {
1.4970 + my $msg = shift;
1.4971 + print STDERR $msg;
1.4972 + cleanup();
1.4973 + exit(1);
1.4974 +}
1.4975 +
1.4976 +
1.4977 +# Run $nm_command and get all the resulting procedure boundaries whose
1.4978 +# names match "$regexp" and returns them in a hashtable mapping from
1.4979 +# procedure name to a two-element vector of [start address, end address]
1.4980 +sub GetProcedureBoundariesViaNm {
1.4981 + my $escaped_nm_command = shift; # shell-escaped
1.4982 + my $regexp = shift;
1.4983 +
1.4984 + my $symbol_table = {};
1.4985 + open(NM, "$escaped_nm_command |") || error("$escaped_nm_command: $!\n");
1.4986 + my $last_start = "0";
1.4987 + my $routine = "";
1.4988 + while (<NM>) {
1.4989 + s/\r//g; # turn windows-looking lines into unix-looking lines
1.4990 + if (m/^\s*([0-9a-f]+) (.) (..*)/) {
1.4991 + my $start_val = $1;
1.4992 + my $type = $2;
1.4993 + my $this_routine = $3;
1.4994 +
1.4995 + # It's possible for two symbols to share the same address, if
1.4996 + # one is a zero-length variable (like __start_google_malloc) or
1.4997 + # one symbol is a weak alias to another (like __libc_malloc).
1.4998 + # In such cases, we want to ignore all values except for the
1.4999 + # actual symbol, which in nm-speak has type "T". The logic
1.5000 + # below does this, though it's a bit tricky: what happens when
1.5001 + # we have a series of lines with the same address, is the first
1.5002 + # one gets queued up to be processed. However, it won't
1.5003 + # *actually* be processed until later, when we read a line with
1.5004 + # a different address. That means that as long as we're reading
1.5005 + # lines with the same address, we have a chance to replace that
1.5006 + # item in the queue, which we do whenever we see a 'T' entry --
1.5007 + # that is, a line with type 'T'. If we never see a 'T' entry,
1.5008 + # we'll just go ahead and process the first entry (which never
1.5009 + # got touched in the queue), and ignore the others.
1.5010 + if ($start_val eq $last_start && $type =~ /t/i) {
1.5011 + # We are the 'T' symbol at this address, replace previous symbol.
1.5012 + $routine = $this_routine;
1.5013 + next;
1.5014 + } elsif ($start_val eq $last_start) {
1.5015 + # We're not the 'T' symbol at this address, so ignore us.
1.5016 + next;
1.5017 + }
1.5018 +
1.5019 + if ($this_routine eq $sep_symbol) {
1.5020 + $sep_address = HexExtend($start_val);
1.5021 + }
1.5022 +
1.5023 + # Tag this routine with the starting address in case the image
1.5024 + # has multiple occurrences of this routine. We use a syntax
1.5025 + # that resembles template paramters that are automatically
1.5026 + # stripped out by ShortFunctionName()
1.5027 + $this_routine .= "<$start_val>";
1.5028 +
1.5029 + if (defined($routine) && $routine =~ m/$regexp/) {
1.5030 + $symbol_table->{$routine} = [HexExtend($last_start),
1.5031 + HexExtend($start_val)];
1.5032 + }
1.5033 + $last_start = $start_val;
1.5034 + $routine = $this_routine;
1.5035 + } elsif (m/^Loaded image name: (.+)/) {
1.5036 + # The win32 nm workalike emits information about the binary it is using.
1.5037 + if ($main::opt_debug) { print STDERR "Using Image $1\n"; }
1.5038 + } elsif (m/^PDB file name: (.+)/) {
1.5039 + # The win32 nm workalike emits information about the pdb it is using.
1.5040 + if ($main::opt_debug) { print STDERR "Using PDB $1\n"; }
1.5041 + }
1.5042 + }
1.5043 + close(NM);
1.5044 + # Handle the last line in the nm output. Unfortunately, we don't know
1.5045 + # how big this last symbol is, because we don't know how big the file
1.5046 + # is. For now, we just give it a size of 0.
1.5047 + # TODO(csilvers): do better here.
1.5048 + if (defined($routine) && $routine =~ m/$regexp/) {
1.5049 + $symbol_table->{$routine} = [HexExtend($last_start),
1.5050 + HexExtend($last_start)];
1.5051 + }
1.5052 + return $symbol_table;
1.5053 +}
1.5054 +
1.5055 +# Gets the procedure boundaries for all routines in "$image" whose names
1.5056 +# match "$regexp" and returns them in a hashtable mapping from procedure
1.5057 +# name to a two-element vector of [start address, end address].
1.5058 +# Will return an empty map if nm is not installed or not working properly.
1.5059 +sub GetProcedureBoundaries {
1.5060 + my $image = shift;
1.5061 + my $regexp = shift;
1.5062 +
1.5063 + # If $image doesn't start with /, then put ./ in front of it. This works
1.5064 + # around an obnoxious bug in our probing of nm -f behavior.
1.5065 + # "nm -f $image" is supposed to fail on GNU nm, but if:
1.5066 + #
1.5067 + # a. $image starts with [BbSsPp] (for example, bin/foo/bar), AND
1.5068 + # b. you have a.out in your current directory (a not uncommon occurence)
1.5069 + #
1.5070 + # then "nm -f $image" succeeds because -f only looks at the first letter of
1.5071 + # the argument, which looks valid because it's [BbSsPp], and then since
1.5072 + # there's no image provided, it looks for a.out and finds it.
1.5073 + #
1.5074 + # This regex makes sure that $image starts with . or /, forcing the -f
1.5075 + # parsing to fail since . and / are not valid formats.
1.5076 + $image =~ s#^[^/]#./$&#;
1.5077 +
1.5078 + # For libc libraries, the copy in /usr/lib/debug contains debugging symbols
1.5079 + my $debugging = DebuggingLibrary($image);
1.5080 + if ($debugging) {
1.5081 + $image = $debugging;
1.5082 + }
1.5083 +
1.5084 + my $nm = $obj_tool_map{"nm"};
1.5085 + my $cppfilt = $obj_tool_map{"c++filt"};
1.5086 +
1.5087 + # nm can fail for two reasons: 1) $image isn't a debug library; 2) nm
1.5088 + # binary doesn't support --demangle. In addition, for OS X we need
1.5089 + # to use the -f flag to get 'flat' nm output (otherwise we don't sort
1.5090 + # properly and get incorrect results). Unfortunately, GNU nm uses -f
1.5091 + # in an incompatible way. So first we test whether our nm supports
1.5092 + # --demangle and -f.
1.5093 + my $demangle_flag = "";
1.5094 + my $cppfilt_flag = "";
1.5095 + my $to_devnull = ">$dev_null 2>&1";
1.5096 + if (system(ShellEscape($nm, "--demangle", "image") . $to_devnull) == 0) {
1.5097 + # In this mode, we do "nm --demangle <foo>"
1.5098 + $demangle_flag = "--demangle";
1.5099 + $cppfilt_flag = "";
1.5100 + } elsif (system(ShellEscape($cppfilt, $image) . $to_devnull) == 0) {
1.5101 + # In this mode, we do "nm <foo> | c++filt"
1.5102 + $cppfilt_flag = " | " . ShellEscape($cppfilt);
1.5103 + };
1.5104 + my $flatten_flag = "";
1.5105 + if (system(ShellEscape($nm, "-f", $image) . $to_devnull) == 0) {
1.5106 + $flatten_flag = "-f";
1.5107 + }
1.5108 +
1.5109 + # Finally, in the case $imagie isn't a debug library, we try again with
1.5110 + # -D to at least get *exported* symbols. If we can't use --demangle,
1.5111 + # we use c++filt instead, if it exists on this system.
1.5112 + my @nm_commands = (ShellEscape($nm, "-n", $flatten_flag, $demangle_flag,
1.5113 + $image) . " 2>$dev_null $cppfilt_flag",
1.5114 + ShellEscape($nm, "-D", "-n", $flatten_flag, $demangle_flag,
1.5115 + $image) . " 2>$dev_null $cppfilt_flag",
1.5116 + # 6nm is for Go binaries
1.5117 + ShellEscape("6nm", "$image") . " 2>$dev_null | sort",
1.5118 + );
1.5119 +
1.5120 + # If the executable is an MS Windows PDB-format executable, we'll
1.5121 + # have set up obj_tool_map("nm_pdb"). In this case, we actually
1.5122 + # want to use both unix nm and windows-specific nm_pdb, since
1.5123 + # PDB-format executables can apparently include dwarf .o files.
1.5124 + if (exists $obj_tool_map{"nm_pdb"}) {
1.5125 + push(@nm_commands,
1.5126 + ShellEscape($obj_tool_map{"nm_pdb"}, "--demangle", $image)
1.5127 + . " 2>$dev_null");
1.5128 + }
1.5129 +
1.5130 + foreach my $nm_command (@nm_commands) {
1.5131 + my $symbol_table = GetProcedureBoundariesViaNm($nm_command, $regexp);
1.5132 + return $symbol_table if (%{$symbol_table});
1.5133 + }
1.5134 + my $symbol_table = {};
1.5135 + return $symbol_table;
1.5136 +}
1.5137 +
1.5138 +
1.5139 +# The test vectors for AddressAdd/Sub/Inc are 8-16-nibble hex strings.
1.5140 +# To make them more readable, we add underscores at interesting places.
1.5141 +# This routine removes the underscores, producing the canonical representation
1.5142 +# used by pprof to represent addresses, particularly in the tested routines.
1.5143 +sub CanonicalHex {
1.5144 + my $arg = shift;
1.5145 + return join '', (split '_',$arg);
1.5146 +}
1.5147 +
1.5148 +
1.5149 +# Unit test for AddressAdd:
1.5150 +sub AddressAddUnitTest {
1.5151 + my $test_data_8 = shift;
1.5152 + my $test_data_16 = shift;
1.5153 + my $error_count = 0;
1.5154 + my $fail_count = 0;
1.5155 + my $pass_count = 0;
1.5156 + # print STDERR "AddressAddUnitTest: ", 1+$#{$test_data_8}, " tests\n";
1.5157 +
1.5158 + # First a few 8-nibble addresses. Note that this implementation uses
1.5159 + # plain old arithmetic, so a quick sanity check along with verifying what
1.5160 + # happens to overflow (we want it to wrap):
1.5161 + $address_length = 8;
1.5162 + foreach my $row (@{$test_data_8}) {
1.5163 + if ($main::opt_debug and $main::opt_test) { print STDERR "@{$row}\n"; }
1.5164 + my $sum = AddressAdd ($row->[0], $row->[1]);
1.5165 + if ($sum ne $row->[2]) {
1.5166 + printf STDERR "ERROR: %s != %s + %s = %s\n", $sum,
1.5167 + $row->[0], $row->[1], $row->[2];
1.5168 + ++$fail_count;
1.5169 + } else {
1.5170 + ++$pass_count;
1.5171 + }
1.5172 + }
1.5173 + printf STDERR "AddressAdd 32-bit tests: %d passes, %d failures\n",
1.5174 + $pass_count, $fail_count;
1.5175 + $error_count = $fail_count;
1.5176 + $fail_count = 0;
1.5177 + $pass_count = 0;
1.5178 +
1.5179 + # Now 16-nibble addresses.
1.5180 + $address_length = 16;
1.5181 + foreach my $row (@{$test_data_16}) {
1.5182 + if ($main::opt_debug and $main::opt_test) { print STDERR "@{$row}\n"; }
1.5183 + my $sum = AddressAdd (CanonicalHex($row->[0]), CanonicalHex($row->[1]));
1.5184 + my $expected = join '', (split '_',$row->[2]);
1.5185 + if ($sum ne CanonicalHex($row->[2])) {
1.5186 + printf STDERR "ERROR: %s != %s + %s = %s\n", $sum,
1.5187 + $row->[0], $row->[1], $row->[2];
1.5188 + ++$fail_count;
1.5189 + } else {
1.5190 + ++$pass_count;
1.5191 + }
1.5192 + }
1.5193 + printf STDERR "AddressAdd 64-bit tests: %d passes, %d failures\n",
1.5194 + $pass_count, $fail_count;
1.5195 + $error_count += $fail_count;
1.5196 +
1.5197 + return $error_count;
1.5198 +}
1.5199 +
1.5200 +
1.5201 +# Unit test for AddressSub:
1.5202 +sub AddressSubUnitTest {
1.5203 + my $test_data_8 = shift;
1.5204 + my $test_data_16 = shift;
1.5205 + my $error_count = 0;
1.5206 + my $fail_count = 0;
1.5207 + my $pass_count = 0;
1.5208 + # print STDERR "AddressSubUnitTest: ", 1+$#{$test_data_8}, " tests\n";
1.5209 +
1.5210 + # First a few 8-nibble addresses. Note that this implementation uses
1.5211 + # plain old arithmetic, so a quick sanity check along with verifying what
1.5212 + # happens to overflow (we want it to wrap):
1.5213 + $address_length = 8;
1.5214 + foreach my $row (@{$test_data_8}) {
1.5215 + if ($main::opt_debug and $main::opt_test) { print STDERR "@{$row}\n"; }
1.5216 + my $sum = AddressSub ($row->[0], $row->[1]);
1.5217 + if ($sum ne $row->[3]) {
1.5218 + printf STDERR "ERROR: %s != %s - %s = %s\n", $sum,
1.5219 + $row->[0], $row->[1], $row->[3];
1.5220 + ++$fail_count;
1.5221 + } else {
1.5222 + ++$pass_count;
1.5223 + }
1.5224 + }
1.5225 + printf STDERR "AddressSub 32-bit tests: %d passes, %d failures\n",
1.5226 + $pass_count, $fail_count;
1.5227 + $error_count = $fail_count;
1.5228 + $fail_count = 0;
1.5229 + $pass_count = 0;
1.5230 +
1.5231 + # Now 16-nibble addresses.
1.5232 + $address_length = 16;
1.5233 + foreach my $row (@{$test_data_16}) {
1.5234 + if ($main::opt_debug and $main::opt_test) { print STDERR "@{$row}\n"; }
1.5235 + my $sum = AddressSub (CanonicalHex($row->[0]), CanonicalHex($row->[1]));
1.5236 + if ($sum ne CanonicalHex($row->[3])) {
1.5237 + printf STDERR "ERROR: %s != %s - %s = %s\n", $sum,
1.5238 + $row->[0], $row->[1], $row->[3];
1.5239 + ++$fail_count;
1.5240 + } else {
1.5241 + ++$pass_count;
1.5242 + }
1.5243 + }
1.5244 + printf STDERR "AddressSub 64-bit tests: %d passes, %d failures\n",
1.5245 + $pass_count, $fail_count;
1.5246 + $error_count += $fail_count;
1.5247 +
1.5248 + return $error_count;
1.5249 +}
1.5250 +
1.5251 +
1.5252 +# Unit test for AddressInc:
1.5253 +sub AddressIncUnitTest {
1.5254 + my $test_data_8 = shift;
1.5255 + my $test_data_16 = shift;
1.5256 + my $error_count = 0;
1.5257 + my $fail_count = 0;
1.5258 + my $pass_count = 0;
1.5259 + # print STDERR "AddressIncUnitTest: ", 1+$#{$test_data_8}, " tests\n";
1.5260 +
1.5261 + # First a few 8-nibble addresses. Note that this implementation uses
1.5262 + # plain old arithmetic, so a quick sanity check along with verifying what
1.5263 + # happens to overflow (we want it to wrap):
1.5264 + $address_length = 8;
1.5265 + foreach my $row (@{$test_data_8}) {
1.5266 + if ($main::opt_debug and $main::opt_test) { print STDERR "@{$row}\n"; }
1.5267 + my $sum = AddressInc ($row->[0]);
1.5268 + if ($sum ne $row->[4]) {
1.5269 + printf STDERR "ERROR: %s != %s + 1 = %s\n", $sum,
1.5270 + $row->[0], $row->[4];
1.5271 + ++$fail_count;
1.5272 + } else {
1.5273 + ++$pass_count;
1.5274 + }
1.5275 + }
1.5276 + printf STDERR "AddressInc 32-bit tests: %d passes, %d failures\n",
1.5277 + $pass_count, $fail_count;
1.5278 + $error_count = $fail_count;
1.5279 + $fail_count = 0;
1.5280 + $pass_count = 0;
1.5281 +
1.5282 + # Now 16-nibble addresses.
1.5283 + $address_length = 16;
1.5284 + foreach my $row (@{$test_data_16}) {
1.5285 + if ($main::opt_debug and $main::opt_test) { print STDERR "@{$row}\n"; }
1.5286 + my $sum = AddressInc (CanonicalHex($row->[0]));
1.5287 + if ($sum ne CanonicalHex($row->[4])) {
1.5288 + printf STDERR "ERROR: %s != %s + 1 = %s\n", $sum,
1.5289 + $row->[0], $row->[4];
1.5290 + ++$fail_count;
1.5291 + } else {
1.5292 + ++$pass_count;
1.5293 + }
1.5294 + }
1.5295 + printf STDERR "AddressInc 64-bit tests: %d passes, %d failures\n",
1.5296 + $pass_count, $fail_count;
1.5297 + $error_count += $fail_count;
1.5298 +
1.5299 + return $error_count;
1.5300 +}
1.5301 +
1.5302 +
1.5303 +# Driver for unit tests.
1.5304 +# Currently just the address add/subtract/increment routines for 64-bit.
1.5305 +sub RunUnitTests {
1.5306 + my $error_count = 0;
1.5307 +
1.5308 + # This is a list of tuples [a, b, a+b, a-b, a+1]
1.5309 + my $unit_test_data_8 = [
1.5310 + [qw(aaaaaaaa 50505050 fafafafa 5a5a5a5a aaaaaaab)],
1.5311 + [qw(50505050 aaaaaaaa fafafafa a5a5a5a6 50505051)],
1.5312 + [qw(ffffffff aaaaaaaa aaaaaaa9 55555555 00000000)],
1.5313 + [qw(00000001 ffffffff 00000000 00000002 00000002)],
1.5314 + [qw(00000001 fffffff0 fffffff1 00000011 00000002)],
1.5315 + ];
1.5316 + my $unit_test_data_16 = [
1.5317 + # The implementation handles data in 7-nibble chunks, so those are the
1.5318 + # interesting boundaries.
1.5319 + [qw(aaaaaaaa 50505050
1.5320 + 00_000000f_afafafa 00_0000005_a5a5a5a 00_000000a_aaaaaab)],
1.5321 + [qw(50505050 aaaaaaaa
1.5322 + 00_000000f_afafafa ff_ffffffa_5a5a5a6 00_0000005_0505051)],
1.5323 + [qw(ffffffff aaaaaaaa
1.5324 + 00_000001a_aaaaaa9 00_0000005_5555555 00_0000010_0000000)],
1.5325 + [qw(00000001 ffffffff
1.5326 + 00_0000010_0000000 ff_ffffff0_0000002 00_0000000_0000002)],
1.5327 + [qw(00000001 fffffff0
1.5328 + 00_000000f_ffffff1 ff_ffffff0_0000011 00_0000000_0000002)],
1.5329 +
1.5330 + [qw(00_a00000a_aaaaaaa 50505050
1.5331 + 00_a00000f_afafafa 00_a000005_a5a5a5a 00_a00000a_aaaaaab)],
1.5332 + [qw(0f_fff0005_0505050 aaaaaaaa
1.5333 + 0f_fff000f_afafafa 0f_ffefffa_5a5a5a6 0f_fff0005_0505051)],
1.5334 + [qw(00_000000f_fffffff 01_800000a_aaaaaaa
1.5335 + 01_800001a_aaaaaa9 fe_8000005_5555555 00_0000010_0000000)],
1.5336 + [qw(00_0000000_0000001 ff_fffffff_fffffff
1.5337 + 00_0000000_0000000 00_0000000_0000002 00_0000000_0000002)],
1.5338 + [qw(00_0000000_0000001 ff_fffffff_ffffff0
1.5339 + ff_fffffff_ffffff1 00_0000000_0000011 00_0000000_0000002)],
1.5340 + ];
1.5341 +
1.5342 + $error_count += AddressAddUnitTest($unit_test_data_8, $unit_test_data_16);
1.5343 + $error_count += AddressSubUnitTest($unit_test_data_8, $unit_test_data_16);
1.5344 + $error_count += AddressIncUnitTest($unit_test_data_8, $unit_test_data_16);
1.5345 + if ($error_count > 0) {
1.5346 + print STDERR $error_count, " errors: FAILED\n";
1.5347 + } else {
1.5348 + print STDERR "PASS\n";
1.5349 + }
1.5350 + exit ($error_count);
1.5351 +}
