michael@0: #! /usr/bin/env perl michael@0: michael@0: # Copyright (c) 1998-2007, Google Inc. michael@0: # All rights reserved. michael@0: # michael@0: # Redistribution and use in source and binary forms, with or without michael@0: # modification, are permitted provided that the following conditions are michael@0: # met: michael@0: # michael@0: # * Redistributions of source code must retain the above copyright michael@0: # notice, this list of conditions and the following disclaimer. michael@0: # * Redistributions in binary form must reproduce the above michael@0: # copyright notice, this list of conditions and the following disclaimer michael@0: # in the documentation and/or other materials provided with the michael@0: # distribution. michael@0: # * Neither the name of Google Inc. nor the names of its michael@0: # contributors may be used to endorse or promote products derived from michael@0: # this software without specific prior written permission. michael@0: # michael@0: # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS michael@0: # "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT michael@0: # LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR michael@0: # A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT michael@0: # OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, michael@0: # SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT michael@0: # LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, michael@0: # DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY michael@0: # THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT michael@0: # (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE michael@0: # OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. michael@0: michael@0: # --- michael@0: # Program for printing the profile generated by common/profiler.cc, michael@0: # or by the heap profiler (common/debugallocation.cc) michael@0: # michael@0: # The profile contains a sequence of entries of the form: michael@0: # michael@0: # This program parses the profile, and generates user-readable michael@0: # output. michael@0: # michael@0: # Examples: michael@0: # michael@0: # % tools/pprof "program" "profile" michael@0: # Enters "interactive" mode michael@0: # michael@0: # % tools/pprof --text "program" "profile" michael@0: # Generates one line per procedure michael@0: # michael@0: # % tools/pprof --gv "program" "profile" michael@0: # Generates annotated call-graph and displays via "gv" michael@0: # michael@0: # % tools/pprof --gv --focus=Mutex "program" "profile" michael@0: # Restrict to code paths that involve an entry that matches "Mutex" michael@0: # michael@0: # % tools/pprof --gv --focus=Mutex --ignore=string "program" "profile" michael@0: # Restrict to code paths that involve an entry that matches "Mutex" michael@0: # and does not match "string" michael@0: # michael@0: # % tools/pprof --list=IBF_CheckDocid "program" "profile" michael@0: # Generates disassembly listing of all routines with at least one michael@0: # sample that match the --list= pattern. The listing is michael@0: # annotated with the flat and cumulative sample counts at each line. michael@0: # michael@0: # % tools/pprof --disasm=IBF_CheckDocid "program" "profile" michael@0: # Generates disassembly listing of all routines with at least one michael@0: # sample that match the --disasm= pattern. The listing is michael@0: # annotated with the flat and cumulative sample counts at each PC value. michael@0: # michael@0: # TODO: Use color to indicate files? michael@0: michael@0: use strict; michael@0: use warnings; michael@0: use Getopt::Long; michael@0: michael@0: my $PPROF_VERSION = "2.0"; michael@0: michael@0: # These are the object tools we use which can come from a michael@0: # user-specified location using --tools, from the PPROF_TOOLS michael@0: # environment variable, or from the environment. michael@0: my %obj_tool_map = ( michael@0: "objdump" => "objdump", michael@0: "nm" => "nm", michael@0: "addr2line" => "addr2line", michael@0: "c++filt" => "c++filt", michael@0: ## ConfigureObjTools may add architecture-specific entries: michael@0: #"nm_pdb" => "nm-pdb", # for reading windows (PDB-format) executables michael@0: #"addr2line_pdb" => "addr2line-pdb", # ditto michael@0: #"otool" => "otool", # equivalent of objdump on OS X michael@0: ); michael@0: # NOTE: these are lists, so you can put in commandline flags if you want. michael@0: my @DOT = ("dot"); # leave non-absolute, since it may be in /usr/local michael@0: my @GV = ("gv"); michael@0: my @EVINCE = ("evince"); # could also be xpdf or perhaps acroread michael@0: my @KCACHEGRIND = ("kcachegrind"); michael@0: my @PS2PDF = ("ps2pdf"); michael@0: # These are used for dynamic profiles michael@0: my @URL_FETCHER = ("curl", "-s"); michael@0: michael@0: # These are the web pages that servers need to support for dynamic profiles michael@0: my $HEAP_PAGE = "/pprof/heap"; michael@0: my $PROFILE_PAGE = "/pprof/profile"; # must support cgi-param "?seconds=#" michael@0: my $PMUPROFILE_PAGE = "/pprof/pmuprofile(?:\\?.*)?"; # must support cgi-param michael@0: # ?seconds=#&event=x&period=n michael@0: my $GROWTH_PAGE = "/pprof/growth"; michael@0: my $CONTENTION_PAGE = "/pprof/contention"; michael@0: my $WALL_PAGE = "/pprof/wall(?:\\?.*)?"; # accepts options like namefilter michael@0: my $FILTEREDPROFILE_PAGE = "/pprof/filteredprofile(?:\\?.*)?"; michael@0: my $CENSUSPROFILE_PAGE = "/pprof/censusprofile(?:\\?.*)?"; # must support cgi-param michael@0: # "?seconds=#", michael@0: # "?tags_regexp=#" and michael@0: # "?type=#". michael@0: my $SYMBOL_PAGE = "/pprof/symbol"; # must support symbol lookup via POST michael@0: my $PROGRAM_NAME_PAGE = "/pprof/cmdline"; michael@0: michael@0: # These are the web pages that can be named on the command line. michael@0: # All the alternatives must begin with /. michael@0: my $PROFILES = "($HEAP_PAGE|$PROFILE_PAGE|$PMUPROFILE_PAGE|" . michael@0: "$GROWTH_PAGE|$CONTENTION_PAGE|$WALL_PAGE|" . michael@0: "$FILTEREDPROFILE_PAGE|$CENSUSPROFILE_PAGE)"; michael@0: michael@0: # default binary name michael@0: my $UNKNOWN_BINARY = "(unknown)"; michael@0: michael@0: # There is a pervasive dependency on the length (in hex characters, michael@0: # i.e., nibbles) of an address, distinguishing between 32-bit and michael@0: # 64-bit profiles. To err on the safe size, default to 64-bit here: michael@0: my $address_length = 16; michael@0: michael@0: my $dev_null = "/dev/null"; michael@0: if (! -e $dev_null && $^O =~ /MSWin/) { # $^O is the OS perl was built for michael@0: $dev_null = "nul"; michael@0: } michael@0: michael@0: # A list of paths to search for shared object files michael@0: my @prefix_list = (); michael@0: michael@0: # Special routine name that should not have any symbols. michael@0: # Used as separator to parse "addr2line -i" output. michael@0: my $sep_symbol = '_fini'; michael@0: my $sep_address = undef; michael@0: michael@0: ##### Argument parsing ##### michael@0: michael@0: sub usage_string { michael@0: return < michael@0: is a space separated list of profile names. michael@0: pprof [options] michael@0: is a list of profile files where each file contains michael@0: the necessary symbol mappings as well as profile data (likely generated michael@0: with --raw). michael@0: pprof [options] michael@0: is a remote form. Symbols are obtained from host:port$SYMBOL_PAGE michael@0: michael@0: Each name can be: michael@0: /path/to/profile - a path to a profile file michael@0: host:port[/] - a location of a service to get profile from michael@0: michael@0: The / can be $HEAP_PAGE, $PROFILE_PAGE, /pprof/pmuprofile, michael@0: $GROWTH_PAGE, $CONTENTION_PAGE, /pprof/wall, michael@0: $CENSUSPROFILE_PAGE, or /pprof/filteredprofile. michael@0: For instance: michael@0: pprof http://myserver.com:80$HEAP_PAGE michael@0: If / is omitted, the service defaults to $PROFILE_PAGE (cpu profiling). michael@0: pprof --symbols michael@0: Maps addresses to symbol names. In this mode, stdin should be a michael@0: list of library mappings, in the same format as is found in the heap- michael@0: and cpu-profile files (this loosely matches that of /proc/self/maps michael@0: on linux), followed by a list of hex addresses to map, one per line. michael@0: michael@0: For more help with querying remote servers, including how to add the michael@0: necessary server-side support code, see this filename (or one like it): michael@0: michael@0: /usr/doc/gperftools-$PPROF_VERSION/pprof_remote_servers.html michael@0: michael@0: Options: michael@0: --cum Sort by cumulative data michael@0: --base= Subtract from before display michael@0: --interactive Run in interactive mode (interactive "help" gives help) [default] michael@0: --seconds= Length of time for dynamic profiles [default=30 secs] michael@0: --add_lib= Read additional symbols and line info from the given library michael@0: --lib_prefix= Comma separated list of library path prefixes michael@0: michael@0: Reporting Granularity: michael@0: --addresses Report at address level michael@0: --lines Report at source line level michael@0: --functions Report at function level [default] michael@0: --files Report at source file level michael@0: michael@0: Output type: michael@0: --text Generate text report michael@0: --callgrind Generate callgrind format to stdout michael@0: --gv Generate Postscript and display michael@0: --evince Generate PDF and display michael@0: --web Generate SVG and display michael@0: --list= Generate source listing of matching routines michael@0: --disasm= Generate disassembly of matching routines michael@0: --symbols Print demangled symbol names found at given addresses michael@0: --dot Generate DOT file to stdout michael@0: --ps Generate Postcript to stdout michael@0: --pdf Generate PDF to stdout michael@0: --svg Generate SVG to stdout michael@0: --gif Generate GIF to stdout michael@0: --raw Generate symbolized pprof data (useful with remote fetch) michael@0: michael@0: Heap-Profile Options: michael@0: --inuse_space Display in-use (mega)bytes [default] michael@0: --inuse_objects Display in-use objects michael@0: --alloc_space Display allocated (mega)bytes michael@0: --alloc_objects Display allocated objects michael@0: --show_bytes Display space in bytes michael@0: --drop_negative Ignore negative differences michael@0: michael@0: Contention-profile options: michael@0: --total_delay Display total delay at each region [default] michael@0: --contentions Display number of delays at each region michael@0: --mean_delay Display mean delay at each region michael@0: michael@0: Call-graph Options: michael@0: --nodecount= Show at most so many nodes [default=80] michael@0: --nodefraction= Hide nodes below *total [default=.005] michael@0: --edgefraction= Hide edges below *total [default=.001] michael@0: --maxdegree= Max incoming/outgoing edges per node [default=8] michael@0: --focus= Focus on nodes matching michael@0: --ignore= Ignore nodes matching michael@0: --scale= Set GV scaling [default=0] michael@0: --heapcheck Make nodes with non-0 object counts michael@0: (i.e. direct leak generators) more visible michael@0: michael@0: Miscellaneous: michael@0: --tools=[,...] \$PATH for object tool pathnames michael@0: --test Run unit tests michael@0: --help This message michael@0: --version Version information michael@0: michael@0: Environment Variables: michael@0: PPROF_TMPDIR Profiles directory. Defaults to \$HOME/pprof michael@0: PPROF_TOOLS Prefix for object tools pathnames michael@0: michael@0: Examples: michael@0: michael@0: pprof /bin/ls ls.prof michael@0: Enters "interactive" mode michael@0: pprof --text /bin/ls ls.prof michael@0: Outputs one line per procedure michael@0: pprof --web /bin/ls ls.prof michael@0: Displays annotated call-graph in web browser michael@0: pprof --gv /bin/ls ls.prof michael@0: Displays annotated call-graph via 'gv' michael@0: pprof --gv --focus=Mutex /bin/ls ls.prof michael@0: Restricts to code paths including a .*Mutex.* entry michael@0: pprof --gv --focus=Mutex --ignore=string /bin/ls ls.prof michael@0: Code paths including Mutex but not string michael@0: pprof --list=getdir /bin/ls ls.prof michael@0: (Per-line) annotated source listing for getdir() michael@0: pprof --disasm=getdir /bin/ls ls.prof michael@0: (Per-PC) annotated disassembly for getdir() michael@0: michael@0: pprof http://localhost:1234/ michael@0: Enters "interactive" mode michael@0: pprof --text localhost:1234 michael@0: Outputs one line per procedure for localhost:1234 michael@0: pprof --raw localhost:1234 > ./local.raw michael@0: pprof --text ./local.raw michael@0: Fetches a remote profile for later analysis and then michael@0: analyzes it in text mode. michael@0: EOF michael@0: } michael@0: michael@0: sub version_string { michael@0: return < \$main::opt_help, michael@0: "version!" => \$main::opt_version, michael@0: "cum!" => \$main::opt_cum, michael@0: "base=s" => \$main::opt_base, michael@0: "seconds=i" => \$main::opt_seconds, michael@0: "add_lib=s" => \$main::opt_lib, michael@0: "lib_prefix=s" => \$main::opt_lib_prefix, michael@0: "functions!" => \$main::opt_functions, michael@0: "lines!" => \$main::opt_lines, michael@0: "addresses!" => \$main::opt_addresses, michael@0: "files!" => \$main::opt_files, michael@0: "text!" => \$main::opt_text, michael@0: "callgrind!" => \$main::opt_callgrind, michael@0: "list=s" => \$main::opt_list, michael@0: "disasm=s" => \$main::opt_disasm, michael@0: "symbols!" => \$main::opt_symbols, michael@0: "gv!" => \$main::opt_gv, michael@0: "evince!" => \$main::opt_evince, michael@0: "web!" => \$main::opt_web, michael@0: "dot!" => \$main::opt_dot, michael@0: "ps!" => \$main::opt_ps, michael@0: "pdf!" => \$main::opt_pdf, michael@0: "svg!" => \$main::opt_svg, michael@0: "gif!" => \$main::opt_gif, michael@0: "raw!" => \$main::opt_raw, michael@0: "interactive!" => \$main::opt_interactive, michael@0: "nodecount=i" => \$main::opt_nodecount, michael@0: "nodefraction=f" => \$main::opt_nodefraction, michael@0: "edgefraction=f" => \$main::opt_edgefraction, michael@0: "maxdegree=i" => \$main::opt_maxdegree, michael@0: "focus=s" => \$main::opt_focus, michael@0: "ignore=s" => \$main::opt_ignore, michael@0: "scale=i" => \$main::opt_scale, michael@0: "heapcheck" => \$main::opt_heapcheck, michael@0: "inuse_space!" => \$main::opt_inuse_space, michael@0: "inuse_objects!" => \$main::opt_inuse_objects, michael@0: "alloc_space!" => \$main::opt_alloc_space, michael@0: "alloc_objects!" => \$main::opt_alloc_objects, michael@0: "show_bytes!" => \$main::opt_show_bytes, michael@0: "drop_negative!" => \$main::opt_drop_negative, michael@0: "total_delay!" => \$main::opt_total_delay, michael@0: "contentions!" => \$main::opt_contentions, michael@0: "mean_delay!" => \$main::opt_mean_delay, michael@0: "tools=s" => \$main::opt_tools, michael@0: "test!" => \$main::opt_test, michael@0: "debug!" => \$main::opt_debug, michael@0: # Undocumented flags used only by unittests: michael@0: "test_stride=i" => \$main::opt_test_stride, michael@0: ) || usage("Invalid option(s)"); michael@0: michael@0: # Deal with the standard --help and --version michael@0: if ($main::opt_help) { michael@0: print usage_string(); michael@0: exit(0); michael@0: } michael@0: michael@0: if ($main::opt_version) { michael@0: print version_string(); michael@0: exit(0); michael@0: } michael@0: michael@0: # Disassembly/listing/symbols mode requires address-level info michael@0: if ($main::opt_disasm || $main::opt_list || $main::opt_symbols) { michael@0: $main::opt_functions = 0; michael@0: $main::opt_lines = 0; michael@0: $main::opt_addresses = 1; michael@0: $main::opt_files = 0; michael@0: } michael@0: michael@0: # Check heap-profiling flags michael@0: if ($main::opt_inuse_space + michael@0: $main::opt_inuse_objects + michael@0: $main::opt_alloc_space + michael@0: $main::opt_alloc_objects > 1) { michael@0: usage("Specify at most on of --inuse/--alloc options"); michael@0: } michael@0: michael@0: # Check output granularities michael@0: my $grains = michael@0: $main::opt_functions + michael@0: $main::opt_lines + michael@0: $main::opt_addresses + michael@0: $main::opt_files + michael@0: 0; michael@0: if ($grains > 1) { michael@0: usage("Only specify one output granularity option"); michael@0: } michael@0: if ($grains == 0) { michael@0: $main::opt_functions = 1; michael@0: } michael@0: michael@0: # Check output modes michael@0: my $modes = michael@0: $main::opt_text + michael@0: $main::opt_callgrind + michael@0: ($main::opt_list eq '' ? 0 : 1) + michael@0: ($main::opt_disasm eq '' ? 0 : 1) + michael@0: ($main::opt_symbols == 0 ? 0 : 1) + michael@0: $main::opt_gv + michael@0: $main::opt_evince + michael@0: $main::opt_web + michael@0: $main::opt_dot + michael@0: $main::opt_ps + michael@0: $main::opt_pdf + michael@0: $main::opt_svg + michael@0: $main::opt_gif + michael@0: $main::opt_raw + michael@0: $main::opt_interactive + michael@0: 0; michael@0: if ($modes > 1) { michael@0: usage("Only specify one output mode"); michael@0: } michael@0: if ($modes == 0) { michael@0: if (-t STDOUT) { # If STDOUT is a tty, activate interactive mode michael@0: $main::opt_interactive = 1; michael@0: } else { michael@0: $main::opt_text = 1; michael@0: } michael@0: } michael@0: michael@0: if ($main::opt_test) { michael@0: RunUnitTests(); michael@0: # Should not return michael@0: exit(1); michael@0: } michael@0: michael@0: # Binary name and profile arguments list michael@0: $main::prog = ""; michael@0: @main::pfile_args = (); michael@0: michael@0: # Remote profiling without a binary (using $SYMBOL_PAGE instead) michael@0: if (@ARGV > 0) { michael@0: if (IsProfileURL($ARGV[0])) { michael@0: $main::use_symbol_page = 1; michael@0: } elsif (IsSymbolizedProfileFile($ARGV[0])) { michael@0: $main::use_symbolized_profile = 1; michael@0: $main::prog = $UNKNOWN_BINARY; # will be set later from the profile file michael@0: } michael@0: } michael@0: michael@0: if ($main::use_symbol_page || $main::use_symbolized_profile) { michael@0: # We don't need a binary! michael@0: my %disabled = ('--lines' => $main::opt_lines, michael@0: '--disasm' => $main::opt_disasm); michael@0: for my $option (keys %disabled) { michael@0: usage("$option cannot be used without a binary") if $disabled{$option}; michael@0: } michael@0: # Set $main::prog later... michael@0: scalar(@ARGV) || usage("Did not specify profile file"); michael@0: } elsif ($main::opt_symbols) { michael@0: # --symbols needs a binary-name (to run nm on, etc) but not profiles michael@0: $main::prog = shift(@ARGV) || usage("Did not specify program"); michael@0: } else { michael@0: $main::prog = shift(@ARGV) || usage("Did not specify program"); michael@0: scalar(@ARGV) || usage("Did not specify profile file"); michael@0: } michael@0: michael@0: # Parse profile file/location arguments michael@0: foreach my $farg (@ARGV) { michael@0: if ($farg =~ m/(.*)\@([0-9]+)(|\/.*)$/ ) { michael@0: my $machine = $1; michael@0: my $num_machines = $2; michael@0: my $path = $3; michael@0: for (my $i = 0; $i < $num_machines; $i++) { michael@0: unshift(@main::pfile_args, "$i.$machine$path"); michael@0: } michael@0: } else { michael@0: unshift(@main::pfile_args, $farg); michael@0: } michael@0: } michael@0: michael@0: if ($main::use_symbol_page) { michael@0: unless (IsProfileURL($main::pfile_args[0])) { michael@0: error("The first profile should be a remote form to use $SYMBOL_PAGE\n"); michael@0: } michael@0: CheckSymbolPage(); michael@0: $main::prog = FetchProgramName(); michael@0: } elsif (!$main::use_symbolized_profile) { # may not need objtools! michael@0: ConfigureObjTools($main::prog) michael@0: } michael@0: michael@0: # Break the opt_lib_prefix into the prefix_list array michael@0: @prefix_list = split (',', $main::opt_lib_prefix); michael@0: michael@0: # Remove trailing / from the prefixes, in the list to prevent michael@0: # searching things like /my/path//lib/mylib.so michael@0: foreach (@prefix_list) { michael@0: s|/+$||; michael@0: } michael@0: } michael@0: michael@0: sub Main() { michael@0: Init(); michael@0: $main::collected_profile = undef; michael@0: @main::profile_files = (); michael@0: $main::op_time = time(); michael@0: michael@0: # Printing symbols is special and requires a lot less info that most. michael@0: if ($main::opt_symbols) { michael@0: PrintSymbols(*STDIN); # Get /proc/maps and symbols output from stdin michael@0: return; michael@0: } michael@0: michael@0: # Fetch all profile data michael@0: FetchDynamicProfiles(); michael@0: michael@0: # this will hold symbols that we read from the profile files michael@0: my $symbol_map = {}; michael@0: michael@0: # Read one profile, pick the last item on the list michael@0: my $data = ReadProfile($main::prog, pop(@main::profile_files)); michael@0: my $profile = $data->{profile}; michael@0: my $pcs = $data->{pcs}; michael@0: my $libs = $data->{libs}; # Info about main program and shared libraries michael@0: $symbol_map = MergeSymbols($symbol_map, $data->{symbols}); michael@0: michael@0: # Add additional profiles, if available. michael@0: if (scalar(@main::profile_files) > 0) { michael@0: foreach my $pname (@main::profile_files) { michael@0: my $data2 = ReadProfile($main::prog, $pname); michael@0: $profile = AddProfile($profile, $data2->{profile}); michael@0: $pcs = AddPcs($pcs, $data2->{pcs}); michael@0: $symbol_map = MergeSymbols($symbol_map, $data2->{symbols}); michael@0: } michael@0: } michael@0: michael@0: # Subtract base from profile, if specified michael@0: if ($main::opt_base ne '') { michael@0: my $base = ReadProfile($main::prog, $main::opt_base); michael@0: $profile = SubtractProfile($profile, $base->{profile}); michael@0: $pcs = AddPcs($pcs, $base->{pcs}); michael@0: $symbol_map = MergeSymbols($symbol_map, $base->{symbols}); michael@0: } michael@0: michael@0: # Get total data in profile michael@0: my $total = TotalProfile($profile); michael@0: michael@0: # Collect symbols michael@0: my $symbols; michael@0: if ($main::use_symbolized_profile) { michael@0: $symbols = FetchSymbols($pcs, $symbol_map); michael@0: } elsif ($main::use_symbol_page) { michael@0: $symbols = FetchSymbols($pcs); michael@0: } else { michael@0: # TODO(csilvers): $libs uses the /proc/self/maps data from profile1, michael@0: # which may differ from the data from subsequent profiles, especially michael@0: # if they were run on different machines. Use appropriate libs for michael@0: # each pc somehow. michael@0: $symbols = ExtractSymbols($libs, $pcs); michael@0: } michael@0: michael@0: # Remove uniniteresting stack items michael@0: $profile = RemoveUninterestingFrames($symbols, $profile); michael@0: michael@0: # Focus? michael@0: if ($main::opt_focus ne '') { michael@0: $profile = FocusProfile($symbols, $profile, $main::opt_focus); michael@0: } michael@0: michael@0: # Ignore? michael@0: if ($main::opt_ignore ne '') { michael@0: $profile = IgnoreProfile($symbols, $profile, $main::opt_ignore); michael@0: } michael@0: michael@0: my $calls = ExtractCalls($symbols, $profile); michael@0: michael@0: # Reduce profiles to required output granularity, and also clean michael@0: # each stack trace so a given entry exists at most once. michael@0: my $reduced = ReduceProfile($symbols, $profile); michael@0: michael@0: # Get derived profiles michael@0: my $flat = FlatProfile($reduced); michael@0: my $cumulative = CumulativeProfile($reduced); michael@0: michael@0: # Print michael@0: if (!$main::opt_interactive) { michael@0: if ($main::opt_disasm) { michael@0: PrintDisassembly($libs, $flat, $cumulative, $main::opt_disasm); michael@0: } elsif ($main::opt_list) { michael@0: PrintListing($total, $libs, $flat, $cumulative, $main::opt_list, 0); michael@0: } elsif ($main::opt_text) { michael@0: # Make sure the output is empty when have nothing to report michael@0: # (only matters when --heapcheck is given but we must be michael@0: # compatible with old branches that did not pass --heapcheck always): michael@0: if ($total != 0) { michael@0: printf("Total: %s %s\n", Unparse($total), Units()); michael@0: } michael@0: PrintText($symbols, $flat, $cumulative, -1); michael@0: } elsif ($main::opt_raw) { michael@0: PrintSymbolizedProfile($symbols, $profile, $main::prog); michael@0: } elsif ($main::opt_callgrind) { michael@0: PrintCallgrind($calls); michael@0: } else { michael@0: if (PrintDot($main::prog, $symbols, $profile, $flat, $cumulative, $total)) { michael@0: if ($main::opt_gv) { michael@0: RunGV(TempName($main::next_tmpfile, "ps"), ""); michael@0: } elsif ($main::opt_evince) { michael@0: RunEvince(TempName($main::next_tmpfile, "pdf"), ""); michael@0: } elsif ($main::opt_web) { michael@0: my $tmp = TempName($main::next_tmpfile, "svg"); michael@0: RunWeb($tmp); michael@0: # The command we run might hand the file name off michael@0: # to an already running browser instance and then exit. michael@0: # Normally, we'd remove $tmp on exit (right now), michael@0: # but fork a child to remove $tmp a little later, so that the michael@0: # browser has time to load it first. michael@0: delete $main::tempnames{$tmp}; michael@0: if (fork() == 0) { michael@0: sleep 5; michael@0: unlink($tmp); michael@0: exit(0); michael@0: } michael@0: } michael@0: } else { michael@0: cleanup(); michael@0: exit(1); michael@0: } michael@0: } michael@0: } else { michael@0: InteractiveMode($profile, $symbols, $libs, $total); michael@0: } michael@0: michael@0: cleanup(); michael@0: exit(0); michael@0: } michael@0: michael@0: ##### Entry Point ##### michael@0: michael@0: Main(); michael@0: michael@0: # Temporary code to detect if we're running on a Goobuntu system. michael@0: # These systems don't have the right stuff installed for the special michael@0: # Readline libraries to work, so as a temporary workaround, we default michael@0: # to using the normal stdio code, rather than the fancier readline-based michael@0: # code michael@0: sub ReadlineMightFail { michael@0: if (-e '/lib/libtermcap.so.2') { michael@0: return 0; # libtermcap exists, so readline should be okay michael@0: } else { michael@0: return 1; michael@0: } michael@0: } michael@0: michael@0: sub RunGV { michael@0: my $fname = shift; michael@0: my $bg = shift; # "" or " &" if we should run in background michael@0: if (!system(ShellEscape(@GV, "--version") . " >$dev_null 2>&1")) { michael@0: # Options using double dash are supported by this gv version. michael@0: # Also, turn on noantialias to better handle bug in gv for michael@0: # postscript files with large dimensions. michael@0: # TODO: Maybe we should not pass the --noantialias flag michael@0: # if the gv version is known to work properly without the flag. michael@0: system(ShellEscape(@GV, "--scale=$main::opt_scale", "--noantialias", $fname) michael@0: . $bg); michael@0: } else { michael@0: # Old gv version - only supports options that use single dash. michael@0: print STDERR ShellEscape(@GV, "-scale", $main::opt_scale) . "\n"; michael@0: system(ShellEscape(@GV, "-scale", "$main::opt_scale", $fname) . $bg); michael@0: } michael@0: } michael@0: michael@0: sub RunEvince { michael@0: my $fname = shift; michael@0: my $bg = shift; # "" or " &" if we should run in background michael@0: system(ShellEscape(@EVINCE, $fname) . $bg); michael@0: } michael@0: michael@0: sub RunWeb { michael@0: my $fname = shift; michael@0: print STDERR "Loading web page file:///$fname\n"; michael@0: michael@0: if (`uname` =~ /Darwin/) { michael@0: # OS X: open will use standard preference for SVG files. michael@0: system("/usr/bin/open", $fname); michael@0: return; michael@0: } michael@0: michael@0: # Some kind of Unix; try generic symlinks, then specific browsers. michael@0: # (Stop once we find one.) michael@0: # Works best if the browser is already running. michael@0: my @alt = ( michael@0: "/etc/alternatives/gnome-www-browser", michael@0: "/etc/alternatives/x-www-browser", michael@0: "google-chrome", michael@0: "firefox", michael@0: ); michael@0: foreach my $b (@alt) { michael@0: if (system($b, $fname) == 0) { michael@0: return; michael@0: } michael@0: } michael@0: michael@0: print STDERR "Could not load web browser.\n"; michael@0: } michael@0: michael@0: sub RunKcachegrind { michael@0: my $fname = shift; michael@0: my $bg = shift; # "" or " &" if we should run in background michael@0: print STDERR "Starting '@KCACHEGRIND " . $fname . $bg . "'\n"; michael@0: system(ShellEscape(@KCACHEGRIND, $fname) . $bg); michael@0: } michael@0: michael@0: michael@0: ##### Interactive helper routines ##### michael@0: michael@0: sub InteractiveMode { michael@0: $| = 1; # Make output unbuffered for interactive mode michael@0: my ($orig_profile, $symbols, $libs, $total) = @_; michael@0: michael@0: print STDERR "Welcome to pprof! For help, type 'help'.\n"; michael@0: michael@0: # Use ReadLine if it's installed and input comes from a console. michael@0: if ( -t STDIN && michael@0: !ReadlineMightFail() && michael@0: defined(eval {require Term::ReadLine}) ) { michael@0: my $term = new Term::ReadLine 'pprof'; michael@0: while ( defined ($_ = $term->readline('(pprof) '))) { michael@0: $term->addhistory($_) if /\S/; michael@0: if (!InteractiveCommand($orig_profile, $symbols, $libs, $total, $_)) { michael@0: last; # exit when we get an interactive command to quit michael@0: } michael@0: } michael@0: } else { # don't have readline michael@0: while (1) { michael@0: print STDERR "(pprof) "; michael@0: $_ = ; michael@0: last if ! defined $_ ; michael@0: s/\r//g; # turn windows-looking lines into unix-looking lines michael@0: michael@0: # Save some flags that might be reset by InteractiveCommand() michael@0: my $save_opt_lines = $main::opt_lines; michael@0: michael@0: if (!InteractiveCommand($orig_profile, $symbols, $libs, $total, $_)) { michael@0: last; # exit when we get an interactive command to quit michael@0: } michael@0: michael@0: # Restore flags michael@0: $main::opt_lines = $save_opt_lines; michael@0: } michael@0: } michael@0: } michael@0: michael@0: # Takes two args: orig profile, and command to run. michael@0: # Returns 1 if we should keep going, or 0 if we were asked to quit michael@0: sub InteractiveCommand { michael@0: my($orig_profile, $symbols, $libs, $total, $command) = @_; michael@0: $_ = $command; # just to make future m//'s easier michael@0: if (!defined($_)) { michael@0: print STDERR "\n"; michael@0: return 0; michael@0: } michael@0: if (m/^\s*quit/) { michael@0: return 0; michael@0: } michael@0: if (m/^\s*help/) { michael@0: InteractiveHelpMessage(); michael@0: return 1; michael@0: } michael@0: # Clear all the mode options -- mode is controlled by "$command" michael@0: $main::opt_text = 0; michael@0: $main::opt_callgrind = 0; michael@0: $main::opt_disasm = 0; michael@0: $main::opt_list = 0; michael@0: $main::opt_gv = 0; michael@0: $main::opt_evince = 0; michael@0: $main::opt_cum = 0; michael@0: michael@0: if (m/^\s*(text|top)(\d*)\s*(.*)/) { michael@0: $main::opt_text = 1; michael@0: michael@0: my $line_limit = ($2 ne "") ? int($2) : 10; michael@0: michael@0: my $routine; michael@0: my $ignore; michael@0: ($routine, $ignore) = ParseInteractiveArgs($3); michael@0: michael@0: my $profile = ProcessProfile($total, $orig_profile, $symbols, "", $ignore); michael@0: my $reduced = ReduceProfile($symbols, $profile); michael@0: michael@0: # Get derived profiles michael@0: my $flat = FlatProfile($reduced); michael@0: my $cumulative = CumulativeProfile($reduced); michael@0: michael@0: PrintText($symbols, $flat, $cumulative, $line_limit); michael@0: return 1; michael@0: } michael@0: if (m/^\s*callgrind\s*([^ \n]*)/) { michael@0: $main::opt_callgrind = 1; michael@0: michael@0: # Get derived profiles michael@0: my $calls = ExtractCalls($symbols, $orig_profile); michael@0: my $filename = $1; michael@0: if ( $1 eq '' ) { michael@0: $filename = TempName($main::next_tmpfile, "callgrind"); michael@0: } michael@0: PrintCallgrind($calls, $filename); michael@0: if ( $1 eq '' ) { michael@0: RunKcachegrind($filename, " & "); michael@0: $main::next_tmpfile++; michael@0: } michael@0: michael@0: return 1; michael@0: } michael@0: if (m/^\s*(web)?list\s*(.+)/) { michael@0: my $html = (defined($1) && ($1 eq "web")); michael@0: $main::opt_list = 1; michael@0: michael@0: my $routine; michael@0: my $ignore; michael@0: ($routine, $ignore) = ParseInteractiveArgs($2); michael@0: michael@0: my $profile = ProcessProfile($total, $orig_profile, $symbols, "", $ignore); michael@0: my $reduced = ReduceProfile($symbols, $profile); michael@0: michael@0: # Get derived profiles michael@0: my $flat = FlatProfile($reduced); michael@0: my $cumulative = CumulativeProfile($reduced); michael@0: michael@0: PrintListing($total, $libs, $flat, $cumulative, $routine, $html); michael@0: return 1; michael@0: } michael@0: if (m/^\s*disasm\s*(.+)/) { michael@0: $main::opt_disasm = 1; michael@0: michael@0: my $routine; michael@0: my $ignore; michael@0: ($routine, $ignore) = ParseInteractiveArgs($1); michael@0: michael@0: # Process current profile to account for various settings michael@0: my $profile = ProcessProfile($total, $orig_profile, $symbols, "", $ignore); michael@0: my $reduced = ReduceProfile($symbols, $profile); michael@0: michael@0: # Get derived profiles michael@0: my $flat = FlatProfile($reduced); michael@0: my $cumulative = CumulativeProfile($reduced); michael@0: michael@0: PrintDisassembly($libs, $flat, $cumulative, $routine); michael@0: return 1; michael@0: } michael@0: if (m/^\s*(gv|web|evince)\s*(.*)/) { michael@0: $main::opt_gv = 0; michael@0: $main::opt_evince = 0; michael@0: $main::opt_web = 0; michael@0: if ($1 eq "gv") { michael@0: $main::opt_gv = 1; michael@0: } elsif ($1 eq "evince") { michael@0: $main::opt_evince = 1; michael@0: } elsif ($1 eq "web") { michael@0: $main::opt_web = 1; michael@0: } michael@0: michael@0: my $focus; michael@0: my $ignore; michael@0: ($focus, $ignore) = ParseInteractiveArgs($2); michael@0: michael@0: # Process current profile to account for various settings michael@0: my $profile = ProcessProfile($total, $orig_profile, $symbols, michael@0: $focus, $ignore); michael@0: my $reduced = ReduceProfile($symbols, $profile); michael@0: michael@0: # Get derived profiles michael@0: my $flat = FlatProfile($reduced); michael@0: my $cumulative = CumulativeProfile($reduced); michael@0: michael@0: if (PrintDot($main::prog, $symbols, $profile, $flat, $cumulative, $total)) { michael@0: if ($main::opt_gv) { michael@0: RunGV(TempName($main::next_tmpfile, "ps"), " &"); michael@0: } elsif ($main::opt_evince) { michael@0: RunEvince(TempName($main::next_tmpfile, "pdf"), " &"); michael@0: } elsif ($main::opt_web) { michael@0: RunWeb(TempName($main::next_tmpfile, "svg")); michael@0: } michael@0: $main::next_tmpfile++; michael@0: } michael@0: return 1; michael@0: } michael@0: if (m/^\s*$/) { michael@0: return 1; michael@0: } michael@0: print STDERR "Unknown command: try 'help'.\n"; michael@0: return 1; michael@0: } michael@0: michael@0: michael@0: sub ProcessProfile { michael@0: my $total_count = shift; michael@0: my $orig_profile = shift; michael@0: my $symbols = shift; michael@0: my $focus = shift; michael@0: my $ignore = shift; michael@0: michael@0: # Process current profile to account for various settings michael@0: my $profile = $orig_profile; michael@0: printf("Total: %s %s\n", Unparse($total_count), Units()); michael@0: if ($focus ne '') { michael@0: $profile = FocusProfile($symbols, $profile, $focus); michael@0: my $focus_count = TotalProfile($profile); michael@0: printf("After focusing on '%s': %s %s of %s (%0.1f%%)\n", michael@0: $focus, michael@0: Unparse($focus_count), Units(), michael@0: Unparse($total_count), ($focus_count*100.0) / $total_count); michael@0: } michael@0: if ($ignore ne '') { michael@0: $profile = IgnoreProfile($symbols, $profile, $ignore); michael@0: my $ignore_count = TotalProfile($profile); michael@0: printf("After ignoring '%s': %s %s of %s (%0.1f%%)\n", michael@0: $ignore, michael@0: Unparse($ignore_count), Units(), michael@0: Unparse($total_count), michael@0: ($ignore_count*100.0) / $total_count); michael@0: } michael@0: michael@0: return $profile; michael@0: } michael@0: michael@0: sub InteractiveHelpMessage { michael@0: print STDERR <{$k}; michael@0: my @addrs = split(/\n/, $k); michael@0: if ($#addrs >= 0) { michael@0: my $depth = $#addrs + 1; michael@0: # int(foo / 2**32) is the only reliable way to get rid of bottom michael@0: # 32 bits on both 32- and 64-bit systems. michael@0: print pack('L*', $count & 0xFFFFFFFF, int($count / 2**32)); michael@0: print pack('L*', $depth & 0xFFFFFFFF, int($depth / 2**32)); michael@0: michael@0: foreach my $full_addr (@addrs) { michael@0: my $addr = $full_addr; michael@0: $addr =~ s/0x0*//; # strip off leading 0x, zeroes michael@0: if (length($addr) > 16) { michael@0: print STDERR "Invalid address in profile: $full_addr\n"; michael@0: next; michael@0: } michael@0: my $low_addr = substr($addr, -8); # get last 8 hex chars michael@0: my $high_addr = substr($addr, -16, 8); # get up to 8 more hex chars michael@0: print pack('L*', hex('0x' . $low_addr), hex('0x' . $high_addr)); michael@0: } michael@0: } michael@0: } michael@0: } michael@0: michael@0: # Print symbols and profile data michael@0: sub PrintSymbolizedProfile { michael@0: my $symbols = shift; michael@0: my $profile = shift; michael@0: my $prog = shift; michael@0: michael@0: $SYMBOL_PAGE =~ m,[^/]+$,; # matches everything after the last slash michael@0: my $symbol_marker = $&; michael@0: michael@0: print '--- ', $symbol_marker, "\n"; michael@0: if (defined($prog)) { michael@0: print 'binary=', $prog, "\n"; michael@0: } michael@0: while (my ($pc, $name) = each(%{$symbols})) { michael@0: my $sep = ' '; michael@0: print '0x', $pc; michael@0: # We have a list of function names, which include the inlined michael@0: # calls. They are separated (and terminated) by --, which is michael@0: # illegal in function names. michael@0: for (my $j = 2; $j <= $#{$name}; $j += 3) { michael@0: print $sep, $name->[$j]; michael@0: $sep = '--'; michael@0: } michael@0: print "\n"; michael@0: } michael@0: print '---', "\n"; michael@0: michael@0: $PROFILE_PAGE =~ m,[^/]+$,; # matches everything after the last slash michael@0: my $profile_marker = $&; michael@0: print '--- ', $profile_marker, "\n"; michael@0: if (defined($main::collected_profile)) { michael@0: # if used with remote fetch, simply dump the collected profile to output. michael@0: open(SRC, "<$main::collected_profile"); michael@0: while () { michael@0: print $_; michael@0: } michael@0: close(SRC); michael@0: } else { michael@0: # dump a cpu-format profile to standard out michael@0: PrintProfileData($profile); michael@0: } michael@0: } michael@0: michael@0: # Print text output michael@0: sub PrintText { michael@0: my $symbols = shift; michael@0: my $flat = shift; michael@0: my $cumulative = shift; michael@0: my $line_limit = shift; michael@0: michael@0: my $total = TotalProfile($flat); michael@0: michael@0: # Which profile to sort by? michael@0: my $s = $main::opt_cum ? $cumulative : $flat; michael@0: michael@0: my $running_sum = 0; michael@0: my $lines = 0; michael@0: foreach my $k (sort { GetEntry($s, $b) <=> GetEntry($s, $a) || $a cmp $b } michael@0: keys(%{$cumulative})) { michael@0: my $f = GetEntry($flat, $k); michael@0: my $c = GetEntry($cumulative, $k); michael@0: $running_sum += $f; michael@0: michael@0: my $sym = $k; michael@0: if (exists($symbols->{$k})) { michael@0: $sym = $symbols->{$k}->[0] . " " . $symbols->{$k}->[1]; michael@0: if ($main::opt_addresses) { michael@0: $sym = $k . " " . $sym; michael@0: } michael@0: } michael@0: michael@0: if ($f != 0 || $c != 0) { michael@0: printf("%8s %6s %6s %8s %6s %s\n", michael@0: Unparse($f), michael@0: Percent($f, $total), michael@0: Percent($running_sum, $total), michael@0: Unparse($c), michael@0: Percent($c, $total), michael@0: $sym); michael@0: } michael@0: $lines++; michael@0: last if ($line_limit >= 0 && $lines >= $line_limit); michael@0: } michael@0: } michael@0: michael@0: # Callgrind format has a compression for repeated function and file michael@0: # names. You show the name the first time, and just use its number michael@0: # subsequently. This can cut down the file to about a third or a michael@0: # quarter of its uncompressed size. $key and $val are the key/value michael@0: # pair that would normally be printed by callgrind; $map is a map from michael@0: # value to number. michael@0: sub CompressedCGName { michael@0: my($key, $val, $map) = @_; michael@0: my $idx = $map->{$val}; michael@0: # For very short keys, providing an index hurts rather than helps. michael@0: if (length($val) <= 3) { michael@0: return "$key=$val\n"; michael@0: } elsif (defined($idx)) { michael@0: return "$key=($idx)\n"; michael@0: } else { michael@0: # scalar(keys $map) gives the number of items in the map. michael@0: $idx = scalar(keys(%{$map})) + 1; michael@0: $map->{$val} = $idx; michael@0: return "$key=($idx) $val\n"; michael@0: } michael@0: } michael@0: michael@0: # Print the call graph in a way that's suiteable for callgrind. michael@0: sub PrintCallgrind { michael@0: my $calls = shift; michael@0: my $filename; michael@0: my %filename_to_index_map; michael@0: my %fnname_to_index_map; michael@0: michael@0: if ($main::opt_interactive) { michael@0: $filename = shift; michael@0: print STDERR "Writing callgrind file to '$filename'.\n" michael@0: } else { michael@0: $filename = "&STDOUT"; michael@0: } michael@0: open(CG, ">$filename"); michael@0: printf CG ("events: Hits\n\n"); michael@0: foreach my $call ( map { $_->[0] } michael@0: sort { $a->[1] cmp $b ->[1] || michael@0: $a->[2] <=> $b->[2] } michael@0: map { /([^:]+):(\d+):([^ ]+)( -> ([^:]+):(\d+):(.+))?/; michael@0: [$_, $1, $2] } michael@0: keys %$calls ) { michael@0: my $count = int($calls->{$call}); michael@0: $call =~ /([^:]+):(\d+):([^ ]+)( -> ([^:]+):(\d+):(.+))?/; michael@0: my ( $caller_file, $caller_line, $caller_function, michael@0: $callee_file, $callee_line, $callee_function ) = michael@0: ( $1, $2, $3, $5, $6, $7 ); michael@0: michael@0: # TODO(csilvers): for better compression, collect all the michael@0: # caller/callee_files and functions first, before printing michael@0: # anything, and only compress those referenced more than once. michael@0: printf CG CompressedCGName("fl", $caller_file, \%filename_to_index_map); michael@0: printf CG CompressedCGName("fn", $caller_function, \%fnname_to_index_map); michael@0: if (defined $6) { michael@0: printf CG CompressedCGName("cfl", $callee_file, \%filename_to_index_map); michael@0: printf CG CompressedCGName("cfn", $callee_function, \%fnname_to_index_map); michael@0: printf CG ("calls=$count $callee_line\n"); michael@0: } michael@0: printf CG ("$caller_line $count\n\n"); michael@0: } michael@0: } michael@0: michael@0: # Print disassembly for all all routines that match $main::opt_disasm michael@0: sub PrintDisassembly { michael@0: my $libs = shift; michael@0: my $flat = shift; michael@0: my $cumulative = shift; michael@0: my $disasm_opts = shift; michael@0: michael@0: my $total = TotalProfile($flat); michael@0: michael@0: foreach my $lib (@{$libs}) { michael@0: my $symbol_table = GetProcedureBoundaries($lib->[0], $disasm_opts); michael@0: my $offset = AddressSub($lib->[1], $lib->[3]); michael@0: foreach my $routine (sort ByName keys(%{$symbol_table})) { michael@0: my $start_addr = $symbol_table->{$routine}->[0]; michael@0: my $end_addr = $symbol_table->{$routine}->[1]; michael@0: # See if there are any samples in this routine michael@0: my $length = hex(AddressSub($end_addr, $start_addr)); michael@0: my $addr = AddressAdd($start_addr, $offset); michael@0: for (my $i = 0; $i < $length; $i++) { michael@0: if (defined($cumulative->{$addr})) { michael@0: PrintDisassembledFunction($lib->[0], $offset, michael@0: $routine, $flat, $cumulative, michael@0: $start_addr, $end_addr, $total); michael@0: last; michael@0: } michael@0: $addr = AddressInc($addr); michael@0: } michael@0: } michael@0: } michael@0: } michael@0: michael@0: # Return reference to array of tuples of the form: michael@0: # [start_address, filename, linenumber, instruction, limit_address] michael@0: # E.g., michael@0: # ["0x806c43d", "/foo/bar.cc", 131, "ret", "0x806c440"] michael@0: sub Disassemble { michael@0: my $prog = shift; michael@0: my $offset = shift; michael@0: my $start_addr = shift; michael@0: my $end_addr = shift; michael@0: michael@0: my $objdump = $obj_tool_map{"objdump"}; michael@0: my $cmd = ShellEscape($objdump, "-C", "-d", "-l", "--no-show-raw-insn", michael@0: "--start-address=0x$start_addr", michael@0: "--stop-address=0x$end_addr", $prog); michael@0: open(OBJDUMP, "$cmd |") || error("$cmd: $!\n"); michael@0: my @result = (); michael@0: my $filename = ""; michael@0: my $linenumber = -1; michael@0: my $last = ["", "", "", ""]; michael@0: while () { michael@0: s/\r//g; # turn windows-looking lines into unix-looking lines michael@0: chop; michael@0: if (m|\s*([^:\s]+):(\d+)\s*$|) { michael@0: # Location line of the form: michael@0: # : michael@0: $filename = $1; michael@0: $linenumber = $2; michael@0: } elsif (m/^ +([0-9a-f]+):\s*(.*)/) { michael@0: # Disassembly line -- zero-extend address to full length michael@0: my $addr = HexExtend($1); michael@0: my $k = AddressAdd($addr, $offset); michael@0: $last->[4] = $k; # Store ending address for previous instruction michael@0: $last = [$k, $filename, $linenumber, $2, $end_addr]; michael@0: push(@result, $last); michael@0: } michael@0: } michael@0: close(OBJDUMP); michael@0: return @result; michael@0: } michael@0: michael@0: # The input file should contain lines of the form /proc/maps-like michael@0: # output (same format as expected from the profiles) or that looks michael@0: # like hex addresses (like "0xDEADBEEF"). We will parse all michael@0: # /proc/maps output, and for all the hex addresses, we will output michael@0: # "short" symbol names, one per line, in the same order as the input. michael@0: sub PrintSymbols { michael@0: my $maps_and_symbols_file = shift; michael@0: michael@0: # ParseLibraries expects pcs to be in a set. Fine by us... michael@0: my @pclist = (); # pcs in sorted order michael@0: my $pcs = {}; michael@0: my $map = ""; michael@0: foreach my $line (<$maps_and_symbols_file>) { michael@0: $line =~ s/\r//g; # turn windows-looking lines into unix-looking lines michael@0: if ($line =~ /\b(0x[0-9a-f]+)\b/i) { michael@0: push(@pclist, HexExtend($1)); michael@0: $pcs->{$pclist[-1]} = 1; michael@0: } else { michael@0: $map .= $line; michael@0: } michael@0: } michael@0: michael@0: my $libs = ParseLibraries($main::prog, $map, $pcs); michael@0: my $symbols = ExtractSymbols($libs, $pcs); michael@0: michael@0: foreach my $pc (@pclist) { michael@0: # ->[0] is the shortname, ->[2] is the full name michael@0: print(($symbols->{$pc}->[0] || "??") . "\n"); michael@0: } michael@0: } michael@0: michael@0: michael@0: # For sorting functions by name michael@0: sub ByName { michael@0: return ShortFunctionName($a) cmp ShortFunctionName($b); michael@0: } michael@0: michael@0: # Print source-listing for all all routines that match $list_opts michael@0: sub PrintListing { michael@0: my $total = shift; michael@0: my $libs = shift; michael@0: my $flat = shift; michael@0: my $cumulative = shift; michael@0: my $list_opts = shift; michael@0: my $html = shift; michael@0: michael@0: my $output = \*STDOUT; michael@0: my $fname = ""; michael@0: michael@0: if ($html) { michael@0: # Arrange to write the output to a temporary file michael@0: $fname = TempName($main::next_tmpfile, "html"); michael@0: $main::next_tmpfile++; michael@0: if (!open(TEMP, ">$fname")) { michael@0: print STDERR "$fname: $!\n"; michael@0: return; michael@0: } michael@0: $output = \*TEMP; michael@0: print $output HtmlListingHeader(); michael@0: printf $output ("

