From: Gurusamy Sarathy Date: Tue, 20 Jul 1999 05:39:11 +0000 (+0000) Subject: add Devel::DProf v19990108 from CPAN, as it was X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=583a019e9331c2d5f46d5ec7bffbf323d14559cd;p=p5sagit%2Fp5-mst-13.2.git add Devel::DProf v19990108 from CPAN, as it was p4raw-id: //depot/perl@3707 --- diff --git a/MANIFEST b/MANIFEST index fccf79e..df8b64a 100644 --- a/MANIFEST +++ b/MANIFEST @@ -221,6 +221,26 @@ ext/Devel/Peek/Changes Data debugging tool, changelog ext/Devel/Peek/Makefile.PL Data debugging tool, makefile writer ext/Devel/Peek/Peek.pm Data debugging tool, module and pod ext/Devel/Peek/Peek.xs Data debugging tool, externals +ext/DProf/Changes Perl code profiler changelog +ext/DProf/DProf.pm Perl code profiler +ext/DProf/DProf.xs Perl code profiler +ext/DProf/Makefile.PL Perl code profiler makefile writer +ext/DProf/Todo Perl code profiler todo list +ext/DProf/dprofpp.PL Perl code profile post-processor +ext/DProf/t/test1.pl Perl code profiler tests +ext/DProf/t/test1.t Perl code profiler tests +ext/DProf/t/test1.v Perl code profiler tests +ext/DProf/t/test2.t Perl code profiler tests +ext/DProf/t/test2.v Perl code profiler tests +ext/DProf/t/test3.t Perl code profiler tests +ext/DProf/t/test3.v Perl code profiler tests +ext/DProf/t/test4.t Perl code profiler tests +ext/DProf/t/test4.v Perl code profiler tests +ext/DProf/t/test5.t Perl code profiler tests +ext/DProf/t/test5.v Perl code profiler tests +ext/DProf/t/test6.t Perl code profiler tests +ext/DProf/t/test6.v Perl code profiler tests +ext/DProf/test.pl Perl code profiler testsuite driver ext/DynaLoader/DynaLoader_pm.PL Dynamic Loader perl module ext/DynaLoader/Makefile.PL Dynamic Loader makefile writer ext/DynaLoader/README Dynamic Loader notes and intro diff --git a/ext/DProf/Changes b/ext/DProf/Changes new file mode 100644 index 0000000..216498b --- /dev/null +++ b/ext/DProf/Changes @@ -0,0 +1,176 @@ +1999 Jan 8 + + Ilya Zakharevich: + Newer perls: Add PERL_POLLUTE and dTHR. + +1998 Nov 10 +This version of DProf should work with older Perls too, but to get +full benefits some patches to 5.004_55 are needed. Patches take effect +after new version of Perl is installed, and DProf recompiled. + +Without these patches the overhead of DProf is too big, thus the statistic +may be very skewed. + +Oct 98: + Ilya Zakharevich: + DProf.xs + - correct defstash to PL_defstash + - nonlocal exits work + dprofpp + - nonlocal exits work + DProf.pm + - documentation updated + t/test6.* + - added + +Nov-Dec 97: + Jason E. Holt and Ilya Zakharevich: + DProf.xs + - will not wait until completion to write the output, size of buffer + regulated by PERL_DPROF_BUFFER, default 2**14 words; + + Ilya Zakharevich: + dprofpp + - smarter in fixing garbled profiles; + - subtracts DProf output overhead, and suggested profiler overhead; + - new options -A, -R, -g subroutine, -S; + - handles 'goto' too; + DProf.xs + - 7x denser output (time separated from name, ids for subs); + - outputs report-write overhead; + - optional higher-resolution (currently OS/2 only, cannot grok VMS code); + - outputs suggested profiler overhead; + - handles 'goto' too; + - handles PERL_DPROF_TICKS (on OS/2, VMS may be easily modified too) + +Jun 14, 97 andreas koenig adds the compatibility notes to the README +and lets the Makefile.PL die on $] < 5.004. + +Jun 06, 97 andreas koenig applies a patch by gurusamy sarathy because +Dean is not available for comments at that time. The patch is available +from CPAN in the authors/id/GSAR directory for inspection. + +Sep 30, 96 dmr + DProf.xs + - added Ilya's patches to fix "&bar as &bar(@_)" bug. This also fixes + the coredumps people have seen when using this with 5.003+. + DProf.pm + - updated manpage + t/bug.t + - moved to test5 + Makefile.PL + - remove special case for bug.t + +Jun 26, 96 dmr + dprofpp.PL + - smarter r.e. to find VERSION in Makefile (for MM5.27). + DProf.pm + - updated manpage + DProf.xs + - keep pid of profiled process, if process forks then only the + parent is profiled. Added test4 for this. + +Mar 2, 96 dmr + README + - updated + dprofpp + - updated manpage, point to DProf for raw profile description. + DProf.pm + - update manpage, update raw profile description with XS_VERSION. + - update manpage for AUTOLOAD changes. + DProf.xs + - smart handling of &AUTOLOAD--looks in $AUTOLOAD for the sub name. + this fixes one problem with corrupt profiles. + +Feb 5, 96 dmr + dprofpp + - updated manpage + - added -E/-I for exclusive/inclusive times + - added DPROFPP_OPTS -- lazily + - added -p/-Q for profile-then-analyze + - added version check + dprofpp.PL + - pull dprofpp's version id from the makefile + DProf.pm + - added version to bootstrap + - updated doc + - updated doc, DProf and -w are now friendly to each other + DProf.xs + - using savepv + - added Tim's patch to check for DBsub, avoids -MDevel::DProf coredump + - turn off warnings during newXS("DB::sub") + tests + - added Tim's patch to ignore Loader::import in results + - added Tim's patch to aid readability of test?.v output + + +-- from those days when I kept a unique changelog for each module -- + +# Devel::DProf - a Perl code profiler +# 31oct95 +# +# changes/bugs fixed since 5apr95 version -dmr: +# -added VMS patches from CharlesB. +# -now open ./tmon.out in BOOT. +# changes/bugs fixed since 2apr95 version -dmr: +# -now mallocing an extra byte for the \0 :) +# changes/bugs fixed since 01mar95 version -dmr: +# -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 -dmr: +# -comments +# changes/bugs fixed since 31dec94 version -dmr: +# -added patches from AndyD. +# + +# Devel::DProf - a Perl code profiler +# 31oct95 +# +# changes/bugs fixed since 05apr95 version -dmr: +# - VMS-related prob; now let tmon.out name be handled in XS. +# changes/bugs fixed since 01mar95 version -dmr: +# - record $pwd and build pathname for tmon.out +# changes/bugs fixed since 03feb95 version -dmr: +# - fixed some doc bugs +# - added require 5.000 +# - added -w note to bugs section of pod +# changes/bugs fixed since 31dec94 version -dmr: +# - podified +# + + +# dprofpp - display perl profile data +# 31oct95 +# +# changes/bugs fixed since 7oct95 version -dmr: +# - PL'd +# changes/bugs fixed since 5apr95 version -dmr: +# - touch up handling of exit timestamps. +# - suggests -F when exit timestamps are missing. +# - added compressed execution tree patches from AchimB, put under -t. +# now -z is the default action; user+system time. +# - doc changes. +# changes/bugs fixed since 10feb95 version -dmr: +# - summary info is printed by default, opt_c is gone. +# - fixed some doc bugs +# - changed name to dprofpp +# changes/bugs fixed since 03feb95 version -dmr: +# - 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 -dmr: +# - podified. +# - correct old documentation flaws. +# - added AndyD's patches. +# + diff --git a/ext/DProf/DProf.pm b/ext/DProf/DProf.pm new file mode 100644 index 0000000..4c43f4d --- /dev/null +++ b/ext/DProf/DProf.pm @@ -0,0 +1,192 @@ +require 5.003; + +=head1 NAME + +Devel::DProf - a Perl code profiler + +=head1 SYNOPSIS + + perl5 -d:DProf 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 profile a Perl script run the perl interpreter with the B<-d> debugging +switch. The profiler uses the debugging hooks. So to profile script +F the following command should be used: + + perl5 -d:DProf test.pl + +When the script terminates (or when the output buffer is filled) the +profiler will dump the profile information to a file called +F. A tool like I 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 L for other options. + +=head1 PROFILE FORMAT + +The old profile is a text file which looks like this: + + #fOrTyTwO + $hz=100; + $XS_VERSION='DProf 19970606'; + # All values are given in HZ + $rrun_utime=2; $rrun_stime=0; $rrun_rtime=7 + PART2 + + 26 28 566822884 DynaLoader::import + - 26 28 566822884 DynaLoader::import + + 27 28 566822885 main::bar + - 27 28 566822886 main::bar + + 27 28 566822886 main::baz + + 27 28 566822887 main::bar + - 27 28 566822888 main::bar + [....] + +The first line is the magic number. The second line is the hertz value, or +clock ticks, of the machine where the profile was collected. The third line +is the name and version identifier of the tool which created the profile. +The fourth line is a comment. The fifth line contains three variables +holding the user time, system time, and realtime of the process while it was +being profiled. The sixth line indicates the beginning of the sub +entry/exit profile section. + +The columns in B are: + + sub entry(+)/exit(-) mark + app's user time at sub entry/exit mark, in ticks + app's system time at sub entry/exit mark, in ticks + app's realtime at sub entry/exit mark, in ticks + fully-qualified sub name, when possible + +With newer perls another format is used, which may look like this: + + #fOrTyTwO + $hz=10000; + $XS_VERSION='DProf 19971213'; + # All values are given in HZ + $over_utime=5917; $over_stime=0; $over_rtime=5917; + $over_tests=10000; + $rrun_utime=1284; $rrun_stime=0; $rrun_rtime=1284; + $total_marks=6; + + PART2 + @ 406 0 406 + & 2 main bar + + 2 + @ 456 0 456 + - 2 + @ 1 0 1 + & 3 main baz + + 3 + @ 141 0 141 + + 2 + @ 141 0 141 + - 2 + @ 1 0 1 + & 4 main foo + + 4 + @ 142 0 142 + + & Devel::DProf::write + @ 5 0 5 + - & Devel::DProf::write + +(with high value of $ENV{PERL_DPROF_TICKS}). + +New C<$over_*> values show the measured overhead of making $over_tests +calls to the profiler These values are used by the profiler to +subtract the overhead from the runtimes. + +The lines starting with C<@> mark time passed from the previous C<@> +line. The lines starting with C<&> introduce new subroutine I and +show the package and the subroutine name of this id. Lines starting +with C<+>, C<-> and C<*> mark entering and exit of subroutines by +Is, and C. + +The I C<+>- and C<->-lines are used to mark the overhead +related to writing to profiler-output file. + +=head1 AUTOLOAD + +When Devel::DProf finds a call to an C<&AUTOLOAD> subroutine it looks at the +C<$AUTOLOAD> variable to find the real name of the sub being called. See +L. + +=head1 ENVIRONMENT + +C sets size of output buffer in words. Defaults to 2**14. + +C sets number of ticks per second on some systems where +a replacement for times() is used. Defaults to the value of C macro. + +=head1 BUGS + +Builtin functions cannot be measured by Devel::DProf. + +With a newer Perl DProf relies on the fact that the numeric slot of +$DB::sub contains an address of a subroutine. Excessive manipulation +of this variable may overwrite this slot, as in + + $DB::sub = 'current_sub'; + ... + $addr = $DB::sub + 0; + +will set this numeric slot to numeric value of the string +C, i.e., to C<0>. This will cause a segfault on the exit +from this subroutine. Note that the first assignment above does not +change the numeric slot (it will I it as invalid, but will not +write over it). + +Mail bug reports and feature requests to the perl5-porters mailing list at +Fperl5-porters@perl.orgE>. + +=head1 SEE ALSO + +L, L, times(2) + +=cut + +# This sub is needed for calibration. +package Devel::DProf; + +sub NONESUCH_noxs { + return $Devel::DProf::VERSION; +} + +package DB; + +# +# As of perl5.003_20, &DB::sub stub is not needed (some versions +# even had problems if stub was redefined with XS version). +# + +# disable DB single-stepping +BEGIN { $single = 0; } + +# This sub is needed during startup. +sub DB { +# print "nonXS DBDB\n"; +} + +require DynaLoader; +@Devel::DProf::ISA = 'DynaLoader'; +$Devel::DProf::VERSION = '19990108'; # this version not authorized by + # Dean Roehrich. See "Changes" file. + +bootstrap Devel::DProf $Devel::DProf::VERSION; + +1; diff --git a/ext/DProf/DProf.xs b/ext/DProf/DProf.xs new file mode 100644 index 0000000..946aee2 --- /dev/null +++ b/ext/DProf/DProf.xs @@ -0,0 +1,703 @@ +#define PERL_POLLUTE + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +/* For older Perls */ +#ifndef dTHR +# define dTHR int dummy_thr +#endif /* dTHR */ + +/*#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 + +static U32 dprof_ticks; + +/* HZ == clock ticks per second */ +#ifdef VMS +# define HZ CLK_TCK +# define DPROF_HZ HZ +# include /* prototype for sys$gettim() */ + clock_t dprof_times(struct tms *bufptr) { + clock_t retval; + /* Get wall time and convert to 10 ms intervals to + * produce the return value dprof expects */ +# if defined(__DECC) && defined (__ALPHA) +# include + uint64 vmstime; + _ckvmssts(sys$gettim(&vmstime)); + vmstime /= 100000; + retval = vmstime & 0x7fffffff; +# else + /* (Older hw or ccs don't have an atomic 64-bit type, so we + * juggle 32-bit ints (and a float) to produce a time_t result + * with minimal loss of information.) */ + long int vmstime[2],remainder,divisor = 100000; + _ckvmssts(sys$gettim((unsigned long int *)vmstime)); + vmstime[1] &= 0x7fff; /* prevent overflow in EDIV */ + _ckvmssts(lib$ediv(&divisor,vmstime,(long int *)&retval,&remainder)); +# endif + /* Fill in the struct tms using the CRTL routine . . .*/ + times((tbuffer_t *)bufptr); + return (clock_t) retval; + } +# define Times(ptr) (dprof_times(ptr)) +#else +# ifndef HZ +# ifdef CLK_TCK +# define HZ CLK_TCK +# else +# define HZ 60 +# endif +# endif +# ifdef OS2 /* times() has significant overhead */ +# define Times(ptr) (dprof_times(ptr)) +# define INCL_DOSPROFILE +# define INCL_DOSERRORS +# include +# define toLongLong(arg) (*(long long*)&(arg)) +# define DPROF_HZ dprof_ticks + +static ULONG frequ; +static long long start_cnt; +clock_t +dprof_times(struct tms *t) +{ + ULONG rc; + QWORD cnt; + + if (!frequ) { + if (CheckOSError(DosTmrQueryFreq(&frequ))) + croak("DosTmrQueryFreq: %s", SvPV(perl_get_sv("!",TRUE),na)); + else + frequ = frequ/DPROF_HZ; /* count per tick */ + if (CheckOSError(DosTmrQueryTime(&cnt))) + croak("DosTmrQueryTime: %s", + SvPV(perl_get_sv("!",TRUE),na)); + start_cnt = toLongLong(cnt); + } + + if (CheckOSError(DosTmrQueryTime(&cnt))) + croak("DosTmrQueryTime: %s", SvPV(perl_get_sv("!",TRUE),na)); + t->tms_stime = 0; + return (t->tms_utime = (toLongLong(cnt) - start_cnt)/frequ); +} +# else +# define Times(ptr) (times(ptr)) +# define DPROF_HZ HZ +# endif +#endif + +XS(XS_Devel__DProf_END); /* used by prof_mark() */ + +static SV * Sub; /* pointer to $DB::sub */ +static PerlIO *fp; /* pointer to tmon.out file */ + +/* Added -JH */ +static long TIMES_LOCATION=42;/* Where in the file to store the time totals */ +static int SAVE_STACK = 1<<14; /* How much data to buffer until */ + /* end of run */ + +static int prof_pid; /* pid of profiled process */ + +/* 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, + wprof_u, wprof_s, wprof_r; + +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; + U32 id; + opcode ptype; +}; + +typedef union prof_any PROFANY; + +static PROFANY *profstack; +static int profstack_max = 128; +static int profstack_ix = 0; + +static void +prof_dump(opcode ptype, char *name) +{ + if(ptype == OP_LEAVESUB){ + PerlIO_printf(fp,"- & %s\n", name ); + } else if(ptype == OP_ENTERSUB) { + PerlIO_printf(fp,"+ & %s\n", name ); + } else if(ptype == OP_DIE) { + PerlIO_printf(fp,"/ & %s\n", name ); + } else { + PerlIO_printf(fp,"Profiler unknown prof code %d\n", ptype); + } + safefree(name); +} + +static void +prof_dumpa(opcode ptype, U32 id) +{ + if(ptype == OP_LEAVESUB){ + PerlIO_printf(fp,"- %lx\n", id ); + } else if(ptype == OP_ENTERSUB) { + PerlIO_printf(fp,"+ %lx\n", id ); + } else if(ptype == OP_GOTO) { + PerlIO_printf(fp,"* %lx\n", id ); + } else if(ptype == OP_DIE) { + PerlIO_printf(fp,"/ %lx\n", id ); + } else { + PerlIO_printf(fp,"Profiler unknown prof code %d\n", ptype); + } +} + +static void +prof_dumps(U32 id, char *pname, char *gname) +{ + PerlIO_printf(fp,"& %lx %s %s\n", id, pname, gname); +} + +static clock_t otms_utime, otms_stime, orealtime; + +static void +prof_dumpt(long tms_utime, long tms_stime, long realtime) +{ + PerlIO_printf(fp,"@ %ld %ld %ld\n", tms_utime, tms_stime, realtime); +} + +static void +prof_dump_until(long ix) +{ + long base = 0; + struct tms t1, t2; + clock_t realtime1, realtime2; + + realtime1 = Times(&t1); + + while( base < ix ){ + opcode ptype = profstack[base++].ptype; + if (ptype == OP_TIME) { + long tms_utime = profstack[base++].tms_utime; + long tms_stime = profstack[base++].tms_stime; + long realtime = profstack[base++].realtime; + + prof_dumpt(tms_utime, tms_stime, realtime); + } else if (ptype == OP_GV) { + U32 id = profstack[base++].id; + char *pname = profstack[base++].name; + char *gname = profstack[base++].name; + + prof_dumps(id, pname, gname); + } else { +#ifdef PERLDBf_NONAME + U32 id = profstack[base++].id; + prof_dumpa(ptype, id); +#else + char *name = profstack[base++].name; + prof_dump(ptype, name); +#endif + } + } + fflush(fp); + realtime2 = Times(&t2); + if (realtime2 != realtime1 || t1.tms_utime != t2.tms_utime + || t1.tms_stime != t2.tms_stime) { + wprof_r += realtime2 - realtime1; + wprof_u += t2.tms_utime - t1.tms_utime; + wprof_s += t2.tms_stime - t1.tms_stime; + + PerlIO_printf(fp,"+ & Devel::DProf::write\n" ); + PerlIO_printf(fp,"@ %ld %ld %ld\n", + t2.tms_utime - t1.tms_utime, t2.tms_stime - t1.tms_stime, + realtime2 - realtime1); + PerlIO_printf(fp,"- & Devel::DProf::write\n" ); + otms_utime = t2.tms_utime; + otms_stime = t2.tms_stime; + orealtime = realtime2; + fflush(fp); + } +} + +static HV* cv_hash; +static U32 total = 0; + +static void +prof_mark( ptype ) +opcode ptype; +{ + struct tms t; + clock_t realtime, rdelta, udelta, sdelta; + char *name, *pv; + char *hvname; + STRLEN len; + SV *sv; + U32 id; + + if( SAVE_STACK ){ + if( profstack_ix + 5 > profstack_max ){ + profstack_max = profstack_max * 3 / 2; + Renew( profstack, profstack_max, PROFANY ); + } + } + + realtime = Times(&t); + rdelta = realtime - orealtime; + udelta = t.tms_utime - otms_utime; + sdelta = t.tms_stime - otms_stime; + if (rdelta || udelta || sdelta) { + if (SAVE_STACK) { + profstack[profstack_ix++].ptype = OP_TIME; + profstack[profstack_ix++].tms_utime = udelta; + profstack[profstack_ix++].tms_stime = sdelta; + profstack[profstack_ix++].realtime = rdelta; + } else { /* Write it to disk now so's not to eat up core */ + if (prof_pid == (int)getpid()) { + prof_dumpt(udelta, sdelta, rdelta); + fflush(fp); + } + } + orealtime = realtime; + otms_stime = t.tms_stime; + otms_utime = t.tms_utime; + } + +#ifdef PERLDBf_NONAME + { + SV **svp; + char *gname, *pname; + static U32 lastid; + CV *cv; + + cv = (CV*)SvIVX(Sub); + svp = hv_fetch(cv_hash, (char*)&cv, sizeof(CV*), TRUE); + if (!SvOK(*svp)) { + GV *gv = CvGV(cv); + + sv_setiv(*svp, id = ++lastid); + pname = ((GvSTASH(gv) && HvNAME(GvSTASH(gv))) + ? HvNAME(GvSTASH(gv)) + : "(null)"); + gname = GvNAME(gv); + if (CvXSUB(cv) == XS_Devel__DProf_END) + return; + if (SAVE_STACK) { /* Store it for later recording -JH */ + profstack[profstack_ix++].ptype = OP_GV; + profstack[profstack_ix++].id = id; + profstack[profstack_ix++].name = pname; + profstack[profstack_ix++].name = gname; + } else { /* Write it to disk now so's not to eat up core */ + + /* Only record the parent's info */ + if (prof_pid == (int)getpid()) { + prof_dumps(id, pname, gname); + fflush(fp); + } else + perldb = 0; /* Do not debug the kid. */ + } + } else { + id = SvIV(*svp); + } + } +#else + pv = SvPV( Sub, len ); + + if( SvROK(Sub) ){ + /* Attempt to make CODE refs slightly identifiable by + * including their package name. + */ + sv = (SV*)SvRV(Sub); + if( sv && SvTYPE(sv) == SVt_PVCV ){ + if( CvSTASH(sv) ){ + hvname = HvNAME(CvSTASH(sv)); + } + else if( CvXSUB(sv) == &XS_Devel__DProf_END ){ + /*warn( "prof_mark() found dprof::end");*/ + return; /* don't profile Devel::DProf::END */ + } + else{ + croak( "DProf prof_mark() lost on CODE ref %s\n", pv ); + } + len += strlen( hvname ) + 2; /* +2 for ::'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{ + if( *(pv+len-1) == 'D' ){ + /* It could be an &AUTOLOAD. */ + + /* I measured a bunch of *.pl and *.pm (from Perl + * distribution and other misc things) and found + * 780 fully-qualified names. They averaged + * about 19 chars each. Only 1 of those names + * ended with 'D' and wasn't an &AUTOLOAD--it + * was &overload::OVERLOAD. + * --dmr 2/19/96 + */ + + if( strcmp( pv+len-9, ":AUTOLOAD" ) == 0 ){ + /* The sub name is in $AUTOLOAD */ + sv = perl_get_sv( pv, 0 ); + if( sv == NULL ){ + croak("DProf prof_mark() lost on AUTOLOAD (%s).\n", pv ); + } + pv = SvPV( sv, na ); + DBG_SUB_NOTIFY( " AUTOLOAD(%s)\n", pv ); + } + } + name = savepv( pv ); + } +#endif /* PERLDBf_NONAME */ + + total++; + if (SAVE_STACK) { /* Store it for later recording -JH */ + profstack[profstack_ix++].ptype = ptype; +#ifdef PERLDBf_NONAME + profstack[profstack_ix++].id = id; +#else + profstack[profstack_ix++].name = name; +#endif + /* Only record the parent's info */ + if (SAVE_STACK < profstack_ix) { + if (prof_pid == (int)getpid()) + prof_dump_until(profstack_ix); + else + perldb = 0; /* Do not debug the kid. */ + profstack_ix = 0; + } + } else { /* Write it to disk now so's not to eat up core */ + + /* Only record the parent's info */ + if (prof_pid == (int)getpid()) { +#ifdef PERLDBf_NONAME + prof_dumpa(ptype, id); +#else + prof_dump(ptype, name); +#endif + fflush(fp); + } else + perldb = 0; /* Do not debug the kid. */ + } +} + +static U32 default_perldb; + +#ifdef PL_NEEDED +# define defstash PL_defstash +#endif + +/* Counts overhead of prof_mark and extra XS call. */ +static void +test_time(clock_t *r, clock_t *u, clock_t *s) +{ + dTHR; + CV *cv = perl_get_cv("Devel::DProf::NONESUCH_noxs", FALSE); + int i, j, k = 0; + HV *oldstash = curstash; + struct tms t1, t2; + clock_t realtime1, realtime2; + U32 ototal = total; + U32 ostack = SAVE_STACK; + U32 operldb = perldb; + + SAVE_STACK = 1000000; + realtime1 = Times(&t1); + + while (k < 2) { + i = 0; + /* Disable debugging of perl_call_sv on second pass: */ + curstash = (k == 0 ? defstash : debstash); + perldb = default_perldb; + while (++i <= 100) { + j = 0; + profstack_ix = 0; /* Do not let the stack grow */ + while (++j <= 100) { +/* prof_mark( OP_ENTERSUB ); */ + + PUSHMARK( stack_sp ); + perl_call_sv( (SV*)cv, G_SCALAR ); + stack_sp--; +/* prof_mark( OP_LEAVESUB ); */ + } + } + curstash = oldstash; + if (k == 0) { /* Put time with debugging */ + realtime2 = Times(&t2); + *r = realtime2 - realtime1; + *u = t2.tms_utime - t1.tms_utime; + *s = t2.tms_stime - t1.tms_stime; + } else { /* Subtract time without debug */ + realtime1 = Times(&t1); + *r -= realtime1 - realtime2; + *u -= t1.tms_utime - t2.tms_utime; + *s -= t1.tms_stime - t2.tms_stime; + } + k++; + } + total = ototal; + SAVE_STACK = ostack; + perldb = operldb; +} + +static void +prof_recordheader() +{ + clock_t r, u, s; + + /* fp is opened in the BOOT section */ + PerlIO_printf(fp, "#fOrTyTwO\n" ); + PerlIO_printf(fp, "$hz=%d;\n", DPROF_HZ ); + PerlIO_printf(fp, "$XS_VERSION='DProf %s';\n", XS_VERSION ); + PerlIO_printf(fp, "# All values are given in HZ\n" ); + test_time(&r, &u, &s); + PerlIO_printf(fp, "$over_utime=%ld; $over_stime=%ld; $over_rtime=%ld;\n", + u, s, r); + PerlIO_printf(fp, "$over_tests=10000;\n"); + + TIMES_LOCATION = ftell(fp); + + /* Pad with whitespace. */ + /* This should be enough even for very large numbers. */ + PerlIO_printf(fp, "%*s\n", 240 , ""); + + PerlIO_printf(fp, "\n"); + PerlIO_printf(fp, "PART2\n" ); + + fflush(fp); +} + +static void +prof_record() +{ + /* fp is opened in the BOOT section */ + + /* Now that we know the runtimes, fill them in at the recorded + location -JH */ + + clock_t r, u, s; + + if(SAVE_STACK){ + prof_dump_until(profstack_ix); + } + fseek(fp, TIMES_LOCATION, SEEK_SET); + /* Write into reserved 240 bytes: */ + PerlIO_printf(fp, "$rrun_utime=%ld; $rrun_stime=%ld; $rrun_rtime=%ld;", + prof_end.tms_utime - prof_start.tms_utime - wprof_u, + prof_end.tms_stime - prof_start.tms_stime - wprof_s, + rprof_end - rprof_start - wprof_r ); + PerlIO_printf(fp, "\n$total_marks=%ld;", total); + + fclose( fp ); +} + +#define NONESUCH() + +static U32 depth = 0; + +static void +check_depth(void *foo) +{ + U32 need_depth = (U32)foo; + if (need_depth != depth) { + if (need_depth > depth) { + warn("garbled call depth when profiling"); + } else { + I32 marks = depth - need_depth; + +/* warn("Check_depth: got %d, expected %d\n", depth, need_depth); */ + while (marks--) { + prof_mark( OP_DIE ); + } + depth = need_depth; + } + } +} + +#define for_real +#ifdef for_real + +XS(XS_DB_sub) +{ + dXSARGS; + dORIGMARK; + HV *oldstash = curstash; + + SP -= items; + + DBG_SUB_NOTIFY( "XS DBsub(%s)\n", SvPV(Sub, na) ); + +#ifndef PERLDBf_NONAME /* Was needed on older Perls */ + sv_setiv( DBsingle, 0 ); /* disable DB single-stepping */ +#endif + + SAVEDESTRUCTOR(check_depth, (void*)depth); + depth++; + + prof_mark( OP_ENTERSUB ); + PUSHMARK( ORIGMARK ); + +#ifdef G_NODEBUG + perl_call_sv( (SV*)SvIV(Sub), GIMME | G_NODEBUG); +#else + curstash = debstash; /* To disable debugging of perl_call_sv */ +#ifdef PERLDBf_NONAME + perl_call_sv( (SV*)SvIV(Sub), GIMME ); +#else + perl_call_sv( Sub, GIMME ); +#endif + curstash = oldstash; +#endif + + prof_mark( OP_LEAVESUB ); + depth--; + + SPAGAIN; + PUTBACK; + return; +} + +XS(XS_DB_goto) +{ + prof_mark( OP_GOTO ); + return; +} + +#endif /* for_real */ + +#ifdef testing + + MODULE = Devel::DProf PACKAGE = DB + + void + sub(...) + PPCODE: + + dORIGMARK; + HV *oldstash = curstash; + /* 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 ); + + curstash = debstash; /* To disable debugging of perl_call_sv +*/ + perl_call_sv( Sub, GIMME ); + curstash = oldstash; + + prof_mark( OP_LEAVESUB ); + SPAGAIN; + /* PUTBACK; added by xsubpp */ + +#endif /* testing */ + +MODULE = Devel::DProf PACKAGE = Devel::DProf + +void +END() + PPCODE: + if( DBsub ){ + /* maybe the process forked--we want only + * the parent's profile. + */ + if( prof_pid == (int)getpid() ){ + rprof_end = Times(&prof_end); + DBG_TIMER_NOTIFY("Profiler timer is off.\n"); + prof_record(); + } + } + +void +NONESUCH() + +BOOT: + /* Before we go anywhere make sure we were invoked + * properly, else we'll dump core. + */ + if( ! DBsub ) + croak("DProf: run perl with -d to use DProf.\n"); + + /* When we hook up the XS DB::sub we'll be redefining + * the DB::sub from the PM file. Turn off warnings + * while we do this. + */ + { + I32 warn_tmp = dowarn; + dowarn = 0; + newXS("DB::sub", XS_DB_sub, file); + newXS("DB::goto", XS_DB_goto, file); + dowarn = warn_tmp; + } + + Sub = GvSV(DBsub); /* name of current sub */ + sv_setiv( DBsingle, 0 ); /* disable DB single-stepping */ + + { + char *buffer = getenv("PERL_DPROF_BUFFER"); + + if (buffer) { + SAVE_STACK = atoi(buffer); + } + + buffer = getenv("PERL_DPROF_TICKS"); + + if (buffer) { + dprof_ticks = atoi(buffer); /* Used under OS/2 only */ + } else { + dprof_ticks = HZ; + } + } + + if( (fp = fopen( "tmon.out", "w" )) == NULL ) + croak("DProf: unable to write tmon.out, errno = %d\n", errno ); +#ifdef PERLDBf_NONAME + default_perldb = PERLDBf_NONAME | PERLDBf_SUB; /* no name needed. */ +#ifdef PERLDBf_GOTO + default_perldb = default_perldb | PERLDBf_GOTO; +#endif + cv_hash = newHV(); +#else +# ifdef PERLDBf_SUB + default_perldb = PERLDBf_SUB; /* debug subroutines only. */ +# endif +#endif + prof_pid = (int)getpid(); + + New( 0, profstack, profstack_max, PROFANY ); + + prof_recordheader(); + + DBG_TIMER_NOTIFY("Profiler timer is on.\n"); + orealtime = rprof_start = Times(&prof_start); + otms_utime = prof_start.tms_utime; + otms_stime = prof_start.tms_stime; + perldb = default_perldb; diff --git a/ext/DProf/Makefile.PL b/ext/DProf/Makefile.PL new file mode 100644 index 0000000..ec23edb --- /dev/null +++ b/ext/DProf/Makefile.PL @@ -0,0 +1,55 @@ +use ExtUtils::MakeMaker; +require 5.003; +die qq{ + +Your perl is too old for this version of DProf. The last version of +DProf that works for perls older than 5.004 is DProf-19960930 and +should be available from Dean Roehrich\'s directory on CPAN: + + CPAN/authors/id/DMR/ + +Please either upgrade your perl or get that older DProf from CPAN. + +} if $] < 5.004; + +if ($] < 5.005) { + $defines = ''; +} else { + $defines = '-DPERLDBf_NONAME=0x40 -DPERLDBf_GOTO=0x80 -DG_NODEBUG=32 -DPL_NEEDED'; +} + +$Verbose = 1; +WriteMakefile( + 'NAME' => 'Devel::DProf', + 'DISTNAME' => 'DProf', + 'VERSION_FROM' => 'DProf.pm', + 'clean' => {'FILES' => 'tmon.out t/tmon.out t/err dprofpp T/tmon.out'}, + 'EXE_FILES' => ['dprofpp'], + 'PL_FILES' => {'dprofpp.PL' => 'dprofpp'}, + 'XSPROTOARG' => '-noprototypes', + 'DEFINE' => $defines, + 'dist' => { COMPRESS => 'gzip', SUFFIX => 'gz' }, +); + +sub MY::test_via_harness { "" } +#sub MY::test_via_harness { +# my( $self, $perl, $tests ) = @_; +# my $t = quotemeta( $tests ); +# my $res; +# +# $res = $self->MM::test_via_harness( $perl, $tests ); +# $res =~ s/^(\s+)/$1-/; +# $res =~ s/(&runtests)/\$\$switches $1/; +# $res =~ s/(; runtests)/; \$\$switches=q{-d:DProf}$1/; +# $res =~ s,$t,t/bug.t,; +# $res; +#} + +sub MY::test_via_script { + my( $self, $perl, $script ) = @_; + my $res; + + $res = $self->MM::test_via_script( $perl, $script ); + $res =~ s/(test.pl)/$1 -p $perl/; + $res; +} diff --git a/ext/DProf/Todo b/ext/DProf/Todo new file mode 100644 index 0000000..0e00347 --- /dev/null +++ b/ext/DProf/Todo @@ -0,0 +1,13 @@ +- work on test suite. +- localize the depth to guard against non-local exits. +Current overhead (with PERLDBf_NONAME) wrt non-debugging run (estimates): + 8% extra call frame on DB::sub + 7% output of subroutine data + 70% output of timing data (on OS/2, 35% with custom dprof_times()) +(Additional 17% are spent to write the output, but they are counted + and subtracted.) + +With compensation for DProf overhead all but some odd 12% are subtracted ?! + +- Calculate overhead/count for XS calls and Perl calls separately. +- goto &XSUB in pp_ctl.c; diff --git a/ext/DProf/dprofpp.PL b/ext/DProf/dprofpp.PL new file mode 100644 index 0000000..c513062 --- /dev/null +++ b/ext/DProf/dprofpp.PL @@ -0,0 +1,800 @@ +#!/usr/local/bin/perl + +use Config; +use File::Basename qw(&basename &dirname); + +# List explicitly here the variables you want Configure to +# generate. Metaconfig only looks for shell variables, so you +# have to mention them as if they were shell variables, not +# %Config entries. Thus you write +# $startperl +# to ensure Configure will look for $Config{startperl}. + +# This forces PL files to create target in same directory as PL file. +# This is so that make depend always knows where to find PL derivatives. +chdir(dirname($0)); +($file = basename($0)) =~ s/\.PL$//; +$file =~ s/\.pl$// + if ($Config{'osname'} eq 'VMS' or + $Config{'osname'} eq 'OS2'); # "case-forgiving" + +print "Pulling version from Makefile for dprofpp...\n"; +my $VERSION = 0; +open( MK, "){ + if( /^VERSION\s*=\s*(\d+)/ ){ + $VERSION = $1; + last; + } +} +close MK; +if( $VERSION == 0 ){ + die "Did not find VERSION in Makefile"; +} +print " version is ($VERSION).\n"; + +open OUT,">$file" or die "Can't create $file: $!"; + +print "Extracting $file (with variable substitutions)\n"; + +# In this section, perl variables will be expanded during extraction. +# You can use $Config{...} to use Configure variables. + +print OUT <<"!GROK!THIS!"; +$Config{'startperl'} + eval 'exec perl -S \$0 "\$@"' + if 0; + +require 5.003; + +my \$VERSION = $VERSION; + +!GROK!THIS! + +# In the following, perl variables are not expanded during extraction. + +print OUT <<'!NO!SUBS!'; +=head1 NAME + +dprofpp - display perl profile data + +=head1 SYNOPSIS + +dprofpp [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] + +dprofpp B<-T> [B<-F>] [B<-g subroutine>] [profile] + +dprofpp B<-t> [B<-F>] [B<-g subroutine>] [profile] + +dprofpp B<-p script> [B<-Q>] [other opts] + +dprofpp B<-V> [profile] + +=head1 DESCRIPTION + +The I command interprets profile data produced by a profiler, such +as the Devel::DProf profiler. Dprofpp will read the file F and +will display the 15 subroutines which are using the most time. By default +the times for each subroutine are given exclusive of the times of their +child subroutines. + +To profile a Perl script run the perl interpreter with the B<-d> switch. So +to profile script F with Devel::DProf the following command should +be used. + + $ perl5 -d:DProf test.pl + +Then run dprofpp to analyze the profile. + + $ dprofpp -u + Total Elapsed Time = 1.67 Seconds + User Time = 0.61 Seconds + Exclusive Times + %Time Seconds #Calls sec/call Name + 52.4 0.320 2 0.1600 main::foo + 45.9 0.280 200 0.0014 main::bar + 0.00 0.000 1 0.0000 DynaLoader::import + 0.00 0.000 1 0.0000 main::baz + +The dprofpp tool can also run the profiler before analyzing the profile +data. The above two commands can be executed with one dprofpp command. + + $ dprofpp -u -p test.pl + +Consult L for a description of the raw profile. + +=head1 OPTIONS + +=over 5 + +=item B<-a> + +Sort alphabetically by subroutine names. + +=item B<-A> + +Count timing for autoloaded subroutine as timing for C<*::AUTOLOAD>. +Otherwise the time to autoload it is counted as time of the subroutine +itself (there is no way to separate autoload time from run time). + +This is going to be irrelevant with newer Perls. They will inform +C I the C switches to actual subroutine, +so a separate statistics for C will be collected no matter +whether this option is set. + +=item B<-R> + +Count anonymous subroutines defined in the same package separately. + +=item B<-E> + +(default) Display all subroutine times exclusive of child subroutine times. + +=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<-I> + +Display all subroutine times inclusive of child subroutine times. + +=item B<-l> + +Sort by number of calls to the subroutines. This may help identify +candidates for inlining. + +=item B<-O cnt> + +Show only I subroutines. The default is 15. + +=item B<-p script> + +Tells dprofpp that it should profile the given script and then interpret its +profile data. See B<-Q>. + +=item B<-Q> + +Used with B<-p> to tell dprofpp to quit after profiling the script, without +interpreting the data. + +=item B<-q> + +Do not display column headers. + +=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<-T> + +Display subroutine call tree to stdout. Subroutine statistics are +not displayed. + +=item B<-t> + +Display subroutine call tree to stdout. Subroutine statistics are not +displayed. When a function is called multiple consecutive times at the same +calling level then it is displayed once with a repeat count. + +=item B<-S> + +Display I subroutine call tree to stdout. Statistics is +displayed for each branch of the tree. + +When a function is called multiple (I) +times in the same branch then all these calls go into one branch of +the next level. A repeat count is output together with combined +inclusive, exclusive and kids time. + +Branches are sorted w.r.t. inclusive time. + +=item B<-U> + +Do not sort. Display in the order found in the raw profile. + +=item B<-u> + +Display user times rather than user+system times. + +=item B<-V> + +Print dprofpp's version number and exit. If a raw profile is found then its +XS_VERSION variable will be displayed, too. + +=item B<-v> + +Sort by average time spent in subroutines during each call. This may help +identify candidates for inlining. + +=item B<-z> + +(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<-g> C + +Ignore subroutines except C and whatever is called from it. + +=back + +=head1 ENVIRONMENT + +The environment variable B can be set to a string containing +options for dprofpp. You might use this if you prefer B<-I> over B<-E> or +if you want B<-F> on all the time. + +This was added fairly lazily, so there are some undesirable side effects. +Options on the commandline should override options in DPROFPP_OPTS--but +don't count on that in this version. + +=head1 BUGS + +Applications which call _exit() or exec() from within a subroutine +will leave an incomplete profile. See the B<-F> option. + +Any bugs in Devel::DProf, or any profiler generating the profile data, could +be visible here. See L. + +Mail bug reports and feature requests to the perl5-porters mailing list at +Fperl5-porters@perl.orgE>. Bug reports should include the +output of the B<-V> option. + +=head1 FILES + + dprofpp - profile processor + tmon.out - raw profile + +=head1 SEE ALSO + +L, L, times(2) + +=cut + +use Getopt::Std 'getopts'; +use Config '%Config'; + +Setup: { + my $options = 'O:g:lzaAvuTtqrRsUFEIp:QVS'; + + $Monfile = 'tmon.out'; + if( exists $ENV{DPROFPP_OPTS} ){ + my @tmpargv = @ARGV; + @ARGV = split( ' ', $ENV{DPROFPP_OPTS} ); + getopts( $options ); + if( @ARGV ){ + # there was a filename. + $Monfile = shift; + } + @ARGV = @tmpargv; + } + + getopts( $options ); + if( @ARGV ){ + # there was a filename, it overrides any earlier name. + $Monfile = shift; + } + +# -O cnt Specifies maximum number of subroutines to display. +# -a Sort by alphabetic name of subroutines. +# -z 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. +# -t Show call tree, compressed. +# -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. +# -E Sub times are reported exclusive of child times. (default) +# -I Sub times are reported inclusive of child times. +# -V Print dprofpp's version. +# -p script Specifies name of script to be profiled. +# -Q Used with -p to indicate the dprofpp should quit after +# profiling the script, without interpreting the data. +# -A count autoloaded to *AUTOLOAD +# -R count anonyms separately even if from the same package +# -g subr count only those who are SUBR or called from SUBR +# -S Create statistics for all the depths + + if( defined $opt_V ){ + my $fh = 'main::fh'; + print "$0 version: $VERSION\n"; + open( $fh, "<$Monfile" ) && do { + local $XS_VERSION = 'early'; + header($fh); + close( $fh ); + print "XS_VERSION: $XS_VERSION\n"; + }; + exit(0); + } + $cnt = $opt_O || 15; + $sort = 'by_time'; + $sort = 'by_ctime' if defined $opt_I; + $sort = 'by_calls' if defined $opt_l; + $sort = 'by_alpha' if defined $opt_a; + $sort = 'by_avgcpu' if defined $opt_v; + $incl_excl = 'Exclusive'; + $incl_excl = 'Inclusive' if defined $opt_I; + $whichtime = 'User+System'; + $whichtime = 'System' if defined $opt_s; + $whichtime = 'Real' if defined $opt_r; + $whichtime = 'User' if defined $opt_u; + + if( defined $opt_p ){ + my $prof = 'DProf'; + my $startperl = $Config{'startperl'}; + + $startperl =~ s/^#!//; # remove shebang + run_profiler( $opt_p, $prof, $startperl ); + $Monfile = 'tmon.out'; # because that's where it is + exit(0) if defined $opt_Q; + } + elsif( defined $opt_Q ){ + die "-Q is meaningful only when used with -p\n"; + } +} + +Main: { + my $monout = $Monfile; + my $fh = 'main::fh'; + local $names = {}; + local $times = {}; # times in hz + local $ctimes = {}; # Cumulative 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; + local $deep_times = {count => 0 , kids => {}, incl_time => 0}; + local $time_precision = 2; + local $overhead = 0; + + open( $fh, "<$monout" ) || die "Unable to open $monout\n"; + + header($fh); + + $rrun_ustime = $rrun_utime + $rrun_stime; + + $~ = 'STAT'; + if( ! $opt_q ){ + $^ = 'CSTAT_top'; + } + + parsestack( $fh, $names, $calls, $times, $ctimes, $idkeys ); + + settime( \$runtime, $hz ) unless $opt_g; + + exit(0) if $opt_T || $opt_t; + + if( $opt_v ){ + percalc( $calls, ($opt_I ? $ctimes : $times), $persecs, $idkeys ); + } + if( ! $opt_U ){ + @a = sort $sort @$idkeys; + $a = \@a; + } + else { + $a = $idkeys; + } + display( $runtime, $hz, $names, $calls, $times, $ctimes, $cnt, $a, + $deep_times); +} + + +# 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 - $overhead - $over_rtime * $total_marks/$over_tests/2)/$hz; + } + elsif( $opt_s ){ + $$runtime = ($rrun_stime - $overhead - $over_stime * $total_marks/$over_tests/2)/$hz; + } + elsif( $opt_u ){ + $$runtime = ($rrun_utime - $overhead - $over_utime * $total_marks/$over_tests/2)/$hz; + } + else{ + $$runtime = ($rrun_ustime - $overhead - ($over_utime + $over_stime) * $total_marks/$over_tests/2)/$hz; + } + $$runtime = 0 unless $$runtime > 0; +} + +sub exclusives_in_tree { + my( $deep_times ) = @_; + my $kids_time = 0; + my $kid; + # When summing, take into account non-rounded-up kids time. + for $kid (keys %{$deep_times->{kids}}) { + $kids_time += $deep_times->{kids}{$kid}{incl_time}; + } + $kids_time = 0 unless $kids_time >= 0; + $deep_times->{excl_time} = $deep_times->{incl_time} - $kids_time; + $deep_times->{excl_time} = 0 unless $deep_times->{excl_time} >= 0; + for $kid (keys %{$deep_times->{kids}}) { + exclusives_in_tree($deep_times->{kids}{$kid}); + } + $deep_times->{incl_time} = 0 unless $deep_times->{incl_time} >= 0; + $deep_times->{kids_time} = $kids_time; +} + +sub kids_by_incl { $kids{$b}{incl_time} <=> $kids{$a}{excl_time} + or $a cmp $b } + +sub display_tree { + my( $deep_times, $name, $level ) = @_; + exclusives_in_tree($deep_times); + + my $kid; + local *kids = $deep_times->{kids}; # %kids + + my $time; + if (%kids) { + $time = sprintf '%.*fs = (%.*f + %.*f)', + $time_precision, $deep_times->{incl_time}/$hz, + $time_precision, $deep_times->{excl_time}/$hz, + $time_precision, $deep_times->{kids_time}/$hz; + } else { + $time = sprintf '%.*f', $time_precision, $deep_times->{incl_time}/$hz; + } + print ' ' x (2*$level), "$name x $deep_times->{count} \t${time}s\n" + if $deep_times->{count}; + + for $kid (sort kids_by_incl keys %kids) { + display_tree( $deep_times->{kids}{$kid}, $kid, $level + 1 ); + } +} + +# Report the times in seconds. +sub display { + my( $runtime, $hz, $names, $calls, $times, $ctimes, $cnt, + $idkeys, $deep_times ) = @_; + my( $x, $key, $s, $cs ); + #format: $ncalls, $name, $secs, $percall, $pcnt + + if ($opt_S) { + display_tree( $deep_times, 'toplevel', -1 ) + } else { + for( $x = 0; $x < @$idkeys; ++$x ){ + $key = $idkeys->[$x]; + $ncalls = $calls->{$key}; + $name = $names->{$key}; + $s = $times->{$key}/$hz; + $secs = sprintf("%.3f", $s ); + $cs = $ctimes->{$key}/$hz; + $csecs = sprintf("%.3f", $cs ); + $percall = sprintf("%.4f", $s/$ncalls ); + $cpercall = sprintf("%.4f", $cs/$ncalls ); + $pcnt = sprintf("%.2f", + $runtime? ((($opt_I ? $csecs : $secs) / $runtime) * 100.0): 0 ); + write; + $pcnt = $secs = $ncalls = $percall = ""; + write while( length $name ); + last unless --$cnt; + } + } +} + +sub move_keys { + my ($source, $dest) = @_; + my $kid; + + for $kid (keys %$source) { + if (exists $dest->{$kid}) { + $dest->{count} += $source->{count}; + $dest->{incl_time} += $source->{incl_time}; + move_keys($source->{kids},$dest->{kids}); + } else { + $dest->{$kid} = delete $source->{$kid}; + } + } +} + +sub add_to_tree { + my ($curdeep_times, $name, $t) = @_; + if ($name ne $curdeep_times->[-1]{name} and $opt_A) { + $name = $curdeep_times->[-1]{name}; + } + die "Shorted?!" unless @$curdeep_times >= 2; + $curdeep_times->[-2]{kids}{$name} = { count => 0 , kids => {}, + incl_time => 0, + } + unless exists $curdeep_times->[-2]{kids}{$name}; + my $entry = $curdeep_times->[-2]{kids}{$name}; + # Now transfer to the new node (could not do earlier, since name can change) + $entry->{count}++; + $entry->{incl_time} += $t - $curdeep_times->[-1]{enter_stamp}; + # Merge the kids? + move_keys($curdeep_times->[-1]->{kids},$entry->{kids}); + pop @$curdeep_times; +} + +sub parsestack { + my( $fh, $names, $calls, $times, $ctimes, $idkeys ) = @_; + my( $dir, $name ); + my( $t, $syst, $realt, $usert ); + my( $x, $z, $c, $id, $pack ); + my @stack = (); + my @tstack = (); + my $tab = 3; + my $in = 0; + + # remember last call depth and function name + my $l_in = $in; + my $l_name = ''; + my $repcnt = 0; + my $repstr = ''; + my $dprof_t = 0; + my $dprof_stamp; + my %cv_hash; + my $in_level = not defined $opt_g; # Level deep in report grouping + my $curdeep_times = [$deep_times]; + + my $over_per_call; + if ( $opt_u ) { $over_per_call = $over_utime } + elsif( $opt_s ) { $over_per_call = $over_stime } + elsif( $opt_r ) { $over_per_call = $over_rtime } + else { $over_per_call = $over_utime + $over_stime } + $over_per_call /= 2*$over_tests; # distribute over entry and exit + + while(<$fh>){ + next if /^#/; + last if /^PART/; + + chop; + if (/^&/) { + ($dir, $id, $pack, $name) = split; + if ($opt_R and ($name =~ /::(__ANON_|END)$/)) { + $name .= "($id)"; + } + $cv_hash{$id} = "$pack\::$name"; + next; + } + ($dir, $usert, $syst, $realt, $name) = split; + + my $ot = $t; + if ( $dir eq '/' ) { + $syst = $stack[-1][0]; + $usert = '&'; + $dir = '-'; + #warn("Inserted exit for $stack[-1][0].\n") + } + if (defined $realt) { # '+ times nam' '- times nam' or '@ incr' + if ( $opt_u ) { $t = $usert } + elsif( $opt_s ) { $t = $syst } + elsif( $opt_r ) { $t = $realt } + else { $t = $usert + $syst } + $t += $ot, next if $dir eq '@'; # Increments there + } else { + # "- id" or "- & name" + $name = defined $syst ? $syst : $cv_hash{$usert}; + } + + next unless $in_level or $name eq $opt_g or $dir eq '*'; + if ( $dir eq '-' or $dir eq '*' ) { + my $ename = $dir eq '*' ? $stack[-1][0] : $name; + $overhead += $over_per_call; + if ($name eq "Devel::DProf::write") { + $dprof_t += $t - $dprof_stamp; + next; + } elsif (defined $opt_g and $ename eq $opt_g) { + $in_level--; + } + add_to_tree($curdeep_times, $ename, + $t - $dprof_t - $overhead) if $opt_S; + exitstamp( \@stack, \@tstack, + $t - $dprof_t - $overhead, + $times, $ctimes, $ename, \$in, $tab, + $curdeep_times ); + } + next unless $in_level or $name eq $opt_g; + if( $dir eq '+' or $dir eq '*' ){ + if ($name eq "Devel::DProf::write") { + $dprof_stamp = $t; + next; + } elsif (defined $opt_g and $name eq $opt_g) { + $in_level++; + } + $overhead += $over_per_call; + if( $opt_T ){ + print ' ' x $in, "$name\n"; + $in += $tab; + } + elsif( $opt_t ){ + # suppress output on same function if the + # same calling level is called. + if ($l_in == $in and $l_name eq $name) { + $repcnt++; + } else { + $repstr = ' ('.++$repcnt.'x)' + if $repcnt; + print ' ' x $l_in, "$l_name$repstr\n" + if $l_name ne ''; + $repstr = ''; + $repcnt = 0; + $l_in = $in; + $l_name = $name; + } + $in += $tab; + } + if( ! defined $names->{$name} ){ + $names->{$name} = $name; + $times->{$name} = 0; + $ctimes->{$name} = 0; + push( @$idkeys, $name ); + } + $calls->{$name}++; + push @$curdeep_times, { kids => {}, + name => $name, + enter_stamp => $t - $dprof_t - $overhead, + } if $opt_S; + $x = [ $name, $t - $dprof_t - $overhead ]; + push( @stack, $x ); + + # my children will put their time here + push( @tstack, 0 ); + } elsif ($dir ne '-'){ + die "Bad profile: $_"; + } + } + if( $opt_t ){ + $repstr = ' ('.++$repcnt.'x)' if $repcnt; + print ' ' x $l_in, "$l_name$repstr\n"; + } + + if( @stack ){ + if( ! $opt_F ){ + warn "Garbled profile is missing some exit time stamps:\n"; + foreach $x (@stack) { + print $x->[0],"\n"; + } + die "Try rerunning dprofpp with -F.\n"; + # I don't want -F to be default behavior--yet + # 9/18/95 dmr + } + else{ + warn( "Faking " . scalar( @stack ) . " exit timestamp(s).\n"); + foreach $x ( reverse @stack ){ + $name = $x->[0]; + exitstamp( \@stack, \@tstack, + $t - $dprof_t - $overhead, $times, + $ctimes, $name, \$in, $tab, + $curdeep_times ); + add_to_tree($curdeep_times, $name, + $t - $dprof_t - $overhead) + if $opt_S; + } + } + } + if (defined $opt_g) { + $runtime = $ctimes->{$opt_g}/$hz; + $runtime = 0 unless $runtime > 0; + } +} + +sub exitstamp { + my($stack, $tstack, $t, $times, $ctimes, $name, $in, $tab, $deep) = @_; + my( $x, $c, $z ); + + $x = pop( @$stack ); + if( ! defined $x ){ + die "Garbled profile, missing an enter time stamp"; + } + if( $x->[0] ne $name ){ + if ($x->[0] =~ /::AUTOLOAD$/) { + if ($opt_A) { + $name = $x->[0]; + } + } elsif ( $opt_F ) { + warn( "Garbled profile, faking exit timestamp:\n\t$name => $x->[0].\n"); + $name = $x->[0]; + } else { + foreach $z (@stack, $x) { + print $z->[0],"\n"; + } + die "Garbled profile, unexpected exit time stamp"; + } + } + if( $opt_T || $opt_t ){ + $$in -= $tab; + } + # collect childtime + $c = pop( @$tstack ); + # total time this func has been active + $z = $t - $x->[1]; + $ctimes->{$name} += $z; + $times->{$name} += ($z > $c)? $z - $c: 0; + # 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 /^#/; + last if /^PART/; + eval; + } + $over_tests = 1 unless $over_tests; + $time_precision = length int ($hz - 1); # log ;-) +} + + +# 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; + } +} + + +# Runs the given script with the given profiler and the given perl. +sub run_profiler { + my $script = shift; + my $profiler = shift; + my $startperl = shift; + + system $startperl, "-d:$profiler", $script; + if( $? / 256 > 0 ){ + die "Failed: $startperl -d:$profiler $script: $!"; + } +} + + +sub by_time { $times->{$b} <=> $times->{$a} } +sub by_ctime { $ctimes->{$b} <=> $ctimes->{$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 - $overhead - $over_rtime * $total_marks/$over_tests/2) / $hz) + @>>>>>>>>>> Time = @>>>>>>> Seconds +$whichtime, $runtime +@<<<<<<<< Times +$incl_excl +%Time ExclSec CumulS #Calls sec/call Csec/c Name +. + +format STAT = + ^>>> ^>>>> ^>>>>> ^>>>>> ^>>>>> ^>>>>> ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< +$pcnt, $secs, $csecs, $ncalls, $percall, $cpercall, $name +. + +!NO!SUBS! + +close OUT or die "Can't close $file: $!"; +chmod 0755, $file or die "Can't reset permissions for $file: $!\n"; +exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':'; diff --git a/ext/DProf/t/V.pm b/ext/DProf/t/V.pm new file mode 100644 index 0000000..e8d59a8 --- /dev/null +++ b/ext/DProf/t/V.pm @@ -0,0 +1,65 @@ +package V; + +use Getopt::Std 'getopts'; +getopts('vp:'); + +require Exporter; +@ISA = 'Exporter'; + +@EXPORT = qw( dprofpp $opt_v $results $expected report @results ); +@EXPORT_OK = qw( notok ok $num ); + +my $out = 0; +$num = 0; +$results = $expected = ''; +$perl = $opt_p || $^X; + +print "\nperl: $perl\n" if $opt_v; +if( ! -f $perl ){ die "Where's Perl?" } + +sub dprofpp { + my $switches = shift; + + open( D, "$perl ../dprofpp $switches 2> err |" ) || warn "$0: Can't run. $!\n"; + @results = ; + close D; + + open( D, "; + close D; + push( @results, @err ) if @err; + + $results = qq{@results}; + # ignore Loader (Dyna/Auto etc), leave newline + $results =~ s/^\w+Loader::import//; + $results =~ s/\n /\n/gm; + $results; +} + +sub report { + $num = shift; + my $sub = shift; + my $x; + + $x = &$sub; + $x ? &ok : ¬ok; +} + +sub ok { + ++$out; + print "ok $num, "; +} + +sub notok { + ++$out; + print "not ok $num, "; + if( $opt_v ){ + print "\nResult\n{$results}\n"; + print "Expected\n{$expected}\n"; + } +} + +END { print "\n" if $out } + + +1; diff --git a/ext/DProf/t/test1.pl b/ext/DProf/t/test1.pl new file mode 100644 index 0000000..af792ed --- /dev/null +++ b/ext/DProf/t/test1.pl @@ -0,0 +1,32 @@ +END { print "main:: the end\n" } +sub FOO::END { print "foo:: the end\n" } + + +sub foo { + my $x; + my $y; + print "in sub foo\n"; + for( $x = 1; $x < 100; ++$x ){ + bar(); + for( $y = 1; $y < 100; ++$y ){ + } + } +} + +sub bar { + my $x; + print "in sub bar\n"; + for( $x = 1; $x < 100; ++$x ){ + } +} + +sub baz { + print "in sub baz\n"; + bar(); + foo(); +} + +bar(); +baz(); +foo(); + diff --git a/ext/DProf/t/test1.t b/ext/DProf/t/test1.t new file mode 100644 index 0000000..d504cd5 --- /dev/null +++ b/ext/DProf/t/test1.t @@ -0,0 +1,18 @@ +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(); diff --git a/ext/DProf/t/test1.v b/ext/DProf/t/test1.v new file mode 100644 index 0000000..542a503 --- /dev/null +++ b/ext/DProf/t/test1.v @@ -0,0 +1,24 @@ +# perl + +use V; + +dprofpp( '-T' ); +$expected = +qq{main::bar +main::baz + main::bar + main::foo + main::bar +main::foo + main::bar +}; +report 1, sub { $expected eq $results }; + +dprofpp('-TF'); +report 2, sub { $expected eq $results }; + +dprofpp( '-t' ); +report 3, sub { $expected eq $results }; + +dprofpp('-tF'); +report 4, sub { $expected eq $results }; diff --git a/ext/DProf/t/test2.t b/ext/DProf/t/test2.t new file mode 100644 index 0000000..edc46c5 --- /dev/null +++ b/ext/DProf/t/test2.t @@ -0,0 +1,21 @@ +sub foo { + print "in sub foo\n"; + bar(); +} + +sub bar { + print "in sub bar\n"; +} + +sub baz { + print "in sub baz\n"; + bar(); + bar(); + bar(); + foo(); +} + +bar(); +bar(); +baz(); +foo(); diff --git a/ext/DProf/t/test2.v b/ext/DProf/t/test2.v new file mode 100644 index 0000000..3e9b183 --- /dev/null +++ b/ext/DProf/t/test2.v @@ -0,0 +1,36 @@ +# perl + +use V; + +dprofpp( '-T' ); +$expected = +qq{main::bar +main::bar +main::baz + main::bar + main::bar + main::bar + main::foo + main::bar +main::foo + main::bar +}; +report 1, sub { $expected eq $results }; + +dprofpp('-TF'); +report 2, sub { $expected eq $results }; + +dprofpp( '-t' ); +$expected = +qq{main::bar (2x) +main::baz + main::bar (3x) + main::foo + main::bar +main::foo + main::bar +}; +report 3, sub { $expected eq $results }; + +dprofpp('-tF'); +report 4, sub { $expected eq $results }; diff --git a/ext/DProf/t/test3.t b/ext/DProf/t/test3.t new file mode 100644 index 0000000..a5327f4 --- /dev/null +++ b/ext/DProf/t/test3.t @@ -0,0 +1,19 @@ +sub foo { + print "in sub foo\n"; + exit(0); + bar(); +} + +sub bar { + print "in sub bar\n"; +} + +sub baz { + print "in sub baz\n"; + bar(); + foo(); +} + +bar(); +baz(); +foo(); diff --git a/ext/DProf/t/test3.v b/ext/DProf/t/test3.v new file mode 100644 index 0000000..31211c1 --- /dev/null +++ b/ext/DProf/t/test3.v @@ -0,0 +1,29 @@ +# perl + +use V; + +dprofpp( '-T' ); +$e1 = $expected = +qq{main::bar +main::baz + main::bar + main::foo +}; +report 1, sub { $expected eq $results }; + +dprofpp('-TF'); +$e2 = $expected = +qq{main::bar +main::baz + main::bar + main::foo +}; +report 2, sub { $expected eq $results }; + +dprofpp( '-t' ); +$expected = $e1; +report 3, sub { 1 }; + +dprofpp('-tF'); +$expected = $e2; +report 4, sub { $expected eq $results }; diff --git a/ext/DProf/t/test4.t b/ext/DProf/t/test4.t new file mode 100644 index 0000000..7d5a356 --- /dev/null +++ b/ext/DProf/t/test4.t @@ -0,0 +1,24 @@ +sub foo { + print "in sub foo\n"; + bar(); +} + +sub bar { + print "in sub bar\n"; +} + +sub baz { + print "in sub baz\n"; + bar(); + bar(); + bar(); + foo(); +} + +bar(); + +fork; + +bar(); +baz(); +foo(); diff --git a/ext/DProf/t/test4.v b/ext/DProf/t/test4.v new file mode 100644 index 0000000..3e9b183 --- /dev/null +++ b/ext/DProf/t/test4.v @@ -0,0 +1,36 @@ +# perl + +use V; + +dprofpp( '-T' ); +$expected = +qq{main::bar +main::bar +main::baz + main::bar + main::bar + main::bar + main::foo + main::bar +main::foo + main::bar +}; +report 1, sub { $expected eq $results }; + +dprofpp('-TF'); +report 2, sub { $expected eq $results }; + +dprofpp( '-t' ); +$expected = +qq{main::bar (2x) +main::baz + main::bar (3x) + main::foo + main::bar +main::foo + main::bar +}; +report 3, sub { $expected eq $results }; + +dprofpp('-tF'); +report 4, sub { $expected eq $results }; diff --git a/ext/DProf/t/test5.t b/ext/DProf/t/test5.t new file mode 100644 index 0000000..0b11137 --- /dev/null +++ b/ext/DProf/t/test5.t @@ -0,0 +1,25 @@ +# Test that dprof doesn't break +# &bar; used as &bar(@_); + +sub foo1 { + print "in foo1(@_)\n"; + bar(@_); +} +sub foo2 { + print "in foo2(@_)\n"; + &bar; +} +sub bar { + print "in bar(@_)\n"; + if( @_ > 0 ){ + &yeppers; + } +} +sub yeppers { + print "rest easy\n"; +} + + +&foo1( A ); +&foo2( B ); + diff --git a/ext/DProf/t/test5.v b/ext/DProf/t/test5.v new file mode 100644 index 0000000..8f90252 --- /dev/null +++ b/ext/DProf/t/test5.v @@ -0,0 +1,15 @@ +# perl + +use V; + +dprofpp( '-T' ); +$expected = +qq{main::foo1 + main::bar + main::yeppers +main::foo2 + main::bar + main::yeppers +}; +report 1, sub { $expected eq $results }; + diff --git a/ext/DProf/t/test6.t b/ext/DProf/t/test6.t new file mode 100644 index 0000000..7b8bf4a --- /dev/null +++ b/ext/DProf/t/test6.t @@ -0,0 +1,29 @@ +sub foo { + my $x; + my $y; + print "in sub foo\n"; + for( $x = 1; $x < 100; ++$x ){ + bar(); + for( $y = 1; $y < 100; ++$y ){ + } + } +} + +sub bar { + my $x; + print "in sub bar\n"; + for( $x = 1; $x < 100; ++$x ){ + } + die "bar exiting"; +} + +sub baz { + print "in sub baz\n"; + eval { bar(); }; + eval { foo(); }; +} + +eval { bar(); }; +baz(); +eval { foo(); }; + diff --git a/ext/DProf/t/test6.v b/ext/DProf/t/test6.v new file mode 100644 index 0000000..1236285 --- /dev/null +++ b/ext/DProf/t/test6.v @@ -0,0 +1,16 @@ +# perl + +use V; + +dprofpp( '-T' ); +$expected = +qq{main::bar +main::baz + main::bar + main::foo + main::bar +main::foo + main::bar +}; +report 1, sub { $expected eq $results }; + diff --git a/ext/DProf/test.pl b/ext/DProf/test.pl new file mode 100644 index 0000000..a889fec --- /dev/null +++ b/ext/DProf/test.pl @@ -0,0 +1,79 @@ +# perl + +require 5.003; + +use Benchmark qw( timediff timestr ); +use Getopt::Std 'getopts'; +use Config '%Config'; +getopts('vI:p:'); + +# -v Verbose +# -I Add to @INC +# -p Name of perl binary + +unless (-r 'dprofpp' and -M 'dprofpp' <= -M 'dprofpp.PL') { + print STDERR "dprofpp out of date, extracting...\n"; + system 'perl', 'dprofpp.PL' and die 'perl dprofpp.PL: exit code $?, $!'; +} +die "Need dprofpp, could not make it" unless -r 'dprofpp'; + +chdir( 't' ) if -d 't'; +@tests = @ARGV ? @ARGV : sort <*.t *.v>; # glob-sort, for OS/2 + +$path_sep = $Config{path_sep} || ':'; +if( -d '../blib' ){ + unshift @INC, '../blib/arch', '../blib/lib'; +} +$perl5lib = $opt_I || join( $path_sep, @INC ); +$perl = $opt_p || $^X; + +if( $opt_v ){ + print "tests: @tests\n"; + print "perl: $perl\n"; + print "perl5lib: $perl5lib\n"; +} +if( $perl =~ m|^\./| ){ + # turn ./perl into ../perl, because of chdir(t) above. + $perl = ".$perl"; +} +if( ! -f $perl ){ die "Where's Perl?" } + +sub profile { + my $test = shift; + my @results; + local $ENV{PERL5LIB} = $perl5lib; + my $opt_d = '-d:DProf'; + + my $t_start = new Benchmark; + open( R, "$perl $opt_d $test |" ) || warn "$0: Can't run. $!\n"; + @results = ; + close R; + my $t_total = timediff( new Benchmark, $t_start ); + + if( $opt_v ){ + print "\n"; + print @results + } + + print timestr( $t_total, 'nop' ), "\n"; +} + + +sub verify { + my $test = shift; + + system $perl, '-I.', $test, $opt_v?'-v':'', '-p', $perl; +} + + +$| = 1; +while( @tests ){ + $test = shift @tests; + print $test . '.' x (20 - length $test); + if( $test =~ /t$/ ){ + profile $test; + } + else{ + verify $test; + } +}