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