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