diff options
author | Andy Dougherty <doughera@lafcol.lafayette.edu> | 1995-10-31 03:33:09 +0000 |
---|---|---|
committer | Andy Dougherty <doughera@lafcol.lafayette.edu> | 1995-10-31 03:33:09 +0000 |
commit | 8e07c86ebc651fe92eb7e3b25f801f57cfb8dd6f (patch) | |
tree | bd67a65038befe4bef8b330a688bf7d915cab92f /ext/Devel | |
parent | e50aee73b3d4c555c37e4b4a16694765fb16c887 (diff) | |
download | perl-8e07c86ebc651fe92eb7e3b25f801f57cfb8dd6f.tar.gz |
This is my patch patch.1n for perl5.001.perl-5.001n
To apply, change to your perl directory, run the command above, then
apply with
patch -p1 -N < thispatch.
This is a consolidation patch. It contains many of the most commonly
applied or agreed-to patches that have been circulating since
patch.1m.
It also changes the 'unofficial patchlevel' in perl.c.
There are some problems (see items marked with '***').
I will attempt to address those in a patch.1o in a few days.
This patch contains the following packages:
My Jumbo Configure patch vs. 1m, with subsequent patches 1, 2, and 3.
Mainly, this provides easier use of local libraries, documents
the installation process in a new INSTALL file, moves important
questions towards the beginning, and improves detection of
signal names (mostly for Linux).
xsubpp-1.922.
Patches from Larry:
eval "1" memory leak patch (as modified by GSAR to apply to 5.001m).
NETaa14551 Infinite loop in formats,
NETaa13729 scope.c patch (fixed problems on AIX and others)
NETaa14138 "substr() & s///" (pp_hot.c)
Patches from ftp.perl.com:
ftp://ftp.perl.com/pub/perl/src/patches/closure-bug.patch,
version of 20 Sep 1995
Includes fix for NETaa14347 (32k limit in regex), and other
fixes.
ftp://ftp.perl.com/pub/perl/src/patches/debugger.patch,
version of 27 Aug 1995
ftp://ftp.perl.com/pub/perl/src/patches/glob-undef.patch,
version of 4 Sep 1995
NETaa14421 $_ doesn't undef
ftp://ftp.perl.com/pub/perl/src/patches/op-segfault.patch,
version of 21 Aug 1995
ftp://ftp.perl.com/pub/perl/src/patches/warn-ref-hash-key.patch,
version of 5 Jun 1995
Tim Bunce's Jumbo DynaLoader patch for Perl5.001m, which is
NETaa14636 Jumbo DynaLoader patch for Perl5.001m, and
Additional patch for NETaa14636 Jumbo DynaLoader patch for Perl5.001m
version of 09 Oct 1995.
***This needs some additional parentheses.***
MakeMaker-5.00. Supercedes NETaa13540 (VMS MakeMaker patches).
(Updates minimod.PL as well.)
***This has a couple of minor problems.
pod2man is run even if it isn't available.
LD_RUN_PATH gets set to some mysterious values.***
NETaa14657 Paul Marquess Net::Ping patch. I've included
Net-Ping-1.00.
NETaa14661 Dean Roehrich DProf. Installed as ext/Devel/DProf.
Configure should pick this up automatically. (5 Apr 1995
version.)
NETaa13742 Jack Shirazi Socket in 5.001. I've also included
his socket.t test in t/lib/socket.t.
c2ph-1.7.
Dean's perlapi patches of Oct 12, 1995, which superceded those
of Oct 8, 1995. This is the one that did
mv perlapi.pid perlxs.pod.
NETaa14310 Tim Bunce A trivial patch for configpm (handy for shell scripts)
DB_File-1.0 patch from Paul Marquess (pmarquess@bfsec.bt.co.uk)
last modified 7th October 1995
version 1.0
Added or updated the following hints files:
hints/hpux.sh
hints/ncr_tower.sh
hints/netbsd.sh
hints/ultrix.sh
Patch and enjoy.
Andy Dougherty doughera@lafcol.lafayette.edu
Dept. of Physics
Lafayette College, Easton PA 18042
Diffstat (limited to 'ext/Devel')
-rw-r--r-- | ext/Devel/DProf/DProf.pm | 106 | ||||
-rw-r--r-- | ext/Devel/DProf/DProf.xs | 247 | ||||
-rw-r--r-- | ext/Devel/DProf/Makefile.PL | 8 | ||||
-rw-r--r-- | ext/Devel/DProf/README | 3 | ||||
-rw-r--r-- | ext/Devel/DProf/dprofpp | 394 | ||||
-rw-r--r-- | ext/Devel/DProf/test.pl | 20 |
6 files changed, 778 insertions, 0 deletions
diff --git a/ext/Devel/DProf/DProf.pm b/ext/Devel/DProf/DProf.pm new file mode 100644 index 0000000000..8ec82d04f2 --- /dev/null +++ b/ext/Devel/DProf/DProf.pm @@ -0,0 +1,106 @@ +# Devel::DProf - a Perl code profiler +# 5apr95 +# Dean Roehrich +# +# changes/bugs fixed since 01mar95 version: +# - record $pwd and build pathname for tmon.out +# (so the profile doesn't get lost if the process chdir's) +# changes/bugs fixed since 03feb95 version: +# - fixed some doc bugs +# - added require 5.000 +# - added -w note to bugs section of pod +# changes/bugs fixed since 31dec94 version: +# - podified +# + +require 5.000; + +=head1 NAME + +Devel::DProf - a Perl code profiler + +=head1 SYNOPSIS + + PERL5DB="use Devel::DProf;" + export PERL5DB + + perl5 -d test.pl + +=head1 DESCRIPTION + +The Devel::DProf package is a Perl code profiler. This will collect +information on the execution time of a Perl script and of the subs in that +script. This information can be used to determine which subroutines are +using the most time and which subroutines are being called most often. This +information can also be used to create an execution graph of the script, +showing subroutine relationships. + +To use this package the PERL5DB environment variable must be set to the +following value: + + PERL5DB="use Devel::DProf;" + export PERL5DB + +To profile a Perl script run the perl interpreter with the B<-d> debugging +switch. The profiler uses the debugging hooks. So to profile script +"test.pl" the following command should be used: + + perl5 -d test.pl + +When the script terminates the profiler will dump the profile information +to a file called I<tmon.out>. The supplied I<dprofpp> tool can be used to +interpret the information which is in that profile. The following command +will print the top 15 subroutines which used the most time: + + dprofpp + +To print an execution graph of the subroutines in the script use the +following command: + + dprofpp -T + +Consult the "dprofpp" manpage for other options. + +=head1 BUGS + +If perl5 is invoked with the B<-w> (warnings) flag then Devel::DProf will +cause a large quantity of warnings to be printed. + +=head1 SEE ALSO + +L<perl>, L<dprofpp>, times(2) + +=cut + +package DB; + +# So Devel::DProf knows where to drop tmon.out. +chop($pwd = `pwd`); +$tmon = "$pwd/tmon.out"; + +# This sub is replaced by an XS version after the profiler is bootstrapped. +sub sub { +# print "nonXS DBsub($sub)\n"; + $single = 0; # disable DB single-stepping + if( wantarray ){ + @a = &$sub; + @a; + } + else{ + $a = &$sub; + $a; + } +} + +# This sub is needed during startup. +sub DB { +# print "nonXS DBDB\n"; +} + + +require DynaLoader; +@Devel::DProf::ISA = qw(DynaLoader); + +bootstrap Devel::DProf; + +1; diff --git a/ext/Devel/DProf/DProf.xs b/ext/Devel/DProf/DProf.xs new file mode 100644 index 0000000000..8670481a35 --- /dev/null +++ b/ext/Devel/DProf/DProf.xs @@ -0,0 +1,247 @@ +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +/* +# Devel::DProf - a Perl code profiler +# 5apr95 +# Dean Roehrich +# +# changes/bugs fixed since 2apr95 version: +# -now mallocing an extra byte for the \0 :) +# changes/bugs fixed since 01mar95 version: +# -stringified code ref is used for name of anonymous sub. +# -include stash name with stringified code ref. +# -use perl.c's DBsingle and DBsub. +# -now using croak() and warn(). +# -print "timer is on" before turning timer on. +# -use safefree() instead of free(). +# -rely on PM to provide full path name to tmon.out. +# -print errno if unable to write tmon.out. +# changes/bugs fixed since 03feb95 version: +# -comments +# changes/bugs fixed since 31dec94 version: +# -added patches from Andy. +# +*/ + +/*#define DBG_SUB 1 /* */ +/*#define DBG_TIMER 1 /* */ + +#ifdef DBG_SUB +# define DBG_SUB_NOTIFY(A,B) warn( A, B ) +#else +# define DBG_SUB_NOTIFY(A,B) /* nothing */ +#endif + +#ifdef DBG_TIMER +# define DBG_TIMER_NOTIFY(A) warn( A ) +#else +# define DBG_TIMER_NOTIFY(A) /* nothing */ +#endif + +/* HZ == clock ticks per second */ +#ifndef HZ +#define HZ 60 +#endif + +static SV * Sub; /* pointer to $DB::sub */ +static char *Tmon; /* name of tmon.out */ + +/* Everything is built on times(2). See its manpage for a description + * of the timings. + */ + +static +struct tms prof_start, + prof_end; + +static +clock_t rprof_start, /* elapsed real time, in ticks */ + rprof_end; + +union prof_any { + clock_t tms_utime; /* cpu time spent in user space */ + clock_t tms_stime; /* cpu time spent in system */ + clock_t realtime; /* elapsed real time, in ticks */ + char *name; + opcode ptype; +}; + +typedef union prof_any PROFANY; + +static PROFANY *profstack; +static int profstack_max = 128; +static int profstack_ix = 0; + + +static void +prof_mark( ptype ) +opcode ptype; +{ + struct tms t; + clock_t realtime; + char *name, *pv; + char *hvname; + STRLEN len; + SV *sv; + + if( profstack_ix + 5 > profstack_max ){ + profstack_max = profstack_max * 3 / 2; + Renew( profstack, profstack_max, PROFANY ); + } + + realtime = times(&t); + pv = SvPV( Sub, len ); + + if( SvROK(Sub) ){ + /* Attempt to make CODE refs identifiable by + * including their package name. + */ + sv = (SV*)SvRV(Sub); + if( sv && SvTYPE(sv) == SVt_PVCV ){ + hvname = HvNAME(CvSTASH(sv)); + len += strlen( hvname ) + 2; /* +2 for more ::'s */ + + } + else { + croak( "DProf prof_mark() lost on supposed CODE ref %s.\n", pv ); + } + name = (char *)safemalloc( len * sizeof(char) + 1 ); + strcpy( name, hvname ); + strcat( name, "::" ); + strcat( name, pv ); + } + else{ + name = (char *)safemalloc( len * sizeof(char) + 1 ); + strcpy( name, pv ); + } + + profstack[profstack_ix++].ptype = ptype; + profstack[profstack_ix++].tms_utime = t.tms_utime; + profstack[profstack_ix++].tms_stime = t.tms_stime; + profstack[profstack_ix++].realtime = realtime; + profstack[profstack_ix++].name = name; +} + +static void +prof_record(){ + FILE *fp; + char *name; + int base = 0; + opcode ptype; + clock_t tms_utime; + clock_t tms_stime; + clock_t realtime; + + if( (fp = fopen( Tmon, "w" )) == NULL ){ + warn("DProf: unable to write %s, errno = %d\n", Tmon, errno ); + return; + } + + fprintf(fp, "#fOrTyTwO\n" ); + fprintf(fp, "$hz=%d;\n", HZ ); + fprintf(fp, "# All values are given in HZ\n" ); + fprintf(fp, "$rrun_utime=%ld; $rrun_stime=%ld; $rrun_rtime=%ld\n", + prof_end.tms_utime - prof_start.tms_utime, + prof_end.tms_stime - prof_start.tms_stime, + rprof_end - rprof_start ); + fprintf(fp, "PART2\n" ); + + while( base < profstack_ix ){ + ptype = profstack[base++].ptype; + tms_utime = profstack[base++].tms_utime; + tms_stime = profstack[base++].tms_stime; + realtime = profstack[base++].realtime; + name = profstack[base++].name; + + switch( ptype ){ + case OP_LEAVESUB: + fprintf(fp,"- %ld %ld %ld %s\n", + tms_utime, tms_stime, realtime, name ); + break; + case OP_ENTERSUB: + fprintf(fp,"+ %ld %ld %ld %s\n", + tms_utime, tms_stime, realtime, name ); + break; + default: + fprintf(fp,"Profiler unknown prof code %d\n", ptype); + } + } + fclose( fp ); +} + +#define for_real +#ifdef for_real + +XS(XS_DB_sub) +{ + dXSARGS; + dORIGMARK; + SP -= items; + + DBG_SUB_NOTIFY( "XS DBsub(%s)\n", SvPV(Sub, na) ); + + sv_setiv( DBsingle, 0 ); /* disable DB single-stepping */ + + prof_mark( OP_ENTERSUB ); + PUSHMARK( ORIGMARK ); + + perl_call_sv( Sub, GIMME ); + + prof_mark( OP_LEAVESUB ); + SPAGAIN; + PUTBACK; + return; +} + +#endif /* for_real */ + +#ifdef testing + + MODULE = Devel::DProf PACKAGE = DB + + void + sub(...) + PPCODE: + + dORIGMARK; + /* SP -= items; added by xsubpp */ + DBG_SUB_NOTIFY( "XS DBsub(%s)\n", SvPV(Sub, na) ); + + sv_setiv( DBsingle, 0 ); /* disable DB single-stepping */ + + prof_mark( OP_ENTERSUB ); + PUSHMARK( ORIGMARK ); + + perl_call_sv( Sub, GIMME ); + + prof_mark( OP_LEAVESUB ); + SPAGAIN; + /* PUTBACK; added by xsubpp */ + +#endif /* testing */ + + +MODULE = Devel::DProf PACKAGE = Devel::DProf + +void +END() + PPCODE: + rprof_end = times(&prof_end); + DBG_TIMER_NOTIFY("Profiler timer is off.\n"); + prof_record(); + +BOOT: + newXS("DB::sub", XS_DB_sub, file); + Sub = GvSV(DBsub); /* name of current sub */ + sv_setiv( DBsingle, 0 ); /* disable DB single-stepping */ + { /* obtain name of tmon.out file */ + SV *sv; + sv = perl_get_sv( "DB::tmon", FALSE ); + Tmon = (char *)safemalloc( SvCUR(sv) * sizeof(char) ); + strcpy( Tmon, SvPVX(sv) ); + } + New( 0, profstack, profstack_max, PROFANY ); + DBG_TIMER_NOTIFY("Profiler timer is on.\n"); + rprof_start = times(&prof_start); diff --git a/ext/Devel/DProf/Makefile.PL b/ext/Devel/DProf/Makefile.PL new file mode 100644 index 0000000000..a1d7b0774d --- /dev/null +++ b/ext/Devel/DProf/Makefile.PL @@ -0,0 +1,8 @@ +use ExtUtils::MakeMaker; +WriteMakefile( + 'NAME' => 'Devel::DProf', + 'VERSION' => 'Apr5,1995', + 'clean' => {'FILES' => "tmon.out"}, + 'EXE_FILES' => ['dprofpp'], + +); diff --git a/ext/Devel/DProf/README b/ext/Devel/DProf/README new file mode 100644 index 0000000000..970e26b46e --- /dev/null +++ b/ext/Devel/DProf/README @@ -0,0 +1,3 @@ +Please consult the pod in DProf.pm. + +Dean Roehrich diff --git a/ext/Devel/DProf/dprofpp b/ext/Devel/DProf/dprofpp new file mode 100644 index 0000000000..6b6c0e70f2 --- /dev/null +++ b/ext/Devel/DProf/dprofpp @@ -0,0 +1,394 @@ +#!/usr/local/bin/perl + +require 5.000; + + +# dprofpp - display perl profile data +# 5apr95 +# Dean Roehrich +# +# changes/bugs fixed since 10feb95 version: +# - summary info is printed by default, opt_c is gone. +# - fixed some doc bugs +# - changed name to dprofpp +# changes/bugs fixed since 03feb95 version: +# - fixed division by zero. +# - replace many local()s with my(). +# - now prints user+system times by default +# now -u prints user time, -U prints unsorted. +# - fixed documentation +# - fixed output, to clarify that times are given in seconds. +# - can now fake exit timestamps if the profile is garbled. +# changes/bugs fixed since 17jun94 version: +# - podified. +# - correct old documentation flaws. +# - added Andy's patches. +# + + +=head1 NAME + +dprofpp - display perl profile data + +=head1 SYNOPSIS + +dprofpp [B<-a|-t|-l|-v|-U|-T>] [B<-s|-r|-u>] [B<-q>] [B<-F>] [B<-O cnt>] [profile] + +=head1 DESCRIPTION + +The I<dprofpp> command interprets a profile file produced by the Devel::DProf +profiler. By default dprofpp will read the file I<tmon.out> and will display +the 15 subroutines which are using the most time. + +=head1 OPTIONS + +=over 5 + +=item B<-a> + +Sort alphabetically by subroutine names. + +=item B<-t> + +(default) Sort by amount of user+system time used. The first few lines +should show you which subroutines are using the most time. + +=item B<-l> + +Sort by number of calls to the subroutines. This may help identify +candidates for inlining. + +=item B<-v> + +Sort by average time spent in subroutines during each call. This may help +identify candidates for inlining. + +=item B<-U> + +Do not sort. Display in the order found in the raw profile. + +=item B<-F> + +Force the generation of fake exit timestamps if dprofpp reports that the +profile is garbled. This is only useful if dprofpp determines that the +profile is garbled due to missing exit timestamps. You're on your own if +you do this. Consult the BUGS section. + +=item B<-T> + +Display subroutine call tree to stdout. Subroutine statistics are +not displayed. + +=item B<-q> + +Do not display column headers. Does nothing if B<-T> is used. + +=item B<-O cnt> + +Show only I<cnt> subroutines. The default is 15. Does nothing if B<-T> +is used. + +=item B<-r> + +Display elapsed real times rather than user+system times. + +=item B<-s> + +Display system times rather than user+system times. + +=item B<-u> + +Display user times rather than user+system times. + +=back + +=head1 BUGS + +Applications which call I<die> from within an eval for exception handling +(catch/throw) or for setjmp/longjmp may not generate a readable profile. + +Applications which call I<exit> from within a subroutine will leave an +incomplete profile. + +=head1 FILES + + dprofpp - profile processor + tmon.out - raw profile + +=head1 SEE ALSO + +L<perl>, L<Devel::DProf>, times(2) + +=cut + +use Getopt::Std 'getopts'; + +Setup: { + getopts('O:ltavuTqrsUF'); + +# -O cnt Specifies maximum number of subroutines to display. +# -a Sort by alphabetic name of subroutines. +# -t Sort by user+system time spent in subroutines. (default) +# -l Sort by number of calls to subroutines. +# -v Sort by average amount of time spent in subroutines. +# -T Show call tree. +# -q Do not print column headers. +# -u Use user time rather than user+system time. +# -s Use system time rather than user+system time. +# -r Use real elapsed time rather than user+system time. +# -U Do not sort subroutines. + + $cnt = $opt_O || 15; + $sort = 'by_time'; + $sort = 'by_calls' if defined $opt_l; + $sort = 'by_alpha' if defined $opt_a; + $sort = 'by_avgcpu' if defined $opt_v; + $whichtime = "User+System"; + $whichtime = "System" if defined $opt_s; + $whichtime = "Real" if defined $opt_r; + $whichtime = "User" if defined $opt_u; +} + +Main: { + my $monout = shift || "tmon.out"; + my $fh = "main::fh"; + local $names = {}; + local $times = {}; # times in hz + local $calls = {}; + local $persecs = {}; # times in seconds + local $idkeys = []; + local $runtime; # runtime in seconds + my @a = (); + my $a; + local $rrun_utime = 0; # user time in hz + local $rrun_stime = 0; # system time in hz + local $rrun_rtime = 0; # elapsed run time in hz + local $rrun_ustime = 0; # user+system time in hz + local $hz = 0; + + open( $fh, "<$monout" ) || die "Unable to open $monout\n"; + + header($fh); + + $rrun_ustime = $rrun_utime + $rrun_stime; + + settime( \$runtime, $hz ); + + $~ = 'STAT'; + if( ! $opt_q ){ + $^ = 'CSTAT_top'; + } + + parsestack( $fh, $names, $calls, $times, $idkeys ); + + exit(0) if $opt_T; + + if( $opt_v ){ + percalc( $calls, $times, $persecs, $idkeys ); + } + if( ! $opt_U ){ + @a = sort $sort @$idkeys; + $a = \@a; + } + else { + $a = $idkeys; + } + display( $runtime, $hz, $names, $calls, $times, $cnt, $a ); +} + + +# Sets $runtime to user, system, real, or user+system time. The +# result is given in seconds. +# +sub settime { + my( $runtime, $hz ) = @_; + + if( $opt_r ){ + $$runtime = $rrun_rtime/$hz; + } + elsif( $opt_s ){ + $$runtime = $rrun_stime/$hz; + } + elsif( $opt_u ){ + $$runtime = $rrun_utime/$hz; + } + else{ + $$runtime = $rrun_ustime/$hz; + } +} + + +# Report the times in seconds. +sub display { + my( $runtime, $hz, $names, $calls , $times, $cnt, $idkeys ) = @_; + my( $x, $key, $s ); + #format: $ncalls, $name, $secs, $percall, $pcnt + + for( $x = 0; $x < @$idkeys; ++$x ){ + $key = $idkeys->[$x]; + $ncalls = $calls->{$key}; + $name = $names->{$key}; + $s = $times->{$key}/$hz; + $secs = sprintf("%.3f", $s ); + $percall = sprintf("%.4f", $s/$ncalls ); + $pcnt = sprintf("%.2f", + $runtime ? + (($secs / $runtime) * 100.0) : + 0 ); + write; + $pcnt = $secs = $ncalls = $percall = ""; + write while( length $name ); + last unless --$cnt; + } +} + + +sub parsestack { + my( $fh, $names, $calls, $times, $idkeys ) = @_; + my( $dir, $name ); + my( $t, $syst, $realt, $usert ); + my( $x, $z, $c ); + my @stack = (); + my @tstack = (); + my $tab = 3; + my $in = 0; + + while(<$fh>){ + next if /^#/o; + last if /^PART/o; + chop; + ($dir, $usert, $syst, $realt, $name) = split; + + if ( $opt_u ) { $t = $usert } + elsif( $opt_s ) { $t = $syst } + elsif( $opt_r ) { $t = $realt } + else { $t = $usert + $syst } + + if( $dir eq '+' ){ + if( $opt_T ){ + print " " x $in, "$name\n"; + $in += $tab; + } + if(! defined $names->{$name} ){ + $names->{$name} = $name; + $times->{$name} = 0; + push( @$idkeys, $name ); + } + $calls->{$name}++; + $x = [ $name, $t ]; + push( @stack, $x ); + + # my children will put their time here + push( @tstack, 0 ); + + next; + } + if( $dir eq '-' ){ + exitstamp( \@stack, \@tstack, $t, $times, + $name, \$in, $tab ); + next; + } + die "Bad profile: $_"; + } + if( @stack ){ + my @astack; + + warn "Garbled profile is missing some exit time stamps:\n"; + foreach (@stack) { + printf "${$_}[0]\n"; + push( @astack, @stack ); + } + if( ! $opt_F ){ + die "Garbled profile"; + } + else{ + warn( "Faking " . scalar( @astack ) . " exit timestamp(s) . . .\n"); + + foreach $x ( @astack ){ + $name = $x->[0]; + exitstamp( \@stack, \@tstack, $t, $times, + $name, \$in, $tab ); + } + } + } +} + +sub exitstamp { + my( $stack, $tstack, $t, $times, $name, $in, $tab ) = @_; + + my( $x, $c, $z ); + + $x = pop( @$stack ); + if( ! defined $x ){ + die "Garbled profile, missing an enter time stamp"; + } + if( $x->[0] ne $name ){ + die "Garbled profile, unexpected exit time stamp"; + } + if( $opt_T ){ + $$in -= $tab; + } + # collect childtime + $c = pop( @$tstack ); + # total time this func has been active + $z = $t - $x->[1]; + # less time spent in child funcs. + # prepare to accept that the children may account + # for all my time. + $times->{$name} += ($z > $c)? $z - $c: $c - $z; + + # pass my time to my parent + if( @$tstack ){ + $c = pop( @$tstack ); + push( @$tstack, $c + $z ); + } +} + + +sub header { + my $fh = shift; + chop($_ = <$fh>); + if( ! /^#fOrTyTwO$/ ){ + die "Not a perl profile"; + } + while(<$fh>){ + next if /^#/o; + last if /^PART/o; + eval; + } +} + + +# Report avg time-per-function in seconds +sub percalc { + my( $calls, $times, $persecs, $idkeys ) = @_; + my( $x, $t, $n, $key ); + + for( $x = 0; $x < @$idkeys; ++$x ){ + $key = $idkeys->[$x]; + $n = $calls->{$key}; + $t = $times->{$key} / $hz; + $persecs->{$key} = $t ? $t / $n : 0; + } +} + + +sub by_time { $times->{$b} <=> $times->{$a} } +sub by_calls { $calls->{$b} <=> $calls->{$a} } +sub by_alpha { $names->{$a} cmp $names->{$b} } +sub by_avgcpu { $persecs->{$b} <=> $persecs->{$a} } + + +format CSTAT_top = +Total Elapsed Time = @>>>>>> Seconds +($rrun_rtime / $hz) + @>>>>>>>>>> Time = @>>>>>> Seconds +$whichtime, $runtime +%Time Seconds #Calls sec/call Name +. + +format STAT = + ^>>> ^>>>> ^>>>>>>>>> ^>>>>> ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< +$pcnt, $secs, $ncalls, $percall, $name +. + diff --git a/ext/Devel/DProf/test.pl b/ext/Devel/DProf/test.pl new file mode 100644 index 0000000000..8fa0f41043 --- /dev/null +++ b/ext/Devel/DProf/test.pl @@ -0,0 +1,20 @@ +#!./perl + +sub foo { + print "in sub foo\n"; + bar(); +} + +sub bar { + print "in sub bar\n"; +} + +sub baz { + print "in sub baz\n"; + bar(); + foo(); +} + +bar(); +baz(); +foo(); |