source: trunk/essentials/dev-lang/perl/utils/dprofpp.PL@ 3951

Last change on this file since 3951 was 3181, checked in by bird, 19 years ago

perl 5.8.8
File size: 25.1 KB
Line 
1#!/usr/local/bin/perl
2
3use Config;
4use File::Basename qw(&basename &dirname);
5use File::Spec;
6
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
11# $startperl
12# to ensure Configure will look for $Config{startperl}.
13
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.
16chdir(dirname($0));
17($file = basename($0)) =~ s/\.PL$//i;
18$file .= '.COM' if ($^O eq 'VMS');
19
20my $dprof_pm = File::Spec->catfile(File::Spec->updir, 'ext', 'Devel', 'DProf', 'DProf.pm');
21my $VERSION = 0;
22open( PM, "<$dprof_pm" ) || die "Can't open $dprof_pm: $!";
23while(<PM>){
24 if( /^\$Devel::DProf::VERSION\s*=\s*'([\d._]+)'/ ){
25 $VERSION = $1;
26 last;
27 }
28}
29close PM;
30if( $VERSION == 0 ){
31 die "Did not find VERSION in $dprof_pm";
32}
33my $stty = 'undef';
34foreach my $s (qw(/bin/stty /usr/bin/stty)) {
35 if (-x $s) {
36 $stty = qq["$s"];
37 last;
38 }
39}
40open OUT,">$file" or die "Can't create $file: $!";
41
42print "Extracting $file (with variable substitutions)\n";
43
44# In this section, perl variables will be expanded during extraction.
45# You can use $Config{...} to use Configure variables.
46
47print OUT <<"!GROK!THIS!";
48$Config{'startperl'}
49 eval 'exec perl -S \$0 "\$@"'
50 if 0;
51
52require 5.003;
53
54my \$VERSION = '$VERSION';
55my \$stty = $stty;
56
57!GROK!THIS!
58
59# In the following, perl variables are not expanded during extraction.
60
61print OUT <<'!NO!SUBS!';
62=head1 NAME
63
64dprofpp - display perl profile data
65
66=head1 SYNOPSIS
67
68dprofpp [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]
69
70dprofpp B<-T> [B<-F>] [B<-g subroutine>] [profile]
71
72dprofpp B<-t> [B<-F>] [B<-g subroutine>] [profile]
73
74dprofpp B<-G> <regexp> [B<-P>] [profile]
75
76dprofpp B<-p script> [B<-Q>] [other opts]
77
78dprofpp B<-V> [profile]
79
80=head1 DESCRIPTION
81
82The I<dprofpp> command interprets profile data produced by a profiler, such
83as the Devel::DProf profiler. Dprofpp will read the file F<tmon.out> and
84display the 15 subroutines which are using the most time. By default
85the times for each subroutine are given exclusive of the times of their
86child subroutines.
87
88To profile a Perl script run the perl interpreter with the B<-d> switch. So
89to profile script F<test.pl> with Devel::DProf use the following:
90
91 $ perl5 -d:DProf test.pl
92
93Then run dprofpp to analyze the profile. The output of dprofpp depends
94on the flags to the program and the version of Perl you're using.
95
96 $ dprofpp -u
97 Total Elapsed Time = 1.67 Seconds
98 User Time = 0.61 Seconds
99 Exclusive Times
100 %Time Seconds #Calls sec/call Name
101 52.4 0.320 2 0.1600 main::foo
102 45.9 0.280 200 0.0014 main::bar
103 0.00 0.000 1 0.0000 DynaLoader::import
104 0.00 0.000 1 0.0000 main::baz
105
106The dprofpp tool can also run the profiler before analyzing the profile
107data. The above two commands can be executed with one dprofpp command.
108
109 $ dprofpp -u -p test.pl
110
111Consult L<Devel::DProf/"PROFILE FORMAT"> for a description of the raw profile.
112
113=head1 OUTPUT
114
115Columns are:
116
117=over 4
118
119=item %Time
120
121Percentage of time spent in this routine.
122
123=item #Calls
124
125Number of calls to this routine.
126
127=item sec/call
128
129Average number of seconds per call to this routine.
130
131=item Name
132
133Name of routine.
134
135=item CumulS
136
137Time (in seconds) spent in this routine and routines called from it.
138
139=item ExclSec
140
141Time (in seconds) spent in this routine (not including those called
142from it).
143
144=item Csec/c
145
146Average time (in seconds) spent in each call of this routine
147(including those called from it).
148
149=back
150
151=head1 OPTIONS
152
153=over 5
154
155=item B<-a>
156
157Sort alphabetically by subroutine names.
158
159=item B<-d>
160
161Reverse whatever sort is used
162
163=item B<-A>
164
165Count timing for autoloaded subroutine as timing for C<*::AUTOLOAD>.
166Otherwise the time to autoload it is counted as time of the subroutine
167itself (there is no way to separate autoload time from run time).
168
169This is going to be irrelevant with newer Perls. They will inform
170C<Devel::DProf> I<when> the C<AUTOLOAD> switches to actual subroutine,
171so a separate statistics for C<AUTOLOAD> will be collected no matter
172whether this option is set.
173
174=item B<-R>
175
176Count anonymous subroutines defined in the same package separately.
177
178=item B<-E>
179
180(default) Display all subroutine times exclusive of child subroutine times.
181
182=item B<-F>
183
184Force the generation of fake exit timestamps if dprofpp reports that the
185profile is garbled. This is only useful if dprofpp determines that the
186profile is garbled due to missing exit timestamps. You're on your own if
187you do this. Consult the BUGS section.
188
189=item B<-I>
190
191Display all subroutine times inclusive of child subroutine times.
192
193=item B<-l>
194
195Sort by number of calls to the subroutines. This may help identify
196candidates for inlining.
197
198=item B<-O cnt>
199
200Show only I<cnt> subroutines. The default is 15.
201
202=item B<-p script>
203
204Tells dprofpp that it should profile the given script and then interpret its
205profile data. See B<-Q>.
206
207=item B<-Q>
208
209Used with B<-p> to tell dprofpp to quit after profiling the script, without
210interpreting the data.
211
212=item B<-q>
213
214Do not display column headers.
215
216=item B<-r>
217
218Display elapsed real times rather than user+system times.
219
220=item B<-s>
221
222Display system times rather than user+system times.
223
224=item B<-T>
225
226Display subroutine call tree to stdout. Subroutine statistics are
227not displayed.
228
229=item B<-t>
230
231Display subroutine call tree to stdout. Subroutine statistics are not
232displayed. When a function is called multiple consecutive times at the same
233calling level then it is displayed once with a repeat count.
234
235=item B<-S>
236
237Display I<merged> subroutine call tree to stdout. Statistics are
238displayed for each branch of the tree.
239
240When a function is called multiple (I<not necessarily consecutive>)
241times in the same branch then all these calls go into one branch of
242the next level. A repeat count is output together with combined
243inclusive, exclusive and kids time.
244
245Branches are sorted with regard to inclusive time.
246
247=item B<-U>
248
249Do not sort. Display in the order found in the raw profile.
250
251=item B<-u>
252
253Display user times rather than user+system times.
254
255=item B<-V>
256
257Print dprofpp's version number and exit. If a raw profile is found then its
258XS_VERSION variable will be displayed, too.
259
260=item B<-v>
261
262Sort by average time spent in subroutines during each call. This may help
263identify candidates for inlining.
264
265=item B<-z>
266
267(default) Sort by amount of user+system time used. The first few lines
268should show you which subroutines are using the most time.
269
270=item B<-g> C<subroutine>
271
272Ignore subroutines except C<subroutine> and whatever is called from it.
273
274=item B<-G> <regexp>
275
276Aggregate "Group" all calls matching the pattern together.
277For example this can be used to group all calls of a set of packages
278
279 -G "(package1::)|(package2::)|(package3::)"
280
281or to group subroutines by name:
282
283 -G "getNum"
284
285=item B<-P>
286
287Used with -G to aggregate "Pull" together all calls that did not match -G.
288
289=item B<-f> <regexp>
290
291Filter all calls matching the pattern.
292
293=item B<-h>
294
295Display brief help and exit.
296
297=item B<-H>
298
299Display long help and exit.
300
301=back
302
303=head1 ENVIRONMENT
304
305The environment variable B<DPROFPP_OPTS> can be set to a string containing
306options for dprofpp. You might use this if you prefer B<-I> over B<-E> or
307if you want B<-F> on all the time.
308
309This was added fairly lazily, so there are some undesirable side effects.
310Options on the commandline should override options in DPROFPP_OPTS--but
311don't count on that in this version.
312
313=head1 BUGS
314
315Applications which call _exit() or exec() from within a subroutine
316will leave an incomplete profile. See the B<-F> option.
317
318Any bugs in Devel::DProf, or any profiler generating the profile data, could
319be visible here. See L<Devel::DProf/BUGS>.
320
321Mail bug reports and feature requests to the perl5-porters mailing list at
322F<E<lt>[email protected]<gt>>. Bug reports should include the
323output of the B<-V> option.
324
325=head1 FILES
326
327 dprofpp - profile processor
328 tmon.out - raw profile
329
330=head1 SEE ALSO
331
332L<perl>, L<Devel::DProf>, times(2)
333
334=cut
335
336sub shortusage {
337 print <<'EOF';
338dprofpp [options] [profile]
339
340 -A Count autoloaded to *AUTOLOAD
341 -a Sort by alphabetic name of subroutines.
342 -d Reverse sort
343 -E Sub times are reported exclusive of child times. (default)
344 -f Filter all calls mathcing the pattern.
345 -G Group all calls matching the pattern together.
346 -g subr Count only those who are SUBR or called from SUBR
347 -H Display long manual page.
348 -h Display this short usage message.
349 -I Sub times are reported inclusive of child times.
350 -l Sort by number of calls to subroutines.
351 -O cnt Specifies maximum number of subroutines to display.
352 -P Used with -G to pull all other calls together.
353 -p script Specifies name of script to be profiled.
354 -Q Used with -p to indicate the dprofpp should quit
355 after profiling the script, without interpreting the data.
356 -q Do not print column headers.
357 -R Count anonyms separately even if from the same package
358 -r Use real elapsed time rather than user+system time.
359 -S Create statistics for all the depths
360 -s Use system time rather than user+system time.
361 -T Show call tree.
362 -t Show call tree, compressed.
363 -U Do not sort subroutines.
364 -u Use user time rather than user+system time.
365 -V Print dprofpp's version.
366 -v Sort by average amount of time spent in subroutines.
367 -z Sort by user+system time spent in subroutines. (default)
368EOF
369}
370
371use Getopt::Std 'getopts';
372use Config '%Config';
373
374Setup: {
375 my $options = 'O:g:G:Pf:dlzaAvuTtqrRsUFEIp:QVShH';
376
377 $Monfile = 'tmon.out';
378 if( exists $ENV{DPROFPP_OPTS} ){
379 my @tmpargv = @ARGV;
380 @ARGV = split( ' ', $ENV{DPROFPP_OPTS} );
381 getopts( $options );
382 if( @ARGV ){
383 # there was a filename.
384 $Monfile = shift;
385 }
386 @ARGV = @tmpargv;
387 }
388
389 getopts( $options ) or die "Try 'dprofpp -h' for help.\n";
390 if( @ARGV ){
391 # there was a filename, it overrides any earlier name.
392 $Monfile = shift;
393 }
394
395 if ( defined $opt_h ) {
396 shortusage();
397 exit;
398 }
399 if ( defined $opt_H ) {
400 require Pod::Usage;
401 Pod::Usage::pod2usage( {-verbose => 2, -input => $0 } );
402 exit;
403 }
404
405 if( defined $opt_V ){
406 my $fh = 'main::fh';
407 print "$0 version: $VERSION\n";
408 open( $fh, "<$Monfile" ) && do {
409 local $XS_VERSION = 'early';
410 header($fh);
411 close( $fh );
412 print "XS_VERSION: $XS_VERSION\n";
413 };
414 exit(0);
415 }
416 $cnt = $opt_O || 15;
417 $sort = 'by_time';
418 $sort = 'by_ctime' if defined $opt_I;
419 $sort = 'by_calls' if defined $opt_l;
420 $sort = 'by_alpha' if defined $opt_a;
421 $sort = 'by_avgcpu' if defined $opt_v;
422
423 if(defined $opt_d){
424 $sort = "r".$sort;
425 }
426 $incl_excl = 'Exclusive';
427 $incl_excl = 'Inclusive' if defined $opt_I;
428 $whichtime = 'User+System';
429 $whichtime = 'System' if defined $opt_s;
430 $whichtime = 'Real' if defined $opt_r;
431 $whichtime = 'User' if defined $opt_u;
432
433 if( defined $opt_p ){
434 my $prof = 'DProf';
435 my $startperl = $Config{'startperl'};
436
437 $startperl =~ s/^#!//; # remove shebang
438 run_profiler( $opt_p, $prof, $startperl );
439 $Monfile = 'tmon.out'; # because that's where it is
440 exit(0) if defined $opt_Q;
441 }
442 elsif( defined $opt_Q ){
443 die "-Q is meaningful only when used with -p\n";
444 }
445}
446
447Main: {
448 my $monout = $Monfile;
449 my $fh = 'main::fh';
450 local $names = {};
451 local $times = {}; # times in hz
452 local $ctimes = {}; # Cumulative times in hz
453 local $calls = {};
454 local $persecs = {}; # times in seconds
455 local $idkeys = [];
456 local $runtime; # runtime in seconds
457 my @a = ();
458 my $a;
459 local $rrun_utime = 0; # user time in hz
460 local $rrun_stime = 0; # system time in hz
461 local $rrun_rtime = 0; # elapsed run time in hz
462 local $rrun_ustime = 0; # user+system time in hz
463 local $hz = 0;
464 local $deep_times = {count => 0 , kids => {}, incl_time => 0};
465 local $time_precision = 2;
466 local $overhead = 0;
467
468 open( $fh, "<$monout" ) || die "Unable to open $monout\n";
469
470 header($fh);
471
472 $rrun_ustime = $rrun_utime + $rrun_stime;
473
474 $~ = 'STAT';
475 if( ! $opt_q ){
476 $^ = 'CSTAT_top';
477 }
478
479 parsestack( $fh, $names, $calls, $times, $ctimes, $idkeys );
480
481 #filter calls
482 if( $opt_f ){
483 for(my $i = 0;$i < @$idkeys - 2;){
484 $key = $$idkeys[$i];
485 if($key =~ /$opt_f/){
486 splice(@$idkeys, $i, 1);
487 $runtime -= $$times{$key};
488 next;
489 }
490 $i++;
491 }
492 }
493
494 if( $opt_G ){
495 group($names, $calls, $times, $ctimes, $idkeys );
496 }
497
498 settime( \$runtime, $hz ) unless $opt_g;
499
500 exit(0) if $opt_T || $opt_t;
501
502 if( $opt_v ){
503 percalc( $calls, ($opt_I ? $ctimes : $times), $persecs, $idkeys );
504 }
505 if( ! $opt_U ){
506 @a = sort $sort @$idkeys;
507 $a = \@a;
508 }
509 else {
510 $a = $idkeys;
511 }
512 display( $runtime, $hz, $names, $calls, $times, $ctimes, $cnt, $a,
513 $deep_times);
514}
515
516sub group{
517 my ($names, $calls, $times, $ctimes, $idkeys ) = @_;
518 print "Option G Grouping: [$opt_G]\n";
519 # create entries to store grouping
520 $$names{$opt_G} = $opt_G;
521 $$calls{$opt_G} = 0;
522 $$times{$opt_G} = 0;
523 $$ctimes{$opt_G} = 0;
524 $$idkeys[@$idkeys] = $opt_G;
525 # Sum calls for the grouping
526
527 my $other = "other";
528 if($opt_P){
529 $$names{$other} = $other;
530 $$calls{$other} = 0;
531 $$times{$other} = 0;
532 $$ctimes{$other} = 0;
533 $$idkeys[@$idkeys] = $other;
534 }
535
536 for(my $i = 0;$i < @$idkeys - 2;){
537 $key = $$idkeys[$i];
538 if($key =~ /$opt_G/){
539 $$calls{$opt_G} += $$calls{$key};
540 $$times{$opt_G} += $$times{$key};
541 $$ctimes{$opt_G} += $$ctimes{$key};
542 splice(@$idkeys, $i, 1);
543 next;
544 }else{
545 if($opt_P){
546 $$calls{$other} += $$calls{$key};
547 $$times{$other} += $$times{$key};
548 $$ctimes{$other} += $$ctimes{$key};
549 splice(@$idkeys, $i, 1);
550 next;
551 }
552 }
553 $i++;
554 }
555 print "Grouping [$opt_G] Calls: [$$calls{$opt_G}]\n".
556 "Grouping [$opt_G] Times: [$$times{$opt_G}]\n".
557 "Grouping [$opt_G] IncTimes: [$$ctimes{$opt_G}]\n";
558}
559
560# Sets $runtime to user, system, real, or user+system time. The
561# result is given in seconds.
562#
563sub settime {
564 my( $runtime, $hz ) = @_;
565
566 $hz ||= 1;
567
568 if( $opt_r ){
569 $$runtime = ($rrun_rtime - $overhead)/$hz;
570 }
571 elsif( $opt_s ){
572 $$runtime = ($rrun_stime - $overhead)/$hz;
573 }
574 elsif( $opt_u ){
575 $$runtime = ($rrun_utime - $overhead)/$hz;
576 }
577 else{
578 $$runtime = ($rrun_ustime - $overhead)/$hz;
579 }
580 $$runtime = 0 unless $$runtime > 0;
581}
582
583sub exclusives_in_tree {
584 my( $deep_times ) = @_;
585 my $kids_time = 0;
586 my $kid;
587 # When summing, take into account non-rounded-up kids time.
588 for $kid (keys %{$deep_times->{kids}}) {
589 $kids_time += $deep_times->{kids}{$kid}{incl_time};
590 }
591 $kids_time = 0 unless $kids_time >= 0;
592 $deep_times->{excl_time} = $deep_times->{incl_time} - $kids_time;
593 $deep_times->{excl_time} = 0 unless $deep_times->{excl_time} >= 0;
594 for $kid (keys %{$deep_times->{kids}}) {
595 exclusives_in_tree($deep_times->{kids}{$kid});
596 }
597 $deep_times->{incl_time} = 0 unless $deep_times->{incl_time} >= 0;
598 $deep_times->{kids_time} = $kids_time;
599}
600
601sub kids_by_incl { $kids{$b}{incl_time} <=> $kids{$a}{excl_time}
602 or $a cmp $b }
603
604sub display_tree {
605 my( $deep_times, $name, $level ) = @_;
606 exclusives_in_tree($deep_times);
607
608 my $kid;
609
610 my $time;
611 if (%{$deep_times->{kids}}) {
612 $time = sprintf '%.*fs = (%.*f + %.*f)',
613 $time_precision, $deep_times->{incl_time}/$hz,
614 $time_precision, $deep_times->{excl_time}/$hz,
615 $time_precision, $deep_times->{kids_time}/$hz;
616 } else {
617 $time = sprintf '%.*f', $time_precision, $deep_times->{incl_time}/$hz;
618 }
619 print ' ' x (2*$level), "$name x $deep_times->{count} \t${time}s\n"
620 if $deep_times->{count};
621
622 for $kid (sort kids_by_incl %{$deep_times->{kids}}) {
623 display_tree( $deep_times->{kids}{$kid}, $kid, $level + 1 );
624 }
625}
626
627# Report the times in seconds.
628sub display {
629 my( $runtime, $hz, $names, $calls, $times, $ctimes, $cnt,
630 $idkeys, $deep_times ) = @_;
631 my( $x, $key, $s, $cs );
632 #format: $ncalls, $name, $secs, $percall, $pcnt
633
634 if ($opt_S) {
635 display_tree( $deep_times, 'toplevel', -1 )
636 } else {
637 for( $x = 0; $x < @$idkeys; ++$x ){
638 $key = $idkeys->[$x];
639 $ncalls = $calls->{$key};
640 $name = $names->{$key};
641 $s = $times->{$key}/$hz;
642 $secs = sprintf("%.3f", $s );
643 $cs = $ctimes->{$key}/$hz;
644 $csecs = sprintf("%.3f", $cs );
645 $percall = sprintf("%.4f", $s/$ncalls );
646 $cpercall = sprintf("%.4f", $cs/$ncalls );
647 $pcnt = sprintf("%.2f",
648 $runtime? ((($opt_I ? $csecs : $secs) / $runtime) * 100.0): 0 );
649 write;
650 $pcnt = $secs = $ncalls = $percall = "";
651 write while( length $name );
652 last unless --$cnt;
653 }
654 }
655}
656
657sub move_keys {
658 my ($source, $dest) = @_;
659
660 for my $kid_name (keys %$source) {
661 my $source_kid = delete $source->{$kid_name};
662
663 if (my $dest_kid = $dest->{$kid_name}) {
664 $dest_kid->{count} += $source_kid->{count};
665 $dest_kid->{incl_time} += $source_kid->{incl_time};
666 move_keys($source_kid->{kids},$dest_kid->{kids});
667 } else {
668 $dest->{$kid_name} = $source_kid;
669 }
670 }
671}
672
673sub add_to_tree {
674 my ($curdeep_times, $name, $t) = @_;
675 if ($name ne $curdeep_times->[-1]{name} and $opt_A) {
676 $name = $curdeep_times->[-1]{name};
677 }
678 die "Shorted?!" unless @$curdeep_times >= 2;
679 my $entry = $curdeep_times->[-2]{kids}{$name} ||= {
680 count => 0,
681 kids => {},
682 incl_time => 0,
683 };
684 # Now transfer to the new node (could not do earlier, since name can change)
685 $entry->{count}++;
686 $entry->{incl_time} += $t - $curdeep_times->[-1]{enter_stamp};
687 # Merge the kids?
688 move_keys($curdeep_times->[-1]->{kids},$entry->{kids});
689 pop @$curdeep_times;
690}
691
692
693sub parsestack {
694 my( $fh, $names, $calls, $times, $ctimes, $idkeys ) = @_;
695 my( $dir, $name );
696 my( $t, $syst, $realt, $usert );
697 my( $x, $z, $c, $id, $pack );
698 my @stack = ();
699 my @tstack = ();
700 my %outer;
701 my $tab = 3;
702 my $in = 0;
703
704 # remember last call depth and function name
705 my $l_in = $in;
706 my $l_name = '';
707 my $repcnt = 0;
708 my $repstr = '';
709 my $dprof_stamp;
710 my %cv_hash;
711 my $in_level = not defined $opt_g; # Level deep in report grouping
712 my $curdeep_times = [$deep_times];
713
714 my $over_per_call;
715 if ( $opt_u ) { $over_per_call = $over_utime }
716 elsif( $opt_s ) { $over_per_call = $over_stime }
717 elsif( $opt_r ) { $over_per_call = $over_rtime }
718 else { $over_per_call = $over_utime + $over_stime }
719 $over_per_call /= 2*$over_tests; # distribute over entry and exit
720
721 while(<$fh>){
722 next if /^#/;
723 last if /^PART/;
724
725 chop;
726 if (/^&/) {
727 ($dir, $id, $pack, $name) = split;
728 if ($opt_R and ($name =~ /(?:::)?(__ANON__|END)$/)) {
729 $name .= "($id)";
730 }
731 $cv_hash{$id} = "$pack\::$name";
732 next;
733 }
734 ($dir, $usert, $syst, $realt, $name) = split;
735
736 my $ot = $t;
737 if ( $dir eq '/' ) {
738 $syst = $stack[-1][0] if scalar @stack;
739 $usert = '&';
740 $dir = '-';
741 #warn("Inserted exit for $stack[-1][0].\n")
742 }
743 if (defined $realt) { # '+ times nam' '- times nam' or '@ incr'
744 if ( $opt_u ) { $t = $usert }
745 elsif( $opt_s ) { $t = $syst }
746 elsif( $opt_r ) { $t = $realt }
747 else { $t = $usert + $syst }
748 $t += $ot, next if $dir eq '@'; # Increments there
749 } else {
750 # "- id" or "- & name"
751 $name = defined $syst ? $syst : $cv_hash{$usert};
752 }
753
754 next unless $in_level or $name eq $opt_g;
755 if ( $dir eq '-' or $dir eq '*' ) {
756 my $ename = $dir eq '*' ? $stack[-1][0] : $name;
757 $overhead += $over_per_call;
758 if ($name eq "Devel::DProf::write") {
759 $overhead += $t - $dprof_stamp;
760 next;
761 } elsif (defined $opt_g and $ename eq $opt_g) {
762 $in_level--;
763 }
764 add_to_tree($curdeep_times, $ename,
765 $t - $overhead) if $opt_S;
766 exitstamp( \@stack, \@tstack,
767 $t - $overhead,
768 $times, $ctimes, $name, \$in, $tab,
769 $curdeep_times, \%outer );
770 }
771 next unless $in_level or $name eq $opt_g;
772 if( $dir eq '+' or $dir eq '*' ){
773 if ($name eq "Devel::DProf::write") {
774 $dprof_stamp = $t;
775 next;
776 } elsif (defined $opt_g and $name eq $opt_g) {
777 $in_level++;
778 }
779 $overhead += $over_per_call;
780 if( $opt_T ){
781 print ' ' x $in, "$name\n";
782 $in += $tab;
783 }
784 elsif( $opt_t ){
785 # suppress output on same function if the
786 # same calling level is called.
787 if ($l_in == $in and $l_name eq $name) {
788 $repcnt++;
789 } else {
790 $repstr = ' ('.++$repcnt.'x)'
791 if $repcnt;
792 print ' ' x $l_in, "$l_name$repstr\n"
793 if $l_name ne '';
794 $repstr = '';
795 $repcnt = 0;
796 $l_in = $in;
797 $l_name = $name;
798 }
799 $in += $tab;
800 }
801 if( ! defined $names->{$name} ){
802 $names->{$name} = $name;
803 $times->{$name} = 0;
804 $ctimes->{$name} = 0;
805 push( @$idkeys, $name );
806 }
807 $calls->{$name}++;
808 $outer{$name}++;
809 push @$curdeep_times, { kids => {},
810 name => $name,
811 enter_stamp => $t - $overhead,
812 } if $opt_S;
813 $x = [ $name, $t - $overhead ];
814 push( @stack, $x );
815
816 # my children will put their time here
817 push( @tstack, 0 );
818 } elsif ($dir ne '-'){
819 die "Bad profile: $_";
820 }
821 }
822 if( $opt_t ){
823 $repstr = ' ('.++$repcnt.'x)' if $repcnt;
824 print ' ' x $l_in, "$l_name$repstr\n";
825 }
826
827 while (my ($key, $count) = each %outer) {
828 next unless $count;
829 warn "$key has $count unstacked calls in outer\n";
830 }
831
832 if( @stack ){
833 if( ! $opt_F ){
834 warn "Garbled profile is missing some exit time stamps:\n";
835 foreach $x (@stack) {
836 print $x->[0],"\n";
837 }
838 die "Try rerunning dprofpp with -F.\n";
839 # I don't want -F to be default behavior--yet
840 # 9/18/95 dmr
841 }
842 else{
843 warn( "Faking " . scalar( @stack ) . " exit timestamp(s).\n");
844 foreach $x ( reverse @stack ){
845 $name = $x->[0];
846 exitstamp( \@stack, \@tstack,
847 $t - $overhead, $times,
848 $ctimes, $name, \$in, $tab,
849 $curdeep_times, \%outer );
850 add_to_tree($curdeep_times, $name,
851 $t - $overhead)
852 if $opt_S;
853 }
854 }
855 }
856 if (defined $opt_g) {
857 $runtime = $ctimes->{$opt_g}/$hz;
858 $runtime = 0 unless $runtime > 0;
859 }
860}
861
862sub exitstamp {
863 my($stack, $tstack, $t, $times, $ctimes, $name, $in, $tab, $deep, $outer) = @_;
864 my( $x, $c, $z );
865
866 $x = pop( @$stack );
867 if( ! defined $x ){
868 die "Garbled profile, missing an enter time stamp";
869 }
870 if( $x->[0] ne $name and $opt_G and ($name =~ /$opt_G/)){
871 if ($x->[0] =~ /(?:::)?AUTOLOAD$/) {
872 if ($opt_A) {
873 $name = $x->[0];
874 }
875 } elsif ( $opt_F ) {
876 warn( "Garbled profile, faking exit timestamp:\n\t$name => $x->[0].\n");
877 $name = $x->[0];
878 } else {
879 foreach $z (@stack, $x) {
880 print $z->[0],"\n";
881 }
882 die "Garbled profile, unexpected exit time stamp";
883 }
884 }
885 if( $opt_T || $opt_t ){
886 $$in -= $tab;
887 }
888 # collect childtime
889 $c = pop( @$tstack );
890 # total time this func has been active
891 $z = $t - $x->[1];
892 $ctimes->{$name} += $z
893 unless --$outer->{$name};
894 $times->{$name} += $z - $c;
895 # pass my time to my parent
896 if( @$tstack ){
897 $c = pop( @$tstack );
898 push( @$tstack, $c + $z );
899 }
900}
901
902
903sub header {
904 my $fh = shift;
905 chop($_ = <$fh>);
906 if( ! /^#fOrTyTwO$/ ){
907 die "Not a perl profile";
908 }
909 while(<$fh>){
910 next if /^#/;
911 last if /^PART/;
912 eval;
913 }
914 $over_tests = 1 unless $over_tests;
915 $time_precision = length int ($hz - 1); # log ;-)
916}
917
918
919# Report avg time-per-function in seconds
920sub percalc {
921 my( $calls, $times, $persecs, $idkeys ) = @_;
922 my( $x, $t, $n, $key );
923
924 for( $x = 0; $x < @$idkeys; ++$x ){
925 $key = $idkeys->[$x];
926 $n = $calls->{$key};
927 $t = $times->{$key} / $hz;
928 $persecs->{$key} = $t ? $t / $n : 0;
929 }
930}
931
932
933# Runs the given script with the given profiler and the given perl.
934sub run_profiler {
935 my $script = shift;
936 my $profiler = shift;
937 my $startperl = shift;
938 my @script_parts = split /\s+/, $script;
939
940 system $startperl, "-d:$profiler", @script_parts;
941 if( $? / 256 > 0 ){
942 my $cmd = join ' ', @script_parts;
943 die "Failed: $startperl -d:$profiler $cmd: $!";
944 }
945}
946
947
948sub by_time { $times->{$b} <=> $times->{$a} }
949sub by_ctime { $ctimes->{$b} <=> $ctimes->{$a} }
950sub by_calls { $calls->{$b} <=> $calls->{$a} }
951sub by_alpha { $names->{$a} cmp $names->{$b} }
952sub by_avgcpu { $persecs->{$b} <=> $persecs->{$a} }
953# Reversed
954sub rby_time { $times->{$a} <=> $times->{$b} }
955sub rby_ctime { $ctimes->{$a} <=> $ctimes->{$b} }
956sub rby_calls { $calls->{$a} <=> $calls->{$b} }
957sub rby_alpha { $names->{$b} cmp $names->{$a} }
958sub rby_avgcpu { $persecs->{$a} <=> $persecs->{$b} }
959
960
961format CSTAT_top =
962Total Elapsed Time = @>>>>>>> Seconds
963(($rrun_rtime - $overhead) / $hz)
964 @>>>>>>>>>> Time = @>>>>>>> Seconds
965$whichtime, $runtime
966@<<<<<<<< Times
967$incl_excl
968%Time ExclSec CumulS #Calls sec/call Csec/c Name
969.
970
971BEGIN {
972 my $fmt = ' ^>>> ^>>>> ^>>>>> ^>>>>> ^>>>>> ^>>>>> ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<';
973 if (-t STDOUT and defined $stty and my ($cols) = `$stty -a` =~ /\bcolumns\s+(\d+)/)
974 {
975 $fmt .= '<' x ($cols - length $fmt) if $cols > 80;
976 }
977
978 eval "format STAT = \n$fmt" . '
979$pcnt, $secs, $csecs, $ncalls, $percall, $cpercall, $name
980.';
981}
982!NO!SUBS!
983
984close OUT or die "Can't close $file: $!";
985chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
986exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
987
Note: See TracBrowser for help on using the repository browser.