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