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();