utils/dprofpp.PL

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