Size.xs

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