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