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 /* For now, this is somewhat a compatibility bodge until the plan comes
 164    together for fine grained recursion control. total_size() would recurse into
 165    hash and array members, whereas sv_size() would not. However, sv_size() is
 166    called with CvSTASH() of a CV, which means that if it (also) starts to
 167    recurse fully, then the size of any CV now becomes the size of the entire
 168    symbol table reachable from it, and potentially the entire symbol table, if
 169    any subroutine makes a reference to a global (such as %SIG). The historical
 170    implementation of total_size() didn't report "everything", and changing the
 171    only available size to "everything" doesn't feel at all useful.  */
 172
 173 #define NO_RECURSION 0
 174 #define SOME_RECURSION 1
 175 #define TOTAL_SIZE_RECURSION 2
 176
 177 static bool sv_size(pTHX_ struct state *, const SV *const, const int recurse);
 178
 179 typedef enum {
 180     OPc_NULL,   /* 0 */
 181     OPc_BASEOP, /* 1 */
 182     OPc_UNOP,   /* 2 */
 183     OPc_BINOP,  /* 3 */
 184     OPc_LOGOP,  /* 4 */
 185     OPc_LISTOP, /* 5 */
 186     OPc_PMOP,   /* 6 */
 187     OPc_SVOP,   /* 7 */
 188     OPc_PADOP,  /* 8 */
 189     OPc_PVOP,   /* 9 */
 190     OPc_LOOP,   /* 10 */
 191     OPc_COP /* 11 */
 192 } opclass;
 193
 194 static opclass
 195 cc_opclass(const OP * const o)
 196 {
 197     if (!o)
 198     return OPc_NULL;
 199     TRY_TO_CATCH_SEGV {
 200         if (o->op_type == 0)
 201         return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
 202
 203         if (o->op_type == OP_SASSIGN)
 204         return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPc_UNOP : OPc_BINOP);
 205
 206     #ifdef USE_ITHREADS
 207         if (o->op_type == OP_GV || o->op_type == OP_GVSV || o->op_type == OP_AELEMFAST)
 208         return OPc_PADOP;
 209     #endif
 210
 211         if ((o->op_type == OP_TRANS)) {
 212           return OPc_BASEOP;
 213         }
 214
 215         switch (PL_opargs[o->op_type] & OA_CLASS_MASK) {
 216         case OA_BASEOP: TAG;
 217         return OPc_BASEOP;
 218
 219         case OA_UNOP: TAG;
 220         return OPc_UNOP;
 221
 222         case OA_BINOP: TAG;
 223         return OPc_BINOP;
 224
 225         case OA_LOGOP: TAG;
 226         return OPc_LOGOP;
 227
 228         case OA_LISTOP: TAG;
 229         return OPc_LISTOP;
 230
 231         case OA_PMOP: TAG;
 232         return OPc_PMOP;
 233
 234         case OA_SVOP: TAG;
 235         return OPc_SVOP;
 236
 237         case OA_PADOP: TAG;
 238         return OPc_PADOP;
 239
 240         case OA_PVOP_OR_SVOP: TAG;
 241             /*
 242              * Character translations (tr///) are usually a PVOP, keeping a
 243              * pointer to a table of shorts used to look up translations.
 244              * Under utf8, however, a simple table isn't practical; instead,
 245              * the OP is an SVOP, and the SV is a reference to a swash
 246              * (i.e., an RV pointing to an HV).
 247              */
 248         return (o->op_private & (OPpTRANS_TO_UTF|OPpTRANS_FROM_UTF))
 249             ? OPc_SVOP : OPc_PVOP;
 250
 251         case OA_LOOP: TAG;
 252         return OPc_LOOP;
 253
 254         case OA_COP: TAG;
 255         return OPc_COP;
 256
 257         case OA_BASEOP_OR_UNOP: TAG;
 258         /*
 259          * UNI(OP_foo) in toke.c returns token UNI or FUNC1 depending on
 260          * whether parens were seen. perly.y uses OPf_SPECIAL to
 261          * signal whether a BASEOP had empty parens or none.
 262          * Some other UNOPs are created later, though, so the best
 263          * test is OPf_KIDS, which is set in newUNOP.
 264          */
 265         return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
 266
 267         case OA_FILESTATOP: TAG;
 268         /*
 269          * The file stat OPs are created via UNI(OP_foo) in toke.c but use
 270          * the OPf_REF flag to distinguish between OP types instead of the
 271          * usual OPf_SPECIAL flag. As usual, if OPf_KIDS is set, then we
 272          * return OPc_UNOP so that walkoptree can find our children. If
 273          * OPf_KIDS is not set then we check OPf_REF. Without OPf_REF set
 274          * (no argument to the operator) it's an OP; with OPf_REF set it's
 275          * an SVOP (and op_sv is the GV for the filehandle argument).
 276          */
 277         return ((o->op_flags & OPf_KIDS) ? OPc_UNOP :
 278     #ifdef USE_ITHREADS
 279             (o->op_flags & OPf_REF) ? OPc_PADOP : OPc_BASEOP);
 280     #else
 281             (o->op_flags & OPf_REF) ? OPc_SVOP : OPc_BASEOP);
 282     #endif
 283         case OA_LOOPEXOP: TAG;
 284         /*
 285          * next, last, redo, dump and goto use OPf_SPECIAL to indicate that a
 286          * label was omitted (in which case it's a BASEOP) or else a term was
 287          * seen. In this last case, all except goto are definitely PVOP but
 288          * goto is either a PVOP (with an ordinary constant label), an UNOP
 289          * with OPf_STACKED (with a non-constant non-sub) or an UNOP for
 290          * OP_REFGEN (with goto &sub) in which case OPf_STACKED also seems to
 291          * get set.
 292          */
 293         if (o->op_flags & OPf_STACKED)
 294             return OPc_UNOP;
 295         else if (o->op_flags & OPf_SPECIAL)
 296             return OPc_BASEOP;
 297         else
 298             return OPc_PVOP;
 299         }
 300         warn("Devel::Size: Can't determine class of operator %s, assuming BASEOP\n",
 301          PL_op_name[o->op_type]);
 302     }
 303     CAUGHT_EXCEPTION { }
 304     return OPc_BASEOP;
 305 }
 306
 307
 308 #if !defined(NV)
 309 #define NV double
 310 #endif
 311
 312 /* Figure out how much magic is attached to the SV and return the
 313    size */
 314 static void
 315 magic_size(const SV * const thing, struct state *st) {
 316   MAGIC *magic_pointer;
 317
 318   /* Is there any? */
 319   if (!SvMAGIC(thing)) {
 320     /* No, bail */
 321     return;
 322   }
 323
 324   /* Get the base magic pointer */
 325   magic_pointer = SvMAGIC(thing);
 326
 327   /* Have we seen the magic pointer? */
 328   while (check_new(st, magic_pointer)) {
 329     st->total_size += sizeof(MAGIC);
 330
 331     TRY_TO_CATCH_SEGV {
 332         /* Have we seen the magic vtable? */
 333         if (check_new(st, magic_pointer->mg_virtual)) {
 334           st->total_size += sizeof(MGVTBL);
 335         }
 336
 337         /* Get the next in the chain */
 338         magic_pointer = magic_pointer->mg_moremagic;
 339     }
 340     CAUGHT_EXCEPTION {
 341         if (st->dangle_whine)
 342             warn( "Devel::Size: Encountered bad magic at: %p\n", magic_pointer );
 343     }
 344   }
 345 }
 346
 347 static void
 348 check_new_and_strlen(struct state *st, const char *const p) {
 349     if(check_new(st, p))
 350         st->total_size += 1 + strlen(p);
 351 }
 352
 353 static void
 354 regex_size(const REGEXP * const baseregex, struct state *st) {
 355     if(!check_new(st, baseregex))
 356         return;
 357   st->total_size += sizeof(REGEXP);
 358 #if (PERL_VERSION < 11)
 359   /* Note the size of the paren offset thing */
 360   st->total_size += sizeof(I32) * baseregex->nparens * 2;
 361   st->total_size += strlen(baseregex->precomp);
 362 #else
 363   st->total_size += sizeof(struct regexp);
 364   st->total_size += sizeof(I32) * SvANY(baseregex)->nparens * 2;
 365   /*st->total_size += strlen(SvANY(baseregex)->subbeg);*/
 366 #endif
 367   if (st->go_yell && !st->regex_whine) {
 368     carp("Devel::Size: Calculated sizes for compiled regexes are incompatible, and probably always will be");
 369     st->regex_whine = 1;
 370   }
 371 }
 372
 373 static void
 374 op_size(pTHX_ const OP * const baseop, struct state *st)
 375 {
 376     TRY_TO_CATCH_SEGV {
 377         TAG;
 378         if(!check_new(st, baseop))
 379             return;
 380         TAG;
 381         op_size(aTHX_ baseop->op_next, st);
 382         TAG;
 383         switch (cc_opclass(baseop)) {
 384         case OPc_BASEOP: TAG;
 385             st->total_size += sizeof(struct op);
 386             TAG;break;
 387         case OPc_UNOP: TAG;
 388             st->total_size += sizeof(struct unop);
 389             op_size(aTHX_ cUNOPx(baseop)->op_first, st);
 390             TAG;break;
 391         case OPc_BINOP: TAG;
 392             st->total_size += sizeof(struct binop);
 393             op_size(aTHX_ cBINOPx(baseop)->op_first, st);
 394             op_size(aTHX_ cBINOPx(baseop)->op_last, st);
 395             TAG;break;
 396         case OPc_LOGOP: TAG;
 397             st->total_size += sizeof(struct logop);
 398             op_size(aTHX_ cBINOPx(baseop)->op_first, st);
 399             op_size(aTHX_ cLOGOPx(baseop)->op_other, st);
 400             TAG;break;
 401         case OPc_LISTOP: TAG;
 402             st->total_size += sizeof(struct listop);
 403             op_size(aTHX_ cLISTOPx(baseop)->op_first, st);
 404             op_size(aTHX_ cLISTOPx(baseop)->op_last, st);
 405             TAG;break;
 406         case OPc_PMOP: TAG;
 407             st->total_size += sizeof(struct pmop);
 408             op_size(aTHX_ cPMOPx(baseop)->op_first, st);
 409             op_size(aTHX_ cPMOPx(baseop)->op_last, st);
 410 #if PERL_VERSION < 9 || (PERL_VERSION == 9 && PERL_SUBVERSION < 5)
 411             op_size(aTHX_ cPMOPx(baseop)->op_pmreplroot, st);
 412             op_size(aTHX_ cPMOPx(baseop)->op_pmreplstart, st);
 413             op_size(aTHX_ (OP *)cPMOPx(baseop)->op_pmnext, st);
 414 #endif
 415             /* This is defined away in perl 5.8.x, but it is in there for
 416                5.6.x */
 417 #ifdef PM_GETRE
 418             regex_size(PM_GETRE(cPMOPx(baseop)), st);
 419 #else
 420             regex_size(cPMOPx(baseop)->op_pmregexp, st);
 421 #endif
 422             TAG;break;
 423         case OPc_SVOP: TAG;
 424             st->total_size += sizeof(struct pmop);
 425             if (!(baseop->op_type == OP_AELEMFAST
 426                   && baseop->op_flags & OPf_SPECIAL)) {
 427                 /* not an OP_PADAV replacement */
 428                 sv_size(aTHX_ st, cSVOPx(baseop)->op_sv, SOME_RECURSION);
 429             }
 430             TAG;break;
 431       case OPc_PADOP: TAG;
 432           st->total_size += sizeof(struct padop);
 433           TAG;break;
 434         case OPc_PVOP: TAG;
 435             check_new_and_strlen(st, cPVOPx(baseop)->op_pv);
 436             TAG;break;
 437         case OPc_LOOP: TAG;
 438             st->total_size += sizeof(struct loop);
 439             op_size(aTHX_ cLOOPx(baseop)->op_first, st);
 440             op_size(aTHX_ cLOOPx(baseop)->op_last, st);
 441             op_size(aTHX_ cLOOPx(baseop)->op_redoop, st);
 442             op_size(aTHX_ cLOOPx(baseop)->op_nextop, st);
 443             op_size(aTHX_ cLOOPx(baseop)->op_lastop, st);
 444             TAG;break;
 445         case OPc_COP: TAG;
 446         {
 447           COP *basecop;
 448           basecop = (COP *)baseop;
 449           st->total_size += sizeof(struct cop);
 450
 451           /* Change 33656 by nicholas@mouse-mill on 2008/04/07 11:29:51
 452           Eliminate cop_label from struct cop by storing a label as the first
 453           entry in the hints hash. Most statements don't have labels, so this
 454           will save memory. Not sure how much.
 455           The check below will be incorrect fail on bleadperls
 456           before 5.11 @33656, but later than 5.10, producing slightly too
 457           small memory sizes on these Perls. */
 458 #if (PERL_VERSION < 11)
 459           check_new_and_strlen(st, basecop->cop_label);
 460 #endif
 461 #ifdef USE_ITHREADS
 462           check_new_and_strlen(st, basecop->cop_file);
 463           check_new_and_strlen(st, basecop->cop_stashpv);
 464 #else
 465           sv_size(aTHX_ st, (SV *)basecop->cop_stash, SOME_RECURSION);
 466           sv_size(aTHX_ st, (SV *)basecop->cop_filegv, SOME_RECURSION);
 467 #endif
 468
 469         }
 470         TAG;break;
 471       default:
 472         TAG;break;
 473       }
 474   }
 475   CAUGHT_EXCEPTION {
 476       if (st->dangle_whine)
 477           warn( "Devel::Size: Encountered dangling pointer in opcode at: %p\n", baseop );
 478   }
 479 }
 480
 481 #if PERL_VERSION > 9 || (PERL_VERSION == 9 && PERL_SUBVERSION > 2)
 482 #  define NEW_HEAD_LAYOUT
 483 #endif
 484
 485 static bool
 486 sv_size(pTHX_ struct state *const st, const SV * const orig_thing,
 487         const int recurse) {
 488   const SV *thing = orig_thing;
 489
 490   if(!check_new(st, thing))
 491       return FALSE;
 492
 493   st->total_size += sizeof(SV);
 494
 495   switch (SvTYPE(thing)) {
 496     /* Is it undef? */
 497   case SVt_NULL: TAG;
 498     TAG;break;
 499     /* Just a plain integer. This will be differently sized depending
 500        on whether purify's been compiled in */
 501   case SVt_IV: TAG;
 502 #ifndef NEW_HEAD_LAYOUT
 503 #  ifdef PURIFY
 504     st->total_size += sizeof(sizeof(XPVIV));
 505 #  else
 506     st->total_size += sizeof(IV);
 507 #  endif
 508 #endif
 509     if(recurse && SvROK(thing))
 510         sv_size(aTHX_ st, SvRV_const(thing), recurse);
 511     TAG;break;
 512     /* Is it a float? Like the int, it depends on purify */
 513   case SVt_NV: TAG;
 514 #ifdef PURIFY
 515     st->total_size += sizeof(sizeof(XPVNV));
 516 #else
 517     st->total_size += sizeof(NV);
 518 #endif
 519     TAG;break;
 520 #if (PERL_VERSION < 11)
 521     /* Is it a reference? */
 522   case SVt_RV: TAG;
 523 #ifndef NEW_HEAD_LAYOUT
 524     st->total_size += sizeof(XRV);
 525 #endif
 526     if(recurse && SvROK(thing))
 527         sv_size(aTHX_ st, SvRV_const(thing), recurse);
 528     TAG;break;
 529 #endif
 530     /* How about a plain string? In which case we need to add in how
 531        much has been allocated */
 532   case SVt_PV: TAG;
 533     st->total_size += sizeof(XPV);
 534     if(recurse && SvROK(thing))
 535         sv_size(aTHX_ st, SvRV_const(thing), recurse);
 536     else
 537         st->total_size += SvLEN(thing);
 538     TAG;break;
 539     /* A string with an integer part? */
 540   case SVt_PVIV: TAG;
 541     st->total_size += sizeof(XPVIV);
 542     if(recurse && SvROK(thing))
 543         sv_size(aTHX_ st, SvRV_const(thing), recurse);
 544     else
 545         st->total_size += SvLEN(thing);
 546     if(SvOOK(thing)) {
 547         st->total_size += SvIVX(thing);
 548     }
 549     TAG;break;
 550     /* A scalar/string/reference with a float part? */
 551   case SVt_PVNV: TAG;
 552     st->total_size += sizeof(XPVNV);
 553     if(recurse && SvROK(thing))
 554         sv_size(aTHX_ st, SvRV_const(thing), recurse);
 555     else
 556         st->total_size += SvLEN(thing);
 557     TAG;break;
 558   case SVt_PVMG: TAG;
 559     st->total_size += sizeof(XPVMG);
 560     if(recurse && SvROK(thing))
 561         sv_size(aTHX_ st, SvRV_const(thing), recurse);
 562     else
 563         st->total_size += SvLEN(thing);
 564     magic_size(thing, st);
 565     TAG;break;
 566 #if PERL_VERSION <= 8
 567   case SVt_PVBM: TAG;
 568     st->total_size += sizeof(XPVBM);
 569     if(recurse && SvROK(thing))
 570         sv_size(aTHX_ st, SvRV_const(thing), recurse);
 571     else
 572         st->total_size += SvLEN(thing);
 573     magic_size(thing, st);
 574     TAG;break;
 575 #endif
 576   case SVt_PVLV: TAG;
 577     st->total_size += sizeof(XPVLV);
 578     if(recurse && SvROK(thing))
 579         sv_size(aTHX_ st, SvRV_const(thing), recurse);
 580     else
 581         st->total_size += SvLEN(thing);
 582     magic_size(thing, st);
 583     TAG;break;
 584     /* How much space is dedicated to the array? Not counting the
 585        elements in the array, mind, just the array itself */
 586   case SVt_PVAV: TAG;
 587     st->total_size += sizeof(XPVAV);
 588     /* Is there anything in the array? */
 589     if (AvMAX(thing) != -1) {
 590       /* an array with 10 slots has AvMax() set to 9 - te 2007-04-22 */
 591       st->total_size += sizeof(SV *) * (AvMAX(thing) + 1);
 592       dbg_printf(("total_size: %li AvMAX: %li av_len: $i\n", st->total_size, AvMAX(thing), av_len((AV*)thing)));
 593
 594       if (recurse >= TOTAL_SIZE_RECURSION) {
 595           SSize_t i = AvFILLp(thing) + 1;
 596
 597           while (i--)
 598               sv_size(aTHX_ st, AvARRAY(thing)[i], recurse);
 599       }
 600     }
 601     /* Add in the bits on the other side of the beginning */
 602
 603     dbg_printf(("total_size %li, sizeof(SV *) %li, AvARRAY(thing) %li, AvALLOC(thing)%li , sizeof(ptr) %li \n",
 604     st->total_size, sizeof(SV*), AvARRAY(thing), AvALLOC(thing), sizeof( thing )));
 605
 606     /* under Perl 5.8.8 64bit threading, AvARRAY(thing) was a pointer while AvALLOC was 0,
 607        resulting in grossly overstated sized for arrays. Technically, this shouldn't happen... */
 608     if (AvALLOC(thing) != 0) {
 609       st->total_size += (sizeof(SV *) * (AvARRAY(thing) - AvALLOC(thing)));
 610       }
 611 #if (PERL_VERSION < 9)
 612     /* Is there something hanging off the arylen element?
 613        Post 5.9.something this is stored in magic, so will be found there,
 614        and Perl_av_arylen_p() takes a non-const AV*, hence compilers rightly
 615        complain about AvARYLEN() passing thing to it.  */
 616     sv_size(aTHX_ st, AvARYLEN(thing), recurse);
 617 #endif
 618     magic_size(thing, st);
 619     TAG;break;
 620   case SVt_PVHV: TAG;
 621     /* First the base struct */
 622     st->total_size += sizeof(XPVHV);
 623     /* Now the array of buckets */
 624     st->total_size += (sizeof(HE *) * (HvMAX(thing) + 1));
 625     /* Now walk the bucket chain */
 626     if (HvARRAY(thing)) {
 627       HE *cur_entry;
 628       UV cur_bucket = 0;
 629       for (cur_bucket = 0; cur_bucket <= HvMAX(thing); cur_bucket++) {
 630         cur_entry = *(HvARRAY(thing) + cur_bucket);
 631         while (cur_entry) {
 632           st->total_size += sizeof(HE);
 633           if (cur_entry->hent_hek) {
 634             /* Hash keys can be shared. Have we seen this before? */
 635             if (check_new(st, cur_entry->hent_hek)) {
 636               st->total_size += HEK_BASESIZE + cur_entry->hent_hek->hek_len + 2;
 637             }
 638           }
 639           if (recurse >= TOTAL_SIZE_RECURSION)
 640               sv_size(aTHX_ st, HeVAL(cur_entry), recurse);
 641           cur_entry = cur_entry->hent_next;
 642         }
 643       }
 644     }
 645     magic_size(thing, st);
 646     TAG;break;
 647   case SVt_PVCV: TAG;
 648     st->total_size += sizeof(XPVCV);
 649     magic_size(thing, st);
 650
 651     st->total_size += ((XPVIO *) SvANY(thing))->xpv_len;
 652     sv_size(aTHX_ st, (SV *)CvSTASH(thing), SOME_RECURSION);
 653     sv_size(aTHX_ st, (SV *)SvSTASH(thing), SOME_RECURSION);
 654     sv_size(aTHX_ st, (SV *)CvGV(thing), SOME_RECURSION);
 655     sv_size(aTHX_ st, (SV *)CvPADLIST(thing), SOME_RECURSION);
 656     sv_size(aTHX_ st, (SV *)CvOUTSIDE(thing), recurse);
 657     if (CvISXSUB(thing)) {
 658         sv_size(aTHX_ st, cv_const_sv((CV *)thing), recurse);
 659     } else {
 660         op_size(aTHX_ CvSTART(thing), st);
 661         op_size(aTHX_ CvROOT(thing), st);
 662     }
 663
 664     TAG;break;
 665   case SVt_PVGV: TAG;
 666     magic_size(thing, st);
 667     st->total_size += sizeof(XPVGV);
 668     if(isGV_with_GP(thing)) {
 669         st->total_size += GvNAMELEN(thing);
 670 #ifdef GvFILE
 671         /* Is there a file? */
 672         check_new_and_strlen(st, GvFILE(thing));
 673 #endif
 674         /* Is there something hanging off the glob? */
 675         if (check_new(st, GvGP(thing))) {
 676             st->total_size += sizeof(GP);
 677             sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_sv), recurse);
 678             sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_form), recurse);
 679             sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_av), recurse);
 680             sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_hv), recurse);
 681             sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_egv), recurse);
 682             sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_cv), recurse);
 683         }
 684     }
 685     TAG;break;
 686   case SVt_PVFM: TAG;
 687     st->total_size += sizeof(XPVFM);
 688     magic_size(thing, st);
 689     st->total_size += ((XPVIO *) SvANY(thing))->xpv_len;
 690     sv_size(aTHX_ st, (SV *)CvPADLIST(thing), SOME_RECURSION);
 691     sv_size(aTHX_ st, (SV *)CvOUTSIDE(thing), recurse);
 692
 693     if (st->go_yell && !st->fm_whine) {
 694       carp("Devel::Size: Calculated sizes for FMs are incomplete");
 695       st->fm_whine = 1;
 696     }
 697     TAG;break;
 698   case SVt_PVIO: TAG;
 699     st->total_size += sizeof(XPVIO);
 700     magic_size(thing, st);
 701     if (check_new(st, (SvPVX_const(thing)))) {
 702       st->total_size += ((XPVIO *) SvANY(thing))->xpv_cur;
 703     }
 704     /* Some embedded char pointers */
 705     check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_top_name);
 706     check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_fmt_name);
 707     check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_bottom_name);
 708     /* Throw the GVs on the list to be walked if they're not-null */
 709     sv_size(aTHX_ st, (SV *)((XPVIO *) SvANY(thing))->xio_top_gv, recurse);
 710     sv_size(aTHX_ st, (SV *)((XPVIO *) SvANY(thing))->xio_bottom_gv, recurse);
 711     sv_size(aTHX_ st, (SV *)((XPVIO *) SvANY(thing))->xio_fmt_gv, recurse);
 712
 713     /* Only go trotting through the IO structures if they're really
 714        trottable. If USE_PERLIO is defined we can do this. If
 715        not... we can't, so we don't even try */
 716 #ifdef USE_PERLIO
 717     /* Dig into xio_ifp and xio_ofp here */
 718     warn("Devel::Size: Can't size up perlio layers yet\n");
 719 #endif
 720     TAG;break;
 721   default:
 722     warn("Devel::Size: Unknown variable type: %d encountered\n", SvTYPE(thing) );
 723   }
 724   return TRUE;
 725 }
 726
 727 static struct state *
 728 new_state(pTHX)
 729 {
 730     SV *warn_flag;
 731     struct state *st;
 732     Newxz(st, 1, struct state);
 733     st->go_yell = TRUE;
 734     if (NULL != (warn_flag = perl_get_sv("Devel::Size::warn", FALSE))) {
 735         st->dangle_whine = st->go_yell = SvIV(warn_flag) ? TRUE : FALSE;
 736     }
 737     if (NULL != (warn_flag = perl_get_sv("Devel::Size::dangle", FALSE))) {
 738         st->dangle_whine = SvIV(warn_flag) ? TRUE : FALSE;
 739     }
 740     check_new(st, &PL_sv_undef);
 741     check_new(st, &PL_sv_no);
 742     check_new(st, &PL_sv_yes);
 743     return st;
 744 }
 745
 746 MODULE = Devel::Size        PACKAGE = Devel::Size
 747
 748 PROTOTYPES: DISABLE
 749
 750 UV
 751 size(orig_thing)
 752      SV *orig_thing
 753 ALIAS:
 754     total_size = TOTAL_SIZE_RECURSION
 755 CODE:
 756 {
 757   SV *thing = orig_thing;
 758   struct state *st = new_state(aTHX);
 759
 760   /* If they passed us a reference then dereference it. This is the
 761      only way we can check the sizes of arrays and hashes */
 762   if (SvROK(thing)) {
 763     thing = SvRV(thing);
 764   }
 765
 766   sv_size(aTHX_ st, thing, ix);
 767   RETVAL = st->total_size;
 768   free_state(st);
 769 }
 770 OUTPUT:
 771   RETVAL