1#!/usr/local/bin/perl 2 3use Config; 4use File::Basename qw(&basename &dirname); 5use 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. 16chdir(dirname($0)); 17($file = basename($0)) =~ s/\.PL$//i; 18$file .= '.COM' if ($^O eq 'VMS'); 19 20my $dprof_pm = File::Spec->catfile(File::Spec->updir, 'ext', 'Devel', 'DProf', 'DProf.pm'); 21my $VERSION = 0; 22open( PM, "<$dprof_pm" ) || die "Can't open $dprof_pm: $!"; 23while(<PM>){ 24 if( /^\$Devel::DProf::VERSION\s*=\s*'([\d._]+)'/ ){ 25 $VERSION = $1; 26 last; 27 } 28} 29close PM; 30if( $VERSION == 0 ){ 31 die "Did not find VERSION in $dprof_pm"; 32} 33my $stty = 'undef'; 34foreach my $s (qw(/bin/stty /usr/bin/stty)) { 35 if (-x $s) { 36 $stty = qq["$s"]; 37 last; 38 } 39} 40open OUT,">$file" or die "Can't create $file: $!"; 41 42print "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 47print OUT <<"!GROK!THIS!"; 48$Config{'startperl'} 49 eval 'exec perl -S \$0 "\$@"' 50 if 0; 51 52require 5.003; 53 54my \$VERSION = '$VERSION'; 55my \$stty = $stty; 56 57!GROK!THIS! 58 59# In the following, perl variables are not expanded during extraction. 60 61print OUT <<'!NO!SUBS!'; 62=head1 NAME 63 64dprofpp - display perl profile data 65 66=head1 SYNOPSIS 67 68dprofpp [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 70dprofpp B<-T> [B<-F>] [B<-g subroutine>] [profile] 71 72dprofpp B<-t> [B<-F>] [B<-g subroutine>] [profile] 73 74dprofpp B<-G> <regexp> [B<-P>] [profile] 75 76dprofpp B<-p script> [B<-Q>] [other opts] 77 78dprofpp B<-V> [profile] 79 80=head1 DESCRIPTION 81 82The I<dprofpp> command interprets profile data produced by a profiler, such 83as the Devel::DProf profiler. Dprofpp will read the file F<tmon.out> and 84will display the 15 subroutines which are using the most time. By default 85the times for each subroutine are given exclusive of the times of their 86child subroutines. 87 88To profile a Perl script run the perl interpreter with the B<-d> switch. So 89to profile script F<test.pl> with Devel::DProf the following command should 90be used. 91 92 $ perl5 -d:DProf test.pl 93 94Then run dprofpp to analyze the profile. The output of dprofpp depends 95on 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 107The dprofpp tool can also run the profiler before analyzing the profile 108data. The above two commands can be executed with one dprofpp command. 109 110 $ dprofpp -u -p test.pl 111 112Consult L<Devel::DProf/"PROFILE FORMAT"> for a description of the raw profile. 113 114=head1 OUTPUT 115 116Columns are: 117 118=over 4 119 120=item %Time 121 122Percentage of time spent in this routine. 123 124=item #Calls 125 126Number of calls to this routine. 127 128=item sec/call 129 130Average number of seconds per call to this routine. 131 132=item Name 133 134Name of routine. 135 136=item CumulS 137 138Time (in seconds) spent in this routine and routines called from it. 139 140=item ExclSec 141 142Time (in seconds) spent in this routine (not including those called 143from it). 144 145=item Csec/c 146 147Average 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 158Sort alphabetically by subroutine names. 159 160=item B<-d> 161 162Reverse whatever sort is used 163 164=item B<-A> 165 166Count timing for autoloaded subroutine as timing for C<*::AUTOLOAD>. 167Otherwise the time to autoload it is counted as time of the subroutine 168itself (there is no way to separate autoload time from run time). 169 170This is going to be irrelevant with newer Perls. They will inform 171C<Devel::DProf> I<when> the C<AUTOLOAD> switches to actual subroutine, 172so a separate statistics for C<AUTOLOAD> will be collected no matter 173whether this option is set. 174 175=item B<-R> 176 177Count 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 185Force the generation of fake exit timestamps if dprofpp reports that the 186profile is garbled. This is only useful if dprofpp determines that the 187profile is garbled due to missing exit timestamps. You're on your own if 188you do this. Consult the BUGS section. 189 190=item B<-I> 191 192Display all subroutine times inclusive of child subroutine times. 193 194=item B<-l> 195 196Sort by number of calls to the subroutines. This may help identify 197candidates for inlining. 198 199=item B<-O cnt> 200 201Show only I<cnt> subroutines. The default is 15. 202 203=item B<-p script> 204 205Tells dprofpp that it should profile the given script and then interpret its 206profile data. See B<-Q>. 207 208=item B<-Q> 209 210Used with B<-p> to tell dprofpp to quit after profiling the script, without 211interpreting the data. 212 213=item B<-q> 214 215Do not display column headers. 216 217=item B<-r> 218 219Display elapsed real times rather than user+system times. 220 221=item B<-s> 222 223Display system times rather than user+system times. 224 225=item B<-T> 226 227Display subroutine call tree to stdout. Subroutine statistics are 228not displayed. 229 230=item B<-t> 231 232Display subroutine call tree to stdout. Subroutine statistics are not 233displayed. When a function is called multiple consecutive times at the same 234calling level then it is displayed once with a repeat count. 235 236=item B<-S> 237 238Display I<merged> subroutine call tree to stdout. Statistics are 239displayed for each branch of the tree. 240 241When a function is called multiple (I<not necessarily consecutive>) 242times in the same branch then all these calls go into one branch of 243the next level. A repeat count is output together with combined 244inclusive, exclusive and kids time. 245 246Branches are sorted w.r.t. inclusive time. 247 248=item B<-U> 249 250Do not sort. Display in the order found in the raw profile. 251 252=item B<-u> 253 254Display user times rather than user+system times. 255 256=item B<-V> 257 258Print dprofpp's version number and exit. If a raw profile is found then its 259XS_VERSION variable will be displayed, too. 260 261=item B<-v> 262 263Sort by average time spent in subroutines during each call. This may help 264identify candidates for inlining. 265 266=item B<-z> 267 268(default) Sort by amount of user+system time used. The first few lines 269should show you which subroutines are using the most time. 270 271=item B<-g> C<subroutine> 272 273Ignore subroutines except C<subroutine> and whatever is called from it. 274 275=item B<-G> <regexp> 276 277Aggregate "Group" all calls matching the pattern together. 278For example this can be used to group all calls of a set of packages 279 280 -G "(package1::)|(package2::)|(package3::)" 281 282or to group subroutines by name: 283 284 -G "getNum" 285 286=item B<-P> 287 288Used with -G to aggregate "Pull" together all calls that did not match -G. 289 290=item B<-f> <regexp> 291 292Filter all calls matching the pattern. 293 294=back 295 296=head1 ENVIRONMENT 297 298The environment variable B<DPROFPP_OPTS> can be set to a string containing 299options for dprofpp. You might use this if you prefer B<-I> over B<-E> or 300if you want B<-F> on all the time. 301 302This was added fairly lazily, so there are some undesirable side effects. 303Options on the commandline should override options in DPROFPP_OPTS--but 304don't count on that in this version. 305 306=head1 BUGS 307 308Applications which call _exit() or exec() from within a subroutine 309will leave an incomplete profile. See the B<-F> option. 310 311Any bugs in Devel::DProf, or any profiler generating the profile data, could 312be visible here. See L<Devel::DProf/BUGS>. 313 314Mail bug reports and feature requests to the perl5-porters mailing list at 315F<E<lt>perl5-porters@perl.orgE<gt>>. Bug reports should include the 316output 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 325L<perl>, L<Devel::DProf>, times(2) 326 327=cut 328 329use Getopt::Std 'getopts'; 330use Config '%Config'; 331 332Setup: { 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 423Main: { 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 492sub 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# 539sub 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 559sub 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 577sub kids_by_incl { $kids{$b}{incl_time} <=> $kids{$a}{excl_time} 578 or $a cmp $b } 579 580sub 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. 604sub 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 633sub 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 649sub 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 669sub 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 838sub 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 879sub 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 896sub 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. 910sub 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 924sub by_time { $times->{$b} <=> $times->{$a} } 925sub by_ctime { $ctimes->{$b} <=> $ctimes->{$a} } 926sub by_calls { $calls->{$b} <=> $calls->{$a} } 927sub by_alpha { $names->{$a} cmp $names->{$b} } 928sub by_avgcpu { $persecs->{$b} <=> $persecs->{$a} } 929# Reversed 930sub rby_time { $times->{$a} <=> $times->{$b} } 931sub rby_ctime { $ctimes->{$a} <=> $ctimes->{$b} } 932sub rby_calls { $calls->{$a} <=> $calls->{$b} } 933sub rby_alpha { $names->{$b} cmp $names->{$a} } 934sub rby_avgcpu { $persecs->{$a} <=> $persecs->{$b} } 935 936 937format CSTAT_top = 938Total 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 947BEGIN { 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 960close OUT or die "Can't close $file: $!"; 961chmod 0755, $file or die "Can't reset permissions for $file: $!\n"; 962exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':'; 963 964