utils/dprofpp.PL

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