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