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