utils/dprofpp.PL

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