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