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