projects / p5sagit/Devel-Size.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | history | HEAD
parser compcv vs comppad
[p5sagit/Devel-Size.git] / SizeMe.xs
CommitLineData
fd495cc6 1/* -*- mode: C -*- */
2
df9491fe 3/* TODO
4 *
5 * Refactor this to split out D:M code from Devel::Size code.
df9491fe 6 * Start migrating Devel::Size's Size.xs towards the new code.
7 *
df9491fe 8 */
9
c07e8ef8 10#undef NDEBUG /* XXX */
11#include <assert.h>
12
265a0548 13#define PERL_NO_GET_CONTEXT
14
e98cedbf 15#include "EXTERN.h"
16#include "perl.h"
17#include "XSUB.h"
9692b300 18
19#define DPPP_PL_parser_NO_DUMMY
20#define NEED_PL_parser
2eb93d08 21#include "ppport.h"
e98cedbf 22
d4f77653 23#include "refcounted_he.h"
24
87372f42 25/* Not yet in ppport.h */
26#ifndef CvISXSUB
27# define CvISXSUB(cv) (CvXSUB(cv) ? TRUE : FALSE)
28#endif
0e1f978f 29#ifndef SvRV_const
30# define SvRV_const(rv) SvRV(rv)
31#endif
95dc1714 32#ifndef SvOOK_offset
33# define SvOOK_offset(sv, len) STMT_START { len = SvIVX(sv); } STMT_END
34#endif
924d9c4e 35#ifndef SvIsCOW
36# define SvIsCOW(sv) ((SvFLAGS(sv) & (SVf_FAKE | SVf_READONLY)) == \
37 (SVf_FAKE | SVf_READONLY))
38#endif
39#ifndef SvIsCOW_shared_hash
40# define SvIsCOW_shared_hash(sv) (SvIsCOW(sv) && SvLEN(sv) == 0)
41#endif
42#ifndef SvSHARED_HEK_FROM_PV
43# define SvSHARED_HEK_FROM_PV(pvx) \
44 ((struct hek*)(pvx - STRUCT_OFFSET(struct hek, hek_key)))
45#endif
3f5c3c40 46#ifndef CopHINTHASH_get
47#define CopHINTHASH_get(c) ((COPHH*)((c)->cop_hints_hash))
48#endif
87372f42 49
177ebd37 50#if PERL_VERSION < 6
51# define PL_opargs opargs
52# define PL_op_name op_name
53#endif
54
9fc9ab86 55#ifdef _MSC_VER
1a36ac09 56/* "structured exception" handling is a Microsoft extension to C and C++.
57 It's *not* C++ exception handling - C++ exception handling can't capture
58 SEGVs and suchlike, whereas this can. There's no known analagous
59 functionality on other platforms. */
60# include <excpt.h>
61# define TRY_TO_CATCH_SEGV __try
1c35d132 62# define CAUGHT_EXCEPTION __except(EXCEPTION_EXECUTE_HANDLER)
9fc9ab86 63#else
1a36ac09 64# define TRY_TO_CATCH_SEGV if(1)
65# define CAUGHT_EXCEPTION else
9fc9ab86 66#endif
67
68#ifdef __GNUC__
69# define __attribute__(x)
70#endif
71
b7621729 72#if 0 && defined(DEBUGGING)
73#define dbg_printf(x) printf x
74#else
75#define dbg_printf(x)
76#endif
98ecbbc6 77
0964064b 78#define TAG /* printf( "# %s(%d)\n", __FILE__, __LINE__ ) */
6a9ad7ec 79#define carp puts
9fc9ab86 80
30fe4f47 81/* The idea is to have a tree structure to store 1 bit per possible pointer
82 address. The lowest 16 bits are stored in a block of 8092 bytes.
83 The blocks are in a 256-way tree, indexed by the reset of the pointer.
84 This can cope with 32 and 64 bit pointers, and any address space layout,
85 without excessive memory needs. The assumption is that your CPU cache
86 works :-) (And that we're not going to bust it) */
87
30fe4f47 88#define BYTE_BITS 3
89#define LEAF_BITS (16 - BYTE_BITS)
90#define LEAF_MASK 0x1FFF
9fc9ab86 91
c07e8ef8 92typedef struct npath_node_st npath_node_t;
93struct npath_node_st {
94 npath_node_t *prev;
95 const void *id;
96 U8 type;
97 U8 flags;
98 UV seqn;
99 U16 depth;
100};
101
65db36c0 102struct state {
eee00145 103 UV total_size;
65db36c0 104 bool regex_whine;
105 bool fm_whine;
106 bool dangle_whine;
107 bool go_yell;
108 /* My hunch (not measured) is that for most architectures pointers will
109 start with 0 bits, hence the start of this array will be hot, and the
110 end unused. So put the flags next to the hot end. */
111 void *tracking[256];
5e2e22f3 112 NV start_time_nv;
05f432c0 113 int min_recurse_threshold;
c07e8ef8 114 /* callback hooks and data */
e9c43be8 115 void (*add_attr_cb)(pTHX_ struct state *st, npath_node_t *npath_node, UV attr_type, const char *name, UV value);
1abba8e9 116 void (*free_state_cb)(pTHX_ struct state *st);
c07e8ef8 117 void *state_cb_data; /* free'd by free_state() after free_state_cb() call */
5e486cae 118 /* this stuff wil be moved to state_cb_data later */
db644d73 119 UV seqn;
1abba8e9 120 FILE *node_stream_fh;
121 char *node_stream_name;
65db36c0 122};
123
e9c43be8 124#define ADD_SIZE(st, leafname, bytes) \
125 STMT_START { \
126 NPathAddSizeCb(st, leafname, bytes); \
127 (st)->total_size += (bytes); \
128 } STMT_END
129
c07e8ef8 130
131#define PATH_TRACKING
132#ifdef PATH_TRACKING
133
c07e8ef8 134#define pPATH npath_node_t *NPathArg
135
84cd88b0 136/* A subtle point here is that dNPathNodes and NPathPushNode leave NP pointing
012b5f33 137 * to the next unused slot (though with prev already filled in)
c07e8ef8 138 * whereas NPathLink leaves NP unchanged, it just fills in the slot NP points
139 * to and passes that NP value to the function being called.
84cd88b0 140 * seqn==0 indicates the node is new (hasn't been output yet)
c07e8ef8 141 */
142#define dNPathNodes(nodes, prev_np) \
143 npath_node_t name_path_nodes[nodes+1]; /* +1 for NPathLink */ \
144 npath_node_t *NP = &name_path_nodes[0]; \
84cd88b0 145 NP->seqn = NP->type = 0; NP->id = Nullch; /* safety/debug */ \
c07e8ef8 146 NP->prev = prev_np
012b5f33 147#define NPathPushNode(nodeid, nodetype) \
c07e8ef8 148 NP->id = nodeid; \
149 NP->type = nodetype; \
84cd88b0 150 NP->seqn = 0; \
012b5f33 151 if(0)fprintf(stderr,"NPathPushNode (%p <-) %p <- [%d %s]\n", NP->prev, NP, nodetype,(char*)nodeid);\
c07e8ef8 152 NP++; \
84cd88b0 153 NP->id = Nullch; /* safety/debug */ \
c07e8ef8 154 NP->seqn = 0; \
155 NP->prev = (NP-1)
012b5f33 156#define NPathSetNode(nodeid, nodetype) \
157 (NP-1)->id = nodeid; \
158 (NP-1)->type = nodetype; \
159 if(0)fprintf(stderr,"NPathSetNode (%p <-) %p <- [%d %s]\n", (NP-1)->prev, (NP-1), nodetype,(char*)nodeid);\
160 (NP-1)->seqn = 0;
1abba8e9 161#define NPathPopNode \
162 --NP
c07e8ef8 163
164/* dNPathUseParent points NP directly the the parents' name_path_nodes array
165 * So the function can only safely call ADD_*() but not NPathLink, unless the
166 * caller has spare nodes in its name_path_nodes.
167 */
168#define dNPathUseParent(prev_np) npath_node_t *NP = (((prev_np+1)->prev = prev_np), prev_np+1)
169
170#define NPtype_NAME 0x01
171#define NPtype_LINK 0x02
172#define NPtype_SV 0x03
173#define NPtype_MAGIC 0x04
174#define NPtype_OP 0x05
175
957d176b 176/* XXX these should probably be generalized into flag bits */
e8f4c506 177#define NPattr_LEAFSIZE 0x00
178#define NPattr_NAME 0x01
179#define NPattr_PADFAKE 0x02
180#define NPattr_PADNAME 0x03
181#define NPattr_PADTMP 0x04
1abba8e9 182#define NPattr_NOTE 0x05
93a78808 183
e9c43be8 184#define _ADD_ATTR_NP(st, attr_type, attr_name, attr_value, np) \
185 STMT_START { \
186 if (st->add_attr_cb) { \
187 st->add_attr_cb(aTHX_ st, np, attr_type, attr_name, attr_value); \
188 } \
189 } STMT_END
190
957d176b 191#define ADD_ATTR(st, attr_type, attr_name, attr_value) \
192 _ADD_ATTR_NP(st, attr_type, attr_name, attr_value, NP-1)
193
322b968f 194#define ADD_LINK_ATTR(st, attr_type, attr_name, attr_value) \
195 STMT_START { \
01f5c6f5 196 if (st->add_attr_cb) assert(NP->seqn); \
322b968f 197 _ADD_ATTR_NP(st, attr_type, attr_name, attr_value, NP); \
198 } STMT_END;
e8f4c506 199
ce5aa2b7 200#define _NPathLink(np, nid, ntype) (((np)->id=nid), ((np)->type=ntype), ((np)->seqn=0))
201#define NPathLink(nid) (_NPathLink(NP, nid, NPtype_LINK), NP)
202/* add a link and a name node to the path - a special case for op_size */
203#define NPathLinkAndNode(nid, nid2) (_NPathLink(NP, nid, NPtype_LINK), _NPathLink(NP+1, nid2, NPtype_NAME), ((NP+1)->prev=NP), (NP+1))
c07e8ef8 204#define NPathOpLink (NPathArg)
e9c43be8 205#define NPathAddSizeCb(st, name, bytes) \
206 STMT_START { \
207 if (st->add_attr_cb) { \
208 st->add_attr_cb(aTHX_ st, NP-1, NPattr_LEAFSIZE, (name), (bytes)); \
209 } \
210 } STMT_END
c07e8ef8 211
212#else
213
214#define NPathAddSizeCb(st, name, bytes)
215#define pPATH void *npath_dummy /* XXX ideally remove */
216#define dNPathNodes(nodes, prev_np) dNOOP
217#define NPathLink(nodeid, nodetype) NULL
218#define NPathOpLink NULL
219#define ADD_ATTR(st, attr_type, attr_name, attr_value) NOOP
220
221#endif /* PATH_TRACKING */
222
223
224
225
226#ifdef PATH_TRACKING
227
228static const char *svtypenames[SVt_LAST] = {
229#if PERL_VERSION < 9
230 "NULL", "IV", "NV", "RV", "PV", "PVIV", "PVNV", "PVMG", "PVBM", "PVLV", "PVAV", "PVHV", "PVCV", "PVGV", "PVFM", "PVIO",
231#elif PERL_VERSION == 10 && PERL_SUBVERSION == 0
232 "NULL", "BIND", "IV", "NV", "RV", "PV", "PVIV", "PVNV", "PVMG", "PVGV", "PVLV", "PVAV", "PVHV", "PVCV", "PVFM", "PVIO",
233#elif PERL_VERSION == 10 && PERL_SUBVERSION == 1
234 "NULL", "BIND", "IV", "NV", "RV", "PV", "PVIV", "PVNV", "PVMG", "PVGV", "PVLV", "PVAV", "PVHV", "PVCV", "PVFM", "PVIO",
235#elif PERL_VERSION < 13
236 "NULL", "BIND", "IV", "NV", "PV", "PVIV", "PVNV", "PVMG", "REGEXP", "PVGV", "PVLV", "PVAV", "PVHV", "PVCV", "PVFM", "PVIO",
237#else
238 "NULL", "BIND", "IV", "NV", "PV", "PVIV", "PVNV", "PVMG", "REGEXP", "PVGV", "PVLV", "PVAV", "PVHV", "PVCV", "PVFM", "PVIO",
239#endif
240};
241
5e2e22f3 242static NV
243gettimeofday_nv(void)
244{
245#ifdef HAS_GETTIMEOFDAY
246 struct timeval when;
247 gettimeofday(&when, (struct timezone *) 0);
248 return when.tv_sec + (when.tv_usec / 1000000.0);
249#else
250 if (u2time) {
251 UV time_of_day[2];
252 (*u2time)(aTHX_ &time_of_day);
253 return time_of_day[0] + (time_of_day[1] / 1000000.0);
254 }
255 return (NV)time();
256#endif
257}
258
259
c07e8ef8 260int
60dacf5f 261np_print_node_name(pTHX_ FILE *fp, npath_node_t *npath_node)
c07e8ef8 262{
c07e8ef8 263 switch (npath_node->type) {
264 case NPtype_SV: { /* id is pointer to the SV sv_size was called on */
265 const SV *sv = (SV*)npath_node->id;
266 int type = SvTYPE(sv);
e9c43be8 267 const char *typename = (type == SVt_IV && SvROK(sv)) ? "RV" : svtypenames[type];
5e486cae 268 fprintf(fp, "SV(%s)", typename);
c07e8ef8 269 switch(type) { /* add some useful details */
5e486cae 270 case SVt_PVAV: fprintf(fp, " fill=%d/%ld", av_len((AV*)sv), AvMAX((AV*)sv)); break;
271 case SVt_PVHV: fprintf(fp, " fill=%ld/%ld", HvFILL((HV*)sv), HvMAX((HV*)sv)); break;
c07e8ef8 272 }
273 break;
274 }
275 case NPtype_OP: { /* id is pointer to the OP op_size was called on */
276 const OP *op = (OP*)npath_node->id;
5e486cae 277 fprintf(fp, "OP(%s)", OP_NAME(op));
c07e8ef8 278 break;
279 }
280 case NPtype_MAGIC: { /* id is pointer to the MAGIC struct */
281 MAGIC *magic_pointer = (MAGIC*)npath_node->id;
282 /* XXX it would be nice if we could reuse mg_names.c [sigh] */
5e486cae 283 fprintf(fp, "MAGIC(%c)", magic_pointer->mg_type ? magic_pointer->mg_type : '0');
c07e8ef8 284 break;
285 }
286 case NPtype_LINK:
e9c43be8 287 fprintf(fp, "%s", (const char *)npath_node->id);
c07e8ef8 288 break;
289 case NPtype_NAME:
e9c43be8 290 fprintf(fp, "%s", (const char *)npath_node->id);
c07e8ef8 291 break;
292 default: /* assume id is a string pointer */
5e486cae 293 fprintf(fp, "UNKNOWN(%d,%p)", npath_node->type, npath_node->id);
c07e8ef8 294 break;
295 }
296 return 0;
297}
298
299void
5e486cae 300np_dump_indent(int depth) {
c07e8ef8 301 while (depth-- > 0)
302 fprintf(stderr, ": ");
303}
304
305int
60dacf5f 306np_walk_new_nodes(pTHX_ struct state *st,
fc6614ee 307 npath_node_t *npath_node,
308 npath_node_t *npath_node_deeper,
60dacf5f 309 int (*cb)(pTHX_ struct state *st, npath_node_t *npath_node, npath_node_t *npath_node_deeper))
c07e8ef8 310{
311 if (npath_node->seqn) /* node already output */
fc6614ee 312 return 0;
c07e8ef8 313
314 if (npath_node->prev) {
60dacf5f 315 np_walk_new_nodes(aTHX_ st, npath_node->prev, npath_node, cb); /* recurse */
c07e8ef8 316 npath_node->depth = npath_node->prev->depth + 1;
317 }
318 else npath_node->depth = 0;
319 npath_node->seqn = ++st->seqn;
320
fc6614ee 321 if (cb) {
60dacf5f 322 if (cb(aTHX_ st, npath_node, npath_node_deeper)) {
fc6614ee 323 /* ignore this node */
324 assert(npath_node->prev);
325 assert(npath_node->depth);
326 assert(npath_node_deeper);
327 npath_node->depth--;
328 npath_node->seqn = --st->seqn;
329 npath_node_deeper->prev = npath_node->prev;
330 }
331 }
c07e8ef8 332
fc6614ee 333 return 0;
334}
335
336int
60dacf5f 337np_dump_formatted_node(pTHX_ struct state *st, npath_node_t *npath_node, npath_node_t *npath_node_deeper) {
e9c43be8 338 PERL_UNUSED_ARG(st);
339 PERL_UNUSED_ARG(npath_node_deeper);
fc6614ee 340 if (0 && npath_node->type == NPtype_LINK)
341 return 1;
342 np_dump_indent(npath_node->depth);
60dacf5f 343 np_print_node_name(aTHX_ stderr, npath_node);
1abba8e9 344 if (npath_node->type == NPtype_LINK)
345 fprintf(stderr, "->"); /* cosmetic */
fc6614ee 346 fprintf(stderr, "\t\t[#%ld @%u] ", npath_node->seqn, npath_node->depth);
347 fprintf(stderr, "\n");
348 return 0;
c07e8ef8 349}
350
e9c43be8 351void
60dacf5f 352np_dump_node_path_info(pTHX_ struct state *st, npath_node_t *npath_node, UV attr_type, const char *attr_name, UV attr_value)
c07e8ef8 353{
1abba8e9 354 if (attr_type == NPattr_LEAFSIZE && !attr_value)
e9c43be8 355 return; /* ignore zero sized leaf items */
60dacf5f 356 np_walk_new_nodes(aTHX_ st, npath_node, NULL, np_dump_formatted_node);
5e486cae 357 np_dump_indent(npath_node->depth+1);
1abba8e9 358 switch (attr_type) {
359 case NPattr_LEAFSIZE:
360 fprintf(stderr, "+%ld %s =%ld", attr_value, attr_name, attr_value+st->total_size);
361 break;
362 case NPattr_NAME:
c07e8ef8 363 fprintf(stderr, "~NAMED('%s') %lu", attr_name, attr_value);
1abba8e9 364 break;
365 case NPattr_NOTE:
366 fprintf(stderr, "~note %s %lu", attr_name, attr_value);
367 break;
368 case NPattr_PADTMP:
369 case NPattr_PADNAME:
370 case NPattr_PADFAKE:
371 fprintf(stderr, "~pad%lu %s %lu", attr_type, attr_name, attr_value);
372 break;
373 default:
374 fprintf(stderr, "~??? %s %lu", attr_name, attr_value);
375 break;
c07e8ef8 376 }
377 fprintf(stderr, "\n");
c07e8ef8 378}
379
5e486cae 380int
60dacf5f 381np_stream_formatted_node(pTHX_ struct state *st, npath_node_t *npath_node, npath_node_t *npath_node_deeper) {
e9c43be8 382 PERL_UNUSED_ARG(npath_node_deeper);
1abba8e9 383 fprintf(st->node_stream_fh, "-%u %lu %u ",
ee2793c1 384 npath_node->type, npath_node->seqn, (unsigned)npath_node->depth
5e486cae 385 );
60dacf5f 386 np_print_node_name(aTHX_ st->node_stream_fh, npath_node);
1abba8e9 387 fprintf(st->node_stream_fh, "\n");
5e486cae 388 return 0;
389}
390
e9c43be8 391void
60dacf5f 392np_stream_node_path_info(pTHX_ struct state *st, npath_node_t *npath_node, UV attr_type, const char *attr_name, UV attr_value)
5e486cae 393{
394 if (!attr_type && !attr_value)
e9c43be8 395 return; /* ignore zero sized leaf items */
60dacf5f 396 np_walk_new_nodes(aTHX_ st, npath_node, NULL, np_stream_formatted_node);
e8f4c506 397 if (attr_type) { /* Attribute type, name and value */
1abba8e9 398 fprintf(st->node_stream_fh, "%lu %lu ", attr_type, npath_node->seqn);
5e486cae 399 }
e8f4c506 400 else { /* Leaf name and memory size */
1abba8e9 401 fprintf(st->node_stream_fh, "L %lu ", npath_node->seqn);
5e486cae 402 }
1abba8e9 403 fprintf(st->node_stream_fh, "%lu %s\n", attr_value, attr_name);
5e486cae 404}
405
1abba8e9 406
c07e8ef8 407#endif /* PATH_TRACKING */
408
409
9fc9ab86 410/*
411 Checks to see if thing is in the bitstring.
412 Returns true or false, and
413 notes thing in the segmented bitstring.
414 */
2eb93d08 415static bool
a4efdff3 416check_new(struct state *st, const void *const p) {
30fe4f47 417 unsigned int bits = 8 * sizeof(void*);
418 const size_t raw_p = PTR2nat(p);
419 /* This effectively rotates the value right by the number of low always-0
420 bits in an aligned pointer. The assmption is that most (if not all)
421 pointers are aligned, and these will be in the same chain of nodes
422 (and hence hot in the cache) but we can still deal with any unaligned
423 pointers. */
424 const size_t cooked_p
f404ed48 425 = (raw_p >> ALIGN_BITS) | (raw_p << (bits - ALIGN_BITS));
30fe4f47 426 const U8 this_bit = 1 << (cooked_p & 0x7);
427 U8 **leaf_p;
428 U8 *leaf;
429 unsigned int i;
302077b6 430 void **tv_p = (void **) (st->tracking);
30fe4f47 431
302077b6 432 if (NULL == p) return FALSE;
1a36ac09 433 TRY_TO_CATCH_SEGV {
2eb93d08 434 const char c = *(const char *)p;
e9c43be8 435 PERL_UNUSED_VAR(c);
9fc9ab86 436 }
1a36ac09 437 CAUGHT_EXCEPTION {
a4efdff3 438 if (st->dangle_whine)
9fc9ab86 439 warn( "Devel::Size: Encountered invalid pointer: %p\n", p );
440 return FALSE;
441 }
9fc9ab86 442 TAG;
30fe4f47 443
444 bits -= 8;
445 /* bits now 24 (32 bit pointers) or 56 (64 bit pointers) */
446
447 /* First level is always present. */
448 do {
449 i = (unsigned int)((cooked_p >> bits) & 0xFF);
450 if (!tv_p[i])
451 Newxz(tv_p[i], 256, void *);
452 tv_p = (void **)(tv_p[i]);
453 bits -= 8;
454 } while (bits > LEAF_BITS + BYTE_BITS);
455 /* bits now 16 always */
5f04c81d 456#if !defined(MULTIPLICITY) || PERL_VERSION > 8 || (PERL_VERSION == 8 && PERL_SUBVERSION > 8)
457 /* 5.8.8 and early have an assert() macro that uses Perl_croak, hence needs
458 a my_perl under multiplicity */
30fe4f47 459 assert(bits == 16);
5f04c81d 460#endif
30fe4f47 461 leaf_p = (U8 **)tv_p;
462 i = (unsigned int)((cooked_p >> bits) & 0xFF);
463 if (!leaf_p[i])
464 Newxz(leaf_p[i], 1 << LEAF_BITS, U8);
465 leaf = leaf_p[i];
466
9fc9ab86 467 TAG;
30fe4f47 468
469 i = (unsigned int)((cooked_p >> BYTE_BITS) & LEAF_MASK);
470
471 if(leaf[i] & this_bit)
472 return FALSE;
473
474 leaf[i] |= this_bit;
9fc9ab86 475 return TRUE;
476}
477
e9716740 478static void
30fe4f47 479free_tracking_at(void **tv, int level)
480{
481 int i = 255;
482
483 if (--level) {
484 /* Nodes */
485 do {
486 if (tv[i]) {
384ebd3f 487 free_tracking_at((void **) tv[i], level);
30fe4f47 488 Safefree(tv[i]);
489 }
490 } while (i--);
491 } else {
492 /* Leaves */
493 do {
494 if (tv[i])
495 Safefree(tv[i]);
496 } while (i--);
497 }
498}
499
500static void
60dacf5f 501free_state(pTHX_ struct state *st)
e9716740 502{
30fe4f47 503 const int top_level = (sizeof(void *) * 8 - LEAF_BITS - BYTE_BITS) / 8;
c07e8ef8 504 if (st->free_state_cb)
60dacf5f 505 st->free_state_cb(aTHX_ st);
c07e8ef8 506 if (st->state_cb_data)
507 Safefree(st->state_cb_data);
a4efdff3 508 free_tracking_at((void **)st->tracking, top_level);
509 Safefree(st);
e9716740 510}
511
f3cf7e20 512/* For now, this is somewhat a compatibility bodge until the plan comes
513 together for fine grained recursion control. total_size() would recurse into
514 hash and array members, whereas sv_size() would not. However, sv_size() is
515 called with CvSTASH() of a CV, which means that if it (also) starts to
516 recurse fully, then the size of any CV now becomes the size of the entire
517 symbol table reachable from it, and potentially the entire symbol table, if
518 any subroutine makes a reference to a global (such as %SIG). The historical
519 implementation of total_size() didn't report "everything", and changing the
520 only available size to "everything" doesn't feel at all useful. */
521
522#define NO_RECURSION 0
523#define SOME_RECURSION 1
524#define TOTAL_SIZE_RECURSION 2
525
e386ab55 526static bool sv_size(pTHX_ struct state *, pPATH, const SV *const, const int recurse);
db519f11 527
7ccc7d88 528typedef enum {
9fc9ab86 529 OPc_NULL, /* 0 */
530 OPc_BASEOP, /* 1 */
531 OPc_UNOP, /* 2 */
532 OPc_BINOP, /* 3 */
533 OPc_LOGOP, /* 4 */
534 OPc_LISTOP, /* 5 */
535 OPc_PMOP, /* 6 */
536 OPc_SVOP, /* 7 */
537 OPc_PADOP, /* 8 */
538 OPc_PVOP, /* 9 */
539 OPc_LOOP, /* 10 */
540 OPc_COP /* 11 */
177ebd37 541#ifdef OA_CONDOP
542 , OPc_CONDOP /* 12 */
543#endif
544#ifdef OA_GVOP
545 , OPc_GVOP /* 13 */
546#endif
547
7ccc7d88 548} opclass;
549
550static opclass
9fc9ab86 551cc_opclass(const OP * const o)
7ccc7d88 552{
553 if (!o)
9fc9ab86 554 return OPc_NULL;
1a36ac09 555 TRY_TO_CATCH_SEGV {
9fc9ab86 556 if (o->op_type == 0)
557 return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
7ccc7d88 558
9fc9ab86 559 if (o->op_type == OP_SASSIGN)
560 return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPc_UNOP : OPc_BINOP);
7ccc7d88 561
9fc9ab86 562 #ifdef USE_ITHREADS
563 if (o->op_type == OP_GV || o->op_type == OP_GVSV || o->op_type == OP_AELEMFAST)
564 return OPc_PADOP;
565 #endif
7ccc7d88 566
9fc9ab86 567 if ((o->op_type == OP_TRANS)) {
568 return OPc_BASEOP;
569 }
7ccc7d88 570
9fc9ab86 571 switch (PL_opargs[o->op_type] & OA_CLASS_MASK) {
572 case OA_BASEOP: TAG;
573 return OPc_BASEOP;
574
575 case OA_UNOP: TAG;
576 return OPc_UNOP;
577
578 case OA_BINOP: TAG;
579 return OPc_BINOP;
62691e7c 580
9fc9ab86 581 case OA_LOGOP: TAG;
582 return OPc_LOGOP;
7ccc7d88 583
9fc9ab86 584 case OA_LISTOP: TAG;
585 return OPc_LISTOP;
7ccc7d88 586
9fc9ab86 587 case OA_PMOP: TAG;
588 return OPc_PMOP;
7ccc7d88 589
9fc9ab86 590 case OA_SVOP: TAG;
591 return OPc_SVOP;
7ccc7d88 592
177ebd37 593#ifdef OA_PADOP
9fc9ab86 594 case OA_PADOP: TAG;
595 return OPc_PADOP;
177ebd37 596#endif
597
598#ifdef OA_GVOP
599 case OA_GVOP: TAG;
600 return OPc_GVOP;
601#endif
7ccc7d88 602
177ebd37 603#ifdef OA_PVOP_OR_SVOP
9fc9ab86 604 case OA_PVOP_OR_SVOP: TAG;
605 /*
606 * Character translations (tr///) are usually a PVOP, keeping a
607 * pointer to a table of shorts used to look up translations.
608 * Under utf8, however, a simple table isn't practical; instead,
609 * the OP is an SVOP, and the SV is a reference to a swash
610 * (i.e., an RV pointing to an HV).
611 */
612 return (o->op_private & (OPpTRANS_TO_UTF|OPpTRANS_FROM_UTF))
613 ? OPc_SVOP : OPc_PVOP;
177ebd37 614#endif
7ccc7d88 615
9fc9ab86 616 case OA_LOOP: TAG;
617 return OPc_LOOP;
7ccc7d88 618
9fc9ab86 619 case OA_COP: TAG;
620 return OPc_COP;
7ccc7d88 621
9fc9ab86 622 case OA_BASEOP_OR_UNOP: TAG;
7ccc7d88 623 /*
9fc9ab86 624 * UNI(OP_foo) in toke.c returns token UNI or FUNC1 depending on
625 * whether parens were seen. perly.y uses OPf_SPECIAL to
626 * signal whether a BASEOP had empty parens or none.
627 * Some other UNOPs are created later, though, so the best
628 * test is OPf_KIDS, which is set in newUNOP.
7ccc7d88 629 */
9fc9ab86 630 return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
631
632 case OA_FILESTATOP: TAG;
633 /*
634 * The file stat OPs are created via UNI(OP_foo) in toke.c but use
635 * the OPf_REF flag to distinguish between OP types instead of the
636 * usual OPf_SPECIAL flag. As usual, if OPf_KIDS is set, then we
637 * return OPc_UNOP so that walkoptree can find our children. If
638 * OPf_KIDS is not set then we check OPf_REF. Without OPf_REF set
639 * (no argument to the operator) it's an OP; with OPf_REF set it's
640 * an SVOP (and op_sv is the GV for the filehandle argument).
641 */
642 return ((o->op_flags & OPf_KIDS) ? OPc_UNOP :
643 #ifdef USE_ITHREADS
644 (o->op_flags & OPf_REF) ? OPc_PADOP : OPc_BASEOP);
645 #else
646 (o->op_flags & OPf_REF) ? OPc_SVOP : OPc_BASEOP);
647 #endif
648 case OA_LOOPEXOP: TAG;
649 /*
650 * next, last, redo, dump and goto use OPf_SPECIAL to indicate that a
651 * label was omitted (in which case it's a BASEOP) or else a term was
652 * seen. In this last case, all except goto are definitely PVOP but
653 * goto is either a PVOP (with an ordinary constant label), an UNOP
654 * with OPf_STACKED (with a non-constant non-sub) or an UNOP for
655 * OP_REFGEN (with goto &sub) in which case OPf_STACKED also seems to
656 * get set.
657 */
658 if (o->op_flags & OPf_STACKED)
659 return OPc_UNOP;
660 else if (o->op_flags & OPf_SPECIAL)
661 return OPc_BASEOP;
662 else
663 return OPc_PVOP;
177ebd37 664
665#ifdef OA_CONDOP
666 case OA_CONDOP: TAG;
667 return OPc_CONDOP;
668#endif
9fc9ab86 669 }
670 warn("Devel::Size: Can't determine class of operator %s, assuming BASEOP\n",
671 PL_op_name[o->op_type]);
672 }
1a36ac09 673 CAUGHT_EXCEPTION { }
7ccc7d88 674 return OPc_BASEOP;
675}
676
6a9ad7ec 677/* Figure out how much magic is attached to the SV and return the
678 size */
eee00145 679static void
c07e8ef8 680magic_size(pTHX_ const SV * const thing, struct state *st, pPATH) {
681 dNPathNodes(1, NPathArg);
7b782333 682 MAGIC *magic_pointer = SvMAGIC(thing); /* caller ensures thing is SvMAGICAL */
6ae4d038 683
012b5f33 684 /* push a dummy node for NPathSetNode to update inside the while loop */
685 NPathPushNode("dummy", NPtype_NAME);
686
980c6576 687 /* Have we seen the magic pointer? (NULL has always been seen before) */
e5c69bdd 688 while (check_new(st, magic_pointer)) {
c07e8ef8 689
012b5f33 690 NPathSetNode(magic_pointer, NPtype_MAGIC);
c07e8ef8 691
692 ADD_SIZE(st, "mg", sizeof(MAGIC));
9847261d 693 /* magic vtables aren't freed when magic is freed, so don't count them.
694 (They are static structures. Anything that assumes otherwise is buggy.)
695 */
696
6a9ad7ec 697
1a36ac09 698 TRY_TO_CATCH_SEGV {
6ae4d038 699 /* XXX only chase mg_obj if mg->mg_flags & MGf_REFCOUNTED ? */
fc6614ee 700 sv_size(aTHX_ st, NPathLink("mg_obj"), magic_pointer->mg_obj, TOTAL_SIZE_RECURSION);
d1888d0b 701 if (magic_pointer->mg_len == HEf_SVKEY) {
fc6614ee 702 sv_size(aTHX_ st, NPathLink("mg_ptr"), (SV *)magic_pointer->mg_ptr, TOTAL_SIZE_RECURSION);
d1888d0b 703 }
704#if defined(PERL_MAGIC_utf8) && defined (PERL_MAGIC_UTF8_CACHESIZE)
705 else if (magic_pointer->mg_type == PERL_MAGIC_utf8) {
706 if (check_new(st, magic_pointer->mg_ptr)) {
c07e8ef8 707 ADD_SIZE(st, "PERL_MAGIC_utf8", PERL_MAGIC_UTF8_CACHESIZE * 2 * sizeof(STRLEN));
d1888d0b 708 }
709 }
710#endif
6ae4d038 711 /* XXX also handle mg->mg_type == PERL_MAGIC_utf8 ? */
d1888d0b 712 else if (magic_pointer->mg_len > 0) {
6ae4d038 713 if(0)do_magic_dump(0, Perl_debug_log, magic_pointer, 0, 0, FALSE, 0);
d1888d0b 714 if (check_new(st, magic_pointer->mg_ptr)) {
c07e8ef8 715 ADD_SIZE(st, "mg_len", magic_pointer->mg_len);
d1888d0b 716 }
717 }
6a9ad7ec 718
0964064b 719 /* Get the next in the chain */
9fc9ab86 720 magic_pointer = magic_pointer->mg_moremagic;
721 }
1a36ac09 722 CAUGHT_EXCEPTION {
a4efdff3 723 if (st->dangle_whine)
9fc9ab86 724 warn( "Devel::Size: Encountered bad magic at: %p\n", magic_pointer );
725 }
6a9ad7ec 726 }
6a9ad7ec 727}
728
60dacf5f 729#define check_new_and_strlen(st, p, ppath) S_check_new_and_strlen(aTHX_ st, p, ppath)
eee00145 730static void
60dacf5f 731S_check_new_and_strlen(pTHX_ struct state *st, const char *const p, pPATH) {
c07e8ef8 732 dNPathNodes(1, NPathArg->prev);
733 if(check_new(st, p)) {
012b5f33 734 NPathPushNode(NPathArg->id, NPtype_NAME);
c07e8ef8 735 ADD_SIZE(st, NPathArg->id, 1 + strlen(p));
736 }
99684fd4 737}
738
739static void
60dacf5f 740regex_size(pTHX_ const REGEXP * const baseregex, struct state *st, pPATH) {
c07e8ef8 741 dNPathNodes(1, NPathArg);
c1bfd7da 742 if(!check_new(st, baseregex))
743 return;
012b5f33 744 NPathPushNode("regex_size", NPtype_NAME);
c07e8ef8 745 ADD_SIZE(st, "REGEXP", sizeof(REGEXP));
9fc9ab86 746#if (PERL_VERSION < 11)
6ea94d90 747 /* Note the size of the paren offset thing */
c07e8ef8 748 ADD_SIZE(st, "nparens", sizeof(I32) * baseregex->nparens * 2);
749 ADD_SIZE(st, "precomp", strlen(baseregex->precomp));
6ea94d90 750#else
c07e8ef8 751 ADD_SIZE(st, "regexp", sizeof(struct regexp));
752 ADD_SIZE(st, "nparens", sizeof(I32) * SvANY(baseregex)->nparens * 2);
753 /*ADD_SIZE(st, strlen(SvANY(baseregex)->subbeg));*/
6ea94d90 754#endif
a4efdff3 755 if (st->go_yell && !st->regex_whine) {
6ea94d90 756 carp("Devel::Size: Calculated sizes for compiled regexes are incompatible, and probably always will be");
a4efdff3 757 st->regex_whine = 1;
98ecbbc6 758 }
7ccc7d88 759}
760
957d176b 761static int
d4f77653 762hek_size(pTHX_ struct state *st, HEK *hek, U32 shared, pPATH)
763{
764 dNPathNodes(1, NPathArg);
765
766 /* Hash keys can be shared. Have we seen this before? */
767 if (!check_new(st, hek))
957d176b 768 return 0;
d4f77653 769 NPathPushNode("hek", NPtype_NAME);
770 ADD_SIZE(st, "hek_len", HEK_BASESIZE + hek->hek_len
771#if PERL_VERSION < 8
772 + 1 /* No hash key flags prior to 5.8.0 */
773#else
774 + 2
775#endif
776 );
777 if (shared) {
778#if PERL_VERSION < 10
779 ADD_SIZE(st, "he", sizeof(struct he));
780#else
781 ADD_SIZE(st, "shared_he", STRUCT_OFFSET(struct shared_he, shared_he_hek));
782#endif
783 }
957d176b 784 return 1;
d4f77653 785}
786
787static void
788refcounted_he_size(pTHX_ struct state *st, struct refcounted_he *he, pPATH)
789{
790 dNPathNodes(1, NPathArg);
791 if (!check_new(st, he))
792 return;
793 NPathPushNode("refcounted_he_size", NPtype_NAME);
794 ADD_SIZE(st, "refcounted_he", sizeof(struct refcounted_he));
795
796#ifdef USE_ITHREADS
797 ADD_SIZE(st, "refcounted_he_data", NPtype_NAME);
798#else
799 hek_size(aTHX_ st, he->refcounted_he_hek, 0, NPathLink("refcounted_he_hek"));
800#endif
801
802 if (he->refcounted_he_next)
803 refcounted_he_size(aTHX_ st, he->refcounted_he_next, NPathLink("refcounted_he_next"));
804}
805
c4e79872 806static void op_size_class(pTHX_ const OP * const baseop, opclass op_class, bool skip_op_struct, struct state *st, pPATH);
2bc82b43 807
d4f77653 808static void
c07e8ef8 809op_size(pTHX_ const OP * const baseop, struct state *st, pPATH)
1e5a8ad2 810{
c4e79872 811 op_size_class(aTHX_ baseop, cc_opclass(baseop), 0, st, NPathArg);
2bc82b43 812}
813
814static void
c4e79872 815op_size_class(pTHX_ const OP * const baseop, opclass op_class, bool skip_op_struct, struct state *st, pPATH)
2bc82b43 816{
ce5aa2b7 817 /* op_size recurses to follow the chain of opcodes. For the node path we
818 * don't want the chain to be 'nested' in the path so we use dNPathUseParent().
819 * Also, to avoid a link-to-a-link the caller should use NPathLinkAndNode()
820 * instead of NPathLink().
c07e8ef8 821 */
822 dNPathUseParent(NPathArg);
823
1e5a8ad2 824 TRY_TO_CATCH_SEGV {
825 TAG;
826 if(!check_new(st, baseop))
827 return;
828 TAG;
c07e8ef8 829 op_size(aTHX_ baseop->op_next, st, NPathOpLink);
66a76d3b 830#ifdef PELR_MAD
831 madprop_size(aTHX_ st, NPathOpLink, baseop->op_madprop);
832#endif
1e5a8ad2 833 TAG;
2bc82b43 834 switch (op_class) {
1e5a8ad2 835 case OPc_BASEOP: TAG;
c4e79872 836 if (!skip_op_struct)
837 ADD_SIZE(st, "op", sizeof(struct op));
1e5a8ad2 838 TAG;break;
839 case OPc_UNOP: TAG;
c4e79872 840 if (!skip_op_struct)
841 ADD_SIZE(st, "unop", sizeof(struct unop));
c07e8ef8 842 op_size(aTHX_ ((UNOP *)baseop)->op_first, st, NPathOpLink);
1e5a8ad2 843 TAG;break;
844 case OPc_BINOP: TAG;
c4e79872 845 if (!skip_op_struct)
846 ADD_SIZE(st, "binop", sizeof(struct binop));
c07e8ef8 847 op_size(aTHX_ ((BINOP *)baseop)->op_first, st, NPathOpLink);
848 op_size(aTHX_ ((BINOP *)baseop)->op_last, st, NPathOpLink);
1e5a8ad2 849 TAG;break;
850 case OPc_LOGOP: TAG;
c4e79872 851 if (!skip_op_struct)
852 ADD_SIZE(st, "logop", sizeof(struct logop));
c07e8ef8 853 op_size(aTHX_ ((BINOP *)baseop)->op_first, st, NPathOpLink);
854 op_size(aTHX_ ((LOGOP *)baseop)->op_other, st, NPathOpLink);
1e5a8ad2 855 TAG;break;
177ebd37 856#ifdef OA_CONDOP
857 case OPc_CONDOP: TAG;
c4e79872 858 if (!skip_op_struct)
859 ADD_SIZE(st, "condop", sizeof(struct condop));
c07e8ef8 860 op_size(aTHX_ ((BINOP *)baseop)->op_first, st, NPathOpLink);
861 op_size(aTHX_ ((CONDOP *)baseop)->op_true, st, NPathOpLink);
862 op_size(aTHX_ ((CONDOP *)baseop)->op_false, st, NPathOpLink);
177ebd37 863 TAG;break;
864#endif
1e5a8ad2 865 case OPc_LISTOP: TAG;
c4e79872 866 if (!skip_op_struct)
867 ADD_SIZE(st, "listop", sizeof(struct listop));
c07e8ef8 868 op_size(aTHX_ ((LISTOP *)baseop)->op_first, st, NPathOpLink);
869 op_size(aTHX_ ((LISTOP *)baseop)->op_last, st, NPathOpLink);
1e5a8ad2 870 TAG;break;
871 case OPc_PMOP: TAG;
c4e79872 872 if (!skip_op_struct)
873 ADD_SIZE(st, "pmop", sizeof(struct pmop));
c07e8ef8 874 op_size(aTHX_ ((PMOP *)baseop)->op_first, st, NPathOpLink);
875 op_size(aTHX_ ((PMOP *)baseop)->op_last, st, NPathOpLink);
5a83b7cf 876#if PERL_VERSION < 9 || (PERL_VERSION == 9 && PERL_SUBVERSION < 5)
c07e8ef8 877 op_size(aTHX_ ((PMOP *)baseop)->op_pmreplroot, st, NPathOpLink);
878 op_size(aTHX_ ((PMOP *)baseop)->op_pmreplstart, st, NPathOpLink);
5a83b7cf 879#endif
c1bfd7da 880 /* This is defined away in perl 5.8.x, but it is in there for
881 5.6.x */
98ecbbc6 882#ifdef PM_GETRE
60dacf5f 883 regex_size(aTHX_ PM_GETRE((PMOP *)baseop), st, NPathLink("PM_GETRE"));
98ecbbc6 884#else
60dacf5f 885 regex_size(aTHX_ ((PMOP *)baseop)->op_pmregexp, st, NPathLink("op_pmregexp"));
98ecbbc6 886#endif
c1bfd7da 887 TAG;break;
81f1c018 888 case OPc_SVOP: TAG;
c4e79872 889 if (!skip_op_struct)
890 ADD_SIZE(st, "svop", sizeof(struct svop));
574d9fd9 891 if (!(baseop->op_type == OP_AELEMFAST
892 && baseop->op_flags & OPf_SPECIAL)) {
893 /* not an OP_PADAV replacement */
fc6614ee 894 sv_size(aTHX_ st, NPathLink("SVOP"), ((SVOP *)baseop)->op_sv, SOME_RECURSION);
574d9fd9 895 }
81f1c018 896 TAG;break;
177ebd37 897#ifdef OA_PADOP
c4e79872 898 case OPc_PADOP: TAG;
899 if (!skip_op_struct)
900 ADD_SIZE(st, "padop", sizeof(struct padop));
901 TAG;break;
177ebd37 902#endif
903#ifdef OA_GVOP
c4e79872 904 case OPc_GVOP: TAG;
905 if (!skip_op_struct)
906 ADD_SIZE(st, "gvop", sizeof(struct gvop));
907 sv_size(aTHX_ st, NPathLink("GVOP"), ((GVOP *)baseop)->op_gv, SOME_RECURSION);
908 TAG;break;
177ebd37 909#endif
99684fd4 910 case OPc_PVOP: TAG;
fc6614ee 911 check_new_and_strlen(st, ((PVOP *)baseop)->op_pv, NPathLink("op_pv"));
219b7d34 912 TAG;break;
1e5a8ad2 913 case OPc_LOOP: TAG;
c4e79872 914 if (!skip_op_struct)
915 ADD_SIZE(st, "loop", sizeof(struct loop));
c07e8ef8 916 op_size(aTHX_ ((LOOP *)baseop)->op_first, st, NPathOpLink);
917 op_size(aTHX_ ((LOOP *)baseop)->op_last, st, NPathOpLink);
918 op_size(aTHX_ ((LOOP *)baseop)->op_redoop, st, NPathOpLink);
919 op_size(aTHX_ ((LOOP *)baseop)->op_nextop, st, NPathOpLink);
920 op_size(aTHX_ ((LOOP *)baseop)->op_lastop, st, NPathOpLink);
1e5a8ad2 921 TAG;break;
922 case OPc_COP: TAG;
9fc9ab86 923 {
924 COP *basecop;
925 basecop = (COP *)baseop;
c4e79872 926 if (!skip_op_struct)
927 ADD_SIZE(st, "cop", sizeof(struct cop));
9fc9ab86 928
929 /* Change 33656 by nicholas@mouse-mill on 2008/04/07 11:29:51
930 Eliminate cop_label from struct cop by storing a label as the first
931 entry in the hints hash. Most statements don't have labels, so this
932 will save memory. Not sure how much.
933 The check below will be incorrect fail on bleadperls
934 before 5.11 @33656, but later than 5.10, producing slightly too
935 small memory sizes on these Perls. */
b7621729 936#if (PERL_VERSION < 11)
fc6614ee 937 check_new_and_strlen(st, basecop->cop_label, NPathLink("cop_label"));
b7621729 938#endif
7ccc7d88 939#ifdef USE_ITHREADS
fc6614ee 940 check_new_and_strlen(st, basecop->cop_file, NPathLink("cop_file"));
941 check_new_and_strlen(st, basecop->cop_stashpv, NPathLink("cop_stashpv"));
7ccc7d88 942#else
49beddc6 943 if (SvREFCNT(basecop->cop_stash) == 1) /* XXX hack? */
944 sv_size(aTHX_ st, NPathLink("cop_stash"), (SV *)basecop->cop_stash, SOME_RECURSION);
fc6614ee 945 sv_size(aTHX_ st, NPathLink("cop_filegv"), (SV *)basecop->cop_filegv, SOME_RECURSION);
7ccc7d88 946#endif
3f5c3c40 947 refcounted_he_size(aTHX_ st, CopHINTHASH_get(basecop), NPathLink("cop_hints_hash"));
9fc9ab86 948 }
949 TAG;break;
950 default:
951 TAG;break;
952 }
953 }
1a36ac09 954 CAUGHT_EXCEPTION {
a4efdff3 955 if (st->dangle_whine)
9fc9ab86 956 warn( "Devel::Size: Encountered dangling pointer in opcode at: %p\n", baseop );
7ccc7d88 957 }
7ccc7d88 958}
6a9ad7ec 959
24638fb4 960#if PERL_VERSION < 8 || PERL_SUBVERSION < 9 /* XXX plain || seems like a bug */
b6558d1d 961# define SVt_LAST 16
24d37977 962#endif
963
f73dcfce 964#ifdef PURIFY
965# define MAYBE_PURIFY(normal, pure) (pure)
966# define MAYBE_OFFSET(struct_name, member) 0
967#else
968# define MAYBE_PURIFY(normal, pure) (normal)
969# define MAYBE_OFFSET(struct_name, member) STRUCT_OFFSET(struct_name, member)
970#endif
971
b6558d1d 972const U8 body_sizes[SVt_LAST] = {
973#if PERL_VERSION < 9
f73dcfce 974 0, /* SVt_NULL */
975 MAYBE_PURIFY(sizeof(IV), sizeof(XPVIV)), /* SVt_IV */
976 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
977 sizeof(XRV), /* SVt_RV */
978 sizeof(XPV), /* SVt_PV */
979 sizeof(XPVIV), /* SVt_PVIV */
980 sizeof(XPVNV), /* SVt_PVNV */
981 sizeof(XPVMG), /* SVt_PVMG */
982 sizeof(XPVBM), /* SVt_PVBM */
983 sizeof(XPVLV), /* SVt_PVLV */
984 sizeof(XPVAV), /* SVt_PVAV */
985 sizeof(XPVHV), /* SVt_PVHV */
986 sizeof(XPVCV), /* SVt_PVCV */
987 sizeof(XPVGV), /* SVt_PVGV */
988 sizeof(XPVFM), /* SVt_PVFM */
989 sizeof(XPVIO) /* SVt_PVIO */
b6558d1d 990#elif PERL_VERSION == 10 && PERL_SUBVERSION == 0
f73dcfce 991 0, /* SVt_NULL */
992 0, /* SVt_BIND */
993 0, /* SVt_IV */
994 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
995 0, /* SVt_RV */
996 MAYBE_PURIFY(sizeof(xpv_allocated), sizeof(XPV)), /* SVt_PV */
997 MAYBE_PURIFY(sizeof(xpviv_allocated), sizeof(XPVIV)),/* SVt_PVIV */
998 sizeof(XPVNV), /* SVt_PVNV */
999 sizeof(XPVMG), /* SVt_PVMG */
1000 sizeof(XPVGV), /* SVt_PVGV */
1001 sizeof(XPVLV), /* SVt_PVLV */
1002 MAYBE_PURIFY(sizeof(xpvav_allocated), sizeof(XPVAV)),/* SVt_PVAV */
1003 MAYBE_PURIFY(sizeof(xpvhv_allocated), sizeof(XPVHV)),/* SVt_PVHV */
1004 MAYBE_PURIFY(sizeof(xpvcv_allocated), sizeof(XPVCV)),/* SVt_PVCV */
1005 MAYBE_PURIFY(sizeof(xpvfm_allocated), sizeof(XPVFM)),/* SVt_PVFM */
1006 sizeof(XPVIO), /* SVt_PVIO */
b6558d1d 1007#elif PERL_VERSION == 10 && PERL_SUBVERSION == 1
f73dcfce 1008 0, /* SVt_NULL */
1009 0, /* SVt_BIND */
1010 0, /* SVt_IV */
1011 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
1012 0, /* SVt_RV */
1013 sizeof(XPV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PV */
1014 sizeof(XPVIV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PVIV */
1015 sizeof(XPVNV), /* SVt_PVNV */
1016 sizeof(XPVMG), /* SVt_PVMG */
1017 sizeof(XPVGV), /* SVt_PVGV */
1018 sizeof(XPVLV), /* SVt_PVLV */
1019 sizeof(XPVAV) - MAYBE_OFFSET(XPVAV, xav_fill), /* SVt_PVAV */
1020 sizeof(XPVHV) - MAYBE_OFFSET(XPVHV, xhv_fill), /* SVt_PVHV */
1021 sizeof(XPVCV) - MAYBE_OFFSET(XPVCV, xpv_cur), /* SVt_PVCV */
1022 sizeof(XPVFM) - MAYBE_OFFSET(XPVFM, xpv_cur), /* SVt_PVFM */
1023 sizeof(XPVIO) /* SVt_PVIO */
b6558d1d 1024#elif PERL_VERSION < 13
f73dcfce 1025 0, /* SVt_NULL */
1026 0, /* SVt_BIND */
1027 0, /* SVt_IV */
1028 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
1029 sizeof(XPV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PV */
1030 sizeof(XPVIV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PVIV */
1031 sizeof(XPVNV), /* SVt_PVNV */
1032 sizeof(XPVMG), /* SVt_PVMG */
1033 sizeof(regexp) - MAYBE_OFFSET(regexp, xpv_cur), /* SVt_REGEXP */
1034 sizeof(XPVGV), /* SVt_PVGV */
1035 sizeof(XPVLV), /* SVt_PVLV */
1036 sizeof(XPVAV) - MAYBE_OFFSET(XPVAV, xav_fill), /* SVt_PVAV */
1037 sizeof(XPVHV) - MAYBE_OFFSET(XPVHV, xhv_fill), /* SVt_PVHV */
1038 sizeof(XPVCV) - MAYBE_OFFSET(XPVCV, xpv_cur), /* SVt_PVCV */
1039 sizeof(XPVFM) - MAYBE_OFFSET(XPVFM, xpv_cur), /* SVt_PVFM */
1040 sizeof(XPVIO) /* SVt_PVIO */
b6558d1d 1041#else
f73dcfce 1042 0, /* SVt_NULL */
1043 0, /* SVt_BIND */
1044 0, /* SVt_IV */
1045 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
1046 sizeof(XPV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PV */
1047 sizeof(XPVIV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PVIV */
1048 sizeof(XPVNV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PVNV */
1049 sizeof(XPVMG), /* SVt_PVMG */
1050 sizeof(regexp), /* SVt_REGEXP */
1051 sizeof(XPVGV), /* SVt_PVGV */
1052 sizeof(XPVLV), /* SVt_PVLV */
1053 sizeof(XPVAV), /* SVt_PVAV */
1054 sizeof(XPVHV), /* SVt_PVHV */
1055 sizeof(XPVCV), /* SVt_PVCV */
1056 sizeof(XPVFM), /* SVt_PVFM */
1057 sizeof(XPVIO) /* SVt_PVIO */
b6558d1d 1058#endif
1059};
1060
c07e8ef8 1061
8a087ef5 1062/* based on Perl_do_dump_pad() - wraps sv_size and adds ADD_ATTR calls for the pad names */
c07e8ef8 1063static void
1064padlist_size(pTHX_ struct state *const st, pPATH, PADLIST *padlist,
1065 const int recurse)
1066{
1067 dNPathUseParent(NPathArg);
c07e8ef8 1068 const AV *pad_name;
1069 SV **pname;
1070 I32 ix;
1071
d2181def 1072 if (!padlist)
1073 return;
1074 if( 0 && !check_new(st, padlist))
c07e8ef8 1075 return;
1869f459 1076
c07e8ef8 1077 pad_name = MUTABLE_AV(*av_fetch(MUTABLE_AV(padlist), 0, FALSE));
1078 pname = AvARRAY(pad_name);
1079
1080 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
1081 const SV *namesv = pname[ix];
1082 if (namesv && namesv == &PL_sv_undef) {
1083 namesv = NULL;
1084 }
1085 if (namesv) {
d2181def 1086 /* SvFAKE: On a pad name SV, that slot in the frame AV is a REFCNT'ed reference to a lexical from "outside" */
c07e8ef8 1087 if (SvFAKE(namesv))
e8f4c506 1088 ADD_ATTR(st, NPattr_PADFAKE, SvPVX_const(namesv), ix);
c07e8ef8 1089 else
e8f4c506 1090 ADD_ATTR(st, NPattr_PADNAME, SvPVX_const(namesv), ix);
c07e8ef8 1091 }
1092 else {
e8f4c506 1093 ADD_ATTR(st, NPattr_PADTMP, "SVs_PADTMP", ix);
c07e8ef8 1094 }
1095
1096 }
1097 sv_size(aTHX_ st, NPathArg, (SV*)padlist, recurse);
1098}
1099
1100
e386ab55 1101static bool
c07e8ef8 1102sv_size(pTHX_ struct state *const st, pPATH, const SV * const orig_thing,
f3cf7e20 1103 const int recurse) {
9fc9ab86 1104 const SV *thing = orig_thing;
c07e8ef8 1105 dNPathNodes(3, NPathArg);
b6558d1d 1106 U32 type;
eee00145 1107
c07e8ef8 1108 if(!check_new(st, orig_thing))
e386ab55 1109 return 0;
81f1c018 1110
b6558d1d 1111 type = SvTYPE(thing);
1112 if (type > SVt_LAST) {
1113 warn("Devel::Size: Unknown variable type: %d encountered\n", type);
01f5c6f5 1114 return 0;
b6558d1d 1115 }
012b5f33 1116 NPathPushNode(thing, NPtype_SV);
df9491fe 1117 ADD_SIZE(st, "sv_head", sizeof(SV));
1118 ADD_SIZE(st, "sv_body", body_sizes[type]);
b1e5ad85 1119
b6558d1d 1120 switch (type) {
1121#if (PERL_VERSION < 11)
e98cedbf 1122 /* Is it a reference? */
9fc9ab86 1123 case SVt_RV: TAG;
b6558d1d 1124#else
1125 case SVt_IV: TAG;
24d37977 1126#endif
d2181def 1127 if(recurse && SvROK(thing)) /* XXX maybe don't follow weakrefs */
1128 sv_size(aTHX_ st, (SvWEAKREF(thing) ? NPathLink("weakRV") : NPathLink("RV")), SvRV_const(thing), recurse);
9fc9ab86 1129 TAG;break;
267703fd 1130
9fc9ab86 1131 case SVt_PVAV: TAG;
e98cedbf 1132 /* Is there anything in the array? */
1133 if (AvMAX(thing) != -1) {
c8db37d3 1134 /* an array with 10 slots has AvMax() set to 9 - te 2007-04-22 */
c07e8ef8 1135 ADD_SIZE(st, "av_max", sizeof(SV *) * (AvMAX(thing) + 1));
12ae883b 1136 ADD_ATTR(st, NPattr_NOTE, "av_len", av_len((AV*)thing));
eee00145 1137 dbg_printf(("total_size: %li AvMAX: %li av_len: $i\n", st->total_size, AvMAX(thing), av_len((AV*)thing)));
6c5ddc0d 1138
05f432c0 1139 if (recurse >= st->min_recurse_threshold) {
6c5ddc0d 1140 SSize_t i = AvFILLp(thing) + 1;
1141
93a78808 1142 while (i--) {
09c6d3bb 1143 if (sv_size(aTHX_ st, NPathLink("AVelem"), AvARRAY(thing)[i], recurse))
1144 ADD_LINK_ATTR(st, NPattr_NOTE, "i", i);
93a78808 1145 }
6c5ddc0d 1146 }
e98cedbf 1147 }
1148 /* Add in the bits on the other side of the beginning */
0430b7f7 1149
b7621729 1150 dbg_printf(("total_size %li, sizeof(SV *) %li, AvARRAY(thing) %li, AvALLOC(thing)%li , sizeof(ptr) %li \n",
c07e8ef8 1151 st->total_size, sizeof(SV*), AvARRAY(thing), AvALLOC(thing), sizeof( thing )));
0430b7f7 1152
1153 /* under Perl 5.8.8 64bit threading, AvARRAY(thing) was a pointer while AvALLOC was 0,
b1e5ad85 1154 resulting in grossly overstated sized for arrays. Technically, this shouldn't happen... */
0430b7f7 1155 if (AvALLOC(thing) != 0) {
c07e8ef8 1156 ADD_SIZE(st, "AvALLOC", (sizeof(SV *) * (AvARRAY(thing) - AvALLOC(thing))));
0430b7f7 1157 }
795fc84c 1158#if (PERL_VERSION < 9)
1159 /* Is there something hanging off the arylen element?
1160 Post 5.9.something this is stored in magic, so will be found there,
1161 and Perl_av_arylen_p() takes a non-const AV*, hence compilers rightly
1162 complain about AvARYLEN() passing thing to it. */
fc6614ee 1163 sv_size(aTHX_ st, NPathLink("ARYLEN"), AvARYLEN(thing), recurse);
795fc84c 1164#endif
9fc9ab86 1165 TAG;break;
49beddc6 1166
9fc9ab86 1167 case SVt_PVHV: TAG;
a6ea0805 1168 /* Now the array of buckets */
9692b300 1169#ifdef HvENAME
1170 if (HvENAME(thing)) { ADD_ATTR(st, NPattr_NAME, HvENAME(thing), 0); }
1171#else
1172 if (HvNAME(thing)) { ADD_ATTR(st, NPattr_NAME, HvNAME(thing), 0); }
1173#endif
c1829d33 1174 ADD_SIZE(st, "hv_max", (sizeof(HE *) * (HvMAX(thing) + 1)));
a6ea0805 1175 /* Now walk the bucket chain */
6a9ad7ec 1176 if (HvARRAY(thing)) {
a6ea0805 1177 HE *cur_entry;
9fc9ab86 1178 UV cur_bucket = 0;
c1829d33 1179
a6ea0805 1180 for (cur_bucket = 0; cur_bucket <= HvMAX(thing); cur_bucket++) {
9fc9ab86 1181 cur_entry = *(HvARRAY(thing) + cur_bucket);
1182 while (cur_entry) {
c1829d33 1183 NPathPushNode("he", NPtype_LINK);
1184 NPathPushNode("he+hek", NPtype_NAME);
c07e8ef8 1185 ADD_SIZE(st, "he", sizeof(HE));
fc6614ee 1186 hek_size(aTHX_ st, cur_entry->hent_hek, HvSHAREKEYS(thing), NPathLink("hent_hek"));
05f432c0 1187 if (recurse >= st->min_recurse_threshold) {
d3b8a135 1188 if (orig_thing == (SV*)PL_strtab) {
df9491fe 1189 /* For PL_strtab the HeVAL is used as a refcnt */
1190 ADD_SIZE(st, "shared_hek", HeKLEN(cur_entry));
1191 }
1192 else {
2c631ee0 1193/* I've seen a PL_strtab HeVAL == 0xC and 0x40C etc
5e486cae 1194 * just running perl -Mblib -Mstrict -MDevel::Size=:all -MCarp -e 'warn perl_size()'
1195 * but it seemed like a corruption - it would change come and go with irrelevant code changes.
1196 * so we protect against that here, but I'd like to know the cause.
1197 */
2c631ee0 1198if (PTR2UV(HeVAL(cur_entry)) > 0xFFF)
fc6614ee 1199 sv_size(aTHX_ st, NPathLink("HeVAL"), HeVAL(cur_entry), recurse);
b6ec3c3a 1200else warn("skipped suspect HeVAL %p", HeVAL(cur_entry));
df9491fe 1201 }
5e486cae 1202 }
9fc9ab86 1203 cur_entry = cur_entry->hent_next;
c1829d33 1204 NPathPopNode;
1205 NPathPopNode;
9fc9ab86 1206 }
c1829d33 1207 } /* bucket chain */
a6ea0805 1208 }
c1829d33 1209
78037efb 1210#ifdef HvAUX
1211 if (SvOOK(thing)) {
1212 /* This direct access is arguably "naughty": */
1213 struct mro_meta *meta = HvAUX(thing)->xhv_mro_meta;
24638fb4 1214#if PERL_VERSION > 13 || PERL_SUBVERSION > 8 /* XXX plain || seems like a bug */
b3a37f1a 1215 /* As is this: */
1216 I32 count = HvAUX(thing)->xhv_name_count;
1217
1218 if (count) {
1219 HEK **names = HvAUX(thing)->xhv_name_u.xhvnameu_names;
1220 if (count < 0)
1221 count = -count;
1222 while (--count)
fc6614ee 1223 hek_size(aTHX_ st, names[count], 1, NPathLink("HvAUXelem"));
b3a37f1a 1224 }
1225 else
1226#endif
1227 {
fc6614ee 1228 hek_size(aTHX_ st, HvNAME_HEK(thing), 1, NPathLink("HvNAME_HEK"));
b3a37f1a 1229 }
1230
c07e8ef8 1231 ADD_SIZE(st, "xpvhv_aux", sizeof(struct xpvhv_aux));
78037efb 1232 if (meta) {
c07e8ef8 1233 ADD_SIZE(st, "mro_meta", sizeof(struct mro_meta));
fc6614ee 1234 sv_size(aTHX_ st, NPathLink("mro_nextmethod"), (SV *)meta->mro_nextmethod, TOTAL_SIZE_RECURSION);
78037efb 1235#if PERL_VERSION > 10 || (PERL_VERSION == 10 && PERL_SUBVERSION > 0)
fc6614ee 1236 sv_size(aTHX_ st, NPathLink("isa"), (SV *)meta->isa, TOTAL_SIZE_RECURSION);
78037efb 1237#endif
1238#if PERL_VERSION > 10
fc6614ee 1239 sv_size(aTHX_ st, NPathLink("mro_linear_all"), (SV *)meta->mro_linear_all, TOTAL_SIZE_RECURSION);
1240 sv_size(aTHX_ st, NPathLink("mro_linear_current"), meta->mro_linear_current, TOTAL_SIZE_RECURSION);
78037efb 1241#else
fc6614ee 1242 sv_size(aTHX_ st, NPathLink("mro_linear_dfs"), (SV *)meta->mro_linear_dfs, TOTAL_SIZE_RECURSION);
1243 sv_size(aTHX_ st, NPathLink("mro_linear_c3"), (SV *)meta->mro_linear_c3, TOTAL_SIZE_RECURSION);
78037efb 1244#endif
1245 }
1246 }
1247#else
fc6614ee 1248 check_new_and_strlen(st, HvNAME_get(thing), NPathLink("HvNAME"));
78037efb 1249#endif
9fc9ab86 1250 TAG;break;
267703fd 1251
1252
1253 case SVt_PVFM: TAG;
eb73dc89 1254 padlist_size(aTHX_ st, NPathLink("CvPADLIST"), CvPADLIST(thing), recurse);
36a03132 1255 sv_size(aTHX_ st, NPathLink("CvOUTSIDE"), (SV *)CvOUTSIDE(thing), SOME_RECURSION);
267703fd 1256
1257 if (st->go_yell && !st->fm_whine) {
1258 carp("Devel::Size: Calculated sizes for FMs are incomplete");
1259 st->fm_whine = 1;
1260 }
1261 goto freescalar;
1262
9fc9ab86 1263 case SVt_PVCV: TAG;
336fdadd 1264 /* not CvSTASH, per https://rt.cpan.org/Ticket/Display.html?id=79366 */
93a78808 1265 ADD_ATTR(st, NPattr_NAME, CvGV(thing) ? GvNAME(CvGV(thing)) : "UNDEFINED", 0);
fc6614ee 1266 sv_size(aTHX_ st, NPathLink("CvGV"), (SV *)CvGV(thing), SOME_RECURSION);
eb73dc89 1267 padlist_size(aTHX_ st, NPathLink("CvPADLIST"), CvPADLIST(thing), recurse);
36a03132 1268 sv_size(aTHX_ st, NPathLink("CvOUTSIDE"), (SV *)CvOUTSIDE(thing), SOME_RECURSION);
66f50dda 1269 if (CvISXSUB(thing)) {
fc6614ee 1270 sv_size(aTHX_ st, NPathLink("cv_const_sv"), cv_const_sv((CV *)thing), recurse);
66f50dda 1271 } else {
ce5aa2b7 1272 if(1)op_size(aTHX_ CvSTART(thing), st, NPathLinkAndNode("CvSTART", "OPs")); /* XXX ? */
1273 op_size(aTHX_ CvROOT(thing), st, NPathLinkAndNode("CvROOT", "OPs"));
7ccc7d88 1274 }
267703fd 1275 goto freescalar;
1276
1277 case SVt_PVIO: TAG;
267703fd 1278 /* Some embedded char pointers */
fc6614ee 1279 check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_top_name, NPathLink("xio_top_name"));
1280 check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_fmt_name, NPathLink("xio_fmt_name"));
1281 check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_bottom_name, NPathLink("xio_bottom_name"));
267703fd 1282 /* Throw the GVs on the list to be walked if they're not-null */
fc6614ee 1283 sv_size(aTHX_ st, NPathLink("xio_top_gv"), (SV *)((XPVIO *) SvANY(thing))->xio_top_gv, recurse);
1284 sv_size(aTHX_ st, NPathLink("xio_bottom_gv"), (SV *)((XPVIO *) SvANY(thing))->xio_bottom_gv, recurse);
1285 sv_size(aTHX_ st, NPathLink("xio_fmt_gv"), (SV *)((XPVIO *) SvANY(thing))->xio_fmt_gv, recurse);
267703fd 1286
1287 /* Only go trotting through the IO structures if they're really
1288 trottable. If USE_PERLIO is defined we can do this. If
1289 not... we can't, so we don't even try */
1290#ifdef USE_PERLIO
1291 /* Dig into xio_ifp and xio_ofp here */
1292 warn("Devel::Size: Can't size up perlio layers yet\n");
1293#endif
1294 goto freescalar;
1295
267703fd 1296 case SVt_PVLV: TAG;
267703fd 1297#if (PERL_VERSION < 9)
1298 goto freescalar;
267703fd 1299#endif
7ccc7d88 1300
9fc9ab86 1301 case SVt_PVGV: TAG;
4a3d023d 1302 if(isGV_with_GP(thing)) {
638a265a 1303#ifdef GvNAME_HEK
fc6614ee 1304 hek_size(aTHX_ st, GvNAME_HEK(thing), 1, NPathLink("GvNAME_HEK"));
638a265a 1305#else
c07e8ef8 1306 ADD_SIZE(st, "GvNAMELEN", GvNAMELEN(thing));
638a265a 1307#endif
e8f4c506 1308 ADD_ATTR(st, NPattr_NAME, GvNAME_get(thing), 0);
15588e9c 1309#ifdef GvFILE_HEK
fc6614ee 1310 hek_size(aTHX_ st, GvFILE_HEK(thing), 1, NPathLink("GvFILE_HEK"));
15588e9c 1311#elif defined(GvFILE)
2b217e71 1312# if !defined(USE_ITHREADS) || (PERL_VERSION > 8 || (PERL_VERSION == 8 && PERL_SUBVERSION > 8))
1313 /* With itreads, before 5.8.9, this can end up pointing to freed memory
1314 if the GV was created in an eval, as GvFILE() points to CopFILE(),
1315 and the relevant COP has been freed on scope cleanup after the eval.
1316 5.8.9 adds a binary compatible fudge that catches the vast majority
1317 of cases. 5.9.something added a proper fix, by converting the GP to
1318 use a shared hash key (porperly reference counted), instead of a
1319 char * (owned by who knows? possibly no-one now) */
fc6614ee 1320 check_new_and_strlen(st, GvFILE(thing), NPathLink("GvFILE"));
2b217e71 1321# endif
78dfb4e7 1322#endif
4a3d023d 1323 /* Is there something hanging off the glob? */
1324 if (check_new(st, GvGP(thing))) {
c07e8ef8 1325 ADD_SIZE(st, "GP", sizeof(GP));
fc6614ee 1326 sv_size(aTHX_ st, NPathLink("gp_sv"), (SV *)(GvGP(thing)->gp_sv), recurse);
fc6614ee 1327 sv_size(aTHX_ st, NPathLink("gp_av"), (SV *)(GvGP(thing)->gp_av), recurse);
1328 sv_size(aTHX_ st, NPathLink("gp_hv"), (SV *)(GvGP(thing)->gp_hv), recurse);
fc6614ee 1329 sv_size(aTHX_ st, NPathLink("gp_cv"), (SV *)(GvGP(thing)->gp_cv), recurse);
49beddc6 1330 sv_size(aTHX_ st, NPathLink("gp_egv"), (SV *)(GvGP(thing)->gp_egv), recurse);
1331 sv_size(aTHX_ st, NPathLink("gp_form"), (SV *)(GvGP(thing)->gp_form), recurse);
4a3d023d 1332 }
267703fd 1333#if (PERL_VERSION >= 9)
1334 TAG; break;
1335#endif
5c2e1b12 1336 }
b6558d1d 1337#if PERL_VERSION <= 8
1338 case SVt_PVBM: TAG;
1339#endif
267703fd 1340 case SVt_PVMG: TAG;
267703fd 1341 case SVt_PVNV: TAG;
267703fd 1342 case SVt_PVIV: TAG;
267703fd 1343 case SVt_PV: TAG;
267703fd 1344 freescalar:
1345 if(recurse && SvROK(thing))
fc6614ee 1346 sv_size(aTHX_ st, NPathLink("RV"), SvRV_const(thing), recurse);
924d9c4e 1347 else if (SvIsCOW_shared_hash(thing))
fc6614ee 1348 hek_size(aTHX_ st, SvSHARED_HEK_FROM_PV(SvPVX(thing)), 1, NPathLink("SvSHARED_HEK_FROM_PV"));
267703fd 1349 else
c07e8ef8 1350 ADD_SIZE(st, "SvLEN", SvLEN(thing));
267703fd 1351
1352 if(SvOOK(thing)) {
95dc1714 1353 STRLEN len;
1354 SvOOK_offset(thing, len);
c07e8ef8 1355 ADD_SIZE(st, "SvOOK", len);
ebb2c5b9 1356 }
9fc9ab86 1357 TAG;break;
5073b933 1358
e98cedbf 1359 }
49beddc6 1360
1361 if (type >= SVt_PVMG) {
7b782333 1362 if (SvMAGICAL(thing))
49beddc6 1363 magic_size(aTHX_ thing, st, NPathLink("MG"));
c922539f 1364 if (SvPAD_OUR(thing) && SvOURSTASH(thing))
1365 sv_size(aTHX_ st, NPathLink("SvOURSTASH"), (SV *)SvOURSTASH(thing), SOME_RECURSION);
7c8a009a 1366 if (SvSTASH(thing))
1367 sv_size(aTHX_ st, NPathLink("SvSTASH"), (SV *)SvSTASH(thing), SOME_RECURSION);
49beddc6 1368 }
1369
e386ab55 1370 return 1;
e98cedbf 1371}
1372
1abba8e9 1373static void
1374free_memnode_state(pTHX_ struct state *st)
1375{
322b968f 1376 /* PERL_UNUSED_ARG(aTHX); fails for non-threaded perl */
d3b8a135 1377 if (st->node_stream_fh && st->node_stream_name && *st->node_stream_name) {
09c6d3bb 1378 fprintf(st->node_stream_fh, "E %d %f %s\n",
5e2e22f3 1379 getpid(), gettimeofday_nv()-st->start_time_nv, "unnamed");
1abba8e9 1380 if (*st->node_stream_name == '|') {
1381 if (pclose(st->node_stream_fh))
1382 warn("%s exited with an error status\n", st->node_stream_name);
1383 }
1384 else {
1385 if (fclose(st->node_stream_fh))
1386 warn("Error closing %s: %s\n", st->node_stream_name, strerror(errno));
1387 }
1388 }
1389}
1390
a4efdff3 1391static struct state *
1392new_state(pTHX)
65db36c0 1393{
1394 SV *warn_flag;
a4efdff3 1395 struct state *st;
d9b022a1 1396
a4efdff3 1397 Newxz(st, 1, struct state);
1398 st->go_yell = TRUE;
05f432c0 1399 st->min_recurse_threshold = TOTAL_SIZE_RECURSION;
9692b300 1400 if (NULL != (warn_flag = get_sv("Devel::Size::warn", FALSE))) {
a4efdff3 1401 st->dangle_whine = st->go_yell = SvIV(warn_flag) ? TRUE : FALSE;
65db36c0 1402 }
9692b300 1403 if (NULL != (warn_flag = get_sv("Devel::Size::dangle", FALSE))) {
a4efdff3 1404 st->dangle_whine = SvIV(warn_flag) ? TRUE : FALSE;
65db36c0 1405 }
5e2e22f3 1406 st->start_time_nv = gettimeofday_nv();
a52ceccd 1407 check_new(st, &PL_sv_undef);
1408 check_new(st, &PL_sv_no);
1409 check_new(st, &PL_sv_yes);
6389ea67 1410#if PERL_VERSION > 8 || (PERL_VERSION == 8 && PERL_SUBVERSION > 0)
1411 check_new(st, &PL_sv_placeholder);
1412#endif
d3b8a135 1413
33f2f60c 1414#ifdef PATH_TRACKING
d3b8a135 1415 /* XXX quick hack */
0e977dbc 1416 st->node_stream_name = getenv("SIZEME");
d3b8a135 1417 if (st->node_stream_name) {
1418 if (*st->node_stream_name) {
1419 if (*st->node_stream_name == '|')
1420 st->node_stream_fh = popen(st->node_stream_name+1, "w");
1421 else
1422 st->node_stream_fh = fopen(st->node_stream_name, "wb");
1423 if (!st->node_stream_fh)
1424 croak("Can't open '%s' for writing: %s", st->node_stream_name, strerror(errno));
5e2e22f3 1425 if(0)setlinebuf(st->node_stream_fh); /* XXX temporary for debugging */
d3b8a135 1426 st->add_attr_cb = np_stream_node_path_info;
09c6d3bb 1427 fprintf(st->node_stream_fh, "S %d %f %s\n",
5e2e22f3 1428 getpid(), st->start_time_nv, "unnamed");
d3b8a135 1429 }
1430 else
1431 st->add_attr_cb = np_dump_node_path_info;
1abba8e9 1432 }
1abba8e9 1433 st->free_state_cb = free_memnode_state;
33f2f60c 1434#endif
d3b8a135 1435
a4efdff3 1436 return st;
65db36c0 1437}
1438
1abba8e9 1439/* XXX based on S_visit() in sv.c */
1440static void
1441unseen_sv_size(pTHX_ struct state *st, pPATH)
1442{
1443 dVAR;
1444 SV* sva;
1abba8e9 1445 dNPathNodes(1, NPathArg);
1446
1447 NPathPushNode("unseen", NPtype_NAME);
1448
1449 /* by this point we should have visited all the SVs
1450 * so now we'll run through all the SVs via the arenas
21058011 1451 * in order to find any that we've missed for some reason.
1452 * Once the rest of the code is finding ALL the SVs then any
1abba8e9 1453 * found here will be leaks.
1454 */
1455 for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) {
1456 const SV * const svend = &sva[SvREFCNT(sva)];
1457 SV* sv;
1458 for (sv = sva + 1; sv < svend; ++sv) {
1459 if (SvTYPE(sv) != (svtype)SVTYPEMASK && SvREFCNT(sv)) {
49beddc6 1460 sv_size(aTHX_ st, NPathLink("arena"), sv, TOTAL_SIZE_RECURSION);
1abba8e9 1461 }
1462 else if (check_new(st, sv)) { /* sanity check */
1abba8e9 1463 sv_dump(sv);
df9491fe 1464 warn("unseen_sv_size encountered freed SV unexpectedly"); /* XXX warn uses an SV, I think */
1abba8e9 1465 }
1466 }
1467 }
1468}
1469
66a76d3b 1470#ifdef PERL_MAD
1471static void
1472madprop_size(pTHX_ struct state *const st, pPath, MADPROP *prop)
1473{
1474 dPathNodes(2, NPathArg);
1475 if (!check_new(st, prop))
1476 return;
1477 NPathPushNode("madprop_size", NPtype_NAME);
1478 ADD_SIZE(st, "MADPROP", sizeof(MADPROP));
1479
1480 NPathPushNode("val");
1481 ADD_SIZE(st, "val", prop->mad_val);
1482 if (prop->mad_next)
1483 madprop_size(aTHX_ st, NPathLink("mad_next"), prop->mad_next);
1484}
1485#endif
1486
1487static void
1488parser_size(pTHX_ struct state *const st, pPATH, yy_parser *parser)
1489{
1490 dNPathNodes(2, NPathArg);
66a76d3b 1491 if (!check_new(st, parser))
1492 return;
1493 NPathPushNode("parser_size", NPtype_NAME);
1494 ADD_SIZE(st, "yy_parser", sizeof(yy_parser));
1495
1496 NPathPushNode("stack", NPtype_NAME);
1497 yy_stack_frame *ps;
9692b300 1498 /*warn("total: %u", parser->stack_size); */
1499 /*warn("foo: %u", parser->ps - parser->stack); */
b42bdc95 1500 ADD_SIZE(st, "stack_frames", parser->stack_size * sizeof(yy_stack_frame));
66a76d3b 1501 for (ps = parser->stack; ps <= parser->ps; ps++) {
ad9ba590 1502#if (PERL_BCDVERSION >= 0x5011001) /* roughly */
21058011 1503 if (sv_size(aTHX_ st, NPathLink("compcv"), (SV*)ps->compcv, TOTAL_SIZE_RECURSION))
1504 ADD_LINK_ATTR(st, NPattr_NOTE, "i", ps - parser->ps);
ad9ba590 1505#else /* prior to perl 8c63ea58 Dec 8 2009 */
1506 if (sv_size(aTHX_ st, NPathLink("comppad"), (SV*)ps->comppad, TOTAL_SIZE_RECURSION))
1507 ADD_LINK_ATTR(st, NPattr_NOTE, "i", ps - parser->ps);
1508#endif
66a76d3b 1509 }
1510 NPathPopNode;
1511
1512 sv_size(aTHX_ st, NPathLink("lex_repl"), (SV*)parser->lex_repl, TOTAL_SIZE_RECURSION);
1513 sv_size(aTHX_ st, NPathLink("lex_stuff"), (SV*)parser->lex_stuff, TOTAL_SIZE_RECURSION);
1514 sv_size(aTHX_ st, NPathLink("linestr"), (SV*)parser->linestr, TOTAL_SIZE_RECURSION);
1515 sv_size(aTHX_ st, NPathLink("in_my_stash"), (SV*)parser->in_my_stash, TOTAL_SIZE_RECURSION);
9692b300 1516 /*sv_size(aTHX_ st, NPathLink("rsfp"), parser->rsfp, TOTAL_SIZE_RECURSION); */
e9c43be8 1517 sv_size(aTHX_ st, NPathLink("rsfp_filters"), (SV*)parser->rsfp_filters, TOTAL_SIZE_RECURSION);
66a76d3b 1518#ifdef PERL_MAD
1519 sv_size(aTHX_ st, NPathLink("endwhite"), parser->endwhite, TOTAL_SIZE_RECURSION);
1520 sv_size(aTHX_ st, NPathLink("nextwhite"), parser->nextwhite, TOTAL_SIZE_RECURSION);
1521 sv_size(aTHX_ st, NPathLink("skipwhite"), parser->skipwhite, TOTAL_SIZE_RECURSION);
1522 sv_size(aTHX_ st, NPathLink("thisclose"), parser->thisclose, TOTAL_SIZE_RECURSION);
1523 madprop_size(aTHX_ st, NPathLink("thismad"), parser->thismad);
1524 sv_size(aTHX_ st, NPathLink("thisopen"), parser->thisopen, TOTAL_SIZE_RECURSION);
1525 sv_size(aTHX_ st, NPathLink("thisstuff"), parser->thisstuff, TOTAL_SIZE_RECURSION);
1526 sv_size(aTHX_ st, NPathLink("thistoken"), parser->thistoken, TOTAL_SIZE_RECURSION);
1527 sv_size(aTHX_ st, NPathLink("thiswhite"), parser->thiswhite, TOTAL_SIZE_RECURSION);
1528#endif
1529 op_size_class(aTHX_ (OP*)parser->saved_curcop, OPc_COP, 0,
1530 st, NPathLink("saved_curcop"));
1531
1532 if (parser->old_parser)
1533 parser_size(aTHX_ st, NPathLink("old_parser"), parser->old_parser);
1534}
1535
df9491fe 1536static void
1537perl_size(pTHX_ struct state *const st, pPATH)
33f2f60c 1538{
df9491fe 1539 dNPathNodes(3, NPathArg);
05f432c0 1540
df9491fe 1541 /* if(!check_new(st, interp)) return; */
1542 NPathPushNode("perl", NPtype_NAME);
e162a822 1543#if defined(MULTIPLICITY)
1544 ADD_SIZE(st, "PerlInterpreter", sizeof(PerlInterpreter));
1545#endif
df9491fe 1546/*
1547 * perl
1548 * PL_defstash
1549 * others
1550 * unknown <== = O/S Heap size - perl - free_malloc_space
1551 */
1abba8e9 1552 /* start with PL_defstash to get everything reachable from \%main:: */
fc6614ee 1553 sv_size(aTHX_ st, NPathLink("PL_defstash"), (SV*)PL_defstash, TOTAL_SIZE_RECURSION);
e8f4c506 1554
1555 NPathPushNode("others", NPtype_NAME); /* group these (typically much smaller) items */
fc6614ee 1556 sv_size(aTHX_ st, NPathLink("PL_defgv"), (SV*)PL_defgv, TOTAL_SIZE_RECURSION);
1557 sv_size(aTHX_ st, NPathLink("PL_incgv"), (SV*)PL_incgv, TOTAL_SIZE_RECURSION);
1558 sv_size(aTHX_ st, NPathLink("PL_rs"), (SV*)PL_rs, TOTAL_SIZE_RECURSION);
1559 sv_size(aTHX_ st, NPathLink("PL_fdpid"), (SV*)PL_fdpid, TOTAL_SIZE_RECURSION);
1560 sv_size(aTHX_ st, NPathLink("PL_modglobal"), (SV*)PL_modglobal, TOTAL_SIZE_RECURSION);
1561 sv_size(aTHX_ st, NPathLink("PL_errors"), (SV*)PL_errors, TOTAL_SIZE_RECURSION);
1562 sv_size(aTHX_ st, NPathLink("PL_stashcache"), (SV*)PL_stashcache, TOTAL_SIZE_RECURSION);
1563 sv_size(aTHX_ st, NPathLink("PL_patchlevel"), (SV*)PL_patchlevel, TOTAL_SIZE_RECURSION);
1564 sv_size(aTHX_ st, NPathLink("PL_apiversion"), (SV*)PL_apiversion, TOTAL_SIZE_RECURSION);
1565 sv_size(aTHX_ st, NPathLink("PL_registered_mros"), (SV*)PL_registered_mros, TOTAL_SIZE_RECURSION);
33f2f60c 1566#ifdef USE_ITHREADS
fc6614ee 1567 sv_size(aTHX_ st, NPathLink("PL_regex_padav"), (SV*)PL_regex_padav, TOTAL_SIZE_RECURSION);
33f2f60c 1568#endif
8a087ef5 1569 sv_size(aTHX_ st, NPathLink("PL_warnhook"), (SV*)PL_warnhook, TOTAL_SIZE_RECURSION);
1570 sv_size(aTHX_ st, NPathLink("PL_diehook"), (SV*)PL_diehook, TOTAL_SIZE_RECURSION);
1571 sv_size(aTHX_ st, NPathLink("PL_endav"), (SV*)PL_endav, TOTAL_SIZE_RECURSION);
1572 sv_size(aTHX_ st, NPathLink("PL_main_cv"), (SV*)PL_main_cv, TOTAL_SIZE_RECURSION);
1573 sv_size(aTHX_ st, NPathLink("PL_main_root"), (SV*)PL_main_root, TOTAL_SIZE_RECURSION);
1574 sv_size(aTHX_ st, NPathLink("PL_main_start"), (SV*)PL_main_start, TOTAL_SIZE_RECURSION);
b7cb716a 1575 sv_size(aTHX_ st, NPathLink("PL_envgv"), (SV*)PL_envgv, TOTAL_SIZE_RECURSION);
1576 sv_size(aTHX_ st, NPathLink("PL_hintgv"), (SV*)PL_hintgv, TOTAL_SIZE_RECURSION);
1577 sv_size(aTHX_ st, NPathLink("PL_e_script"), (SV*)PL_e_script, TOTAL_SIZE_RECURSION);
1578 sv_size(aTHX_ st, NPathLink("PL_encoding"), (SV*)PL_encoding, TOTAL_SIZE_RECURSION);
1579 sv_size(aTHX_ st, NPathLink("PL_ofsgv"), (SV*)PL_ofsgv, TOTAL_SIZE_RECURSION);
1580 sv_size(aTHX_ st, NPathLink("PL_argvout_stack"), (SV*)PL_argvout_stack, TOTAL_SIZE_RECURSION);
1581 sv_size(aTHX_ st, NPathLink("PL_beginav"), (SV*)PL_beginav, TOTAL_SIZE_RECURSION);
1582 sv_size(aTHX_ st, NPathLink("PL_beginav_save"), (SV*)PL_beginav_save, TOTAL_SIZE_RECURSION);
1583 sv_size(aTHX_ st, NPathLink("PL_checkav_save"), (SV*)PL_checkav_save, TOTAL_SIZE_RECURSION);
1584 sv_size(aTHX_ st, NPathLink("PL_unitcheckav"), (SV*)PL_unitcheckav, TOTAL_SIZE_RECURSION);
1585 sv_size(aTHX_ st, NPathLink("PL_unitcheckav_save"), (SV*)PL_unitcheckav_save, TOTAL_SIZE_RECURSION);
1586 sv_size(aTHX_ st, NPathLink("PL_endav"), (SV*)PL_endav, TOTAL_SIZE_RECURSION);
1587 sv_size(aTHX_ st, NPathLink("PL_checkav"), (SV*)PL_checkav, TOTAL_SIZE_RECURSION);
1588 sv_size(aTHX_ st, NPathLink("PL_initav"), (SV*)PL_initav, TOTAL_SIZE_RECURSION);
1589 sv_size(aTHX_ st, NPathLink("PL_isarev"), (SV*)PL_isarev, TOTAL_SIZE_RECURSION);
1590 sv_size(aTHX_ st, NPathLink("PL_fdpid"), (SV*)PL_fdpid, TOTAL_SIZE_RECURSION);
d2f828cb 1591 sv_size(aTHX_ st, NPathLink("PL_preambleav"), (SV*)PL_preambleav, TOTAL_SIZE_RECURSION);
1592 sv_size(aTHX_ st, NPathLink("PL_ors_sv"), (SV*)PL_ors_sv, TOTAL_SIZE_RECURSION);
1593 sv_size(aTHX_ st, NPathLink("PL_modglobal"), (SV*)PL_modglobal, TOTAL_SIZE_RECURSION);
1594 sv_size(aTHX_ st, NPathLink("PL_custom_op_names"), (SV*)PL_custom_op_names, TOTAL_SIZE_RECURSION);
1595 sv_size(aTHX_ st, NPathLink("PL_custom_op_descs"), (SV*)PL_custom_op_descs, TOTAL_SIZE_RECURSION);
1596 sv_size(aTHX_ st, NPathLink("PL_custom_ops"), (SV*)PL_custom_ops, TOTAL_SIZE_RECURSION);
1597 sv_size(aTHX_ st, NPathLink("PL_compcv"), (SV*)PL_compcv, TOTAL_SIZE_RECURSION);
1598 sv_size(aTHX_ st, NPathLink("PL_DBcv"), (SV*)PL_DBcv, TOTAL_SIZE_RECURSION);
1599#ifdef PERL_USES_PL_PIDSTATUS
1600 sv_size(aTHX_ st, NPathLink("PL_pidstatus"), (SV*)PL_pidstatus, TOTAL_SIZE_RECURSION);
1601#endif
66a76d3b 1602 sv_size(aTHX_ st, NPathLink("PL_subname"), (SV*)PL_subname, TOTAL_SIZE_RECURSION);
1603#ifdef USE_LOCALE_NUMERIC
1604 sv_size(aTHX_ st, NPathLink("PL_numeric_radix_sv"), (SV*)PL_numeric_radix_sv, TOTAL_SIZE_RECURSION);
1605 check_new_and_strlen(st, PL_numeric_name, NPathLink("PL_numeric_name"));
1606#endif
1607#ifdef USE_LOCALE_COLLATE
1608 check_new_and_strlen(st, PL_collation_name, NPathLink("PL_collation_name"));
1609#endif
b7cb716a 1610 check_new_and_strlen(st, PL_origfilename, NPathLink("PL_origfilename"));
1611 check_new_and_strlen(st, PL_inplace, NPathLink("PL_inplace"));
d2f828cb 1612 check_new_and_strlen(st, PL_osname, NPathLink("PL_osname"));
1613 if (PL_op_mask && check_new(st, PL_op_mask))
1614 ADD_SIZE(st, "PL_op_mask", PL_maxo);
1615 if (PL_exitlistlen && check_new(st, PL_exitlist))
1616 ADD_SIZE(st, "PL_exitlist", (PL_exitlistlen * sizeof(PerlExitListEntry *))
1617 + (PL_exitlistlen * sizeof(PerlExitListEntry)));
322b968f 1618#ifdef PERL_IMPLICIT_CONTEXT
d2f828cb 1619 if (PL_my_cxt_size && check_new(st, PL_my_cxt_list)) {
1620 ADD_SIZE(st, "PL_my_cxt_list", (PL_my_cxt_size * sizeof(void *)));
1621#ifdef PERL_GLOBAL_STRUCT_PRIVATE
1622 ADD_SIZE(st, "PL_my_cxt_keys", (PL_my_cxt_size * sizeof(char *)));
1623#endif
1624 }
322b968f 1625#endif
33f2f60c 1626 /* TODO PL_stashpad */
e9c43be8 1627 op_size_class(aTHX_ (OP*)&PL_compiling, OPc_COP, 1, st, NPathLink("PL_compiling"));
1628 op_size_class(aTHX_ (OP*)PL_curcopdb, OPc_COP, 0, st, NPathLink("PL_curcopdb"));
33f2f60c 1629
66a76d3b 1630 parser_size(aTHX_ st, NPathLink("PL_parser"), PL_parser);
33f2f60c 1631 /* TODO stacks: cur, main, tmps, mark, scope, save */
8a087ef5 1632 /* TODO PL_exitlist */
1abba8e9 1633 /* TODO PL_reentrant_buffers etc */
8a087ef5 1634 /* TODO environ */
1635 /* TODO PerlIO? PL_known_layers PL_def_layerlist PL_perlio_fd_refcnt etc */
5e486cae 1636 /* TODO threads? */
33f2f60c 1637 /* TODO anything missed? */
1638
1abba8e9 1639 /* --- by this point we should have seen all reachable SVs --- */
1640
1641 /* in theory we shouldn't have any elements in PL_strtab that haven't been seen yet */
df9491fe 1642 sv_size(aTHX_ st, NPathLink("PL_strtab-unseen"), (SV*)PL_strtab, TOTAL_SIZE_RECURSION);
1abba8e9 1643
1644 /* unused space in sv head arenas */
1645 if (PL_sv_root) {
1646 SV *p = PL_sv_root;
1647 UV free_heads = 1;
df9491fe 1648# define SvARENA_CHAIN(sv) SvANY(sv) /* XXX breaks encapsulation*/
1abba8e9 1649 while ((p = MUTABLE_SV(SvARENA_CHAIN(p)))) {
1650 if (!check_new(st, p)) /* sanity check */
1651 warn("Free'd SV head unexpectedly already seen");
1652 ++free_heads;
1653 }
1654 NPathPushNode("unused_sv_heads", NPtype_NAME);
1655 ADD_SIZE(st, "sv", free_heads * sizeof(SV));
1656 NPathPopNode;
1657 }
1658 /* XXX iterate over bodies_by_type and crawl the free chains for each */
1659
1660 /* iterate over all SVs to find any we've not accounted for yet */
1661 /* once the code above is visiting all SVs, any found here have been leaked */
1662 unseen_sv_size(aTHX_ st, NPathLink("unaccounted"));
df9491fe 1663}
1664
1665
eda23e24 1666MODULE = Devel::SizeMe PACKAGE = Devel::SizeMe
df9491fe 1667
1668PROTOTYPES: DISABLE
1abba8e9 1669
df9491fe 1670UV
1671size(orig_thing)
1672 SV *orig_thing
1673ALIAS:
1674 total_size = TOTAL_SIZE_RECURSION
1675CODE:
1676{
1677 SV *thing = orig_thing;
1678 struct state *st = new_state(aTHX);
1679
1680 /* If they passed us a reference then dereference it. This is the
1681 only way we can check the sizes of arrays and hashes */
1682 if (SvROK(thing)) {
1683 thing = SvRV(thing);
1abba8e9 1684 }
1685
df9491fe 1686 sv_size(aTHX_ st, NULL, thing, ix);
1687 RETVAL = st->total_size;
60dacf5f 1688 free_state(aTHX_ st);
df9491fe 1689}
1690OUTPUT:
1691 RETVAL
1692
1693UV
1694perl_size()
1695CODE:
1696{
1697 /* just the current perl interpreter */
1698 struct state *st = new_state(aTHX);
1699 st->min_recurse_threshold = NO_RECURSION; /* so always recurse */
1700 perl_size(aTHX_ st, NULL);
1701 RETVAL = st->total_size;
60dacf5f 1702 free_state(aTHX_ st);
df9491fe 1703}
1704OUTPUT:
1705 RETVAL
1706
1707UV
1708heap_size()
1709CODE:
1710{
1711 /* the current perl interpreter plus malloc, in the context of total heap size */
6a9ab1d2 1712# ifdef _MALLOC_MALLOC_H_ /* OSX. Now sure where else mstats is available */
1713# define HAS_MSTATS
1714# endif
1715# ifdef HAS_MSTATS
1716 /* some systems have the SVID2/XPG mallinfo structure and function */
df9491fe 1717 struct mstats ms = mstats(); /* mstats() first */
6a9ab1d2 1718# endif
df9491fe 1719 struct state *st = new_state(aTHX);
1720 dNPathNodes(1, NULL);
1721 NPathPushNode("heap", NPtype_NAME);
1722
1723 st->min_recurse_threshold = NO_RECURSION; /* so always recurse */
1724
1725 perl_size(aTHX_ st, NPathLink("perl_interp"));
21920e7f 1726# ifdef HAS_MSTATS
df9491fe 1727 NPathSetNode("free_malloc_space", NPtype_NAME);
1728 ADD_SIZE(st, "bytes_free", ms.bytes_free);
1729 ADD_ATTR(st, NPattr_NOTE, "bytes_total", ms.bytes_total);
1730 ADD_ATTR(st, NPattr_NOTE, "bytes_used", ms.bytes_used);
1731 ADD_ATTR(st, NPattr_NOTE, "chunks_used", ms.chunks_used);
1732 ADD_ATTR(st, NPattr_NOTE, "chunks_free", ms.chunks_free);
df9491fe 1733 /* TODO get heap size from OS and add a node: unknown = heapsize - perl - ms.bytes_free */
1734 /* for now we use bytes_total as an approximation */
1735 NPathSetNode("unknown", NPtype_NAME);
1736 ADD_SIZE(st, "unknown", ms.bytes_total - st->total_size);
6a9ab1d2 1737# else
1738 /* XXX ? */
1739# endif
df9491fe 1740
33f2f60c 1741 RETVAL = st->total_size;
60dacf5f 1742 free_state(aTHX_ st);
33f2f60c 1743}
1744OUTPUT:
1745 RETVAL
Unnamed repository; edit this file 'description' to name the repository.