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 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           check_new_and_strlen(st, basecop->cop_stashpv);
 522 #else
 523           sv_size(aTHX_ st, (SV *)basecop->cop_stash, SOME_RECURSION);
 524           sv_size(aTHX_ st, (SV *)basecop->cop_filegv, SOME_RECURSION);
 525 #endif
 526
 527         }
 528         TAG;break;
 529       default:
 530         TAG;break;
 531       }
 532   }
 533   CAUGHT_EXCEPTION {
 534       if (st->dangle_whine)
 535           warn( "Devel::Size: Encountered dangling pointer in opcode at: %p\n", baseop );
 536   }
 537 }
 538
 539 static void
 540 hek_size(pTHX_ struct state *st, HEK *hek, U32 shared)
 541 {
 542     /* Hash keys can be shared. Have we seen this before? */
 543     if (!check_new(st, hek))
 544         return;
 545     st->total_size += HEK_BASESIZE + hek->hek_len
 546 #if PERL_VERSION < 8
 547         + 1 /* No hash key flags prior to 5.8.0  */
 548 #else
 549         + 2
 550 #endif
 551         ;
 552     if (shared) {
 553 #if PERL_VERSION < 10
 554         st->total_size += sizeof(struct he);
 555 #else
 556         st->total_size += STRUCT_OFFSET(struct shared_he, shared_he_hek);
 557 #endif
 558     }
 559 }
 560
 561
 562 #if PERL_VERSION < 8 || PERL_SUBVERSION < 9
 563 #  define SVt_LAST 16
 564 #endif
 565
 566 #ifdef PURIFY
 567 #  define MAYBE_PURIFY(normal, pure) (pure)
 568 #  define MAYBE_OFFSET(struct_name, member) 0
 569 #else
 570 #  define MAYBE_PURIFY(normal, pure) (normal)
 571 #  define MAYBE_OFFSET(struct_name, member) STRUCT_OFFSET(struct_name, member)
 572 #endif
 573
 574 const U8 body_sizes[SVt_LAST] = {
 575 #if PERL_VERSION < 9
 576      0,                                                       /* SVt_NULL */
 577      MAYBE_PURIFY(sizeof(IV), sizeof(XPVIV)),                 /* SVt_IV */
 578      MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)),                 /* SVt_NV */
 579      sizeof(XRV),                                             /* SVt_RV */
 580      sizeof(XPV),                                             /* SVt_PV */
 581      sizeof(XPVIV),                                           /* SVt_PVIV */
 582      sizeof(XPVNV),                                           /* SVt_PVNV */
 583      sizeof(XPVMG),                                           /* SVt_PVMG */
 584      sizeof(XPVBM),                                           /* SVt_PVBM */
 585      sizeof(XPVLV),                                           /* SVt_PVLV */
 586      sizeof(XPVAV),                                           /* SVt_PVAV */
 587      sizeof(XPVHV),                                           /* SVt_PVHV */
 588      sizeof(XPVCV),                                           /* SVt_PVCV */
 589      sizeof(XPVGV),                                           /* SVt_PVGV */
 590      sizeof(XPVFM),                                           /* SVt_PVFM */
 591      sizeof(XPVIO)                                            /* SVt_PVIO */
 592 #elif PERL_VERSION == 10 && PERL_SUBVERSION == 0
 593      0,                                                       /* SVt_NULL */
 594      0,                                                       /* SVt_BIND */
 595      0,                                                       /* SVt_IV */
 596      MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)),                 /* SVt_NV */
 597      0,                                                       /* SVt_RV */
 598      MAYBE_PURIFY(sizeof(xpv_allocated), sizeof(XPV)),        /* SVt_PV */
 599      MAYBE_PURIFY(sizeof(xpviv_allocated), sizeof(XPVIV)),/* SVt_PVIV */
 600      sizeof(XPVNV),                                           /* SVt_PVNV */
 601      sizeof(XPVMG),                                           /* SVt_PVMG */
 602      sizeof(XPVGV),                                           /* SVt_PVGV */
 603      sizeof(XPVLV),                                           /* SVt_PVLV */
 604      MAYBE_PURIFY(sizeof(xpvav_allocated), sizeof(XPVAV)),/* SVt_PVAV */
 605      MAYBE_PURIFY(sizeof(xpvhv_allocated), sizeof(XPVHV)),/* SVt_PVHV */
 606      MAYBE_PURIFY(sizeof(xpvcv_allocated), sizeof(XPVCV)),/* SVt_PVCV */
 607      MAYBE_PURIFY(sizeof(xpvfm_allocated), sizeof(XPVFM)),/* SVt_PVFM */
 608      sizeof(XPVIO),                                           /* SVt_PVIO */
 609 #elif PERL_VERSION == 10 && PERL_SUBVERSION == 1
 610      0,                                                       /* SVt_NULL */
 611      0,                                                       /* SVt_BIND */
 612      0,                                                       /* SVt_IV */
 613      MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)),                 /* SVt_NV */
 614      0,                                                       /* SVt_RV */
 615      sizeof(XPV) - MAYBE_OFFSET(XPV, xpv_cur),                /* SVt_PV */
 616      sizeof(XPVIV) - MAYBE_OFFSET(XPV, xpv_cur),              /* SVt_PVIV */
 617      sizeof(XPVNV),                                           /* SVt_PVNV */
 618      sizeof(XPVMG),                                           /* SVt_PVMG */
 619      sizeof(XPVGV),                                           /* SVt_PVGV */
 620      sizeof(XPVLV),                                           /* SVt_PVLV */
 621      sizeof(XPVAV) - MAYBE_OFFSET(XPVAV, xav_fill),           /* SVt_PVAV */
 622      sizeof(XPVHV) - MAYBE_OFFSET(XPVHV, xhv_fill),           /* SVt_PVHV */
 623      sizeof(XPVCV) - MAYBE_OFFSET(XPVCV, xpv_cur),            /* SVt_PVCV */
 624      sizeof(XPVFM) - MAYBE_OFFSET(XPVFM, xpv_cur),            /* SVt_PVFM */
 625      sizeof(XPVIO)                                            /* SVt_PVIO */
 626 #elif PERL_VERSION < 13
 627      0,                                                       /* SVt_NULL */
 628      0,                                                       /* SVt_BIND */
 629      0,                                                       /* SVt_IV */
 630      MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)),                 /* SVt_NV */
 631      sizeof(XPV) - MAYBE_OFFSET(XPV, xpv_cur),                /* SVt_PV */
 632      sizeof(XPVIV) - MAYBE_OFFSET(XPV, xpv_cur),              /* SVt_PVIV */
 633      sizeof(XPVNV),                                           /* SVt_PVNV */
 634      sizeof(XPVMG),                                           /* SVt_PVMG */
 635      sizeof(regexp) - MAYBE_OFFSET(regexp, xpv_cur),          /* SVt_REGEXP */
 636      sizeof(XPVGV),                                           /* SVt_PVGV */
 637      sizeof(XPVLV),                                           /* SVt_PVLV */
 638      sizeof(XPVAV) - MAYBE_OFFSET(XPVAV, xav_fill),           /* SVt_PVAV */
 639      sizeof(XPVHV) - MAYBE_OFFSET(XPVHV, xhv_fill),           /* SVt_PVHV */
 640      sizeof(XPVCV) - MAYBE_OFFSET(XPVCV, xpv_cur),            /* SVt_PVCV */
 641      sizeof(XPVFM) - MAYBE_OFFSET(XPVFM, xpv_cur),            /* SVt_PVFM */
 642      sizeof(XPVIO)                                            /* SVt_PVIO */
 643 #else
 644      0,                                                       /* SVt_NULL */
 645      0,                                                       /* SVt_BIND */
 646      0,                                                       /* SVt_IV */
 647      MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)),                 /* SVt_NV */
 648      sizeof(XPV) - MAYBE_OFFSET(XPV, xpv_cur),                /* SVt_PV */
 649      sizeof(XPVIV) - MAYBE_OFFSET(XPV, xpv_cur),              /* SVt_PVIV */
 650      sizeof(XPVNV) - MAYBE_OFFSET(XPV, xpv_cur),              /* SVt_PVNV */
 651      sizeof(XPVMG),                                           /* SVt_PVMG */
 652      sizeof(regexp),                                          /* SVt_REGEXP */
 653      sizeof(XPVGV),                                           /* SVt_PVGV */
 654      sizeof(XPVLV),                                           /* SVt_PVLV */
 655      sizeof(XPVAV),                                           /* SVt_PVAV */
 656      sizeof(XPVHV),                                           /* SVt_PVHV */
 657      sizeof(XPVCV),                                           /* SVt_PVCV */
 658      sizeof(XPVFM),                                           /* SVt_PVFM */
 659      sizeof(XPVIO)                                            /* SVt_PVIO */
 660 #endif
 661 };
 662
 663 static void
 664 sv_size(pTHX_ struct state *const st, const SV * const orig_thing,
 665         const int recurse) {
 666   const SV *thing = orig_thing;
 667   U32 type;
 668
 669   if(!check_new(st, thing))
 670       return;
 671
 672   type = SvTYPE(thing);
 673   if (type > SVt_LAST) {
 674       warn("Devel::Size: Unknown variable type: %d encountered\n", type);
 675       return;
 676   }
 677   st->total_size += sizeof(SV) + body_sizes[type];
 678
 679   if (type >= SVt_PVMG) {
 680       magic_size(aTHX_ thing, st);
 681   }
 682
 683   switch (type) {
 684 #if (PERL_VERSION < 11)
 685     /* Is it a reference? */
 686   case SVt_RV: TAG;
 687 #else
 688   case SVt_IV: TAG;
 689 #endif
 690     if(recurse && SvROK(thing))
 691         sv_size(aTHX_ st, SvRV_const(thing), recurse);
 692     TAG;break;
 693
 694   case SVt_PVAV: TAG;
 695     /* Is there anything in the array? */
 696     if (AvMAX(thing) != -1) {
 697       /* an array with 10 slots has AvMax() set to 9 - te 2007-04-22 */
 698       st->total_size += sizeof(SV *) * (AvMAX(thing) + 1);
 699       dbg_printf(("total_size: %li AvMAX: %li av_len: $i\n", st->total_size, AvMAX(thing), av_len((AV*)thing)));
 700
 701       if (recurse >= TOTAL_SIZE_RECURSION) {
 702           SSize_t i = AvFILLp(thing) + 1;
 703
 704           while (i--)
 705               sv_size(aTHX_ st, AvARRAY(thing)[i], recurse);
 706       }
 707     }
 708     /* Add in the bits on the other side of the beginning */
 709
 710     dbg_printf(("total_size %li, sizeof(SV *) %li, AvARRAY(thing) %li, AvALLOC(thing)%li , sizeof(ptr) %li \n",
 711     st->total_size, sizeof(SV*), AvARRAY(thing), AvALLOC(thing), sizeof( thing )));
 712
 713     /* under Perl 5.8.8 64bit threading, AvARRAY(thing) was a pointer while AvALLOC was 0,
 714        resulting in grossly overstated sized for arrays. Technically, this shouldn't happen... */
 715     if (AvALLOC(thing) != 0) {
 716       st->total_size += (sizeof(SV *) * (AvARRAY(thing) - AvALLOC(thing)));
 717       }
 718 #if (PERL_VERSION < 9)
 719     /* Is there something hanging off the arylen element?
 720        Post 5.9.something this is stored in magic, so will be found there,
 721        and Perl_av_arylen_p() takes a non-const AV*, hence compilers rightly
 722        complain about AvARYLEN() passing thing to it.  */
 723     sv_size(aTHX_ st, AvARYLEN(thing), recurse);
 724 #endif
 725     TAG;break;
 726   case SVt_PVHV: TAG;
 727     /* Now the array of buckets */
 728     st->total_size += (sizeof(HE *) * (HvMAX(thing) + 1));
 729     /* Now walk the bucket chain */
 730     if (HvARRAY(thing)) {
 731       HE *cur_entry;
 732       UV cur_bucket = 0;
 733       for (cur_bucket = 0; cur_bucket <= HvMAX(thing); cur_bucket++) {
 734         cur_entry = *(HvARRAY(thing) + cur_bucket);
 735         while (cur_entry) {
 736           st->total_size += sizeof(HE);
 737           hek_size(aTHX_ st, cur_entry->hent_hek, HvSHAREKEYS(thing));
 738           if (recurse >= TOTAL_SIZE_RECURSION)
 739               sv_size(aTHX_ st, HeVAL(cur_entry), recurse);
 740           cur_entry = cur_entry->hent_next;
 741         }
 742       }
 743     }
 744     TAG;break;
 745
 746
 747   case SVt_PVFM: TAG;
 748     sv_size(aTHX_ st, (SV *)CvPADLIST(thing), SOME_RECURSION);
 749     sv_size(aTHX_ st, (SV *)CvOUTSIDE(thing), recurse);
 750
 751     if (st->go_yell && !st->fm_whine) {
 752       carp("Devel::Size: Calculated sizes for FMs are incomplete");
 753       st->fm_whine = 1;
 754     }
 755     goto freescalar;
 756
 757   case SVt_PVCV: TAG;
 758     sv_size(aTHX_ st, (SV *)CvSTASH(thing), SOME_RECURSION);
 759     sv_size(aTHX_ st, (SV *)SvSTASH(thing), SOME_RECURSION);
 760     sv_size(aTHX_ st, (SV *)CvGV(thing), SOME_RECURSION);
 761     sv_size(aTHX_ st, (SV *)CvPADLIST(thing), SOME_RECURSION);
 762     sv_size(aTHX_ st, (SV *)CvOUTSIDE(thing), recurse);
 763     if (CvISXSUB(thing)) {
 764         sv_size(aTHX_ st, cv_const_sv((CV *)thing), recurse);
 765     } else {
 766         op_size(aTHX_ CvSTART(thing), st);
 767         op_size(aTHX_ CvROOT(thing), st);
 768     }
 769     goto freescalar;
 770
 771   case SVt_PVIO: TAG;
 772     /* Some embedded char pointers */
 773     check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_top_name);
 774     check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_fmt_name);
 775     check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_bottom_name);
 776     /* Throw the GVs on the list to be walked if they're not-null */
 777     sv_size(aTHX_ st, (SV *)((XPVIO *) SvANY(thing))->xio_top_gv, recurse);
 778     sv_size(aTHX_ st, (SV *)((XPVIO *) SvANY(thing))->xio_bottom_gv, recurse);
 779     sv_size(aTHX_ st, (SV *)((XPVIO *) SvANY(thing))->xio_fmt_gv, recurse);
 780
 781     /* Only go trotting through the IO structures if they're really
 782        trottable. If USE_PERLIO is defined we can do this. If
 783        not... we can't, so we don't even try */
 784 #ifdef USE_PERLIO
 785     /* Dig into xio_ifp and xio_ofp here */
 786     warn("Devel::Size: Can't size up perlio layers yet\n");
 787 #endif
 788     goto freescalar;
 789
 790   case SVt_PVLV: TAG;
 791 #if (PERL_VERSION < 9)
 792     goto freescalar;
 793 #endif
 794
 795   case SVt_PVGV: TAG;
 796     if(isGV_with_GP(thing)) {
 797 #ifdef GvNAME_HEK
 798         hek_size(aTHX_ st, GvNAME_HEK(thing), 1);
 799 #else
 800         st->total_size += GvNAMELEN(thing);
 801 #endif
 802 #ifdef GvFILE_HEK
 803         hek_size(aTHX_ st, GvFILE_HEK(thing), 1);
 804 #elif defined(GvFILE)
 805 #  if !defined(USE_ITHREADS) || (PERL_VERSION > 8 || (PERL_VERSION == 8 && PERL_SUBVERSION > 8))
 806         /* With itreads, before 5.8.9, this can end up pointing to freed memory
 807            if the GV was created in an eval, as GvFILE() points to CopFILE(),
 808            and the relevant COP has been freed on scope cleanup after the eval.
 809            5.8.9 adds a binary compatible fudge that catches the vast majority
 810            of cases. 5.9.something added a proper fix, by converting the GP to
 811            use a shared hash key (porperly reference counted), instead of a
 812            char * (owned by who knows? possibly no-one now) */
 813         check_new_and_strlen(st, GvFILE(thing));
 814 #  endif
 815 #endif
 816         /* Is there something hanging off the glob? */
 817         if (check_new(st, GvGP(thing))) {
 818             st->total_size += sizeof(GP);
 819             sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_sv), recurse);
 820             sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_form), recurse);
 821             sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_av), recurse);
 822             sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_hv), recurse);
 823             sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_egv), recurse);
 824             sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_cv), recurse);
 825         }
 826 #if (PERL_VERSION >= 9)
 827         TAG; break;
 828 #endif
 829     }
 830 #if PERL_VERSION <= 8
 831   case SVt_PVBM: TAG;
 832 #endif
 833   case SVt_PVMG: TAG;
 834   case SVt_PVNV: TAG;
 835   case SVt_PVIV: TAG;
 836   case SVt_PV: TAG;
 837   freescalar:
 838     if(recurse && SvROK(thing))
 839         sv_size(aTHX_ st, SvRV_const(thing), recurse);
 840     else if (SvIsCOW_shared_hash(thing))
 841         hek_size(aTHX_ st, SvSHARED_HEK_FROM_PV(SvPVX(thing)), 1);
 842     else
 843         st->total_size += SvLEN(thing);
 844
 845     if(SvOOK(thing)) {
 846         STRLEN len;
 847         SvOOK_offset(thing, len);
 848         st->total_size += len;
 849     }
 850     TAG;break;
 851
 852   }
 853   return;
 854 }
 855
 856 static struct state *
 857 new_state(pTHX)
 858 {
 859     SV *warn_flag;
 860     struct state *st;
 861
 862     Newxz(st, 1, struct state);
 863     st->go_yell = TRUE;
 864     if (NULL != (warn_flag = perl_get_sv("Devel::Size::warn", FALSE))) {
 865         st->dangle_whine = st->go_yell = SvIV(warn_flag) ? TRUE : FALSE;
 866     }
 867     if (NULL != (warn_flag = perl_get_sv("Devel::Size::dangle", FALSE))) {
 868         st->dangle_whine = SvIV(warn_flag) ? TRUE : FALSE;
 869     }
 870     check_new(st, &PL_sv_undef);
 871     check_new(st, &PL_sv_no);
 872     check_new(st, &PL_sv_yes);
 873 #if PERL_VERSION > 8 || (PERL_VERSION == 8 && PERL_SUBVERSION > 0)
 874     check_new(st, &PL_sv_placeholder);
 875 #endif
 876     return st;
 877 }
 878
 879 MODULE = Devel::Size        PACKAGE = Devel::Size
 880
 881 PROTOTYPES: DISABLE
 882
 883 UV
 884 size(orig_thing)
 885      SV *orig_thing
 886 ALIAS:
 887     total_size = TOTAL_SIZE_RECURSION
 888 CODE:
 889 {
 890   SV *thing = orig_thing;
 891   struct state *st = new_state(aTHX);
 892
 893   /* If they passed us a reference then dereference it. This is the
 894      only way we can check the sizes of arrays and hashes */
 895   if (SvROK(thing)) {
 896     thing = SvRV(thing);
 897   }
 898
 899   sv_size(aTHX_ st, thing, ix);
 900   RETVAL = st->total_size;
 901   free_state(st);
 902 }
 903 OUTPUT:
 904   RETVAL