pprof revision 25a000e89649d9ce5aacc1089408b8b3bafeb5e4
1#! /usr/bin/env perl
2
3# Copyright (c) 1998-2007, Google Inc.
4# All rights reserved.
5# 
6# Redistribution and use in source and binary forms, with or without
7# modification, are permitted provided that the following conditions are
8# met:
9# 
10#     * Redistributions of source code must retain the above copyright
11# notice, this list of conditions and the following disclaimer.
12#     * Redistributions in binary form must reproduce the above
13# copyright notice, this list of conditions and the following disclaimer
14# in the documentation and/or other materials provided with the
15# distribution.
16#     * Neither the name of Google Inc. nor the names of its
17# contributors may be used to endorse or promote products derived from
18# this software without specific prior written permission.
19# 
20# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21# "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22# LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
23# A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24# OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25# SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
26# LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
27# DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28# THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29# (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
30# OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
31
32# ---
33# Program for printing the profile generated by common/profiler.cc,
34# or by the heap profiler (common/debugallocation.cc)
35#
36# The profile contains a sequence of entries of the form:
37#       <count> <stack trace>
38# This program parses the profile, and generates user-readable
39# output.
40#
41# Examples:
42#
43# % tools/pprof "program" "profile"
44#   Enters "interactive" mode
45#
46# % tools/pprof --text "program" "profile"
47#   Generates one line per procedure
48#
49# % tools/pprof --gv "program" "profile"
50#   Generates annotated call-graph and displays via "gv"
51#
52# % tools/pprof --gv --focus=Mutex "program" "profile"
53#   Restrict to code paths that involve an entry that matches "Mutex"
54#
55# % tools/pprof --gv --focus=Mutex --ignore=string "program" "profile"
56#   Restrict to code paths that involve an entry that matches "Mutex"
57#   and does not match "string"
58#
59# % tools/pprof --list=IBF_CheckDocid "program" "profile"
60#   Generates disassembly listing of all routines with at least one
61#   sample that match the --list=<regexp> pattern.  The listing is
62#   annotated with the flat and cumulative sample counts at each line.
63#
64# % tools/pprof --disasm=IBF_CheckDocid "program" "profile"
65#   Generates disassembly listing of all routines with at least one
66#   sample that match the --disasm=<regexp> pattern.  The listing is
67#   annotated with the flat and cumulative sample counts at each PC value.
68#
69# TODO: Use color to indicate files?
70
71use strict;
72use warnings;
73use Getopt::Long;
74
75my $PPROF_VERSION = "2.0";
76
77# These are the object tools we use which can come from a
78# user-specified location using --tools, from the PPROF_TOOLS
79# environment variable, or from the environment.
80my %obj_tool_map = (
81  "objdump" => "objdump",
82  "nm" => "nm",
83  "addr2line" => "addr2line",
84  "c++filt" => "c++filt",
85  ## ConfigureObjTools may add architecture-specific entries:
86  #"nm_pdb" => "nm-pdb",       # for reading windows (PDB-format) executables
87  #"addr2line_pdb" => "addr2line-pdb",                                # ditto
88  #"otool" => "otool",         # equivalent of objdump on OS X
89);
90# NOTE: these are lists, so you can put in commandline flags if you want.
91my @DOT = ("dot");          # leave non-absolute, since it may be in /usr/local
92my @GV = ("gv");
93my @EVINCE = ("evince");    # could also be xpdf or perhaps acroread
94my @KCACHEGRIND = ("kcachegrind");
95my @PS2PDF = ("ps2pdf");
96# These are used for dynamic profiles
97my @URL_FETCHER = ("curl", "-s");
98
99# These are the web pages that servers need to support for dynamic profiles
100my $HEAP_PAGE = "/pprof/heap";
101my $PROFILE_PAGE = "/pprof/profile";   # must support cgi-param "?seconds=#"
102my $PMUPROFILE_PAGE = "/pprof/pmuprofile(?:\\?.*)?"; # must support cgi-param
103                                                # ?seconds=#&event=x&period=n
104my $GROWTH_PAGE = "/pprof/growth";
105my $CONTENTION_PAGE = "/pprof/contention";
106my $WALL_PAGE = "/pprof/wall(?:\\?.*)?";  # accepts options like namefilter
107my $FILTEREDPROFILE_PAGE = "/pprof/filteredprofile(?:\\?.*)?";
108my $CENSUSPROFILE_PAGE = "/pprof/censusprofile(?:\\?.*)?"; # must support cgi-param
109                                                       # "?seconds=#",
110                                                       # "?tags_regexp=#" and
111                                                       # "?type=#".
112my $SYMBOL_PAGE = "/pprof/symbol";     # must support symbol lookup via POST
113my $PROGRAM_NAME_PAGE = "/pprof/cmdline";
114
115# These are the web pages that can be named on the command line.
116# All the alternatives must begin with /.
117my $PROFILES = "($HEAP_PAGE|$PROFILE_PAGE|$PMUPROFILE_PAGE|" .
118               "$GROWTH_PAGE|$CONTENTION_PAGE|$WALL_PAGE|" .
119               "$FILTEREDPROFILE_PAGE|$CENSUSPROFILE_PAGE)";
120
121# default binary name
122my $UNKNOWN_BINARY = "(unknown)";
123
124# There is a pervasive dependency on the length (in hex characters,
125# i.e., nibbles) of an address, distinguishing between 32-bit and
126# 64-bit profiles.  To err on the safe size, default to 64-bit here:
127my $address_length = 16;
128
129my $dev_null = "/dev/null";
130if (! -e $dev_null && $^O =~ /MSWin/) {    # $^O is the OS perl was built for
131  $dev_null = "nul";
132}
133
134# A list of paths to search for shared object files
135my @prefix_list = ();
136
137# Special routine name that should not have any symbols.
138# Used as separator to parse "addr2line -i" output.
139my $sep_symbol = '_fini';
140my $sep_address = undef;
141
142##### Argument parsing #####
143
144sub usage_string {
145  return <<EOF;
146Usage:
147pprof [options] <program> <profiles>
148   <profiles> is a space separated list of profile names.
149pprof [options] <symbolized-profiles>
150   <symbolized-profiles> is a list of profile files where each file contains
151   the necessary symbol mappings  as well as profile data (likely generated
152   with --raw).
153pprof [options] <profile>
154   <profile> is a remote form.  Symbols are obtained from host:port$SYMBOL_PAGE
155
156   Each name can be:
157   /path/to/profile        - a path to a profile file
158   host:port[/<service>]   - a location of a service to get profile from
159
160   The /<service> can be $HEAP_PAGE, $PROFILE_PAGE, /pprof/pmuprofile,
161                         $GROWTH_PAGE, $CONTENTION_PAGE, /pprof/wall,
162                         $CENSUSPROFILE_PAGE, or /pprof/filteredprofile.
163   For instance:
164     pprof http://myserver.com:80$HEAP_PAGE
165   If /<service> is omitted, the service defaults to $PROFILE_PAGE (cpu profiling).
166pprof --symbols <program>
167   Maps addresses to symbol names.  In this mode, stdin should be a
168   list of library mappings, in the same format as is found in the heap-
169   and cpu-profile files (this loosely matches that of /proc/self/maps
170   on linux), followed by a list of hex addresses to map, one per line.
171
172   For more help with querying remote servers, including how to add the
173   necessary server-side support code, see this filename (or one like it):
174
175   /usr/doc/gperftools-$PPROF_VERSION/pprof_remote_servers.html
176
177Options:
178   --cum               Sort by cumulative data
179   --base=<base>       Subtract <base> from <profile> before display
180   --interactive       Run in interactive mode (interactive "help" gives help) [default]
181   --seconds=<n>       Length of time for dynamic profiles [default=30 secs]
182   --add_lib=<file>    Read additional symbols and line info from the given library
183   --lib_prefix=<dir>  Comma separated list of library path prefixes
184
185Reporting Granularity:
186   --addresses         Report at address level
187   --lines             Report at source line level
188   --functions         Report at function level [default]
189   --files             Report at source file level
190
191Output type:
192   --text              Generate text report
193   --callgrind         Generate callgrind format to stdout
194   --gv                Generate Postscript and display
195   --evince            Generate PDF and display
196   --web               Generate SVG and display
197   --list=<regexp>     Generate source listing of matching routines
198   --disasm=<regexp>   Generate disassembly of matching routines
199   --symbols           Print demangled symbol names found at given addresses
200   --dot               Generate DOT file to stdout
201   --ps                Generate Postcript to stdout
202   --pdf               Generate PDF to stdout
203   --svg               Generate SVG to stdout
204   --gif               Generate GIF to stdout
205   --raw               Generate symbolized pprof data (useful with remote fetch)
206
207Heap-Profile Options:
208   --inuse_space       Display in-use (mega)bytes [default]
209   --inuse_objects     Display in-use objects
210   --alloc_space       Display allocated (mega)bytes
211   --alloc_objects     Display allocated objects
212   --show_bytes        Display space in bytes
213   --drop_negative     Ignore negative differences
214
215Contention-profile options:
216   --total_delay       Display total delay at each region [default]
217   --contentions       Display number of delays at each region
218   --mean_delay        Display mean delay at each region
219
220Call-graph Options:
221   --nodecount=<n>     Show at most so many nodes [default=80]
222   --nodefraction=<f>  Hide nodes below <f>*total [default=.005]
223   --edgefraction=<f>  Hide edges below <f>*total [default=.001]
224   --maxdegree=<n>     Max incoming/outgoing edges per node [default=8]
225   --focus=<regexp>    Focus on nodes matching <regexp>
226   --ignore=<regexp>   Ignore nodes matching <regexp>
227   --scale=<n>         Set GV scaling [default=0]
228   --heapcheck         Make nodes with non-0 object counts
229                       (i.e. direct leak generators) more visible
230
231Miscellaneous:
232   --tools=<prefix or binary:fullpath>[,...]   \$PATH for object tool pathnames
233   --test              Run unit tests
234   --help              This message
235   --version           Version information
236
237Environment Variables:
238   PPROF_TMPDIR        Profiles directory. Defaults to \$HOME/pprof
239   PPROF_TOOLS         Prefix for object tools pathnames
240
241Examples:
242
243pprof /bin/ls ls.prof
244                       Enters "interactive" mode
245pprof --text /bin/ls ls.prof
246                       Outputs one line per procedure
247pprof --web /bin/ls ls.prof
248                       Displays annotated call-graph in web browser
249pprof --gv /bin/ls ls.prof
250                       Displays annotated call-graph via 'gv'
251pprof --gv --focus=Mutex /bin/ls ls.prof
252                       Restricts to code paths including a .*Mutex.* entry
253pprof --gv --focus=Mutex --ignore=string /bin/ls ls.prof
254                       Code paths including Mutex but not string
255pprof --list=getdir /bin/ls ls.prof
256                       (Per-line) annotated source listing for getdir()
257pprof --disasm=getdir /bin/ls ls.prof
258                       (Per-PC) annotated disassembly for getdir()
259
260pprof http://localhost:1234/
261                       Enters "interactive" mode
262pprof --text localhost:1234
263                       Outputs one line per procedure for localhost:1234
264pprof --raw localhost:1234 > ./local.raw
265pprof --text ./local.raw
266                       Fetches a remote profile for later analysis and then
267                       analyzes it in text mode.
268EOF
269}
270
271sub version_string {
272  return <<EOF
273pprof (part of gperftools $PPROF_VERSION)
274
275Copyright 1998-2007 Google Inc.
276
277This is BSD licensed software; see the source for copying conditions
278and license information.
279There is NO warranty; not even for MERCHANTABILITY or FITNESS FOR A
280PARTICULAR PURPOSE.
281EOF
282}
283
284sub usage {
285  my $msg = shift;
286  print STDERR "$msg\n\n";
287  print STDERR usage_string();
288  print STDERR "\nFATAL ERROR: $msg\n";    # just as a reminder
289  exit(1);
290}
291
292sub Init() {
293  # Setup tmp-file name and handler to clean it up.
294  # We do this in the very beginning so that we can use
295  # error() and cleanup() function anytime here after.
296  $main::tmpfile_sym = "/tmp/pprof$$.sym";
297  $main::tmpfile_ps = "/tmp/pprof$$";
298  $main::next_tmpfile = 0;
299  $SIG{'INT'} = \&sighandler;
300
301  # Cache from filename/linenumber to source code
302  $main::source_cache = ();
303
304  $main::opt_help = 0;
305  $main::opt_version = 0;
306
307  $main::opt_cum = 0;
308  $main::opt_base = '';
309  $main::opt_addresses = 0;
310  $main::opt_lines = 0;
311  $main::opt_functions = 0;
312  $main::opt_files = 0;
313  $main::opt_lib_prefix = "";
314
315  $main::opt_text = 0;
316  $main::opt_callgrind = 0;
317  $main::opt_list = "";
318  $main::opt_disasm = "";
319  $main::opt_symbols = 0;
320  $main::opt_gv = 0;
321  $main::opt_evince = 0;
322  $main::opt_web = 0;
323  $main::opt_dot = 0;
324  $main::opt_ps = 0;
325  $main::opt_pdf = 0;
326  $main::opt_gif = 0;
327  $main::opt_svg = 0;
328  $main::opt_raw = 0;
329
330  $main::opt_nodecount = 80;
331  $main::opt_nodefraction = 0.005;
332  $main::opt_edgefraction = 0.001;
333  $main::opt_maxdegree = 8;
334  $main::opt_focus = '';
335  $main::opt_ignore = '';
336  $main::opt_scale = 0;
337  $main::opt_heapcheck = 0;
338  $main::opt_seconds = 30;
339  $main::opt_lib = "";
340
341  $main::opt_inuse_space   = 0;
342  $main::opt_inuse_objects = 0;
343  $main::opt_alloc_space   = 0;
344  $main::opt_alloc_objects = 0;
345  $main::opt_show_bytes    = 0;
346  $main::opt_drop_negative = 0;
347  $main::opt_interactive   = 0;
348
349  $main::opt_total_delay = 0;
350  $main::opt_contentions = 0;
351  $main::opt_mean_delay = 0;
352
353  $main::opt_tools   = "";
354  $main::opt_debug   = 0;
355  $main::opt_test    = 0;
356
357  # These are undocumented flags used only by unittests.
358  $main::opt_test_stride = 0;
359
360  # Are we using $SYMBOL_PAGE?
361  $main::use_symbol_page = 0;
362
363  # Files returned by TempName.
364  %main::tempnames = ();
365
366  # Type of profile we are dealing with
367  # Supported types:
368  #     cpu
369  #     heap
370  #     growth
371  #     contention
372  $main::profile_type = '';     # Empty type means "unknown"
373
374  GetOptions("help!"          => \$main::opt_help,
375             "version!"       => \$main::opt_version,
376             "cum!"           => \$main::opt_cum,
377             "base=s"         => \$main::opt_base,
378             "seconds=i"      => \$main::opt_seconds,
379             "add_lib=s"      => \$main::opt_lib,
380             "lib_prefix=s"   => \$main::opt_lib_prefix,
381             "functions!"     => \$main::opt_functions,
382             "lines!"         => \$main::opt_lines,
383             "addresses!"     => \$main::opt_addresses,
384             "files!"         => \$main::opt_files,
385             "text!"          => \$main::opt_text,
386             "callgrind!"     => \$main::opt_callgrind,
387             "list=s"         => \$main::opt_list,
388             "disasm=s"       => \$main::opt_disasm,
389             "symbols!"       => \$main::opt_symbols,
390             "gv!"            => \$main::opt_gv,
391             "evince!"        => \$main::opt_evince,
392             "web!"           => \$main::opt_web,
393             "dot!"           => \$main::opt_dot,
394             "ps!"            => \$main::opt_ps,
395             "pdf!"           => \$main::opt_pdf,
396             "svg!"           => \$main::opt_svg,
397             "gif!"           => \$main::opt_gif,
398             "raw!"           => \$main::opt_raw,
399             "interactive!"   => \$main::opt_interactive,
400             "nodecount=i"    => \$main::opt_nodecount,
401             "nodefraction=f" => \$main::opt_nodefraction,
402             "edgefraction=f" => \$main::opt_edgefraction,
403             "maxdegree=i"    => \$main::opt_maxdegree,
404             "focus=s"        => \$main::opt_focus,
405             "ignore=s"       => \$main::opt_ignore,
406             "scale=i"        => \$main::opt_scale,
407             "heapcheck"      => \$main::opt_heapcheck,
408             "inuse_space!"   => \$main::opt_inuse_space,
409             "inuse_objects!" => \$main::opt_inuse_objects,
410             "alloc_space!"   => \$main::opt_alloc_space,
411             "alloc_objects!" => \$main::opt_alloc_objects,
412             "show_bytes!"    => \$main::opt_show_bytes,
413             "drop_negative!" => \$main::opt_drop_negative,
414             "total_delay!"   => \$main::opt_total_delay,
415             "contentions!"   => \$main::opt_contentions,
416             "mean_delay!"    => \$main::opt_mean_delay,
417             "tools=s"        => \$main::opt_tools,
418             "test!"          => \$main::opt_test,
419             "debug!"         => \$main::opt_debug,
420             # Undocumented flags used only by unittests:
421             "test_stride=i"  => \$main::opt_test_stride,
422      ) || usage("Invalid option(s)");
423
424  # Deal with the standard --help and --version
425  if ($main::opt_help) {
426    print usage_string();
427    exit(0);
428  }
429
430  if ($main::opt_version) {
431    print version_string();
432    exit(0);
433  }
434
435  # Disassembly/listing/symbols mode requires address-level info
436  if ($main::opt_disasm || $main::opt_list || $main::opt_symbols) {
437    $main::opt_functions = 0;
438    $main::opt_lines = 0;
439    $main::opt_addresses = 1;
440    $main::opt_files = 0;
441  }
442
443  # Check heap-profiling flags
444  if ($main::opt_inuse_space +
445      $main::opt_inuse_objects +
446      $main::opt_alloc_space +
447      $main::opt_alloc_objects > 1) {
448    usage("Specify at most on of --inuse/--alloc options");
449  }
450
451  # Check output granularities
452  my $grains =
453      $main::opt_functions +
454      $main::opt_lines +
455      $main::opt_addresses +
456      $main::opt_files +
457      0;
458  if ($grains > 1) {
459    usage("Only specify one output granularity option");
460  }
461  if ($grains == 0) {
462    $main::opt_functions = 1;
463  }
464
465  # Check output modes
466  my $modes =
467      $main::opt_text +
468      $main::opt_callgrind +
469      ($main::opt_list eq '' ? 0 : 1) +
470      ($main::opt_disasm eq '' ? 0 : 1) +
471      ($main::opt_symbols == 0 ? 0 : 1) +
472      $main::opt_gv +
473      $main::opt_evince +
474      $main::opt_web +
475      $main::opt_dot +
476      $main::opt_ps +
477      $main::opt_pdf +
478      $main::opt_svg +
479      $main::opt_gif +
480      $main::opt_raw +
481      $main::opt_interactive +
482      0;
483  if ($modes > 1) {
484    usage("Only specify one output mode");
485  }
486  if ($modes == 0) {
487    if (-t STDOUT) {  # If STDOUT is a tty, activate interactive mode
488      $main::opt_interactive = 1;
489    } else {
490      $main::opt_text = 1;
491    }
492  }
493
494  if ($main::opt_test) {
495    RunUnitTests();
496    # Should not return
497    exit(1);
498  }
499
500  # Binary name and profile arguments list
501  $main::prog = "";
502  @main::pfile_args = ();
503
504  # Remote profiling without a binary (using $SYMBOL_PAGE instead)
505  if (@ARGV > 0) {
506    if (IsProfileURL($ARGV[0])) {
507      $main::use_symbol_page = 1;
508    } elsif (IsSymbolizedProfileFile($ARGV[0])) {
509      $main::use_symbolized_profile = 1;
510      $main::prog = $UNKNOWN_BINARY;  # will be set later from the profile file
511    }
512  }
513
514  if ($main::use_symbol_page || $main::use_symbolized_profile) {
515    # We don't need a binary!
516    my %disabled = ('--lines' => $main::opt_lines,
517                    '--disasm' => $main::opt_disasm);
518    for my $option (keys %disabled) {
519      usage("$option cannot be used without a binary") if $disabled{$option};
520    }
521    # Set $main::prog later...
522    scalar(@ARGV) || usage("Did not specify profile file");
523  } elsif ($main::opt_symbols) {
524    # --symbols needs a binary-name (to run nm on, etc) but not profiles
525    $main::prog = shift(@ARGV) || usage("Did not specify program");
526  } else {
527    $main::prog = shift(@ARGV) || usage("Did not specify program");
528    scalar(@ARGV) || usage("Did not specify profile file");
529  }
530
531  # Parse profile file/location arguments
532  foreach my $farg (@ARGV) {
533    if ($farg =~ m/(.*)\@([0-9]+)(|\/.*)$/ ) {
534      my $machine = $1;
535      my $num_machines = $2;
536      my $path = $3;
537      for (my $i = 0; $i < $num_machines; $i++) {
538        unshift(@main::pfile_args, "$i.$machine$path");
539      }
540    } else {
541      unshift(@main::pfile_args, $farg);
542    }
543  }
544
545  if ($main::use_symbol_page) {
546    unless (IsProfileURL($main::pfile_args[0])) {
547      error("The first profile should be a remote form to use $SYMBOL_PAGE\n");
548    }
549    CheckSymbolPage();
550    $main::prog = FetchProgramName();
551  } elsif (!$main::use_symbolized_profile) {  # may not need objtools!
552    ConfigureObjTools($main::prog)
553  }
554
555  # Break the opt_lib_prefix into the prefix_list array
556  @prefix_list = split (',', $main::opt_lib_prefix);
557
558  # Remove trailing / from the prefixes, in the list to prevent
559  # searching things like /my/path//lib/mylib.so
560  foreach (@prefix_list) {
561    s|/+$||;
562  }
563}
564
565sub Main() {
566  Init();
567  $main::collected_profile = undef;
568  @main::profile_files = ();
569  $main::op_time = time();
570
571  # Printing symbols is special and requires a lot less info that most.
572  if ($main::opt_symbols) {
573    PrintSymbols(*STDIN);   # Get /proc/maps and symbols output from stdin
574    return;
575  }
576
577  # Fetch all profile data
578  FetchDynamicProfiles();
579
580  # this will hold symbols that we read from the profile files
581  my $symbol_map = {};
582
583  # Read one profile, pick the last item on the list
584  my $data = ReadProfile($main::prog, pop(@main::profile_files));
585  my $profile = $data->{profile};
586  my $pcs = $data->{pcs};
587  my $libs = $data->{libs};   # Info about main program and shared libraries
588  $symbol_map = MergeSymbols($symbol_map, $data->{symbols});
589
590  # Add additional profiles, if available.
591  if (scalar(@main::profile_files) > 0) {
592    foreach my $pname (@main::profile_files) {
593      my $data2 = ReadProfile($main::prog, $pname);
594      $profile = AddProfile($profile, $data2->{profile});
595      $pcs = AddPcs($pcs, $data2->{pcs});
596      $symbol_map = MergeSymbols($symbol_map, $data2->{symbols});
597    }
598  }
599
600  # Subtract base from profile, if specified
601  if ($main::opt_base ne '') {
602    my $base = ReadProfile($main::prog, $main::opt_base);
603    $profile = SubtractProfile($profile, $base->{profile});
604    $pcs = AddPcs($pcs, $base->{pcs});
605    $symbol_map = MergeSymbols($symbol_map, $base->{symbols});
606  }
607
608  # Get total data in profile
609  my $total = TotalProfile($profile);
610
611  # Collect symbols
612  my $symbols;
613  if ($main::use_symbolized_profile) {
614    $symbols = FetchSymbols($pcs, $symbol_map);
615  } elsif ($main::use_symbol_page) {
616    $symbols = FetchSymbols($pcs);
617  } else {
618    # TODO(csilvers): $libs uses the /proc/self/maps data from profile1,
619    # which may differ from the data from subsequent profiles, especially
620    # if they were run on different machines.  Use appropriate libs for
621    # each pc somehow.
622    $symbols = ExtractSymbols($libs, $pcs);
623  }
624
625  # Remove uniniteresting stack items
626  $profile = RemoveUninterestingFrames($symbols, $profile);
627
628  # Focus?
629  if ($main::opt_focus ne '') {
630    $profile = FocusProfile($symbols, $profile, $main::opt_focus);
631  }
632
633  # Ignore?
634  if ($main::opt_ignore ne '') {
635    $profile = IgnoreProfile($symbols, $profile, $main::opt_ignore);
636  }
637
638  my $calls = ExtractCalls($symbols, $profile);
639
640  # Reduce profiles to required output granularity, and also clean
641  # each stack trace so a given entry exists at most once.
642  my $reduced = ReduceProfile($symbols, $profile);
643
644  # Get derived profiles
645  my $flat = FlatProfile($reduced);
646  my $cumulative = CumulativeProfile($reduced);
647
648  # Print
649  if (!$main::opt_interactive) {
650    if ($main::opt_disasm) {
651      PrintDisassembly($libs, $flat, $cumulative, $main::opt_disasm);
652    } elsif ($main::opt_list) {
653      PrintListing($total, $libs, $flat, $cumulative, $main::opt_list, 0);
654    } elsif ($main::opt_text) {
655      # Make sure the output is empty when have nothing to report
656      # (only matters when --heapcheck is given but we must be
657      # compatible with old branches that did not pass --heapcheck always):
658      if ($total != 0) {
659        printf("Total: %s %s\n", Unparse($total), Units());
660      }
661      PrintText($symbols, $flat, $cumulative, -1);
662    } elsif ($main::opt_raw) {
663      PrintSymbolizedProfile($symbols, $profile, $main::prog);
664    } elsif ($main::opt_callgrind) {
665      PrintCallgrind($calls);
666    } else {
667      if (PrintDot($main::prog, $symbols, $profile, $flat, $cumulative, $total)) {
668        if ($main::opt_gv) {
669          RunGV(TempName($main::next_tmpfile, "ps"), "");
670        } elsif ($main::opt_evince) {
671          RunEvince(TempName($main::next_tmpfile, "pdf"), "");
672        } elsif ($main::opt_web) {
673          my $tmp = TempName($main::next_tmpfile, "svg");
674          RunWeb($tmp);
675          # The command we run might hand the file name off
676          # to an already running browser instance and then exit.
677          # Normally, we'd remove $tmp on exit (right now),
678          # but fork a child to remove $tmp a little later, so that the
679          # browser has time to load it first.
680          delete $main::tempnames{$tmp};
681          if (fork() == 0) {
682            sleep 5;
683            unlink($tmp);
684            exit(0);
685          }
686        }
687      } else {
688        cleanup();
689        exit(1);
690      }
691    }
692  } else {
693    InteractiveMode($profile, $symbols, $libs, $total);
694  }
695
696  cleanup();
697  exit(0);
698}
699
700##### Entry Point #####
701
702Main();
703
704# Temporary code to detect if we're running on a Goobuntu system.
705# These systems don't have the right stuff installed for the special
706# Readline libraries to work, so as a temporary workaround, we default
707# to using the normal stdio code, rather than the fancier readline-based
708# code
709sub ReadlineMightFail {
710  if (-e '/lib/libtermcap.so.2') {
711    return 0;  # libtermcap exists, so readline should be okay
712  } else {
713    return 1;
714  }
715}
716
717sub RunGV {
718  my $fname = shift;
719  my $bg = shift;       # "" or " &" if we should run in background
720  if (!system(ShellEscape(@GV, "--version") . " >$dev_null 2>&1")) {
721    # Options using double dash are supported by this gv version.
722    # Also, turn on noantialias to better handle bug in gv for
723    # postscript files with large dimensions.
724    # TODO: Maybe we should not pass the --noantialias flag
725    # if the gv version is known to work properly without the flag.
726    system(ShellEscape(@GV, "--scale=$main::opt_scale", "--noantialias", $fname)
727           . $bg);
728  } else {
729    # Old gv version - only supports options that use single dash.
730    print STDERR ShellEscape(@GV, "-scale", $main::opt_scale) . "\n";
731    system(ShellEscape(@GV, "-scale", "$main::opt_scale", $fname) . $bg);
732  }
733}
734
735sub RunEvince {
736  my $fname = shift;
737  my $bg = shift;       # "" or " &" if we should run in background
738  system(ShellEscape(@EVINCE, $fname) . $bg);
739}
740
741sub RunWeb {
742  my $fname = shift;
743  print STDERR "Loading web page file:///$fname\n";
744
745  if (`uname` =~ /Darwin/) {
746    # OS X: open will use standard preference for SVG files.
747    system("/usr/bin/open", $fname);
748    return;
749  }
750
751  # Some kind of Unix; try generic symlinks, then specific browsers.
752  # (Stop once we find one.)
753  # Works best if the browser is already running.
754  my @alt = (
755    "/etc/alternatives/gnome-www-browser",
756    "/etc/alternatives/x-www-browser",
757    "google-chrome",
758    "firefox",
759  );
760  foreach my $b (@alt) {
761    if (system($b, $fname) == 0) {
762      return;
763    }
764  }
765
766  print STDERR "Could not load web browser.\n";
767}
768
769sub RunKcachegrind {
770  my $fname = shift;
771  my $bg = shift;       # "" or " &" if we should run in background
772  print STDERR "Starting '@KCACHEGRIND " . $fname . $bg . "'\n";
773  system(ShellEscape(@KCACHEGRIND, $fname) . $bg);
774}
775
776
777##### Interactive helper routines #####
778
779sub InteractiveMode {
780  $| = 1;  # Make output unbuffered for interactive mode
781  my ($orig_profile, $symbols, $libs, $total) = @_;
782
783  print STDERR "Welcome to pprof!  For help, type 'help'.\n";
784
785  # Use ReadLine if it's installed and input comes from a console.
786  if ( -t STDIN &&
787       !ReadlineMightFail() &&
788       defined(eval {require Term::ReadLine}) ) {
789    my $term = new Term::ReadLine 'pprof';
790    while ( defined ($_ = $term->readline('(pprof) '))) {
791      $term->addhistory($_) if /\S/;
792      if (!InteractiveCommand($orig_profile, $symbols, $libs, $total, $_)) {
793        last;    # exit when we get an interactive command to quit
794      }
795    }
796  } else {       # don't have readline
797    while (1) {
798      print STDERR "(pprof) ";
799      $_ = <STDIN>;
800      last if ! defined $_ ;
801      s/\r//g;         # turn windows-looking lines into unix-looking lines
802
803      # Save some flags that might be reset by InteractiveCommand()
804      my $save_opt_lines = $main::opt_lines;
805
806      if (!InteractiveCommand($orig_profile, $symbols, $libs, $total, $_)) {
807        last;    # exit when we get an interactive command to quit
808      }
809
810      # Restore flags
811      $main::opt_lines = $save_opt_lines;
812    }
813  }
814}
815
816# Takes two args: orig profile, and command to run.
817# Returns 1 if we should keep going, or 0 if we were asked to quit
818sub InteractiveCommand {
819  my($orig_profile, $symbols, $libs, $total, $command) = @_;
820  $_ = $command;                # just to make future m//'s easier
821  if (!defined($_)) {
822    print STDERR "\n";
823    return 0;
824  }
825  if (m/^\s*quit/) {
826    return 0;
827  }
828  if (m/^\s*help/) {
829    InteractiveHelpMessage();
830    return 1;
831  }
832  # Clear all the mode options -- mode is controlled by "$command"
833  $main::opt_text = 0;
834  $main::opt_callgrind = 0;
835  $main::opt_disasm = 0;
836  $main::opt_list = 0;
837  $main::opt_gv = 0;
838  $main::opt_evince = 0;
839  $main::opt_cum = 0;
840
841  if (m/^\s*(text|top)(\d*)\s*(.*)/) {
842    $main::opt_text = 1;
843
844    my $line_limit = ($2 ne "") ? int($2) : 10;
845
846    my $routine;
847    my $ignore;
848    ($routine, $ignore) = ParseInteractiveArgs($3);
849
850    my $profile = ProcessProfile($total, $orig_profile, $symbols, "", $ignore);
851    my $reduced = ReduceProfile($symbols, $profile);
852
853    # Get derived profiles
854    my $flat = FlatProfile($reduced);
855    my $cumulative = CumulativeProfile($reduced);
856
857    PrintText($symbols, $flat, $cumulative, $line_limit);
858    return 1;
859  }
860  if (m/^\s*callgrind\s*([^ \n]*)/) {
861    $main::opt_callgrind = 1;
862
863    # Get derived profiles
864    my $calls = ExtractCalls($symbols, $orig_profile);
865    my $filename = $1;
866    if ( $1 eq '' ) {
867      $filename = TempName($main::next_tmpfile, "callgrind");
868    }
869    PrintCallgrind($calls, $filename);
870    if ( $1 eq '' ) {
871      RunKcachegrind($filename, " & ");
872      $main::next_tmpfile++;
873    }
874
875    return 1;
876  }
877  if (m/^\s*(web)?list\s*(.+)/) {
878    my $html = (defined($1) && ($1 eq "web"));
879    $main::opt_list = 1;
880
881    my $routine;
882    my $ignore;
883    ($routine, $ignore) = ParseInteractiveArgs($2);
884
885    my $profile = ProcessProfile($total, $orig_profile, $symbols, "", $ignore);
886    my $reduced = ReduceProfile($symbols, $profile);
887
888    # Get derived profiles
889    my $flat = FlatProfile($reduced);
890    my $cumulative = CumulativeProfile($reduced);
891
892    PrintListing($total, $libs, $flat, $cumulative, $routine, $html);
893    return 1;
894  }
895  if (m/^\s*disasm\s*(.+)/) {
896    $main::opt_disasm = 1;
897
898    my $routine;
899    my $ignore;
900    ($routine, $ignore) = ParseInteractiveArgs($1);
901
902    # Process current profile to account for various settings
903    my $profile = ProcessProfile($total, $orig_profile, $symbols, "", $ignore);
904    my $reduced = ReduceProfile($symbols, $profile);
905
906    # Get derived profiles
907    my $flat = FlatProfile($reduced);
908    my $cumulative = CumulativeProfile($reduced);
909
910    PrintDisassembly($libs, $flat, $cumulative, $routine);
911    return 1;
912  }
913  if (m/^\s*(gv|web|evince)\s*(.*)/) {
914    $main::opt_gv = 0;
915    $main::opt_evince = 0;
916    $main::opt_web = 0;
917    if ($1 eq "gv") {
918      $main::opt_gv = 1;
919    } elsif ($1 eq "evince") {
920      $main::opt_evince = 1;
921    } elsif ($1 eq "web") {
922      $main::opt_web = 1;
923    }
924
925    my $focus;
926    my $ignore;
927    ($focus, $ignore) = ParseInteractiveArgs($2);
928
929    # Process current profile to account for various settings
930    my $profile = ProcessProfile($total, $orig_profile, $symbols,
931                                 $focus, $ignore);
932    my $reduced = ReduceProfile($symbols, $profile);
933
934    # Get derived profiles
935    my $flat = FlatProfile($reduced);
936    my $cumulative = CumulativeProfile($reduced);
937
938    if (PrintDot($main::prog, $symbols, $profile, $flat, $cumulative, $total)) {
939      if ($main::opt_gv) {
940        RunGV(TempName($main::next_tmpfile, "ps"), " &");
941      } elsif ($main::opt_evince) {
942        RunEvince(TempName($main::next_tmpfile, "pdf"), " &");
943      } elsif ($main::opt_web) {
944        RunWeb(TempName($main::next_tmpfile, "svg"));
945      }
946      $main::next_tmpfile++;
947    }
948    return 1;
949  }
950  if (m/^\s*$/) {
951    return 1;
952  }
953  print STDERR "Unknown command: try 'help'.\n";
954  return 1;
955}
956
957
958sub ProcessProfile {
959  my $total_count = shift;
960  my $orig_profile = shift;
961  my $symbols = shift;
962  my $focus = shift;
963  my $ignore = shift;
964
965  # Process current profile to account for various settings
966  my $profile = $orig_profile;
967  printf("Total: %s %s\n", Unparse($total_count), Units());
968  if ($focus ne '') {
969    $profile = FocusProfile($symbols, $profile, $focus);
970    my $focus_count = TotalProfile($profile);
971    printf("After focusing on '%s': %s %s of %s (%0.1f%%)\n",
972           $focus,
973           Unparse($focus_count), Units(),
974           Unparse($total_count), ($focus_count*100.0) / $total_count);
975  }
976  if ($ignore ne '') {
977    $profile = IgnoreProfile($symbols, $profile, $ignore);
978    my $ignore_count = TotalProfile($profile);
979    printf("After ignoring '%s': %s %s of %s (%0.1f%%)\n",
980           $ignore,
981           Unparse($ignore_count), Units(),
982           Unparse($total_count),
983           ($ignore_count*100.0) / $total_count);
984  }
985
986  return $profile;
987}
988
989sub InteractiveHelpMessage {
990  print STDERR <<ENDOFHELP;
991Interactive pprof mode
992
993Commands:
994  gv
995  gv [focus] [-ignore1] [-ignore2]
996      Show graphical hierarchical display of current profile.  Without
997      any arguments, shows all samples in the profile.  With the optional
998      "focus" argument, restricts the samples shown to just those where
999      the "focus" regular expression matches a routine name on the stack
1000      trace.
1001
1002  web
1003  web [focus] [-ignore1] [-ignore2]
1004      Like GV, but displays profile in your web browser instead of using
1005      Ghostview. Works best if your web browser is already running.
1006      To change the browser that gets used:
1007      On Linux, set the /etc/alternatives/gnome-www-browser symlink.
1008      On OS X, change the Finder association for SVG files.
1009
1010  list [routine_regexp] [-ignore1] [-ignore2]
1011      Show source listing of routines whose names match "routine_regexp"
1012
1013  weblist [routine_regexp] [-ignore1] [-ignore2]
1014     Displays a source listing of routines whose names match "routine_regexp"
1015     in a web browser.  You can click on source lines to view the
1016     corresponding disassembly.
1017
1018  top [--cum] [-ignore1] [-ignore2]
1019  top20 [--cum] [-ignore1] [-ignore2]
1020  top37 [--cum] [-ignore1] [-ignore2]
1021      Show top lines ordered by flat profile count, or cumulative count
1022      if --cum is specified.  If a number is present after 'top', the
1023      top K routines will be shown (defaults to showing the top 10)
1024
1025  disasm [routine_regexp] [-ignore1] [-ignore2]
1026      Show disassembly of routines whose names match "routine_regexp",
1027      annotated with sample counts.
1028
1029  callgrind
1030  callgrind [filename]
1031      Generates callgrind file. If no filename is given, kcachegrind is called.
1032
1033  help - This listing
1034  quit or ^D - End pprof
1035
1036For commands that accept optional -ignore tags, samples where any routine in
1037the stack trace matches the regular expression in any of the -ignore
1038parameters will be ignored.
1039
1040Further pprof details are available at this location (or one similar):
1041
1042 /usr/doc/gperftools-$PPROF_VERSION/cpu_profiler.html
1043 /usr/doc/gperftools-$PPROF_VERSION/heap_profiler.html
1044
1045ENDOFHELP
1046}
1047sub ParseInteractiveArgs {
1048  my $args = shift;
1049  my $focus = "";
1050  my $ignore = "";
1051  my @x = split(/ +/, $args);
1052  foreach $a (@x) {
1053    if ($a =~ m/^(--|-)lines$/) {
1054      $main::opt_lines = 1;
1055    } elsif ($a =~ m/^(--|-)cum$/) {
1056      $main::opt_cum = 1;
1057    } elsif ($a =~ m/^-(.*)/) {
1058      $ignore .= (($ignore ne "") ? "|" : "" ) . $1;
1059    } else {
1060      $focus .= (($focus ne "") ? "|" : "" ) . $a;
1061    }
1062  }
1063  if ($ignore ne "") {
1064    print STDERR "Ignoring samples in call stacks that match '$ignore'\n";
1065  }
1066  return ($focus, $ignore);
1067}
1068
1069##### Output code #####
1070
1071sub TempName {
1072  my $fnum = shift;
1073  my $ext = shift;
1074  my $file = "$main::tmpfile_ps.$fnum.$ext";
1075  $main::tempnames{$file} = 1;
1076  return $file;
1077}
1078
1079# Print profile data in packed binary format (64-bit) to standard out
1080sub PrintProfileData {
1081  my $profile = shift;
1082
1083  # print header (64-bit style)
1084  # (zero) (header-size) (version) (sample-period) (zero)
1085  print pack('L*', 0, 0, 3, 0, 0, 0, 1, 0, 0, 0);
1086
1087  foreach my $k (keys(%{$profile})) {
1088    my $count = $profile->{$k};
1089    my @addrs = split(/\n/, $k);
1090    if ($#addrs >= 0) {
1091      my $depth = $#addrs + 1;
1092      # int(foo / 2**32) is the only reliable way to get rid of bottom
1093      # 32 bits on both 32- and 64-bit systems.
1094      print pack('L*', $count & 0xFFFFFFFF, int($count / 2**32));
1095      print pack('L*', $depth & 0xFFFFFFFF, int($depth / 2**32));
1096
1097      foreach my $full_addr (@addrs) {
1098        my $addr = $full_addr;
1099        $addr =~ s/0x0*//;  # strip off leading 0x, zeroes
1100        if (length($addr) > 16) {
1101          print STDERR "Invalid address in profile: $full_addr\n";
1102          next;
1103        }
1104        my $low_addr = substr($addr, -8);       # get last 8 hex chars
1105        my $high_addr = substr($addr, -16, 8);  # get up to 8 more hex chars
1106        print pack('L*', hex('0x' . $low_addr), hex('0x' . $high_addr));
1107      }
1108    }
1109  }
1110}
1111
1112# Print symbols and profile data
1113sub PrintSymbolizedProfile {
1114  my $symbols = shift;
1115  my $profile = shift;
1116  my $prog = shift;
1117
1118  $SYMBOL_PAGE =~ m,[^/]+$,;    # matches everything after the last slash
1119  my $symbol_marker = $&;
1120
1121  print '--- ', $symbol_marker, "\n";
1122  if (defined($prog)) {
1123    print 'binary=', $prog, "\n";
1124  }
1125  while (my ($pc, $name) = each(%{$symbols})) {
1126    my $sep = ' ';
1127    print '0x', $pc;
1128    # We have a list of function names, which include the inlined
1129    # calls.  They are separated (and terminated) by --, which is
1130    # illegal in function names.
1131    for (my $j = 2; $j <= $#{$name}; $j += 3) {
1132      print $sep, $name->[$j];
1133      $sep = '--';
1134    }
1135    print "\n";
1136  }
1137  print '---', "\n";
1138
1139  $PROFILE_PAGE =~ m,[^/]+$,;    # matches everything after the last slash
1140  my $profile_marker = $&;
1141  print '--- ', $profile_marker, "\n";
1142  if (defined($main::collected_profile)) {
1143    # if used with remote fetch, simply dump the collected profile to output.
1144    open(SRC, "<$main::collected_profile");
1145    while (<SRC>) {
1146      print $_;
1147    }
1148    close(SRC);
1149  } else {
1150    # dump a cpu-format profile to standard out
1151    PrintProfileData($profile);
1152  }
1153}
1154
1155# Print text output
1156sub PrintText {
1157  my $symbols = shift;
1158  my $flat = shift;
1159  my $cumulative = shift;
1160  my $line_limit = shift;
1161
1162  my $total = TotalProfile($flat);
1163
1164  # Which profile to sort by?
1165  my $s = $main::opt_cum ? $cumulative : $flat;
1166
1167  my $running_sum = 0;
1168  my $lines = 0;
1169  foreach my $k (sort { GetEntry($s, $b) <=> GetEntry($s, $a) || $a cmp $b }
1170                 keys(%{$cumulative})) {
1171    my $f = GetEntry($flat, $k);
1172    my $c = GetEntry($cumulative, $k);
1173    $running_sum += $f;
1174
1175    my $sym = $k;
1176    if (exists($symbols->{$k})) {
1177      $sym = $symbols->{$k}->[0] . " " . $symbols->{$k}->[1];
1178      if ($main::opt_addresses) {
1179        $sym = $k . " " . $sym;
1180      }
1181    }
1182
1183    if ($f != 0 || $c != 0) {
1184      printf("%8s %6s %6s %8s %6s %s\n",
1185             Unparse($f),
1186             Percent($f, $total),
1187             Percent($running_sum, $total),
1188             Unparse($c),
1189             Percent($c, $total),
1190             $sym);
1191    }
1192    $lines++;
1193    last if ($line_limit >= 0 && $lines >= $line_limit);
1194  }
1195}
1196
1197# Callgrind format has a compression for repeated function and file
1198# names.  You show the name the first time, and just use its number
1199# subsequently.  This can cut down the file to about a third or a
1200# quarter of its uncompressed size.  $key and $val are the key/value
1201# pair that would normally be printed by callgrind; $map is a map from
1202# value to number.
1203sub CompressedCGName {
1204  my($key, $val, $map) = @_;
1205  my $idx = $map->{$val};
1206  # For very short keys, providing an index hurts rather than helps.
1207  if (length($val) <= 3) {
1208    return "$key=$val\n";
1209  } elsif (defined($idx)) {
1210    return "$key=($idx)\n";
1211  } else {
1212    # scalar(keys $map) gives the number of items in the map.
1213    $idx = scalar(keys(%{$map})) + 1;
1214    $map->{$val} = $idx;
1215    return "$key=($idx) $val\n";
1216  }
1217}
1218
1219# Print the call graph in a way that's suiteable for callgrind.
1220sub PrintCallgrind {
1221  my $calls = shift;
1222  my $filename;
1223  my %filename_to_index_map;
1224  my %fnname_to_index_map;
1225
1226  if ($main::opt_interactive) {
1227    $filename = shift;
1228    print STDERR "Writing callgrind file to '$filename'.\n"
1229  } else {
1230    $filename = "&STDOUT";
1231  }
1232  open(CG, ">$filename");
1233  printf CG ("events: Hits\n\n");
1234  foreach my $call ( map { $_->[0] }
1235                     sort { $a->[1] cmp $b ->[1] ||
1236                            $a->[2] <=> $b->[2] }
1237                     map { /([^:]+):(\d+):([^ ]+)( -> ([^:]+):(\d+):(.+))?/;
1238                           [$_, $1, $2] }
1239                     keys %$calls ) {
1240    my $count = int($calls->{$call});
1241    $call =~ /([^:]+):(\d+):([^ ]+)( -> ([^:]+):(\d+):(.+))?/;
1242    my ( $caller_file, $caller_line, $caller_function,
1243         $callee_file, $callee_line, $callee_function ) =
1244       ( $1, $2, $3, $5, $6, $7 );
1245
1246    # TODO(csilvers): for better compression, collect all the
1247    # caller/callee_files and functions first, before printing
1248    # anything, and only compress those referenced more than once.
1249    printf CG CompressedCGName("fl", $caller_file, \%filename_to_index_map);
1250    printf CG CompressedCGName("fn", $caller_function, \%fnname_to_index_map);
1251    if (defined $6) {
1252      printf CG CompressedCGName("cfl", $callee_file, \%filename_to_index_map);
1253      printf CG CompressedCGName("cfn", $callee_function, \%fnname_to_index_map);
1254      printf CG ("calls=$count $callee_line\n");
1255    }
1256    printf CG ("$caller_line $count\n\n");
1257  }
1258}
1259
1260# Print disassembly for all all routines that match $main::opt_disasm
1261sub PrintDisassembly {
1262  my $libs = shift;
1263  my $flat = shift;
1264  my $cumulative = shift;
1265  my $disasm_opts = shift;
1266
1267  my $total = TotalProfile($flat);
1268
1269  foreach my $lib (@{$libs}) {
1270    my $symbol_table = GetProcedureBoundaries($lib->[0], $disasm_opts);
1271    my $offset = AddressSub($lib->[1], $lib->[3]);
1272    foreach my $routine (sort ByName keys(%{$symbol_table})) {
1273      my $start_addr = $symbol_table->{$routine}->[0];
1274      my $end_addr = $symbol_table->{$routine}->[1];
1275      # See if there are any samples in this routine
1276      my $length = hex(AddressSub($end_addr, $start_addr));
1277      my $addr = AddressAdd($start_addr, $offset);
1278      for (my $i = 0; $i < $length; $i++) {
1279        if (defined($cumulative->{$addr})) {
1280          PrintDisassembledFunction($lib->[0], $offset,
1281                                    $routine, $flat, $cumulative,
1282                                    $start_addr, $end_addr, $total);
1283          last;
1284        }
1285        $addr = AddressInc($addr);
1286      }
1287    }
1288  }
1289}
1290
1291# Return reference to array of tuples of the form:
1292#       [start_address, filename, linenumber, instruction, limit_address]
1293# E.g.,
1294#       ["0x806c43d", "/foo/bar.cc", 131, "ret", "0x806c440"]
1295sub Disassemble {
1296  my $prog = shift;
1297  my $offset = shift;
1298  my $start_addr = shift;
1299  my $end_addr = shift;
1300
1301  my $objdump = $obj_tool_map{"objdump"};
1302  my $cmd = ShellEscape($objdump, "-C", "-d", "-l", "--no-show-raw-insn",
1303                        "--start-address=0x$start_addr",
1304                        "--stop-address=0x$end_addr", $prog);
1305  open(OBJDUMP, "$cmd |") || error("$cmd: $!\n");
1306  my @result = ();
1307  my $filename = "";
1308  my $linenumber = -1;
1309  my $last = ["", "", "", ""];
1310  while (<OBJDUMP>) {
1311    s/\r//g;         # turn windows-looking lines into unix-looking lines
1312    chop;
1313    if (m|\s*([^:\s]+):(\d+)\s*$|) {
1314      # Location line of the form:
1315      #   <filename>:<linenumber>
1316      $filename = $1;
1317      $linenumber = $2;
1318    } elsif (m/^ +([0-9a-f]+):\s*(.*)/) {
1319      # Disassembly line -- zero-extend address to full length
1320      my $addr = HexExtend($1);
1321      my $k = AddressAdd($addr, $offset);
1322      $last->[4] = $k;   # Store ending address for previous instruction
1323      $last = [$k, $filename, $linenumber, $2, $end_addr];
1324      push(@result, $last);
1325    }
1326  }
1327  close(OBJDUMP);
1328  return @result;
1329}
1330
1331# The input file should contain lines of the form /proc/maps-like
1332# output (same format as expected from the profiles) or that looks
1333# like hex addresses (like "0xDEADBEEF").  We will parse all
1334# /proc/maps output, and for all the hex addresses, we will output
1335# "short" symbol names, one per line, in the same order as the input.
1336sub PrintSymbols {
1337  my $maps_and_symbols_file = shift;
1338
1339  # ParseLibraries expects pcs to be in a set.  Fine by us...
1340  my @pclist = ();   # pcs in sorted order
1341  my $pcs = {};
1342  my $map = "";
1343  foreach my $line (<$maps_and_symbols_file>) {
1344    $line =~ s/\r//g;    # turn windows-looking lines into unix-looking lines
1345    if ($line =~ /\b(0x[0-9a-f]+)\b/i) {
1346      push(@pclist, HexExtend($1));
1347      $pcs->{$pclist[-1]} = 1;
1348    } else {
1349      $map .= $line;
1350    }
1351  }
1352
1353  my $libs = ParseLibraries($main::prog, $map, $pcs);
1354  my $symbols = ExtractSymbols($libs, $pcs);
1355
1356  foreach my $pc (@pclist) {
1357    # ->[0] is the shortname, ->[2] is the full name
1358    print(($symbols->{$pc}->[0] || "??") . "\n");
1359  }
1360}
1361
1362
1363# For sorting functions by name
1364sub ByName {
1365  return ShortFunctionName($a) cmp ShortFunctionName($b);
1366}
1367
1368# Print source-listing for all all routines that match $list_opts
1369sub PrintListing {
1370  my $total = shift;
1371  my $libs = shift;
1372  my $flat = shift;
1373  my $cumulative = shift;
1374  my $list_opts = shift;
1375  my $html = shift;
1376
1377  my $output = \*STDOUT;
1378  my $fname = "";
1379
1380  if ($html) {
1381    # Arrange to write the output to a temporary file
1382    $fname = TempName($main::next_tmpfile, "html");
1383    $main::next_tmpfile++;
1384    if (!open(TEMP, ">$fname")) {
1385      print STDERR "$fname: $!\n";
1386      return;
1387    }
1388    $output = \*TEMP;
1389    print $output HtmlListingHeader();
1390    printf $output ("<div class=\"legend\">%s<br>Total: %s %s</div>\n",
1391                    $main::prog, Unparse($total), Units());
1392  }
1393
1394  my $listed = 0;
1395  foreach my $lib (@{$libs}) {
1396    my $symbol_table = GetProcedureBoundaries($lib->[0], $list_opts);
1397    my $offset = AddressSub($lib->[1], $lib->[3]);
1398    foreach my $routine (sort ByName keys(%{$symbol_table})) {
1399      # Print if there are any samples in this routine
1400      my $start_addr = $symbol_table->{$routine}->[0];
1401      my $end_addr = $symbol_table->{$routine}->[1];
1402      my $length = hex(AddressSub($end_addr, $start_addr));
1403      my $addr = AddressAdd($start_addr, $offset);
1404      for (my $i = 0; $i < $length; $i++) {
1405        if (defined($cumulative->{$addr})) {
1406          $listed += PrintSource(
1407            $lib->[0], $offset,
1408            $routine, $flat, $cumulative,
1409            $start_addr, $end_addr,
1410            $html,
1411            $output);
1412          last;
1413        }
1414        $addr = AddressInc($addr);
1415      }
1416    }
1417  }
1418
1419  if ($html) {
1420    if ($listed > 0) {
1421      print $output HtmlListingFooter();
1422      close($output);
1423      RunWeb($fname);
1424    } else {
1425      close($output);
1426      unlink($fname);
1427    }
1428  }
1429}
1430
1431sub HtmlListingHeader {
1432  return <<'EOF';
1433<DOCTYPE html>
1434<html>
1435<head>
1436<title>Pprof listing</title>
1437<style type="text/css">
1438body {
1439  font-family: sans-serif;
1440}
1441h1 {
1442  font-size: 1.5em;
1443  margin-bottom: 4px;
1444}
1445.legend {
1446  font-size: 1.25em;
1447}
1448.line {
1449  color: #aaaaaa;
1450}
1451.nop {
1452  color: #aaaaaa;
1453}
1454.unimportant {
1455  color: #cccccc;
1456}
1457.disasmloc {
1458  color: #000000;
1459}
1460.deadsrc {
1461  cursor: pointer;
1462}
1463.deadsrc:hover {
1464  background-color: #eeeeee;
1465}
1466.livesrc {
1467  color: #0000ff;
1468  cursor: pointer;
1469}
1470.livesrc:hover {
1471  background-color: #eeeeee;
1472}
1473.asm {
1474  color: #008800;
1475  display: none;
1476}
1477</style>
1478<script type="text/javascript">
1479function pprof_toggle_asm(e) {
1480  var target;
1481  if (!e) e = window.event;
1482  if (e.target) target = e.target;
1483  else if (e.srcElement) target = e.srcElement;
1484
1485  if (target) {
1486    var asm = target.nextSibling;
1487    if (asm && asm.className == "asm") {
1488      asm.style.display = (asm.style.display == "block" ? "" : "block");
1489      e.preventDefault();
1490      return false;
1491    }
1492  }
1493}
1494</script>
1495</head>
1496<body>
1497EOF
1498}
1499
1500sub HtmlListingFooter {
1501  return <<'EOF';
1502</body>
1503</html>
1504EOF
1505}
1506
1507sub HtmlEscape {
1508  my $text = shift;
1509  $text =~ s/&/&amp;/g;
1510  $text =~ s/</&lt;/g;
1511  $text =~ s/>/&gt;/g;
1512  return $text;
1513}
1514
1515# Returns the indentation of the line, if it has any non-whitespace
1516# characters.  Otherwise, returns -1.
1517sub Indentation {
1518  my $line = shift;
1519  if (m/^(\s*)\S/) {
1520    return length($1);
1521  } else {
1522    return -1;
1523  }
1524}
1525
1526# If the symbol table contains inlining info, Disassemble() may tag an
1527# instruction with a location inside an inlined function.  But for
1528# source listings, we prefer to use the location in the function we
1529# are listing.  So use MapToSymbols() to fetch full location
1530# information for each instruction and then pick out the first
1531# location from a location list (location list contains callers before
1532# callees in case of inlining).
1533#
1534# After this routine has run, each entry in $instructions contains:
1535#   [0] start address
1536#   [1] filename for function we are listing
1537#   [2] line number for function we are listing
1538#   [3] disassembly
1539#   [4] limit address
1540#   [5] most specific filename (may be different from [1] due to inlining)
1541#   [6] most specific line number (may be different from [2] due to inlining)
1542sub GetTopLevelLineNumbers {
1543  my ($lib, $offset, $instructions) = @_;
1544  my $pcs = [];
1545  for (my $i = 0; $i <= $#{$instructions}; $i++) {
1546    push(@{$pcs}, $instructions->[$i]->[0]);
1547  }
1548  my $symbols = {};
1549  MapToSymbols($lib, $offset, $pcs, $symbols);
1550  for (my $i = 0; $i <= $#{$instructions}; $i++) {
1551    my $e = $instructions->[$i];
1552    push(@{$e}, $e->[1]);
1553    push(@{$e}, $e->[2]);
1554    my $addr = $e->[0];
1555    my $sym = $symbols->{$addr};
1556    if (defined($sym)) {
1557      if ($#{$sym} >= 2 && $sym->[1] =~ m/^(.*):(\d+)$/) {
1558        $e->[1] = $1;  # File name
1559        $e->[2] = $2;  # Line number
1560      }
1561    }
1562  }
1563}
1564
1565# Print source-listing for one routine
1566sub PrintSource {
1567  my $prog = shift;
1568  my $offset = shift;
1569  my $routine = shift;
1570  my $flat = shift;
1571  my $cumulative = shift;
1572  my $start_addr = shift;
1573  my $end_addr = shift;
1574  my $html = shift;
1575  my $output = shift;
1576
1577  # Disassemble all instructions (just to get line numbers)
1578  my @instructions = Disassemble($prog, $offset, $start_addr, $end_addr);
1579  GetTopLevelLineNumbers($prog, $offset, \@instructions);
1580
1581  # Hack 1: assume that the first source file encountered in the
1582  # disassembly contains the routine
1583  my $filename = undef;
1584  for (my $i = 0; $i <= $#instructions; $i++) {
1585    if ($instructions[$i]->[2] >= 0) {
1586      $filename = $instructions[$i]->[1];
1587      last;
1588    }
1589  }
1590  if (!defined($filename)) {
1591    print STDERR "no filename found in $routine\n";
1592    return 0;
1593  }
1594
1595  # Hack 2: assume that the largest line number from $filename is the
1596  # end of the procedure.  This is typically safe since if P1 contains
1597  # an inlined call to P2, then P2 usually occurs earlier in the
1598  # source file.  If this does not work, we might have to compute a
1599  # density profile or just print all regions we find.
1600  my $lastline = 0;
1601  for (my $i = 0; $i <= $#instructions; $i++) {
1602    my $f = $instructions[$i]->[1];
1603    my $l = $instructions[$i]->[2];
1604    if (($f eq $filename) && ($l > $lastline)) {
1605      $lastline = $l;
1606    }
1607  }
1608
1609  # Hack 3: assume the first source location from "filename" is the start of
1610  # the source code.
1611  my $firstline = 1;
1612  for (my $i = 0; $i <= $#instructions; $i++) {
1613    if ($instructions[$i]->[1] eq $filename) {
1614      $firstline = $instructions[$i]->[2];
1615      last;
1616    }
1617  }
1618
1619  # Hack 4: Extend last line forward until its indentation is less than
1620  # the indentation we saw on $firstline
1621  my $oldlastline = $lastline;
1622  {
1623    if (!open(FILE, "<$filename")) {
1624      print STDERR "$filename: $!\n";
1625      return 0;
1626    }
1627    my $l = 0;
1628    my $first_indentation = -1;
1629    while (<FILE>) {
1630      s/\r//g;         # turn windows-looking lines into unix-looking lines
1631      $l++;
1632      my $indent = Indentation($_);
1633      if ($l >= $firstline) {
1634        if ($first_indentation < 0 && $indent >= 0) {
1635          $first_indentation = $indent;
1636          last if ($first_indentation == 0);
1637        }
1638      }
1639      if ($l >= $lastline && $indent >= 0) {
1640        if ($indent >= $first_indentation) {
1641          $lastline = $l+1;
1642        } else {
1643          last;
1644        }
1645      }
1646    }
1647    close(FILE);
1648  }
1649
1650  # Assign all samples to the range $firstline,$lastline,
1651  # Hack 4: If an instruction does not occur in the range, its samples
1652  # are moved to the next instruction that occurs in the range.
1653  my $samples1 = {};        # Map from line number to flat count
1654  my $samples2 = {};        # Map from line number to cumulative count
1655  my $running1 = 0;         # Unassigned flat counts
1656  my $running2 = 0;         # Unassigned cumulative counts
1657  my $total1 = 0;           # Total flat counts
1658  my $total2 = 0;           # Total cumulative counts
1659  my %disasm = ();          # Map from line number to disassembly
1660  my $running_disasm = "";  # Unassigned disassembly
1661  my $skip_marker = "---\n";
1662  if ($html) {
1663    $skip_marker = "";
1664    for (my $l = $firstline; $l <= $lastline; $l++) {
1665      $disasm{$l} = "";
1666    }
1667  }
1668  my $last_dis_filename = '';
1669  my $last_dis_linenum = -1;
1670  my $last_touched_line = -1;  # To detect gaps in disassembly for a line
1671  foreach my $e (@instructions) {
1672    # Add up counts for all address that fall inside this instruction
1673    my $c1 = 0;
1674    my $c2 = 0;
1675    for (my $a = $e->[0]; $a lt $e->[4]; $a = AddressInc($a)) {
1676      $c1 += GetEntry($flat, $a);
1677      $c2 += GetEntry($cumulative, $a);
1678    }
1679
1680    if ($html) {
1681      my $dis = sprintf("      %6s %6s \t\t%8s: %s ",
1682                        HtmlPrintNumber($c1),
1683                        HtmlPrintNumber($c2),
1684                        UnparseAddress($offset, $e->[0]),
1685                        CleanDisassembly($e->[3]));
1686      
1687      # Append the most specific source line associated with this instruction
1688      if (length($dis) < 80) { $dis .= (' ' x (80 - length($dis))) };
1689      $dis = HtmlEscape($dis);
1690      my $f = $e->[5];
1691      my $l = $e->[6];
1692      if ($f ne $last_dis_filename) {
1693        $dis .= sprintf("<span class=disasmloc>%s:%d</span>", 
1694                        HtmlEscape(CleanFileName($f)), $l);
1695      } elsif ($l ne $last_dis_linenum) {
1696        # De-emphasize the unchanged file name portion
1697        $dis .= sprintf("<span class=unimportant>%s</span>" .
1698                        "<span class=disasmloc>:%d</span>", 
1699                        HtmlEscape(CleanFileName($f)), $l);
1700      } else {
1701        # De-emphasize the entire location
1702        $dis .= sprintf("<span class=unimportant>%s:%d</span>", 
1703                        HtmlEscape(CleanFileName($f)), $l);
1704      }
1705      $last_dis_filename = $f;
1706      $last_dis_linenum = $l;
1707      $running_disasm .= $dis;
1708      $running_disasm .= "\n";
1709    }
1710
1711    $running1 += $c1;
1712    $running2 += $c2;
1713    $total1 += $c1;
1714    $total2 += $c2;
1715    my $file = $e->[1];
1716    my $line = $e->[2];
1717    if (($file eq $filename) &&
1718        ($line >= $firstline) &&
1719        ($line <= $lastline)) {
1720      # Assign all accumulated samples to this line
1721      AddEntry($samples1, $line, $running1);
1722      AddEntry($samples2, $line, $running2);
1723      $running1 = 0;
1724      $running2 = 0;
1725      if ($html) {
1726        if ($line != $last_touched_line && $disasm{$line} ne '') {
1727          $disasm{$line} .= "\n";
1728        }
1729        $disasm{$line} .= $running_disasm;
1730        $running_disasm = '';
1731        $last_touched_line = $line;
1732      }
1733    }
1734  }
1735
1736  # Assign any leftover samples to $lastline
1737  AddEntry($samples1, $lastline, $running1);
1738  AddEntry($samples2, $lastline, $running2);
1739  if ($html) {
1740    if ($lastline != $last_touched_line && $disasm{$lastline} ne '') {
1741      $disasm{$lastline} .= "\n";
1742    }
1743    $disasm{$lastline} .= $running_disasm;
1744  }
1745
1746  if ($html) {
1747    printf $output (
1748      "<h1>%s</h1>%s\n<pre onClick=\"pprof_toggle_asm()\">\n" .
1749      "Total:%6s %6s (flat / cumulative %s)\n",
1750      HtmlEscape(ShortFunctionName($routine)),
1751      HtmlEscape(CleanFileName($filename)),
1752      Unparse($total1),
1753      Unparse($total2),
1754      Units());
1755  } else {
1756    printf $output (
1757      "ROUTINE ====================== %s in %s\n" .
1758      "%6s %6s Total %s (flat / cumulative)\n",
1759      ShortFunctionName($routine),
1760      CleanFileName($filename),
1761      Unparse($total1),
1762      Unparse($total2),
1763      Units());
1764  }
1765  if (!open(FILE, "<$filename")) {
1766    print STDERR "$filename: $!\n";
1767    return 0;
1768  }
1769  my $l = 0;
1770  while (<FILE>) {
1771    s/\r//g;         # turn windows-looking lines into unix-looking lines
1772    $l++;
1773    if ($l >= $firstline - 5 &&
1774        (($l <= $oldlastline + 5) || ($l <= $lastline))) {
1775      chop;
1776      my $text = $_;
1777      if ($l == $firstline) { print $output $skip_marker; }
1778      my $n1 = GetEntry($samples1, $l);
1779      my $n2 = GetEntry($samples2, $l);
1780      if ($html) {
1781        # Emit a span that has one of the following classes:
1782        #    livesrc -- has samples
1783        #    deadsrc -- has disassembly, but with no samples
1784        #    nop     -- has no matching disasembly
1785        # Also emit an optional span containing disassembly.
1786        my $dis = $disasm{$l};
1787        my $asm = "";
1788        if (defined($dis) && $dis ne '') {
1789          $asm = "<span class=\"asm\">" . $dis . "</span>";
1790        }
1791        my $source_class = (($n1 + $n2 > 0) 
1792                            ? "livesrc" 
1793                            : (($asm ne "") ? "deadsrc" : "nop"));
1794        printf $output (
1795          "<span class=\"line\">%5d</span> " .
1796          "<span class=\"%s\">%6s %6s %s</span>%s\n",
1797          $l, $source_class,
1798          HtmlPrintNumber($n1),
1799          HtmlPrintNumber($n2),
1800          HtmlEscape($text),
1801          $asm);
1802      } else {
1803        printf $output(
1804          "%6s %6s %4d: %s\n",
1805          UnparseAlt($n1),
1806          UnparseAlt($n2),
1807          $l,
1808          $text);
1809      }
1810      if ($l == $lastline)  { print $output $skip_marker; }
1811    };
1812  }
1813  close(FILE);
1814  if ($html) {
1815    print $output "</pre>\n";
1816  }
1817  return 1;
1818}
1819
1820# Return the source line for the specified file/linenumber.
1821# Returns undef if not found.
1822sub SourceLine {
1823  my $file = shift;
1824  my $line = shift;
1825
1826  # Look in cache
1827  if (!defined($main::source_cache{$file})) {
1828    if (100 < scalar keys(%main::source_cache)) {
1829      # Clear the cache when it gets too big
1830      $main::source_cache = ();
1831    }
1832
1833    # Read all lines from the file
1834    if (!open(FILE, "<$file")) {
1835      print STDERR "$file: $!\n";
1836      $main::source_cache{$file} = [];  # Cache the negative result
1837      return undef;
1838    }
1839    my $lines = [];
1840    push(@{$lines}, "");        # So we can use 1-based line numbers as indices
1841    while (<FILE>) {
1842      push(@{$lines}, $_);
1843    }
1844    close(FILE);
1845
1846    # Save the lines in the cache
1847    $main::source_cache{$file} = $lines;
1848  }
1849
1850  my $lines = $main::source_cache{$file};
1851  if (($line < 0) || ($line > $#{$lines})) {
1852    return undef;
1853  } else {
1854    return $lines->[$line];
1855  }
1856}
1857
1858# Print disassembly for one routine with interspersed source if available
1859sub PrintDisassembledFunction {
1860  my $prog = shift;
1861  my $offset = shift;
1862  my $routine = shift;
1863  my $flat = shift;
1864  my $cumulative = shift;
1865  my $start_addr = shift;
1866  my $end_addr = shift;
1867  my $total = shift;
1868
1869  # Disassemble all instructions
1870  my @instructions = Disassemble($prog, $offset, $start_addr, $end_addr);
1871
1872  # Make array of counts per instruction
1873  my @flat_count = ();
1874  my @cum_count = ();
1875  my $flat_total = 0;
1876  my $cum_total = 0;
1877  foreach my $e (@instructions) {
1878    # Add up counts for all address that fall inside this instruction
1879    my $c1 = 0;
1880    my $c2 = 0;
1881    for (my $a = $e->[0]; $a lt $e->[4]; $a = AddressInc($a)) {
1882      $c1 += GetEntry($flat, $a);
1883      $c2 += GetEntry($cumulative, $a);
1884    }
1885    push(@flat_count, $c1);
1886    push(@cum_count, $c2);
1887    $flat_total += $c1;
1888    $cum_total += $c2;
1889  }
1890
1891  # Print header with total counts
1892  printf("ROUTINE ====================== %s\n" .
1893         "%6s %6s %s (flat, cumulative) %.1f%% of total\n",
1894         ShortFunctionName($routine),
1895         Unparse($flat_total),
1896         Unparse($cum_total),
1897         Units(),
1898         ($cum_total * 100.0) / $total);
1899
1900  # Process instructions in order
1901  my $current_file = "";
1902  for (my $i = 0; $i <= $#instructions; ) {
1903    my $e = $instructions[$i];
1904
1905    # Print the new file name whenever we switch files
1906    if ($e->[1] ne $current_file) {
1907      $current_file = $e->[1];
1908      my $fname = $current_file;
1909      $fname =~ s|^\./||;   # Trim leading "./"
1910
1911      # Shorten long file names
1912      if (length($fname) >= 58) {
1913        $fname = "..." . substr($fname, -55);
1914      }
1915      printf("-------------------- %s\n", $fname);
1916    }
1917
1918    # TODO: Compute range of lines to print together to deal with
1919    # small reorderings.
1920    my $first_line = $e->[2];
1921    my $last_line = $first_line;
1922    my %flat_sum = ();
1923    my %cum_sum = ();
1924    for (my $l = $first_line; $l <= $last_line; $l++) {
1925      $flat_sum{$l} = 0;
1926      $cum_sum{$l} = 0;
1927    }
1928
1929    # Find run of instructions for this range of source lines
1930    my $first_inst = $i;
1931    while (($i <= $#instructions) &&
1932           ($instructions[$i]->[2] >= $first_line) &&
1933           ($instructions[$i]->[2] <= $last_line)) {
1934      $e = $instructions[$i];
1935      $flat_sum{$e->[2]} += $flat_count[$i];
1936      $cum_sum{$e->[2]} += $cum_count[$i];
1937      $i++;
1938    }
1939    my $last_inst = $i - 1;
1940
1941    # Print source lines
1942    for (my $l = $first_line; $l <= $last_line; $l++) {
1943      my $line = SourceLine($current_file, $l);
1944      if (!defined($line)) {
1945        $line = "?\n";
1946        next;
1947      } else {
1948        $line =~ s/^\s+//;
1949      }
1950      printf("%6s %6s %5d: %s",
1951             UnparseAlt($flat_sum{$l}),
1952             UnparseAlt($cum_sum{$l}),
1953             $l,
1954             $line);
1955    }
1956
1957    # Print disassembly
1958    for (my $x = $first_inst; $x <= $last_inst; $x++) {
1959      my $e = $instructions[$x];
1960      printf("%6s %6s    %8s: %6s\n",
1961             UnparseAlt($flat_count[$x]),
1962             UnparseAlt($cum_count[$x]),
1963             UnparseAddress($offset, $e->[0]),
1964             CleanDisassembly($e->[3]));
1965    }
1966  }
1967}
1968
1969# Print DOT graph
1970sub PrintDot {
1971  my $prog = shift;
1972  my $symbols = shift;
1973  my $raw = shift;
1974  my $flat = shift;
1975  my $cumulative = shift;
1976  my $overall_total = shift;
1977
1978  # Get total
1979  my $local_total = TotalProfile($flat);
1980  my $nodelimit = int($main::opt_nodefraction * $local_total);
1981  my $edgelimit = int($main::opt_edgefraction * $local_total);
1982  my $nodecount = $main::opt_nodecount;
1983
1984  # Find nodes to include
1985  my @list = (sort { abs(GetEntry($cumulative, $b)) <=>
1986                     abs(GetEntry($cumulative, $a))
1987                     || $a cmp $b }
1988              keys(%{$cumulative}));
1989  my $last = $nodecount - 1;
1990  if ($last > $#list) {
1991    $last = $#list;
1992  }
1993  while (($last >= 0) &&
1994         (abs(GetEntry($cumulative, $list[$last])) <= $nodelimit)) {
1995    $last--;
1996  }
1997  if ($last < 0) {
1998    print STDERR "No nodes to print\n";
1999    return 0;
2000  }
2001
2002  if ($nodelimit > 0 || $edgelimit > 0) {
2003    printf STDERR ("Dropping nodes with <= %s %s; edges with <= %s abs(%s)\n",
2004                   Unparse($nodelimit), Units(),
2005                   Unparse($edgelimit), Units());
2006  }
2007
2008  # Open DOT output file
2009  my $output;
2010  my $escaped_dot = ShellEscape(@DOT);
2011  my $escaped_ps2pdf = ShellEscape(@PS2PDF);
2012  if ($main::opt_gv) {
2013    my $escaped_outfile = ShellEscape(TempName($main::next_tmpfile, "ps"));
2014    $output = "| $escaped_dot -Tps2 >$escaped_outfile";
2015  } elsif ($main::opt_evince) {
2016    my $escaped_outfile = ShellEscape(TempName($main::next_tmpfile, "pdf"));
2017    $output = "| $escaped_dot -Tps2 | $escaped_ps2pdf - $escaped_outfile";
2018  } elsif ($main::opt_ps) {
2019    $output = "| $escaped_dot -Tps2";
2020  } elsif ($main::opt_pdf) {
2021    $output = "| $escaped_dot -Tps2 | $escaped_ps2pdf - -";
2022  } elsif ($main::opt_web || $main::opt_svg) {
2023    # We need to post-process the SVG, so write to a temporary file always.
2024    my $escaped_outfile = ShellEscape(TempName($main::next_tmpfile, "svg"));
2025    $output = "| $escaped_dot -Tsvg >$escaped_outfile";
2026  } elsif ($main::opt_gif) {
2027    $output = "| $escaped_dot -Tgif";
2028  } else {
2029    $output = ">&STDOUT";
2030  }
2031  open(DOT, $output) || error("$output: $!\n");
2032
2033  # Title
2034  printf DOT ("digraph \"%s; %s %s\" {\n",
2035              $prog,
2036              Unparse($overall_total),
2037              Units());
2038  if ($main::opt_pdf) {
2039    # The output is more printable if we set the page size for dot.
2040    printf DOT ("size=\"8,11\"\n");
2041  }
2042  printf DOT ("node [width=0.375,height=0.25];\n");
2043
2044  # Print legend
2045  printf DOT ("Legend [shape=box,fontsize=24,shape=plaintext," .
2046              "label=\"%s\\l%s\\l%s\\l%s\\l%s\\l\"];\n",
2047              $prog,
2048              sprintf("Total %s: %s", Units(), Unparse($overall_total)),
2049              sprintf("Focusing on: %s", Unparse($local_total)),
2050              sprintf("Dropped nodes with <= %s abs(%s)",
2051                      Unparse($nodelimit), Units()),
2052              sprintf("Dropped edges with <= %s %s",
2053                      Unparse($edgelimit), Units())
2054              );
2055
2056  # Print nodes
2057  my %node = ();
2058  my $nextnode = 1;
2059  foreach my $a (@list[0..$last]) {
2060    # Pick font size
2061    my $f = GetEntry($flat, $a);
2062    my $c = GetEntry($cumulative, $a);
2063
2064    my $fs = 8;
2065    if ($local_total > 0) {
2066      $fs = 8 + (50.0 * sqrt(abs($f * 1.0 / $local_total)));
2067    }
2068
2069    $node{$a} = $nextnode++;
2070    my $sym = $a;
2071    $sym =~ s/\s+/\\n/g;
2072    $sym =~ s/::/\\n/g;
2073
2074    # Extra cumulative info to print for non-leaves
2075    my $extra = "";
2076    if ($f != $c) {
2077      $extra = sprintf("\\rof %s (%s)",
2078                       Unparse($c),
2079                       Percent($c, $local_total));
2080    }
2081    my $style = "";
2082    if ($main::opt_heapcheck) {
2083      if ($f > 0) {
2084        # make leak-causing nodes more visible (add a background)
2085        $style = ",style=filled,fillcolor=gray"
2086      } elsif ($f < 0) {
2087        # make anti-leak-causing nodes (which almost never occur)
2088        # stand out as well (triple border)
2089        $style = ",peripheries=3"
2090      }
2091    }
2092
2093    printf DOT ("N%d [label=\"%s\\n%s (%s)%s\\r" .
2094                "\",shape=box,fontsize=%.1f%s];\n",
2095                $node{$a},
2096                $sym,
2097                Unparse($f),
2098                Percent($f, $local_total),
2099                $extra,
2100                $fs,
2101                $style,
2102               );
2103  }
2104
2105  # Get edges and counts per edge
2106  my %edge = ();
2107  my $n;
2108  my $fullname_to_shortname_map = {};
2109  FillFullnameToShortnameMap($symbols, $fullname_to_shortname_map);
2110  foreach my $k (keys(%{$raw})) {
2111    # TODO: omit low %age edges
2112    $n = $raw->{$k};
2113    my @translated = TranslateStack($symbols, $fullname_to_shortname_map, $k);
2114    for (my $i = 1; $i <= $#translated; $i++) {
2115      my $src = $translated[$i];
2116      my $dst = $translated[$i-1];
2117      #next if ($src eq $dst);  # Avoid self-edges?
2118      if (exists($node{$src}) && exists($node{$dst})) {
2119        my $edge_label = "$src\001$dst";
2120        if (!exists($edge{$edge_label})) {
2121          $edge{$edge_label} = 0;
2122        }
2123        $edge{$edge_label} += $n;
2124      }
2125    }
2126  }
2127
2128  # Print edges (process in order of decreasing counts)
2129  my %indegree = ();   # Number of incoming edges added per node so far
2130  my %outdegree = ();  # Number of outgoing edges added per node so far
2131  foreach my $e (sort { $edge{$b} <=> $edge{$a} } keys(%edge)) {
2132    my @x = split(/\001/, $e);
2133    $n = $edge{$e};
2134
2135    # Initialize degree of kept incoming and outgoing edges if necessary
2136    my $src = $x[0];
2137    my $dst = $x[1];
2138    if (!exists($outdegree{$src})) { $outdegree{$src} = 0; }
2139    if (!exists($indegree{$dst})) { $indegree{$dst} = 0; }
2140
2141    my $keep;
2142    if ($indegree{$dst} == 0) {
2143      # Keep edge if needed for reachability
2144      $keep = 1;
2145    } elsif (abs($n) <= $edgelimit) {
2146      # Drop if we are below --edgefraction
2147      $keep = 0;
2148    } elsif ($outdegree{$src} >= $main::opt_maxdegree ||
2149             $indegree{$dst} >= $main::opt_maxdegree) {
2150      # Keep limited number of in/out edges per node
2151      $keep = 0;
2152    } else {
2153      $keep = 1;
2154    }
2155
2156    if ($keep) {
2157      $outdegree{$src}++;
2158      $indegree{$dst}++;
2159
2160      # Compute line width based on edge count
2161      my $fraction = abs($local_total ? (3 * ($n / $local_total)) : 0);
2162      if ($fraction > 1) { $fraction = 1; }
2163      my $w = $fraction * 2;
2164      if ($w < 1 && ($main::opt_web || $main::opt_svg)) {
2165        # SVG output treats line widths < 1 poorly.
2166        $w = 1;
2167      }
2168
2169      # Dot sometimes segfaults if given edge weights that are too large, so
2170      # we cap the weights at a large value
2171      my $edgeweight = abs($n) ** 0.7;
2172      if ($edgeweight > 100000) { $edgeweight = 100000; }
2173      $edgeweight = int($edgeweight);
2174
2175      my $style = sprintf("setlinewidth(%f)", $w);
2176      if ($x[1] =~ m/\(inline\)/) {
2177        $style .= ",dashed";
2178      }
2179
2180      # Use a slightly squashed function of the edge count as the weight
2181      printf DOT ("N%s -> N%s [label=%s, weight=%d, style=\"%s\"];\n",
2182                  $node{$x[0]},
2183                  $node{$x[1]},
2184                  Unparse($n),
2185                  $edgeweight,
2186                  $style);
2187    }
2188  }
2189
2190  print DOT ("}\n");
2191  close(DOT);
2192
2193  if ($main::opt_web || $main::opt_svg) {
2194    # Rewrite SVG to be more usable inside web browser.
2195    RewriteSvg(TempName($main::next_tmpfile, "svg"));
2196  }
2197
2198  return 1;
2199}
2200
2201sub RewriteSvg {
2202  my $svgfile = shift;
2203
2204  open(SVG, $svgfile) || die "open temp svg: $!";
2205  my @svg = <SVG>;
2206  close(SVG);
2207  unlink $svgfile;
2208  my $svg = join('', @svg);
2209
2210  # Dot's SVG output is
2211  #
2212  #    <svg width="___" height="___"
2213  #     viewBox="___" xmlns=...>
2214  #    <g id="graph0" transform="...">
2215  #    ...
2216  #    </g>
2217  #    </svg>
2218  #
2219  # Change it to
2220  #
2221  #    <svg width="100%" height="100%"
2222  #     xmlns=...>
2223  #    $svg_javascript
2224  #    <g id="viewport" transform="translate(0,0)">
2225  #    <g id="graph0" transform="...">
2226  #    ...
2227  #    </g>
2228  #    </g>
2229  #    </svg>
2230
2231  # Fix width, height; drop viewBox.
2232  $svg =~ s/(?s)<svg width="[^"]+" height="[^"]+"(.*?)viewBox="[^"]+"/<svg width="100%" height="100%"$1/;
2233
2234  # Insert script, viewport <g> above first <g>
2235  my $svg_javascript = SvgJavascript();
2236  my $viewport = "<g id=\"viewport\" transform=\"translate(0,0)\">\n";
2237  $svg =~ s/<g id="graph\d"/$svg_javascript$viewport$&/;
2238
2239  # Insert final </g> above </svg>.
2240  $svg =~ s/(.*)(<\/svg>)/$1<\/g>$2/;
2241  $svg =~ s/<g id="graph\d"(.*?)/<g id="viewport"$1/;
2242
2243  if ($main::opt_svg) {
2244    # --svg: write to standard output.
2245    print $svg;
2246  } else {
2247    # Write back to temporary file.
2248    open(SVG, ">$svgfile") || die "open $svgfile: $!";
2249    print SVG $svg;
2250    close(SVG);
2251  }
2252}
2253
2254sub SvgJavascript {
2255  return <<'EOF';
2256<script type="text/ecmascript"><![CDATA[
2257// SVGPan
2258// http://www.cyberz.org/blog/2009/12/08/svgpan-a-javascript-svg-panzoomdrag-library/
2259// Local modification: if(true || ...) below to force panning, never moving.
2260
2261/**
2262 *  SVGPan library 1.2
2263 * ====================
2264 *
2265 * Given an unique existing element with id "viewport", including the
2266 * the library into any SVG adds the following capabilities:
2267 *
2268 *  - Mouse panning
2269 *  - Mouse zooming (using the wheel)
2270 *  - Object dargging
2271 *
2272 * Known issues:
2273 *
2274 *  - Zooming (while panning) on Safari has still some issues
2275 *
2276 * Releases:
2277 *
2278 * 1.2, Sat Mar 20 08:42:50 GMT 2010, Zeng Xiaohui
2279 *	Fixed a bug with browser mouse handler interaction
2280 *
2281 * 1.1, Wed Feb  3 17:39:33 GMT 2010, Zeng Xiaohui
2282 *	Updated the zoom code to support the mouse wheel on Safari/Chrome
2283 *
2284 * 1.0, Andrea Leofreddi
2285 *	First release
2286 *
2287 * This code is licensed under the following BSD license:
2288 *
2289 * Copyright 2009-2010 Andrea Leofreddi <a.leofreddi@itcharm.com>. All rights reserved.
2290 *
2291 * Redistribution and use in source and binary forms, with or without modification, are
2292 * permitted provided that the following conditions are met:
2293 *
2294 *    1. Redistributions of source code must retain the above copyright notice, this list of
2295 *       conditions and the following disclaimer.
2296 *
2297 *    2. Redistributions in binary form must reproduce the above copyright notice, this list
2298 *       of conditions and the following disclaimer in the documentation and/or other materials
2299 *       provided with the distribution.
2300 *
2301 * THIS SOFTWARE IS PROVIDED BY Andrea Leofreddi ``AS IS'' AND ANY EXPRESS OR IMPLIED
2302 * WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
2303 * FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL Andrea Leofreddi OR
2304 * CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
2305 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
2306 * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
2307 * ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
2308 * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
2309 * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
2310 *
2311 * The views and conclusions contained in the software and documentation are those of the
2312 * authors and should not be interpreted as representing official policies, either expressed
2313 * or implied, of Andrea Leofreddi.
2314 */
2315
2316var root = document.documentElement;
2317
2318var state = 'none', stateTarget, stateOrigin, stateTf;
2319
2320setupHandlers(root);
2321
2322/**
2323 * Register handlers
2324 */
2325function setupHandlers(root){
2326	setAttributes(root, {
2327		"onmouseup" : "add(evt)",
2328		"onmousedown" : "handleMouseDown(evt)",
2329		"onmousemove" : "handleMouseMove(evt)",
2330		"onmouseup" : "handleMouseUp(evt)",
2331		//"onmouseout" : "handleMouseUp(evt)", // Decomment this to stop the pan functionality when dragging out of the SVG element
2332	});
2333
2334	if(navigator.userAgent.toLowerCase().indexOf('webkit') >= 0)
2335		window.addEventListener('mousewheel', handleMouseWheel, false); // Chrome/Safari
2336	else
2337		window.addEventListener('DOMMouseScroll', handleMouseWheel, false); // Others
2338
2339	var g = svgDoc.getElementById("svg");
2340	g.width = "100%";
2341	g.height = "100%";
2342}
2343
2344/**
2345 * Instance an SVGPoint object with given event coordinates.
2346 */
2347function getEventPoint(evt) {
2348	var p = root.createSVGPoint();
2349
2350	p.x = evt.clientX;
2351	p.y = evt.clientY;
2352
2353	return p;
2354}
2355
2356/**
2357 * Sets the current transform matrix of an element.
2358 */
2359function setCTM(element, matrix) {
2360	var s = "matrix(" + matrix.a + "," + matrix.b + "," + matrix.c + "," + matrix.d + "," + matrix.e + "," + matrix.f + ")";
2361
2362	element.setAttribute("transform", s);
2363}
2364
2365/**
2366 * Dumps a matrix to a string (useful for debug).
2367 */
2368function dumpMatrix(matrix) {
2369	var s = "[ " + matrix.a + ", " + matrix.c + ", " + matrix.e + "\n  " + matrix.b + ", " + matrix.d + ", " + matrix.f + "\n  0, 0, 1 ]";
2370
2371	return s;
2372}
2373
2374/**
2375 * Sets attributes of an element.
2376 */
2377function setAttributes(element, attributes){
2378	for (i in attributes)
2379		element.setAttributeNS(null, i, attributes[i]);
2380}
2381
2382/**
2383 * Handle mouse move event.
2384 */
2385function handleMouseWheel(evt) {
2386	if(evt.preventDefault)
2387		evt.preventDefault();
2388
2389	evt.returnValue = false;
2390
2391	var svgDoc = evt.target.ownerDocument;
2392
2393	var delta;
2394
2395	if(evt.wheelDelta)
2396		delta = evt.wheelDelta / 3600; // Chrome/Safari
2397	else
2398		delta = evt.detail / -90; // Mozilla
2399
2400	var z = 1 + delta; // Zoom factor: 0.9/1.1
2401
2402	var g = svgDoc.getElementById("viewport");
2403
2404	var p = getEventPoint(evt);
2405
2406	p = p.matrixTransform(g.getCTM().inverse());
2407
2408	// Compute new scale matrix in current mouse position
2409	var k = root.createSVGMatrix().translate(p.x, p.y).scale(z).translate(-p.x, -p.y);
2410
2411        setCTM(g, g.getCTM().multiply(k));
2412
2413	stateTf = stateTf.multiply(k.inverse());
2414}
2415
2416/**
2417 * Handle mouse move event.
2418 */
2419function handleMouseMove(evt) {
2420	if(evt.preventDefault)
2421		evt.preventDefault();
2422
2423	evt.returnValue = false;
2424
2425	var svgDoc = evt.target.ownerDocument;
2426
2427	var g = svgDoc.getElementById("viewport");
2428
2429	if(state == 'pan') {
2430		// Pan mode
2431		var p = getEventPoint(evt).matrixTransform(stateTf);
2432
2433		setCTM(g, stateTf.inverse().translate(p.x - stateOrigin.x, p.y - stateOrigin.y));
2434	} else if(state == 'move') {
2435		// Move mode
2436		var p = getEventPoint(evt).matrixTransform(g.getCTM().inverse());
2437
2438		setCTM(stateTarget, root.createSVGMatrix().translate(p.x - stateOrigin.x, p.y - stateOrigin.y).multiply(g.getCTM().inverse()).multiply(stateTarget.getCTM()));
2439
2440		stateOrigin = p;
2441	}
2442}
2443
2444/**
2445 * Handle click event.
2446 */
2447function handleMouseDown(evt) {
2448	if(evt.preventDefault)
2449		evt.preventDefault();
2450
2451	evt.returnValue = false;
2452
2453	var svgDoc = evt.target.ownerDocument;
2454
2455	var g = svgDoc.getElementById("viewport");
2456
2457	if(true || evt.target.tagName == "svg") {
2458		// Pan mode
2459		state = 'pan';
2460
2461		stateTf = g.getCTM().inverse();
2462
2463		stateOrigin = getEventPoint(evt).matrixTransform(stateTf);
2464	} else {
2465		// Move mode
2466		state = 'move';
2467
2468		stateTarget = evt.target;
2469
2470		stateTf = g.getCTM().inverse();
2471
2472		stateOrigin = getEventPoint(evt).matrixTransform(stateTf);
2473	}
2474}
2475
2476/**
2477 * Handle mouse button release event.
2478 */
2479function handleMouseUp(evt) {
2480	if(evt.preventDefault)
2481		evt.preventDefault();
2482
2483	evt.returnValue = false;
2484
2485	var svgDoc = evt.target.ownerDocument;
2486
2487	if(state == 'pan' || state == 'move') {
2488		// Quit pan mode
2489		state = '';
2490	}
2491}
2492
2493]]></script>
2494EOF
2495}
2496
2497# Provides a map from fullname to shortname for cases where the
2498# shortname is ambiguous.  The symlist has both the fullname and
2499# shortname for all symbols, which is usually fine, but sometimes --
2500# such as overloaded functions -- two different fullnames can map to
2501# the same shortname.  In that case, we use the address of the
2502# function to disambiguate the two.  This function fills in a map that
2503# maps fullnames to modified shortnames in such cases.  If a fullname
2504# is not present in the map, the 'normal' shortname provided by the
2505# symlist is the appropriate one to use.
2506sub FillFullnameToShortnameMap {
2507  my $symbols = shift;
2508  my $fullname_to_shortname_map = shift;
2509  my $shortnames_seen_once = {};
2510  my $shortnames_seen_more_than_once = {};
2511
2512  foreach my $symlist (values(%{$symbols})) {
2513    # TODO(csilvers): deal with inlined symbols too.
2514    my $shortname = $symlist->[0];
2515    my $fullname = $symlist->[2];
2516    if ($fullname !~ /<[0-9a-fA-F]+>$/) {  # fullname doesn't end in an address
2517      next;       # the only collisions we care about are when addresses differ
2518    }
2519    if (defined($shortnames_seen_once->{$shortname}) &&
2520        $shortnames_seen_once->{$shortname} ne $fullname) {
2521      $shortnames_seen_more_than_once->{$shortname} = 1;
2522    } else {
2523      $shortnames_seen_once->{$shortname} = $fullname;
2524    }
2525  }
2526
2527  foreach my $symlist (values(%{$symbols})) {
2528    my $shortname = $symlist->[0];
2529    my $fullname = $symlist->[2];
2530    # TODO(csilvers): take in a list of addresses we care about, and only
2531    # store in the map if $symlist->[1] is in that list.  Saves space.
2532    next if defined($fullname_to_shortname_map->{$fullname});
2533    if (defined($shortnames_seen_more_than_once->{$shortname})) {
2534      if ($fullname =~ /<0*([^>]*)>$/) {   # fullname has address at end of it
2535        $fullname_to_shortname_map->{$fullname} = "$shortname\@$1";
2536      }
2537    }
2538  }
2539}
2540
2541# Return a small number that identifies the argument.
2542# Multiple calls with the same argument will return the same number.
2543# Calls with different arguments will return different numbers.
2544sub ShortIdFor {
2545  my $key = shift;
2546  my $id = $main::uniqueid{$key};
2547  if (!defined($id)) {
2548    $id = keys(%main::uniqueid) + 1;
2549    $main::uniqueid{$key} = $id;
2550  }
2551  return $id;
2552}
2553
2554# Translate a stack of addresses into a stack of symbols
2555sub TranslateStack {
2556  my $symbols = shift;
2557  my $fullname_to_shortname_map = shift;
2558  my $k = shift;
2559
2560  my @addrs = split(/\n/, $k);
2561  my @result = ();
2562  for (my $i = 0; $i <= $#addrs; $i++) {
2563    my $a = $addrs[$i];
2564
2565    # Skip large addresses since they sometimes show up as fake entries on RH9
2566    if (length($a) > 8 && $a gt "7fffffffffffffff") {
2567      next;
2568    }
2569
2570    if ($main::opt_disasm || $main::opt_list) {
2571      # We want just the address for the key
2572      push(@result, $a);
2573      next;
2574    }
2575
2576    my $symlist = $symbols->{$a};
2577    if (!defined($symlist)) {
2578      $symlist = [$a, "", $a];
2579    }
2580
2581    # We can have a sequence of symbols for a particular entry
2582    # (more than one symbol in the case of inlining).  Callers
2583    # come before callees in symlist, so walk backwards since
2584    # the translated stack should contain callees before callers.
2585    for (my $j = $#{$symlist}; $j >= 2; $j -= 3) {
2586      my $func = $symlist->[$j-2];
2587      my $fileline = $symlist->[$j-1];
2588      my $fullfunc = $symlist->[$j];
2589      if (defined($fullname_to_shortname_map->{$fullfunc})) {
2590        $func = $fullname_to_shortname_map->{$fullfunc};
2591      }
2592      if ($j > 2) {
2593        $func = "$func (inline)";
2594      }
2595
2596      # Do not merge nodes corresponding to Callback::Run since that
2597      # causes confusing cycles in dot display.  Instead, we synthesize
2598      # a unique name for this frame per caller.
2599      if ($func =~ m/Callback.*::Run$/) {
2600        my $caller = ($i > 0) ? $addrs[$i-1] : 0;
2601        $func = "Run#" . ShortIdFor($caller);
2602      }
2603
2604      if ($main::opt_addresses) {
2605        push(@result, "$a $func $fileline");
2606      } elsif ($main::opt_lines) {
2607        if ($func eq '??' && $fileline eq '??:0') {
2608          push(@result, "$a");
2609        } else {
2610          push(@result, "$func $fileline");
2611        }
2612      } elsif ($main::opt_functions) {
2613        if ($func eq '??') {
2614          push(@result, "$a");
2615        } else {
2616          push(@result, $func);
2617        }
2618      } elsif ($main::opt_files) {
2619        if ($fileline eq '??:0' || $fileline eq '') {
2620          push(@result, "$a");
2621        } else {
2622          my $f = $fileline;
2623          $f =~ s/:\d+$//;
2624          push(@result, $f);
2625        }
2626      } else {
2627        push(@result, $a);
2628        last;  # Do not print inlined info
2629      }
2630    }
2631  }
2632
2633  # print join(",", @addrs), " => ", join(",", @result), "\n";
2634  return @result;
2635}
2636
2637# Generate percent string for a number and a total
2638sub Percent {
2639  my $num = shift;
2640  my $tot = shift;
2641  if ($tot != 0) {
2642    return sprintf("%.1f%%", $num * 100.0 / $tot);
2643  } else {
2644    return ($num == 0) ? "nan" : (($num > 0) ? "+inf" : "-inf");
2645  }
2646}
2647
2648# Generate pretty-printed form of number
2649sub Unparse {
2650  my $num = shift;
2651  if ($main::profile_type eq 'heap' || $main::profile_type eq 'growth') {
2652    if ($main::opt_inuse_objects || $main::opt_alloc_objects) {
2653      return sprintf("%d", $num);
2654    } else {
2655      if ($main::opt_show_bytes) {
2656        return sprintf("%d", $num);
2657      } else {
2658        return sprintf("%.1f", $num / 1048576.0);
2659      }
2660    }
2661  } elsif ($main::profile_type eq 'contention' && !$main::opt_contentions) {
2662    return sprintf("%.3f", $num / 1e9); # Convert nanoseconds to seconds
2663  } else {
2664    return sprintf("%d", $num);
2665  }
2666}
2667
2668# Alternate pretty-printed form: 0 maps to "."
2669sub UnparseAlt {
2670  my $num = shift;
2671  if ($num == 0) {
2672    return ".";
2673  } else {
2674    return Unparse($num);
2675  }
2676}
2677
2678# Alternate pretty-printed form: 0 maps to ""
2679sub HtmlPrintNumber {
2680  my $num = shift;
2681  if ($num == 0) {
2682    return "";
2683  } else {
2684    return Unparse($num);
2685  }
2686}
2687
2688# Return output units
2689sub Units {
2690  if ($main::profile_type eq 'heap' || $main::profile_type eq 'growth') {
2691    if ($main::opt_inuse_objects || $main::opt_alloc_objects) {
2692      return "objects";
2693    } else {
2694      if ($main::opt_show_bytes) {
2695        return "B";
2696      } else {
2697        return "MB";
2698      }
2699    }
2700  } elsif ($main::profile_type eq 'contention' && !$main::opt_contentions) {
2701    return "seconds";
2702  } else {
2703    return "samples";
2704  }
2705}
2706
2707##### Profile manipulation code #####
2708
2709# Generate flattened profile:
2710# If count is charged to stack [a,b,c,d], in generated profile,
2711# it will be charged to [a]
2712sub FlatProfile {
2713  my $profile = shift;
2714  my $result = {};
2715  foreach my $k (keys(%{$profile})) {
2716    my $count = $profile->{$k};
2717    my @addrs = split(/\n/, $k);
2718    if ($#addrs >= 0) {
2719      AddEntry($result, $addrs[0], $count);
2720    }
2721  }
2722  return $result;
2723}
2724
2725# Generate cumulative profile:
2726# If count is charged to stack [a,b,c,d], in generated profile,
2727# it will be charged to [a], [b], [c], [d]
2728sub CumulativeProfile {
2729  my $profile = shift;
2730  my $result = {};
2731  foreach my $k (keys(%{$profile})) {
2732    my $count = $profile->{$k};
2733    my @addrs = split(/\n/, $k);
2734    foreach my $a (@addrs) {
2735      AddEntry($result, $a, $count);
2736    }
2737  }
2738  return $result;
2739}
2740
2741# If the second-youngest PC on the stack is always the same, returns
2742# that pc.  Otherwise, returns undef.
2743sub IsSecondPcAlwaysTheSame {
2744  my $profile = shift;
2745
2746  my $second_pc = undef;
2747  foreach my $k (keys(%{$profile})) {
2748    my @addrs = split(/\n/, $k);
2749    if ($#addrs < 1) {
2750      return undef;
2751    }
2752    if (not defined $second_pc) {
2753      $second_pc = $addrs[1];
2754    } else {
2755      if ($second_pc ne $addrs[1]) {
2756        return undef;
2757      }
2758    }
2759  }
2760  return $second_pc;
2761}
2762
2763sub ExtractSymbolLocation {
2764  my $symbols = shift;
2765  my $address = shift;
2766  # 'addr2line' outputs "??:0" for unknown locations; we do the
2767  # same to be consistent.
2768  my $location = "??:0:unknown";
2769  if (exists $symbols->{$address}) {
2770    my $file = $symbols->{$address}->[1];
2771    if ($file eq "?") {
2772      $file = "??:0"
2773    }
2774    $location = $file . ":" . $symbols->{$address}->[0];
2775  }
2776  return $location;
2777}
2778
2779# Extracts a graph of calls.
2780sub ExtractCalls {
2781  my $symbols = shift;
2782  my $profile = shift;
2783
2784  my $calls = {};
2785  while( my ($stack_trace, $count) = each %$profile ) {
2786    my @address = split(/\n/, $stack_trace);
2787    my $destination = ExtractSymbolLocation($symbols, $address[0]);
2788    AddEntry($calls, $destination, $count);
2789    for (my $i = 1; $i <= $#address; $i++) {
2790      my $source = ExtractSymbolLocation($symbols, $address[$i]);
2791      my $call = "$source -> $destination";
2792      AddEntry($calls, $call, $count);
2793      $destination = $source;
2794    }
2795  }
2796
2797  return $calls;
2798}
2799
2800sub RemoveUninterestingFrames {
2801  my $symbols = shift;
2802  my $profile = shift;
2803
2804  # List of function names to skip
2805  my %skip = ();
2806  my $skip_regexp = 'NOMATCH';
2807  if ($main::profile_type eq 'heap' || $main::profile_type eq 'growth') {
2808    foreach my $name ('calloc',
2809                      'cfree',
2810                      'malloc',
2811                      'free',
2812                      'memalign',
2813                      'posix_memalign',
2814                      'pvalloc',
2815                      'valloc',
2816                      'realloc',
2817                      'tc_calloc',
2818                      'tc_cfree',
2819                      'tc_malloc',
2820                      'tc_free',
2821                      'tc_memalign',
2822                      'tc_posix_memalign',
2823                      'tc_pvalloc',
2824                      'tc_valloc',
2825                      'tc_realloc',
2826                      'tc_new',
2827                      'tc_delete',
2828                      'tc_newarray',
2829                      'tc_deletearray',
2830                      'tc_new_nothrow',
2831                      'tc_newarray_nothrow',
2832                      'do_malloc',
2833                      '::do_malloc',   # new name -- got moved to an unnamed ns
2834                      '::do_malloc_or_cpp_alloc',
2835                      'DoSampledAllocation',
2836                      'simple_alloc::allocate',
2837                      '__malloc_alloc_template::allocate',
2838                      '__builtin_delete',
2839                      '__builtin_new',
2840                      '__builtin_vec_delete',
2841                      '__builtin_vec_new',
2842                      'operator new',
2843                      'operator new[]',
2844                      # The entry to our memory-allocation routines on OS X
2845                      'malloc_zone_malloc',
2846                      'malloc_zone_calloc',
2847                      'malloc_zone_valloc',
2848                      'malloc_zone_realloc',
2849                      'malloc_zone_memalign',
2850                      'malloc_zone_free',
2851                      # These mark the beginning/end of our custom sections
2852                      '__start_google_malloc',
2853                      '__stop_google_malloc',
2854                      '__start_malloc_hook',
2855                      '__stop_malloc_hook') {
2856      $skip{$name} = 1;
2857      $skip{"_" . $name} = 1;   # Mach (OS X) adds a _ prefix to everything
2858    }
2859    # TODO: Remove TCMalloc once everything has been
2860    # moved into the tcmalloc:: namespace and we have flushed
2861    # old code out of the system.
2862    $skip_regexp = "TCMalloc|^tcmalloc::";
2863  } elsif ($main::profile_type eq 'contention') {
2864    foreach my $vname ('base::RecordLockProfileData',
2865                       'base::SubmitMutexProfileData',
2866                       'base::SubmitSpinLockProfileData',
2867                       'Mutex::Unlock',
2868                       'Mutex::UnlockSlow',
2869                       'Mutex::ReaderUnlock',
2870                       'MutexLock::~MutexLock',
2871                       'SpinLock::Unlock',
2872                       'SpinLock::SlowUnlock',
2873                       'SpinLockHolder::~SpinLockHolder') {
2874      $skip{$vname} = 1;
2875    }
2876  } elsif ($main::profile_type eq 'cpu') {
2877    # Drop signal handlers used for CPU profile collection
2878    # TODO(dpeng): this should not be necessary; it's taken
2879    # care of by the general 2nd-pc mechanism below.
2880    foreach my $name ('ProfileData::Add',           # historical
2881                      'ProfileData::prof_handler',  # historical
2882                      'CpuProfiler::prof_handler',
2883                      '__FRAME_END__',
2884                      '__pthread_sighandler',
2885                      '__restore') {
2886      $skip{$name} = 1;
2887    }
2888  } else {
2889    # Nothing skipped for unknown types
2890  }
2891
2892  if ($main::profile_type eq 'cpu') {
2893    # If all the second-youngest program counters are the same,
2894    # this STRONGLY suggests that it is an artifact of measurement,
2895    # i.e., stack frames pushed by the CPU profiler signal handler.
2896    # Hence, we delete them.
2897    # (The topmost PC is read from the signal structure, not from
2898    # the stack, so it does not get involved.)
2899    while (my $second_pc = IsSecondPcAlwaysTheSame($profile)) {
2900      my $result = {};
2901      my $func = '';
2902      if (exists($symbols->{$second_pc})) {
2903        $second_pc = $symbols->{$second_pc}->[0];
2904      }
2905      print STDERR "Removing $second_pc from all stack traces.\n";
2906      foreach my $k (keys(%{$profile})) {
2907        my $count = $profile->{$k};
2908        my @addrs = split(/\n/, $k);
2909        splice @addrs, 1, 1;
2910        my $reduced_path = join("\n", @addrs);
2911        AddEntry($result, $reduced_path, $count);
2912      }
2913      $profile = $result;
2914    }
2915  }
2916
2917  my $result = {};
2918  foreach my $k (keys(%{$profile})) {
2919    my $count = $profile->{$k};
2920    my @addrs = split(/\n/, $k);
2921    my @path = ();
2922    foreach my $a (@addrs) {
2923      if (exists($symbols->{$a})) {
2924        my $func = $symbols->{$a}->[0];
2925        if ($skip{$func} || ($func =~ m/$skip_regexp/)) {
2926          next;
2927        }
2928      }
2929      push(@path, $a);
2930    }
2931    my $reduced_path = join("\n", @path);
2932    AddEntry($result, $reduced_path, $count);
2933  }
2934  return $result;
2935}
2936
2937# Reduce profile to granularity given by user
2938sub ReduceProfile {
2939  my $symbols = shift;
2940  my $profile = shift;
2941  my $result = {};
2942  my $fullname_to_shortname_map = {};
2943  FillFullnameToShortnameMap($symbols, $fullname_to_shortname_map);
2944  foreach my $k (keys(%{$profile})) {
2945    my $count = $profile->{$k};
2946    my @translated = TranslateStack($symbols, $fullname_to_shortname_map, $k);
2947    my @path = ();
2948    my %seen = ();
2949    $seen{''} = 1;      # So that empty keys are skipped
2950    foreach my $e (@translated) {
2951      # To avoid double-counting due to recursion, skip a stack-trace
2952      # entry if it has already been seen
2953      if (!$seen{$e}) {
2954        $seen{$e} = 1;
2955        push(@path, $e);
2956      }
2957    }
2958    my $reduced_path = join("\n", @path);
2959    AddEntry($result, $reduced_path, $count);
2960  }
2961  return $result;
2962}
2963
2964# Does the specified symbol array match the regexp?
2965sub SymbolMatches {
2966  my $sym = shift;
2967  my $re = shift;
2968  if (defined($sym)) {
2969    for (my $i = 0; $i < $#{$sym}; $i += 3) {
2970      if ($sym->[$i] =~ m/$re/ || $sym->[$i+1] =~ m/$re/) {
2971        return 1;
2972      }
2973    }
2974  }
2975  return 0;
2976}
2977
2978# Focus only on paths involving specified regexps
2979sub FocusProfile {
2980  my $symbols = shift;
2981  my $profile = shift;
2982  my $focus = shift;
2983  my $result = {};
2984  foreach my $k (keys(%{$profile})) {
2985    my $count = $profile->{$k};
2986    my @addrs = split(/\n/, $k);
2987    foreach my $a (@addrs) {
2988      # Reply if it matches either the address/shortname/fileline
2989      if (($a =~ m/$focus/) || SymbolMatches($symbols->{$a}, $focus)) {
2990        AddEntry($result, $k, $count);
2991        last;
2992      }
2993    }
2994  }
2995  return $result;
2996}
2997
2998# Focus only on paths not involving specified regexps
2999sub IgnoreProfile {
3000  my $symbols = shift;
3001  my $profile = shift;
3002  my $ignore = shift;
3003  my $result = {};
3004  foreach my $k (keys(%{$profile})) {
3005    my $count = $profile->{$k};
3006    my @addrs = split(/\n/, $k);
3007    my $matched = 0;
3008    foreach my $a (@addrs) {
3009      # Reply if it matches either the address/shortname/fileline
3010      if (($a =~ m/$ignore/) || SymbolMatches($symbols->{$a}, $ignore)) {
3011        $matched = 1;
3012        last;
3013      }
3014    }
3015    if (!$matched) {
3016      AddEntry($result, $k, $count);
3017    }
3018  }
3019  return $result;
3020}
3021
3022# Get total count in profile
3023sub TotalProfile {
3024  my $profile = shift;
3025  my $result = 0;
3026  foreach my $k (keys(%{$profile})) {
3027    $result += $profile->{$k};
3028  }
3029  return $result;
3030}
3031
3032# Add A to B
3033sub AddProfile {
3034  my $A = shift;
3035  my $B = shift;
3036
3037  my $R = {};
3038  # add all keys in A
3039  foreach my $k (keys(%{$A})) {
3040    my $v = $A->{$k};
3041    AddEntry($R, $k, $v);
3042  }
3043  # add all keys in B
3044  foreach my $k (keys(%{$B})) {
3045    my $v = $B->{$k};
3046    AddEntry($R, $k, $v);
3047  }
3048  return $R;
3049}
3050
3051# Merges symbol maps
3052sub MergeSymbols {
3053  my $A = shift;
3054  my $B = shift;
3055
3056  my $R = {};
3057  foreach my $k (keys(%{$A})) {
3058    $R->{$k} = $A->{$k};
3059  }
3060  if (defined($B)) {
3061    foreach my $k (keys(%{$B})) {
3062      $R->{$k} = $B->{$k};
3063    }
3064  }
3065  return $R;
3066}
3067
3068
3069# Add A to B
3070sub AddPcs {
3071  my $A = shift;
3072  my $B = shift;
3073
3074  my $R = {};
3075  # add all keys in A
3076  foreach my $k (keys(%{$A})) {
3077    $R->{$k} = 1
3078  }
3079  # add all keys in B
3080  foreach my $k (keys(%{$B})) {
3081    $R->{$k} = 1
3082  }
3083  return $R;
3084}
3085
3086# Subtract B from A
3087sub SubtractProfile {
3088  my $A = shift;
3089  my $B = shift;
3090
3091  my $R = {};
3092  foreach my $k (keys(%{$A})) {
3093    my $v = $A->{$k} - GetEntry($B, $k);
3094    if ($v < 0 && $main::opt_drop_negative) {
3095      $v = 0;
3096    }
3097    AddEntry($R, $k, $v);
3098  }
3099  if (!$main::opt_drop_negative) {
3100    # Take care of when subtracted profile has more entries
3101    foreach my $k (keys(%{$B})) {
3102      if (!exists($A->{$k})) {
3103        AddEntry($R, $k, 0 - $B->{$k});
3104      }
3105    }
3106  }
3107  return $R;
3108}
3109
3110# Get entry from profile; zero if not present
3111sub GetEntry {
3112  my $profile = shift;
3113  my $k = shift;
3114  if (exists($profile->{$k})) {
3115    return $profile->{$k};
3116  } else {
3117    return 0;
3118  }
3119}
3120
3121# Add entry to specified profile
3122sub AddEntry {
3123  my $profile = shift;
3124  my $k = shift;
3125  my $n = shift;
3126  if (!exists($profile->{$k})) {
3127    $profile->{$k} = 0;
3128  }
3129  $profile->{$k} += $n;
3130}
3131
3132# Add a stack of entries to specified profile, and add them to the $pcs
3133# list.
3134sub AddEntries {
3135  my $profile = shift;
3136  my $pcs = shift;
3137  my $stack = shift;
3138  my $count = shift;
3139  my @k = ();
3140
3141  foreach my $e (split(/\s+/, $stack)) {
3142    my $pc = HexExtend($e);
3143    $pcs->{$pc} = 1;
3144    push @k, $pc;
3145  }
3146  AddEntry($profile, (join "\n", @k), $count);
3147}
3148
3149##### Code to profile a server dynamically #####
3150
3151sub CheckSymbolPage {
3152  my $url = SymbolPageURL();
3153  my $command = ShellEscape(@URL_FETCHER, $url);
3154  open(SYMBOL, "$command |") or error($command);
3155  my $line = <SYMBOL>;
3156  $line =~ s/\r//g;         # turn windows-looking lines into unix-looking lines
3157  close(SYMBOL);
3158  unless (defined($line)) {
3159    error("$url doesn't exist\n");
3160  }
3161
3162  if ($line =~ /^num_symbols:\s+(\d+)$/) {
3163    if ($1 == 0) {
3164      error("Stripped binary. No symbols available.\n");
3165    }
3166  } else {
3167    error("Failed to get the number of symbols from $url\n");
3168  }
3169}
3170
3171sub IsProfileURL {
3172  my $profile_name = shift;
3173  if (-f $profile_name) {
3174    printf STDERR "Using local file $profile_name.\n";
3175    return 0;
3176  }
3177  return 1;
3178}
3179
3180sub ParseProfileURL {
3181  my $profile_name = shift;
3182
3183  if (!defined($profile_name) || $profile_name eq "") {
3184    return ();
3185  }
3186
3187  # Split profile URL - matches all non-empty strings, so no test.
3188  $profile_name =~ m,^(https?://)?([^/]+)(.*?)(/|$PROFILES)?$,;
3189
3190  my $proto = $1 || "http://";
3191  my $hostport = $2;
3192  my $prefix = $3;
3193  my $profile = $4 || "/";
3194
3195  my $host = $hostport;
3196  $host =~ s/:.*//;
3197
3198  my $baseurl = "$proto$hostport$prefix";
3199  return ($host, $baseurl, $profile);
3200}
3201
3202# We fetch symbols from the first profile argument.
3203sub SymbolPageURL {
3204  my ($host, $baseURL, $path) = ParseProfileURL($main::pfile_args[0]);
3205  return "$baseURL$SYMBOL_PAGE";
3206}
3207
3208sub FetchProgramName() {
3209  my ($host, $baseURL, $path) = ParseProfileURL($main::pfile_args[0]);
3210  my $url = "$baseURL$PROGRAM_NAME_PAGE";
3211  my $command_line = ShellEscape(@URL_FETCHER, $url);
3212  open(CMDLINE, "$command_line |") or error($command_line);
3213  my $cmdline = <CMDLINE>;
3214  $cmdline =~ s/\r//g;   # turn windows-looking lines into unix-looking lines
3215  close(CMDLINE);
3216  error("Failed to get program name from $url\n") unless defined($cmdline);
3217  $cmdline =~ s/\x00.+//;  # Remove argv[1] and latters.
3218  $cmdline =~ s!\n!!g;  # Remove LFs.
3219  return $cmdline;
3220}
3221
3222# Gee, curl's -L (--location) option isn't reliable at least
3223# with its 7.12.3 version.  Curl will forget to post data if
3224# there is a redirection.  This function is a workaround for
3225# curl.  Redirection happens on borg hosts.
3226sub ResolveRedirectionForCurl {
3227  my $url = shift;
3228  my $command_line = ShellEscape(@URL_FETCHER, "--head", $url);
3229  open(CMDLINE, "$command_line |") or error($command_line);
3230  while (<CMDLINE>) {
3231    s/\r//g;         # turn windows-looking lines into unix-looking lines
3232    if (/^Location: (.*)/) {
3233      $url = $1;
3234    }
3235  }
3236  close(CMDLINE);
3237  return $url;
3238}
3239
3240# Add a timeout flat to URL_FETCHER.  Returns a new list.
3241sub AddFetchTimeout {
3242  my $timeout = shift;
3243  my @fetcher = shift;
3244  if (defined($timeout)) {
3245    if (join(" ", @fetcher) =~ m/\bcurl -s/) {
3246      push(@fetcher, "--max-time", sprintf("%d", $timeout));
3247    } elsif (join(" ", @fetcher) =~ m/\brpcget\b/) {
3248      push(@fetcher, sprintf("--deadline=%d", $timeout));
3249    }
3250  }
3251  return @fetcher;
3252}
3253
3254# Reads a symbol map from the file handle name given as $1, returning
3255# the resulting symbol map.  Also processes variables relating to symbols.
3256# Currently, the only variable processed is 'binary=<value>' which updates
3257# $main::prog to have the correct program name.
3258sub ReadSymbols {
3259  my $in = shift;
3260  my $map = {};
3261  while (<$in>) {
3262    s/\r//g;         # turn windows-looking lines into unix-looking lines
3263    # Removes all the leading zeroes from the symbols, see comment below.
3264    if (m/^0x0*([0-9a-f]+)\s+(.+)/) {
3265      $map->{$1} = $2;
3266    } elsif (m/^---/) {
3267      last;
3268    } elsif (m/^([a-z][^=]*)=(.*)$/ ) {
3269      my ($variable, $value) = ($1, $2);
3270      for ($variable, $value) {
3271        s/^\s+//;
3272        s/\s+$//;
3273      }
3274      if ($variable eq "binary") {
3275        if ($main::prog ne $UNKNOWN_BINARY && $main::prog ne $value) {
3276          printf STDERR ("Warning: Mismatched binary name '%s', using '%s'.\n",
3277                         $main::prog, $value);
3278        }
3279        $main::prog = $value;
3280      } else {
3281        printf STDERR ("Ignoring unknown variable in symbols list: " .
3282            "'%s' = '%s'\n", $variable, $value);
3283      }
3284    }
3285  }
3286  return $map;
3287}
3288
3289# Fetches and processes symbols to prepare them for use in the profile output
3290# code.  If the optional 'symbol_map' arg is not given, fetches symbols from
3291# $SYMBOL_PAGE for all PC values found in profile.  Otherwise, the raw symbols
3292# are assumed to have already been fetched into 'symbol_map' and are simply
3293# extracted and processed.
3294sub FetchSymbols {
3295  my $pcset = shift;
3296  my $symbol_map = shift;
3297
3298  my %seen = ();
3299  my @pcs = grep { !$seen{$_}++ } keys(%$pcset);  # uniq
3300
3301  if (!defined($symbol_map)) {
3302    my $post_data = join("+", sort((map {"0x" . "$_"} @pcs)));
3303
3304    open(POSTFILE, ">$main::tmpfile_sym");
3305    print POSTFILE $post_data;
3306    close(POSTFILE);
3307
3308    my $url = SymbolPageURL();
3309
3310    my $command_line;
3311    if (join(" ", @URL_FETCHER) =~ m/\bcurl -s/) {
3312      $url = ResolveRedirectionForCurl($url);
3313      $command_line = ShellEscape(@URL_FETCHER, "-d", "\@$main::tmpfile_sym",
3314                                  $url);
3315    } else {
3316      $command_line = (ShellEscape(@URL_FETCHER, "--post", $url)
3317                       . " < " . ShellEscape($main::tmpfile_sym));
3318    }
3319    # We use c++filt in case $SYMBOL_PAGE gives us mangled symbols.
3320    my $escaped_cppfilt = ShellEscape($obj_tool_map{"c++filt"});
3321    open(SYMBOL, "$command_line | $escaped_cppfilt |") or error($command_line);
3322    $symbol_map = ReadSymbols(*SYMBOL{IO});
3323    close(SYMBOL);
3324  }
3325
3326  my $symbols = {};
3327  foreach my $pc (@pcs) {
3328    my $fullname;
3329    # For 64 bits binaries, symbols are extracted with 8 leading zeroes.
3330    # Then /symbol reads the long symbols in as uint64, and outputs
3331    # the result with a "0x%08llx" format which get rid of the zeroes.
3332    # By removing all the leading zeroes in both $pc and the symbols from
3333    # /symbol, the symbols match and are retrievable from the map.
3334    my $shortpc = $pc;
3335    $shortpc =~ s/^0*//;
3336    # Each line may have a list of names, which includes the function
3337    # and also other functions it has inlined.  They are separated (in
3338    # PrintSymbolizedProfile), by --, which is illegal in function names.
3339    my $fullnames;
3340    if (defined($symbol_map->{$shortpc})) {
3341      $fullnames = $symbol_map->{$shortpc};
3342    } else {
3343      $fullnames = "0x" . $pc;  # Just use addresses
3344    }
3345    my $sym = [];
3346    $symbols->{$pc} = $sym;
3347    foreach my $fullname (split("--", $fullnames)) {
3348      my $name = ShortFunctionName($fullname);
3349      push(@{$sym}, $name, "?", $fullname);
3350    }
3351  }
3352  return $symbols;
3353}
3354
3355sub BaseName {
3356  my $file_name = shift;
3357  $file_name =~ s!^.*/!!;  # Remove directory name
3358  return $file_name;
3359}
3360
3361sub MakeProfileBaseName {
3362  my ($binary_name, $profile_name) = @_;
3363  my ($host, $baseURL, $path) = ParseProfileURL($profile_name);
3364  my $binary_shortname = BaseName($binary_name);
3365  return sprintf("%s.%s.%s",
3366                 $binary_shortname, $main::op_time, $host);
3367}
3368
3369sub FetchDynamicProfile {
3370  my $binary_name = shift;
3371  my $profile_name = shift;
3372  my $fetch_name_only = shift;
3373  my $encourage_patience = shift;
3374
3375  if (!IsProfileURL($profile_name)) {
3376    return $profile_name;
3377  } else {
3378    my ($host, $baseURL, $path) = ParseProfileURL($profile_name);
3379    if ($path eq "" || $path eq "/") {
3380      # Missing type specifier defaults to cpu-profile
3381      $path = $PROFILE_PAGE;
3382    }
3383
3384    my $profile_file = MakeProfileBaseName($binary_name, $profile_name);
3385
3386    my $url = "$baseURL$path";
3387    my $fetch_timeout = undef;
3388    if ($path =~ m/$PROFILE_PAGE|$PMUPROFILE_PAGE/) {
3389      if ($path =~ m/[?]/) {
3390        $url .= "&";
3391      } else {
3392        $url .= "?";
3393      }
3394      $url .= sprintf("seconds=%d", $main::opt_seconds);
3395      $fetch_timeout = $main::opt_seconds * 1.01 + 60;
3396    } else {
3397      # For non-CPU profiles, we add a type-extension to
3398      # the target profile file name.
3399      my $suffix = $path;
3400      $suffix =~ s,/,.,g;
3401      $profile_file .= $suffix;
3402    }
3403
3404    my $profile_dir = $ENV{"PPROF_TMPDIR"} || ($ENV{HOME} . "/pprof");
3405    if (! -d $profile_dir) {
3406      mkdir($profile_dir)
3407          || die("Unable to create profile directory $profile_dir: $!\n");
3408    }
3409    my $tmp_profile = "$profile_dir/.tmp.$profile_file";
3410    my $real_profile = "$profile_dir/$profile_file";
3411
3412    if ($fetch_name_only > 0) {
3413      return $real_profile;
3414    }
3415
3416    my @fetcher = AddFetchTimeout($fetch_timeout, @URL_FETCHER);
3417    my $cmd = ShellEscape(@fetcher, $url) . " > " . ShellEscape($tmp_profile);
3418    if ($path =~ m/$PROFILE_PAGE|$PMUPROFILE_PAGE|$CENSUSPROFILE_PAGE/){
3419      print STDERR "Gathering CPU profile from $url for $main::opt_seconds seconds to\n  ${real_profile}\n";
3420      if ($encourage_patience) {
3421        print STDERR "Be patient...\n";
3422      }
3423    } else {
3424      print STDERR "Fetching $path profile from $url to\n  ${real_profile}\n";
3425    }
3426
3427    (system($cmd) == 0) || error("Failed to get profile: $cmd: $!\n");
3428    (system("mv", $tmp_profile, $real_profile) == 0) || error("Unable to rename profile\n");
3429    print STDERR "Wrote profile to $real_profile\n";
3430    $main::collected_profile = $real_profile;
3431    return $main::collected_profile;
3432  }
3433}
3434
3435# Collect profiles in parallel
3436sub FetchDynamicProfiles {
3437  my $items = scalar(@main::pfile_args);
3438  my $levels = log($items) / log(2);
3439
3440  if ($items == 1) {
3441    $main::profile_files[0] = FetchDynamicProfile($main::prog, $main::pfile_args[0], 0, 1);
3442  } else {
3443    # math rounding issues
3444    if ((2 ** $levels) < $items) {
3445     $levels++;
3446    }
3447    my $count = scalar(@main::pfile_args);
3448    for (my $i = 0; $i < $count; $i++) {
3449      $main::profile_files[$i] = FetchDynamicProfile($main::prog, $main::pfile_args[$i], 1, 0);
3450    }
3451    print STDERR "Fetching $count profiles, Be patient...\n";
3452    FetchDynamicProfilesRecurse($levels, 0, 0);
3453    $main::collected_profile = join(" \\\n    ", @main::profile_files);
3454  }
3455}
3456
3457# Recursively fork a process to get enough processes
3458# collecting profiles
3459sub FetchDynamicProfilesRecurse {
3460  my $maxlevel = shift;
3461  my $level = shift;
3462  my $position = shift;
3463
3464  if (my $pid = fork()) {
3465    $position = 0 | ($position << 1);
3466    TryCollectProfile($maxlevel, $level, $position);
3467    wait;
3468  } else {
3469    $position = 1 | ($position << 1);
3470    TryCollectProfile($maxlevel, $level, $position);
3471    cleanup();
3472    exit(0);
3473  }
3474}
3475
3476# Collect a single profile
3477sub TryCollectProfile {
3478  my $maxlevel = shift;
3479  my $level = shift;
3480  my $position = shift;
3481
3482  if ($level >= ($maxlevel - 1)) {
3483    if ($position < scalar(@main::pfile_args)) {
3484      FetchDynamicProfile($main::prog, $main::pfile_args[$position], 0, 0);
3485    }
3486  } else {
3487    FetchDynamicProfilesRecurse($maxlevel, $level+1, $position);
3488  }
3489}
3490
3491##### Parsing code #####
3492
3493# Provide a small streaming-read module to handle very large
3494# cpu-profile files.  Stream in chunks along a sliding window.
3495# Provides an interface to get one 'slot', correctly handling
3496# endian-ness differences.  A slot is one 32-bit or 64-bit word
3497# (depending on the input profile).  We tell endianness and bit-size
3498# for the profile by looking at the first 8 bytes: in cpu profiles,
3499# the second slot is always 3 (we'll accept anything that's not 0).
3500BEGIN {
3501  package CpuProfileStream;
3502
3503  sub new {
3504    my ($class, $file, $fname) = @_;
3505    my $self = { file        => $file,
3506                 base        => 0,
3507                 stride      => 512 * 1024,   # must be a multiple of bitsize/8
3508                 slots       => [],
3509                 unpack_code => "",           # N for big-endian, V for little
3510                 perl_is_64bit => 1,          # matters if profile is 64-bit
3511    };
3512    bless $self, $class;
3513    # Let unittests adjust the stride
3514    if ($main::opt_test_stride > 0) {
3515      $self->{stride} = $main::opt_test_stride;
3516    }
3517    # Read the first two slots to figure out bitsize and endianness.
3518    my $slots = $self->{slots};
3519    my $str;
3520    read($self->{file}, $str, 8);
3521    # Set the global $address_length based on what we see here.
3522    # 8 is 32-bit (8 hexadecimal chars); 16 is 64-bit (16 hexadecimal chars).
3523    $address_length = ($str eq (chr(0)x8)) ? 16 : 8;
3524    if ($address_length == 8) {
3525      if (substr($str, 6, 2) eq chr(0)x2) {
3526        $self->{unpack_code} = 'V';  # Little-endian.
3527      } elsif (substr($str, 4, 2) eq chr(0)x2) {
3528        $self->{unpack_code} = 'N';  # Big-endian
3529      } else {
3530        ::error("$fname: header size >= 2**16\n");
3531      }
3532      @$slots = unpack($self->{unpack_code} . "*", $str);
3533    } else {
3534      # If we're a 64-bit profile, check if we're a 64-bit-capable
3535      # perl.  Otherwise, each slot will be represented as a float
3536      # instead of an int64, losing precision and making all the
3537      # 64-bit addresses wrong.  We won't complain yet, but will
3538      # later if we ever see a value that doesn't fit in 32 bits.
3539      my $has_q = 0;
3540      eval { $has_q = pack("Q", "1") ? 1 : 1; };
3541      if (!$has_q) {
3542        $self->{perl_is_64bit} = 0;
3543      }
3544      read($self->{file}, $str, 8);
3545      if (substr($str, 4, 4) eq chr(0)x4) {
3546        # We'd love to use 'Q', but it's a) not universal, b) not endian-proof.
3547        $self->{unpack_code} = 'V';  # Little-endian.
3548      } elsif (substr($str, 0, 4) eq chr(0)x4) {
3549        $self->{unpack_code} = 'N';  # Big-endian
3550      } else {
3551        ::error("$fname: header size >= 2**32\n");
3552      }
3553      my @pair = unpack($self->{unpack_code} . "*", $str);
3554      # Since we know one of the pair is 0, it's fine to just add them.
3555      @$slots = (0, $pair[0] + $pair[1]);
3556    }
3557    return $self;
3558  }
3559
3560  # Load more data when we access slots->get(X) which is not yet in memory.
3561  sub overflow {
3562    my ($self) = @_;
3563    my $slots = $self->{slots};
3564    $self->{base} += $#$slots + 1;   # skip over data we're replacing
3565    my $str;
3566    read($self->{file}, $str, $self->{stride});
3567    if ($address_length == 8) {      # the 32-bit case
3568      # This is the easy case: unpack provides 32-bit unpacking primitives.
3569      @$slots = unpack($self->{unpack_code} . "*", $str);
3570    } else {
3571      # We need to unpack 32 bits at a time and combine.
3572      my @b32_values = unpack($self->{unpack_code} . "*", $str);
3573      my @b64_values = ();
3574      for (my $i = 0; $i < $#b32_values; $i += 2) {
3575        # TODO(csilvers): if this is a 32-bit perl, the math below
3576        #    could end up in a too-large int, which perl will promote
3577        #    to a double, losing necessary precision.  Deal with that.
3578        #    Right now, we just die.
3579        my ($lo, $hi) = ($b32_values[$i], $b32_values[$i+1]);
3580        if ($self->{unpack_code} eq 'N') {    # big-endian
3581          ($lo, $hi) = ($hi, $lo);
3582        }
3583        my $value = $lo + $hi * (2**32);
3584        if (!$self->{perl_is_64bit} &&   # check value is exactly represented
3585            (($value % (2**32)) != $lo || int($value / (2**32)) != $hi)) {
3586          ::error("Need a 64-bit perl to process this 64-bit profile.\n");
3587        }
3588        push(@b64_values, $value);
3589      }
3590      @$slots = @b64_values;
3591    }
3592  }
3593
3594  # Access the i-th long in the file (logically), or -1 at EOF.
3595  sub get {
3596    my ($self, $idx) = @_;
3597    my $slots = $self->{slots};
3598    while ($#$slots >= 0) {
3599      if ($idx < $self->{base}) {
3600        # The only time we expect a reference to $slots[$i - something]
3601        # after referencing $slots[$i] is reading the very first header.
3602        # Since $stride > |header|, that shouldn't cause any lookback
3603        # errors.  And everything after the header is sequential.
3604        print STDERR "Unexpected look-back reading CPU profile";
3605        return -1;   # shrug, don't know what better to return
3606      } elsif ($idx > $self->{base} + $#$slots) {
3607        $self->overflow();
3608      } else {
3609        return $slots->[$idx - $self->{base}];
3610      }
3611    }
3612    # If we get here, $slots is [], which means we've reached EOF
3613    return -1;  # unique since slots is supposed to hold unsigned numbers
3614  }
3615}
3616
3617# Reads the top, 'header' section of a profile, and returns the last
3618# line of the header, commonly called a 'header line'.  The header
3619# section of a profile consists of zero or more 'command' lines that
3620# are instructions to pprof, which pprof executes when reading the
3621# header.  All 'command' lines start with a %.  After the command
3622# lines is the 'header line', which is a profile-specific line that
3623# indicates what type of profile it is, and perhaps other global
3624# information about the profile.  For instance, here's a header line
3625# for a heap profile:
3626#   heap profile:     53:    38236 [  5525:  1284029] @ heapprofile
3627# For historical reasons, the CPU profile does not contain a text-
3628# readable header line.  If the profile looks like a CPU profile,
3629# this function returns "".  If no header line could be found, this
3630# function returns undef.
3631#
3632# The following commands are recognized:
3633#   %warn -- emit the rest of this line to stderr, prefixed by 'WARNING:'
3634#
3635# The input file should be in binmode.
3636sub ReadProfileHeader {
3637  local *PROFILE = shift;
3638  my $firstchar = "";
3639  my $line = "";
3640  read(PROFILE, $firstchar, 1);
3641  seek(PROFILE, -1, 1);                    # unread the firstchar
3642  if ($firstchar !~ /[[:print:]]/) {       # is not a text character
3643    return "";
3644  }
3645  while (defined($line = <PROFILE>)) {
3646    $line =~ s/\r//g;   # turn windows-looking lines into unix-looking lines
3647    if ($line =~ /^%warn\s+(.*)/) {        # 'warn' command
3648      # Note this matches both '%warn blah\n' and '%warn\n'.
3649      print STDERR "WARNING: $1\n";        # print the rest of the line
3650    } elsif ($line =~ /^%/) {
3651      print STDERR "Ignoring unknown command from profile header: $line";
3652    } else {
3653      # End of commands, must be the header line.
3654      return $line;
3655    }
3656  }
3657  return undef;     # got to EOF without seeing a header line
3658}
3659
3660sub IsSymbolizedProfileFile {
3661  my $file_name = shift;
3662  if (!(-e $file_name) || !(-r $file_name)) {
3663    return 0;
3664  }
3665  # Check if the file contains a symbol-section marker.
3666  open(TFILE, "<$file_name");
3667  binmode TFILE;
3668  my $firstline = ReadProfileHeader(*TFILE);
3669  close(TFILE);
3670  if (!$firstline) {
3671    return 0;
3672  }
3673  $SYMBOL_PAGE =~ m,[^/]+$,;    # matches everything after the last slash
3674  my $symbol_marker = $&;
3675  return $firstline =~ /^--- *$symbol_marker/;
3676}
3677
3678# Parse profile generated by common/profiler.cc and return a reference
3679# to a map:
3680#      $result->{version}     Version number of profile file
3681#      $result->{period}      Sampling period (in microseconds)
3682#      $result->{profile}     Profile object
3683#      $result->{map}         Memory map info from profile
3684#      $result->{pcs}         Hash of all PC values seen, key is hex address
3685sub ReadProfile {
3686  my $prog = shift;
3687  my $fname = shift;
3688  my $result;            # return value
3689
3690  $CONTENTION_PAGE =~ m,[^/]+$,;    # matches everything after the last slash
3691  my $contention_marker = $&;
3692  $GROWTH_PAGE  =~ m,[^/]+$,;    # matches everything after the last slash
3693  my $growth_marker = $&;
3694  $SYMBOL_PAGE =~ m,[^/]+$,;    # matches everything after the last slash
3695  my $symbol_marker = $&;
3696  $PROFILE_PAGE =~ m,[^/]+$,;    # matches everything after the last slash
3697  my $profile_marker = $&;
3698
3699  # Look at first line to see if it is a heap or a CPU profile.
3700  # CPU profile may start with no header at all, and just binary data
3701  # (starting with \0\0\0\0) -- in that case, don't try to read the
3702  # whole firstline, since it may be gigabytes(!) of data.
3703  open(PROFILE, "<$fname") || error("$fname: $!\n");
3704  binmode PROFILE;      # New perls do UTF-8 processing
3705  my $header = ReadProfileHeader(*PROFILE);
3706  if (!defined($header)) {   # means "at EOF"
3707    error("Profile is empty.\n");
3708  }
3709
3710  my $symbols;
3711  if ($header =~ m/^--- *$symbol_marker/o) {
3712    # Verify that the user asked for a symbolized profile
3713    if (!$main::use_symbolized_profile) {
3714      # we have both a binary and symbolized profiles, abort
3715      error("FATAL ERROR: Symbolized profile\n   $fname\ncannot be used with " .
3716            "a binary arg. Try again without passing\n   $prog\n");
3717    }
3718    # Read the symbol section of the symbolized profile file.
3719    $symbols = ReadSymbols(*PROFILE{IO});
3720    # Read the next line to get the header for the remaining profile.
3721    $header = ReadProfileHeader(*PROFILE) || "";
3722  }
3723
3724  $main::profile_type = '';
3725  if ($header =~ m/^heap profile:.*$growth_marker/o) {
3726    $main::profile_type = 'growth';
3727    $result =  ReadHeapProfile($prog, *PROFILE, $header);
3728  } elsif ($header =~ m/^heap profile:/) {
3729    $main::profile_type = 'heap';
3730    $result =  ReadHeapProfile($prog, *PROFILE, $header);
3731  } elsif ($header =~ m/^--- *$contention_marker/o) {
3732    $main::profile_type = 'contention';
3733    $result = ReadSynchProfile($prog, *PROFILE);
3734  } elsif ($header =~ m/^--- *Stacks:/) {
3735    print STDERR
3736      "Old format contention profile: mistakenly reports " .
3737      "condition variable signals as lock contentions.\n";
3738    $main::profile_type = 'contention';
3739    $result = ReadSynchProfile($prog, *PROFILE);
3740  } elsif ($header =~ m/^--- *$profile_marker/) {
3741    # the binary cpu profile data starts immediately after this line
3742    $main::profile_type = 'cpu';
3743    $result = ReadCPUProfile($prog, $fname, *PROFILE);
3744  } else {
3745    if (defined($symbols)) {
3746      # a symbolized profile contains a format we don't recognize, bail out
3747      error("$fname: Cannot recognize profile section after symbols.\n");
3748    }
3749    # no ascii header present -- must be a CPU profile
3750    $main::profile_type = 'cpu';
3751    $result = ReadCPUProfile($prog, $fname, *PROFILE);
3752  }
3753
3754  close(PROFILE);
3755
3756  # if we got symbols along with the profile, return those as well
3757  if (defined($symbols)) {
3758    $result->{symbols} = $symbols;
3759  }
3760
3761  return $result;
3762}
3763
3764# Subtract one from caller pc so we map back to call instr.
3765# However, don't do this if we're reading a symbolized profile
3766# file, in which case the subtract-one was done when the file
3767# was written.
3768#
3769# We apply the same logic to all readers, though ReadCPUProfile uses an
3770# independent implementation.
3771sub FixCallerAddresses {
3772  my $stack = shift;
3773  if ($main::use_symbolized_profile) {
3774    return $stack;
3775  } else {
3776    $stack =~ /(\s)/;
3777    my $delimiter = $1;
3778    my @addrs = split(' ', $stack);
3779    my @fixedaddrs;
3780    $#fixedaddrs = $#addrs;
3781    if ($#addrs >= 0) {
3782      $fixedaddrs[0] = $addrs[0];
3783    }
3784    for (my $i = 1; $i <= $#addrs; $i++) {
3785      $fixedaddrs[$i] = AddressSub($addrs[$i], "0x1");
3786    }
3787    return join $delimiter, @fixedaddrs;
3788  }
3789}
3790
3791# CPU profile reader
3792sub ReadCPUProfile {
3793  my $prog = shift;
3794  my $fname = shift;       # just used for logging
3795  local *PROFILE = shift;
3796  my $version;
3797  my $period;
3798  my $i;
3799  my $profile = {};
3800  my $pcs = {};
3801
3802  # Parse string into array of slots.
3803  my $slots = CpuProfileStream->new(*PROFILE, $fname);
3804
3805  # Read header.  The current header version is a 5-element structure
3806  # containing:
3807  #   0: header count (always 0)
3808  #   1: header "words" (after this one: 3)
3809  #   2: format version (0)
3810  #   3: sampling period (usec)
3811  #   4: unused padding (always 0)
3812  if ($slots->get(0) != 0 ) {
3813    error("$fname: not a profile file, or old format profile file\n");
3814  }
3815  $i = 2 + $slots->get(1);
3816  $version = $slots->get(2);
3817  $period = $slots->get(3);
3818  # Do some sanity checking on these header values.
3819  if ($version > (2**32) || $period > (2**32) || $i > (2**32) || $i < 5) {
3820    error("$fname: not a profile file, or corrupted profile file\n");
3821  }
3822
3823  # Parse profile
3824  while ($slots->get($i) != -1) {
3825    my $n = $slots->get($i++);
3826    my $d = $slots->get($i++);
3827    if ($d > (2**16)) {  # TODO(csilvers): what's a reasonable max-stack-depth?
3828      my $addr = sprintf("0%o", $i * ($address_length == 8 ? 4 : 8));
3829      print STDERR "At index $i (address $addr):\n";
3830      error("$fname: stack trace depth >= 2**32\n");
3831    }
3832    if ($slots->get($i) == 0) {
3833      # End of profile data marker
3834      $i += $d;
3835      last;
3836    }
3837
3838    # Make key out of the stack entries
3839    my @k = ();
3840    for (my $j = 0; $j < $d; $j++) {
3841      my $pc = $slots->get($i+$j);
3842      # Subtract one from caller pc so we map back to call instr.
3843      # However, don't do this if we're reading a symbolized profile
3844      # file, in which case the subtract-one was done when the file
3845      # was written.
3846      if ($j > 0 && !$main::use_symbolized_profile) {
3847        $pc--;
3848      }
3849      $pc = sprintf("%0*x", $address_length, $pc);
3850      $pcs->{$pc} = 1;
3851      push @k, $pc;
3852    }
3853
3854    AddEntry($profile, (join "\n", @k), $n);
3855    $i += $d;
3856  }
3857
3858  # Parse map
3859  my $map = '';
3860  seek(PROFILE, $i * 4, 0);
3861  read(PROFILE, $map, (stat PROFILE)[7]);
3862
3863  my $r = {};
3864  $r->{version} = $version;
3865  $r->{period} = $period;
3866  $r->{profile} = $profile;
3867  $r->{libs} = ParseLibraries($prog, $map, $pcs);
3868  $r->{pcs} = $pcs;
3869
3870  return $r;
3871}
3872
3873sub ReadHeapProfile {
3874  my $prog = shift;
3875  local *PROFILE = shift;
3876  my $header = shift;
3877
3878  my $index = 1;
3879  if ($main::opt_inuse_space) {
3880    $index = 1;
3881  } elsif ($main::opt_inuse_objects) {
3882    $index = 0;
3883  } elsif ($main::opt_alloc_space) {
3884    $index = 3;
3885  } elsif ($main::opt_alloc_objects) {
3886    $index = 2;
3887  }
3888
3889  # Find the type of this profile.  The header line looks like:
3890  #    heap profile:   1246:  8800744 [  1246:  8800744] @ <heap-url>/266053
3891  # There are two pairs <count: size>, the first inuse objects/space, and the
3892  # second allocated objects/space.  This is followed optionally by a profile
3893  # type, and if that is present, optionally by a sampling frequency.
3894  # For remote heap profiles (v1):
3895  # The interpretation of the sampling frequency is that the profiler, for
3896  # each sample, calculates a uniformly distributed random integer less than
3897  # the given value, and records the next sample after that many bytes have
3898  # been allocated.  Therefore, the expected sample interval is half of the
3899  # given frequency.  By default, if not specified, the expected sample
3900  # interval is 128KB.  Only remote-heap-page profiles are adjusted for
3901  # sample size.
3902  # For remote heap profiles (v2):
3903  # The sampling frequency is the rate of a Poisson process. This means that
3904  # the probability of sampling an allocation of size X with sampling rate Y
3905  # is 1 - exp(-X/Y)
3906  # For version 2, a typical header line might look like this:
3907  # heap profile:   1922: 127792360 [  1922: 127792360] @ <heap-url>_v2/524288
3908  # the trailing number (524288) is the sampling rate. (Version 1 showed
3909  # double the 'rate' here)
3910  my $sampling_algorithm = 0;
3911  my $sample_adjustment = 0;
3912  chomp($header);
3913  my $type = "unknown";
3914  if ($header =~ m"^heap profile:\s*(\d+):\s+(\d+)\s+\[\s*(\d+):\s+(\d+)\](\s*@\s*([^/]*)(/(\d+))?)?") {
3915    if (defined($6) && ($6 ne '')) {
3916      $type = $6;
3917      my $sample_period = $8;
3918      # $type is "heapprofile" for profiles generated by the
3919      # heap-profiler, and either "heap" or "heap_v2" for profiles
3920      # generated by sampling directly within tcmalloc.  It can also
3921      # be "growth" for heap-growth profiles.  The first is typically
3922      # found for profiles generated locally, and the others for
3923      # remote profiles.
3924      if (($type eq "heapprofile") || ($type !~ /heap/) ) {
3925        # No need to adjust for the sampling rate with heap-profiler-derived data
3926        $sampling_algorithm = 0;
3927      } elsif ($type =~ /_v2/) {
3928        $sampling_algorithm = 2;     # version 2 sampling
3929        if (defined($sample_period) && ($sample_period ne '')) {
3930          $sample_adjustment = int($sample_period);
3931        }
3932      } else {
3933        $sampling_algorithm = 1;     # version 1 sampling
3934        if (defined($sample_period) && ($sample_period ne '')) {
3935          $sample_adjustment = int($sample_period)/2;
3936        }
3937      }
3938    } else {
3939      # We detect whether or not this is a remote-heap profile by checking
3940      # that the total-allocated stats ($n2,$s2) are exactly the
3941      # same as the in-use stats ($n1,$s1).  It is remotely conceivable
3942      # that a non-remote-heap profile may pass this check, but it is hard
3943      # to imagine how that could happen.
3944      # In this case it's so old it's guaranteed to be remote-heap version 1.
3945      my ($n1, $s1, $n2, $s2) = ($1, $2, $3, $4);
3946      if (($n1 == $n2) && ($s1 == $s2)) {
3947        # This is likely to be a remote-heap based sample profile
3948        $sampling_algorithm = 1;
3949      }
3950    }
3951  }
3952
3953  if ($sampling_algorithm > 0) {
3954    # For remote-heap generated profiles, adjust the counts and sizes to
3955    # account for the sample rate (we sample once every 128KB by default).
3956    if ($sample_adjustment == 0) {
3957      # Turn on profile adjustment.
3958      $sample_adjustment = 128*1024;
3959      print STDERR "Adjusting heap profiles for 1-in-128KB sampling rate\n";
3960    } else {
3961      printf STDERR ("Adjusting heap profiles for 1-in-%d sampling rate\n",
3962                     $sample_adjustment);
3963    }
3964    if ($sampling_algorithm > 1) {
3965      # We don't bother printing anything for the original version (version 1)
3966      printf STDERR "Heap version $sampling_algorithm\n";
3967    }
3968  }
3969
3970  my $profile = {};
3971  my $pcs = {};
3972  my $map = "";
3973
3974  while (<PROFILE>) {
3975    s/\r//g;         # turn windows-looking lines into unix-looking lines
3976    if (/^MAPPED_LIBRARIES:/) {
3977      # Read the /proc/self/maps data
3978      while (<PROFILE>) {
3979        s/\r//g;         # turn windows-looking lines into unix-looking lines
3980        $map .= $_;
3981      }
3982      last;
3983    }
3984
3985    if (/^--- Memory map:/) {
3986      # Read /proc/self/maps data as formatted by DumpAddressMap()
3987      my $buildvar = "";
3988      while (<PROFILE>) {
3989        s/\r//g;         # turn windows-looking lines into unix-looking lines
3990        # Parse "build=<dir>" specification if supplied
3991        if (m/^\s*build=(.*)\n/) {
3992          $buildvar = $1;
3993        }
3994
3995        # Expand "$build" variable if available
3996        $_ =~ s/\$build\b/$buildvar/g;
3997
3998        $map .= $_;
3999      }
4000      last;
4001    }
4002
4003    # Read entry of the form:
4004    #  <count1>: <bytes1> [<count2>: <bytes2>] @ a1 a2 a3 ... an
4005    s/^\s*//;
4006    s/\s*$//;
4007    if (m/^\s*(\d+):\s+(\d+)\s+\[\s*(\d+):\s+(\d+)\]\s+@\s+(.*)$/) {
4008      my $stack = $5;
4009      my ($n1, $s1, $n2, $s2) = ($1, $2, $3, $4);
4010
4011      if ($sample_adjustment) {
4012        if ($sampling_algorithm == 2) {
4013          # Remote-heap version 2
4014          # The sampling frequency is the rate of a Poisson process.
4015          # This means that the probability of sampling an allocation of
4016          # size X with sampling rate Y is 1 - exp(-X/Y)
4017          if ($n1 != 0) {
4018            my $ratio = (($s1*1.0)/$n1)/($sample_adjustment);
4019            my $scale_factor = 1/(1 - exp(-$ratio));
4020            $n1 *= $scale_factor;
4021            $s1 *= $scale_factor;
4022          }
4023          if ($n2 != 0) {
4024            my $ratio = (($s2*1.0)/$n2)/($sample_adjustment);
4025            my $scale_factor = 1/(1 - exp(-$ratio));
4026            $n2 *= $scale_factor;
4027            $s2 *= $scale_factor;
4028          }
4029        } else {
4030          # Remote-heap version 1
4031          my $ratio;
4032          $ratio = (($s1*1.0)/$n1)/($sample_adjustment);
4033          if ($ratio < 1) {
4034            $n1 /= $ratio;
4035            $s1 /= $ratio;
4036          }
4037          $ratio = (($s2*1.0)/$n2)/($sample_adjustment);
4038          if ($ratio < 1) {
4039            $n2 /= $ratio;
4040            $s2 /= $ratio;
4041          }
4042        }
4043      }
4044
4045      my @counts = ($n1, $s1, $n2, $s2);
4046      AddEntries($profile, $pcs, FixCallerAddresses($stack), $counts[$index]);
4047    }
4048  }
4049
4050  my $r = {};
4051  $r->{version} = "heap";
4052  $r->{period} = 1;
4053  $r->{profile} = $profile;
4054  $r->{libs} = ParseLibraries($prog, $map, $pcs);
4055  $r->{pcs} = $pcs;
4056  return $r;
4057}
4058
4059sub ReadSynchProfile {
4060  my $prog = shift;
4061  local *PROFILE = shift;
4062  my $header = shift;
4063
4064  my $map = '';
4065  my $profile = {};
4066  my $pcs = {};
4067  my $sampling_period = 1;
4068  my $cyclespernanosec = 2.8;   # Default assumption for old binaries
4069  my $seen_clockrate = 0;
4070  my $line;
4071
4072  my $index = 0;
4073  if ($main::opt_total_delay) {
4074    $index = 0;
4075  } elsif ($main::opt_contentions) {
4076    $index = 1;
4077  } elsif ($main::opt_mean_delay) {
4078    $index = 2;
4079  }
4080
4081  while ( $line = <PROFILE> ) {
4082    $line =~ s/\r//g;      # turn windows-looking lines into unix-looking lines
4083    if ( $line =~ /^\s*(\d+)\s+(\d+) \@\s*(.*?)\s*$/ ) {
4084      my ($cycles, $count, $stack) = ($1, $2, $3);
4085
4086      # Convert cycles to nanoseconds
4087      $cycles /= $cyclespernanosec;
4088
4089      # Adjust for sampling done by application
4090      $cycles *= $sampling_period;
4091      $count *= $sampling_period;
4092
4093      my @values = ($cycles, $count, $cycles / $count);
4094      AddEntries($profile, $pcs, FixCallerAddresses($stack), $values[$index]);
4095
4096    } elsif ( $line =~ /^(slow release).*thread \d+  \@\s*(.*?)\s*$/ ||
4097              $line =~ /^\s*(\d+) \@\s*(.*?)\s*$/ ) {
4098      my ($cycles, $stack) = ($1, $2);
4099      if ($cycles !~ /^\d+$/) {
4100        next;
4101      }
4102
4103      # Convert cycles to nanoseconds
4104      $cycles /= $cyclespernanosec;
4105
4106      # Adjust for sampling done by application
4107      $cycles *= $sampling_period;
4108
4109      AddEntries($profile, $pcs, FixCallerAddresses($stack), $cycles);
4110
4111    } elsif ( $line =~ m/^([a-z][^=]*)=(.*)$/ ) {
4112      my ($variable, $value) = ($1,$2);
4113      for ($variable, $value) {
4114        s/^\s+//;
4115        s/\s+$//;
4116      }
4117      if ($variable eq "cycles/second") {
4118        $cyclespernanosec = $value / 1e9;
4119        $seen_clockrate = 1;
4120      } elsif ($variable eq "sampling period") {
4121        $sampling_period = $value;
4122      } elsif ($variable eq "ms since reset") {
4123        # Currently nothing is done with this value in pprof
4124        # So we just silently ignore it for now
4125      } elsif ($variable eq "discarded samples") {
4126        # Currently nothing is done with this value in pprof
4127        # So we just silently ignore it for now
4128      } else {
4129        printf STDERR ("Ignoring unnknown variable in /contention output: " .
4130                       "'%s' = '%s'\n",$variable,$value);
4131      }
4132    } else {
4133      # Memory map entry
4134      $map .= $line;
4135    }
4136  }
4137
4138  if (!$seen_clockrate) {
4139    printf STDERR ("No cycles/second entry in profile; Guessing %.1f GHz\n",
4140                   $cyclespernanosec);
4141  }
4142
4143  my $r = {};
4144  $r->{version} = 0;
4145  $r->{period} = $sampling_period;
4146  $r->{profile} = $profile;
4147  $r->{libs} = ParseLibraries($prog, $map, $pcs);
4148  $r->{pcs} = $pcs;
4149  return $r;
4150}
4151
4152# Given a hex value in the form "0x1abcd" or "1abcd", return either
4153# "0001abcd" or "000000000001abcd", depending on the current (global)
4154# address length.
4155sub HexExtend {
4156  my $addr = shift;
4157
4158  $addr =~ s/^(0x)?0*//;
4159  my $zeros_needed = $address_length - length($addr);
4160  if ($zeros_needed < 0) {
4161    printf STDERR "Warning: address $addr is longer than address length $address_length\n";
4162    return $addr;
4163  }
4164  return ("0" x $zeros_needed) . $addr;
4165}
4166
4167##### Symbol extraction #####
4168
4169# Aggressively search the lib_prefix values for the given library
4170# If all else fails, just return the name of the library unmodified.
4171# If the lib_prefix is "/my/path,/other/path" and $file is "/lib/dir/mylib.so"
4172# it will search the following locations in this order, until it finds a file:
4173#   /my/path/lib/dir/mylib.so
4174#   /other/path/lib/dir/mylib.so
4175#   /my/path/dir/mylib.so
4176#   /other/path/dir/mylib.so
4177#   /my/path/mylib.so
4178#   /other/path/mylib.so
4179#   /lib/dir/mylib.so              (returned as last resort)
4180sub FindLibrary {
4181  my $file = shift;
4182  my $suffix = $file;
4183
4184  # Search for the library as described above
4185  do {
4186    foreach my $prefix (@prefix_list) {
4187      my $fullpath = $prefix . $suffix;
4188      if (-e $fullpath) {
4189        return $fullpath;
4190      }
4191    }
4192  } while ($suffix =~ s|^/[^/]+/|/|);
4193  return $file;
4194}
4195
4196# Return path to library with debugging symbols.
4197# For libc libraries, the copy in /usr/lib/debug contains debugging symbols
4198sub DebuggingLibrary {
4199  my $file = shift;
4200  if ($file =~ m|^/| && -f "/usr/lib/debug$file") {
4201    return "/usr/lib/debug$file";
4202  }
4203  return undef;
4204}
4205
4206# Parse text section header of a library using objdump
4207sub ParseTextSectionHeaderFromObjdump {
4208  my $lib = shift;
4209
4210  my $size = undef;
4211  my $vma;
4212  my $file_offset;
4213  # Get objdump output from the library file to figure out how to
4214  # map between mapped addresses and addresses in the library.
4215  my $cmd = ShellEscape($obj_tool_map{"objdump"}, "-h", $lib);
4216  open(OBJDUMP, "$cmd |") || error("$cmd: $!\n");
4217  while (<OBJDUMP>) {
4218    s/\r//g;         # turn windows-looking lines into unix-looking lines
4219    # Idx Name          Size      VMA       LMA       File off  Algn
4220    #  10 .text         00104b2c  420156f0  420156f0  000156f0  2**4
4221    # For 64-bit objects, VMA and LMA will be 16 hex digits, size and file
4222    # offset may still be 8.  But AddressSub below will still handle that.
4223    my @x = split;
4224    if (($#x >= 6) && ($x[1] eq '.text')) {
4225      $size = $x[2];
4226      $vma = $x[3];
4227      $file_offset = $x[5];
4228      last;
4229    }
4230  }
4231  close(OBJDUMP);
4232
4233  if (!defined($size)) {
4234    return undef;
4235  }
4236
4237  my $r = {};
4238  $r->{size} = $size;
4239  $r->{vma} = $vma;
4240  $r->{file_offset} = $file_offset;
4241
4242  return $r;
4243}
4244
4245# Parse text section header of a library using otool (on OS X)
4246sub ParseTextSectionHeaderFromOtool {
4247  my $lib = shift;
4248
4249  my $size = undef;
4250  my $vma = undef;
4251  my $file_offset = undef;
4252  # Get otool output from the library file to figure out how to
4253  # map between mapped addresses and addresses in the library.
4254  my $command = ShellEscape($obj_tool_map{"otool"}, "-l", $lib);
4255  open(OTOOL, "$command |") || error("$command: $!\n");
4256  my $cmd = "";
4257  my $sectname = "";
4258  my $segname = "";
4259  foreach my $line (<OTOOL>) {
4260    $line =~ s/\r//g;      # turn windows-looking lines into unix-looking lines
4261    # Load command <#>
4262    #       cmd LC_SEGMENT
4263    # [...]
4264    # Section
4265    #   sectname __text
4266    #    segname __TEXT
4267    #       addr 0x000009f8
4268    #       size 0x00018b9e
4269    #     offset 2552
4270    #      align 2^2 (4)
4271    # We will need to strip off the leading 0x from the hex addresses,
4272    # and convert the offset into hex.
4273    if ($line =~ /Load command/) {
4274      $cmd = "";
4275      $sectname = "";
4276      $segname = "";
4277    } elsif ($line =~ /Section/) {
4278      $sectname = "";
4279      $segname = "";
4280    } elsif ($line =~ /cmd (\w+)/) {
4281      $cmd = $1;
4282    } elsif ($line =~ /sectname (\w+)/) {
4283      $sectname = $1;
4284    } elsif ($line =~ /segname (\w+)/) {
4285      $segname = $1;
4286    } elsif (!(($cmd eq "LC_SEGMENT" || $cmd eq "LC_SEGMENT_64") &&
4287               $sectname eq "__text" &&
4288               $segname eq "__TEXT")) {
4289      next;
4290    } elsif ($line =~ /\baddr 0x([0-9a-fA-F]+)/) {
4291      $vma = $1;
4292    } elsif ($line =~ /\bsize 0x([0-9a-fA-F]+)/) {
4293      $size = $1;
4294    } elsif ($line =~ /\boffset ([0-9]+)/) {
4295      $file_offset = sprintf("%016x", $1);
4296    }
4297    if (defined($vma) && defined($size) && defined($file_offset)) {
4298      last;
4299    }
4300  }
4301  close(OTOOL);
4302
4303  if (!defined($vma) || !defined($size) || !defined($file_offset)) {
4304     return undef;
4305  }
4306
4307  my $r = {};
4308  $r->{size} = $size;
4309  $r->{vma} = $vma;
4310  $r->{file_offset} = $file_offset;
4311
4312  return $r;
4313}
4314
4315sub ParseTextSectionHeader {
4316  # obj_tool_map("otool") is only defined if we're in a Mach-O environment
4317  if (defined($obj_tool_map{"otool"})) {
4318    my $r = ParseTextSectionHeaderFromOtool(@_);
4319    if (defined($r)){
4320      return $r;
4321    }
4322  }
4323  # If otool doesn't work, or we don't have it, fall back to objdump
4324  return ParseTextSectionHeaderFromObjdump(@_);
4325}
4326
4327# Split /proc/pid/maps dump into a list of libraries
4328sub ParseLibraries {
4329  return if $main::use_symbol_page;  # We don't need libraries info.
4330  my $prog = shift;
4331  my $map = shift;
4332  my $pcs = shift;
4333
4334  my $result = [];
4335  my $h = "[a-f0-9]+";
4336  my $zero_offset = HexExtend("0");
4337
4338  my $buildvar = "";
4339  foreach my $l (split("\n", $map)) {
4340    if ($l =~ m/^\s*build=(.*)$/) {
4341      $buildvar = $1;
4342    }
4343
4344    my $start;
4345    my $finish;
4346    my $offset;
4347    my $lib;
4348    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) {
4349      # Full line from /proc/self/maps.  Example:
4350      #   40000000-40015000 r-xp 00000000 03:01 12845071   /lib/ld-2.3.2.so
4351      $start = HexExtend($1);
4352      $finish = HexExtend($2);
4353      $offset = HexExtend($3);
4354      $lib = $4;
4355      $lib =~ s|\\|/|g;     # turn windows-style paths into unix-style paths
4356    } elsif ($l =~ /^\s*($h)-($h):\s*(\S+\.so(\.\d+)*)/) {
4357      # Cooked line from DumpAddressMap.  Example:
4358      #   40000000-40015000: /lib/ld-2.3.2.so
4359      $start = HexExtend($1);
4360      $finish = HexExtend($2);
4361      $offset = $zero_offset;
4362      $lib = $3;
4363    } else {
4364      next;
4365    }
4366
4367    # Expand "$build" variable if available
4368    $lib =~ s/\$build\b/$buildvar/g;
4369
4370    $lib = FindLibrary($lib);
4371
4372    # Check for pre-relocated libraries, which use pre-relocated symbol tables
4373    # and thus require adjusting the offset that we'll use to translate
4374    # VM addresses into symbol table addresses.
4375    # Only do this if we're not going to fetch the symbol table from a
4376    # debugging copy of the library.
4377    if (!DebuggingLibrary($lib)) {
4378      my $text = ParseTextSectionHeader($lib);
4379      if (defined($text)) {
4380         my $vma_offset = AddressSub($text->{vma}, $text->{file_offset});
4381         $offset = AddressAdd($offset, $vma_offset);
4382      }
4383    }
4384
4385    push(@{$result}, [$lib, $start, $finish, $offset]);
4386  }
4387
4388  # Append special entry for additional library (not relocated)
4389  if ($main::opt_lib ne "") {
4390    my $text = ParseTextSectionHeader($main::opt_lib);
4391    if (defined($text)) {
4392       my $start = $text->{vma};
4393       my $finish = AddressAdd($start, $text->{size});
4394
4395       push(@{$result}, [$main::opt_lib, $start, $finish, $start]);
4396    }
4397  }
4398
4399  # Append special entry for the main program.  This covers
4400  # 0..max_pc_value_seen, so that we assume pc values not found in one
4401  # of the library ranges will be treated as coming from the main
4402  # program binary.
4403  my $min_pc = HexExtend("0");
4404  my $max_pc = $min_pc;          # find the maximal PC value in any sample
4405  foreach my $pc (keys(%{$pcs})) {
4406    if (HexExtend($pc) gt $max_pc) { $max_pc = HexExtend($pc); }
4407  }
4408  push(@{$result}, [$prog, $min_pc, $max_pc, $zero_offset]);
4409
4410  return $result;
4411}
4412
4413# Add two hex addresses of length $address_length.
4414# Run pprof --test for unit test if this is changed.
4415sub AddressAdd {
4416  my $addr1 = shift;
4417  my $addr2 = shift;
4418  my $sum;
4419
4420  if ($address_length == 8) {
4421    # Perl doesn't cope with wraparound arithmetic, so do it explicitly:
4422    $sum = (hex($addr1)+hex($addr2)) % (0x10000000 * 16);
4423    return sprintf("%08x", $sum);
4424
4425  } else {
4426    # Do the addition in 7-nibble chunks to trivialize carry handling.
4427
4428    if ($main::opt_debug and $main::opt_test) {
4429      print STDERR "AddressAdd $addr1 + $addr2 = ";
4430    }
4431
4432    my $a1 = substr($addr1,-7);
4433    $addr1 = substr($addr1,0,-7);
4434    my $a2 = substr($addr2,-7);
4435    $addr2 = substr($addr2,0,-7);
4436    $sum = hex($a1) + hex($a2);
4437    my $c = 0;
4438    if ($sum > 0xfffffff) {
4439      $c = 1;
4440      $sum -= 0x10000000;
4441    }
4442    my $r = sprintf("%07x", $sum);
4443
4444    $a1 = substr($addr1,-7);
4445    $addr1 = substr($addr1,0,-7);
4446    $a2 = substr($addr2,-7);
4447    $addr2 = substr($addr2,0,-7);
4448    $sum = hex($a1) + hex($a2) + $c;
4449    $c = 0;
4450    if ($sum > 0xfffffff) {
4451      $c = 1;
4452      $sum -= 0x10000000;
4453    }
4454    $r = sprintf("%07x", $sum) . $r;
4455
4456    $sum = hex($addr1) + hex($addr2) + $c;
4457    if ($sum > 0xff) { $sum -= 0x100; }
4458    $r = sprintf("%02x", $sum) . $r;
4459
4460    if ($main::opt_debug and $main::opt_test) { print STDERR "$r\n"; }
4461
4462    return $r;
4463  }
4464}
4465
4466
4467# Subtract two hex addresses of length $address_length.
4468# Run pprof --test for unit test if this is changed.
4469sub AddressSub {
4470  my $addr1 = shift;
4471  my $addr2 = shift;
4472  my $diff;
4473
4474  if ($address_length == 8) {
4475    # Perl doesn't cope with wraparound arithmetic, so do it explicitly:
4476    $diff = (hex($addr1)-hex($addr2)) % (0x10000000 * 16);
4477    return sprintf("%08x", $diff);
4478
4479  } else {
4480    # Do the addition in 7-nibble chunks to trivialize borrow handling.
4481    # if ($main::opt_debug) { print STDERR "AddressSub $addr1 - $addr2 = "; }
4482
4483    my $a1 = hex(substr($addr1,-7));
4484    $addr1 = substr($addr1,0,-7);
4485    my $a2 = hex(substr($addr2,-7));
4486    $addr2 = substr($addr2,0,-7);
4487    my $b = 0;
4488    if ($a2 > $a1) {
4489      $b = 1;
4490      $a1 += 0x10000000;
4491    }
4492    $diff = $a1 - $a2;
4493    my $r = sprintf("%07x", $diff);
4494
4495    $a1 = hex(substr($addr1,-7));
4496    $addr1 = substr($addr1,0,-7);
4497    $a2 = hex(substr($addr2,-7)) + $b;
4498    $addr2 = substr($addr2,0,-7);
4499    $b = 0;
4500    if ($a2 > $a1) {
4501      $b = 1;
4502      $a1 += 0x10000000;
4503    }
4504    $diff = $a1 - $a2;
4505    $r = sprintf("%07x", $diff) . $r;
4506
4507    $a1 = hex($addr1);
4508    $a2 = hex($addr2) + $b;
4509    if ($a2 > $a1) { $a1 += 0x100; }
4510    $diff = $a1 - $a2;
4511    $r = sprintf("%02x", $diff) . $r;
4512
4513    # if ($main::opt_debug) { print STDERR "$r\n"; }
4514
4515    return $r;
4516  }
4517}
4518
4519# Increment a hex addresses of length $address_length.
4520# Run pprof --test for unit test if this is changed.
4521sub AddressInc {
4522  my $addr = shift;
4523  my $sum;
4524
4525  if ($address_length == 8) {
4526    # Perl doesn't cope with wraparound arithmetic, so do it explicitly:
4527    $sum = (hex($addr)+1) % (0x10000000 * 16);
4528    return sprintf("%08x", $sum);
4529
4530  } else {
4531    # Do the addition in 7-nibble chunks to trivialize carry handling.
4532    # We are always doing this to step through the addresses in a function,
4533    # and will almost never overflow the first chunk, so we check for this
4534    # case and exit early.
4535
4536    # if ($main::opt_debug) { print STDERR "AddressInc $addr1 = "; }
4537
4538    my $a1 = substr($addr,-7);
4539    $addr = substr($addr,0,-7);
4540    $sum = hex($a1) + 1;
4541    my $r = sprintf("%07x", $sum);
4542    if ($sum <= 0xfffffff) {
4543      $r = $addr . $r;
4544      # if ($main::opt_debug) { print STDERR "$r\n"; }
4545      return HexExtend($r);
4546    } else {
4547      $r = "0000000";
4548    }
4549
4550    $a1 = substr($addr,-7);
4551    $addr = substr($addr,0,-7);
4552    $sum = hex($a1) + 1;
4553    $r = sprintf("%07x", $sum) . $r;
4554    if ($sum <= 0xfffffff) {
4555      $r = $addr . $r;
4556      # if ($main::opt_debug) { print STDERR "$r\n"; }
4557      return HexExtend($r);
4558    } else {
4559      $r = "00000000000000";
4560    }
4561
4562    $sum = hex($addr) + 1;
4563    if ($sum > 0xff) { $sum -= 0x100; }
4564    $r = sprintf("%02x", $sum) . $r;
4565
4566    # if ($main::opt_debug) { print STDERR "$r\n"; }
4567    return $r;
4568  }
4569}
4570
4571# Extract symbols for all PC values found in profile
4572sub ExtractSymbols {
4573  my $libs = shift;
4574  my $pcset = shift;
4575
4576  my $symbols = {};
4577
4578  # Map each PC value to the containing library.  To make this faster,
4579  # we sort libraries by their starting pc value (highest first), and
4580  # advance through the libraries as we advance the pc.  Sometimes the
4581  # addresses of libraries may overlap with the addresses of the main
4582  # binary, so to make sure the libraries 'win', we iterate over the
4583  # libraries in reverse order (which assumes the binary doesn't start
4584  # in the middle of a library, which seems a fair assumption).
4585  my @pcs = (sort { $a cmp $b } keys(%{$pcset}));  # pcset is 0-extended strings
4586  foreach my $lib (sort {$b->[1] cmp $a->[1]} @{$libs}) {
4587    my $libname = $lib->[0];
4588    my $start = $lib->[1];
4589    my $finish = $lib->[2];
4590    my $offset = $lib->[3];
4591
4592    # Get list of pcs that belong in this library.
4593    my $contained = [];
4594    my ($start_pc_index, $finish_pc_index);
4595    # Find smallest finish_pc_index such that $finish < $pc[$finish_pc_index].
4596    for ($finish_pc_index = $#pcs + 1; $finish_pc_index > 0;
4597         $finish_pc_index--) {
4598      last if $pcs[$finish_pc_index - 1] le $finish;
4599    }
4600    # Find smallest start_pc_index such that $start <= $pc[$start_pc_index].
4601    for ($start_pc_index = $finish_pc_index; $start_pc_index > 0;
4602         $start_pc_index--) {
4603      last if $pcs[$start_pc_index - 1] lt $start;
4604    }
4605    # This keeps PC values higher than $pc[$finish_pc_index] in @pcs,
4606    # in case there are overlaps in libraries and the main binary.
4607    @{$contained} = splice(@pcs, $start_pc_index,
4608                           $finish_pc_index - $start_pc_index);
4609    # Map to symbols
4610    MapToSymbols($libname, AddressSub($start, $offset), $contained, $symbols);
4611  }
4612
4613  return $symbols;
4614}
4615
4616# Map list of PC values to symbols for a given image
4617sub MapToSymbols {
4618  my $image = shift;
4619  my $offset = shift;
4620  my $pclist = shift;
4621  my $symbols = shift;
4622
4623  my $debug = 0;
4624
4625  # Ignore empty binaries
4626  if ($#{$pclist} < 0) { return; }
4627
4628  # Figure out the addr2line command to use
4629  my $addr2line = $obj_tool_map{"addr2line"};
4630  my $cmd = ShellEscape($addr2line, "-f", "-C", "-e", $image);
4631  if (exists $obj_tool_map{"addr2line_pdb"}) {
4632    $addr2line = $obj_tool_map{"addr2line_pdb"};
4633    $cmd = ShellEscape($addr2line, "--demangle", "-f", "-C", "-e", $image);
4634  }
4635
4636  # If "addr2line" isn't installed on the system at all, just use
4637  # nm to get what info we can (function names, but not line numbers).
4638  if (system(ShellEscape($addr2line, "--help") . " >$dev_null 2>&1") != 0) {
4639    MapSymbolsWithNM($image, $offset, $pclist, $symbols);
4640    return;
4641  }
4642
4643  # "addr2line -i" can produce a variable number of lines per input
4644  # address, with no separator that allows us to tell when data for
4645  # the next address starts.  So we find the address for a special
4646  # symbol (_fini) and interleave this address between all real
4647  # addresses passed to addr2line.  The name of this special symbol
4648  # can then be used as a separator.
4649  $sep_address = undef;  # May be filled in by MapSymbolsWithNM()
4650  my $nm_symbols = {};
4651  MapSymbolsWithNM($image, $offset, $pclist, $nm_symbols);
4652  if (defined($sep_address)) {
4653    # Only add " -i" to addr2line if the binary supports it.
4654    # addr2line --help returns 0, but not if it sees an unknown flag first.
4655    if (system("$cmd -i --help >$dev_null 2>&1") == 0) {
4656      $cmd .= " -i";
4657    } else {
4658      $sep_address = undef;   # no need for sep_address if we don't support -i
4659    }
4660  }
4661
4662  # Make file with all PC values with intervening 'sep_address' so
4663  # that we can reliably detect the end of inlined function list
4664  open(ADDRESSES, ">$main::tmpfile_sym") || error("$main::tmpfile_sym: $!\n");
4665  if ($debug) { print("---- $image ---\n"); }
4666  for (my $i = 0; $i <= $#{$pclist}; $i++) {
4667    # addr2line always reads hex addresses, and does not need '0x' prefix.
4668    if ($debug) { printf STDERR ("%s\n", $pclist->[$i]); }
4669    printf ADDRESSES ("%s\n", AddressSub($pclist->[$i], $offset));
4670    if (defined($sep_address)) {
4671      printf ADDRESSES ("%s\n", $sep_address);
4672    }
4673  }
4674  close(ADDRESSES);
4675  if ($debug) {
4676    print("----\n");
4677    system("cat", $main::tmpfile_sym);
4678    print("----\n");
4679    system("$cmd < " . ShellEscape($main::tmpfile_sym));
4680    print("----\n");
4681  }
4682
4683  open(SYMBOLS, "$cmd <" . ShellEscape($main::tmpfile_sym) . " |")
4684      || error("$cmd: $!\n");
4685  my $count = 0;   # Index in pclist
4686  while (<SYMBOLS>) {
4687    # Read fullfunction and filelineinfo from next pair of lines
4688    s/\r?\n$//g;
4689    my $fullfunction = $_;
4690    $_ = <SYMBOLS>;
4691    s/\r?\n$//g;
4692    my $filelinenum = $_;
4693
4694    if (defined($sep_address) && $fullfunction eq $sep_symbol) {
4695      # Terminating marker for data for this address
4696      $count++;
4697      next;
4698    }
4699
4700    $filelinenum =~ s|\\|/|g; # turn windows-style paths into unix-style paths
4701
4702    my $pcstr = $pclist->[$count];
4703    my $function = ShortFunctionName($fullfunction);
4704    my $nms = $nm_symbols->{$pcstr};
4705    if (defined($nms)) {
4706      if ($fullfunction eq '??') {
4707        # nm found a symbol for us.
4708        $function = $nms->[0];
4709        $fullfunction = $nms->[2];
4710      } else {
4711	# MapSymbolsWithNM tags each routine with its starting address,
4712	# useful in case the image has multiple occurrences of this
4713	# routine.  (It uses a syntax that resembles template paramters,
4714	# that are automatically stripped out by ShortFunctionName().)
4715	# addr2line does not provide the same information.  So we check
4716	# if nm disambiguated our symbol, and if so take the annotated
4717	# (nm) version of the routine-name.  TODO(csilvers): this won't
4718	# catch overloaded, inlined symbols, which nm doesn't see.
4719	# Better would be to do a check similar to nm's, in this fn.
4720	if ($nms->[2] =~ m/^\Q$function\E/) {  # sanity check it's the right fn
4721	  $function = $nms->[0];
4722	  $fullfunction = $nms->[2];
4723	}
4724      }
4725    }
4726    
4727    # Prepend to accumulated symbols for pcstr
4728    # (so that caller comes before callee)
4729    my $sym = $symbols->{$pcstr};
4730    if (!defined($sym)) {
4731      $sym = [];
4732      $symbols->{$pcstr} = $sym;
4733    }
4734    unshift(@{$sym}, $function, $filelinenum, $fullfunction);
4735    if ($debug) { printf STDERR ("%s => [%s]\n", $pcstr, join(" ", @{$sym})); }
4736    if (!defined($sep_address)) {
4737      # Inlining is off, so this entry ends immediately
4738      $count++;
4739    }
4740  }
4741  close(SYMBOLS);
4742}
4743
4744# Use nm to map the list of referenced PCs to symbols.  Return true iff we
4745# are able to read procedure information via nm.
4746sub MapSymbolsWithNM {
4747  my $image = shift;
4748  my $offset = shift;
4749  my $pclist = shift;
4750  my $symbols = shift;
4751
4752  # Get nm output sorted by increasing address
4753  my $symbol_table = GetProcedureBoundaries($image, ".");
4754  if (!%{$symbol_table}) {
4755    return 0;
4756  }
4757  # Start addresses are already the right length (8 or 16 hex digits).
4758  my @names = sort { $symbol_table->{$a}->[0] cmp $symbol_table->{$b}->[0] }
4759    keys(%{$symbol_table});
4760
4761  if ($#names < 0) {
4762    # No symbols: just use addresses
4763    foreach my $pc (@{$pclist}) {
4764      my $pcstr = "0x" . $pc;
4765      $symbols->{$pc} = [$pcstr, "?", $pcstr];
4766    }
4767    return 0;
4768  }
4769
4770  # Sort addresses so we can do a join against nm output
4771  my $index = 0;
4772  my $fullname = $names[0];
4773  my $name = ShortFunctionName($fullname);
4774  foreach my $pc (sort { $a cmp $b } @{$pclist}) {
4775    # Adjust for mapped offset
4776    my $mpc = AddressSub($pc, $offset);
4777    while (($index < $#names) && ($mpc ge $symbol_table->{$fullname}->[1])){
4778      $index++;
4779      $fullname = $names[$index];
4780      $name = ShortFunctionName($fullname);
4781    }
4782    if ($mpc lt $symbol_table->{$fullname}->[1]) {
4783      $symbols->{$pc} = [$name, "?", $fullname];
4784    } else {
4785      my $pcstr = "0x" . $pc;
4786      $symbols->{$pc} = [$pcstr, "?", $pcstr];
4787    }
4788  }
4789  return 1;
4790}
4791
4792sub ShortFunctionName {
4793  my $function = shift;
4794  while ($function =~ s/\([^()]*\)(\s*const)?//g) { }   # Argument types
4795  while ($function =~ s/<[^<>]*>//g)  { }    # Remove template arguments
4796  $function =~ s/^.*\s+(\w+::)/$1/;          # Remove leading type
4797  return $function;
4798}
4799
4800# Trim overly long symbols found in disassembler output
4801sub CleanDisassembly {
4802  my $d = shift;
4803  while ($d =~ s/\([^()%]*\)(\s*const)?//g) { } # Argument types, not (%rax)
4804  while ($d =~ s/(\w+)<[^<>]*>/$1/g)  { }       # Remove template arguments
4805  return $d;
4806}
4807
4808# Clean file name for display
4809sub CleanFileName {
4810  my ($f) = @_;
4811  $f =~ s|^/proc/self/cwd/||;
4812  $f =~ s|^\./||;
4813  return $f;
4814}
4815
4816# Make address relative to section and clean up for display
4817sub UnparseAddress {
4818  my ($offset, $address) = @_;
4819  $address = AddressSub($address, $offset);
4820  $address =~ s/^0x//;
4821  $address =~ s/^0*//;
4822  return $address;
4823}
4824
4825##### Miscellaneous #####
4826
4827# Find the right versions of the above object tools to use.  The
4828# argument is the program file being analyzed, and should be an ELF
4829# 32-bit or ELF 64-bit executable file.  The location of the tools
4830# is determined by considering the following options in this order:
4831#   1) --tools option, if set
4832#   2) PPROF_TOOLS environment variable, if set
4833#   3) the environment
4834sub ConfigureObjTools {
4835  my $prog_file = shift;
4836
4837  # Check for the existence of $prog_file because /usr/bin/file does not
4838  # predictably return error status in prod.
4839  (-e $prog_file)  || error("$prog_file does not exist.\n");
4840
4841  my $file_type = undef;
4842  if (-e "/usr/bin/file") {
4843    # Follow symlinks (at least for systems where "file" supports that).
4844    my $escaped_prog_file = ShellEscape($prog_file);
4845    $file_type = `/usr/bin/file -L $escaped_prog_file 2>$dev_null ||
4846                  /usr/bin/file $escaped_prog_file`;
4847  } elsif ($^O == "MSWin32") {
4848    $file_type = "MS Windows";
4849  } else {
4850    print STDERR "WARNING: Can't determine the file type of $prog_file";
4851  }
4852
4853  if ($file_type =~ /64-bit/) {
4854    # Change $address_length to 16 if the program file is ELF 64-bit.
4855    # We can't detect this from many (most?) heap or lock contention
4856    # profiles, since the actual addresses referenced are generally in low
4857    # memory even for 64-bit programs.
4858    $address_length = 16;
4859  }
4860
4861  if ($file_type =~ /MS Windows/) {
4862    # For windows, we provide a version of nm and addr2line as part of
4863    # the opensource release, which is capable of parsing
4864    # Windows-style PDB executables.  It should live in the path, or
4865    # in the same directory as pprof.
4866    $obj_tool_map{"nm_pdb"} = "nm-pdb";
4867    $obj_tool_map{"addr2line_pdb"} = "addr2line-pdb";
4868  }
4869
4870  if ($file_type =~ /Mach-O/) {
4871    # OS X uses otool to examine Mach-O files, rather than objdump.
4872    $obj_tool_map{"otool"} = "otool";
4873    $obj_tool_map{"addr2line"} = "false";  # no addr2line
4874    $obj_tool_map{"objdump"} = "false";  # no objdump
4875  }
4876
4877  # Go fill in %obj_tool_map with the pathnames to use:
4878  foreach my $tool (keys %obj_tool_map) {
4879    $obj_tool_map{$tool} = ConfigureTool($obj_tool_map{$tool});
4880  }
4881}
4882
4883# Returns the path of a caller-specified object tool.  If --tools or
4884# PPROF_TOOLS are specified, then returns the full path to the tool
4885# with that prefix.  Otherwise, returns the path unmodified (which
4886# means we will look for it on PATH).
4887sub ConfigureTool {
4888  my $tool = shift;
4889  my $path;
4890
4891  # --tools (or $PPROF_TOOLS) is a comma separated list, where each
4892  # item is either a) a pathname prefix, or b) a map of the form
4893  # <tool>:<path>.  First we look for an entry of type (b) for our
4894  # tool.  If one is found, we use it.  Otherwise, we consider all the
4895  # pathname prefixes in turn, until one yields an existing file.  If
4896  # none does, we use a default path.
4897  my $tools = $main::opt_tools || $ENV{"PPROF_TOOLS"} || "";
4898  if ($tools =~ m/(,|^)\Q$tool\E:([^,]*)/) {
4899    $path = $2;
4900    # TODO(csilvers): sanity-check that $path exists?  Hard if it's relative.
4901  } elsif ($tools ne '') {
4902    foreach my $prefix (split(',', $tools)) {
4903      next if ($prefix =~ /:/);    # ignore "tool:fullpath" entries in the list
4904      if (-x $prefix . $tool) {
4905        $path = $prefix . $tool;
4906        last;
4907      }
4908    }
4909    if (!$path) {
4910      error("No '$tool' found with prefix specified by " .
4911            "--tools (or \$PPROF_TOOLS) '$tools'\n");
4912    }
4913  } else {
4914    # ... otherwise use the version that exists in the same directory as
4915    # pprof.  If there's nothing there, use $PATH.
4916    $0 =~ m,[^/]*$,;     # this is everything after the last slash
4917    my $dirname = $`;    # this is everything up to and including the last slash
4918    if (-x "$dirname$tool") {
4919      $path = "$dirname$tool";
4920    } else { 
4921      $path = $tool;
4922    }
4923  }
4924  if ($main::opt_debug) { print STDERR "Using '$path' for '$tool'.\n"; }
4925  return $path;
4926}
4927
4928sub ShellEscape {
4929  my @escaped_words = ();
4930  foreach my $word (@_) {
4931    my $escaped_word = $word;
4932    if ($word =~ m![^a-zA-Z0-9/.,_=-]!) {  # check for anything not in whitelist
4933      $escaped_word =~ s/'/'\\''/;
4934      $escaped_word = "'$escaped_word'";
4935    }
4936    push(@escaped_words, $escaped_word);
4937  }
4938  return join(" ", @escaped_words);
4939}
4940
4941sub cleanup {
4942  unlink($main::tmpfile_sym);
4943  unlink(keys %main::tempnames);
4944
4945  # We leave any collected profiles in $HOME/pprof in case the user wants
4946  # to look at them later.  We print a message informing them of this.
4947  if ((scalar(@main::profile_files) > 0) &&
4948      defined($main::collected_profile)) {
4949    if (scalar(@main::profile_files) == 1) {
4950      print STDERR "Dynamically gathered profile is in $main::collected_profile\n";
4951    }
4952    print STDERR "If you want to investigate this profile further, you can do:\n";
4953    print STDERR "\n";
4954    print STDERR "  pprof \\\n";
4955    print STDERR "    $main::prog \\\n";
4956    print STDERR "    $main::collected_profile\n";
4957    print STDERR "\n";
4958  }
4959}
4960
4961sub sighandler {
4962  cleanup();
4963  exit(1);
4964}
4965
4966sub error {
4967  my $msg = shift;
4968  print STDERR $msg;
4969  cleanup();
4970  exit(1);
4971}
4972
4973
4974# Run $nm_command and get all the resulting procedure boundaries whose
4975# names match "$regexp" and returns them in a hashtable mapping from
4976# procedure name to a two-element vector of [start address, end address]
4977sub GetProcedureBoundariesViaNm {
4978  my $escaped_nm_command = shift;    # shell-escaped
4979  my $regexp = shift;
4980
4981  my $symbol_table = {};
4982  open(NM, "$escaped_nm_command |") || error("$escaped_nm_command: $!\n");
4983  my $last_start = "0";
4984  my $routine = "";
4985  while (<NM>) {
4986    s/\r//g;         # turn windows-looking lines into unix-looking lines
4987    if (m/^\s*([0-9a-f]+) (.) (..*)/) {
4988      my $start_val = $1;
4989      my $type = $2;
4990      my $this_routine = $3;
4991
4992      # It's possible for two symbols to share the same address, if
4993      # one is a zero-length variable (like __start_google_malloc) or
4994      # one symbol is a weak alias to another (like __libc_malloc).
4995      # In such cases, we want to ignore all values except for the
4996      # actual symbol, which in nm-speak has type "T".  The logic
4997      # below does this, though it's a bit tricky: what happens when
4998      # we have a series of lines with the same address, is the first
4999      # one gets queued up to be processed.  However, it won't
5000      # *actually* be processed until later, when we read a line with
5001      # a different address.  That means that as long as we're reading
5002      # lines with the same address, we have a chance to replace that
5003      # item in the queue, which we do whenever we see a 'T' entry --
5004      # that is, a line with type 'T'.  If we never see a 'T' entry,
5005      # we'll just go ahead and process the first entry (which never
5006      # got touched in the queue), and ignore the others.
5007      if ($start_val eq $last_start && $type =~ /t/i) {
5008        # We are the 'T' symbol at this address, replace previous symbol.
5009        $routine = $this_routine;
5010        next;
5011      } elsif ($start_val eq $last_start) {
5012        # We're not the 'T' symbol at this address, so ignore us.
5013        next;
5014      }
5015
5016      if ($this_routine eq $sep_symbol) {
5017        $sep_address = HexExtend($start_val);
5018      }
5019
5020      # Tag this routine with the starting address in case the image
5021      # has multiple occurrences of this routine.  We use a syntax
5022      # that resembles template paramters that are automatically
5023      # stripped out by ShortFunctionName()
5024      $this_routine .= "<$start_val>";
5025
5026      if (defined($routine) && $routine =~ m/$regexp/) {
5027        $symbol_table->{$routine} = [HexExtend($last_start),
5028                                     HexExtend($start_val)];
5029      }
5030      $last_start = $start_val;
5031      $routine = $this_routine;
5032    } elsif (m/^Loaded image name: (.+)/) {
5033      # The win32 nm workalike emits information about the binary it is using.
5034      if ($main::opt_debug) { print STDERR "Using Image $1\n"; }
5035    } elsif (m/^PDB file name: (.+)/) {
5036      # The win32 nm workalike emits information about the pdb it is using.
5037      if ($main::opt_debug) { print STDERR "Using PDB $1\n"; }
5038    }
5039  }
5040  close(NM);
5041  # Handle the last line in the nm output.  Unfortunately, we don't know
5042  # how big this last symbol is, because we don't know how big the file
5043  # is.  For now, we just give it a size of 0.
5044  # TODO(csilvers): do better here.
5045  if (defined($routine) && $routine =~ m/$regexp/) {
5046    $symbol_table->{$routine} = [HexExtend($last_start),
5047                                 HexExtend($last_start)];
5048  }
5049  return $symbol_table;
5050}
5051
5052# Gets the procedure boundaries for all routines in "$image" whose names
5053# match "$regexp" and returns them in a hashtable mapping from procedure
5054# name to a two-element vector of [start address, end address].
5055# Will return an empty map if nm is not installed or not working properly.
5056sub GetProcedureBoundaries {
5057  my $image = shift;
5058  my $regexp = shift;
5059
5060  # If $image doesn't start with /, then put ./ in front of it.  This works
5061  # around an obnoxious bug in our probing of nm -f behavior.
5062  # "nm -f $image" is supposed to fail on GNU nm, but if:
5063  #
5064  # a. $image starts with [BbSsPp] (for example, bin/foo/bar), AND
5065  # b. you have a.out in your current directory (a not uncommon occurence)
5066  #
5067  # then "nm -f $image" succeeds because -f only looks at the first letter of
5068  # the argument, which looks valid because it's [BbSsPp], and then since
5069  # there's no image provided, it looks for a.out and finds it.
5070  #
5071  # This regex makes sure that $image starts with . or /, forcing the -f
5072  # parsing to fail since . and / are not valid formats.
5073  $image =~ s#^[^/]#./$&#;
5074
5075  # For libc libraries, the copy in /usr/lib/debug contains debugging symbols
5076  my $debugging = DebuggingLibrary($image);
5077  if ($debugging) {
5078    $image = $debugging;
5079  }
5080
5081  my $nm = $obj_tool_map{"nm"};
5082  my $cppfilt = $obj_tool_map{"c++filt"};
5083
5084  # nm can fail for two reasons: 1) $image isn't a debug library; 2) nm
5085  # binary doesn't support --demangle.  In addition, for OS X we need
5086  # to use the -f flag to get 'flat' nm output (otherwise we don't sort
5087  # properly and get incorrect results).  Unfortunately, GNU nm uses -f
5088  # in an incompatible way.  So first we test whether our nm supports
5089  # --demangle and -f.
5090  my $demangle_flag = "";
5091  my $cppfilt_flag = "";
5092  my $to_devnull = ">$dev_null 2>&1";
5093  if (system(ShellEscape($nm, "--demangle", "image") . $to_devnull) == 0) {
5094    # In this mode, we do "nm --demangle <foo>"
5095    $demangle_flag = "--demangle";
5096    $cppfilt_flag = "";
5097  } elsif (system(ShellEscape($cppfilt, $image) . $to_devnull) == 0) {
5098    # In this mode, we do "nm <foo> | c++filt"
5099    $cppfilt_flag = " | " . ShellEscape($cppfilt);
5100  };
5101  my $flatten_flag = "";
5102  if (system(ShellEscape($nm, "-f", $image) . $to_devnull) == 0) {
5103    $flatten_flag = "-f";
5104  }
5105
5106  # Finally, in the case $imagie isn't a debug library, we try again with
5107  # -D to at least get *exported* symbols.  If we can't use --demangle,
5108  # we use c++filt instead, if it exists on this system.
5109  my @nm_commands = (ShellEscape($nm, "-n", $flatten_flag, $demangle_flag,
5110                                 $image) . " 2>$dev_null $cppfilt_flag",
5111                     ShellEscape($nm, "-D", "-n", $flatten_flag, $demangle_flag,
5112                                 $image) . " 2>$dev_null $cppfilt_flag",
5113                     # 6nm is for Go binaries
5114                     ShellEscape("6nm", "$image") . " 2>$dev_null | sort",
5115                     );
5116
5117  # If the executable is an MS Windows PDB-format executable, we'll
5118  # have set up obj_tool_map("nm_pdb").  In this case, we actually
5119  # want to use both unix nm and windows-specific nm_pdb, since
5120  # PDB-format executables can apparently include dwarf .o files.
5121  if (exists $obj_tool_map{"nm_pdb"}) {
5122    push(@nm_commands,
5123         ShellEscape($obj_tool_map{"nm_pdb"}, "--demangle", $image)
5124         . " 2>$dev_null");
5125  }
5126
5127  foreach my $nm_command (@nm_commands) {
5128    my $symbol_table = GetProcedureBoundariesViaNm($nm_command, $regexp);
5129    return $symbol_table if (%{$symbol_table});
5130  }
5131  my $symbol_table = {};
5132  return $symbol_table;
5133}
5134
5135
5136# The test vectors for AddressAdd/Sub/Inc are 8-16-nibble hex strings.
5137# To make them more readable, we add underscores at interesting places.
5138# This routine removes the underscores, producing the canonical representation
5139# used by pprof to represent addresses, particularly in the tested routines.
5140sub CanonicalHex {
5141  my $arg = shift;
5142  return join '', (split '_',$arg);
5143}
5144
5145
5146# Unit test for AddressAdd:
5147sub AddressAddUnitTest {
5148  my $test_data_8 = shift;
5149  my $test_data_16 = shift;
5150  my $error_count = 0;
5151  my $fail_count = 0;
5152  my $pass_count = 0;
5153  # print STDERR "AddressAddUnitTest: ", 1+$#{$test_data_8}, " tests\n";
5154
5155  # First a few 8-nibble addresses.  Note that this implementation uses
5156  # plain old arithmetic, so a quick sanity check along with verifying what
5157  # happens to overflow (we want it to wrap):
5158  $address_length = 8;
5159  foreach my $row (@{$test_data_8}) {
5160    if ($main::opt_debug and $main::opt_test) { print STDERR "@{$row}\n"; }
5161    my $sum = AddressAdd ($row->[0], $row->[1]);
5162    if ($sum ne $row->[2]) {
5163      printf STDERR "ERROR: %s != %s + %s = %s\n", $sum,
5164             $row->[0], $row->[1], $row->[2];
5165      ++$fail_count;
5166    } else {
5167      ++$pass_count;
5168    }
5169  }
5170  printf STDERR "AddressAdd 32-bit tests: %d passes, %d failures\n",
5171         $pass_count, $fail_count;
5172  $error_count = $fail_count;
5173  $fail_count = 0;
5174  $pass_count = 0;
5175
5176  # Now 16-nibble addresses.
5177  $address_length = 16;
5178  foreach my $row (@{$test_data_16}) {
5179    if ($main::opt_debug and $main::opt_test) { print STDERR "@{$row}\n"; }
5180    my $sum = AddressAdd (CanonicalHex($row->[0]), CanonicalHex($row->[1]));
5181    my $expected = join '', (split '_',$row->[2]);
5182    if ($sum ne CanonicalHex($row->[2])) {
5183      printf STDERR "ERROR: %s != %s + %s = %s\n", $sum,
5184             $row->[0], $row->[1], $row->[2];
5185      ++$fail_count;
5186    } else {
5187      ++$pass_count;
5188    }
5189  }
5190  printf STDERR "AddressAdd 64-bit tests: %d passes, %d failures\n",
5191         $pass_count, $fail_count;
5192  $error_count += $fail_count;
5193
5194  return $error_count;
5195}
5196
5197
5198# Unit test for AddressSub:
5199sub AddressSubUnitTest {
5200  my $test_data_8 = shift;
5201  my $test_data_16 = shift;
5202  my $error_count = 0;
5203  my $fail_count = 0;
5204  my $pass_count = 0;
5205  # print STDERR "AddressSubUnitTest: ", 1+$#{$test_data_8}, " tests\n";
5206
5207  # First a few 8-nibble addresses.  Note that this implementation uses
5208  # plain old arithmetic, so a quick sanity check along with verifying what
5209  # happens to overflow (we want it to wrap):
5210  $address_length = 8;
5211  foreach my $row (@{$test_data_8}) {
5212    if ($main::opt_debug and $main::opt_test) { print STDERR "@{$row}\n"; }
5213    my $sum = AddressSub ($row->[0], $row->[1]);
5214    if ($sum ne $row->[3]) {
5215      printf STDERR "ERROR: %s != %s - %s = %s\n", $sum,
5216             $row->[0], $row->[1], $row->[3];
5217      ++$fail_count;
5218    } else {
5219      ++$pass_count;
5220    }
5221  }
5222  printf STDERR "AddressSub 32-bit tests: %d passes, %d failures\n",
5223         $pass_count, $fail_count;
5224  $error_count = $fail_count;
5225  $fail_count = 0;
5226  $pass_count = 0;
5227
5228  # Now 16-nibble addresses.
5229  $address_length = 16;
5230  foreach my $row (@{$test_data_16}) {
5231    if ($main::opt_debug and $main::opt_test) { print STDERR "@{$row}\n"; }
5232    my $sum = AddressSub (CanonicalHex($row->[0]), CanonicalHex($row->[1]));
5233    if ($sum ne CanonicalHex($row->[3])) {
5234      printf STDERR "ERROR: %s != %s - %s = %s\n", $sum,
5235             $row->[0], $row->[1], $row->[3];
5236      ++$fail_count;
5237    } else {
5238      ++$pass_count;
5239    }
5240  }
5241  printf STDERR "AddressSub 64-bit tests: %d passes, %d failures\n",
5242         $pass_count, $fail_count;
5243  $error_count += $fail_count;
5244
5245  return $error_count;
5246}
5247
5248
5249# Unit test for AddressInc:
5250sub AddressIncUnitTest {
5251  my $test_data_8 = shift;
5252  my $test_data_16 = shift;
5253  my $error_count = 0;
5254  my $fail_count = 0;
5255  my $pass_count = 0;
5256  # print STDERR "AddressIncUnitTest: ", 1+$#{$test_data_8}, " tests\n";
5257
5258  # First a few 8-nibble addresses.  Note that this implementation uses
5259  # plain old arithmetic, so a quick sanity check along with verifying what
5260  # happens to overflow (we want it to wrap):
5261  $address_length = 8;
5262  foreach my $row (@{$test_data_8}) {
5263    if ($main::opt_debug and $main::opt_test) { print STDERR "@{$row}\n"; }
5264    my $sum = AddressInc ($row->[0]);
5265    if ($sum ne $row->[4]) {
5266      printf STDERR "ERROR: %s != %s + 1 = %s\n", $sum,
5267             $row->[0], $row->[4];
5268      ++$fail_count;
5269    } else {
5270      ++$pass_count;
5271    }
5272  }
5273  printf STDERR "AddressInc 32-bit tests: %d passes, %d failures\n",
5274         $pass_count, $fail_count;
5275  $error_count = $fail_count;
5276  $fail_count = 0;
5277  $pass_count = 0;
5278
5279  # Now 16-nibble addresses.
5280  $address_length = 16;
5281  foreach my $row (@{$test_data_16}) {
5282    if ($main::opt_debug and $main::opt_test) { print STDERR "@{$row}\n"; }
5283    my $sum = AddressInc (CanonicalHex($row->[0]));
5284    if ($sum ne CanonicalHex($row->[4])) {
5285      printf STDERR "ERROR: %s != %s + 1 = %s\n", $sum,
5286             $row->[0], $row->[4];
5287      ++$fail_count;
5288    } else {
5289      ++$pass_count;
5290    }
5291  }
5292  printf STDERR "AddressInc 64-bit tests: %d passes, %d failures\n",
5293         $pass_count, $fail_count;
5294  $error_count += $fail_count;
5295
5296  return $error_count;
5297}
5298
5299
5300# Driver for unit tests.
5301# Currently just the address add/subtract/increment routines for 64-bit.
5302sub RunUnitTests {
5303  my $error_count = 0;
5304
5305  # This is a list of tuples [a, b, a+b, a-b, a+1]
5306  my $unit_test_data_8 = [
5307    [qw(aaaaaaaa 50505050 fafafafa 5a5a5a5a aaaaaaab)],
5308    [qw(50505050 aaaaaaaa fafafafa a5a5a5a6 50505051)],
5309    [qw(ffffffff aaaaaaaa aaaaaaa9 55555555 00000000)],
5310    [qw(00000001 ffffffff 00000000 00000002 00000002)],
5311    [qw(00000001 fffffff0 fffffff1 00000011 00000002)],
5312  ];
5313  my $unit_test_data_16 = [
5314    # The implementation handles data in 7-nibble chunks, so those are the
5315    # interesting boundaries.
5316    [qw(aaaaaaaa 50505050
5317        00_000000f_afafafa 00_0000005_a5a5a5a 00_000000a_aaaaaab)],
5318    [qw(50505050 aaaaaaaa
5319        00_000000f_afafafa ff_ffffffa_5a5a5a6 00_0000005_0505051)],
5320    [qw(ffffffff aaaaaaaa
5321        00_000001a_aaaaaa9 00_0000005_5555555 00_0000010_0000000)],
5322    [qw(00000001 ffffffff
5323        00_0000010_0000000 ff_ffffff0_0000002 00_0000000_0000002)],
5324    [qw(00000001 fffffff0
5325        00_000000f_ffffff1 ff_ffffff0_0000011 00_0000000_0000002)],
5326
5327    [qw(00_a00000a_aaaaaaa 50505050
5328        00_a00000f_afafafa 00_a000005_a5a5a5a 00_a00000a_aaaaaab)],
5329    [qw(0f_fff0005_0505050 aaaaaaaa
5330        0f_fff000f_afafafa 0f_ffefffa_5a5a5a6 0f_fff0005_0505051)],
5331    [qw(00_000000f_fffffff 01_800000a_aaaaaaa
5332        01_800001a_aaaaaa9 fe_8000005_5555555 00_0000010_0000000)],
5333    [qw(00_0000000_0000001 ff_fffffff_fffffff
5334        00_0000000_0000000 00_0000000_0000002 00_0000000_0000002)],
5335    [qw(00_0000000_0000001 ff_fffffff_ffffff0
5336        ff_fffffff_ffffff1 00_0000000_0000011 00_0000000_0000002)],
5337  ];
5338
5339  $error_count += AddressAddUnitTest($unit_test_data_8, $unit_test_data_16);
5340  $error_count += AddressSubUnitTest($unit_test_data_8, $unit_test_data_16);
5341  $error_count += AddressIncUnitTest($unit_test_data_8, $unit_test_data_16);
5342  if ($error_count > 0) {
5343    print STDERR $error_count, " errors: FAILED\n";
5344  } else {
5345    print STDERR "PASS\n";
5346  }
5347  exit ($error_count);
5348}
5349