utils/dprofpp.PL

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