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