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