Size.xs

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