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)))
48 # define PL_opargs opargs
49 # define PL_op_name op_name
53 /* "structured exception" handling is a Microsoft extension to C and C++.
54 It's *not* C++ exception handling - C++ exception handling can't capture
55 SEGVs and suchlike, whereas this can. There's no known analagous
56 functionality on other platforms. */
58 # define TRY_TO_CATCH_SEGV __try
59 # define CAUGHT_EXCEPTION __except(EXCEPTION_EXECUTE_HANDLER)
61 # define TRY_TO_CATCH_SEGV if(1)
62 # define CAUGHT_EXCEPTION else
66 # define __attribute__(x)
69 #if 0 && defined(DEBUGGING)
70 #define dbg_printf(x) printf x
75 #define TAG /* printf( "# %s(%d)\n", __FILE__, __LINE__ ) */
78 /* The idea is to have a tree structure to store 1 bit per possible pointer
79 address. The lowest 16 bits are stored in a block of 8092 bytes.
80 The blocks are in a 256-way tree, indexed by the reset of the pointer.
81 This can cope with 32 and 64 bit pointers, and any address space layout,
82 without excessive memory needs. The assumption is that your CPU cache
83 works :-) (And that we're not going to bust it) */
86 #define LEAF_BITS (16 - BYTE_BITS)
87 #define LEAF_MASK 0x1FFF
89 typedef struct npath_node_st npath_node_t;
90 struct npath_node_st {
105 /* My hunch (not measured) is that for most architectures pointers will
106 start with 0 bits, hence the start of this array will be hot, and the
107 end unused. So put the flags next to the hot end. */
110 int min_recurse_threshold;
111 /* callback hooks and data */
112 void (*add_attr_cb)(pTHX_ struct state *st, npath_node_t *npath_node, UV attr_type, const char *name, UV value);
113 void (*free_state_cb)(pTHX_ struct state *st);
114 void *state_cb_data; /* free'd by free_state() after free_state_cb() call */
115 /* this stuff wil be moved to state_cb_data later */
117 FILE *node_stream_fh;
118 char *node_stream_name;
121 #define ADD_SIZE(st, leafname, bytes) \
123 NPathAddSizeCb(st, leafname, bytes); \
124 (st)->total_size += (bytes); \
128 #define PATH_TRACKING
131 #define pPATH npath_node_t *NPathArg
133 /* A subtle point here is that dNPathNodes and NPathPushNode leave NP pointing
134 * to the next unused slot (though with prev already filled in)
135 * whereas NPathLink leaves NP unchanged, it just fills in the slot NP points
136 * to and passes that NP value to the function being called.
137 * seqn==0 indicates the node is new (hasn't been output yet)
139 #define dNPathNodes(nodes, prev_np) \
140 npath_node_t name_path_nodes[nodes+1]; /* +1 for NPathLink */ \
141 npath_node_t *NP = &name_path_nodes[0]; \
142 NP->seqn = NP->type = 0; NP->id = Nullch; /* safety/debug */ \
144 #define NPathPushNode(nodeid, nodetype) \
146 NP->type = nodetype; \
148 if(0)fprintf(stderr,"NPathPushNode (%p <-) %p <- [%d %s]\n", NP->prev, NP, nodetype,(char*)nodeid);\
150 NP->id = Nullch; /* safety/debug */ \
153 #define NPathSetNode(nodeid, nodetype) \
154 (NP-1)->id = nodeid; \
155 (NP-1)->type = nodetype; \
156 if(0)fprintf(stderr,"NPathSetNode (%p <-) %p <- [%d %s]\n", (NP-1)->prev, (NP-1), nodetype,(char*)nodeid);\
158 #define NPathPopNode \
161 /* dNPathUseParent points NP directly the the parents' name_path_nodes array
162 * So the function can only safely call ADD_*() but not NPathLink, unless the
163 * caller has spare nodes in its name_path_nodes.
165 #define dNPathUseParent(prev_np) npath_node_t *NP = (((prev_np+1)->prev = prev_np), prev_np+1)
167 #define NPtype_NAME 0x01
168 #define NPtype_LINK 0x02
169 #define NPtype_SV 0x03
170 #define NPtype_MAGIC 0x04
171 #define NPtype_OP 0x05
173 /* XXX these should probably be generalized into flag bits */
174 #define NPattr_LEAFSIZE 0x00
175 #define NPattr_NAME 0x01
176 #define NPattr_PADFAKE 0x02
177 #define NPattr_PADNAME 0x03
178 #define NPattr_PADTMP 0x04
179 #define NPattr_NOTE 0x05
181 #define _ADD_ATTR_NP(st, attr_type, attr_name, attr_value, np) \
183 if (st->add_attr_cb) { \
184 st->add_attr_cb(aTHX_ st, np, attr_type, attr_name, attr_value); \
188 #define ADD_ATTR(st, attr_type, attr_name, attr_value) \
189 _ADD_ATTR_NP(st, attr_type, attr_name, attr_value, NP-1)
191 #define ADD_LINK_ATTR(st, attr_type, attr_name, attr_value) \
193 if (st->add_attr_cb) assert(NP->seqn); \
194 _ADD_ATTR_NP(st, attr_type, attr_name, attr_value, NP); \
197 #define _NPathLink(np, nid, ntype) (((np)->id=nid), ((np)->type=ntype), ((np)->seqn=0))
198 #define NPathLink(nid) (_NPathLink(NP, nid, NPtype_LINK), NP)
199 /* add a link and a name node to the path - a special case for op_size */
200 #define NPathLinkAndNode(nid, nid2) (_NPathLink(NP, nid, NPtype_LINK), _NPathLink(NP+1, nid2, NPtype_NAME), ((NP+1)->prev=NP), (NP+1))
201 #define NPathOpLink (NPathArg)
202 #define NPathAddSizeCb(st, name, bytes) \
204 if (st->add_attr_cb) { \
205 st->add_attr_cb(aTHX_ st, NP-1, NPattr_LEAFSIZE, (name), (bytes)); \
211 #define NPathAddSizeCb(st, name, bytes)
212 #define pPATH void *npath_dummy /* XXX ideally remove */
213 #define dNPathNodes(nodes, prev_np) dNOOP
214 #define NPathLink(nodeid, nodetype) NULL
215 #define NPathOpLink NULL
216 #define ADD_ATTR(st, attr_type, attr_name, attr_value) NOOP
218 #endif /* PATH_TRACKING */
225 static const char *svtypenames[SVt_LAST] = {
227 "NULL", "IV", "NV", "RV", "PV", "PVIV", "PVNV", "PVMG", "PVBM", "PVLV", "PVAV", "PVHV", "PVCV", "PVGV", "PVFM", "PVIO",
228 #elif PERL_VERSION == 10 && PERL_SUBVERSION == 0
229 "NULL", "BIND", "IV", "NV", "RV", "PV", "PVIV", "PVNV", "PVMG", "PVGV", "PVLV", "PVAV", "PVHV", "PVCV", "PVFM", "PVIO",
230 #elif PERL_VERSION == 10 && PERL_SUBVERSION == 1
231 "NULL", "BIND", "IV", "NV", "RV", "PV", "PVIV", "PVNV", "PVMG", "PVGV", "PVLV", "PVAV", "PVHV", "PVCV", "PVFM", "PVIO",
232 #elif PERL_VERSION < 13
233 "NULL", "BIND", "IV", "NV", "PV", "PVIV", "PVNV", "PVMG", "REGEXP", "PVGV", "PVLV", "PVAV", "PVHV", "PVCV", "PVFM", "PVIO",
235 "NULL", "BIND", "IV", "NV", "PV", "PVIV", "PVNV", "PVMG", "REGEXP", "PVGV", "PVLV", "PVAV", "PVHV", "PVCV", "PVFM", "PVIO",
240 gettimeofday_nv(void)
242 #ifdef HAS_GETTIMEOFDAY
244 gettimeofday(&when, (struct timezone *) 0);
245 return when.tv_sec + (when.tv_usec / 1000000.0);
249 (*u2time)(aTHX_ &time_of_day);
250 return time_of_day[0] + (time_of_day[1] / 1000000.0);
258 np_print_node_name(pTHX_ FILE *fp, npath_node_t *npath_node)
260 switch (npath_node->type) {
261 case NPtype_SV: { /* id is pointer to the SV sv_size was called on */
262 const SV *sv = (SV*)npath_node->id;
263 int type = SvTYPE(sv);
264 const char *typename = (type == SVt_IV && SvROK(sv)) ? "RV" : svtypenames[type];
265 fprintf(fp, "SV(%s)", typename);
266 switch(type) { /* add some useful details */
267 case SVt_PVAV: fprintf(fp, " fill=%d/%ld", av_len((AV*)sv), AvMAX((AV*)sv)); break;
268 case SVt_PVHV: fprintf(fp, " fill=%ld/%ld", HvFILL((HV*)sv), HvMAX((HV*)sv)); break;
272 case NPtype_OP: { /* id is pointer to the OP op_size was called on */
273 const OP *op = (OP*)npath_node->id;
274 fprintf(fp, "OP(%s)", OP_NAME(op));
277 case NPtype_MAGIC: { /* id is pointer to the MAGIC struct */
278 MAGIC *magic_pointer = (MAGIC*)npath_node->id;
279 /* XXX it would be nice if we could reuse mg_names.c [sigh] */
280 fprintf(fp, "MAGIC(%c)", magic_pointer->mg_type ? magic_pointer->mg_type : '0');
284 fprintf(fp, "%s", (const char *)npath_node->id);
287 fprintf(fp, "%s", (const char *)npath_node->id);
289 default: /* assume id is a string pointer */
290 fprintf(fp, "UNKNOWN(%d,%p)", npath_node->type, npath_node->id);
297 np_dump_indent(int depth) {
299 fprintf(stderr, ": ");
303 np_walk_new_nodes(pTHX_ struct state *st,
304 npath_node_t *npath_node,
305 npath_node_t *npath_node_deeper,
306 int (*cb)(pTHX_ struct state *st, npath_node_t *npath_node, npath_node_t *npath_node_deeper))
308 if (npath_node->seqn) /* node already output */
311 if (npath_node->prev) {
312 np_walk_new_nodes(aTHX_ st, npath_node->prev, npath_node, cb); /* recurse */
313 npath_node->depth = npath_node->prev->depth + 1;
315 else npath_node->depth = 0;
316 npath_node->seqn = ++st->seqn;
319 if (cb(aTHX_ st, npath_node, npath_node_deeper)) {
320 /* ignore this node */
321 assert(npath_node->prev);
322 assert(npath_node->depth);
323 assert(npath_node_deeper);
325 npath_node->seqn = --st->seqn;
326 npath_node_deeper->prev = npath_node->prev;
334 np_dump_formatted_node(pTHX_ struct state *st, npath_node_t *npath_node, npath_node_t *npath_node_deeper) {
336 PERL_UNUSED_ARG(npath_node_deeper);
337 if (0 && npath_node->type == NPtype_LINK)
339 np_dump_indent(npath_node->depth);
340 np_print_node_name(aTHX_ stderr, npath_node);
341 if (npath_node->type == NPtype_LINK)
342 fprintf(stderr, "->"); /* cosmetic */
343 fprintf(stderr, "\t\t[#%ld @%u] ", npath_node->seqn, npath_node->depth);
344 fprintf(stderr, "\n");
349 np_dump_node_path_info(pTHX_ struct state *st, npath_node_t *npath_node, UV attr_type, const char *attr_name, UV attr_value)
351 if (attr_type == NPattr_LEAFSIZE && !attr_value)
352 return; /* ignore zero sized leaf items */
353 np_walk_new_nodes(aTHX_ st, npath_node, NULL, np_dump_formatted_node);
354 np_dump_indent(npath_node->depth+1);
356 case NPattr_LEAFSIZE:
357 fprintf(stderr, "+%ld %s =%ld", attr_value, attr_name, attr_value+st->total_size);
360 fprintf(stderr, "~NAMED('%s') %lu", attr_name, attr_value);
363 fprintf(stderr, "~note %s %lu", attr_name, attr_value);
368 fprintf(stderr, "~pad%lu %s %lu", attr_type, attr_name, attr_value);
371 fprintf(stderr, "~??? %s %lu", attr_name, attr_value);
374 fprintf(stderr, "\n");
378 np_stream_formatted_node(pTHX_ struct state *st, npath_node_t *npath_node, npath_node_t *npath_node_deeper) {
379 PERL_UNUSED_ARG(npath_node_deeper);
380 fprintf(st->node_stream_fh, "-%u %lu %u ",
381 npath_node->type, npath_node->seqn, (unsigned)npath_node->depth
383 np_print_node_name(aTHX_ st->node_stream_fh, npath_node);
384 fprintf(st->node_stream_fh, "\n");
389 np_stream_node_path_info(pTHX_ struct state *st, npath_node_t *npath_node, UV attr_type, const char *attr_name, UV attr_value)
391 if (!attr_type && !attr_value)
392 return; /* ignore zero sized leaf items */
393 np_walk_new_nodes(aTHX_ st, npath_node, NULL, np_stream_formatted_node);
394 if (attr_type) { /* Attribute type, name and value */
395 fprintf(st->node_stream_fh, "%lu %lu ", attr_type, npath_node->seqn);
397 else { /* Leaf name and memory size */
398 fprintf(st->node_stream_fh, "L %lu ", npath_node->seqn);
400 fprintf(st->node_stream_fh, "%lu %s\n", attr_value, attr_name);
404 #endif /* PATH_TRACKING */
408 Checks to see if thing is in the bitstring.
409 Returns true or false, and
410 notes thing in the segmented bitstring.
413 check_new(struct state *st, const void *const p) {
414 unsigned int bits = 8 * sizeof(void*);
415 const size_t raw_p = PTR2nat(p);
416 /* This effectively rotates the value right by the number of low always-0
417 bits in an aligned pointer. The assmption is that most (if not all)
418 pointers are aligned, and these will be in the same chain of nodes
419 (and hence hot in the cache) but we can still deal with any unaligned
421 const size_t cooked_p
422 = (raw_p >> ALIGN_BITS) | (raw_p << (bits - ALIGN_BITS));
423 const U8 this_bit = 1 << (cooked_p & 0x7);
427 void **tv_p = (void **) (st->tracking);
429 if (NULL == p) return FALSE;
431 const char c = *(const char *)p;
435 if (st->dangle_whine)
436 warn( "Devel::Size: Encountered invalid pointer: %p\n", p );
442 /* bits now 24 (32 bit pointers) or 56 (64 bit pointers) */
444 /* First level is always present. */
446 i = (unsigned int)((cooked_p >> bits) & 0xFF);
448 Newxz(tv_p[i], 256, void *);
449 tv_p = (void **)(tv_p[i]);
451 } while (bits > LEAF_BITS + BYTE_BITS);
452 /* bits now 16 always */
453 #if !defined(MULTIPLICITY) || PERL_VERSION > 8 || (PERL_VERSION == 8 && PERL_SUBVERSION > 8)
454 /* 5.8.8 and early have an assert() macro that uses Perl_croak, hence needs
455 a my_perl under multiplicity */
458 leaf_p = (U8 **)tv_p;
459 i = (unsigned int)((cooked_p >> bits) & 0xFF);
461 Newxz(leaf_p[i], 1 << LEAF_BITS, U8);
466 i = (unsigned int)((cooked_p >> BYTE_BITS) & LEAF_MASK);
468 if(leaf[i] & this_bit)
476 free_tracking_at(void **tv, int level)
484 free_tracking_at((void **) tv[i], level);
498 free_state(pTHX_ struct state *st)
500 const int top_level = (sizeof(void *) * 8 - LEAF_BITS - BYTE_BITS) / 8;
501 if (st->free_state_cb)
502 st->free_state_cb(aTHX_ st);
503 if (st->state_cb_data)
504 Safefree(st->state_cb_data);
505 free_tracking_at((void **)st->tracking, top_level);
509 /* For now, this is somewhat a compatibility bodge until the plan comes
510 together for fine grained recursion control. total_size() would recurse into
511 hash and array members, whereas sv_size() would not. However, sv_size() is
512 called with CvSTASH() of a CV, which means that if it (also) starts to
513 recurse fully, then the size of any CV now becomes the size of the entire
514 symbol table reachable from it, and potentially the entire symbol table, if
515 any subroutine makes a reference to a global (such as %SIG). The historical
516 implementation of total_size() didn't report "everything", and changing the
517 only available size to "everything" doesn't feel at all useful. */
519 #define NO_RECURSION 0
520 #define SOME_RECURSION 1
521 #define TOTAL_SIZE_RECURSION 2
523 static bool sv_size(pTHX_ struct state *, pPATH, const SV *const, const int recurse);
539 , OPc_CONDOP /* 12 */
548 cc_opclass(const OP * const o)
554 return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
556 if (o->op_type == OP_SASSIGN)
557 return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPc_UNOP : OPc_BINOP);
560 if (o->op_type == OP_GV || o->op_type == OP_GVSV || o->op_type == OP_AELEMFAST)
564 if ((o->op_type == OP_TRANS)) {
568 switch (PL_opargs[o->op_type] & OA_CLASS_MASK) {
600 #ifdef OA_PVOP_OR_SVOP
601 case OA_PVOP_OR_SVOP: TAG;
603 * Character translations (tr///) are usually a PVOP, keeping a
604 * pointer to a table of shorts used to look up translations.
605 * Under utf8, however, a simple table isn't practical; instead,
606 * the OP is an SVOP, and the SV is a reference to a swash
607 * (i.e., an RV pointing to an HV).
609 return (o->op_private & (OPpTRANS_TO_UTF|OPpTRANS_FROM_UTF))
610 ? OPc_SVOP : OPc_PVOP;
619 case OA_BASEOP_OR_UNOP: TAG;
621 * UNI(OP_foo) in toke.c returns token UNI or FUNC1 depending on
622 * whether parens were seen. perly.y uses OPf_SPECIAL to
623 * signal whether a BASEOP had empty parens or none.
624 * Some other UNOPs are created later, though, so the best
625 * test is OPf_KIDS, which is set in newUNOP.
627 return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
629 case OA_FILESTATOP: TAG;
631 * The file stat OPs are created via UNI(OP_foo) in toke.c but use
632 * the OPf_REF flag to distinguish between OP types instead of the
633 * usual OPf_SPECIAL flag. As usual, if OPf_KIDS is set, then we
634 * return OPc_UNOP so that walkoptree can find our children. If
635 * OPf_KIDS is not set then we check OPf_REF. Without OPf_REF set
636 * (no argument to the operator) it's an OP; with OPf_REF set it's
637 * an SVOP (and op_sv is the GV for the filehandle argument).
639 return ((o->op_flags & OPf_KIDS) ? OPc_UNOP :
641 (o->op_flags & OPf_REF) ? OPc_PADOP : OPc_BASEOP);
643 (o->op_flags & OPf_REF) ? OPc_SVOP : OPc_BASEOP);
645 case OA_LOOPEXOP: TAG;
647 * next, last, redo, dump and goto use OPf_SPECIAL to indicate that a
648 * label was omitted (in which case it's a BASEOP) or else a term was
649 * seen. In this last case, all except goto are definitely PVOP but
650 * goto is either a PVOP (with an ordinary constant label), an UNOP
651 * with OPf_STACKED (with a non-constant non-sub) or an UNOP for
652 * OP_REFGEN (with goto &sub) in which case OPf_STACKED also seems to
655 if (o->op_flags & OPf_STACKED)
657 else if (o->op_flags & OPf_SPECIAL)
667 warn("Devel::Size: Can't determine class of operator %s, assuming BASEOP\n",
668 PL_op_name[o->op_type]);
674 /* Figure out how much magic is attached to the SV and return the
677 magic_size(pTHX_ const SV * const thing, struct state *st, pPATH) {
678 dNPathNodes(1, NPathArg);
679 MAGIC *magic_pointer = SvMAGIC(thing); /* caller ensures thing is SvMAGICAL */
681 /* push a dummy node for NPathSetNode to update inside the while loop */
682 NPathPushNode("dummy", NPtype_NAME);
684 /* Have we seen the magic pointer? (NULL has always been seen before) */
685 while (check_new(st, magic_pointer)) {
687 NPathSetNode(magic_pointer, NPtype_MAGIC);
689 ADD_SIZE(st, "mg", sizeof(MAGIC));
690 /* magic vtables aren't freed when magic is freed, so don't count them.
691 (They are static structures. Anything that assumes otherwise is buggy.)
696 /* XXX only chase mg_obj if mg->mg_flags & MGf_REFCOUNTED ? */
697 sv_size(aTHX_ st, NPathLink("mg_obj"), magic_pointer->mg_obj, TOTAL_SIZE_RECURSION);
698 if (magic_pointer->mg_len == HEf_SVKEY) {
699 sv_size(aTHX_ st, NPathLink("mg_ptr"), (SV *)magic_pointer->mg_ptr, TOTAL_SIZE_RECURSION);
701 #if defined(PERL_MAGIC_utf8) && defined (PERL_MAGIC_UTF8_CACHESIZE)
702 else if (magic_pointer->mg_type == PERL_MAGIC_utf8) {
703 if (check_new(st, magic_pointer->mg_ptr)) {
704 ADD_SIZE(st, "PERL_MAGIC_utf8", PERL_MAGIC_UTF8_CACHESIZE * 2 * sizeof(STRLEN));
708 /* XXX also handle mg->mg_type == PERL_MAGIC_utf8 ? */
709 else if (magic_pointer->mg_len > 0) {
710 if(0)do_magic_dump(0, Perl_debug_log, magic_pointer, 0, 0, FALSE, 0);
711 if (check_new(st, magic_pointer->mg_ptr)) {
712 ADD_SIZE(st, "mg_len", magic_pointer->mg_len);
716 /* Get the next in the chain */
717 magic_pointer = magic_pointer->mg_moremagic;
720 if (st->dangle_whine)
721 warn( "Devel::Size: Encountered bad magic at: %p\n", magic_pointer );
726 #define check_new_and_strlen(st, p, ppath) S_check_new_and_strlen(aTHX_ st, p, ppath)
728 S_check_new_and_strlen(pTHX_ struct state *st, const char *const p, pPATH) {
729 dNPathNodes(1, NPathArg->prev);
730 if(check_new(st, p)) {
731 NPathPushNode(NPathArg->id, NPtype_NAME);
732 ADD_SIZE(st, NPathArg->id, 1 + strlen(p));
737 regex_size(pTHX_ const REGEXP * const baseregex, struct state *st, pPATH) {
738 dNPathNodes(1, NPathArg);
739 if(!check_new(st, baseregex))
741 NPathPushNode("regex_size", NPtype_NAME);
742 ADD_SIZE(st, "REGEXP", sizeof(REGEXP));
743 #if (PERL_VERSION < 11)
744 /* Note the size of the paren offset thing */
745 ADD_SIZE(st, "nparens", sizeof(I32) * baseregex->nparens * 2);
746 ADD_SIZE(st, "precomp", strlen(baseregex->precomp));
748 ADD_SIZE(st, "regexp", sizeof(struct regexp));
749 ADD_SIZE(st, "nparens", sizeof(I32) * SvANY(baseregex)->nparens * 2);
750 /*ADD_SIZE(st, strlen(SvANY(baseregex)->subbeg));*/
752 if (st->go_yell && !st->regex_whine) {
753 carp("Devel::Size: Calculated sizes for compiled regexes are incompatible, and probably always will be");
759 hek_size(pTHX_ struct state *st, HEK *hek, U32 shared, pPATH)
761 dNPathNodes(1, NPathArg);
763 /* Hash keys can be shared. Have we seen this before? */
764 if (!check_new(st, hek))
766 NPathPushNode("hek", NPtype_NAME);
767 ADD_SIZE(st, "hek_len", HEK_BASESIZE + hek->hek_len
769 + 1 /* No hash key flags prior to 5.8.0 */
775 #if PERL_VERSION < 10
776 ADD_SIZE(st, "he", sizeof(struct he));
778 ADD_SIZE(st, "shared_he", STRUCT_OFFSET(struct shared_he, shared_he_hek));
785 refcounted_he_size(pTHX_ struct state *st, struct refcounted_he *he, pPATH)
787 dNPathNodes(1, NPathArg);
788 if (!check_new(st, he))
790 NPathPushNode("refcounted_he_size", NPtype_NAME);
791 ADD_SIZE(st, "refcounted_he", sizeof(struct refcounted_he));
794 ADD_SIZE(st, "refcounted_he_data", NPtype_NAME);
796 hek_size(aTHX_ st, he->refcounted_he_hek, 0, NPathLink("refcounted_he_hek"));
799 if (he->refcounted_he_next)
800 refcounted_he_size(aTHX_ st, he->refcounted_he_next, NPathLink("refcounted_he_next"));
803 static void op_size_class(pTHX_ const OP * const baseop, opclass op_class, bool skip_op_struct, struct state *st, pPATH);
806 op_size(pTHX_ const OP * const baseop, struct state *st, pPATH)
808 op_size_class(aTHX_ baseop, cc_opclass(baseop), 0, st, NPathArg);
812 op_size_class(pTHX_ const OP * const baseop, opclass op_class, bool skip_op_struct, struct state *st, pPATH)
814 /* op_size recurses to follow the chain of opcodes. For the node path we
815 * don't want the chain to be 'nested' in the path so we use dNPathUseParent().
816 * Also, to avoid a link-to-a-link the caller should use NPathLinkAndNode()
817 * instead of NPathLink().
819 dNPathUseParent(NPathArg);
823 if(!check_new(st, baseop))
826 op_size(aTHX_ baseop->op_next, st, NPathOpLink);
828 madprop_size(aTHX_ st, NPathOpLink, baseop->op_madprop);
832 case OPc_BASEOP: TAG;
834 ADD_SIZE(st, "op", sizeof(struct op));
838 ADD_SIZE(st, "unop", sizeof(struct unop));
839 op_size(aTHX_ ((UNOP *)baseop)->op_first, st, NPathOpLink);
843 ADD_SIZE(st, "binop", sizeof(struct binop));
844 op_size(aTHX_ ((BINOP *)baseop)->op_first, st, NPathOpLink);
845 op_size(aTHX_ ((BINOP *)baseop)->op_last, st, NPathOpLink);
849 ADD_SIZE(st, "logop", sizeof(struct logop));
850 op_size(aTHX_ ((BINOP *)baseop)->op_first, st, NPathOpLink);
851 op_size(aTHX_ ((LOGOP *)baseop)->op_other, st, NPathOpLink);
854 case OPc_CONDOP: TAG;
856 ADD_SIZE(st, "condop", sizeof(struct condop));
857 op_size(aTHX_ ((BINOP *)baseop)->op_first, st, NPathOpLink);
858 op_size(aTHX_ ((CONDOP *)baseop)->op_true, st, NPathOpLink);
859 op_size(aTHX_ ((CONDOP *)baseop)->op_false, st, NPathOpLink);
862 case OPc_LISTOP: TAG;
864 ADD_SIZE(st, "listop", sizeof(struct listop));
865 op_size(aTHX_ ((LISTOP *)baseop)->op_first, st, NPathOpLink);
866 op_size(aTHX_ ((LISTOP *)baseop)->op_last, st, NPathOpLink);
870 ADD_SIZE(st, "pmop", sizeof(struct pmop));
871 op_size(aTHX_ ((PMOP *)baseop)->op_first, st, NPathOpLink);
872 op_size(aTHX_ ((PMOP *)baseop)->op_last, st, NPathOpLink);
873 #if PERL_VERSION < 9 || (PERL_VERSION == 9 && PERL_SUBVERSION < 5)
874 op_size(aTHX_ ((PMOP *)baseop)->op_pmreplroot, st, NPathOpLink);
875 op_size(aTHX_ ((PMOP *)baseop)->op_pmreplstart, st, NPathOpLink);
877 /* This is defined away in perl 5.8.x, but it is in there for
880 regex_size(aTHX_ PM_GETRE((PMOP *)baseop), st, NPathLink("PM_GETRE"));
882 regex_size(aTHX_ ((PMOP *)baseop)->op_pmregexp, st, NPathLink("op_pmregexp"));
887 ADD_SIZE(st, "svop", sizeof(struct svop));
888 if (!(baseop->op_type == OP_AELEMFAST
889 && baseop->op_flags & OPf_SPECIAL)) {
890 /* not an OP_PADAV replacement */
891 sv_size(aTHX_ st, NPathLink("SVOP"), ((SVOP *)baseop)->op_sv, SOME_RECURSION);
897 ADD_SIZE(st, "padop", sizeof(struct padop));
903 ADD_SIZE(st, "gvop", sizeof(struct gvop));
904 sv_size(aTHX_ st, NPathLink("GVOP"), ((GVOP *)baseop)->op_gv, SOME_RECURSION);
908 check_new_and_strlen(st, ((PVOP *)baseop)->op_pv, NPathLink("op_pv"));
912 ADD_SIZE(st, "loop", sizeof(struct loop));
913 op_size(aTHX_ ((LOOP *)baseop)->op_first, st, NPathOpLink);
914 op_size(aTHX_ ((LOOP *)baseop)->op_last, st, NPathOpLink);
915 op_size(aTHX_ ((LOOP *)baseop)->op_redoop, st, NPathOpLink);
916 op_size(aTHX_ ((LOOP *)baseop)->op_nextop, st, NPathOpLink);
917 op_size(aTHX_ ((LOOP *)baseop)->op_lastop, st, NPathOpLink);
923 basecop = (COP *)baseop;
925 ADD_SIZE(st, "cop", sizeof(struct cop));
927 /* Change 33656 by nicholas@mouse-mill on 2008/04/07 11:29:51
928 Eliminate cop_label from struct cop by storing a label as the first
929 entry in the hints hash. Most statements don't have labels, so this
930 will save memory. Not sure how much.
931 The check below will be incorrect fail on bleadperls
932 before 5.11 @33656, but later than 5.10, producing slightly too
933 small memory sizes on these Perls. */
934 #if (PERL_VERSION < 11)
935 check_new_and_strlen(st, basecop->cop_label, NPathLink("cop_label"));
938 check_new_and_strlen(st, basecop->cop_file, NPathLink("cop_file"));
939 check_new_and_strlen(st, basecop->cop_stashpv, NPathLink("cop_stashpv"));
941 if (SvREFCNT(basecop->cop_stash) == 1) /* XXX hack? */
942 sv_size(aTHX_ st, NPathLink("cop_stash"), (SV *)basecop->cop_stash, SOME_RECURSION);
943 sv_size(aTHX_ st, NPathLink("cop_filegv"), (SV *)basecop->cop_filegv, SOME_RECURSION);
946 hh = CopHINTHASH_get(basecop);
947 refcounted_he_size(aTHX_ st, hh, 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);