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 | 679 | ||||
| -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 | 12 | ||||
| -rw-r--r-- | contrib/perl5/ext/Devel/Peek/Peek.pm | 494 | ||||
| -rw-r--r-- | contrib/perl5/ext/Devel/Peek/Peek.xs | 404 |
9 files changed, 0 insertions, 2055 deletions
diff --git a/contrib/perl5/ext/Devel/DProf/Changes b/contrib/perl5/ext/Devel/DProf/Changes deleted file mode 100644 index 216498b..0000000 --- a/contrib/perl5/ext/Devel/DProf/Changes +++ /dev/null @@ -1,176 +0,0 @@ -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 deleted file mode 100644 index 38082fc..0000000 --- a/contrib/perl5/ext/Devel/DProf/DProf.pm +++ /dev/null @@ -1,196 +0,0 @@ -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 deleted file mode 100644 index aba6de9..0000000 --- a/contrib/perl5/ext/Devel/DProf/DProf.xs +++ /dev/null @@ -1,679 +0,0 @@ -#define PERL_NO_GET_CONTEXT -#include "EXTERN.h" -#include "perl.h" -#include "XSUB.h" - -/*#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() */ -# include <lib$routines.h> -# 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; - 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) -{ - 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 */ - - 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 = PTR2UV(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); - PL_curstash = oldstash; - 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 deleted file mode 100644 index 667cc52..0000000 --- a/contrib/perl5/ext/Devel/DProf/Makefile.PL +++ /dev/null @@ -1,17 +0,0 @@ -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 deleted file mode 100644 index 0e00347..0000000 --- a/contrib/perl5/ext/Devel/DProf/Todo +++ /dev/null @@ -1,13 +0,0 @@ -- 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 deleted file mode 100644 index e143f87..0000000 --- a/contrib/perl5/ext/Devel/Peek/Changes +++ /dev/null @@ -1,64 +0,0 @@ -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 deleted file mode 100644 index f6d0cc9..0000000 --- a/contrib/perl5/ext/Devel/Peek/Makefile.PL +++ /dev/null @@ -1,12 +0,0 @@ -use ExtUtils::MakeMaker; -WriteMakefile( - NAME => "Devel::Peek", - VERSION_FROM => 'Peek.pm', - XSPROTOARG => '-noprototypes', - '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 deleted file mode 100644 index 0850172..0000000 --- a/contrib/perl5/ext/Devel/Peek/Peek.pm +++ /dev/null @@ -1,494 +0,0 @@ -# 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 - fill_mstats mstats_fillhash mstats2hash); -@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. - -Function C<DumpArray()> allows dumping of multiple values (useful when you -need to analyze 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. - -=head2 Memory footprint debugging - -When perl is compiled with support for memory footprint debugging -(default with Perl's malloc()), Devel::Peek provides an access to this API. - -Use mstat() function to emit a memory state statistic to the terminal. -For more information on the format of output of mstat() see -L<perldebug/Using C<$ENV{PERL_DEBUG_MSTATS}>>. - -Three additional functions allow access to this statistic from Perl. -First, use C<mstats_fillhash(%hash)> to get the information contained -in the output of mstat() into %hash. The field of this hash are - - minbucket nbuckets sbrk_good sbrk_slack sbrked_remains sbrks start_slack - topbucket topbucket_ev topbucket_odd total total_chain total_sbrk totfree - -Two additional fields C<free>, C<used> contain array references which -provide per-bucket count of free and used chunks. Two other fields -C<mem_size>, C<available_size> contain array references which provide -the information about the allocated size and usable size of chunks in -each bucket. Again, see L<perldebug/Using C<$ENV{PERL_DEBUG_MSTATS}>> -for details. - -Keep in mind that only the first several "odd-numbered" buckets are -used, so the information on size of the "odd-numbered" buckets which are -not used is probably meaningless. - -The information in - - mem_size available_size minbucket nbuckets - -is the property of a particular build of perl, and does not depend on -the current process. If you do not provide the optional argument to -the functions mstats_fillhash(), fill_mstats(), mstats2hash(), then -the information in fields C<mem_size>, C<available_size> is not -updated. - -C<fill_mstats($buf)> is a much cheaper call (both speedwise and -memory-wise) which collects the statistic into $buf in -machine-readable form. At a later moment you may need to call -C<mstats2hash($buf, %hash)> to use this information to fill %hash. - -All three APIs C<fill_mstats($buf)>, C<mstats_fillhash(%hash)>, and -C<mstats2hash($buf, %hash)> are designed to allocate no memory if used -I<the second time> on the same $buf and/or %hash. - -So, if you want to collect memory info in a cycle, you may call - - $#buf = 999; - fill_mstats($_) for @buf; - mstats_fillhash(%report, 1); # Static info too - - foreach (@buf) { - # Do something... - fill_mstats $_; # Collect statistic - } - foreach (@buf) { - mstats2hash($_, %report); # Preserve static info - # Do something with %report - } - -=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>, C<fill_mstats>, C<mstats_fillhash>, C<mstats2hash> 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 deleted file mode 100644 index 1e48149..0000000 --- a/contrib/perl5/ext/Devel/Peek/Peek.xs +++ /dev/null @@ -1,404 +0,0 @@ -#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])) { - 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 - -#if defined(PERL_DEBUGGING_MSTATS) || defined(DEBUGGING_MSTATS) \ - || (defined(MYMALLOC) && !defined(PLAIN_MALLOC)) - -/* Very coarse overestimate, 2-per-power-of-2, one more to determine NBUCKETS. */ -# define _NBUCKETS (2*8*IVSIZE+1) - -struct mstats_buffer -{ - perl_mstats_t buffer; - UV buf[_NBUCKETS*4]; -}; - -void -_fill_mstats(struct mstats_buffer *b, int level) -{ - dTHX; - b->buffer.nfree = b->buf; - b->buffer.ntotal = b->buf + _NBUCKETS; - b->buffer.bucket_mem_size = b->buf + 2*_NBUCKETS; - b->buffer.bucket_available_size = b->buf + 3*_NBUCKETS; - Zero(b->buf, (level ? 4*_NBUCKETS: 2*_NBUCKETS), unsigned long); - get_mstats(&(b->buffer), _NBUCKETS, level); -} - -void -fill_mstats(SV *sv, int level) -{ - dTHX; - int nbuckets; - struct mstats_buffer buf; - - if (SvREADONLY(sv)) - croak("Cannot modify a readonly value"); - SvGROW(sv, sizeof(struct mstats_buffer)+1); - _fill_mstats((struct mstats_buffer*)SvPVX(sv),level); - SvCUR_set(sv, sizeof(struct mstats_buffer)); - *SvEND(sv) = '\0'; - SvPOK_only(sv); -} - -void -_mstats_to_hv(HV *hv, struct mstats_buffer *b, int level) -{ - dTHX; - SV **svp; - int type; - - svp = hv_fetch(hv, "topbucket", 9, 1); - sv_setiv(*svp, b->buffer.topbucket); - - svp = hv_fetch(hv, "topbucket_ev", 12, 1); - sv_setiv(*svp, b->buffer.topbucket_ev); - - svp = hv_fetch(hv, "topbucket_odd", 13, 1); - sv_setiv(*svp, b->buffer.topbucket_odd); - - svp = hv_fetch(hv, "totfree", 7, 1); - sv_setiv(*svp, b->buffer.totfree); - - svp = hv_fetch(hv, "total", 5, 1); - sv_setiv(*svp, b->buffer.total); - - svp = hv_fetch(hv, "total_chain", 11, 1); - sv_setiv(*svp, b->buffer.total_chain); - - svp = hv_fetch(hv, "total_sbrk", 10, 1); - sv_setiv(*svp, b->buffer.total_sbrk); - - svp = hv_fetch(hv, "sbrks", 5, 1); - sv_setiv(*svp, b->buffer.sbrks); - - svp = hv_fetch(hv, "sbrk_good", 9, 1); - sv_setiv(*svp, b->buffer.sbrk_good); - - svp = hv_fetch(hv, "sbrk_slack", 10, 1); - sv_setiv(*svp, b->buffer.sbrk_slack); - - svp = hv_fetch(hv, "start_slack", 11, 1); - sv_setiv(*svp, b->buffer.start_slack); - - svp = hv_fetch(hv, "sbrked_remains", 14, 1); - sv_setiv(*svp, b->buffer.sbrked_remains); - - svp = hv_fetch(hv, "minbucket", 9, 1); - sv_setiv(*svp, b->buffer.minbucket); - - svp = hv_fetch(hv, "nbuckets", 8, 1); - sv_setiv(*svp, b->buffer.nbuckets); - - if (_NBUCKETS < b->buffer.nbuckets) - warn("FIXME: internal mstats buffer too short"); - - for (type = 0; type < (level ? 4 : 2); type++) { - UV *p, *p1; - AV *av; - int i; - static const char *types[4] = { - "free", "used", "mem_size", "available_size" - }; - - svp = hv_fetch(hv, types[type], strlen(types[type]), 1); - - if (SvOK(*svp) && !(SvROK(*svp) && SvTYPE(SvRV(*svp)) == SVt_PVAV)) - croak("Unexpected value for the key '%s' in the mstats hash", types[type]); - if (!SvOK(*svp)) { - av = newAV(); - SvUPGRADE(*svp, SVt_RV); - SvRV(*svp) = (SV*)av; - SvROK_on(*svp); - } else - av = (AV*)SvRV(*svp); - - av_extend(av, b->buffer.nbuckets - 1); - /* XXXX What is the official way to reduce the size of the array? */ - switch (type) { - case 0: - p = b->buffer.nfree; - break; - case 1: - p = b->buffer.ntotal; - p1 = b->buffer.nfree; - break; - case 2: - p = b->buffer.bucket_mem_size; - break; - case 3: - p = b->buffer.bucket_available_size; - break; - } - for (i = 0; i < b->buffer.nbuckets; i++) { - svp = av_fetch(av, i, 1); - if (type == 1) - sv_setiv(*svp, p[i]-p1[i]); - else - sv_setuv(*svp, p[i]); - } - } -} -void -mstats_fillhash(SV *sv, int level) -{ - struct mstats_buffer buf; - - if (!(SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVHV)) - croak("Not a hash reference"); - _fill_mstats(&buf, level); - _mstats_to_hv((HV *)SvRV(sv), &buf, level); -} -void -mstats2hash(SV *sv, SV *rv, int level) -{ - if (!(SvROK(rv) && SvTYPE(SvRV(rv)) == SVt_PVHV)) - croak("Not a hash reference"); - if (!SvPOK(sv)) - croak("Undefined value when expecting mstats buffer"); - if (SvCUR(sv) != sizeof(struct mstats_buffer)) - croak("Wrong size for a value with a mstats buffer"); - _mstats_to_hv((HV *)SvRV(rv), (struct mstats_buffer*)SvPVX(sv), level); -} -#else /* !( defined(PERL_DEBUGGING_MSTATS) || defined(DEBUGGING_MSTATS) \ ) */ -void -fill_mstats(SV *sv, int level) -{ - croak("Cannot report mstats without Perl malloc"); -} -void -mstats_fillhash(SV *sv, int level) -{ - croak("Cannot report mstats without Perl malloc"); -} -void -mstats2hash(SV *sv, SV *rv, int level) -{ - croak("Cannot report mstats without Perl malloc"); -} -#endif /* defined(PERL_DEBUGGING_MSTATS) || defined(DEBUGGING_MSTATS)... */ - -#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 -fill_mstats(SV *sv, int level = 0) - -void -mstats_fillhash(SV *sv, int level = 0) - PROTOTYPE: \%;$ - -void -mstats2hash(SV *sv, SV *rv, int level = 0) - PROTOTYPE: $\%;$ - -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", (int)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 - -void -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 |
