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