utils/dprofpp.PL

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