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