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