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 my $dprof_pm = '../ext/Devel/DProf/DProf.pm';
23 open( PM, "<$dprof_pm" ) || die "Can't open $dprof_pm: $!";
25 if( /^\$Devel::DProf::VERSION\s*=\s*'(\d+)'/ ){
32 die "Did not find VERSION in $dprof_pm";
34 open OUT,">$file" or die "Can't create $file: $!";
36 print "Extracting $file (with variable substitutions)\n";
38 # In this section, perl variables will be expanded during extraction.
39 # You can use $Config{...} to use Configure variables.
41 print OUT <<"!GROK!THIS!";
43 eval 'exec perl -S \$0 "\$@"'
48 my \$VERSION = $VERSION;
52 # In the following, perl variables are not expanded during extraction.
54 print OUT <<'!NO!SUBS!';
57 dprofpp - display perl profile data
61 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]
63 dprofpp B<-T> [B<-F>] [B<-g subroutine>] [profile]
65 dprofpp B<-t> [B<-F>] [B<-g subroutine>] [profile]
67 dprofpp B<-p script> [B<-Q>] [other opts]
69 dprofpp B<-V> [profile]
73 The I<dprofpp> command interprets profile data produced by a profiler, such
74 as the Devel::DProf profiler. Dprofpp will read the file F<tmon.out> and
75 will display the 15 subroutines which are using the most time. By default
76 the times for each subroutine are given exclusive of the times of their
79 To profile a Perl script run the perl interpreter with the B<-d> switch. So
80 to profile script F<test.pl> with Devel::DProf the following command should
83 $ perl5 -d:DProf test.pl
85 Then run dprofpp to analyze the profile.
88 Total Elapsed Time = 1.67 Seconds
89 User Time = 0.61 Seconds
91 %Time Seconds #Calls sec/call Name
92 52.4 0.320 2 0.1600 main::foo
93 45.9 0.280 200 0.0014 main::bar
94 0.00 0.000 1 0.0000 DynaLoader::import
95 0.00 0.000 1 0.0000 main::baz
97 The dprofpp tool can also run the profiler before analyzing the profile
98 data. The above two commands can be executed with one dprofpp command.
100 $ dprofpp -u -p test.pl
102 Consult L<Devel::DProf/"PROFILE FORMAT"> for a description of the raw profile.
110 Sort alphabetically by subroutine names.
114 Count timing for autoloaded subroutine as timing for C<*::AUTOLOAD>.
115 Otherwise the time to autoload it is counted as time of the subroutine
116 itself (there is no way to separate autoload time from run time).
118 This is going to be irrelevant with newer Perls. They will inform
119 C<Devel::DProf> I<when> the C<AUTOLOAD> switches to actual subroutine,
120 so a separate statistics for C<AUTOLOAD> will be collected no matter
121 whether this option is set.
125 Count anonymous subroutines defined in the same package separately.
129 (default) Display all subroutine times exclusive of child subroutine times.
133 Force the generation of fake exit timestamps if dprofpp reports that the
134 profile is garbled. This is only useful if dprofpp determines that the
135 profile is garbled due to missing exit timestamps. You're on your own if
136 you do this. Consult the BUGS section.
140 Display all subroutine times inclusive of child subroutine times.
144 Sort by number of calls to the subroutines. This may help identify
145 candidates for inlining.
149 Show only I<cnt> subroutines. The default is 15.
153 Tells dprofpp that it should profile the given script and then interpret its
154 profile data. See B<-Q>.
158 Used with B<-p> to tell dprofpp to quit after profiling the script, without
159 interpreting the data.
163 Do not display column headers.
167 Display elapsed real times rather than user+system times.
171 Display system times rather than user+system times.
175 Display subroutine call tree to stdout. Subroutine statistics are
180 Display subroutine call tree to stdout. Subroutine statistics are not
181 displayed. When a function is called multiple consecutive times at the same
182 calling level then it is displayed once with a repeat count.
186 Display I<merged> subroutine call tree to stdout. Statistics is
187 displayed for each branch of the tree.
189 When a function is called multiple (I<not necessarily consecutive>)
190 times in the same branch then all these calls go into one branch of
191 the next level. A repeat count is output together with combined
192 inclusive, exclusive and kids time.
194 Branches are sorted w.r.t. inclusive time.
198 Do not sort. Display in the order found in the raw profile.
202 Display user times rather than user+system times.
206 Print dprofpp's version number and exit. If a raw profile is found then its
207 XS_VERSION variable will be displayed, too.
211 Sort by average time spent in subroutines during each call. This may help
212 identify candidates for inlining.
216 (default) Sort by amount of user+system time used. The first few lines
217 should show you which subroutines are using the most time.
219 =item B<-g> C<subroutine>
221 Ignore subroutines except C<subroutine> and whatever is called from it.
227 The environment variable B<DPROFPP_OPTS> can be set to a string containing
228 options for dprofpp. You might use this if you prefer B<-I> over B<-E> or
229 if you want B<-F> on all the time.
231 This was added fairly lazily, so there are some undesirable side effects.
232 Options on the commandline should override options in DPROFPP_OPTS--but
233 don't count on that in this version.
237 Applications which call _exit() or exec() from within a subroutine
238 will leave an incomplete profile. See the B<-F> option.
240 Any bugs in Devel::DProf, or any profiler generating the profile data, could
241 be visible here. See L<Devel::DProf/BUGS>.
243 Mail bug reports and feature requests to the perl5-porters mailing list at
244 F<E<lt>perl5-porters@perl.orgE<gt>>. Bug reports should include the
245 output of the B<-V> option.
249 dprofpp - profile processor
250 tmon.out - raw profile
254 L<perl>, L<Devel::DProf>, times(2)
258 use Getopt::Std 'getopts';
259 use Config '%Config';
262 my $options = 'O:g:lzaAvuTtqrRsUFEIp:QVS';
264 $Monfile = 'tmon.out';
265 if( exists $ENV{DPROFPP_OPTS} ){
267 @ARGV = split( ' ', $ENV{DPROFPP_OPTS} );
270 # there was a filename.
278 # there was a filename, it overrides any earlier name.
282 # -O cnt Specifies maximum number of subroutines to display.
283 # -a Sort by alphabetic name of subroutines.
284 # -z Sort by user+system time spent in subroutines. (default)
285 # -l Sort by number of calls to subroutines.
286 # -v Sort by average amount of time spent in subroutines.
288 # -t Show call tree, compressed.
289 # -q Do not print column headers.
290 # -u Use user time rather than user+system time.
291 # -s Use system time rather than user+system time.
292 # -r Use real elapsed time rather than user+system time.
293 # -U Do not sort subroutines.
294 # -E Sub times are reported exclusive of child times. (default)
295 # -I Sub times are reported inclusive of child times.
296 # -V Print dprofpp's version.
297 # -p script Specifies name of script to be profiled.
298 # -Q Used with -p to indicate the dprofpp should quit after
299 # profiling the script, without interpreting the data.
300 # -A count autoloaded to *AUTOLOAD
301 # -R count anonyms separately even if from the same package
302 # -g subr count only those who are SUBR or called from SUBR
303 # -S Create statistics for all the depths
305 if( defined $opt_V ){
307 print "$0 version: $VERSION\n";
308 open( $fh, "<$Monfile" ) && do {
309 local $XS_VERSION = 'early';
312 print "XS_VERSION: $XS_VERSION\n";
318 $sort = 'by_ctime' if defined $opt_I;
319 $sort = 'by_calls' if defined $opt_l;
320 $sort = 'by_alpha' if defined $opt_a;
321 $sort = 'by_avgcpu' if defined $opt_v;
322 $incl_excl = 'Exclusive';
323 $incl_excl = 'Inclusive' if defined $opt_I;
324 $whichtime = 'User+System';
325 $whichtime = 'System' if defined $opt_s;
326 $whichtime = 'Real' if defined $opt_r;
327 $whichtime = 'User' if defined $opt_u;
329 if( defined $opt_p ){
331 my $startperl = $Config{'startperl'};
333 $startperl =~ s/^#!//; # remove shebang
334 run_profiler( $opt_p, $prof, $startperl );
335 $Monfile = 'tmon.out'; # because that's where it is
336 exit(0) if defined $opt_Q;
338 elsif( defined $opt_Q ){
339 die "-Q is meaningful only when used with -p\n";
344 my $monout = $Monfile;
347 local $times = {}; # times in hz
348 local $ctimes = {}; # Cumulative times in hz
350 local $persecs = {}; # times in seconds
352 local $runtime; # runtime in seconds
355 local $rrun_utime = 0; # user time in hz
356 local $rrun_stime = 0; # system time in hz
357 local $rrun_rtime = 0; # elapsed run time in hz
358 local $rrun_ustime = 0; # user+system time in hz
360 local $deep_times = {count => 0 , kids => {}, incl_time => 0};
361 local $time_precision = 2;
364 open( $fh, "<$monout" ) || die "Unable to open $monout\n";
368 $rrun_ustime = $rrun_utime + $rrun_stime;
375 parsestack( $fh, $names, $calls, $times, $ctimes, $idkeys );
377 settime( \$runtime, $hz ) unless $opt_g;
379 exit(0) if $opt_T || $opt_t;
382 percalc( $calls, ($opt_I ? $ctimes : $times), $persecs, $idkeys );
385 @a = sort $sort @$idkeys;
391 display( $runtime, $hz, $names, $calls, $times, $ctimes, $cnt, $a,
396 # Sets $runtime to user, system, real, or user+system time. The
397 # result is given in seconds.
400 my( $runtime, $hz ) = @_;
403 $$runtime = ($rrun_rtime - $overhead - $over_rtime * $total_marks/$over_tests/2)/$hz;
406 $$runtime = ($rrun_stime - $overhead - $over_stime * $total_marks/$over_tests/2)/$hz;
409 $$runtime = ($rrun_utime - $overhead - $over_utime * $total_marks/$over_tests/2)/$hz;
412 $$runtime = ($rrun_ustime - $overhead - ($over_utime + $over_stime) * $total_marks/$over_tests/2)/$hz;
414 $$runtime = 0 unless $$runtime > 0;
417 sub exclusives_in_tree {
418 my( $deep_times ) = @_;
421 # When summing, take into account non-rounded-up kids time.
422 for $kid (keys %{$deep_times->{kids}}) {
423 $kids_time += $deep_times->{kids}{$kid}{incl_time};
425 $kids_time = 0 unless $kids_time >= 0;
426 $deep_times->{excl_time} = $deep_times->{incl_time} - $kids_time;
427 $deep_times->{excl_time} = 0 unless $deep_times->{excl_time} >= 0;
428 for $kid (keys %{$deep_times->{kids}}) {
429 exclusives_in_tree($deep_times->{kids}{$kid});
431 $deep_times->{incl_time} = 0 unless $deep_times->{incl_time} >= 0;
432 $deep_times->{kids_time} = $kids_time;
435 sub kids_by_incl { $kids{$b}{incl_time} <=> $kids{$a}{excl_time}
439 my( $deep_times, $name, $level ) = @_;
440 exclusives_in_tree($deep_times);
443 local *kids = $deep_times->{kids}; # %kids
447 $time = sprintf '%.*fs = (%.*f + %.*f)',
448 $time_precision, $deep_times->{incl_time}/$hz,
449 $time_precision, $deep_times->{excl_time}/$hz,
450 $time_precision, $deep_times->{kids_time}/$hz;
452 $time = sprintf '%.*f', $time_precision, $deep_times->{incl_time}/$hz;
454 print ' ' x (2*$level), "$name x $deep_times->{count} \t${time}s\n"
455 if $deep_times->{count};
457 for $kid (sort kids_by_incl keys %kids) {
458 display_tree( $deep_times->{kids}{$kid}, $kid, $level + 1 );
462 # Report the times in seconds.
464 my( $runtime, $hz, $names, $calls, $times, $ctimes, $cnt,
465 $idkeys, $deep_times ) = @_;
466 my( $x, $key, $s, $cs );
467 #format: $ncalls, $name, $secs, $percall, $pcnt
470 display_tree( $deep_times, 'toplevel', -1 )
472 for( $x = 0; $x < @$idkeys; ++$x ){
473 $key = $idkeys->[$x];
474 $ncalls = $calls->{$key};
475 $name = $names->{$key};
476 $s = $times->{$key}/$hz;
477 $secs = sprintf("%.3f", $s );
478 $cs = $ctimes->{$key}/$hz;
479 $csecs = sprintf("%.3f", $cs );
480 $percall = sprintf("%.4f", $s/$ncalls );
481 $cpercall = sprintf("%.4f", $cs/$ncalls );
482 $pcnt = sprintf("%.2f",
483 $runtime? ((($opt_I ? $csecs : $secs) / $runtime) * 100.0): 0 );
485 $pcnt = $secs = $ncalls = $percall = "";
486 write while( length $name );
493 my ($source, $dest) = @_;
496 for $kid (keys %$source) {
497 if (exists $dest->{$kid}) {
498 $dest->{count} += $source->{count};
499 $dest->{incl_time} += $source->{incl_time};
500 move_keys($source->{kids},$dest->{kids});
502 $dest->{$kid} = delete $source->{$kid};
508 my ($curdeep_times, $name, $t) = @_;
509 if ($name ne $curdeep_times->[-1]{name} and $opt_A) {
510 $name = $curdeep_times->[-1]{name};
512 die "Shorted?!" unless @$curdeep_times >= 2;
513 $curdeep_times->[-2]{kids}{$name} = { count => 0 , kids => {},
516 unless exists $curdeep_times->[-2]{kids}{$name};
517 my $entry = $curdeep_times->[-2]{kids}{$name};
518 # Now transfer to the new node (could not do earlier, since name can change)
520 $entry->{incl_time} += $t - $curdeep_times->[-1]{enter_stamp};
522 move_keys($curdeep_times->[-1]->{kids},$entry->{kids});
527 my( $fh, $names, $calls, $times, $ctimes, $idkeys ) = @_;
529 my( $t, $syst, $realt, $usert );
530 my( $x, $z, $c, $id, $pack );
536 # remember last call depth and function name
544 my $in_level = not defined $opt_g; # Level deep in report grouping
545 my $curdeep_times = [$deep_times];
548 if ( $opt_u ) { $over_per_call = $over_utime }
549 elsif( $opt_s ) { $over_per_call = $over_stime }
550 elsif( $opt_r ) { $over_per_call = $over_rtime }
551 else { $over_per_call = $over_utime + $over_stime }
552 $over_per_call /= 2*$over_tests; # distribute over entry and exit
560 ($dir, $id, $pack, $name) = split;
561 if ($opt_R and ($name =~ /::(__ANON_|END)$/)) {
564 $cv_hash{$id} = "$pack\::$name";
567 ($dir, $usert, $syst, $realt, $name) = split;
571 $syst = $stack[-1][0];
574 #warn("Inserted exit for $stack[-1][0].\n")
576 if (defined $realt) { # '+ times nam' '- times nam' or '@ incr'
577 if ( $opt_u ) { $t = $usert }
578 elsif( $opt_s ) { $t = $syst }
579 elsif( $opt_r ) { $t = $realt }
580 else { $t = $usert + $syst }
581 $t += $ot, next if $dir eq '@'; # Increments there
583 # "- id" or "- & name"
584 $name = defined $syst ? $syst : $cv_hash{$usert};
587 next unless $in_level or $name eq $opt_g or $dir eq '*';
588 if ( $dir eq '-' or $dir eq '*' ) {
589 my $ename = $dir eq '*' ? $stack[-1][0] : $name;
590 $overhead += $over_per_call;
591 if ($name eq "Devel::DProf::write") {
592 $dprof_t += $t - $dprof_stamp;
594 } elsif (defined $opt_g and $ename eq $opt_g) {
597 add_to_tree($curdeep_times, $ename,
598 $t - $dprof_t - $overhead) if $opt_S;
599 exitstamp( \@stack, \@tstack,
600 $t - $dprof_t - $overhead,
601 $times, $ctimes, $ename, \$in, $tab,
604 next unless $in_level or $name eq $opt_g;
605 if( $dir eq '+' or $dir eq '*' ){
606 if ($name eq "Devel::DProf::write") {
609 } elsif (defined $opt_g and $name eq $opt_g) {
612 $overhead += $over_per_call;
614 print ' ' x $in, "$name\n";
618 # suppress output on same function if the
619 # same calling level is called.
620 if ($l_in == $in and $l_name eq $name) {
623 $repstr = ' ('.++$repcnt.'x)'
625 print ' ' x $l_in, "$l_name$repstr\n"
634 if( ! defined $names->{$name} ){
635 $names->{$name} = $name;
637 $ctimes->{$name} = 0;
638 push( @$idkeys, $name );
641 push @$curdeep_times, { kids => {},
643 enter_stamp => $t - $dprof_t - $overhead,
645 $x = [ $name, $t - $dprof_t - $overhead ];
648 # my children will put their time here
650 } elsif ($dir ne '-'){
651 die "Bad profile: $_";
655 $repstr = ' ('.++$repcnt.'x)' if $repcnt;
656 print ' ' x $l_in, "$l_name$repstr\n";
661 warn "Garbled profile is missing some exit time stamps:\n";
662 foreach $x (@stack) {
665 die "Try rerunning dprofpp with -F.\n";
666 # I don't want -F to be default behavior--yet
670 warn( "Faking " . scalar( @stack ) . " exit timestamp(s).\n");
671 foreach $x ( reverse @stack ){
673 exitstamp( \@stack, \@tstack,
674 $t - $dprof_t - $overhead, $times,
675 $ctimes, $name, \$in, $tab,
677 add_to_tree($curdeep_times, $name,
678 $t - $dprof_t - $overhead)
683 if (defined $opt_g) {
684 $runtime = $ctimes->{$opt_g}/$hz;
685 $runtime = 0 unless $runtime > 0;
690 my($stack, $tstack, $t, $times, $ctimes, $name, $in, $tab, $deep) = @_;
695 die "Garbled profile, missing an enter time stamp";
697 if( $x->[0] ne $name ){
698 if ($x->[0] =~ /::AUTOLOAD$/) {
703 warn( "Garbled profile, faking exit timestamp:\n\t$name => $x->[0].\n");
706 foreach $z (@stack, $x) {
709 die "Garbled profile, unexpected exit time stamp";
712 if( $opt_T || $opt_t ){
716 $c = pop( @$tstack );
717 # total time this func has been active
719 $ctimes->{$name} += $z;
720 $times->{$name} += ($z > $c)? $z - $c: 0;
721 # pass my time to my parent
723 $c = pop( @$tstack );
724 push( @$tstack, $c + $z );
732 if( ! /^#fOrTyTwO$/ ){
733 die "Not a perl profile";
740 $over_tests = 1 unless $over_tests;
741 $time_precision = length int ($hz - 1); # log ;-)
745 # Report avg time-per-function in seconds
747 my( $calls, $times, $persecs, $idkeys ) = @_;
748 my( $x, $t, $n, $key );
750 for( $x = 0; $x < @$idkeys; ++$x ){
751 $key = $idkeys->[$x];
753 $t = $times->{$key} / $hz;
754 $persecs->{$key} = $t ? $t / $n : 0;
759 # Runs the given script with the given profiler and the given perl.
762 my $profiler = shift;
763 my $startperl = shift;
765 system $startperl, "-d:$profiler", $script;
767 die "Failed: $startperl -d:$profiler $script: $!";
772 sub by_time { $times->{$b} <=> $times->{$a} }
773 sub by_ctime { $ctimes->{$b} <=> $ctimes->{$a} }
774 sub by_calls { $calls->{$b} <=> $calls->{$a} }
775 sub by_alpha { $names->{$a} cmp $names->{$b} }
776 sub by_avgcpu { $persecs->{$b} <=> $persecs->{$a} }
780 Total Elapsed Time = @>>>>>>> Seconds
781 (($rrun_rtime - $overhead - $over_rtime * $total_marks/$over_tests/2) / $hz)
782 @>>>>>>>>>> Time = @>>>>>>> Seconds
786 %Time ExclSec CumulS #Calls sec/call Csec/c Name
790 ^>>> ^>>>> ^>>>>> ^>>>>> ^>>>>> ^>>>>> ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
791 $pcnt, $secs, $csecs, $ncalls, $percall, $cpercall, $name
796 close OUT or die "Can't close $file: $!";
797 chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
798 exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';