diff options
Diffstat (limited to 'contrib/perl5/ext/Devel')
| -rw-r--r-- | contrib/perl5/ext/Devel/DProf/Changes | 176 | ||||
| -rw-r--r-- | contrib/perl5/ext/Devel/DProf/DProf.pm | 196 | ||||
| -rw-r--r-- | contrib/perl5/ext/Devel/DProf/DProf.xs | 689 | ||||
| -rw-r--r-- | contrib/perl5/ext/Devel/DProf/Makefile.PL | 17 | ||||
| -rw-r--r-- | contrib/perl5/ext/Devel/DProf/Todo | 13 | ||||
| -rw-r--r-- | contrib/perl5/ext/Devel/Peek/Changes | 64 | ||||
| -rw-r--r-- | contrib/perl5/ext/Devel/Peek/Makefile.PL | 11 | ||||
| -rw-r--r-- | contrib/perl5/ext/Devel/Peek/Peek.pm | 432 | ||||
| -rw-r--r-- | contrib/perl5/ext/Devel/Peek/Peek.xs | 218 |
9 files changed, 1816 insertions, 0 deletions
diff --git a/contrib/perl5/ext/Devel/DProf/Changes b/contrib/perl5/ext/Devel/DProf/Changes new file mode 100644 index 0000000..216498b --- /dev/null +++ b/contrib/perl5/ext/Devel/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/contrib/perl5/ext/Devel/DProf/DProf.pm b/contrib/perl5/ext/Devel/DProf/DProf.pm new file mode 100644 index 0000000..38082fc --- /dev/null +++ b/contrib/perl5/ext/Devel/DProf/DProf.pm @@ -0,0 +1,196 @@ +require 5.005_64; + +=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<test.pl> 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<tmon.out>. A tool like I<dprofpp> 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<dprofpp> 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<PART2> 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<id> 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 +I<id>s, and C<goto &subr>. + +The I<old-style> 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<perlsub/"Autoloading">. + +=head1 ENVIRONMENT + +C<PERL_DPROF_BUFFER> sets size of output buffer in words. Defaults to 2**14. + +C<PERL_DPROF_TICKS> sets number of ticks per second on some systems where +a replacement for times() is used. Defaults to the value of C<HZ> macro. + +C<PERL_DPROF_OUT_FILE_NAME> sets the name of the output file. If not set, +defaults to tmon.out. + +=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<current_sub>, 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<mark> it as invalid, but will not +write over it). + +Mail bug reports and feature requests to the perl5-porters mailing list at +F<E<lt>perl5-porters@perl.orgE<gt>>. + +=head1 SEE ALSO + +L<perl>, L<dprofpp>, 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"; +} + +use XSLoader (); + +# Underscore to allow older Perls to access older version from CPAN +$Devel::DProf::VERSION = '20000000.00_00'; # this version not authorized by + # Dean Roehrich. See "Changes" file. + +XSLoader::load 'Devel::DProf', $Devel::DProf::VERSION; + +1; diff --git a/contrib/perl5/ext/Devel/DProf/DProf.xs b/contrib/perl5/ext/Devel/DProf/DProf.xs new file mode 100644 index 0000000..31e984f --- /dev/null +++ b/contrib/perl5/ext/Devel/DProf/DProf.xs @@ -0,0 +1,689 @@ +#define PERL_NO_GET_CONTEXT +#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 + +/* HZ == clock ticks per second */ +#ifdef VMS +# define HZ ((I32)CLK_TCK) +# define DPROF_HZ HZ +# include <starlet.h> /* prototype for sys$gettim() */ +# define Times(ptr) (dprof_times(aTHX_ ptr)) +#else +# ifndef HZ +# ifdef CLK_TCK +# define HZ ((I32)CLK_TCK) +# else +# define HZ 60 +# endif +# endif +# ifdef OS2 /* times() has significant overhead */ +# define Times(ptr) (dprof_times(aTHX_ ptr)) +# define INCL_DOSPROFILE +# define INCL_DOSERRORS +# include <os2.h> +# define toLongLong(arg) (*(long long*)&(arg)) +# define DPROF_HZ g_dprof_ticks +# else +# define Times(ptr) (times(ptr)) +# define DPROF_HZ HZ +# endif +#endif + +XS(XS_Devel__DProf_END); /* used by prof_mark() */ + +/* Everything is built on times(2). See its manpage for a description + * of the timings. + */ + +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; + +typedef struct { + U32 dprof_ticks; + char* out_file_name; /* output file (defaults to tmon.out) */ + PerlIO* fp; /* pointer to tmon.out file */ + long TIMES_LOCATION; /* Where in the file to store the time totals */ + int SAVE_STACK; /* How much data to buffer until end of run */ + int prof_pid; /* pid of profiled process */ + struct tms prof_start; + struct tms prof_end; + clock_t rprof_start; /* elapsed real time ticks */ + clock_t rprof_end; + clock_t wprof_u; + clock_t wprof_s; + clock_t wprof_r; + clock_t otms_utime; + clock_t otms_stime; + clock_t orealtime; + PROFANY* profstack; + int profstack_max; + int profstack_ix; + HV* cv_hash; + U32 total; + U32 lastid; + U32 default_perldb; + U32 depth; +#ifdef OS2 + ULONG frequ; + long long start_cnt; +#endif +#ifdef PERL_IMPLICIT_CONTEXT +# define register + pTHX; +# undef register +#endif +} prof_state_t; + +prof_state_t g_prof_state; + +#define g_dprof_ticks g_prof_state.dprof_ticks +#define g_out_file_name g_prof_state.out_file_name +#define g_fp g_prof_state.fp +#define g_TIMES_LOCATION g_prof_state.TIMES_LOCATION +#define g_SAVE_STACK g_prof_state.SAVE_STACK +#define g_prof_pid g_prof_state.prof_pid +#define g_prof_start g_prof_state.prof_start +#define g_prof_end g_prof_state.prof_end +#define g_rprof_start g_prof_state.rprof_start +#define g_rprof_end g_prof_state.rprof_end +#define g_wprof_u g_prof_state.wprof_u +#define g_wprof_s g_prof_state.wprof_s +#define g_wprof_r g_prof_state.wprof_r +#define g_otms_utime g_prof_state.otms_utime +#define g_otms_stime g_prof_state.otms_stime +#define g_orealtime g_prof_state.orealtime +#define g_profstack g_prof_state.profstack +#define g_profstack_max g_prof_state.profstack_max +#define g_profstack_ix g_prof_state.profstack_ix +#define g_cv_hash g_prof_state.cv_hash +#define g_total g_prof_state.total +#define g_lastid g_prof_state.lastid +#define g_default_perldb g_prof_state.default_perldb +#define g_depth g_prof_state.depth +#ifdef PERL_IMPLICIT_CONTEXT +# define g_THX g_prof_state.aTHX +#endif +#ifdef OS2 +# define g_frequ g_prof_state.frequ +# define g_start_cnt g_prof_state.start_cnt +#endif + +clock_t +dprof_times(pTHX_ struct tms *t) +{ +#ifdef OS2 + ULONG rc; + QWORD cnt; + STRLEN n_a; + + if (!g_frequ) { + if (CheckOSError(DosTmrQueryFreq(&g_frequ))) + croak("DosTmrQueryFreq: %s", SvPV(perl_get_sv("!",TRUE),n_a)); + else + g_frequ = g_frequ/DPROF_HZ; /* count per tick */ + if (CheckOSError(DosTmrQueryTime(&cnt))) + croak("DosTmrQueryTime: %s", + SvPV(perl_get_sv("!",TRUE), n_a)); + g_start_cnt = toLongLong(cnt); + } + + if (CheckOSError(DosTmrQueryTime(&cnt))) + croak("DosTmrQueryTime: %s", SvPV(perl_get_sv("!",TRUE), n_a)); + t->tms_stime = 0; + return (t->tms_utime = (toLongLong(cnt) - g_start_cnt)/g_frequ); +#else /* !OS2 */ +# ifdef VMS + 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 <ints.h> + 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 *)t); + return (clock_t) retval; +# else /* !VMS && !OS2 */ + return times(t); +# endif +#endif +} + +static void +prof_dumpa(pTHX_ opcode ptype, U32 id) +{ + if (ptype == OP_LEAVESUB) { + PerlIO_printf(g_fp,"- %"UVxf"\n", (UV)id); + } + else if(ptype == OP_ENTERSUB) { + PerlIO_printf(g_fp,"+ %"UVxf"\n", (UV)id); + } + else if(ptype == OP_GOTO) { + PerlIO_printf(g_fp,"* %"UVxf"\n", (UV)id); + } + else if(ptype == OP_DIE) { + PerlIO_printf(g_fp,"/ %"UVxf"\n", (UV)id); + } + else { + PerlIO_printf(g_fp,"Profiler unknown prof code %d\n", ptype); + } +} + +static void +prof_dumps(pTHX_ U32 id, char *pname, char *gname) +{ + PerlIO_printf(g_fp,"& %"UVxf" %s %s\n", (UV)id, pname, gname); +} + +static void +prof_dumpt(pTHX_ long tms_utime, long tms_stime, long realtime) +{ + PerlIO_printf(g_fp,"@ %ld %ld %ld\n", tms_utime, tms_stime, realtime); +} + +static void +prof_dump_until(pTHX_ long ix) +{ + long base = 0; + struct tms t1, t2; + clock_t realtime1, realtime2; + + realtime1 = Times(&t1); + + while (base < ix) { + opcode ptype = g_profstack[base++].ptype; + if (ptype == OP_TIME) { + long tms_utime = g_profstack[base++].tms_utime; + long tms_stime = g_profstack[base++].tms_stime; + long realtime = g_profstack[base++].realtime; + + prof_dumpt(aTHX_ tms_utime, tms_stime, realtime); + } + else if (ptype == OP_GV) { + U32 id = g_profstack[base++].id; + char *pname = g_profstack[base++].name; + char *gname = g_profstack[base++].name; + + prof_dumps(aTHX_ id, pname, gname); + } + else { + U32 id = g_profstack[base++].id; + prof_dumpa(aTHX_ ptype, id); + } + } + PerlIO_flush(g_fp); + realtime2 = Times(&t2); + if (realtime2 != realtime1 || t1.tms_utime != t2.tms_utime + || t1.tms_stime != t2.tms_stime) { + g_wprof_r += realtime2 - realtime1; + g_wprof_u += t2.tms_utime - t1.tms_utime; + g_wprof_s += t2.tms_stime - t1.tms_stime; + + PerlIO_printf(g_fp,"+ & Devel::DProf::write\n"); + PerlIO_printf(g_fp,"@ %"IVdf" %"IVdf" %"IVdf"\n", + /* The (IV) casts are one possibility: + * the Painfully Correct Way would be to + * have Clock_t_f. */ + (IV)(t2.tms_utime - t1.tms_utime), + (IV)(t2.tms_stime - t1.tms_stime), + (IV)(realtime2 - realtime1)); + PerlIO_printf(g_fp,"- & Devel::DProf::write\n"); + g_otms_utime = t2.tms_utime; + g_otms_stime = t2.tms_stime; + g_orealtime = realtime2; + PerlIO_flush(g_fp); + } +} + +static void +prof_mark(pTHX_ opcode ptype) +{ + struct tms t; + clock_t realtime, rdelta, udelta, sdelta; + char *name, *pv; + char *hvname; + STRLEN len; + SV *sv; + U32 id; + SV *Sub = GvSV(PL_DBsub); /* name of current sub */ + + if (g_SAVE_STACK) { + if (g_profstack_ix + 5 > g_profstack_max) { + g_profstack_max = g_profstack_max * 3 / 2; + Renew(g_profstack, g_profstack_max, PROFANY); + } + } + + realtime = Times(&t); + rdelta = realtime - g_orealtime; + udelta = t.tms_utime - g_otms_utime; + sdelta = t.tms_stime - g_otms_stime; + if (rdelta || udelta || sdelta) { + if (g_SAVE_STACK) { + g_profstack[g_profstack_ix++].ptype = OP_TIME; + g_profstack[g_profstack_ix++].tms_utime = udelta; + g_profstack[g_profstack_ix++].tms_stime = sdelta; + g_profstack[g_profstack_ix++].realtime = rdelta; + } + else { /* Write it to disk now so's not to eat up core */ + if (g_prof_pid == (int)getpid()) { + prof_dumpt(aTHX_ udelta, sdelta, rdelta); + PerlIO_flush(g_fp); + } + } + g_orealtime = realtime; + g_otms_stime = t.tms_stime; + g_otms_utime = t.tms_utime; + } + + { + SV **svp; + char *gname, *pname; + CV *cv; + + cv = INT2PTR(CV*,SvIVX(Sub)); + svp = hv_fetch(g_cv_hash, (char*)&cv, sizeof(CV*), TRUE); + if (!SvOK(*svp)) { + GV *gv = CvGV(cv); + + sv_setiv(*svp, id = ++g_lastid); + pname = ((GvSTASH(gv) && HvNAME(GvSTASH(gv))) + ? HvNAME(GvSTASH(gv)) + : "(null)"); + gname = GvNAME(gv); + if (CvXSUB(cv) == XS_Devel__DProf_END) + return; + if (g_SAVE_STACK) { /* Store it for later recording -JH */ + g_profstack[g_profstack_ix++].ptype = OP_GV; + g_profstack[g_profstack_ix++].id = id; + g_profstack[g_profstack_ix++].name = pname; + g_profstack[g_profstack_ix++].name = gname; + } + else { /* Write it to disk now so's not to eat up core */ + /* Only record the parent's info */ + if (g_prof_pid == (int)getpid()) { + prof_dumps(aTHX_ id, pname, gname); + PerlIO_flush(g_fp); + } + else + PL_perldb = 0; /* Do not debug the kid. */ + } + } + else { + id = SvIV(*svp); + } + } + + g_total++; + if (g_SAVE_STACK) { /* Store it for later recording -JH */ + g_profstack[g_profstack_ix++].ptype = ptype; + g_profstack[g_profstack_ix++].id = id; + + /* Only record the parent's info */ + if (g_SAVE_STACK < g_profstack_ix) { + if (g_prof_pid == (int)getpid()) + prof_dump_until(aTHX_ g_profstack_ix); + else + PL_perldb = 0; /* Do not debug the kid. */ + g_profstack_ix = 0; + } + } + else { /* Write it to disk now so's not to eat up core */ + + /* Only record the parent's info */ + if (g_prof_pid == (int)getpid()) { + prof_dumpa(aTHX_ ptype, id); + PerlIO_flush(g_fp); + } + else + PL_perldb = 0; /* Do not debug the kid. */ + } +} + +#ifdef PL_NEEDED +# define defstash PL_defstash +#endif + +/* Counts overhead of prof_mark and extra XS call. */ +static void +test_time(pTHX_ 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 = PL_curstash; + struct tms t1, t2; + clock_t realtime1, realtime2; + U32 ototal = g_total; + U32 ostack = g_SAVE_STACK; + U32 operldb = PL_perldb; + + g_SAVE_STACK = 1000000; + realtime1 = Times(&t1); + + while (k < 2) { + i = 0; + /* Disable debugging of perl_call_sv on second pass: */ + PL_curstash = (k == 0 ? PL_defstash : PL_debstash); + PL_perldb = g_default_perldb; + while (++i <= 100) { + j = 0; + g_profstack_ix = 0; /* Do not let the stack grow */ + while (++j <= 100) { +/* prof_mark(aTHX_ OP_ENTERSUB); */ + + PUSHMARK(PL_stack_sp); + perl_call_sv((SV*)cv, G_SCALAR); + PL_stack_sp--; +/* prof_mark(aTHX_ OP_LEAVESUB); */ + } + } + PL_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++; + } + g_total = ototal; + g_SAVE_STACK = ostack; + PL_perldb = operldb; +} + +static void +prof_recordheader(pTHX) +{ + clock_t r, u, s; + + /* g_fp is opened in the BOOT section */ + PerlIO_printf(g_fp, "#fOrTyTwO\n"); + PerlIO_printf(g_fp, "$hz=%"IVdf";\n", (IV)DPROF_HZ); + PerlIO_printf(g_fp, "$XS_VERSION='DProf %s';\n", XS_VERSION); + PerlIO_printf(g_fp, "# All values are given in HZ\n"); + test_time(aTHX_ &r, &u, &s); + PerlIO_printf(g_fp, + "$over_utime=%"IVdf"; $over_stime=%"IVdf"; $over_rtime=%"IVdf";\n", + /* The (IV) casts are one possibility: + * the Painfully Correct Way would be to + * have Clock_t_f. */ + (IV)u, (IV)s, (IV)r); + PerlIO_printf(g_fp, "$over_tests=10000;\n"); + + g_TIMES_LOCATION = PerlIO_tell(g_fp); + + /* Pad with whitespace. */ + /* This should be enough even for very large numbers. */ + PerlIO_printf(g_fp, "%*s\n", 240 , ""); + + PerlIO_printf(g_fp, "\n"); + PerlIO_printf(g_fp, "PART2\n"); + + PerlIO_flush(g_fp); +} + +static void +prof_record(pTHX) +{ + /* g_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 (g_SAVE_STACK) { + prof_dump_until(aTHX_ g_profstack_ix); + } + PerlIO_seek(g_fp, g_TIMES_LOCATION, SEEK_SET); + /* Write into reserved 240 bytes: */ + PerlIO_printf(g_fp, + "$rrun_utime=%"IVdf"; $rrun_stime=%"IVdf"; $rrun_rtime=%"IVdf";", + /* The (IV) casts are one possibility: + * the Painfully Correct Way would be to + * have Clock_t_f. */ + (IV)(g_prof_end.tms_utime-g_prof_start.tms_utime-g_wprof_u), + (IV)(g_prof_end.tms_stime-g_prof_start.tms_stime-g_wprof_s), + (IV)(g_rprof_end-g_rprof_start-g_wprof_r)); + PerlIO_printf(g_fp, "\n$total_marks=%"IVdf, (IV)g_total); + + PerlIO_close(g_fp); +} + +#define NONESUCH() + +static void +check_depth(pTHX_ void *foo) +{ + U32 need_depth = (U32)foo; + if (need_depth != g_depth) { + if (need_depth > g_depth) { + warn("garbled call depth when profiling"); + } + else { + I32 marks = g_depth - need_depth; + +/* warn("Check_depth: got %d, expected %d\n", g_depth, need_depth); */ + while (marks--) { + prof_mark(aTHX_ OP_DIE); + } + g_depth = need_depth; + } + } +} + +#define for_real +#ifdef for_real + +XS(XS_DB_sub) +{ + dXSARGS; + dORIGMARK; + SV *Sub = GvSV(PL_DBsub); /* name of current sub */ + +#ifdef PERL_IMPLICIT_CONTEXT + /* profile only the interpreter that loaded us */ + if (g_THX != aTHX) { + PUSHMARK(ORIGMARK); + perl_call_sv(INT2PTR(SV*,SvIV(Sub)), GIMME | G_NODEBUG); + } + else +#endif + { + HV *oldstash = PL_curstash; + + DBG_SUB_NOTIFY("XS DBsub(%s)\n", SvPV_nolen(Sub)); + + SAVEDESTRUCTOR_X(check_depth, (void*)g_depth); + g_depth++; + + prof_mark(aTHX_ OP_ENTERSUB); + PUSHMARK(ORIGMARK); + perl_call_sv(INT2PTR(SV*,SvIV(Sub)), GIMME | G_NODEBUG); + prof_mark(aTHX_ OP_LEAVESUB); + g_depth--; + } + return; +} + +XS(XS_DB_goto) +{ +#ifdef PERL_IMPLICIT_CONTEXT + if (g_THX == aTHX) +#endif + { + prof_mark(aTHX_ OP_GOTO); + return; + } +} + +#endif /* for_real */ + +#ifdef testing + + MODULE = Devel::DProf PACKAGE = DB + + void + sub(...) + PPCODE: + { + dORIGMARK; + HV *oldstash = PL_curstash; + SV *Sub = GvSV(PL_DBsub); /* name of current sub */ + /* SP -= items; added by xsubpp */ + DBG_SUB_NOTIFY("XS DBsub(%s)\n", SvPV_nolen(Sub)); + + sv_setiv(PL_DBsingle, 0); /* disable DB single-stepping */ + + prof_mark(aTHX_ OP_ENTERSUB); + PUSHMARK(ORIGMARK); + + PL_curstash = PL_debstash; /* To disable debugging of perl_call_sv */ + perl_call_sv(Sub, GIMME); + PL_curstash = oldstash; + + prof_mark(aTHX_ OP_LEAVESUB); + SPAGAIN; + /* PUTBACK; added by xsubpp */ + } + +#endif /* testing */ + +MODULE = Devel::DProf PACKAGE = Devel::DProf + +void +END() +PPCODE: + { + if (PL_DBsub) { + /* maybe the process forked--we want only + * the parent's profile. + */ + if ( +#ifdef PERL_IMPLICIT_CONTEXT + g_THX == aTHX && +#endif + g_prof_pid == (int)getpid()) + { + g_rprof_end = Times(&g_prof_end); + DBG_TIMER_NOTIFY("Profiler timer is off.\n"); + prof_record(aTHX); + } + } + } + +void +NONESUCH() + +BOOT: + { + g_TIMES_LOCATION = 42; + g_SAVE_STACK = 1<<14; + g_profstack_max = 128; +#ifdef PERL_IMPLICIT_CONTEXT + g_THX = aTHX; +#endif + + /* Before we go anywhere make sure we were invoked + * properly, else we'll dump core. + */ + if (!PL_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 = PL_dowarn; + PL_dowarn = 0; + newXS("DB::sub", XS_DB_sub, file); + newXS("DB::goto", XS_DB_goto, file); + PL_dowarn = warn_tmp; + } + + sv_setiv(PL_DBsingle, 0); /* disable DB single-stepping */ + + { + char *buffer = getenv("PERL_DPROF_BUFFER"); + + if (buffer) { + g_SAVE_STACK = atoi(buffer); + } + + buffer = getenv("PERL_DPROF_TICKS"); + + if (buffer) { + g_dprof_ticks = atoi(buffer); /* Used under OS/2 only */ + } + else { + g_dprof_ticks = HZ; + } + + buffer = getenv("PERL_DPROF_OUT_FILE_NAME"); + g_out_file_name = savepv(buffer ? buffer : "tmon.out"); + } + + if ((g_fp = PerlIO_open(g_out_file_name, "w")) == NULL) + croak("DProf: unable to write '%s', errno = %d\n", + g_out_file_name, errno); + + g_default_perldb = PERLDBf_NONAME | PERLDBf_SUB | PERLDBf_GOTO; + g_cv_hash = newHV(); + g_prof_pid = (int)getpid(); + + New(0, g_profstack, g_profstack_max, PROFANY); + prof_recordheader(aTHX); + DBG_TIMER_NOTIFY("Profiler timer is on.\n"); + g_orealtime = g_rprof_start = Times(&g_prof_start); + g_otms_utime = g_prof_start.tms_utime; + g_otms_stime = g_prof_start.tms_stime; + PL_perldb = g_default_perldb; + } diff --git a/contrib/perl5/ext/Devel/DProf/Makefile.PL b/contrib/perl5/ext/Devel/DProf/Makefile.PL new file mode 100644 index 0000000..667cc52 --- /dev/null +++ b/contrib/perl5/ext/Devel/DProf/Makefile.PL @@ -0,0 +1,17 @@ +use ExtUtils::MakeMaker; + +WriteMakefile( + NAME => 'Devel::DProf', + DISTNAME => 'DProf', + VERSION_FROM => 'DProf.pm', + clean => { 'FILES' => 'tmon.out t/tmon.out t/err'}, + XSPROTOARG => '-noprototypes', + DEFINE => '-DPERLDBf_NONAME=0x40 -DPERLDBf_GOTO=0x80 ' + .'-DG_NODEBUG=32 -DPL_NEEDED', + dist => { + COMPRESS => 'gzip -9f', + SUFFIX => 'gz', + DIST_DEFAULT => 'all tardist', + }, + MAN3PODS => {}, +); diff --git a/contrib/perl5/ext/Devel/DProf/Todo b/contrib/perl5/ext/Devel/DProf/Todo new file mode 100644 index 0000000..0e00347 --- /dev/null +++ b/contrib/perl5/ext/Devel/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/contrib/perl5/ext/Devel/Peek/Changes b/contrib/perl5/ext/Devel/Peek/Changes new file mode 100644 index 0000000..e143f87 --- /dev/null +++ b/contrib/perl5/ext/Devel/Peek/Changes @@ -0,0 +1,64 @@ +0.3: Some functions return SV * now. +0.4: Hashes dumped recursively. + Additional fields for CV added. +0.5: Prototypes for functions supported. + Strings are consostently in quotes now. + Name changed to Devel::Peek (former ExtUtils::Peek). +0.7: + New function mstat added. + Docs added (thanks to Dean Roehrich). + +0.8: + Exports Dump and mstat. + Docs list more details. + Arrays print addresses of SV. + CV: STASH renamed to COMP_STASH. The package of GV is printed now. + Updated for newer overloading implementation (but will not report + packages with overloading). +0.81: + Implements and exports DeadCode(). + Buglet in the definition of mstat for malloc-less perl corrected. +0.82: + New style PADless CV allowed. +0.83: + DumpArray added. + Compatible with PerlIO. + When calculating junk inside subs, divide by refcount. +0.84: + Indented output. +0.85: + By Gisle Aas: format SvPVX, print magic (but not unrefcounted mg_obj); + A lot of new fields stolen from sv_dump(); +0.86: + By Gisle Aas: + - Updated the documentation. + - Move string printer to it's own function: fprintpv() + - Use it to print PVs, HV keys, MG_PTR + - Don't print IV for hashes as KEY is the same field + - Tag GvSTASH as "GvSTASH" in order to not confuse it with + the other STASH field, e.g. Dump(bless \*foo, "bar") +0.87: + Extra indentation of SvRV. + AMAGIC removed. + Head of OOK data printed too. +0.88: + PADLIST and OUTSIDE of CVs itemized. + Prints the value of the hash of HV keys. + Changes by Gisle: do not print both if AvARRAY == AvALLOC; + print hash fill statistics. +0.89: + Changes by Gisle: optree dump. +0.90: + DumpWithOP, DumpProg exported. + Better indent for AV, HV elts. + Address of SV printed. + Corrected Zero code which was causing segfaults. +0.91: + Compiles, runs test under 5.005beta2. + Update DEBUGGING_MSTATS-less MSTATS. +0.92: + Should compile without MYMALLOC too. +0.94: + Had problems with HEf_SVKEY magic. +0.95: + Added "hash quality" output to estimate Perl's hash functions. diff --git a/contrib/perl5/ext/Devel/Peek/Makefile.PL b/contrib/perl5/ext/Devel/Peek/Makefile.PL new file mode 100644 index 0000000..3c6dbf5 --- /dev/null +++ b/contrib/perl5/ext/Devel/Peek/Makefile.PL @@ -0,0 +1,11 @@ +use ExtUtils::MakeMaker; +WriteMakefile( + NAME => "Devel::Peek", + VERSION_FROM => 'Peek.pm', + 'dist' => { + COMPRESS => 'gzip -9f', + SUFFIX => 'gz', + DIST_DEFAULT => 'all tardist', + }, + MAN3PODS => {}, +); diff --git a/contrib/perl5/ext/Devel/Peek/Peek.pm b/contrib/perl5/ext/Devel/Peek/Peek.pm new file mode 100644 index 0000000..080251b --- /dev/null +++ b/contrib/perl5/ext/Devel/Peek/Peek.pm @@ -0,0 +1,432 @@ +# Devel::Peek - A data debugging tool for the XS programmer +# The documentation is after the __END__ + +package Devel::Peek; + +# Underscore to allow older Perls to access older version from CPAN +$VERSION = '1.00_01'; + +require Exporter; +use XSLoader (); + +@ISA = qw(Exporter); +@EXPORT = qw(Dump mstat DeadCode DumpArray DumpWithOP DumpProg); +@EXPORT_OK = qw(SvREFCNT SvREFCNT_inc SvREFCNT_dec CvGV); +%EXPORT_TAGS = ('ALL' => [@EXPORT, @EXPORT_OK]); + +XSLoader::load 'Devel::Peek'; + +sub DumpWithOP ($;$) { + local($Devel::Peek::dump_ops)=1; + my $depth = @_ > 1 ? $_[1] : 4 ; + Dump($_[0],$depth); +} + +1; +__END__ + +=head1 NAME + +Devel::Peek - A data debugging tool for the XS programmer + +=head1 SYNOPSIS + + use Devel::Peek; + Dump( $a ); + Dump( $a, 5 ); + DumpArray( 5, $a, $b, ... ); + mstat "Point 5"; + +=head1 DESCRIPTION + +Devel::Peek contains functions which allows raw Perl datatypes to be +manipulated from a Perl script. This is used by those who do XS programming +to check that the data they are sending from C to Perl looks as they think +it should look. The trick, then, is to know what the raw datatype is +supposed to look like when it gets to Perl. This document offers some tips +and hints to describe good and bad raw data. + +It is very possible that this document will fall far short of being useful +to the casual reader. The reader is expected to understand the material in +the first few sections of L<perlguts>. + +Devel::Peek supplies a C<Dump()> function which can dump a raw Perl +datatype, and C<mstat("marker")> function to report on memory usage +(if perl is compiled with corresponding option). The function +DeadCode() provides statistics on the data "frozen" into inactive +C<CV>. Devel::Peek also supplies C<SvREFCNT()>, C<SvREFCNT_inc()>, and +C<SvREFCNT_dec()> which can query, increment, and decrement reference +counts on SVs. This document will take a passive, and safe, approach +to data debugging and for that it will describe only the C<Dump()> +function. For format of output of mstats() see +L<perldebug/Using C<$ENV{PERL_DEBUG_MSTATS}>>. + +Function C<DumpArray()> allows dumping of multiple values (useful when you +need to analize returns of functions). + +The global variable $Devel::Peek::pv_limit can be set to limit the +number of character printed in various string values. Setting it to 0 +means no limit. + +=head1 EXAMPLES + +The following examples don't attempt to show everything as that would be a +monumental task, and, frankly, we don't want this manpage to be an internals +document for Perl. The examples do demonstrate some basics of the raw Perl +datatypes, and should suffice to get most determined people on their way. +There are no guidewires or safety nets, nor blazed trails, so be prepared to +travel alone from this point and on and, if at all possible, don't fall into +the quicksand (it's bad for business). + +Oh, one final bit of advice: take L<perlguts> with you. When you return we +expect to see it well-thumbed. + +=head2 A simple scalar string + +Let's begin by looking a simple scalar which is holding a string. + + use Devel::Peek; + $a = "hello"; + Dump $a; + +The output: + + SV = PVIV(0xbc288) + REFCNT = 1 + FLAGS = (POK,pPOK) + IV = 0 + PV = 0xb2048 "hello"\0 + CUR = 5 + LEN = 6 + +This says C<$a> is an SV, a scalar. The scalar is a PVIV, a string. +Its reference count is 1. It has the C<POK> flag set, meaning its +current PV field is valid. Because POK is set we look at the PV item +to see what is in the scalar. The \0 at the end indicate that this +PV is properly NUL-terminated. +If the FLAGS had been IOK we would look +at the IV item. CUR indicates the number of characters in the PV. +LEN indicates the number of bytes requested for the PV (one more than +CUR, in this case, because LEN includes an extra byte for the +end-of-string marker). + +=head2 A simple scalar number + +If the scalar contains a number the raw SV will be leaner. + + use Devel::Peek; + $a = 42; + Dump $a; + +The output: + + SV = IV(0xbc818) + REFCNT = 1 + FLAGS = (IOK,pIOK) + IV = 42 + +This says C<$a> is an SV, a scalar. The scalar is an IV, a number. Its +reference count is 1. It has the C<IOK> flag set, meaning it is currently +being evaluated as a number. Because IOK is set we look at the IV item to +see what is in the scalar. + +=head2 A simple scalar with an extra reference + +If the scalar from the previous example had an extra reference: + + use Devel::Peek; + $a = 42; + $b = \$a; + Dump $a; + +The output: + + SV = IV(0xbe860) + REFCNT = 2 + FLAGS = (IOK,pIOK) + IV = 42 + +Notice that this example differs from the previous example only in its +reference count. Compare this to the next example, where we dump C<$b> +instead of C<$a>. + +=head2 A reference to a simple scalar + +This shows what a reference looks like when it references a simple scalar. + + use Devel::Peek; + $a = 42; + $b = \$a; + Dump $b; + +The output: + + SV = RV(0xf041c) + REFCNT = 1 + FLAGS = (ROK) + RV = 0xbab08 + SV = IV(0xbe860) + REFCNT = 2 + FLAGS = (IOK,pIOK) + IV = 42 + +Starting from the top, this says C<$b> is an SV. The scalar is an RV, a +reference. It has the C<ROK> flag set, meaning it is a reference. Because +ROK is set we have an RV item rather than an IV or PV. Notice that Dump +follows the reference and shows us what C<$b> was referencing. We see the +same C<$a> that we found in the previous example. + +Note that the value of C<RV> coincides with the numbers we see when we +stringify $b. The addresses inside RV() and IV() are addresses of +C<X***> structure which holds the current state of an C<SV>. This +address may change during lifetime of an SV. + +=head2 A reference to an array + +This shows what a reference to an array looks like. + + use Devel::Peek; + $a = [42]; + Dump $a; + +The output: + + SV = RV(0xf041c) + REFCNT = 1 + FLAGS = (ROK) + RV = 0xb2850 + SV = PVAV(0xbd448) + REFCNT = 1 + FLAGS = () + IV = 0 + NV = 0 + ARRAY = 0xb2048 + ALLOC = 0xb2048 + FILL = 0 + MAX = 0 + ARYLEN = 0x0 + FLAGS = (REAL) + Elt No. 0 0xb5658 + SV = IV(0xbe860) + REFCNT = 1 + FLAGS = (IOK,pIOK) + IV = 42 + +This says C<$a> is an SV and that it is an RV. That RV points to +another SV which is a PVAV, an array. The array has one element, +element zero, which is another SV. The field C<FILL> above indicates +the last element in the array, similar to C<$#$a>. + +If C<$a> pointed to an array of two elements then we would see the +following. + + use Devel::Peek 'Dump'; + $a = [42,24]; + Dump $a; + +The output: + + SV = RV(0xf041c) + REFCNT = 1 + FLAGS = (ROK) + RV = 0xb2850 + SV = PVAV(0xbd448) + REFCNT = 1 + FLAGS = () + IV = 0 + NV = 0 + ARRAY = 0xb2048 + ALLOC = 0xb2048 + FILL = 0 + MAX = 0 + ARYLEN = 0x0 + FLAGS = (REAL) + Elt No. 0 0xb5658 + SV = IV(0xbe860) + REFCNT = 1 + FLAGS = (IOK,pIOK) + IV = 42 + Elt No. 1 0xb5680 + SV = IV(0xbe818) + REFCNT = 1 + FLAGS = (IOK,pIOK) + IV = 24 + +Note that C<Dump> will not report I<all> the elements in the array, +only several first (depending on how deep it already went into the +report tree). + +=head2 A reference to a hash + +The following shows the raw form of a reference to a hash. + + use Devel::Peek; + $a = {hello=>42}; + Dump $a; + +The output: + + SV = RV(0xf041c) + REFCNT = 1 + FLAGS = (ROK) + RV = 0xb2850 + SV = PVHV(0xbd448) + REFCNT = 1 + FLAGS = () + NV = 0 + ARRAY = 0xbd748 + KEYS = 1 + FILL = 1 + MAX = 7 + RITER = -1 + EITER = 0x0 + Elt "hello" => 0xbaaf0 + SV = IV(0xbe860) + REFCNT = 1 + FLAGS = (IOK,pIOK) + IV = 42 + +This shows C<$a> is a reference pointing to an SV. That SV is a PVHV, a +hash. Fields RITER and EITER are used by C<L<each>>. + +=head2 Dumping a large array or hash + +The C<Dump()> function, by default, dumps up to 4 elements from a +toplevel array or hash. This number can be increased by supplying a +second argument to the function. + + use Devel::Peek; + $a = [10,11,12,13,14]; + Dump $a; + +Notice that C<Dump()> prints only elements 10 through 13 in the above code. +The following code will print all of the elements. + + use Devel::Peek 'Dump'; + $a = [10,11,12,13,14]; + Dump $a, 5; + +=head2 A reference to an SV which holds a C pointer + +This is what you really need to know as an XS programmer, of course. When +an XSUB returns a pointer to a C structure that pointer is stored in an SV +and a reference to that SV is placed on the XSUB stack. So the output from +an XSUB which uses something like the T_PTROBJ map might look something like +this: + + SV = RV(0xf381c) + REFCNT = 1 + FLAGS = (ROK) + RV = 0xb8ad8 + SV = PVMG(0xbb3c8) + REFCNT = 1 + FLAGS = (OBJECT,IOK,pIOK) + IV = 729160 + NV = 0 + PV = 0 + STASH = 0xc1d10 "CookBookB::Opaque" + +This shows that we have an SV which is an RV. That RV points at another +SV. In this case that second SV is a PVMG, a blessed scalar. Because it is +blessed it has the C<OBJECT> flag set. Note that an SV which holds a C +pointer also has the C<IOK> flag set. The C<STASH> is set to the package +name which this SV was blessed into. + +The output from an XSUB which uses something like the T_PTRREF map, which +doesn't bless the object, might look something like this: + + SV = RV(0xf381c) + REFCNT = 1 + FLAGS = (ROK) + RV = 0xb8ad8 + SV = PVMG(0xbb3c8) + REFCNT = 1 + FLAGS = (IOK,pIOK) + IV = 729160 + NV = 0 + PV = 0 + +=head2 A reference to a subroutine + +Looks like this: + + SV = RV(0x798ec) + REFCNT = 1 + FLAGS = (TEMP,ROK) + RV = 0x1d453c + SV = PVCV(0x1c768c) + REFCNT = 2 + FLAGS = () + IV = 0 + NV = 0 + COMP_STASH = 0x31068 "main" + START = 0xb20e0 + ROOT = 0xbece0 + XSUB = 0x0 + XSUBANY = 0 + GVGV::GV = 0x1d44e8 "MY" :: "top_targets" + FILE = "(eval 5)" + DEPTH = 0 + PADLIST = 0x1c9338 + +This shows that + +=over + +=item * + +the subroutine is not an XSUB (since C<START> and C<ROOT> are +non-zero, and C<XSUB> is zero); + +=item * + +that it was compiled in the package C<main>; + +=item * + +under the name C<MY::top_targets>; + +=item * + +inside a 5th eval in the program; + +=item * + +it is not currently executed (see C<DEPTH>); + +=item * + +it has no prototype (C<PROTOTYPE> field is missing). + +=back + +=head1 EXPORTS + +C<Dump>, C<mstat>, C<DeadCode>, C<DumpArray>, C<DumpWithOP> and +C<DumpProg> by default. Additionally available C<SvREFCNT>, +C<SvREFCNT_inc> and C<SvREFCNT_dec>. + +=head1 BUGS + +Readers have been known to skip important parts of L<perlguts>, causing much +frustration for all. + +=head1 AUTHOR + +Ilya Zakharevich ilya@math.ohio-state.edu + +Copyright (c) 1995-98 Ilya Zakharevich. All rights reserved. +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +Author of this software makes no claim whatsoever about suitability, +reliability, edability, editability or usability of this product, and +should not be kept liable for any damage resulting from the use of +it. If you can use it, you are in luck, if not, I should not be kept +responsible. Keep a handy copy of your backup tape at hand. + +=head1 SEE ALSO + +L<perlguts>, and L<perlguts>, again. + +=cut diff --git a/contrib/perl5/ext/Devel/Peek/Peek.xs b/contrib/perl5/ext/Devel/Peek/Peek.xs new file mode 100644 index 0000000..9837e9c --- /dev/null +++ b/contrib/perl5/ext/Devel/Peek/Peek.xs @@ -0,0 +1,218 @@ +#define PERL_NO_GET_CONTEXT +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +SV * +DeadCode(pTHX) +{ +#ifdef PURIFY + return Nullsv; +#else + SV* sva; + SV* sv, *dbg; + SV* ret = newRV_noinc((SV*)newAV()); + register SV* svend; + int tm = 0, tref = 0, ts = 0, ta = 0, tas = 0; + + for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) { + svend = &sva[SvREFCNT(sva)]; + for (sv = sva + 1; sv < svend; ++sv) { + if (SvTYPE(sv) == SVt_PVCV) { + CV *cv = (CV*)sv; + AV* padlist = CvPADLIST(cv), *argav; + SV** svp; + SV** pad; + int i = 0, j, levelm, totm = 0, levelref, totref = 0; + int levels, tots = 0, levela, tota = 0, levelas, totas = 0; + int dumpit = 0; + + if (CvXSUB(sv)) { + continue; /* XSUB */ + } + if (!CvGV(sv)) { + continue; /* file-level scope. */ + } + if (!CvROOT(cv)) { + /* PerlIO_printf(Perl_debug_log, " no root?!\n"); */ + continue; /* autoloading stub. */ + } + do_gvgv_dump(0, Perl_debug_log, "GVGV::GV", CvGV(sv)); + if (CvDEPTH(cv)) { + PerlIO_printf(Perl_debug_log, " busy\n"); + continue; + } + svp = AvARRAY(padlist); + while (++i <= AvFILL(padlist)) { /* Depth. */ + SV **args; + + pad = AvARRAY((AV*)svp[i]); + argav = (AV*)pad[0]; + if (!argav || (SV*)argav == &PL_sv_undef) { + PerlIO_printf(Perl_debug_log, " closure-template\n"); + continue; + } + args = AvARRAY(argav); + levelm = levels = levelref = levelas = 0; + levela = sizeof(SV*) * (AvMAX(argav) + 1); + if (AvREAL(argav)) { + for (j = 0; j < AvFILL(argav); j++) { + if (SvROK(args[j])) { + PerlIO_printf(Perl_debug_log, " ref in args!\n"); + levelref++; + } + /* else if (SvPOK(args[j]) && SvPVX(args[j])) { */ + else if (SvTYPE(args[j]) >= SVt_PV && SvLEN(args[j])) { + levelas += SvLEN(args[j])/SvREFCNT(args[j]); + } + } + } + for (j = 1; j < AvFILL((AV*)svp[1]); j++) { /* Vars. */ + if (SvROK(pad[j])) { + levelref++; + do_sv_dump(0, Perl_debug_log, pad[j], 0, 4, 0, 0); + dumpit = 1; + } + /* else if (SvPOK(pad[j]) && SvPVX(pad[j])) { */ + else if (SvTYPE(pad[j]) >= SVt_PVAV) { + if (!SvPADMY(pad[j])) { + levelref++; + do_sv_dump(0, Perl_debug_log, pad[j], 0, 4, 0, 0); + dumpit = 1; + } + } + else if (SvTYPE(pad[j]) >= SVt_PV && SvLEN(pad[j])) { + int db_len = SvLEN(pad[j]); + SV *db_sv = pad[j]; + levels++; + levelm += SvLEN(pad[j])/SvREFCNT(pad[j]); + /* Dump(pad[j],4); */ + } + } + PerlIO_printf(Perl_debug_log, " level %i: refs: %i, strings: %i in %i,\targsarray: %i, argsstrings: %i\n", + i, levelref, levelm, levels, levela, levelas); + totm += levelm; + tota += levela; + totas += levelas; + tots += levels; + totref += levelref; + if (dumpit) + do_sv_dump(0, Perl_debug_log, (SV*)cv, 0, 2, 0, 0); + } + if (AvFILL(padlist) > 1) { + PerlIO_printf(Perl_debug_log, " total: refs: %i, strings: %i in %i,\targsarrays: %i, argsstrings: %i\n", + totref, totm, tots, tota, totas); + } + tref += totref; + tm += totm; + ts += tots; + ta += tota; + tas += totas; + } + } + } + PerlIO_printf(Perl_debug_log, "total: refs: %i, strings: %i in %i\targsarray: %i, argsstrings: %i\n", tref, tm, ts, ta, tas); + + return ret; +#endif /* !PURIFY */ +} + +#if defined(PERL_DEBUGGING_MSTATS) || defined(DEBUGGING_MSTATS) \ + || (defined(MYMALLOC) && !defined(PLAIN_MALLOC)) +# define mstat(str) dump_mstats(str) +#else +# define mstat(str) \ + PerlIO_printf(Perl_debug_log, "%s: perl not compiled with DEBUGGING_MSTATS\n",str); +#endif + +#define _CvGV(cv) \ + (SvROK(cv) && (SvTYPE(SvRV(cv))==SVt_PVCV) \ + ? SvREFCNT_inc(CvGV((CV*)SvRV(cv))) : &PL_sv_undef) + +MODULE = Devel::Peek PACKAGE = Devel::Peek + +void +mstat(str="Devel::Peek::mstat: ") +char *str + +void +Dump(sv,lim=4) +SV * sv +I32 lim +PPCODE: +{ + SV *pv_lim_sv = perl_get_sv("Devel::Peek::pv_limit", FALSE); + STRLEN pv_lim = pv_lim_sv ? SvIV(pv_lim_sv) : 0; + SV *dumpop = perl_get_sv("Devel::Peek::dump_ops", FALSE); + I32 save_dumpindent = PL_dumpindent; + PL_dumpindent = 2; + do_sv_dump(0, Perl_debug_log, sv, 0, lim, dumpop && SvTRUE(dumpop), pv_lim); + PL_dumpindent = save_dumpindent; +} + +void +DumpArray(lim,...) +I32 lim +PPCODE: +{ + long i; + SV *pv_lim_sv = perl_get_sv("Devel::Peek::pv_limit", FALSE); + STRLEN pv_lim = pv_lim_sv ? SvIV(pv_lim_sv) : 0; + SV *dumpop = perl_get_sv("Devel::Peek::dump_ops", FALSE); + I32 save_dumpindent = PL_dumpindent; + PL_dumpindent = 2; + + for (i=1; i<items; i++) { + PerlIO_printf(Perl_debug_log, "Elt No. %ld 0x%"UVxf"\n", i - 1, PTR2UV(ST(i))); + do_sv_dump(0, Perl_debug_log, ST(i), 0, lim, dumpop && SvTRUE(dumpop), pv_lim); + } + PL_dumpindent = save_dumpindent; +} + +void +DumpProg() +PPCODE: +{ + warn("dumpindent is %d", PL_dumpindent); + if (PL_main_root) + op_dump(PL_main_root); +} + +I32 +SvREFCNT(sv) +SV * sv + +# PPCODE needed since otherwise sv_2mortal is inserted that will kill the value. + +SV * +SvREFCNT_inc(sv) +SV * sv +PPCODE: +{ + RETVAL = SvREFCNT_inc(sv); + PUSHs(RETVAL); +} + +# PPCODE needed since by default it is void + +SV * +SvREFCNT_dec(sv) +SV * sv +PPCODE: +{ + SvREFCNT_dec(sv); + PUSHs(sv); +} + +SV * +DeadCode() +CODE: + RETVAL = DeadCode(aTHX); +OUTPUT: + RETVAL + +MODULE = Devel::Peek PACKAGE = Devel::Peek PREFIX = _ + +SV * +_CvGV(cv) + SV *cv |
