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 ADD_ATTR(st, NPattr_NOTE, "av_len", av_len((AV*)thing));
1134 dbg_printf(("total_size: %li AvMAX: %li av_len: $i\n", st->total_size, AvMAX(thing), av_len((AV*)thing)));
1136 if (recurse >= st->min_recurse_threshold) {
1137 SSize_t i = AvFILLp(thing) + 1;
1140 if (sv_size(aTHX_ st, NPathLink("AVelem"), AvARRAY(thing)[i], recurse))
1141 ADD_LINK_ATTR(st, NPattr_NOTE, "i", i);
1145 /* Add in the bits on the other side of the beginning */
1147 dbg_printf(("total_size %li, sizeof(SV *) %li, AvARRAY(thing) %li, AvALLOC(thing)%li , sizeof(ptr) %li \n",
1148 st->total_size, sizeof(SV*), AvARRAY(thing), AvALLOC(thing), sizeof( thing )));
1150 /* under Perl 5.8.8 64bit threading, AvARRAY(thing) was a pointer while AvALLOC was 0,
1151 resulting in grossly overstated sized for arrays. Technically, this shouldn't happen... */
1152 if (AvALLOC(thing) != 0) {
1153 ADD_SIZE(st, "AvALLOC", (sizeof(SV *) * (AvARRAY(thing) - AvALLOC(thing))));
1155 #if (PERL_VERSION < 9)
1156 /* Is there something hanging off the arylen element?
1157 Post 5.9.something this is stored in magic, so will be found there,
1158 and Perl_av_arylen_p() takes a non-const AV*, hence compilers rightly
1159 complain about AvARYLEN() passing thing to it. */
1160 sv_size(aTHX_ st, NPathLink("ARYLEN"), AvARYLEN(thing), recurse);
1165 /* Now the array of buckets */
1166 if (HvENAME(thing)) {
1167 ADD_ATTR(st, NPattr_NAME, HvENAME(thing), 0);
1169 ADD_SIZE(st, "hv_max", (sizeof(HE *) * (HvMAX(thing) + 1)));
1170 /* Now walk the bucket chain */
1171 if (HvARRAY(thing)) {
1175 for (cur_bucket = 0; cur_bucket <= HvMAX(thing); cur_bucket++) {
1176 cur_entry = *(HvARRAY(thing) + cur_bucket);
1178 NPathPushNode("he", NPtype_LINK);
1179 NPathPushNode("he+hek", NPtype_NAME);
1180 ADD_SIZE(st, "he", sizeof(HE));
1181 hek_size(aTHX_ st, cur_entry->hent_hek, HvSHAREKEYS(thing), NPathLink("hent_hek"));
1182 if (recurse >= st->min_recurse_threshold) {
1183 if (orig_thing == (SV*)PL_strtab) {
1184 /* For PL_strtab the HeVAL is used as a refcnt */
1185 ADD_SIZE(st, "shared_hek", HeKLEN(cur_entry));
1188 /* I've seen a PL_strtab HeVAL == 0xC and 0x40C etc
1189 * just running perl -Mblib -Mstrict -MDevel::Size=:all -MCarp -e 'warn perl_size()'
1190 * but it seemed like a corruption - it would change come and go with irrelevant code changes.
1191 * so we protect against that here, but I'd like to know the cause.
1193 if (PTR2UV(HeVAL(cur_entry)) > 0xFFF)
1194 sv_size(aTHX_ st, NPathLink("HeVAL"), HeVAL(cur_entry), recurse);
1195 else warn("skipped suspect HeVAL %p", HeVAL(cur_entry));
1198 cur_entry = cur_entry->hent_next;
1202 } /* bucket chain */
1207 /* This direct access is arguably "naughty": */
1208 struct mro_meta *meta = HvAUX(thing)->xhv_mro_meta;
1209 #if PERL_VERSION > 13 || PERL_SUBVERSION > 8 /* XXX plain || seems like a bug */
1211 I32 count = HvAUX(thing)->xhv_name_count;
1214 HEK **names = HvAUX(thing)->xhv_name_u.xhvnameu_names;
1218 hek_size(aTHX_ st, names[count], 1, NPathLink("HvAUXelem"));
1223 hek_size(aTHX_ st, HvNAME_HEK(thing), 1, NPathLink("HvNAME_HEK"));
1226 ADD_SIZE(st, "xpvhv_aux", sizeof(struct xpvhv_aux));
1228 ADD_SIZE(st, "mro_meta", sizeof(struct mro_meta));
1229 sv_size(aTHX_ st, NPathLink("mro_nextmethod"), (SV *)meta->mro_nextmethod, TOTAL_SIZE_RECURSION);
1230 #if PERL_VERSION > 10 || (PERL_VERSION == 10 && PERL_SUBVERSION > 0)
1231 sv_size(aTHX_ st, NPathLink("isa"), (SV *)meta->isa, TOTAL_SIZE_RECURSION);
1233 #if PERL_VERSION > 10
1234 sv_size(aTHX_ st, NPathLink("mro_linear_all"), (SV *)meta->mro_linear_all, TOTAL_SIZE_RECURSION);
1235 sv_size(aTHX_ st, NPathLink("mro_linear_current"), meta->mro_linear_current, TOTAL_SIZE_RECURSION);
1237 sv_size(aTHX_ st, NPathLink("mro_linear_dfs"), (SV *)meta->mro_linear_dfs, TOTAL_SIZE_RECURSION);
1238 sv_size(aTHX_ st, NPathLink("mro_linear_c3"), (SV *)meta->mro_linear_c3, TOTAL_SIZE_RECURSION);
1243 check_new_and_strlen(st, HvNAME_get(thing), NPathLink("HvNAME"));
1249 padlist_size(aTHX_ st, NPathLink("CvPADLIST"), CvPADLIST(thing), recurse);
1250 sv_size(aTHX_ st, NPathLink("CvOUTSIDE"), (SV *)CvOUTSIDE(thing), SOME_RECURSION);
1252 if (st->go_yell && !st->fm_whine) {
1253 carp("Devel::Size: Calculated sizes for FMs are incomplete");
1259 /* not CvSTASH, per https://rt.cpan.org/Ticket/Display.html?id=79366 */
1260 ADD_ATTR(st, NPattr_NAME, CvGV(thing) ? GvNAME(CvGV(thing)) : "UNDEFINED", 0);
1261 sv_size(aTHX_ st, NPathLink("CvGV"), (SV *)CvGV(thing), SOME_RECURSION);
1262 padlist_size(aTHX_ st, NPathLink("CvPADLIST"), CvPADLIST(thing), recurse);
1263 sv_size(aTHX_ st, NPathLink("CvOUTSIDE"), (SV *)CvOUTSIDE(thing), SOME_RECURSION);
1264 if (CvISXSUB(thing)) {
1265 sv_size(aTHX_ st, NPathLink("cv_const_sv"), cv_const_sv((CV *)thing), recurse);
1267 if(1)op_size(aTHX_ CvSTART(thing), st, NPathLinkAndNode("CvSTART", "OPs")); /* XXX ? */
1268 op_size(aTHX_ CvROOT(thing), st, NPathLinkAndNode("CvROOT", "OPs"));
1273 /* Some embedded char pointers */
1274 check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_top_name, NPathLink("xio_top_name"));
1275 check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_fmt_name, NPathLink("xio_fmt_name"));
1276 check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_bottom_name, NPathLink("xio_bottom_name"));
1277 /* Throw the GVs on the list to be walked if they're not-null */
1278 sv_size(aTHX_ st, NPathLink("xio_top_gv"), (SV *)((XPVIO *) SvANY(thing))->xio_top_gv, recurse);
1279 sv_size(aTHX_ st, NPathLink("xio_bottom_gv"), (SV *)((XPVIO *) SvANY(thing))->xio_bottom_gv, recurse);
1280 sv_size(aTHX_ st, NPathLink("xio_fmt_gv"), (SV *)((XPVIO *) SvANY(thing))->xio_fmt_gv, recurse);
1282 /* Only go trotting through the IO structures if they're really
1283 trottable. If USE_PERLIO is defined we can do this. If
1284 not... we can't, so we don't even try */
1286 /* Dig into xio_ifp and xio_ofp here */
1287 warn("Devel::Size: Can't size up perlio layers yet\n");
1292 #if (PERL_VERSION < 9)
1297 if(isGV_with_GP(thing)) {
1299 hek_size(aTHX_ st, GvNAME_HEK(thing), 1, NPathLink("GvNAME_HEK"));
1301 ADD_SIZE(st, "GvNAMELEN", GvNAMELEN(thing));
1303 ADD_ATTR(st, NPattr_NAME, GvNAME_get(thing), 0);
1305 hek_size(aTHX_ st, GvFILE_HEK(thing), 1, NPathLink("GvFILE_HEK"));
1306 #elif defined(GvFILE)
1307 # if !defined(USE_ITHREADS) || (PERL_VERSION > 8 || (PERL_VERSION == 8 && PERL_SUBVERSION > 8))
1308 /* With itreads, before 5.8.9, this can end up pointing to freed memory
1309 if the GV was created in an eval, as GvFILE() points to CopFILE(),
1310 and the relevant COP has been freed on scope cleanup after the eval.
1311 5.8.9 adds a binary compatible fudge that catches the vast majority
1312 of cases. 5.9.something added a proper fix, by converting the GP to
1313 use a shared hash key (porperly reference counted), instead of a
1314 char * (owned by who knows? possibly no-one now) */
1315 check_new_and_strlen(st, GvFILE(thing), NPathLink("GvFILE"));
1318 /* Is there something hanging off the glob? */
1319 if (check_new(st, GvGP(thing))) {
1320 ADD_SIZE(st, "GP", sizeof(GP));
1321 sv_size(aTHX_ st, NPathLink("gp_sv"), (SV *)(GvGP(thing)->gp_sv), recurse);
1322 sv_size(aTHX_ st, NPathLink("gp_av"), (SV *)(GvGP(thing)->gp_av), recurse);
1323 sv_size(aTHX_ st, NPathLink("gp_hv"), (SV *)(GvGP(thing)->gp_hv), recurse);
1324 sv_size(aTHX_ st, NPathLink("gp_cv"), (SV *)(GvGP(thing)->gp_cv), recurse);
1325 sv_size(aTHX_ st, NPathLink("gp_egv"), (SV *)(GvGP(thing)->gp_egv), recurse);
1326 sv_size(aTHX_ st, NPathLink("gp_form"), (SV *)(GvGP(thing)->gp_form), recurse);
1328 #if (PERL_VERSION >= 9)
1332 #if PERL_VERSION <= 8
1340 if(recurse && SvROK(thing))
1341 sv_size(aTHX_ st, NPathLink("RV"), SvRV_const(thing), recurse);
1342 else if (SvIsCOW_shared_hash(thing))
1343 hek_size(aTHX_ st, SvSHARED_HEK_FROM_PV(SvPVX(thing)), 1, NPathLink("SvSHARED_HEK_FROM_PV"));
1345 ADD_SIZE(st, "SvLEN", SvLEN(thing));
1349 SvOOK_offset(thing, len);
1350 ADD_SIZE(st, "SvOOK", len);
1356 if (type >= SVt_PVMG) {
1357 if (SvMAGICAL(thing))
1358 magic_size(aTHX_ thing, st, NPathLink("MG"));
1359 if (SvPAD_OUR(thing) && SvOURSTASH(thing))
1360 sv_size(aTHX_ st, NPathLink("SvOURSTASH"), (SV *)SvOURSTASH(thing), SOME_RECURSION);
1362 sv_size(aTHX_ st, NPathLink("SvSTASH"), (SV *)SvSTASH(thing), SOME_RECURSION);
1369 free_memnode_state(pTHX_ struct state *st)
1371 /* PERL_UNUSED_ARG(aTHX); fails for non-threaded perl */
1372 if (st->node_stream_fh && st->node_stream_name && *st->node_stream_name) {
1373 fprintf(st->node_stream_fh, "E %d %f %s\n",
1374 getpid(), gettimeofday_nv()-st->start_time_nv, "unnamed");
1375 if (*st->node_stream_name == '|') {
1376 if (pclose(st->node_stream_fh))
1377 warn("%s exited with an error status\n", st->node_stream_name);
1380 if (fclose(st->node_stream_fh))
1381 warn("Error closing %s: %s\n", st->node_stream_name, strerror(errno));
1386 static struct state *
1392 Newxz(st, 1, struct state);
1394 st->min_recurse_threshold = TOTAL_SIZE_RECURSION;
1395 if (NULL != (warn_flag = perl_get_sv("Devel::Size::warn", FALSE))) {
1396 st->dangle_whine = st->go_yell = SvIV(warn_flag) ? TRUE : FALSE;
1398 if (NULL != (warn_flag = perl_get_sv("Devel::Size::dangle", FALSE))) {
1399 st->dangle_whine = SvIV(warn_flag) ? TRUE : FALSE;
1401 st->start_time_nv = gettimeofday_nv();
1402 check_new(st, &PL_sv_undef);
1403 check_new(st, &PL_sv_no);
1404 check_new(st, &PL_sv_yes);
1405 #if PERL_VERSION > 8 || (PERL_VERSION == 8 && PERL_SUBVERSION > 0)
1406 check_new(st, &PL_sv_placeholder);
1409 #ifdef PATH_TRACKING
1410 /* XXX quick hack */
1411 st->node_stream_name = getenv("SIZEME");
1412 if (st->node_stream_name) {
1413 if (*st->node_stream_name) {
1414 if (*st->node_stream_name == '|')
1415 st->node_stream_fh = popen(st->node_stream_name+1, "w");
1417 st->node_stream_fh = fopen(st->node_stream_name, "wb");
1418 if (!st->node_stream_fh)
1419 croak("Can't open '%s' for writing: %s", st->node_stream_name, strerror(errno));
1420 if(0)setlinebuf(st->node_stream_fh); /* XXX temporary for debugging */
1421 st->add_attr_cb = np_stream_node_path_info;
1422 fprintf(st->node_stream_fh, "S %d %f %s\n",
1423 getpid(), st->start_time_nv, "unnamed");
1426 st->add_attr_cb = np_dump_node_path_info;
1428 st->free_state_cb = free_memnode_state;
1434 /* XXX based on S_visit() in sv.c */
1436 unseen_sv_size(pTHX_ struct state *st, pPATH)
1440 dNPathNodes(1, NPathArg);
1442 NPathPushNode("unseen", NPtype_NAME);
1444 /* by this point we should have visited all the SVs
1445 * so now we'll run through all the SVs via the arenas
1446 * in order to find any that we've missed for some reason.
1447 * Once the rest of the code is finding ALL the SVs then any
1448 * found here will be leaks.
1450 for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) {
1451 const SV * const svend = &sva[SvREFCNT(sva)];
1453 for (sv = sva + 1; sv < svend; ++sv) {
1454 if (SvTYPE(sv) != (svtype)SVTYPEMASK && SvREFCNT(sv)) {
1455 sv_size(aTHX_ st, NPathLink("arena"), sv, TOTAL_SIZE_RECURSION);
1457 else if (check_new(st, sv)) { /* sanity check */
1459 warn("unseen_sv_size encountered freed SV unexpectedly"); /* XXX warn uses an SV, I think */
1467 madprop_size(pTHX_ struct state *const st, pPath, MADPROP *prop)
1469 dPathNodes(2, NPathArg);
1470 if (!check_new(st, prop))
1472 NPathPushNode("madprop_size", NPtype_NAME);
1473 ADD_SIZE(st, "MADPROP", sizeof(MADPROP));
1475 NPathPushNode("val");
1476 ADD_SIZE(st, "val", prop->mad_val);
1478 madprop_size(aTHX_ st, NPathLink("mad_next"), prop->mad_next);
1483 parser_size(pTHX_ struct state *const st, pPATH, yy_parser *parser)
1485 dNPathNodes(2, NPathArg);
1486 if (!check_new(st, parser))
1488 NPathPushNode("parser_size", NPtype_NAME);
1489 ADD_SIZE(st, "yy_parser", sizeof(yy_parser));
1491 NPathPushNode("stack", NPtype_NAME);
1493 //warn("total: %u", parser->stack_size);
1494 //warn("foo: %u", parser->ps - parser->stack);
1495 ADD_SIZE(st, "stack_frames", parser->stack_size * sizeof(yy_stack_frame));
1496 for (ps = parser->stack; ps <= parser->ps; ps++) {
1497 if (sv_size(aTHX_ st, NPathLink("compcv"), (SV*)ps->compcv, TOTAL_SIZE_RECURSION))
1498 ADD_LINK_ATTR(st, NPattr_NOTE, "i", ps - parser->ps);
1502 sv_size(aTHX_ st, NPathLink("lex_repl"), (SV*)parser->lex_repl, TOTAL_SIZE_RECURSION);
1503 sv_size(aTHX_ st, NPathLink("lex_stuff"), (SV*)parser->lex_stuff, TOTAL_SIZE_RECURSION);
1504 sv_size(aTHX_ st, NPathLink("linestr"), (SV*)parser->linestr, TOTAL_SIZE_RECURSION);
1505 sv_size(aTHX_ st, NPathLink("in_my_stash"), (SV*)parser->in_my_stash, TOTAL_SIZE_RECURSION);
1506 //sv_size(aTHX_ st, NPathLink("rsfp"), parser->rsfp, TOTAL_SIZE_RECURSION);
1507 sv_size(aTHX_ st, NPathLink("rsfp_filters"), (SV*)parser->rsfp_filters, TOTAL_SIZE_RECURSION);
1509 sv_size(aTHX_ st, NPathLink("endwhite"), parser->endwhite, TOTAL_SIZE_RECURSION);
1510 sv_size(aTHX_ st, NPathLink("nextwhite"), parser->nextwhite, TOTAL_SIZE_RECURSION);
1511 sv_size(aTHX_ st, NPathLink("skipwhite"), parser->skipwhite, TOTAL_SIZE_RECURSION);
1512 sv_size(aTHX_ st, NPathLink("thisclose"), parser->thisclose, TOTAL_SIZE_RECURSION);
1513 madprop_size(aTHX_ st, NPathLink("thismad"), parser->thismad);
1514 sv_size(aTHX_ st, NPathLink("thisopen"), parser->thisopen, TOTAL_SIZE_RECURSION);
1515 sv_size(aTHX_ st, NPathLink("thisstuff"), parser->thisstuff, TOTAL_SIZE_RECURSION);
1516 sv_size(aTHX_ st, NPathLink("thistoken"), parser->thistoken, TOTAL_SIZE_RECURSION);
1517 sv_size(aTHX_ st, NPathLink("thiswhite"), parser->thiswhite, TOTAL_SIZE_RECURSION);
1519 op_size_class(aTHX_ (OP*)parser->saved_curcop, OPc_COP, 0,
1520 st, NPathLink("saved_curcop"));
1522 if (parser->old_parser)
1523 parser_size(aTHX_ st, NPathLink("old_parser"), parser->old_parser);
1527 perl_size(pTHX_ struct state *const st, pPATH)
1529 dNPathNodes(3, NPathArg);
1531 /* if(!check_new(st, interp)) return; */
1532 NPathPushNode("perl", NPtype_NAME);
1533 #if defined(MULTIPLICITY)
1534 ADD_SIZE(st, "PerlInterpreter", sizeof(PerlInterpreter));
1540 * unknown <== = O/S Heap size - perl - free_malloc_space
1542 /* start with PL_defstash to get everything reachable from \%main:: */
1543 sv_size(aTHX_ st, NPathLink("PL_defstash"), (SV*)PL_defstash, TOTAL_SIZE_RECURSION);
1545 NPathPushNode("others", NPtype_NAME); /* group these (typically much smaller) items */
1546 sv_size(aTHX_ st, NPathLink("PL_defgv"), (SV*)PL_defgv, TOTAL_SIZE_RECURSION);
1547 sv_size(aTHX_ st, NPathLink("PL_incgv"), (SV*)PL_incgv, TOTAL_SIZE_RECURSION);
1548 sv_size(aTHX_ st, NPathLink("PL_rs"), (SV*)PL_rs, TOTAL_SIZE_RECURSION);
1549 sv_size(aTHX_ st, NPathLink("PL_fdpid"), (SV*)PL_fdpid, TOTAL_SIZE_RECURSION);
1550 sv_size(aTHX_ st, NPathLink("PL_modglobal"), (SV*)PL_modglobal, TOTAL_SIZE_RECURSION);
1551 sv_size(aTHX_ st, NPathLink("PL_errors"), (SV*)PL_errors, TOTAL_SIZE_RECURSION);
1552 sv_size(aTHX_ st, NPathLink("PL_stashcache"), (SV*)PL_stashcache, TOTAL_SIZE_RECURSION);
1553 sv_size(aTHX_ st, NPathLink("PL_patchlevel"), (SV*)PL_patchlevel, TOTAL_SIZE_RECURSION);
1554 sv_size(aTHX_ st, NPathLink("PL_apiversion"), (SV*)PL_apiversion, TOTAL_SIZE_RECURSION);
1555 sv_size(aTHX_ st, NPathLink("PL_registered_mros"), (SV*)PL_registered_mros, TOTAL_SIZE_RECURSION);
1557 sv_size(aTHX_ st, NPathLink("PL_regex_padav"), (SV*)PL_regex_padav, TOTAL_SIZE_RECURSION);
1559 sv_size(aTHX_ st, NPathLink("PL_warnhook"), (SV*)PL_warnhook, TOTAL_SIZE_RECURSION);
1560 sv_size(aTHX_ st, NPathLink("PL_diehook"), (SV*)PL_diehook, TOTAL_SIZE_RECURSION);
1561 sv_size(aTHX_ st, NPathLink("PL_endav"), (SV*)PL_endav, TOTAL_SIZE_RECURSION);
1562 sv_size(aTHX_ st, NPathLink("PL_main_cv"), (SV*)PL_main_cv, TOTAL_SIZE_RECURSION);
1563 sv_size(aTHX_ st, NPathLink("PL_main_root"), (SV*)PL_main_root, TOTAL_SIZE_RECURSION);
1564 sv_size(aTHX_ st, NPathLink("PL_main_start"), (SV*)PL_main_start, TOTAL_SIZE_RECURSION);
1565 sv_size(aTHX_ st, NPathLink("PL_envgv"), (SV*)PL_envgv, TOTAL_SIZE_RECURSION);
1566 sv_size(aTHX_ st, NPathLink("PL_hintgv"), (SV*)PL_hintgv, TOTAL_SIZE_RECURSION);
1567 sv_size(aTHX_ st, NPathLink("PL_e_script"), (SV*)PL_e_script, TOTAL_SIZE_RECURSION);
1568 sv_size(aTHX_ st, NPathLink("PL_encoding"), (SV*)PL_encoding, TOTAL_SIZE_RECURSION);
1569 sv_size(aTHX_ st, NPathLink("PL_ofsgv"), (SV*)PL_ofsgv, TOTAL_SIZE_RECURSION);
1570 sv_size(aTHX_ st, NPathLink("PL_argvout_stack"), (SV*)PL_argvout_stack, TOTAL_SIZE_RECURSION);
1571 sv_size(aTHX_ st, NPathLink("PL_beginav"), (SV*)PL_beginav, TOTAL_SIZE_RECURSION);
1572 sv_size(aTHX_ st, NPathLink("PL_beginav_save"), (SV*)PL_beginav_save, TOTAL_SIZE_RECURSION);
1573 sv_size(aTHX_ st, NPathLink("PL_checkav_save"), (SV*)PL_checkav_save, TOTAL_SIZE_RECURSION);
1574 sv_size(aTHX_ st, NPathLink("PL_unitcheckav"), (SV*)PL_unitcheckav, TOTAL_SIZE_RECURSION);
1575 sv_size(aTHX_ st, NPathLink("PL_unitcheckav_save"), (SV*)PL_unitcheckav_save, TOTAL_SIZE_RECURSION);
1576 sv_size(aTHX_ st, NPathLink("PL_endav"), (SV*)PL_endav, TOTAL_SIZE_RECURSION);
1577 sv_size(aTHX_ st, NPathLink("PL_checkav"), (SV*)PL_checkav, TOTAL_SIZE_RECURSION);
1578 sv_size(aTHX_ st, NPathLink("PL_initav"), (SV*)PL_initav, TOTAL_SIZE_RECURSION);
1579 sv_size(aTHX_ st, NPathLink("PL_isarev"), (SV*)PL_isarev, TOTAL_SIZE_RECURSION);
1580 sv_size(aTHX_ st, NPathLink("PL_fdpid"), (SV*)PL_fdpid, TOTAL_SIZE_RECURSION);
1581 sv_size(aTHX_ st, NPathLink("PL_preambleav"), (SV*)PL_preambleav, TOTAL_SIZE_RECURSION);
1582 sv_size(aTHX_ st, NPathLink("PL_ors_sv"), (SV*)PL_ors_sv, TOTAL_SIZE_RECURSION);
1583 sv_size(aTHX_ st, NPathLink("PL_modglobal"), (SV*)PL_modglobal, TOTAL_SIZE_RECURSION);
1584 sv_size(aTHX_ st, NPathLink("PL_custom_op_names"), (SV*)PL_custom_op_names, TOTAL_SIZE_RECURSION);
1585 sv_size(aTHX_ st, NPathLink("PL_custom_op_descs"), (SV*)PL_custom_op_descs, TOTAL_SIZE_RECURSION);
1586 sv_size(aTHX_ st, NPathLink("PL_custom_ops"), (SV*)PL_custom_ops, TOTAL_SIZE_RECURSION);
1587 sv_size(aTHX_ st, NPathLink("PL_compcv"), (SV*)PL_compcv, TOTAL_SIZE_RECURSION);
1588 sv_size(aTHX_ st, NPathLink("PL_DBcv"), (SV*)PL_DBcv, TOTAL_SIZE_RECURSION);
1589 #ifdef PERL_USES_PL_PIDSTATUS
1590 sv_size(aTHX_ st, NPathLink("PL_pidstatus"), (SV*)PL_pidstatus, TOTAL_SIZE_RECURSION);
1592 sv_size(aTHX_ st, NPathLink("PL_subname"), (SV*)PL_subname, TOTAL_SIZE_RECURSION);
1593 #ifdef USE_LOCALE_NUMERIC
1594 sv_size(aTHX_ st, NPathLink("PL_numeric_radix_sv"), (SV*)PL_numeric_radix_sv, TOTAL_SIZE_RECURSION);
1595 check_new_and_strlen(st, PL_numeric_name, NPathLink("PL_numeric_name"));
1597 #ifdef USE_LOCALE_COLLATE
1598 check_new_and_strlen(st, PL_collation_name, NPathLink("PL_collation_name"));
1600 check_new_and_strlen(st, PL_origfilename, NPathLink("PL_origfilename"));
1601 check_new_and_strlen(st, PL_inplace, NPathLink("PL_inplace"));
1602 check_new_and_strlen(st, PL_osname, NPathLink("PL_osname"));
1603 if (PL_op_mask && check_new(st, PL_op_mask))
1604 ADD_SIZE(st, "PL_op_mask", PL_maxo);
1605 if (PL_exitlistlen && check_new(st, PL_exitlist))
1606 ADD_SIZE(st, "PL_exitlist", (PL_exitlistlen * sizeof(PerlExitListEntry *))
1607 + (PL_exitlistlen * sizeof(PerlExitListEntry)));
1608 #ifdef PERL_IMPLICIT_CONTEXT
1609 if (PL_my_cxt_size && check_new(st, PL_my_cxt_list)) {
1610 ADD_SIZE(st, "PL_my_cxt_list", (PL_my_cxt_size * sizeof(void *)));
1611 #ifdef PERL_GLOBAL_STRUCT_PRIVATE
1612 ADD_SIZE(st, "PL_my_cxt_keys", (PL_my_cxt_size * sizeof(char *)));
1616 /* TODO PL_stashpad */
1617 op_size_class(aTHX_ (OP*)&PL_compiling, OPc_COP, 1, st, NPathLink("PL_compiling"));
1618 op_size_class(aTHX_ (OP*)PL_curcopdb, OPc_COP, 0, st, NPathLink("PL_curcopdb"));
1620 parser_size(aTHX_ st, NPathLink("PL_parser"), PL_parser);
1621 /* TODO stacks: cur, main, tmps, mark, scope, save */
1622 /* TODO PL_exitlist */
1623 /* TODO PL_reentrant_buffers etc */
1625 /* TODO PerlIO? PL_known_layers PL_def_layerlist PL_perlio_fd_refcnt etc */
1627 /* TODO anything missed? */
1629 /* --- by this point we should have seen all reachable SVs --- */
1631 /* in theory we shouldn't have any elements in PL_strtab that haven't been seen yet */
1632 sv_size(aTHX_ st, NPathLink("PL_strtab-unseen"), (SV*)PL_strtab, TOTAL_SIZE_RECURSION);
1634 /* unused space in sv head arenas */
1638 # define SvARENA_CHAIN(sv) SvANY(sv) /* XXX breaks encapsulation*/
1639 while ((p = MUTABLE_SV(SvARENA_CHAIN(p)))) {
1640 if (!check_new(st, p)) /* sanity check */
1641 warn("Free'd SV head unexpectedly already seen");
1644 NPathPushNode("unused_sv_heads", NPtype_NAME);
1645 ADD_SIZE(st, "sv", free_heads * sizeof(SV));
1648 /* XXX iterate over bodies_by_type and crawl the free chains for each */
1650 /* iterate over all SVs to find any we've not accounted for yet */
1651 /* once the code above is visiting all SVs, any found here have been leaked */
1652 unseen_sv_size(aTHX_ st, NPathLink("unaccounted"));
1656 MODULE = Devel::SizeMe PACKAGE = Devel::SizeMe
1664 total_size = TOTAL_SIZE_RECURSION
1667 SV *thing = orig_thing;
1668 struct state *st = new_state(aTHX);
1670 /* If they passed us a reference then dereference it. This is the
1671 only way we can check the sizes of arrays and hashes */
1673 thing = SvRV(thing);
1676 sv_size(aTHX_ st, NULL, thing, ix);
1677 RETVAL = st->total_size;
1678 free_state(aTHX_ st);
1687 /* just the current perl interpreter */
1688 struct state *st = new_state(aTHX);
1689 st->min_recurse_threshold = NO_RECURSION; /* so always recurse */
1690 perl_size(aTHX_ st, NULL);
1691 RETVAL = st->total_size;
1692 free_state(aTHX_ st);
1701 /* the current perl interpreter plus malloc, in the context of total heap size */
1702 # ifdef _MALLOC_MALLOC_H_ /* OSX. Now sure where else mstats is available */
1706 /* some systems have the SVID2/XPG mallinfo structure and function */
1707 struct mstats ms = mstats(); /* mstats() first */
1709 struct state *st = new_state(aTHX);
1710 dNPathNodes(1, NULL);
1711 NPathPushNode("heap", NPtype_NAME);
1713 st->min_recurse_threshold = NO_RECURSION; /* so always recurse */
1715 perl_size(aTHX_ st, NPathLink("perl_interp"));
1717 NPathSetNode("free_malloc_space", NPtype_NAME);
1718 ADD_SIZE(st, "bytes_free", ms.bytes_free);
1719 ADD_ATTR(st, NPattr_NOTE, "bytes_total", ms.bytes_total);
1720 ADD_ATTR(st, NPattr_NOTE, "bytes_used", ms.bytes_used);
1721 ADD_ATTR(st, NPattr_NOTE, "chunks_used", ms.chunks_used);
1722 ADD_ATTR(st, NPattr_NOTE, "chunks_free", ms.chunks_free);
1723 /* TODO get heap size from OS and add a node: unknown = heapsize - perl - ms.bytes_free */
1724 /* for now we use bytes_total as an approximation */
1725 NPathSetNode("unknown", NPtype_NAME);
1726 ADD_SIZE(st, "unknown", ms.bytes_total - st->total_size);
1731 RETVAL = st->total_size;
1732 free_state(aTHX_ st);