1 #define PERL_NO_GET_CONTEXT
8 /* Not yet in ppport.h */
10 # define CvISXSUB(cv) (CvXSUB(cv) ? TRUE : FALSE)
14 /* "structured exception" handling is a Microsoft extension to C and C++.
15 It's *not* C++ exception handling - C++ exception handling can't capture
16 SEGVs and suchlike, whereas this can. There's no known analagous
17 functionality on other platforms. */
19 # define TRY_TO_CATCH_SEGV __try
20 # define CAUGHT_EXCEPTION __except(EXCEPTION EXCEPTION_EXECUTE_HANDLER)
22 # define TRY_TO_CATCH_SEGV if(1)
23 # define CAUGHT_EXCEPTION else
27 # define __attribute__(x)
30 #if 0 && defined(DEBUGGING)
31 #define dbg_printf(x) printf x
36 #define TAG /* printf( "# %s(%d)\n", __FILE__, __LINE__ ) */
39 /* The idea is to have a tree structure to store 1 bit per possible pointer
40 address. The lowest 16 bits are stored in a block of 8092 bytes.
41 The blocks are in a 256-way tree, indexed by the reset of the pointer.
42 This can cope with 32 and 64 bit pointers, and any address space layout,
43 without excessive memory needs. The assumption is that your CPU cache
44 works :-) (And that we're not going to bust it) */
46 #define ALIGN_BITS ( sizeof(void*) >> 1 )
48 #define LEAF_BITS (16 - BYTE_BITS)
49 #define LEAF_MASK 0x1FFF
56 /* My hunch (not measured) is that for most architectures pointers will
57 start with 0 bits, hence the start of this array will be hot, and the
58 end unused. So put the flags next to the hot end. */
63 Checks to see if thing is in the bitstring.
64 Returns true or false, and
65 notes thing in the segmented bitstring.
68 check_new(struct state *st, const void *const p) {
69 unsigned int bits = 8 * sizeof(void*);
70 const size_t raw_p = PTR2nat(p);
71 /* This effectively rotates the value right by the number of low always-0
72 bits in an aligned pointer. The assmption is that most (if not all)
73 pointers are aligned, and these will be in the same chain of nodes
74 (and hence hot in the cache) but we can still deal with any unaligned
77 = (raw_p >> ALIGN_BITS) | (raw_p << (bits - BYTE_BITS));
78 const U8 this_bit = 1 << (cooked_p & 0x7);
85 if (NULL == p || NULL == st) return FALSE;
86 tv_p = (void **) (st->tracking);
88 const char c = *(const char *)p;
92 warn( "Devel::Size: Encountered invalid pointer: %p\n", p );
98 /* bits now 24 (32 bit pointers) or 56 (64 bit pointers) */
100 /* First level is always present. */
102 i = (unsigned int)((cooked_p >> bits) & 0xFF);
104 Newxz(tv_p[i], 256, void *);
105 tv_p = (void **)(tv_p[i]);
107 } while (bits > LEAF_BITS + BYTE_BITS);
108 /* bits now 16 always */
110 leaf_p = (U8 **)tv_p;
111 i = (unsigned int)((cooked_p >> bits) & 0xFF);
113 Newxz(leaf_p[i], 1 << LEAF_BITS, U8);
118 i = (unsigned int)((cooked_p >> BYTE_BITS) & LEAF_MASK);
120 if(leaf[i] & this_bit)
128 free_tracking_at(void **tv, int level)
136 free_tracking_at(tv[i], level);
150 free_state(struct state *st)
152 const int top_level = (sizeof(void *) * 8 - LEAF_BITS - BYTE_BITS) / 8;
153 free_tracking_at((void **)st->tracking, top_level);
157 static UV thing_size(pTHX_ const SV *const, struct state *);
174 cc_opclass(const OP * const o)
180 return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
182 if (o->op_type == OP_SASSIGN)
183 return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPc_UNOP : OPc_BINOP);
186 if (o->op_type == OP_GV || o->op_type == OP_GVSV || o->op_type == OP_AELEMFAST)
190 if ((o->op_type == OP_TRANS)) {
194 switch (PL_opargs[o->op_type] & OA_CLASS_MASK) {
219 case OA_PVOP_OR_SVOP: TAG;
221 * Character translations (tr///) are usually a PVOP, keeping a
222 * pointer to a table of shorts used to look up translations.
223 * Under utf8, however, a simple table isn't practical; instead,
224 * the OP is an SVOP, and the SV is a reference to a swash
225 * (i.e., an RV pointing to an HV).
227 return (o->op_private & (OPpTRANS_TO_UTF|OPpTRANS_FROM_UTF))
228 ? OPc_SVOP : OPc_PVOP;
236 case OA_BASEOP_OR_UNOP: TAG;
238 * UNI(OP_foo) in toke.c returns token UNI or FUNC1 depending on
239 * whether parens were seen. perly.y uses OPf_SPECIAL to
240 * signal whether a BASEOP had empty parens or none.
241 * Some other UNOPs are created later, though, so the best
242 * test is OPf_KIDS, which is set in newUNOP.
244 return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
246 case OA_FILESTATOP: TAG;
248 * The file stat OPs are created via UNI(OP_foo) in toke.c but use
249 * the OPf_REF flag to distinguish between OP types instead of the
250 * usual OPf_SPECIAL flag. As usual, if OPf_KIDS is set, then we
251 * return OPc_UNOP so that walkoptree can find our children. If
252 * OPf_KIDS is not set then we check OPf_REF. Without OPf_REF set
253 * (no argument to the operator) it's an OP; with OPf_REF set it's
254 * an SVOP (and op_sv is the GV for the filehandle argument).
256 return ((o->op_flags & OPf_KIDS) ? OPc_UNOP :
258 (o->op_flags & OPf_REF) ? OPc_PADOP : OPc_BASEOP);
260 (o->op_flags & OPf_REF) ? OPc_SVOP : OPc_BASEOP);
262 case OA_LOOPEXOP: TAG;
264 * next, last, redo, dump and goto use OPf_SPECIAL to indicate that a
265 * label was omitted (in which case it's a BASEOP) or else a term was
266 * seen. In this last case, all except goto are definitely PVOP but
267 * goto is either a PVOP (with an ordinary constant label), an UNOP
268 * with OPf_STACKED (with a non-constant non-sub) or an UNOP for
269 * OP_REFGEN (with goto &sub) in which case OPf_STACKED also seems to
272 if (o->op_flags & OPf_STACKED)
274 else if (o->op_flags & OPf_SPECIAL)
279 warn("Devel::Size: Can't determine class of operator %s, assuming BASEOP\n",
280 PL_op_name[o->op_type]);
291 /* Figure out how much magic is attached to the SV and return the
293 IV magic_size(const SV * const thing, struct state *st) {
295 MAGIC *magic_pointer;
298 if (!SvMAGIC(thing)) {
303 /* Get the base magic pointer */
304 magic_pointer = SvMAGIC(thing);
306 /* Have we seen the magic pointer? */
307 while (magic_pointer && check_new(st, magic_pointer)) {
308 total_size += sizeof(MAGIC);
311 /* Have we seen the magic vtable? */
312 if (magic_pointer->mg_virtual &&
313 check_new(st, magic_pointer->mg_virtual)) {
314 total_size += sizeof(MGVTBL);
317 /* Get the next in the chain */
318 magic_pointer = magic_pointer->mg_moremagic;
321 if (st->dangle_whine)
322 warn( "Devel::Size: Encountered bad magic at: %p\n", magic_pointer );
328 UV regex_size(const REGEXP * const baseregex, struct state *st) {
331 total_size += sizeof(REGEXP);
332 #if (PERL_VERSION < 11)
333 /* Note the size of the paren offset thing */
334 total_size += sizeof(I32) * baseregex->nparens * 2;
335 total_size += strlen(baseregex->precomp);
337 total_size += sizeof(struct regexp);
338 total_size += sizeof(I32) * SvANY(baseregex)->nparens * 2;
339 /*total_size += strlen(SvANY(baseregex)->subbeg);*/
341 if (st->go_yell && !st->regex_whine) {
342 carp("Devel::Size: Calculated sizes for compiled regexes are incompatible, and probably always will be");
350 op_size(pTHX_ const OP * const baseop, struct state *st) {
354 if (check_new(st, baseop->op_next)) {
355 total_size += op_size(aTHX_ baseop->op_next, st);
358 switch (cc_opclass(baseop)) {
359 case OPc_BASEOP: TAG;
360 total_size += sizeof(struct op);
363 total_size += sizeof(struct unop);
364 if (check_new(st, cUNOPx(baseop)->op_first)) {
365 total_size += op_size(aTHX_ cUNOPx(baseop)->op_first, st);
369 total_size += sizeof(struct binop);
370 if (check_new(st, cBINOPx(baseop)->op_first)) {
371 total_size += op_size(aTHX_ cBINOPx(baseop)->op_first, st);
373 if (check_new(st, cBINOPx(baseop)->op_last)) {
374 total_size += op_size(aTHX_ cBINOPx(baseop)->op_last, st);
378 total_size += sizeof(struct logop);
379 if (check_new(st, cLOGOPx(baseop)->op_first)) {
380 total_size += op_size(aTHX_ cBINOPx(baseop)->op_first, st);
382 if (check_new(st, cLOGOPx(baseop)->op_other)) {
383 total_size += op_size(aTHX_ cLOGOPx(baseop)->op_other, st);
386 case OPc_LISTOP: TAG;
387 total_size += sizeof(struct listop);
388 if (check_new(st, cLISTOPx(baseop)->op_first)) {
389 total_size += op_size(aTHX_ cLISTOPx(baseop)->op_first, st);
391 if (check_new(st, cLISTOPx(baseop)->op_last)) {
392 total_size += op_size(aTHX_ cLISTOPx(baseop)->op_last, st);
396 total_size += sizeof(struct pmop);
397 if (check_new(st, cPMOPx(baseop)->op_first)) {
398 total_size += op_size(aTHX_ cPMOPx(baseop)->op_first, st);
400 if (check_new(st, cPMOPx(baseop)->op_last)) {
401 total_size += op_size(aTHX_ cPMOPx(baseop)->op_last, st);
403 #if PERL_VERSION < 9 || (PERL_VERSION == 9 && PERL_SUBVERSION < 5)
404 if (check_new(st, cPMOPx(baseop)->op_pmreplroot)) {
405 total_size += op_size(aTHX_ cPMOPx(baseop)->op_pmreplroot, st);
407 if (check_new(st, cPMOPx(baseop)->op_pmreplstart)) {
408 total_size += op_size(aTHX_ cPMOPx(baseop)->op_pmreplstart, st);
410 if (check_new(st, cPMOPx(baseop)->op_pmnext)) {
411 total_size += op_size(aTHX_ (OP *)cPMOPx(baseop)->op_pmnext, st);
414 /* This is defined away in perl 5.8.x, but it is in there for
417 if (check_new(st, PM_GETRE((cPMOPx(baseop))))) {
418 total_size += regex_size(PM_GETRE(cPMOPx(baseop)), st);
421 if (check_new(st, cPMOPx(baseop)->op_pmregexp)) {
422 total_size += regex_size(cPMOPx(baseop)->op_pmregexp, st);
427 total_size += sizeof(struct pmop);
428 if (check_new(st, cSVOPx(baseop)->op_sv)) {
429 total_size += thing_size(aTHX_ cSVOPx(baseop)->op_sv, st);
433 total_size += sizeof(struct padop);
436 if (check_new(st, cPVOPx(baseop)->op_pv)) {
437 total_size += strlen(cPVOPx(baseop)->op_pv);
440 total_size += sizeof(struct loop);
441 if (check_new(st, cLOOPx(baseop)->op_first)) {
442 total_size += op_size(aTHX_ cLOOPx(baseop)->op_first, st);
444 if (check_new(st, cLOOPx(baseop)->op_last)) {
445 total_size += op_size(aTHX_ cLOOPx(baseop)->op_last, st);
447 if (check_new(st, cLOOPx(baseop)->op_redoop)) {
448 total_size += op_size(aTHX_ cLOOPx(baseop)->op_redoop, st);
450 if (check_new(st, cLOOPx(baseop)->op_nextop)) {
451 total_size += op_size(aTHX_ cLOOPx(baseop)->op_nextop, st);
453 if (check_new(st, cLOOPx(baseop)->op_lastop)) {
454 total_size += op_size(aTHX_ cLOOPx(baseop)->op_lastop, st);
461 basecop = (COP *)baseop;
462 total_size += sizeof(struct cop);
464 /* Change 33656 by nicholas@mouse-mill on 2008/04/07 11:29:51
465 Eliminate cop_label from struct cop by storing a label as the first
466 entry in the hints hash. Most statements don't have labels, so this
467 will save memory. Not sure how much.
468 The check below will be incorrect fail on bleadperls
469 before 5.11 @33656, but later than 5.10, producing slightly too
470 small memory sizes on these Perls. */
471 #if (PERL_VERSION < 11)
472 if (check_new(st, basecop->cop_label)) {
473 total_size += strlen(basecop->cop_label);
477 if (check_new(st, basecop->cop_file)) {
478 total_size += strlen(basecop->cop_file);
480 if (check_new(st, basecop->cop_stashpv)) {
481 total_size += strlen(basecop->cop_stashpv);
484 if (check_new(st, basecop->cop_stash)) {
485 total_size += thing_size(aTHX_ (SV *)basecop->cop_stash, st);
487 if (check_new(st, basecop->cop_filegv)) {
488 total_size += thing_size(aTHX_ (SV *)basecop->cop_filegv, st);
499 if (st->dangle_whine)
500 warn( "Devel::Size: Encountered dangling pointer in opcode at: %p\n", baseop );
505 #if PERL_VERSION > 9 || (PERL_VERSION == 9 && PERL_SUBVERSION > 2)
506 # define NEW_HEAD_LAYOUT
510 thing_size(pTHX_ const SV * const orig_thing, struct state *st) {
511 const SV *thing = orig_thing;
512 UV total_size = sizeof(SV);
514 switch (SvTYPE(thing)) {
518 /* Just a plain integer. This will be differently sized depending
519 on whether purify's been compiled in */
521 #ifndef NEW_HEAD_LAYOUT
523 total_size += sizeof(sizeof(XPVIV));
525 total_size += sizeof(IV);
529 /* Is it a float? Like the int, it depends on purify */
532 total_size += sizeof(sizeof(XPVNV));
534 total_size += sizeof(NV);
537 #if (PERL_VERSION < 11)
538 /* Is it a reference? */
540 #ifndef NEW_HEAD_LAYOUT
541 total_size += sizeof(XRV);
545 /* How about a plain string? In which case we need to add in how
546 much has been allocated */
548 total_size += sizeof(XPV);
549 #if (PERL_VERSION < 11)
550 total_size += SvROK(thing) ? thing_size(aTHX_ SvRV(thing), st) : SvLEN(thing);
552 total_size += SvLEN(thing);
555 /* A string with an integer part? */
557 total_size += sizeof(XPVIV);
558 #if (PERL_VERSION < 11)
559 total_size += SvROK(thing) ? thing_size(aTHX_ SvRV(thing), st) : SvLEN(thing);
561 total_size += SvLEN(thing);
564 total_size += SvIVX(thing);
567 /* A scalar/string/reference with a float part? */
569 total_size += sizeof(XPVNV);
570 #if (PERL_VERSION < 11)
571 total_size += SvROK(thing) ? thing_size(aTHX_ SvRV(thing), st) : SvLEN(thing);
573 total_size += SvLEN(thing);
577 total_size += sizeof(XPVMG);
578 #if (PERL_VERSION < 11)
579 total_size += SvROK(thing) ? thing_size(aTHX_ SvRV(thing), st) : SvLEN(thing);
581 total_size += SvLEN(thing);
583 total_size += magic_size(thing, st);
585 #if PERL_VERSION <= 8
587 total_size += sizeof(XPVBM);
588 #if (PERL_VERSION < 11)
589 total_size += SvROK(thing) ? thing_size(aTHX_ SvRV(thing), st) : SvLEN(thing);
591 total_size += SvLEN(thing);
593 total_size += magic_size(thing, st);
597 total_size += sizeof(XPVLV);
598 #if (PERL_VERSION < 11)
599 total_size += SvROK(thing) ? thing_size(aTHX_ SvRV(thing), st) : SvLEN(thing);
601 total_size += SvLEN(thing);
603 total_size += magic_size(thing, st);
605 /* How much space is dedicated to the array? Not counting the
606 elements in the array, mind, just the array itself */
608 total_size += sizeof(XPVAV);
609 /* Is there anything in the array? */
610 if (AvMAX(thing) != -1) {
611 /* an array with 10 slots has AvMax() set to 9 - te 2007-04-22 */
612 total_size += sizeof(SV *) * (AvMAX(thing) + 1);
613 dbg_printf(("total_size: %li AvMAX: %li av_len: $i\n", total_size, AvMAX(thing), av_len((AV*)thing)));
615 /* Add in the bits on the other side of the beginning */
617 dbg_printf(("total_size %li, sizeof(SV *) %li, AvARRAY(thing) %li, AvALLOC(thing)%li , sizeof(ptr) %li \n",
618 total_size, sizeof(SV*), AvARRAY(thing), AvALLOC(thing), sizeof( thing )));
620 /* under Perl 5.8.8 64bit threading, AvARRAY(thing) was a pointer while AvALLOC was 0,
621 resulting in grossly overstated sized for arrays. Technically, this shouldn't happen... */
622 if (AvALLOC(thing) != 0) {
623 total_size += (sizeof(SV *) * (AvARRAY(thing) - AvALLOC(thing)));
625 #if (PERL_VERSION < 9)
626 /* Is there something hanging off the arylen element?
627 Post 5.9.something this is stored in magic, so will be found there,
628 and Perl_av_arylen_p() takes a non-const AV*, hence compilers rightly
629 complain about AvARYLEN() passing thing to it. */
630 if (AvARYLEN(thing)) {
631 if (check_new(st, AvARYLEN(thing))) {
632 total_size += thing_size(aTHX_ AvARYLEN(thing), st);
636 total_size += magic_size(thing, st);
639 /* First the base struct */
640 total_size += sizeof(XPVHV);
641 /* Now the array of buckets */
642 total_size += (sizeof(HE *) * (HvMAX(thing) + 1));
643 /* Now walk the bucket chain */
644 if (HvARRAY(thing)) {
647 for (cur_bucket = 0; cur_bucket <= HvMAX(thing); cur_bucket++) {
648 cur_entry = *(HvARRAY(thing) + cur_bucket);
650 total_size += sizeof(HE);
651 if (cur_entry->hent_hek) {
652 /* Hash keys can be shared. Have we seen this before? */
653 if (check_new(st, cur_entry->hent_hek)) {
654 total_size += HEK_BASESIZE + cur_entry->hent_hek->hek_len + 2;
657 cur_entry = cur_entry->hent_next;
661 total_size += magic_size(thing, st);
664 total_size += sizeof(XPVCV);
665 total_size += magic_size(thing, st);
667 total_size += ((XPVIO *) SvANY(thing))->xpv_len;
668 if (check_new(st, CvSTASH(thing))) {
669 total_size += thing_size(aTHX_ (SV *)CvSTASH(thing), st);
671 if (check_new(st, SvSTASH(thing))) {
672 total_size += thing_size(aTHX_ (SV *)SvSTASH(thing), st);
674 if (check_new(st, CvGV(thing))) {
675 total_size += thing_size(aTHX_ (SV *)CvGV(thing), st);
677 if (check_new(st, CvPADLIST(thing))) {
678 total_size += thing_size(aTHX_ (SV *)CvPADLIST(thing), st);
680 if (check_new(st, CvOUTSIDE(thing))) {
681 total_size += thing_size(aTHX_ (SV *)CvOUTSIDE(thing), st);
683 if (CvISXSUB(thing)) {
684 SV *sv = cv_const_sv((CV *)thing);
686 total_size += thing_size(aTHX_ sv, st);
689 if (check_new(st, CvSTART(thing))) {
690 total_size += op_size(aTHX_ CvSTART(thing), st);
692 if (check_new(st, CvROOT(thing))) {
693 total_size += op_size(aTHX_ CvROOT(thing), st);
699 total_size += magic_size(thing, st);
700 total_size += sizeof(XPVGV);
701 total_size += GvNAMELEN(thing);
703 /* Is there a file? */
705 if (check_new(st, GvFILE(thing))) {
706 total_size += strlen(GvFILE(thing));
710 /* Is there something hanging off the glob? */
712 if (check_new(st, GvGP(thing))) {
713 total_size += sizeof(GP);
716 if ((generic_thing = (SV *)(GvGP(thing)->gp_sv))) {
717 total_size += thing_size(aTHX_ generic_thing, st);
719 if ((generic_thing = (SV *)(GvGP(thing)->gp_form))) {
720 total_size += thing_size(aTHX_ generic_thing, st);
722 if ((generic_thing = (SV *)(GvGP(thing)->gp_av))) {
723 total_size += thing_size(aTHX_ generic_thing, st);
725 if ((generic_thing = (SV *)(GvGP(thing)->gp_hv))) {
726 total_size += thing_size(aTHX_ generic_thing, st);
728 if ((generic_thing = (SV *)(GvGP(thing)->gp_egv))) {
729 total_size += thing_size(aTHX_ generic_thing, st);
731 if ((generic_thing = (SV *)(GvGP(thing)->gp_cv))) {
732 total_size += thing_size(aTHX_ generic_thing, st);
739 total_size += sizeof(XPVFM);
740 total_size += magic_size(thing, st);
741 total_size += ((XPVIO *) SvANY(thing))->xpv_len;
742 if (check_new(st, CvPADLIST(thing))) {
743 total_size += thing_size(aTHX_ (SV *)CvPADLIST(thing), st);
745 if (check_new(st, CvOUTSIDE(thing))) {
746 total_size += thing_size(aTHX_ (SV *)CvOUTSIDE(thing), st);
749 if (st->go_yell && !st->fm_whine) {
750 carp("Devel::Size: Calculated sizes for FMs are incomplete");
755 total_size += sizeof(XPVIO);
756 total_size += magic_size(thing, st);
757 if (check_new(st, (SvPVX_const(thing)))) {
758 total_size += ((XPVIO *) SvANY(thing))->xpv_cur;
760 /* Some embedded char pointers */
761 if (check_new(st, ((XPVIO *) SvANY(thing))->xio_top_name)) {
762 total_size += strlen(((XPVIO *) SvANY(thing))->xio_top_name);
764 if (check_new(st, ((XPVIO *) SvANY(thing))->xio_fmt_name)) {
765 total_size += strlen(((XPVIO *) SvANY(thing))->xio_fmt_name);
767 if (check_new(st, ((XPVIO *) SvANY(thing))->xio_bottom_name)) {
768 total_size += strlen(((XPVIO *) SvANY(thing))->xio_bottom_name);
770 /* Throw the GVs on the list to be walked if they're not-null */
771 if (((XPVIO *) SvANY(thing))->xio_top_gv) {
772 total_size += thing_size(aTHX_ (SV *)((XPVIO *) SvANY(thing))->xio_top_gv,
775 if (((XPVIO *) SvANY(thing))->xio_bottom_gv) {
776 total_size += thing_size(aTHX_ (SV *)((XPVIO *) SvANY(thing))->xio_bottom_gv,
779 if (((XPVIO *) SvANY(thing))->xio_fmt_gv) {
780 total_size += thing_size(aTHX_ (SV *)((XPVIO *) SvANY(thing))->xio_fmt_gv,
784 /* Only go trotting through the IO structures if they're really
785 trottable. If USE_PERLIO is defined we can do this. If
786 not... we can't, so we don't even try */
788 /* Dig into xio_ifp and xio_ofp here */
789 warn("Devel::Size: Can't size up perlio layers yet\n");
793 warn("Devel::Size: Unknown variable type: %d encountered\n", SvTYPE(thing) );
798 static struct state *
803 Newxz(st, 1, struct state);
805 if (NULL != (warn_flag = perl_get_sv("Devel::Size::warn", FALSE))) {
806 st->dangle_whine = st->go_yell = SvIV(warn_flag) ? TRUE : FALSE;
808 if (NULL != (warn_flag = perl_get_sv("Devel::Size::dangle", FALSE))) {
809 st->dangle_whine = SvIV(warn_flag) ? TRUE : FALSE;
814 MODULE = Devel::Size PACKAGE = Devel::Size
823 SV *thing = orig_thing;
824 struct state *st = new_state(aTHX);
826 /* If they passed us a reference then dereference it. This is the
827 only way we can check the sizes of arrays and hashes */
828 #if (PERL_VERSION < 11)
829 if (SvOK(thing) && SvROK(thing)) {
838 RETVAL = thing_size(aTHX_ thing, st);
846 total_size(orig_thing)
850 SV *thing = orig_thing;
851 /* Array with things we still need to do */
854 struct state *st = new_state(aTHX);
856 /* Size starts at zero */
859 pending_array = newAV();
861 /* We cannot push HV/AV directly, only the RV. So deref it
862 later (see below for "*** dereference later") and adjust here for
864 This is the only way we can check the sizes of arrays and hashes. */
866 RETVAL -= thing_size(aTHX_ thing, NULL);
869 /* Put it on the pending array */
870 av_push(pending_array, thing);
872 /* Now just yank things off the end of the array until it's done */
873 while (av_len(pending_array) >= 0) {
874 thing = av_pop(pending_array);
875 /* Process it if we've not seen it */
876 if (check_new(st, thing)) {
877 dbg_printf(("# Found type %i at %p\n", SvTYPE(thing), thing));
880 /* Yes, it is. So let's check the type */
881 switch (SvTYPE(thing)) {
882 /* fix for bug #24846 (Does not correctly recurse into references in a PVNV-type scalar) */
886 av_push(pending_array, SvRV(thing));
890 /* this is the "*** dereference later" part - see above */
891 #if (PERL_VERSION < 11)
896 dbg_printf(("# Found RV\n"));
898 dbg_printf(("# Found RV\n"));
899 av_push(pending_array, SvRV(thing));
905 AV *tempAV = (AV *)thing;
908 dbg_printf(("# Found type AV\n"));
909 /* Quick alias to cut down on casting */
912 if (av_len(tempAV) != -1) {
914 /* Run through them all */
915 for (index = 0; index <= av_len(tempAV); index++) {
916 /* Did we get something? */
917 if ((tempSV = av_fetch(tempAV, index, 0))) {
919 if (*tempSV != &PL_sv_undef) {
920 /* Apparently not. Save it for later */
921 av_push(pending_array, *tempSV);
930 dbg_printf(("# Found type HV\n"));
931 /* Is there anything in here? */
932 if (hv_iterinit((HV *)thing)) {
934 while ((temp_he = hv_iternext((HV *)thing))) {
935 av_push(pending_array, hv_iterval((HV *)thing, temp_he));
941 dbg_printf(("# Found type GV\n"));
942 /* Run through all the pieces and push the ones with bits */
944 av_push(pending_array, (SV *)GvSV(thing));
947 av_push(pending_array, (SV *)GvFORM(thing));
950 av_push(pending_array, (SV *)GvAV(thing));
953 av_push(pending_array, (SV *)GvHV(thing));
956 av_push(pending_array, (SV *)GvCV(thing));
964 size = thing_size(aTHX_ thing, st);
967 /* check_new() returned false: */
968 #ifdef DEVEL_SIZE_DEBUGGING
969 if (SvOK(sv)) printf("# Ignore ref copy 0x%x\n", sv);
970 else printf("# Ignore non-sv 0x%x\n", sv);
976 SvREFCNT_dec(pending_array);