Size.xs

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