3 #define PERL_NO_GET_CONTEXT
10 /* Not yet in ppport.h */
12 # define CvISXSUB(cv) (CvXSUB(cv) ? TRUE : FALSE)
15 # define SvRV_const(rv) SvRV(rv)
18 # define SvOOK_offset(sv, len) STMT_START { len = SvIVX(sv); } STMT_END
21 # define SvIsCOW(sv) ((SvFLAGS(sv) & (SVf_FAKE | SVf_READONLY)) == \
22 (SVf_FAKE | SVf_READONLY))
24 #ifndef SvIsCOW_shared_hash
25 # define SvIsCOW_shared_hash(sv) (SvIsCOW(sv) && SvLEN(sv) == 0)
27 #ifndef SvSHARED_HEK_FROM_PV
28 # define SvSHARED_HEK_FROM_PV(pvx) \
29 ((struct hek*)(pvx - STRUCT_OFFSET(struct hek, hek_key)))
33 # define PL_opargs opargs
34 # define PL_op_name op_name
38 /* "structured exception" handling is a Microsoft extension to C and C++.
39 It's *not* C++ exception handling - C++ exception handling can't capture
40 SEGVs and suchlike, whereas this can. There's no known analagous
41 functionality on other platforms. */
43 # define TRY_TO_CATCH_SEGV __try
44 # define CAUGHT_EXCEPTION __except(EXCEPTION_EXECUTE_HANDLER)
46 # define TRY_TO_CATCH_SEGV if(1)
47 # define CAUGHT_EXCEPTION else
51 # define __attribute__(x)
54 #if 0 && defined(DEBUGGING)
55 #define dbg_printf(x) printf x
60 #define TAG /* printf( "# %s(%d)\n", __FILE__, __LINE__ ) */
63 /* The idea is to have a tree structure to store 1 bit per possible pointer
64 address. The lowest 16 bits are stored in a block of 8092 bytes.
65 The blocks are in a 256-way tree, indexed by the reset of the pointer.
66 This can cope with 32 and 64 bit pointers, and any address space layout,
67 without excessive memory needs. The assumption is that your CPU cache
68 works :-) (And that we're not going to bust it) */
71 #define LEAF_BITS (16 - BYTE_BITS)
72 #define LEAF_MASK 0x1FFF
80 /* My hunch (not measured) is that for most architectures pointers will
81 start with 0 bits, hence the start of this array will be hot, and the
82 end unused. So put the flags next to the hot end. */
87 Checks to see if thing is in the bitstring.
88 Returns true or false, and
89 notes thing in the segmented bitstring.
92 check_new(struct state *st, const void *const p) {
93 unsigned int bits = 8 * sizeof(void*);
94 const size_t raw_p = PTR2nat(p);
95 /* This effectively rotates the value right by the number of low always-0
96 bits in an aligned pointer. The assmption is that most (if not all)
97 pointers are aligned, and these will be in the same chain of nodes
98 (and hence hot in the cache) but we can still deal with any unaligned
100 const size_t cooked_p
101 = (raw_p >> ALIGN_BITS) | (raw_p << (bits - ALIGN_BITS));
102 const U8 this_bit = 1 << (cooked_p & 0x7);
106 void **tv_p = (void **) (st->tracking);
108 if (NULL == p) return FALSE;
110 const char c = *(const char *)p;
113 if (st->dangle_whine)
114 warn( "Devel::Size: Encountered invalid pointer: %p\n", p );
120 /* bits now 24 (32 bit pointers) or 56 (64 bit pointers) */
122 /* First level is always present. */
124 i = (unsigned int)((cooked_p >> bits) & 0xFF);
126 Newxz(tv_p[i], 256, void *);
127 tv_p = (void **)(tv_p[i]);
129 } while (bits > LEAF_BITS + BYTE_BITS);
130 /* bits now 16 always */
131 #if !defined(MULTIPLICITY) || PERL_VERSION > 8 || (PERL_VERSION == 8 && PERL_SUBVERSION > 8)
132 /* 5.8.8 and early have an assert() macro that uses Perl_croak, hence needs
133 a my_perl under multiplicity */
136 leaf_p = (U8 **)tv_p;
137 i = (unsigned int)((cooked_p >> bits) & 0xFF);
139 Newxz(leaf_p[i], 1 << LEAF_BITS, U8);
144 i = (unsigned int)((cooked_p >> BYTE_BITS) & LEAF_MASK);
146 if(leaf[i] & this_bit)
154 free_tracking_at(void **tv, int level)
162 free_tracking_at((void **) tv[i], level);
176 free_state(struct state *st)
178 const int top_level = (sizeof(void *) * 8 - LEAF_BITS - BYTE_BITS) / 8;
179 free_tracking_at((void **)st->tracking, top_level);
183 /* For now, this is somewhat a compatibility bodge until the plan comes
184 together for fine grained recursion control. total_size() would recurse into
185 hash and array members, whereas sv_size() would not. However, sv_size() is
186 called with CvSTASH() of a CV, which means that if it (also) starts to
187 recurse fully, then the size of any CV now becomes the size of the entire
188 symbol table reachable from it, and potentially the entire symbol table, if
189 any subroutine makes a reference to a global (such as %SIG). The historical
190 implementation of total_size() didn't report "everything", and changing the
191 only available size to "everything" doesn't feel at all useful. */
193 #define NO_RECURSION 0
194 #define SOME_RECURSION 1
195 #define TOTAL_SIZE_RECURSION 2
197 static void sv_size(pTHX_ struct state *, const SV *const, const int recurse);
213 , OPc_CONDOP /* 12 */
228 cc_opclass(const OP * const o)
234 return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
236 if (o->op_type == OP_SASSIGN)
237 return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPc_UNOP : OPc_BINOP);
240 if (o->op_type == OP_GV || o->op_type == OP_GVSV || o->op_type == OP_AELEMFAST)
244 if ((o->op_type == OP_TRANS)) {
248 switch (PL_opargs[o->op_type] & OA_CLASS_MASK) {
280 #ifdef OA_PVOP_OR_SVOP
281 case OA_PVOP_OR_SVOP: TAG;
283 * Character translations (tr///) are usually a PVOP, keeping a
284 * pointer to a table of shorts used to look up translations.
285 * Under utf8, however, a simple table isn't practical; instead,
286 * the OP is an SVOP, and the SV is a reference to a swash
287 * (i.e., an RV pointing to an HV).
289 return (o->op_private & (OPpTRANS_TO_UTF|OPpTRANS_FROM_UTF))
290 ? OPc_SVOP : OPc_PVOP;
299 case OA_BASEOP_OR_UNOP: TAG;
301 * UNI(OP_foo) in toke.c returns token UNI or FUNC1 depending on
302 * whether parens were seen. perly.y uses OPf_SPECIAL to
303 * signal whether a BASEOP had empty parens or none.
304 * Some other UNOPs are created later, though, so the best
305 * test is OPf_KIDS, which is set in newUNOP.
307 return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
309 case OA_FILESTATOP: TAG;
311 * The file stat OPs are created via UNI(OP_foo) in toke.c but use
312 * the OPf_REF flag to distinguish between OP types instead of the
313 * usual OPf_SPECIAL flag. As usual, if OPf_KIDS is set, then we
314 * return OPc_UNOP so that walkoptree can find our children. If
315 * OPf_KIDS is not set then we check OPf_REF. Without OPf_REF set
316 * (no argument to the operator) it's an OP; with OPf_REF set it's
317 * an SVOP (and op_sv is the GV for the filehandle argument).
319 return ((o->op_flags & OPf_KIDS) ? OPc_UNOP :
321 (o->op_flags & OPf_REF) ? OPc_PADOP : OPc_BASEOP);
323 (o->op_flags & OPf_REF) ? OPc_SVOP : OPc_BASEOP);
325 case OA_LOOPEXOP: TAG;
327 * next, last, redo, dump and goto use OPf_SPECIAL to indicate that a
328 * label was omitted (in which case it's a BASEOP) or else a term was
329 * seen. In this last case, all except goto are definitely PVOP but
330 * goto is either a PVOP (with an ordinary constant label), an UNOP
331 * with OPf_STACKED (with a non-constant non-sub) or an UNOP for
332 * OP_REFGEN (with goto &sub) in which case OPf_STACKED also seems to
335 if (o->op_flags & OPf_STACKED)
337 else if (o->op_flags & OPf_SPECIAL)
352 case OA_UNOP_AUX: TAG;
356 warn("Devel::Size: Can't determine class of operator %s, assuming BASEOP\n",
357 PL_op_name[o->op_type]);
363 /* Figure out how much magic is attached to the SV and return the
366 magic_size(pTHX_ const SV * const thing, struct state *st) {
367 MAGIC *magic_pointer = SvMAGIC(thing);
369 /* Have we seen the magic pointer? (NULL has always been seen before) */
370 while (check_new(st, magic_pointer)) {
371 st->total_size += sizeof(MAGIC);
372 /* magic vtables aren't freed when magic is freed, so don't count them.
373 (They are static structures. Anything that assumes otherwise is buggy.)
378 sv_size(aTHX_ st, magic_pointer->mg_obj, TOTAL_SIZE_RECURSION);
379 if (magic_pointer->mg_len == HEf_SVKEY) {
380 sv_size(aTHX_ st, (SV *)magic_pointer->mg_ptr, TOTAL_SIZE_RECURSION);
382 #if defined(PERL_MAGIC_utf8) && defined (PERL_MAGIC_UTF8_CACHESIZE)
383 else if (magic_pointer->mg_type == PERL_MAGIC_utf8) {
384 if (check_new(st, magic_pointer->mg_ptr)) {
385 st->total_size += PERL_MAGIC_UTF8_CACHESIZE * 2 * sizeof(STRLEN);
389 else if (magic_pointer->mg_len > 0) {
390 if (check_new(st, magic_pointer->mg_ptr)) {
391 st->total_size += magic_pointer->mg_len;
395 /* Get the next in the chain */
396 magic_pointer = magic_pointer->mg_moremagic;
399 if (st->dangle_whine)
400 warn( "Devel::Size: Encountered bad magic at: %p\n", magic_pointer );
406 check_new_and_strlen(struct state *st, const char *const p) {
408 st->total_size += 1 + strlen(p);
412 regex_size(const REGEXP * const baseregex, struct state *st) {
413 if(!check_new(st, baseregex))
415 st->total_size += sizeof(REGEXP);
416 #if (PERL_VERSION < 11)
417 /* Note the size of the paren offset thing */
418 st->total_size += sizeof(I32) * baseregex->nparens * 2;
419 st->total_size += strlen(baseregex->precomp);
421 st->total_size += sizeof(struct regexp);
422 st->total_size += sizeof(I32) * SvANY(baseregex)->nparens * 2;
423 /*st->total_size += strlen(SvANY(baseregex)->subbeg);*/
425 if (st->go_yell && !st->regex_whine) {
426 carp("Devel::Size: Calculated sizes for compiled regexes are incompatible, and probably always will be");
432 op_size(pTHX_ const OP * const baseop, struct state *st)
436 if(!check_new(st, baseop))
439 op_size(aTHX_ baseop->op_next, st);
441 switch (cc_opclass(baseop)) {
442 case OPc_BASEOP: TAG;
443 st->total_size += sizeof(struct op);
446 st->total_size += sizeof(struct unop);
447 op_size(aTHX_ ((UNOP *)baseop)->op_first, st);
450 st->total_size += sizeof(struct binop);
451 op_size(aTHX_ ((BINOP *)baseop)->op_first, st);
452 op_size(aTHX_ ((BINOP *)baseop)->op_last, st);
455 st->total_size += sizeof(struct logop);
456 op_size(aTHX_ ((BINOP *)baseop)->op_first, st);
457 op_size(aTHX_ ((LOGOP *)baseop)->op_other, st);
460 case OPc_CONDOP: TAG;
461 st->total_size += sizeof(struct condop);
462 op_size(aTHX_ ((BINOP *)baseop)->op_first, st);
463 op_size(aTHX_ ((CONDOP *)baseop)->op_true, st);
464 op_size(aTHX_ ((CONDOP *)baseop)->op_false, st);
467 case OPc_LISTOP: TAG;
468 st->total_size += sizeof(struct listop);
469 op_size(aTHX_ ((LISTOP *)baseop)->op_first, st);
470 op_size(aTHX_ ((LISTOP *)baseop)->op_last, st);
473 st->total_size += sizeof(struct pmop);
474 op_size(aTHX_ ((PMOP *)baseop)->op_first, st);
475 op_size(aTHX_ ((PMOP *)baseop)->op_last, st);
476 #if PERL_VERSION < 9 || (PERL_VERSION == 9 && PERL_SUBVERSION < 5)
477 op_size(aTHX_ ((PMOP *)baseop)->op_pmreplroot, st);
478 op_size(aTHX_ ((PMOP *)baseop)->op_pmreplstart, st);
480 /* This is defined away in perl 5.8.x, but it is in there for
483 regex_size(PM_GETRE((PMOP *)baseop), st);
485 regex_size(((PMOP *)baseop)->op_pmregexp, st);
489 st->total_size += sizeof(struct pmop);
490 if (!(baseop->op_type == OP_AELEMFAST
491 && baseop->op_flags & OPf_SPECIAL)) {
492 /* not an OP_PADAV replacement */
493 sv_size(aTHX_ st, ((SVOP *)baseop)->op_sv, SOME_RECURSION);
498 st->total_size += sizeof(struct padop);
503 st->total_size += sizeof(struct gvop);
504 sv_size(aTHX_ st, ((GVOP *)baseop)->op_gv, SOME_RECURSION);
508 check_new_and_strlen(st, ((PVOP *)baseop)->op_pv);
511 st->total_size += sizeof(struct loop);
512 op_size(aTHX_ ((LOOP *)baseop)->op_first, st);
513 op_size(aTHX_ ((LOOP *)baseop)->op_last, st);
514 op_size(aTHX_ ((LOOP *)baseop)->op_redoop, st);
515 op_size(aTHX_ ((LOOP *)baseop)->op_nextop, st);
516 op_size(aTHX_ ((LOOP *)baseop)->op_lastop, st);
521 basecop = (COP *)baseop;
522 st->total_size += sizeof(struct cop);
524 /* Change 33656 by nicholas@mouse-mill on 2008/04/07 11:29:51
525 Eliminate cop_label from struct cop by storing a label as the first
526 entry in the hints hash. Most statements don't have labels, so this
527 will save memory. Not sure how much.
528 The check below will be incorrect fail on bleadperls
529 before 5.11 @33656, but later than 5.10, producing slightly too
530 small memory sizes on these Perls. */
531 #if (PERL_VERSION < 11)
532 check_new_and_strlen(st, basecop->cop_label);
535 check_new_and_strlen(st, basecop->cop_file);
536 #if PERL_VERSION < 17 || (PERL_VERSION == 17 && PERL_SUBVERSION == 0)
537 /* This pointer is owned by the COP, and freed with it. */
538 check_new_and_strlen(st, basecop->cop_stashpv);
540 /* A per-interpreter pointer for this stash is allocated in
542 if (check_new(st, PL_stashpad + basecop->cop_stashoff))
543 st->total_size += sizeof(PL_stashpad[basecop->cop_stashoff]);
546 sv_size(aTHX_ st, (SV *)basecop->cop_filegv, SOME_RECURSION);
552 case OPc_METHOP: TAG;
553 st->total_size += sizeof(struct methop);
554 if (baseop->op_type != OP_METHOD)
555 sv_size(aTHX_ st, cMETHOPx_meth(baseop), SOME_RECURSION);
556 #if PERL_VERSION*1000+PERL_SUBVERSION >= 21007
557 if (baseop->op_type == OP_METHOD_REDIR || baseop->op_type == OP_METHOD_REDIR_SUPER) {
558 SV *rclass = cMETHOPx_rclass(baseop);
559 if(SvTYPE(rclass) != SVt_PVHV)
560 sv_size(aTHX_ st, rclass, SOME_RECURSION);
566 case OPc_UNAUXOP: TAG;
567 st->total_size += sizeof(struct unop_aux) + sizeof(UNOP_AUX_item) * (cUNOP_AUXx(baseop)->op_aux[-1].uv+1);
568 if (baseop->op_type == OP_MULTIDEREF) {
569 UNOP_AUX_item *items = cUNOP_AUXx(baseop)->op_aux;
570 UV actions = items->uv;
574 switch (actions & MDEREF_ACTION_MASK) {
576 actions = (++items)->uv;
578 case MDEREF_HV_padhv_helem:
579 case MDEREF_HV_gvhv_helem:
580 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
581 case MDEREF_HV_padsv_vivify_rv2hv_helem:
583 case MDEREF_AV_padav_aelem:
584 case MDEREF_AV_gvav_aelem:
585 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
586 case MDEREF_AV_padsv_vivify_rv2av_aelem:
589 case MDEREF_HV_pop_rv2hv_helem:
590 case MDEREF_HV_vivify_rv2hv_helem:
592 case MDEREF_AV_pop_rv2av_aelem:
593 case MDEREF_AV_vivify_rv2av_aelem:
595 switch (actions & MDEREF_INDEX_MASK) {
596 case MDEREF_INDEX_none:
599 case MDEREF_INDEX_const:
603 SV *key = PAD_SVl(items->pad_offset);
607 sv_size(aTHX_ st, key, SOME_RECURSION);
610 case MDEREF_INDEX_padsv:
611 case MDEREF_INDEX_gvsv:
615 if (actions & MDEREF_FLAG_last)
623 actions >>= MDEREF_SHIFT;
633 if (st->dangle_whine)
634 warn( "Devel::Size: Encountered dangling pointer in opcode at: %p\n", baseop );
639 hek_size(pTHX_ struct state *st, HEK *hek, U32 shared)
641 /* Hash keys can be shared. Have we seen this before? */
642 if (!check_new(st, hek))
644 st->total_size += HEK_BASESIZE + hek->hek_len
646 + 1 /* No hash key flags prior to 5.8.0 */
652 #if PERL_VERSION < 10
653 st->total_size += sizeof(struct he);
655 st->total_size += STRUCT_OFFSET(struct shared_he, shared_he_hek);
661 #if PERL_VERSION < 8 || PERL_SUBVERSION < 9
666 # define MAYBE_PURIFY(normal, pure) (pure)
667 # define MAYBE_OFFSET(struct_name, member) 0
669 # define MAYBE_PURIFY(normal, pure) (normal)
670 # define MAYBE_OFFSET(struct_name, member) STRUCT_OFFSET(struct_name, member)
673 const U8 body_sizes[SVt_LAST] = {
676 MAYBE_PURIFY(sizeof(IV), sizeof(XPVIV)), /* SVt_IV */
677 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
678 sizeof(XRV), /* SVt_RV */
679 sizeof(XPV), /* SVt_PV */
680 sizeof(XPVIV), /* SVt_PVIV */
681 sizeof(XPVNV), /* SVt_PVNV */
682 sizeof(XPVMG), /* SVt_PVMG */
683 sizeof(XPVBM), /* SVt_PVBM */
684 sizeof(XPVLV), /* SVt_PVLV */
685 sizeof(XPVAV), /* SVt_PVAV */
686 sizeof(XPVHV), /* SVt_PVHV */
687 sizeof(XPVCV), /* SVt_PVCV */
688 sizeof(XPVGV), /* SVt_PVGV */
689 sizeof(XPVFM), /* SVt_PVFM */
690 sizeof(XPVIO) /* SVt_PVIO */
691 #elif PERL_VERSION == 10 && PERL_SUBVERSION == 0
695 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
697 MAYBE_PURIFY(sizeof(xpv_allocated), sizeof(XPV)), /* SVt_PV */
698 MAYBE_PURIFY(sizeof(xpviv_allocated), sizeof(XPVIV)),/* SVt_PVIV */
699 sizeof(XPVNV), /* SVt_PVNV */
700 sizeof(XPVMG), /* SVt_PVMG */
701 sizeof(XPVGV), /* SVt_PVGV */
702 sizeof(XPVLV), /* SVt_PVLV */
703 MAYBE_PURIFY(sizeof(xpvav_allocated), sizeof(XPVAV)),/* SVt_PVAV */
704 MAYBE_PURIFY(sizeof(xpvhv_allocated), sizeof(XPVHV)),/* SVt_PVHV */
705 MAYBE_PURIFY(sizeof(xpvcv_allocated), sizeof(XPVCV)),/* SVt_PVCV */
706 MAYBE_PURIFY(sizeof(xpvfm_allocated), sizeof(XPVFM)),/* SVt_PVFM */
707 sizeof(XPVIO), /* SVt_PVIO */
708 #elif PERL_VERSION == 10 && PERL_SUBVERSION == 1
712 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
714 sizeof(XPV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PV */
715 sizeof(XPVIV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PVIV */
716 sizeof(XPVNV), /* SVt_PVNV */
717 sizeof(XPVMG), /* SVt_PVMG */
718 sizeof(XPVGV), /* SVt_PVGV */
719 sizeof(XPVLV), /* SVt_PVLV */
720 sizeof(XPVAV) - MAYBE_OFFSET(XPVAV, xav_fill), /* SVt_PVAV */
721 sizeof(XPVHV) - MAYBE_OFFSET(XPVHV, xhv_fill), /* SVt_PVHV */
722 sizeof(XPVCV) - MAYBE_OFFSET(XPVCV, xpv_cur), /* SVt_PVCV */
723 sizeof(XPVFM) - MAYBE_OFFSET(XPVFM, xpv_cur), /* SVt_PVFM */
724 sizeof(XPVIO) /* SVt_PVIO */
725 #elif PERL_VERSION < 13
729 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
730 sizeof(XPV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PV */
731 sizeof(XPVIV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PVIV */
732 sizeof(XPVNV), /* SVt_PVNV */
733 sizeof(XPVMG), /* SVt_PVMG */
734 sizeof(regexp) - MAYBE_OFFSET(regexp, xpv_cur), /* SVt_REGEXP */
735 sizeof(XPVGV), /* SVt_PVGV */
736 sizeof(XPVLV), /* SVt_PVLV */
737 sizeof(XPVAV) - MAYBE_OFFSET(XPVAV, xav_fill), /* SVt_PVAV */
738 sizeof(XPVHV) - MAYBE_OFFSET(XPVHV, xhv_fill), /* SVt_PVHV */
739 sizeof(XPVCV) - MAYBE_OFFSET(XPVCV, xpv_cur), /* SVt_PVCV */
740 sizeof(XPVFM) - MAYBE_OFFSET(XPVFM, xpv_cur), /* SVt_PVFM */
741 sizeof(XPVIO) /* SVt_PVIO */
746 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
747 sizeof(XPV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PV */
748 sizeof(XPVIV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PVIV */
749 sizeof(XPVNV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PVNV */
750 sizeof(XPVMG), /* SVt_PVMG */
751 sizeof(regexp), /* SVt_REGEXP */
752 sizeof(XPVGV), /* SVt_PVGV */
753 sizeof(XPVLV), /* SVt_PVLV */
754 sizeof(XPVAV), /* SVt_PVAV */
755 sizeof(XPVHV), /* SVt_PVHV */
756 sizeof(XPVCV), /* SVt_PVCV */
757 sizeof(XPVFM), /* SVt_PVFM */
758 sizeof(XPVIO) /* SVt_PVIO */
764 padlist_size(pTHX_ struct state *const st, const PADLIST * const padl,
767 if (!check_new(st, padl))
769 /* This relies on PADNAMELIST and PAD being typedefed to AV. If that
770 ever changes, this code will need an update. */
771 st->total_size += sizeof(PADLIST);
772 sv_size(aTHX_ st, (SV*)PadlistNAMES(padl), TOTAL_SIZE_RECURSION);
773 i = PadlistMAX(padl) + 1;
774 st->total_size += sizeof(PAD*) * i;
776 sv_size(aTHX_ st, (SV*)PadlistARRAY(padl)[i], recurse);
780 padlist_size(pTHX_ struct state *const st, const AV * const padl,
782 sv_size(aTHX_ st, (SV*)padl, recurse);
787 sv_size(pTHX_ struct state *const st, const SV * const orig_thing,
789 const SV *thing = orig_thing;
792 if(!check_new(st, thing))
795 type = SvTYPE(thing);
796 if (type > SVt_LAST) {
797 warn("Devel::Size: Unknown variable type: %d encountered\n", type);
800 st->total_size += sizeof(SV) + body_sizes[type];
802 if (SvMAGICAL(thing)) {
803 magic_size(aTHX_ thing, st);
807 #if (PERL_VERSION < 11)
808 /* Is it a reference? */
813 if(recurse && SvROK(thing))
814 sv_size(aTHX_ st, SvRV_const(thing), recurse);
818 /* Is there anything in the array? */
819 if (AvMAX(thing) != -1) {
820 /* an array with 10 slots has AvMax() set to 9 - te 2007-04-22 */
821 st->total_size += sizeof(SV *) * (AvMAX(thing) + 1);
822 dbg_printf(("total_size: %li AvMAX: %li av_len: $i\n", st->total_size, AvMAX(thing), av_len((AV*)thing)));
824 if (recurse >= TOTAL_SIZE_RECURSION) {
825 SSize_t i = AvFILLp(thing) + 1;
828 sv_size(aTHX_ st, AvARRAY(thing)[i], recurse);
831 /* Add in the bits on the other side of the beginning */
833 dbg_printf(("total_size %li, sizeof(SV *) %li, AvARRAY(thing) %li, AvALLOC(thing)%li , sizeof(ptr) %li \n",
834 st->total_size, sizeof(SV*), AvARRAY(thing), AvALLOC(thing), sizeof( thing )));
836 /* under Perl 5.8.8 64bit threading, AvARRAY(thing) was a pointer while AvALLOC was 0,
837 resulting in grossly overstated sized for arrays. Technically, this shouldn't happen... */
838 if (AvALLOC(thing) != 0) {
839 st->total_size += (sizeof(SV *) * (AvARRAY(thing) - AvALLOC(thing)));
841 #if (PERL_VERSION < 9)
842 /* Is there something hanging off the arylen element?
843 Post 5.9.something this is stored in magic, so will be found there,
844 and Perl_av_arylen_p() takes a non-const AV*, hence compilers rightly
845 complain about AvARYLEN() passing thing to it. */
846 sv_size(aTHX_ st, AvARYLEN(thing), recurse);
850 /* Now the array of buckets */
851 st->total_size += (sizeof(HE *) * (HvMAX(thing) + 1));
852 /* Now walk the bucket chain */
853 if (HvARRAY(thing)) {
856 for (cur_bucket = 0; cur_bucket <= HvMAX(thing); cur_bucket++) {
857 cur_entry = *(HvARRAY(thing) + cur_bucket);
859 st->total_size += sizeof(HE);
860 hek_size(aTHX_ st, cur_entry->hent_hek, HvSHAREKEYS(thing));
861 if (recurse >= TOTAL_SIZE_RECURSION)
862 sv_size(aTHX_ st, HeVAL(cur_entry), recurse);
863 cur_entry = cur_entry->hent_next;
869 /* This direct access is arguably "naughty": */
870 struct mro_meta *meta = HvAUX(thing)->xhv_mro_meta;
871 #if PERL_VERSION > 13 || PERL_SUBVERSION > 8
873 I32 count = HvAUX(thing)->xhv_name_count;
876 HEK **names = HvAUX(thing)->xhv_name_u.xhvnameu_names;
880 hek_size(aTHX_ st, names[count], 1);
885 hek_size(aTHX_ st, HvNAME_HEK(thing), 1);
888 st->total_size += sizeof(struct xpvhv_aux);
890 st->total_size += sizeof(struct mro_meta);
891 sv_size(aTHX_ st, (SV *)meta->mro_nextmethod, TOTAL_SIZE_RECURSION);
892 #if PERL_VERSION > 10 || (PERL_VERSION == 10 && PERL_SUBVERSION > 0)
893 sv_size(aTHX_ st, (SV *)meta->isa, TOTAL_SIZE_RECURSION);
895 #if PERL_VERSION > 10
896 sv_size(aTHX_ st, (SV *)meta->mro_linear_all, TOTAL_SIZE_RECURSION);
897 sv_size(aTHX_ st, meta->mro_linear_current, TOTAL_SIZE_RECURSION);
899 sv_size(aTHX_ st, (SV *)meta->mro_linear_dfs, TOTAL_SIZE_RECURSION);
900 sv_size(aTHX_ st, (SV *)meta->mro_linear_c3, TOTAL_SIZE_RECURSION);
905 check_new_and_strlen(st, HvNAME_get(thing));
911 padlist_size(aTHX_ st, CvPADLIST(thing), SOME_RECURSION);
912 sv_size(aTHX_ st, (SV *)CvOUTSIDE(thing), recurse);
914 if (st->go_yell && !st->fm_whine) {
915 carp("Devel::Size: Calculated sizes for FMs are incomplete");
921 sv_size(aTHX_ st, (SV *)CvSTASH(thing), SOME_RECURSION);
922 sv_size(aTHX_ st, (SV *)SvSTASH(thing), SOME_RECURSION);
923 sv_size(aTHX_ st, (SV *)CvGV(thing), SOME_RECURSION);
924 sv_size(aTHX_ st, (SV *)CvOUTSIDE(thing), recurse);
925 if (CvISXSUB(thing)) {
926 sv_size(aTHX_ st, cv_const_sv((CV *)thing), recurse);
928 padlist_size(aTHX_ st, CvPADLIST(thing), SOME_RECURSION);
930 op_size(aTHX_ CvSTART(thing), st);
931 op_size(aTHX_ CvROOT(thing), st);
937 /* Some embedded char pointers */
938 check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_top_name);
939 check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_fmt_name);
940 check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_bottom_name);
941 /* Throw the GVs on the list to be walked if they're not-null */
942 sv_size(aTHX_ st, (SV *)((XPVIO *) SvANY(thing))->xio_top_gv, recurse);
943 sv_size(aTHX_ st, (SV *)((XPVIO *) SvANY(thing))->xio_bottom_gv, recurse);
944 sv_size(aTHX_ st, (SV *)((XPVIO *) SvANY(thing))->xio_fmt_gv, recurse);
946 /* Only go trotting through the IO structures if they're really
947 trottable. If USE_PERLIO is defined we can do this. If
948 not... we can't, so we don't even try */
950 /* Dig into xio_ifp and xio_ofp here */
951 warn("Devel::Size: Can't size up perlio layers yet\n");
956 #if (PERL_VERSION < 9)
961 if(isGV_with_GP(thing)) {
963 hek_size(aTHX_ st, GvNAME_HEK(thing), 1);
965 st->total_size += GvNAMELEN(thing);
968 hek_size(aTHX_ st, GvFILE_HEK(thing), 1);
969 #elif defined(GvFILE)
970 # if !defined(USE_ITHREADS) || (PERL_VERSION > 8 || (PERL_VERSION == 8 && PERL_SUBVERSION > 8))
971 /* With itreads, before 5.8.9, this can end up pointing to freed memory
972 if the GV was created in an eval, as GvFILE() points to CopFILE(),
973 and the relevant COP has been freed on scope cleanup after the eval.
974 5.8.9 adds a binary compatible fudge that catches the vast majority
975 of cases. 5.9.something added a proper fix, by converting the GP to
976 use a shared hash key (porperly reference counted), instead of a
977 char * (owned by who knows? possibly no-one now) */
978 check_new_and_strlen(st, GvFILE(thing));
981 /* Is there something hanging off the glob? */
982 if (check_new(st, GvGP(thing))) {
983 st->total_size += sizeof(GP);
984 sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_sv), recurse);
985 sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_form), recurse);
986 sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_av), recurse);
987 sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_hv), recurse);
988 sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_egv), recurse);
989 sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_cv), recurse);
991 #if (PERL_VERSION >= 9)
995 #if PERL_VERSION <= 8
1003 if(recurse && SvROK(thing))
1004 sv_size(aTHX_ st, SvRV_const(thing), recurse);
1005 else if (SvIsCOW_shared_hash(thing))
1006 hek_size(aTHX_ st, SvSHARED_HEK_FROM_PV(SvPVX(thing)), 1);
1008 st->total_size += SvLEN(thing);
1012 SvOOK_offset(thing, len);
1013 st->total_size += len;
1021 static struct state *
1027 Newxz(st, 1, struct state);
1029 if (NULL != (warn_flag = perl_get_sv("Devel::Size::warn", FALSE))) {
1030 st->dangle_whine = st->go_yell = SvIV(warn_flag) ? TRUE : FALSE;
1032 if (NULL != (warn_flag = perl_get_sv("Devel::Size::dangle", FALSE))) {
1033 st->dangle_whine = SvIV(warn_flag) ? TRUE : FALSE;
1035 check_new(st, &PL_sv_undef);
1036 check_new(st, &PL_sv_no);
1037 check_new(st, &PL_sv_yes);
1038 #if PERL_VERSION > 8 || (PERL_VERSION == 8 && PERL_SUBVERSION > 0)
1039 check_new(st, &PL_sv_placeholder);
1044 MODULE = Devel::Size PACKAGE = Devel::Size
1052 total_size = TOTAL_SIZE_RECURSION
1055 SV *thing = orig_thing;
1056 struct state *st = new_state(aTHX);
1058 /* If they passed us a reference then dereference it. This is the
1059 only way we can check the sizes of arrays and hashes */
1061 thing = SvRV(thing);
1064 sv_size(aTHX_ st, thing, ix);
1065 RETVAL = st->total_size;