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