utils/dprofpp.PL

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