OLD | NEW |
1 #! /usr/bin/env perl | 1 #! /usr/bin/env perl |
2 | 2 |
3 # Copyright (c) 1998-2007, Google Inc. | 3 # Copyright (c) 1998-2007, Google Inc. |
4 # All rights reserved. | 4 # All rights reserved. |
5 # | 5 # |
6 # Redistribution and use in source and binary forms, with or without | 6 # Redistribution and use in source and binary forms, with or without |
7 # modification, are permitted provided that the following conditions are | 7 # modification, are permitted provided that the following conditions are |
8 # met: | 8 # met: |
9 # | 9 # |
10 # * Redistributions of source code must retain the above copyright | 10 # * Redistributions of source code must retain the above copyright |
(...skipping 54 matching lines...) Expand 10 before | Expand all | Expand 10 after Loading... |
65 # Generates disassembly listing of all routines with at least one | 65 # Generates disassembly listing of all routines with at least one |
66 # sample that match the --disasm=<regexp> pattern. The listing is | 66 # sample that match the --disasm=<regexp> pattern. The listing is |
67 # annotated with the flat and cumulative sample counts at each PC value. | 67 # annotated with the flat and cumulative sample counts at each PC value. |
68 # | 68 # |
69 # TODO: Use color to indicate files? | 69 # TODO: Use color to indicate files? |
70 | 70 |
71 use strict; | 71 use strict; |
72 use warnings; | 72 use warnings; |
73 use Getopt::Long; | 73 use Getopt::Long; |
74 | 74 |
75 my $PPROF_VERSION = "1.8"; | 75 my $PPROF_VERSION = "2.0"; |
76 | 76 |
77 # These are the object tools we use which can come from a | 77 # These are the object tools we use which can come from a |
78 # user-specified location using --tools, from the PPROF_TOOLS | 78 # user-specified location using --tools, from the PPROF_TOOLS |
79 # environment variable, or from the environment. | 79 # environment variable, or from the environment. |
80 my %obj_tool_map = ( | 80 my %obj_tool_map = ( |
81 "objdump" => "objdump", | 81 "objdump" => "objdump", |
82 "nm" => "nm", | 82 "nm" => "nm", |
83 "addr2line" => "addr2line", | 83 "addr2line" => "addr2line", |
84 "c++filt" => "c++filt", | 84 "c++filt" => "c++filt", |
85 ## ConfigureObjTools may add architecture-specific entries: | 85 ## ConfigureObjTools may add architecture-specific entries: |
86 #"nm_pdb" => "nm-pdb", # for reading windows (PDB-format) executables | 86 #"nm_pdb" => "nm-pdb", # for reading windows (PDB-format) executables |
87 #"addr2line_pdb" => "addr2line-pdb", # ditto | 87 #"addr2line_pdb" => "addr2line-pdb", # ditto |
88 #"otool" => "otool", # equivalent of objdump on OS X | 88 #"otool" => "otool", # equivalent of objdump on OS X |
89 ); | 89 ); |
90 my $DOT = "dot"; # leave non-absolute, since it may be in /usr/local | 90 # NOTE: these are lists, so you can put in commandline flags if you want. |
91 my $GV = "gv"; | 91 my @DOT = ("dot"); # leave non-absolute, since it may be in /usr/local |
92 my $EVINCE = "evince"; # could also be xpdf or perhaps acroread | 92 my @GV = ("gv"); |
93 my $KCACHEGRIND = "kcachegrind"; | 93 my @EVINCE = ("evince"); # could also be xpdf or perhaps acroread |
94 my $PS2PDF = "ps2pdf"; | 94 my @KCACHEGRIND = ("kcachegrind"); |
| 95 my @PS2PDF = ("ps2pdf"); |
95 # These are used for dynamic profiles | 96 # These are used for dynamic profiles |
96 my $URL_FETCHER = "curl -s"; | 97 my @URL_FETCHER = ("curl", "-s"); |
97 | 98 |
98 # These are the web pages that servers need to support for dynamic profiles | 99 # These are the web pages that servers need to support for dynamic profiles |
99 my $HEAP_PAGE = "/pprof/heap"; | 100 my $HEAP_PAGE = "/pprof/heap"; |
100 my $PROFILE_PAGE = "/pprof/profile"; # must support cgi-param "?seconds=#" | 101 my $PROFILE_PAGE = "/pprof/profile"; # must support cgi-param "?seconds=#" |
101 my $PMUPROFILE_PAGE = "/pprof/pmuprofile(?:\\?.*)?"; # must support cgi-param | 102 my $PMUPROFILE_PAGE = "/pprof/pmuprofile(?:\\?.*)?"; # must support cgi-param |
102 # ?seconds=#&event=x&period=n | 103 # ?seconds=#&event=x&period=n |
103 my $GROWTH_PAGE = "/pprof/growth"; | 104 my $GROWTH_PAGE = "/pprof/growth"; |
104 my $CONTENTION_PAGE = "/pprof/contention"; | 105 my $CONTENTION_PAGE = "/pprof/contention"; |
105 my $WALL_PAGE = "/pprof/wall(?:\\?.*)?"; # accepts options like namefilter | 106 my $WALL_PAGE = "/pprof/wall(?:\\?.*)?"; # accepts options like namefilter |
106 my $FILTEREDPROFILE_PAGE = "/pprof/filteredprofile(?:\\?.*)?"; | 107 my $FILTEREDPROFILE_PAGE = "/pprof/filteredprofile(?:\\?.*)?"; |
107 my $CENSUSPROFILE_PAGE = "/pprof/censusprofile"; # must support "?seconds=#" | 108 my $CENSUSPROFILE_PAGE = "/pprof/censusprofile(?:\\?.*)?"; # must support cgi-pa
ram |
| 109 # "?seconds=#", |
| 110 # "?tags_regexp=#" and |
| 111 # "?type=#". |
108 my $SYMBOL_PAGE = "/pprof/symbol"; # must support symbol lookup via POST | 112 my $SYMBOL_PAGE = "/pprof/symbol"; # must support symbol lookup via POST |
109 my $PROGRAM_NAME_PAGE = "/pprof/cmdline"; | 113 my $PROGRAM_NAME_PAGE = "/pprof/cmdline"; |
110 | 114 |
111 # These are the web pages that can be named on the command line. | 115 # These are the web pages that can be named on the command line. |
112 # All the alternatives must begin with /. | 116 # All the alternatives must begin with /. |
113 my $PROFILES = "($HEAP_PAGE|$PROFILE_PAGE|$PMUPROFILE_PAGE|" . | 117 my $PROFILES = "($HEAP_PAGE|$PROFILE_PAGE|$PMUPROFILE_PAGE|" . |
114 "$GROWTH_PAGE|$CONTENTION_PAGE|$WALL_PAGE|" . | 118 "$GROWTH_PAGE|$CONTENTION_PAGE|$WALL_PAGE|" . |
115 "$FILTEREDPROFILE_PAGE|$CENSUSPROFILE_PAGE)"; | 119 "$FILTEREDPROFILE_PAGE|$CENSUSPROFILE_PAGE)"; |
116 | 120 |
117 # default binary name | 121 # default binary name |
(...skipping 43 matching lines...) Expand 10 before | Expand all | Expand 10 after Loading... |
161 If /<service> is omitted, the service defaults to $PROFILE_PAGE (cpu profilin
g). | 165 If /<service> is omitted, the service defaults to $PROFILE_PAGE (cpu profilin
g). |
162 pprof --symbols <program> | 166 pprof --symbols <program> |
163 Maps addresses to symbol names. In this mode, stdin should be a | 167 Maps addresses to symbol names. In this mode, stdin should be a |
164 list of library mappings, in the same format as is found in the heap- | 168 list of library mappings, in the same format as is found in the heap- |
165 and cpu-profile files (this loosely matches that of /proc/self/maps | 169 and cpu-profile files (this loosely matches that of /proc/self/maps |
166 on linux), followed by a list of hex addresses to map, one per line. | 170 on linux), followed by a list of hex addresses to map, one per line. |
167 | 171 |
168 For more help with querying remote servers, including how to add the | 172 For more help with querying remote servers, including how to add the |
169 necessary server-side support code, see this filename (or one like it): | 173 necessary server-side support code, see this filename (or one like it): |
170 | 174 |
171 /usr/doc/google-perftools-$PPROF_VERSION/pprof_remote_servers.html | 175 /usr/doc/gperftools-$PPROF_VERSION/pprof_remote_servers.html |
172 | 176 |
173 Options: | 177 Options: |
174 --cum Sort by cumulative data | 178 --cum Sort by cumulative data |
175 --base=<base> Subtract <base> from <profile> before display | 179 --base=<base> Subtract <base> from <profile> before display |
176 --interactive Run in interactive mode (interactive "help" gives help) [
default] | 180 --interactive Run in interactive mode (interactive "help" gives help) [
default] |
177 --seconds=<n> Length of time for dynamic profiles [default=30 secs] | 181 --seconds=<n> Length of time for dynamic profiles [default=30 secs] |
178 --add_lib=<file> Read additional symbols and line info from the given libr
ary | 182 --add_lib=<file> Read additional symbols and line info from the given libr
ary |
179 --lib_prefix=<dir> Comma separated list of library path prefixes | 183 --lib_prefix=<dir> Comma separated list of library path prefixes |
180 | 184 |
181 Reporting Granularity: | 185 Reporting Granularity: |
(...skipping 77 matching lines...) Expand 10 before | Expand all | Expand 10 after Loading... |
259 Outputs one line per procedure for localhost:1234 | 263 Outputs one line per procedure for localhost:1234 |
260 pprof --raw localhost:1234 > ./local.raw | 264 pprof --raw localhost:1234 > ./local.raw |
261 pprof --text ./local.raw | 265 pprof --text ./local.raw |
262 Fetches a remote profile for later analysis and then | 266 Fetches a remote profile for later analysis and then |
263 analyzes it in text mode. | 267 analyzes it in text mode. |
264 EOF | 268 EOF |
265 } | 269 } |
266 | 270 |
267 sub version_string { | 271 sub version_string { |
268 return <<EOF | 272 return <<EOF |
269 pprof (part of google-perftools $PPROF_VERSION) | 273 pprof (part of gperftools $PPROF_VERSION) |
270 | 274 |
271 Copyright 1998-2007 Google Inc. | 275 Copyright 1998-2007 Google Inc. |
272 | 276 |
273 This is BSD licensed software; see the source for copying conditions | 277 This is BSD licensed software; see the source for copying conditions |
274 and license information. | 278 and license information. |
275 There is NO warranty; not even for MERCHANTABILITY or FITNESS FOR A | 279 There is NO warranty; not even for MERCHANTABILITY or FITNESS FOR A |
276 PARTICULAR PURPOSE. | 280 PARTICULAR PURPOSE. |
277 EOF | 281 EOF |
278 } | 282 } |
279 | 283 |
(...skipping 211 matching lines...) Expand 10 before | Expand all | Expand 10 after Loading... |
491 RunUnitTests(); | 495 RunUnitTests(); |
492 # Should not return | 496 # Should not return |
493 exit(1); | 497 exit(1); |
494 } | 498 } |
495 | 499 |
496 # Binary name and profile arguments list | 500 # Binary name and profile arguments list |
497 $main::prog = ""; | 501 $main::prog = ""; |
498 @main::pfile_args = (); | 502 @main::pfile_args = (); |
499 | 503 |
500 # Remote profiling without a binary (using $SYMBOL_PAGE instead) | 504 # Remote profiling without a binary (using $SYMBOL_PAGE instead) |
501 if (IsProfileURL($ARGV[0])) { | 505 if (@ARGV > 0) { |
502 $main::use_symbol_page = 1; | 506 if (IsProfileURL($ARGV[0])) { |
503 } elsif (IsSymbolizedProfileFile($ARGV[0])) { | 507 $main::use_symbol_page = 1; |
504 $main::use_symbolized_profile = 1; | 508 } elsif (IsSymbolizedProfileFile($ARGV[0])) { |
505 $main::prog = $UNKNOWN_BINARY; # will be set later from the profile file | 509 $main::use_symbolized_profile = 1; |
| 510 $main::prog = $UNKNOWN_BINARY; # will be set later from the profile file |
| 511 } |
506 } | 512 } |
507 | 513 |
508 if ($main::use_symbol_page || $main::use_symbolized_profile) { | 514 if ($main::use_symbol_page || $main::use_symbolized_profile) { |
509 # We don't need a binary! | 515 # We don't need a binary! |
510 my %disabled = ('--lines' => $main::opt_lines, | 516 my %disabled = ('--lines' => $main::opt_lines, |
511 '--disasm' => $main::opt_disasm); | 517 '--disasm' => $main::opt_disasm); |
512 for my $option (keys %disabled) { | 518 for my $option (keys %disabled) { |
513 usage("$option cannot be used without a binary") if $disabled{$option}; | 519 usage("$option cannot be used without a binary") if $disabled{$option}; |
514 } | 520 } |
515 # Set $main::prog later... | 521 # Set $main::prog later... |
(...skipping 139 matching lines...) Expand 10 before | Expand all | Expand 10 after Loading... |
655 PrintText($symbols, $flat, $cumulative, -1); | 661 PrintText($symbols, $flat, $cumulative, -1); |
656 } elsif ($main::opt_raw) { | 662 } elsif ($main::opt_raw) { |
657 PrintSymbolizedProfile($symbols, $profile, $main::prog); | 663 PrintSymbolizedProfile($symbols, $profile, $main::prog); |
658 } elsif ($main::opt_callgrind) { | 664 } elsif ($main::opt_callgrind) { |
659 PrintCallgrind($calls); | 665 PrintCallgrind($calls); |
660 } else { | 666 } else { |
661 if (PrintDot($main::prog, $symbols, $profile, $flat, $cumulative, $total))
{ | 667 if (PrintDot($main::prog, $symbols, $profile, $flat, $cumulative, $total))
{ |
662 if ($main::opt_gv) { | 668 if ($main::opt_gv) { |
663 RunGV(TempName($main::next_tmpfile, "ps"), ""); | 669 RunGV(TempName($main::next_tmpfile, "ps"), ""); |
664 } elsif ($main::opt_evince) { | 670 } elsif ($main::opt_evince) { |
665 » RunEvince(TempName($main::next_tmpfile, "pdf"), ""); | 671 RunEvince(TempName($main::next_tmpfile, "pdf"), ""); |
666 } elsif ($main::opt_web) { | 672 } elsif ($main::opt_web) { |
667 my $tmp = TempName($main::next_tmpfile, "svg"); | 673 my $tmp = TempName($main::next_tmpfile, "svg"); |
668 RunWeb($tmp); | 674 RunWeb($tmp); |
669 # The command we run might hand the file name off | 675 # The command we run might hand the file name off |
670 # to an already running browser instance and then exit. | 676 # to an already running browser instance and then exit. |
671 # Normally, we'd remove $tmp on exit (right now), | 677 # Normally, we'd remove $tmp on exit (right now), |
672 # but fork a child to remove $tmp a little later, so that the | 678 # but fork a child to remove $tmp a little later, so that the |
673 # browser has time to load it first. | 679 # browser has time to load it first. |
674 delete $main::tempnames{$tmp}; | 680 delete $main::tempnames{$tmp}; |
675 if (fork() == 0) { | 681 if (fork() == 0) { |
(...skipping 28 matching lines...) Expand all Loading... |
704 if (-e '/lib/libtermcap.so.2') { | 710 if (-e '/lib/libtermcap.so.2') { |
705 return 0; # libtermcap exists, so readline should be okay | 711 return 0; # libtermcap exists, so readline should be okay |
706 } else { | 712 } else { |
707 return 1; | 713 return 1; |
708 } | 714 } |
709 } | 715 } |
710 | 716 |
711 sub RunGV { | 717 sub RunGV { |
712 my $fname = shift; | 718 my $fname = shift; |
713 my $bg = shift; # "" or " &" if we should run in background | 719 my $bg = shift; # "" or " &" if we should run in background |
714 if (!system("$GV --version >$dev_null 2>&1")) { | 720 if (!system(ShellEscape(@GV, "--version") . " >$dev_null 2>&1")) { |
715 # Options using double dash are supported by this gv version. | 721 # Options using double dash are supported by this gv version. |
716 # Also, turn on noantialias to better handle bug in gv for | 722 # Also, turn on noantialias to better handle bug in gv for |
717 # postscript files with large dimensions. | 723 # postscript files with large dimensions. |
718 # TODO: Maybe we should not pass the --noantialias flag | 724 # TODO: Maybe we should not pass the --noantialias flag |
719 # if the gv version is known to work properly without the flag. | 725 # if the gv version is known to work properly without the flag. |
720 system("$GV --scale=$main::opt_scale --noantialias " . $fname . $bg); | 726 system(ShellEscape(@GV, "--scale=$main::opt_scale", "--noantialias", $fname) |
| 727 . $bg); |
721 } else { | 728 } else { |
722 # Old gv version - only supports options that use single dash. | 729 # Old gv version - only supports options that use single dash. |
723 print STDERR "$GV -scale $main::opt_scale\n"; | 730 print STDERR ShellEscape(@GV, "-scale", $main::opt_scale) . "\n"; |
724 system("$GV -scale $main::opt_scale " . $fname . $bg); | 731 system(ShellEscape(@GV, "-scale", "$main::opt_scale", $fname) . $bg); |
725 } | 732 } |
726 } | 733 } |
727 | 734 |
728 sub RunEvince { | 735 sub RunEvince { |
729 my $fname = shift; | 736 my $fname = shift; |
730 my $bg = shift; # "" or " &" if we should run in background | 737 my $bg = shift; # "" or " &" if we should run in background |
731 system("$EVINCE " . $fname . $bg); | 738 system(ShellEscape(@EVINCE, $fname) . $bg); |
732 } | 739 } |
733 | 740 |
734 sub RunWeb { | 741 sub RunWeb { |
735 my $fname = shift; | 742 my $fname = shift; |
736 print STDERR "Loading web page file:///$fname\n"; | 743 print STDERR "Loading web page file:///$fname\n"; |
737 | 744 |
738 if (`uname` =~ /Darwin/) { | 745 if (`uname` =~ /Darwin/) { |
739 # OS X: open will use standard preference for SVG files. | 746 # OS X: open will use standard preference for SVG files. |
740 system("/usr/bin/open", $fname); | 747 system("/usr/bin/open", $fname); |
741 return; | 748 return; |
(...skipping 13 matching lines...) Expand all Loading... |
755 return; | 762 return; |
756 } | 763 } |
757 } | 764 } |
758 | 765 |
759 print STDERR "Could not load web browser.\n"; | 766 print STDERR "Could not load web browser.\n"; |
760 } | 767 } |
761 | 768 |
762 sub RunKcachegrind { | 769 sub RunKcachegrind { |
763 my $fname = shift; | 770 my $fname = shift; |
764 my $bg = shift; # "" or " &" if we should run in background | 771 my $bg = shift; # "" or " &" if we should run in background |
765 print STDERR "Starting '$KCACHEGRIND " . $fname . $bg . "'\n"; | 772 print STDERR "Starting '@KCACHEGRIND " . $fname . $bg . "'\n"; |
766 system("$KCACHEGRIND " . $fname . $bg); | 773 system(ShellEscape(@KCACHEGRIND, $fname) . $bg); |
767 } | 774 } |
768 | 775 |
769 | 776 |
770 ##### Interactive helper routines ##### | 777 ##### Interactive helper routines ##### |
771 | 778 |
772 sub InteractiveMode { | 779 sub InteractiveMode { |
773 $| = 1; # Make output unbuffered for interactive mode | 780 $| = 1; # Make output unbuffered for interactive mode |
774 my ($orig_profile, $symbols, $libs, $total) = @_; | 781 my ($orig_profile, $symbols, $libs, $total) = @_; |
775 | 782 |
776 print STDERR "Welcome to pprof! For help, type 'help'.\n"; | 783 print STDERR "Welcome to pprof! For help, type 'help'.\n"; |
(...skipping 248 matching lines...) Expand 10 before | Expand all | Expand 10 after Loading... |
1025 | 1032 |
1026 help - This listing | 1033 help - This listing |
1027 quit or ^D - End pprof | 1034 quit or ^D - End pprof |
1028 | 1035 |
1029 For commands that accept optional -ignore tags, samples where any routine in | 1036 For commands that accept optional -ignore tags, samples where any routine in |
1030 the stack trace matches the regular expression in any of the -ignore | 1037 the stack trace matches the regular expression in any of the -ignore |
1031 parameters will be ignored. | 1038 parameters will be ignored. |
1032 | 1039 |
1033 Further pprof details are available at this location (or one similar): | 1040 Further pprof details are available at this location (or one similar): |
1034 | 1041 |
1035 /usr/doc/google-perftools-$PPROF_VERSION/cpu_profiler.html | 1042 /usr/doc/gperftools-$PPROF_VERSION/cpu_profiler.html |
1036 /usr/doc/google-perftools-$PPROF_VERSION/heap_profiler.html | 1043 /usr/doc/gperftools-$PPROF_VERSION/heap_profiler.html |
1037 | 1044 |
1038 ENDOFHELP | 1045 ENDOFHELP |
1039 } | 1046 } |
1040 sub ParseInteractiveArgs { | 1047 sub ParseInteractiveArgs { |
1041 my $args = shift; | 1048 my $args = shift; |
1042 my $focus = ""; | 1049 my $focus = ""; |
1043 my $ignore = ""; | 1050 my $ignore = ""; |
1044 my @x = split(/ +/, $args); | 1051 my @x = split(/ +/, $args); |
1045 foreach $a (@x) { | 1052 foreach $a (@x) { |
1046 if ($a =~ m/^(--|-)lines$/) { | 1053 if ($a =~ m/^(--|-)lines$/) { |
(...skipping 133 matching lines...) Expand 10 before | Expand all | Expand 10 after Loading... |
1180 Percent($running_sum, $total), | 1187 Percent($running_sum, $total), |
1181 Unparse($c), | 1188 Unparse($c), |
1182 Percent($c, $total), | 1189 Percent($c, $total), |
1183 $sym); | 1190 $sym); |
1184 } | 1191 } |
1185 $lines++; | 1192 $lines++; |
1186 last if ($line_limit >= 0 && $lines >= $line_limit); | 1193 last if ($line_limit >= 0 && $lines >= $line_limit); |
1187 } | 1194 } |
1188 } | 1195 } |
1189 | 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"; |
| 1216 } |
| 1217 } |
| 1218 |
1190 # Print the call graph in a way that's suiteable for callgrind. | 1219 # Print the call graph in a way that's suiteable for callgrind. |
1191 sub PrintCallgrind { | 1220 sub PrintCallgrind { |
1192 my $calls = shift; | 1221 my $calls = shift; |
1193 my $filename; | 1222 my $filename; |
| 1223 my %filename_to_index_map; |
| 1224 my %fnname_to_index_map; |
| 1225 |
1194 if ($main::opt_interactive) { | 1226 if ($main::opt_interactive) { |
1195 $filename = shift; | 1227 $filename = shift; |
1196 print STDERR "Writing callgrind file to '$filename'.\n" | 1228 print STDERR "Writing callgrind file to '$filename'.\n" |
1197 } else { | 1229 } else { |
1198 $filename = "&STDOUT"; | 1230 $filename = "&STDOUT"; |
1199 } | 1231 } |
1200 open(CG, ">".$filename ); | 1232 open(CG, ">$filename"); |
1201 printf CG ("events: Hits\n\n"); | 1233 printf CG ("events: Hits\n\n"); |
1202 foreach my $call ( map { $_->[0] } | 1234 foreach my $call ( map { $_->[0] } |
1203 sort { $a->[1] cmp $b ->[1] || | 1235 sort { $a->[1] cmp $b ->[1] || |
1204 $a->[2] <=> $b->[2] } | 1236 $a->[2] <=> $b->[2] } |
1205 map { /([^:]+):(\d+):([^ ]+)( -> ([^:]+):(\d+):(.+))?/; | 1237 map { /([^:]+):(\d+):([^ ]+)( -> ([^:]+):(\d+):(.+))?/; |
1206 [$_, $1, $2] } | 1238 [$_, $1, $2] } |
1207 keys %$calls ) { | 1239 keys %$calls ) { |
1208 my $count = int($calls->{$call}); | 1240 my $count = int($calls->{$call}); |
1209 $call =~ /([^:]+):(\d+):([^ ]+)( -> ([^:]+):(\d+):(.+))?/; | 1241 $call =~ /([^:]+):(\d+):([^ ]+)( -> ([^:]+):(\d+):(.+))?/; |
1210 my ( $caller_file, $caller_line, $caller_function, | 1242 my ( $caller_file, $caller_line, $caller_function, |
1211 $callee_file, $callee_line, $callee_function ) = | 1243 $callee_file, $callee_line, $callee_function ) = |
1212 ( $1, $2, $3, $5, $6, $7 ); | 1244 ( $1, $2, $3, $5, $6, $7 ); |
1213 | 1245 |
1214 | 1246 # TODO(csilvers): for better compression, collect all the |
1215 printf CG ("fl=$caller_file\nfn=$caller_function\n"); | 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); |
1216 if (defined $6) { | 1251 if (defined $6) { |
1217 printf CG ("cfl=$callee_file\n"); | 1252 printf CG CompressedCGName("cfl", $callee_file, \%filename_to_index_map); |
1218 printf CG ("cfn=$callee_function\n"); | 1253 printf CG CompressedCGName("cfn", $callee_function, \%fnname_to_index_map)
; |
1219 printf CG ("calls=$count $callee_line\n"); | 1254 printf CG ("calls=$count $callee_line\n"); |
1220 } | 1255 } |
1221 printf CG ("$caller_line $count\n\n"); | 1256 printf CG ("$caller_line $count\n\n"); |
1222 } | 1257 } |
1223 } | 1258 } |
1224 | 1259 |
1225 # Print disassembly for all all routines that match $main::opt_disasm | 1260 # Print disassembly for all all routines that match $main::opt_disasm |
1226 sub PrintDisassembly { | 1261 sub PrintDisassembly { |
1227 my $libs = shift; | 1262 my $libs = shift; |
1228 my $flat = shift; | 1263 my $flat = shift; |
(...skipping 28 matching lines...) Expand all Loading... |
1257 # [start_address, filename, linenumber, instruction, limit_address] | 1292 # [start_address, filename, linenumber, instruction, limit_address] |
1258 # E.g., | 1293 # E.g., |
1259 # ["0x806c43d", "/foo/bar.cc", 131, "ret", "0x806c440"] | 1294 # ["0x806c43d", "/foo/bar.cc", 131, "ret", "0x806c440"] |
1260 sub Disassemble { | 1295 sub Disassemble { |
1261 my $prog = shift; | 1296 my $prog = shift; |
1262 my $offset = shift; | 1297 my $offset = shift; |
1263 my $start_addr = shift; | 1298 my $start_addr = shift; |
1264 my $end_addr = shift; | 1299 my $end_addr = shift; |
1265 | 1300 |
1266 my $objdump = $obj_tool_map{"objdump"}; | 1301 my $objdump = $obj_tool_map{"objdump"}; |
1267 my $cmd = sprintf("$objdump -C -d -l --no-show-raw-insn " . | 1302 my $cmd = ShellEscape($objdump, "-C", "-d", "-l", "--no-show-raw-insn", |
1268 "--start-address=0x$start_addr " . | 1303 "--start-address=0x$start_addr", |
1269 "--stop-address=0x$end_addr $prog"); | 1304 "--stop-address=0x$end_addr", $prog); |
1270 open(OBJDUMP, "$cmd |") || error("$objdump: $!\n"); | 1305 open(OBJDUMP, "$cmd |") || error("$cmd: $!\n"); |
1271 my @result = (); | 1306 my @result = (); |
1272 my $filename = ""; | 1307 my $filename = ""; |
1273 my $linenumber = -1; | 1308 my $linenumber = -1; |
1274 my $last = ["", "", "", ""]; | 1309 my $last = ["", "", "", ""]; |
1275 while (<OBJDUMP>) { | 1310 while (<OBJDUMP>) { |
1276 s/\r//g; # turn windows-looking lines into unix-looking lines | 1311 s/\r//g; # turn windows-looking lines into unix-looking lines |
1277 chop; | 1312 chop; |
1278 if (m|\s*([^:\s]+):(\d+)\s*$|) { | 1313 if (m|\s*([^:\s]+):(\d+)\s*$|) { |
1279 # Location line of the form: | 1314 # Location line of the form: |
1280 # <filename>:<linenumber> | 1315 # <filename>:<linenumber> |
(...skipping 684 matching lines...) Expand 10 before | Expand all | Expand 10 after Loading... |
1965 } | 2000 } |
1966 | 2001 |
1967 if ($nodelimit > 0 || $edgelimit > 0) { | 2002 if ($nodelimit > 0 || $edgelimit > 0) { |
1968 printf STDERR ("Dropping nodes with <= %s %s; edges with <= %s abs(%s)\n", | 2003 printf STDERR ("Dropping nodes with <= %s %s; edges with <= %s abs(%s)\n", |
1969 Unparse($nodelimit), Units(), | 2004 Unparse($nodelimit), Units(), |
1970 Unparse($edgelimit), Units()); | 2005 Unparse($edgelimit), Units()); |
1971 } | 2006 } |
1972 | 2007 |
1973 # Open DOT output file | 2008 # Open DOT output file |
1974 my $output; | 2009 my $output; |
| 2010 my $escaped_dot = ShellEscape(@DOT); |
| 2011 my $escaped_ps2pdf = ShellEscape(@PS2PDF); |
1975 if ($main::opt_gv) { | 2012 if ($main::opt_gv) { |
1976 $output = "| $DOT -Tps2 >" . TempName($main::next_tmpfile, "ps"); | 2013 my $escaped_outfile = ShellEscape(TempName($main::next_tmpfile, "ps")); |
| 2014 $output = "| $escaped_dot -Tps2 >$escaped_outfile"; |
1977 } elsif ($main::opt_evince) { | 2015 } elsif ($main::opt_evince) { |
1978 $output = "| $DOT -Tps2 | $PS2PDF - " . TempName($main::next_tmpfile, "pdf")
; | 2016 my $escaped_outfile = ShellEscape(TempName($main::next_tmpfile, "pdf")); |
| 2017 $output = "| $escaped_dot -Tps2 | $escaped_ps2pdf - $escaped_outfile"; |
1979 } elsif ($main::opt_ps) { | 2018 } elsif ($main::opt_ps) { |
1980 $output = "| $DOT -Tps2"; | 2019 $output = "| $escaped_dot -Tps2"; |
1981 } elsif ($main::opt_pdf) { | 2020 } elsif ($main::opt_pdf) { |
1982 $output = "| $DOT -Tps2 | $PS2PDF - -"; | 2021 $output = "| $escaped_dot -Tps2 | $escaped_ps2pdf - -"; |
1983 } elsif ($main::opt_web || $main::opt_svg) { | 2022 } elsif ($main::opt_web || $main::opt_svg) { |
1984 # We need to post-process the SVG, so write to a temporary file always. | 2023 # We need to post-process the SVG, so write to a temporary file always. |
1985 $output = "| $DOT -Tsvg >" . TempName($main::next_tmpfile, "svg"); | 2024 my $escaped_outfile = ShellEscape(TempName($main::next_tmpfile, "svg")); |
| 2025 $output = "| $escaped_dot -Tsvg >$escaped_outfile"; |
1986 } elsif ($main::opt_gif) { | 2026 } elsif ($main::opt_gif) { |
1987 $output = "| $DOT -Tgif"; | 2027 $output = "| $escaped_dot -Tgif"; |
1988 } else { | 2028 } else { |
1989 $output = ">&STDOUT"; | 2029 $output = ">&STDOUT"; |
1990 } | 2030 } |
1991 open(DOT, $output) || error("$output: $!\n"); | 2031 open(DOT, $output) || error("$output: $!\n"); |
1992 | 2032 |
1993 # Title | 2033 # Title |
1994 printf DOT ("digraph \"%s; %s %s\" {\n", | 2034 printf DOT ("digraph \"%s; %s %s\" {\n", |
1995 $prog, | 2035 $prog, |
1996 Unparse($overall_total), | 2036 Unparse($overall_total), |
1997 Units()); | 2037 Units()); |
(...skipping 60 matching lines...) Expand 10 before | Expand all | Expand 10 after Loading... |
2058 Percent($f, $local_total), | 2098 Percent($f, $local_total), |
2059 $extra, | 2099 $extra, |
2060 $fs, | 2100 $fs, |
2061 $style, | 2101 $style, |
2062 ); | 2102 ); |
2063 } | 2103 } |
2064 | 2104 |
2065 # Get edges and counts per edge | 2105 # Get edges and counts per edge |
2066 my %edge = (); | 2106 my %edge = (); |
2067 my $n; | 2107 my $n; |
| 2108 my $fullname_to_shortname_map = {}; |
| 2109 FillFullnameToShortnameMap($symbols, $fullname_to_shortname_map); |
2068 foreach my $k (keys(%{$raw})) { | 2110 foreach my $k (keys(%{$raw})) { |
2069 # TODO: omit low %age edges | 2111 # TODO: omit low %age edges |
2070 $n = $raw->{$k}; | 2112 $n = $raw->{$k}; |
2071 my @translated = TranslateStack($symbols, $k); | 2113 my @translated = TranslateStack($symbols, $fullname_to_shortname_map, $k); |
2072 for (my $i = 1; $i <= $#translated; $i++) { | 2114 for (my $i = 1; $i <= $#translated; $i++) { |
2073 my $src = $translated[$i]; | 2115 my $src = $translated[$i]; |
2074 my $dst = $translated[$i-1]; | 2116 my $dst = $translated[$i-1]; |
2075 #next if ($src eq $dst); # Avoid self-edges? | 2117 #next if ($src eq $dst); # Avoid self-edges? |
2076 if (exists($node{$src}) && exists($node{$dst})) { | 2118 if (exists($node{$src}) && exists($node{$dst})) { |
2077 my $edge_label = "$src\001$dst"; | 2119 my $edge_label = "$src\001$dst"; |
2078 if (!exists($edge{$edge_label})) { | 2120 if (!exists($edge{$edge_label})) { |
2079 $edge{$edge_label} = 0; | 2121 $edge{$edge_label} = 0; |
2080 } | 2122 } |
2081 $edge{$edge_label} += $n; | 2123 $edge{$edge_label} += $n; |
(...skipping 363 matching lines...) Expand 10 before | Expand all | Expand 10 after Loading... |
2445 if(state == 'pan' || state == 'move') { | 2487 if(state == 'pan' || state == 'move') { |
2446 // Quit pan mode | 2488 // Quit pan mode |
2447 state = ''; | 2489 state = ''; |
2448 } | 2490 } |
2449 } | 2491 } |
2450 | 2492 |
2451 ]]></script> | 2493 ]]></script> |
2452 EOF | 2494 EOF |
2453 } | 2495 } |
2454 | 2496 |
| 2497 # Provides a map from fullname to shortname for cases where the |
| 2498 # shortname is ambiguous. The symlist has both the fullname and |
| 2499 # shortname for all symbols, which is usually fine, but sometimes -- |
| 2500 # such as overloaded functions -- two different fullnames can map to |
| 2501 # the same shortname. In that case, we use the address of the |
| 2502 # function to disambiguate the two. This function fills in a map that |
| 2503 # maps fullnames to modified shortnames in such cases. If a fullname |
| 2504 # is not present in the map, the 'normal' shortname provided by the |
| 2505 # symlist is the appropriate one to use. |
| 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 |
2455 # Return a small number that identifies the argument. | 2541 # Return a small number that identifies the argument. |
2456 # Multiple calls with the same argument will return the same number. | 2542 # Multiple calls with the same argument will return the same number. |
2457 # Calls with different arguments will return different numbers. | 2543 # Calls with different arguments will return different numbers. |
2458 sub ShortIdFor { | 2544 sub ShortIdFor { |
2459 my $key = shift; | 2545 my $key = shift; |
2460 my $id = $main::uniqueid{$key}; | 2546 my $id = $main::uniqueid{$key}; |
2461 if (!defined($id)) { | 2547 if (!defined($id)) { |
2462 $id = keys(%main::uniqueid) + 1; | 2548 $id = keys(%main::uniqueid) + 1; |
2463 $main::uniqueid{$key} = $id; | 2549 $main::uniqueid{$key} = $id; |
2464 } | 2550 } |
2465 return $id; | 2551 return $id; |
2466 } | 2552 } |
2467 | 2553 |
2468 # Translate a stack of addresses into a stack of symbols | 2554 # Translate a stack of addresses into a stack of symbols |
2469 sub TranslateStack { | 2555 sub TranslateStack { |
2470 my $symbols = shift; | 2556 my $symbols = shift; |
| 2557 my $fullname_to_shortname_map = shift; |
2471 my $k = shift; | 2558 my $k = shift; |
2472 | 2559 |
2473 my @addrs = split(/\n/, $k); | 2560 my @addrs = split(/\n/, $k); |
2474 my @result = (); | 2561 my @result = (); |
2475 for (my $i = 0; $i <= $#addrs; $i++) { | 2562 for (my $i = 0; $i <= $#addrs; $i++) { |
2476 my $a = $addrs[$i]; | 2563 my $a = $addrs[$i]; |
2477 | 2564 |
2478 # Skip large addresses since they sometimes show up as fake entries on RH9 | 2565 # Skip large addresses since they sometimes show up as fake entries on RH9 |
2479 if (length($a) > 8 && $a gt "7fffffffffffffff") { | 2566 if (length($a) > 8 && $a gt "7fffffffffffffff") { |
2480 next; | 2567 next; |
(...skipping 11 matching lines...) Expand all Loading... |
2492 } | 2579 } |
2493 | 2580 |
2494 # We can have a sequence of symbols for a particular entry | 2581 # We can have a sequence of symbols for a particular entry |
2495 # (more than one symbol in the case of inlining). Callers | 2582 # (more than one symbol in the case of inlining). Callers |
2496 # come before callees in symlist, so walk backwards since | 2583 # come before callees in symlist, so walk backwards since |
2497 # the translated stack should contain callees before callers. | 2584 # the translated stack should contain callees before callers. |
2498 for (my $j = $#{$symlist}; $j >= 2; $j -= 3) { | 2585 for (my $j = $#{$symlist}; $j >= 2; $j -= 3) { |
2499 my $func = $symlist->[$j-2]; | 2586 my $func = $symlist->[$j-2]; |
2500 my $fileline = $symlist->[$j-1]; | 2587 my $fileline = $symlist->[$j-1]; |
2501 my $fullfunc = $symlist->[$j]; | 2588 my $fullfunc = $symlist->[$j]; |
| 2589 if (defined($fullname_to_shortname_map->{$fullfunc})) { |
| 2590 $func = $fullname_to_shortname_map->{$fullfunc}; |
| 2591 } |
2502 if ($j > 2) { | 2592 if ($j > 2) { |
2503 $func = "$func (inline)"; | 2593 $func = "$func (inline)"; |
2504 } | 2594 } |
2505 | 2595 |
2506 # Do not merge nodes corresponding to Callback::Run since that | 2596 # Do not merge nodes corresponding to Callback::Run since that |
2507 # causes confusing cycles in dot display. Instead, we synthesize | 2597 # causes confusing cycles in dot display. Instead, we synthesize |
2508 # a unique name for this frame per caller. | 2598 # a unique name for this frame per caller. |
2509 if ($func =~ m/Callback.*::Run$/) { | 2599 if ($func =~ m/Callback.*::Run$/) { |
2510 my $caller = ($i > 0) ? $addrs[$i-1] : 0; | 2600 my $caller = ($i > 0) ? $addrs[$i-1] : 0; |
2511 $func = "Run#" . ShortIdFor($caller); | 2601 $func = "Run#" . ShortIdFor($caller); |
(...skipping 232 matching lines...) Expand 10 before | Expand all | Expand 10 after Loading... |
2744 '::do_malloc_or_cpp_alloc', | 2834 '::do_malloc_or_cpp_alloc', |
2745 'DoSampledAllocation', | 2835 'DoSampledAllocation', |
2746 'simple_alloc::allocate', | 2836 'simple_alloc::allocate', |
2747 '__malloc_alloc_template::allocate', | 2837 '__malloc_alloc_template::allocate', |
2748 '__builtin_delete', | 2838 '__builtin_delete', |
2749 '__builtin_new', | 2839 '__builtin_new', |
2750 '__builtin_vec_delete', | 2840 '__builtin_vec_delete', |
2751 '__builtin_vec_new', | 2841 '__builtin_vec_new', |
2752 'operator new', | 2842 'operator new', |
2753 'operator new[]', | 2843 'operator new[]', |
2754 » » # The entry to our memory-allocation routines on OS X | 2844 # The entry to our memory-allocation routines on OS X |
2755 » » 'malloc_zone_malloc', | 2845 'malloc_zone_malloc', |
2756 » » 'malloc_zone_calloc', | 2846 'malloc_zone_calloc', |
2757 » » 'malloc_zone_valloc', | 2847 'malloc_zone_valloc', |
2758 » » 'malloc_zone_realloc', | 2848 'malloc_zone_realloc', |
2759 » » 'malloc_zone_memalign', | 2849 'malloc_zone_memalign', |
2760 » » 'malloc_zone_free', | 2850 'malloc_zone_free', |
2761 # These mark the beginning/end of our custom sections | 2851 # These mark the beginning/end of our custom sections |
2762 '__start_google_malloc', | 2852 '__start_google_malloc', |
2763 '__stop_google_malloc', | 2853 '__stop_google_malloc', |
2764 '__start_malloc_hook', | 2854 '__start_malloc_hook', |
2765 '__stop_malloc_hook') { | 2855 '__stop_malloc_hook') { |
2766 $skip{$name} = 1; | 2856 $skip{$name} = 1; |
2767 $skip{"_" . $name} = 1; # Mach (OS X) adds a _ prefix to everything | 2857 $skip{"_" . $name} = 1; # Mach (OS X) adds a _ prefix to everything |
2768 } | 2858 } |
2769 # TODO: Remove TCMalloc once everything has been | 2859 # TODO: Remove TCMalloc once everything has been |
2770 # moved into the tcmalloc:: namespace and we have flushed | 2860 # moved into the tcmalloc:: namespace and we have flushed |
(...skipping 71 matching lines...) Expand 10 before | Expand all | Expand 10 after Loading... |
2842 AddEntry($result, $reduced_path, $count); | 2932 AddEntry($result, $reduced_path, $count); |
2843 } | 2933 } |
2844 return $result; | 2934 return $result; |
2845 } | 2935 } |
2846 | 2936 |
2847 # Reduce profile to granularity given by user | 2937 # Reduce profile to granularity given by user |
2848 sub ReduceProfile { | 2938 sub ReduceProfile { |
2849 my $symbols = shift; | 2939 my $symbols = shift; |
2850 my $profile = shift; | 2940 my $profile = shift; |
2851 my $result = {}; | 2941 my $result = {}; |
| 2942 my $fullname_to_shortname_map = {}; |
| 2943 FillFullnameToShortnameMap($symbols, $fullname_to_shortname_map); |
2852 foreach my $k (keys(%{$profile})) { | 2944 foreach my $k (keys(%{$profile})) { |
2853 my $count = $profile->{$k}; | 2945 my $count = $profile->{$k}; |
2854 my @translated = TranslateStack($symbols, $k); | 2946 my @translated = TranslateStack($symbols, $fullname_to_shortname_map, $k); |
2855 my @path = (); | 2947 my @path = (); |
2856 my %seen = (); | 2948 my %seen = (); |
2857 $seen{''} = 1; # So that empty keys are skipped | 2949 $seen{''} = 1; # So that empty keys are skipped |
2858 foreach my $e (@translated) { | 2950 foreach my $e (@translated) { |
2859 # To avoid double-counting due to recursion, skip a stack-trace | 2951 # To avoid double-counting due to recursion, skip a stack-trace |
2860 # entry if it has already been seen | 2952 # entry if it has already been seen |
2861 if (!$seen{$e}) { | 2953 if (!$seen{$e}) { |
2862 $seen{$e} = 1; | 2954 $seen{$e} = 1; |
2863 push(@path, $e); | 2955 push(@path, $e); |
2864 } | 2956 } |
(...skipping 186 matching lines...) Expand 10 before | Expand all | Expand 10 after Loading... |
3051 $pcs->{$pc} = 1; | 3143 $pcs->{$pc} = 1; |
3052 push @k, $pc; | 3144 push @k, $pc; |
3053 } | 3145 } |
3054 AddEntry($profile, (join "\n", @k), $count); | 3146 AddEntry($profile, (join "\n", @k), $count); |
3055 } | 3147 } |
3056 | 3148 |
3057 ##### Code to profile a server dynamically ##### | 3149 ##### Code to profile a server dynamically ##### |
3058 | 3150 |
3059 sub CheckSymbolPage { | 3151 sub CheckSymbolPage { |
3060 my $url = SymbolPageURL(); | 3152 my $url = SymbolPageURL(); |
3061 open(SYMBOL, "$URL_FETCHER '$url' |"); | 3153 my $command = ShellEscape(@URL_FETCHER, $url); |
| 3154 open(SYMBOL, "$command |") or error($command); |
3062 my $line = <SYMBOL>; | 3155 my $line = <SYMBOL>; |
3063 $line =~ s/\r//g; # turn windows-looking lines into unix-looking lines | 3156 $line =~ s/\r//g; # turn windows-looking lines into unix-looking lines |
3064 close(SYMBOL); | 3157 close(SYMBOL); |
3065 unless (defined($line)) { | 3158 unless (defined($line)) { |
3066 error("$url doesn't exist\n"); | 3159 error("$url doesn't exist\n"); |
3067 } | 3160 } |
3068 | 3161 |
3069 if ($line =~ /^num_symbols:\s+(\d+)$/) { | 3162 if ($line =~ /^num_symbols:\s+(\d+)$/) { |
3070 if ($1 == 0) { | 3163 if ($1 == 0) { |
3071 error("Stripped binary. No symbols available.\n"); | 3164 error("Stripped binary. No symbols available.\n"); |
(...skipping 36 matching lines...) Expand 10 before | Expand all | Expand 10 after Loading... |
3108 | 3201 |
3109 # We fetch symbols from the first profile argument. | 3202 # We fetch symbols from the first profile argument. |
3110 sub SymbolPageURL { | 3203 sub SymbolPageURL { |
3111 my ($host, $baseURL, $path) = ParseProfileURL($main::pfile_args[0]); | 3204 my ($host, $baseURL, $path) = ParseProfileURL($main::pfile_args[0]); |
3112 return "$baseURL$SYMBOL_PAGE"; | 3205 return "$baseURL$SYMBOL_PAGE"; |
3113 } | 3206 } |
3114 | 3207 |
3115 sub FetchProgramName() { | 3208 sub FetchProgramName() { |
3116 my ($host, $baseURL, $path) = ParseProfileURL($main::pfile_args[0]); | 3209 my ($host, $baseURL, $path) = ParseProfileURL($main::pfile_args[0]); |
3117 my $url = "$baseURL$PROGRAM_NAME_PAGE"; | 3210 my $url = "$baseURL$PROGRAM_NAME_PAGE"; |
3118 my $command_line = "$URL_FETCHER '$url'"; | 3211 my $command_line = ShellEscape(@URL_FETCHER, $url); |
3119 open(CMDLINE, "$command_line |") or error($command_line); | 3212 open(CMDLINE, "$command_line |") or error($command_line); |
3120 my $cmdline = <CMDLINE>; | 3213 my $cmdline = <CMDLINE>; |
3121 $cmdline =~ s/\r//g; # turn windows-looking lines into unix-looking lines | 3214 $cmdline =~ s/\r//g; # turn windows-looking lines into unix-looking lines |
3122 close(CMDLINE); | 3215 close(CMDLINE); |
3123 error("Failed to get program name from $url\n") unless defined($cmdline); | 3216 error("Failed to get program name from $url\n") unless defined($cmdline); |
3124 $cmdline =~ s/\x00.+//; # Remove argv[1] and latters. | 3217 $cmdline =~ s/\x00.+//; # Remove argv[1] and latters. |
3125 $cmdline =~ s!\n!!g; # Remove LFs. | 3218 $cmdline =~ s!\n!!g; # Remove LFs. |
3126 return $cmdline; | 3219 return $cmdline; |
3127 } | 3220 } |
3128 | 3221 |
3129 # Gee, curl's -L (--location) option isn't reliable at least | 3222 # Gee, curl's -L (--location) option isn't reliable at least |
3130 # with its 7.12.3 version. Curl will forget to post data if | 3223 # with its 7.12.3 version. Curl will forget to post data if |
3131 # there is a redirection. This function is a workaround for | 3224 # there is a redirection. This function is a workaround for |
3132 # curl. Redirection happens on borg hosts. | 3225 # curl. Redirection happens on borg hosts. |
3133 sub ResolveRedirectionForCurl { | 3226 sub ResolveRedirectionForCurl { |
3134 my $url = shift; | 3227 my $url = shift; |
3135 my $command_line = "$URL_FETCHER --head '$url'"; | 3228 my $command_line = ShellEscape(@URL_FETCHER, "--head", $url); |
3136 open(CMDLINE, "$command_line |") or error($command_line); | 3229 open(CMDLINE, "$command_line |") or error($command_line); |
3137 while (<CMDLINE>) { | 3230 while (<CMDLINE>) { |
3138 s/\r//g; # turn windows-looking lines into unix-looking lines | 3231 s/\r//g; # turn windows-looking lines into unix-looking lines |
3139 if (/^Location: (.*)/) { | 3232 if (/^Location: (.*)/) { |
3140 $url = $1; | 3233 $url = $1; |
3141 } | 3234 } |
3142 } | 3235 } |
3143 close(CMDLINE); | 3236 close(CMDLINE); |
3144 return $url; | 3237 return $url; |
3145 } | 3238 } |
3146 | 3239 |
3147 # Add a timeout flat to URL_FETCHER | 3240 # Add a timeout flat to URL_FETCHER. Returns a new list. |
3148 sub AddFetchTimeout { | 3241 sub AddFetchTimeout { |
3149 my $fetcher = shift; | |
3150 my $timeout = shift; | 3242 my $timeout = shift; |
| 3243 my @fetcher = shift; |
3151 if (defined($timeout)) { | 3244 if (defined($timeout)) { |
3152 if ($fetcher =~ m/\bcurl -s/) { | 3245 if (join(" ", @fetcher) =~ m/\bcurl -s/) { |
3153 $fetcher .= sprintf(" --max-time %d", $timeout); | 3246 push(@fetcher, "--max-time", sprintf("%d", $timeout)); |
3154 } elsif ($fetcher =~ m/\brpcget\b/) { | 3247 } elsif (join(" ", @fetcher) =~ m/\brpcget\b/) { |
3155 $fetcher .= sprintf(" --deadline=%d", $timeout); | 3248 push(@fetcher, sprintf("--deadline=%d", $timeout)); |
3156 } | 3249 } |
3157 } | 3250 } |
3158 return $fetcher; | 3251 return @fetcher; |
3159 } | 3252 } |
3160 | 3253 |
3161 # Reads a symbol map from the file handle name given as $1, returning | 3254 # Reads a symbol map from the file handle name given as $1, returning |
3162 # the resulting symbol map. Also processes variables relating to symbols. | 3255 # the resulting symbol map. Also processes variables relating to symbols. |
3163 # Currently, the only variable processed is 'binary=<value>' which updates | 3256 # Currently, the only variable processed is 'binary=<value>' which updates |
3164 # $main::prog to have the correct program name. | 3257 # $main::prog to have the correct program name. |
3165 sub ReadSymbols { | 3258 sub ReadSymbols { |
3166 my $in = shift; | 3259 my $in = shift; |
3167 my $map = {}; | 3260 my $map = {}; |
3168 while (<$in>) { | 3261 while (<$in>) { |
(...skipping 39 matching lines...) Expand 10 before | Expand all | Expand 10 after Loading... |
3208 if (!defined($symbol_map)) { | 3301 if (!defined($symbol_map)) { |
3209 my $post_data = join("+", sort((map {"0x" . "$_"} @pcs))); | 3302 my $post_data = join("+", sort((map {"0x" . "$_"} @pcs))); |
3210 | 3303 |
3211 open(POSTFILE, ">$main::tmpfile_sym"); | 3304 open(POSTFILE, ">$main::tmpfile_sym"); |
3212 print POSTFILE $post_data; | 3305 print POSTFILE $post_data; |
3213 close(POSTFILE); | 3306 close(POSTFILE); |
3214 | 3307 |
3215 my $url = SymbolPageURL(); | 3308 my $url = SymbolPageURL(); |
3216 | 3309 |
3217 my $command_line; | 3310 my $command_line; |
3218 if ($URL_FETCHER =~ m/\bcurl -s/) { | 3311 if (join(" ", @URL_FETCHER) =~ m/\bcurl -s/) { |
3219 $url = ResolveRedirectionForCurl($url); | 3312 $url = ResolveRedirectionForCurl($url); |
3220 $command_line = "$URL_FETCHER -d '\@$main::tmpfile_sym' '$url'"; | 3313 $command_line = ShellEscape(@URL_FETCHER, "-d", "\@$main::tmpfile_sym", |
| 3314 $url); |
3221 } else { | 3315 } else { |
3222 $command_line = "$URL_FETCHER --post '$url' < '$main::tmpfile_sym'"; | 3316 $command_line = (ShellEscape(@URL_FETCHER, "--post", $url) |
| 3317 . " < " . ShellEscape($main::tmpfile_sym)); |
3223 } | 3318 } |
3224 # We use c++filt in case $SYMBOL_PAGE gives us mangled symbols. | 3319 # We use c++filt in case $SYMBOL_PAGE gives us mangled symbols. |
3225 my $cppfilt = $obj_tool_map{"c++filt"}; | 3320 my $escaped_cppfilt = ShellEscape($obj_tool_map{"c++filt"}); |
3226 open(SYMBOL, "$command_line | $cppfilt |") or error($command_line); | 3321 open(SYMBOL, "$command_line | $escaped_cppfilt |") or error($command_line); |
3227 $symbol_map = ReadSymbols(*SYMBOL{IO}); | 3322 $symbol_map = ReadSymbols(*SYMBOL{IO}); |
3228 close(SYMBOL); | 3323 close(SYMBOL); |
3229 } | 3324 } |
3230 | 3325 |
3231 my $symbols = {}; | 3326 my $symbols = {}; |
3232 foreach my $pc (@pcs) { | 3327 foreach my $pc (@pcs) { |
3233 my $fullname; | 3328 my $fullname; |
3234 # For 64 bits binaries, symbols are extracted with 8 leading zeroes. | 3329 # For 64 bits binaries, symbols are extracted with 8 leading zeroes. |
3235 # Then /symbol reads the long symbols in as uint64, and outputs | 3330 # Then /symbol reads the long symbols in as uint64, and outputs |
3236 # the result with a "0x%08llx" format which get rid of the zeroes. | 3331 # the result with a "0x%08llx" format which get rid of the zeroes. |
3237 # By removing all the leading zeroes in both $pc and the symbols from | 3332 # By removing all the leading zeroes in both $pc and the symbols from |
3238 # /symbol, the symbols match and are retrievable from the map. | 3333 # /symbol, the symbols match and are retrievable from the map. |
3239 my $shortpc = $pc; | 3334 my $shortpc = $pc; |
3240 $shortpc =~ s/^0*//; | 3335 $shortpc =~ s/^0*//; |
3241 # Each line may have a list of names, which includes the function | 3336 # Each line may have a list of names, which includes the function |
3242 # and also other functions it has inlined. They are separated | 3337 # and also other functions it has inlined. They are separated (in |
3243 # (in PrintSymbolizedFile), by --, which is illegal in function names. | 3338 # PrintSymbolizedProfile), by --, which is illegal in function names. |
3244 my $fullnames; | 3339 my $fullnames; |
3245 if (defined($symbol_map->{$shortpc})) { | 3340 if (defined($symbol_map->{$shortpc})) { |
3246 $fullnames = $symbol_map->{$shortpc}; | 3341 $fullnames = $symbol_map->{$shortpc}; |
3247 } else { | 3342 } else { |
3248 $fullnames = "0x" . $pc; # Just use addresses | 3343 $fullnames = "0x" . $pc; # Just use addresses |
3249 } | 3344 } |
3250 my $sym = []; | 3345 my $sym = []; |
3251 $symbols->{$pc} = $sym; | 3346 $symbols->{$pc} = $sym; |
3252 foreach my $fullname (split("--", $fullnames)) { | 3347 foreach my $fullname (split("--", $fullnames)) { |
3253 my $name = ShortFunctionName($fullname); | 3348 my $name = ShortFunctionName($fullname); |
(...skipping 57 matching lines...) Expand 10 before | Expand all | Expand 10 after Loading... |
3311 mkdir($profile_dir) | 3406 mkdir($profile_dir) |
3312 || die("Unable to create profile directory $profile_dir: $!\n"); | 3407 || die("Unable to create profile directory $profile_dir: $!\n"); |
3313 } | 3408 } |
3314 my $tmp_profile = "$profile_dir/.tmp.$profile_file"; | 3409 my $tmp_profile = "$profile_dir/.tmp.$profile_file"; |
3315 my $real_profile = "$profile_dir/$profile_file"; | 3410 my $real_profile = "$profile_dir/$profile_file"; |
3316 | 3411 |
3317 if ($fetch_name_only > 0) { | 3412 if ($fetch_name_only > 0) { |
3318 return $real_profile; | 3413 return $real_profile; |
3319 } | 3414 } |
3320 | 3415 |
3321 my $fetcher = AddFetchTimeout($URL_FETCHER, $fetch_timeout); | 3416 my @fetcher = AddFetchTimeout($fetch_timeout, @URL_FETCHER); |
3322 my $cmd = "$fetcher '$url' > '$tmp_profile'"; | 3417 my $cmd = ShellEscape(@fetcher, $url) . " > " . ShellEscape($tmp_profile); |
3323 if ($path =~ m/$PROFILE_PAGE|$PMUPROFILE_PAGE|$CENSUSPROFILE_PAGE/){ | 3418 if ($path =~ m/$PROFILE_PAGE|$PMUPROFILE_PAGE|$CENSUSPROFILE_PAGE/){ |
3324 print STDERR "Gathering CPU profile from $url for $main::opt_seconds secon
ds to\n ${real_profile}\n"; | 3419 print STDERR "Gathering CPU profile from $url for $main::opt_seconds secon
ds to\n ${real_profile}\n"; |
3325 if ($encourage_patience) { | 3420 if ($encourage_patience) { |
3326 print STDERR "Be patient...\n"; | 3421 print STDERR "Be patient...\n"; |
3327 } | 3422 } |
3328 } else { | 3423 } else { |
3329 print STDERR "Fetching $path profile from $url to\n ${real_profile}\n"; | 3424 print STDERR "Fetching $path profile from $url to\n ${real_profile}\n"; |
3330 } | 3425 } |
3331 | 3426 |
3332 (system($cmd) == 0) || error("Failed to get profile: $cmd: $!\n"); | 3427 (system($cmd) == 0) || error("Failed to get profile: $cmd: $!\n"); |
3333 (system("mv $tmp_profile $real_profile") == 0) || error("Unable to rename pr
ofile\n"); | 3428 (system("mv", $tmp_profile, $real_profile) == 0) || error("Unable to rename
profile\n"); |
3334 print STDERR "Wrote profile to $real_profile\n"; | 3429 print STDERR "Wrote profile to $real_profile\n"; |
3335 $main::collected_profile = $real_profile; | 3430 $main::collected_profile = $real_profile; |
3336 return $main::collected_profile; | 3431 return $main::collected_profile; |
3337 } | 3432 } |
3338 } | 3433 } |
3339 | 3434 |
3340 # Collect profiles in parallel | 3435 # Collect profiles in parallel |
3341 sub FetchDynamicProfiles { | 3436 sub FetchDynamicProfiles { |
3342 my $items = scalar(@main::pfile_args); | 3437 my $items = scalar(@main::pfile_args); |
3343 my $levels = log($items) / log(2); | 3438 my $levels = log($items) / log(2); |
(...skipping 93 matching lines...) Expand 10 before | Expand all | Expand 10 after Loading... |
3437 @$slots = unpack($self->{unpack_code} . "*", $str); | 3532 @$slots = unpack($self->{unpack_code} . "*", $str); |
3438 } else { | 3533 } else { |
3439 # If we're a 64-bit profile, check if we're a 64-bit-capable | 3534 # If we're a 64-bit profile, check if we're a 64-bit-capable |
3440 # perl. Otherwise, each slot will be represented as a float | 3535 # perl. Otherwise, each slot will be represented as a float |
3441 # instead of an int64, losing precision and making all the | 3536 # instead of an int64, losing precision and making all the |
3442 # 64-bit addresses wrong. We won't complain yet, but will | 3537 # 64-bit addresses wrong. We won't complain yet, but will |
3443 # later if we ever see a value that doesn't fit in 32 bits. | 3538 # later if we ever see a value that doesn't fit in 32 bits. |
3444 my $has_q = 0; | 3539 my $has_q = 0; |
3445 eval { $has_q = pack("Q", "1") ? 1 : 1; }; | 3540 eval { $has_q = pack("Q", "1") ? 1 : 1; }; |
3446 if (!$has_q) { | 3541 if (!$has_q) { |
3447 » $self->{perl_is_64bit} = 0; | 3542 $self->{perl_is_64bit} = 0; |
3448 } | 3543 } |
3449 read($self->{file}, $str, 8); | 3544 read($self->{file}, $str, 8); |
3450 if (substr($str, 4, 4) eq chr(0)x4) { | 3545 if (substr($str, 4, 4) eq chr(0)x4) { |
3451 # We'd love to use 'Q', but it's a) not universal, b) not endian-proof. | 3546 # We'd love to use 'Q', but it's a) not universal, b) not endian-proof. |
3452 $self->{unpack_code} = 'V'; # Little-endian. | 3547 $self->{unpack_code} = 'V'; # Little-endian. |
3453 } elsif (substr($str, 0, 4) eq chr(0)x4) { | 3548 } elsif (substr($str, 0, 4) eq chr(0)x4) { |
3454 $self->{unpack_code} = 'N'; # Big-endian | 3549 $self->{unpack_code} = 'N'; # Big-endian |
3455 } else { | 3550 } else { |
3456 ::error("$fname: header size >= 2**32\n"); | 3551 ::error("$fname: header size >= 2**32\n"); |
3457 } | 3552 } |
(...skipping 15 matching lines...) Expand all Loading... |
3473 # This is the easy case: unpack provides 32-bit unpacking primitives. | 3568 # This is the easy case: unpack provides 32-bit unpacking primitives. |
3474 @$slots = unpack($self->{unpack_code} . "*", $str); | 3569 @$slots = unpack($self->{unpack_code} . "*", $str); |
3475 } else { | 3570 } else { |
3476 # We need to unpack 32 bits at a time and combine. | 3571 # We need to unpack 32 bits at a time and combine. |
3477 my @b32_values = unpack($self->{unpack_code} . "*", $str); | 3572 my @b32_values = unpack($self->{unpack_code} . "*", $str); |
3478 my @b64_values = (); | 3573 my @b64_values = (); |
3479 for (my $i = 0; $i < $#b32_values; $i += 2) { | 3574 for (my $i = 0; $i < $#b32_values; $i += 2) { |
3480 # TODO(csilvers): if this is a 32-bit perl, the math below | 3575 # TODO(csilvers): if this is a 32-bit perl, the math below |
3481 # could end up in a too-large int, which perl will promote | 3576 # could end up in a too-large int, which perl will promote |
3482 # to a double, losing necessary precision. Deal with that. | 3577 # to a double, losing necessary precision. Deal with that. |
3483 » # Right now, we just die. | 3578 # Right now, we just die. |
3484 » my ($lo, $hi) = ($b32_values[$i], $b32_values[$i+1]); | 3579 my ($lo, $hi) = ($b32_values[$i], $b32_values[$i+1]); |
3485 if ($self->{unpack_code} eq 'N') { # big-endian | 3580 if ($self->{unpack_code} eq 'N') { # big-endian |
3486 » ($lo, $hi) = ($hi, $lo); | 3581 ($lo, $hi) = ($hi, $lo); |
3487 » } | 3582 } |
3488 » my $value = $lo + $hi * (2**32); | 3583 my $value = $lo + $hi * (2**32); |
3489 » if (!$self->{perl_is_64bit} && # check value is exactly represented | 3584 if (!$self->{perl_is_64bit} && # check value is exactly represented |
3490 » (($value % (2**32)) != $lo || int($value / (2**32)) != $hi)) { | 3585 (($value % (2**32)) != $lo || int($value / (2**32)) != $hi)) { |
3491 » ::error("Need a 64-bit perl to process this 64-bit profile.\n"); | 3586 ::error("Need a 64-bit perl to process this 64-bit profile.\n"); |
3492 » } | 3587 } |
3493 » push(@b64_values, $value); | 3588 push(@b64_values, $value); |
3494 } | 3589 } |
3495 @$slots = @b64_values; | 3590 @$slots = @b64_values; |
3496 } | 3591 } |
3497 } | 3592 } |
3498 | 3593 |
3499 # Access the i-th long in the file (logically), or -1 at EOF. | 3594 # Access the i-th long in the file (logically), or -1 at EOF. |
3500 sub get { | 3595 sub get { |
3501 my ($self, $idx) = @_; | 3596 my ($self, $idx) = @_; |
3502 my $slots = $self->{slots}; | 3597 my $slots = $self->{slots}; |
3503 while ($#$slots >= 0) { | 3598 while ($#$slots >= 0) { |
(...skipping 107 matching lines...) Expand 10 before | Expand all | Expand 10 after Loading... |
3611 if (!defined($header)) { # means "at EOF" | 3706 if (!defined($header)) { # means "at EOF" |
3612 error("Profile is empty.\n"); | 3707 error("Profile is empty.\n"); |
3613 } | 3708 } |
3614 | 3709 |
3615 my $symbols; | 3710 my $symbols; |
3616 if ($header =~ m/^--- *$symbol_marker/o) { | 3711 if ($header =~ m/^--- *$symbol_marker/o) { |
3617 # Verify that the user asked for a symbolized profile | 3712 # Verify that the user asked for a symbolized profile |
3618 if (!$main::use_symbolized_profile) { | 3713 if (!$main::use_symbolized_profile) { |
3619 # we have both a binary and symbolized profiles, abort | 3714 # we have both a binary and symbolized profiles, abort |
3620 error("FATAL ERROR: Symbolized profile\n $fname\ncannot be used with " . | 3715 error("FATAL ERROR: Symbolized profile\n $fname\ncannot be used with " . |
3621 » "a binary arg. Try again without passing\n $prog\n"); | 3716 "a binary arg. Try again without passing\n $prog\n"); |
3622 } | 3717 } |
3623 # Read the symbol section of the symbolized profile file. | 3718 # Read the symbol section of the symbolized profile file. |
3624 $symbols = ReadSymbols(*PROFILE{IO}); | 3719 $symbols = ReadSymbols(*PROFILE{IO}); |
3625 # Read the next line to get the header for the remaining profile. | 3720 # Read the next line to get the header for the remaining profile. |
3626 $header = ReadProfileHeader(*PROFILE) || ""; | 3721 $header = ReadProfileHeader(*PROFILE) || ""; |
3627 } | 3722 } |
3628 | 3723 |
3629 $main::profile_type = ''; | 3724 $main::profile_type = ''; |
3630 if ($header =~ m/^heap profile:.*$growth_marker/o) { | 3725 if ($header =~ m/^heap profile:.*$growth_marker/o) { |
3631 $main::profile_type = 'growth'; | 3726 $main::profile_type = 'growth'; |
(...skipping 280 matching lines...) Expand 10 before | Expand all | Expand 10 after Loading... |
3912 if (m/^\s*(\d+):\s+(\d+)\s+\[\s*(\d+):\s+(\d+)\]\s+@\s+(.*)$/) { | 4007 if (m/^\s*(\d+):\s+(\d+)\s+\[\s*(\d+):\s+(\d+)\]\s+@\s+(.*)$/) { |
3913 my $stack = $5; | 4008 my $stack = $5; |
3914 my ($n1, $s1, $n2, $s2) = ($1, $2, $3, $4); | 4009 my ($n1, $s1, $n2, $s2) = ($1, $2, $3, $4); |
3915 | 4010 |
3916 if ($sample_adjustment) { | 4011 if ($sample_adjustment) { |
3917 if ($sampling_algorithm == 2) { | 4012 if ($sampling_algorithm == 2) { |
3918 # Remote-heap version 2 | 4013 # Remote-heap version 2 |
3919 # The sampling frequency is the rate of a Poisson process. | 4014 # The sampling frequency is the rate of a Poisson process. |
3920 # This means that the probability of sampling an allocation of | 4015 # This means that the probability of sampling an allocation of |
3921 # size X with sampling rate Y is 1 - exp(-X/Y) | 4016 # size X with sampling rate Y is 1 - exp(-X/Y) |
3922 » if ($n1 != 0) { | 4017 if ($n1 != 0) { |
3923 » my $ratio = (($s1*1.0)/$n1)/($sample_adjustment); | 4018 my $ratio = (($s1*1.0)/$n1)/($sample_adjustment); |
3924 » my $scale_factor = 1/(1 - exp(-$ratio)); | 4019 my $scale_factor = 1/(1 - exp(-$ratio)); |
3925 » $n1 *= $scale_factor; | 4020 $n1 *= $scale_factor; |
3926 » $s1 *= $scale_factor; | 4021 $s1 *= $scale_factor; |
3927 » } | 4022 } |
3928 » if ($n2 != 0) { | 4023 if ($n2 != 0) { |
3929 » my $ratio = (($s2*1.0)/$n2)/($sample_adjustment); | 4024 my $ratio = (($s2*1.0)/$n2)/($sample_adjustment); |
3930 » my $scale_factor = 1/(1 - exp(-$ratio)); | 4025 my $scale_factor = 1/(1 - exp(-$ratio)); |
3931 » $n2 *= $scale_factor; | 4026 $n2 *= $scale_factor; |
3932 » $s2 *= $scale_factor; | 4027 $s2 *= $scale_factor; |
3933 » } | 4028 } |
3934 } else { | 4029 } else { |
3935 # Remote-heap version 1 | 4030 # Remote-heap version 1 |
3936 my $ratio; | 4031 my $ratio; |
3937 $ratio = (($s1*1.0)/$n1)/($sample_adjustment); | 4032 $ratio = (($s1*1.0)/$n1)/($sample_adjustment); |
3938 if ($ratio < 1) { | 4033 if ($ratio < 1) { |
3939 $n1 /= $ratio; | 4034 $n1 /= $ratio; |
3940 $s1 /= $ratio; | 4035 $s1 /= $ratio; |
3941 } | 4036 } |
3942 $ratio = (($s2*1.0)/$n2)/($sample_adjustment); | 4037 $ratio = (($s2*1.0)/$n2)/($sample_adjustment); |
3943 if ($ratio < 1) { | 4038 if ($ratio < 1) { |
(...skipping 103 matching lines...) Expand 10 before | Expand all | Expand 10 after Loading... |
4047 | 4142 |
4048 my $r = {}; | 4143 my $r = {}; |
4049 $r->{version} = 0; | 4144 $r->{version} = 0; |
4050 $r->{period} = $sampling_period; | 4145 $r->{period} = $sampling_period; |
4051 $r->{profile} = $profile; | 4146 $r->{profile} = $profile; |
4052 $r->{libs} = ParseLibraries($prog, $map, $pcs); | 4147 $r->{libs} = ParseLibraries($prog, $map, $pcs); |
4053 $r->{pcs} = $pcs; | 4148 $r->{pcs} = $pcs; |
4054 return $r; | 4149 return $r; |
4055 } | 4150 } |
4056 | 4151 |
4057 # Given a hex value in the form "0x1abcd" return "0001abcd" or | 4152 # Given a hex value in the form "0x1abcd" or "1abcd", return either |
4058 # "000000000001abcd", depending on the current address length. | 4153 # "0001abcd" or "000000000001abcd", depending on the current (global) |
4059 # There's probably a more idiomatic (or faster) way to do this... | 4154 # address length. |
4060 sub HexExtend { | 4155 sub HexExtend { |
4061 my $addr = shift; | 4156 my $addr = shift; |
4062 | 4157 |
4063 $addr =~ s/^0x//; | 4158 $addr =~ s/^(0x)?0*//; |
4064 | 4159 my $zeros_needed = $address_length - length($addr); |
4065 if (length $addr > $address_length) { | 4160 if ($zeros_needed < 0) { |
4066 printf STDERR "Warning: address $addr is longer than address length $addres
s_length\n"; | 4161 printf STDERR "Warning: address $addr is longer than address length $address
_length\n"; |
| 4162 return $addr; |
4067 } | 4163 } |
4068 | 4164 return ("0" x $zeros_needed) . $addr; |
4069 return substr("000000000000000".$addr, -$address_length); | |
4070 } | 4165 } |
4071 | 4166 |
4072 ##### Symbol extraction ##### | 4167 ##### Symbol extraction ##### |
4073 | 4168 |
4074 # Aggressively search the lib_prefix values for the given library | 4169 # Aggressively search the lib_prefix values for the given library |
4075 # If all else fails, just return the name of the library unmodified. | 4170 # If all else fails, just return the name of the library unmodified. |
4076 # If the lib_prefix is "/my/path,/other/path" and $file is "/lib/dir/mylib.so" | 4171 # If the lib_prefix is "/my/path,/other/path" and $file is "/lib/dir/mylib.so" |
4077 # it will search the following locations in this order, until it finds a file: | 4172 # it will search the following locations in this order, until it finds a file: |
4078 # /my/path/lib/dir/mylib.so | 4173 # /my/path/lib/dir/mylib.so |
4079 # /other/path/lib/dir/mylib.so | 4174 # /other/path/lib/dir/mylib.so |
(...skipping 30 matching lines...) Expand all Loading... |
4110 | 4205 |
4111 # Parse text section header of a library using objdump | 4206 # Parse text section header of a library using objdump |
4112 sub ParseTextSectionHeaderFromObjdump { | 4207 sub ParseTextSectionHeaderFromObjdump { |
4113 my $lib = shift; | 4208 my $lib = shift; |
4114 | 4209 |
4115 my $size = undef; | 4210 my $size = undef; |
4116 my $vma; | 4211 my $vma; |
4117 my $file_offset; | 4212 my $file_offset; |
4118 # Get objdump output from the library file to figure out how to | 4213 # Get objdump output from the library file to figure out how to |
4119 # map between mapped addresses and addresses in the library. | 4214 # map between mapped addresses and addresses in the library. |
4120 my $objdump = $obj_tool_map{"objdump"}; | 4215 my $cmd = ShellEscape($obj_tool_map{"objdump"}, "-h", $lib); |
4121 open(OBJDUMP, "$objdump -h $lib |") | 4216 open(OBJDUMP, "$cmd |") || error("$cmd: $!\n"); |
4122 || error("$objdump $lib: $!\n"); | |
4123 while (<OBJDUMP>) { | 4217 while (<OBJDUMP>) { |
4124 s/\r//g; # turn windows-looking lines into unix-looking lines | 4218 s/\r//g; # turn windows-looking lines into unix-looking lines |
4125 # Idx Name Size VMA LMA File off Algn | 4219 # Idx Name Size VMA LMA File off Algn |
4126 # 10 .text 00104b2c 420156f0 420156f0 000156f0 2**4 | 4220 # 10 .text 00104b2c 420156f0 420156f0 000156f0 2**4 |
4127 # For 64-bit objects, VMA and LMA will be 16 hex digits, size and file | 4221 # For 64-bit objects, VMA and LMA will be 16 hex digits, size and file |
4128 # offset may still be 8. But AddressSub below will still handle that. | 4222 # offset may still be 8. But AddressSub below will still handle that. |
4129 my @x = split; | 4223 my @x = split; |
4130 if (($#x >= 6) && ($x[1] eq '.text')) { | 4224 if (($#x >= 6) && ($x[1] eq '.text')) { |
4131 $size = $x[2]; | 4225 $size = $x[2]; |
4132 $vma = $x[3]; | 4226 $vma = $x[3]; |
(...skipping 17 matching lines...) Expand all Loading... |
4150 | 4244 |
4151 # Parse text section header of a library using otool (on OS X) | 4245 # Parse text section header of a library using otool (on OS X) |
4152 sub ParseTextSectionHeaderFromOtool { | 4246 sub ParseTextSectionHeaderFromOtool { |
4153 my $lib = shift; | 4247 my $lib = shift; |
4154 | 4248 |
4155 my $size = undef; | 4249 my $size = undef; |
4156 my $vma = undef; | 4250 my $vma = undef; |
4157 my $file_offset = undef; | 4251 my $file_offset = undef; |
4158 # Get otool output from the library file to figure out how to | 4252 # Get otool output from the library file to figure out how to |
4159 # map between mapped addresses and addresses in the library. | 4253 # map between mapped addresses and addresses in the library. |
4160 my $otool = $obj_tool_map{"otool"}; | 4254 my $command = ShellEscape($obj_tool_map{"otool"}, "-l", $lib); |
4161 open(OTOOL, "$otool -l $lib |") | 4255 open(OTOOL, "$command |") || error("$command: $!\n"); |
4162 || error("$otool $lib: $!\n"); | |
4163 my $cmd = ""; | 4256 my $cmd = ""; |
4164 my $sectname = ""; | 4257 my $sectname = ""; |
4165 my $segname = ""; | 4258 my $segname = ""; |
4166 foreach my $line (<OTOOL>) { | 4259 foreach my $line (<OTOOL>) { |
4167 $line =~ s/\r//g; # turn windows-looking lines into unix-looking lines | 4260 $line =~ s/\r//g; # turn windows-looking lines into unix-looking lines |
4168 # Load command <#> | 4261 # Load command <#> |
4169 # cmd LC_SEGMENT | 4262 # cmd LC_SEGMENT |
4170 # [...] | 4263 # [...] |
4171 # Section | 4264 # Section |
4172 # sectname __text | 4265 # sectname __text |
(...skipping 321 matching lines...) Expand 10 before | Expand all | Expand 10 after Loading... |
4494 my $libname = $lib->[0]; | 4587 my $libname = $lib->[0]; |
4495 my $start = $lib->[1]; | 4588 my $start = $lib->[1]; |
4496 my $finish = $lib->[2]; | 4589 my $finish = $lib->[2]; |
4497 my $offset = $lib->[3]; | 4590 my $offset = $lib->[3]; |
4498 | 4591 |
4499 # Get list of pcs that belong in this library. | 4592 # Get list of pcs that belong in this library. |
4500 my $contained = []; | 4593 my $contained = []; |
4501 my ($start_pc_index, $finish_pc_index); | 4594 my ($start_pc_index, $finish_pc_index); |
4502 # Find smallest finish_pc_index such that $finish < $pc[$finish_pc_index]. | 4595 # Find smallest finish_pc_index such that $finish < $pc[$finish_pc_index]. |
4503 for ($finish_pc_index = $#pcs + 1; $finish_pc_index > 0; | 4596 for ($finish_pc_index = $#pcs + 1; $finish_pc_index > 0; |
4504 » $finish_pc_index--) { | 4597 $finish_pc_index--) { |
4505 last if $pcs[$finish_pc_index - 1] le $finish; | 4598 last if $pcs[$finish_pc_index - 1] le $finish; |
4506 } | 4599 } |
4507 # Find smallest start_pc_index such that $start <= $pc[$start_pc_index]. | 4600 # Find smallest start_pc_index such that $start <= $pc[$start_pc_index]. |
4508 for ($start_pc_index = $finish_pc_index; $start_pc_index > 0; | 4601 for ($start_pc_index = $finish_pc_index; $start_pc_index > 0; |
4509 » $start_pc_index--) { | 4602 $start_pc_index--) { |
4510 last if $pcs[$start_pc_index - 1] lt $start; | 4603 last if $pcs[$start_pc_index - 1] lt $start; |
4511 } | 4604 } |
4512 # This keeps PC values higher than $pc[$finish_pc_index] in @pcs, | 4605 # This keeps PC values higher than $pc[$finish_pc_index] in @pcs, |
4513 # in case there are overlaps in libraries and the main binary. | 4606 # in case there are overlaps in libraries and the main binary. |
4514 @{$contained} = splice(@pcs, $start_pc_index, | 4607 @{$contained} = splice(@pcs, $start_pc_index, |
4515 » » » $finish_pc_index - $start_pc_index); | 4608 $finish_pc_index - $start_pc_index); |
4516 # Map to symbols | 4609 # Map to symbols |
4517 MapToSymbols($libname, AddressSub($start, $offset), $contained, $symbols); | 4610 MapToSymbols($libname, AddressSub($start, $offset), $contained, $symbols); |
4518 } | 4611 } |
4519 | 4612 |
4520 return $symbols; | 4613 return $symbols; |
4521 } | 4614 } |
4522 | 4615 |
4523 # Map list of PC values to symbols for a given image | 4616 # Map list of PC values to symbols for a given image |
4524 sub MapToSymbols { | 4617 sub MapToSymbols { |
4525 my $image = shift; | 4618 my $image = shift; |
4526 my $offset = shift; | 4619 my $offset = shift; |
4527 my $pclist = shift; | 4620 my $pclist = shift; |
4528 my $symbols = shift; | 4621 my $symbols = shift; |
4529 | 4622 |
4530 my $debug = 0; | 4623 my $debug = 0; |
4531 | 4624 |
4532 # Ignore empty binaries | 4625 # Ignore empty binaries |
4533 if ($#{$pclist} < 0) { return; } | 4626 if ($#{$pclist} < 0) { return; } |
4534 | 4627 |
4535 # Figure out the addr2line command to use | 4628 # Figure out the addr2line command to use |
4536 my $addr2line = $obj_tool_map{"addr2line"}; | 4629 my $addr2line = $obj_tool_map{"addr2line"}; |
4537 my $cmd = "$addr2line -f -C -e $image"; | 4630 my $cmd = ShellEscape($addr2line, "-f", "-C", "-e", $image); |
4538 if (exists $obj_tool_map{"addr2line_pdb"}) { | 4631 if (exists $obj_tool_map{"addr2line_pdb"}) { |
4539 $addr2line = $obj_tool_map{"addr2line_pdb"}; | 4632 $addr2line = $obj_tool_map{"addr2line_pdb"}; |
4540 $cmd = "$addr2line --demangle -f -C -e $image"; | 4633 $cmd = ShellEscape($addr2line, "--demangle", "-f", "-C", "-e", $image); |
4541 } | 4634 } |
4542 | 4635 |
4543 # If "addr2line" isn't installed on the system at all, just use | 4636 # If "addr2line" isn't installed on the system at all, just use |
4544 # nm to get what info we can (function names, but not line numbers). | 4637 # nm to get what info we can (function names, but not line numbers). |
4545 if (system("$addr2line --help >$dev_null 2>&1") != 0) { | 4638 if (system(ShellEscape($addr2line, "--help") . " >$dev_null 2>&1") != 0) { |
4546 MapSymbolsWithNM($image, $offset, $pclist, $symbols); | 4639 MapSymbolsWithNM($image, $offset, $pclist, $symbols); |
4547 return; | 4640 return; |
4548 } | 4641 } |
4549 | 4642 |
4550 # "addr2line -i" can produce a variable number of lines per input | 4643 # "addr2line -i" can produce a variable number of lines per input |
4551 # address, with no separator that allows us to tell when data for | 4644 # address, with no separator that allows us to tell when data for |
4552 # the next address starts. So we find the address for a special | 4645 # the next address starts. So we find the address for a special |
4553 # symbol (_fini) and interleave this address between all real | 4646 # symbol (_fini) and interleave this address between all real |
4554 # addresses passed to addr2line. The name of this special symbol | 4647 # addresses passed to addr2line. The name of this special symbol |
4555 # can then be used as a separator. | 4648 # can then be used as a separator. |
4556 $sep_address = undef; # May be filled in by MapSymbolsWithNM() | 4649 $sep_address = undef; # May be filled in by MapSymbolsWithNM() |
4557 my $nm_symbols = {}; | 4650 my $nm_symbols = {}; |
4558 MapSymbolsWithNM($image, $offset, $pclist, $nm_symbols); | 4651 MapSymbolsWithNM($image, $offset, $pclist, $nm_symbols); |
4559 # TODO(csilvers): only add '-i' if addr2line supports it. | |
4560 if (defined($sep_address)) { | 4652 if (defined($sep_address)) { |
4561 # Only add " -i" to addr2line if the binary supports it. | 4653 # Only add " -i" to addr2line if the binary supports it. |
4562 # addr2line --help returns 0, but not if it sees an unknown flag first. | 4654 # addr2line --help returns 0, but not if it sees an unknown flag first. |
4563 if (system("$cmd -i --help >$dev_null 2>&1") == 0) { | 4655 if (system("$cmd -i --help >$dev_null 2>&1") == 0) { |
4564 $cmd .= " -i"; | 4656 $cmd .= " -i"; |
4565 } else { | 4657 } else { |
4566 $sep_address = undef; # no need for sep_address if we don't support -i | 4658 $sep_address = undef; # no need for sep_address if we don't support -i |
4567 } | 4659 } |
4568 } | 4660 } |
4569 | 4661 |
4570 # Make file with all PC values with intervening 'sep_address' so | 4662 # Make file with all PC values with intervening 'sep_address' so |
4571 # that we can reliably detect the end of inlined function list | 4663 # that we can reliably detect the end of inlined function list |
4572 open(ADDRESSES, ">$main::tmpfile_sym") || error("$main::tmpfile_sym: $!\n"); | 4664 open(ADDRESSES, ">$main::tmpfile_sym") || error("$main::tmpfile_sym: $!\n"); |
4573 if ($debug) { print("---- $image ---\n"); } | 4665 if ($debug) { print("---- $image ---\n"); } |
4574 for (my $i = 0; $i <= $#{$pclist}; $i++) { | 4666 for (my $i = 0; $i <= $#{$pclist}; $i++) { |
4575 # addr2line always reads hex addresses, and does not need '0x' prefix. | 4667 # addr2line always reads hex addresses, and does not need '0x' prefix. |
4576 if ($debug) { printf STDERR ("%s\n", $pclist->[$i]); } | 4668 if ($debug) { printf STDERR ("%s\n", $pclist->[$i]); } |
4577 printf ADDRESSES ("%s\n", AddressSub($pclist->[$i], $offset)); | 4669 printf ADDRESSES ("%s\n", AddressSub($pclist->[$i], $offset)); |
4578 if (defined($sep_address)) { | 4670 if (defined($sep_address)) { |
4579 printf ADDRESSES ("%s\n", $sep_address); | 4671 printf ADDRESSES ("%s\n", $sep_address); |
4580 } | 4672 } |
4581 } | 4673 } |
4582 close(ADDRESSES); | 4674 close(ADDRESSES); |
4583 if ($debug) { | 4675 if ($debug) { |
4584 print("----\n"); | 4676 print("----\n"); |
4585 system("cat $main::tmpfile_sym"); | 4677 system("cat", $main::tmpfile_sym); |
4586 print("----\n"); | 4678 print("----\n"); |
4587 system("$cmd <$main::tmpfile_sym"); | 4679 system("$cmd < " . ShellEscape($main::tmpfile_sym)); |
4588 print("----\n"); | 4680 print("----\n"); |
4589 } | 4681 } |
4590 | 4682 |
4591 open(SYMBOLS, "$cmd <$main::tmpfile_sym |") || error("$cmd: $!\n"); | 4683 open(SYMBOLS, "$cmd <" . ShellEscape($main::tmpfile_sym) . " |") |
| 4684 || error("$cmd: $!\n"); |
4592 my $count = 0; # Index in pclist | 4685 my $count = 0; # Index in pclist |
4593 while (<SYMBOLS>) { | 4686 while (<SYMBOLS>) { |
4594 # Read fullfunction and filelineinfo from next pair of lines | 4687 # Read fullfunction and filelineinfo from next pair of lines |
4595 s/\r?\n$//g; | 4688 s/\r?\n$//g; |
4596 my $fullfunction = $_; | 4689 my $fullfunction = $_; |
4597 $_ = <SYMBOLS>; | 4690 $_ = <SYMBOLS>; |
4598 s/\r?\n$//g; | 4691 s/\r?\n$//g; |
4599 my $filelinenum = $_; | 4692 my $filelinenum = $_; |
4600 | 4693 |
4601 if (defined($sep_address) && $fullfunction eq $sep_symbol) { | 4694 if (defined($sep_address) && $fullfunction eq $sep_symbol) { |
4602 # Terminating marker for data for this address | 4695 # Terminating marker for data for this address |
4603 $count++; | 4696 $count++; |
4604 next; | 4697 next; |
4605 } | 4698 } |
4606 | 4699 |
4607 $filelinenum =~ s|\\|/|g; # turn windows-style paths into unix-style paths | 4700 $filelinenum =~ s|\\|/|g; # turn windows-style paths into unix-style paths |
4608 | 4701 |
4609 my $pcstr = $pclist->[$count]; | 4702 my $pcstr = $pclist->[$count]; |
4610 my $function = ShortFunctionName($fullfunction); | 4703 my $function = ShortFunctionName($fullfunction); |
4611 if ($fullfunction eq '??') { | 4704 my $nms = $nm_symbols->{$pcstr}; |
4612 # See if nm found a symbol | 4705 if (defined($nms)) { |
4613 my $nms = $nm_symbols->{$pcstr}; | 4706 if ($fullfunction eq '??') { |
4614 if (defined($nms)) { | 4707 # nm found a symbol for us. |
4615 $function = $nms->[0]; | 4708 $function = $nms->[0]; |
4616 $fullfunction = $nms->[2]; | 4709 $fullfunction = $nms->[2]; |
| 4710 } else { |
| 4711 # MapSymbolsWithNM tags each routine with its starting address, |
| 4712 # useful in case the image has multiple occurrences of this |
| 4713 # routine. (It uses a syntax that resembles template paramters, |
| 4714 # that are automatically stripped out by ShortFunctionName().) |
| 4715 # addr2line does not provide the same information. So we check |
| 4716 # if nm disambiguated our symbol, and if so take the annotated |
| 4717 # (nm) version of the routine-name. TODO(csilvers): this won't |
| 4718 # catch overloaded, inlined symbols, which nm doesn't see. |
| 4719 # Better would be to do a check similar to nm's, in this fn. |
| 4720 if ($nms->[2] =~ m/^\Q$function\E/) { # sanity check it's the right fn |
| 4721 $function = $nms->[0]; |
| 4722 $fullfunction = $nms->[2]; |
| 4723 } |
4617 } | 4724 } |
4618 } | 4725 } |
4619 | 4726 |
4620 # Prepend to accumulated symbols for pcstr | 4727 # Prepend to accumulated symbols for pcstr |
4621 # (so that caller comes before callee) | 4728 # (so that caller comes before callee) |
4622 my $sym = $symbols->{$pcstr}; | 4729 my $sym = $symbols->{$pcstr}; |
4623 if (!defined($sym)) { | 4730 if (!defined($sym)) { |
4624 $sym = []; | 4731 $sym = []; |
4625 $symbols->{$pcstr} = $sym; | 4732 $symbols->{$pcstr} = $sym; |
4626 } | 4733 } |
4627 unshift(@{$sym}, $function, $filelinenum, $fullfunction); | 4734 unshift(@{$sym}, $function, $filelinenum, $fullfunction); |
4628 if ($debug) { printf STDERR ("%s => [%s]\n", $pcstr, join(" ", @{$sym})); } | 4735 if ($debug) { printf STDERR ("%s => [%s]\n", $pcstr, join(" ", @{$sym})); } |
4629 if (!defined($sep_address)) { | 4736 if (!defined($sep_address)) { |
4630 # Inlining is off, se this entry ends immediately | 4737 # Inlining is off, so this entry ends immediately |
4631 $count++; | 4738 $count++; |
4632 } | 4739 } |
4633 } | 4740 } |
4634 close(SYMBOLS); | 4741 close(SYMBOLS); |
4635 } | 4742 } |
4636 | 4743 |
4637 # Use nm to map the list of referenced PCs to symbols. Return true iff we | 4744 # Use nm to map the list of referenced PCs to symbols. Return true iff we |
4638 # are able to read procedure information via nm. | 4745 # are able to read procedure information via nm. |
4639 sub MapSymbolsWithNM { | 4746 sub MapSymbolsWithNM { |
4640 my $image = shift; | 4747 my $image = shift; |
(...skipping 86 matching lines...) Expand 10 before | Expand all | Expand 10 after Loading... |
4727 sub ConfigureObjTools { | 4834 sub ConfigureObjTools { |
4728 my $prog_file = shift; | 4835 my $prog_file = shift; |
4729 | 4836 |
4730 # Check for the existence of $prog_file because /usr/bin/file does not | 4837 # Check for the existence of $prog_file because /usr/bin/file does not |
4731 # predictably return error status in prod. | 4838 # predictably return error status in prod. |
4732 (-e $prog_file) || error("$prog_file does not exist.\n"); | 4839 (-e $prog_file) || error("$prog_file does not exist.\n"); |
4733 | 4840 |
4734 my $file_type = undef; | 4841 my $file_type = undef; |
4735 if (-e "/usr/bin/file") { | 4842 if (-e "/usr/bin/file") { |
4736 # Follow symlinks (at least for systems where "file" supports that). | 4843 # Follow symlinks (at least for systems where "file" supports that). |
4737 $file_type = `/usr/bin/file -L $prog_file 2>$dev_null || /usr/bin/file $prog
_file`; | 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`; |
4738 } elsif ($^O == "MSWin32") { | 4847 } elsif ($^O == "MSWin32") { |
4739 $file_type = "MS Windows"; | 4848 $file_type = "MS Windows"; |
4740 } else { | 4849 } else { |
4741 print STDERR "WARNING: Can't determine the file type of $prog_file"; | 4850 print STDERR "WARNING: Can't determine the file type of $prog_file"; |
4742 } | 4851 } |
4743 | 4852 |
4744 if ($file_type =~ /64-bit/) { | 4853 if ($file_type =~ /64-bit/) { |
4745 # Change $address_length to 16 if the program file is ELF 64-bit. | 4854 # Change $address_length to 16 if the program file is ELF 64-bit. |
4746 # We can't detect this from many (most?) heap or lock contention | 4855 # We can't detect this from many (most?) heap or lock contention |
4747 # profiles, since the actual addresses referenced are generally in low | 4856 # profiles, since the actual addresses referenced are generally in low |
(...skipping 61 matching lines...) Expand 10 before | Expand all | Expand 10 after Loading... |
4809 if (-x "$dirname$tool") { | 4918 if (-x "$dirname$tool") { |
4810 $path = "$dirname$tool"; | 4919 $path = "$dirname$tool"; |
4811 } else { | 4920 } else { |
4812 $path = $tool; | 4921 $path = $tool; |
4813 } | 4922 } |
4814 } | 4923 } |
4815 if ($main::opt_debug) { print STDERR "Using '$path' for '$tool'.\n"; } | 4924 if ($main::opt_debug) { print STDERR "Using '$path' for '$tool'.\n"; } |
4816 return $path; | 4925 return $path; |
4817 } | 4926 } |
4818 | 4927 |
| 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 |
4819 sub cleanup { | 4941 sub cleanup { |
4820 unlink($main::tmpfile_sym); | 4942 unlink($main::tmpfile_sym); |
4821 unlink(keys %main::tempnames); | 4943 unlink(keys %main::tempnames); |
4822 | 4944 |
4823 # We leave any collected profiles in $HOME/pprof in case the user wants | 4945 # We leave any collected profiles in $HOME/pprof in case the user wants |
4824 # to look at them later. We print a message informing them of this. | 4946 # to look at them later. We print a message informing them of this. |
4825 if ((scalar(@main::profile_files) > 0) && | 4947 if ((scalar(@main::profile_files) > 0) && |
4826 defined($main::collected_profile)) { | 4948 defined($main::collected_profile)) { |
4827 if (scalar(@main::profile_files) == 1) { | 4949 if (scalar(@main::profile_files) == 1) { |
4828 print STDERR "Dynamically gathered profile is in $main::collected_profile\
n"; | 4950 print STDERR "Dynamically gathered profile is in $main::collected_profile\
n"; |
(...skipping 17 matching lines...) Expand all Loading... |
4846 print STDERR $msg; | 4968 print STDERR $msg; |
4847 cleanup(); | 4969 cleanup(); |
4848 exit(1); | 4970 exit(1); |
4849 } | 4971 } |
4850 | 4972 |
4851 | 4973 |
4852 # Run $nm_command and get all the resulting procedure boundaries whose | 4974 # Run $nm_command and get all the resulting procedure boundaries whose |
4853 # names match "$regexp" and returns them in a hashtable mapping from | 4975 # names match "$regexp" and returns them in a hashtable mapping from |
4854 # procedure name to a two-element vector of [start address, end address] | 4976 # procedure name to a two-element vector of [start address, end address] |
4855 sub GetProcedureBoundariesViaNm { | 4977 sub GetProcedureBoundariesViaNm { |
4856 my $nm_command = shift; | 4978 my $escaped_nm_command = shift; # shell-escaped |
4857 my $regexp = shift; | 4979 my $regexp = shift; |
4858 | 4980 |
4859 my $symbol_table = {}; | 4981 my $symbol_table = {}; |
4860 open(NM, "$nm_command |") || error("$nm_command: $!\n"); | 4982 open(NM, "$escaped_nm_command |") || error("$escaped_nm_command: $!\n"); |
4861 my $last_start = "0"; | 4983 my $last_start = "0"; |
4862 my $routine = ""; | 4984 my $routine = ""; |
4863 while (<NM>) { | 4985 while (<NM>) { |
4864 s/\r//g; # turn windows-looking lines into unix-looking lines | 4986 s/\r//g; # turn windows-looking lines into unix-looking lines |
4865 if (m/^\s*([0-9a-f]+) (.) (..*)/) { | 4987 if (m/^\s*([0-9a-f]+) (.) (..*)/) { |
4866 my $start_val = $1; | 4988 my $start_val = $1; |
4867 my $type = $2; | 4989 my $type = $2; |
4868 my $this_routine = $3; | 4990 my $this_routine = $3; |
4869 | 4991 |
4870 # It's possible for two symbols to share the same address, if | 4992 # It's possible for two symbols to share the same address, if |
(...skipping 57 matching lines...) Expand 10 before | Expand all | Expand 10 after Loading... |
4928 } | 5050 } |
4929 | 5051 |
4930 # Gets the procedure boundaries for all routines in "$image" whose names | 5052 # Gets the procedure boundaries for all routines in "$image" whose names |
4931 # match "$regexp" and returns them in a hashtable mapping from procedure | 5053 # match "$regexp" and returns them in a hashtable mapping from procedure |
4932 # name to a two-element vector of [start address, end address]. | 5054 # name to a two-element vector of [start address, end address]. |
4933 # Will return an empty map if nm is not installed or not working properly. | 5055 # Will return an empty map if nm is not installed or not working properly. |
4934 sub GetProcedureBoundaries { | 5056 sub GetProcedureBoundaries { |
4935 my $image = shift; | 5057 my $image = shift; |
4936 my $regexp = shift; | 5058 my $regexp = shift; |
4937 | 5059 |
| 5060 # If $image doesn't start with /, then put ./ in front of it. This works |
| 5061 # around an obnoxious bug in our probing of nm -f behavior. |
| 5062 # "nm -f $image" is supposed to fail on GNU nm, but if: |
| 5063 # |
| 5064 # a. $image starts with [BbSsPp] (for example, bin/foo/bar), AND |
| 5065 # b. you have a.out in your current directory (a not uncommon occurence) |
| 5066 # |
| 5067 # then "nm -f $image" succeeds because -f only looks at the first letter of |
| 5068 # the argument, which looks valid because it's [BbSsPp], and then since |
| 5069 # there's no image provided, it looks for a.out and finds it. |
| 5070 # |
| 5071 # This regex makes sure that $image starts with . or /, forcing the -f |
| 5072 # parsing to fail since . and / are not valid formats. |
| 5073 $image =~ s#^[^/]#./$&#; |
| 5074 |
4938 # For libc libraries, the copy in /usr/lib/debug contains debugging symbols | 5075 # For libc libraries, the copy in /usr/lib/debug contains debugging symbols |
4939 my $debugging = DebuggingLibrary($image); | 5076 my $debugging = DebuggingLibrary($image); |
4940 if ($debugging) { | 5077 if ($debugging) { |
4941 $image = $debugging; | 5078 $image = $debugging; |
4942 } | 5079 } |
4943 | 5080 |
4944 my $nm = $obj_tool_map{"nm"}; | 5081 my $nm = $obj_tool_map{"nm"}; |
4945 my $cppfilt = $obj_tool_map{"c++filt"}; | 5082 my $cppfilt = $obj_tool_map{"c++filt"}; |
4946 | 5083 |
4947 # nm can fail for two reasons: 1) $image isn't a debug library; 2) nm | 5084 # nm can fail for two reasons: 1) $image isn't a debug library; 2) nm |
4948 # binary doesn't support --demangle. In addition, for OS X we need | 5085 # binary doesn't support --demangle. In addition, for OS X we need |
4949 # to use the -f flag to get 'flat' nm output (otherwise we don't sort | 5086 # to use the -f flag to get 'flat' nm output (otherwise we don't sort |
4950 # properly and get incorrect results). Unfortunately, GNU nm uses -f | 5087 # properly and get incorrect results). Unfortunately, GNU nm uses -f |
4951 # in an incompatible way. So first we test whether our nm supports | 5088 # in an incompatible way. So first we test whether our nm supports |
4952 # --demangle and -f. | 5089 # --demangle and -f. |
4953 my $demangle_flag = ""; | 5090 my $demangle_flag = ""; |
4954 my $cppfilt_flag = ""; | 5091 my $cppfilt_flag = ""; |
4955 if (system("$nm --demangle $image >$dev_null 2>&1") == 0) { | 5092 my $to_devnull = ">$dev_null 2>&1"; |
| 5093 if (system(ShellEscape($nm, "--demangle", "image") . $to_devnull) == 0) { |
4956 # In this mode, we do "nm --demangle <foo>" | 5094 # In this mode, we do "nm --demangle <foo>" |
4957 $demangle_flag = "--demangle"; | 5095 $demangle_flag = "--demangle"; |
4958 $cppfilt_flag = ""; | 5096 $cppfilt_flag = ""; |
4959 } elsif (system("$cppfilt $image >$dev_null 2>&1") == 0) { | 5097 } elsif (system(ShellEscape($cppfilt, $image) . $to_devnull) == 0) { |
4960 # In this mode, we do "nm <foo> | c++filt" | 5098 # In this mode, we do "nm <foo> | c++filt" |
4961 $cppfilt_flag = " | $cppfilt"; | 5099 $cppfilt_flag = " | " . ShellEscape($cppfilt); |
4962 }; | 5100 }; |
4963 my $flatten_flag = ""; | 5101 my $flatten_flag = ""; |
4964 if (system("$nm -f $image >$dev_null 2>&1") == 0) { | 5102 if (system(ShellEscape($nm, "-f", $image) . $to_devnull) == 0) { |
4965 $flatten_flag = "-f"; | 5103 $flatten_flag = "-f"; |
4966 } | 5104 } |
4967 | 5105 |
4968 # Finally, in the case $imagie isn't a debug library, we try again with | 5106 # Finally, in the case $imagie isn't a debug library, we try again with |
4969 # -D to at least get *exported* symbols. If we can't use --demangle, | 5107 # -D to at least get *exported* symbols. If we can't use --demangle, |
4970 # we use c++filt instead, if it exists on this system. | 5108 # we use c++filt instead, if it exists on this system. |
4971 my @nm_commands = ("$nm -n $flatten_flag $demangle_flag" . | 5109 my @nm_commands = (ShellEscape($nm, "-n", $flatten_flag, $demangle_flag, |
4972 " $image 2>$dev_null $cppfilt_flag", | 5110 $image) . " 2>$dev_null $cppfilt_flag", |
4973 "$nm -D -n $flatten_flag $demangle_flag" . | 5111 ShellEscape($nm, "-D", "-n", $flatten_flag, $demangle_flag, |
4974 " $image 2>$dev_null $cppfilt_flag", | 5112 $image) . " 2>$dev_null $cppfilt_flag", |
4975 # 6nm is for Go binaries | 5113 # 6nm is for Go binaries |
4976 » » "6nm $image 2>$dev_null | sort", | 5114 ShellEscape("6nm", "$image") . " 2>$dev_null | sort", |
4977 ); | 5115 ); |
4978 | 5116 |
4979 # If the executable is an MS Windows PDB-format executable, we'll | 5117 # If the executable is an MS Windows PDB-format executable, we'll |
4980 # have set up obj_tool_map("nm_pdb"). In this case, we actually | 5118 # have set up obj_tool_map("nm_pdb"). In this case, we actually |
4981 # want to use both unix nm and windows-specific nm_pdb, since | 5119 # want to use both unix nm and windows-specific nm_pdb, since |
4982 # PDB-format executables can apparently include dwarf .o files. | 5120 # PDB-format executables can apparently include dwarf .o files. |
4983 if (exists $obj_tool_map{"nm_pdb"}) { | 5121 if (exists $obj_tool_map{"nm_pdb"}) { |
4984 my $nm_pdb = $obj_tool_map{"nm_pdb"}; | 5122 push(@nm_commands, |
4985 push(@nm_commands, "$nm_pdb --demangle $image 2>$dev_null"); | 5123 ShellEscape($obj_tool_map{"nm_pdb"}, "--demangle", $image) |
| 5124 . " 2>$dev_null"); |
4986 } | 5125 } |
4987 | 5126 |
4988 foreach my $nm_command (@nm_commands) { | 5127 foreach my $nm_command (@nm_commands) { |
4989 my $symbol_table = GetProcedureBoundariesViaNm($nm_command, $regexp); | 5128 my $symbol_table = GetProcedureBoundariesViaNm($nm_command, $regexp); |
4990 return $symbol_table if (%{$symbol_table}); | 5129 return $symbol_table if (%{$symbol_table}); |
4991 } | 5130 } |
4992 my $symbol_table = {}; | 5131 my $symbol_table = {}; |
4993 return $symbol_table; | 5132 return $symbol_table; |
4994 } | 5133 } |
4995 | 5134 |
(...skipping 204 matching lines...) Expand 10 before | Expand all | Expand 10 after Loading... |
5200 $error_count += AddressAddUnitTest($unit_test_data_8, $unit_test_data_16); | 5339 $error_count += AddressAddUnitTest($unit_test_data_8, $unit_test_data_16); |
5201 $error_count += AddressSubUnitTest($unit_test_data_8, $unit_test_data_16); | 5340 $error_count += AddressSubUnitTest($unit_test_data_8, $unit_test_data_16); |
5202 $error_count += AddressIncUnitTest($unit_test_data_8, $unit_test_data_16); | 5341 $error_count += AddressIncUnitTest($unit_test_data_8, $unit_test_data_16); |
5203 if ($error_count > 0) { | 5342 if ($error_count > 0) { |
5204 print STDERR $error_count, " errors: FAILED\n"; | 5343 print STDERR $error_count, " errors: FAILED\n"; |
5205 } else { | 5344 } else { |
5206 print STDERR "PASS\n"; | 5345 print STDERR "PASS\n"; |
5207 } | 5346 } |
5208 exit ($error_count); | 5347 exit ($error_count); |
5209 } | 5348 } |
OLD | NEW |