Commit | Line | Data |
---|---|---|
c5be433b | 1 | #define PERL_NO_GET_CONTEXT |
3967c732 JD |
2 | #include "EXTERN.h" |
3 | #include "perl.h" | |
4 | #include "XSUB.h" | |
5 | ||
bd16a5f0 IZ |
6 | bool |
7 | _runops_debug(int flag) | |
8 | { | |
9 | dTHX; | |
10 | bool d = PL_runops == MEMBER_TO_FPTR(Perl_runops_debug); | |
11 | ||
12 | if (flag >= 0) | |
13 | PL_runops | |
14 | = MEMBER_TO_FPTR(flag ? Perl_runops_debug : Perl_runops_standard); | |
15 | return d; | |
16 | } | |
17 | ||
3967c732 | 18 | SV * |
cea2e8a9 | 19 | DeadCode(pTHX) |
3967c732 | 20 | { |
8ecf7187 GS |
21 | #ifdef PURIFY |
22 | return Nullsv; | |
23 | #else | |
3967c732 | 24 | SV* sva; |
9c5ffd7c | 25 | SV* sv; |
3967c732 JD |
26 | SV* ret = newRV_noinc((SV*)newAV()); |
27 | register SV* svend; | |
28 | int tm = 0, tref = 0, ts = 0, ta = 0, tas = 0; | |
29 | ||
30 | for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) { | |
31 | svend = &sva[SvREFCNT(sva)]; | |
32 | for (sv = sva + 1; sv < svend; ++sv) { | |
33 | if (SvTYPE(sv) == SVt_PVCV) { | |
34 | CV *cv = (CV*)sv; | |
35 | AV* padlist = CvPADLIST(cv), *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 (CvXSUB(sv)) { | |
43 | continue; /* XSUB */ | |
44 | } | |
45 | if (!CvGV(sv)) { | |
46 | continue; /* file-level scope. */ | |
47 | } | |
48 | if (!CvROOT(cv)) { | |
bf49b057 | 49 | /* PerlIO_printf(Perl_debug_log, " no root?!\n"); */ |
3967c732 JD |
50 | continue; /* autoloading stub. */ |
51 | } | |
bf49b057 | 52 | do_gvgv_dump(0, Perl_debug_log, "GVGV::GV", CvGV(sv)); |
3967c732 | 53 | if (CvDEPTH(cv)) { |
bf49b057 | 54 | PerlIO_printf(Perl_debug_log, " busy\n"); |
3967c732 JD |
55 | continue; |
56 | } | |
57 | svp = AvARRAY(padlist); | |
58 | while (++i <= AvFILL(padlist)) { /* Depth. */ | |
59 | SV **args; | |
60 | ||
61 | pad = AvARRAY((AV*)svp[i]); | |
62 | argav = (AV*)pad[0]; | |
63 | if (!argav || (SV*)argav == &PL_sv_undef) { | |
bf49b057 | 64 | PerlIO_printf(Perl_debug_log, " closure-template\n"); |
3967c732 JD |
65 | continue; |
66 | } | |
67 | args = AvARRAY(argav); | |
68 | levelm = levels = levelref = levelas = 0; | |
69 | levela = sizeof(SV*) * (AvMAX(argav) + 1); | |
70 | if (AvREAL(argav)) { | |
71 | for (j = 0; j < AvFILL(argav); j++) { | |
72 | if (SvROK(args[j])) { | |
bf49b057 | 73 | PerlIO_printf(Perl_debug_log, " ref in args!\n"); |
3967c732 JD |
74 | levelref++; |
75 | } | |
76 | /* else if (SvPOK(args[j]) && SvPVX(args[j])) { */ | |
77 | else if (SvTYPE(args[j]) >= SVt_PV && SvLEN(args[j])) { | |
78 | levelas += SvLEN(args[j])/SvREFCNT(args[j]); | |
79 | } | |
80 | } | |
81 | } | |
82 | for (j = 1; j < AvFILL((AV*)svp[1]); j++) { /* Vars. */ | |
83 | if (SvROK(pad[j])) { | |
84 | levelref++; | |
bf49b057 | 85 | do_sv_dump(0, Perl_debug_log, pad[j], 0, 4, 0, 0); |
3967c732 JD |
86 | dumpit = 1; |
87 | } | |
88 | /* else if (SvPOK(pad[j]) && SvPVX(pad[j])) { */ | |
89 | else if (SvTYPE(pad[j]) >= SVt_PVAV) { | |
90 | if (!SvPADMY(pad[j])) { | |
91 | levelref++; | |
bf49b057 | 92 | do_sv_dump(0, Perl_debug_log, pad[j], 0, 4, 0, 0); |
3967c732 JD |
93 | dumpit = 1; |
94 | } | |
95 | } | |
96 | else if (SvTYPE(pad[j]) >= SVt_PV && SvLEN(pad[j])) { | |
3967c732 JD |
97 | levels++; |
98 | levelm += SvLEN(pad[j])/SvREFCNT(pad[j]); | |
99 | /* Dump(pad[j],4); */ | |
100 | } | |
101 | } | |
bf49b057 | 102 | PerlIO_printf(Perl_debug_log, " level %i: refs: %i, strings: %i in %i,\targsarray: %i, argsstrings: %i\n", |
3967c732 JD |
103 | i, levelref, levelm, levels, levela, levelas); |
104 | totm += levelm; | |
105 | tota += levela; | |
106 | totas += levelas; | |
107 | tots += levels; | |
108 | totref += levelref; | |
109 | if (dumpit) | |
bf49b057 | 110 | do_sv_dump(0, Perl_debug_log, (SV*)cv, 0, 2, 0, 0); |
3967c732 JD |
111 | } |
112 | if (AvFILL(padlist) > 1) { | |
bf49b057 | 113 | PerlIO_printf(Perl_debug_log, " total: refs: %i, strings: %i in %i,\targsarrays: %i, argsstrings: %i\n", |
3967c732 JD |
114 | totref, totm, tots, tota, totas); |
115 | } | |
116 | tref += totref; | |
117 | tm += totm; | |
118 | ts += tots; | |
119 | ta += tota; | |
120 | tas += totas; | |
121 | } | |
122 | } | |
123 | } | |
bf49b057 | 124 | PerlIO_printf(Perl_debug_log, "total: refs: %i, strings: %i in %i\targsarray: %i, argsstrings: %i\n", tref, tm, ts, ta, tas); |
3967c732 JD |
125 | |
126 | return ret; | |
3967c732 | 127 | #endif /* !PURIFY */ |
8ecf7187 | 128 | } |
3967c732 | 129 | |
7e84e004 SR |
130 | #if (defined(PERL_DEBUGGING_MSTATS) || defined(DEBUGGING_MSTATS)) \ |
131 | && (defined(MYMALLOC) && !defined(PLAIN_MALLOC)) | |
3967c732 JD |
132 | # define mstat(str) dump_mstats(str) |
133 | #else | |
134 | # define mstat(str) \ | |
bf49b057 | 135 | PerlIO_printf(Perl_debug_log, "%s: perl not compiled with DEBUGGING_MSTATS\n",str); |
3967c732 JD |
136 | #endif |
137 | ||
7e84e004 SR |
138 | #if (defined(PERL_DEBUGGING_MSTATS) || defined(DEBUGGING_MSTATS)) \ |
139 | && (defined(MYMALLOC) && !defined(PLAIN_MALLOC)) | |
d1424c31 IZ |
140 | |
141 | /* Very coarse overestimate, 2-per-power-of-2, one more to determine NBUCKETS. */ | |
142 | # define _NBUCKETS (2*8*IVSIZE+1) | |
143 | ||
144 | struct mstats_buffer | |
145 | { | |
146 | perl_mstats_t buffer; | |
147 | UV buf[_NBUCKETS*4]; | |
148 | }; | |
149 | ||
150 | void | |
151 | _fill_mstats(struct mstats_buffer *b, int level) | |
152 | { | |
c024d977 | 153 | dTHX; |
d1424c31 IZ |
154 | b->buffer.nfree = b->buf; |
155 | b->buffer.ntotal = b->buf + _NBUCKETS; | |
156 | b->buffer.bucket_mem_size = b->buf + 2*_NBUCKETS; | |
157 | b->buffer.bucket_available_size = b->buf + 3*_NBUCKETS; | |
158 | Zero(b->buf, (level ? 4*_NBUCKETS: 2*_NBUCKETS), unsigned long); | |
159 | get_mstats(&(b->buffer), _NBUCKETS, level); | |
160 | } | |
161 | ||
162 | void | |
163 | fill_mstats(SV *sv, int level) | |
164 | { | |
c024d977 | 165 | dTHX; |
d1424c31 IZ |
166 | |
167 | if (SvREADONLY(sv)) | |
168 | croak("Cannot modify a readonly value"); | |
169 | SvGROW(sv, sizeof(struct mstats_buffer)+1); | |
170 | _fill_mstats((struct mstats_buffer*)SvPVX(sv),level); | |
171 | SvCUR_set(sv, sizeof(struct mstats_buffer)); | |
172 | *SvEND(sv) = '\0'; | |
173 | SvPOK_only(sv); | |
174 | } | |
175 | ||
176 | void | |
177 | _mstats_to_hv(HV *hv, struct mstats_buffer *b, int level) | |
178 | { | |
c024d977 | 179 | dTHX; |
d1424c31 IZ |
180 | SV **svp; |
181 | int type; | |
182 | ||
183 | svp = hv_fetch(hv, "topbucket", 9, 1); | |
184 | sv_setiv(*svp, b->buffer.topbucket); | |
185 | ||
186 | svp = hv_fetch(hv, "topbucket_ev", 12, 1); | |
187 | sv_setiv(*svp, b->buffer.topbucket_ev); | |
188 | ||
189 | svp = hv_fetch(hv, "topbucket_odd", 13, 1); | |
190 | sv_setiv(*svp, b->buffer.topbucket_odd); | |
191 | ||
192 | svp = hv_fetch(hv, "totfree", 7, 1); | |
193 | sv_setiv(*svp, b->buffer.totfree); | |
194 | ||
195 | svp = hv_fetch(hv, "total", 5, 1); | |
196 | sv_setiv(*svp, b->buffer.total); | |
197 | ||
198 | svp = hv_fetch(hv, "total_chain", 11, 1); | |
199 | sv_setiv(*svp, b->buffer.total_chain); | |
200 | ||
201 | svp = hv_fetch(hv, "total_sbrk", 10, 1); | |
202 | sv_setiv(*svp, b->buffer.total_sbrk); | |
203 | ||
204 | svp = hv_fetch(hv, "sbrks", 5, 1); | |
205 | sv_setiv(*svp, b->buffer.sbrks); | |
206 | ||
207 | svp = hv_fetch(hv, "sbrk_good", 9, 1); | |
208 | sv_setiv(*svp, b->buffer.sbrk_good); | |
209 | ||
210 | svp = hv_fetch(hv, "sbrk_slack", 10, 1); | |
211 | sv_setiv(*svp, b->buffer.sbrk_slack); | |
212 | ||
213 | svp = hv_fetch(hv, "start_slack", 11, 1); | |
214 | sv_setiv(*svp, b->buffer.start_slack); | |
215 | ||
216 | svp = hv_fetch(hv, "sbrked_remains", 14, 1); | |
217 | sv_setiv(*svp, b->buffer.sbrked_remains); | |
218 | ||
219 | svp = hv_fetch(hv, "minbucket", 9, 1); | |
220 | sv_setiv(*svp, b->buffer.minbucket); | |
221 | ||
222 | svp = hv_fetch(hv, "nbuckets", 8, 1); | |
223 | sv_setiv(*svp, b->buffer.nbuckets); | |
224 | ||
225 | if (_NBUCKETS < b->buffer.nbuckets) | |
226 | warn("FIXME: internal mstats buffer too short"); | |
227 | ||
228 | for (type = 0; type < (level ? 4 : 2); type++) { | |
d05c1ba0 | 229 | UV *p = 0, *p1 = 0; |
d1424c31 IZ |
230 | AV *av; |
231 | int i; | |
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(); | |
d05c1ba0 | 242 | (void)SvUPGRADE(*svp, SVt_RV); |
d1424c31 IZ |
243 | SvRV(*svp) = (SV*)av; |
244 | SvROK_on(*svp); | |
245 | } else | |
246 | av = (AV*)SvRV(*svp); | |
247 | ||
248 | av_extend(av, b->buffer.nbuckets - 1); | |
249 | /* XXXX What is the official way to reduce the size of the array? */ | |
250 | switch (type) { | |
251 | case 0: | |
252 | p = b->buffer.nfree; | |
253 | break; | |
254 | case 1: | |
255 | p = b->buffer.ntotal; | |
256 | p1 = b->buffer.nfree; | |
257 | break; | |
258 | case 2: | |
259 | p = b->buffer.bucket_mem_size; | |
260 | break; | |
261 | case 3: | |
262 | p = b->buffer.bucket_available_size; | |
263 | break; | |
264 | } | |
265 | for (i = 0; i < b->buffer.nbuckets; i++) { | |
266 | svp = av_fetch(av, i, 1); | |
267 | if (type == 1) | |
268 | sv_setiv(*svp, p[i]-p1[i]); | |
269 | else | |
270 | sv_setuv(*svp, p[i]); | |
271 | } | |
272 | } | |
273 | } | |
274 | void | |
275 | mstats_fillhash(SV *sv, int level) | |
276 | { | |
277 | struct mstats_buffer buf; | |
278 | ||
279 | if (!(SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVHV)) | |
280 | croak("Not a hash reference"); | |
281 | _fill_mstats(&buf, level); | |
282 | _mstats_to_hv((HV *)SvRV(sv), &buf, level); | |
283 | } | |
284 | void | |
285 | mstats2hash(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(PERL_DEBUGGING_MSTATS) || defined(DEBUGGING_MSTATS) \ ) */ | |
296 | void | |
297 | fill_mstats(SV *sv, int level) | |
298 | { | |
299 | croak("Cannot report mstats without Perl malloc"); | |
300 | } | |
301 | void | |
302 | mstats_fillhash(SV *sv, int level) | |
303 | { | |
304 | croak("Cannot report mstats without Perl malloc"); | |
305 | } | |
306 | void | |
307 | mstats2hash(SV *sv, SV *rv, int level) | |
308 | { | |
309 | croak("Cannot report mstats without Perl malloc"); | |
310 | } | |
311 | #endif /* defined(PERL_DEBUGGING_MSTATS) || defined(DEBUGGING_MSTATS)... */ | |
312 | ||
83ee9e09 GS |
313 | #define _CvGV(cv) \ |
314 | (SvROK(cv) && (SvTYPE(SvRV(cv))==SVt_PVCV) \ | |
15bcf759 | 315 | ? SvREFCNT_inc(CvGV((CV*)SvRV(cv))) : &PL_sv_undef) |
83ee9e09 | 316 | |
3967c732 JD |
317 | MODULE = Devel::Peek PACKAGE = Devel::Peek |
318 | ||
319 | void | |
320 | mstat(str="Devel::Peek::mstat: ") | |
321 | char *str | |
322 | ||
323 | void | |
d1424c31 IZ |
324 | fill_mstats(SV *sv, int level = 0) |
325 | ||
326 | void | |
327 | mstats_fillhash(SV *sv, int level = 0) | |
328 | PROTOTYPE: \%;$ | |
329 | ||
330 | void | |
331 | mstats2hash(SV *sv, SV *rv, int level = 0) | |
332 | PROTOTYPE: $\%;$ | |
333 | ||
334 | void | |
3967c732 JD |
335 | Dump(sv,lim=4) |
336 | SV * sv | |
337 | I32 lim | |
338 | PPCODE: | |
339 | { | |
340 | SV *pv_lim_sv = perl_get_sv("Devel::Peek::pv_limit", FALSE); | |
341 | STRLEN pv_lim = pv_lim_sv ? SvIV(pv_lim_sv) : 0; | |
342 | SV *dumpop = perl_get_sv("Devel::Peek::dump_ops", FALSE); | |
343 | I32 save_dumpindent = PL_dumpindent; | |
344 | PL_dumpindent = 2; | |
bf49b057 | 345 | do_sv_dump(0, Perl_debug_log, sv, 0, lim, dumpop && SvTRUE(dumpop), pv_lim); |
3967c732 JD |
346 | PL_dumpindent = save_dumpindent; |
347 | } | |
348 | ||
349 | void | |
350 | DumpArray(lim,...) | |
351 | I32 lim | |
352 | PPCODE: | |
353 | { | |
354 | long i; | |
355 | SV *pv_lim_sv = perl_get_sv("Devel::Peek::pv_limit", FALSE); | |
356 | STRLEN pv_lim = pv_lim_sv ? SvIV(pv_lim_sv) : 0; | |
357 | SV *dumpop = perl_get_sv("Devel::Peek::dump_ops", FALSE); | |
358 | I32 save_dumpindent = PL_dumpindent; | |
359 | PL_dumpindent = 2; | |
360 | ||
361 | for (i=1; i<items; i++) { | |
7b0972df | 362 | PerlIO_printf(Perl_debug_log, "Elt No. %ld 0x%"UVxf"\n", i - 1, PTR2UV(ST(i))); |
bf49b057 | 363 | do_sv_dump(0, Perl_debug_log, ST(i), 0, lim, dumpop && SvTRUE(dumpop), pv_lim); |
3967c732 JD |
364 | } |
365 | PL_dumpindent = save_dumpindent; | |
366 | } | |
367 | ||
368 | void | |
369 | DumpProg() | |
370 | PPCODE: | |
371 | { | |
d2560b70 | 372 | warn("dumpindent is %d", (int)PL_dumpindent); |
3967c732 JD |
373 | if (PL_main_root) |
374 | op_dump(PL_main_root); | |
375 | } | |
376 | ||
377 | I32 | |
378 | SvREFCNT(sv) | |
379 | SV * sv | |
380 | ||
381 | # PPCODE needed since otherwise sv_2mortal is inserted that will kill the value. | |
382 | ||
383 | SV * | |
384 | SvREFCNT_inc(sv) | |
385 | SV * sv | |
386 | PPCODE: | |
387 | { | |
388 | RETVAL = SvREFCNT_inc(sv); | |
389 | PUSHs(RETVAL); | |
390 | } | |
391 | ||
392 | # PPCODE needed since by default it is void | |
393 | ||
8063af02 | 394 | void |
3967c732 JD |
395 | SvREFCNT_dec(sv) |
396 | SV * sv | |
397 | PPCODE: | |
398 | { | |
399 | SvREFCNT_dec(sv); | |
400 | PUSHs(sv); | |
401 | } | |
402 | ||
403 | SV * | |
404 | DeadCode() | |
cea2e8a9 GS |
405 | CODE: |
406 | RETVAL = DeadCode(aTHX); | |
407 | OUTPUT: | |
408 | RETVAL | |
83ee9e09 GS |
409 | |
410 | MODULE = Devel::Peek PACKAGE = Devel::Peek PREFIX = _ | |
411 | ||
412 | SV * | |
413 | _CvGV(cv) | |
414 | SV *cv | |
bd16a5f0 IZ |
415 | |
416 | bool | |
417 | _runops_debug(int flag = -1) |