%s
Total: %s %s

\n", michael@0: $main::prog, Unparse($total), Units()); michael@0: } michael@0: michael@0: my $listed = 0; michael@0: foreach my $lib (@{$libs}) { michael@0: my $symbol_table = GetProcedureBoundaries($lib->[0], $list_opts); michael@0: my $offset = AddressSub($lib->[1], $lib->[3]); michael@0: foreach my $routine (sort ByName keys(%{$symbol_table})) { michael@0: # Print if there are any samples in this routine michael@0: my $start_addr = $symbol_table->{$routine}->[0]; michael@0: my $end_addr = $symbol_table->{$routine}->[1]; michael@0: my $length = hex(AddressSub($end_addr, $start_addr)); michael@0: my $addr = AddressAdd($start_addr, $offset); michael@0: for (my $i = 0; $i < $length; $i++) { michael@0: if (defined($cumulative->{$addr})) { michael@0: $listed += PrintSource( michael@0: $lib->[0], $offset, michael@0: $routine, $flat, $cumulative, michael@0: $start_addr, $end_addr, michael@0: $html, michael@0: $output); michael@0: last; michael@0: } michael@0: $addr = AddressInc($addr); michael@0: } michael@0: } michael@0: } michael@0: michael@0: if ($html) { michael@0: if ($listed > 0) { michael@0: print $output HtmlListingFooter(); michael@0: close($output); michael@0: RunWeb($fname); michael@0: } else { michael@0: close($output); michael@0: unlink($fname); michael@0: } michael@0: } michael@0: } michael@0: michael@0: sub HtmlListingHeader { michael@0: return <<'EOF'; michael@0: michael@0: michael@0: michael@0: Pprof listing michael@0: michael@0: michael@0: michael@0: michael@0: EOF michael@0: } michael@0: michael@0: sub HtmlListingFooter { michael@0: return <<'EOF'; michael@0: michael@0: michael@0: EOF michael@0: } michael@0: michael@0: sub HtmlEscape { michael@0: my $text = shift; michael@0: $text =~ s/&/&/g; michael@0: $text =~ s//>/g; michael@0: return $text; michael@0: } michael@0: michael@0: # Returns the indentation of the line, if it has any non-whitespace michael@0: # characters. Otherwise, returns -1. michael@0: sub Indentation { michael@0: my $line = shift; michael@0: if (m/^(\s*)\S/) { michael@0: return length($1); michael@0: } else { michael@0: return -1; michael@0: } michael@0: } michael@0: michael@0: # If the symbol table contains inlining info, Disassemble() may tag an michael@0: # instruction with a location inside an inlined function. But for michael@0: # source listings, we prefer to use the location in the function we michael@0: # are listing. So use MapToSymbols() to fetch full location michael@0: # information for each instruction and then pick out the first michael@0: # location from a location list (location list contains callers before michael@0: # callees in case of inlining). michael@0: # michael@0: # After this routine has run, each entry in $instructions contains: michael@0: # [0] start address michael@0: # [1] filename for function we are listing michael@0: # [2] line number for function we are listing michael@0: # [3] disassembly michael@0: # [4] limit address michael@0: # [5] most specific filename (may be different from [1] due to inlining) michael@0: # [6] most specific line number (may be different from [2] due to inlining) michael@0: sub GetTopLevelLineNumbers { michael@0: my ($lib, $offset, $instructions) = @_; michael@0: my $pcs = []; michael@0: for (my $i = 0; $i <= $#{$instructions}; $i++) { michael@0: push(@{$pcs}, $instructions->[$i]->[0]); michael@0: } michael@0: my $symbols = {}; michael@0: MapToSymbols($lib, $offset, $pcs, $symbols); michael@0: for (my $i = 0; $i <= $#{$instructions}; $i++) { michael@0: my $e = $instructions->[$i]; michael@0: push(@{$e}, $e->[1]); michael@0: push(@{$e}, $e->[2]); michael@0: my $addr = $e->[0]; michael@0: my $sym = $symbols->{$addr}; michael@0: if (defined($sym)) { michael@0: if ($#{$sym} >= 2 && $sym->[1] =~ m/^(.*):(\d+)$/) { michael@0: $e->[1] = $1; # File name michael@0: $e->[2] = $2; # Line number michael@0: } michael@0: } michael@0: } michael@0: } michael@0: michael@0: # Print source-listing for one routine michael@0: sub PrintSource { michael@0: my $prog = shift; michael@0: my $offset = shift; michael@0: my $routine = shift; michael@0: my $flat = shift; michael@0: my $cumulative = shift; michael@0: my $start_addr = shift; michael@0: my $end_addr = shift; michael@0: my $html = shift; michael@0: my $output = shift; michael@0: michael@0: # Disassemble all instructions (just to get line numbers) michael@0: my @instructions = Disassemble($prog, $offset, $start_addr, $end_addr); michael@0: GetTopLevelLineNumbers($prog, $offset, \@instructions); michael@0: michael@0: # Hack 1: assume that the first source file encountered in the michael@0: # disassembly contains the routine michael@0: my $filename = undef; michael@0: for (my $i = 0; $i <= $#instructions; $i++) { michael@0: if ($instructions[$i]->[2] >= 0) { michael@0: $filename = $instructions[$i]->[1]; michael@0: last; michael@0: } michael@0: } michael@0: if (!defined($filename)) { michael@0: print STDERR "no filename found in $routine\n"; michael@0: return 0; michael@0: } michael@0: michael@0: # Hack 2: assume that the largest line number from $filename is the michael@0: # end of the procedure. This is typically safe since if P1 contains michael@0: # an inlined call to P2, then P2 usually occurs earlier in the michael@0: # source file. If this does not work, we might have to compute a michael@0: # density profile or just print all regions we find. michael@0: my $lastline = 0; michael@0: for (my $i = 0; $i <= $#instructions; $i++) { michael@0: my $f = $instructions[$i]->[1]; michael@0: my $l = $instructions[$i]->[2]; michael@0: if (($f eq $filename) && ($l > $lastline)) { michael@0: $lastline = $l; michael@0: } michael@0: } michael@0: michael@0: # Hack 3: assume the first source location from "filename" is the start of michael@0: # the source code. michael@0: my $firstline = 1; michael@0: for (my $i = 0; $i <= $#instructions; $i++) { michael@0: if ($instructions[$i]->[1] eq $filename) { michael@0: $firstline = $instructions[$i]->[2]; michael@0: last; michael@0: } michael@0: } michael@0: michael@0: # Hack 4: Extend last line forward until its indentation is less than michael@0: # the indentation we saw on $firstline michael@0: my $oldlastline = $lastline; michael@0: { michael@0: if (!open(FILE, "<$filename")) { michael@0: print STDERR "$filename: $!\n"; michael@0: return 0; michael@0: } michael@0: my $l = 0; michael@0: my $first_indentation = -1; michael@0: while () { michael@0: s/\r//g; # turn windows-looking lines into unix-looking lines michael@0: $l++; michael@0: my $indent = Indentation($_); michael@0: if ($l >= $firstline) { michael@0: if ($first_indentation < 0 && $indent >= 0) { michael@0: $first_indentation = $indent; michael@0: last if ($first_indentation == 0); michael@0: } michael@0: } michael@0: if ($l >= $lastline && $indent >= 0) { michael@0: if ($indent >= $first_indentation) { michael@0: $lastline = $l+1; michael@0: } else { michael@0: last; michael@0: } michael@0: } michael@0: } michael@0: close(FILE); michael@0: } michael@0: michael@0: # Assign all samples to the range $firstline,$lastline, michael@0: # Hack 4: If an instruction does not occur in the range, its samples michael@0: # are moved to the next instruction that occurs in the range. michael@0: my $samples1 = {}; # Map from line number to flat count michael@0: my $samples2 = {}; # Map from line number to cumulative count michael@0: my $running1 = 0; # Unassigned flat counts michael@0: my $running2 = 0; # Unassigned cumulative counts michael@0: my $total1 = 0; # Total flat counts michael@0: my $total2 = 0; # Total cumulative counts michael@0: my %disasm = (); # Map from line number to disassembly michael@0: my $running_disasm = ""; # Unassigned disassembly michael@0: my $skip_marker = "---\n"; michael@0: if ($html) { michael@0: $skip_marker = ""; michael@0: for (my $l = $firstline; $l <= $lastline; $l++) { michael@0: $disasm{$l} = ""; michael@0: } michael@0: } michael@0: my $last_dis_filename = ''; michael@0: my $last_dis_linenum = -1; michael@0: my $last_touched_line = -1; # To detect gaps in disassembly for a line michael@0: foreach my $e (@instructions) { michael@0: # Add up counts for all address that fall inside this instruction michael@0: my $c1 = 0; michael@0: my $c2 = 0; michael@0: for (my $a = $e->[0]; $a lt $e->[4]; $a = AddressInc($a)) { michael@0: $c1 += GetEntry($flat, $a); michael@0: $c2 += GetEntry($cumulative, $a); michael@0: } michael@0: michael@0: if ($html) { michael@0: my $dis = sprintf(" %6s %6s \t\t%8s: %s ", michael@0: HtmlPrintNumber($c1), michael@0: HtmlPrintNumber($c2), michael@0: UnparseAddress($offset, $e->[0]), michael@0: CleanDisassembly($e->[3])); michael@0: michael@0: # Append the most specific source line associated with this instruction michael@0: if (length($dis) < 80) { $dis .= (' ' x (80 - length($dis))) }; michael@0: $dis = HtmlEscape($dis); michael@0: my $f = $e->[5]; michael@0: my $l = $e->[6]; michael@0: if ($f ne $last_dis_filename) { michael@0: $dis .= sprintf("%s:%d", michael@0: HtmlEscape(CleanFileName($f)), $l); michael@0: } elsif ($l ne $last_dis_linenum) { michael@0: # De-emphasize the unchanged file name portion michael@0: $dis .= sprintf("%s" . michael@0: ":%d", michael@0: HtmlEscape(CleanFileName($f)), $l); michael@0: } else { michael@0: # De-emphasize the entire location michael@0: $dis .= sprintf("%s:%d", michael@0: HtmlEscape(CleanFileName($f)), $l); michael@0: } michael@0: $last_dis_filename = $f; michael@0: $last_dis_linenum = $l; michael@0: $running_disasm .= $dis; michael@0: $running_disasm .= "\n"; michael@0: } michael@0: michael@0: $running1 += $c1; michael@0: $running2 += $c2; michael@0: $total1 += $c1; michael@0: $total2 += $c2; michael@0: my $file = $e->[1]; michael@0: my $line = $e->[2]; michael@0: if (($file eq $filename) && michael@0: ($line >= $firstline) && michael@0: ($line <= $lastline)) { michael@0: # Assign all accumulated samples to this line michael@0: AddEntry($samples1, $line, $running1); michael@0: AddEntry($samples2, $line, $running2); michael@0: $running1 = 0; michael@0: $running2 = 0; michael@0: if ($html) { michael@0: if ($line != $last_touched_line && $disasm{$line} ne '') { michael@0: $disasm{$line} .= "\n"; michael@0: } michael@0: $disasm{$line} .= $running_disasm; michael@0: $running_disasm = ''; michael@0: $last_touched_line = $line; michael@0: } michael@0: } michael@0: } michael@0: michael@0: # Assign any leftover samples to $lastline michael@0: AddEntry($samples1, $lastline, $running1); michael@0: AddEntry($samples2, $lastline, $running2); michael@0: if ($html) { michael@0: if ($lastline != $last_touched_line && $disasm{$lastline} ne '') { michael@0: $disasm{$lastline} .= "\n"; michael@0: } michael@0: $disasm{$lastline} .= $running_disasm; michael@0: } michael@0: michael@0: if ($html) { michael@0: printf $output ( michael@0: "

