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