5 * Refactor this to split out D:M code from Devel::Size code.
6 * Start migrating Devel::Size's Size.xs towards the new code.
10 #undef NDEBUG /* XXX */
13 #define PERL_NO_GET_CONTEXT
20 #include "refcounted_he.h"
22 /* Not yet in ppport.h */
24 # define CvISXSUB(cv) (CvXSUB(cv) ? TRUE : FALSE)
27 # define SvRV_const(rv) SvRV(rv)
30 # define SvOOK_offset(sv, len) STMT_START { len = SvIVX(sv); } STMT_END
33 # define SvIsCOW(sv) ((SvFLAGS(sv) & (SVf_FAKE | SVf_READONLY)) == \
34 (SVf_FAKE | SVf_READONLY))
36 #ifndef SvIsCOW_shared_hash
37 # define SvIsCOW_shared_hash(sv) (SvIsCOW(sv) && SvLEN(sv) == 0)
39 #ifndef SvSHARED_HEK_FROM_PV
40 # define SvSHARED_HEK_FROM_PV(pvx) \
41 ((struct hek*)(pvx - STRUCT_OFFSET(struct hek, hek_key)))
45 # define PL_opargs opargs
46 # define PL_op_name op_name
50 /* "structured exception" handling is a Microsoft extension to C and C++.
51 It's *not* C++ exception handling - C++ exception handling can't capture
52 SEGVs and suchlike, whereas this can. There's no known analagous
53 functionality on other platforms. */
55 # define TRY_TO_CATCH_SEGV __try
56 # define CAUGHT_EXCEPTION __except(EXCEPTION_EXECUTE_HANDLER)
58 # define TRY_TO_CATCH_SEGV if(1)
59 # define CAUGHT_EXCEPTION else
63 # define __attribute__(x)
66 #if 0 && defined(DEBUGGING)
67 #define dbg_printf(x) printf x
72 #define TAG /* printf( "# %s(%d)\n", __FILE__, __LINE__ ) */
75 /* The idea is to have a tree structure to store 1 bit per possible pointer
76 address. The lowest 16 bits are stored in a block of 8092 bytes.
77 The blocks are in a 256-way tree, indexed by the reset of the pointer.
78 This can cope with 32 and 64 bit pointers, and any address space layout,
79 without excessive memory needs. The assumption is that your CPU cache
80 works :-) (And that we're not going to bust it) */
83 #define LEAF_BITS (16 - BYTE_BITS)
84 #define LEAF_MASK 0x1FFF
86 typedef struct npath_node_st npath_node_t;
87 struct npath_node_st {
102 /* My hunch (not measured) is that for most architectures pointers will
103 start with 0 bits, hence the start of this array will be hot, and the
104 end unused. So put the flags next to the hot end. */
107 int min_recurse_threshold;
108 /* callback hooks and data */
109 void (*add_attr_cb)(pTHX_ struct state *st, npath_node_t *npath_node, UV attr_type, const char *name, UV value);
110 void (*free_state_cb)(pTHX_ struct state *st);
111 void *state_cb_data; /* free'd by free_state() after free_state_cb() call */
112 /* this stuff wil be moved to state_cb_data later */
114 FILE *node_stream_fh;
115 char *node_stream_name;
118 #define ADD_SIZE(st, leafname, bytes) \
120 NPathAddSizeCb(st, leafname, bytes); \
121 (st)->total_size += (bytes); \
125 #define PATH_TRACKING
128 #define pPATH npath_node_t *NPathArg
130 /* A subtle point here is that dNPathNodes and NPathPushNode leave NP pointing
131 * to the next unused slot (though with prev already filled in)
132 * whereas NPathLink leaves NP unchanged, it just fills in the slot NP points
133 * to and passes that NP value to the function being called.
134 * seqn==0 indicates the node is new (hasn't been output yet)
136 #define dNPathNodes(nodes, prev_np) \
137 npath_node_t name_path_nodes[nodes+1]; /* +1 for NPathLink */ \
138 npath_node_t *NP = &name_path_nodes[0]; \
139 NP->seqn = NP->type = 0; NP->id = Nullch; /* safety/debug */ \
141 #define NPathPushNode(nodeid, nodetype) \
143 NP->type = nodetype; \
145 if(0)fprintf(stderr,"NPathPushNode (%p <-) %p <- [%d %s]\n", NP->prev, NP, nodetype,(char*)nodeid);\
147 NP->id = Nullch; /* safety/debug */ \
150 #define NPathSetNode(nodeid, nodetype) \
151 (NP-1)->id = nodeid; \
152 (NP-1)->type = nodetype; \
153 if(0)fprintf(stderr,"NPathSetNode (%p <-) %p <- [%d %s]\n", (NP-1)->prev, (NP-1), nodetype,(char*)nodeid);\
155 #define NPathPopNode \
158 /* dNPathUseParent points NP directly the the parents' name_path_nodes array
159 * So the function can only safely call ADD_*() but not NPathLink, unless the
160 * caller has spare nodes in its name_path_nodes.
162 #define dNPathUseParent(prev_np) npath_node_t *NP = (((prev_np+1)->prev = prev_np), prev_np+1)
164 #define NPtype_NAME 0x01
165 #define NPtype_LINK 0x02
166 #define NPtype_SV 0x03
167 #define NPtype_MAGIC 0x04
168 #define NPtype_OP 0x05
170 /* XXX these should probably be generalized into flag bits */
171 #define NPattr_LEAFSIZE 0x00
172 #define NPattr_NAME 0x01
173 #define NPattr_PADFAKE 0x02
174 #define NPattr_PADNAME 0x03
175 #define NPattr_PADTMP 0x04
176 #define NPattr_NOTE 0x05
178 #define _ADD_ATTR_NP(st, attr_type, attr_name, attr_value, np) \
180 if (st->add_attr_cb) { \
181 st->add_attr_cb(aTHX_ st, np, attr_type, attr_name, attr_value); \
185 #define ADD_ATTR(st, attr_type, attr_name, attr_value) \
186 _ADD_ATTR_NP(st, attr_type, attr_name, attr_value, NP-1)
188 #define ADD_LINK_ATTR(st, attr_type, attr_name, attr_value) \
191 _ADD_ATTR_NP(st, attr_type, attr_name, attr_value, NP); \
194 #define _NPathLink(np, nid, ntype) (((np)->id=nid), ((np)->type=ntype), ((np)->seqn=0))
195 #define NPathLink(nid) (_NPathLink(NP, nid, NPtype_LINK), NP)
196 /* add a link and a name node to the path - a special case for op_size */
197 #define NPathLinkAndNode(nid, nid2) (_NPathLink(NP, nid, NPtype_LINK), _NPathLink(NP+1, nid2, NPtype_NAME), ((NP+1)->prev=NP), (NP+1))
198 #define NPathOpLink (NPathArg)
199 #define NPathAddSizeCb(st, name, bytes) \
201 if (st->add_attr_cb) { \
202 st->add_attr_cb(aTHX_ st, NP-1, NPattr_LEAFSIZE, (name), (bytes)); \
208 #define NPathAddSizeCb(st, name, bytes)
209 #define pPATH void *npath_dummy /* XXX ideally remove */
210 #define dNPathNodes(nodes, prev_np) dNOOP
211 #define NPathLink(nodeid, nodetype) NULL
212 #define NPathOpLink NULL
213 #define ADD_ATTR(st, attr_type, attr_name, attr_value) NOOP
215 #endif /* PATH_TRACKING */
222 static const char *svtypenames[SVt_LAST] = {
224 "NULL", "IV", "NV", "RV", "PV", "PVIV", "PVNV", "PVMG", "PVBM", "PVLV", "PVAV", "PVHV", "PVCV", "PVGV", "PVFM", "PVIO",
225 #elif PERL_VERSION == 10 && PERL_SUBVERSION == 0
226 "NULL", "BIND", "IV", "NV", "RV", "PV", "PVIV", "PVNV", "PVMG", "PVGV", "PVLV", "PVAV", "PVHV", "PVCV", "PVFM", "PVIO",
227 #elif PERL_VERSION == 10 && PERL_SUBVERSION == 1
228 "NULL", "BIND", "IV", "NV", "RV", "PV", "PVIV", "PVNV", "PVMG", "PVGV", "PVLV", "PVAV", "PVHV", "PVCV", "PVFM", "PVIO",
229 #elif PERL_VERSION < 13
230 "NULL", "BIND", "IV", "NV", "PV", "PVIV", "PVNV", "PVMG", "REGEXP", "PVGV", "PVLV", "PVAV", "PVHV", "PVCV", "PVFM", "PVIO",
232 "NULL", "BIND", "IV", "NV", "PV", "PVIV", "PVNV", "PVMG", "REGEXP", "PVGV", "PVLV", "PVAV", "PVHV", "PVCV", "PVFM", "PVIO",
237 gettimeofday_nv(void)
239 #ifdef HAS_GETTIMEOFDAY
241 gettimeofday(&when, (struct timezone *) 0);
242 return when.tv_sec + (when.tv_usec / 1000000.0);
246 (*u2time)(aTHX_ &time_of_day);
247 return time_of_day[0] + (time_of_day[1] / 1000000.0);
255 np_print_node_name(pTHX_ FILE *fp, npath_node_t *npath_node)
257 switch (npath_node->type) {
258 case NPtype_SV: { /* id is pointer to the SV sv_size was called on */
259 const SV *sv = (SV*)npath_node->id;
260 int type = SvTYPE(sv);
261 const char *typename = (type == SVt_IV && SvROK(sv)) ? "RV" : svtypenames[type];
262 fprintf(fp, "SV(%s)", typename);
263 switch(type) { /* add some useful details */
264 case SVt_PVAV: fprintf(fp, " fill=%d/%ld", av_len((AV*)sv), AvMAX((AV*)sv)); break;
265 case SVt_PVHV: fprintf(fp, " fill=%ld/%ld", HvFILL((HV*)sv), HvMAX((HV*)sv)); break;
269 case NPtype_OP: { /* id is pointer to the OP op_size was called on */
270 const OP *op = (OP*)npath_node->id;
271 fprintf(fp, "OP(%s)", OP_NAME(op));
274 case NPtype_MAGIC: { /* id is pointer to the MAGIC struct */
275 MAGIC *magic_pointer = (MAGIC*)npath_node->id;
276 /* XXX it would be nice if we could reuse mg_names.c [sigh] */
277 fprintf(fp, "MAGIC(%c)", magic_pointer->mg_type ? magic_pointer->mg_type : '0');
281 fprintf(fp, "%s", (const char *)npath_node->id);
284 fprintf(fp, "%s", (const char *)npath_node->id);
286 default: /* assume id is a string pointer */
287 fprintf(fp, "UNKNOWN(%d,%p)", npath_node->type, npath_node->id);
294 np_dump_indent(int depth) {
296 fprintf(stderr, ": ");
300 np_walk_new_nodes(pTHX_ struct state *st,
301 npath_node_t *npath_node,
302 npath_node_t *npath_node_deeper,
303 int (*cb)(pTHX_ struct state *st, npath_node_t *npath_node, npath_node_t *npath_node_deeper))
305 if (npath_node->seqn) /* node already output */
308 if (npath_node->prev) {
309 np_walk_new_nodes(aTHX_ st, npath_node->prev, npath_node, cb); /* recurse */
310 npath_node->depth = npath_node->prev->depth + 1;
312 else npath_node->depth = 0;
313 npath_node->seqn = ++st->seqn;
316 if (cb(aTHX_ st, npath_node, npath_node_deeper)) {
317 /* ignore this node */
318 assert(npath_node->prev);
319 assert(npath_node->depth);
320 assert(npath_node_deeper);
322 npath_node->seqn = --st->seqn;
323 npath_node_deeper->prev = npath_node->prev;
331 np_dump_formatted_node(pTHX_ struct state *st, npath_node_t *npath_node, npath_node_t *npath_node_deeper) {
333 PERL_UNUSED_ARG(npath_node_deeper);
334 if (0 && npath_node->type == NPtype_LINK)
336 np_dump_indent(npath_node->depth);
337 np_print_node_name(aTHX_ stderr, npath_node);
338 if (npath_node->type == NPtype_LINK)
339 fprintf(stderr, "->"); /* cosmetic */
340 fprintf(stderr, "\t\t[#%ld @%u] ", npath_node->seqn, npath_node->depth);
341 fprintf(stderr, "\n");
346 np_dump_node_path_info(pTHX_ struct state *st, npath_node_t *npath_node, UV attr_type, const char *attr_name, UV attr_value)
348 if (attr_type == NPattr_LEAFSIZE && !attr_value)
349 return; /* ignore zero sized leaf items */
350 np_walk_new_nodes(aTHX_ st, npath_node, NULL, np_dump_formatted_node);
351 np_dump_indent(npath_node->depth+1);
353 case NPattr_LEAFSIZE:
354 fprintf(stderr, "+%ld %s =%ld", attr_value, attr_name, attr_value+st->total_size);
357 fprintf(stderr, "~NAMED('%s') %lu", attr_name, attr_value);
360 fprintf(stderr, "~note %s %lu", attr_name, attr_value);
365 fprintf(stderr, "~pad%lu %s %lu", attr_type, attr_name, attr_value);
368 fprintf(stderr, "~??? %s %lu", attr_name, attr_value);
371 fprintf(stderr, "\n");
375 np_stream_formatted_node(pTHX_ struct state *st, npath_node_t *npath_node, npath_node_t *npath_node_deeper) {
376 PERL_UNUSED_ARG(npath_node_deeper);
377 fprintf(st->node_stream_fh, "-%u %lu %u ",
378 npath_node->type, npath_node->seqn, (unsigned)npath_node->depth
380 np_print_node_name(aTHX_ st->node_stream_fh, npath_node);
381 fprintf(st->node_stream_fh, "\n");
386 np_stream_node_path_info(pTHX_ struct state *st, npath_node_t *npath_node, UV attr_type, const char *attr_name, UV attr_value)
388 if (!attr_type && !attr_value)
389 return; /* ignore zero sized leaf items */
390 np_walk_new_nodes(aTHX_ st, npath_node, NULL, np_stream_formatted_node);
391 if (attr_type) { /* Attribute type, name and value */
392 fprintf(st->node_stream_fh, "%lu %lu ", attr_type, npath_node->seqn);
394 else { /* Leaf name and memory size */
395 fprintf(st->node_stream_fh, "L %lu ", npath_node->seqn);
397 fprintf(st->node_stream_fh, "%lu %s\n", attr_value, attr_name);
401 #endif /* PATH_TRACKING */
405 Checks to see if thing is in the bitstring.
406 Returns true or false, and
407 notes thing in the segmented bitstring.
410 check_new(struct state *st, const void *const p) {
411 unsigned int bits = 8 * sizeof(void*);
412 const size_t raw_p = PTR2nat(p);
413 /* This effectively rotates the value right by the number of low always-0
414 bits in an aligned pointer. The assmption is that most (if not all)
415 pointers are aligned, and these will be in the same chain of nodes
416 (and hence hot in the cache) but we can still deal with any unaligned
418 const size_t cooked_p
419 = (raw_p >> ALIGN_BITS) | (raw_p << (bits - ALIGN_BITS));
420 const U8 this_bit = 1 << (cooked_p & 0x7);
424 void **tv_p = (void **) (st->tracking);
426 if (NULL == p) return FALSE;
428 const char c = *(const char *)p;
432 if (st->dangle_whine)
433 warn( "Devel::Size: Encountered invalid pointer: %p\n", p );
439 /* bits now 24 (32 bit pointers) or 56 (64 bit pointers) */
441 /* First level is always present. */
443 i = (unsigned int)((cooked_p >> bits) & 0xFF);
445 Newxz(tv_p[i], 256, void *);
446 tv_p = (void **)(tv_p[i]);
448 } while (bits > LEAF_BITS + BYTE_BITS);
449 /* bits now 16 always */
450 #if !defined(MULTIPLICITY) || PERL_VERSION > 8 || (PERL_VERSION == 8 && PERL_SUBVERSION > 8)
451 /* 5.8.8 and early have an assert() macro that uses Perl_croak, hence needs
452 a my_perl under multiplicity */
455 leaf_p = (U8 **)tv_p;
456 i = (unsigned int)((cooked_p >> bits) & 0xFF);
458 Newxz(leaf_p[i], 1 << LEAF_BITS, U8);
463 i = (unsigned int)((cooked_p >> BYTE_BITS) & LEAF_MASK);
465 if(leaf[i] & this_bit)
473 free_tracking_at(void **tv, int level)
481 free_tracking_at((void **) tv[i], level);
495 free_state(pTHX_ struct state *st)
497 const int top_level = (sizeof(void *) * 8 - LEAF_BITS - BYTE_BITS) / 8;
498 if (st->free_state_cb)
499 st->free_state_cb(aTHX_ st);
500 if (st->state_cb_data)
501 Safefree(st->state_cb_data);
502 free_tracking_at((void **)st->tracking, top_level);
506 /* For now, this is somewhat a compatibility bodge until the plan comes
507 together for fine grained recursion control. total_size() would recurse into
508 hash and array members, whereas sv_size() would not. However, sv_size() is
509 called with CvSTASH() of a CV, which means that if it (also) starts to
510 recurse fully, then the size of any CV now becomes the size of the entire
511 symbol table reachable from it, and potentially the entire symbol table, if
512 any subroutine makes a reference to a global (such as %SIG). The historical
513 implementation of total_size() didn't report "everything", and changing the
514 only available size to "everything" doesn't feel at all useful. */
516 #define NO_RECURSION 0
517 #define SOME_RECURSION 1
518 #define TOTAL_SIZE_RECURSION 2
520 static bool sv_size(pTHX_ struct state *, pPATH, const SV *const, const int recurse);
536 , OPc_CONDOP /* 12 */
545 cc_opclass(const OP * const o)
551 return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
553 if (o->op_type == OP_SASSIGN)
554 return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPc_UNOP : OPc_BINOP);
557 if (o->op_type == OP_GV || o->op_type == OP_GVSV || o->op_type == OP_AELEMFAST)
561 if ((o->op_type == OP_TRANS)) {
565 switch (PL_opargs[o->op_type] & OA_CLASS_MASK) {
597 #ifdef OA_PVOP_OR_SVOP
598 case OA_PVOP_OR_SVOP: TAG;
600 * Character translations (tr///) are usually a PVOP, keeping a
601 * pointer to a table of shorts used to look up translations.
602 * Under utf8, however, a simple table isn't practical; instead,
603 * the OP is an SVOP, and the SV is a reference to a swash
604 * (i.e., an RV pointing to an HV).
606 return (o->op_private & (OPpTRANS_TO_UTF|OPpTRANS_FROM_UTF))
607 ? OPc_SVOP : OPc_PVOP;
616 case OA_BASEOP_OR_UNOP: TAG;
618 * UNI(OP_foo) in toke.c returns token UNI or FUNC1 depending on
619 * whether parens were seen. perly.y uses OPf_SPECIAL to
620 * signal whether a BASEOP had empty parens or none.
621 * Some other UNOPs are created later, though, so the best
622 * test is OPf_KIDS, which is set in newUNOP.
624 return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
626 case OA_FILESTATOP: TAG;
628 * The file stat OPs are created via UNI(OP_foo) in toke.c but use
629 * the OPf_REF flag to distinguish between OP types instead of the
630 * usual OPf_SPECIAL flag. As usual, if OPf_KIDS is set, then we
631 * return OPc_UNOP so that walkoptree can find our children. If
632 * OPf_KIDS is not set then we check OPf_REF. Without OPf_REF set
633 * (no argument to the operator) it's an OP; with OPf_REF set it's
634 * an SVOP (and op_sv is the GV for the filehandle argument).
636 return ((o->op_flags & OPf_KIDS) ? OPc_UNOP :
638 (o->op_flags & OPf_REF) ? OPc_PADOP : OPc_BASEOP);
640 (o->op_flags & OPf_REF) ? OPc_SVOP : OPc_BASEOP);
642 case OA_LOOPEXOP: TAG;
644 * next, last, redo, dump and goto use OPf_SPECIAL to indicate that a
645 * label was omitted (in which case it's a BASEOP) or else a term was
646 * seen. In this last case, all except goto are definitely PVOP but
647 * goto is either a PVOP (with an ordinary constant label), an UNOP
648 * with OPf_STACKED (with a non-constant non-sub) or an UNOP for
649 * OP_REFGEN (with goto &sub) in which case OPf_STACKED also seems to
652 if (o->op_flags & OPf_STACKED)
654 else if (o->op_flags & OPf_SPECIAL)
664 warn("Devel::Size: Can't determine class of operator %s, assuming BASEOP\n",
665 PL_op_name[o->op_type]);
671 /* Figure out how much magic is attached to the SV and return the
674 magic_size(pTHX_ const SV * const thing, struct state *st, pPATH) {
675 dNPathNodes(1, NPathArg);
676 MAGIC *magic_pointer = SvMAGIC(thing); /* caller ensures thing is SvMAGICAL */
678 /* push a dummy node for NPathSetNode to update inside the while loop */
679 NPathPushNode("dummy", NPtype_NAME);
681 /* Have we seen the magic pointer? (NULL has always been seen before) */
682 while (check_new(st, magic_pointer)) {
684 NPathSetNode(magic_pointer, NPtype_MAGIC);
686 ADD_SIZE(st, "mg", sizeof(MAGIC));
687 /* magic vtables aren't freed when magic is freed, so don't count them.
688 (They are static structures. Anything that assumes otherwise is buggy.)
693 /* XXX only chase mg_obj if mg->mg_flags & MGf_REFCOUNTED ? */
694 sv_size(aTHX_ st, NPathLink("mg_obj"), magic_pointer->mg_obj, TOTAL_SIZE_RECURSION);
695 if (magic_pointer->mg_len == HEf_SVKEY) {
696 sv_size(aTHX_ st, NPathLink("mg_ptr"), (SV *)magic_pointer->mg_ptr, TOTAL_SIZE_RECURSION);
698 #if defined(PERL_MAGIC_utf8) && defined (PERL_MAGIC_UTF8_CACHESIZE)
699 else if (magic_pointer->mg_type == PERL_MAGIC_utf8) {
700 if (check_new(st, magic_pointer->mg_ptr)) {
701 ADD_SIZE(st, "PERL_MAGIC_utf8", PERL_MAGIC_UTF8_CACHESIZE * 2 * sizeof(STRLEN));
705 /* XXX also handle mg->mg_type == PERL_MAGIC_utf8 ? */
706 else if (magic_pointer->mg_len > 0) {
707 if(0)do_magic_dump(0, Perl_debug_log, magic_pointer, 0, 0, FALSE, 0);
708 if (check_new(st, magic_pointer->mg_ptr)) {
709 ADD_SIZE(st, "mg_len", magic_pointer->mg_len);
713 /* Get the next in the chain */
714 magic_pointer = magic_pointer->mg_moremagic;
717 if (st->dangle_whine)
718 warn( "Devel::Size: Encountered bad magic at: %p\n", magic_pointer );
723 #define check_new_and_strlen(st, p, ppath) S_check_new_and_strlen(aTHX_ st, p, ppath)
725 S_check_new_and_strlen(pTHX_ struct state *st, const char *const p, pPATH) {
726 dNPathNodes(1, NPathArg->prev);
727 if(check_new(st, p)) {
728 NPathPushNode(NPathArg->id, NPtype_NAME);
729 ADD_SIZE(st, NPathArg->id, 1 + strlen(p));
734 regex_size(pTHX_ const REGEXP * const baseregex, struct state *st, pPATH) {
735 dNPathNodes(1, NPathArg);
736 if(!check_new(st, baseregex))
738 NPathPushNode("regex_size", NPtype_NAME);
739 ADD_SIZE(st, "REGEXP", sizeof(REGEXP));
740 #if (PERL_VERSION < 11)
741 /* Note the size of the paren offset thing */
742 ADD_SIZE(st, "nparens", sizeof(I32) * baseregex->nparens * 2);
743 ADD_SIZE(st, "precomp", strlen(baseregex->precomp));
745 ADD_SIZE(st, "regexp", sizeof(struct regexp));
746 ADD_SIZE(st, "nparens", sizeof(I32) * SvANY(baseregex)->nparens * 2);
747 /*ADD_SIZE(st, strlen(SvANY(baseregex)->subbeg));*/
749 if (st->go_yell && !st->regex_whine) {
750 carp("Devel::Size: Calculated sizes for compiled regexes are incompatible, and probably always will be");
756 hek_size(pTHX_ struct state *st, HEK *hek, U32 shared, pPATH)
758 dNPathNodes(1, NPathArg);
760 /* Hash keys can be shared. Have we seen this before? */
761 if (!check_new(st, hek))
763 NPathPushNode("hek", NPtype_NAME);
764 ADD_SIZE(st, "hek_len", HEK_BASESIZE + hek->hek_len
766 + 1 /* No hash key flags prior to 5.8.0 */
772 #if PERL_VERSION < 10
773 ADD_SIZE(st, "he", sizeof(struct he));
775 ADD_SIZE(st, "shared_he", STRUCT_OFFSET(struct shared_he, shared_he_hek));
782 refcounted_he_size(pTHX_ struct state *st, struct refcounted_he *he, pPATH)
784 dNPathNodes(1, NPathArg);
785 if (!check_new(st, he))
787 NPathPushNode("refcounted_he_size", NPtype_NAME);
788 ADD_SIZE(st, "refcounted_he", sizeof(struct refcounted_he));
791 ADD_SIZE(st, "refcounted_he_data", NPtype_NAME);
793 hek_size(aTHX_ st, he->refcounted_he_hek, 0, NPathLink("refcounted_he_hek"));
796 if (he->refcounted_he_next)
797 refcounted_he_size(aTHX_ st, he->refcounted_he_next, NPathLink("refcounted_he_next"));
800 static void op_size_class(pTHX_ const OP * const baseop, opclass op_class, bool skip_op_struct, struct state *st, pPATH);
803 op_size(pTHX_ const OP * const baseop, struct state *st, pPATH)
805 op_size_class(aTHX_ baseop, cc_opclass(baseop), 0, st, NPathArg);
809 op_size_class(pTHX_ const OP * const baseop, opclass op_class, bool skip_op_struct, struct state *st, pPATH)
811 /* op_size recurses to follow the chain of opcodes. For the node path we
812 * don't want the chain to be 'nested' in the path so we use dNPathUseParent().
813 * Also, to avoid a link-to-a-link the caller should use NPathLinkAndNode()
814 * instead of NPathLink().
816 dNPathUseParent(NPathArg);
820 if(!check_new(st, baseop))
823 op_size(aTHX_ baseop->op_next, st, NPathOpLink);
825 madprop_size(aTHX_ st, NPathOpLink, baseop->op_madprop);
829 case OPc_BASEOP: TAG;
831 ADD_SIZE(st, "op", sizeof(struct op));
835 ADD_SIZE(st, "unop", sizeof(struct unop));
836 op_size(aTHX_ ((UNOP *)baseop)->op_first, st, NPathOpLink);
840 ADD_SIZE(st, "binop", sizeof(struct binop));
841 op_size(aTHX_ ((BINOP *)baseop)->op_first, st, NPathOpLink);
842 op_size(aTHX_ ((BINOP *)baseop)->op_last, st, NPathOpLink);
846 ADD_SIZE(st, "logop", sizeof(struct logop));
847 op_size(aTHX_ ((BINOP *)baseop)->op_first, st, NPathOpLink);
848 op_size(aTHX_ ((LOGOP *)baseop)->op_other, st, NPathOpLink);
851 case OPc_CONDOP: TAG;
853 ADD_SIZE(st, "condop", sizeof(struct condop));
854 op_size(aTHX_ ((BINOP *)baseop)->op_first, st, NPathOpLink);
855 op_size(aTHX_ ((CONDOP *)baseop)->op_true, st, NPathOpLink);
856 op_size(aTHX_ ((CONDOP *)baseop)->op_false, st, NPathOpLink);
859 case OPc_LISTOP: TAG;
861 ADD_SIZE(st, "listop", sizeof(struct listop));
862 op_size(aTHX_ ((LISTOP *)baseop)->op_first, st, NPathOpLink);
863 op_size(aTHX_ ((LISTOP *)baseop)->op_last, st, NPathOpLink);
867 ADD_SIZE(st, "pmop", sizeof(struct pmop));
868 op_size(aTHX_ ((PMOP *)baseop)->op_first, st, NPathOpLink);
869 op_size(aTHX_ ((PMOP *)baseop)->op_last, st, NPathOpLink);
870 #if PERL_VERSION < 9 || (PERL_VERSION == 9 && PERL_SUBVERSION < 5)
871 op_size(aTHX_ ((PMOP *)baseop)->op_pmreplroot, st, NPathOpLink);
872 op_size(aTHX_ ((PMOP *)baseop)->op_pmreplstart, st, NPathOpLink);
874 /* This is defined away in perl 5.8.x, but it is in there for
877 regex_size(aTHX_ PM_GETRE((PMOP *)baseop), st, NPathLink("PM_GETRE"));
879 regex_size(aTHX_ ((PMOP *)baseop)->op_pmregexp, st, NPathLink("op_pmregexp"));
884 ADD_SIZE(st, "svop", sizeof(struct svop));
885 if (!(baseop->op_type == OP_AELEMFAST
886 && baseop->op_flags & OPf_SPECIAL)) {
887 /* not an OP_PADAV replacement */
888 sv_size(aTHX_ st, NPathLink("SVOP"), ((SVOP *)baseop)->op_sv, SOME_RECURSION);
894 ADD_SIZE(st, "padop", sizeof(struct padop));
900 ADD_SIZE(st, "gvop", sizeof(struct gvop));
901 sv_size(aTHX_ st, NPathLink("GVOP"), ((GVOP *)baseop)->op_gv, SOME_RECURSION);
905 check_new_and_strlen(st, ((PVOP *)baseop)->op_pv, NPathLink("op_pv"));
909 ADD_SIZE(st, "loop", sizeof(struct loop));
910 op_size(aTHX_ ((LOOP *)baseop)->op_first, st, NPathOpLink);
911 op_size(aTHX_ ((LOOP *)baseop)->op_last, st, NPathOpLink);
912 op_size(aTHX_ ((LOOP *)baseop)->op_redoop, st, NPathOpLink);
913 op_size(aTHX_ ((LOOP *)baseop)->op_nextop, st, NPathOpLink);
914 op_size(aTHX_ ((LOOP *)baseop)->op_lastop, st, NPathOpLink);
920 basecop = (COP *)baseop;
922 ADD_SIZE(st, "cop", sizeof(struct cop));
924 /* Change 33656 by nicholas@mouse-mill on 2008/04/07 11:29:51
925 Eliminate cop_label from struct cop by storing a label as the first
926 entry in the hints hash. Most statements don't have labels, so this
927 will save memory. Not sure how much.
928 The check below will be incorrect fail on bleadperls
929 before 5.11 @33656, but later than 5.10, producing slightly too
930 small memory sizes on these Perls. */
931 #if (PERL_VERSION < 11)
932 check_new_and_strlen(st, basecop->cop_label, NPathLink("cop_label"));
935 check_new_and_strlen(st, basecop->cop_file, NPathLink("cop_file"));
936 check_new_and_strlen(st, basecop->cop_stashpv, NPathLink("cop_stashpv"));
938 if (SvREFCNT(basecop->cop_stash) == 1) /* XXX hack? */
939 sv_size(aTHX_ st, NPathLink("cop_stash"), (SV *)basecop->cop_stash, SOME_RECURSION);
940 sv_size(aTHX_ st, NPathLink("cop_filegv"), (SV *)basecop->cop_filegv, SOME_RECURSION);
943 hh = CopHINTHASH_get(basecop);
944 refcounted_he_size(aTHX_ st, hh, NPathLink("cop_hints_hash"));
952 if (st->dangle_whine)
953 warn( "Devel::Size: Encountered dangling pointer in opcode at: %p\n", baseop );
957 #if PERL_VERSION < 8 || PERL_SUBVERSION < 9 /* XXX plain || seems like a bug */
962 # define MAYBE_PURIFY(normal, pure) (pure)
963 # define MAYBE_OFFSET(struct_name, member) 0
965 # define MAYBE_PURIFY(normal, pure) (normal)
966 # define MAYBE_OFFSET(struct_name, member) STRUCT_OFFSET(struct_name, member)
969 const U8 body_sizes[SVt_LAST] = {
972 MAYBE_PURIFY(sizeof(IV), sizeof(XPVIV)), /* SVt_IV */
973 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
974 sizeof(XRV), /* SVt_RV */
975 sizeof(XPV), /* SVt_PV */
976 sizeof(XPVIV), /* SVt_PVIV */
977 sizeof(XPVNV), /* SVt_PVNV */
978 sizeof(XPVMG), /* SVt_PVMG */
979 sizeof(XPVBM), /* SVt_PVBM */
980 sizeof(XPVLV), /* SVt_PVLV */
981 sizeof(XPVAV), /* SVt_PVAV */
982 sizeof(XPVHV), /* SVt_PVHV */
983 sizeof(XPVCV), /* SVt_PVCV */
984 sizeof(XPVGV), /* SVt_PVGV */
985 sizeof(XPVFM), /* SVt_PVFM */
986 sizeof(XPVIO) /* SVt_PVIO */
987 #elif PERL_VERSION == 10 && PERL_SUBVERSION == 0
991 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
993 MAYBE_PURIFY(sizeof(xpv_allocated), sizeof(XPV)), /* SVt_PV */
994 MAYBE_PURIFY(sizeof(xpviv_allocated), sizeof(XPVIV)),/* SVt_PVIV */
995 sizeof(XPVNV), /* SVt_PVNV */
996 sizeof(XPVMG), /* SVt_PVMG */
997 sizeof(XPVGV), /* SVt_PVGV */
998 sizeof(XPVLV), /* SVt_PVLV */
999 MAYBE_PURIFY(sizeof(xpvav_allocated), sizeof(XPVAV)),/* SVt_PVAV */
1000 MAYBE_PURIFY(sizeof(xpvhv_allocated), sizeof(XPVHV)),/* SVt_PVHV */
1001 MAYBE_PURIFY(sizeof(xpvcv_allocated), sizeof(XPVCV)),/* SVt_PVCV */
1002 MAYBE_PURIFY(sizeof(xpvfm_allocated), sizeof(XPVFM)),/* SVt_PVFM */
1003 sizeof(XPVIO), /* SVt_PVIO */
1004 #elif PERL_VERSION == 10 && PERL_SUBVERSION == 1
1008 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
1010 sizeof(XPV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PV */
1011 sizeof(XPVIV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PVIV */
1012 sizeof(XPVNV), /* SVt_PVNV */
1013 sizeof(XPVMG), /* SVt_PVMG */
1014 sizeof(XPVGV), /* SVt_PVGV */
1015 sizeof(XPVLV), /* SVt_PVLV */
1016 sizeof(XPVAV) - MAYBE_OFFSET(XPVAV, xav_fill), /* SVt_PVAV */
1017 sizeof(XPVHV) - MAYBE_OFFSET(XPVHV, xhv_fill), /* SVt_PVHV */
1018 sizeof(XPVCV) - MAYBE_OFFSET(XPVCV, xpv_cur), /* SVt_PVCV */
1019 sizeof(XPVFM) - MAYBE_OFFSET(XPVFM, xpv_cur), /* SVt_PVFM */
1020 sizeof(XPVIO) /* SVt_PVIO */
1021 #elif PERL_VERSION < 13
1025 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
1026 sizeof(XPV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PV */
1027 sizeof(XPVIV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PVIV */
1028 sizeof(XPVNV), /* SVt_PVNV */
1029 sizeof(XPVMG), /* SVt_PVMG */
1030 sizeof(regexp) - MAYBE_OFFSET(regexp, xpv_cur), /* SVt_REGEXP */
1031 sizeof(XPVGV), /* SVt_PVGV */
1032 sizeof(XPVLV), /* SVt_PVLV */
1033 sizeof(XPVAV) - MAYBE_OFFSET(XPVAV, xav_fill), /* SVt_PVAV */
1034 sizeof(XPVHV) - MAYBE_OFFSET(XPVHV, xhv_fill), /* SVt_PVHV */
1035 sizeof(XPVCV) - MAYBE_OFFSET(XPVCV, xpv_cur), /* SVt_PVCV */
1036 sizeof(XPVFM) - MAYBE_OFFSET(XPVFM, xpv_cur), /* SVt_PVFM */
1037 sizeof(XPVIO) /* SVt_PVIO */
1042 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
1043 sizeof(XPV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PV */
1044 sizeof(XPVIV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PVIV */
1045 sizeof(XPVNV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PVNV */
1046 sizeof(XPVMG), /* SVt_PVMG */
1047 sizeof(regexp), /* SVt_REGEXP */
1048 sizeof(XPVGV), /* SVt_PVGV */
1049 sizeof(XPVLV), /* SVt_PVLV */
1050 sizeof(XPVAV), /* SVt_PVAV */
1051 sizeof(XPVHV), /* SVt_PVHV */
1052 sizeof(XPVCV), /* SVt_PVCV */
1053 sizeof(XPVFM), /* SVt_PVFM */
1054 sizeof(XPVIO) /* SVt_PVIO */
1059 /* based on Perl_do_dump_pad() - wraps sv_size and adds ADD_ATTR calls for the pad names */
1061 padlist_size(pTHX_ struct state *const st, pPATH, PADLIST *padlist,
1064 dNPathUseParent(NPathArg);
1071 if( 0 && !check_new(st, padlist))
1074 pad_name = MUTABLE_AV(*av_fetch(MUTABLE_AV(padlist), 0, FALSE));
1075 pname = AvARRAY(pad_name);
1077 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
1078 const SV *namesv = pname[ix];
1079 if (namesv && namesv == &PL_sv_undef) {
1083 /* SvFAKE: On a pad name SV, that slot in the frame AV is a REFCNT'ed reference to a lexical from "outside" */
1085 ADD_ATTR(st, NPattr_PADFAKE, SvPVX_const(namesv), ix);
1087 ADD_ATTR(st, NPattr_PADNAME, SvPVX_const(namesv), ix);
1090 ADD_ATTR(st, NPattr_PADTMP, "SVs_PADTMP", ix);
1094 sv_size(aTHX_ st, NPathArg, (SV*)padlist, recurse);
1099 sv_size(pTHX_ struct state *const st, pPATH, const SV * const orig_thing,
1100 const int recurse) {
1101 const SV *thing = orig_thing;
1102 dNPathNodes(3, NPathArg);
1105 if(!check_new(st, orig_thing))
1108 type = SvTYPE(thing);
1109 if (type > SVt_LAST) {
1110 warn("Devel::Size: Unknown variable type: %d encountered\n", type);
1113 NPathPushNode(thing, NPtype_SV);
1114 ADD_SIZE(st, "sv_head", sizeof(SV));
1115 ADD_SIZE(st, "sv_body", body_sizes[type]);
1118 #if (PERL_VERSION < 11)
1119 /* Is it a reference? */
1124 if(recurse && SvROK(thing)) /* XXX maybe don't follow weakrefs */
1125 sv_size(aTHX_ st, (SvWEAKREF(thing) ? NPathLink("weakRV") : NPathLink("RV")), SvRV_const(thing), recurse);
1129 /* Is there anything in the array? */
1130 if (AvMAX(thing) != -1) {
1131 /* an array with 10 slots has AvMax() set to 9 - te 2007-04-22 */
1132 ADD_SIZE(st, "av_max", sizeof(SV *) * (AvMAX(thing) + 1));
1133 dbg_printf(("total_size: %li AvMAX: %li av_len: $i\n", st->total_size, AvMAX(thing), av_len((AV*)thing)));
1135 if (recurse >= st->min_recurse_threshold) {
1136 SSize_t i = AvFILLp(thing) + 1;
1139 if (sv_size(aTHX_ st, NPathLink("AVelem"), AvARRAY(thing)[i], recurse))
1140 ADD_LINK_ATTR(st, NPattr_NOTE, "i", i);
1144 /* Add in the bits on the other side of the beginning */
1146 dbg_printf(("total_size %li, sizeof(SV *) %li, AvARRAY(thing) %li, AvALLOC(thing)%li , sizeof(ptr) %li \n",
1147 st->total_size, sizeof(SV*), AvARRAY(thing), AvALLOC(thing), sizeof( thing )));
1149 /* under Perl 5.8.8 64bit threading, AvARRAY(thing) was a pointer while AvALLOC was 0,
1150 resulting in grossly overstated sized for arrays. Technically, this shouldn't happen... */
1151 if (AvALLOC(thing) != 0) {
1152 ADD_SIZE(st, "AvALLOC", (sizeof(SV *) * (AvARRAY(thing) - AvALLOC(thing))));
1154 #if (PERL_VERSION < 9)
1155 /* Is there something hanging off the arylen element?
1156 Post 5.9.something this is stored in magic, so will be found there,
1157 and Perl_av_arylen_p() takes a non-const AV*, hence compilers rightly
1158 complain about AvARYLEN() passing thing to it. */
1159 sv_size(aTHX_ st, NPathLink("ARYLEN"), AvARYLEN(thing), recurse);
1164 /* Now the array of buckets */
1165 if (HvENAME(thing)) {
1166 ADD_ATTR(st, NPattr_NAME, HvENAME(thing), 0);
1168 ADD_SIZE(st, "hv_max", (sizeof(HE *) * (HvMAX(thing) + 1)));
1169 /* Now walk the bucket chain */
1170 if (HvARRAY(thing)) {
1174 for (cur_bucket = 0; cur_bucket <= HvMAX(thing); cur_bucket++) {
1175 cur_entry = *(HvARRAY(thing) + cur_bucket);
1177 NPathPushNode("he", NPtype_LINK);
1178 NPathPushNode("he+hek", NPtype_NAME);
1179 ADD_SIZE(st, "he", sizeof(HE));
1180 hek_size(aTHX_ st, cur_entry->hent_hek, HvSHAREKEYS(thing), NPathLink("hent_hek"));
1181 if (recurse >= st->min_recurse_threshold) {
1182 if (orig_thing == (SV*)PL_strtab) {
1183 /* For PL_strtab the HeVAL is used as a refcnt */
1184 ADD_SIZE(st, "shared_hek", HeKLEN(cur_entry));
1187 /* I've seen a PL_strtab HeVAL == 0xC and 0x40C etc
1188 * just running perl -Mblib -Mstrict -MDevel::Size=:all -MCarp -e 'warn perl_size()'
1189 * but it seemed like a corruption - it would change come and go with irrelevant code changes.
1190 * so we protect against that here, but I'd like to know the cause.
1192 if (PTR2UV(HeVAL(cur_entry)) > 0xFFF)
1193 sv_size(aTHX_ st, NPathLink("HeVAL"), HeVAL(cur_entry), recurse);
1194 else warn("skipped suspect HeVAL %p", HeVAL(cur_entry));
1197 cur_entry = cur_entry->hent_next;
1201 } /* bucket chain */
1206 /* This direct access is arguably "naughty": */
1207 struct mro_meta *meta = HvAUX(thing)->xhv_mro_meta;
1208 #if PERL_VERSION > 13 || PERL_SUBVERSION > 8 /* XXX plain || seems like a bug */
1210 I32 count = HvAUX(thing)->xhv_name_count;
1213 HEK **names = HvAUX(thing)->xhv_name_u.xhvnameu_names;
1217 hek_size(aTHX_ st, names[count], 1, NPathLink("HvAUXelem"));
1222 hek_size(aTHX_ st, HvNAME_HEK(thing), 1, NPathLink("HvNAME_HEK"));
1225 ADD_SIZE(st, "xpvhv_aux", sizeof(struct xpvhv_aux));
1227 ADD_SIZE(st, "mro_meta", sizeof(struct mro_meta));
1228 sv_size(aTHX_ st, NPathLink("mro_nextmethod"), (SV *)meta->mro_nextmethod, TOTAL_SIZE_RECURSION);
1229 #if PERL_VERSION > 10 || (PERL_VERSION == 10 && PERL_SUBVERSION > 0)
1230 sv_size(aTHX_ st, NPathLink("isa"), (SV *)meta->isa, TOTAL_SIZE_RECURSION);
1232 #if PERL_VERSION > 10
1233 sv_size(aTHX_ st, NPathLink("mro_linear_all"), (SV *)meta->mro_linear_all, TOTAL_SIZE_RECURSION);
1234 sv_size(aTHX_ st, NPathLink("mro_linear_current"), meta->mro_linear_current, TOTAL_SIZE_RECURSION);
1236 sv_size(aTHX_ st, NPathLink("mro_linear_dfs"), (SV *)meta->mro_linear_dfs, TOTAL_SIZE_RECURSION);
1237 sv_size(aTHX_ st, NPathLink("mro_linear_c3"), (SV *)meta->mro_linear_c3, TOTAL_SIZE_RECURSION);
1242 check_new_and_strlen(st, HvNAME_get(thing), NPathLink("HvNAME"));
1248 padlist_size(aTHX_ st, NPathLink("CvPADLIST"), CvPADLIST(thing), recurse);
1249 sv_size(aTHX_ st, NPathLink("CvOUTSIDE"), (SV *)CvOUTSIDE(thing), SOME_RECURSION);
1251 if (st->go_yell && !st->fm_whine) {
1252 carp("Devel::Size: Calculated sizes for FMs are incomplete");
1258 /* not CvSTASH, per https://rt.cpan.org/Ticket/Display.html?id=79366 */
1259 ADD_ATTR(st, NPattr_NAME, CvGV(thing) ? GvNAME(CvGV(thing)) : "UNDEFINED", 0);
1260 sv_size(aTHX_ st, NPathLink("CvGV"), (SV *)CvGV(thing), SOME_RECURSION);
1261 padlist_size(aTHX_ st, NPathLink("CvPADLIST"), CvPADLIST(thing), recurse);
1262 sv_size(aTHX_ st, NPathLink("CvOUTSIDE"), (SV *)CvOUTSIDE(thing), SOME_RECURSION);
1263 if (CvISXSUB(thing)) {
1264 sv_size(aTHX_ st, NPathLink("cv_const_sv"), cv_const_sv((CV *)thing), recurse);
1266 if(1)op_size(aTHX_ CvSTART(thing), st, NPathLinkAndNode("CvSTART", "OPs")); /* XXX ? */
1267 op_size(aTHX_ CvROOT(thing), st, NPathLinkAndNode("CvROOT", "OPs"));
1272 /* Some embedded char pointers */
1273 check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_top_name, NPathLink("xio_top_name"));
1274 check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_fmt_name, NPathLink("xio_fmt_name"));
1275 check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_bottom_name, NPathLink("xio_bottom_name"));
1276 /* Throw the GVs on the list to be walked if they're not-null */
1277 sv_size(aTHX_ st, NPathLink("xio_top_gv"), (SV *)((XPVIO *) SvANY(thing))->xio_top_gv, recurse);
1278 sv_size(aTHX_ st, NPathLink("xio_bottom_gv"), (SV *)((XPVIO *) SvANY(thing))->xio_bottom_gv, recurse);
1279 sv_size(aTHX_ st, NPathLink("xio_fmt_gv"), (SV *)((XPVIO *) SvANY(thing))->xio_fmt_gv, recurse);
1281 /* Only go trotting through the IO structures if they're really
1282 trottable. If USE_PERLIO is defined we can do this. If
1283 not... we can't, so we don't even try */
1285 /* Dig into xio_ifp and xio_ofp here */
1286 warn("Devel::Size: Can't size up perlio layers yet\n");
1291 #if (PERL_VERSION < 9)
1296 if(isGV_with_GP(thing)) {
1298 hek_size(aTHX_ st, GvNAME_HEK(thing), 1, NPathLink("GvNAME_HEK"));
1300 ADD_SIZE(st, "GvNAMELEN", GvNAMELEN(thing));
1302 ADD_ATTR(st, NPattr_NAME, GvNAME_get(thing), 0);
1304 hek_size(aTHX_ st, GvFILE_HEK(thing), 1, NPathLink("GvFILE_HEK"));
1305 #elif defined(GvFILE)
1306 # if !defined(USE_ITHREADS) || (PERL_VERSION > 8 || (PERL_VERSION == 8 && PERL_SUBVERSION > 8))
1307 /* With itreads, before 5.8.9, this can end up pointing to freed memory
1308 if the GV was created in an eval, as GvFILE() points to CopFILE(),
1309 and the relevant COP has been freed on scope cleanup after the eval.
1310 5.8.9 adds a binary compatible fudge that catches the vast majority
1311 of cases. 5.9.something added a proper fix, by converting the GP to
1312 use a shared hash key (porperly reference counted), instead of a
1313 char * (owned by who knows? possibly no-one now) */
1314 check_new_and_strlen(st, GvFILE(thing), NPathLink("GvFILE"));
1317 /* Is there something hanging off the glob? */
1318 if (check_new(st, GvGP(thing))) {
1319 ADD_SIZE(st, "GP", sizeof(GP));
1320 sv_size(aTHX_ st, NPathLink("gp_sv"), (SV *)(GvGP(thing)->gp_sv), recurse);
1321 sv_size(aTHX_ st, NPathLink("gp_av"), (SV *)(GvGP(thing)->gp_av), recurse);
1322 sv_size(aTHX_ st, NPathLink("gp_hv"), (SV *)(GvGP(thing)->gp_hv), recurse);
1323 sv_size(aTHX_ st, NPathLink("gp_cv"), (SV *)(GvGP(thing)->gp_cv), recurse);
1324 sv_size(aTHX_ st, NPathLink("gp_egv"), (SV *)(GvGP(thing)->gp_egv), recurse);
1325 sv_size(aTHX_ st, NPathLink("gp_form"), (SV *)(GvGP(thing)->gp_form), recurse);
1327 #if (PERL_VERSION >= 9)
1331 #if PERL_VERSION <= 8
1339 if(recurse && SvROK(thing))
1340 sv_size(aTHX_ st, NPathLink("RV"), SvRV_const(thing), recurse);
1341 else if (SvIsCOW_shared_hash(thing))
1342 hek_size(aTHX_ st, SvSHARED_HEK_FROM_PV(SvPVX(thing)), 1, NPathLink("SvSHARED_HEK_FROM_PV"));
1344 ADD_SIZE(st, "SvLEN", SvLEN(thing));
1348 SvOOK_offset(thing, len);
1349 ADD_SIZE(st, "SvOOK", len);
1355 if (type >= SVt_PVMG) {
1356 if (SvMAGICAL(thing))
1357 magic_size(aTHX_ thing, st, NPathLink("MG"));
1358 if (SvPAD_OUR(thing) && SvOURSTASH(thing))
1359 sv_size(aTHX_ st, NPathLink("SvOURSTASH"), (SV *)SvOURSTASH(thing), SOME_RECURSION);
1361 sv_size(aTHX_ st, NPathLink("SvSTASH"), (SV *)SvSTASH(thing), SOME_RECURSION);
1368 free_memnode_state(pTHX_ struct state *st)
1370 /* PERL_UNUSED_ARG(aTHX); fails for non-threaded perl */
1371 if (st->node_stream_fh && st->node_stream_name && *st->node_stream_name) {
1372 fprintf(st->node_stream_fh, "E %d %f %s\n",
1373 getpid(), gettimeofday_nv()-st->start_time_nv, "unnamed");
1374 if (*st->node_stream_name == '|') {
1375 if (pclose(st->node_stream_fh))
1376 warn("%s exited with an error status\n", st->node_stream_name);
1379 if (fclose(st->node_stream_fh))
1380 warn("Error closing %s: %s\n", st->node_stream_name, strerror(errno));
1385 static struct state *
1391 Newxz(st, 1, struct state);
1393 st->min_recurse_threshold = TOTAL_SIZE_RECURSION;
1394 if (NULL != (warn_flag = perl_get_sv("Devel::Size::warn", FALSE))) {
1395 st->dangle_whine = st->go_yell = SvIV(warn_flag) ? TRUE : FALSE;
1397 if (NULL != (warn_flag = perl_get_sv("Devel::Size::dangle", FALSE))) {
1398 st->dangle_whine = SvIV(warn_flag) ? TRUE : FALSE;
1400 st->start_time_nv = gettimeofday_nv();
1401 check_new(st, &PL_sv_undef);
1402 check_new(st, &PL_sv_no);
1403 check_new(st, &PL_sv_yes);
1404 #if PERL_VERSION > 8 || (PERL_VERSION == 8 && PERL_SUBVERSION > 0)
1405 check_new(st, &PL_sv_placeholder);
1408 #ifdef PATH_TRACKING
1409 /* XXX quick hack */
1410 st->node_stream_name = getenv("SIZEME");
1411 if (st->node_stream_name) {
1412 if (*st->node_stream_name) {
1413 if (*st->node_stream_name == '|')
1414 st->node_stream_fh = popen(st->node_stream_name+1, "w");
1416 st->node_stream_fh = fopen(st->node_stream_name, "wb");
1417 if (!st->node_stream_fh)
1418 croak("Can't open '%s' for writing: %s", st->node_stream_name, strerror(errno));
1419 if(0)setlinebuf(st->node_stream_fh); /* XXX temporary for debugging */
1420 st->add_attr_cb = np_stream_node_path_info;
1421 fprintf(st->node_stream_fh, "S %d %f %s\n",
1422 getpid(), st->start_time_nv, "unnamed");
1425 st->add_attr_cb = np_dump_node_path_info;
1427 st->free_state_cb = free_memnode_state;
1433 /* XXX based on S_visit() in sv.c */
1435 unseen_sv_size(pTHX_ struct state *st, pPATH)
1439 dNPathNodes(1, NPathArg);
1441 NPathPushNode("unseen", NPtype_NAME);
1443 /* by this point we should have visited all the SVs
1444 * so now we'll run through all the SVs via the arenas
1445 * in order to find any that we've missed for some reason.
1446 * Once the rest of the code is finding ALL the SVs then any
1447 * found here will be leaks.
1449 for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) {
1450 const SV * const svend = &sva[SvREFCNT(sva)];
1452 for (sv = sva + 1; sv < svend; ++sv) {
1453 if (SvTYPE(sv) != (svtype)SVTYPEMASK && SvREFCNT(sv)) {
1454 sv_size(aTHX_ st, NPathLink("arena"), sv, TOTAL_SIZE_RECURSION);
1456 else if (check_new(st, sv)) { /* sanity check */
1458 warn("unseen_sv_size encountered freed SV unexpectedly"); /* XXX warn uses an SV, I think */
1466 madprop_size(pTHX_ struct state *const st, pPath, MADPROP *prop)
1468 dPathNodes(2, NPathArg);
1469 if (!check_new(st, prop))
1471 NPathPushNode("madprop_size", NPtype_NAME);
1472 ADD_SIZE(st, "MADPROP", sizeof(MADPROP));
1474 NPathPushNode("val");
1475 ADD_SIZE(st, "val", prop->mad_val);
1477 madprop_size(aTHX_ st, NPathLink("mad_next"), prop->mad_next);
1482 parser_size(pTHX_ struct state *const st, pPATH, yy_parser *parser)
1484 dNPathNodes(2, NPathArg);
1485 if (!check_new(st, parser))
1487 NPathPushNode("parser_size", NPtype_NAME);
1488 ADD_SIZE(st, "yy_parser", sizeof(yy_parser));
1490 NPathPushNode("stack", NPtype_NAME);
1492 //warn("total: %u", parser->stack_size);
1493 //warn("foo: %u", parser->ps - parser->stack);
1494 ADD_SIZE(st, "stack_frames", parser->stack_size * sizeof(yy_stack_frame));
1495 for (ps = parser->stack; ps <= parser->ps; ps++) {
1496 if (sv_size(aTHX_ st, NPathLink("compcv"), (SV*)ps->compcv, TOTAL_SIZE_RECURSION))
1497 ADD_LINK_ATTR(st, NPattr_NOTE, "i", ps - parser->ps);
1501 sv_size(aTHX_ st, NPathLink("lex_repl"), (SV*)parser->lex_repl, TOTAL_SIZE_RECURSION);
1502 sv_size(aTHX_ st, NPathLink("lex_stuff"), (SV*)parser->lex_stuff, TOTAL_SIZE_RECURSION);
1503 sv_size(aTHX_ st, NPathLink("linestr"), (SV*)parser->linestr, TOTAL_SIZE_RECURSION);
1504 sv_size(aTHX_ st, NPathLink("in_my_stash"), (SV*)parser->in_my_stash, TOTAL_SIZE_RECURSION);
1505 //sv_size(aTHX_ st, NPathLink("rsfp"), parser->rsfp, TOTAL_SIZE_RECURSION);
1506 sv_size(aTHX_ st, NPathLink("rsfp_filters"), (SV*)parser->rsfp_filters, TOTAL_SIZE_RECURSION);
1508 sv_size(aTHX_ st, NPathLink("endwhite"), parser->endwhite, TOTAL_SIZE_RECURSION);
1509 sv_size(aTHX_ st, NPathLink("nextwhite"), parser->nextwhite, TOTAL_SIZE_RECURSION);
1510 sv_size(aTHX_ st, NPathLink("skipwhite"), parser->skipwhite, TOTAL_SIZE_RECURSION);
1511 sv_size(aTHX_ st, NPathLink("thisclose"), parser->thisclose, TOTAL_SIZE_RECURSION);
1512 madprop_size(aTHX_ st, NPathLink("thismad"), parser->thismad);
1513 sv_size(aTHX_ st, NPathLink("thisopen"), parser->thisopen, TOTAL_SIZE_RECURSION);
1514 sv_size(aTHX_ st, NPathLink("thisstuff"), parser->thisstuff, TOTAL_SIZE_RECURSION);
1515 sv_size(aTHX_ st, NPathLink("thistoken"), parser->thistoken, TOTAL_SIZE_RECURSION);
1516 sv_size(aTHX_ st, NPathLink("thiswhite"), parser->thiswhite, TOTAL_SIZE_RECURSION);
1518 op_size_class(aTHX_ (OP*)parser->saved_curcop, OPc_COP, 0,
1519 st, NPathLink("saved_curcop"));
1521 if (parser->old_parser)
1522 parser_size(aTHX_ st, NPathLink("old_parser"), parser->old_parser);
1526 perl_size(pTHX_ struct state *const st, pPATH)
1528 dNPathNodes(3, NPathArg);
1530 /* if(!check_new(st, interp)) return; */
1531 NPathPushNode("perl", NPtype_NAME);
1532 #if defined(MULTIPLICITY)
1533 ADD_SIZE(st, "PerlInterpreter", sizeof(PerlInterpreter));
1539 * unknown <== = O/S Heap size - perl - free_malloc_space
1541 /* start with PL_defstash to get everything reachable from \%main:: */
1542 sv_size(aTHX_ st, NPathLink("PL_defstash"), (SV*)PL_defstash, TOTAL_SIZE_RECURSION);
1544 NPathPushNode("others", NPtype_NAME); /* group these (typically much smaller) items */
1545 sv_size(aTHX_ st, NPathLink("PL_defgv"), (SV*)PL_defgv, TOTAL_SIZE_RECURSION);
1546 sv_size(aTHX_ st, NPathLink("PL_incgv"), (SV*)PL_incgv, TOTAL_SIZE_RECURSION);
1547 sv_size(aTHX_ st, NPathLink("PL_rs"), (SV*)PL_rs, TOTAL_SIZE_RECURSION);
1548 sv_size(aTHX_ st, NPathLink("PL_fdpid"), (SV*)PL_fdpid, TOTAL_SIZE_RECURSION);
1549 sv_size(aTHX_ st, NPathLink("PL_modglobal"), (SV*)PL_modglobal, TOTAL_SIZE_RECURSION);
1550 sv_size(aTHX_ st, NPathLink("PL_errors"), (SV*)PL_errors, TOTAL_SIZE_RECURSION);
1551 sv_size(aTHX_ st, NPathLink("PL_stashcache"), (SV*)PL_stashcache, TOTAL_SIZE_RECURSION);
1552 sv_size(aTHX_ st, NPathLink("PL_patchlevel"), (SV*)PL_patchlevel, TOTAL_SIZE_RECURSION);
1553 sv_size(aTHX_ st, NPathLink("PL_apiversion"), (SV*)PL_apiversion, TOTAL_SIZE_RECURSION);
1554 sv_size(aTHX_ st, NPathLink("PL_registered_mros"), (SV*)PL_registered_mros, TOTAL_SIZE_RECURSION);
1556 sv_size(aTHX_ st, NPathLink("PL_regex_padav"), (SV*)PL_regex_padav, TOTAL_SIZE_RECURSION);
1558 sv_size(aTHX_ st, NPathLink("PL_warnhook"), (SV*)PL_warnhook, TOTAL_SIZE_RECURSION);
1559 sv_size(aTHX_ st, NPathLink("PL_diehook"), (SV*)PL_diehook, TOTAL_SIZE_RECURSION);
1560 sv_size(aTHX_ st, NPathLink("PL_endav"), (SV*)PL_endav, TOTAL_SIZE_RECURSION);
1561 sv_size(aTHX_ st, NPathLink("PL_main_cv"), (SV*)PL_main_cv, TOTAL_SIZE_RECURSION);
1562 sv_size(aTHX_ st, NPathLink("PL_main_root"), (SV*)PL_main_root, TOTAL_SIZE_RECURSION);
1563 sv_size(aTHX_ st, NPathLink("PL_main_start"), (SV*)PL_main_start, TOTAL_SIZE_RECURSION);
1564 sv_size(aTHX_ st, NPathLink("PL_envgv"), (SV*)PL_envgv, TOTAL_SIZE_RECURSION);
1565 sv_size(aTHX_ st, NPathLink("PL_hintgv"), (SV*)PL_hintgv, TOTAL_SIZE_RECURSION);
1566 sv_size(aTHX_ st, NPathLink("PL_e_script"), (SV*)PL_e_script, TOTAL_SIZE_RECURSION);
1567 sv_size(aTHX_ st, NPathLink("PL_encoding"), (SV*)PL_encoding, TOTAL_SIZE_RECURSION);
1568 sv_size(aTHX_ st, NPathLink("PL_ofsgv"), (SV*)PL_ofsgv, TOTAL_SIZE_RECURSION);
1569 sv_size(aTHX_ st, NPathLink("PL_argvout_stack"), (SV*)PL_argvout_stack, TOTAL_SIZE_RECURSION);
1570 sv_size(aTHX_ st, NPathLink("PL_beginav"), (SV*)PL_beginav, TOTAL_SIZE_RECURSION);
1571 sv_size(aTHX_ st, NPathLink("PL_beginav_save"), (SV*)PL_beginav_save, TOTAL_SIZE_RECURSION);
1572 sv_size(aTHX_ st, NPathLink("PL_checkav_save"), (SV*)PL_checkav_save, TOTAL_SIZE_RECURSION);
1573 sv_size(aTHX_ st, NPathLink("PL_unitcheckav"), (SV*)PL_unitcheckav, TOTAL_SIZE_RECURSION);
1574 sv_size(aTHX_ st, NPathLink("PL_unitcheckav_save"), (SV*)PL_unitcheckav_save, TOTAL_SIZE_RECURSION);
1575 sv_size(aTHX_ st, NPathLink("PL_endav"), (SV*)PL_endav, TOTAL_SIZE_RECURSION);
1576 sv_size(aTHX_ st, NPathLink("PL_checkav"), (SV*)PL_checkav, TOTAL_SIZE_RECURSION);
1577 sv_size(aTHX_ st, NPathLink("PL_initav"), (SV*)PL_initav, TOTAL_SIZE_RECURSION);
1578 sv_size(aTHX_ st, NPathLink("PL_isarev"), (SV*)PL_isarev, TOTAL_SIZE_RECURSION);
1579 sv_size(aTHX_ st, NPathLink("PL_fdpid"), (SV*)PL_fdpid, TOTAL_SIZE_RECURSION);
1580 sv_size(aTHX_ st, NPathLink("PL_preambleav"), (SV*)PL_preambleav, TOTAL_SIZE_RECURSION);
1581 sv_size(aTHX_ st, NPathLink("PL_ors_sv"), (SV*)PL_ors_sv, TOTAL_SIZE_RECURSION);
1582 sv_size(aTHX_ st, NPathLink("PL_modglobal"), (SV*)PL_modglobal, TOTAL_SIZE_RECURSION);
1583 sv_size(aTHX_ st, NPathLink("PL_custom_op_names"), (SV*)PL_custom_op_names, TOTAL_SIZE_RECURSION);
1584 sv_size(aTHX_ st, NPathLink("PL_custom_op_descs"), (SV*)PL_custom_op_descs, TOTAL_SIZE_RECURSION);
1585 sv_size(aTHX_ st, NPathLink("PL_custom_ops"), (SV*)PL_custom_ops, TOTAL_SIZE_RECURSION);
1586 sv_size(aTHX_ st, NPathLink("PL_compcv"), (SV*)PL_compcv, TOTAL_SIZE_RECURSION);
1587 sv_size(aTHX_ st, NPathLink("PL_DBcv"), (SV*)PL_DBcv, TOTAL_SIZE_RECURSION);
1588 #ifdef PERL_USES_PL_PIDSTATUS
1589 sv_size(aTHX_ st, NPathLink("PL_pidstatus"), (SV*)PL_pidstatus, TOTAL_SIZE_RECURSION);
1591 sv_size(aTHX_ st, NPathLink("PL_subname"), (SV*)PL_subname, TOTAL_SIZE_RECURSION);
1592 #ifdef USE_LOCALE_NUMERIC
1593 sv_size(aTHX_ st, NPathLink("PL_numeric_radix_sv"), (SV*)PL_numeric_radix_sv, TOTAL_SIZE_RECURSION);
1594 check_new_and_strlen(st, PL_numeric_name, NPathLink("PL_numeric_name"));
1596 #ifdef USE_LOCALE_COLLATE
1597 check_new_and_strlen(st, PL_collation_name, NPathLink("PL_collation_name"));
1599 check_new_and_strlen(st, PL_origfilename, NPathLink("PL_origfilename"));
1600 check_new_and_strlen(st, PL_inplace, NPathLink("PL_inplace"));
1601 check_new_and_strlen(st, PL_osname, NPathLink("PL_osname"));
1602 if (PL_op_mask && check_new(st, PL_op_mask))
1603 ADD_SIZE(st, "PL_op_mask", PL_maxo);
1604 if (PL_exitlistlen && check_new(st, PL_exitlist))
1605 ADD_SIZE(st, "PL_exitlist", (PL_exitlistlen * sizeof(PerlExitListEntry *))
1606 + (PL_exitlistlen * sizeof(PerlExitListEntry)));
1607 #ifdef PERL_IMPLICIT_CONTEXT
1608 if (PL_my_cxt_size && check_new(st, PL_my_cxt_list)) {
1609 ADD_SIZE(st, "PL_my_cxt_list", (PL_my_cxt_size * sizeof(void *)));
1610 #ifdef PERL_GLOBAL_STRUCT_PRIVATE
1611 ADD_SIZE(st, "PL_my_cxt_keys", (PL_my_cxt_size * sizeof(char *)));
1615 /* TODO PL_stashpad */
1616 op_size_class(aTHX_ (OP*)&PL_compiling, OPc_COP, 1, st, NPathLink("PL_compiling"));
1617 op_size_class(aTHX_ (OP*)PL_curcopdb, OPc_COP, 0, st, NPathLink("PL_curcopdb"));
1619 parser_size(aTHX_ st, NPathLink("PL_parser"), PL_parser);
1620 /* TODO stacks: cur, main, tmps, mark, scope, save */
1621 /* TODO PL_exitlist */
1622 /* TODO PL_reentrant_buffers etc */
1624 /* TODO PerlIO? PL_known_layers PL_def_layerlist PL_perlio_fd_refcnt etc */
1626 /* TODO anything missed? */
1628 /* --- by this point we should have seen all reachable SVs --- */
1630 /* in theory we shouldn't have any elements in PL_strtab that haven't been seen yet */
1631 sv_size(aTHX_ st, NPathLink("PL_strtab-unseen"), (SV*)PL_strtab, TOTAL_SIZE_RECURSION);
1633 /* unused space in sv head arenas */
1637 # define SvARENA_CHAIN(sv) SvANY(sv) /* XXX breaks encapsulation*/
1638 while ((p = MUTABLE_SV(SvARENA_CHAIN(p)))) {
1639 if (!check_new(st, p)) /* sanity check */
1640 warn("Free'd SV head unexpectedly already seen");
1643 NPathPushNode("unused_sv_heads", NPtype_NAME);
1644 ADD_SIZE(st, "sv", free_heads * sizeof(SV));
1647 /* XXX iterate over bodies_by_type and crawl the free chains for each */
1649 /* iterate over all SVs to find any we've not accounted for yet */
1650 /* once the code above is visiting all SVs, any found here have been leaked */
1651 unseen_sv_size(aTHX_ st, NPathLink("unaccounted"));
1655 MODULE = Devel::SizeMe PACKAGE = Devel::SizeMe
1663 total_size = TOTAL_SIZE_RECURSION
1666 SV *thing = orig_thing;
1667 struct state *st = new_state(aTHX);
1669 /* If they passed us a reference then dereference it. This is the
1670 only way we can check the sizes of arrays and hashes */
1672 thing = SvRV(thing);
1675 sv_size(aTHX_ st, NULL, thing, ix);
1676 RETVAL = st->total_size;
1677 free_state(aTHX_ st);
1686 /* just the current perl interpreter */
1687 struct state *st = new_state(aTHX);
1688 st->min_recurse_threshold = NO_RECURSION; /* so always recurse */
1689 perl_size(aTHX_ st, NULL);
1690 RETVAL = st->total_size;
1691 free_state(aTHX_ st);
1700 /* the current perl interpreter plus malloc, in the context of total heap size */
1701 # ifdef _MALLOC_MALLOC_H_ /* OSX. Now sure where else mstats is available */
1705 /* some systems have the SVID2/XPG mallinfo structure and function */
1706 struct mstats ms = mstats(); /* mstats() first */
1708 struct state *st = new_state(aTHX);
1709 dNPathNodes(1, NULL);
1710 NPathPushNode("heap", NPtype_NAME);
1712 st->min_recurse_threshold = NO_RECURSION; /* so always recurse */
1714 perl_size(aTHX_ st, NPathLink("perl_interp"));
1716 NPathSetNode("free_malloc_space", NPtype_NAME);
1717 ADD_SIZE(st, "bytes_free", ms.bytes_free);
1718 ADD_ATTR(st, NPattr_NOTE, "bytes_total", ms.bytes_total);
1719 ADD_ATTR(st, NPattr_NOTE, "bytes_used", ms.bytes_used);
1720 ADD_ATTR(st, NPattr_NOTE, "chunks_used", ms.chunks_used);
1721 ADD_ATTR(st, NPattr_NOTE, "chunks_free", ms.chunks_free);
1722 /* TODO get heap size from OS and add a node: unknown = heapsize - perl - ms.bytes_free */
1723 /* for now we use bytes_total as an approximation */
1724 NPathSetNode("unknown", NPtype_NAME);
1725 ADD_SIZE(st, "unknown", ms.bytes_total - st->total_size);
1730 RETVAL = st->total_size;
1731 free_state(aTHX_ st);