bin/dprofpp

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