]> git.saurik.com Git - redis.git/blame - deps/jemalloc/bin/pprof
Test SINTER against same integer elements, but different set encoding.
[redis.git] / deps / jemalloc / bin / pprof
CommitLineData
a78e148b 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}