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     if(!check_new(st, baseregex))
 338         return;
 339   st->total_size += sizeof(REGEXP);
 340 #if (PERL_VERSION < 11)
 341   /* Note the size of the paren offset thing */
 342   st->total_size += sizeof(I32) * baseregex->nparens * 2;
 343   st->total_size += strlen(baseregex->precomp);
 344 #else
 345   st->total_size += sizeof(struct regexp);
 346   st->total_size += sizeof(I32) * SvANY(baseregex)->nparens * 2;
 347   /*st->total_size += strlen(SvANY(baseregex)->subbeg);*/
 348 #endif
 349   if (st->go_yell && !st->regex_whine) {
 350     carp("Devel::Size: Calculated sizes for compiled regexes are incompatible, and probably always will be");
 351     st->regex_whine = 1;
 352   }
 353 }
 354
 355 static void
 356 op_size(pTHX_ const OP * const baseop, struct state *st)
 357 {
 358     TRY_TO_CATCH_SEGV {
 359         TAG;
 360         if(!check_new(st, baseop))
 361             return;
 362         TAG;
 363         op_size(aTHX_ baseop->op_next, st);
 364         TAG;
 365         switch (cc_opclass(baseop)) {
 366         case OPc_BASEOP: TAG;
 367             st->total_size += sizeof(struct op);
 368             TAG;break;
 369         case OPc_UNOP: TAG;
 370             st->total_size += sizeof(struct unop);
 371             op_size(aTHX_ cUNOPx(baseop)->op_first, st);
 372             TAG;break;
 373         case OPc_BINOP: TAG;
 374             st->total_size += sizeof(struct binop);
 375             op_size(aTHX_ cBINOPx(baseop)->op_first, st);
 376             op_size(aTHX_ cBINOPx(baseop)->op_last, st);
 377             TAG;break;
 378         case OPc_LOGOP: TAG;
 379             st->total_size += sizeof(struct logop);
 380             op_size(aTHX_ cBINOPx(baseop)->op_first, st);
 381             op_size(aTHX_ cLOGOPx(baseop)->op_other, st);
 382             TAG;break;
 383         case OPc_LISTOP: TAG;
 384             st->total_size += sizeof(struct listop);
 385             op_size(aTHX_ cLISTOPx(baseop)->op_first, st);
 386             op_size(aTHX_ cLISTOPx(baseop)->op_last, st);
 387             TAG;break;
 388         case OPc_PMOP: TAG;
 389             st->total_size += sizeof(struct pmop);
 390             op_size(aTHX_ cPMOPx(baseop)->op_first, st);
 391             op_size(aTHX_ cPMOPx(baseop)->op_last, st);
 392 #if PERL_VERSION < 9 || (PERL_VERSION == 9 && PERL_SUBVERSION < 5)
 393             op_size(aTHX_ cPMOPx(baseop)->op_pmreplroot, st);
 394             op_size(aTHX_ cPMOPx(baseop)->op_pmreplstart, st);
 395             op_size(aTHX_ (OP *)cPMOPx(baseop)->op_pmnext, st);
 396 #endif
 397             /* This is defined away in perl 5.8.x, but it is in there for
 398                5.6.x */
 399 #ifdef PM_GETRE
 400             regex_size(PM_GETRE(cPMOPx(baseop)), st);
 401 #else
 402             regex_size(cPMOPx(baseop)->op_pmregexp, st);
 403 #endif
 404             TAG;break;
 405       case OPc_SVOP: TAG;
 406         st->total_size += sizeof(struct pmop);
 407         if (check_new(st, cSVOPx(baseop)->op_sv)) {
 408           thing_size(aTHX_ cSVOPx(baseop)->op_sv, st);
 409         }
 410         TAG;break;
 411       case OPc_PADOP: TAG;
 412           st->total_size += sizeof(struct padop);
 413         TAG;break;
 414       case OPc_PVOP: TAG;
 415         if (check_new(st, cPVOPx(baseop)->op_pv)) {
 416           st->total_size += strlen(cPVOPx(baseop)->op_pv);
 417         }
 418         case OPc_LOOP: TAG;
 419             st->total_size += sizeof(struct loop);
 420             op_size(aTHX_ cLOOPx(baseop)->op_first, st);
 421             op_size(aTHX_ cLOOPx(baseop)->op_last, st);
 422             op_size(aTHX_ cLOOPx(baseop)->op_redoop, st);
 423             op_size(aTHX_ cLOOPx(baseop)->op_nextop, st);
 424             op_size(aTHX_ cLOOPx(baseop)->op_lastop, st);
 425             TAG;break;
 426         case OPc_COP: TAG;
 427         {
 428           COP *basecop;
 429           basecop = (COP *)baseop;
 430           st->total_size += sizeof(struct cop);
 431
 432           /* Change 33656 by nicholas@mouse-mill on 2008/04/07 11:29:51
 433           Eliminate cop_label from struct cop by storing a label as the first
 434           entry in the hints hash. Most statements don't have labels, so this
 435           will save memory. Not sure how much.
 436           The check below will be incorrect fail on bleadperls
 437           before 5.11 @33656, but later than 5.10, producing slightly too
 438           small memory sizes on these Perls. */
 439 #if (PERL_VERSION < 11)
 440           if (check_new(st, basecop->cop_label)) {
 441         st->total_size += strlen(basecop->cop_label);
 442           }
 443 #endif
 444 #ifdef USE_ITHREADS
 445           if (check_new(st, basecop->cop_file)) {
 446         st->total_size += strlen(basecop->cop_file);
 447           }
 448           if (check_new(st, basecop->cop_stashpv)) {
 449         st->total_size += strlen(basecop->cop_stashpv);
 450           }
 451 #else
 452           if (check_new(st, basecop->cop_stash)) {
 453               thing_size(aTHX_ (SV *)basecop->cop_stash, st);
 454           }
 455           if (check_new(st, basecop->cop_filegv)) {
 456               thing_size(aTHX_ (SV *)basecop->cop_filegv, st);
 457           }
 458 #endif
 459
 460         }
 461         TAG;break;
 462       default:
 463         TAG;break;
 464       }
 465   }
 466   CAUGHT_EXCEPTION {
 467       if (st->dangle_whine)
 468           warn( "Devel::Size: Encountered dangling pointer in opcode at: %p\n", baseop );
 469   }
 470 }
 471
 472 #if PERL_VERSION > 9 || (PERL_VERSION == 9 && PERL_SUBVERSION > 2)
 473 #  define NEW_HEAD_LAYOUT
 474 #endif
 475
 476 static void
 477 thing_size(pTHX_ const SV * const orig_thing, struct state *st) {
 478   const SV *thing = orig_thing;
 479
 480   st->total_size += sizeof(SV);
 481
 482   switch (SvTYPE(thing)) {
 483     /* Is it undef? */
 484   case SVt_NULL: TAG;
 485     TAG;break;
 486     /* Just a plain integer. This will be differently sized depending
 487        on whether purify's been compiled in */
 488   case SVt_IV: TAG;
 489 #ifndef NEW_HEAD_LAYOUT
 490 #  ifdef PURIFY
 491     st->total_size += sizeof(sizeof(XPVIV));
 492 #  else
 493     st->total_size += sizeof(IV);
 494 #  endif
 495 #endif
 496     TAG;break;
 497     /* Is it a float? Like the int, it depends on purify */
 498   case SVt_NV: TAG;
 499 #ifdef PURIFY
 500     st->total_size += sizeof(sizeof(XPVNV));
 501 #else
 502     st->total_size += sizeof(NV);
 503 #endif
 504     TAG;break;
 505 #if (PERL_VERSION < 11)
 506     /* Is it a reference? */
 507   case SVt_RV: TAG;
 508 #ifndef NEW_HEAD_LAYOUT
 509     st->total_size += sizeof(XRV);
 510 #endif
 511     TAG;break;
 512 #endif
 513     /* How about a plain string? In which case we need to add in how
 514        much has been allocated */
 515   case SVt_PV: TAG;
 516     st->total_size += sizeof(XPV);
 517     if(SvROK(thing))
 518         thing_size(aTHX_ SvRV_const(thing), st);
 519     else
 520         st->total_size += SvLEN(thing);
 521     TAG;break;
 522     /* A string with an integer part? */
 523   case SVt_PVIV: TAG;
 524     st->total_size += sizeof(XPVIV);
 525     if(SvROK(thing))
 526         thing_size(aTHX_ SvRV_const(thing), st);
 527     else
 528         st->total_size += SvLEN(thing);
 529     if(SvOOK(thing)) {
 530         st->total_size += SvIVX(thing);
 531     }
 532     TAG;break;
 533     /* A scalar/string/reference with a float part? */
 534   case SVt_PVNV: TAG;
 535     st->total_size += sizeof(XPVNV);
 536     if(SvROK(thing))
 537         thing_size(aTHX_ SvRV_const(thing), st);
 538     else
 539         st->total_size += SvLEN(thing);
 540     TAG;break;
 541   case SVt_PVMG: TAG;
 542     st->total_size += sizeof(XPVMG);
 543     if(SvROK(thing))
 544         thing_size(aTHX_ SvRV_const(thing), st);
 545     else
 546         st->total_size += SvLEN(thing);
 547     magic_size(thing, st);
 548     TAG;break;
 549 #if PERL_VERSION <= 8
 550   case SVt_PVBM: TAG;
 551     st->total_size += sizeof(XPVBM);
 552     if(SvROK(thing))
 553         thing_size(aTHX_ SvRV_const(thing), st);
 554     else
 555         st->total_size += SvLEN(thing);
 556     magic_size(thing, st);
 557     TAG;break;
 558 #endif
 559   case SVt_PVLV: TAG;
 560     st->total_size += sizeof(XPVLV);
 561     if(SvROK(thing))
 562         thing_size(aTHX_ SvRV_const(thing), st);
 563     else
 564         st->total_size += SvLEN(thing);
 565     magic_size(thing, st);
 566     TAG;break;
 567     /* How much space is dedicated to the array? Not counting the
 568        elements in the array, mind, just the array itself */
 569   case SVt_PVAV: TAG;
 570     st->total_size += sizeof(XPVAV);
 571     /* Is there anything in the array? */
 572     if (AvMAX(thing) != -1) {
 573       /* an array with 10 slots has AvMax() set to 9 - te 2007-04-22 */
 574       st->total_size += sizeof(SV *) * (AvMAX(thing) + 1);
 575       dbg_printf(("total_size: %li AvMAX: %li av_len: $i\n", st->total_size, AvMAX(thing), av_len((AV*)thing)));
 576     }
 577     /* Add in the bits on the other side of the beginning */
 578
 579     dbg_printf(("total_size %li, sizeof(SV *) %li, AvARRAY(thing) %li, AvALLOC(thing)%li , sizeof(ptr) %li \n",
 580     st->total_size, sizeof(SV*), AvARRAY(thing), AvALLOC(thing), sizeof( thing )));
 581
 582     /* under Perl 5.8.8 64bit threading, AvARRAY(thing) was a pointer while AvALLOC was 0,
 583        resulting in grossly overstated sized for arrays. Technically, this shouldn't happen... */
 584     if (AvALLOC(thing) != 0) {
 585       st->total_size += (sizeof(SV *) * (AvARRAY(thing) - AvALLOC(thing)));
 586       }
 587 #if (PERL_VERSION < 9)
 588     /* Is there something hanging off the arylen element?
 589        Post 5.9.something this is stored in magic, so will be found there,
 590        and Perl_av_arylen_p() takes a non-const AV*, hence compilers rightly
 591        complain about AvARYLEN() passing thing to it.  */
 592     if (AvARYLEN(thing)) {
 593       if (check_new(st, AvARYLEN(thing))) {
 594           thing_size(aTHX_ AvARYLEN(thing), st);
 595       }
 596     }
 597 #endif
 598     magic_size(thing, st);
 599     TAG;break;
 600   case SVt_PVHV: TAG;
 601     /* First the base struct */
 602     st->total_size += sizeof(XPVHV);
 603     /* Now the array of buckets */
 604     st->total_size += (sizeof(HE *) * (HvMAX(thing) + 1));
 605     /* Now walk the bucket chain */
 606     if (HvARRAY(thing)) {
 607       HE *cur_entry;
 608       UV cur_bucket = 0;
 609       for (cur_bucket = 0; cur_bucket <= HvMAX(thing); cur_bucket++) {
 610         cur_entry = *(HvARRAY(thing) + cur_bucket);
 611         while (cur_entry) {
 612           st->total_size += sizeof(HE);
 613           if (cur_entry->hent_hek) {
 614             /* Hash keys can be shared. Have we seen this before? */
 615             if (check_new(st, cur_entry->hent_hek)) {
 616               st->total_size += HEK_BASESIZE + cur_entry->hent_hek->hek_len + 2;
 617             }
 618           }
 619           cur_entry = cur_entry->hent_next;
 620         }
 621       }
 622     }
 623     magic_size(thing, st);
 624     TAG;break;
 625   case SVt_PVCV: TAG;
 626     st->total_size += sizeof(XPVCV);
 627     magic_size(thing, st);
 628
 629     st->total_size += ((XPVIO *) SvANY(thing))->xpv_len;
 630     if (check_new(st, CvSTASH(thing))) {
 631       thing_size(aTHX_ (SV *)CvSTASH(thing), st);
 632     }
 633     if (check_new(st, SvSTASH(thing))) {
 634       thing_size(aTHX_ (SV *)SvSTASH(thing), st);
 635     }
 636     if (check_new(st, CvGV(thing))) {
 637       thing_size(aTHX_ (SV *)CvGV(thing), st);
 638     }
 639     if (check_new(st, CvPADLIST(thing))) {
 640       thing_size(aTHX_ (SV *)CvPADLIST(thing), st);
 641     }
 642     if (check_new(st, CvOUTSIDE(thing))) {
 643       thing_size(aTHX_ (SV *)CvOUTSIDE(thing), st);
 644     }
 645     if (CvISXSUB(thing)) {
 646         SV *sv = cv_const_sv((CV *)thing);
 647         if (sv) {
 648             thing_size(aTHX_ sv, st);
 649         }
 650     } else {
 651         op_size(aTHX_ CvSTART(thing), st);
 652         op_size(aTHX_ CvROOT(thing), st);
 653     }
 654
 655     TAG;break;
 656   case SVt_PVGV: TAG;
 657     magic_size(thing, st);
 658     st->total_size += sizeof(XPVGV);
 659     st->total_size += GvNAMELEN(thing);
 660 #ifdef GvFILE
 661     /* Is there a file? */
 662     if (GvFILE(thing)) {
 663       if (check_new(st, GvFILE(thing))) {
 664     st->total_size += strlen(GvFILE(thing));
 665       }
 666     }
 667 #endif
 668     /* Is there something hanging off the glob? */
 669     if (GvGP(thing)) {
 670       if (check_new(st, GvGP(thing))) {
 671     st->total_size += sizeof(GP);
 672     {
 673       SV *generic_thing;
 674       if ((generic_thing = (SV *)(GvGP(thing)->gp_sv))) {
 675         thing_size(aTHX_ generic_thing, st);
 676       }
 677       if ((generic_thing = (SV *)(GvGP(thing)->gp_form))) {
 678         thing_size(aTHX_ generic_thing, st);
 679       }
 680       if ((generic_thing = (SV *)(GvGP(thing)->gp_av))) {
 681         thing_size(aTHX_ generic_thing, st);
 682       }
 683       if ((generic_thing = (SV *)(GvGP(thing)->gp_hv))) {
 684         thing_size(aTHX_ generic_thing, st);
 685       }
 686       if ((generic_thing = (SV *)(GvGP(thing)->gp_egv))) {
 687         thing_size(aTHX_ generic_thing, st);
 688       }
 689       if ((generic_thing = (SV *)(GvGP(thing)->gp_cv))) {
 690         thing_size(aTHX_ generic_thing, st);
 691       }
 692     }
 693       }
 694     }
 695     TAG;break;
 696   case SVt_PVFM: TAG;
 697     st->total_size += sizeof(XPVFM);
 698     magic_size(thing, st);
 699     st->total_size += ((XPVIO *) SvANY(thing))->xpv_len;
 700     if (check_new(st, CvPADLIST(thing))) {
 701       thing_size(aTHX_ (SV *)CvPADLIST(thing), st);
 702     }
 703     if (check_new(st, CvOUTSIDE(thing))) {
 704       thing_size(aTHX_ (SV *)CvOUTSIDE(thing), st);
 705     }
 706
 707     if (st->go_yell && !st->fm_whine) {
 708       carp("Devel::Size: Calculated sizes for FMs are incomplete");
 709       st->fm_whine = 1;
 710     }
 711     TAG;break;
 712   case SVt_PVIO: TAG;
 713     st->total_size += sizeof(XPVIO);
 714     magic_size(thing, st);
 715     if (check_new(st, (SvPVX_const(thing)))) {
 716       st->total_size += ((XPVIO *) SvANY(thing))->xpv_cur;
 717     }
 718     /* Some embedded char pointers */
 719     if (check_new(st, ((XPVIO *) SvANY(thing))->xio_top_name)) {
 720       st->total_size += strlen(((XPVIO *) SvANY(thing))->xio_top_name);
 721     }
 722     if (check_new(st, ((XPVIO *) SvANY(thing))->xio_fmt_name)) {
 723       st->total_size += strlen(((XPVIO *) SvANY(thing))->xio_fmt_name);
 724     }
 725     if (check_new(st, ((XPVIO *) SvANY(thing))->xio_bottom_name)) {
 726       st->total_size += strlen(((XPVIO *) SvANY(thing))->xio_bottom_name);
 727     }
 728     /* Throw the GVs on the list to be walked if they're not-null */
 729     if (((XPVIO *) SvANY(thing))->xio_top_gv) {
 730       thing_size(aTHX_ (SV *)((XPVIO *) SvANY(thing))->xio_top_gv, st);
 731     }
 732     if (((XPVIO *) SvANY(thing))->xio_bottom_gv) {
 733       thing_size(aTHX_ (SV *)((XPVIO *) SvANY(thing))->xio_bottom_gv, st);
 734     }
 735     if (((XPVIO *) SvANY(thing))->xio_fmt_gv) {
 736       thing_size(aTHX_ (SV *)((XPVIO *) SvANY(thing))->xio_fmt_gv, st);
 737     }
 738
 739     /* Only go trotting through the IO structures if they're really
 740        trottable. If USE_PERLIO is defined we can do this. If
 741        not... we can't, so we don't even try */
 742 #ifdef USE_PERLIO
 743     /* Dig into xio_ifp and xio_ofp here */
 744     warn("Devel::Size: Can't size up perlio layers yet\n");
 745 #endif
 746     TAG;break;
 747   default:
 748     warn("Devel::Size: Unknown variable type: %d encountered\n", SvTYPE(thing) );
 749   }
 750 }
 751
 752 static struct state *
 753 new_state(pTHX)
 754 {
 755     SV *warn_flag;
 756     struct state *st;
 757     Newxz(st, 1, struct state);
 758     st->go_yell = TRUE;
 759     if (NULL != (warn_flag = perl_get_sv("Devel::Size::warn", FALSE))) {
 760         st->dangle_whine = st->go_yell = SvIV(warn_flag) ? TRUE : FALSE;
 761     }
 762     if (NULL != (warn_flag = perl_get_sv("Devel::Size::dangle", FALSE))) {
 763         st->dangle_whine = SvIV(warn_flag) ? TRUE : FALSE;
 764     }
 765     return st;
 766 }
 767
 768 MODULE = Devel::Size        PACKAGE = Devel::Size
 769
 770 PROTOTYPES: DISABLE
 771
 772 UV
 773 size(orig_thing)
 774      SV *orig_thing
 775 CODE:
 776 {
 777   SV *thing = orig_thing;
 778   struct state *st = new_state(aTHX);
 779
 780   /* If they passed us a reference then dereference it. This is the
 781      only way we can check the sizes of arrays and hashes */
 782 #if (PERL_VERSION < 11)
 783   if (SvOK(thing) && SvROK(thing)) {
 784     thing = SvRV(thing);
 785   }
 786 #else
 787   if (SvROK(thing)) {
 788     thing = SvRV(thing);
 789   }
 790 #endif
 791
 792   thing_size(aTHX_ thing, st);
 793   RETVAL = st->total_size;
 794   free_state(st);
 795 }
 796 OUTPUT:
 797   RETVAL
 798
 799
 800 UV
 801 total_size(orig_thing)
 802        SV *orig_thing
 803 CODE:
 804 {
 805   SV *thing = orig_thing;
 806   /* Array with things we still need to do */
 807   AV *pending_array;
 808   IV size = 0;
 809   struct state *st = new_state(aTHX);
 810
 811   /* Size starts at zero */
 812   RETVAL = 0;
 813
 814   pending_array = newAV();
 815
 816   /* If they passed us a reference then dereference it.
 817      This is the only way we can check the sizes of arrays and hashes. */
 818   if (SvROK(thing)) {
 819       thing = SvRV(thing);
 820   }
 821
 822   /* Put it on the pending array */
 823   av_push(pending_array, thing);
 824
 825   /* Now just yank things off the end of the array until it's done */
 826   while (av_len(pending_array) >= 0) {
 827     thing = av_pop(pending_array);
 828     /* Process it if we've not seen it */
 829     if (check_new(st, thing)) {
 830       dbg_printf(("# Found type %i at %p\n", SvTYPE(thing), thing));
 831       /* Is it valid? */
 832       if (thing) {
 833     /* Yes, it is. So let's check the type */
 834     switch (SvTYPE(thing)) {
 835     /* fix for bug #24846 (Does not correctly recurse into references in a PVNV-type scalar) */
 836     case SVt_PVNV: TAG;
 837       if (SvROK(thing))
 838         {
 839         av_push(pending_array, SvRV(thing));
 840         }
 841       TAG;break;
 842 #if (PERL_VERSION < 11)
 843         case SVt_RV: TAG;
 844 #else
 845         case SVt_IV: TAG;
 846 #endif
 847              dbg_printf(("# Found RV\n"));
 848           if (SvROK(thing)) {
 849              dbg_printf(("# Found RV\n"));
 850              av_push(pending_array, SvRV(thing));
 851           }
 852           TAG;break;
 853
 854     case SVt_PVAV: TAG;
 855       {
 856         AV *tempAV = (AV *)thing;
 857         SV **tempSV;
 858
 859         dbg_printf(("# Found type AV\n"));
 860         /* Quick alias to cut down on casting */
 861
 862         /* Any elements? */
 863         if (av_len(tempAV) != -1) {
 864           IV index;
 865           /* Run through them all */
 866           for (index = 0; index <= av_len(tempAV); index++) {
 867         /* Did we get something? */
 868         if ((tempSV = av_fetch(tempAV, index, 0))) {
 869           /* Was it undef? */
 870           if (*tempSV != &PL_sv_undef) {
 871             /* Apparently not. Save it for later */
 872             av_push(pending_array, *tempSV);
 873           }
 874         }
 875           }
 876         }
 877       }
 878       TAG;break;
 879
 880     case SVt_PVHV: TAG;
 881       dbg_printf(("# Found type HV\n"));
 882       /* Is there anything in here? */
 883       if (hv_iterinit((HV *)thing)) {
 884         HE *temp_he;
 885         while ((temp_he = hv_iternext((HV *)thing))) {
 886           av_push(pending_array, hv_iterval((HV *)thing, temp_he));
 887         }
 888       }
 889       TAG;break;
 890
 891     case SVt_PVGV: TAG;
 892       dbg_printf(("# Found type GV\n"));
 893       /* Run through all the pieces and push the ones with bits */
 894       if (GvSV(thing)) {
 895         av_push(pending_array, (SV *)GvSV(thing));
 896       }
 897       if (GvFORM(thing)) {
 898         av_push(pending_array, (SV *)GvFORM(thing));
 899       }
 900       if (GvAV(thing)) {
 901         av_push(pending_array, (SV *)GvAV(thing));
 902       }
 903       if (GvHV(thing)) {
 904         av_push(pending_array, (SV *)GvHV(thing));
 905       }
 906       if (GvCV(thing)) {
 907         av_push(pending_array, (SV *)GvCV(thing));
 908       }
 909       TAG;break;
 910     default:
 911       TAG;break;
 912     }
 913       }
 914
 915       thing_size(aTHX_ thing, st);
 916     } else {
 917     /* check_new() returned false: */
 918 #ifdef DEVEL_SIZE_DEBUGGING
 919        if (SvOK(sv)) printf("# Ignore ref copy 0x%x\n", sv);
 920        else printf("# Ignore non-sv 0x%x\n", sv);
 921 #endif
 922     }
 923   } /* end while */
 924
 925   RETVAL = st->total_size;
 926   free_state(st);
 927   SvREFCNT_dec(pending_array);
 928 }
 929 OUTPUT:
 930   RETVAL
 931