This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[perl #92260] Devel::Peek::fill_mstats and non-PVs
[perl5.git] / ext / Devel-Peek / Peek.xs
1 #define PERL_NO_GET_CONTEXT
2 #include "EXTERN.h"
3 #include "perl.h"
4 #include "XSUB.h"
5
6 static 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
17 static SV *
18 DeadCode(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 = CvPADLIST(cv);
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                 svp = (SV**) PadlistARRAY(padlist);
58                 while (++i <= PadlistMAX(padlist)) { /* Depth. */
59                     SV **args;
60                     
61                     if (!svp[i]) continue;
62                     pad = AvARRAY((AV*)svp[i]);
63                     argav = (AV*)pad[0];
64                     if (!argav || (SV*)argav == &PL_sv_undef) {
65                         PerlIO_printf(Perl_debug_log, "    closure-template\n");
66                         continue;
67                     }
68                     args = AvARRAY(argav);
69                     levelm = levels = levelref = levelas = 0;
70                     levela = sizeof(SV*) * (AvMAX(argav) + 1);
71                     if (AvREAL(argav)) {
72                         for (j = 0; j < AvFILL(argav); j++) {
73                             if (SvROK(args[j])) {
74                                 PerlIO_printf(Perl_debug_log, "     ref in args!\n");
75                                 levelref++;
76                             }
77                             /* else if (SvPOK(args[j]) && SvPVX(args[j])) { */
78                             else if (SvTYPE(args[j]) >= SVt_PV && SvLEN(args[j])) {
79                                 levelas += SvLEN(args[j])/SvREFCNT(args[j]);
80                             }
81                         }
82                     }
83                     for (j = 1; j < AvFILL((AV*)svp[1]); j++) { /* Vars. */
84                         if (SvROK(pad[j])) {
85                             levelref++;
86                             do_sv_dump(0, Perl_debug_log, pad[j], 0, 4, 0, 0);
87                             dumpit = 1;
88                         }
89                         /* else if (SvPOK(pad[j]) && SvPVX(pad[j])) { */
90                         else if (SvTYPE(pad[j]) >= SVt_PVAV) {
91                             if (!SvPADMY(pad[j])) {
92                                 levelref++;
93                                 do_sv_dump(0, Perl_debug_log, pad[j], 0, 4, 0, 0);
94                                 dumpit = 1;
95                             }
96                         }
97                         else if (SvTYPE(pad[j]) >= SVt_PV && SvLEN(pad[j])) {
98                             levels++;
99                             levelm += SvLEN(pad[j])/SvREFCNT(pad[j]);
100                                 /* Dump(pad[j],4); */
101                         }
102                     }
103                     PerlIO_printf(Perl_debug_log, "    level %i: refs: %i, strings: %i in %i,\targsarray: %i, argsstrings: %i\n", 
104                             i, levelref, levelm, levels, levela, levelas);
105                     totm += levelm;
106                     tota += levela;
107                     totas += levelas;
108                     tots += levels;
109                     totref += levelref;
110                     if (dumpit)
111                         do_sv_dump(0, Perl_debug_log, (SV*)cv, 0, 2, 0, 0);
112                 }
113                 if (PadlistMAX(padlist) > 1) {
114                     PerlIO_printf(Perl_debug_log, "  total: refs: %i, strings: %i in %i,\targsarrays: %i, argsstrings: %i\n", 
115                             totref, totm, tots, tota, totas);
116                 }
117                 tref += totref;
118                 tm += totm;
119                 ts += tots;
120                 ta += tota;
121                 tas += totas;
122             }
123         }
124     }
125     PerlIO_printf(Perl_debug_log, "total: refs: %i, strings: %i in %i\targsarray: %i, argsstrings: %i\n", tref, tm, ts, ta, tas);
126
127     return ret;
128 #endif /* !PURIFY */
129 }
130
131 #if defined(MYMALLOC)
132 #   define mstat(str) dump_mstats(str)
133 #else
134 #   define mstat(str) \
135         PerlIO_printf(Perl_debug_log, "%s: perl not compiled with MYMALLOC\n",str);
136 #endif
137
138 #if defined(MYMALLOC)
139
140 /* Very coarse overestimate, 2-per-power-of-2, one more to determine NBUCKETS. */
141 #  define _NBUCKETS (2*8*IVSIZE+1)
142
143 struct mstats_buffer 
144 {
145     perl_mstats_t buffer;
146     UV buf[_NBUCKETS*4];
147 };
148
149 static void
150 _fill_mstats(struct mstats_buffer *b, int level)
151 {
152     dTHX;
153     b->buffer.nfree  = b->buf;
154     b->buffer.ntotal = b->buf + _NBUCKETS;
155     b->buffer.bucket_mem_size = b->buf + 2*_NBUCKETS;
156     b->buffer.bucket_available_size = b->buf + 3*_NBUCKETS;
157     Zero(b->buf, (level ? 4*_NBUCKETS: 2*_NBUCKETS), unsigned long);
158     get_mstats(&(b->buffer), _NBUCKETS, level);
159 }
160
161 static void
162 fill_mstats(SV *sv, int level)
163 {
164     dTHX;
165
166     if (SvREADONLY(sv))
167         croak("Cannot modify a readonly value");
168     sv_grow(sv, sizeof(struct mstats_buffer)+1);
169     _fill_mstats((struct mstats_buffer*)SvPVX(sv),level);
170     SvCUR_set(sv, sizeof(struct mstats_buffer));
171     *SvEND(sv) = '\0';
172     SvPOK_only(sv);
173 }
174
175 static void
176 _mstats_to_hv(HV *hv, const struct mstats_buffer *b, int level)
177 {
178     dTHX;
179     SV **svp;
180     int type;
181
182     svp = hv_fetch(hv, "topbucket", 9, 1);
183     sv_setiv(*svp, b->buffer.topbucket);
184
185     svp = hv_fetch(hv, "topbucket_ev", 12, 1);
186     sv_setiv(*svp, b->buffer.topbucket_ev);
187
188     svp = hv_fetch(hv, "topbucket_odd", 13, 1);
189     sv_setiv(*svp, b->buffer.topbucket_odd);
190
191     svp = hv_fetch(hv, "totfree", 7, 1);
192     sv_setiv(*svp, b->buffer.totfree);
193
194     svp = hv_fetch(hv, "total", 5, 1);
195     sv_setiv(*svp, b->buffer.total);
196
197     svp = hv_fetch(hv, "total_chain", 11, 1);
198     sv_setiv(*svp, b->buffer.total_chain);
199
200     svp = hv_fetch(hv, "total_sbrk", 10, 1);
201     sv_setiv(*svp, b->buffer.total_sbrk);
202
203     svp = hv_fetch(hv, "sbrks", 5, 1);
204     sv_setiv(*svp, b->buffer.sbrks);
205
206     svp = hv_fetch(hv, "sbrk_good", 9, 1);
207     sv_setiv(*svp, b->buffer.sbrk_good);
208
209     svp = hv_fetch(hv, "sbrk_slack", 10, 1);
210     sv_setiv(*svp, b->buffer.sbrk_slack);
211
212     svp = hv_fetch(hv, "start_slack", 11, 1);
213     sv_setiv(*svp, b->buffer.start_slack);
214
215     svp = hv_fetch(hv, "sbrked_remains", 14, 1);
216     sv_setiv(*svp, b->buffer.sbrked_remains);
217     
218     svp = hv_fetch(hv, "minbucket", 9, 1);
219     sv_setiv(*svp, b->buffer.minbucket);
220     
221     svp = hv_fetch(hv, "nbuckets", 8, 1);
222     sv_setiv(*svp, b->buffer.nbuckets);
223
224     if (_NBUCKETS < b->buffer.nbuckets) 
225         warn("FIXME: internal mstats buffer too short");
226     
227     for (type = 0; type < (level ? 4 : 2); type++) {
228         UV *p = 0, *p1 = 0, i;
229         AV *av;
230         static const char *types[4] = { 
231             "free", "used", "mem_size", "available_size"    
232         };
233
234         svp = hv_fetch(hv, types[type], strlen(types[type]), 1);
235
236         if (SvOK(*svp) && !(SvROK(*svp) && SvTYPE(SvRV(*svp)) == SVt_PVAV))
237             croak("Unexpected value for the key '%s' in the mstats hash", types[type]);
238         if (!SvOK(*svp)) {
239             av = newAV();
240             (void)SvUPGRADE(*svp, SVt_RV);
241             SvRV_set(*svp, (SV*)av);
242             SvROK_on(*svp);
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
273 static void
274 mstats_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
284 static 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(MYMALLOC) */ 
296 static void
297 fill_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
304 static void
305 mstats_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
312 static void
313 mstats2hash(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
326 MODULE = Devel::Peek            PACKAGE = Devel::Peek
327
328 void
329 mstat(str="Devel::Peek::mstat: ")
330 const char *str
331
332 void
333 fill_mstats(SV *sv, int level = 0)
334
335 void
336 mstats_fillhash(SV *sv, int level = 0)
337     PROTOTYPE: \%;$
338
339 void
340 mstats2hash(SV *sv, SV *rv, int level = 0)
341     PROTOTYPE: $\%;$
342
343 void
344 Dump(sv,lim=4)
345 SV *    sv
346 I32     lim
347 PPCODE:
348 {
349     SV *pv_lim_sv = perl_get_sv("Devel::Peek::pv_limit", 0);
350     const STRLEN pv_lim = pv_lim_sv ? SvIV(pv_lim_sv) : 0;
351     SV *dumpop = perl_get_sv("Devel::Peek::dump_ops", 0);
352     const U16 save_dumpindent = PL_dumpindent;
353     PL_dumpindent = 2;
354     do_sv_dump(0, Perl_debug_log, sv, 0, lim,
355                (bool)(dumpop && SvTRUE(dumpop)), pv_lim);
356     PL_dumpindent = save_dumpindent;
357 }
358
359 void
360 DumpArray(lim,...)
361 I32     lim
362 PPCODE:
363 {
364     long i;
365     SV *pv_lim_sv = perl_get_sv("Devel::Peek::pv_limit", 0);
366     const STRLEN pv_lim = pv_lim_sv ? SvIV(pv_lim_sv) : 0;
367     SV *dumpop = perl_get_sv("Devel::Peek::dump_ops", 0);
368     const U16 save_dumpindent = PL_dumpindent;
369     PL_dumpindent = 2;
370
371     for (i=1; i<items; i++) {
372         PerlIO_printf(Perl_debug_log, "Elt No. %ld  0x%"UVxf"\n", i - 1, PTR2UV(ST(i)));
373         do_sv_dump(0, Perl_debug_log, ST(i), 0, lim,
374                    (bool)(dumpop && SvTRUE(dumpop)), pv_lim);
375     }
376     PL_dumpindent = save_dumpindent;
377 }
378
379 void
380 DumpProg()
381 PPCODE:
382 {
383     warn("dumpindent is %d", (int)PL_dumpindent);
384     if (PL_main_root)
385         op_dump(PL_main_root);
386 }
387
388 U32
389 SvREFCNT(sv)
390 SV *    sv
391 PROTOTYPE: \[$@%&*]
392 CODE:
393     RETVAL = SvREFCNT(SvRV(sv)) - 1; /* -1 because our ref doesn't count */
394 OUTPUT:
395     RETVAL
396
397 SV *
398 DeadCode()
399 CODE:
400     RETVAL = DeadCode(aTHX);
401 OUTPUT:
402     RETVAL
403
404 MODULE = Devel::Peek            PACKAGE = Devel::Peek   PREFIX = _
405
406 SV *
407 _CvGV(cv)
408     SV *cv
409
410 bool
411 _runops_debug(int flag = -1)