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 op_size(aTHX_ ((UNOP *)baseop)->op_first, st);
557 sv_size(aTHX_ st, cMETHOPx_meth(baseop), SOME_RECURSION);
558 #if PERL_VERSION*1000+PERL_SUBVERSION >= 21007
559 if (baseop->op_type == OP_METHOD_REDIR || baseop->op_type == OP_METHOD_REDIR_SUPER) {
560 SV *rclass = cMETHOPx_rclass(baseop);
561 if(SvTYPE(rclass) != SVt_PVHV)
562 sv_size(aTHX_ st, rclass, SOME_RECURSION);
568 case OPc_UNAUXOP: TAG;
569 st->total_size += sizeof(struct unop_aux) + sizeof(UNOP_AUX_item) * (cUNOP_AUXx(baseop)->op_aux[-1].uv+1);
570 op_size(aTHX_ ((UNOP *)baseop)->op_first, st);
571 if (baseop->op_type == OP_MULTIDEREF) {
572 UNOP_AUX_item *items = cUNOP_AUXx(baseop)->op_aux;
573 UV actions = items->uv;
577 switch (actions & MDEREF_ACTION_MASK) {
579 actions = (++items)->uv;
581 case MDEREF_HV_padhv_helem:
582 case MDEREF_HV_gvhv_helem:
583 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
584 case MDEREF_HV_padsv_vivify_rv2hv_helem:
586 case MDEREF_AV_padav_aelem:
587 case MDEREF_AV_gvav_aelem:
588 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
589 case MDEREF_AV_padsv_vivify_rv2av_aelem:
592 case MDEREF_HV_pop_rv2hv_helem:
593 case MDEREF_HV_vivify_rv2hv_helem:
595 case MDEREF_AV_pop_rv2av_aelem:
596 case MDEREF_AV_vivify_rv2av_aelem:
598 switch (actions & MDEREF_INDEX_MASK) {
599 case MDEREF_INDEX_none:
602 case MDEREF_INDEX_const:
606 SV *key = PAD_SVl(items->pad_offset);
610 sv_size(aTHX_ st, key, SOME_RECURSION);
613 case MDEREF_INDEX_padsv:
614 case MDEREF_INDEX_gvsv:
618 if (actions & MDEREF_FLAG_last)
626 actions >>= MDEREF_SHIFT;
636 if (st->dangle_whine)
637 warn( "Devel::Size: Encountered dangling pointer in opcode at: %p\n", baseop );
642 hek_size(pTHX_ struct state *st, HEK *hek, U32 shared)
644 /* Hash keys can be shared. Have we seen this before? */
645 if (!check_new(st, hek))
647 st->total_size += HEK_BASESIZE + hek->hek_len
649 + 1 /* No hash key flags prior to 5.8.0 */
655 #if PERL_VERSION < 10
656 st->total_size += sizeof(struct he);
658 st->total_size += STRUCT_OFFSET(struct shared_he, shared_he_hek);
664 #if PERL_VERSION < 8 || PERL_SUBVERSION < 9
669 # define MAYBE_PURIFY(normal, pure) (pure)
670 # define MAYBE_OFFSET(struct_name, member) 0
672 # define MAYBE_PURIFY(normal, pure) (normal)
673 # define MAYBE_OFFSET(struct_name, member) STRUCT_OFFSET(struct_name, member)
676 const U8 body_sizes[SVt_LAST] = {
679 MAYBE_PURIFY(sizeof(IV), sizeof(XPVIV)), /* SVt_IV */
680 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
681 sizeof(XRV), /* SVt_RV */
682 sizeof(XPV), /* SVt_PV */
683 sizeof(XPVIV), /* SVt_PVIV */
684 sizeof(XPVNV), /* SVt_PVNV */
685 sizeof(XPVMG), /* SVt_PVMG */
686 sizeof(XPVBM), /* SVt_PVBM */
687 sizeof(XPVLV), /* SVt_PVLV */
688 sizeof(XPVAV), /* SVt_PVAV */
689 sizeof(XPVHV), /* SVt_PVHV */
690 sizeof(XPVCV), /* SVt_PVCV */
691 sizeof(XPVGV), /* SVt_PVGV */
692 sizeof(XPVFM), /* SVt_PVFM */
693 sizeof(XPVIO) /* SVt_PVIO */
694 #elif PERL_VERSION == 10 && PERL_SUBVERSION == 0
698 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
700 MAYBE_PURIFY(sizeof(xpv_allocated), sizeof(XPV)), /* SVt_PV */
701 MAYBE_PURIFY(sizeof(xpviv_allocated), sizeof(XPVIV)),/* SVt_PVIV */
702 sizeof(XPVNV), /* SVt_PVNV */
703 sizeof(XPVMG), /* SVt_PVMG */
704 sizeof(XPVGV), /* SVt_PVGV */
705 sizeof(XPVLV), /* SVt_PVLV */
706 MAYBE_PURIFY(sizeof(xpvav_allocated), sizeof(XPVAV)),/* SVt_PVAV */
707 MAYBE_PURIFY(sizeof(xpvhv_allocated), sizeof(XPVHV)),/* SVt_PVHV */
708 MAYBE_PURIFY(sizeof(xpvcv_allocated), sizeof(XPVCV)),/* SVt_PVCV */
709 MAYBE_PURIFY(sizeof(xpvfm_allocated), sizeof(XPVFM)),/* SVt_PVFM */
710 sizeof(XPVIO), /* SVt_PVIO */
711 #elif PERL_VERSION == 10 && PERL_SUBVERSION == 1
715 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
717 sizeof(XPV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PV */
718 sizeof(XPVIV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PVIV */
719 sizeof(XPVNV), /* SVt_PVNV */
720 sizeof(XPVMG), /* SVt_PVMG */
721 sizeof(XPVGV), /* SVt_PVGV */
722 sizeof(XPVLV), /* SVt_PVLV */
723 sizeof(XPVAV) - MAYBE_OFFSET(XPVAV, xav_fill), /* SVt_PVAV */
724 sizeof(XPVHV) - MAYBE_OFFSET(XPVHV, xhv_fill), /* SVt_PVHV */
725 sizeof(XPVCV) - MAYBE_OFFSET(XPVCV, xpv_cur), /* SVt_PVCV */
726 sizeof(XPVFM) - MAYBE_OFFSET(XPVFM, xpv_cur), /* SVt_PVFM */
727 sizeof(XPVIO) /* SVt_PVIO */
728 #elif PERL_VERSION < 13
732 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
733 sizeof(XPV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PV */
734 sizeof(XPVIV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PVIV */
735 sizeof(XPVNV), /* SVt_PVNV */
736 sizeof(XPVMG), /* SVt_PVMG */
737 sizeof(regexp) - MAYBE_OFFSET(regexp, xpv_cur), /* SVt_REGEXP */
738 sizeof(XPVGV), /* SVt_PVGV */
739 sizeof(XPVLV), /* SVt_PVLV */
740 sizeof(XPVAV) - MAYBE_OFFSET(XPVAV, xav_fill), /* SVt_PVAV */
741 sizeof(XPVHV) - MAYBE_OFFSET(XPVHV, xhv_fill), /* SVt_PVHV */
742 sizeof(XPVCV) - MAYBE_OFFSET(XPVCV, xpv_cur), /* SVt_PVCV */
743 sizeof(XPVFM) - MAYBE_OFFSET(XPVFM, xpv_cur), /* SVt_PVFM */
744 sizeof(XPVIO) /* SVt_PVIO */
749 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
750 sizeof(XPV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PV */
751 sizeof(XPVIV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PVIV */
752 sizeof(XPVNV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PVNV */
753 sizeof(XPVMG), /* SVt_PVMG */
754 sizeof(regexp), /* SVt_REGEXP */
755 sizeof(XPVGV), /* SVt_PVGV */
756 sizeof(XPVLV), /* SVt_PVLV */
757 sizeof(XPVAV), /* SVt_PVAV */
758 sizeof(XPVHV), /* SVt_PVHV */
759 sizeof(XPVCV), /* SVt_PVCV */
760 sizeof(XPVFM), /* SVt_PVFM */
761 sizeof(XPVIO) /* SVt_PVIO */
765 #if PERL_VERSION*1000+PERL_SUBVERSION >= 21007
766 /* This is, as ever, excessively nosey with the implementation, and hence
768 padlist_size(pTHX_ struct state *const st, const PADLIST * const padl,
771 const PADNAMELIST *pnl;
773 if (!check_new(st, padl))
775 st->total_size += sizeof(PADLIST);
777 st->total_size += sizeof(PADNAMELIST);
778 pnl = PadlistNAMES(padl);
779 st->total_size += pnl->xpadnl_max * sizeof(PADNAME *);
780 i = PadnamelistMAX(pnl) + 1;
782 const PADNAME *const pn =
783 PadnamelistARRAY(pnl)[i];
784 if (!pn || pn == &PL_padname_undef || pn == &PL_padname_const)
786 if (!check_new(st, pn))
788 st->total_size += STRUCT_OFFSET(struct padname_with_str, xpadn_str[0])
789 + PadnameLEN(pn) + 1;
792 i = PadlistMAX(padl) + 1;
793 st->total_size += sizeof(PAD*) * i;
795 sv_size(aTHX_ st, (SV*)PadlistARRAY(padl)[i], recurse);
798 #elif defined PadlistNAMES
800 padlist_size(pTHX_ struct state *const st, const PADLIST * const padl,
803 if (!check_new(st, padl))
805 st->total_size += sizeof(PADLIST);
806 sv_size(aTHX_ st, (SV*)PadlistNAMES(padl), TOTAL_SIZE_RECURSION);
807 i = PadlistMAX(padl) + 1;
808 st->total_size += sizeof(PAD*) * i;
810 sv_size(aTHX_ st, (SV*)PadlistARRAY(padl)[i], recurse);
814 padlist_size(pTHX_ struct state *const st, const AV * const padl,
816 sv_size(aTHX_ st, (SV*)padl, recurse);
821 sv_size(pTHX_ struct state *const st, const SV * const orig_thing,
823 const SV *thing = orig_thing;
826 if(!check_new(st, thing))
829 type = SvTYPE(thing);
830 if (type > SVt_LAST) {
831 warn("Devel::Size: Unknown variable type: %d encountered\n", type);
834 st->total_size += sizeof(SV) + body_sizes[type];
836 if (SvMAGICAL(thing)) {
837 magic_size(aTHX_ thing, st);
841 #if (PERL_VERSION < 11)
842 /* Is it a reference? */
847 if(recurse && SvROK(thing))
848 sv_size(aTHX_ st, SvRV_const(thing), recurse);
852 /* Is there anything in the array? */
853 if (AvMAX(thing) != -1) {
854 /* an array with 10 slots has AvMax() set to 9 - te 2007-04-22 */
855 st->total_size += sizeof(SV *) * (AvMAX(thing) + 1);
856 dbg_printf(("total_size: %li AvMAX: %li av_len: $i\n", st->total_size, AvMAX(thing), av_len((AV*)thing)));
858 if (recurse >= TOTAL_SIZE_RECURSION) {
859 SSize_t i = AvFILLp(thing) + 1;
862 sv_size(aTHX_ st, AvARRAY(thing)[i], recurse);
865 /* Add in the bits on the other side of the beginning */
867 dbg_printf(("total_size %li, sizeof(SV *) %li, AvARRAY(thing) %li, AvALLOC(thing)%li , sizeof(ptr) %li \n",
868 st->total_size, sizeof(SV*), AvARRAY(thing), AvALLOC(thing), sizeof( thing )));
870 /* under Perl 5.8.8 64bit threading, AvARRAY(thing) was a pointer while AvALLOC was 0,
871 resulting in grossly overstated sized for arrays. Technically, this shouldn't happen... */
872 if (AvALLOC(thing) != 0) {
873 st->total_size += (sizeof(SV *) * (AvARRAY(thing) - AvALLOC(thing)));
875 #if (PERL_VERSION < 9)
876 /* Is there something hanging off the arylen element?
877 Post 5.9.something this is stored in magic, so will be found there,
878 and Perl_av_arylen_p() takes a non-const AV*, hence compilers rightly
879 complain about AvARYLEN() passing thing to it. */
880 sv_size(aTHX_ st, AvARYLEN(thing), recurse);
884 /* Now the array of buckets */
885 st->total_size += (sizeof(HE *) * (HvMAX(thing) + 1));
886 /* Now walk the bucket chain */
887 if (HvARRAY(thing)) {
890 for (cur_bucket = 0; cur_bucket <= HvMAX(thing); cur_bucket++) {
891 cur_entry = *(HvARRAY(thing) + cur_bucket);
893 st->total_size += sizeof(HE);
894 hek_size(aTHX_ st, cur_entry->hent_hek, HvSHAREKEYS(thing));
895 if (recurse >= TOTAL_SIZE_RECURSION)
896 sv_size(aTHX_ st, HeVAL(cur_entry), recurse);
897 cur_entry = cur_entry->hent_next;
903 /* This direct access is arguably "naughty": */
904 struct mro_meta *meta = HvAUX(thing)->xhv_mro_meta;
905 #if PERL_VERSION > 13 || PERL_SUBVERSION > 8
907 I32 count = HvAUX(thing)->xhv_name_count;
910 HEK **names = HvAUX(thing)->xhv_name_u.xhvnameu_names;
914 hek_size(aTHX_ st, names[count], 1);
919 hek_size(aTHX_ st, HvNAME_HEK(thing), 1);
922 st->total_size += sizeof(struct xpvhv_aux);
924 st->total_size += sizeof(struct mro_meta);
925 sv_size(aTHX_ st, (SV *)meta->mro_nextmethod, TOTAL_SIZE_RECURSION);
926 #if PERL_VERSION > 10 || (PERL_VERSION == 10 && PERL_SUBVERSION > 0)
927 sv_size(aTHX_ st, (SV *)meta->isa, TOTAL_SIZE_RECURSION);
929 #if PERL_VERSION > 10
930 sv_size(aTHX_ st, (SV *)meta->mro_linear_all, TOTAL_SIZE_RECURSION);
931 sv_size(aTHX_ st, meta->mro_linear_current, TOTAL_SIZE_RECURSION);
933 sv_size(aTHX_ st, (SV *)meta->mro_linear_dfs, TOTAL_SIZE_RECURSION);
934 sv_size(aTHX_ st, (SV *)meta->mro_linear_c3, TOTAL_SIZE_RECURSION);
939 check_new_and_strlen(st, HvNAME_get(thing));
945 padlist_size(aTHX_ st, CvPADLIST(thing), SOME_RECURSION);
946 sv_size(aTHX_ st, (SV *)CvOUTSIDE(thing), recurse);
948 if (st->go_yell && !st->fm_whine) {
949 carp("Devel::Size: Calculated sizes for FMs are incomplete");
955 sv_size(aTHX_ st, (SV *)CvSTASH(thing), SOME_RECURSION);
956 sv_size(aTHX_ st, (SV *)SvSTASH(thing), SOME_RECURSION);
957 sv_size(aTHX_ st, (SV *)CvGV(thing), SOME_RECURSION);
958 sv_size(aTHX_ st, (SV *)CvOUTSIDE(thing), recurse);
959 if (CvISXSUB(thing)) {
960 sv_size(aTHX_ st, cv_const_sv((CV *)thing), recurse);
962 padlist_size(aTHX_ st, CvPADLIST(thing), SOME_RECURSION);
964 op_size(aTHX_ CvSTART(thing), st);
965 op_size(aTHX_ CvROOT(thing), st);
971 /* Some embedded char pointers */
972 check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_top_name);
973 check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_fmt_name);
974 check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_bottom_name);
975 /* Throw the GVs on the list to be walked if they're not-null */
976 sv_size(aTHX_ st, (SV *)((XPVIO *) SvANY(thing))->xio_top_gv, recurse);
977 sv_size(aTHX_ st, (SV *)((XPVIO *) SvANY(thing))->xio_bottom_gv, recurse);
978 sv_size(aTHX_ st, (SV *)((XPVIO *) SvANY(thing))->xio_fmt_gv, recurse);
980 /* Only go trotting through the IO structures if they're really
981 trottable. If USE_PERLIO is defined we can do this. If
982 not... we can't, so we don't even try */
984 /* Dig into xio_ifp and xio_ofp here */
985 warn("Devel::Size: Can't size up perlio layers yet\n");
990 #if (PERL_VERSION < 9)
995 if(isGV_with_GP(thing)) {
997 hek_size(aTHX_ st, GvNAME_HEK(thing), 1);
999 st->total_size += GvNAMELEN(thing);
1002 hek_size(aTHX_ st, GvFILE_HEK(thing), 1);
1003 #elif defined(GvFILE)
1004 # if !defined(USE_ITHREADS) || (PERL_VERSION > 8 || (PERL_VERSION == 8 && PERL_SUBVERSION > 8))
1005 /* With itreads, before 5.8.9, this can end up pointing to freed memory
1006 if the GV was created in an eval, as GvFILE() points to CopFILE(),
1007 and the relevant COP has been freed on scope cleanup after the eval.
1008 5.8.9 adds a binary compatible fudge that catches the vast majority
1009 of cases. 5.9.something added a proper fix, by converting the GP to
1010 use a shared hash key (porperly reference counted), instead of a
1011 char * (owned by who knows? possibly no-one now) */
1012 check_new_and_strlen(st, GvFILE(thing));
1015 /* Is there something hanging off the glob? */
1016 if (check_new(st, GvGP(thing))) {
1017 st->total_size += sizeof(GP);
1018 sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_sv), recurse);
1019 sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_form), recurse);
1020 sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_av), recurse);
1021 sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_hv), recurse);
1022 sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_egv), recurse);
1023 sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_cv), recurse);
1025 #if (PERL_VERSION >= 9)
1029 #if PERL_VERSION <= 8
1037 if(recurse && SvROK(thing))
1038 sv_size(aTHX_ st, SvRV_const(thing), recurse);
1039 else if (SvIsCOW_shared_hash(thing))
1040 hek_size(aTHX_ st, SvSHARED_HEK_FROM_PV(SvPVX(thing)), 1);
1042 st->total_size += SvLEN(thing);
1046 SvOOK_offset(thing, len);
1047 st->total_size += len;
1055 static struct state *
1061 Newxz(st, 1, struct state);
1063 if (NULL != (warn_flag = perl_get_sv("Devel::Size::warn", FALSE))) {
1064 st->dangle_whine = st->go_yell = SvIV(warn_flag) ? TRUE : FALSE;
1066 if (NULL != (warn_flag = perl_get_sv("Devel::Size::dangle", FALSE))) {
1067 st->dangle_whine = SvIV(warn_flag) ? TRUE : FALSE;
1069 check_new(st, &PL_sv_undef);
1070 check_new(st, &PL_sv_no);
1071 check_new(st, &PL_sv_yes);
1072 #if PERL_VERSION > 8 || (PERL_VERSION == 8 && PERL_SUBVERSION > 0)
1073 check_new(st, &PL_sv_placeholder);
1078 MODULE = Devel::Size PACKAGE = Devel::Size
1086 total_size = TOTAL_SIZE_RECURSION
1089 SV *thing = orig_thing;
1090 struct state *st = new_state(aTHX);
1092 /* If they passed us a reference then dereference it. This is the
1093 only way we can check the sizes of arrays and hashes */
1095 thing = SvRV(thing);
1098 sv_size(aTHX_ st, thing, ix);
1099 RETVAL = st->total_size;