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