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