utils/dprofpp.PL

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