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";
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<-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]
63 dprofpp B<-T> [B<-F>] [B<-g subroutine>] [profile]
65 dprofpp B<-t> [B<-F>] [B<-g subroutine>] [profile]
67 dprofpp B<-G> <regexp> [B<-P>] [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. The output of dprofpp depends
88 on the flags to the program and the version of Perl you're using.
91 Total Elapsed Time = 1.67 Seconds
92 User Time = 0.61 Seconds
94 %Time Seconds #Calls sec/call Name
95 52.4 0.320 2 0.1600 main::foo
96 45.9 0.280 200 0.0014 main::bar
97 0.00 0.000 1 0.0000 DynaLoader::import
98 0.00 0.000 1 0.0000 main::baz
100 The dprofpp tool can also run the profiler before analyzing the profile
101 data. The above two commands can be executed with one dprofpp command.
103 $ dprofpp -u -p test.pl
105 Consult L<Devel::DProf/"PROFILE FORMAT"> for a description of the raw profile.
115 Percentage of time spent in this routine.
119 Number of calls to this routine.
123 Average number of seconds per call to this routine.
131 Time (in seconds) spent in this routine and routines called from it.
135 Time (in seconds) spent in this routine (not including those called
140 Average time (in seconds) spent in each call of this routine
141 (including those called from it).
151 Sort alphabetically by subroutine names.
155 Reverse whatever sort is used
159 Count timing for autoloaded subroutine as timing for C<*::AUTOLOAD>.
160 Otherwise the time to autoload it is counted as time of the subroutine
161 itself (there is no way to separate autoload time from run time).
163 This is going to be irrelevant with newer Perls. They will inform
164 C<Devel::DProf> I<when> the C<AUTOLOAD> switches to actual subroutine,
165 so a separate statistics for C<AUTOLOAD> will be collected no matter
166 whether this option is set.
170 Count anonymous subroutines defined in the same package separately.
174 (default) Display all subroutine times exclusive of child subroutine times.
178 Force the generation of fake exit timestamps if dprofpp reports that the
179 profile is garbled. This is only useful if dprofpp determines that the
180 profile is garbled due to missing exit timestamps. You're on your own if
181 you do this. Consult the BUGS section.
185 Display all subroutine times inclusive of child subroutine times.
189 Sort by number of calls to the subroutines. This may help identify
190 candidates for inlining.
194 Show only I<cnt> subroutines. The default is 15.
198 Tells dprofpp that it should profile the given script and then interpret its
199 profile data. See B<-Q>.
203 Used with B<-p> to tell dprofpp to quit after profiling the script, without
204 interpreting the data.
208 Do not display column headers.
212 Display elapsed real times rather than user+system times.
216 Display system times rather than user+system times.
220 Display subroutine call tree to stdout. Subroutine statistics are
225 Display subroutine call tree to stdout. Subroutine statistics are not
226 displayed. When a function is called multiple consecutive times at the same
227 calling level then it is displayed once with a repeat count.
231 Display I<merged> subroutine call tree to stdout. Statistics are
232 displayed for each branch of the tree.
234 When a function is called multiple (I<not necessarily consecutive>)
235 times in the same branch then all these calls go into one branch of
236 the next level. A repeat count is output together with combined
237 inclusive, exclusive and kids time.
239 Branches are sorted w.r.t. inclusive time.
243 Do not sort. Display in the order found in the raw profile.
247 Display user times rather than user+system times.
251 Print dprofpp's version number and exit. If a raw profile is found then its
252 XS_VERSION variable will be displayed, too.
256 Sort by average time spent in subroutines during each call. This may help
257 identify candidates for inlining.
261 (default) Sort by amount of user+system time used. The first few lines
262 should show you which subroutines are using the most time.
264 =item B<-g> C<subroutine>
266 Ignore subroutines except C<subroutine> and whatever is called from it.
270 Aggregate "Group" all calls matching the pattern together.
271 For example this can be used to group all calls of a set of packages
273 -G "(package1::)|(package2::)|(package3::)"
275 or to group subroutines by name:
281 Used with -G to aggregate "Pull" together all calls that did not match -G.
285 Filter all calls matching the pattern.
291 The environment variable B<DPROFPP_OPTS> can be set to a string containing
292 options for dprofpp. You might use this if you prefer B<-I> over B<-E> or
293 if you want B<-F> on all the time.
295 This was added fairly lazily, so there are some undesirable side effects.
296 Options on the commandline should override options in DPROFPP_OPTS--but
297 don't count on that in this version.
301 Applications which call _exit() or exec() from within a subroutine
302 will leave an incomplete profile. See the B<-F> option.
304 Any bugs in Devel::DProf, or any profiler generating the profile data, could
305 be visible here. See L<Devel::DProf/BUGS>.
307 Mail bug reports and feature requests to the perl5-porters mailing list at
308 F<E<lt>perl5-porters@perl.orgE<gt>>. Bug reports should include the
309 output of the B<-V> option.
313 dprofpp - profile processor
314 tmon.out - raw profile
318 L<perl>, L<Devel::DProf>, times(2)
322 use Getopt::Std 'getopts';
323 use Config '%Config';
326 my $options = 'O:g:G:Pf:dlzaAvuTtqrRsUFEIp:QVS';
328 $Monfile = 'tmon.out';
329 if( exists $ENV{DPROFPP_OPTS} ){
331 @ARGV = split( ' ', $ENV{DPROFPP_OPTS} );
334 # there was a filename.
342 # there was a filename, it overrides any earlier name.
346 # -O cnt Specifies maximum number of subroutines to display.
347 # -a Sort by alphabetic name of subroutines.
348 # -z Sort by user+system time spent in subroutines. (default)
349 # -l Sort by number of calls to subroutines.
350 # -v Sort by average amount of time spent in subroutines.
352 # -t Show call tree, compressed.
353 # -q Do not print column headers.
354 # -u Use user time rather than user+system time.
355 # -s Use system time rather than user+system time.
356 # -r Use real elapsed time rather than user+system time.
357 # -U Do not sort subroutines.
358 # -E Sub times are reported exclusive of child times. (default)
359 # -I Sub times are reported inclusive of child times.
360 # -V Print dprofpp's version.
361 # -p script Specifies name of script to be profiled.
362 # -Q Used with -p to indicate the dprofpp should quit after
363 # profiling the script, without interpreting the data.
364 # -A count autoloaded to *AUTOLOAD
365 # -R count anonyms separately even if from the same package
366 # -g subr count only those who are SUBR or called from SUBR
367 # -S Create statistics for all the depths
369 # -G Group all calls matching the pattern together.
370 # -P Used with -G to pull all other calls together.
371 # -f Filter all calls mathcing the pattern.
374 if( defined $opt_V ){
376 print "$0 version: $VERSION\n";
377 open( $fh, "<$Monfile" ) && do {
378 local $XS_VERSION = 'early';
381 print "XS_VERSION: $XS_VERSION\n";
387 $sort = 'by_ctime' if defined $opt_I;
388 $sort = 'by_calls' if defined $opt_l;
389 $sort = 'by_alpha' if defined $opt_a;
390 $sort = 'by_avgcpu' if defined $opt_v;
395 $incl_excl = 'Exclusive';
396 $incl_excl = 'Inclusive' if defined $opt_I;
397 $whichtime = 'User+System';
398 $whichtime = 'System' if defined $opt_s;
399 $whichtime = 'Real' if defined $opt_r;
400 $whichtime = 'User' if defined $opt_u;
402 if( defined $opt_p ){
404 my $startperl = $Config{'startperl'};
406 $startperl =~ s/^#!//; # remove shebang
407 run_profiler( $opt_p, $prof, $startperl );
408 $Monfile = 'tmon.out'; # because that's where it is
409 exit(0) if defined $opt_Q;
411 elsif( defined $opt_Q ){
412 die "-Q is meaningful only when used with -p\n";
417 my $monout = $Monfile;
420 local $times = {}; # times in hz
421 local $ctimes = {}; # Cumulative times in hz
423 local $persecs = {}; # times in seconds
425 local $runtime; # runtime in seconds
428 local $rrun_utime = 0; # user time in hz
429 local $rrun_stime = 0; # system time in hz
430 local $rrun_rtime = 0; # elapsed run time in hz
431 local $rrun_ustime = 0; # user+system time in hz
433 local $deep_times = {count => 0 , kids => {}, incl_time => 0};
434 local $time_precision = 2;
437 open( $fh, "<$monout" ) || die "Unable to open $monout\n";
441 $rrun_ustime = $rrun_utime + $rrun_stime;
448 parsestack( $fh, $names, $calls, $times, $ctimes, $idkeys );
452 for(my $i = 0;$i < @$idkeys - 2;){
454 if($key =~ /$opt_f/){
455 splice(@$idkeys, $i, 1);
456 $runtime -= $$times{$key};
464 group($names, $calls, $times, $ctimes, $idkeys );
467 settime( \$runtime, $hz ) unless $opt_g;
469 exit(0) if $opt_T || $opt_t;
472 percalc( $calls, ($opt_I ? $ctimes : $times), $persecs, $idkeys );
475 @a = sort $sort @$idkeys;
481 display( $runtime, $hz, $names, $calls, $times, $ctimes, $cnt, $a,
486 my ($names, $calls, $times, $ctimes, $idkeys ) = @_;
487 print "Option G Grouping: [$opt_G]\n";
488 # create entries to store grouping
489 $$names{$opt_G} = $opt_G;
492 $$ctimes{$opt_G} = 0;
493 $$idkeys[@$idkeys] = $opt_G;
494 # Sum calls for the grouping
498 $$names{$other} = $other;
501 $$ctimes{$other} = 0;
502 $$idkeys[@$idkeys] = $other;
505 for(my $i = 0;$i < @$idkeys - 2;){
507 if($key =~ /$opt_G/){
508 $$calls{$opt_G} += $$calls{$key};
509 $$times{$opt_G} += $$times{$key};
510 $$ctimes{$opt_G} += $$ctimes{$key};
511 splice(@$idkeys, $i, 1);
515 $$calls{$other} += $$calls{$key};
516 $$times{$other} += $$times{$key};
517 $$ctimes{$other} += $$ctimes{$key};
518 splice(@$idkeys, $i, 1);
524 print "Grouping [$opt_G] Calls: [$$calls{$opt_G}]\n".
525 "Grouping [$opt_G] Times: [$$times{$opt_G}]\n".
526 "Grouping [$opt_G] IncTimes: [$$ctimes{$opt_G}]\n";
529 # Sets $runtime to user, system, real, or user+system time. The
530 # result is given in seconds.
533 my( $runtime, $hz ) = @_;
538 $$runtime = ($rrun_rtime - $overhead - $over_rtime * $total_marks/$over_tests/2)/$hz;
541 $$runtime = ($rrun_stime - $overhead - $over_stime * $total_marks/$over_tests/2)/$hz;
544 $$runtime = ($rrun_utime - $overhead - $over_utime * $total_marks/$over_tests/2)/$hz;
547 $$runtime = ($rrun_ustime - $overhead - ($over_utime + $over_stime) * $total_marks/$over_tests/2)/$hz;
549 $$runtime = 0 unless $$runtime > 0;
552 sub exclusives_in_tree {
553 my( $deep_times ) = @_;
556 # When summing, take into account non-rounded-up kids time.
557 for $kid (keys %{$deep_times->{kids}}) {
558 $kids_time += $deep_times->{kids}{$kid}{incl_time};
560 $kids_time = 0 unless $kids_time >= 0;
561 $deep_times->{excl_time} = $deep_times->{incl_time} - $kids_time;
562 $deep_times->{excl_time} = 0 unless $deep_times->{excl_time} >= 0;
563 for $kid (keys %{$deep_times->{kids}}) {
564 exclusives_in_tree($deep_times->{kids}{$kid});
566 $deep_times->{incl_time} = 0 unless $deep_times->{incl_time} >= 0;
567 $deep_times->{kids_time} = $kids_time;
570 sub kids_by_incl { $kids{$b}{incl_time} <=> $kids{$a}{excl_time}
574 my( $deep_times, $name, $level ) = @_;
575 exclusives_in_tree($deep_times);
578 local *kids = $deep_times->{kids}; # %kids
582 $time = sprintf '%.*fs = (%.*f + %.*f)',
583 $time_precision, $deep_times->{incl_time}/$hz,
584 $time_precision, $deep_times->{excl_time}/$hz,
585 $time_precision, $deep_times->{kids_time}/$hz;
587 $time = sprintf '%.*f', $time_precision, $deep_times->{incl_time}/$hz;
589 print ' ' x (2*$level), "$name x $deep_times->{count} \t${time}s\n"
590 if $deep_times->{count};
592 for $kid (sort kids_by_incl keys %kids) {
593 display_tree( $deep_times->{kids}{$kid}, $kid, $level + 1 );
597 # Report the times in seconds.
599 my( $runtime, $hz, $names, $calls, $times, $ctimes, $cnt,
600 $idkeys, $deep_times ) = @_;
601 my( $x, $key, $s, $cs );
602 #format: $ncalls, $name, $secs, $percall, $pcnt
605 display_tree( $deep_times, 'toplevel', -1 )
607 for( $x = 0; $x < @$idkeys; ++$x ){
608 $key = $idkeys->[$x];
609 $ncalls = $calls->{$key};
610 $name = $names->{$key};
611 $s = $times->{$key}/$hz;
612 $secs = sprintf("%.3f", $s );
613 $cs = $ctimes->{$key}/$hz;
614 $csecs = sprintf("%.3f", $cs );
615 $percall = sprintf("%.4f", $s/$ncalls );
616 $cpercall = sprintf("%.4f", $cs/$ncalls );
617 $pcnt = sprintf("%.2f",
618 $runtime? ((($opt_I ? $csecs : $secs) / $runtime) * 100.0): 0 );
620 $pcnt = $secs = $ncalls = $percall = "";
621 write while( length $name );
628 my ($source, $dest) = @_;
631 for $kid (keys %$source) {
632 if (exists $dest->{$kid}) {
633 $dest->{count} += $source->{count};
634 $dest->{incl_time} += $source->{incl_time};
635 move_keys($source->{kids},$dest->{kids});
637 $dest->{$kid} = delete $source->{$kid};
643 my ($curdeep_times, $name, $t) = @_;
644 if ($name ne $curdeep_times->[-1]{name} and $opt_A) {
645 $name = $curdeep_times->[-1]{name};
647 die "Shorted?!" unless @$curdeep_times >= 2;
648 $curdeep_times->[-2]{kids}{$name} = { count => 0 , kids => {},
651 unless exists $curdeep_times->[-2]{kids}{$name};
652 my $entry = $curdeep_times->[-2]{kids}{$name};
653 # Now transfer to the new node (could not do earlier, since name can change)
655 $entry->{incl_time} += $t - $curdeep_times->[-1]{enter_stamp};
657 move_keys($curdeep_times->[-1]->{kids},$entry->{kids});
663 my( $fh, $names, $calls, $times, $ctimes, $idkeys ) = @_;
665 my( $t, $syst, $realt, $usert );
666 my( $x, $z, $c, $id, $pack );
672 # remember last call depth and function name
680 my $in_level = not defined $opt_g; # Level deep in report grouping
681 my $curdeep_times = [$deep_times];
684 if ( $opt_u ) { $over_per_call = $over_utime }
685 elsif( $opt_s ) { $over_per_call = $over_stime }
686 elsif( $opt_r ) { $over_per_call = $over_rtime }
687 else { $over_per_call = $over_utime + $over_stime }
688 $over_per_call /= 2*$over_tests; # distribute over entry and exit
696 ($dir, $id, $pack, $name) = split;
697 if ($opt_R and ($name =~ /(?:::)?(__ANON__|END)$/)) {
700 $cv_hash{$id} = "$pack\::$name";
703 ($dir, $usert, $syst, $realt, $name) = split;
707 $syst = $stack[-1][0];
710 #warn("Inserted exit for $stack[-1][0].\n")
712 if (defined $realt) { # '+ times nam' '- times nam' or '@ incr'
713 if ( $opt_u ) { $t = $usert }
714 elsif( $opt_s ) { $t = $syst }
715 elsif( $opt_r ) { $t = $realt }
716 else { $t = $usert + $syst }
717 $t += $ot, next if $dir eq '@'; # Increments there
719 # "- id" or "- & name"
720 $name = defined $syst ? $syst : $cv_hash{$usert};
723 next unless $in_level or $name eq $opt_g or $dir eq '*';
724 if ( $dir eq '-' or $dir eq '*' ) {
725 my $ename = $dir eq '*' ? $stack[-1][0] : $name;
726 $overhead += $over_per_call;
727 if ($name eq "Devel::DProf::write") {
728 $dprof_t += $t - $dprof_stamp;
730 } elsif (defined $opt_g and $ename eq $opt_g) {
733 add_to_tree($curdeep_times, $ename,
734 $t - $dprof_t - $overhead) if $opt_S;
735 exitstamp( \@stack, \@tstack,
736 $t - $dprof_t - $overhead,
737 $times, $ctimes, $ename, \$in, $tab,
740 next unless $in_level or $name eq $opt_g;
741 if( $dir eq '+' or $dir eq '*' ){
742 if ($name eq "Devel::DProf::write") {
745 } elsif (defined $opt_g and $name eq $opt_g) {
748 $overhead += $over_per_call;
750 print ' ' x $in, "$name\n";
754 # suppress output on same function if the
755 # same calling level is called.
756 if ($l_in == $in and $l_name eq $name) {
759 $repstr = ' ('.++$repcnt.'x)'
761 print ' ' x $l_in, "$l_name$repstr\n"
770 if( ! defined $names->{$name} ){
771 $names->{$name} = $name;
773 $ctimes->{$name} = 0;
774 push( @$idkeys, $name );
777 push @$curdeep_times, { kids => {},
779 enter_stamp => $t - $dprof_t - $overhead,
781 $x = [ $name, $t - $dprof_t - $overhead ];
784 # my children will put their time here
786 } elsif ($dir ne '-'){
787 die "Bad profile: $_";
791 $repstr = ' ('.++$repcnt.'x)' if $repcnt;
792 print ' ' x $l_in, "$l_name$repstr\n";
797 warn "Garbled profile is missing some exit time stamps:\n";
798 foreach $x (@stack) {
801 die "Try rerunning dprofpp with -F.\n";
802 # I don't want -F to be default behavior--yet
806 warn( "Faking " . scalar( @stack ) . " exit timestamp(s).\n");
807 foreach $x ( reverse @stack ){
809 exitstamp( \@stack, \@tstack,
810 $t - $dprof_t - $overhead, $times,
811 $ctimes, $name, \$in, $tab,
813 add_to_tree($curdeep_times, $name,
814 $t - $dprof_t - $overhead)
819 if (defined $opt_g) {
820 $runtime = $ctimes->{$opt_g}/$hz;
821 $runtime = 0 unless $runtime > 0;
826 my($stack, $tstack, $t, $times, $ctimes, $name, $in, $tab, $deep) = @_;
831 die "Garbled profile, missing an enter time stamp";
833 if( $x->[0] ne $name and $opt_G and ($name =~ /$opt_G/)){
834 if ($x->[0] =~ /(?:::)?AUTOLOAD$/) {
839 warn( "Garbled profile, faking exit timestamp:\n\t$name => $x->[0].\n");
842 foreach $z (@stack, $x) {
845 die "Garbled profile, unexpected exit time stamp";
848 if( $opt_T || $opt_t ){
852 $c = pop( @$tstack );
853 # total time this func has been active
855 $ctimes->{$name} += $z;
856 $times->{$name} += ($z > $c)? $z - $c: 0;
857 # pass my time to my parent
859 $c = pop( @$tstack );
860 push( @$tstack, $c + $z );
868 if( ! /^#fOrTyTwO$/ ){
869 die "Not a perl profile";
876 $over_tests = 1 unless $over_tests;
877 $time_precision = length int ($hz - 1); # log ;-)
881 # Report avg time-per-function in seconds
883 my( $calls, $times, $persecs, $idkeys ) = @_;
884 my( $x, $t, $n, $key );
886 for( $x = 0; $x < @$idkeys; ++$x ){
887 $key = $idkeys->[$x];
889 $t = $times->{$key} / $hz;
890 $persecs->{$key} = $t ? $t / $n : 0;
895 # Runs the given script with the given profiler and the given perl.
898 my $profiler = shift;
899 my $startperl = shift;
900 my @script_parts = split /\s+/, $script;
902 system $startperl, "-d:$profiler", @script_parts;
904 my $cmd = join ' ', @script_parts;
905 die "Failed: $startperl -d:$profiler $cmd: $!";
910 sub by_time { $times->{$b} <=> $times->{$a} }
911 sub by_ctime { $ctimes->{$b} <=> $ctimes->{$a} }
912 sub by_calls { $calls->{$b} <=> $calls->{$a} }
913 sub by_alpha { $names->{$a} cmp $names->{$b} }
914 sub by_avgcpu { $persecs->{$b} <=> $persecs->{$a} }
916 sub rby_time { $times->{$a} <=> $times->{$b} }
917 sub rby_ctime { $ctimes->{$a} <=> $ctimes->{$b} }
918 sub rby_calls { $calls->{$a} <=> $calls->{$b} }
919 sub rby_alpha { $names->{$b} cmp $names->{$a} }
920 sub rby_avgcpu { $persecs->{$a} <=> $persecs->{$b} }
924 Total Elapsed Time = @>>>>>>> Seconds
925 (($rrun_rtime - $overhead - $over_rtime * $total_marks/$over_tests/2) / $hz)
926 @>>>>>>>>>> Time = @>>>>>>> Seconds
930 %Time ExclSec CumulS #Calls sec/call Csec/c Name
934 ^>>> ^>>>> ^>>>>> ^>>>>> ^>>>>> ^>>>>> ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
935 $pcnt, $secs, $csecs, $ncalls, $percall, $cpercall, $name
940 close OUT or die "Can't close $file: $!";
941 chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
942 exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';