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. The output of dprofpp depends
86 on the flags to the program and the version of Perl you're using.
89 Total Elapsed Time = 1.67 Seconds
90 User Time = 0.61 Seconds
92 %Time Seconds #Calls sec/call Name
93 52.4 0.320 2 0.1600 main::foo
94 45.9 0.280 200 0.0014 main::bar
95 0.00 0.000 1 0.0000 DynaLoader::import
96 0.00 0.000 1 0.0000 main::baz
98 The dprofpp tool can also run the profiler before analyzing the profile
99 data. The above two commands can be executed with one dprofpp command.
101 $ dprofpp -u -p test.pl
103 Consult L<Devel::DProf/"PROFILE FORMAT"> for a description of the raw profile.
113 Percentage of time spent in this routine.
117 Number of calls to this routine.
121 Average number of seconds per call to this routine.
129 Time (in seconds) spent in this routine and routines called from it.
133 Time (in seconds) spent in this routine (not including those called
138 Average time (in seconds) spent in each call of this routine
139 (including those called from it).
149 Sort alphabetically by subroutine names.
153 Count timing for autoloaded subroutine as timing for C<*::AUTOLOAD>.
154 Otherwise the time to autoload it is counted as time of the subroutine
155 itself (there is no way to separate autoload time from run time).
157 This is going to be irrelevant with newer Perls. They will inform
158 C<Devel::DProf> I<when> the C<AUTOLOAD> switches to actual subroutine,
159 so a separate statistics for C<AUTOLOAD> will be collected no matter
160 whether this option is set.
164 Count anonymous subroutines defined in the same package separately.
168 (default) Display all subroutine times exclusive of child subroutine times.
172 Force the generation of fake exit timestamps if dprofpp reports that the
173 profile is garbled. This is only useful if dprofpp determines that the
174 profile is garbled due to missing exit timestamps. You're on your own if
175 you do this. Consult the BUGS section.
179 Display all subroutine times inclusive of child subroutine times.
183 Sort by number of calls to the subroutines. This may help identify
184 candidates for inlining.
188 Show only I<cnt> subroutines. The default is 15.
192 Tells dprofpp that it should profile the given script and then interpret its
193 profile data. See B<-Q>.
197 Used with B<-p> to tell dprofpp to quit after profiling the script, without
198 interpreting the data.
202 Do not display column headers.
206 Display elapsed real times rather than user+system times.
210 Display system times rather than user+system times.
214 Display subroutine call tree to stdout. Subroutine statistics are
219 Display subroutine call tree to stdout. Subroutine statistics are not
220 displayed. When a function is called multiple consecutive times at the same
221 calling level then it is displayed once with a repeat count.
225 Display I<merged> subroutine call tree to stdout. Statistics is
226 displayed for each branch of the tree.
228 When a function is called multiple (I<not necessarily consecutive>)
229 times in the same branch then all these calls go into one branch of
230 the next level. A repeat count is output together with combined
231 inclusive, exclusive and kids time.
233 Branches are sorted w.r.t. inclusive time.
237 Do not sort. Display in the order found in the raw profile.
241 Display user times rather than user+system times.
245 Print dprofpp's version number and exit. If a raw profile is found then its
246 XS_VERSION variable will be displayed, too.
250 Sort by average time spent in subroutines during each call. This may help
251 identify candidates for inlining.
255 (default) Sort by amount of user+system time used. The first few lines
256 should show you which subroutines are using the most time.
258 =item B<-g> C<subroutine>
260 Ignore subroutines except C<subroutine> and whatever is called from it.
266 The environment variable B<DPROFPP_OPTS> can be set to a string containing
267 options for dprofpp. You might use this if you prefer B<-I> over B<-E> or
268 if you want B<-F> on all the time.
270 This was added fairly lazily, so there are some undesirable side effects.
271 Options on the commandline should override options in DPROFPP_OPTS--but
272 don't count on that in this version.
276 Applications which call _exit() or exec() from within a subroutine
277 will leave an incomplete profile. See the B<-F> option.
279 Any bugs in Devel::DProf, or any profiler generating the profile data, could
280 be visible here. See L<Devel::DProf/BUGS>.
282 Mail bug reports and feature requests to the perl5-porters mailing list at
283 F<E<lt>perl5-porters@perl.orgE<gt>>. Bug reports should include the
284 output of the B<-V> option.
288 dprofpp - profile processor
289 tmon.out - raw profile
293 L<perl>, L<Devel::DProf>, times(2)
297 use Getopt::Std 'getopts';
298 use Config '%Config';
301 my $options = 'O:g:lzaAvuTtqrRsUFEIp:QVS';
303 $Monfile = 'tmon.out';
304 if( exists $ENV{DPROFPP_OPTS} ){
306 @ARGV = split( ' ', $ENV{DPROFPP_OPTS} );
309 # there was a filename.
317 # there was a filename, it overrides any earlier name.
321 # -O cnt Specifies maximum number of subroutines to display.
322 # -a Sort by alphabetic name of subroutines.
323 # -z Sort by user+system time spent in subroutines. (default)
324 # -l Sort by number of calls to subroutines.
325 # -v Sort by average amount of time spent in subroutines.
327 # -t Show call tree, compressed.
328 # -q Do not print column headers.
329 # -u Use user time rather than user+system time.
330 # -s Use system time rather than user+system time.
331 # -r Use real elapsed time rather than user+system time.
332 # -U Do not sort subroutines.
333 # -E Sub times are reported exclusive of child times. (default)
334 # -I Sub times are reported inclusive of child times.
335 # -V Print dprofpp's version.
336 # -p script Specifies name of script to be profiled.
337 # -Q Used with -p to indicate the dprofpp should quit after
338 # profiling the script, without interpreting the data.
339 # -A count autoloaded to *AUTOLOAD
340 # -R count anonyms separately even if from the same package
341 # -g subr count only those who are SUBR or called from SUBR
342 # -S Create statistics for all the depths
344 if( defined $opt_V ){
346 print "$0 version: $VERSION\n";
347 open( $fh, "<$Monfile" ) && do {
348 local $XS_VERSION = 'early';
351 print "XS_VERSION: $XS_VERSION\n";
357 $sort = 'by_ctime' if defined $opt_I;
358 $sort = 'by_calls' if defined $opt_l;
359 $sort = 'by_alpha' if defined $opt_a;
360 $sort = 'by_avgcpu' if defined $opt_v;
361 $incl_excl = 'Exclusive';
362 $incl_excl = 'Inclusive' if defined $opt_I;
363 $whichtime = 'User+System';
364 $whichtime = 'System' if defined $opt_s;
365 $whichtime = 'Real' if defined $opt_r;
366 $whichtime = 'User' if defined $opt_u;
368 if( defined $opt_p ){
370 my $startperl = $Config{'startperl'};
372 $startperl =~ s/^#!//; # remove shebang
373 run_profiler( $opt_p, $prof, $startperl );
374 $Monfile = 'tmon.out'; # because that's where it is
375 exit(0) if defined $opt_Q;
377 elsif( defined $opt_Q ){
378 die "-Q is meaningful only when used with -p\n";
383 my $monout = $Monfile;
386 local $times = {}; # times in hz
387 local $ctimes = {}; # Cumulative times in hz
389 local $persecs = {}; # times in seconds
391 local $runtime; # runtime in seconds
394 local $rrun_utime = 0; # user time in hz
395 local $rrun_stime = 0; # system time in hz
396 local $rrun_rtime = 0; # elapsed run time in hz
397 local $rrun_ustime = 0; # user+system time in hz
399 local $deep_times = {count => 0 , kids => {}, incl_time => 0};
400 local $time_precision = 2;
403 open( $fh, "<$monout" ) || die "Unable to open $monout\n";
407 $rrun_ustime = $rrun_utime + $rrun_stime;
414 parsestack( $fh, $names, $calls, $times, $ctimes, $idkeys );
416 settime( \$runtime, $hz ) unless $opt_g;
418 exit(0) if $opt_T || $opt_t;
421 percalc( $calls, ($opt_I ? $ctimes : $times), $persecs, $idkeys );
424 @a = sort $sort @$idkeys;
430 display( $runtime, $hz, $names, $calls, $times, $ctimes, $cnt, $a,
435 # Sets $runtime to user, system, real, or user+system time. The
436 # result is given in seconds.
439 my( $runtime, $hz ) = @_;
444 $$runtime = ($rrun_rtime - $overhead - $over_rtime * $total_marks/$over_tests/2)/$hz;
447 $$runtime = ($rrun_stime - $overhead - $over_stime * $total_marks/$over_tests/2)/$hz;
450 $$runtime = ($rrun_utime - $overhead - $over_utime * $total_marks/$over_tests/2)/$hz;
453 $$runtime = ($rrun_ustime - $overhead - ($over_utime + $over_stime) * $total_marks/$over_tests/2)/$hz;
455 $$runtime = 0 unless $$runtime > 0;
458 sub exclusives_in_tree {
459 my( $deep_times ) = @_;
462 # When summing, take into account non-rounded-up kids time.
463 for $kid (keys %{$deep_times->{kids}}) {
464 $kids_time += $deep_times->{kids}{$kid}{incl_time};
466 $kids_time = 0 unless $kids_time >= 0;
467 $deep_times->{excl_time} = $deep_times->{incl_time} - $kids_time;
468 $deep_times->{excl_time} = 0 unless $deep_times->{excl_time} >= 0;
469 for $kid (keys %{$deep_times->{kids}}) {
470 exclusives_in_tree($deep_times->{kids}{$kid});
472 $deep_times->{incl_time} = 0 unless $deep_times->{incl_time} >= 0;
473 $deep_times->{kids_time} = $kids_time;
476 sub kids_by_incl { $kids{$b}{incl_time} <=> $kids{$a}{excl_time}
480 my( $deep_times, $name, $level ) = @_;
481 exclusives_in_tree($deep_times);
484 local *kids = $deep_times->{kids}; # %kids
488 $time = sprintf '%.*fs = (%.*f + %.*f)',
489 $time_precision, $deep_times->{incl_time}/$hz,
490 $time_precision, $deep_times->{excl_time}/$hz,
491 $time_precision, $deep_times->{kids_time}/$hz;
493 $time = sprintf '%.*f', $time_precision, $deep_times->{incl_time}/$hz;
495 print ' ' x (2*$level), "$name x $deep_times->{count} \t${time}s\n"
496 if $deep_times->{count};
498 for $kid (sort kids_by_incl keys %kids) {
499 display_tree( $deep_times->{kids}{$kid}, $kid, $level + 1 );
503 # Report the times in seconds.
505 my( $runtime, $hz, $names, $calls, $times, $ctimes, $cnt,
506 $idkeys, $deep_times ) = @_;
507 my( $x, $key, $s, $cs );
508 #format: $ncalls, $name, $secs, $percall, $pcnt
511 display_tree( $deep_times, 'toplevel', -1 )
513 for( $x = 0; $x < @$idkeys; ++$x ){
514 $key = $idkeys->[$x];
515 $ncalls = $calls->{$key};
516 $name = $names->{$key};
517 $s = $times->{$key}/$hz;
518 $secs = sprintf("%.3f", $s );
519 $cs = $ctimes->{$key}/$hz;
520 $csecs = sprintf("%.3f", $cs );
521 $percall = sprintf("%.4f", $s/$ncalls );
522 $cpercall = sprintf("%.4f", $cs/$ncalls );
523 $pcnt = sprintf("%.2f",
524 $runtime? ((($opt_I ? $csecs : $secs) / $runtime) * 100.0): 0 );
526 $pcnt = $secs = $ncalls = $percall = "";
527 write while( length $name );
534 my ($source, $dest) = @_;
537 for $kid (keys %$source) {
538 if (exists $dest->{$kid}) {
539 $dest->{count} += $source->{count};
540 $dest->{incl_time} += $source->{incl_time};
541 move_keys($source->{kids},$dest->{kids});
543 $dest->{$kid} = delete $source->{$kid};
549 my ($curdeep_times, $name, $t) = @_;
550 if ($name ne $curdeep_times->[-1]{name} and $opt_A) {
551 $name = $curdeep_times->[-1]{name};
553 die "Shorted?!" unless @$curdeep_times >= 2;
554 $curdeep_times->[-2]{kids}{$name} = { count => 0 , kids => {},
557 unless exists $curdeep_times->[-2]{kids}{$name};
558 my $entry = $curdeep_times->[-2]{kids}{$name};
559 # Now transfer to the new node (could not do earlier, since name can change)
561 $entry->{incl_time} += $t - $curdeep_times->[-1]{enter_stamp};
563 move_keys($curdeep_times->[-1]->{kids},$entry->{kids});
568 my( $fh, $names, $calls, $times, $ctimes, $idkeys ) = @_;
570 my( $t, $syst, $realt, $usert );
571 my( $x, $z, $c, $id, $pack );
577 # remember last call depth and function name
585 my $in_level = not defined $opt_g; # Level deep in report grouping
586 my $curdeep_times = [$deep_times];
589 if ( $opt_u ) { $over_per_call = $over_utime }
590 elsif( $opt_s ) { $over_per_call = $over_stime }
591 elsif( $opt_r ) { $over_per_call = $over_rtime }
592 else { $over_per_call = $over_utime + $over_stime }
593 $over_per_call /= 2*$over_tests; # distribute over entry and exit
601 ($dir, $id, $pack, $name) = split;
602 if ($opt_R and ($name =~ /::(__ANON_|END)$/)) {
605 $cv_hash{$id} = "$pack\::$name";
608 ($dir, $usert, $syst, $realt, $name) = split;
612 $syst = $stack[-1][0];
615 #warn("Inserted exit for $stack[-1][0].\n")
617 if (defined $realt) { # '+ times nam' '- times nam' or '@ incr'
618 if ( $opt_u ) { $t = $usert }
619 elsif( $opt_s ) { $t = $syst }
620 elsif( $opt_r ) { $t = $realt }
621 else { $t = $usert + $syst }
622 $t += $ot, next if $dir eq '@'; # Increments there
624 # "- id" or "- & name"
625 $name = defined $syst ? $syst : $cv_hash{$usert};
628 next unless $in_level or $name eq $opt_g or $dir eq '*';
629 if ( $dir eq '-' or $dir eq '*' ) {
630 my $ename = $dir eq '*' ? $stack[-1][0] : $name;
631 $overhead += $over_per_call;
632 if ($name eq "Devel::DProf::write") {
633 $dprof_t += $t - $dprof_stamp;
635 } elsif (defined $opt_g and $ename eq $opt_g) {
638 add_to_tree($curdeep_times, $ename,
639 $t - $dprof_t - $overhead) if $opt_S;
640 exitstamp( \@stack, \@tstack,
641 $t - $dprof_t - $overhead,
642 $times, $ctimes, $ename, \$in, $tab,
645 next unless $in_level or $name eq $opt_g;
646 if( $dir eq '+' or $dir eq '*' ){
647 if ($name eq "Devel::DProf::write") {
650 } elsif (defined $opt_g and $name eq $opt_g) {
653 $overhead += $over_per_call;
655 print ' ' x $in, "$name\n";
659 # suppress output on same function if the
660 # same calling level is called.
661 if ($l_in == $in and $l_name eq $name) {
664 $repstr = ' ('.++$repcnt.'x)'
666 print ' ' x $l_in, "$l_name$repstr\n"
675 if( ! defined $names->{$name} ){
676 $names->{$name} = $name;
678 $ctimes->{$name} = 0;
679 push( @$idkeys, $name );
682 push @$curdeep_times, { kids => {},
684 enter_stamp => $t - $dprof_t - $overhead,
686 $x = [ $name, $t - $dprof_t - $overhead ];
689 # my children will put their time here
691 } elsif ($dir ne '-'){
692 die "Bad profile: $_";
696 $repstr = ' ('.++$repcnt.'x)' if $repcnt;
697 print ' ' x $l_in, "$l_name$repstr\n";
702 warn "Garbled profile is missing some exit time stamps:\n";
703 foreach $x (@stack) {
706 die "Try rerunning dprofpp with -F.\n";
707 # I don't want -F to be default behavior--yet
711 warn( "Faking " . scalar( @stack ) . " exit timestamp(s).\n");
712 foreach $x ( reverse @stack ){
714 exitstamp( \@stack, \@tstack,
715 $t - $dprof_t - $overhead, $times,
716 $ctimes, $name, \$in, $tab,
718 add_to_tree($curdeep_times, $name,
719 $t - $dprof_t - $overhead)
724 if (defined $opt_g) {
725 $runtime = $ctimes->{$opt_g}/$hz;
726 $runtime = 0 unless $runtime > 0;
731 my($stack, $tstack, $t, $times, $ctimes, $name, $in, $tab, $deep) = @_;
736 die "Garbled profile, missing an enter time stamp";
738 if( $x->[0] ne $name ){
739 if ($x->[0] =~ /::AUTOLOAD$/) {
744 warn( "Garbled profile, faking exit timestamp:\n\t$name => $x->[0].\n");
747 foreach $z (@stack, $x) {
750 die "Garbled profile, unexpected exit time stamp";
753 if( $opt_T || $opt_t ){
757 $c = pop( @$tstack );
758 # total time this func has been active
760 $ctimes->{$name} += $z;
761 $times->{$name} += ($z > $c)? $z - $c: 0;
762 # pass my time to my parent
764 $c = pop( @$tstack );
765 push( @$tstack, $c + $z );
773 if( ! /^#fOrTyTwO$/ ){
774 die "Not a perl profile";
781 $over_tests = 1 unless $over_tests;
782 $time_precision = length int ($hz - 1); # log ;-)
786 # Report avg time-per-function in seconds
788 my( $calls, $times, $persecs, $idkeys ) = @_;
789 my( $x, $t, $n, $key );
791 for( $x = 0; $x < @$idkeys; ++$x ){
792 $key = $idkeys->[$x];
794 $t = $times->{$key} / $hz;
795 $persecs->{$key} = $t ? $t / $n : 0;
800 # Runs the given script with the given profiler and the given perl.
803 my $profiler = shift;
804 my $startperl = shift;
806 system $startperl, "-d:$profiler", $script;
808 die "Failed: $startperl -d:$profiler $script: $!";
813 sub by_time { $times->{$b} <=> $times->{$a} }
814 sub by_ctime { $ctimes->{$b} <=> $ctimes->{$a} }
815 sub by_calls { $calls->{$b} <=> $calls->{$a} }
816 sub by_alpha { $names->{$a} cmp $names->{$b} }
817 sub by_avgcpu { $persecs->{$b} <=> $persecs->{$a} }
821 Total Elapsed Time = @>>>>>>> Seconds
822 (($rrun_rtime - $overhead - $over_rtime * $total_marks/$over_tests/2) / $hz)
823 @>>>>>>>>>> Time = @>>>>>>> Seconds
827 %Time ExclSec CumulS #Calls sec/call Csec/c Name
831 ^>>> ^>>>> ^>>>>> ^>>>>> ^>>>>> ^>>>>> ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
832 $pcnt, $secs, $csecs, $ncalls, $percall, $cpercall, $name
837 close OUT or die "Can't close $file: $!";
838 chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
839 exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';