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