Size.xs

   1 #define PERL_NO_GET_CONTEXT
   2
   3 #include "EXTERN.h"
   4 #include "perl.h"
   5 #include "XSUB.h"
   6 #include "ppport.h"
   7
   8 /* Not yet in ppport.h */
   9 #ifndef CvISXSUB
  10 #  define CvISXSUB(cv)  (CvXSUB(cv) ? TRUE : FALSE)
  11 #endif
  12 #ifndef SvRV_const
  13 #  define SvRV_const(rv) SvRV(rv)
  14 #endif
  15
  16 #ifdef _MSC_VER
  17 /* "structured exception" handling is a Microsoft extension to C and C++.
  18    It's *not* C++ exception handling - C++ exception handling can't capture
  19    SEGVs and suchlike, whereas this can. There's no known analagous
  20     functionality on other platforms.  */
  21 #  include <excpt.h>
  22 #  define TRY_TO_CATCH_SEGV __try
  23 #  define CAUGHT_EXCEPTION __except(EXCEPTION EXCEPTION_EXECUTE_HANDLER)
  24 #else
  25 #  define TRY_TO_CATCH_SEGV if(1)
  26 #  define CAUGHT_EXCEPTION else
  27 #endif
  28
  29 #ifdef __GNUC__
  30 # define __attribute__(x)
  31 #endif
  32
  33 #if 0 && defined(DEBUGGING)
  34 #define dbg_printf(x) printf x
  35 #else
  36 #define dbg_printf(x)
  37 #endif
  38
  39 #define TAG /* printf( "# %s(%d)\n", __FILE__, __LINE__ ) */
  40 #define carp puts
  41
  42 /* The idea is to have a tree structure to store 1 bit per possible pointer
  43    address. The lowest 16 bits are stored in a block of 8092 bytes.
  44    The blocks are in a 256-way tree, indexed by the reset of the pointer.
  45    This can cope with 32 and 64 bit pointers, and any address space layout,
  46    without excessive memory needs. The assumption is that your CPU cache
  47    works :-) (And that we're not going to bust it)  */
  48
  49 #define ALIGN_BITS  ( sizeof(void*) >> 1 )
  50 #define BYTE_BITS    3
  51 #define LEAF_BITS   (16 - BYTE_BITS)
  52 #define LEAF_MASK   0x1FFF
  53
  54 struct state {
  55     UV total_size;
  56     bool regex_whine;
  57     bool fm_whine;
  58     bool dangle_whine;
  59     bool go_yell;
  60     /* My hunch (not measured) is that for most architectures pointers will
  61        start with 0 bits, hence the start of this array will be hot, and the
  62        end unused. So put the flags next to the hot end.  */
  63     void *tracking[256];
  64 };
  65
  66 /*
  67     Checks to see if thing is in the bitstring.
  68     Returns true or false, and
  69     notes thing in the segmented bitstring.
  70  */
  71 static bool
  72 check_new(struct state *st, const void *const p) {
  73     unsigned int bits = 8 * sizeof(void*);
  74     const size_t raw_p = PTR2nat(p);
  75     /* This effectively rotates the value right by the number of low always-0
  76        bits in an aligned pointer. The assmption is that most (if not all)
  77        pointers are aligned, and these will be in the same chain of nodes
  78        (and hence hot in the cache) but we can still deal with any unaligned
  79        pointers.  */
  80     const size_t cooked_p
  81         = (raw_p >> ALIGN_BITS) | (raw_p << (bits - BYTE_BITS));
  82     const U8 this_bit = 1 << (cooked_p & 0x7);
  83     U8 **leaf_p;
  84     U8 *leaf;
  85     unsigned int i;
  86     void **tv_p;
  87
  88
  89     if (NULL == p || NULL == st) return FALSE;
  90     tv_p = (void **) (st->tracking);
  91     TRY_TO_CATCH_SEGV {
  92         const char c = *(const char *)p;
  93     }
  94     CAUGHT_EXCEPTION {
  95         if (st->dangle_whine)
  96             warn( "Devel::Size: Encountered invalid pointer: %p\n", p );
  97         return FALSE;
  98     }
  99     TAG;
 100
 101     bits -= 8;
 102     /* bits now 24 (32 bit pointers) or 56 (64 bit pointers) */
 103
 104     /* First level is always present.  */
 105     do {
 106         i = (unsigned int)((cooked_p >> bits) & 0xFF);
 107         if (!tv_p[i])
 108             Newxz(tv_p[i], 256, void *);
 109         tv_p = (void **)(tv_p[i]);
 110         bits -= 8;
 111     } while (bits > LEAF_BITS + BYTE_BITS);
 112     /* bits now 16 always */
 113 #if !defined(MULTIPLICITY) || PERL_VERSION > 8 || (PERL_VERSION == 8 && PERL_SUBVERSION > 8)
 114     /* 5.8.8 and early have an assert() macro that uses Perl_croak, hence needs
 115        a my_perl under multiplicity  */
 116     assert(bits == 16);
 117 #endif
 118     leaf_p = (U8 **)tv_p;
 119     i = (unsigned int)((cooked_p >> bits) & 0xFF);
 120     if (!leaf_p[i])
 121         Newxz(leaf_p[i], 1 << LEAF_BITS, U8);
 122     leaf = leaf_p[i];
 123
 124     TAG;
 125
 126     i = (unsigned int)((cooked_p >> BYTE_BITS) & LEAF_MASK);
 127
 128     if(leaf[i] & this_bit)
 129         return FALSE;
 130
 131     leaf[i] |= this_bit;
 132     return TRUE;
 133 }
 134
 135 static void
 136 free_tracking_at(void **tv, int level)
 137 {
 138     int i = 255;
 139
 140     if (--level) {
 141         /* Nodes */
 142         do {
 143             if (tv[i]) {
 144                 free_tracking_at(tv[i], level);
 145                 Safefree(tv[i]);
 146             }
 147         } while (i--);
 148     } else {
 149         /* Leaves */
 150         do {
 151             if (tv[i])
 152                 Safefree(tv[i]);
 153         } while (i--);
 154     }
 155 }
 156
 157 static void
 158 free_state(struct state *st)
 159 {
 160     const int top_level = (sizeof(void *) * 8 - LEAF_BITS - BYTE_BITS) / 8;
 161     free_tracking_at((void **)st->tracking, top_level);
 162     Safefree(st);
 163 }
 164
 165 static void thing_size(pTHX_ const SV *const, struct state *);
 166 typedef enum {
 167     OPc_NULL,   /* 0 */
 168     OPc_BASEOP, /* 1 */
 169     OPc_UNOP,   /* 2 */
 170     OPc_BINOP,  /* 3 */
 171     OPc_LOGOP,  /* 4 */
 172     OPc_LISTOP, /* 5 */
 173     OPc_PMOP,   /* 6 */
 174     OPc_SVOP,   /* 7 */
 175     OPc_PADOP,  /* 8 */
 176     OPc_PVOP,   /* 9 */
 177     OPc_LOOP,   /* 10 */
 178     OPc_COP /* 11 */
 179 } opclass;
 180
 181 static opclass
 182 cc_opclass(const OP * const o)
 183 {
 184     if (!o)
 185     return OPc_NULL;
 186     TRY_TO_CATCH_SEGV {
 187         if (o->op_type == 0)
 188         return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
 189
 190         if (o->op_type == OP_SASSIGN)
 191         return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPc_UNOP : OPc_BINOP);
 192
 193     #ifdef USE_ITHREADS
 194         if (o->op_type == OP_GV || o->op_type == OP_GVSV || o->op_type == OP_AELEMFAST)
 195         return OPc_PADOP;
 196     #endif
 197
 198         if ((o->op_type == OP_TRANS)) {
 199           return OPc_BASEOP;
 200         }
 201
 202         switch (PL_opargs[o->op_type] & OA_CLASS_MASK) {
 203         case OA_BASEOP: TAG;
 204         return OPc_BASEOP;
 205
 206         case OA_UNOP: TAG;
 207         return OPc_UNOP;
 208
 209         case OA_BINOP: TAG;
 210         return OPc_BINOP;
 211
 212         case OA_LOGOP: TAG;
 213         return OPc_LOGOP;
 214
 215         case OA_LISTOP: TAG;
 216         return OPc_LISTOP;
 217
 218         case OA_PMOP: TAG;
 219         return OPc_PMOP;
 220
 221         case OA_SVOP: TAG;
 222         return OPc_SVOP;
 223
 224         case OA_PADOP: TAG;
 225         return OPc_PADOP;
 226
 227         case OA_PVOP_OR_SVOP: TAG;
 228             /*
 229              * Character translations (tr///) are usually a PVOP, keeping a
 230              * pointer to a table of shorts used to look up translations.
 231              * Under utf8, however, a simple table isn't practical; instead,
 232              * the OP is an SVOP, and the SV is a reference to a swash
 233              * (i.e., an RV pointing to an HV).
 234              */
 235         return (o->op_private & (OPpTRANS_TO_UTF|OPpTRANS_FROM_UTF))
 236             ? OPc_SVOP : OPc_PVOP;
 237
 238         case OA_LOOP: TAG;
 239         return OPc_LOOP;
 240
 241         case OA_COP: TAG;
 242         return OPc_COP;
 243
 244         case OA_BASEOP_OR_UNOP: TAG;
 245         /*
 246          * UNI(OP_foo) in toke.c returns token UNI or FUNC1 depending on
 247          * whether parens were seen. perly.y uses OPf_SPECIAL to
 248          * signal whether a BASEOP had empty parens or none.
 249          * Some other UNOPs are created later, though, so the best
 250          * test is OPf_KIDS, which is set in newUNOP.
 251          */
 252         return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
 253
 254         case OA_FILESTATOP: TAG;
 255         /*
 256          * The file stat OPs are created via UNI(OP_foo) in toke.c but use
 257          * the OPf_REF flag to distinguish between OP types instead of the
 258          * usual OPf_SPECIAL flag. As usual, if OPf_KIDS is set, then we
 259          * return OPc_UNOP so that walkoptree can find our children. If
 260          * OPf_KIDS is not set then we check OPf_REF. Without OPf_REF set
 261          * (no argument to the operator) it's an OP; with OPf_REF set it's
 262          * an SVOP (and op_sv is the GV for the filehandle argument).
 263          */
 264         return ((o->op_flags & OPf_KIDS) ? OPc_UNOP :
 265     #ifdef USE_ITHREADS
 266             (o->op_flags & OPf_REF) ? OPc_PADOP : OPc_BASEOP);
 267     #else
 268             (o->op_flags & OPf_REF) ? OPc_SVOP : OPc_BASEOP);
 269     #endif
 270         case OA_LOOPEXOP: TAG;
 271         /*
 272          * next, last, redo, dump and goto use OPf_SPECIAL to indicate that a
 273          * label was omitted (in which case it's a BASEOP) or else a term was
 274          * seen. In this last case, all except goto are definitely PVOP but
 275          * goto is either a PVOP (with an ordinary constant label), an UNOP
 276          * with OPf_STACKED (with a non-constant non-sub) or an UNOP for
 277          * OP_REFGEN (with goto &sub) in which case OPf_STACKED also seems to
 278          * get set.
 279          */
 280         if (o->op_flags & OPf_STACKED)
 281             return OPc_UNOP;
 282         else if (o->op_flags & OPf_SPECIAL)
 283             return OPc_BASEOP;
 284         else
 285             return OPc_PVOP;
 286         }
 287         warn("Devel::Size: Can't determine class of operator %s, assuming BASEOP\n",
 288          PL_op_name[o->op_type]);
 289     }
 290     CAUGHT_EXCEPTION { }
 291     return OPc_BASEOP;
 292 }
 293
 294
 295 #if !defined(NV)
 296 #define NV double
 297 #endif
 298
 299 /* Figure out how much magic is attached to the SV and return the
 300    size */
 301 static void
 302 magic_size(const SV * const thing, struct state *st) {
 303   MAGIC *magic_pointer;
 304
 305   /* Is there any? */
 306   if (!SvMAGIC(thing)) {
 307     /* No, bail */
 308     return;
 309   }
 310
 311   /* Get the base magic pointer */
 312   magic_pointer = SvMAGIC(thing);
 313
 314   /* Have we seen the magic pointer? */
 315   while (check_new(st, magic_pointer)) {
 316     st->total_size += sizeof(MAGIC);
 317
 318     TRY_TO_CATCH_SEGV {
 319         /* Have we seen the magic vtable? */
 320         if (check_new(st, magic_pointer->mg_virtual)) {
 321           st->total_size += sizeof(MGVTBL);
 322         }
 323
 324         /* Get the next in the chain */
 325         magic_pointer = magic_pointer->mg_moremagic;
 326     }
 327     CAUGHT_EXCEPTION {
 328         if (st->dangle_whine)
 329             warn( "Devel::Size: Encountered bad magic at: %p\n", magic_pointer );
 330     }
 331   }
 332 }
 333
 334 static void
 335 regex_size(const REGEXP * const baseregex, struct state *st) {
 336     if(!check_new(st, baseregex))
 337         return;
 338   st->total_size += sizeof(REGEXP);
 339 #if (PERL_VERSION < 11)
 340   /* Note the size of the paren offset thing */
 341   st->total_size += sizeof(I32) * baseregex->nparens * 2;
 342   st->total_size += strlen(baseregex->precomp);
 343 #else
 344   st->total_size += sizeof(struct regexp);
 345   st->total_size += sizeof(I32) * SvANY(baseregex)->nparens * 2;
 346   /*st->total_size += strlen(SvANY(baseregex)->subbeg);*/
 347 #endif
 348   if (st->go_yell && !st->regex_whine) {
 349     carp("Devel::Size: Calculated sizes for compiled regexes are incompatible, and probably always will be");
 350     st->regex_whine = 1;
 351   }
 352 }
 353
 354 static void
 355 op_size(pTHX_ const OP * const baseop, struct state *st)
 356 {
 357     TRY_TO_CATCH_SEGV {
 358         TAG;
 359         if(!check_new(st, baseop))
 360             return;
 361         TAG;
 362         op_size(aTHX_ baseop->op_next, st);
 363         TAG;
 364         switch (cc_opclass(baseop)) {
 365         case OPc_BASEOP: TAG;
 366             st->total_size += sizeof(struct op);
 367             TAG;break;
 368         case OPc_UNOP: TAG;
 369             st->total_size += sizeof(struct unop);
 370             op_size(aTHX_ cUNOPx(baseop)->op_first, st);
 371             TAG;break;
 372         case OPc_BINOP: TAG;
 373             st->total_size += sizeof(struct binop);
 374             op_size(aTHX_ cBINOPx(baseop)->op_first, st);
 375             op_size(aTHX_ cBINOPx(baseop)->op_last, st);
 376             TAG;break;
 377         case OPc_LOGOP: TAG;
 378             st->total_size += sizeof(struct logop);
 379             op_size(aTHX_ cBINOPx(baseop)->op_first, st);
 380             op_size(aTHX_ cLOGOPx(baseop)->op_other, st);
 381             TAG;break;
 382         case OPc_LISTOP: TAG;
 383             st->total_size += sizeof(struct listop);
 384             op_size(aTHX_ cLISTOPx(baseop)->op_first, st);
 385             op_size(aTHX_ cLISTOPx(baseop)->op_last, st);
 386             TAG;break;
 387         case OPc_PMOP: TAG;
 388             st->total_size += sizeof(struct pmop);
 389             op_size(aTHX_ cPMOPx(baseop)->op_first, st);
 390             op_size(aTHX_ cPMOPx(baseop)->op_last, st);
 391 #if PERL_VERSION < 9 || (PERL_VERSION == 9 && PERL_SUBVERSION < 5)
 392             op_size(aTHX_ cPMOPx(baseop)->op_pmreplroot, st);
 393             op_size(aTHX_ cPMOPx(baseop)->op_pmreplstart, st);
 394             op_size(aTHX_ (OP *)cPMOPx(baseop)->op_pmnext, st);
 395 #endif
 396             /* This is defined away in perl 5.8.x, but it is in there for
 397                5.6.x */
 398 #ifdef PM_GETRE
 399             regex_size(PM_GETRE(cPMOPx(baseop)), st);
 400 #else
 401             regex_size(cPMOPx(baseop)->op_pmregexp, st);
 402 #endif
 403             TAG;break;
 404       case OPc_SVOP: TAG;
 405         st->total_size += sizeof(struct pmop);
 406         if (check_new(st, cSVOPx(baseop)->op_sv)) {
 407           thing_size(aTHX_ cSVOPx(baseop)->op_sv, st);
 408         }
 409         TAG;break;
 410       case OPc_PADOP: TAG;
 411           st->total_size += sizeof(struct padop);
 412         TAG;break;
 413       case OPc_PVOP: TAG;
 414         if (check_new(st, cPVOPx(baseop)->op_pv)) {
 415           st->total_size += strlen(cPVOPx(baseop)->op_pv);
 416         }
 417         case OPc_LOOP: TAG;
 418             st->total_size += sizeof(struct loop);
 419             op_size(aTHX_ cLOOPx(baseop)->op_first, st);
 420             op_size(aTHX_ cLOOPx(baseop)->op_last, st);
 421             op_size(aTHX_ cLOOPx(baseop)->op_redoop, st);
 422             op_size(aTHX_ cLOOPx(baseop)->op_nextop, st);
 423             op_size(aTHX_ cLOOPx(baseop)->op_lastop, st);
 424             TAG;break;
 425         case OPc_COP: TAG;
 426         {
 427           COP *basecop;
 428           basecop = (COP *)baseop;
 429           st->total_size += sizeof(struct cop);
 430
 431           /* Change 33656 by nicholas@mouse-mill on 2008/04/07 11:29:51
 432           Eliminate cop_label from struct cop by storing a label as the first
 433           entry in the hints hash. Most statements don't have labels, so this
 434           will save memory. Not sure how much.
 435           The check below will be incorrect fail on bleadperls
 436           before 5.11 @33656, but later than 5.10, producing slightly too
 437           small memory sizes on these Perls. */
 438 #if (PERL_VERSION < 11)
 439           if (check_new(st, basecop->cop_label)) {
 440         st->total_size += strlen(basecop->cop_label);
 441           }
 442 #endif
 443 #ifdef USE_ITHREADS
 444           if (check_new(st, basecop->cop_file)) {
 445         st->total_size += strlen(basecop->cop_file);
 446           }
 447           if (check_new(st, basecop->cop_stashpv)) {
 448         st->total_size += strlen(basecop->cop_stashpv);
 449           }
 450 #else
 451           if (check_new(st, basecop->cop_stash)) {
 452               thing_size(aTHX_ (SV *)basecop->cop_stash, st);
 453           }
 454           if (check_new(st, basecop->cop_filegv)) {
 455               thing_size(aTHX_ (SV *)basecop->cop_filegv, st);
 456           }
 457 #endif
 458
 459         }
 460         TAG;break;
 461       default:
 462         TAG;break;
 463       }
 464   }
 465   CAUGHT_EXCEPTION {
 466       if (st->dangle_whine)
 467           warn( "Devel::Size: Encountered dangling pointer in opcode at: %p\n", baseop );
 468   }
 469 }
 470
 471 #if PERL_VERSION > 9 || (PERL_VERSION == 9 && PERL_SUBVERSION > 2)
 472 #  define NEW_HEAD_LAYOUT
 473 #endif
 474
 475 static void
 476 thing_size(pTHX_ const SV * const orig_thing, struct state *st) {
 477   const SV *thing = orig_thing;
 478
 479   st->total_size += sizeof(SV);
 480
 481   switch (SvTYPE(thing)) {
 482     /* Is it undef? */
 483   case SVt_NULL: TAG;
 484     TAG;break;
 485     /* Just a plain integer. This will be differently sized depending
 486        on whether purify's been compiled in */
 487   case SVt_IV: TAG;
 488 #ifndef NEW_HEAD_LAYOUT
 489 #  ifdef PURIFY
 490     st->total_size += sizeof(sizeof(XPVIV));
 491 #  else
 492     st->total_size += sizeof(IV);
 493 #  endif
 494 #endif
 495     TAG;break;
 496     /* Is it a float? Like the int, it depends on purify */
 497   case SVt_NV: TAG;
 498 #ifdef PURIFY
 499     st->total_size += sizeof(sizeof(XPVNV));
 500 #else
 501     st->total_size += sizeof(NV);
 502 #endif
 503     TAG;break;
 504 #if (PERL_VERSION < 11)
 505     /* Is it a reference? */
 506   case SVt_RV: TAG;
 507 #ifndef NEW_HEAD_LAYOUT
 508     st->total_size += sizeof(XRV);
 509 #endif
 510     TAG;break;
 511 #endif
 512     /* How about a plain string? In which case we need to add in how
 513        much has been allocated */
 514   case SVt_PV: TAG;
 515     st->total_size += sizeof(XPV);
 516     if(SvROK(thing))
 517         thing_size(aTHX_ SvRV_const(thing), st);
 518     else
 519         st->total_size += SvLEN(thing);
 520     TAG;break;
 521     /* A string with an integer part? */
 522   case SVt_PVIV: TAG;
 523     st->total_size += sizeof(XPVIV);
 524     if(SvROK(thing))
 525         thing_size(aTHX_ SvRV_const(thing), st);
 526     else
 527         st->total_size += SvLEN(thing);
 528     if(SvOOK(thing)) {
 529         st->total_size += SvIVX(thing);
 530     }
 531     TAG;break;
 532     /* A scalar/string/reference with a float part? */
 533   case SVt_PVNV: TAG;
 534     st->total_size += sizeof(XPVNV);
 535     if(SvROK(thing))
 536         thing_size(aTHX_ SvRV_const(thing), st);
 537     else
 538         st->total_size += SvLEN(thing);
 539     TAG;break;
 540   case SVt_PVMG: TAG;
 541     st->total_size += sizeof(XPVMG);
 542     if(SvROK(thing))
 543         thing_size(aTHX_ SvRV_const(thing), st);
 544     else
 545         st->total_size += SvLEN(thing);
 546     magic_size(thing, st);
 547     TAG;break;
 548 #if PERL_VERSION <= 8
 549   case SVt_PVBM: TAG;
 550     st->total_size += sizeof(XPVBM);
 551     if(SvROK(thing))
 552         thing_size(aTHX_ SvRV_const(thing), st);
 553     else
 554         st->total_size += SvLEN(thing);
 555     magic_size(thing, st);
 556     TAG;break;
 557 #endif
 558   case SVt_PVLV: TAG;
 559     st->total_size += sizeof(XPVLV);
 560     if(SvROK(thing))
 561         thing_size(aTHX_ SvRV_const(thing), st);
 562     else
 563         st->total_size += SvLEN(thing);
 564     magic_size(thing, st);
 565     TAG;break;
 566     /* How much space is dedicated to the array? Not counting the
 567        elements in the array, mind, just the array itself */
 568   case SVt_PVAV: TAG;
 569     st->total_size += sizeof(XPVAV);
 570     /* Is there anything in the array? */
 571     if (AvMAX(thing) != -1) {
 572       /* an array with 10 slots has AvMax() set to 9 - te 2007-04-22 */
 573       st->total_size += sizeof(SV *) * (AvMAX(thing) + 1);
 574       dbg_printf(("total_size: %li AvMAX: %li av_len: $i\n", st->total_size, AvMAX(thing), av_len((AV*)thing)));
 575     }
 576     /* Add in the bits on the other side of the beginning */
 577
 578     dbg_printf(("total_size %li, sizeof(SV *) %li, AvARRAY(thing) %li, AvALLOC(thing)%li , sizeof(ptr) %li \n",
 579     st->total_size, sizeof(SV*), AvARRAY(thing), AvALLOC(thing), sizeof( thing )));
 580
 581     /* under Perl 5.8.8 64bit threading, AvARRAY(thing) was a pointer while AvALLOC was 0,
 582        resulting in grossly overstated sized for arrays. Technically, this shouldn't happen... */
 583     if (AvALLOC(thing) != 0) {
 584       st->total_size += (sizeof(SV *) * (AvARRAY(thing) - AvALLOC(thing)));
 585       }
 586 #if (PERL_VERSION < 9)
 587     /* Is there something hanging off the arylen element?
 588        Post 5.9.something this is stored in magic, so will be found there,
 589        and Perl_av_arylen_p() takes a non-const AV*, hence compilers rightly
 590        complain about AvARYLEN() passing thing to it.  */
 591     if (AvARYLEN(thing)) {
 592       if (check_new(st, AvARYLEN(thing))) {
 593           thing_size(aTHX_ AvARYLEN(thing), st);
 594       }
 595     }
 596 #endif
 597     magic_size(thing, st);
 598     TAG;break;
 599   case SVt_PVHV: TAG;
 600     /* First the base struct */
 601     st->total_size += sizeof(XPVHV);
 602     /* Now the array of buckets */
 603     st->total_size += (sizeof(HE *) * (HvMAX(thing) + 1));
 604     /* Now walk the bucket chain */
 605     if (HvARRAY(thing)) {
 606       HE *cur_entry;
 607       UV cur_bucket = 0;
 608       for (cur_bucket = 0; cur_bucket <= HvMAX(thing); cur_bucket++) {
 609         cur_entry = *(HvARRAY(thing) + cur_bucket);
 610         while (cur_entry) {
 611           st->total_size += sizeof(HE);
 612           if (cur_entry->hent_hek) {
 613             /* Hash keys can be shared. Have we seen this before? */
 614             if (check_new(st, cur_entry->hent_hek)) {
 615               st->total_size += HEK_BASESIZE + cur_entry->hent_hek->hek_len + 2;
 616             }
 617           }
 618           cur_entry = cur_entry->hent_next;
 619         }
 620       }
 621     }
 622     magic_size(thing, st);
 623     TAG;break;
 624   case SVt_PVCV: TAG;
 625     st->total_size += sizeof(XPVCV);
 626     magic_size(thing, st);
 627
 628     st->total_size += ((XPVIO *) SvANY(thing))->xpv_len;
 629     if (check_new(st, CvSTASH(thing))) {
 630       thing_size(aTHX_ (SV *)CvSTASH(thing), st);
 631     }
 632     if (check_new(st, SvSTASH(thing))) {
 633       thing_size(aTHX_ (SV *)SvSTASH(thing), st);
 634     }
 635     if (check_new(st, CvGV(thing))) {
 636       thing_size(aTHX_ (SV *)CvGV(thing), st);
 637     }
 638     if (check_new(st, CvPADLIST(thing))) {
 639       thing_size(aTHX_ (SV *)CvPADLIST(thing), st);
 640     }
 641     if (check_new(st, CvOUTSIDE(thing))) {
 642       thing_size(aTHX_ (SV *)CvOUTSIDE(thing), st);
 643     }
 644     if (CvISXSUB(thing)) {
 645         SV *sv = cv_const_sv((CV *)thing);
 646         if (sv) {
 647             thing_size(aTHX_ sv, st);
 648         }
 649     } else {
 650         op_size(aTHX_ CvSTART(thing), st);
 651         op_size(aTHX_ CvROOT(thing), st);
 652     }
 653
 654     TAG;break;
 655   case SVt_PVGV: TAG;
 656     magic_size(thing, st);
 657     st->total_size += sizeof(XPVGV);
 658     st->total_size += GvNAMELEN(thing);
 659 #ifdef GvFILE
 660     /* Is there a file? */
 661     if (check_new(st, GvFILE(thing))) {
 662         st->total_size += strlen(GvFILE(thing));
 663     }
 664 #endif
 665     /* Is there something hanging off the glob? */
 666     if (GvGP(thing)) {
 667       if (check_new(st, GvGP(thing))) {
 668     st->total_size += sizeof(GP);
 669     {
 670       SV *generic_thing;
 671       if ((generic_thing = (SV *)(GvGP(thing)->gp_sv))) {
 672         thing_size(aTHX_ generic_thing, st);
 673       }
 674       if ((generic_thing = (SV *)(GvGP(thing)->gp_form))) {
 675         thing_size(aTHX_ generic_thing, st);
 676       }
 677       if ((generic_thing = (SV *)(GvGP(thing)->gp_av))) {
 678         thing_size(aTHX_ generic_thing, st);
 679       }
 680       if ((generic_thing = (SV *)(GvGP(thing)->gp_hv))) {
 681         thing_size(aTHX_ generic_thing, st);
 682       }
 683       if ((generic_thing = (SV *)(GvGP(thing)->gp_egv))) {
 684         thing_size(aTHX_ generic_thing, st);
 685       }
 686       if ((generic_thing = (SV *)(GvGP(thing)->gp_cv))) {
 687         thing_size(aTHX_ generic_thing, st);
 688       }
 689     }
 690       }
 691     }
 692     TAG;break;
 693   case SVt_PVFM: TAG;
 694     st->total_size += sizeof(XPVFM);
 695     magic_size(thing, st);
 696     st->total_size += ((XPVIO *) SvANY(thing))->xpv_len;
 697     if (check_new(st, CvPADLIST(thing))) {
 698       thing_size(aTHX_ (SV *)CvPADLIST(thing), st);
 699     }
 700     if (check_new(st, CvOUTSIDE(thing))) {
 701       thing_size(aTHX_ (SV *)CvOUTSIDE(thing), st);
 702     }
 703
 704     if (st->go_yell && !st->fm_whine) {
 705       carp("Devel::Size: Calculated sizes for FMs are incomplete");
 706       st->fm_whine = 1;
 707     }
 708     TAG;break;
 709   case SVt_PVIO: TAG;
 710     st->total_size += sizeof(XPVIO);
 711     magic_size(thing, st);
 712     if (check_new(st, (SvPVX_const(thing)))) {
 713       st->total_size += ((XPVIO *) SvANY(thing))->xpv_cur;
 714     }
 715     /* Some embedded char pointers */
 716     if (check_new(st, ((XPVIO *) SvANY(thing))->xio_top_name)) {
 717       st->total_size += strlen(((XPVIO *) SvANY(thing))->xio_top_name);
 718     }
 719     if (check_new(st, ((XPVIO *) SvANY(thing))->xio_fmt_name)) {
 720       st->total_size += strlen(((XPVIO *) SvANY(thing))->xio_fmt_name);
 721     }
 722     if (check_new(st, ((XPVIO *) SvANY(thing))->xio_bottom_name)) {
 723       st->total_size += strlen(((XPVIO *) SvANY(thing))->xio_bottom_name);
 724     }
 725     /* Throw the GVs on the list to be walked if they're not-null */
 726     if (((XPVIO *) SvANY(thing))->xio_top_gv) {
 727       thing_size(aTHX_ (SV *)((XPVIO *) SvANY(thing))->xio_top_gv, st);
 728     }
 729     if (((XPVIO *) SvANY(thing))->xio_bottom_gv) {
 730       thing_size(aTHX_ (SV *)((XPVIO *) SvANY(thing))->xio_bottom_gv, st);
 731     }
 732     if (((XPVIO *) SvANY(thing))->xio_fmt_gv) {
 733       thing_size(aTHX_ (SV *)((XPVIO *) SvANY(thing))->xio_fmt_gv, st);
 734     }
 735
 736     /* Only go trotting through the IO structures if they're really
 737        trottable. If USE_PERLIO is defined we can do this. If
 738        not... we can't, so we don't even try */
 739 #ifdef USE_PERLIO
 740     /* Dig into xio_ifp and xio_ofp here */
 741     warn("Devel::Size: Can't size up perlio layers yet\n");
 742 #endif
 743     TAG;break;
 744   default:
 745     warn("Devel::Size: Unknown variable type: %d encountered\n", SvTYPE(thing) );
 746   }
 747 }
 748
 749 static struct state *
 750 new_state(pTHX)
 751 {
 752     SV *warn_flag;
 753     struct state *st;
 754     Newxz(st, 1, struct state);
 755     st->go_yell = TRUE;
 756     if (NULL != (warn_flag = perl_get_sv("Devel::Size::warn", FALSE))) {
 757         st->dangle_whine = st->go_yell = SvIV(warn_flag) ? TRUE : FALSE;
 758     }
 759     if (NULL != (warn_flag = perl_get_sv("Devel::Size::dangle", FALSE))) {
 760         st->dangle_whine = SvIV(warn_flag) ? TRUE : FALSE;
 761     }
 762     return st;
 763 }
 764
 765 MODULE = Devel::Size        PACKAGE = Devel::Size
 766
 767 PROTOTYPES: DISABLE
 768
 769 UV
 770 size(orig_thing)
 771      SV *orig_thing
 772 CODE:
 773 {
 774   SV *thing = orig_thing;
 775   struct state *st = new_state(aTHX);
 776
 777   /* If they passed us a reference then dereference it. This is the
 778      only way we can check the sizes of arrays and hashes */
 779 #if (PERL_VERSION < 11)
 780   if (SvOK(thing) && SvROK(thing)) {
 781     thing = SvRV(thing);
 782   }
 783 #else
 784   if (SvROK(thing)) {
 785     thing = SvRV(thing);
 786   }
 787 #endif
 788
 789   thing_size(aTHX_ thing, st);
 790   RETVAL = st->total_size;
 791   free_state(st);
 792 }
 793 OUTPUT:
 794   RETVAL
 795
 796
 797 UV
 798 total_size(orig_thing)
 799        SV *orig_thing
 800 CODE:
 801 {
 802   SV *thing = orig_thing;
 803   /* Array with things we still need to do */
 804   AV *pending_array;
 805   IV size = 0;
 806   struct state *st = new_state(aTHX);
 807
 808   /* Size starts at zero */
 809   RETVAL = 0;
 810
 811   pending_array = newAV();
 812
 813   /* If they passed us a reference then dereference it.
 814      This is the only way we can check the sizes of arrays and hashes. */
 815   if (SvROK(thing)) {
 816       thing = SvRV(thing);
 817   }
 818
 819   /* Put it on the pending array */
 820   av_push(pending_array, thing);
 821
 822   /* Now just yank things off the end of the array until it's done */
 823   while (av_len(pending_array) >= 0) {
 824     thing = av_pop(pending_array);
 825     /* Process it if we've not seen it */
 826     if (check_new(st, thing)) {
 827       dbg_printf(("# Found type %i at %p\n", SvTYPE(thing), thing));
 828       /* Is it valid? */
 829       if (thing) {
 830     /* Yes, it is. So let's check the type */
 831     switch (SvTYPE(thing)) {
 832     /* fix for bug #24846 (Does not correctly recurse into references in a PVNV-type scalar) */
 833     case SVt_PVNV: TAG;
 834       if (SvROK(thing))
 835         {
 836         av_push(pending_array, SvRV(thing));
 837         }
 838       TAG;break;
 839 #if (PERL_VERSION < 11)
 840         case SVt_RV: TAG;
 841 #else
 842         case SVt_IV: TAG;
 843 #endif
 844              dbg_printf(("# Found RV\n"));
 845           if (SvROK(thing)) {
 846              dbg_printf(("# Found RV\n"));
 847              av_push(pending_array, SvRV(thing));
 848           }
 849           TAG;break;
 850
 851     case SVt_PVAV: TAG;
 852       {
 853         AV *tempAV = (AV *)thing;
 854         SV **tempSV;
 855
 856         dbg_printf(("# Found type AV\n"));
 857         /* Quick alias to cut down on casting */
 858
 859         /* Any elements? */
 860         if (av_len(tempAV) != -1) {
 861           IV index;
 862           /* Run through them all */
 863           for (index = 0; index <= av_len(tempAV); index++) {
 864         /* Did we get something? */
 865         if ((tempSV = av_fetch(tempAV, index, 0))) {
 866           /* Was it undef? */
 867           if (*tempSV != &PL_sv_undef) {
 868             /* Apparently not. Save it for later */
 869             av_push(pending_array, *tempSV);
 870           }
 871         }
 872           }
 873         }
 874       }
 875       TAG;break;
 876
 877     case SVt_PVHV: TAG;
 878       dbg_printf(("# Found type HV\n"));
 879       /* Is there anything in here? */
 880       if (hv_iterinit((HV *)thing)) {
 881         HE *temp_he;
 882         while ((temp_he = hv_iternext((HV *)thing))) {
 883           av_push(pending_array, hv_iterval((HV *)thing, temp_he));
 884         }
 885       }
 886       TAG;break;
 887
 888     case SVt_PVGV: TAG;
 889       dbg_printf(("# Found type GV\n"));
 890       /* Run through all the pieces and push the ones with bits */
 891       if (GvSV(thing)) {
 892         av_push(pending_array, (SV *)GvSV(thing));
 893       }
 894       if (GvFORM(thing)) {
 895         av_push(pending_array, (SV *)GvFORM(thing));
 896       }
 897       if (GvAV(thing)) {
 898         av_push(pending_array, (SV *)GvAV(thing));
 899       }
 900       if (GvHV(thing)) {
 901         av_push(pending_array, (SV *)GvHV(thing));
 902       }
 903       if (GvCV(thing)) {
 904         av_push(pending_array, (SV *)GvCV(thing));
 905       }
 906       TAG;break;
 907     default:
 908       TAG;break;
 909     }
 910       }
 911
 912       thing_size(aTHX_ thing, st);
 913     } else {
 914     /* check_new() returned false: */
 915 #ifdef DEVEL_SIZE_DEBUGGING
 916        if (SvOK(sv)) printf("# Ignore ref copy 0x%x\n", sv);
 917        else printf("# Ignore non-sv 0x%x\n", sv);
 918 #endif
 919     }
 920   } /* end while */
 921
 922   RETVAL = st->total_size;
 923   free_state(st);
 924   SvREFCNT_dec(pending_array);
 925 }
 926 OUTPUT:
 927   RETVAL
 928