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         if (magic_pointer->mg_len == HEf_SVKEY) {
 337             sv_size(aTHX_ st, (SV *)magic_pointer->mg_ptr, TOTAL_SIZE_RECURSION);
 338         }
 339 #if defined(PERL_MAGIC_utf8) && defined (PERL_MAGIC_UTF8_CACHESIZE)
 340         else if (magic_pointer->mg_type == PERL_MAGIC_utf8) {
 341             if (check_new(st, magic_pointer->mg_ptr)) {
 342                 st->total_size += PERL_MAGIC_UTF8_CACHESIZE * 2 * sizeof(STRLEN);
 343             }
 344         }
 345 #endif
 346         else if (magic_pointer->mg_len > 0) {
 347             if (check_new(st, magic_pointer->mg_ptr)) {
 348                 st->total_size += magic_pointer->mg_len;
 349             }
 350         }
 351
 352         /* Get the next in the chain */
 353         magic_pointer = magic_pointer->mg_moremagic;
 354     }
 355     CAUGHT_EXCEPTION {
 356         if (st->dangle_whine)
 357             warn( "Devel::Size: Encountered bad magic at: %p\n", magic_pointer );
 358     }
 359   }
 360 }
 361
 362 static void
 363 check_new_and_strlen(struct state *st, const char *const p) {
 364     if(check_new(st, p))
 365         st->total_size += 1 + strlen(p);
 366 }
 367
 368 static void
 369 regex_size(const REGEXP * const baseregex, struct state *st) {
 370     if(!check_new(st, baseregex))
 371         return;
 372   st->total_size += sizeof(REGEXP);
 373 #if (PERL_VERSION < 11)
 374   /* Note the size of the paren offset thing */
 375   st->total_size += sizeof(I32) * baseregex->nparens * 2;
 376   st->total_size += strlen(baseregex->precomp);
 377 #else
 378   st->total_size += sizeof(struct regexp);
 379   st->total_size += sizeof(I32) * SvANY(baseregex)->nparens * 2;
 380   /*st->total_size += strlen(SvANY(baseregex)->subbeg);*/
 381 #endif
 382   if (st->go_yell && !st->regex_whine) {
 383     carp("Devel::Size: Calculated sizes for compiled regexes are incompatible, and probably always will be");
 384     st->regex_whine = 1;
 385   }
 386 }
 387
 388 static void
 389 op_size(pTHX_ const OP * const baseop, struct state *st)
 390 {
 391     TRY_TO_CATCH_SEGV {
 392         TAG;
 393         if(!check_new(st, baseop))
 394             return;
 395         TAG;
 396         op_size(aTHX_ baseop->op_next, st);
 397         TAG;
 398         switch (cc_opclass(baseop)) {
 399         case OPc_BASEOP: TAG;
 400             st->total_size += sizeof(struct op);
 401             TAG;break;
 402         case OPc_UNOP: TAG;
 403             st->total_size += sizeof(struct unop);
 404             op_size(aTHX_ cUNOPx(baseop)->op_first, st);
 405             TAG;break;
 406         case OPc_BINOP: TAG;
 407             st->total_size += sizeof(struct binop);
 408             op_size(aTHX_ cBINOPx(baseop)->op_first, st);
 409             op_size(aTHX_ cBINOPx(baseop)->op_last, st);
 410             TAG;break;
 411         case OPc_LOGOP: TAG;
 412             st->total_size += sizeof(struct logop);
 413             op_size(aTHX_ cBINOPx(baseop)->op_first, st);
 414             op_size(aTHX_ cLOGOPx(baseop)->op_other, st);
 415             TAG;break;
 416         case OPc_LISTOP: TAG;
 417             st->total_size += sizeof(struct listop);
 418             op_size(aTHX_ cLISTOPx(baseop)->op_first, st);
 419             op_size(aTHX_ cLISTOPx(baseop)->op_last, st);
 420             TAG;break;
 421         case OPc_PMOP: TAG;
 422             st->total_size += sizeof(struct pmop);
 423             op_size(aTHX_ cPMOPx(baseop)->op_first, st);
 424             op_size(aTHX_ cPMOPx(baseop)->op_last, st);
 425 #if PERL_VERSION < 9 || (PERL_VERSION == 9 && PERL_SUBVERSION < 5)
 426             op_size(aTHX_ cPMOPx(baseop)->op_pmreplroot, st);
 427             op_size(aTHX_ cPMOPx(baseop)->op_pmreplstart, st);
 428             op_size(aTHX_ (OP *)cPMOPx(baseop)->op_pmnext, st);
 429 #endif
 430             /* This is defined away in perl 5.8.x, but it is in there for
 431                5.6.x */
 432 #ifdef PM_GETRE
 433             regex_size(PM_GETRE(cPMOPx(baseop)), st);
 434 #else
 435             regex_size(cPMOPx(baseop)->op_pmregexp, st);
 436 #endif
 437             TAG;break;
 438         case OPc_SVOP: TAG;
 439             st->total_size += sizeof(struct pmop);
 440             if (!(baseop->op_type == OP_AELEMFAST
 441                   && baseop->op_flags & OPf_SPECIAL)) {
 442                 /* not an OP_PADAV replacement */
 443                 sv_size(aTHX_ st, cSVOPx(baseop)->op_sv, SOME_RECURSION);
 444             }
 445             TAG;break;
 446       case OPc_PADOP: TAG;
 447           st->total_size += sizeof(struct padop);
 448           TAG;break;
 449         case OPc_PVOP: TAG;
 450             check_new_and_strlen(st, cPVOPx(baseop)->op_pv);
 451             TAG;break;
 452         case OPc_LOOP: TAG;
 453             st->total_size += sizeof(struct loop);
 454             op_size(aTHX_ cLOOPx(baseop)->op_first, st);
 455             op_size(aTHX_ cLOOPx(baseop)->op_last, st);
 456             op_size(aTHX_ cLOOPx(baseop)->op_redoop, st);
 457             op_size(aTHX_ cLOOPx(baseop)->op_nextop, st);
 458             op_size(aTHX_ cLOOPx(baseop)->op_lastop, st);
 459             TAG;break;
 460         case OPc_COP: TAG;
 461         {
 462           COP *basecop;
 463           basecop = (COP *)baseop;
 464           st->total_size += sizeof(struct cop);
 465
 466           /* Change 33656 by nicholas@mouse-mill on 2008/04/07 11:29:51
 467           Eliminate cop_label from struct cop by storing a label as the first
 468           entry in the hints hash. Most statements don't have labels, so this
 469           will save memory. Not sure how much.
 470           The check below will be incorrect fail on bleadperls
 471           before 5.11 @33656, but later than 5.10, producing slightly too
 472           small memory sizes on these Perls. */
 473 #if (PERL_VERSION < 11)
 474           check_new_and_strlen(st, basecop->cop_label);
 475 #endif
 476 #ifdef USE_ITHREADS
 477           check_new_and_strlen(st, basecop->cop_file);
 478           check_new_and_strlen(st, basecop->cop_stashpv);
 479 #else
 480           sv_size(aTHX_ st, (SV *)basecop->cop_stash, SOME_RECURSION);
 481           sv_size(aTHX_ st, (SV *)basecop->cop_filegv, SOME_RECURSION);
 482 #endif
 483
 484         }
 485         TAG;break;
 486       default:
 487         TAG;break;
 488       }
 489   }
 490   CAUGHT_EXCEPTION {
 491       if (st->dangle_whine)
 492           warn( "Devel::Size: Encountered dangling pointer in opcode at: %p\n", baseop );
 493   }
 494 }
 495
 496 #if PERL_VERSION > 9 || (PERL_VERSION == 9 && PERL_SUBVERSION > 2)
 497 #  define NEW_HEAD_LAYOUT
 498 #endif
 499
 500 static bool
 501 sv_size(pTHX_ struct state *const st, const SV * const orig_thing,
 502         const int recurse) {
 503   const SV *thing = orig_thing;
 504
 505   if(!check_new(st, thing))
 506       return FALSE;
 507
 508   st->total_size += sizeof(SV);
 509
 510   switch (SvTYPE(thing)) {
 511     /* Is it undef? */
 512   case SVt_NULL: TAG;
 513     TAG;break;
 514     /* Just a plain integer. This will be differently sized depending
 515        on whether purify's been compiled in */
 516   case SVt_IV: TAG;
 517 #ifndef NEW_HEAD_LAYOUT
 518 #  ifdef PURIFY
 519     st->total_size += sizeof(sizeof(XPVIV));
 520 #  else
 521     st->total_size += sizeof(IV);
 522 #  endif
 523 #endif
 524     if(recurse && SvROK(thing))
 525         sv_size(aTHX_ st, SvRV_const(thing), recurse);
 526     TAG;break;
 527     /* Is it a float? Like the int, it depends on purify */
 528   case SVt_NV: TAG;
 529 #ifdef PURIFY
 530     st->total_size += sizeof(sizeof(XPVNV));
 531 #else
 532     st->total_size += sizeof(NV);
 533 #endif
 534     TAG;break;
 535 #if (PERL_VERSION < 11)
 536     /* Is it a reference? */
 537   case SVt_RV: TAG;
 538 #ifndef NEW_HEAD_LAYOUT
 539     st->total_size += sizeof(XRV);
 540 #endif
 541     if(recurse && SvROK(thing))
 542         sv_size(aTHX_ st, SvRV_const(thing), recurse);
 543     TAG;break;
 544 #endif
 545     /* How about a plain string? In which case we need to add in how
 546        much has been allocated */
 547   case SVt_PV: TAG;
 548     st->total_size += sizeof(XPV);
 549     if(recurse && SvROK(thing))
 550         sv_size(aTHX_ st, SvRV_const(thing), recurse);
 551     else
 552         st->total_size += SvLEN(thing);
 553     TAG;break;
 554     /* A string with an integer part? */
 555   case SVt_PVIV: TAG;
 556     st->total_size += sizeof(XPVIV);
 557     if(recurse && SvROK(thing))
 558         sv_size(aTHX_ st, SvRV_const(thing), recurse);
 559     else
 560         st->total_size += SvLEN(thing);
 561     if(SvOOK(thing)) {
 562         st->total_size += SvIVX(thing);
 563     }
 564     TAG;break;
 565     /* A scalar/string/reference with a float part? */
 566   case SVt_PVNV: TAG;
 567     st->total_size += sizeof(XPVNV);
 568     if(recurse && SvROK(thing))
 569         sv_size(aTHX_ st, SvRV_const(thing), recurse);
 570     else
 571         st->total_size += SvLEN(thing);
 572     TAG;break;
 573   case SVt_PVMG: TAG;
 574     st->total_size += sizeof(XPVMG);
 575     if(recurse && SvROK(thing))
 576         sv_size(aTHX_ st, SvRV_const(thing), recurse);
 577     else
 578         st->total_size += SvLEN(thing);
 579     magic_size(aTHX_ thing, st);
 580     TAG;break;
 581 #if PERL_VERSION <= 8
 582   case SVt_PVBM: TAG;
 583     st->total_size += sizeof(XPVBM);
 584     if(recurse && SvROK(thing))
 585         sv_size(aTHX_ st, SvRV_const(thing), recurse);
 586     else
 587         st->total_size += SvLEN(thing);
 588     magic_size(aTHX_ thing, st);
 589     TAG;break;
 590 #endif
 591   case SVt_PVLV: TAG;
 592     st->total_size += sizeof(XPVLV);
 593     if(recurse && SvROK(thing))
 594         sv_size(aTHX_ st, SvRV_const(thing), recurse);
 595     else
 596         st->total_size += SvLEN(thing);
 597     magic_size(aTHX_ thing, st);
 598     TAG;break;
 599     /* How much space is dedicated to the array? Not counting the
 600        elements in the array, mind, just the array itself */
 601   case SVt_PVAV: TAG;
 602     st->total_size += sizeof(XPVAV);
 603     /* Is there anything in the array? */
 604     if (AvMAX(thing) != -1) {
 605       /* an array with 10 slots has AvMax() set to 9 - te 2007-04-22 */
 606       st->total_size += sizeof(SV *) * (AvMAX(thing) + 1);
 607       dbg_printf(("total_size: %li AvMAX: %li av_len: $i\n", st->total_size, AvMAX(thing), av_len((AV*)thing)));
 608
 609       if (recurse >= TOTAL_SIZE_RECURSION) {
 610           SSize_t i = AvFILLp(thing) + 1;
 611
 612           while (i--)
 613               sv_size(aTHX_ st, AvARRAY(thing)[i], recurse);
 614       }
 615     }
 616     /* Add in the bits on the other side of the beginning */
 617
 618     dbg_printf(("total_size %li, sizeof(SV *) %li, AvARRAY(thing) %li, AvALLOC(thing)%li , sizeof(ptr) %li \n",
 619     st->total_size, sizeof(SV*), AvARRAY(thing), AvALLOC(thing), sizeof( thing )));
 620
 621     /* under Perl 5.8.8 64bit threading, AvARRAY(thing) was a pointer while AvALLOC was 0,
 622        resulting in grossly overstated sized for arrays. Technically, this shouldn't happen... */
 623     if (AvALLOC(thing) != 0) {
 624       st->total_size += (sizeof(SV *) * (AvARRAY(thing) - AvALLOC(thing)));
 625       }
 626 #if (PERL_VERSION < 9)
 627     /* Is there something hanging off the arylen element?
 628        Post 5.9.something this is stored in magic, so will be found there,
 629        and Perl_av_arylen_p() takes a non-const AV*, hence compilers rightly
 630        complain about AvARYLEN() passing thing to it.  */
 631     sv_size(aTHX_ st, AvARYLEN(thing), recurse);
 632 #endif
 633     magic_size(aTHX_ thing, st);
 634     TAG;break;
 635   case SVt_PVHV: TAG;
 636     /* First the base struct */
 637     st->total_size += sizeof(XPVHV);
 638     /* Now the array of buckets */
 639     st->total_size += (sizeof(HE *) * (HvMAX(thing) + 1));
 640     /* Now walk the bucket chain */
 641     if (HvARRAY(thing)) {
 642       HE *cur_entry;
 643       UV cur_bucket = 0;
 644       for (cur_bucket = 0; cur_bucket <= HvMAX(thing); cur_bucket++) {
 645         cur_entry = *(HvARRAY(thing) + cur_bucket);
 646         while (cur_entry) {
 647           st->total_size += sizeof(HE);
 648           if (cur_entry->hent_hek) {
 649             /* Hash keys can be shared. Have we seen this before? */
 650             if (check_new(st, cur_entry->hent_hek)) {
 651               st->total_size += HEK_BASESIZE + cur_entry->hent_hek->hek_len + 2;
 652             }
 653           }
 654           if (recurse >= TOTAL_SIZE_RECURSION)
 655               sv_size(aTHX_ st, HeVAL(cur_entry), recurse);
 656           cur_entry = cur_entry->hent_next;
 657         }
 658       }
 659     }
 660     magic_size(aTHX_ thing, st);
 661     TAG;break;
 662   case SVt_PVCV: TAG;
 663     st->total_size += sizeof(XPVCV);
 664     magic_size(aTHX_ thing, st);
 665
 666     st->total_size += ((XPVIO *) SvANY(thing))->xpv_len;
 667     sv_size(aTHX_ st, (SV *)CvSTASH(thing), SOME_RECURSION);
 668     sv_size(aTHX_ st, (SV *)SvSTASH(thing), SOME_RECURSION);
 669     sv_size(aTHX_ st, (SV *)CvGV(thing), SOME_RECURSION);
 670     sv_size(aTHX_ st, (SV *)CvPADLIST(thing), SOME_RECURSION);
 671     sv_size(aTHX_ st, (SV *)CvOUTSIDE(thing), recurse);
 672     if (CvISXSUB(thing)) {
 673         sv_size(aTHX_ st, cv_const_sv((CV *)thing), recurse);
 674     } else {
 675         op_size(aTHX_ CvSTART(thing), st);
 676         op_size(aTHX_ CvROOT(thing), st);
 677     }
 678
 679     TAG;break;
 680   case SVt_PVGV: TAG;
 681     magic_size(aTHX_ thing, st);
 682     st->total_size += sizeof(XPVGV);
 683     if(isGV_with_GP(thing)) {
 684         st->total_size += GvNAMELEN(thing);
 685 #ifdef GvFILE
 686 #  if !defined(USE_ITHREADS) || (PERL_VERSION > 8 || (PERL_VERSION == 8 && PERL_SUBVERSION > 8))
 687         /* With itreads, before 5.8.9, this can end up pointing to freed memory
 688            if the GV was created in an eval, as GvFILE() points to CopFILE(),
 689            and the relevant COP has been freed on scope cleanup after the eval.
 690            5.8.9 adds a binary compatible fudge that catches the vast majority
 691            of cases. 5.9.something added a proper fix, by converting the GP to
 692            use a shared hash key (porperly reference counted), instead of a
 693            char * (owned by who knows? possibly no-one now) */
 694         check_new_and_strlen(st, GvFILE(thing));
 695 #  endif
 696 #endif
 697         /* Is there something hanging off the glob? */
 698         if (check_new(st, GvGP(thing))) {
 699             st->total_size += sizeof(GP);
 700             sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_sv), recurse);
 701             sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_form), recurse);
 702             sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_av), recurse);
 703             sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_hv), recurse);
 704             sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_egv), recurse);
 705             sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_cv), recurse);
 706         }
 707     }
 708     TAG;break;
 709   case SVt_PVFM: TAG;
 710     st->total_size += sizeof(XPVFM);
 711     magic_size(aTHX_ thing, st);
 712     st->total_size += ((XPVIO *) SvANY(thing))->xpv_len;
 713     sv_size(aTHX_ st, (SV *)CvPADLIST(thing), SOME_RECURSION);
 714     sv_size(aTHX_ st, (SV *)CvOUTSIDE(thing), recurse);
 715
 716     if (st->go_yell && !st->fm_whine) {
 717       carp("Devel::Size: Calculated sizes for FMs are incomplete");
 718       st->fm_whine = 1;
 719     }
 720     TAG;break;
 721   case SVt_PVIO: TAG;
 722     st->total_size += sizeof(XPVIO);
 723     magic_size(aTHX_ thing, st);
 724     if (check_new(st, (SvPVX_const(thing)))) {
 725       st->total_size += ((XPVIO *) SvANY(thing))->xpv_cur;
 726     }
 727     /* Some embedded char pointers */
 728     check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_top_name);
 729     check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_fmt_name);
 730     check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_bottom_name);
 731     /* Throw the GVs on the list to be walked if they're not-null */
 732     sv_size(aTHX_ st, (SV *)((XPVIO *) SvANY(thing))->xio_top_gv, recurse);
 733     sv_size(aTHX_ st, (SV *)((XPVIO *) SvANY(thing))->xio_bottom_gv, recurse);
 734     sv_size(aTHX_ st, (SV *)((XPVIO *) SvANY(thing))->xio_fmt_gv, recurse);
 735
 736     /* Only go trotting through the IO structures if they're really
 737        trottable. If USE_PERLIO is defined we can do this. If
 738        not... we can't, so we don't even try */
 739 #ifdef USE_PERLIO
 740     /* Dig into xio_ifp and xio_ofp here */
 741     warn("Devel::Size: Can't size up perlio layers yet\n");
 742 #endif
 743     TAG;break;
 744   default:
 745     warn("Devel::Size: Unknown variable type: %d encountered\n", SvTYPE(thing) );
 746   }
 747   return TRUE;
 748 }
 749
 750 void *vtables[] = {
 751 #include "vtables.inc"
 752     NULL
 753 };
 754
 755 static struct state *
 756 new_state(pTHX)
 757 {
 758     SV *warn_flag;
 759     struct state *st;
 760     void **vt_p = vtables;
 761
 762     Newxz(st, 1, struct state);
 763     st->go_yell = TRUE;
 764     if (NULL != (warn_flag = perl_get_sv("Devel::Size::warn", FALSE))) {
 765         st->dangle_whine = st->go_yell = SvIV(warn_flag) ? TRUE : FALSE;
 766     }
 767     if (NULL != (warn_flag = perl_get_sv("Devel::Size::dangle", FALSE))) {
 768         st->dangle_whine = SvIV(warn_flag) ? TRUE : FALSE;
 769     }
 770     check_new(st, &PL_sv_undef);
 771     check_new(st, &PL_sv_no);
 772     check_new(st, &PL_sv_yes);
 773     while(*vt_p)
 774         check_new(st, *vt_p++);
 775     return st;
 776 }
 777
 778 MODULE = Devel::Size        PACKAGE = Devel::Size
 779
 780 PROTOTYPES: DISABLE
 781
 782 UV
 783 size(orig_thing)
 784      SV *orig_thing
 785 ALIAS:
 786     total_size = TOTAL_SIZE_RECURSION
 787 CODE:
 788 {
 789   SV *thing = orig_thing;
 790   struct state *st = new_state(aTHX);
 791
 792   /* If they passed us a reference then dereference it. This is the
 793      only way we can check the sizes of arrays and hashes */
 794   if (SvROK(thing)) {
 795     thing = SvRV(thing);
 796   }
 797
 798   sv_size(aTHX_ st, thing, ix);
 799   RETVAL = st->total_size;
 800   free_state(st);
 801 }
 802 OUTPUT:
 803   RETVAL