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