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