3 #define PERL_NO_GET_CONTEXT
10 #ifndef PERL_COMBI_VERSION
11 #define PERL_COMBI_VERSION (PERL_REVISION * 1000000 + PERL_VERSION * 1000 + \
15 /* Not yet in ppport.h */
17 # define CvISXSUB(cv) (CvXSUB(cv) ? TRUE : FALSE)
20 # define SvRV_const(rv) SvRV(rv)
23 # define SvOOK_offset(sv, len) STMT_START { len = SvIVX(sv); } STMT_END
26 # define SvIsCOW(sv) ((SvFLAGS(sv) & (SVf_FAKE | SVf_READONLY)) == \
27 (SVf_FAKE | SVf_READONLY))
29 #ifndef SvIsCOW_shared_hash
30 # define SvIsCOW_shared_hash(sv) (SvIsCOW(sv) && SvLEN(sv) == 0)
32 #ifndef SvSHARED_HEK_FROM_PV
33 # define SvSHARED_HEK_FROM_PV(pvx) \
34 ((struct hek*)(pvx - STRUCT_OFFSET(struct hek, hek_key)))
38 # define PL_opargs opargs
39 # define PL_op_name op_name
43 /* "structured exception" handling is a Microsoft extension to C and C++.
44 It's *not* C++ exception handling - C++ exception handling can't capture
45 SEGVs and suchlike, whereas this can. There's no known analagous
46 functionality on other platforms. */
48 # define TRY_TO_CATCH_SEGV __try
49 # define CAUGHT_EXCEPTION __except(EXCEPTION_EXECUTE_HANDLER)
51 # define TRY_TO_CATCH_SEGV if(1)
52 # define CAUGHT_EXCEPTION else
56 # define __attribute__(x)
59 #if 0 && defined(DEBUGGING)
60 #define dbg_printf(x) printf x
65 #define TAG /* printf( "# %s(%d)\n", __FILE__, __LINE__ ) */
68 /* The idea is to have a tree structure to store 1 bit per possible pointer
69 address. The lowest 16 bits are stored in a block of 8092 bytes.
70 The blocks are in a 256-way tree, indexed by the reset of the pointer.
71 This can cope with 32 and 64 bit pointers, and any address space layout,
72 without excessive memory needs. The assumption is that your CPU cache
73 works :-) (And that we're not going to bust it) */
76 #define LEAF_BITS (16 - BYTE_BITS)
77 #define LEAF_MASK 0x1FFF
85 /* My hunch (not measured) is that for most architectures pointers will
86 start with 0 bits, hence the start of this array will be hot, and the
87 end unused. So put the flags next to the hot end. */
92 Checks to see if thing is in the bitstring.
93 Returns true or false, and
94 notes thing in the segmented bitstring.
97 check_new(struct state *st, const void *const p) {
98 unsigned int bits = 8 * sizeof(void*);
99 const size_t raw_p = PTR2nat(p);
100 /* This effectively rotates the value right by the number of low always-0
101 bits in an aligned pointer. The assmption is that most (if not all)
102 pointers are aligned, and these will be in the same chain of nodes
103 (and hence hot in the cache) but we can still deal with any unaligned
105 const size_t cooked_p
106 = (raw_p >> ALIGN_BITS) | (raw_p << (bits - ALIGN_BITS));
107 const U8 this_bit = 1 << (cooked_p & 0x7);
111 void **tv_p = (void **) (st->tracking);
113 if (NULL == p) return FALSE;
115 const char c = *(const char *)p;
118 if (st->dangle_whine)
119 warn( "Devel::Size: Encountered invalid pointer: %p\n", p );
125 /* bits now 24 (32 bit pointers) or 56 (64 bit pointers) */
127 /* First level is always present. */
129 i = (unsigned int)((cooked_p >> bits) & 0xFF);
131 Newxz(tv_p[i], 256, void *);
132 tv_p = (void **)(tv_p[i]);
134 } while (bits > LEAF_BITS + BYTE_BITS);
135 /* bits now 16 always */
136 #if PERL_COMBI_VERSION > 5008008 || (!defined(MULTIPLICITY) && !defined(USE_THREADS))
137 /* 5.8.8 and earlier have an assert() macro that uses Perl_croak, hence
138 needs a my_perl under multiplicity. Similarly, under 5.005 threads
139 Perl_croak needs a thr. In both cases, just skip the assert. */
142 leaf_p = (U8 **)tv_p;
143 i = (unsigned int)((cooked_p >> bits) & 0xFF);
145 Newxz(leaf_p[i], 1 << LEAF_BITS, U8);
150 i = (unsigned int)((cooked_p >> BYTE_BITS) & LEAF_MASK);
152 if(leaf[i] & this_bit)
160 free_tracking_at(void **tv, int level)
168 free_tracking_at((void **) tv[i], level);
182 free_state(struct state *st)
184 const int top_level = (sizeof(void *) * 8 - LEAF_BITS - BYTE_BITS) / 8;
185 free_tracking_at((void **)st->tracking, top_level);
189 /* For now, this is somewhat a compatibility bodge until the plan comes
190 together for fine grained recursion control. total_size() would recurse into
191 hash and array members, whereas sv_size() would not. However, sv_size() is
192 called with CvSTASH() of a CV, which means that if it (also) starts to
193 recurse fully, then the size of any CV now becomes the size of the entire
194 symbol table reachable from it, and potentially the entire symbol table, if
195 any subroutine makes a reference to a global (such as %SIG). The historical
196 implementation of total_size() didn't report "everything", and changing the
197 only available size to "everything" doesn't feel at all useful. */
199 #define NO_RECURSION 0
200 #define SOME_RECURSION 1
201 #define TOTAL_SIZE_RECURSION 2
203 static void sv_size(pTHX_ struct state *, const SV *const, const int recurse);
219 , OPc_CONDOP /* 12 */
234 cc_opclass(const OP * const o)
240 return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
242 if (o->op_type == OP_SASSIGN)
243 return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPc_UNOP : OPc_BINOP);
246 if (o->op_type == OP_GV || o->op_type == OP_GVSV || o->op_type == OP_AELEMFAST)
250 if ((o->op_type == OP_TRANS)) {
254 switch (PL_opargs[o->op_type] & OA_CLASS_MASK) {
286 #ifdef OA_PVOP_OR_SVOP
287 case OA_PVOP_OR_SVOP: TAG;
289 * Character translations (tr///) are usually a PVOP, keeping a
290 * pointer to a table of shorts used to look up translations.
291 * Under utf8, however, a simple table isn't practical; instead,
292 * the OP is an SVOP, and the SV is a reference to a swash
293 * (i.e., an RV pointing to an HV).
295 return (o->op_private & (OPpTRANS_TO_UTF|OPpTRANS_FROM_UTF))
296 ? OPc_SVOP : OPc_PVOP;
305 case OA_BASEOP_OR_UNOP: TAG;
307 * UNI(OP_foo) in toke.c returns token UNI or FUNC1 depending on
308 * whether parens were seen. perly.y uses OPf_SPECIAL to
309 * signal whether a BASEOP had empty parens or none.
310 * Some other UNOPs are created later, though, so the best
311 * test is OPf_KIDS, which is set in newUNOP.
313 return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
315 case OA_FILESTATOP: TAG;
317 * The file stat OPs are created via UNI(OP_foo) in toke.c but use
318 * the OPf_REF flag to distinguish between OP types instead of the
319 * usual OPf_SPECIAL flag. As usual, if OPf_KIDS is set, then we
320 * return OPc_UNOP so that walkoptree can find our children. If
321 * OPf_KIDS is not set then we check OPf_REF. Without OPf_REF set
322 * (no argument to the operator) it's an OP; with OPf_REF set it's
323 * an SVOP (and op_sv is the GV for the filehandle argument).
325 return ((o->op_flags & OPf_KIDS) ? OPc_UNOP :
327 (o->op_flags & OPf_REF) ? OPc_PADOP : OPc_BASEOP);
329 (o->op_flags & OPf_REF) ? OPc_SVOP : OPc_BASEOP);
331 case OA_LOOPEXOP: TAG;
333 * next, last, redo, dump and goto use OPf_SPECIAL to indicate that a
334 * label was omitted (in which case it's a BASEOP) or else a term was
335 * seen. In this last case, all except goto are definitely PVOP but
336 * goto is either a PVOP (with an ordinary constant label), an UNOP
337 * with OPf_STACKED (with a non-constant non-sub) or an UNOP for
338 * OP_REFGEN (with goto &sub) in which case OPf_STACKED also seems to
341 if (o->op_flags & OPf_STACKED)
343 else if (o->op_flags & OPf_SPECIAL)
358 case OA_UNOP_AUX: TAG;
362 warn("Devel::Size: Can't determine class of operator %s, assuming BASEOP\n",
363 PL_op_name[o->op_type]);
369 /* Figure out how much magic is attached to the SV and return the
372 magic_size(pTHX_ const SV * const thing, struct state *st) {
373 MAGIC *magic_pointer = SvMAGIC(thing);
375 /* Have we seen the magic pointer? (NULL has always been seen before) */
376 while (check_new(st, magic_pointer)) {
377 st->total_size += sizeof(MAGIC);
378 /* magic vtables aren't freed when magic is freed, so don't count them.
379 (They are static structures. Anything that assumes otherwise is buggy.)
384 sv_size(aTHX_ st, magic_pointer->mg_obj, TOTAL_SIZE_RECURSION);
385 if (magic_pointer->mg_len == HEf_SVKEY) {
386 sv_size(aTHX_ st, (SV *)magic_pointer->mg_ptr, TOTAL_SIZE_RECURSION);
388 #if defined(PERL_MAGIC_utf8) && defined (PERL_MAGIC_UTF8_CACHESIZE)
389 else if (magic_pointer->mg_type == PERL_MAGIC_utf8) {
390 if (check_new(st, magic_pointer->mg_ptr)) {
391 st->total_size += PERL_MAGIC_UTF8_CACHESIZE * 2 * sizeof(STRLEN);
395 else if (magic_pointer->mg_len > 0) {
396 if (check_new(st, magic_pointer->mg_ptr)) {
397 st->total_size += magic_pointer->mg_len;
401 /* Get the next in the chain */
402 magic_pointer = magic_pointer->mg_moremagic;
405 if (st->dangle_whine)
406 warn( "Devel::Size: Encountered bad magic at: %p\n", magic_pointer );
412 check_new_and_strlen(struct state *st, const char *const p) {
414 st->total_size += 1 + strlen(p);
418 regex_size(const REGEXP * const baseregex, struct state *st) {
419 if(!check_new(st, baseregex))
421 st->total_size += sizeof(REGEXP);
422 #if (PERL_VERSION < 11)
423 /* Note the size of the paren offset thing */
424 st->total_size += sizeof(I32) * baseregex->nparens * 2;
425 st->total_size += strlen(baseregex->precomp);
427 st->total_size += sizeof(struct regexp);
428 st->total_size += sizeof(I32) * SvANY(baseregex)->nparens * 2;
429 /*st->total_size += strlen(SvANY(baseregex)->subbeg);*/
431 if (st->go_yell && !st->regex_whine) {
432 carp("Devel::Size: Calculated sizes for compiled regexes are incompatible, and probably always will be");
438 op_size(pTHX_ const OP * const baseop, struct state *st)
442 if(!check_new(st, baseop))
445 op_size(aTHX_ baseop->op_next, st);
447 switch (cc_opclass(baseop)) {
448 case OPc_BASEOP: TAG;
449 st->total_size += sizeof(struct op);
452 st->total_size += sizeof(struct unop);
453 op_size(aTHX_ ((UNOP *)baseop)->op_first, st);
456 st->total_size += sizeof(struct binop);
457 op_size(aTHX_ ((BINOP *)baseop)->op_first, st);
458 op_size(aTHX_ ((BINOP *)baseop)->op_last, st);
461 st->total_size += sizeof(struct logop);
462 op_size(aTHX_ ((BINOP *)baseop)->op_first, st);
463 op_size(aTHX_ ((LOGOP *)baseop)->op_other, st);
466 case OPc_CONDOP: TAG;
467 st->total_size += sizeof(struct condop);
468 op_size(aTHX_ ((BINOP *)baseop)->op_first, st);
469 op_size(aTHX_ ((CONDOP *)baseop)->op_true, st);
470 op_size(aTHX_ ((CONDOP *)baseop)->op_false, st);
473 case OPc_LISTOP: TAG;
474 st->total_size += sizeof(struct listop);
475 op_size(aTHX_ ((LISTOP *)baseop)->op_first, st);
476 op_size(aTHX_ ((LISTOP *)baseop)->op_last, st);
479 st->total_size += sizeof(struct pmop);
480 op_size(aTHX_ ((PMOP *)baseop)->op_first, st);
481 op_size(aTHX_ ((PMOP *)baseop)->op_last, st);
482 #if PERL_VERSION < 9 || (PERL_VERSION == 9 && PERL_SUBVERSION < 5)
483 op_size(aTHX_ ((PMOP *)baseop)->op_pmreplroot, st);
484 op_size(aTHX_ ((PMOP *)baseop)->op_pmreplstart, st);
486 /* This is defined away in perl 5.8.x, but it is in there for
489 regex_size(PM_GETRE((PMOP *)baseop), st);
491 regex_size(((PMOP *)baseop)->op_pmregexp, st);
495 st->total_size += sizeof(struct pmop);
496 if (!(baseop->op_type == OP_AELEMFAST
497 && baseop->op_flags & OPf_SPECIAL)) {
498 /* not an OP_PADAV replacement */
499 sv_size(aTHX_ st, ((SVOP *)baseop)->op_sv, SOME_RECURSION);
504 st->total_size += sizeof(struct padop);
509 st->total_size += sizeof(struct gvop);
510 sv_size(aTHX_ st, ((GVOP *)baseop)->op_gv, SOME_RECURSION);
514 check_new_and_strlen(st, ((PVOP *)baseop)->op_pv);
517 st->total_size += sizeof(struct loop);
518 op_size(aTHX_ ((LOOP *)baseop)->op_first, st);
519 op_size(aTHX_ ((LOOP *)baseop)->op_last, st);
520 op_size(aTHX_ ((LOOP *)baseop)->op_redoop, st);
521 op_size(aTHX_ ((LOOP *)baseop)->op_nextop, st);
522 op_size(aTHX_ ((LOOP *)baseop)->op_lastop, st);
527 basecop = (COP *)baseop;
528 st->total_size += sizeof(struct cop);
530 /* Change 33656 by nicholas@mouse-mill on 2008/04/07 11:29:51
531 Eliminate cop_label from struct cop by storing a label as the first
532 entry in the hints hash. Most statements don't have labels, so this
533 will save memory. Not sure how much.
534 The check below will be incorrect fail on bleadperls
535 before 5.11 @33656, but later than 5.10, producing slightly too
536 small memory sizes on these Perls. */
537 #if (PERL_VERSION < 11)
538 check_new_and_strlen(st, basecop->cop_label);
541 check_new_and_strlen(st, basecop->cop_file);
542 #if PERL_VERSION < 17 || (PERL_VERSION == 17 && PERL_SUBVERSION == 0)
543 /* This pointer is owned by the COP, and freed with it. */
544 check_new_and_strlen(st, basecop->cop_stashpv);
546 /* A per-interpreter pointer for this stash is allocated in
548 if (check_new(st, PL_stashpad + basecop->cop_stashoff))
549 st->total_size += sizeof(PL_stashpad[basecop->cop_stashoff]);
552 sv_size(aTHX_ st, (SV *)basecop->cop_filegv, SOME_RECURSION);
558 case OPc_METHOP: TAG;
559 st->total_size += sizeof(struct methop);
560 if (baseop->op_type == OP_METHOD)
561 op_size(aTHX_ ((UNOP *)baseop)->op_first, st);
563 sv_size(aTHX_ st, cMETHOPx_meth(baseop), SOME_RECURSION);
564 #if PERL_VERSION*1000+PERL_SUBVERSION >= 21007
565 if (baseop->op_type == OP_METHOD_REDIR || baseop->op_type == OP_METHOD_REDIR_SUPER) {
566 SV *rclass = cMETHOPx_rclass(baseop);
567 if(SvTYPE(rclass) != SVt_PVHV)
568 sv_size(aTHX_ st, rclass, SOME_RECURSION);
574 case OPc_UNAUXOP: TAG;
575 st->total_size += sizeof(struct unop_aux) + sizeof(UNOP_AUX_item) * (cUNOP_AUXx(baseop)->op_aux[-1].uv+1);
576 op_size(aTHX_ ((UNOP *)baseop)->op_first, st);
577 if (baseop->op_type == OP_MULTIDEREF) {
578 UNOP_AUX_item *items = cUNOP_AUXx(baseop)->op_aux;
579 UV actions = items->uv;
583 switch (actions & MDEREF_ACTION_MASK) {
585 actions = (++items)->uv;
587 case MDEREF_HV_padhv_helem:
588 case MDEREF_HV_gvhv_helem:
589 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
590 case MDEREF_HV_padsv_vivify_rv2hv_helem:
592 case MDEREF_AV_padav_aelem:
593 case MDEREF_AV_gvav_aelem:
594 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
595 case MDEREF_AV_padsv_vivify_rv2av_aelem:
598 case MDEREF_HV_pop_rv2hv_helem:
599 case MDEREF_HV_vivify_rv2hv_helem:
601 case MDEREF_AV_pop_rv2av_aelem:
602 case MDEREF_AV_vivify_rv2av_aelem:
604 switch (actions & MDEREF_INDEX_MASK) {
605 case MDEREF_INDEX_none:
608 case MDEREF_INDEX_const:
612 SV *key = PAD_SVl(items->pad_offset);
616 sv_size(aTHX_ st, key, SOME_RECURSION);
619 case MDEREF_INDEX_padsv:
620 case MDEREF_INDEX_gvsv:
624 if (actions & MDEREF_FLAG_last)
632 actions >>= MDEREF_SHIFT;
642 if (st->dangle_whine)
643 warn( "Devel::Size: Encountered dangling pointer in opcode at: %p\n", baseop );
648 hek_size(pTHX_ struct state *st, HEK *hek, U32 shared)
650 /* Hash keys can be shared. Have we seen this before? */
651 if (!check_new(st, hek))
653 st->total_size += HEK_BASESIZE + hek->hek_len
655 + 1 /* No hash key flags prior to 5.8.0 */
661 #if PERL_VERSION < 10
662 st->total_size += sizeof(struct he);
664 st->total_size += STRUCT_OFFSET(struct shared_he, shared_he_hek);
670 #if PERL_VERSION < 8 || PERL_SUBVERSION < 9
675 # define MAYBE_PURIFY(normal, pure) (pure)
676 # define MAYBE_OFFSET(struct_name, member) 0
678 # define MAYBE_PURIFY(normal, pure) (normal)
679 # define MAYBE_OFFSET(struct_name, member) STRUCT_OFFSET(struct_name, member)
682 const U8 body_sizes[SVt_LAST] = {
685 MAYBE_PURIFY(sizeof(IV), sizeof(XPVIV)), /* SVt_IV */
686 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
687 sizeof(XRV), /* SVt_RV */
688 sizeof(XPV), /* SVt_PV */
689 sizeof(XPVIV), /* SVt_PVIV */
690 sizeof(XPVNV), /* SVt_PVNV */
691 sizeof(XPVMG), /* SVt_PVMG */
692 sizeof(XPVBM), /* SVt_PVBM */
693 sizeof(XPVLV), /* SVt_PVLV */
694 sizeof(XPVAV), /* SVt_PVAV */
695 sizeof(XPVHV), /* SVt_PVHV */
696 sizeof(XPVCV), /* SVt_PVCV */
697 sizeof(XPVGV), /* SVt_PVGV */
698 sizeof(XPVFM), /* SVt_PVFM */
699 sizeof(XPVIO) /* SVt_PVIO */
700 #elif PERL_VERSION == 10 && PERL_SUBVERSION == 0
704 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
706 MAYBE_PURIFY(sizeof(xpv_allocated), sizeof(XPV)), /* SVt_PV */
707 MAYBE_PURIFY(sizeof(xpviv_allocated), sizeof(XPVIV)),/* SVt_PVIV */
708 sizeof(XPVNV), /* SVt_PVNV */
709 sizeof(XPVMG), /* SVt_PVMG */
710 sizeof(XPVGV), /* SVt_PVGV */
711 sizeof(XPVLV), /* SVt_PVLV */
712 MAYBE_PURIFY(sizeof(xpvav_allocated), sizeof(XPVAV)),/* SVt_PVAV */
713 MAYBE_PURIFY(sizeof(xpvhv_allocated), sizeof(XPVHV)),/* SVt_PVHV */
714 MAYBE_PURIFY(sizeof(xpvcv_allocated), sizeof(XPVCV)),/* SVt_PVCV */
715 MAYBE_PURIFY(sizeof(xpvfm_allocated), sizeof(XPVFM)),/* SVt_PVFM */
716 sizeof(XPVIO), /* SVt_PVIO */
717 #elif PERL_VERSION == 10 && PERL_SUBVERSION == 1
721 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
723 sizeof(XPV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PV */
724 sizeof(XPVIV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PVIV */
725 sizeof(XPVNV), /* SVt_PVNV */
726 sizeof(XPVMG), /* SVt_PVMG */
727 sizeof(XPVGV), /* SVt_PVGV */
728 sizeof(XPVLV), /* SVt_PVLV */
729 sizeof(XPVAV) - MAYBE_OFFSET(XPVAV, xav_fill), /* SVt_PVAV */
730 sizeof(XPVHV) - MAYBE_OFFSET(XPVHV, xhv_fill), /* SVt_PVHV */
731 sizeof(XPVCV) - MAYBE_OFFSET(XPVCV, xpv_cur), /* SVt_PVCV */
732 sizeof(XPVFM) - MAYBE_OFFSET(XPVFM, xpv_cur), /* SVt_PVFM */
733 sizeof(XPVIO) /* SVt_PVIO */
734 #elif PERL_VERSION < 13
738 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
739 sizeof(XPV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PV */
740 sizeof(XPVIV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PVIV */
741 sizeof(XPVNV), /* SVt_PVNV */
742 sizeof(XPVMG), /* SVt_PVMG */
743 sizeof(regexp) - MAYBE_OFFSET(regexp, xpv_cur), /* SVt_REGEXP */
744 sizeof(XPVGV), /* SVt_PVGV */
745 sizeof(XPVLV), /* SVt_PVLV */
746 sizeof(XPVAV) - MAYBE_OFFSET(XPVAV, xav_fill), /* SVt_PVAV */
747 sizeof(XPVHV) - MAYBE_OFFSET(XPVHV, xhv_fill), /* SVt_PVHV */
748 sizeof(XPVCV) - MAYBE_OFFSET(XPVCV, xpv_cur), /* SVt_PVCV */
749 sizeof(XPVFM) - MAYBE_OFFSET(XPVFM, xpv_cur), /* SVt_PVFM */
750 sizeof(XPVIO) /* SVt_PVIO */
755 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
756 sizeof(XPV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PV */
757 sizeof(XPVIV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PVIV */
758 sizeof(XPVNV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PVNV */
759 sizeof(XPVMG), /* SVt_PVMG */
760 sizeof(regexp), /* SVt_REGEXP */
761 sizeof(XPVGV), /* SVt_PVGV */
762 sizeof(XPVLV), /* SVt_PVLV */
763 sizeof(XPVAV), /* SVt_PVAV */
764 sizeof(XPVHV), /* SVt_PVHV */
765 sizeof(XPVCV), /* SVt_PVCV */
766 sizeof(XPVFM), /* SVt_PVFM */
767 sizeof(XPVIO) /* SVt_PVIO */
771 #if PERL_COMBI_VERSION < 5008001
776 padlist_size(pTHX_ struct state *const st, const PADLIST * const padl,
779 #if PERL_VERSION*1000+PERL_SUBVERSION >= 21007
780 /* This is, as ever, excessively nosey with the implementation, and hence
783 const PADNAMELIST *pnl;
785 if (!check_new(st, padl))
787 st->total_size += sizeof(PADLIST);
789 st->total_size += sizeof(PADNAMELIST);
790 pnl = PadlistNAMES(padl);
791 st->total_size += pnl->xpadnl_max * sizeof(PADNAME *);
792 i = PadnamelistMAX(pnl) + 1;
794 const PADNAME *const pn =
795 PadnamelistARRAY(pnl)[i];
796 if (!pn || pn == &PL_padname_undef || pn == &PL_padname_const)
798 if (!check_new(st, pn))
800 st->total_size += STRUCT_OFFSET(struct padname_with_str, xpadn_str[0])
801 + PadnameLEN(pn) + 1;
804 i = PadlistMAX(padl) + 1;
805 st->total_size += sizeof(PAD*) * i;
807 sv_size(aTHX_ st, (SV*)PadlistARRAY(padl)[i], recurse);
809 #elif defined PadlistNAMES
812 if (!check_new(st, padl))
814 st->total_size += sizeof(PADLIST);
815 sv_size(aTHX_ st, (SV*)PadlistNAMES(padl), TOTAL_SIZE_RECURSION);
816 i = PadlistMAX(padl) + 1;
817 st->total_size += sizeof(PAD*) * i;
819 sv_size(aTHX_ st, (SV*)PadlistARRAY(padl)[i], recurse);
823 sv_size(aTHX_ st, (SV*)padl, recurse);
829 sv_size(pTHX_ struct state *const st, const SV * const orig_thing,
831 const SV *thing = orig_thing;
834 if(!check_new(st, thing))
837 type = SvTYPE(thing);
838 if (type > SVt_LAST) {
839 warn("Devel::Size: Unknown variable type: %d encountered\n", type);
842 st->total_size += sizeof(SV) + body_sizes[type];
844 if (SvMAGICAL(thing)) {
845 magic_size(aTHX_ thing, st);
849 #if (PERL_VERSION < 11)
850 /* Is it a reference? */
855 if(recurse && SvROK(thing))
856 sv_size(aTHX_ st, SvRV_const(thing), recurse);
860 /* Is there anything in the array? */
861 if (AvMAX(thing) != -1) {
862 /* an array with 10 slots has AvMax() set to 9 - te 2007-04-22 */
863 st->total_size += sizeof(SV *) * (AvMAX(thing) + 1);
864 dbg_printf(("total_size: %li AvMAX: %li av_len: $i\n", st->total_size, AvMAX(thing), av_len((AV*)thing)));
866 if (recurse >= TOTAL_SIZE_RECURSION) {
867 SSize_t i = AvFILLp(thing) + 1;
870 sv_size(aTHX_ st, AvARRAY(thing)[i], recurse);
873 /* Add in the bits on the other side of the beginning */
875 dbg_printf(("total_size %li, sizeof(SV *) %li, AvARRAY(thing) %li, AvALLOC(thing)%li , sizeof(ptr) %li \n",
876 st->total_size, sizeof(SV*), AvARRAY(thing), AvALLOC(thing), sizeof( thing )));
878 /* under Perl 5.8.8 64bit threading, AvARRAY(thing) was a pointer while AvALLOC was 0,
879 resulting in grossly overstated sized for arrays. Technically, this shouldn't happen... */
880 if (AvALLOC(thing) != 0) {
881 st->total_size += (sizeof(SV *) * (AvARRAY(thing) - AvALLOC(thing)));
883 #if (PERL_VERSION < 9)
884 /* Is there something hanging off the arylen element?
885 Post 5.9.something this is stored in magic, so will be found there,
886 and Perl_av_arylen_p() takes a non-const AV*, hence compilers rightly
887 complain about AvARYLEN() passing thing to it. */
888 sv_size(aTHX_ st, AvARYLEN(thing), recurse);
892 /* Now the array of buckets */
893 st->total_size += (sizeof(HE *) * (HvMAX(thing) + 1));
894 /* Now walk the bucket chain */
895 if (HvARRAY(thing)) {
898 for (cur_bucket = 0; cur_bucket <= HvMAX(thing); cur_bucket++) {
899 cur_entry = *(HvARRAY(thing) + cur_bucket);
901 st->total_size += sizeof(HE);
902 hek_size(aTHX_ st, cur_entry->hent_hek, HvSHAREKEYS(thing));
903 if (recurse >= TOTAL_SIZE_RECURSION)
904 sv_size(aTHX_ st, HeVAL(cur_entry), recurse);
905 cur_entry = cur_entry->hent_next;
911 /* This direct access is arguably "naughty": */
912 struct mro_meta *meta = HvAUX(thing)->xhv_mro_meta;
913 #if PERL_VERSION > 13 || PERL_SUBVERSION > 8
915 I32 count = HvAUX(thing)->xhv_name_count;
918 HEK **names = HvAUX(thing)->xhv_name_u.xhvnameu_names;
922 hek_size(aTHX_ st, names[count], 1);
927 hek_size(aTHX_ st, HvNAME_HEK(thing), 1);
930 st->total_size += sizeof(struct xpvhv_aux);
932 st->total_size += sizeof(struct mro_meta);
933 sv_size(aTHX_ st, (SV *)meta->mro_nextmethod, TOTAL_SIZE_RECURSION);
934 #if PERL_VERSION > 10 || (PERL_VERSION == 10 && PERL_SUBVERSION > 0)
935 sv_size(aTHX_ st, (SV *)meta->isa, TOTAL_SIZE_RECURSION);
937 #if PERL_VERSION > 10
938 sv_size(aTHX_ st, (SV *)meta->mro_linear_all, TOTAL_SIZE_RECURSION);
939 sv_size(aTHX_ st, meta->mro_linear_current, TOTAL_SIZE_RECURSION);
941 sv_size(aTHX_ st, (SV *)meta->mro_linear_dfs, TOTAL_SIZE_RECURSION);
942 sv_size(aTHX_ st, (SV *)meta->mro_linear_c3, TOTAL_SIZE_RECURSION);
947 check_new_and_strlen(st, HvNAME_get(thing));
953 if (PERL_VERSION*1000+PERL_SUBVERSION < 21006 || !CvISXSUB(thing))
954 padlist_size(aTHX_ st, CvPADLIST(thing), SOME_RECURSION);
955 sv_size(aTHX_ st, (SV *)CvOUTSIDE(thing), recurse);
957 if (st->go_yell && !st->fm_whine) {
958 carp("Devel::Size: Calculated sizes for FMs are incomplete");
964 sv_size(aTHX_ st, (SV *)CvSTASH(thing), SOME_RECURSION);
965 sv_size(aTHX_ st, (SV *)SvSTASH(thing), SOME_RECURSION);
966 sv_size(aTHX_ st, (SV *)CvGV(thing), SOME_RECURSION);
967 if (PERL_VERSION*1000+PERL_SUBVERSION < 21006 || !CvISXSUB(thing))
968 padlist_size(aTHX_ st, CvPADLIST(thing), SOME_RECURSION);
969 sv_size(aTHX_ st, (SV *)CvOUTSIDE(thing), recurse);
970 if (CvISXSUB(thing)) {
971 sv_size(aTHX_ st, cv_const_sv((CV *)thing), recurse);
972 } else if (CvROOT(thing)) {
973 op_size(aTHX_ CvSTART(thing), st);
974 op_size(aTHX_ CvROOT(thing), st);
979 /* Some embedded char pointers */
980 check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_top_name);
981 check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_fmt_name);
982 check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_bottom_name);
983 /* Throw the GVs on the list to be walked if they're not-null */
984 sv_size(aTHX_ st, (SV *)((XPVIO *) SvANY(thing))->xio_top_gv, recurse);
985 sv_size(aTHX_ st, (SV *)((XPVIO *) SvANY(thing))->xio_bottom_gv, recurse);
986 sv_size(aTHX_ st, (SV *)((XPVIO *) SvANY(thing))->xio_fmt_gv, recurse);
988 /* Only go trotting through the IO structures if they're really
989 trottable. If USE_PERLIO is defined we can do this. If
990 not... we can't, so we don't even try */
992 /* Dig into xio_ifp and xio_ofp here */
993 warn("Devel::Size: Can't size up perlio layers yet\n");
998 #if (PERL_VERSION < 9)
1003 if(isGV_with_GP(thing)) {
1005 hek_size(aTHX_ st, GvNAME_HEK(thing), 1);
1007 st->total_size += GvNAMELEN(thing);
1010 hek_size(aTHX_ st, GvFILE_HEK(thing), 1);
1011 #elif defined(GvFILE)
1012 # if !defined(USE_ITHREADS) || (PERL_VERSION > 8 || (PERL_VERSION == 8 && PERL_SUBVERSION > 8))
1013 /* With itreads, before 5.8.9, this can end up pointing to freed memory
1014 if the GV was created in an eval, as GvFILE() points to CopFILE(),
1015 and the relevant COP has been freed on scope cleanup after the eval.
1016 5.8.9 adds a binary compatible fudge that catches the vast majority
1017 of cases. 5.9.something added a proper fix, by converting the GP to
1018 use a shared hash key (porperly reference counted), instead of a
1019 char * (owned by who knows? possibly no-one now) */
1020 check_new_and_strlen(st, GvFILE(thing));
1023 /* Is there something hanging off the glob? */
1024 if (check_new(st, GvGP(thing))) {
1025 st->total_size += sizeof(GP);
1026 sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_sv), recurse);
1027 sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_form), recurse);
1028 sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_av), recurse);
1029 sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_hv), recurse);
1030 sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_egv), recurse);
1031 sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_cv), recurse);
1033 #if (PERL_VERSION >= 9)
1037 #if PERL_VERSION <= 8
1045 if(recurse && SvROK(thing))
1046 sv_size(aTHX_ st, SvRV_const(thing), recurse);
1047 else if (SvIsCOW_shared_hash(thing))
1048 hek_size(aTHX_ st, SvSHARED_HEK_FROM_PV(SvPVX(thing)), 1);
1050 st->total_size += SvLEN(thing);
1054 SvOOK_offset(thing, len);
1055 st->total_size += len;
1063 static struct state *
1069 Newxz(st, 1, struct state);
1071 if (NULL != (warn_flag = perl_get_sv("Devel::Size::warn", FALSE))) {
1072 st->dangle_whine = st->go_yell = SvIV(warn_flag) ? TRUE : FALSE;
1074 if (NULL != (warn_flag = perl_get_sv("Devel::Size::dangle", FALSE))) {
1075 st->dangle_whine = SvIV(warn_flag) ? TRUE : FALSE;
1077 check_new(st, &PL_sv_undef);
1078 check_new(st, &PL_sv_no);
1079 check_new(st, &PL_sv_yes);
1080 #if PERL_VERSION > 8 || (PERL_VERSION == 8 && PERL_SUBVERSION > 0)
1081 check_new(st, &PL_sv_placeholder);
1086 MODULE = Devel::Size PACKAGE = Devel::Size
1094 total_size = TOTAL_SIZE_RECURSION
1097 SV *thing = orig_thing;
1098 struct state *st = new_state(aTHX);
1100 /* If they passed us a reference then dereference it. This is the
1101 only way we can check the sizes of arrays and hashes */
1103 thing = SvRV(thing);
1106 sv_size(aTHX_ st, thing, ix);
1107 RETVAL = st->total_size;