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 #if !defined(MULTIPLICITY) || PERL_VERSION > 8 || (PERL_VERSION == 8 && PERL_SUBVERSION > 8)
 110     /* 5.8.8 and early have an assert() macro that uses Perl_croak, hence needs
 111        a my_perl under multiplicity  */
 112     assert(bits == 16);
 113 #endif
 114     leaf_p = (U8 **)tv_p;
 115     i = (unsigned int)((cooked_p >> bits) & 0xFF);
 116     if (!leaf_p[i])
 117         Newxz(leaf_p[i], 1 << LEAF_BITS, U8);
 118     leaf = leaf_p[i];
 119
 120     TAG;
 121
 122     i = (unsigned int)((cooked_p >> BYTE_BITS) & LEAF_MASK);
 123
 124     if(leaf[i] & this_bit)
 125         return FALSE;
 126
 127     leaf[i] |= this_bit;
 128     return TRUE;
 129 }
 130
 131 static void
 132 free_tracking_at(void **tv, int level)
 133 {
 134     int i = 255;
 135
 136     if (--level) {
 137         /* Nodes */
 138         do {
 139             if (tv[i]) {
 140                 free_tracking_at(tv[i], level);
 141                 Safefree(tv[i]);
 142             }
 143         } while (i--);
 144     } else {
 145         /* Leaves */
 146         do {
 147             if (tv[i])
 148                 Safefree(tv[i]);
 149         } while (i--);
 150     }
 151 }
 152
 153 static void
 154 free_state(struct state *st)
 155 {
 156     const int top_level = (sizeof(void *) * 8 - LEAF_BITS - BYTE_BITS) / 8;
 157     free_tracking_at((void **)st->tracking, top_level);
 158     Safefree(st);
 159 }
 160
 161 static UV thing_size(pTHX_ const SV *const, struct state *);
 162 typedef enum {
 163     OPc_NULL,   /* 0 */
 164     OPc_BASEOP, /* 1 */
 165     OPc_UNOP,   /* 2 */
 166     OPc_BINOP,  /* 3 */
 167     OPc_LOGOP,  /* 4 */
 168     OPc_LISTOP, /* 5 */
 169     OPc_PMOP,   /* 6 */
 170     OPc_SVOP,   /* 7 */
 171     OPc_PADOP,  /* 8 */
 172     OPc_PVOP,   /* 9 */
 173     OPc_LOOP,   /* 10 */
 174     OPc_COP /* 11 */
 175 } opclass;
 176
 177 static opclass
 178 cc_opclass(const OP * const o)
 179 {
 180     if (!o)
 181     return OPc_NULL;
 182     TRY_TO_CATCH_SEGV {
 183         if (o->op_type == 0)
 184         return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
 185
 186         if (o->op_type == OP_SASSIGN)
 187         return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPc_UNOP : OPc_BINOP);
 188
 189     #ifdef USE_ITHREADS
 190         if (o->op_type == OP_GV || o->op_type == OP_GVSV || o->op_type == OP_AELEMFAST)
 191         return OPc_PADOP;
 192     #endif
 193
 194         if ((o->op_type == OP_TRANS)) {
 195           return OPc_BASEOP;
 196         }
 197
 198         switch (PL_opargs[o->op_type] & OA_CLASS_MASK) {
 199         case OA_BASEOP: TAG;
 200         return OPc_BASEOP;
 201
 202         case OA_UNOP: TAG;
 203         return OPc_UNOP;
 204
 205         case OA_BINOP: TAG;
 206         return OPc_BINOP;
 207
 208         case OA_LOGOP: TAG;
 209         return OPc_LOGOP;
 210
 211         case OA_LISTOP: TAG;
 212         return OPc_LISTOP;
 213
 214         case OA_PMOP: TAG;
 215         return OPc_PMOP;
 216
 217         case OA_SVOP: TAG;
 218         return OPc_SVOP;
 219
 220         case OA_PADOP: TAG;
 221         return OPc_PADOP;
 222
 223         case OA_PVOP_OR_SVOP: TAG;
 224             /*
 225              * Character translations (tr///) are usually a PVOP, keeping a
 226              * pointer to a table of shorts used to look up translations.
 227              * Under utf8, however, a simple table isn't practical; instead,
 228              * the OP is an SVOP, and the SV is a reference to a swash
 229              * (i.e., an RV pointing to an HV).
 230              */
 231         return (o->op_private & (OPpTRANS_TO_UTF|OPpTRANS_FROM_UTF))
 232             ? OPc_SVOP : OPc_PVOP;
 233
 234         case OA_LOOP: TAG;
 235         return OPc_LOOP;
 236
 237         case OA_COP: TAG;
 238         return OPc_COP;
 239
 240         case OA_BASEOP_OR_UNOP: TAG;
 241         /*
 242          * UNI(OP_foo) in toke.c returns token UNI or FUNC1 depending on
 243          * whether parens were seen. perly.y uses OPf_SPECIAL to
 244          * signal whether a BASEOP had empty parens or none.
 245          * Some other UNOPs are created later, though, so the best
 246          * test is OPf_KIDS, which is set in newUNOP.
 247          */
 248         return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
 249
 250         case OA_FILESTATOP: TAG;
 251         /*
 252          * The file stat OPs are created via UNI(OP_foo) in toke.c but use
 253          * the OPf_REF flag to distinguish between OP types instead of the
 254          * usual OPf_SPECIAL flag. As usual, if OPf_KIDS is set, then we
 255          * return OPc_UNOP so that walkoptree can find our children. If
 256          * OPf_KIDS is not set then we check OPf_REF. Without OPf_REF set
 257          * (no argument to the operator) it's an OP; with OPf_REF set it's
 258          * an SVOP (and op_sv is the GV for the filehandle argument).
 259          */
 260         return ((o->op_flags & OPf_KIDS) ? OPc_UNOP :
 261     #ifdef USE_ITHREADS
 262             (o->op_flags & OPf_REF) ? OPc_PADOP : OPc_BASEOP);
 263     #else
 264             (o->op_flags & OPf_REF) ? OPc_SVOP : OPc_BASEOP);
 265     #endif
 266         case OA_LOOPEXOP: TAG;
 267         /*
 268          * next, last, redo, dump and goto use OPf_SPECIAL to indicate that a
 269          * label was omitted (in which case it's a BASEOP) or else a term was
 270          * seen. In this last case, all except goto are definitely PVOP but
 271          * goto is either a PVOP (with an ordinary constant label), an UNOP
 272          * with OPf_STACKED (with a non-constant non-sub) or an UNOP for
 273          * OP_REFGEN (with goto &sub) in which case OPf_STACKED also seems to
 274          * get set.
 275          */
 276         if (o->op_flags & OPf_STACKED)
 277             return OPc_UNOP;
 278         else if (o->op_flags & OPf_SPECIAL)
 279             return OPc_BASEOP;
 280         else
 281             return OPc_PVOP;
 282         }
 283         warn("Devel::Size: Can't determine class of operator %s, assuming BASEOP\n",
 284          PL_op_name[o->op_type]);
 285     }
 286     CAUGHT_EXCEPTION { }
 287     return OPc_BASEOP;
 288 }
 289
 290
 291 #if !defined(NV)
 292 #define NV double
 293 #endif
 294
 295 /* Figure out how much magic is attached to the SV and return the
 296    size */
 297 IV magic_size(const SV * const thing, struct state *st) {
 298   IV total_size = 0;
 299   MAGIC *magic_pointer;
 300
 301   /* Is there any? */
 302   if (!SvMAGIC(thing)) {
 303     /* No, bail */
 304     return 0;
 305   }
 306
 307   /* Get the base magic pointer */
 308   magic_pointer = SvMAGIC(thing);
 309
 310   /* Have we seen the magic pointer? */
 311   while (magic_pointer && check_new(st, magic_pointer)) {
 312     total_size += sizeof(MAGIC);
 313
 314     TRY_TO_CATCH_SEGV {
 315         /* Have we seen the magic vtable? */
 316         if (magic_pointer->mg_virtual &&
 317         check_new(st, magic_pointer->mg_virtual)) {
 318           total_size += sizeof(MGVTBL);
 319         }
 320
 321         /* Get the next in the chain */
 322         magic_pointer = magic_pointer->mg_moremagic;
 323     }
 324     CAUGHT_EXCEPTION {
 325         if (st->dangle_whine)
 326             warn( "Devel::Size: Encountered bad magic at: %p\n", magic_pointer );
 327     }
 328   }
 329   return total_size;
 330 }
 331
 332 UV regex_size(const REGEXP * const baseregex, struct state *st) {
 333   UV total_size = 0;
 334
 335   total_size += sizeof(REGEXP);
 336 #if (PERL_VERSION < 11)
 337   /* Note the size of the paren offset thing */
 338   total_size += sizeof(I32) * baseregex->nparens * 2;
 339   total_size += strlen(baseregex->precomp);
 340 #else
 341   total_size += sizeof(struct regexp);
 342   total_size += sizeof(I32) * SvANY(baseregex)->nparens * 2;
 343   /*total_size += strlen(SvANY(baseregex)->subbeg);*/
 344 #endif
 345   if (st->go_yell && !st->regex_whine) {
 346     carp("Devel::Size: Calculated sizes for compiled regexes are incompatible, and probably always will be");
 347     st->regex_whine = 1;
 348   }
 349
 350   return total_size;
 351 }
 352
 353 static UV
 354 op_size(pTHX_ const OP * const baseop, struct state *st) {
 355   UV total_size = 0;
 356   TRY_TO_CATCH_SEGV {
 357       TAG;
 358       if (check_new(st, baseop->op_next)) {
 359            total_size += op_size(aTHX_ baseop->op_next, st);
 360       }
 361       TAG;
 362       switch (cc_opclass(baseop)) {
 363       case OPc_BASEOP: TAG;
 364         total_size += sizeof(struct op);
 365         TAG;break;
 366       case OPc_UNOP: TAG;
 367         total_size += sizeof(struct unop);
 368         if (check_new(st, cUNOPx(baseop)->op_first)) {
 369           total_size += op_size(aTHX_ cUNOPx(baseop)->op_first, st);
 370         }
 371         TAG;break;
 372       case OPc_BINOP: TAG;
 373         total_size += sizeof(struct binop);
 374         if (check_new(st, cBINOPx(baseop)->op_first)) {
 375           total_size += op_size(aTHX_ cBINOPx(baseop)->op_first, st);
 376         }
 377         if (check_new(st, cBINOPx(baseop)->op_last)) {
 378           total_size += op_size(aTHX_ cBINOPx(baseop)->op_last, st);
 379         }
 380         TAG;break;
 381       case OPc_LOGOP: TAG;
 382         total_size += sizeof(struct logop);
 383         if (check_new(st, cLOGOPx(baseop)->op_first)) {
 384           total_size += op_size(aTHX_ cBINOPx(baseop)->op_first, st);
 385         }
 386         if (check_new(st, cLOGOPx(baseop)->op_other)) {
 387           total_size += op_size(aTHX_ cLOGOPx(baseop)->op_other, st);
 388         }
 389         TAG;break;
 390       case OPc_LISTOP: TAG;
 391         total_size += sizeof(struct listop);
 392         if (check_new(st, cLISTOPx(baseop)->op_first)) {
 393           total_size += op_size(aTHX_ cLISTOPx(baseop)->op_first, st);
 394         }
 395         if (check_new(st, cLISTOPx(baseop)->op_last)) {
 396           total_size += op_size(aTHX_ cLISTOPx(baseop)->op_last, st);
 397         }
 398         TAG;break;
 399       case OPc_PMOP: TAG;
 400         total_size += sizeof(struct pmop);
 401         if (check_new(st, cPMOPx(baseop)->op_first)) {
 402           total_size += op_size(aTHX_ cPMOPx(baseop)->op_first, st);
 403         }
 404         if (check_new(st, cPMOPx(baseop)->op_last)) {
 405           total_size += op_size(aTHX_ cPMOPx(baseop)->op_last, st);
 406         }
 407 #if PERL_VERSION < 9 || (PERL_VERSION == 9 && PERL_SUBVERSION < 5)
 408         if (check_new(st, cPMOPx(baseop)->op_pmreplroot)) {
 409           total_size += op_size(aTHX_ cPMOPx(baseop)->op_pmreplroot, st);
 410         }
 411         if (check_new(st, cPMOPx(baseop)->op_pmreplstart)) {
 412           total_size += op_size(aTHX_ cPMOPx(baseop)->op_pmreplstart, st);
 413         }
 414         if (check_new(st, cPMOPx(baseop)->op_pmnext)) {
 415           total_size += op_size(aTHX_ (OP *)cPMOPx(baseop)->op_pmnext, st);
 416         }
 417 #endif
 418         /* This is defined away in perl 5.8.x, but it is in there for
 419            5.6.x */
 420 #ifdef PM_GETRE
 421         if (check_new(st, PM_GETRE((cPMOPx(baseop))))) {
 422           total_size += regex_size(PM_GETRE(cPMOPx(baseop)), st);
 423         }
 424 #else
 425         if (check_new(st, cPMOPx(baseop)->op_pmregexp)) {
 426           total_size += regex_size(cPMOPx(baseop)->op_pmregexp, st);
 427         }
 428 #endif
 429         TAG;break;
 430       case OPc_SVOP: TAG;
 431         total_size += sizeof(struct pmop);
 432         if (check_new(st, cSVOPx(baseop)->op_sv)) {
 433           total_size += thing_size(aTHX_ cSVOPx(baseop)->op_sv, st);
 434         }
 435         TAG;break;
 436       case OPc_PADOP: TAG;
 437         total_size += sizeof(struct padop);
 438         TAG;break;
 439       case OPc_PVOP: TAG;
 440         if (check_new(st, cPVOPx(baseop)->op_pv)) {
 441           total_size += strlen(cPVOPx(baseop)->op_pv);
 442         }
 443       case OPc_LOOP: TAG;
 444         total_size += sizeof(struct loop);
 445         if (check_new(st, cLOOPx(baseop)->op_first)) {
 446           total_size += op_size(aTHX_ cLOOPx(baseop)->op_first, st);
 447         }
 448         if (check_new(st, cLOOPx(baseop)->op_last)) {
 449           total_size += op_size(aTHX_ cLOOPx(baseop)->op_last, st);
 450         }
 451         if (check_new(st, cLOOPx(baseop)->op_redoop)) {
 452           total_size += op_size(aTHX_ cLOOPx(baseop)->op_redoop, st);
 453         }
 454         if (check_new(st, cLOOPx(baseop)->op_nextop)) {
 455           total_size += op_size(aTHX_ cLOOPx(baseop)->op_nextop, st);
 456         }
 457         if (check_new(st, cLOOPx(baseop)->op_lastop)) {
 458           total_size += op_size(aTHX_ cLOOPx(baseop)->op_lastop, st);
 459         }
 460
 461         TAG;break;
 462       case OPc_COP: TAG;
 463         {
 464           COP *basecop;
 465           basecop = (COP *)baseop;
 466           total_size += sizeof(struct cop);
 467
 468           /* Change 33656 by nicholas@mouse-mill on 2008/04/07 11:29:51
 469           Eliminate cop_label from struct cop by storing a label as the first
 470           entry in the hints hash. Most statements don't have labels, so this
 471           will save memory. Not sure how much.
 472           The check below will be incorrect fail on bleadperls
 473           before 5.11 @33656, but later than 5.10, producing slightly too
 474           small memory sizes on these Perls. */
 475 #if (PERL_VERSION < 11)
 476           if (check_new(st, basecop->cop_label)) {
 477         total_size += strlen(basecop->cop_label);
 478           }
 479 #endif
 480 #ifdef USE_ITHREADS
 481           if (check_new(st, basecop->cop_file)) {
 482         total_size += strlen(basecop->cop_file);
 483           }
 484           if (check_new(st, basecop->cop_stashpv)) {
 485         total_size += strlen(basecop->cop_stashpv);
 486           }
 487 #else
 488           if (check_new(st, basecop->cop_stash)) {
 489         total_size += thing_size(aTHX_ (SV *)basecop->cop_stash, st);
 490           }
 491           if (check_new(st, basecop->cop_filegv)) {
 492         total_size += thing_size(aTHX_ (SV *)basecop->cop_filegv, st);
 493           }
 494 #endif
 495
 496         }
 497         TAG;break;
 498       default:
 499         TAG;break;
 500       }
 501   }
 502   CAUGHT_EXCEPTION {
 503       if (st->dangle_whine)
 504           warn( "Devel::Size: Encountered dangling pointer in opcode at: %p\n", baseop );
 505   }
 506   return total_size;
 507 }
 508
 509 #if PERL_VERSION > 9 || (PERL_VERSION == 9 && PERL_SUBVERSION > 2)
 510 #  define NEW_HEAD_LAYOUT
 511 #endif
 512
 513 static UV
 514 thing_size(pTHX_ const SV * const orig_thing, struct state *st) {
 515   const SV *thing = orig_thing;
 516   UV total_size = sizeof(SV);
 517
 518   switch (SvTYPE(thing)) {
 519     /* Is it undef? */
 520   case SVt_NULL: TAG;
 521     TAG;break;
 522     /* Just a plain integer. This will be differently sized depending
 523        on whether purify's been compiled in */
 524   case SVt_IV: TAG;
 525 #ifndef NEW_HEAD_LAYOUT
 526 #  ifdef PURIFY
 527     total_size += sizeof(sizeof(XPVIV));
 528 #  else
 529     total_size += sizeof(IV);
 530 #  endif
 531 #endif
 532     TAG;break;
 533     /* Is it a float? Like the int, it depends on purify */
 534   case SVt_NV: TAG;
 535 #ifdef PURIFY
 536     total_size += sizeof(sizeof(XPVNV));
 537 #else
 538     total_size += sizeof(NV);
 539 #endif
 540     TAG;break;
 541 #if (PERL_VERSION < 11)
 542     /* Is it a reference? */
 543   case SVt_RV: TAG;
 544 #ifndef NEW_HEAD_LAYOUT
 545     total_size += sizeof(XRV);
 546 #endif
 547     TAG;break;
 548 #endif
 549     /* How about a plain string? In which case we need to add in how
 550        much has been allocated */
 551   case SVt_PV: TAG;
 552     total_size += sizeof(XPV);
 553 #if (PERL_VERSION < 11)
 554     total_size += SvROK(thing) ? thing_size(aTHX_ SvRV(thing), st) : SvLEN(thing);
 555 #else
 556     total_size += SvLEN(thing);
 557 #endif
 558     TAG;break;
 559     /* A string with an integer part? */
 560   case SVt_PVIV: TAG;
 561     total_size += sizeof(XPVIV);
 562 #if (PERL_VERSION < 11)
 563     total_size += SvROK(thing) ? thing_size(aTHX_ SvRV(thing), st) : SvLEN(thing);
 564 #else
 565     total_size += SvLEN(thing);
 566 #endif
 567     if(SvOOK(thing)) {
 568         total_size += SvIVX(thing);
 569     }
 570     TAG;break;
 571     /* A scalar/string/reference with a float part? */
 572   case SVt_PVNV: TAG;
 573     total_size += sizeof(XPVNV);
 574 #if (PERL_VERSION < 11)
 575     total_size += SvROK(thing) ? thing_size(aTHX_ SvRV(thing), st) : SvLEN(thing);
 576 #else
 577     total_size += SvLEN(thing);
 578 #endif
 579     TAG;break;
 580   case SVt_PVMG: TAG;
 581     total_size += sizeof(XPVMG);
 582 #if (PERL_VERSION < 11)
 583     total_size += SvROK(thing) ? thing_size(aTHX_ SvRV(thing), st) : SvLEN(thing);
 584 #else
 585     total_size += SvLEN(thing);
 586 #endif
 587     total_size += magic_size(thing, st);
 588     TAG;break;
 589 #if PERL_VERSION <= 8
 590   case SVt_PVBM: TAG;
 591     total_size += sizeof(XPVBM);
 592     total_size += SvROK(thing) ? thing_size(aTHX_ SvRV(thing), st) : SvLEN(thing);
 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   /* If they passed us a reference then dereference it.
 862      This is the only way we can check the sizes of arrays and hashes. */
 863   if (SvROK(thing)) {
 864       thing = SvRV(thing);
 865   }
 866
 867   /* Put it on the pending array */
 868   av_push(pending_array, thing);
 869
 870   /* Now just yank things off the end of the array until it's done */
 871   while (av_len(pending_array) >= 0) {
 872     thing = av_pop(pending_array);
 873     /* Process it if we've not seen it */
 874     if (check_new(st, thing)) {
 875       dbg_printf(("# Found type %i at %p\n", SvTYPE(thing), thing));
 876       /* Is it valid? */
 877       if (thing) {
 878     /* Yes, it is. So let's check the type */
 879     switch (SvTYPE(thing)) {
 880     /* fix for bug #24846 (Does not correctly recurse into references in a PVNV-type scalar) */
 881     case SVt_PVNV: TAG;
 882       if (SvROK(thing))
 883         {
 884         av_push(pending_array, SvRV(thing));
 885         }
 886       TAG;break;
 887 #if (PERL_VERSION < 11)
 888         case SVt_RV: TAG;
 889 #else
 890         case SVt_IV: TAG;
 891 #endif
 892              dbg_printf(("# Found RV\n"));
 893           if (SvROK(thing)) {
 894              dbg_printf(("# Found RV\n"));
 895              av_push(pending_array, SvRV(thing));
 896           }
 897           TAG;break;
 898
 899     case SVt_PVAV: TAG;
 900       {
 901         AV *tempAV = (AV *)thing;
 902         SV **tempSV;
 903
 904         dbg_printf(("# Found type AV\n"));
 905         /* Quick alias to cut down on casting */
 906
 907         /* Any elements? */
 908         if (av_len(tempAV) != -1) {
 909           IV index;
 910           /* Run through them all */
 911           for (index = 0; index <= av_len(tempAV); index++) {
 912         /* Did we get something? */
 913         if ((tempSV = av_fetch(tempAV, index, 0))) {
 914           /* Was it undef? */
 915           if (*tempSV != &PL_sv_undef) {
 916             /* Apparently not. Save it for later */
 917             av_push(pending_array, *tempSV);
 918           }
 919         }
 920           }
 921         }
 922       }
 923       TAG;break;
 924
 925     case SVt_PVHV: TAG;
 926       dbg_printf(("# Found type HV\n"));
 927       /* Is there anything in here? */
 928       if (hv_iterinit((HV *)thing)) {
 929         HE *temp_he;
 930         while ((temp_he = hv_iternext((HV *)thing))) {
 931           av_push(pending_array, hv_iterval((HV *)thing, temp_he));
 932         }
 933       }
 934       TAG;break;
 935
 936     case SVt_PVGV: TAG;
 937       dbg_printf(("# Found type GV\n"));
 938       /* Run through all the pieces and push the ones with bits */
 939       if (GvSV(thing)) {
 940         av_push(pending_array, (SV *)GvSV(thing));
 941       }
 942       if (GvFORM(thing)) {
 943         av_push(pending_array, (SV *)GvFORM(thing));
 944       }
 945       if (GvAV(thing)) {
 946         av_push(pending_array, (SV *)GvAV(thing));
 947       }
 948       if (GvHV(thing)) {
 949         av_push(pending_array, (SV *)GvHV(thing));
 950       }
 951       if (GvCV(thing)) {
 952         av_push(pending_array, (SV *)GvCV(thing));
 953       }
 954       TAG;break;
 955     default:
 956       TAG;break;
 957     }
 958       }
 959
 960       size = thing_size(aTHX_ thing, st);
 961       RETVAL += size;
 962     } else {
 963     /* check_new() returned false: */
 964 #ifdef DEVEL_SIZE_DEBUGGING
 965        if (SvOK(sv)) printf("# Ignore ref copy 0x%x\n", sv);
 966        else printf("# Ignore non-sv 0x%x\n", sv);
 967 #endif
 968     }
 969   } /* end while */
 970
 971   free_state(st);
 972   SvREFCNT_dec(pending_array);
 973 }
 974 OUTPUT:
 975   RETVAL
 976