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 BYTE_BITS    3
  50 #define LEAF_BITS   (16 - BYTE_BITS)
  51 #define LEAF_MASK   0x1FFF
  52
  53 struct state {
  54     UV total_size;
  55     bool regex_whine;
  56     bool fm_whine;
  57     bool dangle_whine;
  58     bool go_yell;
  59     /* My hunch (not measured) is that for most architectures pointers will
  60        start with 0 bits, hence the start of this array will be hot, and the
  61        end unused. So put the flags next to the hot end.  */
  62     void *tracking[256];
  63 };
  64
  65 /*
  66     Checks to see if thing is in the bitstring.
  67     Returns true or false, and
  68     notes thing in the segmented bitstring.
  69  */
  70 static bool
  71 check_new(struct state *st, const void *const p) {
  72     unsigned int bits = 8 * sizeof(void*);
  73     const size_t raw_p = PTR2nat(p);
  74     /* This effectively rotates the value right by the number of low always-0
  75        bits in an aligned pointer. The assmption is that most (if not all)
  76        pointers are aligned, and these will be in the same chain of nodes
  77        (and hence hot in the cache) but we can still deal with any unaligned
  78        pointers.  */
  79     const size_t cooked_p
  80         = (raw_p >> ALIGN_BITS) | (raw_p << (bits - ALIGN_BITS));
  81     const U8 this_bit = 1 << (cooked_p & 0x7);
  82     U8 **leaf_p;
  83     U8 *leaf;
  84     unsigned int i;
  85     void **tv_p = (void **) (st->tracking);
  86
  87     if (NULL == p) return FALSE;
  88     TRY_TO_CATCH_SEGV {
  89         const char c = *(const char *)p;
  90     }
  91     CAUGHT_EXCEPTION {
  92         if (st->dangle_whine)
  93             warn( "Devel::Size: Encountered invalid pointer: %p\n", p );
  94         return FALSE;
  95     }
  96     TAG;
  97
  98     bits -= 8;
  99     /* bits now 24 (32 bit pointers) or 56 (64 bit pointers) */
 100
 101     /* First level is always present.  */
 102     do {
 103         i = (unsigned int)((cooked_p >> bits) & 0xFF);
 104         if (!tv_p[i])
 105             Newxz(tv_p[i], 256, void *);
 106         tv_p = (void **)(tv_p[i]);
 107         bits -= 8;
 108     } while (bits > LEAF_BITS + BYTE_BITS);
 109     /* bits now 16 always */
 110 #if !defined(MULTIPLICITY) || PERL_VERSION > 8 || (PERL_VERSION == 8 && PERL_SUBVERSION > 8)
 111     /* 5.8.8 and early have an assert() macro that uses Perl_croak, hence needs
 112        a my_perl under multiplicity  */
 113     assert(bits == 16);
 114 #endif
 115     leaf_p = (U8 **)tv_p;
 116     i = (unsigned int)((cooked_p >> bits) & 0xFF);
 117     if (!leaf_p[i])
 118         Newxz(leaf_p[i], 1 << LEAF_BITS, U8);
 119     leaf = leaf_p[i];
 120
 121     TAG;
 122
 123     i = (unsigned int)((cooked_p >> BYTE_BITS) & LEAF_MASK);
 124
 125     if(leaf[i] & this_bit)
 126         return FALSE;
 127
 128     leaf[i] |= this_bit;
 129     return TRUE;
 130 }
 131
 132 static void
 133 free_tracking_at(void **tv, int level)
 134 {
 135     int i = 255;
 136
 137     if (--level) {
 138         /* Nodes */
 139         do {
 140             if (tv[i]) {
 141                 free_tracking_at(tv[i], level);
 142                 Safefree(tv[i]);
 143             }
 144         } while (i--);
 145     } else {
 146         /* Leaves */
 147         do {
 148             if (tv[i])
 149                 Safefree(tv[i]);
 150         } while (i--);
 151     }
 152 }
 153
 154 static void
 155 free_state(struct state *st)
 156 {
 157     const int top_level = (sizeof(void *) * 8 - LEAF_BITS - BYTE_BITS) / 8;
 158     free_tracking_at((void **)st->tracking, top_level);
 159     Safefree(st);
 160 }
 161
 162 /* For now, this is somewhat a compatibility bodge until the plan comes
 163    together for fine grained recursion control. total_size() would recurse into
 164    hash and array members, whereas sv_size() would not. However, sv_size() is
 165    called with CvSTASH() of a CV, which means that if it (also) starts to
 166    recurse fully, then the size of any CV now becomes the size of the entire
 167    symbol table reachable from it, and potentially the entire symbol table, if
 168    any subroutine makes a reference to a global (such as %SIG). The historical
 169    implementation of total_size() didn't report "everything", and changing the
 170    only available size to "everything" doesn't feel at all useful.  */
 171
 172 #define NO_RECURSION 0
 173 #define SOME_RECURSION 1
 174 #define TOTAL_SIZE_RECURSION 2
 175
 176 static bool sv_size(pTHX_ struct state *, const SV *const, const int recurse);
 177
 178 typedef enum {
 179     OPc_NULL,   /* 0 */
 180     OPc_BASEOP, /* 1 */
 181     OPc_UNOP,   /* 2 */
 182     OPc_BINOP,  /* 3 */
 183     OPc_LOGOP,  /* 4 */
 184     OPc_LISTOP, /* 5 */
 185     OPc_PMOP,   /* 6 */
 186     OPc_SVOP,   /* 7 */
 187     OPc_PADOP,  /* 8 */
 188     OPc_PVOP,   /* 9 */
 189     OPc_LOOP,   /* 10 */
 190     OPc_COP /* 11 */
 191 } opclass;
 192
 193 static opclass
 194 cc_opclass(const OP * const o)
 195 {
 196     if (!o)
 197     return OPc_NULL;
 198     TRY_TO_CATCH_SEGV {
 199         if (o->op_type == 0)
 200         return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
 201
 202         if (o->op_type == OP_SASSIGN)
 203         return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPc_UNOP : OPc_BINOP);
 204
 205     #ifdef USE_ITHREADS
 206         if (o->op_type == OP_GV || o->op_type == OP_GVSV || o->op_type == OP_AELEMFAST)
 207         return OPc_PADOP;
 208     #endif
 209
 210         if ((o->op_type == OP_TRANS)) {
 211           return OPc_BASEOP;
 212         }
 213
 214         switch (PL_opargs[o->op_type] & OA_CLASS_MASK) {
 215         case OA_BASEOP: TAG;
 216         return OPc_BASEOP;
 217
 218         case OA_UNOP: TAG;
 219         return OPc_UNOP;
 220
 221         case OA_BINOP: TAG;
 222         return OPc_BINOP;
 223
 224         case OA_LOGOP: TAG;
 225         return OPc_LOGOP;
 226
 227         case OA_LISTOP: TAG;
 228         return OPc_LISTOP;
 229
 230         case OA_PMOP: TAG;
 231         return OPc_PMOP;
 232
 233         case OA_SVOP: TAG;
 234         return OPc_SVOP;
 235
 236         case OA_PADOP: TAG;
 237         return OPc_PADOP;
 238
 239         case OA_PVOP_OR_SVOP: TAG;
 240             /*
 241              * Character translations (tr///) are usually a PVOP, keeping a
 242              * pointer to a table of shorts used to look up translations.
 243              * Under utf8, however, a simple table isn't practical; instead,
 244              * the OP is an SVOP, and the SV is a reference to a swash
 245              * (i.e., an RV pointing to an HV).
 246              */
 247         return (o->op_private & (OPpTRANS_TO_UTF|OPpTRANS_FROM_UTF))
 248             ? OPc_SVOP : OPc_PVOP;
 249
 250         case OA_LOOP: TAG;
 251         return OPc_LOOP;
 252
 253         case OA_COP: TAG;
 254         return OPc_COP;
 255
 256         case OA_BASEOP_OR_UNOP: TAG;
 257         /*
 258          * UNI(OP_foo) in toke.c returns token UNI or FUNC1 depending on
 259          * whether parens were seen. perly.y uses OPf_SPECIAL to
 260          * signal whether a BASEOP had empty parens or none.
 261          * Some other UNOPs are created later, though, so the best
 262          * test is OPf_KIDS, which is set in newUNOP.
 263          */
 264         return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
 265
 266         case OA_FILESTATOP: TAG;
 267         /*
 268          * The file stat OPs are created via UNI(OP_foo) in toke.c but use
 269          * the OPf_REF flag to distinguish between OP types instead of the
 270          * usual OPf_SPECIAL flag. As usual, if OPf_KIDS is set, then we
 271          * return OPc_UNOP so that walkoptree can find our children. If
 272          * OPf_KIDS is not set then we check OPf_REF. Without OPf_REF set
 273          * (no argument to the operator) it's an OP; with OPf_REF set it's
 274          * an SVOP (and op_sv is the GV for the filehandle argument).
 275          */
 276         return ((o->op_flags & OPf_KIDS) ? OPc_UNOP :
 277     #ifdef USE_ITHREADS
 278             (o->op_flags & OPf_REF) ? OPc_PADOP : OPc_BASEOP);
 279     #else
 280             (o->op_flags & OPf_REF) ? OPc_SVOP : OPc_BASEOP);
 281     #endif
 282         case OA_LOOPEXOP: TAG;
 283         /*
 284          * next, last, redo, dump and goto use OPf_SPECIAL to indicate that a
 285          * label was omitted (in which case it's a BASEOP) or else a term was
 286          * seen. In this last case, all except goto are definitely PVOP but
 287          * goto is either a PVOP (with an ordinary constant label), an UNOP
 288          * with OPf_STACKED (with a non-constant non-sub) or an UNOP for
 289          * OP_REFGEN (with goto &sub) in which case OPf_STACKED also seems to
 290          * get set.
 291          */
 292         if (o->op_flags & OPf_STACKED)
 293             return OPc_UNOP;
 294         else if (o->op_flags & OPf_SPECIAL)
 295             return OPc_BASEOP;
 296         else
 297             return OPc_PVOP;
 298         }
 299         warn("Devel::Size: Can't determine class of operator %s, assuming BASEOP\n",
 300          PL_op_name[o->op_type]);
 301     }
 302     CAUGHT_EXCEPTION { }
 303     return OPc_BASEOP;
 304 }
 305
 306
 307 #if !defined(NV)
 308 #define NV double
 309 #endif
 310
 311 /* Figure out how much magic is attached to the SV and return the
 312    size */
 313 static void
 314 magic_size(pTHX_ const SV * const thing, struct state *st) {
 315   MAGIC *magic_pointer;
 316
 317   /* Is there any? */
 318   if (!SvMAGIC(thing)) {
 319     /* No, bail */
 320     return;
 321   }
 322
 323   /* Get the base magic pointer */
 324   magic_pointer = SvMAGIC(thing);
 325
 326   /* Have we seen the magic pointer? */
 327   while (check_new(st, magic_pointer)) {
 328     st->total_size += sizeof(MAGIC);
 329
 330     TRY_TO_CATCH_SEGV {
 331         /* Have we seen the magic vtable? */
 332         if (check_new(st, magic_pointer->mg_virtual)) {
 333           st->total_size += sizeof(MGVTBL);
 334         }
 335         sv_size(aTHX_ st, magic_pointer->mg_obj, TOTAL_SIZE_RECURSION);
 336
 337         /* Get the next in the chain */
 338         magic_pointer = magic_pointer->mg_moremagic;
 339     }
 340     CAUGHT_EXCEPTION {
 341         if (st->dangle_whine)
 342             warn( "Devel::Size: Encountered bad magic at: %p\n", magic_pointer );
 343     }
 344   }
 345 }
 346
 347 static void
 348 check_new_and_strlen(struct state *st, const char *const p) {
 349     if(check_new(st, p))
 350         st->total_size += 1 + strlen(p);
 351 }
 352
 353 static void
 354 regex_size(const REGEXP * const baseregex, struct state *st) {
 355     if(!check_new(st, baseregex))
 356         return;
 357   st->total_size += sizeof(REGEXP);
 358 #if (PERL_VERSION < 11)
 359   /* Note the size of the paren offset thing */
 360   st->total_size += sizeof(I32) * baseregex->nparens * 2;
 361   st->total_size += strlen(baseregex->precomp);
 362 #else
 363   st->total_size += sizeof(struct regexp);
 364   st->total_size += sizeof(I32) * SvANY(baseregex)->nparens * 2;
 365   /*st->total_size += strlen(SvANY(baseregex)->subbeg);*/
 366 #endif
 367   if (st->go_yell && !st->regex_whine) {
 368     carp("Devel::Size: Calculated sizes for compiled regexes are incompatible, and probably always will be");
 369     st->regex_whine = 1;
 370   }
 371 }
 372
 373 static void
 374 op_size(pTHX_ const OP * const baseop, struct state *st)
 375 {
 376     TRY_TO_CATCH_SEGV {
 377         TAG;
 378         if(!check_new(st, baseop))
 379             return;
 380         TAG;
 381         op_size(aTHX_ baseop->op_next, st);
 382         TAG;
 383         switch (cc_opclass(baseop)) {
 384         case OPc_BASEOP: TAG;
 385             st->total_size += sizeof(struct op);
 386             TAG;break;
 387         case OPc_UNOP: TAG;
 388             st->total_size += sizeof(struct unop);
 389             op_size(aTHX_ cUNOPx(baseop)->op_first, st);
 390             TAG;break;
 391         case OPc_BINOP: TAG;
 392             st->total_size += sizeof(struct binop);
 393             op_size(aTHX_ cBINOPx(baseop)->op_first, st);
 394             op_size(aTHX_ cBINOPx(baseop)->op_last, st);
 395             TAG;break;
 396         case OPc_LOGOP: TAG;
 397             st->total_size += sizeof(struct logop);
 398             op_size(aTHX_ cBINOPx(baseop)->op_first, st);
 399             op_size(aTHX_ cLOGOPx(baseop)->op_other, st);
 400             TAG;break;
 401         case OPc_LISTOP: TAG;
 402             st->total_size += sizeof(struct listop);
 403             op_size(aTHX_ cLISTOPx(baseop)->op_first, st);
 404             op_size(aTHX_ cLISTOPx(baseop)->op_last, st);
 405             TAG;break;
 406         case OPc_PMOP: TAG;
 407             st->total_size += sizeof(struct pmop);
 408             op_size(aTHX_ cPMOPx(baseop)->op_first, st);
 409             op_size(aTHX_ cPMOPx(baseop)->op_last, st);
 410 #if PERL_VERSION < 9 || (PERL_VERSION == 9 && PERL_SUBVERSION < 5)
 411             op_size(aTHX_ cPMOPx(baseop)->op_pmreplroot, st);
 412             op_size(aTHX_ cPMOPx(baseop)->op_pmreplstart, st);
 413             op_size(aTHX_ (OP *)cPMOPx(baseop)->op_pmnext, st);
 414 #endif
 415             /* This is defined away in perl 5.8.x, but it is in there for
 416                5.6.x */
 417 #ifdef PM_GETRE
 418             regex_size(PM_GETRE(cPMOPx(baseop)), st);
 419 #else
 420             regex_size(cPMOPx(baseop)->op_pmregexp, st);
 421 #endif
 422             TAG;break;
 423         case OPc_SVOP: TAG;
 424             st->total_size += sizeof(struct pmop);
 425             if (!(baseop->op_type == OP_AELEMFAST
 426                   && baseop->op_flags & OPf_SPECIAL)) {
 427                 /* not an OP_PADAV replacement */
 428                 sv_size(aTHX_ st, cSVOPx(baseop)->op_sv, SOME_RECURSION);
 429             }
 430             TAG;break;
 431       case OPc_PADOP: TAG;
 432           st->total_size += sizeof(struct padop);
 433           TAG;break;
 434         case OPc_PVOP: TAG;
 435             check_new_and_strlen(st, cPVOPx(baseop)->op_pv);
 436             TAG;break;
 437         case OPc_LOOP: TAG;
 438             st->total_size += sizeof(struct loop);
 439             op_size(aTHX_ cLOOPx(baseop)->op_first, st);
 440             op_size(aTHX_ cLOOPx(baseop)->op_last, st);
 441             op_size(aTHX_ cLOOPx(baseop)->op_redoop, st);
 442             op_size(aTHX_ cLOOPx(baseop)->op_nextop, st);
 443             op_size(aTHX_ cLOOPx(baseop)->op_lastop, st);
 444             TAG;break;
 445         case OPc_COP: TAG;
 446         {
 447           COP *basecop;
 448           basecop = (COP *)baseop;
 449           st->total_size += sizeof(struct cop);
 450
 451           /* Change 33656 by nicholas@mouse-mill on 2008/04/07 11:29:51
 452           Eliminate cop_label from struct cop by storing a label as the first
 453           entry in the hints hash. Most statements don't have labels, so this
 454           will save memory. Not sure how much.
 455           The check below will be incorrect fail on bleadperls
 456           before 5.11 @33656, but later than 5.10, producing slightly too
 457           small memory sizes on these Perls. */
 458 #if (PERL_VERSION < 11)
 459           check_new_and_strlen(st, basecop->cop_label);
 460 #endif
 461 #ifdef USE_ITHREADS
 462           check_new_and_strlen(st, basecop->cop_file);
 463           check_new_and_strlen(st, basecop->cop_stashpv);
 464 #else
 465           sv_size(aTHX_ st, (SV *)basecop->cop_stash, SOME_RECURSION);
 466           sv_size(aTHX_ st, (SV *)basecop->cop_filegv, SOME_RECURSION);
 467 #endif
 468
 469         }
 470         TAG;break;
 471       default:
 472         TAG;break;
 473       }
 474   }
 475   CAUGHT_EXCEPTION {
 476       if (st->dangle_whine)
 477           warn( "Devel::Size: Encountered dangling pointer in opcode at: %p\n", baseop );
 478   }
 479 }
 480
 481 #if PERL_VERSION > 9 || (PERL_VERSION == 9 && PERL_SUBVERSION > 2)
 482 #  define NEW_HEAD_LAYOUT
 483 #endif
 484
 485 static bool
 486 sv_size(pTHX_ struct state *const st, const SV * const orig_thing,
 487         const int recurse) {
 488   const SV *thing = orig_thing;
 489
 490   if(!check_new(st, thing))
 491       return FALSE;
 492
 493   st->total_size += sizeof(SV);
 494
 495   switch (SvTYPE(thing)) {
 496     /* Is it undef? */
 497   case SVt_NULL: TAG;
 498     TAG;break;
 499     /* Just a plain integer. This will be differently sized depending
 500        on whether purify's been compiled in */
 501   case SVt_IV: TAG;
 502 #ifndef NEW_HEAD_LAYOUT
 503 #  ifdef PURIFY
 504     st->total_size += sizeof(sizeof(XPVIV));
 505 #  else
 506     st->total_size += sizeof(IV);
 507 #  endif
 508 #endif
 509     if(recurse && SvROK(thing))
 510         sv_size(aTHX_ st, SvRV_const(thing), recurse);
 511     TAG;break;
 512     /* Is it a float? Like the int, it depends on purify */
 513   case SVt_NV: TAG;
 514 #ifdef PURIFY
 515     st->total_size += sizeof(sizeof(XPVNV));
 516 #else
 517     st->total_size += sizeof(NV);
 518 #endif
 519     TAG;break;
 520 #if (PERL_VERSION < 11)
 521     /* Is it a reference? */
 522   case SVt_RV: TAG;
 523 #ifndef NEW_HEAD_LAYOUT
 524     st->total_size += sizeof(XRV);
 525 #endif
 526     if(recurse && SvROK(thing))
 527         sv_size(aTHX_ st, SvRV_const(thing), recurse);
 528     TAG;break;
 529 #endif
 530     /* How about a plain string? In which case we need to add in how
 531        much has been allocated */
 532   case SVt_PV: TAG;
 533     st->total_size += sizeof(XPV);
 534     if(recurse && SvROK(thing))
 535         sv_size(aTHX_ st, SvRV_const(thing), recurse);
 536     else
 537         st->total_size += SvLEN(thing);
 538     TAG;break;
 539     /* A string with an integer part? */
 540   case SVt_PVIV: TAG;
 541     st->total_size += sizeof(XPVIV);
 542     if(recurse && SvROK(thing))
 543         sv_size(aTHX_ st, SvRV_const(thing), recurse);
 544     else
 545         st->total_size += SvLEN(thing);
 546     if(SvOOK(thing)) {
 547         st->total_size += SvIVX(thing);
 548     }
 549     TAG;break;
 550     /* A scalar/string/reference with a float part? */
 551   case SVt_PVNV: TAG;
 552     st->total_size += sizeof(XPVNV);
 553     if(recurse && SvROK(thing))
 554         sv_size(aTHX_ st, SvRV_const(thing), recurse);
 555     else
 556         st->total_size += SvLEN(thing);
 557     TAG;break;
 558   case SVt_PVMG: TAG;
 559     st->total_size += sizeof(XPVMG);
 560     if(recurse && SvROK(thing))
 561         sv_size(aTHX_ st, SvRV_const(thing), recurse);
 562     else
 563         st->total_size += SvLEN(thing);
 564     magic_size(aTHX_ thing, st);
 565     TAG;break;
 566 #if PERL_VERSION <= 8
 567   case SVt_PVBM: TAG;
 568     st->total_size += sizeof(XPVBM);
 569     if(recurse && SvROK(thing))
 570         sv_size(aTHX_ st, SvRV_const(thing), recurse);
 571     else
 572         st->total_size += SvLEN(thing);
 573     magic_size(aTHX_ thing, st);
 574     TAG;break;
 575 #endif
 576   case SVt_PVLV: TAG;
 577     st->total_size += sizeof(XPVLV);
 578     if(recurse && SvROK(thing))
 579         sv_size(aTHX_ st, SvRV_const(thing), recurse);
 580     else
 581         st->total_size += SvLEN(thing);
 582     magic_size(aTHX_ thing, st);
 583     TAG;break;
 584     /* How much space is dedicated to the array? Not counting the
 585        elements in the array, mind, just the array itself */
 586   case SVt_PVAV: TAG;
 587     st->total_size += sizeof(XPVAV);
 588     /* Is there anything in the array? */
 589     if (AvMAX(thing) != -1) {
 590       /* an array with 10 slots has AvMax() set to 9 - te 2007-04-22 */
 591       st->total_size += sizeof(SV *) * (AvMAX(thing) + 1);
 592       dbg_printf(("total_size: %li AvMAX: %li av_len: $i\n", st->total_size, AvMAX(thing), av_len((AV*)thing)));
 593
 594       if (recurse >= TOTAL_SIZE_RECURSION) {
 595           SSize_t i = AvFILLp(thing) + 1;
 596
 597           while (i--)
 598               sv_size(aTHX_ st, AvARRAY(thing)[i], recurse);
 599       }
 600     }
 601     /* Add in the bits on the other side of the beginning */
 602
 603     dbg_printf(("total_size %li, sizeof(SV *) %li, AvARRAY(thing) %li, AvALLOC(thing)%li , sizeof(ptr) %li \n",
 604     st->total_size, sizeof(SV*), AvARRAY(thing), AvALLOC(thing), sizeof( thing )));
 605
 606     /* under Perl 5.8.8 64bit threading, AvARRAY(thing) was a pointer while AvALLOC was 0,
 607        resulting in grossly overstated sized for arrays. Technically, this shouldn't happen... */
 608     if (AvALLOC(thing) != 0) {
 609       st->total_size += (sizeof(SV *) * (AvARRAY(thing) - AvALLOC(thing)));
 610       }
 611 #if (PERL_VERSION < 9)
 612     /* Is there something hanging off the arylen element?
 613        Post 5.9.something this is stored in magic, so will be found there,
 614        and Perl_av_arylen_p() takes a non-const AV*, hence compilers rightly
 615        complain about AvARYLEN() passing thing to it.  */
 616     sv_size(aTHX_ st, AvARYLEN(thing), recurse);
 617 #endif
 618     magic_size(aTHX_ thing, st);
 619     TAG;break;
 620   case SVt_PVHV: TAG;
 621     /* First the base struct */
 622     st->total_size += sizeof(XPVHV);
 623     /* Now the array of buckets */
 624     st->total_size += (sizeof(HE *) * (HvMAX(thing) + 1));
 625     /* Now walk the bucket chain */
 626     if (HvARRAY(thing)) {
 627       HE *cur_entry;
 628       UV cur_bucket = 0;
 629       for (cur_bucket = 0; cur_bucket <= HvMAX(thing); cur_bucket++) {
 630         cur_entry = *(HvARRAY(thing) + cur_bucket);
 631         while (cur_entry) {
 632           st->total_size += sizeof(HE);
 633           if (cur_entry->hent_hek) {
 634             /* Hash keys can be shared. Have we seen this before? */
 635             if (check_new(st, cur_entry->hent_hek)) {
 636               st->total_size += HEK_BASESIZE + cur_entry->hent_hek->hek_len + 2;
 637             }
 638           }
 639           if (recurse >= TOTAL_SIZE_RECURSION)
 640               sv_size(aTHX_ st, HeVAL(cur_entry), recurse);
 641           cur_entry = cur_entry->hent_next;
 642         }
 643       }
 644     }
 645     magic_size(aTHX_ thing, st);
 646     TAG;break;
 647   case SVt_PVCV: TAG;
 648     st->total_size += sizeof(XPVCV);
 649     magic_size(aTHX_ thing, st);
 650
 651     st->total_size += ((XPVIO *) SvANY(thing))->xpv_len;
 652     sv_size(aTHX_ st, (SV *)CvSTASH(thing), SOME_RECURSION);
 653     sv_size(aTHX_ st, (SV *)SvSTASH(thing), SOME_RECURSION);
 654     sv_size(aTHX_ st, (SV *)CvGV(thing), SOME_RECURSION);
 655     sv_size(aTHX_ st, (SV *)CvPADLIST(thing), SOME_RECURSION);
 656     sv_size(aTHX_ st, (SV *)CvOUTSIDE(thing), recurse);
 657     if (CvISXSUB(thing)) {
 658         sv_size(aTHX_ st, cv_const_sv((CV *)thing), recurse);
 659     } else {
 660         op_size(aTHX_ CvSTART(thing), st);
 661         op_size(aTHX_ CvROOT(thing), st);
 662     }
 663
 664     TAG;break;
 665   case SVt_PVGV: TAG;
 666     magic_size(aTHX_ thing, st);
 667     st->total_size += sizeof(XPVGV);
 668     if(isGV_with_GP(thing)) {
 669         st->total_size += GvNAMELEN(thing);
 670 #ifdef GvFILE
 671 #  if !defined(USE_ITHREADS) || (PERL_VERSION > 8 || (PERL_VERSION == 8 && PERL_SUBVERSION > 8))
 672         /* With itreads, before 5.8.9, this can end up pointing to freed memory
 673            if the GV was created in an eval, as GvFILE() points to CopFILE(),
 674            and the relevant COP has been freed on scope cleanup after the eval.
 675            5.8.9 adds a binary compatible fudge that catches the vast majority
 676            of cases. 5.9.something added a proper fix, by converting the GP to
 677            use a shared hash key (porperly reference counted), instead of a
 678            char * (owned by who knows? possibly no-one now) */
 679         check_new_and_strlen(st, GvFILE(thing));
 680 #  endif
 681 #endif
 682         /* Is there something hanging off the glob? */
 683         if (check_new(st, GvGP(thing))) {
 684             st->total_size += sizeof(GP);
 685             sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_sv), recurse);
 686             sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_form), recurse);
 687             sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_av), recurse);
 688             sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_hv), recurse);
 689             sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_egv), recurse);
 690             sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_cv), recurse);
 691         }
 692     }
 693     TAG;break;
 694   case SVt_PVFM: TAG;
 695     st->total_size += sizeof(XPVFM);
 696     magic_size(aTHX_ thing, st);
 697     st->total_size += ((XPVIO *) SvANY(thing))->xpv_len;
 698     sv_size(aTHX_ st, (SV *)CvPADLIST(thing), SOME_RECURSION);
 699     sv_size(aTHX_ st, (SV *)CvOUTSIDE(thing), recurse);
 700
 701     if (st->go_yell && !st->fm_whine) {
 702       carp("Devel::Size: Calculated sizes for FMs are incomplete");
 703       st->fm_whine = 1;
 704     }
 705     TAG;break;
 706   case SVt_PVIO: TAG;
 707     st->total_size += sizeof(XPVIO);
 708     magic_size(aTHX_ thing, st);
 709     if (check_new(st, (SvPVX_const(thing)))) {
 710       st->total_size += ((XPVIO *) SvANY(thing))->xpv_cur;
 711     }
 712     /* Some embedded char pointers */
 713     check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_top_name);
 714     check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_fmt_name);
 715     check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_bottom_name);
 716     /* Throw the GVs on the list to be walked if they're not-null */
 717     sv_size(aTHX_ st, (SV *)((XPVIO *) SvANY(thing))->xio_top_gv, recurse);
 718     sv_size(aTHX_ st, (SV *)((XPVIO *) SvANY(thing))->xio_bottom_gv, recurse);
 719     sv_size(aTHX_ st, (SV *)((XPVIO *) SvANY(thing))->xio_fmt_gv, recurse);
 720
 721     /* Only go trotting through the IO structures if they're really
 722        trottable. If USE_PERLIO is defined we can do this. If
 723        not... we can't, so we don't even try */
 724 #ifdef USE_PERLIO
 725     /* Dig into xio_ifp and xio_ofp here */
 726     warn("Devel::Size: Can't size up perlio layers yet\n");
 727 #endif
 728     TAG;break;
 729   default:
 730     warn("Devel::Size: Unknown variable type: %d encountered\n", SvTYPE(thing) );
 731   }
 732   return TRUE;
 733 }
 734
 735 void *vtables[] = {
 736 #include "vtables.inc"
 737     NULL
 738 };
 739
 740 static struct state *
 741 new_state(pTHX)
 742 {
 743     SV *warn_flag;
 744     struct state *st;
 745     void **vt_p = vtables;
 746
 747     Newxz(st, 1, struct state);
 748     st->go_yell = TRUE;
 749     if (NULL != (warn_flag = perl_get_sv("Devel::Size::warn", FALSE))) {
 750         st->dangle_whine = st->go_yell = SvIV(warn_flag) ? TRUE : FALSE;
 751     }
 752     if (NULL != (warn_flag = perl_get_sv("Devel::Size::dangle", FALSE))) {
 753         st->dangle_whine = SvIV(warn_flag) ? TRUE : FALSE;
 754     }
 755     check_new(st, &PL_sv_undef);
 756     check_new(st, &PL_sv_no);
 757     check_new(st, &PL_sv_yes);
 758     while(*vt_p)
 759         check_new(st, *vt_p++);
 760     return st;
 761 }
 762
 763 MODULE = Devel::Size        PACKAGE = Devel::Size
 764
 765 PROTOTYPES: DISABLE
 766
 767 UV
 768 size(orig_thing)
 769      SV *orig_thing
 770 ALIAS:
 771     total_size = TOTAL_SIZE_RECURSION
 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 (SvROK(thing)) {
 780     thing = SvRV(thing);
 781   }
 782
 783   sv_size(aTHX_ st, thing, ix);
 784   RETVAL = st->total_size;
 785   free_state(st);
 786 }
 787 OUTPUT:
 788   RETVAL