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