%s

%s\n

\n" .
michael@0:       "Total:%6s %6s (flat / cumulative %s)\n",
michael@0:       HtmlEscape(ShortFunctionName($routine)),
michael@0:       HtmlEscape(CleanFileName($filename)),
michael@0:       Unparse($total1),
michael@0:       Unparse($total2),
michael@0:       Units());
michael@0:   } else {
michael@0:     printf $output (
michael@0:       "ROUTINE ====================== %s in %s\n" .
michael@0:       "%6s %6s Total %s (flat / cumulative)\n",
michael@0:       ShortFunctionName($routine),
michael@0:       CleanFileName($filename),
michael@0:       Unparse($total1),
michael@0:       Unparse($total2),
michael@0:       Units());
michael@0:   }
michael@0:   if (!open(FILE, "<$filename")) {
michael@0:     print STDERR "$filename: $!\n";
michael@0:     return 0;
michael@0:   }
michael@0:   my $l = 0;
michael@0:   while () {
michael@0:     s/\r//g;         # turn windows-looking lines into unix-looking lines
michael@0:     $l++;
michael@0:     if ($l >= $firstline - 5 &&
michael@0:         (($l <= $oldlastline + 5) || ($l <= $lastline))) {
michael@0:       chop;
michael@0:       my $text = $_;
michael@0:       if ($l == $firstline) { print $output $skip_marker; }
michael@0:       my $n1 = GetEntry($samples1, $l);
michael@0:       my $n2 = GetEntry($samples2, $l);
michael@0:       if ($html) {
michael@0:         # Emit a span that has one of the following classes:
michael@0:         #    livesrc -- has samples
michael@0:         #    deadsrc -- has disassembly, but with no samples
michael@0:         #    nop     -- has no matching disasembly
michael@0:         # Also emit an optional span containing disassembly.
michael@0:         my $dis = $disasm{$l};
michael@0:         my $asm = "";
michael@0:         if (defined($dis) && $dis ne '') {
michael@0:           $asm = "" . $dis . "";
michael@0:         }
michael@0:         my $source_class = (($n1 + $n2 > 0) 
michael@0:                             ? "livesrc" 
michael@0:                             : (($asm ne "") ? "deadsrc" : "nop"));
michael@0:         printf $output (
michael@0:           "%5d " .
michael@0:           "%6s %6s %s%s\n",
michael@0:           $l, $source_class,
michael@0:           HtmlPrintNumber($n1),
michael@0:           HtmlPrintNumber($n2),
michael@0:           HtmlEscape($text),
michael@0:           $asm);
michael@0:       } else {
michael@0:         printf $output(
michael@0:           "%6s %6s %4d: %s\n",
michael@0:           UnparseAlt($n1),
michael@0:           UnparseAlt($n2),
michael@0:           $l,
michael@0:           $text);
michael@0:       }
michael@0:       if ($l == $lastline)  { print $output $skip_marker; }
michael@0:     };
michael@0:   }
michael@0:   close(FILE);
michael@0:   if ($html) {
michael@0:     print $output "

\n"; michael@0: } michael@0: return 1; michael@0: } michael@0: michael@0: # Return the source line for the specified file/linenumber. michael@0: # Returns undef if not found. michael@0: sub SourceLine { michael@0: my $file = shift; michael@0: my $line = shift; michael@0: michael@0: # Look in cache michael@0: if (!defined($main::source_cache{$file})) { michael@0: if (100 < scalar keys(%main::source_cache)) { michael@0: # Clear the cache when it gets too big michael@0: $main::source_cache = (); michael@0: } michael@0: michael@0: # Read all lines from the file michael@0: if (!open(FILE, "<$file")) { michael@0: print STDERR "$file: $!\n"; michael@0: $main::source_cache{$file} = []; # Cache the negative result michael@0: return undef; michael@0: } michael@0: my $lines = []; michael@0: push(@{$lines}, ""); # So we can use 1-based line numbers as indices michael@0: while () { michael@0: push(@{$lines}, $_); michael@0: } michael@0: close(FILE); michael@0: michael@0: # Save the lines in the cache michael@0: $main::source_cache{$file} = $lines; michael@0: } michael@0: michael@0: my $lines = $main::source_cache{$file}; michael@0: if (($line < 0) || ($line > $#{$lines})) { michael@0: return undef; michael@0: } else { michael@0: return $lines->[$line]; michael@0: } michael@0: } michael@0: michael@0: # Print disassembly for one routine with interspersed source if available michael@0: sub PrintDisassembledFunction { michael@0: my $prog = shift; michael@0: my $offset = shift; michael@0: my $routine = shift; michael@0: my $flat = shift; michael@0: my $cumulative = shift; michael@0: my $start_addr = shift; michael@0: my $end_addr = shift; michael@0: my $total = shift; michael@0: michael@0: # Disassemble all instructions michael@0: my @instructions = Disassemble($prog, $offset, $start_addr, $end_addr); michael@0: michael@0: # Make array of counts per instruction michael@0: my @flat_count = (); michael@0: my @cum_count = (); michael@0: my $flat_total = 0; michael@0: my $cum_total = 0; michael@0: foreach my $e (@instructions) { michael@0: # Add up counts for all address that fall inside this instruction michael@0: my $c1 = 0; michael@0: my $c2 = 0; michael@0: for (my $a = $e->[0]; $a lt $e->[4]; $a = AddressInc($a)) { michael@0: $c1 += GetEntry($flat, $a); michael@0: $c2 += GetEntry($cumulative, $a); michael@0: } michael@0: push(@flat_count, $c1); michael@0: push(@cum_count, $c2); michael@0: $flat_total += $c1; michael@0: $cum_total += $c2; michael@0: } michael@0: michael@0: # Print header with total counts michael@0: printf("ROUTINE ====================== %s\n" . michael@0: "%6s %6s %s (flat, cumulative) %.1f%% of total\n", michael@0: ShortFunctionName($routine), michael@0: Unparse($flat_total), michael@0: Unparse($cum_total), michael@0: Units(), michael@0: ($cum_total * 100.0) / $total); michael@0: michael@0: # Process instructions in order michael@0: my $current_file = ""; michael@0: for (my $i = 0; $i <= $#instructions; ) { michael@0: my $e = $instructions[$i]; michael@0: michael@0: # Print the new file name whenever we switch files michael@0: if ($e->[1] ne $current_file) { michael@0: $current_file = $e->[1]; michael@0: my $fname = $current_file; michael@0: $fname =~ s|^\./||; # Trim leading "./" michael@0: michael@0: # Shorten long file names michael@0: if (length($fname) >= 58) { michael@0: $fname = "..." . substr($fname, -55); michael@0: } michael@0: printf("-------------------- %s\n", $fname); michael@0: } michael@0: michael@0: # TODO: Compute range of lines to print together to deal with michael@0: # small reorderings. michael@0: my $first_line = $e->[2]; michael@0: my $last_line = $first_line; michael@0: my %flat_sum = (); michael@0: my %cum_sum = (); michael@0: for (my $l = $first_line; $l <= $last_line; $l++) { michael@0: $flat_sum{$l} = 0; michael@0: $cum_sum{$l} = 0; michael@0: } michael@0: michael@0: # Find run of instructions for this range of source lines michael@0: my $first_inst = $i; michael@0: while (($i <= $#instructions) && michael@0: ($instructions[$i]->[2] >= $first_line) && michael@0: ($instructions[$i]->[2] <= $last_line)) { michael@0: $e = $instructions[$i]; michael@0: $flat_sum{$e->[2]} += $flat_count[$i]; michael@0: $cum_sum{$e->[2]} += $cum_count[$i]; michael@0: $i++; michael@0: } michael@0: my $last_inst = $i - 1; michael@0: michael@0: # Print source lines michael@0: for (my $l = $first_line; $l <= $last_line; $l++) { michael@0: my $line = SourceLine($current_file, $l); michael@0: if (!defined($line)) { michael@0: $line = "?\n"; michael@0: next; michael@0: } else { michael@0: $line =~ s/^\s+//; michael@0: } michael@0: printf("%6s %6s %5d: %s", michael@0: UnparseAlt($flat_sum{$l}), michael@0: UnparseAlt($cum_sum{$l}), michael@0: $l, michael@0: $line); michael@0: } michael@0: michael@0: # Print disassembly michael@0: for (my $x = $first_inst; $x <= $last_inst; $x++) { michael@0: my $e = $instructions[$x]; michael@0: printf("%6s %6s %8s: %6s\n", michael@0: UnparseAlt($flat_count[$x]), michael@0: UnparseAlt($cum_count[$x]), michael@0: UnparseAddress($offset, $e->[0]), michael@0: CleanDisassembly($e->[3])); michael@0: } michael@0: } michael@0: } michael@0: michael@0: # Print DOT graph michael@0: sub PrintDot { michael@0: my $prog = shift; michael@0: my $symbols = shift; michael@0: my $raw = shift; michael@0: my $flat = shift; michael@0: my $cumulative = shift; michael@0: my $overall_total = shift; michael@0: michael@0: # Get total michael@0: my $local_total = TotalProfile($flat); michael@0: my $nodelimit = int($main::opt_nodefraction * $local_total); michael@0: my $edgelimit = int($main::opt_edgefraction * $local_total); michael@0: my $nodecount = $main::opt_nodecount; michael@0: michael@0: # Find nodes to include michael@0: my @list = (sort { abs(GetEntry($cumulative, $b)) <=> michael@0: abs(GetEntry($cumulative, $a)) michael@0: || $a cmp $b } michael@0: keys(%{$cumulative})); michael@0: my $last = $nodecount - 1; michael@0: if ($last > $#list) { michael@0: $last = $#list; michael@0: } michael@0: while (($last >= 0) && michael@0: (abs(GetEntry($cumulative, $list[$last])) <= $nodelimit)) { michael@0: $last--; michael@0: } michael@0: if ($last < 0) { michael@0: print STDERR "No nodes to print\n"; michael@0: return 0; michael@0: } michael@0: michael@0: if ($nodelimit > 0 || $edgelimit > 0) { michael@0: printf STDERR ("Dropping nodes with <= %s %s; edges with <= %s abs(%s)\n", michael@0: Unparse($nodelimit), Units(), michael@0: Unparse($edgelimit), Units()); michael@0: } michael@0: michael@0: # Open DOT output file michael@0: my $output; michael@0: my $escaped_dot = ShellEscape(@DOT); michael@0: my $escaped_ps2pdf = ShellEscape(@PS2PDF); michael@0: if ($main::opt_gv) { michael@0: my $escaped_outfile = ShellEscape(TempName($main::next_tmpfile, "ps")); michael@0: $output = "| $escaped_dot -Tps2 >$escaped_outfile"; michael@0: } elsif ($main::opt_evince) { michael@0: my $escaped_outfile = ShellEscape(TempName($main::next_tmpfile, "pdf")); michael@0: $output = "| $escaped_dot -Tps2 | $escaped_ps2pdf - $escaped_outfile"; michael@0: } elsif ($main::opt_ps) { michael@0: $output = "| $escaped_dot -Tps2"; michael@0: } elsif ($main::opt_pdf) { michael@0: $output = "| $escaped_dot -Tps2 | $escaped_ps2pdf - -"; michael@0: } elsif ($main::opt_web || $main::opt_svg) { michael@0: # We need to post-process the SVG, so write to a temporary file always. michael@0: my $escaped_outfile = ShellEscape(TempName($main::next_tmpfile, "svg")); michael@0: $output = "| $escaped_dot -Tsvg >$escaped_outfile"; michael@0: } elsif ($main::opt_gif) { michael@0: $output = "| $escaped_dot -Tgif"; michael@0: } else { michael@0: $output = ">&STDOUT"; michael@0: } michael@0: open(DOT, $output) || error("$output: $!\n"); michael@0: michael@0: # Title michael@0: printf DOT ("digraph \"%s; %s %s\" {\n", michael@0: $prog, michael@0: Unparse($overall_total), michael@0: Units()); michael@0: if ($main::opt_pdf) { michael@0: # The output is more printable if we set the page size for dot. michael@0: printf DOT ("size=\"8,11\"\n"); michael@0: } michael@0: printf DOT ("node [width=0.375,height=0.25];\n"); michael@0: michael@0: # Print legend michael@0: printf DOT ("Legend [shape=box,fontsize=24,shape=plaintext," . michael@0: "label=\"%s\\l%s\\l%s\\l%s\\l%s\\l\"];\n", michael@0: $prog, michael@0: sprintf("Total %s: %s", Units(), Unparse($overall_total)), michael@0: sprintf("Focusing on: %s", Unparse($local_total)), michael@0: sprintf("Dropped nodes with <= %s abs(%s)", michael@0: Unparse($nodelimit), Units()), michael@0: sprintf("Dropped edges with <= %s %s", michael@0: Unparse($edgelimit), Units()) michael@0: ); michael@0: michael@0: # Print nodes michael@0: my %node = (); michael@0: my $nextnode = 1; michael@0: foreach my $a (@list[0..$last]) { michael@0: # Pick font size michael@0: my $f = GetEntry($flat, $a); michael@0: my $c = GetEntry($cumulative, $a); michael@0: michael@0: my $fs = 8; michael@0: if ($local_total > 0) { michael@0: $fs = 8 + (50.0 * sqrt(abs($f * 1.0 / $local_total))); michael@0: } michael@0: michael@0: $node{$a} = $nextnode++; michael@0: my $sym = $a; michael@0: $sym =~ s/\s+/\\n/g; michael@0: $sym =~ s/::/\\n/g; michael@0: michael@0: # Extra cumulative info to print for non-leaves michael@0: my $extra = ""; michael@0: if ($f != $c) { michael@0: $extra = sprintf("\\rof %s (%s)", michael@0: Unparse($c), michael@0: Percent($c, $local_total)); michael@0: } michael@0: my $style = ""; michael@0: if ($main::opt_heapcheck) { michael@0: if ($f > 0) { michael@0: # make leak-causing nodes more visible (add a background) michael@0: $style = ",style=filled,fillcolor=gray" michael@0: } elsif ($f < 0) { michael@0: # make anti-leak-causing nodes (which almost never occur) michael@0: # stand out as well (triple border) michael@0: $style = ",peripheries=3" michael@0: } michael@0: } michael@0: michael@0: printf DOT ("N%d [label=\"%s\\n%s (%s)%s\\r" . michael@0: "\",shape=box,fontsize=%.1f%s];\n", michael@0: $node{$a}, michael@0: $sym, michael@0: Unparse($f), michael@0: Percent($f, $local_total), michael@0: $extra, michael@0: $fs, michael@0: $style, michael@0: ); michael@0: } michael@0: michael@0: # Get edges and counts per edge michael@0: my %edge = (); michael@0: my $n; michael@0: my $fullname_to_shortname_map = {}; michael@0: FillFullnameToShortnameMap($symbols, $fullname_to_shortname_map); michael@0: foreach my $k (keys(%{$raw})) { michael@0: # TODO: omit low %age edges michael@0: $n = $raw->{$k}; michael@0: my @translated = TranslateStack($symbols, $fullname_to_shortname_map, $k); michael@0: for (my $i = 1; $i <= $#translated; $i++) { michael@0: my $src = $translated[$i]; michael@0: my $dst = $translated[$i-1]; michael@0: #next if ($src eq $dst); # Avoid self-edges? michael@0: if (exists($node{$src}) && exists($node{$dst})) { michael@0: my $edge_label = "$src\001$dst"; michael@0: if (!exists($edge{$edge_label})) { michael@0: $edge{$edge_label} = 0; michael@0: } michael@0: $edge{$edge_label} += $n; michael@0: } michael@0: } michael@0: } michael@0: michael@0: # Print edges (process in order of decreasing counts) michael@0: my %indegree = (); # Number of incoming edges added per node so far michael@0: my %outdegree = (); # Number of outgoing edges added per node so far michael@0: foreach my $e (sort { $edge{$b} <=> $edge{$a} } keys(%edge)) { michael@0: my @x = split(/\001/, $e); michael@0: $n = $edge{$e}; michael@0: michael@0: # Initialize degree of kept incoming and outgoing edges if necessary michael@0: my $src = $x[0]; michael@0: my $dst = $x[1]; michael@0: if (!exists($outdegree{$src})) { $outdegree{$src} = 0; } michael@0: if (!exists($indegree{$dst})) { $indegree{$dst} = 0; } michael@0: michael@0: my $keep; michael@0: if ($indegree{$dst} == 0) { michael@0: # Keep edge if needed for reachability michael@0: $keep = 1; michael@0: } elsif (abs($n) <= $edgelimit) { michael@0: # Drop if we are below --edgefraction michael@0: $keep = 0; michael@0: } elsif ($outdegree{$src} >= $main::opt_maxdegree || michael@0: $indegree{$dst} >= $main::opt_maxdegree) { michael@0: # Keep limited number of in/out edges per node michael@0: $keep = 0; michael@0: } else { michael@0: $keep = 1; michael@0: } michael@0: michael@0: if ($keep) { michael@0: $outdegree{$src}++; michael@0: $indegree{$dst}++; michael@0: michael@0: # Compute line width based on edge count michael@0: my $fraction = abs($local_total ? (3 * ($n / $local_total)) : 0); michael@0: if ($fraction > 1) { $fraction = 1; } michael@0: my $w = $fraction * 2; michael@0: if ($w < 1 && ($main::opt_web || $main::opt_svg)) { michael@0: # SVG output treats line widths < 1 poorly. michael@0: $w = 1; michael@0: } michael@0: michael@0: # Dot sometimes segfaults if given edge weights that are too large, so michael@0: # we cap the weights at a large value michael@0: my $edgeweight = abs($n) ** 0.7; michael@0: if ($edgeweight > 100000) { $edgeweight = 100000; } michael@0: $edgeweight = int($edgeweight); michael@0: michael@0: my $style = sprintf("setlinewidth(%f)", $w); michael@0: if ($x[1] =~ m/$inline$/) { michael@0: $style .= ",dashed"; michael@0: } michael@0: michael@0: # Use a slightly squashed function of the edge count as the weight michael@0: printf DOT ("N%s -> N%s [label=%s, weight=%d, style=\"%s\"];\n", michael@0: $node{$x[0]}, michael@0: $node{$x[1]}, michael@0: Unparse($n), michael@0: $edgeweight, michael@0: $style); michael@0: } michael@0: } michael@0: michael@0: print DOT ("}\n"); michael@0: close(DOT); michael@0: michael@0: if ($main::opt_web || $main::opt_svg) { michael@0: # Rewrite SVG to be more usable inside web browser. michael@0: RewriteSvg(TempName($main::next_tmpfile, "svg")); michael@0: } michael@0: michael@0: return 1; michael@0: } michael@0: michael@0: sub RewriteSvg { michael@0: my $svgfile = shift; michael@0: michael@0: open(SVG, $svgfile) || die "open temp svg: $!"; michael@0: my @svg =