| #! /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; |
| use File::Temp; |
| use File::Copy; |
| |
| my $PPROF_VERSION = "1.5"; |
| |
| # NOTE: All mentions of c++filt have been expunged from this script |
| # because (1) we don't use C++, and (2) the copy of c++filt that ships |
| # on OS X is from 2007 and destroys nm output by "demangling" the |
| # first two columns (address and symbol type). |
| |
| # 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", |
| ## 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 |
| |
| # 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 $BLOCK_PAGE = "/pprof/block"; |
| 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; |
| |
| my $OS = $^O; |
| my $DEVNULL = "/dev/null"; |
| if ($^O =~ /MSWin32|cygwin|msys/) { |
| $OS = "windows"; |
| $DEVNULL = "NUL"; |
| } |
| |
| ##### 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, $BLOCK_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 = File::Temp->new()->filename; |
| $main::tmpfile_ps = File::Temp->new()->filename; |
| |
| $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 ($ARGV[0] && 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) { |
| Infof("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 >$DEVNULL 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"; |
| |
| my $uname = `uname`; |
| if ($uname =~ /Darwin/) { |
| # OS X: open will use standard preference for SVG files. |
| system("/usr/bin/open", $fname); |
| return; |
| } |
| |
| if ($uname =~ /CYGWIN/) { |
| # Windows(cygwin): open will use standard preference for SVG files. |
| my $winname = `cygpath -wa $fname`; |
| system("explorer.exe", $winname); |
| return; |
| } |
| if ($uname =~ /MINGW/) { |
| # Windows(MinGW): open will use standard preference for SVG files. |
| system("cmd", "/c", "start", $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 (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); |
| Infof("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); |
| Infof("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 information conditionally filtered out depending on the output |
| # format. |
| sub Infof { |
| my $format = shift; |
| my @args = @_; |
| return if $main::opt_svg; |
| printf($format, @args); |
| } |
| |
| # 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"); |
| |
| if (system("$objdump --help >$DEVNULL 2>&1") != 0) { |
| # objdump must not exist. Fall back to go tool objdump. |
| $objdump = "go tool objdump"; |
| $cmd = "$objdump $prog 0x$start_addr 0x$end_addr"; |
| } |
| |
| 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', |
| 'cnew', |
| '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', |
| 'profilealloc', |
| 'runtime.new', |
| 'makeslice1', |
| 'runtime.malloc', |
| 'unsafe.New', |
| 'runtime.mallocgc', |
| 'runtime.catstring', |
| 'runtime.cnew', |
| 'runtime.cnewarray', |
| 'runtime.growslice', |
| 'runtime.ifaceT2E', |
| 'runtime.ifaceT2I', |
| 'runtime.makechan', |
| 'runtime.makechan_c', |
| 'runtime.makemap', |
| 'runtime.makemap_c', |
| 'runtime.makeslice', |
| 'runtime.mal', |
| 'runtime.settype', |
| 'runtime.settype_flush', |
| '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"; |
| |
| my $line = FetchHTTP($url); |
| $line =~ s/\r//g; # turn windows-looking lines into unix-looking lines |
| 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 ($scheme, $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,^(?:(https?)://|)([^/:]+):(\d+)(|\@\d+)(|/|(.*?)($PROFILE_PAGE|$PMUPROFILE_PAGE|$HEAP_PAGE|$GROWTH_PAGE|$THREAD_PAGE|$BLOCK_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 ($1 || "http", $2, $3, $6, $7 || $5); |
| } |
| return (); |
| } |
| |
| # We fetch symbols from the first profile argument. |
| sub SymbolPageURL { |
| my ($scheme, $host, $port, $prefix, $path) = ParseProfileURL($main::pfile_args[0]); |
| return "$scheme://$host:$port$prefix$SYMBOL_PAGE"; |
| } |
| |
| sub FetchProgramName() { |
| my ($scheme, $host, $port, $prefix, $path) = ParseProfileURL($main::pfile_args[0]); |
| my $url = "$scheme://$host:$port$prefix$PROGRAM_NAME_PAGE"; |
| |
| my $cmdline = FetchHTTP($url); |
| $cmdline =~ s/\n.*//s; # first line only |
| $cmdline =~ s/\r//g; # turn windows-looking lines into unix-looking lines |
| 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; |
| } |
| |
| # 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))); |
| my $url = SymbolPageURL(); |
| my $content = PostHTTP($url, $post_data); |
| |
| my $tmp_symbol = File::Temp->new()->filename; |
| open(SYMBOL, ">$tmp_symbol"); |
| print SYMBOL $content; |
| close(SYMBOL); |
| |
| open(SYMBOL, "<$tmp_symbol") || error("$tmp_symbol"); |
| 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 ($scheme, $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 ($scheme, $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 $timeout; |
| if (($path =~ m/$PROFILE_PAGE/) || ($path =~ m/$PMUPROFILE_PAGE/)) { |
| if ($path =~ m/$PROFILE_PAGE/) { |
| $url = sprintf("$scheme://$host:$port$prefix$path?seconds=%d", |
| $main::opt_seconds); |
| } else { |
| if ($profile_name =~ m/[?]/) { |
| $profile_name .= "&" |
| } else { |
| $profile_name .= "?" |
| } |
| $url = sprintf("$scheme://$profile_name" . "seconds=%d", |
| $main::opt_seconds); |
| } |
| $timeout = 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 = "$scheme://$host:$port$prefix$path"; |
| } |
| |
| my $tmp_profile = File::Temp->new()->filename; |
| my $real_profile = File::Temp->new()->filename; |
| |
| if ($fetch_name_only > 0) { |
| return $real_profile; |
| } |
| |
| 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"; |
| } |
| |
| my $content = FetchHTTP($url, $timeout); |
| |
| open(OUTFILE, ">$tmp_profile"); |
| binmode(OUTFILE); |
| print OUTFILE $content; |
| close(OUTFILE); |
| |
| my $line = $content; |
| $line !~ /^Could not enable CPU profiling/ || error($line); |
| |
| copy($tmp_profile, $real_profile) || error("Unable to copy 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; |
| if ($n1 > 0) { |
| $ratio = (($s1*1.0)/$n1)/($sample_adjustment); |
| if ($ratio < 1) { |
| $n1 /= $ratio; |
| $s1 /= $ratio; |
| } |
| } |
| if ($n2 > 0) { |
| $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; |
|