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