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