projects / p5sagit/Devel-Size.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | history | HEAD
Add refcounted_he structs counting
[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
766static void
c07e8ef8 767op_size(pTHX_ const OP * const baseop, struct state *st, pPATH)
1e5a8ad2 768{
ce5aa2b7 769 /* op_size recurses to follow the chain of opcodes. For the node path we
770 * don't want the chain to be 'nested' in the path so we use dNPathUseParent().
771 * Also, to avoid a link-to-a-link the caller should use NPathLinkAndNode()
772 * instead of NPathLink().
c07e8ef8 773 */
774 dNPathUseParent(NPathArg);
775
1e5a8ad2 776 TRY_TO_CATCH_SEGV {
777 TAG;
778 if(!check_new(st, baseop))
779 return;
780 TAG;
c07e8ef8 781 op_size(aTHX_ baseop->op_next, st, NPathOpLink);
1e5a8ad2 782 TAG;
783 switch (cc_opclass(baseop)) {
784 case OPc_BASEOP: TAG;
c07e8ef8 785 ADD_SIZE(st, "op", sizeof(struct op));
1e5a8ad2 786 TAG;break;
787 case OPc_UNOP: TAG;
c07e8ef8 788 ADD_SIZE(st, "unop", sizeof(struct unop));
789 op_size(aTHX_ ((UNOP *)baseop)->op_first, st, NPathOpLink);
1e5a8ad2 790 TAG;break;
791 case OPc_BINOP: TAG;
c07e8ef8 792 ADD_SIZE(st, "binop", sizeof(struct binop));
793 op_size(aTHX_ ((BINOP *)baseop)->op_first, st, NPathOpLink);
794 op_size(aTHX_ ((BINOP *)baseop)->op_last, st, NPathOpLink);
1e5a8ad2 795 TAG;break;
796 case OPc_LOGOP: TAG;
c07e8ef8 797 ADD_SIZE(st, "logop", sizeof(struct logop));
798 op_size(aTHX_ ((BINOP *)baseop)->op_first, st, NPathOpLink);
799 op_size(aTHX_ ((LOGOP *)baseop)->op_other, st, NPathOpLink);
1e5a8ad2 800 TAG;break;
177ebd37 801#ifdef OA_CONDOP
802 case OPc_CONDOP: TAG;
c07e8ef8 803 ADD_SIZE(st, "condop", sizeof(struct condop));
804 op_size(aTHX_ ((BINOP *)baseop)->op_first, st, NPathOpLink);
805 op_size(aTHX_ ((CONDOP *)baseop)->op_true, st, NPathOpLink);
806 op_size(aTHX_ ((CONDOP *)baseop)->op_false, st, NPathOpLink);
177ebd37 807 TAG;break;
808#endif
1e5a8ad2 809 case OPc_LISTOP: TAG;
c07e8ef8 810 ADD_SIZE(st, "listop", sizeof(struct listop));
811 op_size(aTHX_ ((LISTOP *)baseop)->op_first, st, NPathOpLink);
812 op_size(aTHX_ ((LISTOP *)baseop)->op_last, st, NPathOpLink);
1e5a8ad2 813 TAG;break;
814 case OPc_PMOP: TAG;
c07e8ef8 815 ADD_SIZE(st, "pmop", sizeof(struct pmop));
816 op_size(aTHX_ ((PMOP *)baseop)->op_first, st, NPathOpLink);
817 op_size(aTHX_ ((PMOP *)baseop)->op_last, st, NPathOpLink);
5a83b7cf 818#if PERL_VERSION < 9 || (PERL_VERSION == 9 && PERL_SUBVERSION < 5)
c07e8ef8 819 op_size(aTHX_ ((PMOP *)baseop)->op_pmreplroot, st, NPathOpLink);
820 op_size(aTHX_ ((PMOP *)baseop)->op_pmreplstart, st, NPathOpLink);
5a83b7cf 821#endif
c1bfd7da 822 /* This is defined away in perl 5.8.x, but it is in there for
823 5.6.x */
98ecbbc6 824#ifdef PM_GETRE
60dacf5f 825 regex_size(aTHX_ PM_GETRE((PMOP *)baseop), st, NPathLink("PM_GETRE"));
98ecbbc6 826#else
60dacf5f 827 regex_size(aTHX_ ((PMOP *)baseop)->op_pmregexp, st, NPathLink("op_pmregexp"));
98ecbbc6 828#endif
c1bfd7da 829 TAG;break;
81f1c018 830 case OPc_SVOP: TAG;
c07e8ef8 831 ADD_SIZE(st, "svop", sizeof(struct svop));
574d9fd9 832 if (!(baseop->op_type == OP_AELEMFAST
833 && baseop->op_flags & OPf_SPECIAL)) {
834 /* not an OP_PADAV replacement */
fc6614ee 835 sv_size(aTHX_ st, NPathLink("SVOP"), ((SVOP *)baseop)->op_sv, SOME_RECURSION);
574d9fd9 836 }
81f1c018 837 TAG;break;
177ebd37 838#ifdef OA_PADOP
9fc9ab86 839 case OPc_PADOP: TAG;
c07e8ef8 840 ADD_SIZE(st, "padop", sizeof(struct padop));
99684fd4 841 TAG;break;
177ebd37 842#endif
843#ifdef OA_GVOP
844 case OPc_GVOP: TAG;
c07e8ef8 845 ADD_SIZE(st, "gvop", sizeof(struct gvop));
fc6614ee 846 sv_size(aTHX_ st, NPathLink("GVOP"), ((GVOP *)baseop)->op_gv, SOME_RECURSION);
177ebd37 847 TAG;break;
848#endif
99684fd4 849 case OPc_PVOP: TAG;
fc6614ee 850 check_new_and_strlen(st, ((PVOP *)baseop)->op_pv, NPathLink("op_pv"));
219b7d34 851 TAG;break;
1e5a8ad2 852 case OPc_LOOP: TAG;
c07e8ef8 853 ADD_SIZE(st, "loop", sizeof(struct loop));
854 op_size(aTHX_ ((LOOP *)baseop)->op_first, st, NPathOpLink);
855 op_size(aTHX_ ((LOOP *)baseop)->op_last, st, NPathOpLink);
856 op_size(aTHX_ ((LOOP *)baseop)->op_redoop, st, NPathOpLink);
857 op_size(aTHX_ ((LOOP *)baseop)->op_nextop, st, NPathOpLink);
858 op_size(aTHX_ ((LOOP *)baseop)->op_lastop, st, NPathOpLink);
1e5a8ad2 859 TAG;break;
860 case OPc_COP: TAG;
9fc9ab86 861 {
862 COP *basecop;
863 basecop = (COP *)baseop;
c07e8ef8 864 ADD_SIZE(st, "cop", sizeof(struct cop));
9fc9ab86 865
866 /* Change 33656 by nicholas@mouse-mill on 2008/04/07 11:29:51
867 Eliminate cop_label from struct cop by storing a label as the first
868 entry in the hints hash. Most statements don't have labels, so this
869 will save memory. Not sure how much.
870 The check below will be incorrect fail on bleadperls
871 before 5.11 @33656, but later than 5.10, producing slightly too
872 small memory sizes on these Perls. */
b7621729 873#if (PERL_VERSION < 11)
fc6614ee 874 check_new_and_strlen(st, basecop->cop_label, NPathLink("cop_label"));
b7621729 875#endif
7ccc7d88 876#ifdef USE_ITHREADS
fc6614ee 877 check_new_and_strlen(st, basecop->cop_file, NPathLink("cop_file"));
878 check_new_and_strlen(st, basecop->cop_stashpv, NPathLink("cop_stashpv"));
7ccc7d88 879#else
49beddc6 880 if (SvREFCNT(basecop->cop_stash) == 1) /* XXX hack? */
881 sv_size(aTHX_ st, NPathLink("cop_stash"), (SV *)basecop->cop_stash, SOME_RECURSION);
fc6614ee 882 sv_size(aTHX_ st, NPathLink("cop_filegv"), (SV *)basecop->cop_filegv, SOME_RECURSION);
7ccc7d88 883#endif
884
9fc9ab86 885 }
886 TAG;break;
887 default:
888 TAG;break;
889 }
890 }
1a36ac09 891 CAUGHT_EXCEPTION {
a4efdff3 892 if (st->dangle_whine)
9fc9ab86 893 warn( "Devel::Size: Encountered dangling pointer in opcode at: %p\n", baseop );
7ccc7d88 894 }
7ccc7d88 895}
6a9ad7ec 896
b6558d1d 897#if PERL_VERSION < 8 || PERL_SUBVERSION < 9
898# define SVt_LAST 16
24d37977 899#endif
900
f73dcfce 901#ifdef PURIFY
902# define MAYBE_PURIFY(normal, pure) (pure)
903# define MAYBE_OFFSET(struct_name, member) 0
904#else
905# define MAYBE_PURIFY(normal, pure) (normal)
906# define MAYBE_OFFSET(struct_name, member) STRUCT_OFFSET(struct_name, member)
907#endif
908
b6558d1d 909const U8 body_sizes[SVt_LAST] = {
910#if PERL_VERSION < 9
f73dcfce 911 0, /* SVt_NULL */
912 MAYBE_PURIFY(sizeof(IV), sizeof(XPVIV)), /* SVt_IV */
913 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
914 sizeof(XRV), /* SVt_RV */
915 sizeof(XPV), /* SVt_PV */
916 sizeof(XPVIV), /* SVt_PVIV */
917 sizeof(XPVNV), /* SVt_PVNV */
918 sizeof(XPVMG), /* SVt_PVMG */
919 sizeof(XPVBM), /* SVt_PVBM */
920 sizeof(XPVLV), /* SVt_PVLV */
921 sizeof(XPVAV), /* SVt_PVAV */
922 sizeof(XPVHV), /* SVt_PVHV */
923 sizeof(XPVCV), /* SVt_PVCV */
924 sizeof(XPVGV), /* SVt_PVGV */
925 sizeof(XPVFM), /* SVt_PVFM */
926 sizeof(XPVIO) /* SVt_PVIO */
b6558d1d 927#elif PERL_VERSION == 10 && PERL_SUBVERSION == 0
f73dcfce 928 0, /* SVt_NULL */
929 0, /* SVt_BIND */
930 0, /* SVt_IV */
931 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
932 0, /* SVt_RV */
933 MAYBE_PURIFY(sizeof(xpv_allocated), sizeof(XPV)), /* SVt_PV */
934 MAYBE_PURIFY(sizeof(xpviv_allocated), sizeof(XPVIV)),/* SVt_PVIV */
935 sizeof(XPVNV), /* SVt_PVNV */
936 sizeof(XPVMG), /* SVt_PVMG */
937 sizeof(XPVGV), /* SVt_PVGV */
938 sizeof(XPVLV), /* SVt_PVLV */
939 MAYBE_PURIFY(sizeof(xpvav_allocated), sizeof(XPVAV)),/* SVt_PVAV */
940 MAYBE_PURIFY(sizeof(xpvhv_allocated), sizeof(XPVHV)),/* SVt_PVHV */
941 MAYBE_PURIFY(sizeof(xpvcv_allocated), sizeof(XPVCV)),/* SVt_PVCV */
942 MAYBE_PURIFY(sizeof(xpvfm_allocated), sizeof(XPVFM)),/* SVt_PVFM */
943 sizeof(XPVIO), /* SVt_PVIO */
b6558d1d 944#elif PERL_VERSION == 10 && PERL_SUBVERSION == 1
f73dcfce 945 0, /* SVt_NULL */
946 0, /* SVt_BIND */
947 0, /* SVt_IV */
948 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
949 0, /* SVt_RV */
950 sizeof(XPV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PV */
951 sizeof(XPVIV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PVIV */
952 sizeof(XPVNV), /* SVt_PVNV */
953 sizeof(XPVMG), /* SVt_PVMG */
954 sizeof(XPVGV), /* SVt_PVGV */
955 sizeof(XPVLV), /* SVt_PVLV */
956 sizeof(XPVAV) - MAYBE_OFFSET(XPVAV, xav_fill), /* SVt_PVAV */
957 sizeof(XPVHV) - MAYBE_OFFSET(XPVHV, xhv_fill), /* SVt_PVHV */
958 sizeof(XPVCV) - MAYBE_OFFSET(XPVCV, xpv_cur), /* SVt_PVCV */
959 sizeof(XPVFM) - MAYBE_OFFSET(XPVFM, xpv_cur), /* SVt_PVFM */
960 sizeof(XPVIO) /* SVt_PVIO */
b6558d1d 961#elif PERL_VERSION < 13
f73dcfce 962 0, /* SVt_NULL */
963 0, /* SVt_BIND */
964 0, /* SVt_IV */
965 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
966 sizeof(XPV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PV */
967 sizeof(XPVIV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PVIV */
968 sizeof(XPVNV), /* SVt_PVNV */
969 sizeof(XPVMG), /* SVt_PVMG */
970 sizeof(regexp) - MAYBE_OFFSET(regexp, xpv_cur), /* SVt_REGEXP */
971 sizeof(XPVGV), /* SVt_PVGV */
972 sizeof(XPVLV), /* SVt_PVLV */
973 sizeof(XPVAV) - MAYBE_OFFSET(XPVAV, xav_fill), /* SVt_PVAV */
974 sizeof(XPVHV) - MAYBE_OFFSET(XPVHV, xhv_fill), /* SVt_PVHV */
975 sizeof(XPVCV) - MAYBE_OFFSET(XPVCV, xpv_cur), /* SVt_PVCV */
976 sizeof(XPVFM) - MAYBE_OFFSET(XPVFM, xpv_cur), /* SVt_PVFM */
977 sizeof(XPVIO) /* SVt_PVIO */
b6558d1d 978#else
f73dcfce 979 0, /* SVt_NULL */
980 0, /* SVt_BIND */
981 0, /* SVt_IV */
982 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
983 sizeof(XPV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PV */
984 sizeof(XPVIV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PVIV */
985 sizeof(XPVNV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PVNV */
986 sizeof(XPVMG), /* SVt_PVMG */
987 sizeof(regexp), /* SVt_REGEXP */
988 sizeof(XPVGV), /* SVt_PVGV */
989 sizeof(XPVLV), /* SVt_PVLV */
990 sizeof(XPVAV), /* SVt_PVAV */
991 sizeof(XPVHV), /* SVt_PVHV */
992 sizeof(XPVCV), /* SVt_PVCV */
993 sizeof(XPVFM), /* SVt_PVFM */
994 sizeof(XPVIO) /* SVt_PVIO */
b6558d1d 995#endif
996};
997
c07e8ef8 998
8a087ef5 999/* based on Perl_do_dump_pad() - wraps sv_size and adds ADD_ATTR calls for the pad names */
c07e8ef8 1000static void
1001padlist_size(pTHX_ struct state *const st, pPATH, PADLIST *padlist,
1002 const int recurse)
1003{
1004 dNPathUseParent(NPathArg);
c07e8ef8 1005 const AV *pad_name;
1006 SV **pname;
1007 I32 ix;
1008
d2181def 1009 if (!padlist)
1010 return;
1011 if( 0 && !check_new(st, padlist))
c07e8ef8 1012 return;
1869f459 1013
c07e8ef8 1014 pad_name = MUTABLE_AV(*av_fetch(MUTABLE_AV(padlist), 0, FALSE));
1015 pname = AvARRAY(pad_name);
1016
1017 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
1018 const SV *namesv = pname[ix];
1019 if (namesv && namesv == &PL_sv_undef) {
1020 namesv = NULL;
1021 }
1022 if (namesv) {
d2181def 1023 /* SvFAKE: On a pad name SV, that slot in the frame AV is a REFCNT'ed reference to a lexical from "outside" */
c07e8ef8 1024 if (SvFAKE(namesv))
e8f4c506 1025 ADD_ATTR(st, NPattr_PADFAKE, SvPVX_const(namesv), ix);
c07e8ef8 1026 else
e8f4c506 1027 ADD_ATTR(st, NPattr_PADNAME, SvPVX_const(namesv), ix);
c07e8ef8 1028 }
1029 else {
e8f4c506 1030 ADD_ATTR(st, NPattr_PADTMP, "SVs_PADTMP", ix);
c07e8ef8 1031 }
1032
1033 }
1034 sv_size(aTHX_ st, NPathArg, (SV*)padlist, recurse);
1035}
1036
1037
a5c6bdd7 1038static void
c07e8ef8 1039sv_size(pTHX_ struct state *const st, pPATH, const SV * const orig_thing,
f3cf7e20 1040 const int recurse) {
9fc9ab86 1041 const SV *thing = orig_thing;
c07e8ef8 1042 dNPathNodes(3, NPathArg);
b6558d1d 1043 U32 type;
eee00145 1044
c07e8ef8 1045 if(!check_new(st, orig_thing))
a5c6bdd7 1046 return;
81f1c018 1047
b6558d1d 1048 type = SvTYPE(thing);
1049 if (type > SVt_LAST) {
1050 warn("Devel::Size: Unknown variable type: %d encountered\n", type);
a5c6bdd7 1051 return;
b6558d1d 1052 }
012b5f33 1053 NPathPushNode(thing, NPtype_SV);
df9491fe 1054 ADD_SIZE(st, "sv_head", sizeof(SV));
1055 ADD_SIZE(st, "sv_body", body_sizes[type]);
b1e5ad85 1056
b6558d1d 1057 switch (type) {
1058#if (PERL_VERSION < 11)
e98cedbf 1059 /* Is it a reference? */
9fc9ab86 1060 case SVt_RV: TAG;
b6558d1d 1061#else
1062 case SVt_IV: TAG;
24d37977 1063#endif
d2181def 1064 if(recurse && SvROK(thing)) /* XXX maybe don't follow weakrefs */
1065 sv_size(aTHX_ st, (SvWEAKREF(thing) ? NPathLink("weakRV") : NPathLink("RV")), SvRV_const(thing), recurse);
9fc9ab86 1066 TAG;break;
267703fd 1067
9fc9ab86 1068 case SVt_PVAV: TAG;
e98cedbf 1069 /* Is there anything in the array? */
1070 if (AvMAX(thing) != -1) {
c8db37d3 1071 /* an array with 10 slots has AvMax() set to 9 - te 2007-04-22 */
c07e8ef8 1072 ADD_SIZE(st, "av_max", sizeof(SV *) * (AvMAX(thing) + 1));
eee00145 1073 dbg_printf(("total_size: %li AvMAX: %li av_len: $i\n", st->total_size, AvMAX(thing), av_len((AV*)thing)));
6c5ddc0d 1074
05f432c0 1075 if (recurse >= st->min_recurse_threshold) {
6c5ddc0d 1076 SSize_t i = AvFILLp(thing) + 1;
1077
93a78808 1078 while (i--) {
1079 ADD_PRE_ATTR(st, 0, "index", i);
fc6614ee 1080 sv_size(aTHX_ st, NPathLink("AVelem"), AvARRAY(thing)[i], recurse);
93a78808 1081 }
6c5ddc0d 1082 }
e98cedbf 1083 }
1084 /* Add in the bits on the other side of the beginning */
0430b7f7 1085
b7621729 1086 dbg_printf(("total_size %li, sizeof(SV *) %li, AvARRAY(thing) %li, AvALLOC(thing)%li , sizeof(ptr) %li \n",
c07e8ef8 1087 st->total_size, sizeof(SV*), AvARRAY(thing), AvALLOC(thing), sizeof( thing )));
0430b7f7 1088
1089 /* under Perl 5.8.8 64bit threading, AvARRAY(thing) was a pointer while AvALLOC was 0,
b1e5ad85 1090 resulting in grossly overstated sized for arrays. Technically, this shouldn't happen... */
0430b7f7 1091 if (AvALLOC(thing) != 0) {
c07e8ef8 1092 ADD_SIZE(st, "AvALLOC", (sizeof(SV *) * (AvARRAY(thing) - AvALLOC(thing))));
0430b7f7 1093 }
795fc84c 1094#if (PERL_VERSION < 9)
1095 /* Is there something hanging off the arylen element?
1096 Post 5.9.something this is stored in magic, so will be found there,
1097 and Perl_av_arylen_p() takes a non-const AV*, hence compilers rightly
1098 complain about AvARYLEN() passing thing to it. */
fc6614ee 1099 sv_size(aTHX_ st, NPathLink("ARYLEN"), AvARYLEN(thing), recurse);
795fc84c 1100#endif
9fc9ab86 1101 TAG;break;
49beddc6 1102
9fc9ab86 1103 case SVt_PVHV: TAG;
a6ea0805 1104 /* Now the array of buckets */
c07e8ef8 1105 ADD_SIZE(st, "hv_max", (sizeof(HE *) * (HvMAX(thing) + 1)));
1106 if (HvENAME(thing)) {
e8f4c506 1107 ADD_ATTR(st, NPattr_NAME, HvENAME(thing), 0);
c07e8ef8 1108 }
a6ea0805 1109 /* Now walk the bucket chain */
6a9ad7ec 1110 if (HvARRAY(thing)) {
a6ea0805 1111 HE *cur_entry;
9fc9ab86 1112 UV cur_bucket = 0;
a6ea0805 1113 for (cur_bucket = 0; cur_bucket <= HvMAX(thing); cur_bucket++) {
9fc9ab86 1114 cur_entry = *(HvARRAY(thing) + cur_bucket);
1115 while (cur_entry) {
b6ec3c3a 1116/* XXX a HE should probably be a node so the keys and values are seen as pairs */
c07e8ef8 1117 ADD_SIZE(st, "he", sizeof(HE));
fc6614ee 1118 hek_size(aTHX_ st, cur_entry->hent_hek, HvSHAREKEYS(thing), NPathLink("hent_hek"));
05f432c0 1119 if (recurse >= st->min_recurse_threshold) {
d3b8a135 1120 if (orig_thing == (SV*)PL_strtab) {
df9491fe 1121 /* For PL_strtab the HeVAL is used as a refcnt */
1122 ADD_SIZE(st, "shared_hek", HeKLEN(cur_entry));
1123 }
1124 else {
2c631ee0 1125/* I've seen a PL_strtab HeVAL == 0xC and 0x40C etc
5e486cae 1126 * just running perl -Mblib -Mstrict -MDevel::Size=:all -MCarp -e 'warn perl_size()'
1127 * but it seemed like a corruption - it would change come and go with irrelevant code changes.
1128 * so we protect against that here, but I'd like to know the cause.
1129 */
2c631ee0 1130if (PTR2UV(HeVAL(cur_entry)) > 0xFFF)
fc6614ee 1131 sv_size(aTHX_ st, NPathLink("HeVAL"), HeVAL(cur_entry), recurse);
b6ec3c3a 1132else warn("skipped suspect HeVAL %p", HeVAL(cur_entry));
df9491fe 1133 }
5e486cae 1134 }
9fc9ab86 1135 cur_entry = cur_entry->hent_next;
1136 }
a6ea0805 1137 }
1138 }
78037efb 1139#ifdef HvAUX
1140 if (SvOOK(thing)) {
1141 /* This direct access is arguably "naughty": */
1142 struct mro_meta *meta = HvAUX(thing)->xhv_mro_meta;
b3a37f1a 1143#if PERL_VERSION > 13 || PERL_SUBVERSION > 8
1144 /* As is this: */
1145 I32 count = HvAUX(thing)->xhv_name_count;
1146
1147 if (count) {
1148 HEK **names = HvAUX(thing)->xhv_name_u.xhvnameu_names;
1149 if (count < 0)
1150 count = -count;
1151 while (--count)
fc6614ee 1152 hek_size(aTHX_ st, names[count], 1, NPathLink("HvAUXelem"));
b3a37f1a 1153 }
1154 else
1155#endif
1156 {
fc6614ee 1157 hek_size(aTHX_ st, HvNAME_HEK(thing), 1, NPathLink("HvNAME_HEK"));
b3a37f1a 1158 }
1159
c07e8ef8 1160 ADD_SIZE(st, "xpvhv_aux", sizeof(struct xpvhv_aux));
78037efb 1161 if (meta) {
c07e8ef8 1162 ADD_SIZE(st, "mro_meta", sizeof(struct mro_meta));
fc6614ee 1163 sv_size(aTHX_ st, NPathLink("mro_nextmethod"), (SV *)meta->mro_nextmethod, TOTAL_SIZE_RECURSION);
78037efb 1164#if PERL_VERSION > 10 || (PERL_VERSION == 10 && PERL_SUBVERSION > 0)
fc6614ee 1165 sv_size(aTHX_ st, NPathLink("isa"), (SV *)meta->isa, TOTAL_SIZE_RECURSION);
78037efb 1166#endif
1167#if PERL_VERSION > 10
fc6614ee 1168 sv_size(aTHX_ st, NPathLink("mro_linear_all"), (SV *)meta->mro_linear_all, TOTAL_SIZE_RECURSION);
1169 sv_size(aTHX_ st, NPathLink("mro_linear_current"), meta->mro_linear_current, TOTAL_SIZE_RECURSION);
78037efb 1170#else
fc6614ee 1171 sv_size(aTHX_ st, NPathLink("mro_linear_dfs"), (SV *)meta->mro_linear_dfs, TOTAL_SIZE_RECURSION);
1172 sv_size(aTHX_ st, NPathLink("mro_linear_c3"), (SV *)meta->mro_linear_c3, TOTAL_SIZE_RECURSION);
78037efb 1173#endif
1174 }
1175 }
1176#else
fc6614ee 1177 check_new_and_strlen(st, HvNAME_get(thing), NPathLink("HvNAME"));
78037efb 1178#endif
9fc9ab86 1179 TAG;break;
267703fd 1180
1181
1182 case SVt_PVFM: TAG;
eb73dc89 1183 padlist_size(aTHX_ st, NPathLink("CvPADLIST"), CvPADLIST(thing), recurse);
36a03132 1184 sv_size(aTHX_ st, NPathLink("CvOUTSIDE"), (SV *)CvOUTSIDE(thing), SOME_RECURSION);
267703fd 1185
1186 if (st->go_yell && !st->fm_whine) {
1187 carp("Devel::Size: Calculated sizes for FMs are incomplete");
1188 st->fm_whine = 1;
1189 }
1190 goto freescalar;
1191
9fc9ab86 1192 case SVt_PVCV: TAG;
336fdadd 1193 /* not CvSTASH, per https://rt.cpan.org/Ticket/Display.html?id=79366 */
93a78808 1194 ADD_ATTR(st, NPattr_NAME, CvGV(thing) ? GvNAME(CvGV(thing)) : "UNDEFINED", 0);
fc6614ee 1195 sv_size(aTHX_ st, NPathLink("CvGV"), (SV *)CvGV(thing), SOME_RECURSION);
eb73dc89 1196 padlist_size(aTHX_ st, NPathLink("CvPADLIST"), CvPADLIST(thing), recurse);
36a03132 1197 sv_size(aTHX_ st, NPathLink("CvOUTSIDE"), (SV *)CvOUTSIDE(thing), SOME_RECURSION);
66f50dda 1198 if (CvISXSUB(thing)) {
fc6614ee 1199 sv_size(aTHX_ st, NPathLink("cv_const_sv"), cv_const_sv((CV *)thing), recurse);
66f50dda 1200 } else {
ce5aa2b7 1201 if(1)op_size(aTHX_ CvSTART(thing), st, NPathLinkAndNode("CvSTART", "OPs")); /* XXX ? */
1202 op_size(aTHX_ CvROOT(thing), st, NPathLinkAndNode("CvROOT", "OPs"));
7ccc7d88 1203 }
267703fd 1204 goto freescalar;
1205
1206 case SVt_PVIO: TAG;
267703fd 1207 /* Some embedded char pointers */
fc6614ee 1208 check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_top_name, NPathLink("xio_top_name"));
1209 check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_fmt_name, NPathLink("xio_fmt_name"));
1210 check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_bottom_name, NPathLink("xio_bottom_name"));
267703fd 1211 /* Throw the GVs on the list to be walked if they're not-null */
fc6614ee 1212 sv_size(aTHX_ st, NPathLink("xio_top_gv"), (SV *)((XPVIO *) SvANY(thing))->xio_top_gv, recurse);
1213 sv_size(aTHX_ st, NPathLink("xio_bottom_gv"), (SV *)((XPVIO *) SvANY(thing))->xio_bottom_gv, recurse);
1214 sv_size(aTHX_ st, NPathLink("xio_fmt_gv"), (SV *)((XPVIO *) SvANY(thing))->xio_fmt_gv, recurse);
267703fd 1215
1216 /* Only go trotting through the IO structures if they're really
1217 trottable. If USE_PERLIO is defined we can do this. If
1218 not... we can't, so we don't even try */
1219#ifdef USE_PERLIO
1220 /* Dig into xio_ifp and xio_ofp here */
1221 warn("Devel::Size: Can't size up perlio layers yet\n");
1222#endif
1223 goto freescalar;
1224
267703fd 1225 case SVt_PVLV: TAG;
267703fd 1226#if (PERL_VERSION < 9)
1227 goto freescalar;
267703fd 1228#endif
7ccc7d88 1229
9fc9ab86 1230 case SVt_PVGV: TAG;
4a3d023d 1231 if(isGV_with_GP(thing)) {
638a265a 1232#ifdef GvNAME_HEK
fc6614ee 1233 hek_size(aTHX_ st, GvNAME_HEK(thing), 1, NPathLink("GvNAME_HEK"));
638a265a 1234#else
c07e8ef8 1235 ADD_SIZE(st, "GvNAMELEN", GvNAMELEN(thing));
638a265a 1236#endif
e8f4c506 1237 ADD_ATTR(st, NPattr_NAME, GvNAME_get(thing), 0);
15588e9c 1238#ifdef GvFILE_HEK
fc6614ee 1239 hek_size(aTHX_ st, GvFILE_HEK(thing), 1, NPathLink("GvFILE_HEK"));
15588e9c 1240#elif defined(GvFILE)
2b217e71 1241# if !defined(USE_ITHREADS) || (PERL_VERSION > 8 || (PERL_VERSION == 8 && PERL_SUBVERSION > 8))
1242 /* With itreads, before 5.8.9, this can end up pointing to freed memory
1243 if the GV was created in an eval, as GvFILE() points to CopFILE(),
1244 and the relevant COP has been freed on scope cleanup after the eval.
1245 5.8.9 adds a binary compatible fudge that catches the vast majority
1246 of cases. 5.9.something added a proper fix, by converting the GP to
1247 use a shared hash key (porperly reference counted), instead of a
1248 char * (owned by who knows? possibly no-one now) */
fc6614ee 1249 check_new_and_strlen(st, GvFILE(thing), NPathLink("GvFILE"));
2b217e71 1250# endif
78dfb4e7 1251#endif
4a3d023d 1252 /* Is there something hanging off the glob? */
1253 if (check_new(st, GvGP(thing))) {
c07e8ef8 1254 ADD_SIZE(st, "GP", sizeof(GP));
fc6614ee 1255 sv_size(aTHX_ st, NPathLink("gp_sv"), (SV *)(GvGP(thing)->gp_sv), recurse);
fc6614ee 1256 sv_size(aTHX_ st, NPathLink("gp_av"), (SV *)(GvGP(thing)->gp_av), recurse);
1257 sv_size(aTHX_ st, NPathLink("gp_hv"), (SV *)(GvGP(thing)->gp_hv), recurse);
fc6614ee 1258 sv_size(aTHX_ st, NPathLink("gp_cv"), (SV *)(GvGP(thing)->gp_cv), recurse);
49beddc6 1259 sv_size(aTHX_ st, NPathLink("gp_egv"), (SV *)(GvGP(thing)->gp_egv), recurse);
1260 sv_size(aTHX_ st, NPathLink("gp_form"), (SV *)(GvGP(thing)->gp_form), recurse);
4a3d023d 1261 }
267703fd 1262#if (PERL_VERSION >= 9)
1263 TAG; break;
1264#endif
5c2e1b12 1265 }
b6558d1d 1266#if PERL_VERSION <= 8
1267 case SVt_PVBM: TAG;
1268#endif
267703fd 1269 case SVt_PVMG: TAG;
267703fd 1270 case SVt_PVNV: TAG;
267703fd 1271 case SVt_PVIV: TAG;
267703fd 1272 case SVt_PV: TAG;
267703fd 1273 freescalar:
1274 if(recurse && SvROK(thing))
fc6614ee 1275 sv_size(aTHX_ st, NPathLink("RV"), SvRV_const(thing), recurse);
924d9c4e 1276 else if (SvIsCOW_shared_hash(thing))
fc6614ee 1277 hek_size(aTHX_ st, SvSHARED_HEK_FROM_PV(SvPVX(thing)), 1, NPathLink("SvSHARED_HEK_FROM_PV"));
267703fd 1278 else
c07e8ef8 1279 ADD_SIZE(st, "SvLEN", SvLEN(thing));
267703fd 1280
1281 if(SvOOK(thing)) {
95dc1714 1282 STRLEN len;
1283 SvOOK_offset(thing, len);
c07e8ef8 1284 ADD_SIZE(st, "SvOOK", len);
ebb2c5b9 1285 }
9fc9ab86 1286 TAG;break;
5073b933 1287
e98cedbf 1288 }
49beddc6 1289
1290 if (type >= SVt_PVMG) {
7b782333 1291 if (SvMAGICAL(thing))
49beddc6 1292 magic_size(aTHX_ thing, st, NPathLink("MG"));
c922539f 1293 if (SvPAD_OUR(thing) && SvOURSTASH(thing))
1294 sv_size(aTHX_ st, NPathLink("SvOURSTASH"), (SV *)SvOURSTASH(thing), SOME_RECURSION);
7c8a009a 1295 if (SvSTASH(thing))
1296 sv_size(aTHX_ st, NPathLink("SvSTASH"), (SV *)SvSTASH(thing), SOME_RECURSION);
49beddc6 1297 }
1298
a5c6bdd7 1299 return;
e98cedbf 1300}
1301
1abba8e9 1302static void
1303free_memnode_state(pTHX_ struct state *st)
1304{
d3b8a135 1305 if (st->node_stream_fh && st->node_stream_name && *st->node_stream_name) {
1abba8e9 1306 if (*st->node_stream_name == '|') {
1307 if (pclose(st->node_stream_fh))
1308 warn("%s exited with an error status\n", st->node_stream_name);
1309 }
1310 else {
1311 if (fclose(st->node_stream_fh))
1312 warn("Error closing %s: %s\n", st->node_stream_name, strerror(errno));
1313 }
1314 }
1315}
1316
a4efdff3 1317static struct state *
1318new_state(pTHX)
65db36c0 1319{
1320 SV *warn_flag;
a4efdff3 1321 struct state *st;
d9b022a1 1322
a4efdff3 1323 Newxz(st, 1, struct state);
1324 st->go_yell = TRUE;
05f432c0 1325 st->min_recurse_threshold = TOTAL_SIZE_RECURSION;
65db36c0 1326 if (NULL != (warn_flag = perl_get_sv("Devel::Size::warn", FALSE))) {
a4efdff3 1327 st->dangle_whine = st->go_yell = SvIV(warn_flag) ? TRUE : FALSE;
65db36c0 1328 }
1329 if (NULL != (warn_flag = perl_get_sv("Devel::Size::dangle", FALSE))) {
a4efdff3 1330 st->dangle_whine = SvIV(warn_flag) ? TRUE : FALSE;
65db36c0 1331 }
a52ceccd 1332 check_new(st, &PL_sv_undef);
1333 check_new(st, &PL_sv_no);
1334 check_new(st, &PL_sv_yes);
6389ea67 1335#if PERL_VERSION > 8 || (PERL_VERSION == 8 && PERL_SUBVERSION > 0)
1336 check_new(st, &PL_sv_placeholder);
1337#endif
d3b8a135 1338
33f2f60c 1339#ifdef PATH_TRACKING
d3b8a135 1340 /* XXX quick hack */
1341 st->node_stream_name = getenv("PERL_DMEM");
1342 if (st->node_stream_name) {
1343 if (*st->node_stream_name) {
1344 if (*st->node_stream_name == '|')
1345 st->node_stream_fh = popen(st->node_stream_name+1, "w");
1346 else
1347 st->node_stream_fh = fopen(st->node_stream_name, "wb");
1348 if (!st->node_stream_fh)
1349 croak("Can't open '%s' for writing: %s", st->node_stream_name, strerror(errno));
1350 setlinebuf(st->node_stream_fh); /* XXX temporary for debugging */
1351 st->add_attr_cb = np_stream_node_path_info;
1352 }
1353 else
1354 st->add_attr_cb = np_dump_node_path_info;
1abba8e9 1355 }
1abba8e9 1356 st->free_state_cb = free_memnode_state;
33f2f60c 1357#endif
d3b8a135 1358
a4efdff3 1359 return st;
65db36c0 1360}
1361
1abba8e9 1362/* XXX based on S_visit() in sv.c */
1363static void
1364unseen_sv_size(pTHX_ struct state *st, pPATH)
1365{
1366 dVAR;
1367 SV* sva;
1368 I32 visited = 0;
1369 dNPathNodes(1, NPathArg);
1370
1371 NPathPushNode("unseen", NPtype_NAME);
1372
1373 /* by this point we should have visited all the SVs
1374 * so now we'll run through all the SVs via the arenas
1375 * in order to find any thet we've missed for some reason.
1376 * Once the rest of the code is finding all the SVs then any
1377 * found here will be leaks.
1378 */
1379 for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) {
1380 const SV * const svend = &sva[SvREFCNT(sva)];
1381 SV* sv;
1382 for (sv = sva + 1; sv < svend; ++sv) {
1383 if (SvTYPE(sv) != (svtype)SVTYPEMASK && SvREFCNT(sv)) {
49beddc6 1384 sv_size(aTHX_ st, NPathLink("arena"), sv, TOTAL_SIZE_RECURSION);
1abba8e9 1385 }
1386 else if (check_new(st, sv)) { /* sanity check */
1abba8e9 1387 sv_dump(sv);
df9491fe 1388 warn("unseen_sv_size encountered freed SV unexpectedly"); /* XXX warn uses an SV, I think */
1abba8e9 1389 }
1390 }
1391 }
1392}
1393
df9491fe 1394static void
1395perl_size(pTHX_ struct state *const st, pPATH)
33f2f60c 1396{
df9491fe 1397 dNPathNodes(3, NPathArg);
05f432c0 1398
df9491fe 1399 /* if(!check_new(st, interp)) return; */
1400 NPathPushNode("perl", NPtype_NAME);
1abba8e9 1401
df9491fe 1402/*
1403 * perl
1404 * PL_defstash
1405 * others
1406 * unknown <== = O/S Heap size - perl - free_malloc_space
1407 */
1abba8e9 1408 /* start with PL_defstash to get everything reachable from \%main:: */
fc6614ee 1409 sv_size(aTHX_ st, NPathLink("PL_defstash"), (SV*)PL_defstash, TOTAL_SIZE_RECURSION);
e8f4c506 1410
1411 NPathPushNode("others", NPtype_NAME); /* group these (typically much smaller) items */
fc6614ee 1412 sv_size(aTHX_ st, NPathLink("PL_defgv"), (SV*)PL_defgv, TOTAL_SIZE_RECURSION);
1413 sv_size(aTHX_ st, NPathLink("PL_incgv"), (SV*)PL_incgv, TOTAL_SIZE_RECURSION);
1414 sv_size(aTHX_ st, NPathLink("PL_rs"), (SV*)PL_rs, TOTAL_SIZE_RECURSION);
1415 sv_size(aTHX_ st, NPathLink("PL_fdpid"), (SV*)PL_fdpid, TOTAL_SIZE_RECURSION);
1416 sv_size(aTHX_ st, NPathLink("PL_modglobal"), (SV*)PL_modglobal, TOTAL_SIZE_RECURSION);
1417 sv_size(aTHX_ st, NPathLink("PL_errors"), (SV*)PL_errors, TOTAL_SIZE_RECURSION);
1418 sv_size(aTHX_ st, NPathLink("PL_stashcache"), (SV*)PL_stashcache, TOTAL_SIZE_RECURSION);
1419 sv_size(aTHX_ st, NPathLink("PL_patchlevel"), (SV*)PL_patchlevel, TOTAL_SIZE_RECURSION);
1420 sv_size(aTHX_ st, NPathLink("PL_apiversion"), (SV*)PL_apiversion, TOTAL_SIZE_RECURSION);
1421 sv_size(aTHX_ st, NPathLink("PL_registered_mros"), (SV*)PL_registered_mros, TOTAL_SIZE_RECURSION);
33f2f60c 1422#ifdef USE_ITHREADS
fc6614ee 1423 sv_size(aTHX_ st, NPathLink("PL_regex_padav"), (SV*)PL_regex_padav, TOTAL_SIZE_RECURSION);
33f2f60c 1424#endif
8a087ef5 1425 sv_size(aTHX_ st, NPathLink("PL_warnhook"), (SV*)PL_warnhook, TOTAL_SIZE_RECURSION);
1426 sv_size(aTHX_ st, NPathLink("PL_diehook"), (SV*)PL_diehook, TOTAL_SIZE_RECURSION);
1427 sv_size(aTHX_ st, NPathLink("PL_endav"), (SV*)PL_endav, TOTAL_SIZE_RECURSION);
1428 sv_size(aTHX_ st, NPathLink("PL_main_cv"), (SV*)PL_main_cv, TOTAL_SIZE_RECURSION);
1429 sv_size(aTHX_ st, NPathLink("PL_main_root"), (SV*)PL_main_root, TOTAL_SIZE_RECURSION);
1430 sv_size(aTHX_ st, NPathLink("PL_main_start"), (SV*)PL_main_start, TOTAL_SIZE_RECURSION);
33f2f60c 1431 /* TODO PL_pidstatus */
1432 /* TODO PL_stashpad */
8a087ef5 1433 /* TODO PL_compiling? COP */
33f2f60c 1434
33f2f60c 1435 /* TODO stacks: cur, main, tmps, mark, scope, save */
8a087ef5 1436 /* TODO PL_exitlist */
1abba8e9 1437 /* TODO PL_reentrant_buffers etc */
8a087ef5 1438 /* TODO environ */
1439 /* TODO PerlIO? PL_known_layers PL_def_layerlist PL_perlio_fd_refcnt etc */
5e486cae 1440 /* TODO threads? */
33f2f60c 1441 /* TODO anything missed? */
1442
1abba8e9 1443 /* --- by this point we should have seen all reachable SVs --- */
1444
1445 /* in theory we shouldn't have any elements in PL_strtab that haven't been seen yet */
df9491fe 1446 sv_size(aTHX_ st, NPathLink("PL_strtab-unseen"), (SV*)PL_strtab, TOTAL_SIZE_RECURSION);
1abba8e9 1447
1448 /* unused space in sv head arenas */
1449 if (PL_sv_root) {
1450 SV *p = PL_sv_root;
1451 UV free_heads = 1;
df9491fe 1452# define SvARENA_CHAIN(sv) SvANY(sv) /* XXX breaks encapsulation*/
1abba8e9 1453 while ((p = MUTABLE_SV(SvARENA_CHAIN(p)))) {
1454 if (!check_new(st, p)) /* sanity check */
1455 warn("Free'd SV head unexpectedly already seen");
1456 ++free_heads;
1457 }
1458 NPathPushNode("unused_sv_heads", NPtype_NAME);
1459 ADD_SIZE(st, "sv", free_heads * sizeof(SV));
1460 NPathPopNode;
1461 }
1462 /* XXX iterate over bodies_by_type and crawl the free chains for each */
1463
1464 /* iterate over all SVs to find any we've not accounted for yet */
1465 /* once the code above is visiting all SVs, any found here have been leaked */
1466 unseen_sv_size(aTHX_ st, NPathLink("unaccounted"));
df9491fe 1467}
1468
1469
d3b8a135 1470MODULE = Devel::Memory PACKAGE = Devel::Memory
df9491fe 1471
1472PROTOTYPES: DISABLE
1abba8e9 1473
df9491fe 1474UV
1475size(orig_thing)
1476 SV *orig_thing
1477ALIAS:
1478 total_size = TOTAL_SIZE_RECURSION
1479CODE:
1480{
1481 SV *thing = orig_thing;
1482 struct state *st = new_state(aTHX);
1483
1484 /* If they passed us a reference then dereference it. This is the
1485 only way we can check the sizes of arrays and hashes */
1486 if (SvROK(thing)) {
1487 thing = SvRV(thing);
1abba8e9 1488 }
1489
df9491fe 1490 sv_size(aTHX_ st, NULL, thing, ix);
1491 RETVAL = st->total_size;
60dacf5f 1492 free_state(aTHX_ st);
df9491fe 1493}
1494OUTPUT:
1495 RETVAL
1496
1497UV
1498perl_size()
1499CODE:
1500{
1501 /* just the current perl interpreter */
1502 struct state *st = new_state(aTHX);
1503 st->min_recurse_threshold = NO_RECURSION; /* so always recurse */
1504 perl_size(aTHX_ st, NULL);
1505 RETVAL = st->total_size;
60dacf5f 1506 free_state(aTHX_ st);
df9491fe 1507}
1508OUTPUT:
1509 RETVAL
1510
1511UV
1512heap_size()
1513CODE:
1514{
1515 /* the current perl interpreter plus malloc, in the context of total heap size */
6a9ab1d2 1516# ifdef _MALLOC_MALLOC_H_ /* OSX. Now sure where else mstats is available */
1517# define HAS_MSTATS
1518# endif
1519# ifdef HAS_MSTATS
1520 /* some systems have the SVID2/XPG mallinfo structure and function */
df9491fe 1521 struct mstats ms = mstats(); /* mstats() first */
6a9ab1d2 1522# endif
df9491fe 1523 struct state *st = new_state(aTHX);
1524 dNPathNodes(1, NULL);
1525 NPathPushNode("heap", NPtype_NAME);
1526
1527 st->min_recurse_threshold = NO_RECURSION; /* so always recurse */
1528
1529 perl_size(aTHX_ st, NPathLink("perl_interp"));
21920e7f 1530# ifdef HAS_MSTATS
df9491fe 1531 NPathSetNode("free_malloc_space", NPtype_NAME);
1532 ADD_SIZE(st, "bytes_free", ms.bytes_free);
1533 ADD_ATTR(st, NPattr_NOTE, "bytes_total", ms.bytes_total);
1534 ADD_ATTR(st, NPattr_NOTE, "bytes_used", ms.bytes_used);
1535 ADD_ATTR(st, NPattr_NOTE, "chunks_used", ms.chunks_used);
1536 ADD_ATTR(st, NPattr_NOTE, "chunks_free", ms.chunks_free);
df9491fe 1537 /* TODO get heap size from OS and add a node: unknown = heapsize - perl - ms.bytes_free */
1538 /* for now we use bytes_total as an approximation */
1539 NPathSetNode("unknown", NPtype_NAME);
1540 ADD_SIZE(st, "unknown", ms.bytes_total - st->total_size);
6a9ab1d2 1541# else
1542 /* XXX ? */
1543# endif
df9491fe 1544
33f2f60c 1545 RETVAL = st->total_size;
60dacf5f 1546 free_state(aTHX_ st);
33f2f60c 1547}
1548OUTPUT:
1549 RETVAL
Unnamed repository; edit this file 'description' to name the repository.