#include "perl.h"
#include "XSUB.h"
-SV *
+static bool
+_runops_debug(int flag)
+{
+ dTHX;
+ const bool d = PL_runops == MEMBER_TO_FPTR(Perl_runops_debug);
+
+ if (flag >= 0)
+ PL_runops
+ = MEMBER_TO_FPTR(flag ? Perl_runops_debug : Perl_runops_standard);
+ return d;
+}
+
+static SV *
DeadCode(pTHX)
{
#ifdef PURIFY
return Nullsv;
#else
SV* sva;
- SV* sv, *dbg;
+ SV* sv;
SV* ret = newRV_noinc((SV*)newAV());
register SV* svend;
int tm = 0, tref = 0, ts = 0, ta = 0, tas = 0;
int levels, tots = 0, levela, tota = 0, levelas, totas = 0;
int dumpit = 0;
- if (CvXSUB(sv)) {
+ if (CvISXSUB(sv)) {
continue; /* XSUB */
}
if (!CvGV(sv)) {
}
}
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); */
#endif /* !PURIFY */
}
-#if defined(PERL_DEBUGGING_MSTATS) || defined(DEBUGGING_MSTATS) \
- || (defined(MYMALLOC) && !defined(PLAIN_MALLOC))
+#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];
+};
+
+static 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);
+}
+
+static void
+fill_mstats(SV *sv, int level)
+{
+ dTHX;
+
+ 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);
+}
+
+static void
+_mstats_to_hv(HV *hv, const 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 = 0, *p1 = 0;
+ 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();
+ (void)SvUPGRADE(*svp, SVt_RV);
+ SvRV_set(*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]);
+ }
+ }
+}
+
+static 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);
+}
+
+static 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) \ ) */
+static void
+fill_mstats(SV *sv, int level)
+{
+ croak("Cannot report mstats without Perl malloc");
+}
+
+static void
+mstats_fillhash(SV *sv, int level)
+{
+ croak("Cannot report mstats without Perl malloc");
+}
+
+static 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) \
- ? (SV*)CvGV((CV*)SvRV(cv)) : &PL_sv_undef)
+ ? SvREFCNT_inc(CvGV((CV*)SvRV(cv))) : &PL_sv_undef)
MODULE = Devel::Peek PACKAGE = Devel::Peek
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;
+ const 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;
+ const I32 save_dumpindent = PL_dumpindent;
PL_dumpindent = 2;
- do_sv_dump(0, Perl_debug_log, sv, 0, lim, dumpop && SvTRUE(dumpop), pv_lim);
+ do_sv_dump(0, Perl_debug_log, sv, 0, lim,
+ (bool)(dumpop && SvTRUE(dumpop)), pv_lim);
PL_dumpindent = save_dumpindent;
}
{
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;
+ const 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;
+ const 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);
+ do_sv_dump(0, Perl_debug_log, ST(i), 0, lim,
+ (bool)(dumpop && SvTRUE(dumpop)), pv_lim);
}
PL_dumpindent = save_dumpindent;
}
DumpProg()
PPCODE:
{
- warn("dumpindent is %d", PL_dumpindent);
+ warn("dumpindent is %d", (int)PL_dumpindent);
if (PL_main_root)
op_dump(PL_main_root);
}
# PPCODE needed since by default it is void
-SV *
+void
SvREFCNT_dec(sv)
SV * sv
PPCODE:
SV *
_CvGV(cv)
SV *cv
+
+bool
+_runops_debug(int flag = -1)
projects / p5sagit/p5-mst-13.2.git / blobdiff