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