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