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
 319     TRY_TO_CATCH_SEGV {
 320         /* Have we seen the magic vtable? */
 321         if (check_new(st, magic_pointer->mg_virtual)) {
 322           st->total_size += sizeof(MGVTBL);
 323         }
 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_ cUNOPx(baseop)->op_first, st);
 394             TAG;break;
 395         case OPc_BINOP: TAG;
 396             st->total_size += sizeof(struct binop);
 397             op_size(aTHX_ cBINOPx(baseop)->op_first, st);
 398             op_size(aTHX_ cBINOPx(baseop)->op_last, st);
 399             TAG;break;
 400         case OPc_LOGOP: TAG;
 401             st->total_size += sizeof(struct logop);
 402             op_size(aTHX_ cBINOPx(baseop)->op_first, st);
 403             op_size(aTHX_ cLOGOPx(baseop)->op_other, st);
 404             TAG;break;
 405         case OPc_LISTOP: TAG;
 406             st->total_size += sizeof(struct listop);
 407             op_size(aTHX_ cLISTOPx(baseop)->op_first, st);
 408             op_size(aTHX_ cLISTOPx(baseop)->op_last, st);
 409             TAG;break;
 410         case OPc_PMOP: TAG;
 411             st->total_size += sizeof(struct pmop);
 412             op_size(aTHX_ cPMOPx(baseop)->op_first, st);
 413             op_size(aTHX_ cPMOPx(baseop)->op_last, st);
 414 #if PERL_VERSION < 9 || (PERL_VERSION == 9 && PERL_SUBVERSION < 5)
 415             op_size(aTHX_ cPMOPx(baseop)->op_pmreplroot, st);
 416             op_size(aTHX_ cPMOPx(baseop)->op_pmreplstart, st);
 417             op_size(aTHX_ (OP *)cPMOPx(baseop)->op_pmnext, st);
 418 #endif
 419             /* This is defined away in perl 5.8.x, but it is in there for
 420                5.6.x */
 421 #ifdef PM_GETRE
 422             regex_size(PM_GETRE(cPMOPx(baseop)), st);
 423 #else
 424             regex_size(cPMOPx(baseop)->op_pmregexp, st);
 425 #endif
 426             TAG;break;
 427         case OPc_SVOP: TAG;
 428             st->total_size += sizeof(struct pmop);
 429             if (!(baseop->op_type == OP_AELEMFAST
 430                   && baseop->op_flags & OPf_SPECIAL)) {
 431                 /* not an OP_PADAV replacement */
 432                 sv_size(aTHX_ st, cSVOPx(baseop)->op_sv, SOME_RECURSION);
 433             }
 434             TAG;break;
 435       case OPc_PADOP: TAG;
 436           st->total_size += sizeof(struct padop);
 437           TAG;break;
 438         case OPc_PVOP: TAG;
 439             check_new_and_strlen(st, cPVOPx(baseop)->op_pv);
 440             TAG;break;
 441         case OPc_LOOP: TAG;
 442             st->total_size += sizeof(struct loop);
 443             op_size(aTHX_ cLOOPx(baseop)->op_first, st);
 444             op_size(aTHX_ cLOOPx(baseop)->op_last, st);
 445             op_size(aTHX_ cLOOPx(baseop)->op_redoop, st);
 446             op_size(aTHX_ cLOOPx(baseop)->op_nextop, st);
 447             op_size(aTHX_ cLOOPx(baseop)->op_lastop, st);
 448             TAG;break;
 449         case OPc_COP: TAG;
 450         {
 451           COP *basecop;
 452           basecop = (COP *)baseop;
 453           st->total_size += sizeof(struct cop);
 454
 455           /* Change 33656 by nicholas@mouse-mill on 2008/04/07 11:29:51
 456           Eliminate cop_label from struct cop by storing a label as the first
 457           entry in the hints hash. Most statements don't have labels, so this
 458           will save memory. Not sure how much.
 459           The check below will be incorrect fail on bleadperls
 460           before 5.11 @33656, but later than 5.10, producing slightly too
 461           small memory sizes on these Perls. */
 462 #if (PERL_VERSION < 11)
 463           check_new_and_strlen(st, basecop->cop_label);
 464 #endif
 465 #ifdef USE_ITHREADS
 466           check_new_and_strlen(st, basecop->cop_file);
 467           check_new_and_strlen(st, basecop->cop_stashpv);
 468 #else
 469           sv_size(aTHX_ st, (SV *)basecop->cop_stash, SOME_RECURSION);
 470           sv_size(aTHX_ st, (SV *)basecop->cop_filegv, SOME_RECURSION);
 471 #endif
 472
 473         }
 474         TAG;break;
 475       default:
 476         TAG;break;
 477       }
 478   }
 479   CAUGHT_EXCEPTION {
 480       if (st->dangle_whine)
 481           warn( "Devel::Size: Encountered dangling pointer in opcode at: %p\n", baseop );
 482   }
 483 }
 484
 485 #if PERL_VERSION < 8 || PERL_SUBVERSION < 9
 486 #  define SVt_LAST 16
 487 #endif
 488
 489 #ifdef PURIFY
 490 #  define MAYBE_PURIFY(normal, pure) (pure)
 491 #  define MAYBE_OFFSET(struct_name, member) 0
 492 #else
 493 #  define MAYBE_PURIFY(normal, pure) (normal)
 494 #  define MAYBE_OFFSET(struct_name, member) STRUCT_OFFSET(struct_name, member)
 495 #endif
 496
 497 const U8 body_sizes[SVt_LAST] = {
 498 #if PERL_VERSION < 9
 499      0,                                                       /* SVt_NULL */
 500      MAYBE_PURIFY(sizeof(IV), sizeof(XPVIV)),                 /* SVt_IV */
 501      MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)),                 /* SVt_NV */
 502      sizeof(XRV),                                             /* SVt_RV */
 503      sizeof(XPV),                                             /* SVt_PV */
 504      sizeof(XPVIV),                                           /* SVt_PVIV */
 505      sizeof(XPVNV),                                           /* SVt_PVNV */
 506      sizeof(XPVMG),                                           /* SVt_PVMG */
 507      sizeof(XPVBM),                                           /* SVt_PVBM */
 508      sizeof(XPVLV),                                           /* SVt_PVLV */
 509      sizeof(XPVAV),                                           /* SVt_PVAV */
 510      sizeof(XPVHV),                                           /* SVt_PVHV */
 511      sizeof(XPVCV),                                           /* SVt_PVCV */
 512      sizeof(XPVGV),                                           /* SVt_PVGV */
 513      sizeof(XPVFM),                                           /* SVt_PVFM */
 514      sizeof(XPVIO)                                            /* SVt_PVIO */
 515 #elif PERL_VERSION == 10 && PERL_SUBVERSION == 0
 516      0,                                                       /* SVt_NULL */
 517      0,                                                       /* SVt_BIND */
 518      0,                                                       /* SVt_IV */
 519      MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)),                 /* SVt_NV */
 520      0,                                                       /* SVt_RV */
 521      MAYBE_PURIFY(sizeof(xpv_allocated), sizeof(XPV)),        /* SVt_PV */
 522      MAYBE_PURIFY(sizeof(xpviv_allocated), sizeof(XPVIV)),/* SVt_PVIV */
 523      sizeof(XPVNV),                                           /* SVt_PVNV */
 524      sizeof(XPVMG),                                           /* SVt_PVMG */
 525      sizeof(XPVGV),                                           /* SVt_PVGV */
 526      sizeof(XPVLV),                                           /* SVt_PVLV */
 527      MAYBE_PURIFY(sizeof(xpvav_allocated), sizeof(XPVAV)),/* SVt_PVAV */
 528      MAYBE_PURIFY(sizeof(xpvhv_allocated), sizeof(XPVHV)),/* SVt_PVHV */
 529      MAYBE_PURIFY(sizeof(xpvcv_allocated), sizeof(XPVCV)),/* SVt_PVCV */
 530      MAYBE_PURIFY(sizeof(xpvfm_allocated), sizeof(XPVFM)),/* SVt_PVFM */
 531      sizeof(XPVIO),                                           /* SVt_PVIO */
 532 #elif PERL_VERSION == 10 && PERL_SUBVERSION == 1
 533      0,                                                       /* SVt_NULL */
 534      0,                                                       /* SVt_BIND */
 535      0,                                                       /* SVt_IV */
 536      MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)),                 /* SVt_NV */
 537      0,                                                       /* SVt_RV */
 538      sizeof(XPV) - MAYBE_OFFSET(XPV, xpv_cur),                /* SVt_PV */
 539      sizeof(XPVIV) - MAYBE_OFFSET(XPV, xpv_cur),              /* SVt_PVIV */
 540      sizeof(XPVNV),                                           /* SVt_PVNV */
 541      sizeof(XPVMG),                                           /* SVt_PVMG */
 542      sizeof(XPVGV),                                           /* SVt_PVGV */
 543      sizeof(XPVLV),                                           /* SVt_PVLV */
 544      sizeof(XPVAV) - MAYBE_OFFSET(XPVAV, xav_fill),           /* SVt_PVAV */
 545      sizeof(XPVHV) - MAYBE_OFFSET(XPVHV, xhv_fill),           /* SVt_PVHV */
 546      sizeof(XPVCV) - MAYBE_OFFSET(XPVCV, xpv_cur),            /* SVt_PVCV */
 547      sizeof(XPVFM) - MAYBE_OFFSET(XPVFM, xpv_cur),            /* SVt_PVFM */
 548      sizeof(XPVIO)                                            /* SVt_PVIO */
 549 #elif PERL_VERSION < 13
 550      0,                                                       /* SVt_NULL */
 551      0,                                                       /* SVt_BIND */
 552      0,                                                       /* SVt_IV */
 553      MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)),                 /* SVt_NV */
 554      sizeof(XPV) - MAYBE_OFFSET(XPV, xpv_cur),                /* SVt_PV */
 555      sizeof(XPVIV) - MAYBE_OFFSET(XPV, xpv_cur),              /* SVt_PVIV */
 556      sizeof(XPVNV),                                           /* SVt_PVNV */
 557      sizeof(XPVMG),                                           /* SVt_PVMG */
 558      sizeof(regexp) - MAYBE_OFFSET(regexp, xpv_cur),          /* SVt_REGEXP */
 559      sizeof(XPVGV),                                           /* SVt_PVGV */
 560      sizeof(XPVLV),                                           /* SVt_PVLV */
 561      sizeof(XPVAV) - MAYBE_OFFSET(XPVAV, xav_fill),           /* SVt_PVAV */
 562      sizeof(XPVHV) - MAYBE_OFFSET(XPVHV, xhv_fill),           /* SVt_PVHV */
 563      sizeof(XPVCV) - MAYBE_OFFSET(XPVCV, xpv_cur),            /* SVt_PVCV */
 564      sizeof(XPVFM) - MAYBE_OFFSET(XPVFM, xpv_cur),            /* SVt_PVFM */
 565      sizeof(XPVIO)                                            /* SVt_PVIO */
 566 #else
 567      0,                                                       /* SVt_NULL */
 568      0,                                                       /* SVt_BIND */
 569      0,                                                       /* SVt_IV */
 570      MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)),                 /* SVt_NV */
 571      sizeof(XPV) - MAYBE_OFFSET(XPV, xpv_cur),                /* SVt_PV */
 572      sizeof(XPVIV) - MAYBE_OFFSET(XPV, xpv_cur),              /* SVt_PVIV */
 573      sizeof(XPVNV) - MAYBE_OFFSET(XPV, xpv_cur),              /* SVt_PVNV */
 574      sizeof(XPVMG),                                           /* SVt_PVMG */
 575      sizeof(regexp),                                          /* SVt_REGEXP */
 576      sizeof(XPVGV),                                           /* SVt_PVGV */
 577      sizeof(XPVLV),                                           /* SVt_PVLV */
 578      sizeof(XPVAV),                                           /* SVt_PVAV */
 579      sizeof(XPVHV),                                           /* SVt_PVHV */
 580      sizeof(XPVCV),                                           /* SVt_PVCV */
 581      sizeof(XPVFM),                                           /* SVt_PVFM */
 582      sizeof(XPVIO)                                            /* SVt_PVIO */
 583 #endif
 584 };
 585
 586 static bool
 587 sv_size(pTHX_ struct state *const st, const SV * const orig_thing,
 588         const int recurse) {
 589   const SV *thing = orig_thing;
 590   U32 type;
 591
 592   if(!check_new(st, thing))
 593       return FALSE;
 594
 595   type = SvTYPE(thing);
 596   if (type > SVt_LAST) {
 597       warn("Devel::Size: Unknown variable type: %d encountered\n", type);
 598       return TRUE;
 599   }
 600   st->total_size += sizeof(SV) + body_sizes[type];
 601
 602   if (type >= SVt_PVMG) {
 603       magic_size(aTHX_ thing, st);
 604   }
 605
 606   switch (type) {
 607 #if (PERL_VERSION < 11)
 608     /* Is it a reference? */
 609   case SVt_RV: TAG;
 610 #else
 611   case SVt_IV: TAG;
 612 #endif
 613     if(recurse && SvROK(thing))
 614         sv_size(aTHX_ st, SvRV_const(thing), recurse);
 615     TAG;break;
 616
 617   case SVt_PVAV: TAG;
 618     /* Is there anything in the array? */
 619     if (AvMAX(thing) != -1) {
 620       /* an array with 10 slots has AvMax() set to 9 - te 2007-04-22 */
 621       st->total_size += sizeof(SV *) * (AvMAX(thing) + 1);
 622       dbg_printf(("total_size: %li AvMAX: %li av_len: $i\n", st->total_size, AvMAX(thing), av_len((AV*)thing)));
 623
 624       if (recurse >= TOTAL_SIZE_RECURSION) {
 625           SSize_t i = AvFILLp(thing) + 1;
 626
 627           while (i--)
 628               sv_size(aTHX_ st, AvARRAY(thing)[i], recurse);
 629       }
 630     }
 631     /* Add in the bits on the other side of the beginning */
 632
 633     dbg_printf(("total_size %li, sizeof(SV *) %li, AvARRAY(thing) %li, AvALLOC(thing)%li , sizeof(ptr) %li \n",
 634     st->total_size, sizeof(SV*), AvARRAY(thing), AvALLOC(thing), sizeof( thing )));
 635
 636     /* under Perl 5.8.8 64bit threading, AvARRAY(thing) was a pointer while AvALLOC was 0,
 637        resulting in grossly overstated sized for arrays. Technically, this shouldn't happen... */
 638     if (AvALLOC(thing) != 0) {
 639       st->total_size += (sizeof(SV *) * (AvARRAY(thing) - AvALLOC(thing)));
 640       }
 641 #if (PERL_VERSION < 9)
 642     /* Is there something hanging off the arylen element?
 643        Post 5.9.something this is stored in magic, so will be found there,
 644        and Perl_av_arylen_p() takes a non-const AV*, hence compilers rightly
 645        complain about AvARYLEN() passing thing to it.  */
 646     sv_size(aTHX_ st, AvARYLEN(thing), recurse);
 647 #endif
 648     TAG;break;
 649   case SVt_PVHV: TAG;
 650     /* Now the array of buckets */
 651     st->total_size += (sizeof(HE *) * (HvMAX(thing) + 1));
 652     /* Now walk the bucket chain */
 653     if (HvARRAY(thing)) {
 654       HE *cur_entry;
 655       UV cur_bucket = 0;
 656       for (cur_bucket = 0; cur_bucket <= HvMAX(thing); cur_bucket++) {
 657         cur_entry = *(HvARRAY(thing) + cur_bucket);
 658         while (cur_entry) {
 659           st->total_size += sizeof(HE);
 660           if (cur_entry->hent_hek) {
 661             /* Hash keys can be shared. Have we seen this before? */
 662             if (check_new(st, cur_entry->hent_hek)) {
 663               st->total_size += HEK_BASESIZE + cur_entry->hent_hek->hek_len + 2;
 664             }
 665           }
 666           if (recurse >= TOTAL_SIZE_RECURSION)
 667               sv_size(aTHX_ st, HeVAL(cur_entry), recurse);
 668           cur_entry = cur_entry->hent_next;
 669         }
 670       }
 671     }
 672     TAG;break;
 673
 674
 675   case SVt_PVFM: TAG;
 676     sv_size(aTHX_ st, (SV *)CvPADLIST(thing), SOME_RECURSION);
 677     sv_size(aTHX_ st, (SV *)CvOUTSIDE(thing), recurse);
 678
 679     if (st->go_yell && !st->fm_whine) {
 680       carp("Devel::Size: Calculated sizes for FMs are incomplete");
 681       st->fm_whine = 1;
 682     }
 683     goto freescalar;
 684
 685   case SVt_PVCV: TAG;
 686     sv_size(aTHX_ st, (SV *)CvSTASH(thing), SOME_RECURSION);
 687     sv_size(aTHX_ st, (SV *)SvSTASH(thing), SOME_RECURSION);
 688     sv_size(aTHX_ st, (SV *)CvGV(thing), SOME_RECURSION);
 689     sv_size(aTHX_ st, (SV *)CvPADLIST(thing), SOME_RECURSION);
 690     sv_size(aTHX_ st, (SV *)CvOUTSIDE(thing), recurse);
 691     if (CvISXSUB(thing)) {
 692         sv_size(aTHX_ st, cv_const_sv((CV *)thing), recurse);
 693     } else {
 694         op_size(aTHX_ CvSTART(thing), st);
 695         op_size(aTHX_ CvROOT(thing), st);
 696     }
 697     goto freescalar;
 698
 699   case SVt_PVIO: TAG;
 700     /* Some embedded char pointers */
 701     check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_top_name);
 702     check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_fmt_name);
 703     check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_bottom_name);
 704     /* Throw the GVs on the list to be walked if they're not-null */
 705     sv_size(aTHX_ st, (SV *)((XPVIO *) SvANY(thing))->xio_top_gv, recurse);
 706     sv_size(aTHX_ st, (SV *)((XPVIO *) SvANY(thing))->xio_bottom_gv, recurse);
 707     sv_size(aTHX_ st, (SV *)((XPVIO *) SvANY(thing))->xio_fmt_gv, recurse);
 708
 709     /* Only go trotting through the IO structures if they're really
 710        trottable. If USE_PERLIO is defined we can do this. If
 711        not... we can't, so we don't even try */
 712 #ifdef USE_PERLIO
 713     /* Dig into xio_ifp and xio_ofp here */
 714     warn("Devel::Size: Can't size up perlio layers yet\n");
 715 #endif
 716     goto freescalar;
 717
 718   case SVt_PVLV: TAG;
 719 #if (PERL_VERSION < 9)
 720     goto freescalar;
 721 #endif
 722
 723   case SVt_PVGV: TAG;
 724     if(isGV_with_GP(thing)) {
 725         st->total_size += GvNAMELEN(thing);
 726 #ifdef GvFILE
 727 #  if !defined(USE_ITHREADS) || (PERL_VERSION > 8 || (PERL_VERSION == 8 && PERL_SUBVERSION > 8))
 728         /* With itreads, before 5.8.9, this can end up pointing to freed memory
 729            if the GV was created in an eval, as GvFILE() points to CopFILE(),
 730            and the relevant COP has been freed on scope cleanup after the eval.
 731            5.8.9 adds a binary compatible fudge that catches the vast majority
 732            of cases. 5.9.something added a proper fix, by converting the GP to
 733            use a shared hash key (porperly reference counted), instead of a
 734            char * (owned by who knows? possibly no-one now) */
 735         check_new_and_strlen(st, GvFILE(thing));
 736 #  endif
 737 #endif
 738         /* Is there something hanging off the glob? */
 739         if (check_new(st, GvGP(thing))) {
 740             st->total_size += sizeof(GP);
 741             sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_sv), recurse);
 742             sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_form), recurse);
 743             sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_av), recurse);
 744             sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_hv), recurse);
 745             sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_egv), recurse);
 746             sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_cv), recurse);
 747         }
 748 #if (PERL_VERSION >= 9)
 749         TAG; break;
 750 #endif
 751     }
 752 #if PERL_VERSION <= 8
 753   case SVt_PVBM: TAG;
 754 #endif
 755   case SVt_PVMG: TAG;
 756   case SVt_PVNV: TAG;
 757   case SVt_PVIV: TAG;
 758   case SVt_PV: TAG;
 759   freescalar:
 760     if(recurse && SvROK(thing))
 761         sv_size(aTHX_ st, SvRV_const(thing), recurse);
 762     else
 763         st->total_size += SvLEN(thing);
 764
 765     if(SvOOK(thing)) {
 766         STRLEN len;
 767         SvOOK_offset(thing, len);
 768         st->total_size += len;
 769     }
 770     TAG;break;
 771
 772   }
 773   return TRUE;
 774 }
 775
 776 /* Frustratingly, the vtables aren't const in perl.h
 777    gcc is happy enough to have non-const initialisers in a static array.
 778    VC seems not to be. (Is it actually treating the file as C++?)
 779    So do the maximally portable thing, unless we know it's gcc, in which case
 780    we can do the more space efficient version.  */
 781
 782 #if __GNUC__
 783 void *vtables[] = {
 784 #include "vtables.inc"
 785     NULL
 786 };
 787 #endif
 788
 789 static struct state *
 790 new_state(pTHX)
 791 {
 792     SV *warn_flag;
 793     struct state *st;
 794 #if __GNUC__
 795     void **vt_p = vtables;
 796 #endif
 797
 798     Newxz(st, 1, struct state);
 799     st->go_yell = TRUE;
 800     if (NULL != (warn_flag = perl_get_sv("Devel::Size::warn", FALSE))) {
 801         st->dangle_whine = st->go_yell = SvIV(warn_flag) ? TRUE : FALSE;
 802     }
 803     if (NULL != (warn_flag = perl_get_sv("Devel::Size::dangle", FALSE))) {
 804         st->dangle_whine = SvIV(warn_flag) ? TRUE : FALSE;
 805     }
 806     check_new(st, &PL_sv_undef);
 807     check_new(st, &PL_sv_no);
 808     check_new(st, &PL_sv_yes);
 809 #if __GNUC__
 810     while(*vt_p)
 811         check_new(st, *vt_p++);
 812 #else
 813 #include "vtables.inc"
 814 #endif
 815     return st;
 816 }
 817
 818 MODULE = Devel::Size        PACKAGE = Devel::Size
 819
 820 PROTOTYPES: DISABLE
 821
 822 UV
 823 size(orig_thing)
 824      SV *orig_thing
 825 ALIAS:
 826     total_size = TOTAL_SIZE_RECURSION
 827 CODE:
 828 {
 829   SV *thing = orig_thing;
 830   struct state *st = new_state(aTHX);
 831
 832   /* If they passed us a reference then dereference it. This is the
 833      only way we can check the sizes of arrays and hashes */
 834   if (SvROK(thing)) {
 835     thing = SvRV(thing);
 836   }
 837
 838   sv_size(aTHX_ st, thing, ix);
 839   RETVAL = st->total_size;
 840   free_state(st);
 841 }
 842 OUTPUT:
 843   RETVAL