5 * Refactor this to split out D:M code from Devel::Size code.
7 * Start migrating Devel::Size's Size.xs towards the new code.
9 * ADD_PRE_ATTR for index should check if the ptr is new first. Currently we're
10 * generating lots of ADD_PRE_ATTR's for SVs that we've already seen via other paths.
11 * That's wasteful and likely to cause subtle bugs.
13 * Give HE's their own node so keys and values can be tied together
17 #undef NDEBUG /* XXX */
20 #define PERL_NO_GET_CONTEXT
27 #include "refcounted_he.h"
29 /* Not yet in ppport.h */
31 # define CvISXSUB(cv) (CvXSUB(cv) ? TRUE : FALSE)
34 # define SvRV_const(rv) SvRV(rv)
37 # define SvOOK_offset(sv, len) STMT_START { len = SvIVX(sv); } STMT_END
40 # define SvIsCOW(sv) ((SvFLAGS(sv) & (SVf_FAKE | SVf_READONLY)) == \
41 (SVf_FAKE | SVf_READONLY))
43 #ifndef SvIsCOW_shared_hash
44 # define SvIsCOW_shared_hash(sv) (SvIsCOW(sv) && SvLEN(sv) == 0)
46 #ifndef SvSHARED_HEK_FROM_PV
47 # define SvSHARED_HEK_FROM_PV(pvx) \
48 ((struct hek*)(pvx - STRUCT_OFFSET(struct hek, hek_key)))
52 # define PL_opargs opargs
53 # define PL_op_name op_name
57 /* "structured exception" handling is a Microsoft extension to C and C++.
58 It's *not* C++ exception handling - C++ exception handling can't capture
59 SEGVs and suchlike, whereas this can. There's no known analagous
60 functionality on other platforms. */
62 # define TRY_TO_CATCH_SEGV __try
63 # define CAUGHT_EXCEPTION __except(EXCEPTION_EXECUTE_HANDLER)
65 # define TRY_TO_CATCH_SEGV if(1)
66 # define CAUGHT_EXCEPTION else
70 # define __attribute__(x)
73 #if 0 && defined(DEBUGGING)
74 #define dbg_printf(x) printf x
79 #define TAG /* printf( "# %s(%d)\n", __FILE__, __LINE__ ) */
82 /* The idea is to have a tree structure to store 1 bit per possible pointer
83 address. The lowest 16 bits are stored in a block of 8092 bytes.
84 The blocks are in a 256-way tree, indexed by the reset of the pointer.
85 This can cope with 32 and 64 bit pointers, and any address space layout,
86 without excessive memory needs. The assumption is that your CPU cache
87 works :-) (And that we're not going to bust it) */
90 #define LEAF_BITS (16 - BYTE_BITS)
91 #define LEAF_MASK 0x1FFF
93 typedef struct npath_node_st npath_node_t;
94 struct npath_node_st {
109 /* My hunch (not measured) is that for most architectures pointers will
110 start with 0 bits, hence the start of this array will be hot, and the
111 end unused. So put the flags next to the hot end. */
114 int min_recurse_threshold;
115 /* callback hooks and data */
116 void (*add_attr_cb)(pTHX_ struct state *st, npath_node_t *npath_node, UV attr_type, const char *name, UV value);
117 void (*free_state_cb)(pTHX_ struct state *st);
118 void *state_cb_data; /* free'd by free_state() after free_state_cb() call */
119 /* this stuff wil be moved to state_cb_data later */
121 FILE *node_stream_fh;
122 char *node_stream_name;
125 #define ADD_SIZE(st, leafname, bytes) \
127 NPathAddSizeCb(st, leafname, bytes); \
128 (st)->total_size += (bytes); \
132 #define PATH_TRACKING
135 #define pPATH npath_node_t *NPathArg
137 /* A subtle point here is that dNPathNodes and NPathPushNode leave NP pointing
138 * to the next unused slot (though with prev already filled in)
139 * whereas NPathLink leaves NP unchanged, it just fills in the slot NP points
140 * to and passes that NP value to the function being called.
141 * seqn==0 indicates the node is new (hasn't been output yet)
143 #define dNPathNodes(nodes, prev_np) \
144 npath_node_t name_path_nodes[nodes+1]; /* +1 for NPathLink */ \
145 npath_node_t *NP = &name_path_nodes[0]; \
146 NP->seqn = NP->type = 0; NP->id = Nullch; /* safety/debug */ \
148 #define NPathPushNode(nodeid, nodetype) \
150 NP->type = nodetype; \
152 if(0)fprintf(stderr,"NPathPushNode (%p <-) %p <- [%d %s]\n", NP->prev, NP, nodetype,(char*)nodeid);\
154 NP->id = Nullch; /* safety/debug */ \
157 #define NPathSetNode(nodeid, nodetype) \
158 (NP-1)->id = nodeid; \
159 (NP-1)->type = nodetype; \
160 if(0)fprintf(stderr,"NPathSetNode (%p <-) %p <- [%d %s]\n", (NP-1)->prev, (NP-1), nodetype,(char*)nodeid);\
162 #define NPathPopNode \
165 /* dNPathUseParent points NP directly the the parents' name_path_nodes array
166 * So the function can only safely call ADD_*() but not NPathLink, unless the
167 * caller has spare nodes in its name_path_nodes.
169 #define dNPathUseParent(prev_np) npath_node_t *NP = (((prev_np+1)->prev = prev_np), prev_np+1)
171 #define NPtype_NAME 0x01
172 #define NPtype_LINK 0x02
173 #define NPtype_SV 0x03
174 #define NPtype_MAGIC 0x04
175 #define NPtype_OP 0x05
177 /* XXX these should probably be generalizes into flag bits */
178 #define NPattr_LEAFSIZE 0x00
179 #define NPattr_NAME 0x01
180 #define NPattr_PADFAKE 0x02
181 #define NPattr_PADNAME 0x03
182 #define NPattr_PADTMP 0x04
183 #define NPattr_NOTE 0x05
184 #define NPattr_PRE_ATTR 0x06 /* deprecated */
186 #define _ADD_ATTR_NP(st, attr_type, attr_name, attr_value, np) \
188 if (st->add_attr_cb) { \
189 st->add_attr_cb(aTHX_ st, np, attr_type, attr_name, attr_value); \
193 #define ADD_ATTR(st, attr_type, attr_name, attr_value) _ADD_ATTR_NP(st, attr_type, attr_name, attr_value, NP-1)
194 #define ADD_LINK_ATTR(st, attr_type, attr_name, attr_value) \
197 _ADD_ATTR_NP(st, attr_type, attr_name, attr_value, NP); \
199 #define ADD_PRE_ATTR(st, attr_type, attr_name, attr_value) \
201 assert(!attr_type); \
202 _ADD_ATTR_NP(st, NPattr_PRE_ATTR, attr_name, attr_value, NP-1); \
205 #define _NPathLink(np, nid, ntype) (((np)->id=nid), ((np)->type=ntype), ((np)->seqn=0))
206 #define NPathLink(nid) (_NPathLink(NP, nid, NPtype_LINK), NP)
207 /* add a link and a name node to the path - a special case for op_size */
208 #define NPathLinkAndNode(nid, nid2) (_NPathLink(NP, nid, NPtype_LINK), _NPathLink(NP+1, nid2, NPtype_NAME), ((NP+1)->prev=NP), (NP+1))
209 #define NPathOpLink (NPathArg)
210 #define NPathAddSizeCb(st, name, bytes) \
212 if (st->add_attr_cb) { \
213 st->add_attr_cb(aTHX_ st, NP-1, NPattr_LEAFSIZE, (name), (bytes)); \
219 #define NPathAddSizeCb(st, name, bytes)
220 #define pPATH void *npath_dummy /* XXX ideally remove */
221 #define dNPathNodes(nodes, prev_np) dNOOP
222 #define NPathLink(nodeid, nodetype) NULL
223 #define NPathOpLink NULL
224 #define ADD_ATTR(st, attr_type, attr_name, attr_value) NOOP
226 #endif /* PATH_TRACKING */
233 static const char *svtypenames[SVt_LAST] = {
235 "NULL", "IV", "NV", "RV", "PV", "PVIV", "PVNV", "PVMG", "PVBM", "PVLV", "PVAV", "PVHV", "PVCV", "PVGV", "PVFM", "PVIO",
236 #elif PERL_VERSION == 10 && PERL_SUBVERSION == 0
237 "NULL", "BIND", "IV", "NV", "RV", "PV", "PVIV", "PVNV", "PVMG", "PVGV", "PVLV", "PVAV", "PVHV", "PVCV", "PVFM", "PVIO",
238 #elif PERL_VERSION == 10 && PERL_SUBVERSION == 1
239 "NULL", "BIND", "IV", "NV", "RV", "PV", "PVIV", "PVNV", "PVMG", "PVGV", "PVLV", "PVAV", "PVHV", "PVCV", "PVFM", "PVIO",
240 #elif PERL_VERSION < 13
241 "NULL", "BIND", "IV", "NV", "PV", "PVIV", "PVNV", "PVMG", "REGEXP", "PVGV", "PVLV", "PVAV", "PVHV", "PVCV", "PVFM", "PVIO",
243 "NULL", "BIND", "IV", "NV", "PV", "PVIV", "PVNV", "PVMG", "REGEXP", "PVGV", "PVLV", "PVAV", "PVHV", "PVCV", "PVFM", "PVIO",
248 gettimeofday_nv(void)
250 #ifdef HAS_GETTIMEOFDAY
252 gettimeofday(&when, (struct timezone *) 0);
253 return when.tv_sec + (when.tv_usec / 1000000.0);
257 (*u2time)(aTHX_ &time_of_day);
258 return time_of_day[0] + (time_of_day[1] / 1000000.0);
266 np_print_node_name(pTHX_ FILE *fp, npath_node_t *npath_node)
268 switch (npath_node->type) {
269 case NPtype_SV: { /* id is pointer to the SV sv_size was called on */
270 const SV *sv = (SV*)npath_node->id;
271 int type = SvTYPE(sv);
272 const char *typename = (type == SVt_IV && SvROK(sv)) ? "RV" : svtypenames[type];
273 fprintf(fp, "SV(%s)", typename);
274 switch(type) { /* add some useful details */
275 case SVt_PVAV: fprintf(fp, " fill=%d/%ld", av_len((AV*)sv), AvMAX((AV*)sv)); break;
276 case SVt_PVHV: fprintf(fp, " fill=%ld/%ld", HvFILL((HV*)sv), HvMAX((HV*)sv)); break;
280 case NPtype_OP: { /* id is pointer to the OP op_size was called on */
281 const OP *op = (OP*)npath_node->id;
282 fprintf(fp, "OP(%s)", OP_NAME(op));
285 case NPtype_MAGIC: { /* id is pointer to the MAGIC struct */
286 MAGIC *magic_pointer = (MAGIC*)npath_node->id;
287 /* XXX it would be nice if we could reuse mg_names.c [sigh] */
288 fprintf(fp, "MAGIC(%c)", magic_pointer->mg_type ? magic_pointer->mg_type : '0');
292 fprintf(fp, "%s", (const char *)npath_node->id);
295 fprintf(fp, "%s", (const char *)npath_node->id);
297 default: /* assume id is a string pointer */
298 fprintf(fp, "UNKNOWN(%d,%p)", npath_node->type, npath_node->id);
305 np_dump_indent(int depth) {
307 fprintf(stderr, ": ");
311 np_walk_new_nodes(pTHX_ struct state *st,
312 npath_node_t *npath_node,
313 npath_node_t *npath_node_deeper,
314 int (*cb)(pTHX_ struct state *st, npath_node_t *npath_node, npath_node_t *npath_node_deeper))
316 if (npath_node->seqn) /* node already output */
319 if (npath_node->prev) {
320 np_walk_new_nodes(aTHX_ st, npath_node->prev, npath_node, cb); /* recurse */
321 npath_node->depth = npath_node->prev->depth + 1;
323 else npath_node->depth = 0;
324 npath_node->seqn = ++st->seqn;
327 if (cb(aTHX_ st, npath_node, npath_node_deeper)) {
328 /* ignore this node */
329 assert(npath_node->prev);
330 assert(npath_node->depth);
331 assert(npath_node_deeper);
333 npath_node->seqn = --st->seqn;
334 npath_node_deeper->prev = npath_node->prev;
342 np_dump_formatted_node(pTHX_ struct state *st, npath_node_t *npath_node, npath_node_t *npath_node_deeper) {
344 PERL_UNUSED_ARG(npath_node_deeper);
345 if (0 && npath_node->type == NPtype_LINK)
347 np_dump_indent(npath_node->depth);
348 np_print_node_name(aTHX_ stderr, npath_node);
349 if (npath_node->type == NPtype_LINK)
350 fprintf(stderr, "->"); /* cosmetic */
351 fprintf(stderr, "\t\t[#%ld @%u] ", npath_node->seqn, npath_node->depth);
352 fprintf(stderr, "\n");
357 np_dump_node_path_info(pTHX_ struct state *st, npath_node_t *npath_node, UV attr_type, const char *attr_name, UV attr_value)
359 if (attr_type == NPattr_LEAFSIZE && !attr_value)
360 return; /* ignore zero sized leaf items */
361 np_walk_new_nodes(aTHX_ st, npath_node, NULL, np_dump_formatted_node);
362 np_dump_indent(npath_node->depth+1);
364 case NPattr_LEAFSIZE:
365 fprintf(stderr, "+%ld %s =%ld", attr_value, attr_name, attr_value+st->total_size);
368 fprintf(stderr, "~NAMED('%s') %lu", attr_name, attr_value);
371 fprintf(stderr, "~note %s %lu", attr_name, attr_value);
376 fprintf(stderr, "~pad%lu %s %lu", attr_type, attr_name, attr_value);
379 fprintf(stderr, "~??? %s %lu", attr_name, attr_value);
382 fprintf(stderr, "\n");
386 np_stream_formatted_node(pTHX_ struct state *st, npath_node_t *npath_node, npath_node_t *npath_node_deeper) {
387 PERL_UNUSED_ARG(npath_node_deeper);
388 fprintf(st->node_stream_fh, "-%u %lu %u ",
389 npath_node->type, npath_node->seqn, (unsigned)npath_node->depth
391 np_print_node_name(aTHX_ st->node_stream_fh, npath_node);
392 fprintf(st->node_stream_fh, "\n");
397 np_stream_node_path_info(pTHX_ struct state *st, npath_node_t *npath_node, UV attr_type, const char *attr_name, UV attr_value)
399 if (!attr_type && !attr_value)
400 return; /* ignore zero sized leaf items */
401 np_walk_new_nodes(aTHX_ st, npath_node, NULL, np_stream_formatted_node);
402 if (attr_type) { /* Attribute type, name and value */
403 fprintf(st->node_stream_fh, "%lu %lu ", attr_type, npath_node->seqn);
405 else { /* Leaf name and memory size */
406 fprintf(st->node_stream_fh, "L %lu ", npath_node->seqn);
408 fprintf(st->node_stream_fh, "%lu %s\n", attr_value, attr_name);
412 #endif /* PATH_TRACKING */
416 Checks to see if thing is in the bitstring.
417 Returns true or false, and
418 notes thing in the segmented bitstring.
421 check_new(struct state *st, const void *const p) {
422 unsigned int bits = 8 * sizeof(void*);
423 const size_t raw_p = PTR2nat(p);
424 /* This effectively rotates the value right by the number of low always-0
425 bits in an aligned pointer. The assmption is that most (if not all)
426 pointers are aligned, and these will be in the same chain of nodes
427 (and hence hot in the cache) but we can still deal with any unaligned
429 const size_t cooked_p
430 = (raw_p >> ALIGN_BITS) | (raw_p << (bits - ALIGN_BITS));
431 const U8 this_bit = 1 << (cooked_p & 0x7);
435 void **tv_p = (void **) (st->tracking);
437 if (NULL == p) return FALSE;
439 const char c = *(const char *)p;
443 if (st->dangle_whine)
444 warn( "Devel::Size: Encountered invalid pointer: %p\n", p );
450 /* bits now 24 (32 bit pointers) or 56 (64 bit pointers) */
452 /* First level is always present. */
454 i = (unsigned int)((cooked_p >> bits) & 0xFF);
456 Newxz(tv_p[i], 256, void *);
457 tv_p = (void **)(tv_p[i]);
459 } while (bits > LEAF_BITS + BYTE_BITS);
460 /* bits now 16 always */
461 #if !defined(MULTIPLICITY) || PERL_VERSION > 8 || (PERL_VERSION == 8 && PERL_SUBVERSION > 8)
462 /* 5.8.8 and early have an assert() macro that uses Perl_croak, hence needs
463 a my_perl under multiplicity */
466 leaf_p = (U8 **)tv_p;
467 i = (unsigned int)((cooked_p >> bits) & 0xFF);
469 Newxz(leaf_p[i], 1 << LEAF_BITS, U8);
474 i = (unsigned int)((cooked_p >> BYTE_BITS) & LEAF_MASK);
476 if(leaf[i] & this_bit)
484 free_tracking_at(void **tv, int level)
492 free_tracking_at((void **) tv[i], level);
506 free_state(pTHX_ struct state *st)
508 const int top_level = (sizeof(void *) * 8 - LEAF_BITS - BYTE_BITS) / 8;
509 if (st->free_state_cb)
510 st->free_state_cb(aTHX_ st);
511 if (st->state_cb_data)
512 Safefree(st->state_cb_data);
513 free_tracking_at((void **)st->tracking, top_level);
517 /* For now, this is somewhat a compatibility bodge until the plan comes
518 together for fine grained recursion control. total_size() would recurse into
519 hash and array members, whereas sv_size() would not. However, sv_size() is
520 called with CvSTASH() of a CV, which means that if it (also) starts to
521 recurse fully, then the size of any CV now becomes the size of the entire
522 symbol table reachable from it, and potentially the entire symbol table, if
523 any subroutine makes a reference to a global (such as %SIG). The historical
524 implementation of total_size() didn't report "everything", and changing the
525 only available size to "everything" doesn't feel at all useful. */
527 #define NO_RECURSION 0
528 #define SOME_RECURSION 1
529 #define TOTAL_SIZE_RECURSION 2
531 static bool sv_size(pTHX_ struct state *, pPATH, const SV *const, const int recurse);
547 , OPc_CONDOP /* 12 */
556 cc_opclass(const OP * const o)
562 return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
564 if (o->op_type == OP_SASSIGN)
565 return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPc_UNOP : OPc_BINOP);
568 if (o->op_type == OP_GV || o->op_type == OP_GVSV || o->op_type == OP_AELEMFAST)
572 if ((o->op_type == OP_TRANS)) {
576 switch (PL_opargs[o->op_type] & OA_CLASS_MASK) {
608 #ifdef OA_PVOP_OR_SVOP
609 case OA_PVOP_OR_SVOP: TAG;
611 * Character translations (tr///) are usually a PVOP, keeping a
612 * pointer to a table of shorts used to look up translations.
613 * Under utf8, however, a simple table isn't practical; instead,
614 * the OP is an SVOP, and the SV is a reference to a swash
615 * (i.e., an RV pointing to an HV).
617 return (o->op_private & (OPpTRANS_TO_UTF|OPpTRANS_FROM_UTF))
618 ? OPc_SVOP : OPc_PVOP;
627 case OA_BASEOP_OR_UNOP: TAG;
629 * UNI(OP_foo) in toke.c returns token UNI or FUNC1 depending on
630 * whether parens were seen. perly.y uses OPf_SPECIAL to
631 * signal whether a BASEOP had empty parens or none.
632 * Some other UNOPs are created later, though, so the best
633 * test is OPf_KIDS, which is set in newUNOP.
635 return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
637 case OA_FILESTATOP: TAG;
639 * The file stat OPs are created via UNI(OP_foo) in toke.c but use
640 * the OPf_REF flag to distinguish between OP types instead of the
641 * usual OPf_SPECIAL flag. As usual, if OPf_KIDS is set, then we
642 * return OPc_UNOP so that walkoptree can find our children. If
643 * OPf_KIDS is not set then we check OPf_REF. Without OPf_REF set
644 * (no argument to the operator) it's an OP; with OPf_REF set it's
645 * an SVOP (and op_sv is the GV for the filehandle argument).
647 return ((o->op_flags & OPf_KIDS) ? OPc_UNOP :
649 (o->op_flags & OPf_REF) ? OPc_PADOP : OPc_BASEOP);
651 (o->op_flags & OPf_REF) ? OPc_SVOP : OPc_BASEOP);
653 case OA_LOOPEXOP: TAG;
655 * next, last, redo, dump and goto use OPf_SPECIAL to indicate that a
656 * label was omitted (in which case it's a BASEOP) or else a term was
657 * seen. In this last case, all except goto are definitely PVOP but
658 * goto is either a PVOP (with an ordinary constant label), an UNOP
659 * with OPf_STACKED (with a non-constant non-sub) or an UNOP for
660 * OP_REFGEN (with goto &sub) in which case OPf_STACKED also seems to
663 if (o->op_flags & OPf_STACKED)
665 else if (o->op_flags & OPf_SPECIAL)
675 warn("Devel::Size: Can't determine class of operator %s, assuming BASEOP\n",
676 PL_op_name[o->op_type]);
682 /* Figure out how much magic is attached to the SV and return the
685 magic_size(pTHX_ const SV * const thing, struct state *st, pPATH) {
686 dNPathNodes(1, NPathArg);
687 MAGIC *magic_pointer = SvMAGIC(thing); /* caller ensures thing is SvMAGICAL */
689 /* push a dummy node for NPathSetNode to update inside the while loop */
690 NPathPushNode("dummy", NPtype_NAME);
692 /* Have we seen the magic pointer? (NULL has always been seen before) */
693 while (check_new(st, magic_pointer)) {
695 NPathSetNode(magic_pointer, NPtype_MAGIC);
697 ADD_SIZE(st, "mg", sizeof(MAGIC));
698 /* magic vtables aren't freed when magic is freed, so don't count them.
699 (They are static structures. Anything that assumes otherwise is buggy.)
704 /* XXX only chase mg_obj if mg->mg_flags & MGf_REFCOUNTED ? */
705 sv_size(aTHX_ st, NPathLink("mg_obj"), magic_pointer->mg_obj, TOTAL_SIZE_RECURSION);
706 if (magic_pointer->mg_len == HEf_SVKEY) {
707 sv_size(aTHX_ st, NPathLink("mg_ptr"), (SV *)magic_pointer->mg_ptr, TOTAL_SIZE_RECURSION);
709 #if defined(PERL_MAGIC_utf8) && defined (PERL_MAGIC_UTF8_CACHESIZE)
710 else if (magic_pointer->mg_type == PERL_MAGIC_utf8) {
711 if (check_new(st, magic_pointer->mg_ptr)) {
712 ADD_SIZE(st, "PERL_MAGIC_utf8", PERL_MAGIC_UTF8_CACHESIZE * 2 * sizeof(STRLEN));
716 /* XXX also handle mg->mg_type == PERL_MAGIC_utf8 ? */
717 else if (magic_pointer->mg_len > 0) {
718 if(0)do_magic_dump(0, Perl_debug_log, magic_pointer, 0, 0, FALSE, 0);
719 if (check_new(st, magic_pointer->mg_ptr)) {
720 ADD_SIZE(st, "mg_len", magic_pointer->mg_len);
724 /* Get the next in the chain */
725 magic_pointer = magic_pointer->mg_moremagic;
728 if (st->dangle_whine)
729 warn( "Devel::Size: Encountered bad magic at: %p\n", magic_pointer );
734 #define check_new_and_strlen(st, p, ppath) S_check_new_and_strlen(aTHX_ st, p, ppath)
736 S_check_new_and_strlen(pTHX_ struct state *st, const char *const p, pPATH) {
737 dNPathNodes(1, NPathArg->prev);
738 if(check_new(st, p)) {
739 NPathPushNode(NPathArg->id, NPtype_NAME);
740 ADD_SIZE(st, NPathArg->id, 1 + strlen(p));
745 regex_size(pTHX_ const REGEXP * const baseregex, struct state *st, pPATH) {
746 dNPathNodes(1, NPathArg);
747 if(!check_new(st, baseregex))
749 NPathPushNode("regex_size", NPtype_NAME);
750 ADD_SIZE(st, "REGEXP", sizeof(REGEXP));
751 #if (PERL_VERSION < 11)
752 /* Note the size of the paren offset thing */
753 ADD_SIZE(st, "nparens", sizeof(I32) * baseregex->nparens * 2);
754 ADD_SIZE(st, "precomp", strlen(baseregex->precomp));
756 ADD_SIZE(st, "regexp", sizeof(struct regexp));
757 ADD_SIZE(st, "nparens", sizeof(I32) * SvANY(baseregex)->nparens * 2);
758 /*ADD_SIZE(st, strlen(SvANY(baseregex)->subbeg));*/
760 if (st->go_yell && !st->regex_whine) {
761 carp("Devel::Size: Calculated sizes for compiled regexes are incompatible, and probably always will be");
767 hek_size(pTHX_ struct state *st, HEK *hek, U32 shared, pPATH)
769 dNPathNodes(1, NPathArg);
771 /* Hash keys can be shared. Have we seen this before? */
772 if (!check_new(st, hek))
774 NPathPushNode("hek", NPtype_NAME);
775 ADD_SIZE(st, "hek_len", HEK_BASESIZE + hek->hek_len
777 + 1 /* No hash key flags prior to 5.8.0 */
783 #if PERL_VERSION < 10
784 ADD_SIZE(st, "he", sizeof(struct he));
786 ADD_SIZE(st, "shared_he", STRUCT_OFFSET(struct shared_he, shared_he_hek));
792 refcounted_he_size(pTHX_ struct state *st, struct refcounted_he *he, pPATH)
794 dNPathNodes(1, NPathArg);
795 if (!check_new(st, he))
797 NPathPushNode("refcounted_he_size", NPtype_NAME);
798 ADD_SIZE(st, "refcounted_he", sizeof(struct refcounted_he));
801 ADD_SIZE(st, "refcounted_he_data", NPtype_NAME);
803 hek_size(aTHX_ st, he->refcounted_he_hek, 0, NPathLink("refcounted_he_hek"));
806 if (he->refcounted_he_next)
807 refcounted_he_size(aTHX_ st, he->refcounted_he_next, NPathLink("refcounted_he_next"));
810 static void op_size_class(pTHX_ const OP * const baseop, opclass op_class, bool skip_op_struct, struct state *st, pPATH);
813 op_size(pTHX_ const OP * const baseop, struct state *st, pPATH)
815 op_size_class(aTHX_ baseop, cc_opclass(baseop), 0, st, NPathArg);
819 op_size_class(pTHX_ const OP * const baseop, opclass op_class, bool skip_op_struct, struct state *st, pPATH)
821 /* op_size recurses to follow the chain of opcodes. For the node path we
822 * don't want the chain to be 'nested' in the path so we use dNPathUseParent().
823 * Also, to avoid a link-to-a-link the caller should use NPathLinkAndNode()
824 * instead of NPathLink().
826 dNPathUseParent(NPathArg);
830 if(!check_new(st, baseop))
833 op_size(aTHX_ baseop->op_next, st, NPathOpLink);
835 madprop_size(aTHX_ st, NPathOpLink, baseop->op_madprop);
839 case OPc_BASEOP: TAG;
841 ADD_SIZE(st, "op", sizeof(struct op));
845 ADD_SIZE(st, "unop", sizeof(struct unop));
846 op_size(aTHX_ ((UNOP *)baseop)->op_first, st, NPathOpLink);
850 ADD_SIZE(st, "binop", sizeof(struct binop));
851 op_size(aTHX_ ((BINOP *)baseop)->op_first, st, NPathOpLink);
852 op_size(aTHX_ ((BINOP *)baseop)->op_last, st, NPathOpLink);
856 ADD_SIZE(st, "logop", sizeof(struct logop));
857 op_size(aTHX_ ((BINOP *)baseop)->op_first, st, NPathOpLink);
858 op_size(aTHX_ ((LOGOP *)baseop)->op_other, st, NPathOpLink);
861 case OPc_CONDOP: TAG;
863 ADD_SIZE(st, "condop", sizeof(struct condop));
864 op_size(aTHX_ ((BINOP *)baseop)->op_first, st, NPathOpLink);
865 op_size(aTHX_ ((CONDOP *)baseop)->op_true, st, NPathOpLink);
866 op_size(aTHX_ ((CONDOP *)baseop)->op_false, st, NPathOpLink);
869 case OPc_LISTOP: TAG;
871 ADD_SIZE(st, "listop", sizeof(struct listop));
872 op_size(aTHX_ ((LISTOP *)baseop)->op_first, st, NPathOpLink);
873 op_size(aTHX_ ((LISTOP *)baseop)->op_last, st, NPathOpLink);
877 ADD_SIZE(st, "pmop", sizeof(struct pmop));
878 op_size(aTHX_ ((PMOP *)baseop)->op_first, st, NPathOpLink);
879 op_size(aTHX_ ((PMOP *)baseop)->op_last, st, NPathOpLink);
880 #if PERL_VERSION < 9 || (PERL_VERSION == 9 && PERL_SUBVERSION < 5)
881 op_size(aTHX_ ((PMOP *)baseop)->op_pmreplroot, st, NPathOpLink);
882 op_size(aTHX_ ((PMOP *)baseop)->op_pmreplstart, st, NPathOpLink);
884 /* This is defined away in perl 5.8.x, but it is in there for
887 regex_size(aTHX_ PM_GETRE((PMOP *)baseop), st, NPathLink("PM_GETRE"));
889 regex_size(aTHX_ ((PMOP *)baseop)->op_pmregexp, st, NPathLink("op_pmregexp"));
894 ADD_SIZE(st, "svop", sizeof(struct svop));
895 if (!(baseop->op_type == OP_AELEMFAST
896 && baseop->op_flags & OPf_SPECIAL)) {
897 /* not an OP_PADAV replacement */
898 sv_size(aTHX_ st, NPathLink("SVOP"), ((SVOP *)baseop)->op_sv, SOME_RECURSION);
904 ADD_SIZE(st, "padop", sizeof(struct padop));
910 ADD_SIZE(st, "gvop", sizeof(struct gvop));
911 sv_size(aTHX_ st, NPathLink("GVOP"), ((GVOP *)baseop)->op_gv, SOME_RECURSION);
915 check_new_and_strlen(st, ((PVOP *)baseop)->op_pv, NPathLink("op_pv"));
919 ADD_SIZE(st, "loop", sizeof(struct loop));
920 op_size(aTHX_ ((LOOP *)baseop)->op_first, st, NPathOpLink);
921 op_size(aTHX_ ((LOOP *)baseop)->op_last, st, NPathOpLink);
922 op_size(aTHX_ ((LOOP *)baseop)->op_redoop, st, NPathOpLink);
923 op_size(aTHX_ ((LOOP *)baseop)->op_nextop, st, NPathOpLink);
924 op_size(aTHX_ ((LOOP *)baseop)->op_lastop, st, NPathOpLink);
930 basecop = (COP *)baseop;
932 ADD_SIZE(st, "cop", sizeof(struct cop));
934 /* Change 33656 by nicholas@mouse-mill on 2008/04/07 11:29:51
935 Eliminate cop_label from struct cop by storing a label as the first
936 entry in the hints hash. Most statements don't have labels, so this
937 will save memory. Not sure how much.
938 The check below will be incorrect fail on bleadperls
939 before 5.11 @33656, but later than 5.10, producing slightly too
940 small memory sizes on these Perls. */
941 #if (PERL_VERSION < 11)
942 check_new_and_strlen(st, basecop->cop_label, NPathLink("cop_label"));
945 check_new_and_strlen(st, basecop->cop_file, NPathLink("cop_file"));
946 check_new_and_strlen(st, basecop->cop_stashpv, NPathLink("cop_stashpv"));
948 if (SvREFCNT(basecop->cop_stash) == 1) /* XXX hack? */
949 sv_size(aTHX_ st, NPathLink("cop_stash"), (SV *)basecop->cop_stash, SOME_RECURSION);
950 sv_size(aTHX_ st, NPathLink("cop_filegv"), (SV *)basecop->cop_filegv, SOME_RECURSION);
953 hh = CopHINTHASH_get(basecop);
954 refcounted_he_size(aTHX_ st, hh, NPathLink("cop_hints_hash"));
962 if (st->dangle_whine)
963 warn( "Devel::Size: Encountered dangling pointer in opcode at: %p\n", baseop );
967 #if PERL_VERSION < 8 || PERL_SUBVERSION < 9 /* XXX plain || seems like a bug */
972 # define MAYBE_PURIFY(normal, pure) (pure)
973 # define MAYBE_OFFSET(struct_name, member) 0
975 # define MAYBE_PURIFY(normal, pure) (normal)
976 # define MAYBE_OFFSET(struct_name, member) STRUCT_OFFSET(struct_name, member)
979 const U8 body_sizes[SVt_LAST] = {
982 MAYBE_PURIFY(sizeof(IV), sizeof(XPVIV)), /* SVt_IV */
983 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
984 sizeof(XRV), /* SVt_RV */
985 sizeof(XPV), /* SVt_PV */
986 sizeof(XPVIV), /* SVt_PVIV */
987 sizeof(XPVNV), /* SVt_PVNV */
988 sizeof(XPVMG), /* SVt_PVMG */
989 sizeof(XPVBM), /* SVt_PVBM */
990 sizeof(XPVLV), /* SVt_PVLV */
991 sizeof(XPVAV), /* SVt_PVAV */
992 sizeof(XPVHV), /* SVt_PVHV */
993 sizeof(XPVCV), /* SVt_PVCV */
994 sizeof(XPVGV), /* SVt_PVGV */
995 sizeof(XPVFM), /* SVt_PVFM */
996 sizeof(XPVIO) /* SVt_PVIO */
997 #elif PERL_VERSION == 10 && PERL_SUBVERSION == 0
1001 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
1003 MAYBE_PURIFY(sizeof(xpv_allocated), sizeof(XPV)), /* SVt_PV */
1004 MAYBE_PURIFY(sizeof(xpviv_allocated), sizeof(XPVIV)),/* SVt_PVIV */
1005 sizeof(XPVNV), /* SVt_PVNV */
1006 sizeof(XPVMG), /* SVt_PVMG */
1007 sizeof(XPVGV), /* SVt_PVGV */
1008 sizeof(XPVLV), /* SVt_PVLV */
1009 MAYBE_PURIFY(sizeof(xpvav_allocated), sizeof(XPVAV)),/* SVt_PVAV */
1010 MAYBE_PURIFY(sizeof(xpvhv_allocated), sizeof(XPVHV)),/* SVt_PVHV */
1011 MAYBE_PURIFY(sizeof(xpvcv_allocated), sizeof(XPVCV)),/* SVt_PVCV */
1012 MAYBE_PURIFY(sizeof(xpvfm_allocated), sizeof(XPVFM)),/* SVt_PVFM */
1013 sizeof(XPVIO), /* SVt_PVIO */
1014 #elif PERL_VERSION == 10 && PERL_SUBVERSION == 1
1018 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
1020 sizeof(XPV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PV */
1021 sizeof(XPVIV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PVIV */
1022 sizeof(XPVNV), /* SVt_PVNV */
1023 sizeof(XPVMG), /* SVt_PVMG */
1024 sizeof(XPVGV), /* SVt_PVGV */
1025 sizeof(XPVLV), /* SVt_PVLV */
1026 sizeof(XPVAV) - MAYBE_OFFSET(XPVAV, xav_fill), /* SVt_PVAV */
1027 sizeof(XPVHV) - MAYBE_OFFSET(XPVHV, xhv_fill), /* SVt_PVHV */
1028 sizeof(XPVCV) - MAYBE_OFFSET(XPVCV, xpv_cur), /* SVt_PVCV */
1029 sizeof(XPVFM) - MAYBE_OFFSET(XPVFM, xpv_cur), /* SVt_PVFM */
1030 sizeof(XPVIO) /* SVt_PVIO */
1031 #elif PERL_VERSION < 13
1035 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
1036 sizeof(XPV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PV */
1037 sizeof(XPVIV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PVIV */
1038 sizeof(XPVNV), /* SVt_PVNV */
1039 sizeof(XPVMG), /* SVt_PVMG */
1040 sizeof(regexp) - MAYBE_OFFSET(regexp, xpv_cur), /* SVt_REGEXP */
1041 sizeof(XPVGV), /* SVt_PVGV */
1042 sizeof(XPVLV), /* SVt_PVLV */
1043 sizeof(XPVAV) - MAYBE_OFFSET(XPVAV, xav_fill), /* SVt_PVAV */
1044 sizeof(XPVHV) - MAYBE_OFFSET(XPVHV, xhv_fill), /* SVt_PVHV */
1045 sizeof(XPVCV) - MAYBE_OFFSET(XPVCV, xpv_cur), /* SVt_PVCV */
1046 sizeof(XPVFM) - MAYBE_OFFSET(XPVFM, xpv_cur), /* SVt_PVFM */
1047 sizeof(XPVIO) /* SVt_PVIO */
1052 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
1053 sizeof(XPV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PV */
1054 sizeof(XPVIV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PVIV */
1055 sizeof(XPVNV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PVNV */
1056 sizeof(XPVMG), /* SVt_PVMG */
1057 sizeof(regexp), /* SVt_REGEXP */
1058 sizeof(XPVGV), /* SVt_PVGV */
1059 sizeof(XPVLV), /* SVt_PVLV */
1060 sizeof(XPVAV), /* SVt_PVAV */
1061 sizeof(XPVHV), /* SVt_PVHV */
1062 sizeof(XPVCV), /* SVt_PVCV */
1063 sizeof(XPVFM), /* SVt_PVFM */
1064 sizeof(XPVIO) /* SVt_PVIO */
1069 /* based on Perl_do_dump_pad() - wraps sv_size and adds ADD_ATTR calls for the pad names */
1071 padlist_size(pTHX_ struct state *const st, pPATH, PADLIST *padlist,
1074 dNPathUseParent(NPathArg);
1081 if( 0 && !check_new(st, padlist))
1084 pad_name = MUTABLE_AV(*av_fetch(MUTABLE_AV(padlist), 0, FALSE));
1085 pname = AvARRAY(pad_name);
1087 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
1088 const SV *namesv = pname[ix];
1089 if (namesv && namesv == &PL_sv_undef) {
1093 /* SvFAKE: On a pad name SV, that slot in the frame AV is a REFCNT'ed reference to a lexical from "outside" */
1095 ADD_ATTR(st, NPattr_PADFAKE, SvPVX_const(namesv), ix);
1097 ADD_ATTR(st, NPattr_PADNAME, SvPVX_const(namesv), ix);
1100 ADD_ATTR(st, NPattr_PADTMP, "SVs_PADTMP", ix);
1104 sv_size(aTHX_ st, NPathArg, (SV*)padlist, recurse);
1109 sv_size(pTHX_ struct state *const st, pPATH, const SV * const orig_thing,
1110 const int recurse) {
1111 const SV *thing = orig_thing;
1112 dNPathNodes(3, NPathArg);
1115 if(!check_new(st, orig_thing))
1118 type = SvTYPE(thing);
1119 if (type > SVt_LAST) {
1120 warn("Devel::Size: Unknown variable type: %d encountered\n", type);
1123 NPathPushNode(thing, NPtype_SV);
1124 ADD_SIZE(st, "sv_head", sizeof(SV));
1125 ADD_SIZE(st, "sv_body", body_sizes[type]);
1128 #if (PERL_VERSION < 11)
1129 /* Is it a reference? */
1134 if(recurse && SvROK(thing)) /* XXX maybe don't follow weakrefs */
1135 sv_size(aTHX_ st, (SvWEAKREF(thing) ? NPathLink("weakRV") : NPathLink("RV")), SvRV_const(thing), recurse);
1139 /* Is there anything in the array? */
1140 if (AvMAX(thing) != -1) {
1141 /* an array with 10 slots has AvMax() set to 9 - te 2007-04-22 */
1142 ADD_SIZE(st, "av_max", sizeof(SV *) * (AvMAX(thing) + 1));
1143 dbg_printf(("total_size: %li AvMAX: %li av_len: $i\n", st->total_size, AvMAX(thing), av_len((AV*)thing)));
1145 if (recurse >= st->min_recurse_threshold) {
1146 SSize_t i = AvFILLp(thing) + 1;
1149 if (sv_size(aTHX_ st, NPathLink("AVelem"), AvARRAY(thing)[i], recurse))
1150 ADD_LINK_ATTR(st, NPattr_NOTE, "i", i);
1154 /* Add in the bits on the other side of the beginning */
1156 dbg_printf(("total_size %li, sizeof(SV *) %li, AvARRAY(thing) %li, AvALLOC(thing)%li , sizeof(ptr) %li \n",
1157 st->total_size, sizeof(SV*), AvARRAY(thing), AvALLOC(thing), sizeof( thing )));
1159 /* under Perl 5.8.8 64bit threading, AvARRAY(thing) was a pointer while AvALLOC was 0,
1160 resulting in grossly overstated sized for arrays. Technically, this shouldn't happen... */
1161 if (AvALLOC(thing) != 0) {
1162 ADD_SIZE(st, "AvALLOC", (sizeof(SV *) * (AvARRAY(thing) - AvALLOC(thing))));
1164 #if (PERL_VERSION < 9)
1165 /* Is there something hanging off the arylen element?
1166 Post 5.9.something this is stored in magic, so will be found there,
1167 and Perl_av_arylen_p() takes a non-const AV*, hence compilers rightly
1168 complain about AvARYLEN() passing thing to it. */
1169 sv_size(aTHX_ st, NPathLink("ARYLEN"), AvARYLEN(thing), recurse);
1174 /* Now the array of buckets */
1175 if (HvENAME(thing)) {
1176 ADD_ATTR(st, NPattr_NAME, HvENAME(thing), 0);
1178 ADD_SIZE(st, "hv_max", (sizeof(HE *) * (HvMAX(thing) + 1)));
1179 /* Now walk the bucket chain */
1180 if (HvARRAY(thing)) {
1184 for (cur_bucket = 0; cur_bucket <= HvMAX(thing); cur_bucket++) {
1185 cur_entry = *(HvARRAY(thing) + cur_bucket);
1187 NPathPushNode("he", NPtype_LINK);
1188 NPathPushNode("he+hek", NPtype_NAME);
1189 ADD_SIZE(st, "he", sizeof(HE));
1190 hek_size(aTHX_ st, cur_entry->hent_hek, HvSHAREKEYS(thing), NPathLink("hent_hek"));
1191 if (recurse >= st->min_recurse_threshold) {
1192 if (orig_thing == (SV*)PL_strtab) {
1193 /* For PL_strtab the HeVAL is used as a refcnt */
1194 ADD_SIZE(st, "shared_hek", HeKLEN(cur_entry));
1197 /* I've seen a PL_strtab HeVAL == 0xC and 0x40C etc
1198 * just running perl -Mblib -Mstrict -MDevel::Size=:all -MCarp -e 'warn perl_size()'
1199 * but it seemed like a corruption - it would change come and go with irrelevant code changes.
1200 * so we protect against that here, but I'd like to know the cause.
1202 if (PTR2UV(HeVAL(cur_entry)) > 0xFFF)
1203 sv_size(aTHX_ st, NPathLink("HeVAL"), HeVAL(cur_entry), recurse);
1204 else warn("skipped suspect HeVAL %p", HeVAL(cur_entry));
1207 cur_entry = cur_entry->hent_next;
1211 } /* bucket chain */
1216 /* This direct access is arguably "naughty": */
1217 struct mro_meta *meta = HvAUX(thing)->xhv_mro_meta;
1218 #if PERL_VERSION > 13 || PERL_SUBVERSION > 8 /* XXX plain || seems like a bug */
1220 I32 count = HvAUX(thing)->xhv_name_count;
1223 HEK **names = HvAUX(thing)->xhv_name_u.xhvnameu_names;
1227 hek_size(aTHX_ st, names[count], 1, NPathLink("HvAUXelem"));
1232 hek_size(aTHX_ st, HvNAME_HEK(thing), 1, NPathLink("HvNAME_HEK"));
1235 ADD_SIZE(st, "xpvhv_aux", sizeof(struct xpvhv_aux));
1237 ADD_SIZE(st, "mro_meta", sizeof(struct mro_meta));
1238 sv_size(aTHX_ st, NPathLink("mro_nextmethod"), (SV *)meta->mro_nextmethod, TOTAL_SIZE_RECURSION);
1239 #if PERL_VERSION > 10 || (PERL_VERSION == 10 && PERL_SUBVERSION > 0)
1240 sv_size(aTHX_ st, NPathLink("isa"), (SV *)meta->isa, TOTAL_SIZE_RECURSION);
1242 #if PERL_VERSION > 10
1243 sv_size(aTHX_ st, NPathLink("mro_linear_all"), (SV *)meta->mro_linear_all, TOTAL_SIZE_RECURSION);
1244 sv_size(aTHX_ st, NPathLink("mro_linear_current"), meta->mro_linear_current, TOTAL_SIZE_RECURSION);
1246 sv_size(aTHX_ st, NPathLink("mro_linear_dfs"), (SV *)meta->mro_linear_dfs, TOTAL_SIZE_RECURSION);
1247 sv_size(aTHX_ st, NPathLink("mro_linear_c3"), (SV *)meta->mro_linear_c3, TOTAL_SIZE_RECURSION);
1252 check_new_and_strlen(st, HvNAME_get(thing), NPathLink("HvNAME"));
1258 padlist_size(aTHX_ st, NPathLink("CvPADLIST"), CvPADLIST(thing), recurse);
1259 sv_size(aTHX_ st, NPathLink("CvOUTSIDE"), (SV *)CvOUTSIDE(thing), SOME_RECURSION);
1261 if (st->go_yell && !st->fm_whine) {
1262 carp("Devel::Size: Calculated sizes for FMs are incomplete");
1268 /* not CvSTASH, per https://rt.cpan.org/Ticket/Display.html?id=79366 */
1269 ADD_ATTR(st, NPattr_NAME, CvGV(thing) ? GvNAME(CvGV(thing)) : "UNDEFINED", 0);
1270 sv_size(aTHX_ st, NPathLink("CvGV"), (SV *)CvGV(thing), SOME_RECURSION);
1271 padlist_size(aTHX_ st, NPathLink("CvPADLIST"), CvPADLIST(thing), recurse);
1272 sv_size(aTHX_ st, NPathLink("CvOUTSIDE"), (SV *)CvOUTSIDE(thing), SOME_RECURSION);
1273 if (CvISXSUB(thing)) {
1274 sv_size(aTHX_ st, NPathLink("cv_const_sv"), cv_const_sv((CV *)thing), recurse);
1276 if(1)op_size(aTHX_ CvSTART(thing), st, NPathLinkAndNode("CvSTART", "OPs")); /* XXX ? */
1277 op_size(aTHX_ CvROOT(thing), st, NPathLinkAndNode("CvROOT", "OPs"));
1282 /* Some embedded char pointers */
1283 check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_top_name, NPathLink("xio_top_name"));
1284 check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_fmt_name, NPathLink("xio_fmt_name"));
1285 check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_bottom_name, NPathLink("xio_bottom_name"));
1286 /* Throw the GVs on the list to be walked if they're not-null */
1287 sv_size(aTHX_ st, NPathLink("xio_top_gv"), (SV *)((XPVIO *) SvANY(thing))->xio_top_gv, recurse);
1288 sv_size(aTHX_ st, NPathLink("xio_bottom_gv"), (SV *)((XPVIO *) SvANY(thing))->xio_bottom_gv, recurse);
1289 sv_size(aTHX_ st, NPathLink("xio_fmt_gv"), (SV *)((XPVIO *) SvANY(thing))->xio_fmt_gv, recurse);
1291 /* Only go trotting through the IO structures if they're really
1292 trottable. If USE_PERLIO is defined we can do this. If
1293 not... we can't, so we don't even try */
1295 /* Dig into xio_ifp and xio_ofp here */
1296 warn("Devel::Size: Can't size up perlio layers yet\n");
1301 #if (PERL_VERSION < 9)
1306 if(isGV_with_GP(thing)) {
1308 hek_size(aTHX_ st, GvNAME_HEK(thing), 1, NPathLink("GvNAME_HEK"));
1310 ADD_SIZE(st, "GvNAMELEN", GvNAMELEN(thing));
1312 ADD_ATTR(st, NPattr_NAME, GvNAME_get(thing), 0);
1314 hek_size(aTHX_ st, GvFILE_HEK(thing), 1, NPathLink("GvFILE_HEK"));
1315 #elif defined(GvFILE)
1316 # if !defined(USE_ITHREADS) || (PERL_VERSION > 8 || (PERL_VERSION == 8 && PERL_SUBVERSION > 8))
1317 /* With itreads, before 5.8.9, this can end up pointing to freed memory
1318 if the GV was created in an eval, as GvFILE() points to CopFILE(),
1319 and the relevant COP has been freed on scope cleanup after the eval.
1320 5.8.9 adds a binary compatible fudge that catches the vast majority
1321 of cases. 5.9.something added a proper fix, by converting the GP to
1322 use a shared hash key (porperly reference counted), instead of a
1323 char * (owned by who knows? possibly no-one now) */
1324 check_new_and_strlen(st, GvFILE(thing), NPathLink("GvFILE"));
1327 /* Is there something hanging off the glob? */
1328 if (check_new(st, GvGP(thing))) {
1329 ADD_SIZE(st, "GP", sizeof(GP));
1330 sv_size(aTHX_ st, NPathLink("gp_sv"), (SV *)(GvGP(thing)->gp_sv), recurse);
1331 sv_size(aTHX_ st, NPathLink("gp_av"), (SV *)(GvGP(thing)->gp_av), recurse);
1332 sv_size(aTHX_ st, NPathLink("gp_hv"), (SV *)(GvGP(thing)->gp_hv), recurse);
1333 sv_size(aTHX_ st, NPathLink("gp_cv"), (SV *)(GvGP(thing)->gp_cv), recurse);
1334 sv_size(aTHX_ st, NPathLink("gp_egv"), (SV *)(GvGP(thing)->gp_egv), recurse);
1335 sv_size(aTHX_ st, NPathLink("gp_form"), (SV *)(GvGP(thing)->gp_form), recurse);
1337 #if (PERL_VERSION >= 9)
1341 #if PERL_VERSION <= 8
1349 if(recurse && SvROK(thing))
1350 sv_size(aTHX_ st, NPathLink("RV"), SvRV_const(thing), recurse);
1351 else if (SvIsCOW_shared_hash(thing))
1352 hek_size(aTHX_ st, SvSHARED_HEK_FROM_PV(SvPVX(thing)), 1, NPathLink("SvSHARED_HEK_FROM_PV"));
1354 ADD_SIZE(st, "SvLEN", SvLEN(thing));
1358 SvOOK_offset(thing, len);
1359 ADD_SIZE(st, "SvOOK", len);
1365 if (type >= SVt_PVMG) {
1366 if (SvMAGICAL(thing))
1367 magic_size(aTHX_ thing, st, NPathLink("MG"));
1368 if (SvPAD_OUR(thing) && SvOURSTASH(thing))
1369 sv_size(aTHX_ st, NPathLink("SvOURSTASH"), (SV *)SvOURSTASH(thing), SOME_RECURSION);
1371 sv_size(aTHX_ st, NPathLink("SvSTASH"), (SV *)SvSTASH(thing), SOME_RECURSION);
1378 free_memnode_state(pTHX_ struct state *st)
1380 /* PERL_UNUSED_ARG(aTHX); fails for non-threaded perl */
1381 if (st->node_stream_fh && st->node_stream_name && *st->node_stream_name) {
1382 fprintf(st->node_stream_fh, "E %d %f %s\n",
1383 getpid(), gettimeofday_nv()-st->start_time_nv, "unnamed");
1384 if (*st->node_stream_name == '|') {
1385 if (pclose(st->node_stream_fh))
1386 warn("%s exited with an error status\n", st->node_stream_name);
1389 if (fclose(st->node_stream_fh))
1390 warn("Error closing %s: %s\n", st->node_stream_name, strerror(errno));
1395 static struct state *
1401 Newxz(st, 1, struct state);
1403 st->min_recurse_threshold = TOTAL_SIZE_RECURSION;
1404 if (NULL != (warn_flag = perl_get_sv("Devel::Size::warn", FALSE))) {
1405 st->dangle_whine = st->go_yell = SvIV(warn_flag) ? TRUE : FALSE;
1407 if (NULL != (warn_flag = perl_get_sv("Devel::Size::dangle", FALSE))) {
1408 st->dangle_whine = SvIV(warn_flag) ? TRUE : FALSE;
1410 st->start_time_nv = gettimeofday_nv();
1411 check_new(st, &PL_sv_undef);
1412 check_new(st, &PL_sv_no);
1413 check_new(st, &PL_sv_yes);
1414 #if PERL_VERSION > 8 || (PERL_VERSION == 8 && PERL_SUBVERSION > 0)
1415 check_new(st, &PL_sv_placeholder);
1418 #ifdef PATH_TRACKING
1419 /* XXX quick hack */
1420 st->node_stream_name = getenv("SIZEME");
1421 if (st->node_stream_name) {
1422 if (*st->node_stream_name) {
1423 if (*st->node_stream_name == '|')
1424 st->node_stream_fh = popen(st->node_stream_name+1, "w");
1426 st->node_stream_fh = fopen(st->node_stream_name, "wb");
1427 if (!st->node_stream_fh)
1428 croak("Can't open '%s' for writing: %s", st->node_stream_name, strerror(errno));
1429 if(0)setlinebuf(st->node_stream_fh); /* XXX temporary for debugging */
1430 st->add_attr_cb = np_stream_node_path_info;
1431 fprintf(st->node_stream_fh, "S %d %f %s\n",
1432 getpid(), st->start_time_nv, "unnamed");
1435 st->add_attr_cb = np_dump_node_path_info;
1437 st->free_state_cb = free_memnode_state;
1443 /* XXX based on S_visit() in sv.c */
1445 unseen_sv_size(pTHX_ struct state *st, pPATH)
1449 dNPathNodes(1, NPathArg);
1451 NPathPushNode("unseen", NPtype_NAME);
1453 /* by this point we should have visited all the SVs
1454 * so now we'll run through all the SVs via the arenas
1455 * in order to find any thet we've missed for some reason.
1456 * Once the rest of the code is finding all the SVs then any
1457 * found here will be leaks.
1459 for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) {
1460 const SV * const svend = &sva[SvREFCNT(sva)];
1462 for (sv = sva + 1; sv < svend; ++sv) {
1463 if (SvTYPE(sv) != (svtype)SVTYPEMASK && SvREFCNT(sv)) {
1464 sv_size(aTHX_ st, NPathLink("arena"), sv, TOTAL_SIZE_RECURSION);
1466 else if (check_new(st, sv)) { /* sanity check */
1468 warn("unseen_sv_size encountered freed SV unexpectedly"); /* XXX warn uses an SV, I think */
1476 madprop_size(pTHX_ struct state *const st, pPath, MADPROP *prop)
1478 dPathNodes(2, NPathArg);
1479 if (!check_new(st, prop))
1481 NPathPushNode("madprop_size", NPtype_NAME);
1482 ADD_SIZE(st, "MADPROP", sizeof(MADPROP));
1484 NPathPushNode("val");
1485 ADD_SIZE(st, "val", prop->mad_val);
1487 madprop_size(aTHX_ st, NPathLink("mad_next"), prop->mad_next);
1492 parser_size(pTHX_ struct state *const st, pPATH, yy_parser *parser)
1494 dNPathNodes(2, NPathArg);
1495 if (!check_new(st, parser))
1497 NPathPushNode("parser_size", NPtype_NAME);
1498 ADD_SIZE(st, "yy_parser", sizeof(yy_parser));
1500 NPathPushNode("stack", NPtype_NAME);
1502 //warn("total: %u", parser->stack_size);
1503 //warn("foo: %u", parser->ps - parser->stack);
1504 ADD_SIZE(st, "stack_frames", parser->stack_size * sizeof(yy_stack_frame));
1505 for (ps = parser->stack; ps <= parser->ps; ps++) {
1506 ADD_PRE_ATTR(st, 0, "frame", ps - parser->ps);
1507 sv_size(aTHX_ st, NPathLink("compcv"), (SV*)ps->compcv, TOTAL_SIZE_RECURSION);
1511 sv_size(aTHX_ st, NPathLink("lex_repl"), (SV*)parser->lex_repl, TOTAL_SIZE_RECURSION);
1512 sv_size(aTHX_ st, NPathLink("lex_stuff"), (SV*)parser->lex_stuff, TOTAL_SIZE_RECURSION);
1513 sv_size(aTHX_ st, NPathLink("linestr"), (SV*)parser->linestr, TOTAL_SIZE_RECURSION);
1514 sv_size(aTHX_ st, NPathLink("in_my_stash"), (SV*)parser->in_my_stash, TOTAL_SIZE_RECURSION);
1515 //sv_size(aTHX_ st, NPathLink("rsfp"), parser->rsfp, TOTAL_SIZE_RECURSION);
1516 sv_size(aTHX_ st, NPathLink("rsfp_filters"), (SV*)parser->rsfp_filters, TOTAL_SIZE_RECURSION);
1518 sv_size(aTHX_ st, NPathLink("endwhite"), parser->endwhite, TOTAL_SIZE_RECURSION);
1519 sv_size(aTHX_ st, NPathLink("nextwhite"), parser->nextwhite, TOTAL_SIZE_RECURSION);
1520 sv_size(aTHX_ st, NPathLink("skipwhite"), parser->skipwhite, TOTAL_SIZE_RECURSION);
1521 sv_size(aTHX_ st, NPathLink("thisclose"), parser->thisclose, TOTAL_SIZE_RECURSION);
1522 madprop_size(aTHX_ st, NPathLink("thismad"), parser->thismad);
1523 sv_size(aTHX_ st, NPathLink("thisopen"), parser->thisopen, TOTAL_SIZE_RECURSION);
1524 sv_size(aTHX_ st, NPathLink("thisstuff"), parser->thisstuff, TOTAL_SIZE_RECURSION);
1525 sv_size(aTHX_ st, NPathLink("thistoken"), parser->thistoken, TOTAL_SIZE_RECURSION);
1526 sv_size(aTHX_ st, NPathLink("thiswhite"), parser->thiswhite, TOTAL_SIZE_RECURSION);
1528 op_size_class(aTHX_ (OP*)parser->saved_curcop, OPc_COP, 0,
1529 st, NPathLink("saved_curcop"));
1531 if (parser->old_parser)
1532 parser_size(aTHX_ st, NPathLink("old_parser"), parser->old_parser);
1536 perl_size(pTHX_ struct state *const st, pPATH)
1538 dNPathNodes(3, NPathArg);
1540 /* if(!check_new(st, interp)) return; */
1541 NPathPushNode("perl", NPtype_NAME);
1542 #if defined(MULTIPLICITY)
1543 ADD_SIZE(st, "PerlInterpreter", sizeof(PerlInterpreter));
1549 * unknown <== = O/S Heap size - perl - free_malloc_space
1551 /* start with PL_defstash to get everything reachable from \%main:: */
1552 sv_size(aTHX_ st, NPathLink("PL_defstash"), (SV*)PL_defstash, TOTAL_SIZE_RECURSION);
1554 NPathPushNode("others", NPtype_NAME); /* group these (typically much smaller) items */
1555 sv_size(aTHX_ st, NPathLink("PL_defgv"), (SV*)PL_defgv, TOTAL_SIZE_RECURSION);
1556 sv_size(aTHX_ st, NPathLink("PL_incgv"), (SV*)PL_incgv, TOTAL_SIZE_RECURSION);
1557 sv_size(aTHX_ st, NPathLink("PL_rs"), (SV*)PL_rs, TOTAL_SIZE_RECURSION);
1558 sv_size(aTHX_ st, NPathLink("PL_fdpid"), (SV*)PL_fdpid, TOTAL_SIZE_RECURSION);
1559 sv_size(aTHX_ st, NPathLink("PL_modglobal"), (SV*)PL_modglobal, TOTAL_SIZE_RECURSION);
1560 sv_size(aTHX_ st, NPathLink("PL_errors"), (SV*)PL_errors, TOTAL_SIZE_RECURSION);
1561 sv_size(aTHX_ st, NPathLink("PL_stashcache"), (SV*)PL_stashcache, TOTAL_SIZE_RECURSION);
1562 sv_size(aTHX_ st, NPathLink("PL_patchlevel"), (SV*)PL_patchlevel, TOTAL_SIZE_RECURSION);
1563 sv_size(aTHX_ st, NPathLink("PL_apiversion"), (SV*)PL_apiversion, TOTAL_SIZE_RECURSION);
1564 sv_size(aTHX_ st, NPathLink("PL_registered_mros"), (SV*)PL_registered_mros, TOTAL_SIZE_RECURSION);
1566 sv_size(aTHX_ st, NPathLink("PL_regex_padav"), (SV*)PL_regex_padav, TOTAL_SIZE_RECURSION);
1568 sv_size(aTHX_ st, NPathLink("PL_warnhook"), (SV*)PL_warnhook, TOTAL_SIZE_RECURSION);
1569 sv_size(aTHX_ st, NPathLink("PL_diehook"), (SV*)PL_diehook, TOTAL_SIZE_RECURSION);
1570 sv_size(aTHX_ st, NPathLink("PL_endav"), (SV*)PL_endav, TOTAL_SIZE_RECURSION);
1571 sv_size(aTHX_ st, NPathLink("PL_main_cv"), (SV*)PL_main_cv, TOTAL_SIZE_RECURSION);
1572 sv_size(aTHX_ st, NPathLink("PL_main_root"), (SV*)PL_main_root, TOTAL_SIZE_RECURSION);
1573 sv_size(aTHX_ st, NPathLink("PL_main_start"), (SV*)PL_main_start, TOTAL_SIZE_RECURSION);
1574 sv_size(aTHX_ st, NPathLink("PL_envgv"), (SV*)PL_envgv, TOTAL_SIZE_RECURSION);
1575 sv_size(aTHX_ st, NPathLink("PL_hintgv"), (SV*)PL_hintgv, TOTAL_SIZE_RECURSION);
1576 sv_size(aTHX_ st, NPathLink("PL_e_script"), (SV*)PL_e_script, TOTAL_SIZE_RECURSION);
1577 sv_size(aTHX_ st, NPathLink("PL_encoding"), (SV*)PL_encoding, TOTAL_SIZE_RECURSION);
1578 sv_size(aTHX_ st, NPathLink("PL_ofsgv"), (SV*)PL_ofsgv, TOTAL_SIZE_RECURSION);
1579 sv_size(aTHX_ st, NPathLink("PL_argvout_stack"), (SV*)PL_argvout_stack, TOTAL_SIZE_RECURSION);
1580 sv_size(aTHX_ st, NPathLink("PL_beginav"), (SV*)PL_beginav, TOTAL_SIZE_RECURSION);
1581 sv_size(aTHX_ st, NPathLink("PL_beginav_save"), (SV*)PL_beginav_save, TOTAL_SIZE_RECURSION);
1582 sv_size(aTHX_ st, NPathLink("PL_checkav_save"), (SV*)PL_checkav_save, TOTAL_SIZE_RECURSION);
1583 sv_size(aTHX_ st, NPathLink("PL_unitcheckav"), (SV*)PL_unitcheckav, TOTAL_SIZE_RECURSION);
1584 sv_size(aTHX_ st, NPathLink("PL_unitcheckav_save"), (SV*)PL_unitcheckav_save, TOTAL_SIZE_RECURSION);
1585 sv_size(aTHX_ st, NPathLink("PL_endav"), (SV*)PL_endav, TOTAL_SIZE_RECURSION);
1586 sv_size(aTHX_ st, NPathLink("PL_checkav"), (SV*)PL_checkav, TOTAL_SIZE_RECURSION);
1587 sv_size(aTHX_ st, NPathLink("PL_initav"), (SV*)PL_initav, TOTAL_SIZE_RECURSION);
1588 sv_size(aTHX_ st, NPathLink("PL_isarev"), (SV*)PL_isarev, TOTAL_SIZE_RECURSION);
1589 sv_size(aTHX_ st, NPathLink("PL_fdpid"), (SV*)PL_fdpid, TOTAL_SIZE_RECURSION);
1590 sv_size(aTHX_ st, NPathLink("PL_preambleav"), (SV*)PL_preambleav, TOTAL_SIZE_RECURSION);
1591 sv_size(aTHX_ st, NPathLink("PL_ors_sv"), (SV*)PL_ors_sv, TOTAL_SIZE_RECURSION);
1592 sv_size(aTHX_ st, NPathLink("PL_modglobal"), (SV*)PL_modglobal, TOTAL_SIZE_RECURSION);
1593 sv_size(aTHX_ st, NPathLink("PL_custom_op_names"), (SV*)PL_custom_op_names, TOTAL_SIZE_RECURSION);
1594 sv_size(aTHX_ st, NPathLink("PL_custom_op_descs"), (SV*)PL_custom_op_descs, TOTAL_SIZE_RECURSION);
1595 sv_size(aTHX_ st, NPathLink("PL_custom_ops"), (SV*)PL_custom_ops, TOTAL_SIZE_RECURSION);
1596 sv_size(aTHX_ st, NPathLink("PL_compcv"), (SV*)PL_compcv, TOTAL_SIZE_RECURSION);
1597 sv_size(aTHX_ st, NPathLink("PL_DBcv"), (SV*)PL_DBcv, TOTAL_SIZE_RECURSION);
1598 #ifdef PERL_USES_PL_PIDSTATUS
1599 sv_size(aTHX_ st, NPathLink("PL_pidstatus"), (SV*)PL_pidstatus, TOTAL_SIZE_RECURSION);
1601 sv_size(aTHX_ st, NPathLink("PL_subname"), (SV*)PL_subname, TOTAL_SIZE_RECURSION);
1602 #ifdef USE_LOCALE_NUMERIC
1603 sv_size(aTHX_ st, NPathLink("PL_numeric_radix_sv"), (SV*)PL_numeric_radix_sv, TOTAL_SIZE_RECURSION);
1604 check_new_and_strlen(st, PL_numeric_name, NPathLink("PL_numeric_name"));
1606 #ifdef USE_LOCALE_COLLATE
1607 check_new_and_strlen(st, PL_collation_name, NPathLink("PL_collation_name"));
1609 check_new_and_strlen(st, PL_origfilename, NPathLink("PL_origfilename"));
1610 check_new_and_strlen(st, PL_inplace, NPathLink("PL_inplace"));
1611 check_new_and_strlen(st, PL_osname, NPathLink("PL_osname"));
1612 if (PL_op_mask && check_new(st, PL_op_mask))
1613 ADD_SIZE(st, "PL_op_mask", PL_maxo);
1614 if (PL_exitlistlen && check_new(st, PL_exitlist))
1615 ADD_SIZE(st, "PL_exitlist", (PL_exitlistlen * sizeof(PerlExitListEntry *))
1616 + (PL_exitlistlen * sizeof(PerlExitListEntry)));
1617 #ifdef PERL_IMPLICIT_CONTEXT
1618 if (PL_my_cxt_size && check_new(st, PL_my_cxt_list)) {
1619 ADD_SIZE(st, "PL_my_cxt_list", (PL_my_cxt_size * sizeof(void *)));
1620 #ifdef PERL_GLOBAL_STRUCT_PRIVATE
1621 ADD_SIZE(st, "PL_my_cxt_keys", (PL_my_cxt_size * sizeof(char *)));
1625 /* TODO PL_stashpad */
1626 op_size_class(aTHX_ (OP*)&PL_compiling, OPc_COP, 1, st, NPathLink("PL_compiling"));
1627 op_size_class(aTHX_ (OP*)PL_curcopdb, OPc_COP, 0, st, NPathLink("PL_curcopdb"));
1629 parser_size(aTHX_ st, NPathLink("PL_parser"), PL_parser);
1630 /* TODO stacks: cur, main, tmps, mark, scope, save */
1631 /* TODO PL_exitlist */
1632 /* TODO PL_reentrant_buffers etc */
1634 /* TODO PerlIO? PL_known_layers PL_def_layerlist PL_perlio_fd_refcnt etc */
1636 /* TODO anything missed? */
1638 /* --- by this point we should have seen all reachable SVs --- */
1640 /* in theory we shouldn't have any elements in PL_strtab that haven't been seen yet */
1641 sv_size(aTHX_ st, NPathLink("PL_strtab-unseen"), (SV*)PL_strtab, TOTAL_SIZE_RECURSION);
1643 /* unused space in sv head arenas */
1647 # define SvARENA_CHAIN(sv) SvANY(sv) /* XXX breaks encapsulation*/
1648 while ((p = MUTABLE_SV(SvARENA_CHAIN(p)))) {
1649 if (!check_new(st, p)) /* sanity check */
1650 warn("Free'd SV head unexpectedly already seen");
1653 NPathPushNode("unused_sv_heads", NPtype_NAME);
1654 ADD_SIZE(st, "sv", free_heads * sizeof(SV));
1657 /* XXX iterate over bodies_by_type and crawl the free chains for each */
1659 /* iterate over all SVs to find any we've not accounted for yet */
1660 /* once the code above is visiting all SVs, any found here have been leaked */
1661 unseen_sv_size(aTHX_ st, NPathLink("unaccounted"));
1665 MODULE = Devel::SizeMe PACKAGE = Devel::SizeMe
1673 total_size = TOTAL_SIZE_RECURSION
1676 SV *thing = orig_thing;
1677 struct state *st = new_state(aTHX);
1679 /* If they passed us a reference then dereference it. This is the
1680 only way we can check the sizes of arrays and hashes */
1682 thing = SvRV(thing);
1685 sv_size(aTHX_ st, NULL, thing, ix);
1686 RETVAL = st->total_size;
1687 free_state(aTHX_ st);
1696 /* just the current perl interpreter */
1697 struct state *st = new_state(aTHX);
1698 st->min_recurse_threshold = NO_RECURSION; /* so always recurse */
1699 perl_size(aTHX_ st, NULL);
1700 RETVAL = st->total_size;
1701 free_state(aTHX_ st);
1710 /* the current perl interpreter plus malloc, in the context of total heap size */
1711 # ifdef _MALLOC_MALLOC_H_ /* OSX. Now sure where else mstats is available */
1715 /* some systems have the SVID2/XPG mallinfo structure and function */
1716 struct mstats ms = mstats(); /* mstats() first */
1718 struct state *st = new_state(aTHX);
1719 dNPathNodes(1, NULL);
1720 NPathPushNode("heap", NPtype_NAME);
1722 st->min_recurse_threshold = NO_RECURSION; /* so always recurse */
1724 perl_size(aTHX_ st, NPathLink("perl_interp"));
1726 NPathSetNode("free_malloc_space", NPtype_NAME);
1727 ADD_SIZE(st, "bytes_free", ms.bytes_free);
1728 ADD_ATTR(st, NPattr_NOTE, "bytes_total", ms.bytes_total);
1729 ADD_ATTR(st, NPattr_NOTE, "bytes_used", ms.bytes_used);
1730 ADD_ATTR(st, NPattr_NOTE, "chunks_used", ms.chunks_used);
1731 ADD_ATTR(st, NPattr_NOTE, "chunks_free", ms.chunks_free);
1732 /* TODO get heap size from OS and add a node: unknown = heapsize - perl - ms.bytes_free */
1733 /* for now we use bytes_total as an approximation */
1734 NPathSetNode("unknown", NPtype_NAME);
1735 ADD_SIZE(st, "unknown", ms.bytes_total - st->total_size);
1740 RETVAL = st->total_size;
1741 free_state(aTHX_ st);