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