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