diff options
author | Larry Wall <lwall@scalpel.netlabs.com> | 1995-11-21 10:01:00 +1200 |
---|---|---|
committer | Larry <lwall@scalpel.netlabs.com> | 1995-11-21 10:01:00 +1200 |
commit | 4633a7c4bad06b471d9310620b7fe8ddd158cccd (patch) | |
tree | 37ebeb26a64f123784fd8fac6243b124767243b0 /ext/Devel | |
parent | 8e07c86ebc651fe92eb7e3b25f801f57cfb8dd6f (diff) | |
download | perl-4633a7c4bad06b471d9310620b7fe8ddd158cccd.tar.gz |
5.002 beta 1
If you're adventurous, have a look at
ftp://ftp.sems.com/pub/outgoing/perl5.0/perl5.002beta1.tar.gz
Many thanks to Andy for doing the integration.
Obviously, if you consult the bugs database, you'll note there are
still plenty of buglets that need fixing, and several enhancements that
I've intended to put in still haven't made it in (Hi, Tim and Ilya).
But I think it'll be pretty stable. And you can start to fiddle around
with prototypes (which are, of course, still totally undocumented).
Packrats, don't worry too much about readvertising this widely.
Nowadays we're on a T1 here, so our bandwidth is okay.
Have the appropriate amount of jollity.
Larry
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, 0 insertions, 778 deletions
diff --git a/ext/Devel/DProf/DProf.pm b/ext/Devel/DProf/DProf.pm deleted file mode 100644 index 8ec82d04f2..0000000000 --- a/ext/Devel/DProf/DProf.pm +++ /dev/null @@ -1,106 +0,0 @@ -# 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 deleted file mode 100644 index 8670481a35..0000000000 --- a/ext/Devel/DProf/DProf.xs +++ /dev/null @@ -1,247 +0,0 @@ -#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 deleted file mode 100644 index a1d7b0774d..0000000000 --- a/ext/Devel/DProf/Makefile.PL +++ /dev/null @@ -1,8 +0,0 @@ -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 deleted file mode 100644 index 970e26b46e..0000000000 --- a/ext/Devel/DProf/README +++ /dev/null @@ -1,3 +0,0 @@ -Please consult the pod in DProf.pm. - -Dean Roehrich diff --git a/ext/Devel/DProf/dprofpp b/ext/Devel/DProf/dprofpp deleted file mode 100644 index 6b6c0e70f2..0000000000 --- a/ext/Devel/DProf/dprofpp +++ /dev/null @@ -1,394 +0,0 @@ -#!/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 deleted file mode 100644 index 8fa0f41043..0000000000 --- a/ext/Devel/DProf/test.pl +++ /dev/null @@ -1,20 +0,0 @@ -#!./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(); |