4 use File::Basename qw(&basename &dirname);
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
12 # to ensure Configure will look for $Config{startperl}.
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.
17 ($file = basename($0)) =~ s/\.PL$//i;
18 $file .= '.COM' if ($^O eq 'VMS');
20 my $dprof_pm = File::Spec->catfile(File::Spec->updir, 'ext', 'Devel', 'DProf', 'DProf.pm');
22 open( PM, "<$dprof_pm" ) || die "Can't open $dprof_pm: $!";
24 if( /^\$Devel::DProf::VERSION\s*=\s*'([\d._]+)'/ ){
31 die "Did not find VERSION in $dprof_pm";
34 foreach my $s (qw(/bin/stty /usr/bin/stty)) {
40 open OUT,">$file" or die "Can't create $file: $!";
42 print "Extracting $file (with variable substitutions)\n";
44 # In this section, perl variables will be expanded during extraction.
45 # You can use $Config{...} to use Configure variables.
47 print OUT <<"!GROK!THIS!";
49 eval 'exec perl -S \$0 "\$@"'
54 my \$VERSION = '$VERSION';
59 # In the following, perl variables are not expanded during extraction.
61 print OUT <<'!NO!SUBS!';
64 dprofpp - display perl profile data
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]
70 dprofpp B<-T> [B<-F>] [B<-g subroutine>] [profile]
72 dprofpp B<-t> [B<-F>] [B<-g subroutine>] [profile]
74 dprofpp B<-G> <regexp> [B<-P>] [profile]
76 dprofpp B<-p script> [B<-Q>] [other opts]
78 dprofpp B<-V> [profile]
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
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
92 $ perl5 -d:DProf test.pl
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.
98 Total Elapsed Time = 1.67 Seconds
99 User Time = 0.61 Seconds
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
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.
110 $ dprofpp -u -p test.pl
112 Consult L<Devel::DProf/"PROFILE FORMAT"> for a description of the raw profile.
122 Percentage of time spent in this routine.
126 Number of calls to this routine.
130 Average number of seconds per call to this routine.
138 Time (in seconds) spent in this routine and routines called from it.
142 Time (in seconds) spent in this routine (not including those called
147 Average time (in seconds) spent in each call of this routine
148 (including those called from it).
158 Sort alphabetically by subroutine names.
162 Reverse whatever sort is used
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).
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.
177 Count anonymous subroutines defined in the same package separately.
181 (default) Display all subroutine times exclusive of child subroutine times.
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.
192 Display all subroutine times inclusive of child subroutine times.
196 Sort by number of calls to the subroutines. This may help identify
197 candidates for inlining.
201 Show only I<cnt> subroutines. The default is 15.
205 Tells dprofpp that it should profile the given script and then interpret its
206 profile data. See B<-Q>.
210 Used with B<-p> to tell dprofpp to quit after profiling the script, without
211 interpreting the data.
215 Do not display column headers.
219 Display elapsed real times rather than user+system times.
223 Display system times rather than user+system times.
227 Display subroutine call tree to stdout. Subroutine statistics are
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.
238 Display I<merged> subroutine call tree to stdout. Statistics are
239 displayed for each branch of the tree.
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.
246 Branches are sorted w.r.t. inclusive time.
250 Do not sort. Display in the order found in the raw profile.
254 Display user times rather than user+system times.
258 Print dprofpp's version number and exit. If a raw profile is found then its
259 XS_VERSION variable will be displayed, too.
263 Sort by average time spent in subroutines during each call. This may help
264 identify candidates for inlining.
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.
271 =item B<-g> C<subroutine>
273 Ignore subroutines except C<subroutine> and whatever is called from it.
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
280 -G "(package1::)|(package2::)|(package3::)"
282 or to group subroutines by name:
288 Used with -G to aggregate "Pull" together all calls that did not match -G.
292 Filter all calls matching the pattern.
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.
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.
308 Applications which call _exit() or exec() from within a subroutine
309 will leave an incomplete profile. See the B<-F> option.
311 Any bugs in Devel::DProf, or any profiler generating the profile data, could
312 be visible here. See L<Devel::DProf/BUGS>.
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.
320 dprofpp - profile processor
321 tmon.out - raw profile
325 L<perl>, L<Devel::DProf>, times(2)
329 use Getopt::Std 'getopts';
330 use Config '%Config';
333 my $options = 'O:g:G:Pf:dlzaAvuTtqrRsUFEIp:QVS';
335 $Monfile = 'tmon.out';
336 if( exists $ENV{DPROFPP_OPTS} ){
338 @ARGV = split( ' ', $ENV{DPROFPP_OPTS} );
341 # there was a filename.
349 # there was a filename, it overrides any earlier name.
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.
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
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.
381 if( defined $opt_V ){
383 print "$0 version: $VERSION\n";
384 open( $fh, "<$Monfile" ) && do {
385 local $XS_VERSION = 'early';
388 print "XS_VERSION: $XS_VERSION\n";
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;
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;
409 if( defined $opt_p ){
411 my $startperl = $Config{'startperl'};
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;
418 elsif( defined $opt_Q ){
419 die "-Q is meaningful only when used with -p\n";
424 my $monout = $Monfile;
427 local $times = {}; # times in hz
428 local $ctimes = {}; # Cumulative times in hz
430 local $persecs = {}; # times in seconds
432 local $runtime; # runtime in seconds
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
440 local $deep_times = {count => 0 , kids => {}, incl_time => 0};
441 local $time_precision = 2;
444 open( $fh, "<$monout" ) || die "Unable to open $monout\n";
448 $rrun_ustime = $rrun_utime + $rrun_stime;
455 parsestack( $fh, $names, $calls, $times, $ctimes, $idkeys );
459 for(my $i = 0;$i < @$idkeys - 2;){
461 if($key =~ /$opt_f/){
462 splice(@$idkeys, $i, 1);
463 $runtime -= $$times{$key};
471 group($names, $calls, $times, $ctimes, $idkeys );
474 settime( \$runtime, $hz ) unless $opt_g;
476 exit(0) if $opt_T || $opt_t;
479 percalc( $calls, ($opt_I ? $ctimes : $times), $persecs, $idkeys );
482 @a = sort $sort @$idkeys;
488 display( $runtime, $hz, $names, $calls, $times, $ctimes, $cnt, $a,
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;
499 $$ctimes{$opt_G} = 0;
500 $$idkeys[@$idkeys] = $opt_G;
501 # Sum calls for the grouping
505 $$names{$other} = $other;
508 $$ctimes{$other} = 0;
509 $$idkeys[@$idkeys] = $other;
512 for(my $i = 0;$i < @$idkeys - 2;){
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);
522 $$calls{$other} += $$calls{$key};
523 $$times{$other} += $$times{$key};
524 $$ctimes{$other} += $$ctimes{$key};
525 splice(@$idkeys, $i, 1);
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";
536 # Sets $runtime to user, system, real, or user+system time. The
537 # result is given in seconds.
540 my( $runtime, $hz ) = @_;
545 $$runtime = ($rrun_rtime - $overhead)/$hz;
548 $$runtime = ($rrun_stime - $overhead)/$hz;
551 $$runtime = ($rrun_utime - $overhead)/$hz;
554 $$runtime = ($rrun_ustime - $overhead)/$hz;
556 $$runtime = 0 unless $$runtime > 0;
559 sub exclusives_in_tree {
560 my( $deep_times ) = @_;
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};
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});
573 $deep_times->{incl_time} = 0 unless $deep_times->{incl_time} >= 0;
574 $deep_times->{kids_time} = $kids_time;
577 sub kids_by_incl { $kids{$b}{incl_time} <=> $kids{$a}{excl_time}
581 my( $deep_times, $name, $level ) = @_;
582 exclusives_in_tree($deep_times);
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;
593 $time = sprintf '%.*f', $time_precision, $deep_times->{incl_time}/$hz;
595 print ' ' x (2*$level), "$name x $deep_times->{count} \t${time}s\n"
596 if $deep_times->{count};
598 for $kid (sort kids_by_incl %{$deep_times->{kids}}) {
599 display_tree( $deep_times->{kids}{$kid}, $kid, $level + 1 );
603 # Report the times in seconds.
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
611 display_tree( $deep_times, 'toplevel', -1 )
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 );
626 $pcnt = $secs = $ncalls = $percall = "";
627 write while( length $name );
634 my ($source, $dest) = @_;
636 for my $kid_name (keys %$source) {
637 my $source_kid = delete $source->{$kid_name};
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});
644 $dest->{$kid_name} = $source_kid;
650 my ($curdeep_times, $name, $t) = @_;
651 if ($name ne $curdeep_times->[-1]{name} and $opt_A) {
652 $name = $curdeep_times->[-1]{name};
654 die "Shorted?!" unless @$curdeep_times >= 2;
655 my $entry = $curdeep_times->[-2]{kids}{$name} ||= {
660 # Now transfer to the new node (could not do earlier, since name can change)
662 $entry->{incl_time} += $t - $curdeep_times->[-1]{enter_stamp};
664 move_keys($curdeep_times->[-1]->{kids},$entry->{kids});
670 my( $fh, $names, $calls, $times, $ctimes, $idkeys ) = @_;
672 my( $t, $syst, $realt, $usert );
673 my( $x, $z, $c, $id, $pack );
680 # remember last call depth and function name
687 my $in_level = not defined $opt_g; # Level deep in report grouping
688 my $curdeep_times = [$deep_times];
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
703 ($dir, $id, $pack, $name) = split;
704 if ($opt_R and ($name =~ /(?:::)?(__ANON__|END)$/)) {
707 $cv_hash{$id} = "$pack\::$name";
710 ($dir, $usert, $syst, $realt, $name) = split;
714 $syst = $stack[-1][0];
717 #warn("Inserted exit for $stack[-1][0].\n")
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
726 # "- id" or "- & name"
727 $name = defined $syst ? $syst : $cv_hash{$usert};
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;
737 } elsif (defined $opt_g and $ename eq $opt_g) {
740 add_to_tree($curdeep_times, $ename,
741 $t - $overhead) if $opt_S;
742 exitstamp( \@stack, \@tstack,
744 $times, $ctimes, $ename, \$in, $tab,
745 $curdeep_times, \%outer );
747 next unless $in_level or $name eq $opt_g;
748 if( $dir eq '+' or $dir eq '*' ){
749 if ($name eq "Devel::DProf::write") {
752 } elsif (defined $opt_g and $name eq $opt_g) {
755 $overhead += $over_per_call;
757 print ' ' x $in, "$name\n";
761 # suppress output on same function if the
762 # same calling level is called.
763 if ($l_in == $in and $l_name eq $name) {
766 $repstr = ' ('.++$repcnt.'x)'
768 print ' ' x $l_in, "$l_name$repstr\n"
777 if( ! defined $names->{$name} ){
778 $names->{$name} = $name;
780 $ctimes->{$name} = 0;
781 push( @$idkeys, $name );
785 push @$curdeep_times, { kids => {},
787 enter_stamp => $t - $overhead,
789 $x = [ $name, $t - $overhead ];
792 # my children will put their time here
794 } elsif ($dir ne '-'){
795 die "Bad profile: $_";
799 $repstr = ' ('.++$repcnt.'x)' if $repcnt;
800 print ' ' x $l_in, "$l_name$repstr\n";
803 while (my ($key, $count) = each %outer) {
805 warn "$key has $count unstacked calls in outer\n";
810 warn "Garbled profile is missing some exit time stamps:\n";
811 foreach $x (@stack) {
814 die "Try rerunning dprofpp with -F.\n";
815 # I don't want -F to be default behavior--yet
819 warn( "Faking " . scalar( @stack ) . " exit timestamp(s).\n");
820 foreach $x ( reverse @stack ){
822 exitstamp( \@stack, \@tstack,
823 $t - $overhead, $times,
824 $ctimes, $name, \$in, $tab,
825 $curdeep_times, \%outer );
826 add_to_tree($curdeep_times, $name,
832 if (defined $opt_g) {
833 $runtime = $ctimes->{$opt_g}/$hz;
834 $runtime = 0 unless $runtime > 0;
839 my($stack, $tstack, $t, $times, $ctimes, $name, $in, $tab, $deep, $outer) = @_;
844 die "Garbled profile, missing an enter time stamp";
846 if( $x->[0] ne $name and $opt_G and ($name =~ /$opt_G/)){
847 if ($x->[0] =~ /(?:::)?AUTOLOAD$/) {
852 warn( "Garbled profile, faking exit timestamp:\n\t$name => $x->[0].\n");
855 foreach $z (@stack, $x) {
858 die "Garbled profile, unexpected exit time stamp";
861 if( $opt_T || $opt_t ){
865 $c = pop( @$tstack );
866 # total time this func has been active
868 $ctimes->{$name} += $z
869 unless --$outer->{$name};
870 $times->{$name} += $z - $c;
871 # pass my time to my parent
873 $c = pop( @$tstack );
874 push( @$tstack, $c + $z );
882 if( ! /^#fOrTyTwO$/ ){
883 die "Not a perl profile";
890 $over_tests = 1 unless $over_tests;
891 $time_precision = length int ($hz - 1); # log ;-)
895 # Report avg time-per-function in seconds
897 my( $calls, $times, $persecs, $idkeys ) = @_;
898 my( $x, $t, $n, $key );
900 for( $x = 0; $x < @$idkeys; ++$x ){
901 $key = $idkeys->[$x];
903 $t = $times->{$key} / $hz;
904 $persecs->{$key} = $t ? $t / $n : 0;
909 # Runs the given script with the given profiler and the given perl.
912 my $profiler = shift;
913 my $startperl = shift;
914 my @script_parts = split /\s+/, $script;
916 system $startperl, "-d:$profiler", @script_parts;
918 my $cmd = join ' ', @script_parts;
919 die "Failed: $startperl -d:$profiler $cmd: $!";
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} }
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} }
938 Total Elapsed Time = @>>>>>>> Seconds
939 (($rrun_rtime - $overhead) / $hz)
940 @>>>>>>>>>> Time = @>>>>>>> Seconds
944 %Time ExclSec CumulS #Calls sec/call Csec/c Name
948 my $fmt = ' ^>>> ^>>>> ^>>>>> ^>>>>> ^>>>>> ^>>>>> ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<';
949 if (-t STDOUT and defined $stty and my ($cols) = `$stty -a` =~ /\bcolumns\s+(\d+)/)
951 $fmt .= '<' x ($cols - length $fmt) if $cols > 80;
954 eval "format STAT = \n$fmt" . '
955 $pcnt, $secs, $csecs, $ncalls, $percall, $cpercall, $name
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 ':';