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
19 #define DPPP_PL_parser_NO_DUMMY
20 #define NEED_PL_parser
23 #include "refcounted_he.h"
25 /* Not yet in ppport.h */
27 # define CvISXSUB(cv) (CvXSUB(cv) ? TRUE : FALSE)
30 # define SvRV_const(rv) SvRV(rv)
33 # define SvOOK_offset(sv, len) STMT_START { len = SvIVX(sv); } STMT_END
36 # define SvIsCOW(sv) ((SvFLAGS(sv) & (SVf_FAKE | SVf_READONLY)) == \
37 (SVf_FAKE | SVf_READONLY))
39 #ifndef SvIsCOW_shared_hash
40 # define SvIsCOW_shared_hash(sv) (SvIsCOW(sv) && SvLEN(sv) == 0)
42 #ifndef SvSHARED_HEK_FROM_PV
43 # define SvSHARED_HEK_FROM_PV(pvx) \
44 ((struct hek*)(pvx - STRUCT_OFFSET(struct hek, hek_key)))
46 #ifndef CopHINTHASH_get
47 #define CopHINTHASH_get(c) ((COPHH*)((c)->cop_hints_hash))
51 # define PL_opargs opargs
52 # define PL_op_name op_name
56 /* "structured exception" handling is a Microsoft extension to C and C++.
57 It's *not* C++ exception handling - C++ exception handling can't capture
58 SEGVs and suchlike, whereas this can. There's no known analagous
59 functionality on other platforms. */
61 # define TRY_TO_CATCH_SEGV __try
62 # define CAUGHT_EXCEPTION __except(EXCEPTION_EXECUTE_HANDLER)
64 # define TRY_TO_CATCH_SEGV if(1)
65 # define CAUGHT_EXCEPTION else
69 # define __attribute__(x)
72 #if 0 && defined(DEBUGGING)
73 #define dbg_printf(x) printf x
78 #define TAG /* printf( "# %s(%d)\n", __FILE__, __LINE__ ) */
81 /* The idea is to have a tree structure to store 1 bit per possible pointer
82 address. The lowest 16 bits are stored in a block of 8092 bytes.
83 The blocks are in a 256-way tree, indexed by the reset of the pointer.
84 This can cope with 32 and 64 bit pointers, and any address space layout,
85 without excessive memory needs. The assumption is that your CPU cache
86 works :-) (And that we're not going to bust it) */
89 #define LEAF_BITS (16 - BYTE_BITS)
90 #define LEAF_MASK 0x1FFF
92 typedef struct npath_node_st npath_node_t;
93 struct npath_node_st {
108 /* My hunch (not measured) is that for most architectures pointers will
109 start with 0 bits, hence the start of this array will be hot, and the
110 end unused. So put the flags next to the hot end. */
113 int min_recurse_threshold;
114 /* callback hooks and data */
115 void (*add_attr_cb)(pTHX_ struct state *st, npath_node_t *npath_node, UV attr_type, const char *name, UV value);
116 void (*free_state_cb)(pTHX_ struct state *st);
117 void *state_cb_data; /* free'd by free_state() after free_state_cb() call */
118 /* this stuff wil be moved to state_cb_data later */
120 FILE *node_stream_fh;
121 char *node_stream_name;
124 #define ADD_SIZE(st, leafname, bytes) \
126 NPathAddSizeCb(st, leafname, bytes); \
127 (st)->total_size += (bytes); \
131 #define PATH_TRACKING
134 #define pPATH npath_node_t *NPathArg
136 /* A subtle point here is that dNPathNodes and NPathPushNode leave NP pointing
137 * to the next unused slot (though with prev already filled in)
138 * whereas NPathLink leaves NP unchanged, it just fills in the slot NP points
139 * to and passes that NP value to the function being called.
140 * seqn==0 indicates the node is new (hasn't been output yet)
142 #define dNPathNodes(nodes, prev_np) \
143 npath_node_t name_path_nodes[nodes+1]; /* +1 for NPathLink */ \
144 npath_node_t *NP = &name_path_nodes[0]; \
145 NP->seqn = NP->type = 0; NP->id = Nullch; /* safety/debug */ \
147 #define NPathPushNode(nodeid, nodetype) \
149 NP->type = nodetype; \
151 if(0)fprintf(stderr,"NPathPushNode (%p <-) %p <- [%d %s]\n", NP->prev, NP, nodetype,(char*)nodeid);\
153 NP->id = Nullch; /* safety/debug */ \
156 #define NPathSetNode(nodeid, nodetype) \
157 (NP-1)->id = nodeid; \
158 (NP-1)->type = nodetype; \
159 if(0)fprintf(stderr,"NPathSetNode (%p <-) %p <- [%d %s]\n", (NP-1)->prev, (NP-1), nodetype,(char*)nodeid);\
161 #define NPathPopNode \
164 /* dNPathUseParent points NP directly the the parents' name_path_nodes array
165 * So the function can only safely call ADD_*() but not NPathLink, unless the
166 * caller has spare nodes in its name_path_nodes.
168 #define dNPathUseParent(prev_np) npath_node_t *NP = (((prev_np+1)->prev = prev_np), prev_np+1)
170 #define NPtype_NAME 0x01
171 #define NPtype_LINK 0x02
172 #define NPtype_SV 0x03
173 #define NPtype_MAGIC 0x04
174 #define NPtype_OP 0x05
176 /* XXX these should probably be generalized into flag bits */
177 #define NPattr_LEAFSIZE 0x00
178 #define NPattr_NAME 0x01
179 #define NPattr_PADFAKE 0x02
180 #define NPattr_PADNAME 0x03
181 #define NPattr_PADTMP 0x04
182 #define NPattr_NOTE 0x05
184 #define _ADD_ATTR_NP(st, attr_type, attr_name, attr_value, np) \
186 if (st->add_attr_cb) { \
187 st->add_attr_cb(aTHX_ st, np, attr_type, attr_name, attr_value); \
191 #define ADD_ATTR(st, attr_type, attr_name, attr_value) \
192 _ADD_ATTR_NP(st, attr_type, attr_name, attr_value, NP-1)
194 #define ADD_LINK_ATTR(st, attr_type, attr_name, attr_value) \
196 if (st->add_attr_cb) assert(NP->seqn); \
197 _ADD_ATTR_NP(st, attr_type, attr_name, attr_value, NP); \
200 #define _NPathLink(np, nid, ntype) (((np)->id=nid), ((np)->type=ntype), ((np)->seqn=0))
201 #define NPathLink(nid) (_NPathLink(NP, nid, NPtype_LINK), NP)
202 /* add a link and a name node to the path - a special case for op_size */
203 #define NPathLinkAndNode(nid, nid2) (_NPathLink(NP, nid, NPtype_LINK), _NPathLink(NP+1, nid2, NPtype_NAME), ((NP+1)->prev=NP), (NP+1))
204 #define NPathOpLink (NPathArg)
205 #define NPathAddSizeCb(st, name, bytes) \
207 if (st->add_attr_cb) { \
208 st->add_attr_cb(aTHX_ st, NP-1, NPattr_LEAFSIZE, (name), (bytes)); \
214 #define NPathAddSizeCb(st, name, bytes)
215 #define pPATH void *npath_dummy /* XXX ideally remove */
216 #define dNPathNodes(nodes, prev_np) dNOOP
217 #define NPathLink(nodeid, nodetype) NULL
218 #define NPathOpLink NULL
219 #define ADD_ATTR(st, attr_type, attr_name, attr_value) NOOP
221 #endif /* PATH_TRACKING */
228 static const char *svtypenames[SVt_LAST] = {
230 "NULL", "IV", "NV", "RV", "PV", "PVIV", "PVNV", "PVMG", "PVBM", "PVLV", "PVAV", "PVHV", "PVCV", "PVGV", "PVFM", "PVIO",
231 #elif PERL_VERSION == 10 && PERL_SUBVERSION == 0
232 "NULL", "BIND", "IV", "NV", "RV", "PV", "PVIV", "PVNV", "PVMG", "PVGV", "PVLV", "PVAV", "PVHV", "PVCV", "PVFM", "PVIO",
233 #elif PERL_VERSION == 10 && PERL_SUBVERSION == 1
234 "NULL", "BIND", "IV", "NV", "RV", "PV", "PVIV", "PVNV", "PVMG", "PVGV", "PVLV", "PVAV", "PVHV", "PVCV", "PVFM", "PVIO",
235 #elif PERL_VERSION < 13
236 "NULL", "BIND", "IV", "NV", "PV", "PVIV", "PVNV", "PVMG", "REGEXP", "PVGV", "PVLV", "PVAV", "PVHV", "PVCV", "PVFM", "PVIO",
238 "NULL", "BIND", "IV", "NV", "PV", "PVIV", "PVNV", "PVMG", "REGEXP", "PVGV", "PVLV", "PVAV", "PVHV", "PVCV", "PVFM", "PVIO",
243 gettimeofday_nv(void)
245 #ifdef HAS_GETTIMEOFDAY
247 gettimeofday(&when, (struct timezone *) 0);
248 return when.tv_sec + (when.tv_usec / 1000000.0);
252 (*u2time)(aTHX_ &time_of_day);
253 return time_of_day[0] + (time_of_day[1] / 1000000.0);
261 np_print_node_name(pTHX_ FILE *fp, npath_node_t *npath_node)
263 switch (npath_node->type) {
264 case NPtype_SV: { /* id is pointer to the SV sv_size was called on */
265 const SV *sv = (SV*)npath_node->id;
266 int type = SvTYPE(sv);
267 const char *typename = (type == SVt_IV && SvROK(sv)) ? "RV" : svtypenames[type];
268 fprintf(fp, "SV(%s)", typename);
269 switch(type) { /* add some useful details */
270 case SVt_PVAV: fprintf(fp, " fill=%d/%ld", av_len((AV*)sv), AvMAX((AV*)sv)); break;
271 case SVt_PVHV: fprintf(fp, " fill=%ld/%ld", HvFILL((HV*)sv), HvMAX((HV*)sv)); break;
275 case NPtype_OP: { /* id is pointer to the OP op_size was called on */
276 const OP *op = (OP*)npath_node->id;
277 fprintf(fp, "OP(%s)", OP_NAME(op));
280 case NPtype_MAGIC: { /* id is pointer to the MAGIC struct */
281 MAGIC *magic_pointer = (MAGIC*)npath_node->id;
282 /* XXX it would be nice if we could reuse mg_names.c [sigh] */
283 fprintf(fp, "MAGIC(%c)", magic_pointer->mg_type ? magic_pointer->mg_type : '0');
287 fprintf(fp, "%s", (const char *)npath_node->id);
290 fprintf(fp, "%s", (const char *)npath_node->id);
292 default: /* assume id is a string pointer */
293 fprintf(fp, "UNKNOWN(%d,%p)", npath_node->type, npath_node->id);
300 np_dump_indent(int depth) {
302 fprintf(stderr, ": ");
306 np_walk_new_nodes(pTHX_ struct state *st,
307 npath_node_t *npath_node,
308 npath_node_t *npath_node_deeper,
309 int (*cb)(pTHX_ struct state *st, npath_node_t *npath_node, npath_node_t *npath_node_deeper))
311 if (npath_node->seqn) /* node already output */
314 if (npath_node->prev) {
315 np_walk_new_nodes(aTHX_ st, npath_node->prev, npath_node, cb); /* recurse */
316 npath_node->depth = npath_node->prev->depth + 1;
318 else npath_node->depth = 0;
319 npath_node->seqn = ++st->seqn;
322 if (cb(aTHX_ st, npath_node, npath_node_deeper)) {
323 /* ignore this node */
324 assert(npath_node->prev);
325 assert(npath_node->depth);
326 assert(npath_node_deeper);
328 npath_node->seqn = --st->seqn;
329 npath_node_deeper->prev = npath_node->prev;
337 np_dump_formatted_node(pTHX_ struct state *st, npath_node_t *npath_node, npath_node_t *npath_node_deeper) {
339 PERL_UNUSED_ARG(npath_node_deeper);
340 if (0 && npath_node->type == NPtype_LINK)
342 np_dump_indent(npath_node->depth);
343 np_print_node_name(aTHX_ stderr, npath_node);
344 if (npath_node->type == NPtype_LINK)
345 fprintf(stderr, "->"); /* cosmetic */
346 fprintf(stderr, "\t\t[#%ld @%u] ", npath_node->seqn, npath_node->depth);
347 fprintf(stderr, "\n");
352 np_dump_node_path_info(pTHX_ struct state *st, npath_node_t *npath_node, UV attr_type, const char *attr_name, UV attr_value)
354 if (attr_type == NPattr_LEAFSIZE && !attr_value)
355 return; /* ignore zero sized leaf items */
356 np_walk_new_nodes(aTHX_ st, npath_node, NULL, np_dump_formatted_node);
357 np_dump_indent(npath_node->depth+1);
359 case NPattr_LEAFSIZE:
360 fprintf(stderr, "+%ld %s =%ld", attr_value, attr_name, attr_value+st->total_size);
363 fprintf(stderr, "~NAMED('%s') %lu", attr_name, attr_value);
366 fprintf(stderr, "~note %s %lu", attr_name, attr_value);
371 fprintf(stderr, "~pad%lu %s %lu", attr_type, attr_name, attr_value);
374 fprintf(stderr, "~??? %s %lu", attr_name, attr_value);
377 fprintf(stderr, "\n");
381 np_stream_formatted_node(pTHX_ struct state *st, npath_node_t *npath_node, npath_node_t *npath_node_deeper) {
382 PERL_UNUSED_ARG(npath_node_deeper);
383 fprintf(st->node_stream_fh, "-%u %lu %u ",
384 npath_node->type, npath_node->seqn, (unsigned)npath_node->depth
386 np_print_node_name(aTHX_ st->node_stream_fh, npath_node);
387 fprintf(st->node_stream_fh, "\n");
392 np_stream_node_path_info(pTHX_ struct state *st, npath_node_t *npath_node, UV attr_type, const char *attr_name, UV attr_value)
394 if (!attr_type && !attr_value)
395 return; /* ignore zero sized leaf items */
396 np_walk_new_nodes(aTHX_ st, npath_node, NULL, np_stream_formatted_node);
397 if (attr_type) { /* Attribute type, name and value */
398 fprintf(st->node_stream_fh, "%lu %lu ", attr_type, npath_node->seqn);
400 else { /* Leaf name and memory size */
401 fprintf(st->node_stream_fh, "L %lu ", npath_node->seqn);
403 fprintf(st->node_stream_fh, "%lu %s\n", attr_value, attr_name);
407 #endif /* PATH_TRACKING */
411 Checks to see if thing is in the bitstring.
412 Returns true or false, and
413 notes thing in the segmented bitstring.
416 check_new(struct state *st, const void *const p) {
417 unsigned int bits = 8 * sizeof(void*);
418 const size_t raw_p = PTR2nat(p);
419 /* This effectively rotates the value right by the number of low always-0
420 bits in an aligned pointer. The assmption is that most (if not all)
421 pointers are aligned, and these will be in the same chain of nodes
422 (and hence hot in the cache) but we can still deal with any unaligned
424 const size_t cooked_p
425 = (raw_p >> ALIGN_BITS) | (raw_p << (bits - ALIGN_BITS));
426 const U8 this_bit = 1 << (cooked_p & 0x7);
430 void **tv_p = (void **) (st->tracking);
432 if (NULL == p) return FALSE;
434 const char c = *(const char *)p;
438 if (st->dangle_whine)
439 warn( "Devel::Size: Encountered invalid pointer: %p\n", p );
445 /* bits now 24 (32 bit pointers) or 56 (64 bit pointers) */
447 /* First level is always present. */
449 i = (unsigned int)((cooked_p >> bits) & 0xFF);
451 Newxz(tv_p[i], 256, void *);
452 tv_p = (void **)(tv_p[i]);
454 } while (bits > LEAF_BITS + BYTE_BITS);
455 /* bits now 16 always */
456 #if !defined(MULTIPLICITY) || PERL_VERSION > 8 || (PERL_VERSION == 8 && PERL_SUBVERSION > 8)
457 /* 5.8.8 and early have an assert() macro that uses Perl_croak, hence needs
458 a my_perl under multiplicity */
461 leaf_p = (U8 **)tv_p;
462 i = (unsigned int)((cooked_p >> bits) & 0xFF);
464 Newxz(leaf_p[i], 1 << LEAF_BITS, U8);
469 i = (unsigned int)((cooked_p >> BYTE_BITS) & LEAF_MASK);
471 if(leaf[i] & this_bit)
479 free_tracking_at(void **tv, int level)
487 free_tracking_at((void **) tv[i], level);
501 free_state(pTHX_ struct state *st)
503 const int top_level = (sizeof(void *) * 8 - LEAF_BITS - BYTE_BITS) / 8;
504 if (st->free_state_cb)
505 st->free_state_cb(aTHX_ st);
506 if (st->state_cb_data)
507 Safefree(st->state_cb_data);
508 free_tracking_at((void **)st->tracking, top_level);
512 /* For now, this is somewhat a compatibility bodge until the plan comes
513 together for fine grained recursion control. total_size() would recurse into
514 hash and array members, whereas sv_size() would not. However, sv_size() is
515 called with CvSTASH() of a CV, which means that if it (also) starts to
516 recurse fully, then the size of any CV now becomes the size of the entire
517 symbol table reachable from it, and potentially the entire symbol table, if
518 any subroutine makes a reference to a global (such as %SIG). The historical
519 implementation of total_size() didn't report "everything", and changing the
520 only available size to "everything" doesn't feel at all useful. */
522 #define NO_RECURSION 0
523 #define SOME_RECURSION 1
524 #define TOTAL_SIZE_RECURSION 2
526 static bool sv_size(pTHX_ struct state *, pPATH, const SV *const, const int recurse);
542 , OPc_CONDOP /* 12 */
551 cc_opclass(const OP * const o)
557 return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
559 if (o->op_type == OP_SASSIGN)
560 return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPc_UNOP : OPc_BINOP);
563 if (o->op_type == OP_GV || o->op_type == OP_GVSV || o->op_type == OP_AELEMFAST)
567 if ((o->op_type == OP_TRANS)) {
571 switch (PL_opargs[o->op_type] & OA_CLASS_MASK) {
603 #ifdef OA_PVOP_OR_SVOP
604 case OA_PVOP_OR_SVOP: TAG;
606 * Character translations (tr///) are usually a PVOP, keeping a
607 * pointer to a table of shorts used to look up translations.
608 * Under utf8, however, a simple table isn't practical; instead,
609 * the OP is an SVOP, and the SV is a reference to a swash
610 * (i.e., an RV pointing to an HV).
612 return (o->op_private & (OPpTRANS_TO_UTF|OPpTRANS_FROM_UTF))
613 ? OPc_SVOP : OPc_PVOP;
622 case OA_BASEOP_OR_UNOP: TAG;
624 * UNI(OP_foo) in toke.c returns token UNI or FUNC1 depending on
625 * whether parens were seen. perly.y uses OPf_SPECIAL to
626 * signal whether a BASEOP had empty parens or none.
627 * Some other UNOPs are created later, though, so the best
628 * test is OPf_KIDS, which is set in newUNOP.
630 return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
632 case OA_FILESTATOP: TAG;
634 * The file stat OPs are created via UNI(OP_foo) in toke.c but use
635 * the OPf_REF flag to distinguish between OP types instead of the
636 * usual OPf_SPECIAL flag. As usual, if OPf_KIDS is set, then we
637 * return OPc_UNOP so that walkoptree can find our children. If
638 * OPf_KIDS is not set then we check OPf_REF. Without OPf_REF set
639 * (no argument to the operator) it's an OP; with OPf_REF set it's
640 * an SVOP (and op_sv is the GV for the filehandle argument).
642 return ((o->op_flags & OPf_KIDS) ? OPc_UNOP :
644 (o->op_flags & OPf_REF) ? OPc_PADOP : OPc_BASEOP);
646 (o->op_flags & OPf_REF) ? OPc_SVOP : OPc_BASEOP);
648 case OA_LOOPEXOP: TAG;
650 * next, last, redo, dump and goto use OPf_SPECIAL to indicate that a
651 * label was omitted (in which case it's a BASEOP) or else a term was
652 * seen. In this last case, all except goto are definitely PVOP but
653 * goto is either a PVOP (with an ordinary constant label), an UNOP
654 * with OPf_STACKED (with a non-constant non-sub) or an UNOP for
655 * OP_REFGEN (with goto &sub) in which case OPf_STACKED also seems to
658 if (o->op_flags & OPf_STACKED)
660 else if (o->op_flags & OPf_SPECIAL)
670 warn("Devel::Size: Can't determine class of operator %s, assuming BASEOP\n",
671 PL_op_name[o->op_type]);
677 /* Figure out how much magic is attached to the SV and return the
680 magic_size(pTHX_ const SV * const thing, struct state *st, pPATH) {
681 dNPathNodes(1, NPathArg);
682 MAGIC *magic_pointer = SvMAGIC(thing); /* caller ensures thing is SvMAGICAL */
684 /* push a dummy node for NPathSetNode to update inside the while loop */
685 NPathPushNode("dummy", NPtype_NAME);
687 /* Have we seen the magic pointer? (NULL has always been seen before) */
688 while (check_new(st, magic_pointer)) {
690 NPathSetNode(magic_pointer, NPtype_MAGIC);
692 ADD_SIZE(st, "mg", sizeof(MAGIC));
693 /* magic vtables aren't freed when magic is freed, so don't count them.
694 (They are static structures. Anything that assumes otherwise is buggy.)
699 /* XXX only chase mg_obj if mg->mg_flags & MGf_REFCOUNTED ? */
700 sv_size(aTHX_ st, NPathLink("mg_obj"), magic_pointer->mg_obj, TOTAL_SIZE_RECURSION);
701 if (magic_pointer->mg_len == HEf_SVKEY) {
702 sv_size(aTHX_ st, NPathLink("mg_ptr"), (SV *)magic_pointer->mg_ptr, TOTAL_SIZE_RECURSION);
704 #if defined(PERL_MAGIC_utf8) && defined (PERL_MAGIC_UTF8_CACHESIZE)
705 else if (magic_pointer->mg_type == PERL_MAGIC_utf8) {
706 if (check_new(st, magic_pointer->mg_ptr)) {
707 ADD_SIZE(st, "PERL_MAGIC_utf8", PERL_MAGIC_UTF8_CACHESIZE * 2 * sizeof(STRLEN));
711 /* XXX also handle mg->mg_type == PERL_MAGIC_utf8 ? */
712 else if (magic_pointer->mg_len > 0) {
713 if(0)do_magic_dump(0, Perl_debug_log, magic_pointer, 0, 0, FALSE, 0);
714 if (check_new(st, magic_pointer->mg_ptr)) {
715 ADD_SIZE(st, "mg_len", magic_pointer->mg_len);
719 /* Get the next in the chain */
720 magic_pointer = magic_pointer->mg_moremagic;
723 if (st->dangle_whine)
724 warn( "Devel::Size: Encountered bad magic at: %p\n", magic_pointer );
729 #define check_new_and_strlen(st, p, ppath) S_check_new_and_strlen(aTHX_ st, p, ppath)
731 S_check_new_and_strlen(pTHX_ struct state *st, const char *const p, pPATH) {
732 dNPathNodes(1, NPathArg->prev);
733 if(check_new(st, p)) {
734 NPathPushNode(NPathArg->id, NPtype_NAME);
735 ADD_SIZE(st, NPathArg->id, 1 + strlen(p));
740 regex_size(pTHX_ const REGEXP * const baseregex, struct state *st, pPATH) {
741 dNPathNodes(1, NPathArg);
742 if(!check_new(st, baseregex))
744 NPathPushNode("regex_size", NPtype_NAME);
745 ADD_SIZE(st, "REGEXP", sizeof(REGEXP));
746 #if (PERL_VERSION < 11)
747 /* Note the size of the paren offset thing */
748 ADD_SIZE(st, "nparens", sizeof(I32) * baseregex->nparens * 2);
749 ADD_SIZE(st, "precomp", strlen(baseregex->precomp));
751 ADD_SIZE(st, "regexp", sizeof(struct regexp));
752 ADD_SIZE(st, "nparens", sizeof(I32) * SvANY(baseregex)->nparens * 2);
753 /*ADD_SIZE(st, strlen(SvANY(baseregex)->subbeg));*/
755 if (st->go_yell && !st->regex_whine) {
756 carp("Devel::Size: Calculated sizes for compiled regexes are incompatible, and probably always will be");
762 hek_size(pTHX_ struct state *st, HEK *hek, U32 shared, pPATH)
764 dNPathNodes(1, NPathArg);
766 /* Hash keys can be shared. Have we seen this before? */
767 if (!check_new(st, hek))
769 NPathPushNode("hek", NPtype_NAME);
770 ADD_SIZE(st, "hek_len", HEK_BASESIZE + hek->hek_len
772 + 1 /* No hash key flags prior to 5.8.0 */
778 #if PERL_VERSION < 10
779 ADD_SIZE(st, "he", sizeof(struct he));
781 ADD_SIZE(st, "shared_he", STRUCT_OFFSET(struct shared_he, shared_he_hek));
788 refcounted_he_size(pTHX_ struct state *st, struct refcounted_he *he, pPATH)
790 dNPathNodes(1, NPathArg);
791 if (!check_new(st, he))
793 NPathPushNode("refcounted_he_size", NPtype_NAME);
794 ADD_SIZE(st, "refcounted_he", sizeof(struct refcounted_he));
797 ADD_SIZE(st, "refcounted_he_data", NPtype_NAME);
799 hek_size(aTHX_ st, he->refcounted_he_hek, 0, NPathLink("refcounted_he_hek"));
802 if (he->refcounted_he_next)
803 refcounted_he_size(aTHX_ st, he->refcounted_he_next, NPathLink("refcounted_he_next"));
806 static void op_size_class(pTHX_ const OP * const baseop, opclass op_class, bool skip_op_struct, struct state *st, pPATH);
809 op_size(pTHX_ const OP * const baseop, struct state *st, pPATH)
811 op_size_class(aTHX_ baseop, cc_opclass(baseop), 0, st, NPathArg);
815 op_size_class(pTHX_ const OP * const baseop, opclass op_class, bool skip_op_struct, struct state *st, pPATH)
817 /* op_size recurses to follow the chain of opcodes. For the node path we
818 * don't want the chain to be 'nested' in the path so we use dNPathUseParent().
819 * Also, to avoid a link-to-a-link the caller should use NPathLinkAndNode()
820 * instead of NPathLink().
822 dNPathUseParent(NPathArg);
826 if(!check_new(st, baseop))
829 op_size(aTHX_ baseop->op_next, st, NPathOpLink);
831 madprop_size(aTHX_ st, NPathOpLink, baseop->op_madprop);
835 case OPc_BASEOP: TAG;
837 ADD_SIZE(st, "op", sizeof(struct op));
841 ADD_SIZE(st, "unop", sizeof(struct unop));
842 op_size(aTHX_ ((UNOP *)baseop)->op_first, st, NPathOpLink);
846 ADD_SIZE(st, "binop", sizeof(struct binop));
847 op_size(aTHX_ ((BINOP *)baseop)->op_first, st, NPathOpLink);
848 op_size(aTHX_ ((BINOP *)baseop)->op_last, st, NPathOpLink);
852 ADD_SIZE(st, "logop", sizeof(struct logop));
853 op_size(aTHX_ ((BINOP *)baseop)->op_first, st, NPathOpLink);
854 op_size(aTHX_ ((LOGOP *)baseop)->op_other, st, NPathOpLink);
857 case OPc_CONDOP: TAG;
859 ADD_SIZE(st, "condop", sizeof(struct condop));
860 op_size(aTHX_ ((BINOP *)baseop)->op_first, st, NPathOpLink);
861 op_size(aTHX_ ((CONDOP *)baseop)->op_true, st, NPathOpLink);
862 op_size(aTHX_ ((CONDOP *)baseop)->op_false, st, NPathOpLink);
865 case OPc_LISTOP: TAG;
867 ADD_SIZE(st, "listop", sizeof(struct listop));
868 op_size(aTHX_ ((LISTOP *)baseop)->op_first, st, NPathOpLink);
869 op_size(aTHX_ ((LISTOP *)baseop)->op_last, st, NPathOpLink);
873 ADD_SIZE(st, "pmop", sizeof(struct pmop));
874 op_size(aTHX_ ((PMOP *)baseop)->op_first, st, NPathOpLink);
875 op_size(aTHX_ ((PMOP *)baseop)->op_last, st, NPathOpLink);
876 #if PERL_VERSION < 9 || (PERL_VERSION == 9 && PERL_SUBVERSION < 5)
877 op_size(aTHX_ ((PMOP *)baseop)->op_pmreplroot, st, NPathOpLink);
878 op_size(aTHX_ ((PMOP *)baseop)->op_pmreplstart, st, NPathOpLink);
880 /* This is defined away in perl 5.8.x, but it is in there for
883 regex_size(aTHX_ PM_GETRE((PMOP *)baseop), st, NPathLink("PM_GETRE"));
885 regex_size(aTHX_ ((PMOP *)baseop)->op_pmregexp, st, NPathLink("op_pmregexp"));
890 ADD_SIZE(st, "svop", sizeof(struct svop));
891 if (!(baseop->op_type == OP_AELEMFAST
892 && baseop->op_flags & OPf_SPECIAL)) {
893 /* not an OP_PADAV replacement */
894 sv_size(aTHX_ st, NPathLink("SVOP"), ((SVOP *)baseop)->op_sv, SOME_RECURSION);
900 ADD_SIZE(st, "padop", sizeof(struct padop));
906 ADD_SIZE(st, "gvop", sizeof(struct gvop));
907 sv_size(aTHX_ st, NPathLink("GVOP"), ((GVOP *)baseop)->op_gv, SOME_RECURSION);
911 check_new_and_strlen(st, ((PVOP *)baseop)->op_pv, NPathLink("op_pv"));
915 ADD_SIZE(st, "loop", sizeof(struct loop));
916 op_size(aTHX_ ((LOOP *)baseop)->op_first, st, NPathOpLink);
917 op_size(aTHX_ ((LOOP *)baseop)->op_last, st, NPathOpLink);
918 op_size(aTHX_ ((LOOP *)baseop)->op_redoop, st, NPathOpLink);
919 op_size(aTHX_ ((LOOP *)baseop)->op_nextop, st, NPathOpLink);
920 op_size(aTHX_ ((LOOP *)baseop)->op_lastop, st, NPathOpLink);
925 basecop = (COP *)baseop;
927 ADD_SIZE(st, "cop", sizeof(struct cop));
929 /* Change 33656 by nicholas@mouse-mill on 2008/04/07 11:29:51
930 Eliminate cop_label from struct cop by storing a label as the first
931 entry in the hints hash. Most statements don't have labels, so this
932 will save memory. Not sure how much.
933 The check below will be incorrect fail on bleadperls
934 before 5.11 @33656, but later than 5.10, producing slightly too
935 small memory sizes on these Perls. */
936 #if (PERL_VERSION < 11)
937 check_new_and_strlen(st, basecop->cop_label, NPathLink("cop_label"));
940 check_new_and_strlen(st, basecop->cop_file, NPathLink("cop_file"));
941 check_new_and_strlen(st, basecop->cop_stashpv, NPathLink("cop_stashpv"));
943 if (SvREFCNT(basecop->cop_stash) == 1) /* XXX hack? */
944 sv_size(aTHX_ st, NPathLink("cop_stash"), (SV *)basecop->cop_stash, SOME_RECURSION);
945 sv_size(aTHX_ st, NPathLink("cop_filegv"), (SV *)basecop->cop_filegv, SOME_RECURSION);
947 refcounted_he_size(aTHX_ st, CopHINTHASH_get(basecop), NPathLink("cop_hints_hash"));
955 if (st->dangle_whine)
956 warn( "Devel::Size: Encountered dangling pointer in opcode at: %p\n", baseop );
960 #if PERL_VERSION < 8 || PERL_SUBVERSION < 9 /* XXX plain || seems like a bug */
965 # define MAYBE_PURIFY(normal, pure) (pure)
966 # define MAYBE_OFFSET(struct_name, member) 0
968 # define MAYBE_PURIFY(normal, pure) (normal)
969 # define MAYBE_OFFSET(struct_name, member) STRUCT_OFFSET(struct_name, member)
972 const U8 body_sizes[SVt_LAST] = {
975 MAYBE_PURIFY(sizeof(IV), sizeof(XPVIV)), /* SVt_IV */
976 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
977 sizeof(XRV), /* SVt_RV */
978 sizeof(XPV), /* SVt_PV */
979 sizeof(XPVIV), /* SVt_PVIV */
980 sizeof(XPVNV), /* SVt_PVNV */
981 sizeof(XPVMG), /* SVt_PVMG */
982 sizeof(XPVBM), /* SVt_PVBM */
983 sizeof(XPVLV), /* SVt_PVLV */
984 sizeof(XPVAV), /* SVt_PVAV */
985 sizeof(XPVHV), /* SVt_PVHV */
986 sizeof(XPVCV), /* SVt_PVCV */
987 sizeof(XPVGV), /* SVt_PVGV */
988 sizeof(XPVFM), /* SVt_PVFM */
989 sizeof(XPVIO) /* SVt_PVIO */
990 #elif PERL_VERSION == 10 && PERL_SUBVERSION == 0
994 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
996 MAYBE_PURIFY(sizeof(xpv_allocated), sizeof(XPV)), /* SVt_PV */
997 MAYBE_PURIFY(sizeof(xpviv_allocated), sizeof(XPVIV)),/* SVt_PVIV */
998 sizeof(XPVNV), /* SVt_PVNV */
999 sizeof(XPVMG), /* SVt_PVMG */
1000 sizeof(XPVGV), /* SVt_PVGV */
1001 sizeof(XPVLV), /* SVt_PVLV */
1002 MAYBE_PURIFY(sizeof(xpvav_allocated), sizeof(XPVAV)),/* SVt_PVAV */
1003 MAYBE_PURIFY(sizeof(xpvhv_allocated), sizeof(XPVHV)),/* SVt_PVHV */
1004 MAYBE_PURIFY(sizeof(xpvcv_allocated), sizeof(XPVCV)),/* SVt_PVCV */
1005 MAYBE_PURIFY(sizeof(xpvfm_allocated), sizeof(XPVFM)),/* SVt_PVFM */
1006 sizeof(XPVIO), /* SVt_PVIO */
1007 #elif PERL_VERSION == 10 && PERL_SUBVERSION == 1
1011 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
1013 sizeof(XPV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PV */
1014 sizeof(XPVIV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PVIV */
1015 sizeof(XPVNV), /* SVt_PVNV */
1016 sizeof(XPVMG), /* SVt_PVMG */
1017 sizeof(XPVGV), /* SVt_PVGV */
1018 sizeof(XPVLV), /* SVt_PVLV */
1019 sizeof(XPVAV) - MAYBE_OFFSET(XPVAV, xav_fill), /* SVt_PVAV */
1020 sizeof(XPVHV) - MAYBE_OFFSET(XPVHV, xhv_fill), /* SVt_PVHV */
1021 sizeof(XPVCV) - MAYBE_OFFSET(XPVCV, xpv_cur), /* SVt_PVCV */
1022 sizeof(XPVFM) - MAYBE_OFFSET(XPVFM, xpv_cur), /* SVt_PVFM */
1023 sizeof(XPVIO) /* SVt_PVIO */
1024 #elif PERL_VERSION < 13
1028 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
1029 sizeof(XPV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PV */
1030 sizeof(XPVIV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PVIV */
1031 sizeof(XPVNV), /* SVt_PVNV */
1032 sizeof(XPVMG), /* SVt_PVMG */
1033 sizeof(regexp) - MAYBE_OFFSET(regexp, xpv_cur), /* SVt_REGEXP */
1034 sizeof(XPVGV), /* SVt_PVGV */
1035 sizeof(XPVLV), /* SVt_PVLV */
1036 sizeof(XPVAV) - MAYBE_OFFSET(XPVAV, xav_fill), /* SVt_PVAV */
1037 sizeof(XPVHV) - MAYBE_OFFSET(XPVHV, xhv_fill), /* SVt_PVHV */
1038 sizeof(XPVCV) - MAYBE_OFFSET(XPVCV, xpv_cur), /* SVt_PVCV */
1039 sizeof(XPVFM) - MAYBE_OFFSET(XPVFM, xpv_cur), /* SVt_PVFM */
1040 sizeof(XPVIO) /* SVt_PVIO */
1045 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
1046 sizeof(XPV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PV */
1047 sizeof(XPVIV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PVIV */
1048 sizeof(XPVNV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PVNV */
1049 sizeof(XPVMG), /* SVt_PVMG */
1050 sizeof(regexp), /* SVt_REGEXP */
1051 sizeof(XPVGV), /* SVt_PVGV */
1052 sizeof(XPVLV), /* SVt_PVLV */
1053 sizeof(XPVAV), /* SVt_PVAV */
1054 sizeof(XPVHV), /* SVt_PVHV */
1055 sizeof(XPVCV), /* SVt_PVCV */
1056 sizeof(XPVFM), /* SVt_PVFM */
1057 sizeof(XPVIO) /* SVt_PVIO */
1062 /* based on Perl_do_dump_pad() - wraps sv_size and adds ADD_ATTR calls for the pad names */
1064 padlist_size(pTHX_ struct state *const st, pPATH, PADLIST *padlist,
1067 dNPathUseParent(NPathArg);
1074 if( 0 && !check_new(st, padlist))
1077 pad_name = MUTABLE_AV(*av_fetch(MUTABLE_AV(padlist), 0, FALSE));
1078 pname = AvARRAY(pad_name);
1080 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
1081 const SV *namesv = pname[ix];
1082 if (namesv && namesv == &PL_sv_undef) {
1086 /* SvFAKE: On a pad name SV, that slot in the frame AV is a REFCNT'ed reference to a lexical from "outside" */
1088 ADD_ATTR(st, NPattr_PADFAKE, SvPVX_const(namesv), ix);
1090 ADD_ATTR(st, NPattr_PADNAME, SvPVX_const(namesv), ix);
1093 ADD_ATTR(st, NPattr_PADTMP, "SVs_PADTMP", ix);
1097 sv_size(aTHX_ st, NPathArg, (SV*)padlist, recurse);
1102 sv_size(pTHX_ struct state *const st, pPATH, const SV * const orig_thing,
1103 const int recurse) {
1104 const SV *thing = orig_thing;
1105 dNPathNodes(3, NPathArg);
1108 if(!check_new(st, orig_thing))
1111 type = SvTYPE(thing);
1112 if (type > SVt_LAST) {
1113 warn("Devel::Size: Unknown variable type: %d encountered\n", type);
1116 NPathPushNode(thing, NPtype_SV);
1117 ADD_SIZE(st, "sv_head", sizeof(SV));
1118 ADD_SIZE(st, "sv_body", body_sizes[type]);
1121 #if (PERL_VERSION < 11)
1122 /* Is it a reference? */
1127 if(recurse && SvROK(thing)) /* XXX maybe don't follow weakrefs */
1128 sv_size(aTHX_ st, (SvWEAKREF(thing) ? NPathLink("weakRV") : NPathLink("RV")), SvRV_const(thing), recurse);
1132 /* Is there anything in the array? */
1133 if (AvMAX(thing) != -1) {
1134 /* an array with 10 slots has AvMax() set to 9 - te 2007-04-22 */
1135 ADD_SIZE(st, "av_max", sizeof(SV *) * (AvMAX(thing) + 1));
1136 ADD_ATTR(st, NPattr_NOTE, "av_len", av_len((AV*)thing));
1137 dbg_printf(("total_size: %li AvMAX: %li av_len: $i\n", st->total_size, AvMAX(thing), av_len((AV*)thing)));
1139 if (recurse >= st->min_recurse_threshold) {
1140 SSize_t i = AvFILLp(thing) + 1;
1143 if (sv_size(aTHX_ st, NPathLink("AVelem"), AvARRAY(thing)[i], recurse))
1144 ADD_LINK_ATTR(st, NPattr_NOTE, "i", i);
1148 /* Add in the bits on the other side of the beginning */
1150 dbg_printf(("total_size %li, sizeof(SV *) %li, AvARRAY(thing) %li, AvALLOC(thing)%li , sizeof(ptr) %li \n",
1151 st->total_size, sizeof(SV*), AvARRAY(thing), AvALLOC(thing), sizeof( thing )));
1153 /* under Perl 5.8.8 64bit threading, AvARRAY(thing) was a pointer while AvALLOC was 0,
1154 resulting in grossly overstated sized for arrays. Technically, this shouldn't happen... */
1155 if (AvALLOC(thing) != 0) {
1156 ADD_SIZE(st, "AvALLOC", (sizeof(SV *) * (AvARRAY(thing) - AvALLOC(thing))));
1158 #if (PERL_VERSION < 9)
1159 /* Is there something hanging off the arylen element?
1160 Post 5.9.something this is stored in magic, so will be found there,
1161 and Perl_av_arylen_p() takes a non-const AV*, hence compilers rightly
1162 complain about AvARYLEN() passing thing to it. */
1163 sv_size(aTHX_ st, NPathLink("ARYLEN"), AvARYLEN(thing), recurse);
1168 /* Now the array of buckets */
1170 if (HvENAME(thing)) { ADD_ATTR(st, NPattr_NAME, HvENAME(thing), 0); }
1172 if (HvNAME(thing)) { ADD_ATTR(st, NPattr_NAME, HvNAME(thing), 0); }
1174 ADD_SIZE(st, "hv_max", (sizeof(HE *) * (HvMAX(thing) + 1)));
1175 /* Now walk the bucket chain */
1176 if (HvARRAY(thing)) {
1180 for (cur_bucket = 0; cur_bucket <= HvMAX(thing); cur_bucket++) {
1181 cur_entry = *(HvARRAY(thing) + cur_bucket);
1183 NPathPushNode("he", NPtype_LINK);
1184 NPathPushNode("he+hek", NPtype_NAME);
1185 ADD_SIZE(st, "he", sizeof(HE));
1186 hek_size(aTHX_ st, cur_entry->hent_hek, HvSHAREKEYS(thing), NPathLink("hent_hek"));
1187 if (recurse >= st->min_recurse_threshold) {
1188 if (orig_thing == (SV*)PL_strtab) {
1189 /* For PL_strtab the HeVAL is used as a refcnt */
1190 ADD_SIZE(st, "shared_hek", HeKLEN(cur_entry));
1193 /* I've seen a PL_strtab HeVAL == 0xC and 0x40C etc
1194 * just running perl -Mblib -Mstrict -MDevel::Size=:all -MCarp -e 'warn perl_size()'
1195 * but it seemed like a corruption - it would change come and go with irrelevant code changes.
1196 * so we protect against that here, but I'd like to know the cause.
1198 if (PTR2UV(HeVAL(cur_entry)) > 0xFFF)
1199 sv_size(aTHX_ st, NPathLink("HeVAL"), HeVAL(cur_entry), recurse);
1200 else warn("skipped suspect HeVAL %p", HeVAL(cur_entry));
1203 cur_entry = cur_entry->hent_next;
1207 } /* bucket chain */
1212 /* This direct access is arguably "naughty": */
1213 struct mro_meta *meta = HvAUX(thing)->xhv_mro_meta;
1214 #if PERL_VERSION > 13 || PERL_SUBVERSION > 8 /* XXX plain || seems like a bug */
1216 I32 count = HvAUX(thing)->xhv_name_count;
1219 HEK **names = HvAUX(thing)->xhv_name_u.xhvnameu_names;
1223 hek_size(aTHX_ st, names[count], 1, NPathLink("HvAUXelem"));
1228 hek_size(aTHX_ st, HvNAME_HEK(thing), 1, NPathLink("HvNAME_HEK"));
1231 ADD_SIZE(st, "xpvhv_aux", sizeof(struct xpvhv_aux));
1233 ADD_SIZE(st, "mro_meta", sizeof(struct mro_meta));
1234 sv_size(aTHX_ st, NPathLink("mro_nextmethod"), (SV *)meta->mro_nextmethod, TOTAL_SIZE_RECURSION);
1235 #if PERL_VERSION > 10 || (PERL_VERSION == 10 && PERL_SUBVERSION > 0)
1236 sv_size(aTHX_ st, NPathLink("isa"), (SV *)meta->isa, TOTAL_SIZE_RECURSION);
1238 #if PERL_VERSION > 10
1239 sv_size(aTHX_ st, NPathLink("mro_linear_all"), (SV *)meta->mro_linear_all, TOTAL_SIZE_RECURSION);
1240 sv_size(aTHX_ st, NPathLink("mro_linear_current"), meta->mro_linear_current, TOTAL_SIZE_RECURSION);
1242 sv_size(aTHX_ st, NPathLink("mro_linear_dfs"), (SV *)meta->mro_linear_dfs, TOTAL_SIZE_RECURSION);
1243 sv_size(aTHX_ st, NPathLink("mro_linear_c3"), (SV *)meta->mro_linear_c3, TOTAL_SIZE_RECURSION);
1248 check_new_and_strlen(st, HvNAME_get(thing), NPathLink("HvNAME"));
1254 padlist_size(aTHX_ st, NPathLink("CvPADLIST"), CvPADLIST(thing), recurse);
1255 sv_size(aTHX_ st, NPathLink("CvOUTSIDE"), (SV *)CvOUTSIDE(thing), SOME_RECURSION);
1257 if (st->go_yell && !st->fm_whine) {
1258 carp("Devel::Size: Calculated sizes for FMs are incomplete");
1264 /* not CvSTASH, per https://rt.cpan.org/Ticket/Display.html?id=79366 */
1265 ADD_ATTR(st, NPattr_NAME, CvGV(thing) ? GvNAME(CvGV(thing)) : "UNDEFINED", 0);
1266 sv_size(aTHX_ st, NPathLink("CvGV"), (SV *)CvGV(thing), SOME_RECURSION);
1267 padlist_size(aTHX_ st, NPathLink("CvPADLIST"), CvPADLIST(thing), recurse);
1268 sv_size(aTHX_ st, NPathLink("CvOUTSIDE"), (SV *)CvOUTSIDE(thing), SOME_RECURSION);
1269 if (CvISXSUB(thing)) {
1270 sv_size(aTHX_ st, NPathLink("cv_const_sv"), cv_const_sv((CV *)thing), recurse);
1272 if(1)op_size(aTHX_ CvSTART(thing), st, NPathLinkAndNode("CvSTART", "OPs")); /* XXX ? */
1273 op_size(aTHX_ CvROOT(thing), st, NPathLinkAndNode("CvROOT", "OPs"));
1278 /* Some embedded char pointers */
1279 check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_top_name, NPathLink("xio_top_name"));
1280 check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_fmt_name, NPathLink("xio_fmt_name"));
1281 check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_bottom_name, NPathLink("xio_bottom_name"));
1282 /* Throw the GVs on the list to be walked if they're not-null */
1283 sv_size(aTHX_ st, NPathLink("xio_top_gv"), (SV *)((XPVIO *) SvANY(thing))->xio_top_gv, recurse);
1284 sv_size(aTHX_ st, NPathLink("xio_bottom_gv"), (SV *)((XPVIO *) SvANY(thing))->xio_bottom_gv, recurse);
1285 sv_size(aTHX_ st, NPathLink("xio_fmt_gv"), (SV *)((XPVIO *) SvANY(thing))->xio_fmt_gv, recurse);
1287 /* Only go trotting through the IO structures if they're really
1288 trottable. If USE_PERLIO is defined we can do this. If
1289 not... we can't, so we don't even try */
1291 /* Dig into xio_ifp and xio_ofp here */
1292 warn("Devel::Size: Can't size up perlio layers yet\n");
1297 #if (PERL_VERSION < 9)
1302 if(isGV_with_GP(thing)) {
1304 hek_size(aTHX_ st, GvNAME_HEK(thing), 1, NPathLink("GvNAME_HEK"));
1306 ADD_SIZE(st, "GvNAMELEN", GvNAMELEN(thing));
1308 ADD_ATTR(st, NPattr_NAME, GvNAME_get(thing), 0);
1310 hek_size(aTHX_ st, GvFILE_HEK(thing), 1, NPathLink("GvFILE_HEK"));
1311 #elif defined(GvFILE)
1312 # if !defined(USE_ITHREADS) || (PERL_VERSION > 8 || (PERL_VERSION == 8 && PERL_SUBVERSION > 8))
1313 /* With itreads, before 5.8.9, this can end up pointing to freed memory
1314 if the GV was created in an eval, as GvFILE() points to CopFILE(),
1315 and the relevant COP has been freed on scope cleanup after the eval.
1316 5.8.9 adds a binary compatible fudge that catches the vast majority
1317 of cases. 5.9.something added a proper fix, by converting the GP to
1318 use a shared hash key (porperly reference counted), instead of a
1319 char * (owned by who knows? possibly no-one now) */
1320 check_new_and_strlen(st, GvFILE(thing), NPathLink("GvFILE"));
1323 /* Is there something hanging off the glob? */
1324 if (check_new(st, GvGP(thing))) {
1325 ADD_SIZE(st, "GP", sizeof(GP));
1326 sv_size(aTHX_ st, NPathLink("gp_sv"), (SV *)(GvGP(thing)->gp_sv), recurse);
1327 sv_size(aTHX_ st, NPathLink("gp_av"), (SV *)(GvGP(thing)->gp_av), recurse);
1328 sv_size(aTHX_ st, NPathLink("gp_hv"), (SV *)(GvGP(thing)->gp_hv), recurse);
1329 sv_size(aTHX_ st, NPathLink("gp_cv"), (SV *)(GvGP(thing)->gp_cv), recurse);
1330 sv_size(aTHX_ st, NPathLink("gp_egv"), (SV *)(GvGP(thing)->gp_egv), recurse);
1331 sv_size(aTHX_ st, NPathLink("gp_form"), (SV *)(GvGP(thing)->gp_form), recurse);
1333 #if (PERL_VERSION >= 9)
1337 #if PERL_VERSION <= 8
1345 if(recurse && SvROK(thing))
1346 sv_size(aTHX_ st, NPathLink("RV"), SvRV_const(thing), recurse);
1347 else if (SvIsCOW_shared_hash(thing))
1348 hek_size(aTHX_ st, SvSHARED_HEK_FROM_PV(SvPVX(thing)), 1, NPathLink("SvSHARED_HEK_FROM_PV"));
1350 ADD_SIZE(st, "SvLEN", SvLEN(thing));
1354 SvOOK_offset(thing, len);
1355 ADD_SIZE(st, "SvOOK", len);
1361 if (type >= SVt_PVMG) {
1362 if (SvMAGICAL(thing))
1363 magic_size(aTHX_ thing, st, NPathLink("MG"));
1364 if (SvPAD_OUR(thing) && SvOURSTASH(thing))
1365 sv_size(aTHX_ st, NPathLink("SvOURSTASH"), (SV *)SvOURSTASH(thing), SOME_RECURSION);
1367 sv_size(aTHX_ st, NPathLink("SvSTASH"), (SV *)SvSTASH(thing), SOME_RECURSION);
1374 free_memnode_state(pTHX_ struct state *st)
1376 /* PERL_UNUSED_ARG(aTHX); fails for non-threaded perl */
1377 if (st->node_stream_fh && st->node_stream_name && *st->node_stream_name) {
1378 fprintf(st->node_stream_fh, "E %d %f %s\n",
1379 getpid(), gettimeofday_nv()-st->start_time_nv, "unnamed");
1380 if (*st->node_stream_name == '|') {
1381 if (pclose(st->node_stream_fh))
1382 warn("%s exited with an error status\n", st->node_stream_name);
1385 if (fclose(st->node_stream_fh))
1386 warn("Error closing %s: %s\n", st->node_stream_name, strerror(errno));
1391 static struct state *
1397 Newxz(st, 1, struct state);
1399 st->min_recurse_threshold = TOTAL_SIZE_RECURSION;
1400 if (NULL != (warn_flag = get_sv("Devel::Size::warn", FALSE))) {
1401 st->dangle_whine = st->go_yell = SvIV(warn_flag) ? TRUE : FALSE;
1403 if (NULL != (warn_flag = get_sv("Devel::Size::dangle", FALSE))) {
1404 st->dangle_whine = SvIV(warn_flag) ? TRUE : FALSE;
1406 st->start_time_nv = gettimeofday_nv();
1407 check_new(st, &PL_sv_undef);
1408 check_new(st, &PL_sv_no);
1409 check_new(st, &PL_sv_yes);
1410 #if PERL_VERSION > 8 || (PERL_VERSION == 8 && PERL_SUBVERSION > 0)
1411 check_new(st, &PL_sv_placeholder);
1414 #ifdef PATH_TRACKING
1415 /* XXX quick hack */
1416 st->node_stream_name = getenv("SIZEME");
1417 if (st->node_stream_name) {
1418 if (*st->node_stream_name) {
1419 if (*st->node_stream_name == '|')
1420 st->node_stream_fh = popen(st->node_stream_name+1, "w");
1422 st->node_stream_fh = fopen(st->node_stream_name, "wb");
1423 if (!st->node_stream_fh)
1424 croak("Can't open '%s' for writing: %s", st->node_stream_name, strerror(errno));
1425 if(0)setlinebuf(st->node_stream_fh); /* XXX temporary for debugging */
1426 st->add_attr_cb = np_stream_node_path_info;
1427 fprintf(st->node_stream_fh, "S %d %f %s\n",
1428 getpid(), st->start_time_nv, "unnamed");
1431 st->add_attr_cb = np_dump_node_path_info;
1433 st->free_state_cb = free_memnode_state;
1439 /* XXX based on S_visit() in sv.c */
1441 unseen_sv_size(pTHX_ struct state *st, pPATH)
1445 dNPathNodes(1, NPathArg);
1447 NPathPushNode("unseen", NPtype_NAME);
1449 /* by this point we should have visited all the SVs
1450 * so now we'll run through all the SVs via the arenas
1451 * in order to find any that we've missed for some reason.
1452 * Once the rest of the code is finding ALL the SVs then any
1453 * found here will be leaks.
1455 for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) {
1456 const SV * const svend = &sva[SvREFCNT(sva)];
1458 for (sv = sva + 1; sv < svend; ++sv) {
1459 if (SvTYPE(sv) != (svtype)SVTYPEMASK && SvREFCNT(sv)) {
1460 sv_size(aTHX_ st, NPathLink("arena"), sv, TOTAL_SIZE_RECURSION);
1462 else if (check_new(st, sv)) { /* sanity check */
1464 warn("unseen_sv_size encountered freed SV unexpectedly"); /* XXX warn uses an SV, I think */
1472 madprop_size(pTHX_ struct state *const st, pPath, MADPROP *prop)
1474 dPathNodes(2, NPathArg);
1475 if (!check_new(st, prop))
1477 NPathPushNode("madprop_size", NPtype_NAME);
1478 ADD_SIZE(st, "MADPROP", sizeof(MADPROP));
1480 NPathPushNode("val");
1481 ADD_SIZE(st, "val", prop->mad_val);
1483 madprop_size(aTHX_ st, NPathLink("mad_next"), prop->mad_next);
1488 parser_size(pTHX_ struct state *const st, pPATH, yy_parser *parser)
1490 dNPathNodes(2, NPathArg);
1491 if (!check_new(st, parser))
1493 NPathPushNode("parser_size", NPtype_NAME);
1494 ADD_SIZE(st, "yy_parser", sizeof(yy_parser));
1496 NPathPushNode("stack", NPtype_NAME);
1498 /*warn("total: %u", parser->stack_size); */
1499 /*warn("foo: %u", parser->ps - parser->stack); */
1500 ADD_SIZE(st, "stack_frames", parser->stack_size * sizeof(yy_stack_frame));
1501 for (ps = parser->stack; ps <= parser->ps; ps++) {
1502 if (sv_size(aTHX_ st, NPathLink("compcv"), (SV*)ps->compcv, TOTAL_SIZE_RECURSION))
1503 ADD_LINK_ATTR(st, NPattr_NOTE, "i", ps - parser->ps);
1507 sv_size(aTHX_ st, NPathLink("lex_repl"), (SV*)parser->lex_repl, TOTAL_SIZE_RECURSION);
1508 sv_size(aTHX_ st, NPathLink("lex_stuff"), (SV*)parser->lex_stuff, TOTAL_SIZE_RECURSION);
1509 sv_size(aTHX_ st, NPathLink("linestr"), (SV*)parser->linestr, TOTAL_SIZE_RECURSION);
1510 sv_size(aTHX_ st, NPathLink("in_my_stash"), (SV*)parser->in_my_stash, TOTAL_SIZE_RECURSION);
1511 /*sv_size(aTHX_ st, NPathLink("rsfp"), parser->rsfp, TOTAL_SIZE_RECURSION); */
1512 sv_size(aTHX_ st, NPathLink("rsfp_filters"), (SV*)parser->rsfp_filters, TOTAL_SIZE_RECURSION);
1514 sv_size(aTHX_ st, NPathLink("endwhite"), parser->endwhite, TOTAL_SIZE_RECURSION);
1515 sv_size(aTHX_ st, NPathLink("nextwhite"), parser->nextwhite, TOTAL_SIZE_RECURSION);
1516 sv_size(aTHX_ st, NPathLink("skipwhite"), parser->skipwhite, TOTAL_SIZE_RECURSION);
1517 sv_size(aTHX_ st, NPathLink("thisclose"), parser->thisclose, TOTAL_SIZE_RECURSION);
1518 madprop_size(aTHX_ st, NPathLink("thismad"), parser->thismad);
1519 sv_size(aTHX_ st, NPathLink("thisopen"), parser->thisopen, TOTAL_SIZE_RECURSION);
1520 sv_size(aTHX_ st, NPathLink("thisstuff"), parser->thisstuff, TOTAL_SIZE_RECURSION);
1521 sv_size(aTHX_ st, NPathLink("thistoken"), parser->thistoken, TOTAL_SIZE_RECURSION);
1522 sv_size(aTHX_ st, NPathLink("thiswhite"), parser->thiswhite, TOTAL_SIZE_RECURSION);
1524 op_size_class(aTHX_ (OP*)parser->saved_curcop, OPc_COP, 0,
1525 st, NPathLink("saved_curcop"));
1527 if (parser->old_parser)
1528 parser_size(aTHX_ st, NPathLink("old_parser"), parser->old_parser);
1532 perl_size(pTHX_ struct state *const st, pPATH)
1534 dNPathNodes(3, NPathArg);
1536 /* if(!check_new(st, interp)) return; */
1537 NPathPushNode("perl", NPtype_NAME);
1538 #if defined(MULTIPLICITY)
1539 ADD_SIZE(st, "PerlInterpreter", sizeof(PerlInterpreter));
1545 * unknown <== = O/S Heap size - perl - free_malloc_space
1547 /* start with PL_defstash to get everything reachable from \%main:: */
1548 sv_size(aTHX_ st, NPathLink("PL_defstash"), (SV*)PL_defstash, TOTAL_SIZE_RECURSION);
1550 NPathPushNode("others", NPtype_NAME); /* group these (typically much smaller) items */
1551 sv_size(aTHX_ st, NPathLink("PL_defgv"), (SV*)PL_defgv, TOTAL_SIZE_RECURSION);
1552 sv_size(aTHX_ st, NPathLink("PL_incgv"), (SV*)PL_incgv, TOTAL_SIZE_RECURSION);
1553 sv_size(aTHX_ st, NPathLink("PL_rs"), (SV*)PL_rs, TOTAL_SIZE_RECURSION);
1554 sv_size(aTHX_ st, NPathLink("PL_fdpid"), (SV*)PL_fdpid, TOTAL_SIZE_RECURSION);
1555 sv_size(aTHX_ st, NPathLink("PL_modglobal"), (SV*)PL_modglobal, TOTAL_SIZE_RECURSION);
1556 sv_size(aTHX_ st, NPathLink("PL_errors"), (SV*)PL_errors, TOTAL_SIZE_RECURSION);
1557 sv_size(aTHX_ st, NPathLink("PL_stashcache"), (SV*)PL_stashcache, TOTAL_SIZE_RECURSION);
1558 sv_size(aTHX_ st, NPathLink("PL_patchlevel"), (SV*)PL_patchlevel, TOTAL_SIZE_RECURSION);
1559 sv_size(aTHX_ st, NPathLink("PL_apiversion"), (SV*)PL_apiversion, TOTAL_SIZE_RECURSION);
1560 sv_size(aTHX_ st, NPathLink("PL_registered_mros"), (SV*)PL_registered_mros, TOTAL_SIZE_RECURSION);
1562 sv_size(aTHX_ st, NPathLink("PL_regex_padav"), (SV*)PL_regex_padav, TOTAL_SIZE_RECURSION);
1564 sv_size(aTHX_ st, NPathLink("PL_warnhook"), (SV*)PL_warnhook, TOTAL_SIZE_RECURSION);
1565 sv_size(aTHX_ st, NPathLink("PL_diehook"), (SV*)PL_diehook, TOTAL_SIZE_RECURSION);
1566 sv_size(aTHX_ st, NPathLink("PL_endav"), (SV*)PL_endav, TOTAL_SIZE_RECURSION);
1567 sv_size(aTHX_ st, NPathLink("PL_main_cv"), (SV*)PL_main_cv, TOTAL_SIZE_RECURSION);
1568 sv_size(aTHX_ st, NPathLink("PL_main_root"), (SV*)PL_main_root, TOTAL_SIZE_RECURSION);
1569 sv_size(aTHX_ st, NPathLink("PL_main_start"), (SV*)PL_main_start, TOTAL_SIZE_RECURSION);
1570 sv_size(aTHX_ st, NPathLink("PL_envgv"), (SV*)PL_envgv, TOTAL_SIZE_RECURSION);
1571 sv_size(aTHX_ st, NPathLink("PL_hintgv"), (SV*)PL_hintgv, TOTAL_SIZE_RECURSION);
1572 sv_size(aTHX_ st, NPathLink("PL_e_script"), (SV*)PL_e_script, TOTAL_SIZE_RECURSION);
1573 sv_size(aTHX_ st, NPathLink("PL_encoding"), (SV*)PL_encoding, TOTAL_SIZE_RECURSION);
1574 sv_size(aTHX_ st, NPathLink("PL_ofsgv"), (SV*)PL_ofsgv, TOTAL_SIZE_RECURSION);
1575 sv_size(aTHX_ st, NPathLink("PL_argvout_stack"), (SV*)PL_argvout_stack, TOTAL_SIZE_RECURSION);
1576 sv_size(aTHX_ st, NPathLink("PL_beginav"), (SV*)PL_beginav, TOTAL_SIZE_RECURSION);
1577 sv_size(aTHX_ st, NPathLink("PL_beginav_save"), (SV*)PL_beginav_save, TOTAL_SIZE_RECURSION);
1578 sv_size(aTHX_ st, NPathLink("PL_checkav_save"), (SV*)PL_checkav_save, TOTAL_SIZE_RECURSION);
1579 sv_size(aTHX_ st, NPathLink("PL_unitcheckav"), (SV*)PL_unitcheckav, TOTAL_SIZE_RECURSION);
1580 sv_size(aTHX_ st, NPathLink("PL_unitcheckav_save"), (SV*)PL_unitcheckav_save, TOTAL_SIZE_RECURSION);
1581 sv_size(aTHX_ st, NPathLink("PL_endav"), (SV*)PL_endav, TOTAL_SIZE_RECURSION);
1582 sv_size(aTHX_ st, NPathLink("PL_checkav"), (SV*)PL_checkav, TOTAL_SIZE_RECURSION);
1583 sv_size(aTHX_ st, NPathLink("PL_initav"), (SV*)PL_initav, TOTAL_SIZE_RECURSION);
1584 sv_size(aTHX_ st, NPathLink("PL_isarev"), (SV*)PL_isarev, TOTAL_SIZE_RECURSION);
1585 sv_size(aTHX_ st, NPathLink("PL_fdpid"), (SV*)PL_fdpid, TOTAL_SIZE_RECURSION);
1586 sv_size(aTHX_ st, NPathLink("PL_preambleav"), (SV*)PL_preambleav, TOTAL_SIZE_RECURSION);
1587 sv_size(aTHX_ st, NPathLink("PL_ors_sv"), (SV*)PL_ors_sv, TOTAL_SIZE_RECURSION);
1588 sv_size(aTHX_ st, NPathLink("PL_modglobal"), (SV*)PL_modglobal, TOTAL_SIZE_RECURSION);
1589 sv_size(aTHX_ st, NPathLink("PL_custom_op_names"), (SV*)PL_custom_op_names, TOTAL_SIZE_RECURSION);
1590 sv_size(aTHX_ st, NPathLink("PL_custom_op_descs"), (SV*)PL_custom_op_descs, TOTAL_SIZE_RECURSION);
1591 sv_size(aTHX_ st, NPathLink("PL_custom_ops"), (SV*)PL_custom_ops, TOTAL_SIZE_RECURSION);
1592 sv_size(aTHX_ st, NPathLink("PL_compcv"), (SV*)PL_compcv, TOTAL_SIZE_RECURSION);
1593 sv_size(aTHX_ st, NPathLink("PL_DBcv"), (SV*)PL_DBcv, TOTAL_SIZE_RECURSION);
1594 #ifdef PERL_USES_PL_PIDSTATUS
1595 sv_size(aTHX_ st, NPathLink("PL_pidstatus"), (SV*)PL_pidstatus, TOTAL_SIZE_RECURSION);
1597 sv_size(aTHX_ st, NPathLink("PL_subname"), (SV*)PL_subname, TOTAL_SIZE_RECURSION);
1598 #ifdef USE_LOCALE_NUMERIC
1599 sv_size(aTHX_ st, NPathLink("PL_numeric_radix_sv"), (SV*)PL_numeric_radix_sv, TOTAL_SIZE_RECURSION);
1600 check_new_and_strlen(st, PL_numeric_name, NPathLink("PL_numeric_name"));
1602 #ifdef USE_LOCALE_COLLATE
1603 check_new_and_strlen(st, PL_collation_name, NPathLink("PL_collation_name"));
1605 check_new_and_strlen(st, PL_origfilename, NPathLink("PL_origfilename"));
1606 check_new_and_strlen(st, PL_inplace, NPathLink("PL_inplace"));
1607 check_new_and_strlen(st, PL_osname, NPathLink("PL_osname"));
1608 if (PL_op_mask && check_new(st, PL_op_mask))
1609 ADD_SIZE(st, "PL_op_mask", PL_maxo);
1610 if (PL_exitlistlen && check_new(st, PL_exitlist))
1611 ADD_SIZE(st, "PL_exitlist", (PL_exitlistlen * sizeof(PerlExitListEntry *))
1612 + (PL_exitlistlen * sizeof(PerlExitListEntry)));
1613 #ifdef PERL_IMPLICIT_CONTEXT
1614 if (PL_my_cxt_size && check_new(st, PL_my_cxt_list)) {
1615 ADD_SIZE(st, "PL_my_cxt_list", (PL_my_cxt_size * sizeof(void *)));
1616 #ifdef PERL_GLOBAL_STRUCT_PRIVATE
1617 ADD_SIZE(st, "PL_my_cxt_keys", (PL_my_cxt_size * sizeof(char *)));
1621 /* TODO PL_stashpad */
1622 op_size_class(aTHX_ (OP*)&PL_compiling, OPc_COP, 1, st, NPathLink("PL_compiling"));
1623 op_size_class(aTHX_ (OP*)PL_curcopdb, OPc_COP, 0, st, NPathLink("PL_curcopdb"));
1625 parser_size(aTHX_ st, NPathLink("PL_parser"), PL_parser);
1626 /* TODO stacks: cur, main, tmps, mark, scope, save */
1627 /* TODO PL_exitlist */
1628 /* TODO PL_reentrant_buffers etc */
1630 /* TODO PerlIO? PL_known_layers PL_def_layerlist PL_perlio_fd_refcnt etc */
1632 /* TODO anything missed? */
1634 /* --- by this point we should have seen all reachable SVs --- */
1636 /* in theory we shouldn't have any elements in PL_strtab that haven't been seen yet */
1637 sv_size(aTHX_ st, NPathLink("PL_strtab-unseen"), (SV*)PL_strtab, TOTAL_SIZE_RECURSION);
1639 /* unused space in sv head arenas */
1643 # define SvARENA_CHAIN(sv) SvANY(sv) /* XXX breaks encapsulation*/
1644 while ((p = MUTABLE_SV(SvARENA_CHAIN(p)))) {
1645 if (!check_new(st, p)) /* sanity check */
1646 warn("Free'd SV head unexpectedly already seen");
1649 NPathPushNode("unused_sv_heads", NPtype_NAME);
1650 ADD_SIZE(st, "sv", free_heads * sizeof(SV));
1653 /* XXX iterate over bodies_by_type and crawl the free chains for each */
1655 /* iterate over all SVs to find any we've not accounted for yet */
1656 /* once the code above is visiting all SVs, any found here have been leaked */
1657 unseen_sv_size(aTHX_ st, NPathLink("unaccounted"));
1661 MODULE = Devel::SizeMe PACKAGE = Devel::SizeMe
1669 total_size = TOTAL_SIZE_RECURSION
1672 SV *thing = orig_thing;
1673 struct state *st = new_state(aTHX);
1675 /* If they passed us a reference then dereference it. This is the
1676 only way we can check the sizes of arrays and hashes */
1678 thing = SvRV(thing);
1681 sv_size(aTHX_ st, NULL, thing, ix);
1682 RETVAL = st->total_size;
1683 free_state(aTHX_ st);
1692 /* just the current perl interpreter */
1693 struct state *st = new_state(aTHX);
1694 st->min_recurse_threshold = NO_RECURSION; /* so always recurse */
1695 perl_size(aTHX_ st, NULL);
1696 RETVAL = st->total_size;
1697 free_state(aTHX_ st);
1706 /* the current perl interpreter plus malloc, in the context of total heap size */
1707 # ifdef _MALLOC_MALLOC_H_ /* OSX. Now sure where else mstats is available */
1711 /* some systems have the SVID2/XPG mallinfo structure and function */
1712 struct mstats ms = mstats(); /* mstats() first */
1714 struct state *st = new_state(aTHX);
1715 dNPathNodes(1, NULL);
1716 NPathPushNode("heap", NPtype_NAME);
1718 st->min_recurse_threshold = NO_RECURSION; /* so always recurse */
1720 perl_size(aTHX_ st, NPathLink("perl_interp"));
1722 NPathSetNode("free_malloc_space", NPtype_NAME);
1723 ADD_SIZE(st, "bytes_free", ms.bytes_free);
1724 ADD_ATTR(st, NPattr_NOTE, "bytes_total", ms.bytes_total);
1725 ADD_ATTR(st, NPattr_NOTE, "bytes_used", ms.bytes_used);
1726 ADD_ATTR(st, NPattr_NOTE, "chunks_used", ms.chunks_used);
1727 ADD_ATTR(st, NPattr_NOTE, "chunks_free", ms.chunks_free);
1728 /* TODO get heap size from OS and add a node: unknown = heapsize - perl - ms.bytes_free */
1729 /* for now we use bytes_total as an approximation */
1730 NPathSetNode("unknown", NPtype_NAME);
1731 ADD_SIZE(st, "unknown", ms.bytes_total - st->total_size);
1736 RETVAL = st->total_size;
1737 free_state(aTHX_ st);