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