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