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 check_new_and_strlen(struct state *st, const char *const p) {
 336     if(check_new(st, p))
 337         st->total_size += strlen(p);
 338 }
 339
 340 static void
 341 regex_size(const REGEXP * const baseregex, struct state *st) {
 342     if(!check_new(st, baseregex))
 343         return;
 344   st->total_size += sizeof(REGEXP);
 345 #if (PERL_VERSION < 11)
 346   /* Note the size of the paren offset thing */
 347   st->total_size += sizeof(I32) * baseregex->nparens * 2;
 348   st->total_size += strlen(baseregex->precomp);
 349 #else
 350   st->total_size += sizeof(struct regexp);
 351   st->total_size += sizeof(I32) * SvANY(baseregex)->nparens * 2;
 352   /*st->total_size += strlen(SvANY(baseregex)->subbeg);*/
 353 #endif
 354   if (st->go_yell && !st->regex_whine) {
 355     carp("Devel::Size: Calculated sizes for compiled regexes are incompatible, and probably always will be");
 356     st->regex_whine = 1;
 357   }
 358 }
 359
 360 static void
 361 op_size(pTHX_ const OP * const baseop, struct state *st)
 362 {
 363     TRY_TO_CATCH_SEGV {
 364         TAG;
 365         if(!check_new(st, baseop))
 366             return;
 367         TAG;
 368         op_size(aTHX_ baseop->op_next, st);
 369         TAG;
 370         switch (cc_opclass(baseop)) {
 371         case OPc_BASEOP: TAG;
 372             st->total_size += sizeof(struct op);
 373             TAG;break;
 374         case OPc_UNOP: TAG;
 375             st->total_size += sizeof(struct unop);
 376             op_size(aTHX_ cUNOPx(baseop)->op_first, st);
 377             TAG;break;
 378         case OPc_BINOP: TAG;
 379             st->total_size += sizeof(struct binop);
 380             op_size(aTHX_ cBINOPx(baseop)->op_first, st);
 381             op_size(aTHX_ cBINOPx(baseop)->op_last, st);
 382             TAG;break;
 383         case OPc_LOGOP: TAG;
 384             st->total_size += sizeof(struct logop);
 385             op_size(aTHX_ cBINOPx(baseop)->op_first, st);
 386             op_size(aTHX_ cLOGOPx(baseop)->op_other, st);
 387             TAG;break;
 388         case OPc_LISTOP: TAG;
 389             st->total_size += sizeof(struct listop);
 390             op_size(aTHX_ cLISTOPx(baseop)->op_first, st);
 391             op_size(aTHX_ cLISTOPx(baseop)->op_last, st);
 392             TAG;break;
 393         case OPc_PMOP: TAG;
 394             st->total_size += sizeof(struct pmop);
 395             op_size(aTHX_ cPMOPx(baseop)->op_first, st);
 396             op_size(aTHX_ cPMOPx(baseop)->op_last, st);
 397 #if PERL_VERSION < 9 || (PERL_VERSION == 9 && PERL_SUBVERSION < 5)
 398             op_size(aTHX_ cPMOPx(baseop)->op_pmreplroot, st);
 399             op_size(aTHX_ cPMOPx(baseop)->op_pmreplstart, st);
 400             op_size(aTHX_ (OP *)cPMOPx(baseop)->op_pmnext, st);
 401 #endif
 402             /* This is defined away in perl 5.8.x, but it is in there for
 403                5.6.x */
 404 #ifdef PM_GETRE
 405             regex_size(PM_GETRE(cPMOPx(baseop)), st);
 406 #else
 407             regex_size(cPMOPx(baseop)->op_pmregexp, st);
 408 #endif
 409             TAG;break;
 410       case OPc_SVOP: TAG;
 411         st->total_size += sizeof(struct pmop);
 412         if (check_new(st, cSVOPx(baseop)->op_sv)) {
 413           thing_size(aTHX_ cSVOPx(baseop)->op_sv, st);
 414         }
 415         TAG;break;
 416       case OPc_PADOP: TAG;
 417           st->total_size += sizeof(struct padop);
 418           TAG;break;
 419         case OPc_PVOP: TAG;
 420             check_new_and_strlen(st, cPVOPx(baseop)->op_pv);
 421         case OPc_LOOP: TAG;
 422             st->total_size += sizeof(struct loop);
 423             op_size(aTHX_ cLOOPx(baseop)->op_first, st);
 424             op_size(aTHX_ cLOOPx(baseop)->op_last, st);
 425             op_size(aTHX_ cLOOPx(baseop)->op_redoop, st);
 426             op_size(aTHX_ cLOOPx(baseop)->op_nextop, st);
 427             op_size(aTHX_ cLOOPx(baseop)->op_lastop, st);
 428             TAG;break;
 429         case OPc_COP: TAG;
 430         {
 431           COP *basecop;
 432           basecop = (COP *)baseop;
 433           st->total_size += sizeof(struct cop);
 434
 435           /* Change 33656 by nicholas@mouse-mill on 2008/04/07 11:29:51
 436           Eliminate cop_label from struct cop by storing a label as the first
 437           entry in the hints hash. Most statements don't have labels, so this
 438           will save memory. Not sure how much.
 439           The check below will be incorrect fail on bleadperls
 440           before 5.11 @33656, but later than 5.10, producing slightly too
 441           small memory sizes on these Perls. */
 442 #if (PERL_VERSION < 11)
 443           check_new_and_strlen(st, basecop->cop_label);
 444 #endif
 445 #ifdef USE_ITHREADS
 446           check_new_and_strlen(st, basecop->cop_file);
 447           check_new_and_strlen(st, basecop->cop_stashpv);
 448 #else
 449           if (check_new(st, basecop->cop_stash)) {
 450               thing_size(aTHX_ (SV *)basecop->cop_stash, st);
 451           }
 452           if (check_new(st, basecop->cop_filegv)) {
 453               thing_size(aTHX_ (SV *)basecop->cop_filegv, st);
 454           }
 455 #endif
 456
 457         }
 458         TAG;break;
 459       default:
 460         TAG;break;
 461       }
 462   }
 463   CAUGHT_EXCEPTION {
 464       if (st->dangle_whine)
 465           warn( "Devel::Size: Encountered dangling pointer in opcode at: %p\n", baseop );
 466   }
 467 }
 468
 469 #if PERL_VERSION > 9 || (PERL_VERSION == 9 && PERL_SUBVERSION > 2)
 470 #  define NEW_HEAD_LAYOUT
 471 #endif
 472
 473 static void
 474 thing_size(pTHX_ const SV * const orig_thing, struct state *st) {
 475   const SV *thing = orig_thing;
 476
 477   st->total_size += sizeof(SV);
 478
 479   switch (SvTYPE(thing)) {
 480     /* Is it undef? */
 481   case SVt_NULL: TAG;
 482     TAG;break;
 483     /* Just a plain integer. This will be differently sized depending
 484        on whether purify's been compiled in */
 485   case SVt_IV: TAG;
 486 #ifndef NEW_HEAD_LAYOUT
 487 #  ifdef PURIFY
 488     st->total_size += sizeof(sizeof(XPVIV));
 489 #  else
 490     st->total_size += sizeof(IV);
 491 #  endif
 492 #endif
 493     TAG;break;
 494     /* Is it a float? Like the int, it depends on purify */
 495   case SVt_NV: TAG;
 496 #ifdef PURIFY
 497     st->total_size += sizeof(sizeof(XPVNV));
 498 #else
 499     st->total_size += sizeof(NV);
 500 #endif
 501     TAG;break;
 502 #if (PERL_VERSION < 11)
 503     /* Is it a reference? */
 504   case SVt_RV: TAG;
 505 #ifndef NEW_HEAD_LAYOUT
 506     st->total_size += sizeof(XRV);
 507 #endif
 508     TAG;break;
 509 #endif
 510     /* How about a plain string? In which case we need to add in how
 511        much has been allocated */
 512   case SVt_PV: TAG;
 513     st->total_size += sizeof(XPV);
 514     if(SvROK(thing))
 515         thing_size(aTHX_ SvRV_const(thing), st);
 516     else
 517         st->total_size += SvLEN(thing);
 518     TAG;break;
 519     /* A string with an integer part? */
 520   case SVt_PVIV: TAG;
 521     st->total_size += sizeof(XPVIV);
 522     if(SvROK(thing))
 523         thing_size(aTHX_ SvRV_const(thing), st);
 524     else
 525         st->total_size += SvLEN(thing);
 526     if(SvOOK(thing)) {
 527         st->total_size += SvIVX(thing);
 528     }
 529     TAG;break;
 530     /* A scalar/string/reference with a float part? */
 531   case SVt_PVNV: TAG;
 532     st->total_size += sizeof(XPVNV);
 533     if(SvROK(thing))
 534         thing_size(aTHX_ SvRV_const(thing), st);
 535     else
 536         st->total_size += SvLEN(thing);
 537     TAG;break;
 538   case SVt_PVMG: TAG;
 539     st->total_size += sizeof(XPVMG);
 540     if(SvROK(thing))
 541         thing_size(aTHX_ SvRV_const(thing), st);
 542     else
 543         st->total_size += SvLEN(thing);
 544     magic_size(thing, st);
 545     TAG;break;
 546 #if PERL_VERSION <= 8
 547   case SVt_PVBM: TAG;
 548     st->total_size += sizeof(XPVBM);
 549     if(SvROK(thing))
 550         thing_size(aTHX_ SvRV_const(thing), st);
 551     else
 552         st->total_size += SvLEN(thing);
 553     magic_size(thing, st);
 554     TAG;break;
 555 #endif
 556   case SVt_PVLV: TAG;
 557     st->total_size += sizeof(XPVLV);
 558     if(SvROK(thing))
 559         thing_size(aTHX_ SvRV_const(thing), st);
 560     else
 561         st->total_size += SvLEN(thing);
 562     magic_size(thing, st);
 563     TAG;break;
 564     /* How much space is dedicated to the array? Not counting the
 565        elements in the array, mind, just the array itself */
 566   case SVt_PVAV: TAG;
 567     st->total_size += sizeof(XPVAV);
 568     /* Is there anything in the array? */
 569     if (AvMAX(thing) != -1) {
 570       /* an array with 10 slots has AvMax() set to 9 - te 2007-04-22 */
 571       st->total_size += sizeof(SV *) * (AvMAX(thing) + 1);
 572       dbg_printf(("total_size: %li AvMAX: %li av_len: $i\n", st->total_size, AvMAX(thing), av_len((AV*)thing)));
 573     }
 574     /* Add in the bits on the other side of the beginning */
 575
 576     dbg_printf(("total_size %li, sizeof(SV *) %li, AvARRAY(thing) %li, AvALLOC(thing)%li , sizeof(ptr) %li \n",
 577     st->total_size, sizeof(SV*), AvARRAY(thing), AvALLOC(thing), sizeof( thing )));
 578
 579     /* under Perl 5.8.8 64bit threading, AvARRAY(thing) was a pointer while AvALLOC was 0,
 580        resulting in grossly overstated sized for arrays. Technically, this shouldn't happen... */
 581     if (AvALLOC(thing) != 0) {
 582       st->total_size += (sizeof(SV *) * (AvARRAY(thing) - AvALLOC(thing)));
 583       }
 584 #if (PERL_VERSION < 9)
 585     /* Is there something hanging off the arylen element?
 586        Post 5.9.something this is stored in magic, so will be found there,
 587        and Perl_av_arylen_p() takes a non-const AV*, hence compilers rightly
 588        complain about AvARYLEN() passing thing to it.  */
 589     if (AvARYLEN(thing)) {
 590       if (check_new(st, AvARYLEN(thing))) {
 591           thing_size(aTHX_ AvARYLEN(thing), st);
 592       }
 593     }
 594 #endif
 595     magic_size(thing, st);
 596     TAG;break;
 597   case SVt_PVHV: TAG;
 598     /* First the base struct */
 599     st->total_size += sizeof(XPVHV);
 600     /* Now the array of buckets */
 601     st->total_size += (sizeof(HE *) * (HvMAX(thing) + 1));
 602     /* Now walk the bucket chain */
 603     if (HvARRAY(thing)) {
 604       HE *cur_entry;
 605       UV cur_bucket = 0;
 606       for (cur_bucket = 0; cur_bucket <= HvMAX(thing); cur_bucket++) {
 607         cur_entry = *(HvARRAY(thing) + cur_bucket);
 608         while (cur_entry) {
 609           st->total_size += sizeof(HE);
 610           if (cur_entry->hent_hek) {
 611             /* Hash keys can be shared. Have we seen this before? */
 612             if (check_new(st, cur_entry->hent_hek)) {
 613               st->total_size += HEK_BASESIZE + cur_entry->hent_hek->hek_len + 2;
 614             }
 615           }
 616           cur_entry = cur_entry->hent_next;
 617         }
 618       }
 619     }
 620     magic_size(thing, st);
 621     TAG;break;
 622   case SVt_PVCV: TAG;
 623     st->total_size += sizeof(XPVCV);
 624     magic_size(thing, st);
 625
 626     st->total_size += ((XPVIO *) SvANY(thing))->xpv_len;
 627     if (check_new(st, CvSTASH(thing))) {
 628       thing_size(aTHX_ (SV *)CvSTASH(thing), st);
 629     }
 630     if (check_new(st, SvSTASH(thing))) {
 631       thing_size(aTHX_ (SV *)SvSTASH(thing), st);
 632     }
 633     if (check_new(st, CvGV(thing))) {
 634       thing_size(aTHX_ (SV *)CvGV(thing), st);
 635     }
 636     if (check_new(st, CvPADLIST(thing))) {
 637       thing_size(aTHX_ (SV *)CvPADLIST(thing), st);
 638     }
 639     if (check_new(st, CvOUTSIDE(thing))) {
 640       thing_size(aTHX_ (SV *)CvOUTSIDE(thing), st);
 641     }
 642     if (CvISXSUB(thing)) {
 643         SV *sv = cv_const_sv((CV *)thing);
 644         if (sv) {
 645             thing_size(aTHX_ sv, st);
 646         }
 647     } else {
 648         op_size(aTHX_ CvSTART(thing), st);
 649         op_size(aTHX_ CvROOT(thing), st);
 650     }
 651
 652     TAG;break;
 653   case SVt_PVGV: TAG;
 654     magic_size(thing, st);
 655     st->total_size += sizeof(XPVGV);
 656     st->total_size += GvNAMELEN(thing);
 657 #ifdef GvFILE
 658     /* Is there a file? */
 659     check_new_and_strlen(st, GvFILE(thing));
 660 #endif
 661     /* Is there something hanging off the glob? */
 662     if (GvGP(thing)) {
 663       if (check_new(st, GvGP(thing))) {
 664     st->total_size += sizeof(GP);
 665     {
 666       SV *generic_thing;
 667       if ((generic_thing = (SV *)(GvGP(thing)->gp_sv))) {
 668         thing_size(aTHX_ generic_thing, st);
 669       }
 670       if ((generic_thing = (SV *)(GvGP(thing)->gp_form))) {
 671         thing_size(aTHX_ generic_thing, st);
 672       }
 673       if ((generic_thing = (SV *)(GvGP(thing)->gp_av))) {
 674         thing_size(aTHX_ generic_thing, st);
 675       }
 676       if ((generic_thing = (SV *)(GvGP(thing)->gp_hv))) {
 677         thing_size(aTHX_ generic_thing, st);
 678       }
 679       if ((generic_thing = (SV *)(GvGP(thing)->gp_egv))) {
 680         thing_size(aTHX_ generic_thing, st);
 681       }
 682       if ((generic_thing = (SV *)(GvGP(thing)->gp_cv))) {
 683         thing_size(aTHX_ generic_thing, st);
 684       }
 685     }
 686       }
 687     }
 688     TAG;break;
 689   case SVt_PVFM: TAG;
 690     st->total_size += sizeof(XPVFM);
 691     magic_size(thing, st);
 692     st->total_size += ((XPVIO *) SvANY(thing))->xpv_len;
 693     if (check_new(st, CvPADLIST(thing))) {
 694       thing_size(aTHX_ (SV *)CvPADLIST(thing), st);
 695     }
 696     if (check_new(st, CvOUTSIDE(thing))) {
 697       thing_size(aTHX_ (SV *)CvOUTSIDE(thing), st);
 698     }
 699
 700     if (st->go_yell && !st->fm_whine) {
 701       carp("Devel::Size: Calculated sizes for FMs are incomplete");
 702       st->fm_whine = 1;
 703     }
 704     TAG;break;
 705   case SVt_PVIO: TAG;
 706     st->total_size += sizeof(XPVIO);
 707     magic_size(thing, st);
 708     if (check_new(st, (SvPVX_const(thing)))) {
 709       st->total_size += ((XPVIO *) SvANY(thing))->xpv_cur;
 710     }
 711     /* Some embedded char pointers */
 712     check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_top_name);
 713     check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_fmt_name);
 714     check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_bottom_name);
 715     /* Throw the GVs on the list to be walked if they're not-null */
 716     if (((XPVIO *) SvANY(thing))->xio_top_gv) {
 717       thing_size(aTHX_ (SV *)((XPVIO *) SvANY(thing))->xio_top_gv, st);
 718     }
 719     if (((XPVIO *) SvANY(thing))->xio_bottom_gv) {
 720       thing_size(aTHX_ (SV *)((XPVIO *) SvANY(thing))->xio_bottom_gv, st);
 721     }
 722     if (((XPVIO *) SvANY(thing))->xio_fmt_gv) {
 723       thing_size(aTHX_ (SV *)((XPVIO *) SvANY(thing))->xio_fmt_gv, st);
 724     }
 725
 726     /* Only go trotting through the IO structures if they're really
 727        trottable. If USE_PERLIO is defined we can do this. If
 728        not... we can't, so we don't even try */
 729 #ifdef USE_PERLIO
 730     /* Dig into xio_ifp and xio_ofp here */
 731     warn("Devel::Size: Can't size up perlio layers yet\n");
 732 #endif
 733     TAG;break;
 734   default:
 735     warn("Devel::Size: Unknown variable type: %d encountered\n", SvTYPE(thing) );
 736   }
 737 }
 738
 739 static struct state *
 740 new_state(pTHX)
 741 {
 742     SV *warn_flag;
 743     struct state *st;
 744     Newxz(st, 1, struct state);
 745     st->go_yell = TRUE;
 746     if (NULL != (warn_flag = perl_get_sv("Devel::Size::warn", FALSE))) {
 747         st->dangle_whine = st->go_yell = SvIV(warn_flag) ? TRUE : FALSE;
 748     }
 749     if (NULL != (warn_flag = perl_get_sv("Devel::Size::dangle", FALSE))) {
 750         st->dangle_whine = SvIV(warn_flag) ? TRUE : FALSE;
 751     }
 752     return st;
 753 }
 754
 755 MODULE = Devel::Size        PACKAGE = Devel::Size
 756
 757 PROTOTYPES: DISABLE
 758
 759 UV
 760 size(orig_thing)
 761      SV *orig_thing
 762 CODE:
 763 {
 764   SV *thing = orig_thing;
 765   struct state *st = new_state(aTHX);
 766
 767   /* If they passed us a reference then dereference it. This is the
 768      only way we can check the sizes of arrays and hashes */
 769 #if (PERL_VERSION < 11)
 770   if (SvOK(thing) && SvROK(thing)) {
 771     thing = SvRV(thing);
 772   }
 773 #else
 774   if (SvROK(thing)) {
 775     thing = SvRV(thing);
 776   }
 777 #endif
 778
 779   thing_size(aTHX_ thing, st);
 780   RETVAL = st->total_size;
 781   free_state(st);
 782 }
 783 OUTPUT:
 784   RETVAL
 785
 786
 787 UV
 788 total_size(orig_thing)
 789        SV *orig_thing
 790 CODE:
 791 {
 792   SV *thing = orig_thing;
 793   /* Array with things we still need to do */
 794   AV *pending_array;
 795   IV size = 0;
 796   struct state *st = new_state(aTHX);
 797
 798   /* Size starts at zero */
 799   RETVAL = 0;
 800
 801   pending_array = newAV();
 802
 803   /* If they passed us a reference then dereference it.
 804      This is the only way we can check the sizes of arrays and hashes. */
 805   if (SvROK(thing)) {
 806       thing = SvRV(thing);
 807   }
 808
 809   /* Put it on the pending array */
 810   av_push(pending_array, thing);
 811
 812   /* Now just yank things off the end of the array until it's done */
 813   while (av_len(pending_array) >= 0) {
 814     thing = av_pop(pending_array);
 815     /* Process it if we've not seen it */
 816     if (check_new(st, thing)) {
 817       dbg_printf(("# Found type %i at %p\n", SvTYPE(thing), thing));
 818       /* Is it valid? */
 819       if (thing) {
 820     /* Yes, it is. So let's check the type */
 821     switch (SvTYPE(thing)) {
 822     /* fix for bug #24846 (Does not correctly recurse into references in a PVNV-type scalar) */
 823     case SVt_PVNV: TAG;
 824       if (SvROK(thing))
 825         {
 826         av_push(pending_array, SvRV(thing));
 827         }
 828       TAG;break;
 829 #if (PERL_VERSION < 11)
 830         case SVt_RV: TAG;
 831 #else
 832         case SVt_IV: TAG;
 833 #endif
 834              dbg_printf(("# Found RV\n"));
 835           if (SvROK(thing)) {
 836              dbg_printf(("# Found RV\n"));
 837              av_push(pending_array, SvRV(thing));
 838           }
 839           TAG;break;
 840
 841     case SVt_PVAV: TAG;
 842       {
 843         AV *tempAV = (AV *)thing;
 844         SV **tempSV;
 845
 846         dbg_printf(("# Found type AV\n"));
 847         /* Quick alias to cut down on casting */
 848
 849         /* Any elements? */
 850         if (av_len(tempAV) != -1) {
 851           IV index;
 852           /* Run through them all */
 853           for (index = 0; index <= av_len(tempAV); index++) {
 854         /* Did we get something? */
 855         if ((tempSV = av_fetch(tempAV, index, 0))) {
 856           /* Was it undef? */
 857           if (*tempSV != &PL_sv_undef) {
 858             /* Apparently not. Save it for later */
 859             av_push(pending_array, *tempSV);
 860           }
 861         }
 862           }
 863         }
 864       }
 865       TAG;break;
 866
 867     case SVt_PVHV: TAG;
 868       dbg_printf(("# Found type HV\n"));
 869       /* Is there anything in here? */
 870       if (hv_iterinit((HV *)thing)) {
 871         HE *temp_he;
 872         while ((temp_he = hv_iternext((HV *)thing))) {
 873           av_push(pending_array, hv_iterval((HV *)thing, temp_he));
 874         }
 875       }
 876       TAG;break;
 877
 878     case SVt_PVGV: TAG;
 879       dbg_printf(("# Found type GV\n"));
 880       /* Run through all the pieces and push the ones with bits */
 881       if (GvSV(thing)) {
 882         av_push(pending_array, (SV *)GvSV(thing));
 883       }
 884       if (GvFORM(thing)) {
 885         av_push(pending_array, (SV *)GvFORM(thing));
 886       }
 887       if (GvAV(thing)) {
 888         av_push(pending_array, (SV *)GvAV(thing));
 889       }
 890       if (GvHV(thing)) {
 891         av_push(pending_array, (SV *)GvHV(thing));
 892       }
 893       if (GvCV(thing)) {
 894         av_push(pending_array, (SV *)GvCV(thing));
 895       }
 896       TAG;break;
 897     default:
 898       TAG;break;
 899     }
 900       }
 901
 902       thing_size(aTHX_ thing, st);
 903     } else {
 904     /* check_new() returned false: */
 905 #ifdef DEVEL_SIZE_DEBUGGING
 906        if (SvOK(sv)) printf("# Ignore ref copy 0x%x\n", sv);
 907        else printf("# Ignore non-sv 0x%x\n", sv);
 908 #endif
 909     }
 910   } /* end while */
 911
 912   RETVAL = st->total_size;
 913   free_state(st);
 914   SvREFCNT_dec(pending_array);
 915 }
 916 OUTPUT:
 917   RETVAL
 918