utils/dprofpp.PL

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