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 #if (PERL_VERSION < 11)
 593     total_size += SvROK(thing) ? thing_size(aTHX_ SvRV(thing), st) : SvLEN(thing);
 594 #else
 595     total_size += SvLEN(thing);
 596 #endif
 597     total_size += magic_size(thing, st);
 598     TAG;break;
 599 #endif
 600   case SVt_PVLV: TAG;
 601     total_size += sizeof(XPVLV);
 602 #if (PERL_VERSION < 11)
 603     total_size += SvROK(thing) ? thing_size(aTHX_ SvRV(thing), st) : SvLEN(thing);
 604 #else
 605     total_size += SvLEN(thing);
 606 #endif
 607     total_size += magic_size(thing, st);
 608     TAG;break;
 609     /* How much space is dedicated to the array? Not counting the
 610        elements in the array, mind, just the array itself */
 611   case SVt_PVAV: TAG;
 612     total_size += sizeof(XPVAV);
 613     /* Is there anything in the array? */
 614     if (AvMAX(thing) != -1) {
 615       /* an array with 10 slots has AvMax() set to 9 - te 2007-04-22 */
 616       total_size += sizeof(SV *) * (AvMAX(thing) + 1);
 617       dbg_printf(("total_size: %li AvMAX: %li av_len: $i\n", total_size, AvMAX(thing), av_len((AV*)thing)));
 618     }
 619     /* Add in the bits on the other side of the beginning */
 620
 621     dbg_printf(("total_size %li, sizeof(SV *) %li, AvARRAY(thing) %li, AvALLOC(thing)%li , sizeof(ptr) %li \n",
 622     total_size, sizeof(SV*), AvARRAY(thing), AvALLOC(thing), sizeof( thing )));
 623
 624     /* under Perl 5.8.8 64bit threading, AvARRAY(thing) was a pointer while AvALLOC was 0,
 625        resulting in grossly overstated sized for arrays. Technically, this shouldn't happen... */
 626     if (AvALLOC(thing) != 0) {
 627       total_size += (sizeof(SV *) * (AvARRAY(thing) - AvALLOC(thing)));
 628       }
 629 #if (PERL_VERSION < 9)
 630     /* Is there something hanging off the arylen element?
 631        Post 5.9.something this is stored in magic, so will be found there,
 632        and Perl_av_arylen_p() takes a non-const AV*, hence compilers rightly
 633        complain about AvARYLEN() passing thing to it.  */
 634     if (AvARYLEN(thing)) {
 635       if (check_new(st, AvARYLEN(thing))) {
 636     total_size += thing_size(aTHX_ AvARYLEN(thing), st);
 637       }
 638     }
 639 #endif
 640     total_size += magic_size(thing, st);
 641     TAG;break;
 642   case SVt_PVHV: TAG;
 643     /* First the base struct */
 644     total_size += sizeof(XPVHV);
 645     /* Now the array of buckets */
 646     total_size += (sizeof(HE *) * (HvMAX(thing) + 1));
 647     /* Now walk the bucket chain */
 648     if (HvARRAY(thing)) {
 649       HE *cur_entry;
 650       UV cur_bucket = 0;
 651       for (cur_bucket = 0; cur_bucket <= HvMAX(thing); cur_bucket++) {
 652         cur_entry = *(HvARRAY(thing) + cur_bucket);
 653         while (cur_entry) {
 654           total_size += sizeof(HE);
 655           if (cur_entry->hent_hek) {
 656             /* Hash keys can be shared. Have we seen this before? */
 657             if (check_new(st, cur_entry->hent_hek)) {
 658               total_size += HEK_BASESIZE + cur_entry->hent_hek->hek_len + 2;
 659             }
 660           }
 661           cur_entry = cur_entry->hent_next;
 662         }
 663       }
 664     }
 665     total_size += magic_size(thing, st);
 666     TAG;break;
 667   case SVt_PVCV: TAG;
 668     total_size += sizeof(XPVCV);
 669     total_size += magic_size(thing, st);
 670
 671     total_size += ((XPVIO *) SvANY(thing))->xpv_len;
 672     if (check_new(st, CvSTASH(thing))) {
 673       total_size += thing_size(aTHX_ (SV *)CvSTASH(thing), st);
 674     }
 675     if (check_new(st, SvSTASH(thing))) {
 676       total_size += thing_size(aTHX_ (SV *)SvSTASH(thing), st);
 677     }
 678     if (check_new(st, CvGV(thing))) {
 679       total_size += thing_size(aTHX_ (SV *)CvGV(thing), st);
 680     }
 681     if (check_new(st, CvPADLIST(thing))) {
 682       total_size += thing_size(aTHX_ (SV *)CvPADLIST(thing), st);
 683     }
 684     if (check_new(st, CvOUTSIDE(thing))) {
 685       total_size += thing_size(aTHX_ (SV *)CvOUTSIDE(thing), st);
 686     }
 687     if (CvISXSUB(thing)) {
 688         SV *sv = cv_const_sv((CV *)thing);
 689         if (sv) {
 690             total_size += thing_size(aTHX_ sv, st);
 691         }
 692     } else {
 693         if (check_new(st, CvSTART(thing))) {
 694             total_size += op_size(aTHX_ CvSTART(thing), st);
 695         }
 696         if (check_new(st, CvROOT(thing))) {
 697             total_size += op_size(aTHX_ CvROOT(thing), st);
 698         }
 699     }
 700
 701     TAG;break;
 702   case SVt_PVGV: TAG;
 703     total_size += magic_size(thing, st);
 704     total_size += sizeof(XPVGV);
 705     total_size += GvNAMELEN(thing);
 706 #ifdef GvFILE
 707     /* Is there a file? */
 708     if (GvFILE(thing)) {
 709       if (check_new(st, GvFILE(thing))) {
 710     total_size += strlen(GvFILE(thing));
 711       }
 712     }
 713 #endif
 714     /* Is there something hanging off the glob? */
 715     if (GvGP(thing)) {
 716       if (check_new(st, GvGP(thing))) {
 717     total_size += sizeof(GP);
 718     {
 719       SV *generic_thing;
 720       if ((generic_thing = (SV *)(GvGP(thing)->gp_sv))) {
 721         total_size += thing_size(aTHX_ generic_thing, st);
 722       }
 723       if ((generic_thing = (SV *)(GvGP(thing)->gp_form))) {
 724         total_size += thing_size(aTHX_ generic_thing, st);
 725       }
 726       if ((generic_thing = (SV *)(GvGP(thing)->gp_av))) {
 727         total_size += thing_size(aTHX_ generic_thing, st);
 728       }
 729       if ((generic_thing = (SV *)(GvGP(thing)->gp_hv))) {
 730         total_size += thing_size(aTHX_ generic_thing, st);
 731       }
 732       if ((generic_thing = (SV *)(GvGP(thing)->gp_egv))) {
 733         total_size += thing_size(aTHX_ generic_thing, st);
 734       }
 735       if ((generic_thing = (SV *)(GvGP(thing)->gp_cv))) {
 736         total_size += thing_size(aTHX_ generic_thing, st);
 737       }
 738     }
 739       }
 740     }
 741     TAG;break;
 742   case SVt_PVFM: TAG;
 743     total_size += sizeof(XPVFM);
 744     total_size += magic_size(thing, st);
 745     total_size += ((XPVIO *) SvANY(thing))->xpv_len;
 746     if (check_new(st, CvPADLIST(thing))) {
 747       total_size += thing_size(aTHX_ (SV *)CvPADLIST(thing), st);
 748     }
 749     if (check_new(st, CvOUTSIDE(thing))) {
 750       total_size += thing_size(aTHX_ (SV *)CvOUTSIDE(thing), st);
 751     }
 752
 753     if (st->go_yell && !st->fm_whine) {
 754       carp("Devel::Size: Calculated sizes for FMs are incomplete");
 755       st->fm_whine = 1;
 756     }
 757     TAG;break;
 758   case SVt_PVIO: TAG;
 759     total_size += sizeof(XPVIO);
 760     total_size += magic_size(thing, st);
 761     if (check_new(st, (SvPVX_const(thing)))) {
 762       total_size += ((XPVIO *) SvANY(thing))->xpv_cur;
 763     }
 764     /* Some embedded char pointers */
 765     if (check_new(st, ((XPVIO *) SvANY(thing))->xio_top_name)) {
 766       total_size += strlen(((XPVIO *) SvANY(thing))->xio_top_name);
 767     }
 768     if (check_new(st, ((XPVIO *) SvANY(thing))->xio_fmt_name)) {
 769       total_size += strlen(((XPVIO *) SvANY(thing))->xio_fmt_name);
 770     }
 771     if (check_new(st, ((XPVIO *) SvANY(thing))->xio_bottom_name)) {
 772       total_size += strlen(((XPVIO *) SvANY(thing))->xio_bottom_name);
 773     }
 774     /* Throw the GVs on the list to be walked if they're not-null */
 775     if (((XPVIO *) SvANY(thing))->xio_top_gv) {
 776       total_size += thing_size(aTHX_ (SV *)((XPVIO *) SvANY(thing))->xio_top_gv,
 777                    st);
 778     }
 779     if (((XPVIO *) SvANY(thing))->xio_bottom_gv) {
 780       total_size += thing_size(aTHX_ (SV *)((XPVIO *) SvANY(thing))->xio_bottom_gv,
 781                    st);
 782     }
 783     if (((XPVIO *) SvANY(thing))->xio_fmt_gv) {
 784       total_size += thing_size(aTHX_ (SV *)((XPVIO *) SvANY(thing))->xio_fmt_gv,
 785                    st);
 786     }
 787
 788     /* Only go trotting through the IO structures if they're really
 789        trottable. If USE_PERLIO is defined we can do this. If
 790        not... we can't, so we don't even try */
 791 #ifdef USE_PERLIO
 792     /* Dig into xio_ifp and xio_ofp here */
 793     warn("Devel::Size: Can't size up perlio layers yet\n");
 794 #endif
 795     TAG;break;
 796   default:
 797     warn("Devel::Size: Unknown variable type: %d encountered\n", SvTYPE(thing) );
 798   }
 799   return total_size;
 800 }
 801
 802 static struct state *
 803 new_state(pTHX)
 804 {
 805     SV *warn_flag;
 806     struct state *st;
 807     Newxz(st, 1, struct state);
 808     st->go_yell = TRUE;
 809     if (NULL != (warn_flag = perl_get_sv("Devel::Size::warn", FALSE))) {
 810         st->dangle_whine = st->go_yell = SvIV(warn_flag) ? TRUE : FALSE;
 811     }
 812     if (NULL != (warn_flag = perl_get_sv("Devel::Size::dangle", FALSE))) {
 813         st->dangle_whine = SvIV(warn_flag) ? TRUE : FALSE;
 814     }
 815     return st;
 816 }
 817
 818 MODULE = Devel::Size        PACKAGE = Devel::Size
 819
 820 PROTOTYPES: DISABLE
 821
 822 IV
 823 size(orig_thing)
 824      SV *orig_thing
 825 CODE:
 826 {
 827   SV *thing = orig_thing;
 828   struct state *st = new_state(aTHX);
 829
 830   /* If they passed us a reference then dereference it. This is the
 831      only way we can check the sizes of arrays and hashes */
 832 #if (PERL_VERSION < 11)
 833   if (SvOK(thing) && SvROK(thing)) {
 834     thing = SvRV(thing);
 835   }
 836 #else
 837   if (SvROK(thing)) {
 838     thing = SvRV(thing);
 839   }
 840 #endif
 841
 842   RETVAL = thing_size(aTHX_ thing, st);
 843   free_state(st);
 844 }
 845 OUTPUT:
 846   RETVAL
 847
 848
 849 IV
 850 total_size(orig_thing)
 851        SV *orig_thing
 852 CODE:
 853 {
 854   SV *thing = orig_thing;
 855   /* Array with things we still need to do */
 856   AV *pending_array;
 857   IV size = 0;
 858   struct state *st = new_state(aTHX);
 859
 860   /* Size starts at zero */
 861   RETVAL = 0;
 862
 863   pending_array = newAV();
 864
 865   /* If they passed us a reference then dereference it.
 866      This is the only way we can check the sizes of arrays and hashes. */
 867   if (SvROK(thing)) {
 868       thing = SvRV(thing);
 869   }
 870
 871   /* Put it on the pending array */
 872   av_push(pending_array, thing);
 873
 874   /* Now just yank things off the end of the array until it's done */
 875   while (av_len(pending_array) >= 0) {
 876     thing = av_pop(pending_array);
 877     /* Process it if we've not seen it */
 878     if (check_new(st, thing)) {
 879       dbg_printf(("# Found type %i at %p\n", SvTYPE(thing), thing));
 880       /* Is it valid? */
 881       if (thing) {
 882     /* Yes, it is. So let's check the type */
 883     switch (SvTYPE(thing)) {
 884     /* fix for bug #24846 (Does not correctly recurse into references in a PVNV-type scalar) */
 885     case SVt_PVNV: TAG;
 886       if (SvROK(thing))
 887         {
 888         av_push(pending_array, SvRV(thing));
 889         }
 890       TAG;break;
 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