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