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 */
225 cc_opclass(const OP * const o)
231 return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
233 if (o->op_type == OP_SASSIGN)
234 return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPc_UNOP : OPc_BINOP);
237 if (o->op_type == OP_GV || o->op_type == OP_GVSV || o->op_type == OP_AELEMFAST)
241 if ((o->op_type == OP_TRANS)) {
245 switch (PL_opargs[o->op_type] & OA_CLASS_MASK) {
277 #ifdef OA_PVOP_OR_SVOP
278 case OA_PVOP_OR_SVOP: TAG;
280 * Character translations (tr///) are usually a PVOP, keeping a
281 * pointer to a table of shorts used to look up translations.
282 * Under utf8, however, a simple table isn't practical; instead,
283 * the OP is an SVOP, and the SV is a reference to a swash
284 * (i.e., an RV pointing to an HV).
286 return (o->op_private & (OPpTRANS_TO_UTF|OPpTRANS_FROM_UTF))
287 ? OPc_SVOP : OPc_PVOP;
296 case OA_BASEOP_OR_UNOP: TAG;
298 * UNI(OP_foo) in toke.c returns token UNI or FUNC1 depending on
299 * whether parens were seen. perly.y uses OPf_SPECIAL to
300 * signal whether a BASEOP had empty parens or none.
301 * Some other UNOPs are created later, though, so the best
302 * test is OPf_KIDS, which is set in newUNOP.
304 return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
306 case OA_FILESTATOP: TAG;
308 * The file stat OPs are created via UNI(OP_foo) in toke.c but use
309 * the OPf_REF flag to distinguish between OP types instead of the
310 * usual OPf_SPECIAL flag. As usual, if OPf_KIDS is set, then we
311 * return OPc_UNOP so that walkoptree can find our children. If
312 * OPf_KIDS is not set then we check OPf_REF. Without OPf_REF set
313 * (no argument to the operator) it's an OP; with OPf_REF set it's
314 * an SVOP (and op_sv is the GV for the filehandle argument).
316 return ((o->op_flags & OPf_KIDS) ? OPc_UNOP :
318 (o->op_flags & OPf_REF) ? OPc_PADOP : OPc_BASEOP);
320 (o->op_flags & OPf_REF) ? OPc_SVOP : OPc_BASEOP);
322 case OA_LOOPEXOP: TAG;
324 * next, last, redo, dump and goto use OPf_SPECIAL to indicate that a
325 * label was omitted (in which case it's a BASEOP) or else a term was
326 * seen. In this last case, all except goto are definitely PVOP but
327 * goto is either a PVOP (with an ordinary constant label), an UNOP
328 * with OPf_STACKED (with a non-constant non-sub) or an UNOP for
329 * OP_REFGEN (with goto &sub) in which case OPf_STACKED also seems to
332 if (o->op_flags & OPf_STACKED)
334 else if (o->op_flags & OPf_SPECIAL)
349 warn("Devel::Size: Can't determine class of operator %s, assuming BASEOP\n",
350 PL_op_name[o->op_type]);
356 /* Figure out how much magic is attached to the SV and return the
359 magic_size(pTHX_ const SV * const thing, struct state *st) {
360 MAGIC *magic_pointer = SvMAGIC(thing);
362 /* Have we seen the magic pointer? (NULL has always been seen before) */
363 while (check_new(st, magic_pointer)) {
364 st->total_size += sizeof(MAGIC);
365 /* magic vtables aren't freed when magic is freed, so don't count them.
366 (They are static structures. Anything that assumes otherwise is buggy.)
371 sv_size(aTHX_ st, magic_pointer->mg_obj, TOTAL_SIZE_RECURSION);
372 if (magic_pointer->mg_len == HEf_SVKEY) {
373 sv_size(aTHX_ st, (SV *)magic_pointer->mg_ptr, TOTAL_SIZE_RECURSION);
375 #if defined(PERL_MAGIC_utf8) && defined (PERL_MAGIC_UTF8_CACHESIZE)
376 else if (magic_pointer->mg_type == PERL_MAGIC_utf8) {
377 if (check_new(st, magic_pointer->mg_ptr)) {
378 st->total_size += PERL_MAGIC_UTF8_CACHESIZE * 2 * sizeof(STRLEN);
382 else if (magic_pointer->mg_len > 0) {
383 if (check_new(st, magic_pointer->mg_ptr)) {
384 st->total_size += magic_pointer->mg_len;
388 /* Get the next in the chain */
389 magic_pointer = magic_pointer->mg_moremagic;
392 if (st->dangle_whine)
393 warn( "Devel::Size: Encountered bad magic at: %p\n", magic_pointer );
399 check_new_and_strlen(struct state *st, const char *const p) {
401 st->total_size += 1 + strlen(p);
405 regex_size(const REGEXP * const baseregex, struct state *st) {
406 if(!check_new(st, baseregex))
408 st->total_size += sizeof(REGEXP);
409 #if (PERL_VERSION < 11)
410 /* Note the size of the paren offset thing */
411 st->total_size += sizeof(I32) * baseregex->nparens * 2;
412 st->total_size += strlen(baseregex->precomp);
414 st->total_size += sizeof(struct regexp);
415 st->total_size += sizeof(I32) * SvANY(baseregex)->nparens * 2;
416 /*st->total_size += strlen(SvANY(baseregex)->subbeg);*/
418 if (st->go_yell && !st->regex_whine) {
419 carp("Devel::Size: Calculated sizes for compiled regexes are incompatible, and probably always will be");
425 op_size(pTHX_ const OP * const baseop, struct state *st)
429 if(!check_new(st, baseop))
432 op_size(aTHX_ baseop->op_next, st);
434 switch (cc_opclass(baseop)) {
435 case OPc_BASEOP: TAG;
436 st->total_size += sizeof(struct op);
439 st->total_size += sizeof(struct unop);
440 op_size(aTHX_ ((UNOP *)baseop)->op_first, st);
443 st->total_size += sizeof(struct binop);
444 op_size(aTHX_ ((BINOP *)baseop)->op_first, st);
445 op_size(aTHX_ ((BINOP *)baseop)->op_last, st);
448 st->total_size += sizeof(struct logop);
449 op_size(aTHX_ ((BINOP *)baseop)->op_first, st);
450 op_size(aTHX_ ((LOGOP *)baseop)->op_other, st);
453 case OPc_CONDOP: TAG;
454 st->total_size += sizeof(struct condop);
455 op_size(aTHX_ ((BINOP *)baseop)->op_first, st);
456 op_size(aTHX_ ((CONDOP *)baseop)->op_true, st);
457 op_size(aTHX_ ((CONDOP *)baseop)->op_false, st);
460 case OPc_LISTOP: TAG;
461 st->total_size += sizeof(struct listop);
462 op_size(aTHX_ ((LISTOP *)baseop)->op_first, st);
463 op_size(aTHX_ ((LISTOP *)baseop)->op_last, st);
466 st->total_size += sizeof(struct pmop);
467 op_size(aTHX_ ((PMOP *)baseop)->op_first, st);
468 op_size(aTHX_ ((PMOP *)baseop)->op_last, st);
469 #if PERL_VERSION < 9 || (PERL_VERSION == 9 && PERL_SUBVERSION < 5)
470 op_size(aTHX_ ((PMOP *)baseop)->op_pmreplroot, st);
471 op_size(aTHX_ ((PMOP *)baseop)->op_pmreplstart, st);
473 /* This is defined away in perl 5.8.x, but it is in there for
476 regex_size(PM_GETRE((PMOP *)baseop), st);
478 regex_size(((PMOP *)baseop)->op_pmregexp, st);
482 st->total_size += sizeof(struct pmop);
483 if (!(baseop->op_type == OP_AELEMFAST
484 && baseop->op_flags & OPf_SPECIAL)) {
485 /* not an OP_PADAV replacement */
486 sv_size(aTHX_ st, ((SVOP *)baseop)->op_sv, SOME_RECURSION);
491 st->total_size += sizeof(struct padop);
496 st->total_size += sizeof(struct gvop);
497 sv_size(aTHX_ st, ((GVOP *)baseop)->op_gv, SOME_RECURSION);
501 check_new_and_strlen(st, ((PVOP *)baseop)->op_pv);
504 st->total_size += sizeof(struct loop);
505 op_size(aTHX_ ((LOOP *)baseop)->op_first, st);
506 op_size(aTHX_ ((LOOP *)baseop)->op_last, st);
507 op_size(aTHX_ ((LOOP *)baseop)->op_redoop, st);
508 op_size(aTHX_ ((LOOP *)baseop)->op_nextop, st);
509 op_size(aTHX_ ((LOOP *)baseop)->op_lastop, st);
514 basecop = (COP *)baseop;
515 st->total_size += sizeof(struct cop);
517 /* Change 33656 by nicholas@mouse-mill on 2008/04/07 11:29:51
518 Eliminate cop_label from struct cop by storing a label as the first
519 entry in the hints hash. Most statements don't have labels, so this
520 will save memory. Not sure how much.
521 The check below will be incorrect fail on bleadperls
522 before 5.11 @33656, but later than 5.10, producing slightly too
523 small memory sizes on these Perls. */
524 #if (PERL_VERSION < 11)
525 check_new_and_strlen(st, basecop->cop_label);
528 check_new_and_strlen(st, basecop->cop_file);
529 #if PERL_VERSION < 17 || (PERL_VERSION == 17 && PERL_SUBVERSION == 0)
530 /* This pointer is owned by the COP, and freed with it. */
531 check_new_and_strlen(st, basecop->cop_stashpv);
533 /* A per-interpreter pointer for this stash is allocated in
535 if (check_new(st, PL_stashpad + basecop->cop_stashoff))
536 st->total_size += sizeof(PL_stashpad[basecop->cop_stashoff]);
539 sv_size(aTHX_ st, (SV *)basecop->cop_filegv, SOME_RECURSION);
545 case OPc_METHOP: TAG;
546 st->total_size += sizeof(struct methop);
547 if (baseop->op_type != OP_METHOD)
548 sv_size(aTHX_ st, cMETHOPx_meth(baseop), SOME_RECURSION);
549 #if PERL_VERSION*1000+PERL_SUBVERSION >= 21007
550 if (baseop->op_type == OP_METHOD_REDIR || baseop->op_type == OP_METHOD_REDIR_SUPER) {
551 SV *rclass = cMETHOPx_rclass(baseop);
552 if(SvTYPE(rclass) != SVt_PVHV)
553 sv_size(aTHX_ st, rclass, SOME_RECURSION);
563 if (st->dangle_whine)
564 warn( "Devel::Size: Encountered dangling pointer in opcode at: %p\n", baseop );
569 hek_size(pTHX_ struct state *st, HEK *hek, U32 shared)
571 /* Hash keys can be shared. Have we seen this before? */
572 if (!check_new(st, hek))
574 st->total_size += HEK_BASESIZE + hek->hek_len
576 + 1 /* No hash key flags prior to 5.8.0 */
582 #if PERL_VERSION < 10
583 st->total_size += sizeof(struct he);
585 st->total_size += STRUCT_OFFSET(struct shared_he, shared_he_hek);
591 #if PERL_VERSION < 8 || PERL_SUBVERSION < 9
596 # define MAYBE_PURIFY(normal, pure) (pure)
597 # define MAYBE_OFFSET(struct_name, member) 0
599 # define MAYBE_PURIFY(normal, pure) (normal)
600 # define MAYBE_OFFSET(struct_name, member) STRUCT_OFFSET(struct_name, member)
603 const U8 body_sizes[SVt_LAST] = {
606 MAYBE_PURIFY(sizeof(IV), sizeof(XPVIV)), /* SVt_IV */
607 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
608 sizeof(XRV), /* SVt_RV */
609 sizeof(XPV), /* SVt_PV */
610 sizeof(XPVIV), /* SVt_PVIV */
611 sizeof(XPVNV), /* SVt_PVNV */
612 sizeof(XPVMG), /* SVt_PVMG */
613 sizeof(XPVBM), /* SVt_PVBM */
614 sizeof(XPVLV), /* SVt_PVLV */
615 sizeof(XPVAV), /* SVt_PVAV */
616 sizeof(XPVHV), /* SVt_PVHV */
617 sizeof(XPVCV), /* SVt_PVCV */
618 sizeof(XPVGV), /* SVt_PVGV */
619 sizeof(XPVFM), /* SVt_PVFM */
620 sizeof(XPVIO) /* SVt_PVIO */
621 #elif PERL_VERSION == 10 && PERL_SUBVERSION == 0
625 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
627 MAYBE_PURIFY(sizeof(xpv_allocated), sizeof(XPV)), /* SVt_PV */
628 MAYBE_PURIFY(sizeof(xpviv_allocated), sizeof(XPVIV)),/* SVt_PVIV */
629 sizeof(XPVNV), /* SVt_PVNV */
630 sizeof(XPVMG), /* SVt_PVMG */
631 sizeof(XPVGV), /* SVt_PVGV */
632 sizeof(XPVLV), /* SVt_PVLV */
633 MAYBE_PURIFY(sizeof(xpvav_allocated), sizeof(XPVAV)),/* SVt_PVAV */
634 MAYBE_PURIFY(sizeof(xpvhv_allocated), sizeof(XPVHV)),/* SVt_PVHV */
635 MAYBE_PURIFY(sizeof(xpvcv_allocated), sizeof(XPVCV)),/* SVt_PVCV */
636 MAYBE_PURIFY(sizeof(xpvfm_allocated), sizeof(XPVFM)),/* SVt_PVFM */
637 sizeof(XPVIO), /* SVt_PVIO */
638 #elif PERL_VERSION == 10 && PERL_SUBVERSION == 1
642 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
644 sizeof(XPV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PV */
645 sizeof(XPVIV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PVIV */
646 sizeof(XPVNV), /* SVt_PVNV */
647 sizeof(XPVMG), /* SVt_PVMG */
648 sizeof(XPVGV), /* SVt_PVGV */
649 sizeof(XPVLV), /* SVt_PVLV */
650 sizeof(XPVAV) - MAYBE_OFFSET(XPVAV, xav_fill), /* SVt_PVAV */
651 sizeof(XPVHV) - MAYBE_OFFSET(XPVHV, xhv_fill), /* SVt_PVHV */
652 sizeof(XPVCV) - MAYBE_OFFSET(XPVCV, xpv_cur), /* SVt_PVCV */
653 sizeof(XPVFM) - MAYBE_OFFSET(XPVFM, xpv_cur), /* SVt_PVFM */
654 sizeof(XPVIO) /* SVt_PVIO */
655 #elif PERL_VERSION < 13
659 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
660 sizeof(XPV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PV */
661 sizeof(XPVIV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PVIV */
662 sizeof(XPVNV), /* SVt_PVNV */
663 sizeof(XPVMG), /* SVt_PVMG */
664 sizeof(regexp) - MAYBE_OFFSET(regexp, xpv_cur), /* SVt_REGEXP */
665 sizeof(XPVGV), /* SVt_PVGV */
666 sizeof(XPVLV), /* SVt_PVLV */
667 sizeof(XPVAV) - MAYBE_OFFSET(XPVAV, xav_fill), /* SVt_PVAV */
668 sizeof(XPVHV) - MAYBE_OFFSET(XPVHV, xhv_fill), /* SVt_PVHV */
669 sizeof(XPVCV) - MAYBE_OFFSET(XPVCV, xpv_cur), /* SVt_PVCV */
670 sizeof(XPVFM) - MAYBE_OFFSET(XPVFM, xpv_cur), /* SVt_PVFM */
671 sizeof(XPVIO) /* SVt_PVIO */
676 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
677 sizeof(XPV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PV */
678 sizeof(XPVIV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PVIV */
679 sizeof(XPVNV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PVNV */
680 sizeof(XPVMG), /* SVt_PVMG */
681 sizeof(regexp), /* SVt_REGEXP */
682 sizeof(XPVGV), /* SVt_PVGV */
683 sizeof(XPVLV), /* SVt_PVLV */
684 sizeof(XPVAV), /* SVt_PVAV */
685 sizeof(XPVHV), /* SVt_PVHV */
686 sizeof(XPVCV), /* SVt_PVCV */
687 sizeof(XPVFM), /* SVt_PVFM */
688 sizeof(XPVIO) /* SVt_PVIO */
694 padlist_size(pTHX_ struct state *const st, const PADLIST * const padl,
697 if (!check_new(st, padl))
699 /* This relies on PADNAMELIST and PAD being typedefed to AV. If that
700 ever changes, this code will need an update. */
701 st->total_size += sizeof(PADLIST);
702 sv_size(aTHX_ st, (SV*)PadlistNAMES(padl), recurse);
703 i = PadlistMAX(padl) + 1;
704 st->total_size += sizeof(PAD*) * i;
706 sv_size(aTHX_ st, (SV*)PadlistARRAY(padl)[i], recurse);
710 padlist_size(pTHX_ struct state *const st, const AV * const padl,
712 sv_size(aTHX_ st, (SV*)padl, recurse);
717 sv_size(pTHX_ struct state *const st, const SV * const orig_thing,
719 const SV *thing = orig_thing;
722 if(!check_new(st, thing))
725 type = SvTYPE(thing);
726 if (type > SVt_LAST) {
727 warn("Devel::Size: Unknown variable type: %d encountered\n", type);
730 st->total_size += sizeof(SV) + body_sizes[type];
732 if (SvMAGICAL(thing)) {
733 magic_size(aTHX_ thing, st);
737 #if (PERL_VERSION < 11)
738 /* Is it a reference? */
743 if(recurse && SvROK(thing))
744 sv_size(aTHX_ st, SvRV_const(thing), recurse);
748 /* Is there anything in the array? */
749 if (AvMAX(thing) != -1) {
750 /* an array with 10 slots has AvMax() set to 9 - te 2007-04-22 */
751 st->total_size += sizeof(SV *) * (AvMAX(thing) + 1);
752 dbg_printf(("total_size: %li AvMAX: %li av_len: $i\n", st->total_size, AvMAX(thing), av_len((AV*)thing)));
754 if (recurse >= TOTAL_SIZE_RECURSION) {
755 SSize_t i = AvFILLp(thing) + 1;
758 sv_size(aTHX_ st, AvARRAY(thing)[i], recurse);
761 /* Add in the bits on the other side of the beginning */
763 dbg_printf(("total_size %li, sizeof(SV *) %li, AvARRAY(thing) %li, AvALLOC(thing)%li , sizeof(ptr) %li \n",
764 st->total_size, sizeof(SV*), AvARRAY(thing), AvALLOC(thing), sizeof( thing )));
766 /* under Perl 5.8.8 64bit threading, AvARRAY(thing) was a pointer while AvALLOC was 0,
767 resulting in grossly overstated sized for arrays. Technically, this shouldn't happen... */
768 if (AvALLOC(thing) != 0) {
769 st->total_size += (sizeof(SV *) * (AvARRAY(thing) - AvALLOC(thing)));
771 #if (PERL_VERSION < 9)
772 /* Is there something hanging off the arylen element?
773 Post 5.9.something this is stored in magic, so will be found there,
774 and Perl_av_arylen_p() takes a non-const AV*, hence compilers rightly
775 complain about AvARYLEN() passing thing to it. */
776 sv_size(aTHX_ st, AvARYLEN(thing), recurse);
780 /* Now the array of buckets */
781 st->total_size += (sizeof(HE *) * (HvMAX(thing) + 1));
782 /* Now walk the bucket chain */
783 if (HvARRAY(thing)) {
786 for (cur_bucket = 0; cur_bucket <= HvMAX(thing); cur_bucket++) {
787 cur_entry = *(HvARRAY(thing) + cur_bucket);
789 st->total_size += sizeof(HE);
790 hek_size(aTHX_ st, cur_entry->hent_hek, HvSHAREKEYS(thing));
791 if (recurse >= TOTAL_SIZE_RECURSION)
792 sv_size(aTHX_ st, HeVAL(cur_entry), recurse);
793 cur_entry = cur_entry->hent_next;
799 /* This direct access is arguably "naughty": */
800 struct mro_meta *meta = HvAUX(thing)->xhv_mro_meta;
801 #if PERL_VERSION > 13 || PERL_SUBVERSION > 8
803 I32 count = HvAUX(thing)->xhv_name_count;
806 HEK **names = HvAUX(thing)->xhv_name_u.xhvnameu_names;
810 hek_size(aTHX_ st, names[count], 1);
815 hek_size(aTHX_ st, HvNAME_HEK(thing), 1);
818 st->total_size += sizeof(struct xpvhv_aux);
820 st->total_size += sizeof(struct mro_meta);
821 sv_size(aTHX_ st, (SV *)meta->mro_nextmethod, TOTAL_SIZE_RECURSION);
822 #if PERL_VERSION > 10 || (PERL_VERSION == 10 && PERL_SUBVERSION > 0)
823 sv_size(aTHX_ st, (SV *)meta->isa, TOTAL_SIZE_RECURSION);
825 #if PERL_VERSION > 10
826 sv_size(aTHX_ st, (SV *)meta->mro_linear_all, TOTAL_SIZE_RECURSION);
827 sv_size(aTHX_ st, meta->mro_linear_current, TOTAL_SIZE_RECURSION);
829 sv_size(aTHX_ st, (SV *)meta->mro_linear_dfs, TOTAL_SIZE_RECURSION);
830 sv_size(aTHX_ st, (SV *)meta->mro_linear_c3, TOTAL_SIZE_RECURSION);
835 check_new_and_strlen(st, HvNAME_get(thing));
841 padlist_size(aTHX_ st, CvPADLIST(thing), SOME_RECURSION);
842 sv_size(aTHX_ st, (SV *)CvOUTSIDE(thing), recurse);
844 if (st->go_yell && !st->fm_whine) {
845 carp("Devel::Size: Calculated sizes for FMs are incomplete");
851 sv_size(aTHX_ st, (SV *)CvSTASH(thing), SOME_RECURSION);
852 sv_size(aTHX_ st, (SV *)SvSTASH(thing), SOME_RECURSION);
853 sv_size(aTHX_ st, (SV *)CvGV(thing), SOME_RECURSION);
854 padlist_size(aTHX_ st, CvPADLIST(thing), SOME_RECURSION);
855 sv_size(aTHX_ st, (SV *)CvOUTSIDE(thing), recurse);
856 if (CvISXSUB(thing)) {
857 sv_size(aTHX_ st, cv_const_sv((CV *)thing), recurse);
858 } else if (CvROOT(thing)) {
859 op_size(aTHX_ CvSTART(thing), st);
860 op_size(aTHX_ CvROOT(thing), st);
865 /* Some embedded char pointers */
866 check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_top_name);
867 check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_fmt_name);
868 check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_bottom_name);
869 /* Throw the GVs on the list to be walked if they're not-null */
870 sv_size(aTHX_ st, (SV *)((XPVIO *) SvANY(thing))->xio_top_gv, recurse);
871 sv_size(aTHX_ st, (SV *)((XPVIO *) SvANY(thing))->xio_bottom_gv, recurse);
872 sv_size(aTHX_ st, (SV *)((XPVIO *) SvANY(thing))->xio_fmt_gv, recurse);
874 /* Only go trotting through the IO structures if they're really
875 trottable. If USE_PERLIO is defined we can do this. If
876 not... we can't, so we don't even try */
878 /* Dig into xio_ifp and xio_ofp here */
879 warn("Devel::Size: Can't size up perlio layers yet\n");
884 #if (PERL_VERSION < 9)
889 if(isGV_with_GP(thing)) {
891 hek_size(aTHX_ st, GvNAME_HEK(thing), 1);
893 st->total_size += GvNAMELEN(thing);
896 hek_size(aTHX_ st, GvFILE_HEK(thing), 1);
897 #elif defined(GvFILE)
898 # if !defined(USE_ITHREADS) || (PERL_VERSION > 8 || (PERL_VERSION == 8 && PERL_SUBVERSION > 8))
899 /* With itreads, before 5.8.9, this can end up pointing to freed memory
900 if the GV was created in an eval, as GvFILE() points to CopFILE(),
901 and the relevant COP has been freed on scope cleanup after the eval.
902 5.8.9 adds a binary compatible fudge that catches the vast majority
903 of cases. 5.9.something added a proper fix, by converting the GP to
904 use a shared hash key (porperly reference counted), instead of a
905 char * (owned by who knows? possibly no-one now) */
906 check_new_and_strlen(st, GvFILE(thing));
909 /* Is there something hanging off the glob? */
910 if (check_new(st, GvGP(thing))) {
911 st->total_size += sizeof(GP);
912 sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_sv), recurse);
913 sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_form), recurse);
914 sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_av), recurse);
915 sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_hv), recurse);
916 sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_egv), recurse);
917 sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_cv), recurse);
919 #if (PERL_VERSION >= 9)
923 #if PERL_VERSION <= 8
931 if(recurse && SvROK(thing))
932 sv_size(aTHX_ st, SvRV_const(thing), recurse);
933 else if (SvIsCOW_shared_hash(thing))
934 hek_size(aTHX_ st, SvSHARED_HEK_FROM_PV(SvPVX(thing)), 1);
936 st->total_size += SvLEN(thing);
940 SvOOK_offset(thing, len);
941 st->total_size += len;
949 static struct state *
955 Newxz(st, 1, struct state);
957 if (NULL != (warn_flag = perl_get_sv("Devel::Size::warn", FALSE))) {
958 st->dangle_whine = st->go_yell = SvIV(warn_flag) ? TRUE : FALSE;
960 if (NULL != (warn_flag = perl_get_sv("Devel::Size::dangle", FALSE))) {
961 st->dangle_whine = SvIV(warn_flag) ? TRUE : FALSE;
963 check_new(st, &PL_sv_undef);
964 check_new(st, &PL_sv_no);
965 check_new(st, &PL_sv_yes);
966 #if PERL_VERSION > 8 || (PERL_VERSION == 8 && PERL_SUBVERSION > 0)
967 check_new(st, &PL_sv_placeholder);
972 MODULE = Devel::Size PACKAGE = Devel::Size
980 total_size = TOTAL_SIZE_RECURSION
983 SV *thing = orig_thing;
984 struct state *st = new_state(aTHX);
986 /* If they passed us a reference then dereference it. This is the
987 only way we can check the sizes of arrays and hashes */
992 sv_size(aTHX_ st, thing, ix);
993 RETVAL = st->total_size;