1 | @rem = '--*-Perl-*--
|
---|
2 | @echo off
|
---|
3 | if "%OS%" == "Windows_NT" goto WinNT
|
---|
4 | perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
|
---|
5 | goto endofperl
|
---|
6 | :WinNT
|
---|
7 | perl -x -S %0 %*
|
---|
8 | if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
|
---|
9 | if %errorlevel% == 9009 echo You do not have Perl in your PATH.
|
---|
10 | if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
|
---|
11 | goto endofperl
|
---|
12 | @rem ';
|
---|
13 | #!perl
|
---|
14 | #line 15
|
---|
15 | eval 'exec perl -S $0 "$@"'
|
---|
16 | if 0;
|
---|
17 |
|
---|
18 | require 5.003;
|
---|
19 |
|
---|
20 | my $VERSION = '20050603.00';
|
---|
21 | my $stty = undef;
|
---|
22 |
|
---|
23 | =head1 NAME
|
---|
24 |
|
---|
25 | dprofpp - display perl profile data
|
---|
26 |
|
---|
27 | =head1 SYNOPSIS
|
---|
28 |
|
---|
29 | dprofpp [B<-a>|B<-z>|B<-l>|B<-v>|B<-U>] [B<-d>] [B<-s>|B<-r>|B<-u>] [B<-q>] [B<-F>] [B<-I|-E>] [B<-O cnt>] [B<-A>] [B<-R>] [B<-S>] [B<-g subroutine>] [B<-G> <regexp> [B<-P>]] [B<-f> <regexp>] [profile]
|
---|
30 |
|
---|
31 | dprofpp B<-T> [B<-F>] [B<-g subroutine>] [profile]
|
---|
32 |
|
---|
33 | dprofpp B<-t> [B<-F>] [B<-g subroutine>] [profile]
|
---|
34 |
|
---|
35 | dprofpp B<-G> <regexp> [B<-P>] [profile]
|
---|
36 |
|
---|
37 | dprofpp B<-p script> [B<-Q>] [other opts]
|
---|
38 |
|
---|
39 | dprofpp B<-V> [profile]
|
---|
40 |
|
---|
41 | =head1 DESCRIPTION
|
---|
42 |
|
---|
43 | The I<dprofpp> command interprets profile data produced by a profiler, such
|
---|
44 | as the Devel::DProf profiler. Dprofpp will read the file F<tmon.out> and
|
---|
45 | display the 15 subroutines which are using the most time. By default
|
---|
46 | the times for each subroutine are given exclusive of the times of their
|
---|
47 | child subroutines.
|
---|
48 |
|
---|
49 | To profile a Perl script run the perl interpreter with the B<-d> switch. So
|
---|
50 | to profile script F<test.pl> with Devel::DProf use the following:
|
---|
51 |
|
---|
52 | $ perl5 -d:DProf test.pl
|
---|
53 |
|
---|
54 | Then run dprofpp to analyze the profile. The output of dprofpp depends
|
---|
55 | on the flags to the program and the version of Perl you're using.
|
---|
56 |
|
---|
57 | $ dprofpp -u
|
---|
58 | Total Elapsed Time = 1.67 Seconds
|
---|
59 | User Time = 0.61 Seconds
|
---|
60 | Exclusive Times
|
---|
61 | %Time Seconds #Calls sec/call Name
|
---|
62 | 52.4 0.320 2 0.1600 main::foo
|
---|
63 | 45.9 0.280 200 0.0014 main::bar
|
---|
64 | 0.00 0.000 1 0.0000 DynaLoader::import
|
---|
65 | 0.00 0.000 1 0.0000 main::baz
|
---|
66 |
|
---|
67 | The dprofpp tool can also run the profiler before analyzing the profile
|
---|
68 | data. The above two commands can be executed with one dprofpp command.
|
---|
69 |
|
---|
70 | $ dprofpp -u -p test.pl
|
---|
71 |
|
---|
72 | Consult L<Devel::DProf/"PROFILE FORMAT"> for a description of the raw profile.
|
---|
73 |
|
---|
74 | =head1 OUTPUT
|
---|
75 |
|
---|
76 | Columns are:
|
---|
77 |
|
---|
78 | =over 4
|
---|
79 |
|
---|
80 | =item %Time
|
---|
81 |
|
---|
82 | Percentage of time spent in this routine.
|
---|
83 |
|
---|
84 | =item #Calls
|
---|
85 |
|
---|
86 | Number of calls to this routine.
|
---|
87 |
|
---|
88 | =item sec/call
|
---|
89 |
|
---|
90 | Average number of seconds per call to this routine.
|
---|
91 |
|
---|
92 | =item Name
|
---|
93 |
|
---|
94 | Name of routine.
|
---|
95 |
|
---|
96 | =item CumulS
|
---|
97 |
|
---|
98 | Time (in seconds) spent in this routine and routines called from it.
|
---|
99 |
|
---|
100 | =item ExclSec
|
---|
101 |
|
---|
102 | Time (in seconds) spent in this routine (not including those called
|
---|
103 | from it).
|
---|
104 |
|
---|
105 | =item Csec/c
|
---|
106 |
|
---|
107 | Average time (in seconds) spent in each call of this routine
|
---|
108 | (including those called from it).
|
---|
109 |
|
---|
110 | =back
|
---|
111 |
|
---|
112 | =head1 OPTIONS
|
---|
113 |
|
---|
114 | =over 5
|
---|
115 |
|
---|
116 | =item B<-a>
|
---|
117 |
|
---|
118 | Sort alphabetically by subroutine names.
|
---|
119 |
|
---|
120 | =item B<-d>
|
---|
121 |
|
---|
122 | Reverse whatever sort is used
|
---|
123 |
|
---|
124 | =item B<-A>
|
---|
125 |
|
---|
126 | Count timing for autoloaded subroutine as timing for C<*::AUTOLOAD>.
|
---|
127 | Otherwise the time to autoload it is counted as time of the subroutine
|
---|
128 | itself (there is no way to separate autoload time from run time).
|
---|
129 |
|
---|
130 | This is going to be irrelevant with newer Perls. They will inform
|
---|
131 | C<Devel::DProf> I<when> the C<AUTOLOAD> switches to actual subroutine,
|
---|
132 | so a separate statistics for C<AUTOLOAD> will be collected no matter
|
---|
133 | whether this option is set.
|
---|
134 |
|
---|
135 | =item B<-R>
|
---|
136 |
|
---|
137 | Count anonymous subroutines defined in the same package separately.
|
---|
138 |
|
---|
139 | =item B<-E>
|
---|
140 |
|
---|
141 | (default) Display all subroutine times exclusive of child subroutine times.
|
---|
142 |
|
---|
143 | =item B<-F>
|
---|
144 |
|
---|
145 | Force the generation of fake exit timestamps if dprofpp reports that the
|
---|
146 | profile is garbled. This is only useful if dprofpp determines that the
|
---|
147 | profile is garbled due to missing exit timestamps. You're on your own if
|
---|
148 | you do this. Consult the BUGS section.
|
---|
149 |
|
---|
150 | =item B<-I>
|
---|
151 |
|
---|
152 | Display all subroutine times inclusive of child subroutine times.
|
---|
153 |
|
---|
154 | =item B<-l>
|
---|
155 |
|
---|
156 | Sort by number of calls to the subroutines. This may help identify
|
---|
157 | candidates for inlining.
|
---|
158 |
|
---|
159 | =item B<-O cnt>
|
---|
160 |
|
---|
161 | Show only I<cnt> subroutines. The default is 15.
|
---|
162 |
|
---|
163 | =item B<-p script>
|
---|
164 |
|
---|
165 | Tells dprofpp that it should profile the given script and then interpret its
|
---|
166 | profile data. See B<-Q>.
|
---|
167 |
|
---|
168 | =item B<-Q>
|
---|
169 |
|
---|
170 | Used with B<-p> to tell dprofpp to quit after profiling the script, without
|
---|
171 | interpreting the data.
|
---|
172 |
|
---|
173 | =item B<-q>
|
---|
174 |
|
---|
175 | Do not display column headers.
|
---|
176 |
|
---|
177 | =item B<-r>
|
---|
178 |
|
---|
179 | Display elapsed real times rather than user+system times.
|
---|
180 |
|
---|
181 | =item B<-s>
|
---|
182 |
|
---|
183 | Display system times rather than user+system times.
|
---|
184 |
|
---|
185 | =item B<-T>
|
---|
186 |
|
---|
187 | Display subroutine call tree to stdout. Subroutine statistics are
|
---|
188 | not displayed.
|
---|
189 |
|
---|
190 | =item B<-t>
|
---|
191 |
|
---|
192 | Display subroutine call tree to stdout. Subroutine statistics are not
|
---|
193 | displayed. When a function is called multiple consecutive times at the same
|
---|
194 | calling level then it is displayed once with a repeat count.
|
---|
195 |
|
---|
196 | =item B<-S>
|
---|
197 |
|
---|
198 | Display I<merged> subroutine call tree to stdout. Statistics are
|
---|
199 | displayed for each branch of the tree.
|
---|
200 |
|
---|
201 | When a function is called multiple (I<not necessarily consecutive>)
|
---|
202 | times in the same branch then all these calls go into one branch of
|
---|
203 | the next level. A repeat count is output together with combined
|
---|
204 | inclusive, exclusive and kids time.
|
---|
205 |
|
---|
206 | Branches are sorted with regard to inclusive time.
|
---|
207 |
|
---|
208 | =item B<-U>
|
---|
209 |
|
---|
210 | Do not sort. Display in the order found in the raw profile.
|
---|
211 |
|
---|
212 | =item B<-u>
|
---|
213 |
|
---|
214 | Display user times rather than user+system times.
|
---|
215 |
|
---|
216 | =item B<-V>
|
---|
217 |
|
---|
218 | Print dprofpp's version number and exit. If a raw profile is found then its
|
---|
219 | XS_VERSION variable will be displayed, too.
|
---|
220 |
|
---|
221 | =item B<-v>
|
---|
222 |
|
---|
223 | Sort by average time spent in subroutines during each call. This may help
|
---|
224 | identify candidates for inlining.
|
---|
225 |
|
---|
226 | =item B<-z>
|
---|
227 |
|
---|
228 | (default) Sort by amount of user+system time used. The first few lines
|
---|
229 | should show you which subroutines are using the most time.
|
---|
230 |
|
---|
231 | =item B<-g> C<subroutine>
|
---|
232 |
|
---|
233 | Ignore subroutines except C<subroutine> and whatever is called from it.
|
---|
234 |
|
---|
235 | =item B<-G> <regexp>
|
---|
236 |
|
---|
237 | Aggregate "Group" all calls matching the pattern together.
|
---|
238 | For example this can be used to group all calls of a set of packages
|
---|
239 |
|
---|
240 | -G "(package1::)|(package2::)|(package3::)"
|
---|
241 |
|
---|
242 | or to group subroutines by name:
|
---|
243 |
|
---|
244 | -G "getNum"
|
---|
245 |
|
---|
246 | =item B<-P>
|
---|
247 |
|
---|
248 | Used with -G to aggregate "Pull" together all calls that did not match -G.
|
---|
249 |
|
---|
250 | =item B<-f> <regexp>
|
---|
251 |
|
---|
252 | Filter all calls matching the pattern.
|
---|
253 |
|
---|
254 | =item B<-h>
|
---|
255 |
|
---|
256 | Display brief help and exit.
|
---|
257 |
|
---|
258 | =item B<-H>
|
---|
259 |
|
---|
260 | Display long help and exit.
|
---|
261 |
|
---|
262 | =back
|
---|
263 |
|
---|
264 | =head1 ENVIRONMENT
|
---|
265 |
|
---|
266 | The environment variable B<DPROFPP_OPTS> can be set to a string containing
|
---|
267 | options for dprofpp. You might use this if you prefer B<-I> over B<-E> or
|
---|
268 | if you want B<-F> on all the time.
|
---|
269 |
|
---|
270 | This was added fairly lazily, so there are some undesirable side effects.
|
---|
271 | Options on the commandline should override options in DPROFPP_OPTS--but
|
---|
272 | don't count on that in this version.
|
---|
273 |
|
---|
274 | =head1 BUGS
|
---|
275 |
|
---|
276 | Applications which call _exit() or exec() from within a subroutine
|
---|
277 | will leave an incomplete profile. See the B<-F> option.
|
---|
278 |
|
---|
279 | Any bugs in Devel::DProf, or any profiler generating the profile data, could
|
---|
280 | be visible here. See L<Devel::DProf/BUGS>.
|
---|
281 |
|
---|
282 | Mail bug reports and feature requests to the perl5-porters mailing list at
|
---|
283 | F<E<lt>[email protected]<gt>>. Bug reports should include the
|
---|
284 | output of the B<-V> option.
|
---|
285 |
|
---|
286 | =head1 FILES
|
---|
287 |
|
---|
288 | dprofpp - profile processor
|
---|
289 | tmon.out - raw profile
|
---|
290 |
|
---|
291 | =head1 SEE ALSO
|
---|
292 |
|
---|
293 | L<perl>, L<Devel::DProf>, times(2)
|
---|
294 |
|
---|
295 | =cut
|
---|
296 |
|
---|
297 | sub shortusage {
|
---|
298 | print <<'EOF';
|
---|
299 | dprofpp [options] [profile]
|
---|
300 |
|
---|
301 | -A Count autoloaded to *AUTOLOAD
|
---|
302 | -a Sort by alphabetic name of subroutines.
|
---|
303 | -d Reverse sort
|
---|
304 | -E Sub times are reported exclusive of child times. (default)
|
---|
305 | -f Filter all calls mathcing the pattern.
|
---|
306 | -G Group all calls matching the pattern together.
|
---|
307 | -g subr Count only those who are SUBR or called from SUBR
|
---|
308 | -H Display long manual page.
|
---|
309 | -h Display this short usage message.
|
---|
310 | -I Sub times are reported inclusive of child times.
|
---|
311 | -l Sort by number of calls to subroutines.
|
---|
312 | -O cnt Specifies maximum number of subroutines to display.
|
---|
313 | -P Used with -G to pull all other calls together.
|
---|
314 | -p script Specifies name of script to be profiled.
|
---|
315 | -Q Used with -p to indicate the dprofpp should quit
|
---|
316 | after profiling the script, without interpreting the data.
|
---|
317 | -q Do not print column headers.
|
---|
318 | -R Count anonyms separately even if from the same package
|
---|
319 | -r Use real elapsed time rather than user+system time.
|
---|
320 | -S Create statistics for all the depths
|
---|
321 | -s Use system time rather than user+system time.
|
---|
322 | -T Show call tree.
|
---|
323 | -t Show call tree, compressed.
|
---|
324 | -U Do not sort subroutines.
|
---|
325 | -u Use user time rather than user+system time.
|
---|
326 | -V Print dprofpp's version.
|
---|
327 | -v Sort by average amount of time spent in subroutines.
|
---|
328 | -z Sort by user+system time spent in subroutines. (default)
|
---|
329 | EOF
|
---|
330 | }
|
---|
331 |
|
---|
332 | use Getopt::Std 'getopts';
|
---|
333 | use Config '%Config';
|
---|
334 |
|
---|
335 | Setup: {
|
---|
336 | my $options = 'O:g:G:Pf:dlzaAvuTtqrRsUFEIp:QVShH';
|
---|
337 |
|
---|
338 | $Monfile = 'tmon.out';
|
---|
339 | if( exists $ENV{DPROFPP_OPTS} ){
|
---|
340 | my @tmpargv = @ARGV;
|
---|
341 | @ARGV = split( ' ', $ENV{DPROFPP_OPTS} );
|
---|
342 | getopts( $options );
|
---|
343 | if( @ARGV ){
|
---|
344 | # there was a filename.
|
---|
345 | $Monfile = shift;
|
---|
346 | }
|
---|
347 | @ARGV = @tmpargv;
|
---|
348 | }
|
---|
349 |
|
---|
350 | getopts( $options ) or die "Try 'dprofpp -h' for help.\n";
|
---|
351 | if( @ARGV ){
|
---|
352 | # there was a filename, it overrides any earlier name.
|
---|
353 | $Monfile = shift;
|
---|
354 | }
|
---|
355 |
|
---|
356 | if ( defined $opt_h ) {
|
---|
357 | shortusage();
|
---|
358 | exit;
|
---|
359 | }
|
---|
360 | if ( defined $opt_H ) {
|
---|
361 | require Pod::Usage;
|
---|
362 | Pod::Usage::pod2usage( {-verbose => 2, -input => $0 } );
|
---|
363 | exit;
|
---|
364 | }
|
---|
365 |
|
---|
366 | if( defined $opt_V ){
|
---|
367 | my $fh = 'main::fh';
|
---|
368 | print "$0 version: $VERSION\n";
|
---|
369 | open( $fh, "<$Monfile" ) && do {
|
---|
370 | local $XS_VERSION = 'early';
|
---|
371 | header($fh);
|
---|
372 | close( $fh );
|
---|
373 | print "XS_VERSION: $XS_VERSION\n";
|
---|
374 | };
|
---|
375 | exit(0);
|
---|
376 | }
|
---|
377 | $cnt = $opt_O || 15;
|
---|
378 | $sort = 'by_time';
|
---|
379 | $sort = 'by_ctime' if defined $opt_I;
|
---|
380 | $sort = 'by_calls' if defined $opt_l;
|
---|
381 | $sort = 'by_alpha' if defined $opt_a;
|
---|
382 | $sort = 'by_avgcpu' if defined $opt_v;
|
---|
383 |
|
---|
384 | if(defined $opt_d){
|
---|
385 | $sort = "r".$sort;
|
---|
386 | }
|
---|
387 | $incl_excl = 'Exclusive';
|
---|
388 | $incl_excl = 'Inclusive' if defined $opt_I;
|
---|
389 | $whichtime = 'User+System';
|
---|
390 | $whichtime = 'System' if defined $opt_s;
|
---|
391 | $whichtime = 'Real' if defined $opt_r;
|
---|
392 | $whichtime = 'User' if defined $opt_u;
|
---|
393 |
|
---|
394 | if( defined $opt_p ){
|
---|
395 | my $prof = 'DProf';
|
---|
396 | my $startperl = $Config{'startperl'};
|
---|
397 |
|
---|
398 | $startperl =~ s/^#!//; # remove shebang
|
---|
399 | run_profiler( $opt_p, $prof, $startperl );
|
---|
400 | $Monfile = 'tmon.out'; # because that's where it is
|
---|
401 | exit(0) if defined $opt_Q;
|
---|
402 | }
|
---|
403 | elsif( defined $opt_Q ){
|
---|
404 | die "-Q is meaningful only when used with -p\n";
|
---|
405 | }
|
---|
406 | }
|
---|
407 |
|
---|
408 | Main: {
|
---|
409 | my $monout = $Monfile;
|
---|
410 | my $fh = 'main::fh';
|
---|
411 | local $names = {};
|
---|
412 | local $times = {}; # times in hz
|
---|
413 | local $ctimes = {}; # Cumulative times in hz
|
---|
414 | local $calls = {};
|
---|
415 | local $persecs = {}; # times in seconds
|
---|
416 | local $idkeys = [];
|
---|
417 | local $runtime; # runtime in seconds
|
---|
418 | my @a = ();
|
---|
419 | my $a;
|
---|
420 | local $rrun_utime = 0; # user time in hz
|
---|
421 | local $rrun_stime = 0; # system time in hz
|
---|
422 | local $rrun_rtime = 0; # elapsed run time in hz
|
---|
423 | local $rrun_ustime = 0; # user+system time in hz
|
---|
424 | local $hz = 0;
|
---|
425 | local $deep_times = {count => 0 , kids => {}, incl_time => 0};
|
---|
426 | local $time_precision = 2;
|
---|
427 | local $overhead = 0;
|
---|
428 |
|
---|
429 | open( $fh, "<$monout" ) || die "Unable to open $monout\n";
|
---|
430 |
|
---|
431 | header($fh);
|
---|
432 |
|
---|
433 | $rrun_ustime = $rrun_utime + $rrun_stime;
|
---|
434 |
|
---|
435 | $~ = 'STAT';
|
---|
436 | if( ! $opt_q ){
|
---|
437 | $^ = 'CSTAT_top';
|
---|
438 | }
|
---|
439 |
|
---|
440 | parsestack( $fh, $names, $calls, $times, $ctimes, $idkeys );
|
---|
441 |
|
---|
442 | #filter calls
|
---|
443 | if( $opt_f ){
|
---|
444 | for(my $i = 0;$i < @$idkeys - 2;){
|
---|
445 | $key = $$idkeys[$i];
|
---|
446 | if($key =~ /$opt_f/){
|
---|
447 | splice(@$idkeys, $i, 1);
|
---|
448 | $runtime -= $$times{$key};
|
---|
449 | next;
|
---|
450 | }
|
---|
451 | $i++;
|
---|
452 | }
|
---|
453 | }
|
---|
454 |
|
---|
455 | if( $opt_G ){
|
---|
456 | group($names, $calls, $times, $ctimes, $idkeys );
|
---|
457 | }
|
---|
458 |
|
---|
459 | settime( \$runtime, $hz ) unless $opt_g;
|
---|
460 |
|
---|
461 | exit(0) if $opt_T || $opt_t;
|
---|
462 |
|
---|
463 | if( $opt_v ){
|
---|
464 | percalc( $calls, ($opt_I ? $ctimes : $times), $persecs, $idkeys );
|
---|
465 | }
|
---|
466 | if( ! $opt_U ){
|
---|
467 | @a = sort $sort @$idkeys;
|
---|
468 | $a = \@a;
|
---|
469 | }
|
---|
470 | else {
|
---|
471 | $a = $idkeys;
|
---|
472 | }
|
---|
473 | display( $runtime, $hz, $names, $calls, $times, $ctimes, $cnt, $a,
|
---|
474 | $deep_times);
|
---|
475 | }
|
---|
476 |
|
---|
477 | sub group{
|
---|
478 | my ($names, $calls, $times, $ctimes, $idkeys ) = @_;
|
---|
479 | print "Option G Grouping: [$opt_G]\n";
|
---|
480 | # create entries to store grouping
|
---|
481 | $$names{$opt_G} = $opt_G;
|
---|
482 | $$calls{$opt_G} = 0;
|
---|
483 | $$times{$opt_G} = 0;
|
---|
484 | $$ctimes{$opt_G} = 0;
|
---|
485 | $$idkeys[@$idkeys] = $opt_G;
|
---|
486 | # Sum calls for the grouping
|
---|
487 |
|
---|
488 | my $other = "other";
|
---|
489 | if($opt_P){
|
---|
490 | $$names{$other} = $other;
|
---|
491 | $$calls{$other} = 0;
|
---|
492 | $$times{$other} = 0;
|
---|
493 | $$ctimes{$other} = 0;
|
---|
494 | $$idkeys[@$idkeys] = $other;
|
---|
495 | }
|
---|
496 |
|
---|
497 | for(my $i = 0;$i < @$idkeys - 2;){
|
---|
498 | $key = $$idkeys[$i];
|
---|
499 | if($key =~ /$opt_G/){
|
---|
500 | $$calls{$opt_G} += $$calls{$key};
|
---|
501 | $$times{$opt_G} += $$times{$key};
|
---|
502 | $$ctimes{$opt_G} += $$ctimes{$key};
|
---|
503 | splice(@$idkeys, $i, 1);
|
---|
504 | next;
|
---|
505 | }else{
|
---|
506 | if($opt_P){
|
---|
507 | $$calls{$other} += $$calls{$key};
|
---|
508 | $$times{$other} += $$times{$key};
|
---|
509 | $$ctimes{$other} += $$ctimes{$key};
|
---|
510 | splice(@$idkeys, $i, 1);
|
---|
511 | next;
|
---|
512 | }
|
---|
513 | }
|
---|
514 | $i++;
|
---|
515 | }
|
---|
516 | print "Grouping [$opt_G] Calls: [$$calls{$opt_G}]\n".
|
---|
517 | "Grouping [$opt_G] Times: [$$times{$opt_G}]\n".
|
---|
518 | "Grouping [$opt_G] IncTimes: [$$ctimes{$opt_G}]\n";
|
---|
519 | }
|
---|
520 |
|
---|
521 | # Sets $runtime to user, system, real, or user+system time. The
|
---|
522 | # result is given in seconds.
|
---|
523 | #
|
---|
524 | sub settime {
|
---|
525 | my( $runtime, $hz ) = @_;
|
---|
526 |
|
---|
527 | $hz ||= 1;
|
---|
528 |
|
---|
529 | if( $opt_r ){
|
---|
530 | $$runtime = ($rrun_rtime - $overhead)/$hz;
|
---|
531 | }
|
---|
532 | elsif( $opt_s ){
|
---|
533 | $$runtime = ($rrun_stime - $overhead)/$hz;
|
---|
534 | }
|
---|
535 | elsif( $opt_u ){
|
---|
536 | $$runtime = ($rrun_utime - $overhead)/$hz;
|
---|
537 | }
|
---|
538 | else{
|
---|
539 | $$runtime = ($rrun_ustime - $overhead)/$hz;
|
---|
540 | }
|
---|
541 | $$runtime = 0 unless $$runtime > 0;
|
---|
542 | }
|
---|
543 |
|
---|
544 | sub exclusives_in_tree {
|
---|
545 | my( $deep_times ) = @_;
|
---|
546 | my $kids_time = 0;
|
---|
547 | my $kid;
|
---|
548 | # When summing, take into account non-rounded-up kids time.
|
---|
549 | for $kid (keys %{$deep_times->{kids}}) {
|
---|
550 | $kids_time += $deep_times->{kids}{$kid}{incl_time};
|
---|
551 | }
|
---|
552 | $kids_time = 0 unless $kids_time >= 0;
|
---|
553 | $deep_times->{excl_time} = $deep_times->{incl_time} - $kids_time;
|
---|
554 | $deep_times->{excl_time} = 0 unless $deep_times->{excl_time} >= 0;
|
---|
555 | for $kid (keys %{$deep_times->{kids}}) {
|
---|
556 | exclusives_in_tree($deep_times->{kids}{$kid});
|
---|
557 | }
|
---|
558 | $deep_times->{incl_time} = 0 unless $deep_times->{incl_time} >= 0;
|
---|
559 | $deep_times->{kids_time} = $kids_time;
|
---|
560 | }
|
---|
561 |
|
---|
562 | sub kids_by_incl { $kids{$b}{incl_time} <=> $kids{$a}{excl_time}
|
---|
563 | or $a cmp $b }
|
---|
564 |
|
---|
565 | sub display_tree {
|
---|
566 | my( $deep_times, $name, $level ) = @_;
|
---|
567 | exclusives_in_tree($deep_times);
|
---|
568 |
|
---|
569 | my $kid;
|
---|
570 |
|
---|
571 | my $time;
|
---|
572 | if (%{$deep_times->{kids}}) {
|
---|
573 | $time = sprintf '%.*fs = (%.*f + %.*f)',
|
---|
574 | $time_precision, $deep_times->{incl_time}/$hz,
|
---|
575 | $time_precision, $deep_times->{excl_time}/$hz,
|
---|
576 | $time_precision, $deep_times->{kids_time}/$hz;
|
---|
577 | } else {
|
---|
578 | $time = sprintf '%.*f', $time_precision, $deep_times->{incl_time}/$hz;
|
---|
579 | }
|
---|
580 | print ' ' x (2*$level), "$name x $deep_times->{count} \t${time}s\n"
|
---|
581 | if $deep_times->{count};
|
---|
582 |
|
---|
583 | for $kid (sort kids_by_incl %{$deep_times->{kids}}) {
|
---|
584 | display_tree( $deep_times->{kids}{$kid}, $kid, $level + 1 );
|
---|
585 | }
|
---|
586 | }
|
---|
587 |
|
---|
588 | # Report the times in seconds.
|
---|
589 | sub display {
|
---|
590 | my( $runtime, $hz, $names, $calls, $times, $ctimes, $cnt,
|
---|
591 | $idkeys, $deep_times ) = @_;
|
---|
592 | my( $x, $key, $s, $cs );
|
---|
593 | #format: $ncalls, $name, $secs, $percall, $pcnt
|
---|
594 |
|
---|
595 | if ($opt_S) {
|
---|
596 | display_tree( $deep_times, 'toplevel', -1 )
|
---|
597 | } else {
|
---|
598 | for( $x = 0; $x < @$idkeys; ++$x ){
|
---|
599 | $key = $idkeys->[$x];
|
---|
600 | $ncalls = $calls->{$key};
|
---|
601 | $name = $names->{$key};
|
---|
602 | $s = $times->{$key}/$hz;
|
---|
603 | $secs = sprintf("%.3f", $s );
|
---|
604 | $cs = $ctimes->{$key}/$hz;
|
---|
605 | $csecs = sprintf("%.3f", $cs );
|
---|
606 | $percall = sprintf("%.4f", $s/$ncalls );
|
---|
607 | $cpercall = sprintf("%.4f", $cs/$ncalls );
|
---|
608 | $pcnt = sprintf("%.2f",
|
---|
609 | $runtime? ((($opt_I ? $csecs : $secs) / $runtime) * 100.0): 0 );
|
---|
610 | write;
|
---|
611 | $pcnt = $secs = $ncalls = $percall = "";
|
---|
612 | write while( length $name );
|
---|
613 | last unless --$cnt;
|
---|
614 | }
|
---|
615 | }
|
---|
616 | }
|
---|
617 |
|
---|
618 | sub move_keys {
|
---|
619 | my ($source, $dest) = @_;
|
---|
620 |
|
---|
621 | for my $kid_name (keys %$source) {
|
---|
622 | my $source_kid = delete $source->{$kid_name};
|
---|
623 |
|
---|
624 | if (my $dest_kid = $dest->{$kid_name}) {
|
---|
625 | $dest_kid->{count} += $source_kid->{count};
|
---|
626 | $dest_kid->{incl_time} += $source_kid->{incl_time};
|
---|
627 | move_keys($source_kid->{kids},$dest_kid->{kids});
|
---|
628 | } else {
|
---|
629 | $dest->{$kid_name} = $source_kid;
|
---|
630 | }
|
---|
631 | }
|
---|
632 | }
|
---|
633 |
|
---|
634 | sub add_to_tree {
|
---|
635 | my ($curdeep_times, $name, $t) = @_;
|
---|
636 | if ($name ne $curdeep_times->[-1]{name} and $opt_A) {
|
---|
637 | $name = $curdeep_times->[-1]{name};
|
---|
638 | }
|
---|
639 | die "Shorted?!" unless @$curdeep_times >= 2;
|
---|
640 | my $entry = $curdeep_times->[-2]{kids}{$name} ||= {
|
---|
641 | count => 0,
|
---|
642 | kids => {},
|
---|
643 | incl_time => 0,
|
---|
644 | };
|
---|
645 | # Now transfer to the new node (could not do earlier, since name can change)
|
---|
646 | $entry->{count}++;
|
---|
647 | $entry->{incl_time} += $t - $curdeep_times->[-1]{enter_stamp};
|
---|
648 | # Merge the kids?
|
---|
649 | move_keys($curdeep_times->[-1]->{kids},$entry->{kids});
|
---|
650 | pop @$curdeep_times;
|
---|
651 | }
|
---|
652 |
|
---|
653 |
|
---|
654 | sub parsestack {
|
---|
655 | my( $fh, $names, $calls, $times, $ctimes, $idkeys ) = @_;
|
---|
656 | my( $dir, $name );
|
---|
657 | my( $t, $syst, $realt, $usert );
|
---|
658 | my( $x, $z, $c, $id, $pack );
|
---|
659 | my @stack = ();
|
---|
660 | my @tstack = ();
|
---|
661 | my %outer;
|
---|
662 | my $tab = 3;
|
---|
663 | my $in = 0;
|
---|
664 |
|
---|
665 | # remember last call depth and function name
|
---|
666 | my $l_in = $in;
|
---|
667 | my $l_name = '';
|
---|
668 | my $repcnt = 0;
|
---|
669 | my $repstr = '';
|
---|
670 | my $dprof_stamp;
|
---|
671 | my %cv_hash;
|
---|
672 | my $in_level = not defined $opt_g; # Level deep in report grouping
|
---|
673 | my $curdeep_times = [$deep_times];
|
---|
674 |
|
---|
675 | my $over_per_call;
|
---|
676 | if ( $opt_u ) { $over_per_call = $over_utime }
|
---|
677 | elsif( $opt_s ) { $over_per_call = $over_stime }
|
---|
678 | elsif( $opt_r ) { $over_per_call = $over_rtime }
|
---|
679 | else { $over_per_call = $over_utime + $over_stime }
|
---|
680 | $over_per_call /= 2*$over_tests; # distribute over entry and exit
|
---|
681 |
|
---|
682 | while(<$fh>){
|
---|
683 | next if /^#/;
|
---|
684 | last if /^PART/;
|
---|
685 |
|
---|
686 | chop;
|
---|
687 | if (/^&/) {
|
---|
688 | ($dir, $id, $pack, $name) = split;
|
---|
689 | if ($opt_R and ($name =~ /(?:::)?(__ANON__|END)$/)) {
|
---|
690 | $name .= "($id)";
|
---|
691 | }
|
---|
692 | $cv_hash{$id} = "$pack\::$name";
|
---|
693 | next;
|
---|
694 | }
|
---|
695 | ($dir, $usert, $syst, $realt, $name) = split;
|
---|
696 |
|
---|
697 | my $ot = $t;
|
---|
698 | if ( $dir eq '/' ) {
|
---|
699 | $syst = $stack[-1][0] if scalar @stack;
|
---|
700 | $usert = '&';
|
---|
701 | $dir = '-';
|
---|
702 | #warn("Inserted exit for $stack[-1][0].\n")
|
---|
703 | }
|
---|
704 | if (defined $realt) { # '+ times nam' '- times nam' or '@ incr'
|
---|
705 | if ( $opt_u ) { $t = $usert }
|
---|
706 | elsif( $opt_s ) { $t = $syst }
|
---|
707 | elsif( $opt_r ) { $t = $realt }
|
---|
708 | else { $t = $usert + $syst }
|
---|
709 | $t += $ot, next if $dir eq '@'; # Increments there
|
---|
710 | } else {
|
---|
711 | # "- id" or "- & name"
|
---|
712 | $name = defined $syst ? $syst : $cv_hash{$usert};
|
---|
713 | }
|
---|
714 |
|
---|
715 | next unless $in_level or $name eq $opt_g;
|
---|
716 | if ( $dir eq '-' or $dir eq '*' ) {
|
---|
717 | my $ename = $dir eq '*' ? $stack[-1][0] : $name;
|
---|
718 | $overhead += $over_per_call;
|
---|
719 | if ($name eq "Devel::DProf::write") {
|
---|
720 | $overhead += $t - $dprof_stamp;
|
---|
721 | next;
|
---|
722 | } elsif (defined $opt_g and $ename eq $opt_g) {
|
---|
723 | $in_level--;
|
---|
724 | }
|
---|
725 | add_to_tree($curdeep_times, $ename,
|
---|
726 | $t - $overhead) if $opt_S;
|
---|
727 | exitstamp( \@stack, \@tstack,
|
---|
728 | $t - $overhead,
|
---|
729 | $times, $ctimes, $name, \$in, $tab,
|
---|
730 | $curdeep_times, \%outer );
|
---|
731 | }
|
---|
732 | next unless $in_level or $name eq $opt_g;
|
---|
733 | if( $dir eq '+' or $dir eq '*' ){
|
---|
734 | if ($name eq "Devel::DProf::write") {
|
---|
735 | $dprof_stamp = $t;
|
---|
736 | next;
|
---|
737 | } elsif (defined $opt_g and $name eq $opt_g) {
|
---|
738 | $in_level++;
|
---|
739 | }
|
---|
740 | $overhead += $over_per_call;
|
---|
741 | if( $opt_T ){
|
---|
742 | print ' ' x $in, "$name\n";
|
---|
743 | $in += $tab;
|
---|
744 | }
|
---|
745 | elsif( $opt_t ){
|
---|
746 | # suppress output on same function if the
|
---|
747 | # same calling level is called.
|
---|
748 | if ($l_in == $in and $l_name eq $name) {
|
---|
749 | $repcnt++;
|
---|
750 | } else {
|
---|
751 | $repstr = ' ('.++$repcnt.'x)'
|
---|
752 | if $repcnt;
|
---|
753 | print ' ' x $l_in, "$l_name$repstr\n"
|
---|
754 | if $l_name ne '';
|
---|
755 | $repstr = '';
|
---|
756 | $repcnt = 0;
|
---|
757 | $l_in = $in;
|
---|
758 | $l_name = $name;
|
---|
759 | }
|
---|
760 | $in += $tab;
|
---|
761 | }
|
---|
762 | if( ! defined $names->{$name} ){
|
---|
763 | $names->{$name} = $name;
|
---|
764 | $times->{$name} = 0;
|
---|
765 | $ctimes->{$name} = 0;
|
---|
766 | push( @$idkeys, $name );
|
---|
767 | }
|
---|
768 | $calls->{$name}++;
|
---|
769 | $outer{$name}++;
|
---|
770 | push @$curdeep_times, { kids => {},
|
---|
771 | name => $name,
|
---|
772 | enter_stamp => $t - $overhead,
|
---|
773 | } if $opt_S;
|
---|
774 | $x = [ $name, $t - $overhead ];
|
---|
775 | push( @stack, $x );
|
---|
776 |
|
---|
777 | # my children will put their time here
|
---|
778 | push( @tstack, 0 );
|
---|
779 | } elsif ($dir ne '-'){
|
---|
780 | die "Bad profile: $_";
|
---|
781 | }
|
---|
782 | }
|
---|
783 | if( $opt_t ){
|
---|
784 | $repstr = ' ('.++$repcnt.'x)' if $repcnt;
|
---|
785 | print ' ' x $l_in, "$l_name$repstr\n";
|
---|
786 | }
|
---|
787 |
|
---|
788 | while (my ($key, $count) = each %outer) {
|
---|
789 | next unless $count;
|
---|
790 | warn "$key has $count unstacked calls in outer\n";
|
---|
791 | }
|
---|
792 |
|
---|
793 | if( @stack ){
|
---|
794 | if( ! $opt_F ){
|
---|
795 | warn "Garbled profile is missing some exit time stamps:\n";
|
---|
796 | foreach $x (@stack) {
|
---|
797 | print $x->[0],"\n";
|
---|
798 | }
|
---|
799 | die "Try rerunning dprofpp with -F.\n";
|
---|
800 | # I don't want -F to be default behavior--yet
|
---|
801 | # 9/18/95 dmr
|
---|
802 | }
|
---|
803 | else{
|
---|
804 | warn( "Faking " . scalar( @stack ) . " exit timestamp(s).\n");
|
---|
805 | foreach $x ( reverse @stack ){
|
---|
806 | $name = $x->[0];
|
---|
807 | exitstamp( \@stack, \@tstack,
|
---|
808 | $t - $overhead, $times,
|
---|
809 | $ctimes, $name, \$in, $tab,
|
---|
810 | $curdeep_times, \%outer );
|
---|
811 | add_to_tree($curdeep_times, $name,
|
---|
812 | $t - $overhead)
|
---|
813 | if $opt_S;
|
---|
814 | }
|
---|
815 | }
|
---|
816 | }
|
---|
817 | if (defined $opt_g) {
|
---|
818 | $runtime = $ctimes->{$opt_g}/$hz;
|
---|
819 | $runtime = 0 unless $runtime > 0;
|
---|
820 | }
|
---|
821 | }
|
---|
822 |
|
---|
823 | sub exitstamp {
|
---|
824 | my($stack, $tstack, $t, $times, $ctimes, $name, $in, $tab, $deep, $outer) = @_;
|
---|
825 | my( $x, $c, $z );
|
---|
826 |
|
---|
827 | $x = pop( @$stack );
|
---|
828 | if( ! defined $x ){
|
---|
829 | die "Garbled profile, missing an enter time stamp";
|
---|
830 | }
|
---|
831 | if( $x->[0] ne $name and $opt_G and ($name =~ /$opt_G/)){
|
---|
832 | if ($x->[0] =~ /(?:::)?AUTOLOAD$/) {
|
---|
833 | if ($opt_A) {
|
---|
834 | $name = $x->[0];
|
---|
835 | }
|
---|
836 | } elsif ( $opt_F ) {
|
---|
837 | warn( "Garbled profile, faking exit timestamp:\n\t$name => $x->[0].\n");
|
---|
838 | $name = $x->[0];
|
---|
839 | } else {
|
---|
840 | foreach $z (@stack, $x) {
|
---|
841 | print $z->[0],"\n";
|
---|
842 | }
|
---|
843 | die "Garbled profile, unexpected exit time stamp";
|
---|
844 | }
|
---|
845 | }
|
---|
846 | if( $opt_T || $opt_t ){
|
---|
847 | $$in -= $tab;
|
---|
848 | }
|
---|
849 | # collect childtime
|
---|
850 | $c = pop( @$tstack );
|
---|
851 | # total time this func has been active
|
---|
852 | $z = $t - $x->[1];
|
---|
853 | $ctimes->{$name} += $z
|
---|
854 | unless --$outer->{$name};
|
---|
855 | $times->{$name} += $z - $c;
|
---|
856 | # pass my time to my parent
|
---|
857 | if( @$tstack ){
|
---|
858 | $c = pop( @$tstack );
|
---|
859 | push( @$tstack, $c + $z );
|
---|
860 | }
|
---|
861 | }
|
---|
862 |
|
---|
863 |
|
---|
864 | sub header {
|
---|
865 | my $fh = shift;
|
---|
866 | chop($_ = <$fh>);
|
---|
867 | if( ! /^#fOrTyTwO$/ ){
|
---|
868 | die "Not a perl profile";
|
---|
869 | }
|
---|
870 | while(<$fh>){
|
---|
871 | next if /^#/;
|
---|
872 | last if /^PART/;
|
---|
873 | eval;
|
---|
874 | }
|
---|
875 | $over_tests = 1 unless $over_tests;
|
---|
876 | $time_precision = length int ($hz - 1); # log ;-)
|
---|
877 | }
|
---|
878 |
|
---|
879 |
|
---|
880 | # Report avg time-per-function in seconds
|
---|
881 | sub percalc {
|
---|
882 | my( $calls, $times, $persecs, $idkeys ) = @_;
|
---|
883 | my( $x, $t, $n, $key );
|
---|
884 |
|
---|
885 | for( $x = 0; $x < @$idkeys; ++$x ){
|
---|
886 | $key = $idkeys->[$x];
|
---|
887 | $n = $calls->{$key};
|
---|
888 | $t = $times->{$key} / $hz;
|
---|
889 | $persecs->{$key} = $t ? $t / $n : 0;
|
---|
890 | }
|
---|
891 | }
|
---|
892 |
|
---|
893 |
|
---|
894 | # Runs the given script with the given profiler and the given perl.
|
---|
895 | sub run_profiler {
|
---|
896 | my $script = shift;
|
---|
897 | my $profiler = shift;
|
---|
898 | my $startperl = shift;
|
---|
899 | my @script_parts = split /\s+/, $script;
|
---|
900 |
|
---|
901 | system $startperl, "-d:$profiler", @script_parts;
|
---|
902 | if( $? / 256 > 0 ){
|
---|
903 | my $cmd = join ' ', @script_parts;
|
---|
904 | die "Failed: $startperl -d:$profiler $cmd: $!";
|
---|
905 | }
|
---|
906 | }
|
---|
907 |
|
---|
908 |
|
---|
909 | sub by_time { $times->{$b} <=> $times->{$a} }
|
---|
910 | sub by_ctime { $ctimes->{$b} <=> $ctimes->{$a} }
|
---|
911 | sub by_calls { $calls->{$b} <=> $calls->{$a} }
|
---|
912 | sub by_alpha { $names->{$a} cmp $names->{$b} }
|
---|
913 | sub by_avgcpu { $persecs->{$b} <=> $persecs->{$a} }
|
---|
914 | # Reversed
|
---|
915 | sub rby_time { $times->{$a} <=> $times->{$b} }
|
---|
916 | sub rby_ctime { $ctimes->{$a} <=> $ctimes->{$b} }
|
---|
917 | sub rby_calls { $calls->{$a} <=> $calls->{$b} }
|
---|
918 | sub rby_alpha { $names->{$b} cmp $names->{$a} }
|
---|
919 | sub rby_avgcpu { $persecs->{$a} <=> $persecs->{$b} }
|
---|
920 |
|
---|
921 |
|
---|
922 | format CSTAT_top =
|
---|
923 | Total Elapsed Time = @>>>>>>> Seconds
|
---|
924 | (($rrun_rtime - $overhead) / $hz)
|
---|
925 | @>>>>>>>>>> Time = @>>>>>>> Seconds
|
---|
926 | $whichtime, $runtime
|
---|
927 | @<<<<<<<< Times
|
---|
928 | $incl_excl
|
---|
929 | %Time ExclSec CumulS #Calls sec/call Csec/c Name
|
---|
930 | .
|
---|
931 |
|
---|
932 | BEGIN {
|
---|
933 | my $fmt = ' ^>>> ^>>>> ^>>>>> ^>>>>> ^>>>>> ^>>>>> ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<';
|
---|
934 | if (-t STDOUT and defined $stty and my ($cols) = `$stty -a` =~ /\bcolumns\s+(\d+)/)
|
---|
935 | {
|
---|
936 | $fmt .= '<' x ($cols - length $fmt) if $cols > 80;
|
---|
937 | }
|
---|
938 |
|
---|
939 | eval "format STAT = \n$fmt" . '
|
---|
940 | $pcnt, $secs, $csecs, $ncalls, $percall, $cpercall, $name
|
---|
941 | .';
|
---|
942 | }
|
---|
943 |
|
---|
944 | __END__
|
---|
945 | :endofperl
|
---|