Size.xs

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