diff options
Diffstat (limited to 'contrib/perl5/ext/Devel')
| -rw-r--r-- | contrib/perl5/ext/Devel/DProf/DProf.xs | 16 | ||||
| -rw-r--r-- | contrib/perl5/ext/Devel/Peek/Makefile.PL | 1 | ||||
| -rw-r--r-- | contrib/perl5/ext/Devel/Peek/Peek.pm | 74 | ||||
| -rw-r--r-- | contrib/perl5/ext/Devel/Peek/Peek.xs | 194 |
4 files changed, 262 insertions, 23 deletions
diff --git a/contrib/perl5/ext/Devel/DProf/DProf.xs b/contrib/perl5/ext/Devel/DProf/DProf.xs index 31e984f..aba6de9 100644 --- a/contrib/perl5/ext/Devel/DProf/DProf.xs +++ b/contrib/perl5/ext/Devel/DProf/DProf.xs @@ -3,11 +3,6 @@ #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 */ @@ -28,6 +23,7 @@ # 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 @@ -280,10 +276,6 @@ 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 */ @@ -388,7 +380,6 @@ prof_mark(pTHX_ opcode ptype) 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; @@ -477,8 +468,6 @@ prof_record(pTHX) /* 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); } @@ -502,7 +491,7 @@ prof_record(pTHX) static void check_depth(pTHX_ void *foo) { - U32 need_depth = (U32)foo; + U32 need_depth = PTR2UV(foo); if (need_depth != g_depth) { if (need_depth > g_depth) { warn("garbled call depth when profiling"); @@ -547,6 +536,7 @@ XS(XS_DB_sub) 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--; } diff --git a/contrib/perl5/ext/Devel/Peek/Makefile.PL b/contrib/perl5/ext/Devel/Peek/Makefile.PL index 3c6dbf5..f6d0cc9 100644 --- a/contrib/perl5/ext/Devel/Peek/Makefile.PL +++ b/contrib/perl5/ext/Devel/Peek/Makefile.PL @@ -2,6 +2,7 @@ use ExtUtils::MakeMaker; WriteMakefile( NAME => "Devel::Peek", VERSION_FROM => 'Peek.pm', + XSPROTOARG => '-noprototypes', 'dist' => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', diff --git a/contrib/perl5/ext/Devel/Peek/Peek.pm b/contrib/perl5/ext/Devel/Peek/Peek.pm index 080251b..0850172 100644 --- a/contrib/perl5/ext/Devel/Peek/Peek.pm +++ b/contrib/perl5/ext/Devel/Peek/Peek.pm @@ -10,7 +10,8 @@ require Exporter; use XSLoader (); @ISA = qw(Exporter); -@EXPORT = qw(Dump mstat DeadCode DumpArray DumpWithOP DumpProg); +@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]); @@ -58,16 +59,76 @@ 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. Function C<DumpArray()> allows dumping of multiple values (useful when you -need to analize returns of functions). +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 @@ -403,8 +464,9 @@ it has no prototype (C<PROTOTYPE> field is missing). =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>. +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 diff --git a/contrib/perl5/ext/Devel/Peek/Peek.xs b/contrib/perl5/ext/Devel/Peek/Peek.xs index 9837e9c..1e48149 100644 --- a/contrib/perl5/ext/Devel/Peek/Peek.xs +++ b/contrib/perl5/ext/Devel/Peek/Peek.xs @@ -82,8 +82,6 @@ DeadCode(pTHX) } } 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); */ @@ -125,6 +123,183 @@ DeadCode(pTHX) 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) @@ -136,6 +311,17 @@ 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 @@ -173,7 +359,7 @@ void DumpProg() PPCODE: { - warn("dumpindent is %d", PL_dumpindent); + warn("dumpindent is %d", (int)PL_dumpindent); if (PL_main_root) op_dump(PL_main_root); } @@ -195,7 +381,7 @@ PPCODE: # PPCODE needed since by default it is void -SV * +void SvREFCNT_dec(sv) SV * sv PPCODE: |
