Size.xs

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