4 use File::Basename qw(&basename &dirname);
6 # List explicitly here the variables you want Configure to
7 # generate. Metaconfig only looks for shell variables, so you
8 # have to mention them as if they were shell variables, not
9 # %Config entries. Thus you write
11 # to ensure Configure will look for $Config{startperl}.
13 # This forces PL files to create target in same directory as PL file.
14 # This is so that make depend always knows where to find PL derivatives.
16 ($file = basename($0)) =~ s/\.PL$//;
18 if ($Config{'osname'} eq 'VMS' or
19 $Config{'osname'} eq 'OS2'); # "case-forgiving"
21 print "Pulling version from Makefile for dprofpp...\n";
23 open( MK, "<Makefile" ) || die "Can't open Makefile: $!";
25 if( /^VERSION\s*=\s*(\d+)/ ){
32 die "Did not find VERSION in Makefile";
34 print " version is ($VERSION).\n";
36 open OUT,">$file" or die "Can't create $file: $!";
38 print "Extracting $file (with variable substitutions)\n";
40 # In this section, perl variables will be expanded during extraction.
41 # You can use $Config{...} to use Configure variables.
43 print OUT <<"!GROK!THIS!";
45 eval 'exec perl -S \$0 "\$@"'
50 my \$VERSION = $VERSION;
54 # In the following, perl variables are not expanded during extraction.
56 print OUT <<'!NO!SUBS!';
59 dprofpp - display perl profile data
63 dprofpp [B<-a>|B<-z>|B<-l>|B<-v>|B<-U>] [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>] [profile]
65 dprofpp B<-T> [B<-F>] [B<-g subroutine>] [profile]
67 dprofpp B<-t> [B<-F>] [B<-g subroutine>] [profile]
69 dprofpp B<-p script> [B<-Q>] [other opts]
71 dprofpp B<-V> [profile]
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
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
85 $ perl5 -d:DProf test.pl
87 Then run dprofpp to analyze the profile.
90 Total Elapsed Time = 1.67 Seconds
91 User Time = 0.61 Seconds
93 %Time Seconds #Calls sec/call Name
94 52.4 0.320 2 0.1600 main::foo
95 45.9 0.280 200 0.0014 main::bar
96 0.00 0.000 1 0.0000 DynaLoader::import
97 0.00 0.000 1 0.0000 main::baz
99 The dprofpp tool can also run the profiler before analyzing the profile
100 data. The above two commands can be executed with one dprofpp command.
102 $ dprofpp -u -p test.pl
104 Consult L<Devel::DProf/"PROFILE FORMAT"> for a description of the raw profile.
112 Sort alphabetically by subroutine names.
116 Count timing for autoloaded subroutine as timing for C<*::AUTOLOAD>.
117 Otherwise the time to autoload it is counted as time of the subroutine
118 itself (there is no way to separate autoload time from run time).
120 This is going to be irrelevant with newer Perls. They will inform
121 C<Devel::DProf> I<when> the C<AUTOLOAD> switches to actual subroutine,
122 so a separate statistics for C<AUTOLOAD> will be collected no matter
123 whether this option is set.
127 Count anonymous subroutines defined in the same package separately.
131 (default) Display all subroutine times exclusive of child subroutine times.
135 Force the generation of fake exit timestamps if dprofpp reports that the
136 profile is garbled. This is only useful if dprofpp determines that the
137 profile is garbled due to missing exit timestamps. You're on your own if
138 you do this. Consult the BUGS section.
142 Display all subroutine times inclusive of child subroutine times.
146 Sort by number of calls to the subroutines. This may help identify
147 candidates for inlining.
151 Show only I<cnt> subroutines. The default is 15.
155 Tells dprofpp that it should profile the given script and then interpret its
156 profile data. See B<-Q>.
160 Used with B<-p> to tell dprofpp to quit after profiling the script, without
161 interpreting the data.
165 Do not display column headers.
169 Display elapsed real times rather than user+system times.
173 Display system times rather than user+system times.
177 Display subroutine call tree to stdout. Subroutine statistics are
182 Display subroutine call tree to stdout. Subroutine statistics are not
183 displayed. When a function is called multiple consecutive times at the same
184 calling level then it is displayed once with a repeat count.
188 Display I<merged> subroutine call tree to stdout. Statistics is
189 displayed for each branch of the tree.
191 When a function is called multiple (I<not necessarily consecutive>)
192 times in the same branch then all these calls go into one branch of
193 the next level. A repeat count is output together with combined
194 inclusive, exclusive and kids time.
196 Branches are sorted w.r.t. inclusive time.
200 Do not sort. Display in the order found in the raw profile.
204 Display user times rather than user+system times.
208 Print dprofpp's version number and exit. If a raw profile is found then its
209 XS_VERSION variable will be displayed, too.
213 Sort by average time spent in subroutines during each call. This may help
214 identify candidates for inlining.
218 (default) Sort by amount of user+system time used. The first few lines
219 should show you which subroutines are using the most time.
221 =item B<-g> C<subroutine>
223 Ignore subroutines except C<subroutine> and whatever is called from it.
229 The environment variable B<DPROFPP_OPTS> can be set to a string containing
230 options for dprofpp. You might use this if you prefer B<-I> over B<-E> or
231 if you want B<-F> on all the time.
233 This was added fairly lazily, so there are some undesirable side effects.
234 Options on the commandline should override options in DPROFPP_OPTS--but
235 don't count on that in this version.
239 Applications which call _exit() or exec() from within a subroutine
240 will leave an incomplete profile. See the B<-F> option.
242 Any bugs in Devel::DProf, or any profiler generating the profile data, could
243 be visible here. See L<Devel::DProf/BUGS>.
245 Mail bug reports and feature requests to the perl5-porters mailing list at
246 F<E<lt>perl5-porters@perl.orgE<gt>>. Bug reports should include the
247 output of the B<-V> option.
251 dprofpp - profile processor
252 tmon.out - raw profile
256 L<perl>, L<Devel::DProf>, times(2)
260 use Getopt::Std 'getopts';
261 use Config '%Config';
264 my $options = 'O:g:lzaAvuTtqrRsUFEIp:QVS';
266 $Monfile = 'tmon.out';
267 if( exists $ENV{DPROFPP_OPTS} ){
269 @ARGV = split( ' ', $ENV{DPROFPP_OPTS} );
272 # there was a filename.
280 # there was a filename, it overrides any earlier name.
284 # -O cnt Specifies maximum number of subroutines to display.
285 # -a Sort by alphabetic name of subroutines.
286 # -z Sort by user+system time spent in subroutines. (default)
287 # -l Sort by number of calls to subroutines.
288 # -v Sort by average amount of time spent in subroutines.
290 # -t Show call tree, compressed.
291 # -q Do not print column headers.
292 # -u Use user time rather than user+system time.
293 # -s Use system time rather than user+system time.
294 # -r Use real elapsed time rather than user+system time.
295 # -U Do not sort subroutines.
296 # -E Sub times are reported exclusive of child times. (default)
297 # -I Sub times are reported inclusive of child times.
298 # -V Print dprofpp's version.
299 # -p script Specifies name of script to be profiled.
300 # -Q Used with -p to indicate the dprofpp should quit after
301 # profiling the script, without interpreting the data.
302 # -A count autoloaded to *AUTOLOAD
303 # -R count anonyms separately even if from the same package
304 # -g subr count only those who are SUBR or called from SUBR
305 # -S Create statistics for all the depths
307 if( defined $opt_V ){
309 print "$0 version: $VERSION\n";
310 open( $fh, "<$Monfile" ) && do {
311 local $XS_VERSION = 'early';
314 print "XS_VERSION: $XS_VERSION\n";
320 $sort = 'by_ctime' if defined $opt_I;
321 $sort = 'by_calls' if defined $opt_l;
322 $sort = 'by_alpha' if defined $opt_a;
323 $sort = 'by_avgcpu' if defined $opt_v;
324 $incl_excl = 'Exclusive';
325 $incl_excl = 'Inclusive' if defined $opt_I;
326 $whichtime = 'User+System';
327 $whichtime = 'System' if defined $opt_s;
328 $whichtime = 'Real' if defined $opt_r;
329 $whichtime = 'User' if defined $opt_u;
331 if( defined $opt_p ){
333 my $startperl = $Config{'startperl'};
335 $startperl =~ s/^#!//; # remove shebang
336 run_profiler( $opt_p, $prof, $startperl );
337 $Monfile = 'tmon.out'; # because that's where it is
338 exit(0) if defined $opt_Q;
340 elsif( defined $opt_Q ){
341 die "-Q is meaningful only when used with -p\n";
346 my $monout = $Monfile;
349 local $times = {}; # times in hz
350 local $ctimes = {}; # Cumulative times in hz
352 local $persecs = {}; # times in seconds
354 local $runtime; # runtime in seconds
357 local $rrun_utime = 0; # user time in hz
358 local $rrun_stime = 0; # system time in hz
359 local $rrun_rtime = 0; # elapsed run time in hz
360 local $rrun_ustime = 0; # user+system time in hz
362 local $deep_times = {count => 0 , kids => {}, incl_time => 0};
363 local $time_precision = 2;
366 open( $fh, "<$monout" ) || die "Unable to open $monout\n";
370 $rrun_ustime = $rrun_utime + $rrun_stime;
377 parsestack( $fh, $names, $calls, $times, $ctimes, $idkeys );
379 settime( \$runtime, $hz ) unless $opt_g;
381 exit(0) if $opt_T || $opt_t;
384 percalc( $calls, ($opt_I ? $ctimes : $times), $persecs, $idkeys );
387 @a = sort $sort @$idkeys;
393 display( $runtime, $hz, $names, $calls, $times, $ctimes, $cnt, $a,
398 # Sets $runtime to user, system, real, or user+system time. The
399 # result is given in seconds.
402 my( $runtime, $hz ) = @_;
405 $$runtime = ($rrun_rtime - $overhead - $over_rtime * $total_marks/$over_tests/2)/$hz;
408 $$runtime = ($rrun_stime - $overhead - $over_stime * $total_marks/$over_tests/2)/$hz;
411 $$runtime = ($rrun_utime - $overhead - $over_utime * $total_marks/$over_tests/2)/$hz;
414 $$runtime = ($rrun_ustime - $overhead - ($over_utime + $over_stime) * $total_marks/$over_tests/2)/$hz;
416 $$runtime = 0 unless $$runtime > 0;
419 sub exclusives_in_tree {
420 my( $deep_times ) = @_;
423 # When summing, take into account non-rounded-up kids time.
424 for $kid (keys %{$deep_times->{kids}}) {
425 $kids_time += $deep_times->{kids}{$kid}{incl_time};
427 $kids_time = 0 unless $kids_time >= 0;
428 $deep_times->{excl_time} = $deep_times->{incl_time} - $kids_time;
429 $deep_times->{excl_time} = 0 unless $deep_times->{excl_time} >= 0;
430 for $kid (keys %{$deep_times->{kids}}) {
431 exclusives_in_tree($deep_times->{kids}{$kid});
433 $deep_times->{incl_time} = 0 unless $deep_times->{incl_time} >= 0;
434 $deep_times->{kids_time} = $kids_time;
437 sub kids_by_incl { $kids{$b}{incl_time} <=> $kids{$a}{excl_time}
441 my( $deep_times, $name, $level ) = @_;
442 exclusives_in_tree($deep_times);
445 local *kids = $deep_times->{kids}; # %kids
449 $time = sprintf '%.*fs = (%.*f + %.*f)',
450 $time_precision, $deep_times->{incl_time}/$hz,
451 $time_precision, $deep_times->{excl_time}/$hz,
452 $time_precision, $deep_times->{kids_time}/$hz;
454 $time = sprintf '%.*f', $time_precision, $deep_times->{incl_time}/$hz;
456 print ' ' x (2*$level), "$name x $deep_times->{count} \t${time}s\n"
457 if $deep_times->{count};
459 for $kid (sort kids_by_incl keys %kids) {
460 display_tree( $deep_times->{kids}{$kid}, $kid, $level + 1 );
464 # Report the times in seconds.
466 my( $runtime, $hz, $names, $calls, $times, $ctimes, $cnt,
467 $idkeys, $deep_times ) = @_;
468 my( $x, $key, $s, $cs );
469 #format: $ncalls, $name, $secs, $percall, $pcnt
472 display_tree( $deep_times, 'toplevel', -1 )
474 for( $x = 0; $x < @$idkeys; ++$x ){
475 $key = $idkeys->[$x];
476 $ncalls = $calls->{$key};
477 $name = $names->{$key};
478 $s = $times->{$key}/$hz;
479 $secs = sprintf("%.3f", $s );
480 $cs = $ctimes->{$key}/$hz;
481 $csecs = sprintf("%.3f", $cs );
482 $percall = sprintf("%.4f", $s/$ncalls );
483 $cpercall = sprintf("%.4f", $cs/$ncalls );
484 $pcnt = sprintf("%.2f",
485 $runtime? ((($opt_I ? $csecs : $secs) / $runtime) * 100.0): 0 );
487 $pcnt = $secs = $ncalls = $percall = "";
488 write while( length $name );
495 my ($source, $dest) = @_;
498 for $kid (keys %$source) {
499 if (exists $dest->{$kid}) {
500 $dest->{count} += $source->{count};
501 $dest->{incl_time} += $source->{incl_time};
502 move_keys($source->{kids},$dest->{kids});
504 $dest->{$kid} = delete $source->{$kid};
510 my ($curdeep_times, $name, $t) = @_;
511 if ($name ne $curdeep_times->[-1]{name} and $opt_A) {
512 $name = $curdeep_times->[-1]{name};
514 die "Shorted?!" unless @$curdeep_times >= 2;
515 $curdeep_times->[-2]{kids}{$name} = { count => 0 , kids => {},
518 unless exists $curdeep_times->[-2]{kids}{$name};
519 my $entry = $curdeep_times->[-2]{kids}{$name};
520 # Now transfer to the new node (could not do earlier, since name can change)
522 $entry->{incl_time} += $t - $curdeep_times->[-1]{enter_stamp};
524 move_keys($curdeep_times->[-1]->{kids},$entry->{kids});
529 my( $fh, $names, $calls, $times, $ctimes, $idkeys ) = @_;
531 my( $t, $syst, $realt, $usert );
532 my( $x, $z, $c, $id, $pack );
538 # remember last call depth and function name
546 my $in_level = not defined $opt_g; # Level deep in report grouping
547 my $curdeep_times = [$deep_times];
550 if ( $opt_u ) { $over_per_call = $over_utime }
551 elsif( $opt_s ) { $over_per_call = $over_stime }
552 elsif( $opt_r ) { $over_per_call = $over_rtime }
553 else { $over_per_call = $over_utime + $over_stime }
554 $over_per_call /= 2*$over_tests; # distribute over entry and exit
562 ($dir, $id, $pack, $name) = split;
563 if ($opt_R and ($name =~ /::(__ANON_|END)$/)) {
566 $cv_hash{$id} = "$pack\::$name";
569 ($dir, $usert, $syst, $realt, $name) = split;
573 $syst = $stack[-1][0];
576 #warn("Inserted exit for $stack[-1][0].\n")
578 if (defined $realt) { # '+ times nam' '- times nam' or '@ incr'
579 if ( $opt_u ) { $t = $usert }
580 elsif( $opt_s ) { $t = $syst }
581 elsif( $opt_r ) { $t = $realt }
582 else { $t = $usert + $syst }
583 $t += $ot, next if $dir eq '@'; # Increments there
585 # "- id" or "- & name"
586 $name = defined $syst ? $syst : $cv_hash{$usert};
589 next unless $in_level or $name eq $opt_g or $dir eq '*';
590 if ( $dir eq '-' or $dir eq '*' ) {
591 my $ename = $dir eq '*' ? $stack[-1][0] : $name;
592 $overhead += $over_per_call;
593 if ($name eq "Devel::DProf::write") {
594 $dprof_t += $t - $dprof_stamp;
596 } elsif (defined $opt_g and $ename eq $opt_g) {
599 add_to_tree($curdeep_times, $ename,
600 $t - $dprof_t - $overhead) if $opt_S;
601 exitstamp( \@stack, \@tstack,
602 $t - $dprof_t - $overhead,
603 $times, $ctimes, $ename, \$in, $tab,
606 next unless $in_level or $name eq $opt_g;
607 if( $dir eq '+' or $dir eq '*' ){
608 if ($name eq "Devel::DProf::write") {
611 } elsif (defined $opt_g and $name eq $opt_g) {
614 $overhead += $over_per_call;
616 print ' ' x $in, "$name\n";
620 # suppress output on same function if the
621 # same calling level is called.
622 if ($l_in == $in and $l_name eq $name) {
625 $repstr = ' ('.++$repcnt.'x)'
627 print ' ' x $l_in, "$l_name$repstr\n"
636 if( ! defined $names->{$name} ){
637 $names->{$name} = $name;
639 $ctimes->{$name} = 0;
640 push( @$idkeys, $name );
643 push @$curdeep_times, { kids => {},
645 enter_stamp => $t - $dprof_t - $overhead,
647 $x = [ $name, $t - $dprof_t - $overhead ];
650 # my children will put their time here
652 } elsif ($dir ne '-'){
653 die "Bad profile: $_";
657 $repstr = ' ('.++$repcnt.'x)' if $repcnt;
658 print ' ' x $l_in, "$l_name$repstr\n";
663 warn "Garbled profile is missing some exit time stamps:\n";
664 foreach $x (@stack) {
667 die "Try rerunning dprofpp with -F.\n";
668 # I don't want -F to be default behavior--yet
672 warn( "Faking " . scalar( @stack ) . " exit timestamp(s).\n");
673 foreach $x ( reverse @stack ){
675 exitstamp( \@stack, \@tstack,
676 $t - $dprof_t - $overhead, $times,
677 $ctimes, $name, \$in, $tab,
679 add_to_tree($curdeep_times, $name,
680 $t - $dprof_t - $overhead)
685 if (defined $opt_g) {
686 $runtime = $ctimes->{$opt_g}/$hz;
687 $runtime = 0 unless $runtime > 0;
692 my($stack, $tstack, $t, $times, $ctimes, $name, $in, $tab, $deep) = @_;
697 die "Garbled profile, missing an enter time stamp";
699 if( $x->[0] ne $name ){
700 if ($x->[0] =~ /::AUTOLOAD$/) {
705 warn( "Garbled profile, faking exit timestamp:\n\t$name => $x->[0].\n");
708 foreach $z (@stack, $x) {
711 die "Garbled profile, unexpected exit time stamp";
714 if( $opt_T || $opt_t ){
718 $c = pop( @$tstack );
719 # total time this func has been active
721 $ctimes->{$name} += $z;
722 $times->{$name} += ($z > $c)? $z - $c: 0;
723 # pass my time to my parent
725 $c = pop( @$tstack );
726 push( @$tstack, $c + $z );
734 if( ! /^#fOrTyTwO$/ ){
735 die "Not a perl profile";
742 $over_tests = 1 unless $over_tests;
743 $time_precision = length int ($hz - 1); # log ;-)
747 # Report avg time-per-function in seconds
749 my( $calls, $times, $persecs, $idkeys ) = @_;
750 my( $x, $t, $n, $key );
752 for( $x = 0; $x < @$idkeys; ++$x ){
753 $key = $idkeys->[$x];
755 $t = $times->{$key} / $hz;
756 $persecs->{$key} = $t ? $t / $n : 0;
761 # Runs the given script with the given profiler and the given perl.
764 my $profiler = shift;
765 my $startperl = shift;
767 system $startperl, "-d:$profiler", $script;
769 die "Failed: $startperl -d:$profiler $script: $!";
774 sub by_time { $times->{$b} <=> $times->{$a} }
775 sub by_ctime { $ctimes->{$b} <=> $ctimes->{$a} }
776 sub by_calls { $calls->{$b} <=> $calls->{$a} }
777 sub by_alpha { $names->{$a} cmp $names->{$b} }
778 sub by_avgcpu { $persecs->{$b} <=> $persecs->{$a} }
782 Total Elapsed Time = @>>>>>>> Seconds
783 (($rrun_rtime - $overhead - $over_rtime * $total_marks/$over_tests/2) / $hz)
784 @>>>>>>>>>> Time = @>>>>>>> Seconds
788 %Time ExclSec CumulS #Calls sec/call Csec/c Name
792 ^>>> ^>>>> ^>>>>> ^>>>>> ^>>>>> ^>>>>> ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
793 $pcnt, $secs, $csecs, $ncalls, $percall, $cpercall, $name
798 close OUT or die "Can't close $file: $!";
799 chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
800 exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';