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]);
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 more information on the format of output of mstat() see
-L<perldebug/Using C<$ENV{PERL_DEBUG_MSTATS}>>.
+function.
Function C<DumpArray()> allows dumping of multiple values (useful when you
need to analyze returns of functions).
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
=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
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)
+{
+ 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)
+{
+ 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)
+{
+ 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)
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
projects / p5sagit/p5-mst-13.2.git / commitdiff