1#define PERL_NO_GET_CONTEXT
2#include "EXTERN.h"
3#include "perl.h"
4#include "XSUB.h"
5
6static bool
7_runops_debug(int flag)
8{
9    dTHX;
10    const bool d = PL_runops == Perl_runops_debug;
11
12    if (flag >= 0)
13	PL_runops = flag ? Perl_runops_debug : Perl_runops_standard;
14    return d;
15}
16
17static SV *
18DeadCode(pTHX)
19{
20#ifdef PURIFY
21    return Nullsv;
22#else
23    SV* sva;
24    SV* sv;
25    SV* ret = newRV_noinc((SV*)newAV());
26    SV* svend;
27    int tm = 0, tref = 0, ts = 0, ta = 0, tas = 0;
28
29    for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
30	svend = &sva[SvREFCNT(sva)];
31	for (sv = sva + 1; sv < svend; ++sv) {
32	    if (SvTYPE(sv) == SVt_PVCV) {
33		CV *cv = (CV*)sv;
34		PADLIST* padlist;
35                AV *argav;
36		SV** svp;
37		SV** pad;
38		int i = 0, j, levelm, totm = 0, levelref, totref = 0;
39		int levels, tots = 0, levela, tota = 0, levelas, totas = 0;
40		int dumpit = 0;
41
42		if (CvISXSUB(sv)) {
43		    continue;		/* XSUB */
44		}
45		if (!CvGV(sv)) {
46		    continue;		/* file-level scope. */
47		}
48		if (!CvROOT(cv)) {
49		    /* PerlIO_printf(Perl_debug_log, "  no root?!\n"); */
50		    continue;		/* autoloading stub. */
51		}
52		do_gvgv_dump(0, Perl_debug_log, "GVGV::GV", CvGV(sv));
53		if (CvDEPTH(cv)) {
54		    PerlIO_printf(Perl_debug_log, "  busy\n");
55		    continue;
56		}
57		padlist = CvPADLIST(cv);
58		svp = (SV**) PadlistARRAY(padlist);
59		while (++i <= PadlistMAX(padlist)) { /* Depth. */
60		    SV **args;
61
62		    if (!svp[i]) continue;
63		    pad = AvARRAY((AV*)svp[i]);
64		    argav = (AV*)pad[0];
65		    if (!argav || (SV*)argav == &PL_sv_undef) {
66			PerlIO_printf(Perl_debug_log, "    closure-template\n");
67			continue;
68		    }
69		    args = AvARRAY(argav);
70		    levelm = levels = levelref = levelas = 0;
71		    levela = sizeof(SV*) * (AvMAX(argav) + 1);
72		    if (AvREAL(argav)) {
73			for (j = 0; j < AvFILL(argav); j++) {
74			    if (SvROK(args[j])) {
75				PerlIO_printf(Perl_debug_log, "     ref in args!\n");
76				levelref++;
77			    }
78			    /* else if (SvPOK(args[j]) && SvPVX(args[j])) { */
79			    else if (SvTYPE(args[j]) >= SVt_PV && SvLEN(args[j])) {
80				levelas += SvLEN(args[j])/SvREFCNT(args[j]);
81			    }
82			}
83		    }
84		    for (j = 1; j < AvFILL((AV*)svp[1]); j++) {	/* Vars. */
85			if (!pad[j]) continue;
86			if (SvROK(pad[j])) {
87			    levelref++;
88			    do_sv_dump(0, Perl_debug_log, pad[j], 0, 4, 0, 0);
89			    dumpit = 1;
90			}
91			/* else if (SvPOK(pad[j]) && SvPVX(pad[j])) { */
92			else if (SvTYPE(pad[j]) >= SVt_PVAV) {
93			    if (!SvPADMY(pad[j])) {
94				levelref++;
95				do_sv_dump(0, Perl_debug_log, pad[j], 0, 4, 0, 0);
96				dumpit = 1;
97			    }
98			}
99			else if (SvTYPE(pad[j]) >= SVt_PV && SvLEN(pad[j])) {
100			    levels++;
101			    levelm += SvLEN(pad[j])/SvREFCNT(pad[j]);
102				/* Dump(pad[j],4); */
103			}
104		    }
105		    PerlIO_printf(Perl_debug_log, "    level %i: refs: %i, strings: %i in %i,\targsarray: %i, argsstrings: %i\n",
106			    i, levelref, levelm, levels, levela, levelas);
107		    totm += levelm;
108		    tota += levela;
109		    totas += levelas;
110		    tots += levels;
111		    totref += levelref;
112		    if (dumpit)
113			do_sv_dump(0, Perl_debug_log, (SV*)cv, 0, 2, 0, 0);
114		}
115		if (PadlistMAX(padlist) > 1) {
116		    PerlIO_printf(Perl_debug_log, "  total: refs: %i, strings: %i in %i,\targsarrays: %i, argsstrings: %i\n",
117			    totref, totm, tots, tota, totas);
118		}
119		tref += totref;
120		tm += totm;
121		ts += tots;
122		ta += tota;
123		tas += totas;
124	    }
125	}
126    }
127    PerlIO_printf(Perl_debug_log, "total: refs: %i, strings: %i in %i\targsarray: %i, argsstrings: %i\n", tref, tm, ts, ta, tas);
128
129    return ret;
130#endif /* !PURIFY */
131}
132
133#if defined(MYMALLOC)
134#   define mstat(str) dump_mstats(str)
135#else
136#   define mstat(str) \
137	PerlIO_printf(Perl_debug_log, "%s: perl not compiled with MYMALLOC\n",str);
138#endif
139
140#if defined(MYMALLOC)
141
142/* Very coarse overestimate, 2-per-power-of-2, one more to determine NBUCKETS. */
143#  define _NBUCKETS (2*8*IVSIZE+1)
144
145struct mstats_buffer
146{
147    perl_mstats_t buffer;
148    UV buf[_NBUCKETS*4];
149};
150
151static void
152_fill_mstats(struct mstats_buffer *b, int level)
153{
154    dTHX;
155    b->buffer.nfree  = b->buf;
156    b->buffer.ntotal = b->buf + _NBUCKETS;
157    b->buffer.bucket_mem_size = b->buf + 2*_NBUCKETS;
158    b->buffer.bucket_available_size = b->buf + 3*_NBUCKETS;
159    Zero(b->buf, (level ? 4*_NBUCKETS: 2*_NBUCKETS), unsigned long);
160    get_mstats(&(b->buffer), _NBUCKETS, level);
161}
162
163static void
164fill_mstats(SV *sv, int level)
165{
166    dTHX;
167
168    if (SvREADONLY(sv))
169	croak("Cannot modify a readonly value");
170    sv_grow(sv, sizeof(struct mstats_buffer)+1);
171    _fill_mstats((struct mstats_buffer*)SvPVX(sv),level);
172    SvCUR_set(sv, sizeof(struct mstats_buffer));
173    *SvEND(sv) = '\0';
174    SvPOK_only(sv);
175}
176
177static void
178_mstats_to_hv(HV *hv, const struct mstats_buffer *b, int level)
179{
180    dTHX;
181    SV **svp;
182    int type;
183
184    svp = hv_fetchs(hv, "topbucket", 1);
185    sv_setiv(*svp, b->buffer.topbucket);
186
187    svp = hv_fetchs(hv, "topbucket_ev", 1);
188    sv_setiv(*svp, b->buffer.topbucket_ev);
189
190    svp = hv_fetchs(hv, "topbucket_odd", 1);
191    sv_setiv(*svp, b->buffer.topbucket_odd);
192
193    svp = hv_fetchs(hv, "totfree", 1);
194    sv_setiv(*svp, b->buffer.totfree);
195
196    svp = hv_fetchs(hv, "total", 1);
197    sv_setiv(*svp, b->buffer.total);
198
199    svp = hv_fetchs(hv, "total_chain", 1);
200    sv_setiv(*svp, b->buffer.total_chain);
201
202    svp = hv_fetchs(hv, "total_sbrk", 1);
203    sv_setiv(*svp, b->buffer.total_sbrk);
204
205    svp = hv_fetchs(hv, "sbrks", 1);
206    sv_setiv(*svp, b->buffer.sbrks);
207
208    svp = hv_fetchs(hv, "sbrk_good", 1);
209    sv_setiv(*svp, b->buffer.sbrk_good);
210
211    svp = hv_fetchs(hv, "sbrk_slack", 1);
212    sv_setiv(*svp, b->buffer.sbrk_slack);
213
214    svp = hv_fetchs(hv, "start_slack", 1);
215    sv_setiv(*svp, b->buffer.start_slack);
216
217    svp = hv_fetchs(hv, "sbrked_remains", 1);
218    sv_setiv(*svp, b->buffer.sbrked_remains);
219
220    svp = hv_fetchs(hv, "minbucket", 1);
221    sv_setiv(*svp, b->buffer.minbucket);
222
223    svp = hv_fetchs(hv, "nbuckets", 1);
224    sv_setiv(*svp, b->buffer.nbuckets);
225
226    if (_NBUCKETS < b->buffer.nbuckets)
227	warn("FIXME: internal mstats buffer too short");
228
229    for (type = 0; type < (level ? 4 : 2); type++) {
230	UV *p = 0, *p1 = 0, i;
231	AV *av;
232	static const char *types[4] = {
233	    "free", "used", "mem_size", "available_size"
234	};
235
236	svp = hv_fetch(hv, types[type], strlen(types[type]), 1);
237
238	if (SvOK(*svp) && !(SvROK(*svp) && SvTYPE(SvRV(*svp)) == SVt_PVAV))
239	    croak("Unexpected value for the key '%s' in the mstats hash", types[type]);
240	if (!SvOK(*svp)) {
241	    av = newAV();
242	    sv_setrv_noinc(*svp, (SV*)av);
243	} else
244	    av = (AV*)SvRV(*svp);
245
246	av_extend(av, b->buffer.nbuckets - 1);
247	/* XXXX What is the official way to reduce the size of the array? */
248	switch (type) {
249	case 0:
250	    p = b->buffer.nfree;
251	    break;
252	case 1:
253	    p = b->buffer.ntotal;
254	    p1 = b->buffer.nfree;
255	    break;
256	case 2:
257	    p = b->buffer.bucket_mem_size;
258	    break;
259	case 3:
260	    p = b->buffer.bucket_available_size;
261	    break;
262	}
263	for (i = 0; i < b->buffer.nbuckets; i++) {
264	    svp = av_fetch(av, i, 1);
265	    if (type == 1)
266		sv_setiv(*svp, p[i]-p1[i]);
267	    else
268		sv_setuv(*svp, p[i]);
269	}
270    }
271}
272
273static void
274mstats_fillhash(SV *sv, int level)
275{
276    struct mstats_buffer buf;
277
278    if (!(SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVHV))
279	croak("Not a hash reference");
280    _fill_mstats(&buf, level);
281    _mstats_to_hv((HV *)SvRV(sv), &buf, level);
282}
283
284static void
285mstats2hash(SV *sv, SV *rv, int level)
286{
287    if (!(SvROK(rv) && SvTYPE(SvRV(rv)) == SVt_PVHV))
288	croak("Not a hash reference");
289    if (!SvPOK(sv))
290	croak("Undefined value when expecting mstats buffer");
291    if (SvCUR(sv) != sizeof(struct mstats_buffer))
292	croak("Wrong size for a value with a mstats buffer");
293    _mstats_to_hv((HV *)SvRV(rv), (struct mstats_buffer*)SvPVX(sv), level);
294}
295#else	/* defined(MYMALLOC) */
296static void
297fill_mstats(SV *sv, int level)
298{
299    PERL_UNUSED_ARG(sv);
300    PERL_UNUSED_ARG(level);
301    croak("Cannot report mstats without Perl malloc");
302}
303
304static void
305mstats_fillhash(SV *sv, int level)
306{
307    PERL_UNUSED_ARG(sv);
308    PERL_UNUSED_ARG(level);
309    croak("Cannot report mstats without Perl malloc");
310}
311
312static void
313mstats2hash(SV *sv, SV *rv, int level)
314{
315    PERL_UNUSED_ARG(sv);
316    PERL_UNUSED_ARG(rv);
317    PERL_UNUSED_ARG(level);
318    croak("Cannot report mstats without Perl malloc");
319}
320#endif	/* defined(MYMALLOC) */
321
322#define _CvGV(cv)					\
323	(SvROK(cv) && (SvTYPE(SvRV(cv))==SVt_PVCV)	\
324	 ? SvREFCNT_inc(CvGV((CV*)SvRV(cv))) : &PL_sv_undef)
325
326static void
327S_do_dump(pTHX_ SV *const sv, I32 lim)
328{
329    SV *pv_lim_sv = perl_get_sv("Devel::Peek::pv_limit", 0);
330    const STRLEN pv_lim = pv_lim_sv ? SvIV(pv_lim_sv) : 0;
331    SV *dumpop = perl_get_sv("Devel::Peek::dump_ops", 0);
332    const U16 save_dumpindent = PL_dumpindent;
333    PL_dumpindent = 2;
334    do_sv_dump(0, Perl_debug_log, sv, 0, lim,
335	       (bool)(dumpop && SvTRUE(dumpop)), pv_lim);
336    PL_dumpindent = save_dumpindent;
337}
338
339static OP *
340S_pp_dump(pTHX)
341{
342    dSP;
343    const I32 lim = PL_op->op_private == 2 ? (I32)POPi : 4;
344    dPOPss;
345    S_do_dump(aTHX_ sv, lim);
346    RETPUSHUNDEF;
347}
348
349static OP *
350S_ck_dump(pTHX_ OP *entersubop, GV *namegv, SV *cv)
351{
352    OP *parent, *pm, *first, *second;
353    BINOP *newop;
354
355    PERL_UNUSED_ARG(cv);
356
357    ck_entersub_args_proto(entersubop, namegv,
358			   newSVpvn_flags("$;$", 3, SVs_TEMP));
359
360    parent = entersubop;
361    pm = cUNOPx(entersubop)->op_first;
362    if (!OpHAS_SIBLING(pm)) {
363        parent = pm;
364	pm = cUNOPx(pm)->op_first;
365    }
366    first = OpSIBLING(pm);
367    second = OpSIBLING(first);
368    if (!second) {
369	/* It doesn���t really matter what we return here, as this only
370	   occurs after yyerror.  */
371	return entersubop;
372    }
373    /* we either have Dump($x):   [pushmark]->[first]->[ex-cvop]
374     * or             Dump($x,1); [pushmark]->[first]->[second]->[ex-cvop]
375     */
376    if (!OpHAS_SIBLING(second))
377        second = NULL;
378
379    if (first->op_type == OP_RV2AV ||
380	first->op_type == OP_PADAV ||
381	first->op_type == OP_RV2HV ||
382	first->op_type == OP_PADHV
383    )
384	first->op_flags |= OPf_REF;
385    else
386	first->op_flags &= ~OPf_MOD;
387
388    /* splice out first (and optionally second) ops, then discard the rest
389     * of the op tree */
390
391    op_sibling_splice(parent, pm, second ? 2 : 1, NULL);
392    op_free(entersubop);
393
394    /* then attach first (and second) to a new binop */
395
396    NewOp(1234, newop, 1, BINOP);
397    newop->op_type   = OP_CUSTOM;
398    newop->op_ppaddr = S_pp_dump;
399    newop->op_private= second ? 2 : 1;
400    newop->op_flags  = OPf_KIDS|OPf_WANT_SCALAR;
401    op_sibling_splice((OP*)newop, NULL, 0, first);
402
403    return (OP *)newop;
404}
405
406static const XOP my_xop = {
407    XOPf_xop_name|XOPf_xop_desc|XOPf_xop_class,		/* xop_flags */
408    "Devel_Peek_Dump",					/* xop_name */
409    "Dump",						/* xop_desc */
410    OA_BINOP,						/* xop_class */
411    NULL						/* xop_peep */
412};
413
414MODULE = Devel::Peek		PACKAGE = Devel::Peek
415
416void
417mstat(str="Devel::Peek::mstat: ")
418const char *str
419
420void
421fill_mstats(SV *sv, int level = 0)
422
423void
424mstats_fillhash(SV *sv, int level = 0)
425    PROTOTYPE: \%;$
426
427void
428mstats2hash(SV *sv, SV *rv, int level = 0)
429    PROTOTYPE: $\%;$
430
431void
432Dump(sv,lim=4)
433SV *	sv
434I32	lim
435PPCODE:
436{
437    S_do_dump(aTHX_ sv, lim);
438}
439
440BOOT:
441{
442    CV * const cv = get_cvn_flags("Devel::Peek::Dump", 17, 0);
443    assert(cv);
444    cv_set_call_checker_flags(cv, S_ck_dump, (SV *)cv, 0);
445    Perl_custom_op_register(aTHX_ S_pp_dump, &my_xop);
446}
447
448void
449DumpArray(lim,...)
450I32	lim
451PPCODE:
452{
453    long i;
454    SV *pv_lim_sv = perl_get_sv("Devel::Peek::pv_limit", 0);
455    const STRLEN pv_lim = pv_lim_sv ? SvIV(pv_lim_sv) : 0;
456    SV *dumpop = perl_get_sv("Devel::Peek::dump_ops", 0);
457    const U16 save_dumpindent = PL_dumpindent;
458    PL_dumpindent = 2;
459
460    for (i=1; i<items; i++) {
461	PerlIO_printf(Perl_debug_log, "Elt No. %ld  0x%" UVxf "\n", i - 1, PTR2UV(ST(i)));
462	do_sv_dump(0, Perl_debug_log, ST(i), 0, lim,
463		   (bool)(dumpop && SvTRUE(dumpop)), pv_lim);
464    }
465    PL_dumpindent = save_dumpindent;
466}
467
468void
469DumpProg()
470PPCODE:
471{
472    warn("dumpindent is %d", (int)PL_dumpindent);
473    if (PL_main_root)
474	op_dump(PL_main_root);
475}
476
477U32
478SvREFCNT(sv)
479SV *	sv
480PROTOTYPE: \[$@%&*]
481CODE:
482    SvGETMAGIC(sv);
483    if (!SvROK(sv))
484        croak_xs_usage(cv, "SCALAR");
485    RETVAL = SvREFCNT(SvRV(sv)) - 1; /* -1 because our ref doesn't count */
486OUTPUT:
487    RETVAL
488
489SV *
490DeadCode()
491CODE:
492    RETVAL = DeadCode(aTHX);
493OUTPUT:
494    RETVAL
495
496MODULE = Devel::Peek		PACKAGE = Devel::Peek	PREFIX = _
497
498SV *
499_CvGV(cv)
500    SV *cv
501
502bool
503_runops_debug(int flag = -1)
504