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$//;
18 $file =~ s/\.pl$// if ($Config{'osname'} eq 'OS2'); # "case-forgiving"
19 $file =~ s/\.pl$/.com/ if ($Config{'osname'} eq 'VMS'); # "case-forgiving"
21 my $dprof_pm = File::Spec->catfile(File::Spec->updir, '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";
35 foreach my $s (qw(/bin/stty /usr/bin/stty)) {
41 open OUT,">$file" or die "Can't create $file: $!";
43 print "Extracting $file (with variable substitutions)\n";
45 # In this section, perl variables will be expanded during extraction.
46 # You can use $Config{...} to use Configure variables.
48 print OUT <<"!GROK!THIS!";
50 eval 'exec perl -S \$0 "\$@"'
55 my \$VERSION = '$VERSION';
60 # In the following, perl variables are not expanded during extraction.
62 print OUT <<'!NO!SUBS!';
65 dprofpp - display perl profile data
69 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]
71 dprofpp B<-T> [B<-F>] [B<-g subroutine>] [profile]
73 dprofpp B<-t> [B<-F>] [B<-g subroutine>] [profile]
75 dprofpp B<-G> <regexp> [B<-P>] [profile]
77 dprofpp B<-p script> [B<-Q>] [other opts]
79 dprofpp B<-V> [profile]
83 The I<dprofpp> command interprets profile data produced by a profiler, such
84 as the Devel::DProf profiler. Dprofpp will read the file F<tmon.out> and
85 will display the 15 subroutines which are using the most time. By default
86 the times for each subroutine are given exclusive of the times of their
89 To profile a Perl script run the perl interpreter with the B<-d> switch. So
90 to profile script F<test.pl> with Devel::DProf the following command should
93 $ perl5 -d:DProf test.pl
95 Then run dprofpp to analyze the profile. The output of dprofpp depends
96 on the flags to the program and the version of Perl you're using.
99 Total Elapsed Time = 1.67 Seconds
100 User Time = 0.61 Seconds
102 %Time Seconds #Calls sec/call Name
103 52.4 0.320 2 0.1600 main::foo
104 45.9 0.280 200 0.0014 main::bar
105 0.00 0.000 1 0.0000 DynaLoader::import
106 0.00 0.000 1 0.0000 main::baz
108 The dprofpp tool can also run the profiler before analyzing the profile
109 data. The above two commands can be executed with one dprofpp command.
111 $ dprofpp -u -p test.pl
113 Consult L<Devel::DProf/"PROFILE FORMAT"> for a description of the raw profile.
123 Percentage of time spent in this routine.
127 Number of calls to this routine.
131 Average number of seconds per call to this routine.
139 Time (in seconds) spent in this routine and routines called from it.
143 Time (in seconds) spent in this routine (not including those called
148 Average time (in seconds) spent in each call of this routine
149 (including those called from it).
159 Sort alphabetically by subroutine names.
163 Reverse whatever sort is used
167 Count timing for autoloaded subroutine as timing for C<*::AUTOLOAD>.
168 Otherwise the time to autoload it is counted as time of the subroutine
169 itself (there is no way to separate autoload time from run time).
171 This is going to be irrelevant with newer Perls. They will inform
172 C<Devel::DProf> I<when> the C<AUTOLOAD> switches to actual subroutine,
173 so a separate statistics for C<AUTOLOAD> will be collected no matter
174 whether this option is set.
178 Count anonymous subroutines defined in the same package separately.
182 (default) Display all subroutine times exclusive of child subroutine times.
186 Force the generation of fake exit timestamps if dprofpp reports that the
187 profile is garbled. This is only useful if dprofpp determines that the
188 profile is garbled due to missing exit timestamps. You're on your own if
189 you do this. Consult the BUGS section.
193 Display all subroutine times inclusive of child subroutine times.
197 Sort by number of calls to the subroutines. This may help identify
198 candidates for inlining.
202 Show only I<cnt> subroutines. The default is 15.
206 Tells dprofpp that it should profile the given script and then interpret its
207 profile data. See B<-Q>.
211 Used with B<-p> to tell dprofpp to quit after profiling the script, without
212 interpreting the data.
216 Do not display column headers.
220 Display elapsed real times rather than user+system times.
224 Display system times rather than user+system times.
228 Display subroutine call tree to stdout. Subroutine statistics are
233 Display subroutine call tree to stdout. Subroutine statistics are not
234 displayed. When a function is called multiple consecutive times at the same
235 calling level then it is displayed once with a repeat count.
239 Display I<merged> subroutine call tree to stdout. Statistics are
240 displayed for each branch of the tree.
242 When a function is called multiple (I<not necessarily consecutive>)
243 times in the same branch then all these calls go into one branch of
244 the next level. A repeat count is output together with combined
245 inclusive, exclusive and kids time.
247 Branches are sorted w.r.t. inclusive time.
251 Do not sort. Display in the order found in the raw profile.
255 Display user times rather than user+system times.
259 Print dprofpp's version number and exit. If a raw profile is found then its
260 XS_VERSION variable will be displayed, too.
264 Sort by average time spent in subroutines during each call. This may help
265 identify candidates for inlining.
269 (default) Sort by amount of user+system time used. The first few lines
270 should show you which subroutines are using the most time.
272 =item B<-g> C<subroutine>
274 Ignore subroutines except C<subroutine> and whatever is called from it.
278 Aggregate "Group" all calls matching the pattern together.
279 For example this can be used to group all calls of a set of packages
281 -G "(package1::)|(package2::)|(package3::)"
283 or to group subroutines by name:
289 Used with -G to aggregate "Pull" together all calls that did not match -G.
293 Filter all calls matching the pattern.
299 The environment variable B<DPROFPP_OPTS> can be set to a string containing
300 options for dprofpp. You might use this if you prefer B<-I> over B<-E> or
301 if you want B<-F> on all the time.
303 This was added fairly lazily, so there are some undesirable side effects.
304 Options on the commandline should override options in DPROFPP_OPTS--but
305 don't count on that in this version.
309 Applications which call _exit() or exec() from within a subroutine
310 will leave an incomplete profile. See the B<-F> option.
312 Any bugs in Devel::DProf, or any profiler generating the profile data, could
313 be visible here. See L<Devel::DProf/BUGS>.
315 Mail bug reports and feature requests to the perl5-porters mailing list at
316 F<E<lt>perl5-porters@perl.orgE<gt>>. Bug reports should include the
317 output of the B<-V> option.
321 dprofpp - profile processor
322 tmon.out - raw profile
326 L<perl>, L<Devel::DProf>, times(2)
330 use Getopt::Std 'getopts';
331 use Config '%Config';
334 my $options = 'O:g:G:Pf:dlzaAvuTtqrRsUFEIp:QVS';
336 $Monfile = 'tmon.out';
337 if( exists $ENV{DPROFPP_OPTS} ){
339 @ARGV = split( ' ', $ENV{DPROFPP_OPTS} );
342 # there was a filename.
350 # there was a filename, it overrides any earlier name.
354 # -O cnt Specifies maximum number of subroutines to display.
355 # -a Sort by alphabetic name of subroutines.
356 # -z Sort by user+system time spent in subroutines. (default)
357 # -l Sort by number of calls to subroutines.
358 # -v Sort by average amount of time spent in subroutines.
360 # -t Show call tree, compressed.
361 # -q Do not print column headers.
362 # -u Use user time rather than user+system time.
363 # -s Use system time rather than user+system time.
364 # -r Use real elapsed time rather than user+system time.
365 # -U Do not sort subroutines.
366 # -E Sub times are reported exclusive of child times. (default)
367 # -I Sub times are reported inclusive of child times.
368 # -V Print dprofpp's version.
369 # -p script Specifies name of script to be profiled.
370 # -Q Used with -p to indicate the dprofpp should quit after
371 # profiling the script, without interpreting the data.
372 # -A count autoloaded to *AUTOLOAD
373 # -R count anonyms separately even if from the same package
374 # -g subr count only those who are SUBR or called from SUBR
375 # -S Create statistics for all the depths
377 # -G Group all calls matching the pattern together.
378 # -P Used with -G to pull all other calls together.
379 # -f Filter all calls mathcing the pattern.
382 if( defined $opt_V ){
384 print "$0 version: $VERSION\n";
385 open( $fh, "<$Monfile" ) && do {
386 local $XS_VERSION = 'early';
389 print "XS_VERSION: $XS_VERSION\n";
395 $sort = 'by_ctime' if defined $opt_I;
396 $sort = 'by_calls' if defined $opt_l;
397 $sort = 'by_alpha' if defined $opt_a;
398 $sort = 'by_avgcpu' if defined $opt_v;
403 $incl_excl = 'Exclusive';
404 $incl_excl = 'Inclusive' if defined $opt_I;
405 $whichtime = 'User+System';
406 $whichtime = 'System' if defined $opt_s;
407 $whichtime = 'Real' if defined $opt_r;
408 $whichtime = 'User' if defined $opt_u;
410 if( defined $opt_p ){
412 my $startperl = $Config{'startperl'};
414 $startperl =~ s/^#!//; # remove shebang
415 run_profiler( $opt_p, $prof, $startperl );
416 $Monfile = 'tmon.out'; # because that's where it is
417 exit(0) if defined $opt_Q;
419 elsif( defined $opt_Q ){
420 die "-Q is meaningful only when used with -p\n";
425 my $monout = $Monfile;
428 local $times = {}; # times in hz
429 local $ctimes = {}; # Cumulative times in hz
431 local $persecs = {}; # times in seconds
433 local $runtime; # runtime in seconds
436 local $rrun_utime = 0; # user time in hz
437 local $rrun_stime = 0; # system time in hz
438 local $rrun_rtime = 0; # elapsed run time in hz
439 local $rrun_ustime = 0; # user+system time in hz
441 local $deep_times = {count => 0 , kids => {}, incl_time => 0};
442 local $time_precision = 2;
445 open( $fh, "<$monout" ) || die "Unable to open $monout\n";
449 $rrun_ustime = $rrun_utime + $rrun_stime;
456 parsestack( $fh, $names, $calls, $times, $ctimes, $idkeys );
460 for(my $i = 0;$i < @$idkeys - 2;){
462 if($key =~ /$opt_f/){
463 splice(@$idkeys, $i, 1);
464 $runtime -= $$times{$key};
472 group($names, $calls, $times, $ctimes, $idkeys );
475 settime( \$runtime, $hz ) unless $opt_g;
477 exit(0) if $opt_T || $opt_t;
480 percalc( $calls, ($opt_I ? $ctimes : $times), $persecs, $idkeys );
483 @a = sort $sort @$idkeys;
489 display( $runtime, $hz, $names, $calls, $times, $ctimes, $cnt, $a,
494 my ($names, $calls, $times, $ctimes, $idkeys ) = @_;
495 print "Option G Grouping: [$opt_G]\n";
496 # create entries to store grouping
497 $$names{$opt_G} = $opt_G;
500 $$ctimes{$opt_G} = 0;
501 $$idkeys[@$idkeys] = $opt_G;
502 # Sum calls for the grouping
506 $$names{$other} = $other;
509 $$ctimes{$other} = 0;
510 $$idkeys[@$idkeys] = $other;
513 for(my $i = 0;$i < @$idkeys - 2;){
515 if($key =~ /$opt_G/){
516 $$calls{$opt_G} += $$calls{$key};
517 $$times{$opt_G} += $$times{$key};
518 $$ctimes{$opt_G} += $$ctimes{$key};
519 splice(@$idkeys, $i, 1);
523 $$calls{$other} += $$calls{$key};
524 $$times{$other} += $$times{$key};
525 $$ctimes{$other} += $$ctimes{$key};
526 splice(@$idkeys, $i, 1);
532 print "Grouping [$opt_G] Calls: [$$calls{$opt_G}]\n".
533 "Grouping [$opt_G] Times: [$$times{$opt_G}]\n".
534 "Grouping [$opt_G] IncTimes: [$$ctimes{$opt_G}]\n";
537 # Sets $runtime to user, system, real, or user+system time. The
538 # result is given in seconds.
541 my( $runtime, $hz ) = @_;
546 $$runtime = ($rrun_rtime - $overhead)/$hz;
549 $$runtime = ($rrun_stime - $overhead)/$hz;
552 $$runtime = ($rrun_utime - $overhead)/$hz;
555 $$runtime = ($rrun_ustime - $overhead)/$hz;
557 $$runtime = 0 unless $$runtime > 0;
560 sub exclusives_in_tree {
561 my( $deep_times ) = @_;
564 # When summing, take into account non-rounded-up kids time.
565 for $kid (keys %{$deep_times->{kids}}) {
566 $kids_time += $deep_times->{kids}{$kid}{incl_time};
568 $kids_time = 0 unless $kids_time >= 0;
569 $deep_times->{excl_time} = $deep_times->{incl_time} - $kids_time;
570 $deep_times->{excl_time} = 0 unless $deep_times->{excl_time} >= 0;
571 for $kid (keys %{$deep_times->{kids}}) {
572 exclusives_in_tree($deep_times->{kids}{$kid});
574 $deep_times->{incl_time} = 0 unless $deep_times->{incl_time} >= 0;
575 $deep_times->{kids_time} = $kids_time;
578 sub kids_by_incl { $kids{$b}{incl_time} <=> $kids{$a}{excl_time}
582 my( $deep_times, $name, $level ) = @_;
583 exclusives_in_tree($deep_times);
588 if (%{$deep_times->{kids}}) {
589 $time = sprintf '%.*fs = (%.*f + %.*f)',
590 $time_precision, $deep_times->{incl_time}/$hz,
591 $time_precision, $deep_times->{excl_time}/$hz,
592 $time_precision, $deep_times->{kids_time}/$hz;
594 $time = sprintf '%.*f', $time_precision, $deep_times->{incl_time}/$hz;
596 print ' ' x (2*$level), "$name x $deep_times->{count} \t${time}s\n"
597 if $deep_times->{count};
599 for $kid (sort kids_by_incl %{$deep_times->{kids}}) {
600 display_tree( $deep_times->{kids}{$kid}, $kid, $level + 1 );
604 # Report the times in seconds.
606 my( $runtime, $hz, $names, $calls, $times, $ctimes, $cnt,
607 $idkeys, $deep_times ) = @_;
608 my( $x, $key, $s, $cs );
609 #format: $ncalls, $name, $secs, $percall, $pcnt
612 display_tree( $deep_times, 'toplevel', -1 )
614 for( $x = 0; $x < @$idkeys; ++$x ){
615 $key = $idkeys->[$x];
616 $ncalls = $calls->{$key};
617 $name = $names->{$key};
618 $s = $times->{$key}/$hz;
619 $secs = sprintf("%.3f", $s );
620 $cs = $ctimes->{$key}/$hz;
621 $csecs = sprintf("%.3f", $cs );
622 $percall = sprintf("%.4f", $s/$ncalls );
623 $cpercall = sprintf("%.4f", $cs/$ncalls );
624 $pcnt = sprintf("%.2f",
625 $runtime? ((($opt_I ? $csecs : $secs) / $runtime) * 100.0): 0 );
627 $pcnt = $secs = $ncalls = $percall = "";
628 write while( length $name );
635 my ($source, $dest) = @_;
637 for my $kid_name (keys %$source) {
638 my $source_kid = delete $source->{$kid_name};
640 if (my $dest_kid = $dest->{$kid_name}) {
641 $dest_kid->{count} += $source_kid->{count};
642 $dest_kid->{incl_time} += $source_kid->{incl_time};
643 move_keys($source_kid->{kids},$dest_kid->{kids});
645 $dest->{$kid_name} = $source_kid;
651 my ($curdeep_times, $name, $t) = @_;
652 if ($name ne $curdeep_times->[-1]{name} and $opt_A) {
653 $name = $curdeep_times->[-1]{name};
655 die "Shorted?!" unless @$curdeep_times >= 2;
656 my $entry = $curdeep_times->[-2]{kids}{$name} ||= {
661 # Now transfer to the new node (could not do earlier, since name can change)
663 $entry->{incl_time} += $t - $curdeep_times->[-1]{enter_stamp};
665 move_keys($curdeep_times->[-1]->{kids},$entry->{kids});
671 my( $fh, $names, $calls, $times, $ctimes, $idkeys ) = @_;
673 my( $t, $syst, $realt, $usert );
674 my( $x, $z, $c, $id, $pack );
681 # remember last call depth and function name
688 my $in_level = not defined $opt_g; # Level deep in report grouping
689 my $curdeep_times = [$deep_times];
692 if ( $opt_u ) { $over_per_call = $over_utime }
693 elsif( $opt_s ) { $over_per_call = $over_stime }
694 elsif( $opt_r ) { $over_per_call = $over_rtime }
695 else { $over_per_call = $over_utime + $over_stime }
696 $over_per_call /= 2*$over_tests; # distribute over entry and exit
704 ($dir, $id, $pack, $name) = split;
705 if ($opt_R and ($name =~ /(?:::)?(__ANON__|END)$/)) {
708 $cv_hash{$id} = "$pack\::$name";
711 ($dir, $usert, $syst, $realt, $name) = split;
715 $syst = $stack[-1][0];
718 #warn("Inserted exit for $stack[-1][0].\n")
720 if (defined $realt) { # '+ times nam' '- times nam' or '@ incr'
721 if ( $opt_u ) { $t = $usert }
722 elsif( $opt_s ) { $t = $syst }
723 elsif( $opt_r ) { $t = $realt }
724 else { $t = $usert + $syst }
725 $t += $ot, next if $dir eq '@'; # Increments there
727 # "- id" or "- & name"
728 $name = defined $syst ? $syst : $cv_hash{$usert};
731 next unless $in_level or $name eq $opt_g;
732 if ( $dir eq '-' or $dir eq '*' ) {
733 my $ename = $dir eq '*' ? $stack[-1][0] : $name;
734 $overhead += $over_per_call;
735 if ($name eq "Devel::DProf::write") {
736 $overhead += $t - $dprof_stamp;
738 } elsif (defined $opt_g and $ename eq $opt_g) {
741 add_to_tree($curdeep_times, $ename,
742 $t - $overhead) if $opt_S;
743 exitstamp( \@stack, \@tstack,
745 $times, $ctimes, $ename, \$in, $tab,
746 $curdeep_times, \%outer );
748 next unless $in_level or $name eq $opt_g;
749 if( $dir eq '+' or $dir eq '*' ){
750 if ($name eq "Devel::DProf::write") {
753 } elsif (defined $opt_g and $name eq $opt_g) {
756 $overhead += $over_per_call;
758 print ' ' x $in, "$name\n";
762 # suppress output on same function if the
763 # same calling level is called.
764 if ($l_in == $in and $l_name eq $name) {
767 $repstr = ' ('.++$repcnt.'x)'
769 print ' ' x $l_in, "$l_name$repstr\n"
778 if( ! defined $names->{$name} ){
779 $names->{$name} = $name;
781 $ctimes->{$name} = 0;
782 push( @$idkeys, $name );
786 push @$curdeep_times, { kids => {},
788 enter_stamp => $t - $overhead,
790 $x = [ $name, $t - $overhead ];
793 # my children will put their time here
795 } elsif ($dir ne '-'){
796 die "Bad profile: $_";
800 $repstr = ' ('.++$repcnt.'x)' if $repcnt;
801 print ' ' x $l_in, "$l_name$repstr\n";
804 while (my ($key, $count) = each %outer) {
806 warn "$key has $count unstacked calls in outer\n";
811 warn "Garbled profile is missing some exit time stamps:\n";
812 foreach $x (@stack) {
815 die "Try rerunning dprofpp with -F.\n";
816 # I don't want -F to be default behavior--yet
820 warn( "Faking " . scalar( @stack ) . " exit timestamp(s).\n");
821 foreach $x ( reverse @stack ){
823 exitstamp( \@stack, \@tstack,
824 $t - $overhead, $times,
825 $ctimes, $name, \$in, $tab,
826 $curdeep_times, \%outer );
827 add_to_tree($curdeep_times, $name,
833 if (defined $opt_g) {
834 $runtime = $ctimes->{$opt_g}/$hz;
835 $runtime = 0 unless $runtime > 0;
840 my($stack, $tstack, $t, $times, $ctimes, $name, $in, $tab, $deep, $outer) = @_;
845 die "Garbled profile, missing an enter time stamp";
847 if( $x->[0] ne $name and $opt_G and ($name =~ /$opt_G/)){
848 if ($x->[0] =~ /(?:::)?AUTOLOAD$/) {
853 warn( "Garbled profile, faking exit timestamp:\n\t$name => $x->[0].\n");
856 foreach $z (@stack, $x) {
859 die "Garbled profile, unexpected exit time stamp";
862 if( $opt_T || $opt_t ){
866 $c = pop( @$tstack );
867 # total time this func has been active
869 $ctimes->{$name} += $z
870 unless --$outer->{$name};
871 $times->{$name} += $z - $c;
872 # pass my time to my parent
874 $c = pop( @$tstack );
875 push( @$tstack, $c + $z );
883 if( ! /^#fOrTyTwO$/ ){
884 die "Not a perl profile";
891 $over_tests = 1 unless $over_tests;
892 $time_precision = length int ($hz - 1); # log ;-)
896 # Report avg time-per-function in seconds
898 my( $calls, $times, $persecs, $idkeys ) = @_;
899 my( $x, $t, $n, $key );
901 for( $x = 0; $x < @$idkeys; ++$x ){
902 $key = $idkeys->[$x];
904 $t = $times->{$key} / $hz;
905 $persecs->{$key} = $t ? $t / $n : 0;
910 # Runs the given script with the given profiler and the given perl.
913 my $profiler = shift;
914 my $startperl = shift;
915 my @script_parts = split /\s+/, $script;
917 system $startperl, "-d:$profiler", @script_parts;
919 my $cmd = join ' ', @script_parts;
920 die "Failed: $startperl -d:$profiler $cmd: $!";
925 sub by_time { $times->{$b} <=> $times->{$a} }
926 sub by_ctime { $ctimes->{$b} <=> $ctimes->{$a} }
927 sub by_calls { $calls->{$b} <=> $calls->{$a} }
928 sub by_alpha { $names->{$a} cmp $names->{$b} }
929 sub by_avgcpu { $persecs->{$b} <=> $persecs->{$a} }
931 sub rby_time { $times->{$a} <=> $times->{$b} }
932 sub rby_ctime { $ctimes->{$a} <=> $ctimes->{$b} }
933 sub rby_calls { $calls->{$a} <=> $calls->{$b} }
934 sub rby_alpha { $names->{$b} cmp $names->{$a} }
935 sub rby_avgcpu { $persecs->{$a} <=> $persecs->{$b} }
939 Total Elapsed Time = @>>>>>>> Seconds
940 (($rrun_rtime - $overhead) / $hz)
941 @>>>>>>>>>> Time = @>>>>>>> Seconds
945 %Time ExclSec CumulS #Calls sec/call Csec/c Name
949 my $fmt = ' ^>>> ^>>>> ^>>>>> ^>>>>> ^>>>>> ^>>>>> ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<';
950 if (-t STDOUT and defined $stty and my ($cols) = `$stty -a` =~ /\bcolumns\s+(\d+)/)
952 $fmt .= '<' x ($cols - length $fmt) if $cols > 80;
955 eval "format STAT = \n$fmt" . '
956 $pcnt, $secs, $csecs, $ncalls, $percall, $cpercall, $name
961 close OUT or die "Can't close $file: $!";
962 chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
963 exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';