Size.xs

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