Commit | Line | Data |
c5be433b |
1 | #define PERL_NO_GET_CONTEXT |
3967c732 |
2 | #include "EXTERN.h" |
3 | #include "perl.h" |
4 | #include "XSUB.h" |
5 | |
f681a178 |
6 | static bool |
bd16a5f0 |
7 | _runops_debug(int flag) |
8 | { |
9 | dTHX; |
7698c435 |
10 | const bool d = PL_runops == MEMBER_TO_FPTR(Perl_runops_debug); |
bd16a5f0 |
11 | |
12 | if (flag >= 0) |
13 | PL_runops |
14 | = MEMBER_TO_FPTR(flag ? Perl_runops_debug : Perl_runops_standard); |
15 | return d; |
16 | } |
17 | |
f681a178 |
18 | static SV * |
cea2e8a9 |
19 | DeadCode(pTHX) |
3967c732 |
20 | { |
8ecf7187 |
21 | #ifdef PURIFY |
22 | return Nullsv; |
23 | #else |
3967c732 |
24 | SV* sva; |
9c5ffd7c |
25 | SV* sv; |
3967c732 |
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 | |
aed2304a |
42 | if (CvISXSUB(sv)) { |
3967c732 |
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 |
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 |
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 |
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 |
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 |
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 |
93 | dumpit = 1; |
94 | } |
95 | } |
96 | else if (SvTYPE(pad[j]) >= SVt_PV && SvLEN(pad[j])) { |
3967c732 |
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 |
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 |
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 |
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 |
125 | |
126 | return ret; |
3967c732 |
127 | #endif /* !PURIFY */ |
8ecf7187 |
128 | } |
3967c732 |
129 | |
3128eefe |
130 | #if defined(MYMALLOC) |
3967c732 |
131 | # define mstat(str) dump_mstats(str) |
132 | #else |
133 | # define mstat(str) \ |
3128eefe |
134 | PerlIO_printf(Perl_debug_log, "%s: perl not compiled with MYMALLOC\n",str); |
3967c732 |
135 | #endif |
136 | |
3128eefe |
137 | #if defined(MYMALLOC) |
d1424c31 |
138 | |
139 | /* Very coarse overestimate, 2-per-power-of-2, one more to determine NBUCKETS. */ |
140 | # define _NBUCKETS (2*8*IVSIZE+1) |
141 | |
142 | struct mstats_buffer |
143 | { |
144 | perl_mstats_t buffer; |
145 | UV buf[_NBUCKETS*4]; |
146 | }; |
147 | |
f681a178 |
148 | static void |
d1424c31 |
149 | _fill_mstats(struct mstats_buffer *b, int level) |
150 | { |
c024d977 |
151 | dTHX; |
d1424c31 |
152 | b->buffer.nfree = b->buf; |
153 | b->buffer.ntotal = b->buf + _NBUCKETS; |
154 | b->buffer.bucket_mem_size = b->buf + 2*_NBUCKETS; |
155 | b->buffer.bucket_available_size = b->buf + 3*_NBUCKETS; |
156 | Zero(b->buf, (level ? 4*_NBUCKETS: 2*_NBUCKETS), unsigned long); |
157 | get_mstats(&(b->buffer), _NBUCKETS, level); |
158 | } |
159 | |
f681a178 |
160 | static void |
d1424c31 |
161 | fill_mstats(SV *sv, int level) |
162 | { |
c024d977 |
163 | dTHX; |
d1424c31 |
164 | |
165 | if (SvREADONLY(sv)) |
166 | croak("Cannot modify a readonly value"); |
167 | SvGROW(sv, sizeof(struct mstats_buffer)+1); |
168 | _fill_mstats((struct mstats_buffer*)SvPVX(sv),level); |
169 | SvCUR_set(sv, sizeof(struct mstats_buffer)); |
170 | *SvEND(sv) = '\0'; |
171 | SvPOK_only(sv); |
172 | } |
173 | |
f681a178 |
174 | static void |
7698c435 |
175 | _mstats_to_hv(HV *hv, const struct mstats_buffer *b, int level) |
d1424c31 |
176 | { |
c024d977 |
177 | dTHX; |
d1424c31 |
178 | SV **svp; |
179 | int type; |
180 | |
181 | svp = hv_fetch(hv, "topbucket", 9, 1); |
182 | sv_setiv(*svp, b->buffer.topbucket); |
183 | |
184 | svp = hv_fetch(hv, "topbucket_ev", 12, 1); |
185 | sv_setiv(*svp, b->buffer.topbucket_ev); |
186 | |
187 | svp = hv_fetch(hv, "topbucket_odd", 13, 1); |
188 | sv_setiv(*svp, b->buffer.topbucket_odd); |
189 | |
190 | svp = hv_fetch(hv, "totfree", 7, 1); |
191 | sv_setiv(*svp, b->buffer.totfree); |
192 | |
193 | svp = hv_fetch(hv, "total", 5, 1); |
194 | sv_setiv(*svp, b->buffer.total); |
195 | |
196 | svp = hv_fetch(hv, "total_chain", 11, 1); |
197 | sv_setiv(*svp, b->buffer.total_chain); |
198 | |
199 | svp = hv_fetch(hv, "total_sbrk", 10, 1); |
200 | sv_setiv(*svp, b->buffer.total_sbrk); |
201 | |
202 | svp = hv_fetch(hv, "sbrks", 5, 1); |
203 | sv_setiv(*svp, b->buffer.sbrks); |
204 | |
205 | svp = hv_fetch(hv, "sbrk_good", 9, 1); |
206 | sv_setiv(*svp, b->buffer.sbrk_good); |
207 | |
208 | svp = hv_fetch(hv, "sbrk_slack", 10, 1); |
209 | sv_setiv(*svp, b->buffer.sbrk_slack); |
210 | |
211 | svp = hv_fetch(hv, "start_slack", 11, 1); |
212 | sv_setiv(*svp, b->buffer.start_slack); |
213 | |
214 | svp = hv_fetch(hv, "sbrked_remains", 14, 1); |
215 | sv_setiv(*svp, b->buffer.sbrked_remains); |
216 | |
217 | svp = hv_fetch(hv, "minbucket", 9, 1); |
218 | sv_setiv(*svp, b->buffer.minbucket); |
219 | |
220 | svp = hv_fetch(hv, "nbuckets", 8, 1); |
221 | sv_setiv(*svp, b->buffer.nbuckets); |
222 | |
223 | if (_NBUCKETS < b->buffer.nbuckets) |
224 | warn("FIXME: internal mstats buffer too short"); |
225 | |
226 | for (type = 0; type < (level ? 4 : 2); type++) { |
f0f74ded |
227 | UV *p = 0, *p1 = 0, i; |
d1424c31 |
228 | AV *av; |
d1424c31 |
229 | static const char *types[4] = { |
230 | "free", "used", "mem_size", "available_size" |
231 | }; |
232 | |
233 | svp = hv_fetch(hv, types[type], strlen(types[type]), 1); |
234 | |
235 | if (SvOK(*svp) && !(SvROK(*svp) && SvTYPE(SvRV(*svp)) == SVt_PVAV)) |
236 | croak("Unexpected value for the key '%s' in the mstats hash", types[type]); |
237 | if (!SvOK(*svp)) { |
238 | av = newAV(); |
d05c1ba0 |
239 | (void)SvUPGRADE(*svp, SVt_RV); |
b162af07 |
240 | SvRV_set(*svp, (SV*)av); |
d1424c31 |
241 | SvROK_on(*svp); |
242 | } else |
243 | av = (AV*)SvRV(*svp); |
244 | |
245 | av_extend(av, b->buffer.nbuckets - 1); |
246 | /* XXXX What is the official way to reduce the size of the array? */ |
247 | switch (type) { |
248 | case 0: |
249 | p = b->buffer.nfree; |
250 | break; |
251 | case 1: |
252 | p = b->buffer.ntotal; |
253 | p1 = b->buffer.nfree; |
254 | break; |
255 | case 2: |
256 | p = b->buffer.bucket_mem_size; |
257 | break; |
258 | case 3: |
259 | p = b->buffer.bucket_available_size; |
260 | break; |
261 | } |
262 | for (i = 0; i < b->buffer.nbuckets; i++) { |
263 | svp = av_fetch(av, i, 1); |
264 | if (type == 1) |
265 | sv_setiv(*svp, p[i]-p1[i]); |
266 | else |
267 | sv_setuv(*svp, p[i]); |
268 | } |
269 | } |
270 | } |
f681a178 |
271 | |
272 | static void |
d1424c31 |
273 | mstats_fillhash(SV *sv, int level) |
274 | { |
275 | struct mstats_buffer buf; |
276 | |
277 | if (!(SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVHV)) |
278 | croak("Not a hash reference"); |
279 | _fill_mstats(&buf, level); |
280 | _mstats_to_hv((HV *)SvRV(sv), &buf, level); |
281 | } |
f681a178 |
282 | |
283 | static void |
d1424c31 |
284 | mstats2hash(SV *sv, SV *rv, int level) |
285 | { |
286 | if (!(SvROK(rv) && SvTYPE(SvRV(rv)) == SVt_PVHV)) |
287 | croak("Not a hash reference"); |
288 | if (!SvPOK(sv)) |
289 | croak("Undefined value when expecting mstats buffer"); |
290 | if (SvCUR(sv) != sizeof(struct mstats_buffer)) |
291 | croak("Wrong size for a value with a mstats buffer"); |
292 | _mstats_to_hv((HV *)SvRV(rv), (struct mstats_buffer*)SvPVX(sv), level); |
293 | } |
3128eefe |
294 | #else /* defined(MYMALLOC) */ |
f681a178 |
295 | static void |
d1424c31 |
296 | fill_mstats(SV *sv, int level) |
297 | { |
298 | croak("Cannot report mstats without Perl malloc"); |
299 | } |
f681a178 |
300 | |
301 | static void |
d1424c31 |
302 | mstats_fillhash(SV *sv, int level) |
303 | { |
304 | croak("Cannot report mstats without Perl malloc"); |
305 | } |
f681a178 |
306 | |
307 | static void |
d1424c31 |
308 | mstats2hash(SV *sv, SV *rv, int level) |
309 | { |
310 | croak("Cannot report mstats without Perl malloc"); |
311 | } |
3128eefe |
312 | #endif /* defined(MYMALLOC) */ |
d1424c31 |
313 | |
83ee9e09 |
314 | #define _CvGV(cv) \ |
315 | (SvROK(cv) && (SvTYPE(SvRV(cv))==SVt_PVCV) \ |
15bcf759 |
316 | ? SvREFCNT_inc(CvGV((CV*)SvRV(cv))) : &PL_sv_undef) |
83ee9e09 |
317 | |
3967c732 |
318 | MODULE = Devel::Peek PACKAGE = Devel::Peek |
319 | |
320 | void |
321 | mstat(str="Devel::Peek::mstat: ") |
d3f5e399 |
322 | const char *str |
3967c732 |
323 | |
324 | void |
d1424c31 |
325 | fill_mstats(SV *sv, int level = 0) |
326 | |
327 | void |
328 | mstats_fillhash(SV *sv, int level = 0) |
329 | PROTOTYPE: \%;$ |
330 | |
331 | void |
332 | mstats2hash(SV *sv, SV *rv, int level = 0) |
333 | PROTOTYPE: $\%;$ |
334 | |
335 | void |
3967c732 |
336 | Dump(sv,lim=4) |
337 | SV * sv |
338 | I32 lim |
339 | PPCODE: |
340 | { |
341 | SV *pv_lim_sv = perl_get_sv("Devel::Peek::pv_limit", FALSE); |
7698c435 |
342 | const STRLEN pv_lim = pv_lim_sv ? SvIV(pv_lim_sv) : 0; |
3967c732 |
343 | SV *dumpop = perl_get_sv("Devel::Peek::dump_ops", FALSE); |
16d8f38a |
344 | const U16 save_dumpindent = PL_dumpindent; |
3967c732 |
345 | PL_dumpindent = 2; |
eb160463 |
346 | do_sv_dump(0, Perl_debug_log, sv, 0, lim, |
347 | (bool)(dumpop && SvTRUE(dumpop)), pv_lim); |
16d8f38a |
348 | PL_dumpindent = save_dumpindent; |
3967c732 |
349 | } |
350 | |
351 | void |
352 | DumpArray(lim,...) |
353 | I32 lim |
354 | PPCODE: |
355 | { |
356 | long i; |
357 | SV *pv_lim_sv = perl_get_sv("Devel::Peek::pv_limit", FALSE); |
7698c435 |
358 | const STRLEN pv_lim = pv_lim_sv ? SvIV(pv_lim_sv) : 0; |
3967c732 |
359 | SV *dumpop = perl_get_sv("Devel::Peek::dump_ops", FALSE); |
16d8f38a |
360 | const U16 save_dumpindent = PL_dumpindent; |
3967c732 |
361 | PL_dumpindent = 2; |
362 | |
363 | for (i=1; i<items; i++) { |
7b0972df |
364 | PerlIO_printf(Perl_debug_log, "Elt No. %ld 0x%"UVxf"\n", i - 1, PTR2UV(ST(i))); |
eb160463 |
365 | do_sv_dump(0, Perl_debug_log, ST(i), 0, lim, |
366 | (bool)(dumpop && SvTRUE(dumpop)), pv_lim); |
3967c732 |
367 | } |
16d8f38a |
368 | PL_dumpindent = save_dumpindent; |
3967c732 |
369 | } |
370 | |
371 | void |
372 | DumpProg() |
373 | PPCODE: |
374 | { |
d2560b70 |
375 | warn("dumpindent is %d", (int)PL_dumpindent); |
3967c732 |
376 | if (PL_main_root) |
377 | op_dump(PL_main_root); |
378 | } |
379 | |
380 | I32 |
381 | SvREFCNT(sv) |
382 | SV * sv |
383 | |
384 | # PPCODE needed since otherwise sv_2mortal is inserted that will kill the value. |
385 | |
386 | SV * |
387 | SvREFCNT_inc(sv) |
388 | SV * sv |
389 | PPCODE: |
390 | { |
391 | RETVAL = SvREFCNT_inc(sv); |
392 | PUSHs(RETVAL); |
393 | } |
394 | |
395 | # PPCODE needed since by default it is void |
396 | |
8063af02 |
397 | void |
3967c732 |
398 | SvREFCNT_dec(sv) |
399 | SV * sv |
400 | PPCODE: |
401 | { |
402 | SvREFCNT_dec(sv); |
403 | PUSHs(sv); |
404 | } |
405 | |
406 | SV * |
407 | DeadCode() |
cea2e8a9 |
408 | CODE: |
409 | RETVAL = DeadCode(aTHX); |
410 | OUTPUT: |
411 | RETVAL |
83ee9e09 |
412 | |
413 | MODULE = Devel::Peek PACKAGE = Devel::Peek PREFIX = _ |
414 | |
415 | SV * |
416 | _CvGV(cv) |
417 | SV *cv |
bd16a5f0 |
418 | |
419 | bool |
420 | _runops_debug(int flag = -1) |