This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
0c5794001406f200ea725f9a211f92a6d98dd369
[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   if( $opt_r ){
442     $$runtime = ($rrun_rtime - $overhead - $over_rtime * $total_marks/$over_tests/2)/$hz;
443   }
444   elsif( $opt_s ){
445     $$runtime = ($rrun_stime - $overhead - $over_stime * $total_marks/$over_tests/2)/$hz;
446   }
447   elsif( $opt_u ){
448     $$runtime = ($rrun_utime - $overhead - $over_utime * $total_marks/$over_tests/2)/$hz;
449   }
450   else{
451     $$runtime = ($rrun_ustime - $overhead - ($over_utime + $over_stime) * $total_marks/$over_tests/2)/$hz;
452   }
453   $$runtime = 0 unless $$runtime > 0;
454 }
455
456 sub exclusives_in_tree {
457   my( $deep_times ) = @_;
458   my $kids_time = 0;
459   my $kid;
460   # When summing, take into account non-rounded-up kids time.
461   for $kid (keys %{$deep_times->{kids}}) {
462     $kids_time += $deep_times->{kids}{$kid}{incl_time};
463   }
464   $kids_time = 0 unless $kids_time >= 0;
465   $deep_times->{excl_time} = $deep_times->{incl_time} - $kids_time;
466   $deep_times->{excl_time} = 0 unless $deep_times->{excl_time} >= 0;
467   for $kid (keys %{$deep_times->{kids}}) {
468     exclusives_in_tree($deep_times->{kids}{$kid});
469   }
470   $deep_times->{incl_time} = 0 unless $deep_times->{incl_time} >= 0;
471   $deep_times->{kids_time} = $kids_time;
472 }
473
474 sub kids_by_incl { $kids{$b}{incl_time} <=> $kids{$a}{excl_time} 
475                    or $a cmp $b }
476
477 sub display_tree {
478   my( $deep_times, $name, $level ) = @_;
479   exclusives_in_tree($deep_times);
480   
481   my $kid;
482   local *kids = $deep_times->{kids}; # %kids
483
484   my $time;
485   if (%kids) {
486     $time = sprintf '%.*fs = (%.*f + %.*f)', 
487       $time_precision, $deep_times->{incl_time}/$hz,
488         $time_precision, $deep_times->{excl_time}/$hz,
489           $time_precision, $deep_times->{kids_time}/$hz;
490   } else {
491     $time = sprintf '%.*f', $time_precision, $deep_times->{incl_time}/$hz;
492   }
493   print ' ' x (2*$level), "$name x $deep_times->{count}  \t${time}s\n"
494     if $deep_times->{count};
495
496   for $kid (sort kids_by_incl keys %kids) {
497     display_tree( $deep_times->{kids}{$kid}, $kid, $level + 1 );
498   }  
499 }
500
501 # Report the times in seconds.
502 sub display {
503         my( $runtime, $hz, $names, $calls, $times, $ctimes, $cnt, 
504             $idkeys, $deep_times ) = @_;
505         my( $x, $key, $s, $cs );
506         #format: $ncalls, $name, $secs, $percall, $pcnt
507
508         if ($opt_S) {
509           display_tree( $deep_times, 'toplevel', -1 )
510         } else {
511           for( $x = 0; $x < @$idkeys; ++$x ){
512             $key = $idkeys->[$x];
513             $ncalls = $calls->{$key};
514             $name = $names->{$key};
515             $s = $times->{$key}/$hz;
516             $secs = sprintf("%.3f", $s );
517             $cs = $ctimes->{$key}/$hz;
518             $csecs = sprintf("%.3f", $cs );
519             $percall = sprintf("%.4f", $s/$ncalls );
520             $cpercall = sprintf("%.4f", $cs/$ncalls );
521             $pcnt = sprintf("%.2f",
522                             $runtime? ((($opt_I ? $csecs : $secs) / $runtime) * 100.0): 0 );
523             write;
524             $pcnt = $secs = $ncalls = $percall = "";
525             write while( length $name );
526             last unless --$cnt;
527           }       
528         }
529 }
530
531 sub move_keys {
532   my ($source, $dest) = @_;
533   my $kid;
534   
535   for $kid (keys %$source) {
536     if (exists $dest->{$kid}) {
537       $dest->{count} += $source->{count};
538       $dest->{incl_time} += $source->{incl_time};
539       move_keys($source->{kids},$dest->{kids});
540     } else {
541       $dest->{$kid} = delete $source->{$kid};
542     }
543   }
544 }
545
546 sub add_to_tree {
547   my ($curdeep_times, $name, $t) = @_;
548   if ($name ne $curdeep_times->[-1]{name} and $opt_A) {
549     $name = $curdeep_times->[-1]{name};
550   }
551   die "Shorted?!" unless @$curdeep_times >= 2;
552   $curdeep_times->[-2]{kids}{$name} = { count => 0 , kids => {}, 
553                                         incl_time => 0,
554                                       } 
555     unless exists $curdeep_times->[-2]{kids}{$name};
556   my $entry = $curdeep_times->[-2]{kids}{$name};
557   # Now transfer to the new node (could not do earlier, since name can change)
558   $entry->{count}++;
559   $entry->{incl_time} += $t - $curdeep_times->[-1]{enter_stamp};
560   # Merge the kids?
561   move_keys($curdeep_times->[-1]->{kids},$entry->{kids});
562   pop @$curdeep_times;
563 }
564
565 sub parsestack {
566         my( $fh, $names, $calls, $times, $ctimes, $idkeys ) = @_;
567         my( $dir, $name );
568         my( $t, $syst, $realt, $usert );
569         my( $x, $z, $c, $id, $pack );
570         my @stack = ();
571         my @tstack = ();
572         my $tab = 3;
573         my $in = 0;
574
575         # remember last call depth and function name
576         my $l_in = $in;
577         my $l_name = '';
578         my $repcnt = 0;
579         my $repstr = '';
580         my $dprof_t = 0;
581         my $dprof_stamp;
582         my %cv_hash;
583         my $in_level = not defined $opt_g; # Level deep in report grouping
584         my $curdeep_times = [$deep_times];
585
586         my $over_per_call;
587         if   ( $opt_u ) {       $over_per_call = $over_utime            }
588         elsif( $opt_s ) {       $over_per_call = $over_stime            }
589         elsif( $opt_r ) {       $over_per_call = $over_rtime            }
590         else            {       $over_per_call = $over_utime + $over_stime }
591         $over_per_call /= 2*$over_tests; # distribute over entry and exit
592
593         while(<$fh>){
594                 next if /^#/;
595                 last if /^PART/;
596
597                 chop;
598                 if (/^&/) {
599                   ($dir, $id, $pack, $name) = split;
600                   if ($opt_R and ($name =~ /::(__ANON_|END)$/)) {
601                     $name .= "($id)";
602                   }
603                   $cv_hash{$id} = "$pack\::$name";
604                   next;
605                 }
606                 ($dir, $usert, $syst, $realt, $name) = split;
607
608                 my $ot = $t;
609                 if ( $dir eq '/' ) {
610                   $syst = $stack[-1][0];
611                   $usert = '&';
612                   $dir = '-';
613                   #warn("Inserted exit for $stack[-1][0].\n")
614                 }
615                 if (defined $realt) { # '+ times nam' '- times nam' or '@ incr'
616                   if   ( $opt_u )       {       $t = $usert             }
617                   elsif( $opt_s )       {       $t = $syst              }
618                   elsif( $opt_r )       {       $t = $realt             }
619                   else                  {       $t = $usert + $syst     }
620                   $t += $ot, next if $dir eq '@'; # Increments there
621                 } else {
622                   # "- id" or "- & name"
623                   $name = defined $syst ? $syst : $cv_hash{$usert};
624                 }
625
626                 next unless $in_level or $name eq $opt_g or $dir eq '*';
627                 if ( $dir eq '-' or $dir eq '*' ) {
628                         my $ename = $dir eq '*' ? $stack[-1][0]  : $name;
629                         $overhead += $over_per_call;
630                         if ($name eq "Devel::DProf::write") {
631                           $dprof_t += $t - $dprof_stamp;
632                           next;
633                         } elsif (defined $opt_g and $ename eq $opt_g) {
634                           $in_level--;
635                         }
636                         add_to_tree($curdeep_times, $ename,
637                                     $t - $dprof_t - $overhead) if $opt_S;
638                         exitstamp( \@stack, \@tstack, 
639                                    $t - $dprof_t - $overhead, 
640                                    $times, $ctimes, $ename, \$in, $tab, 
641                                    $curdeep_times );
642                 } 
643                 next unless $in_level or $name eq $opt_g;
644                 if( $dir eq '+' or $dir eq '*' ){
645                         if ($name eq "Devel::DProf::write") {
646                           $dprof_stamp = $t;
647                           next;
648                         } elsif (defined $opt_g and $name eq $opt_g) {
649                           $in_level++;
650                         }
651                         $overhead += $over_per_call;
652                         if( $opt_T ){
653                                 print ' ' x $in, "$name\n";
654                                 $in += $tab;
655                         }
656                         elsif( $opt_t ){
657                                 # suppress output on same function if the
658                                 # same calling level is called.
659                                 if ($l_in == $in and $l_name eq $name) {
660                                         $repcnt++;
661                                 } else {
662                                         $repstr = ' ('.++$repcnt.'x)'
663                                                  if $repcnt;
664                                         print ' ' x $l_in, "$l_name$repstr\n"
665                                                 if $l_name ne '';
666                                         $repstr = '';
667                                         $repcnt = 0;
668                                         $l_in = $in;
669                                         $l_name = $name;
670                                 }
671                                 $in += $tab;
672                         }
673                         if( ! defined $names->{$name} ){
674                                 $names->{$name} = $name;
675                                 $times->{$name} = 0;
676                                 $ctimes->{$name} = 0;
677                                 push( @$idkeys, $name );
678                         }
679                         $calls->{$name}++;
680                         push @$curdeep_times, { kids => {}, 
681                                                 name => $name, 
682                                                 enter_stamp => $t - $dprof_t - $overhead,
683                                               } if $opt_S;
684                         $x = [ $name, $t - $dprof_t - $overhead ];
685                         push( @stack, $x );
686
687                         # my children will put their time here
688                         push( @tstack, 0 );
689                 } elsif ($dir ne '-'){
690                     die "Bad profile: $_";
691                 }
692         }
693         if( $opt_t ){
694                 $repstr = ' ('.++$repcnt.'x)' if $repcnt;
695                 print ' ' x $l_in, "$l_name$repstr\n";
696         }
697
698         if( @stack ){
699                 if( ! $opt_F ){
700                         warn "Garbled profile is missing some exit time stamps:\n";
701                         foreach $x (@stack) {
702                                 print $x->[0],"\n";
703                         }
704                         die "Try rerunning dprofpp with -F.\n";
705                         # I don't want -F to be default behavior--yet
706                         #  9/18/95 dmr
707                 }
708                 else{
709                         warn( "Faking " . scalar( @stack ) . " exit timestamp(s).\n");
710                         foreach $x ( reverse @stack ){
711                                 $name = $x->[0];
712                                 exitstamp( \@stack, \@tstack, 
713                                            $t - $dprof_t - $overhead, $times, 
714                                            $ctimes, $name, \$in, $tab, 
715                                            $curdeep_times );
716                                 add_to_tree($curdeep_times, $name,
717                                             $t - $dprof_t - $overhead)
718                                   if $opt_S;
719                         }
720                 }
721         }
722         if (defined $opt_g) {
723           $runtime = $ctimes->{$opt_g}/$hz;
724           $runtime = 0 unless $runtime > 0;
725         }
726 }
727
728 sub exitstamp {
729         my($stack, $tstack, $t, $times, $ctimes, $name, $in, $tab, $deep) = @_;
730         my( $x, $c, $z );
731
732         $x = pop( @$stack );
733         if( ! defined $x ){
734                 die "Garbled profile, missing an enter time stamp";
735         }
736         if( $x->[0] ne $name ){
737           if ($x->[0] =~ /::AUTOLOAD$/) {
738             if ($opt_A) {
739               $name = $x->[0];
740             }
741           } elsif ( $opt_F ) {
742             warn( "Garbled profile, faking exit timestamp:\n\t$name => $x->[0].\n");
743             $name = $x->[0];
744           } else {
745             foreach $z (@stack, $x) {
746               print $z->[0],"\n";
747             }
748             die "Garbled profile, unexpected exit time stamp";
749           }
750         }
751         if( $opt_T || $opt_t ){
752                 $$in -= $tab;
753         }
754         # collect childtime
755         $c = pop( @$tstack );
756         # total time this func has been active
757         $z = $t - $x->[1];
758         $ctimes->{$name} += $z;
759         $times->{$name} += ($z > $c)? $z - $c: 0;
760         # pass my time to my parent
761         if( @$tstack ){
762                 $c = pop( @$tstack );
763                 push( @$tstack, $c + $z );
764         }
765 }
766
767
768 sub header {
769         my $fh = shift;
770         chop($_ = <$fh>);
771         if( ! /^#fOrTyTwO$/ ){
772                 die "Not a perl profile";
773         }
774         while(<$fh>){
775                 next if /^#/;
776                 last if /^PART/;
777                 eval;
778         }
779         $over_tests = 1 unless $over_tests;
780         $time_precision = length int ($hz - 1); # log ;-)
781 }
782
783
784 # Report avg time-per-function in seconds
785 sub percalc {
786         my( $calls, $times, $persecs, $idkeys ) = @_;
787         my( $x, $t, $n, $key );
788
789         for( $x = 0; $x < @$idkeys; ++$x ){
790                 $key = $idkeys->[$x];
791                 $n = $calls->{$key};
792                 $t = $times->{$key} / $hz;
793                 $persecs->{$key} = $t ? $t / $n : 0;
794         }
795 }
796
797
798 # Runs the given script with the given profiler and the given perl.
799 sub run_profiler {
800         my $script = shift;
801         my $profiler = shift;
802         my $startperl = shift;
803
804         system $startperl, "-d:$profiler", $script;
805         if( $? / 256 > 0 ){
806                 die "Failed: $startperl -d:$profiler $script: $!";
807         }
808 }
809
810
811 sub by_time { $times->{$b} <=> $times->{$a} }
812 sub by_ctime { $ctimes->{$b} <=> $ctimes->{$a} }
813 sub by_calls { $calls->{$b} <=> $calls->{$a} }
814 sub by_alpha { $names->{$a} cmp $names->{$b} }
815 sub by_avgcpu { $persecs->{$b} <=> $persecs->{$a} }
816
817
818 format CSTAT_top =
819 Total Elapsed Time = @>>>>>>> Seconds
820 (($rrun_rtime - $overhead - $over_rtime * $total_marks/$over_tests/2) / $hz)
821   @>>>>>>>>>> Time = @>>>>>>> Seconds
822 $whichtime, $runtime
823 @<<<<<<<< Times
824 $incl_excl
825 %Time ExclSec CumulS #Calls sec/call Csec/c  Name
826 .
827
828 format STAT =
829  ^>>>   ^>>>> ^>>>>> ^>>>>>   ^>>>>> ^>>>>>  ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
830 $pcnt, $secs, $csecs, $ncalls, $percall, $cpercall, $name
831 .
832
833 !NO!SUBS!
834
835 close OUT or die "Can't close $file: $!";
836 chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
837 exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';