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