5 * Refactor this to split out D:M code from Devel::Size code.
6 * Start migrating Devel::Size's Size.xs towards the new code.
10 #undef NDEBUG /* XXX */
13 #define PERL_NO_GET_CONTEXT
19 #define DPPP_PL_parser_NO_DUMMY
20 #define NEED_PL_parser
23 #include "refcounted_he.h"
25 /* Not yet in ppport.h */
27 # define CvISXSUB(cv) (CvXSUB(cv) ? TRUE : FALSE)
30 # define SvRV_const(rv) SvRV(rv)
33 # define SvOOK_offset(sv, len) STMT_START { len = SvIVX(sv); } STMT_END
36 # define SvIsCOW(sv) ((SvFLAGS(sv) & (SVf_FAKE | SVf_READONLY)) == \
37 (SVf_FAKE | SVf_READONLY))
39 #ifndef SvIsCOW_shared_hash
40 # define SvIsCOW_shared_hash(sv) (SvIsCOW(sv) && SvLEN(sv) == 0)
42 #ifndef SvSHARED_HEK_FROM_PV
43 # define SvSHARED_HEK_FROM_PV(pvx) \
44 ((struct hek*)(pvx - STRUCT_OFFSET(struct hek, hek_key)))
46 #ifndef CopHINTHASH_get
47 #define CopHINTHASH_get(c) ((COPHH*)((c)->cop_hints_hash))
50 #define MUTABLE_AV(p) ((AV*)p)
53 #define MUTABLE_SV(p) ((SV*)p)
57 # define PL_opargs opargs
58 # define PL_op_name op_name
62 /* "structured exception" handling is a Microsoft extension to C and C++.
63 It's *not* C++ exception handling - C++ exception handling can't capture
64 SEGVs and suchlike, whereas this can. There's no known analagous
65 functionality on other platforms. */
67 # define TRY_TO_CATCH_SEGV __try
68 # define CAUGHT_EXCEPTION __except(EXCEPTION_EXECUTE_HANDLER)
70 # define TRY_TO_CATCH_SEGV if(1)
71 # define CAUGHT_EXCEPTION else
75 # define __attribute__(x)
78 #if 0 && defined(DEBUGGING)
79 #define dbg_printf(x) printf x
84 #define TAG /* printf( "# %s(%d)\n", __FILE__, __LINE__ ) */
87 /* The idea is to have a tree structure to store 1 bit per possible pointer
88 address. The lowest 16 bits are stored in a block of 8092 bytes.
89 The blocks are in a 256-way tree, indexed by the reset of the pointer.
90 This can cope with 32 and 64 bit pointers, and any address space layout,
91 without excessive memory needs. The assumption is that your CPU cache
92 works :-) (And that we're not going to bust it) */
95 #define LEAF_BITS (16 - BYTE_BITS)
96 #define LEAF_MASK 0x1FFF
98 typedef struct npath_node_st npath_node_t;
99 struct npath_node_st {
114 /* My hunch (not measured) is that for most architectures pointers will
115 start with 0 bits, hence the start of this array will be hot, and the
116 end unused. So put the flags next to the hot end. */
119 int min_recurse_threshold;
120 /* callback hooks and data */
121 void (*add_attr_cb)(pTHX_ struct state *st, npath_node_t *npath_node, UV attr_type, const char *name, UV value);
122 void (*free_state_cb)(pTHX_ struct state *st);
123 void *state_cb_data; /* free'd by free_state() after free_state_cb() call */
124 /* this stuff wil be moved to state_cb_data later */
126 FILE *node_stream_fh;
127 char *node_stream_name;
130 #define ADD_SIZE(st, leafname, bytes) \
132 NPathAddSizeCb(st, leafname, bytes); \
133 (st)->total_size += (bytes); \
137 #define PATH_TRACKING
140 #define pPATH npath_node_t *NPathArg
142 /* A subtle point here is that dNPathNodes and NPathPushNode leave NP pointing
143 * to the next unused slot (though with prev already filled in)
144 * whereas NPathLink leaves NP unchanged, it just fills in the slot NP points
145 * to and passes that NP value to the function being called.
146 * seqn==0 indicates the node is new (hasn't been output yet)
148 #define dNPathNodes(nodes, prev_np) \
149 npath_node_t name_path_nodes[nodes+1]; /* +1 for NPathLink */ \
150 npath_node_t *NP = &name_path_nodes[0]; \
151 NP->seqn = NP->type = 0; NP->id = Nullch; /* safety/debug */ \
153 #define NPathPushNode(nodeid, nodetype) \
155 NP->type = nodetype; \
157 if(0)fprintf(stderr,"NPathPushNode (%p <-) %p <- [%d %s]\n", NP->prev, NP, nodetype,(char*)nodeid);\
159 NP->id = Nullch; /* safety/debug */ \
162 #define NPathSetNode(nodeid, nodetype) \
163 (NP-1)->id = nodeid; \
164 (NP-1)->type = nodetype; \
165 if(0)fprintf(stderr,"NPathSetNode (%p <-) %p <- [%d %s]\n", (NP-1)->prev, (NP-1), nodetype,(char*)nodeid);\
167 #define NPathPopNode \
170 /* dNPathUseParent points NP directly the the parents' name_path_nodes array
171 * So the function can only safely call ADD_*() but not NPathLink, unless the
172 * caller has spare nodes in its name_path_nodes.
174 #define dNPathUseParent(prev_np) npath_node_t *NP = (((prev_np+1)->prev = prev_np), prev_np+1)
176 #define NPtype_NAME 0x01
177 #define NPtype_LINK 0x02
178 #define NPtype_SV 0x03
179 #define NPtype_MAGIC 0x04
180 #define NPtype_OP 0x05
182 /* XXX these should probably be generalized into flag bits */
183 #define NPattr_LEAFSIZE 0x00
184 #define NPattr_NAME 0x01
185 #define NPattr_PADFAKE 0x02
186 #define NPattr_PADNAME 0x03
187 #define NPattr_PADTMP 0x04
188 #define NPattr_NOTE 0x05
190 #define _ADD_ATTR_NP(st, attr_type, attr_name, attr_value, np) \
192 if (st->add_attr_cb) { \
193 st->add_attr_cb(aTHX_ st, np, attr_type, attr_name, attr_value); \
197 #define ADD_ATTR(st, attr_type, attr_name, attr_value) \
198 _ADD_ATTR_NP(st, attr_type, attr_name, attr_value, NP-1)
200 #define ADD_LINK_ATTR(st, attr_type, attr_name, attr_value) \
202 if (st->add_attr_cb) assert(NP->seqn); \
203 _ADD_ATTR_NP(st, attr_type, attr_name, attr_value, NP); \
206 #define _NPathLink(np, nid, ntype) (((np)->id=nid), ((np)->type=ntype), ((np)->seqn=0))
207 #define NPathLink(nid) (_NPathLink(NP, nid, NPtype_LINK), NP)
208 /* add a link and a name node to the path - a special case for op_size */
209 #define NPathLinkAndNode(nid, nid2) (_NPathLink(NP, nid, NPtype_LINK), _NPathLink(NP+1, nid2, NPtype_NAME), ((NP+1)->prev=NP), (NP+1))
210 #define NPathOpLink (NPathArg)
211 #define NPathAddSizeCb(st, name, bytes) \
213 if (st->add_attr_cb) { \
214 st->add_attr_cb(aTHX_ st, NP-1, NPattr_LEAFSIZE, (name), (bytes)); \
220 #define NPathAddSizeCb(st, name, bytes)
221 #define pPATH void *npath_dummy /* XXX ideally remove */
222 #define dNPathNodes(nodes, prev_np) dNOOP
223 #define NPathLink(nodeid, nodetype) NULL
224 #define NPathOpLink NULL
225 #define ADD_ATTR(st, attr_type, attr_name, attr_value) NOOP
227 #endif /* PATH_TRACKING */
234 static const char *svtypenames[SVt_LAST] = {
236 "NULL", "IV", "NV", "RV", "PV", "PVIV", "PVNV", "PVMG", "PVBM", "PVLV", "PVAV", "PVHV", "PVCV", "PVGV", "PVFM", "PVIO",
237 #elif PERL_VERSION == 10 && PERL_SUBVERSION == 0
238 "NULL", "BIND", "IV", "NV", "RV", "PV", "PVIV", "PVNV", "PVMG", "PVGV", "PVLV", "PVAV", "PVHV", "PVCV", "PVFM", "PVIO",
239 #elif PERL_VERSION == 10 && PERL_SUBVERSION == 1
240 "NULL", "BIND", "IV", "NV", "RV", "PV", "PVIV", "PVNV", "PVMG", "PVGV", "PVLV", "PVAV", "PVHV", "PVCV", "PVFM", "PVIO",
241 #elif PERL_VERSION < 13
242 "NULL", "BIND", "IV", "NV", "PV", "PVIV", "PVNV", "PVMG", "REGEXP", "PVGV", "PVLV", "PVAV", "PVHV", "PVCV", "PVFM", "PVIO",
244 "NULL", "BIND", "IV", "NV", "PV", "PVIV", "PVNV", "PVMG", "REGEXP", "PVGV", "PVLV", "PVAV", "PVHV", "PVCV", "PVFM", "PVIO",
249 gettimeofday_nv(void)
251 #ifdef HAS_GETTIMEOFDAY
253 gettimeofday(&when, (struct timezone *) 0);
254 return when.tv_sec + (when.tv_usec / 1000000.0);
258 (*u2time)(aTHX_ &time_of_day);
259 return time_of_day[0] + (time_of_day[1] / 1000000.0);
267 np_print_node_name(pTHX_ FILE *fp, npath_node_t *npath_node)
269 switch (npath_node->type) {
270 case NPtype_SV: { /* id is pointer to the SV sv_size was called on */
271 const SV *sv = (SV*)npath_node->id;
272 int type = SvTYPE(sv);
273 const char *typename = (type == SVt_IV && SvROK(sv)) ? "RV" : svtypenames[type];
274 fprintf(fp, "SV(%s)", typename);
275 switch(type) { /* add some useful details */
276 case SVt_PVAV: fprintf(fp, " fill=%d/%ld", av_len((AV*)sv), AvMAX((AV*)sv)); break;
277 case SVt_PVHV: fprintf(fp, " fill=%ld/%ld", HvFILL((HV*)sv), HvMAX((HV*)sv)); break;
281 case NPtype_OP: { /* id is pointer to the OP op_size was called on */
282 const OP *op = (OP*)npath_node->id;
283 fprintf(fp, "OP(%s)", OP_NAME(op));
286 case NPtype_MAGIC: { /* id is pointer to the MAGIC struct */
287 MAGIC *magic_pointer = (MAGIC*)npath_node->id;
288 /* XXX it would be nice if we could reuse mg_names.c [sigh] */
289 fprintf(fp, "MAGIC(%c)", magic_pointer->mg_type ? magic_pointer->mg_type : '0');
293 fprintf(fp, "%s", (const char *)npath_node->id);
296 fprintf(fp, "%s", (const char *)npath_node->id);
298 default: /* assume id is a string pointer */
299 fprintf(fp, "UNKNOWN(%d,%p)", npath_node->type, npath_node->id);
306 np_dump_indent(int depth) {
308 fprintf(stderr, ": ");
312 np_walk_new_nodes(pTHX_ struct state *st,
313 npath_node_t *npath_node,
314 npath_node_t *npath_node_deeper,
315 int (*cb)(pTHX_ struct state *st, npath_node_t *npath_node, npath_node_t *npath_node_deeper))
317 if (npath_node->seqn) /* node already output */
320 if (npath_node->prev) {
321 np_walk_new_nodes(aTHX_ st, npath_node->prev, npath_node, cb); /* recurse */
322 npath_node->depth = npath_node->prev->depth + 1;
324 else npath_node->depth = 0;
325 npath_node->seqn = ++st->seqn;
328 if (cb(aTHX_ st, npath_node, npath_node_deeper)) {
329 /* ignore this node */
330 assert(npath_node->prev);
331 assert(npath_node->depth);
332 assert(npath_node_deeper);
334 npath_node->seqn = --st->seqn;
335 npath_node_deeper->prev = npath_node->prev;
343 np_dump_formatted_node(pTHX_ struct state *st, npath_node_t *npath_node, npath_node_t *npath_node_deeper) {
345 PERL_UNUSED_ARG(npath_node_deeper);
346 if (0 && npath_node->type == NPtype_LINK)
348 np_dump_indent(npath_node->depth);
349 np_print_node_name(aTHX_ stderr, npath_node);
350 if (npath_node->type == NPtype_LINK)
351 fprintf(stderr, "->"); /* cosmetic */
352 fprintf(stderr, "\t\t[#%ld @%u] ", npath_node->seqn, npath_node->depth);
353 fprintf(stderr, "\n");
358 np_dump_node_path_info(pTHX_ struct state *st, npath_node_t *npath_node, UV attr_type, const char *attr_name, UV attr_value)
360 if (attr_type == NPattr_LEAFSIZE && !attr_value)
361 return; /* ignore zero sized leaf items */
362 np_walk_new_nodes(aTHX_ st, npath_node, NULL, np_dump_formatted_node);
363 np_dump_indent(npath_node->depth+1);
365 case NPattr_LEAFSIZE:
366 fprintf(stderr, "+%ld %s =%ld", attr_value, attr_name, attr_value+st->total_size);
369 fprintf(stderr, "~NAMED('%s') %lu", attr_name, attr_value);
372 fprintf(stderr, "~note %s %lu", attr_name, attr_value);
377 fprintf(stderr, "~pad%lu %s %lu", attr_type, attr_name, attr_value);
380 fprintf(stderr, "~??? %s %lu", attr_name, attr_value);
383 fprintf(stderr, "\n");
387 np_stream_formatted_node(pTHX_ struct state *st, npath_node_t *npath_node, npath_node_t *npath_node_deeper) {
388 PERL_UNUSED_ARG(npath_node_deeper);
389 fprintf(st->node_stream_fh, "-%u %lu %u ",
390 npath_node->type, npath_node->seqn, (unsigned)npath_node->depth
392 np_print_node_name(aTHX_ st->node_stream_fh, npath_node);
393 fprintf(st->node_stream_fh, "\n");
398 np_stream_node_path_info(pTHX_ struct state *st, npath_node_t *npath_node, UV attr_type, const char *attr_name, UV attr_value)
400 if (!attr_type && !attr_value)
401 return; /* ignore zero sized leaf items */
402 np_walk_new_nodes(aTHX_ st, npath_node, NULL, np_stream_formatted_node);
403 if (attr_type) { /* Attribute type, name and value */
404 fprintf(st->node_stream_fh, "%lu %lu ", attr_type, npath_node->seqn);
406 else { /* Leaf name and memory size */
407 fprintf(st->node_stream_fh, "L %lu ", npath_node->seqn);
409 fprintf(st->node_stream_fh, "%lu %s\n", attr_value, attr_name);
413 #endif /* PATH_TRACKING */
417 Checks to see if thing is in the bitstring.
418 Returns true or false, and
419 notes thing in the segmented bitstring.
422 check_new(struct state *st, const void *const p) {
423 unsigned int bits = 8 * sizeof(void*);
424 const size_t raw_p = PTR2nat(p);
425 /* This effectively rotates the value right by the number of low always-0
426 bits in an aligned pointer. The assmption is that most (if not all)
427 pointers are aligned, and these will be in the same chain of nodes
428 (and hence hot in the cache) but we can still deal with any unaligned
430 const size_t cooked_p
431 = (raw_p >> ALIGN_BITS) | (raw_p << (bits - ALIGN_BITS));
432 const U8 this_bit = 1 << (cooked_p & 0x7);
436 void **tv_p = (void **) (st->tracking);
438 if (NULL == p) return FALSE;
440 const char c = *(const char *)p;
444 if (st->dangle_whine)
445 warn( "Devel::Size: Encountered invalid pointer: %p\n", p );
451 /* bits now 24 (32 bit pointers) or 56 (64 bit pointers) */
453 /* First level is always present. */
455 i = (unsigned int)((cooked_p >> bits) & 0xFF);
457 Newxz(tv_p[i], 256, void *);
458 tv_p = (void **)(tv_p[i]);
460 } while (bits > LEAF_BITS + BYTE_BITS);
461 /* bits now 16 always */
462 #if !defined(MULTIPLICITY) || PERL_VERSION > 8 || (PERL_VERSION == 8 && PERL_SUBVERSION > 8)
463 /* 5.8.8 and early have an assert() macro that uses Perl_croak, hence needs
464 a my_perl under multiplicity */
467 leaf_p = (U8 **)tv_p;
468 i = (unsigned int)((cooked_p >> bits) & 0xFF);
470 Newxz(leaf_p[i], 1 << LEAF_BITS, U8);
475 i = (unsigned int)((cooked_p >> BYTE_BITS) & LEAF_MASK);
477 if(leaf[i] & this_bit)
485 free_tracking_at(void **tv, int level)
493 free_tracking_at((void **) tv[i], level);
507 free_state(pTHX_ struct state *st)
509 const int top_level = (sizeof(void *) * 8 - LEAF_BITS - BYTE_BITS) / 8;
510 if (st->free_state_cb)
511 st->free_state_cb(aTHX_ st);
512 if (st->state_cb_data)
513 Safefree(st->state_cb_data);
514 free_tracking_at((void **)st->tracking, top_level);
518 /* For now, this is somewhat a compatibility bodge until the plan comes
519 together for fine grained recursion control. total_size() would recurse into
520 hash and array members, whereas sv_size() would not. However, sv_size() is
521 called with CvSTASH() of a CV, which means that if it (also) starts to
522 recurse fully, then the size of any CV now becomes the size of the entire
523 symbol table reachable from it, and potentially the entire symbol table, if
524 any subroutine makes a reference to a global (such as %SIG). The historical
525 implementation of total_size() didn't report "everything", and changing the
526 only available size to "everything" doesn't feel at all useful. */
528 #define NO_RECURSION 0
529 #define SOME_RECURSION 1
530 #define TOTAL_SIZE_RECURSION 2
532 static bool sv_size(pTHX_ struct state *, pPATH, const SV *const, const int recurse);
548 , OPc_CONDOP /* 12 */
557 cc_opclass(const OP * const o)
563 return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
565 if (o->op_type == OP_SASSIGN)
566 return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPc_UNOP : OPc_BINOP);
569 if (o->op_type == OP_GV || o->op_type == OP_GVSV || o->op_type == OP_AELEMFAST)
573 if ((o->op_type == OP_TRANS)) {
577 switch (PL_opargs[o->op_type] & OA_CLASS_MASK) {
609 #ifdef OA_PVOP_OR_SVOP
610 case OA_PVOP_OR_SVOP: TAG;
612 * Character translations (tr///) are usually a PVOP, keeping a
613 * pointer to a table of shorts used to look up translations.
614 * Under utf8, however, a simple table isn't practical; instead,
615 * the OP is an SVOP, and the SV is a reference to a swash
616 * (i.e., an RV pointing to an HV).
618 return (o->op_private & (OPpTRANS_TO_UTF|OPpTRANS_FROM_UTF))
619 ? OPc_SVOP : OPc_PVOP;
628 case OA_BASEOP_OR_UNOP: TAG;
630 * UNI(OP_foo) in toke.c returns token UNI or FUNC1 depending on
631 * whether parens were seen. perly.y uses OPf_SPECIAL to
632 * signal whether a BASEOP had empty parens or none.
633 * Some other UNOPs are created later, though, so the best
634 * test is OPf_KIDS, which is set in newUNOP.
636 return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
638 case OA_FILESTATOP: TAG;
640 * The file stat OPs are created via UNI(OP_foo) in toke.c but use
641 * the OPf_REF flag to distinguish between OP types instead of the
642 * usual OPf_SPECIAL flag. As usual, if OPf_KIDS is set, then we
643 * return OPc_UNOP so that walkoptree can find our children. If
644 * OPf_KIDS is not set then we check OPf_REF. Without OPf_REF set
645 * (no argument to the operator) it's an OP; with OPf_REF set it's
646 * an SVOP (and op_sv is the GV for the filehandle argument).
648 return ((o->op_flags & OPf_KIDS) ? OPc_UNOP :
650 (o->op_flags & OPf_REF) ? OPc_PADOP : OPc_BASEOP);
652 (o->op_flags & OPf_REF) ? OPc_SVOP : OPc_BASEOP);
654 case OA_LOOPEXOP: TAG;
656 * next, last, redo, dump and goto use OPf_SPECIAL to indicate that a
657 * label was omitted (in which case it's a BASEOP) or else a term was
658 * seen. In this last case, all except goto are definitely PVOP but
659 * goto is either a PVOP (with an ordinary constant label), an UNOP
660 * with OPf_STACKED (with a non-constant non-sub) or an UNOP for
661 * OP_REFGEN (with goto &sub) in which case OPf_STACKED also seems to
664 if (o->op_flags & OPf_STACKED)
666 else if (o->op_flags & OPf_SPECIAL)
676 warn("Devel::Size: Can't determine class of operator %s, assuming BASEOP\n",
677 PL_op_name[o->op_type]);
683 /* Figure out how much magic is attached to the SV and return the
686 magic_size(pTHX_ const SV * const thing, struct state *st, pPATH) {
687 dNPathNodes(1, NPathArg);
688 MAGIC *magic_pointer = SvMAGIC(thing); /* caller ensures thing is SvMAGICAL */
690 /* push a dummy node for NPathSetNode to update inside the while loop */
691 NPathPushNode("dummy", NPtype_NAME);
693 /* Have we seen the magic pointer? (NULL has always been seen before) */
694 while (check_new(st, magic_pointer)) {
696 NPathSetNode(magic_pointer, NPtype_MAGIC);
698 ADD_SIZE(st, "mg", sizeof(MAGIC));
699 /* magic vtables aren't freed when magic is freed, so don't count them.
700 (They are static structures. Anything that assumes otherwise is buggy.)
705 /* XXX only chase mg_obj if mg->mg_flags & MGf_REFCOUNTED ? */
706 sv_size(aTHX_ st, NPathLink("mg_obj"), magic_pointer->mg_obj, TOTAL_SIZE_RECURSION);
707 if (magic_pointer->mg_len == HEf_SVKEY) {
708 sv_size(aTHX_ st, NPathLink("mg_ptr"), (SV *)magic_pointer->mg_ptr, TOTAL_SIZE_RECURSION);
710 #if defined(PERL_MAGIC_utf8) && defined (PERL_MAGIC_UTF8_CACHESIZE)
711 else if (magic_pointer->mg_type == PERL_MAGIC_utf8) {
712 if (check_new(st, magic_pointer->mg_ptr)) {
713 ADD_SIZE(st, "PERL_MAGIC_utf8", PERL_MAGIC_UTF8_CACHESIZE * 2 * sizeof(STRLEN));
717 /* XXX also handle mg->mg_type == PERL_MAGIC_utf8 ? */
718 else if (magic_pointer->mg_len > 0) {
719 if(0)do_magic_dump(0, Perl_debug_log, magic_pointer, 0, 0, FALSE, 0);
720 if (check_new(st, magic_pointer->mg_ptr)) {
721 ADD_SIZE(st, "mg_len", magic_pointer->mg_len);
725 /* Get the next in the chain */
726 magic_pointer = magic_pointer->mg_moremagic;
729 if (st->dangle_whine)
730 warn( "Devel::Size: Encountered bad magic at: %p\n", magic_pointer );
735 #define check_new_and_strlen(st, p, ppath) S_check_new_and_strlen(aTHX_ st, p, ppath)
737 S_check_new_and_strlen(pTHX_ struct state *st, const char *const p, pPATH) {
738 dNPathNodes(1, NPathArg->prev);
739 if(check_new(st, p)) {
740 NPathPushNode(NPathArg->id, NPtype_NAME);
741 ADD_SIZE(st, NPathArg->id, 1 + strlen(p));
746 regex_size(pTHX_ const REGEXP * const baseregex, struct state *st, pPATH) {
747 dNPathNodes(1, NPathArg);
748 if(!check_new(st, baseregex))
750 NPathPushNode("regex_size", NPtype_NAME);
751 ADD_SIZE(st, "REGEXP", sizeof(REGEXP));
752 #if (PERL_VERSION < 11)
753 /* Note the size of the paren offset thing */
754 ADD_SIZE(st, "nparens", sizeof(I32) * baseregex->nparens * 2);
755 ADD_SIZE(st, "precomp", strlen(baseregex->precomp));
757 ADD_SIZE(st, "regexp", sizeof(struct regexp));
758 ADD_SIZE(st, "nparens", sizeof(I32) * SvANY(baseregex)->nparens * 2);
759 /*ADD_SIZE(st, strlen(SvANY(baseregex)->subbeg));*/
761 if (st->go_yell && !st->regex_whine) {
762 carp("Devel::Size: Calculated sizes for compiled regexes are incompatible, and probably always will be");
768 hek_size(pTHX_ struct state *st, HEK *hek, U32 shared, pPATH)
770 dNPathNodes(1, NPathArg);
772 /* Hash keys can be shared. Have we seen this before? */
773 if (!check_new(st, hek))
775 NPathPushNode("hek", NPtype_NAME);
776 ADD_SIZE(st, "hek_len", HEK_BASESIZE + hek->hek_len
778 + 1 /* No hash key flags prior to 5.8.0 */
784 #if PERL_VERSION < 10
785 ADD_SIZE(st, "he", sizeof(struct he));
787 ADD_SIZE(st, "shared_he", STRUCT_OFFSET(struct shared_he, shared_he_hek));
793 #if (PERL_BCDVERSION >= 0x5009004)
795 refcounted_he_size(pTHX_ struct state *st, struct refcounted_he *he, pPATH)
797 dNPathNodes(1, NPathArg);
798 if (!check_new(st, he))
800 NPathPushNode("refcounted_he_size", NPtype_NAME);
801 ADD_SIZE(st, "refcounted_he", sizeof(struct refcounted_he));
804 ADD_SIZE(st, "refcounted_he_data", NPtype_NAME);
806 hek_size(aTHX_ st, he->refcounted_he_hek, 0, NPathLink("refcounted_he_hek"));
809 if (he->refcounted_he_next)
810 refcounted_he_size(aTHX_ st, he->refcounted_he_next, NPathLink("refcounted_he_next"));
814 static void op_size_class(pTHX_ const OP * const baseop, opclass op_class, bool skip_op_struct, struct state *st, pPATH);
817 op_size(pTHX_ const OP * const baseop, struct state *st, pPATH)
819 op_size_class(aTHX_ baseop, cc_opclass(baseop), 0, st, NPathArg);
823 op_size_class(pTHX_ const OP * const baseop, opclass op_class, bool skip_op_struct, struct state *st, pPATH)
825 /* op_size recurses to follow the chain of opcodes. For the node path we
826 * don't want the chain to be 'nested' in the path so we use dNPathUseParent().
827 * Also, to avoid a link-to-a-link the caller should use NPathLinkAndNode()
828 * instead of NPathLink().
830 dNPathUseParent(NPathArg);
834 if(!check_new(st, baseop))
837 op_size(aTHX_ baseop->op_next, st, NPathOpLink);
839 madprop_size(aTHX_ st, NPathOpLink, baseop->op_madprop);
843 case OPc_BASEOP: TAG;
845 ADD_SIZE(st, "op", sizeof(struct op));
849 ADD_SIZE(st, "unop", sizeof(struct unop));
850 op_size(aTHX_ ((UNOP *)baseop)->op_first, st, NPathOpLink);
854 ADD_SIZE(st, "binop", sizeof(struct binop));
855 op_size(aTHX_ ((BINOP *)baseop)->op_first, st, NPathOpLink);
856 op_size(aTHX_ ((BINOP *)baseop)->op_last, st, NPathOpLink);
860 ADD_SIZE(st, "logop", sizeof(struct logop));
861 op_size(aTHX_ ((BINOP *)baseop)->op_first, st, NPathOpLink);
862 op_size(aTHX_ ((LOGOP *)baseop)->op_other, st, NPathOpLink);
865 case OPc_CONDOP: TAG;
867 ADD_SIZE(st, "condop", sizeof(struct condop));
868 op_size(aTHX_ ((BINOP *)baseop)->op_first, st, NPathOpLink);
869 op_size(aTHX_ ((CONDOP *)baseop)->op_true, st, NPathOpLink);
870 op_size(aTHX_ ((CONDOP *)baseop)->op_false, st, NPathOpLink);
873 case OPc_LISTOP: TAG;
875 ADD_SIZE(st, "listop", sizeof(struct listop));
876 op_size(aTHX_ ((LISTOP *)baseop)->op_first, st, NPathOpLink);
877 op_size(aTHX_ ((LISTOP *)baseop)->op_last, st, NPathOpLink);
881 ADD_SIZE(st, "pmop", sizeof(struct pmop));
882 op_size(aTHX_ ((PMOP *)baseop)->op_first, st, NPathOpLink);
883 op_size(aTHX_ ((PMOP *)baseop)->op_last, st, NPathOpLink);
884 #if PERL_VERSION < 9 || (PERL_VERSION == 9 && PERL_SUBVERSION < 5)
885 op_size(aTHX_ ((PMOP *)baseop)->op_pmreplroot, st, NPathOpLink);
886 op_size(aTHX_ ((PMOP *)baseop)->op_pmreplstart, st, NPathOpLink);
888 /* This is defined away in perl 5.8.x, but it is in there for
891 regex_size(aTHX_ PM_GETRE((PMOP *)baseop), st, NPathLink("PM_GETRE"));
893 regex_size(aTHX_ ((PMOP *)baseop)->op_pmregexp, st, NPathLink("op_pmregexp"));
898 ADD_SIZE(st, "svop", sizeof(struct svop));
899 if (!(baseop->op_type == OP_AELEMFAST
900 && baseop->op_flags & OPf_SPECIAL)) {
901 /* not an OP_PADAV replacement */
902 sv_size(aTHX_ st, NPathLink("SVOP"), ((SVOP *)baseop)->op_sv, SOME_RECURSION);
908 ADD_SIZE(st, "padop", sizeof(struct padop));
914 ADD_SIZE(st, "gvop", sizeof(struct gvop));
915 sv_size(aTHX_ st, NPathLink("GVOP"), ((GVOP *)baseop)->op_gv, SOME_RECURSION);
919 check_new_and_strlen(st, ((PVOP *)baseop)->op_pv, NPathLink("op_pv"));
923 ADD_SIZE(st, "loop", sizeof(struct loop));
924 op_size(aTHX_ ((LOOP *)baseop)->op_first, st, NPathOpLink);
925 op_size(aTHX_ ((LOOP *)baseop)->op_last, st, NPathOpLink);
926 op_size(aTHX_ ((LOOP *)baseop)->op_redoop, st, NPathOpLink);
927 op_size(aTHX_ ((LOOP *)baseop)->op_nextop, st, NPathOpLink);
928 op_size(aTHX_ ((LOOP *)baseop)->op_lastop, st, NPathOpLink);
933 basecop = (COP *)baseop;
935 ADD_SIZE(st, "cop", sizeof(struct cop));
937 /* Change 33656 by nicholas@mouse-mill on 2008/04/07 11:29:51
938 Eliminate cop_label from struct cop by storing a label as the first
939 entry in the hints hash. Most statements don't have labels, so this
940 will save memory. Not sure how much.
941 The check below will be incorrect fail on bleadperls
942 before 5.11 @33656, but later than 5.10, producing slightly too
943 small memory sizes on these Perls. */
944 #if (PERL_VERSION < 11)
945 check_new_and_strlen(st, basecop->cop_label, NPathLink("cop_label"));
948 check_new_and_strlen(st, basecop->cop_file, NPathLink("cop_file"));
949 /*check_new_and_strlen(st, basecop->cop_stashpv, NPathLink("cop_stashpv")); XXX */
951 if (SvREFCNT(basecop->cop_stash) == 1) /* XXX hack? */
952 sv_size(aTHX_ st, NPathLink("cop_stash"), (SV *)basecop->cop_stash, SOME_RECURSION);
953 sv_size(aTHX_ st, NPathLink("cop_filegv"), (SV *)basecop->cop_filegv, SOME_RECURSION);
955 #if (PERL_BCDVERSION >= 0x5009004)
956 refcounted_he_size(aTHX_ st, CopHINTHASH_get(basecop), NPathLink("cop_hints_hash"));
965 if (st->dangle_whine)
966 warn( "Devel::Size: Encountered dangling pointer in opcode at: %p\n", baseop );
970 #if PERL_VERSION < 8 || PERL_SUBVERSION < 9 /* XXX plain || seems like a bug */
975 # define MAYBE_PURIFY(normal, pure) (pure)
976 # define MAYBE_OFFSET(struct_name, member) 0
978 # define MAYBE_PURIFY(normal, pure) (normal)
979 # define MAYBE_OFFSET(struct_name, member) STRUCT_OFFSET(struct_name, member)
982 const U8 body_sizes[SVt_LAST] = {
985 MAYBE_PURIFY(sizeof(IV), sizeof(XPVIV)), /* SVt_IV */
986 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
987 sizeof(XRV), /* SVt_RV */
988 sizeof(XPV), /* SVt_PV */
989 sizeof(XPVIV), /* SVt_PVIV */
990 sizeof(XPVNV), /* SVt_PVNV */
991 sizeof(XPVMG), /* SVt_PVMG */
992 sizeof(XPVBM), /* SVt_PVBM */
993 sizeof(XPVLV), /* SVt_PVLV */
994 sizeof(XPVAV), /* SVt_PVAV */
995 sizeof(XPVHV), /* SVt_PVHV */
996 sizeof(XPVCV), /* SVt_PVCV */
997 sizeof(XPVGV), /* SVt_PVGV */
998 sizeof(XPVFM), /* SVt_PVFM */
999 sizeof(XPVIO) /* SVt_PVIO */
1000 #elif PERL_VERSION == 10 && PERL_SUBVERSION == 0
1004 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
1006 MAYBE_PURIFY(sizeof(xpv_allocated), sizeof(XPV)), /* SVt_PV */
1007 MAYBE_PURIFY(sizeof(xpviv_allocated), sizeof(XPVIV)),/* SVt_PVIV */
1008 sizeof(XPVNV), /* SVt_PVNV */
1009 sizeof(XPVMG), /* SVt_PVMG */
1010 sizeof(XPVGV), /* SVt_PVGV */
1011 sizeof(XPVLV), /* SVt_PVLV */
1012 MAYBE_PURIFY(sizeof(xpvav_allocated), sizeof(XPVAV)),/* SVt_PVAV */
1013 MAYBE_PURIFY(sizeof(xpvhv_allocated), sizeof(XPVHV)),/* SVt_PVHV */
1014 MAYBE_PURIFY(sizeof(xpvcv_allocated), sizeof(XPVCV)),/* SVt_PVCV */
1015 MAYBE_PURIFY(sizeof(xpvfm_allocated), sizeof(XPVFM)),/* SVt_PVFM */
1016 sizeof(XPVIO), /* SVt_PVIO */
1017 #elif PERL_VERSION == 10 && PERL_SUBVERSION == 1
1021 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
1023 sizeof(XPV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PV */
1024 sizeof(XPVIV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PVIV */
1025 sizeof(XPVNV), /* SVt_PVNV */
1026 sizeof(XPVMG), /* SVt_PVMG */
1027 sizeof(XPVGV), /* SVt_PVGV */
1028 sizeof(XPVLV), /* SVt_PVLV */
1029 sizeof(XPVAV) - MAYBE_OFFSET(XPVAV, xav_fill), /* SVt_PVAV */
1030 sizeof(XPVHV) - MAYBE_OFFSET(XPVHV, xhv_fill), /* SVt_PVHV */
1031 sizeof(XPVCV) - MAYBE_OFFSET(XPVCV, xpv_cur), /* SVt_PVCV */
1032 sizeof(XPVFM) - MAYBE_OFFSET(XPVFM, xpv_cur), /* SVt_PVFM */
1033 sizeof(XPVIO) /* SVt_PVIO */
1034 #elif PERL_VERSION < 13
1038 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
1039 sizeof(XPV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PV */
1040 sizeof(XPVIV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PVIV */
1041 sizeof(XPVNV), /* SVt_PVNV */
1042 sizeof(XPVMG), /* SVt_PVMG */
1043 sizeof(regexp) - MAYBE_OFFSET(regexp, xpv_cur), /* SVt_REGEXP */
1044 sizeof(XPVGV), /* SVt_PVGV */
1045 sizeof(XPVLV), /* SVt_PVLV */
1046 sizeof(XPVAV) - MAYBE_OFFSET(XPVAV, xav_fill), /* SVt_PVAV */
1047 sizeof(XPVHV) - MAYBE_OFFSET(XPVHV, xhv_fill), /* SVt_PVHV */
1048 sizeof(XPVCV) - MAYBE_OFFSET(XPVCV, xpv_cur), /* SVt_PVCV */
1049 sizeof(XPVFM) - MAYBE_OFFSET(XPVFM, xpv_cur), /* SVt_PVFM */
1050 sizeof(XPVIO) /* SVt_PVIO */
1055 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
1056 sizeof(XPV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PV */
1057 sizeof(XPVIV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PVIV */
1058 sizeof(XPVNV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PVNV */
1059 sizeof(XPVMG), /* SVt_PVMG */
1060 sizeof(regexp), /* SVt_REGEXP */
1061 sizeof(XPVGV), /* SVt_PVGV */
1062 sizeof(XPVLV), /* SVt_PVLV */
1063 sizeof(XPVAV), /* SVt_PVAV */
1064 sizeof(XPVHV), /* SVt_PVHV */
1065 sizeof(XPVCV), /* SVt_PVCV */
1066 sizeof(XPVFM), /* SVt_PVFM */
1067 sizeof(XPVIO) /* SVt_PVIO */
1072 /* based on Perl_do_dump_pad() - wraps sv_size and adds ADD_ATTR calls for the pad names */
1074 padlist_size(pTHX_ struct state *const st, pPATH, PADLIST *padlist,
1077 dNPathUseParent(NPathArg);
1084 if( 0 && !check_new(st, padlist))
1087 pad_name = MUTABLE_AV(*av_fetch(MUTABLE_AV(padlist), 0, FALSE));
1088 pname = AvARRAY(pad_name);
1090 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
1091 const SV *namesv = pname[ix];
1092 if (namesv && namesv == &PL_sv_undef) {
1096 /* SvFAKE: On a pad name SV, that slot in the frame AV is a REFCNT'ed reference to a lexical from "outside" */
1098 ADD_ATTR(st, NPattr_PADFAKE, SvPVX_const(namesv), ix);
1100 ADD_ATTR(st, NPattr_PADNAME, SvPVX_const(namesv), ix);
1103 ADD_ATTR(st, NPattr_PADTMP, "SVs_PADTMP", ix);
1107 sv_size(aTHX_ st, NPathArg, (SV*)padlist, recurse);
1112 sv_size(pTHX_ struct state *const st, pPATH, const SV * const orig_thing,
1113 const int recurse) {
1114 const SV *thing = orig_thing;
1115 dNPathNodes(3, NPathArg);
1118 if(!check_new(st, orig_thing))
1121 type = SvTYPE(thing);
1122 if (type > SVt_LAST) {
1123 warn("Devel::Size: Unknown variable type: %d encountered\n", type);
1126 NPathPushNode(thing, NPtype_SV);
1127 ADD_SIZE(st, "sv_head", sizeof(SV));
1128 ADD_SIZE(st, "sv_body", body_sizes[type]);
1131 #if (PERL_VERSION < 11)
1132 /* Is it a reference? */
1137 if(recurse && SvROK(thing)) /* XXX maybe don't follow weakrefs */
1138 sv_size(aTHX_ st, (SvWEAKREF(thing) ? NPathLink("weakRV") : NPathLink("RV")), SvRV_const(thing), recurse);
1142 /* Is there anything in the array? */
1143 if (AvMAX(thing) != -1) {
1144 /* an array with 10 slots has AvMax() set to 9 - te 2007-04-22 */
1145 ADD_SIZE(st, "av_max", sizeof(SV *) * (AvMAX(thing) + 1));
1146 ADD_ATTR(st, NPattr_NOTE, "av_len", av_len((AV*)thing));
1147 dbg_printf(("total_size: %li AvMAX: %li av_len: $i\n", st->total_size, AvMAX(thing), av_len((AV*)thing)));
1149 if (recurse >= st->min_recurse_threshold) {
1150 SSize_t i = AvFILLp(thing) + 1;
1153 if (sv_size(aTHX_ st, NPathLink("AVelem"), AvARRAY(thing)[i], recurse))
1154 ADD_LINK_ATTR(st, NPattr_NOTE, "i", i);
1158 /* Add in the bits on the other side of the beginning */
1160 dbg_printf(("total_size %li, sizeof(SV *) %li, AvARRAY(thing) %li, AvALLOC(thing)%li , sizeof(ptr) %li \n",
1161 st->total_size, sizeof(SV*), AvARRAY(thing), AvALLOC(thing), sizeof( thing )));
1163 /* under Perl 5.8.8 64bit threading, AvARRAY(thing) was a pointer while AvALLOC was 0,
1164 resulting in grossly overstated sized for arrays. Technically, this shouldn't happen... */
1165 if (AvALLOC(thing) != 0) {
1166 ADD_SIZE(st, "AvALLOC", (sizeof(SV *) * (AvARRAY(thing) - AvALLOC(thing))));
1168 #if (PERL_VERSION < 9)
1169 /* Is there something hanging off the arylen element?
1170 Post 5.9.something this is stored in magic, so will be found there,
1171 and Perl_av_arylen_p() takes a non-const AV*, hence compilers rightly
1172 complain about AvARYLEN() passing thing to it. */
1173 sv_size(aTHX_ st, NPathLink("ARYLEN"), AvARYLEN(thing), recurse);
1178 /* Now the array of buckets */
1180 if (HvENAME(thing)) { ADD_ATTR(st, NPattr_NAME, HvENAME(thing), 0); }
1182 if (HvNAME(thing)) { ADD_ATTR(st, NPattr_NAME, HvNAME(thing), 0); }
1184 ADD_SIZE(st, "hv_max", (sizeof(HE *) * (HvMAX(thing) + 1)));
1185 /* Now walk the bucket chain */
1186 if (HvARRAY(thing)) {
1190 for (cur_bucket = 0; cur_bucket <= HvMAX(thing); cur_bucket++) {
1191 cur_entry = *(HvARRAY(thing) + cur_bucket);
1193 NPathPushNode("he", NPtype_LINK);
1194 NPathPushNode("he+hek", NPtype_NAME);
1195 ADD_SIZE(st, "he", sizeof(HE));
1196 hek_size(aTHX_ st, cur_entry->hent_hek, HvSHAREKEYS(thing), NPathLink("hent_hek"));
1197 if (recurse >= st->min_recurse_threshold) {
1198 if (orig_thing == (SV*)PL_strtab) {
1199 /* For PL_strtab the HeVAL is used as a refcnt */
1200 ADD_SIZE(st, "shared_hek", HeKLEN(cur_entry));
1203 /* I've seen a PL_strtab HeVAL == 0xC and 0x40C etc
1204 * just running perl -Mblib -Mstrict -MDevel::Size=:all -MCarp -e 'warn perl_size()'
1205 * but it seemed like a corruption - it would change come and go with irrelevant code changes.
1206 * so we protect against that here, but I'd like to know the cause.
1208 if (PTR2UV(HeVAL(cur_entry)) > 0xFFF)
1209 sv_size(aTHX_ st, NPathLink("HeVAL"), HeVAL(cur_entry), recurse);
1210 else warn("skipped suspect HeVAL %p", HeVAL(cur_entry));
1213 cur_entry = cur_entry->hent_next;
1217 } /* bucket chain */
1222 /* This direct access is arguably "naughty": */
1223 struct mro_meta *meta = HvAUX(thing)->xhv_mro_meta;
1224 #if PERL_VERSION > 13 || PERL_SUBVERSION > 8 /* XXX plain || seems like a bug */
1226 I32 count = HvAUX(thing)->xhv_name_count;
1229 HEK **names = HvAUX(thing)->xhv_name_u.xhvnameu_names;
1233 hek_size(aTHX_ st, names[count], 1, NPathLink("HvAUXelem"));
1238 hek_size(aTHX_ st, HvNAME_HEK(thing), 1, NPathLink("HvNAME_HEK"));
1241 ADD_SIZE(st, "xpvhv_aux", sizeof(struct xpvhv_aux));
1243 ADD_SIZE(st, "mro_meta", sizeof(struct mro_meta));
1244 sv_size(aTHX_ st, NPathLink("mro_nextmethod"), (SV *)meta->mro_nextmethod, TOTAL_SIZE_RECURSION);
1245 #if PERL_VERSION > 10 || (PERL_VERSION == 10 && PERL_SUBVERSION > 0)
1246 sv_size(aTHX_ st, NPathLink("isa"), (SV *)meta->isa, TOTAL_SIZE_RECURSION);
1248 #if PERL_VERSION > 10
1249 sv_size(aTHX_ st, NPathLink("mro_linear_all"), (SV *)meta->mro_linear_all, TOTAL_SIZE_RECURSION);
1250 sv_size(aTHX_ st, NPathLink("mro_linear_current"), meta->mro_linear_current, TOTAL_SIZE_RECURSION);
1252 sv_size(aTHX_ st, NPathLink("mro_linear_dfs"), (SV *)meta->mro_linear_dfs, TOTAL_SIZE_RECURSION);
1253 sv_size(aTHX_ st, NPathLink("mro_linear_c3"), (SV *)meta->mro_linear_c3, TOTAL_SIZE_RECURSION);
1258 check_new_and_strlen(st, HvNAME_get(thing), NPathLink("HvNAME"));
1264 padlist_size(aTHX_ st, NPathLink("CvPADLIST"), CvPADLIST(thing), recurse);
1265 sv_size(aTHX_ st, NPathLink("CvOUTSIDE"), (SV *)CvOUTSIDE(thing), SOME_RECURSION);
1267 if (st->go_yell && !st->fm_whine) {
1268 carp("Devel::Size: Calculated sizes for FMs are incomplete");
1274 /* not CvSTASH, per https://rt.cpan.org/Ticket/Display.html?id=79366 */
1275 ADD_ATTR(st, NPattr_NAME, CvGV(thing) ? GvNAME(CvGV(thing)) : "UNDEFINED", 0);
1276 sv_size(aTHX_ st, NPathLink("CvGV"), (SV *)CvGV(thing), SOME_RECURSION);
1277 padlist_size(aTHX_ st, NPathLink("CvPADLIST"), CvPADLIST(thing), recurse);
1278 sv_size(aTHX_ st, NPathLink("CvOUTSIDE"), (SV *)CvOUTSIDE(thing), SOME_RECURSION);
1279 if (CvISXSUB(thing)) {
1280 sv_size(aTHX_ st, NPathLink("cv_const_sv"), cv_const_sv((CV *)thing), recurse);
1282 if(1)op_size(aTHX_ CvSTART(thing), st, NPathLinkAndNode("CvSTART", "OPs")); /* XXX ? */
1283 op_size(aTHX_ CvROOT(thing), st, NPathLinkAndNode("CvROOT", "OPs"));
1288 /* Some embedded char pointers */
1289 check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_top_name, NPathLink("xio_top_name"));
1290 check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_fmt_name, NPathLink("xio_fmt_name"));
1291 check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_bottom_name, NPathLink("xio_bottom_name"));
1292 /* Throw the GVs on the list to be walked if they're not-null */
1293 sv_size(aTHX_ st, NPathLink("xio_top_gv"), (SV *)((XPVIO *) SvANY(thing))->xio_top_gv, recurse);
1294 sv_size(aTHX_ st, NPathLink("xio_bottom_gv"), (SV *)((XPVIO *) SvANY(thing))->xio_bottom_gv, recurse);
1295 sv_size(aTHX_ st, NPathLink("xio_fmt_gv"), (SV *)((XPVIO *) SvANY(thing))->xio_fmt_gv, recurse);
1297 /* Only go trotting through the IO structures if they're really
1298 trottable. If USE_PERLIO is defined we can do this. If
1299 not... we can't, so we don't even try */
1301 /* Dig into xio_ifp and xio_ofp here */
1302 warn("Devel::Size: Can't size up perlio layers yet\n");
1307 #if (PERL_VERSION < 9)
1312 if(isGV_with_GP(thing)) {
1314 hek_size(aTHX_ st, GvNAME_HEK(thing), 1, NPathLink("GvNAME_HEK"));
1316 ADD_SIZE(st, "GvNAMELEN", GvNAMELEN(thing));
1318 ADD_ATTR(st, NPattr_NAME, GvNAME_get(thing), 0);
1320 hek_size(aTHX_ st, GvFILE_HEK(thing), 1, NPathLink("GvFILE_HEK"));
1321 #elif defined(GvFILE)
1322 # if !defined(USE_ITHREADS) || (PERL_VERSION > 8 || (PERL_VERSION == 8 && PERL_SUBVERSION > 8))
1323 /* With itreads, before 5.8.9, this can end up pointing to freed memory
1324 if the GV was created in an eval, as GvFILE() points to CopFILE(),
1325 and the relevant COP has been freed on scope cleanup after the eval.
1326 5.8.9 adds a binary compatible fudge that catches the vast majority
1327 of cases. 5.9.something added a proper fix, by converting the GP to
1328 use a shared hash key (porperly reference counted), instead of a
1329 char * (owned by who knows? possibly no-one now) */
1330 check_new_and_strlen(st, GvFILE(thing), NPathLink("GvFILE"));
1333 /* Is there something hanging off the glob? */
1334 if (check_new(st, GvGP(thing))) {
1335 ADD_SIZE(st, "GP", sizeof(GP));
1336 sv_size(aTHX_ st, NPathLink("gp_sv"), (SV *)(GvGP(thing)->gp_sv), recurse);
1337 sv_size(aTHX_ st, NPathLink("gp_av"), (SV *)(GvGP(thing)->gp_av), recurse);
1338 sv_size(aTHX_ st, NPathLink("gp_hv"), (SV *)(GvGP(thing)->gp_hv), recurse);
1339 sv_size(aTHX_ st, NPathLink("gp_cv"), (SV *)(GvGP(thing)->gp_cv), recurse);
1340 sv_size(aTHX_ st, NPathLink("gp_egv"), (SV *)(GvGP(thing)->gp_egv), recurse);
1341 sv_size(aTHX_ st, NPathLink("gp_form"), (SV *)(GvGP(thing)->gp_form), recurse);
1343 #if (PERL_VERSION >= 9)
1347 #if PERL_VERSION <= 8
1355 if(recurse && SvROK(thing))
1356 sv_size(aTHX_ st, NPathLink("RV"), SvRV_const(thing), recurse);
1357 else if (SvIsCOW_shared_hash(thing))
1358 hek_size(aTHX_ st, SvSHARED_HEK_FROM_PV(SvPVX(thing)), 1, NPathLink("SvSHARED_HEK_FROM_PV"));
1360 ADD_SIZE(st, "SvLEN", SvLEN(thing));
1364 SvOOK_offset(thing, len);
1365 ADD_SIZE(st, "SvOOK", len);
1371 if (type >= SVt_PVMG) {
1372 if (SvMAGICAL(thing))
1373 magic_size(aTHX_ thing, st, NPathLink("MG"));
1374 /* SVpad_OUR shares same flag bit as SVpbm_VALID and others */
1375 if (type == SVt_PVGV && SvPAD_OUR(thing) && SvOURSTASH(thing))
1376 sv_size(aTHX_ st, NPathLink("SvOURSTASH"), (SV *)SvOURSTASH(thing), SOME_RECURSION);
1378 sv_size(aTHX_ st, NPathLink("SvSTASH"), (SV *)SvSTASH(thing), SOME_RECURSION);
1385 free_memnode_state(pTHX_ struct state *st)
1387 /* PERL_UNUSED_ARG(aTHX); fails for non-threaded perl */
1388 if (st->node_stream_fh && st->node_stream_name && *st->node_stream_name) {
1389 fprintf(st->node_stream_fh, "E %d %f %s\n",
1390 getpid(), gettimeofday_nv()-st->start_time_nv, "unnamed");
1391 if (*st->node_stream_name == '|') {
1392 if (pclose(st->node_stream_fh))
1393 warn("%s exited with an error status\n", st->node_stream_name);
1396 if (fclose(st->node_stream_fh))
1397 warn("Error closing %s: %s\n", st->node_stream_name, strerror(errno));
1402 static struct state *
1408 Newxz(st, 1, struct state);
1410 st->min_recurse_threshold = TOTAL_SIZE_RECURSION;
1411 if (NULL != (warn_flag = get_sv("Devel::Size::warn", FALSE))) {
1412 st->dangle_whine = st->go_yell = SvIV(warn_flag) ? TRUE : FALSE;
1414 if (NULL != (warn_flag = get_sv("Devel::Size::dangle", FALSE))) {
1415 st->dangle_whine = SvIV(warn_flag) ? TRUE : FALSE;
1417 st->start_time_nv = gettimeofday_nv();
1418 check_new(st, &PL_sv_undef);
1419 check_new(st, &PL_sv_no);
1420 check_new(st, &PL_sv_yes);
1421 #if PERL_VERSION > 8 || (PERL_VERSION == 8 && PERL_SUBVERSION > 0)
1422 check_new(st, &PL_sv_placeholder);
1425 #ifdef PATH_TRACKING
1426 /* XXX quick hack */
1427 st->node_stream_name = getenv("SIZEME");
1428 if (st->node_stream_name) {
1429 if (*st->node_stream_name) {
1430 if (*st->node_stream_name == '|')
1431 st->node_stream_fh = popen(st->node_stream_name+1, "w");
1433 st->node_stream_fh = fopen(st->node_stream_name, "wb");
1434 if (!st->node_stream_fh)
1435 croak("Can't open '%s' for writing: %s", st->node_stream_name, strerror(errno));
1436 if(0)setlinebuf(st->node_stream_fh); /* XXX temporary for debugging */
1437 st->add_attr_cb = np_stream_node_path_info;
1438 fprintf(st->node_stream_fh, "S %d %f %s\n",
1439 getpid(), st->start_time_nv, "unnamed");
1442 st->add_attr_cb = np_dump_node_path_info;
1444 st->free_state_cb = free_memnode_state;
1450 /* XXX based on S_visit() in sv.c */
1452 unseen_sv_size(pTHX_ struct state *st, pPATH)
1456 dNPathNodes(1, NPathArg);
1458 NPathPushNode("unseen", NPtype_NAME);
1460 /* by this point we should have visited all the SVs
1461 * so now we'll run through all the SVs via the arenas
1462 * in order to find any that we've missed for some reason.
1463 * Once the rest of the code is finding ALL the SVs then any
1464 * found here will be leaks.
1466 for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) {
1467 const SV * const svend = &sva[SvREFCNT(sva)];
1469 for (sv = sva + 1; sv < svend; ++sv) {
1470 if (SvTYPE(sv) != (svtype)SVTYPEMASK && SvREFCNT(sv)) {
1471 sv_size(aTHX_ st, NPathLink("arena"), sv, TOTAL_SIZE_RECURSION);
1473 else if (check_new(st, sv)) { /* sanity check */
1475 warn("unseen_sv_size encountered freed SV unexpectedly"); /* XXX warn uses an SV, I think */
1483 madprop_size(pTHX_ struct state *const st, pPath, MADPROP *prop)
1485 dPathNodes(2, NPathArg);
1486 if (!check_new(st, prop))
1488 NPathPushNode("madprop_size", NPtype_NAME);
1489 ADD_SIZE(st, "MADPROP", sizeof(MADPROP));
1491 NPathPushNode("val");
1492 ADD_SIZE(st, "val", prop->mad_val);
1494 madprop_size(aTHX_ st, NPathLink("mad_next"), prop->mad_next);
1498 #if (PERL_BCDVERSION >= 0x5009005)
1500 parser_size(pTHX_ struct state *const st, pPATH, yy_parser *parser)
1502 dNPathNodes(2, NPathArg);
1503 if (!check_new(st, parser))
1505 NPathPushNode("parser_size", NPtype_NAME);
1506 ADD_SIZE(st, "yy_parser", sizeof(yy_parser));
1508 NPathPushNode("stack", NPtype_NAME);
1510 /*warn("total: %u", parser->stack_size); */
1511 /*warn("foo: %u", parser->ps - parser->stack); */
1512 ADD_SIZE(st, "stack_frames", parser->stack_size * sizeof(yy_stack_frame));
1513 for (ps = parser->stack; ps <= parser->ps; ps++) {
1514 #if (PERL_BCDVERSION >= 0x5011001) /* roughly */
1515 if (sv_size(aTHX_ st, NPathLink("compcv"), (SV*)ps->compcv, TOTAL_SIZE_RECURSION))
1516 ADD_LINK_ATTR(st, NPattr_NOTE, "i", ps - parser->ps);
1517 #else /* prior to perl 8c63ea58 Dec 8 2009 */
1518 if (sv_size(aTHX_ st, NPathLink("comppad"), (SV*)ps->comppad, TOTAL_SIZE_RECURSION))
1519 ADD_LINK_ATTR(st, NPattr_NOTE, "i", ps - parser->ps);
1524 sv_size(aTHX_ st, NPathLink("lex_repl"), (SV*)parser->lex_repl, TOTAL_SIZE_RECURSION);
1525 sv_size(aTHX_ st, NPathLink("lex_stuff"), (SV*)parser->lex_stuff, TOTAL_SIZE_RECURSION);
1526 sv_size(aTHX_ st, NPathLink("linestr"), (SV*)parser->linestr, TOTAL_SIZE_RECURSION);
1527 sv_size(aTHX_ st, NPathLink("in_my_stash"), (SV*)parser->in_my_stash, TOTAL_SIZE_RECURSION);
1528 /*sv_size(aTHX_ st, NPathLink("rsfp"), parser->rsfp, TOTAL_SIZE_RECURSION); */
1529 sv_size(aTHX_ st, NPathLink("rsfp_filters"), (SV*)parser->rsfp_filters, TOTAL_SIZE_RECURSION);
1531 sv_size(aTHX_ st, NPathLink("endwhite"), parser->endwhite, TOTAL_SIZE_RECURSION);
1532 sv_size(aTHX_ st, NPathLink("nextwhite"), parser->nextwhite, TOTAL_SIZE_RECURSION);
1533 sv_size(aTHX_ st, NPathLink("skipwhite"), parser->skipwhite, TOTAL_SIZE_RECURSION);
1534 sv_size(aTHX_ st, NPathLink("thisclose"), parser->thisclose, TOTAL_SIZE_RECURSION);
1535 madprop_size(aTHX_ st, NPathLink("thismad"), parser->thismad);
1536 sv_size(aTHX_ st, NPathLink("thisopen"), parser->thisopen, TOTAL_SIZE_RECURSION);
1537 sv_size(aTHX_ st, NPathLink("thisstuff"), parser->thisstuff, TOTAL_SIZE_RECURSION);
1538 sv_size(aTHX_ st, NPathLink("thistoken"), parser->thistoken, TOTAL_SIZE_RECURSION);
1539 sv_size(aTHX_ st, NPathLink("thiswhite"), parser->thiswhite, TOTAL_SIZE_RECURSION);
1541 op_size_class(aTHX_ (OP*)parser->saved_curcop, OPc_COP, 0,
1542 st, NPathLink("saved_curcop"));
1544 if (parser->old_parser)
1545 parser_size(aTHX_ st, NPathLink("old_parser"), parser->old_parser);
1550 perl_size(pTHX_ struct state *const st, pPATH)
1552 dNPathNodes(3, NPathArg);
1554 /* if(!check_new(st, interp)) return; */
1555 NPathPushNode("perl", NPtype_NAME);
1556 #if defined(MULTIPLICITY)
1557 ADD_SIZE(st, "PerlInterpreter", sizeof(PerlInterpreter));
1563 * unknown <== = O/S Heap size - perl - free_malloc_space
1565 /* start with PL_defstash to get everything reachable from \%main:: */
1566 sv_size(aTHX_ st, NPathLink("PL_defstash"), (SV*)PL_defstash, TOTAL_SIZE_RECURSION);
1568 NPathPushNode("others", NPtype_NAME); /* group these (typically much smaller) items */
1569 sv_size(aTHX_ st, NPathLink("PL_defgv"), (SV*)PL_defgv, TOTAL_SIZE_RECURSION);
1570 sv_size(aTHX_ st, NPathLink("PL_incgv"), (SV*)PL_incgv, TOTAL_SIZE_RECURSION);
1571 sv_size(aTHX_ st, NPathLink("PL_rs"), (SV*)PL_rs, TOTAL_SIZE_RECURSION);
1572 sv_size(aTHX_ st, NPathLink("PL_fdpid"), (SV*)PL_fdpid, TOTAL_SIZE_RECURSION);
1573 sv_size(aTHX_ st, NPathLink("PL_modglobal"), (SV*)PL_modglobal, TOTAL_SIZE_RECURSION);
1574 sv_size(aTHX_ st, NPathLink("PL_errors"), (SV*)PL_errors, TOTAL_SIZE_RECURSION);
1575 sv_size(aTHX_ st, NPathLink("PL_stashcache"), (SV*)PL_stashcache, TOTAL_SIZE_RECURSION);
1576 sv_size(aTHX_ st, NPathLink("PL_patchlevel"), (SV*)PL_patchlevel, TOTAL_SIZE_RECURSION);
1577 #ifdef PL_apiversion
1578 sv_size(aTHX_ st, NPathLink("PL_apiversion"), (SV*)PL_apiversion, TOTAL_SIZE_RECURSION);
1580 #ifdef PL_registered_mros
1581 sv_size(aTHX_ st, NPathLink("PL_registered_mros"), (SV*)PL_registered_mros, TOTAL_SIZE_RECURSION);
1584 sv_size(aTHX_ st, NPathLink("PL_regex_padav"), (SV*)PL_regex_padav, TOTAL_SIZE_RECURSION);
1586 sv_size(aTHX_ st, NPathLink("PL_warnhook"), (SV*)PL_warnhook, TOTAL_SIZE_RECURSION);
1587 sv_size(aTHX_ st, NPathLink("PL_diehook"), (SV*)PL_diehook, TOTAL_SIZE_RECURSION);
1588 sv_size(aTHX_ st, NPathLink("PL_endav"), (SV*)PL_endav, TOTAL_SIZE_RECURSION);
1589 sv_size(aTHX_ st, NPathLink("PL_main_cv"), (SV*)PL_main_cv, TOTAL_SIZE_RECURSION);
1590 sv_size(aTHX_ st, NPathLink("PL_main_root"), (SV*)PL_main_root, TOTAL_SIZE_RECURSION);
1591 sv_size(aTHX_ st, NPathLink("PL_main_start"), (SV*)PL_main_start, TOTAL_SIZE_RECURSION);
1592 sv_size(aTHX_ st, NPathLink("PL_envgv"), (SV*)PL_envgv, TOTAL_SIZE_RECURSION);
1593 sv_size(aTHX_ st, NPathLink("PL_hintgv"), (SV*)PL_hintgv, TOTAL_SIZE_RECURSION);
1594 sv_size(aTHX_ st, NPathLink("PL_e_script"), (SV*)PL_e_script, TOTAL_SIZE_RECURSION);
1595 sv_size(aTHX_ st, NPathLink("PL_encoding"), (SV*)PL_encoding, TOTAL_SIZE_RECURSION);
1597 sv_size(aTHX_ st, NPathLink("PL_ofsgv"), (SV*)PL_ofsgv, TOTAL_SIZE_RECURSION);
1599 sv_size(aTHX_ st, NPathLink("PL_argvout_stack"), (SV*)PL_argvout_stack, TOTAL_SIZE_RECURSION);
1600 sv_size(aTHX_ st, NPathLink("PL_beginav"), (SV*)PL_beginav, TOTAL_SIZE_RECURSION);
1601 sv_size(aTHX_ st, NPathLink("PL_beginav_save"), (SV*)PL_beginav_save, TOTAL_SIZE_RECURSION);
1602 sv_size(aTHX_ st, NPathLink("PL_checkav_save"), (SV*)PL_checkav_save, TOTAL_SIZE_RECURSION);
1603 #ifdef PL_unitcheckav
1604 sv_size(aTHX_ st, NPathLink("PL_unitcheckav"), (SV*)PL_unitcheckav, TOTAL_SIZE_RECURSION);
1606 #ifdef PL_unitcheckav_save
1607 sv_size(aTHX_ st, NPathLink("PL_unitcheckav_save"), (SV*)PL_unitcheckav_save, TOTAL_SIZE_RECURSION);
1609 sv_size(aTHX_ st, NPathLink("PL_endav"), (SV*)PL_endav, TOTAL_SIZE_RECURSION);
1610 sv_size(aTHX_ st, NPathLink("PL_checkav"), (SV*)PL_checkav, TOTAL_SIZE_RECURSION);
1611 sv_size(aTHX_ st, NPathLink("PL_initav"), (SV*)PL_initav, TOTAL_SIZE_RECURSION);
1613 sv_size(aTHX_ st, NPathLink("PL_isarev"), (SV*)PL_isarev, TOTAL_SIZE_RECURSION);
1615 sv_size(aTHX_ st, NPathLink("PL_fdpid"), (SV*)PL_fdpid, TOTAL_SIZE_RECURSION);
1616 sv_size(aTHX_ st, NPathLink("PL_preambleav"), (SV*)PL_preambleav, TOTAL_SIZE_RECURSION);
1617 sv_size(aTHX_ st, NPathLink("PL_ors_sv"), (SV*)PL_ors_sv, TOTAL_SIZE_RECURSION);
1618 sv_size(aTHX_ st, NPathLink("PL_modglobal"), (SV*)PL_modglobal, TOTAL_SIZE_RECURSION);
1619 sv_size(aTHX_ st, NPathLink("PL_custom_op_names"), (SV*)PL_custom_op_names, TOTAL_SIZE_RECURSION);
1620 sv_size(aTHX_ st, NPathLink("PL_custom_op_descs"), (SV*)PL_custom_op_descs, TOTAL_SIZE_RECURSION);
1621 #ifdef PL_custom_ops
1622 sv_size(aTHX_ st, NPathLink("PL_custom_ops"), (SV*)PL_custom_ops, TOTAL_SIZE_RECURSION);
1624 sv_size(aTHX_ st, NPathLink("PL_compcv"), (SV*)PL_compcv, TOTAL_SIZE_RECURSION);
1625 sv_size(aTHX_ st, NPathLink("PL_DBcv"), (SV*)PL_DBcv, TOTAL_SIZE_RECURSION);
1626 #ifdef PERL_USES_PL_PIDSTATUS
1627 sv_size(aTHX_ st, NPathLink("PL_pidstatus"), (SV*)PL_pidstatus, TOTAL_SIZE_RECURSION);
1629 sv_size(aTHX_ st, NPathLink("PL_subname"), (SV*)PL_subname, TOTAL_SIZE_RECURSION);
1630 #ifdef USE_LOCALE_NUMERIC
1631 sv_size(aTHX_ st, NPathLink("PL_numeric_radix_sv"), (SV*)PL_numeric_radix_sv, TOTAL_SIZE_RECURSION);
1632 check_new_and_strlen(st, PL_numeric_name, NPathLink("PL_numeric_name"));
1634 #ifdef USE_LOCALE_COLLATE
1635 check_new_and_strlen(st, PL_collation_name, NPathLink("PL_collation_name"));
1637 check_new_and_strlen(st, PL_origfilename, NPathLink("PL_origfilename"));
1638 check_new_and_strlen(st, PL_inplace, NPathLink("PL_inplace"));
1639 check_new_and_strlen(st, PL_osname, NPathLink("PL_osname"));
1640 if (PL_op_mask && check_new(st, PL_op_mask))
1641 ADD_SIZE(st, "PL_op_mask", PL_maxo);
1642 if (PL_exitlistlen && check_new(st, PL_exitlist))
1643 ADD_SIZE(st, "PL_exitlist", (PL_exitlistlen * sizeof(PerlExitListEntry *))
1644 + (PL_exitlistlen * sizeof(PerlExitListEntry)));
1645 #ifdef PERL_IMPLICIT_CONTEXT
1646 if (PL_my_cxt_size && check_new(st, PL_my_cxt_list)) {
1647 ADD_SIZE(st, "PL_my_cxt_list", (PL_my_cxt_size * sizeof(void *)));
1648 #ifdef PERL_GLOBAL_STRUCT_PRIVATE
1649 ADD_SIZE(st, "PL_my_cxt_keys", (PL_my_cxt_size * sizeof(char *)));
1653 /* TODO PL_stashpad */
1654 op_size_class(aTHX_ (OP*)&PL_compiling, OPc_COP, 1, st, NPathLink("PL_compiling"));
1655 op_size_class(aTHX_ (OP*)PL_curcopdb, OPc_COP, 0, st, NPathLink("PL_curcopdb"));
1657 #if (PERL_BCDVERSION >= 0x5009005)
1658 parser_size(aTHX_ st, NPathLink("PL_parser"), PL_parser);
1661 /* TODO stacks: cur, main, tmps, mark, scope, save */
1662 /* TODO PL_exitlist */
1663 /* TODO PL_reentrant_buffers etc */
1665 /* TODO PerlIO? PL_known_layers PL_def_layerlist PL_perlio_fd_refcnt etc */
1667 /* TODO anything missed? */
1669 /* --- by this point we should have seen all reachable SVs --- */
1671 /* in theory we shouldn't have any elements in PL_strtab that haven't been seen yet */
1672 sv_size(aTHX_ st, NPathLink("PL_strtab-unseen"), (SV*)PL_strtab, TOTAL_SIZE_RECURSION);
1674 /* unused space in sv head arenas */
1678 # define SvARENA_CHAIN(sv) SvANY(sv) /* XXX breaks encapsulation*/
1679 while ((p = MUTABLE_SV(SvARENA_CHAIN(p)))) {
1680 if (!check_new(st, p)) /* sanity check */
1681 warn("Free'd SV head unexpectedly already seen");
1684 NPathPushNode("unused_sv_heads", NPtype_NAME);
1685 ADD_SIZE(st, "sv", free_heads * sizeof(SV));
1688 /* XXX iterate over bodies_by_type and crawl the free chains for each */
1690 /* iterate over all SVs to find any we've not accounted for yet */
1691 /* once the code above is visiting all SVs, any found here have been leaked */
1692 unseen_sv_size(aTHX_ st, NPathLink("unaccounted"));
1696 MODULE = Devel::SizeMe PACKAGE = Devel::SizeMe
1704 total_size = TOTAL_SIZE_RECURSION
1707 SV *thing = orig_thing;
1708 struct state *st = new_state(aTHX);
1710 /* If they passed us a reference then dereference it. This is the
1711 only way we can check the sizes of arrays and hashes */
1713 thing = SvRV(thing);
1716 sv_size(aTHX_ st, NULL, thing, ix);
1717 RETVAL = st->total_size;
1718 free_state(aTHX_ st);
1727 /* just the current perl interpreter */
1728 struct state *st = new_state(aTHX);
1729 st->min_recurse_threshold = NO_RECURSION; /* so always recurse */
1730 perl_size(aTHX_ st, NULL);
1731 RETVAL = st->total_size;
1732 free_state(aTHX_ st);
1741 /* the current perl interpreter plus malloc, in the context of total heap size */
1742 # ifdef _MALLOC_MALLOC_H_ /* OSX. Now sure where else mstats is available */
1746 /* some systems have the SVID2/XPG mallinfo structure and function */
1747 struct mstats ms = mstats(); /* mstats() first */
1749 struct state *st = new_state(aTHX);
1750 dNPathNodes(1, NULL);
1751 NPathPushNode("heap", NPtype_NAME);
1753 st->min_recurse_threshold = NO_RECURSION; /* so always recurse */
1755 perl_size(aTHX_ st, NPathLink("perl_interp"));
1757 NPathSetNode("free_malloc_space", NPtype_NAME);
1758 ADD_SIZE(st, "bytes_free", ms.bytes_free);
1759 ADD_ATTR(st, NPattr_NOTE, "bytes_total", ms.bytes_total);
1760 ADD_ATTR(st, NPattr_NOTE, "bytes_used", ms.bytes_used);
1761 ADD_ATTR(st, NPattr_NOTE, "chunks_used", ms.chunks_used);
1762 ADD_ATTR(st, NPattr_NOTE, "chunks_free", ms.chunks_free);
1763 /* TODO get heap size from OS and add a node: unknown = heapsize - perl - ms.bytes_free */
1764 /* for now we use bytes_total as an approximation */
1765 NPathSetNode("unknown", NPtype_NAME);
1766 ADD_SIZE(st, "unknown", ms.bytes_total - st->total_size);
1771 RETVAL = st->total_size;
1772 free_state(aTHX_ st);