Size.xs

   1 /* -*- mode: C -*- */
   2
   3 #undef NDEBUG /* XXX */
   4 #include <assert.h>
   5
   6 #define PERL_NO_GET_CONTEXT
   7
   8 #include "EXTERN.h"
   9 #include "perl.h"
  10 #include "XSUB.h"
  11 #include "ppport.h"
  12
  13 /* Not yet in ppport.h */
  14 #ifndef CvISXSUB
  15 #  define CvISXSUB(cv)  (CvXSUB(cv) ? TRUE : FALSE)
  16 #endif
  17 #ifndef SvRV_const
  18 #  define SvRV_const(rv) SvRV(rv)
  19 #endif
  20 #ifndef SvOOK_offset
  21 #  define SvOOK_offset(sv, len) STMT_START { len = SvIVX(sv); } STMT_END
  22 #endif
  23 #ifndef SvIsCOW
  24 #  define SvIsCOW(sv)           ((SvFLAGS(sv) & (SVf_FAKE | SVf_READONLY)) == \
  25                                     (SVf_FAKE | SVf_READONLY))
  26 #endif
  27 #ifndef SvIsCOW_shared_hash
  28 #  define SvIsCOW_shared_hash(sv)   (SvIsCOW(sv) && SvLEN(sv) == 0)
  29 #endif
  30 #ifndef SvSHARED_HEK_FROM_PV
  31 #  define SvSHARED_HEK_FROM_PV(pvx) \
  32         ((struct hek*)(pvx - STRUCT_OFFSET(struct hek, hek_key)))
  33 #endif
  34
  35 #if PERL_VERSION < 6
  36 #  define PL_opargs opargs
  37 #  define PL_op_name op_name
  38 #endif
  39
  40 #ifdef _MSC_VER
  41 /* "structured exception" handling is a Microsoft extension to C and C++.
  42    It's *not* C++ exception handling - C++ exception handling can't capture
  43    SEGVs and suchlike, whereas this can. There's no known analagous
  44     functionality on other platforms.  */
  45 #  include <excpt.h>
  46 #  define TRY_TO_CATCH_SEGV __try
  47 #  define CAUGHT_EXCEPTION __except(EXCEPTION_EXECUTE_HANDLER)
  48 #else
  49 #  define TRY_TO_CATCH_SEGV if(1)
  50 #  define CAUGHT_EXCEPTION else
  51 #endif
  52
  53 #ifdef __GNUC__
  54 # define __attribute__(x)
  55 #endif
  56
  57 #if 0 && defined(DEBUGGING)
  58 #define dbg_printf(x) printf x
  59 #else
  60 #define dbg_printf(x)
  61 #endif
  62
  63 #define TAG /* printf( "# %s(%d)\n", __FILE__, __LINE__ ) */
  64 #define carp puts
  65
  66 /* The idea is to have a tree structure to store 1 bit per possible pointer
  67    address. The lowest 16 bits are stored in a block of 8092 bytes.
  68    The blocks are in a 256-way tree, indexed by the reset of the pointer.
  69    This can cope with 32 and 64 bit pointers, and any address space layout,
  70    without excessive memory needs. The assumption is that your CPU cache
  71    works :-) (And that we're not going to bust it)  */
  72
  73 #define BYTE_BITS    3
  74 #define LEAF_BITS   (16 - BYTE_BITS)
  75 #define LEAF_MASK   0x1FFF
  76
  77 typedef struct npath_node_st npath_node_t;
  78 struct npath_node_st {
  79     npath_node_t *prev;
  80     const void *id;
  81     U8 type;
  82     U8 flags;
  83     UV seqn;
  84     U16 depth;
  85 };
  86
  87 struct state {
  88     UV total_size;
  89     bool regex_whine;
  90     bool fm_whine;
  91     bool dangle_whine;
  92     bool go_yell;
  93     /* My hunch (not measured) is that for most architectures pointers will
  94        start with 0 bits, hence the start of this array will be hot, and the
  95        end unused. So put the flags next to the hot end.  */
  96     void *tracking[256];
  97     /* callback hooks and data */
  98     int (*add_attr_cb)(struct state *st, npath_node_t *npath_node, UV attr_type, const char *name, UV value);
  99     void (*free_state_cb)(struct state *st);
 100     UV seqn;
 101     void *state_cb_data; /* free'd by free_state() after free_state_cb() call */
 102 };
 103
 104 #define ADD_SIZE(st, leafname, bytes) (NPathAddSizeCb(st, leafname, bytes) (st)->total_size += (bytes))
 105
 106 #define PATH_TRACKING
 107 #ifdef PATH_TRACKING
 108
 109 #define NPathAddSizeCb(st, name, bytes) (st->add_attr_cb && st->add_attr_cb(st, NP-1, 0, (name), (bytes))),
 110 #define pPATH npath_node_t *NPathArg
 111
 112 /* A subtle point here is that each dNPathSetNode leaves NP pointing to
 113  * the next unused slot (though with prev already filled in)
 114  * whereas NPathLink leaves NP unchanged, it just fills in the slot NP points
 115  * to and passes that NP value to the function being called.
 116  */
 117 #define dNPathNodes(nodes, prev_np) \
 118             npath_node_t name_path_nodes[nodes+1]; /* +1 for NPathLink */ \
 119             npath_node_t *NP = &name_path_nodes[0]; \
 120             NP->seqn = 0; \
 121             NP->type = 0; \
 122             NP->id = "?0?"; /* DEBUG */ \
 123             NP->prev = prev_np
 124 #define dNPathSetNode(nodeid, nodetype) \
 125             NP->id = nodeid; \
 126             NP->type = nodetype; \
 127             if(0)fprintf(stderr,"dNPathSetNode (%p <-) %p <- [%d %s]\n", NP->prev, NP, nodetype,(char*)nodeid);\
 128             NP++; \
 129             NP->id="?+?"; /* DEBUG */ \
 130             NP->seqn = 0; \
 131             NP->prev = (NP-1)
 132
 133 /* dNPathUseParent points NP directly the the parents' name_path_nodes array
 134  * So the function can only safely call ADD_*() but not NPathLink, unless the
 135  * caller has spare nodes in its name_path_nodes.
 136  */
 137 #define dNPathUseParent(prev_np) npath_node_t *NP = (((prev_np+1)->prev = prev_np), prev_np+1)
 138
 139 #define NPtype_NAME     0x01
 140 #define NPtype_LINK     0x02
 141 #define NPtype_SV       0x03
 142 #define NPtype_MAGIC    0x04
 143 #define NPtype_OP       0x05
 144
 145 #define NPathLink(nodeid, nodetype)   ((NP->id = nodeid), (NP->type = nodetype), (NP->seqn = 0), NP)
 146 #define NPathOpLink  (NPathArg)
 147 #define ADD_ATTR(st, attr_type, attr_name, attr_value) (st->add_attr_cb && st->add_attr_cb(st, NP-1, attr_type, attr_name, attr_value))
 148
 149 #else
 150
 151 #define NPathAddSizeCb(st, name, bytes)
 152 #define pPATH void *npath_dummy /* XXX ideally remove */
 153 #define dNPathNodes(nodes, prev_np)  dNOOP
 154 #define NPathLink(nodeid, nodetype)  NULL
 155 #define NPathOpLink NULL
 156 #define ADD_ATTR(st, attr_type, attr_name, attr_value) NOOP
 157
 158 #endif /* PATH_TRACKING */
 159
 160
 161
 162
 163 #ifdef PATH_TRACKING
 164
 165 static const char *svtypenames[SVt_LAST] = {
 166 #if PERL_VERSION < 9
 167   "NULL", "IV", "NV", "RV", "PV", "PVIV", "PVNV", "PVMG", "PVBM", "PVLV", "PVAV", "PVHV", "PVCV", "PVGV", "PVFM", "PVIO",
 168 #elif PERL_VERSION == 10 && PERL_SUBVERSION == 0
 169   "NULL", "BIND", "IV", "NV", "RV", "PV", "PVIV", "PVNV", "PVMG", "PVGV", "PVLV", "PVAV", "PVHV", "PVCV", "PVFM", "PVIO",
 170 #elif PERL_VERSION == 10 && PERL_SUBVERSION == 1
 171   "NULL", "BIND", "IV", "NV", "RV", "PV", "PVIV", "PVNV", "PVMG", "PVGV", "PVLV", "PVAV", "PVHV", "PVCV", "PVFM", "PVIO",
 172 #elif PERL_VERSION < 13
 173   "NULL", "BIND", "IV", "NV", "PV", "PVIV", "PVNV", "PVMG", "REGEXP", "PVGV", "PVLV", "PVAV", "PVHV", "PVCV", "PVFM", "PVIO",
 174 #else
 175   "NULL", "BIND", "IV", "NV", "PV", "PVIV", "PVNV", "PVMG", "REGEXP", "PVGV", "PVLV", "PVAV", "PVHV", "PVCV", "PVFM", "PVIO",
 176 #endif
 177 };
 178
 179 int
 180 print_node_name(npath_node_t *npath_node)
 181 {
 182     char buf[1024]; /* XXX */
 183
 184     switch (npath_node->type) {
 185     case NPtype_SV: { /* id is pointer to the SV sv_size was called on */
 186         const SV *sv = (SV*)npath_node->id;
 187         int type = SvTYPE(sv);
 188         char *typename = (type == SVt_IV && SvROK(sv)) ? "RV" : svtypenames[type];
 189         fprintf(stderr, "SV(%s)", typename);
 190         switch(type) {  /* add some useful details */
 191         case SVt_PVAV: fprintf(stderr, " fill=%d/%ld", av_len((AV*)sv), AvMAX((AV*)sv)); break;
 192         case SVt_PVHV: fprintf(stderr, " fill=%ld/%ld", HvFILL((HV*)sv), HvMAX((HV*)sv)); break;
 193         }
 194         break;
 195     }
 196     case NPtype_OP: { /* id is pointer to the OP op_size was called on */
 197         const OP *op = (OP*)npath_node->id;
 198         fprintf(stderr, "OP(%s)", OP_NAME(op));
 199         break;
 200     }
 201     case NPtype_MAGIC: { /* id is pointer to the MAGIC struct */
 202         MAGIC *magic_pointer = (MAGIC*)npath_node->id;
 203         /* XXX it would be nice if we could reuse mg_names.c [sigh] */
 204         fprintf(stderr, "MAGIC(%c)", magic_pointer->mg_type ? magic_pointer->mg_type : '0');
 205         break;
 206     }
 207     case NPtype_LINK:
 208         fprintf(stderr, "%s->", npath_node->id);
 209         break;
 210     case NPtype_NAME:
 211         fprintf(stderr, "%s", npath_node->id);
 212         break;
 213     default:    /* assume id is a string pointer */
 214         fprintf(stderr, "UNKNOWN(%d,%p)", npath_node->type, npath_node->id);
 215         break;
 216     }
 217     return 0;
 218 }
 219
 220 void
 221 print_indent(int depth) {
 222     while (depth-- > 0)
 223         fprintf(stderr, ":   ");
 224 }
 225
 226 int
 227 print_formatted_node(struct state *st, npath_node_t *npath_node) {
 228     print_indent(npath_node->depth);
 229     print_node_name(npath_node);
 230     fprintf(stderr, "\t\t[#%ld @%u] ", npath_node->seqn, npath_node->depth);
 231     fprintf(stderr, "\n");
 232     return 0;
 233 }
 234
 235 void
 236 walk_new_nodes(struct state *st, npath_node_t *npath_node, int (*cb)(struct state *st, npath_node_t *npath_node))
 237 {
 238     if (npath_node->seqn) /* node already output */
 239         return;
 240
 241     if (npath_node->prev) {
 242         walk_new_nodes(st, npath_node->prev, cb); /* recurse */
 243         npath_node->depth = npath_node->prev->depth + 1;
 244     }
 245     else npath_node->depth = 0;
 246     npath_node->seqn = ++st->seqn;
 247
 248     if (cb)
 249         cb(st, npath_node);
 250
 251     return;
 252 }
 253
 254 int
 255 dump_path(struct state *st, npath_node_t *npath_node, UV attr_type, const char *attr_name, UV attr_value)
 256 {
 257     if (!attr_type && !attr_value)
 258         return 0;
 259     walk_new_nodes(st, npath_node, print_formatted_node);
 260     print_indent(npath_node->depth+1);
 261     if (attr_type) {
 262         fprintf(stderr, "~NAMED('%s') %lu", attr_name, attr_value);
 263     }
 264     else {
 265         fprintf(stderr, "+%ld ", attr_value);
 266         fprintf(stderr, "%s ", attr_name);
 267         fprintf(stderr, "=%ld ", attr_value+st->total_size);
 268     }
 269     fprintf(stderr, "\n");
 270     return 0;
 271 }
 272
 273 #endif /* PATH_TRACKING */
 274
 275
 276 /*
 277     Checks to see if thing is in the bitstring.
 278     Returns true or false, and
 279     notes thing in the segmented bitstring.
 280  */
 281 static bool
 282 check_new(struct state *st, const void *const p) {
 283     unsigned int bits = 8 * sizeof(void*);
 284     const size_t raw_p = PTR2nat(p);
 285     /* This effectively rotates the value right by the number of low always-0
 286        bits in an aligned pointer. The assmption is that most (if not all)
 287        pointers are aligned, and these will be in the same chain of nodes
 288        (and hence hot in the cache) but we can still deal with any unaligned
 289        pointers.  */
 290     const size_t cooked_p
 291         = (raw_p >> ALIGN_BITS) | (raw_p << (bits - ALIGN_BITS));
 292     const U8 this_bit = 1 << (cooked_p & 0x7);
 293     U8 **leaf_p;
 294     U8 *leaf;
 295     unsigned int i;
 296     void **tv_p = (void **) (st->tracking);
 297
 298     if (NULL == p) return FALSE;
 299     TRY_TO_CATCH_SEGV {
 300         const char c = *(const char *)p;
 301     }
 302     CAUGHT_EXCEPTION {
 303         if (st->dangle_whine)
 304             warn( "Devel::Size: Encountered invalid pointer: %p\n", p );
 305         return FALSE;
 306     }
 307     TAG;
 308
 309     bits -= 8;
 310     /* bits now 24 (32 bit pointers) or 56 (64 bit pointers) */
 311
 312     /* First level is always present.  */
 313     do {
 314         i = (unsigned int)((cooked_p >> bits) & 0xFF);
 315         if (!tv_p[i])
 316             Newxz(tv_p[i], 256, void *);
 317         tv_p = (void **)(tv_p[i]);
 318         bits -= 8;
 319     } while (bits > LEAF_BITS + BYTE_BITS);
 320     /* bits now 16 always */
 321 #if !defined(MULTIPLICITY) || PERL_VERSION > 8 || (PERL_VERSION == 8 && PERL_SUBVERSION > 8)
 322     /* 5.8.8 and early have an assert() macro that uses Perl_croak, hence needs
 323        a my_perl under multiplicity  */
 324     assert(bits == 16);
 325 #endif
 326     leaf_p = (U8 **)tv_p;
 327     i = (unsigned int)((cooked_p >> bits) & 0xFF);
 328     if (!leaf_p[i])
 329         Newxz(leaf_p[i], 1 << LEAF_BITS, U8);
 330     leaf = leaf_p[i];
 331
 332     TAG;
 333
 334     i = (unsigned int)((cooked_p >> BYTE_BITS) & LEAF_MASK);
 335
 336     if(leaf[i] & this_bit)
 337         return FALSE;
 338
 339     leaf[i] |= this_bit;
 340     return TRUE;
 341 }
 342
 343 static void
 344 free_tracking_at(void **tv, int level)
 345 {
 346     int i = 255;
 347
 348     if (--level) {
 349         /* Nodes */
 350         do {
 351             if (tv[i]) {
 352                 free_tracking_at((void **) tv[i], level);
 353                 Safefree(tv[i]);
 354             }
 355         } while (i--);
 356     } else {
 357         /* Leaves */
 358         do {
 359             if (tv[i])
 360                 Safefree(tv[i]);
 361         } while (i--);
 362     }
 363 }
 364
 365 static void
 366 free_state(struct state *st)
 367 {
 368     const int top_level = (sizeof(void *) * 8 - LEAF_BITS - BYTE_BITS) / 8;
 369     if (st->free_state_cb)
 370         st->free_state_cb(st);
 371     if (st->state_cb_data)
 372         Safefree(st->state_cb_data);
 373     free_tracking_at((void **)st->tracking, top_level);
 374     Safefree(st);
 375 }
 376
 377 /* For now, this is somewhat a compatibility bodge until the plan comes
 378    together for fine grained recursion control. total_size() would recurse into
 379    hash and array members, whereas sv_size() would not. However, sv_size() is
 380    called with CvSTASH() of a CV, which means that if it (also) starts to
 381    recurse fully, then the size of any CV now becomes the size of the entire
 382    symbol table reachable from it, and potentially the entire symbol table, if
 383    any subroutine makes a reference to a global (such as %SIG). The historical
 384    implementation of total_size() didn't report "everything", and changing the
 385    only available size to "everything" doesn't feel at all useful.  */
 386
 387 #define NO_RECURSION 0
 388 #define SOME_RECURSION 1
 389 #define TOTAL_SIZE_RECURSION 2
 390
 391 static void sv_size(pTHX_ struct state *, pPATH, const SV *const, const int recurse);
 392
 393 typedef enum {
 394     OPc_NULL,   /* 0 */
 395     OPc_BASEOP, /* 1 */
 396     OPc_UNOP,   /* 2 */
 397     OPc_BINOP,  /* 3 */
 398     OPc_LOGOP,  /* 4 */
 399     OPc_LISTOP, /* 5 */
 400     OPc_PMOP,   /* 6 */
 401     OPc_SVOP,   /* 7 */
 402     OPc_PADOP,  /* 8 */
 403     OPc_PVOP,   /* 9 */
 404     OPc_LOOP,   /* 10 */
 405     OPc_COP /* 11 */
 406 #ifdef OA_CONDOP
 407     , OPc_CONDOP /* 12 */
 408 #endif
 409 #ifdef OA_GVOP
 410     , OPc_GVOP /* 13 */
 411 #endif
 412
 413 } opclass;
 414
 415 static opclass
 416 cc_opclass(const OP * const o)
 417 {
 418     if (!o)
 419     return OPc_NULL;
 420     TRY_TO_CATCH_SEGV {
 421         if (o->op_type == 0)
 422         return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
 423
 424         if (o->op_type == OP_SASSIGN)
 425         return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPc_UNOP : OPc_BINOP);
 426
 427     #ifdef USE_ITHREADS
 428         if (o->op_type == OP_GV || o->op_type == OP_GVSV || o->op_type == OP_AELEMFAST)
 429         return OPc_PADOP;
 430     #endif
 431
 432         if ((o->op_type == OP_TRANS)) {
 433           return OPc_BASEOP;
 434         }
 435
 436         switch (PL_opargs[o->op_type] & OA_CLASS_MASK) {
 437         case OA_BASEOP: TAG;
 438         return OPc_BASEOP;
 439
 440         case OA_UNOP: TAG;
 441         return OPc_UNOP;
 442
 443         case OA_BINOP: TAG;
 444         return OPc_BINOP;
 445
 446         case OA_LOGOP: TAG;
 447         return OPc_LOGOP;
 448
 449         case OA_LISTOP: TAG;
 450         return OPc_LISTOP;
 451
 452         case OA_PMOP: TAG;
 453         return OPc_PMOP;
 454
 455         case OA_SVOP: TAG;
 456         return OPc_SVOP;
 457
 458 #ifdef OA_PADOP
 459         case OA_PADOP: TAG;
 460         return OPc_PADOP;
 461 #endif
 462
 463 #ifdef OA_GVOP
 464         case OA_GVOP: TAG;
 465         return OPc_GVOP;
 466 #endif
 467
 468 #ifdef OA_PVOP_OR_SVOP
 469         case OA_PVOP_OR_SVOP: TAG;
 470             /*
 471              * Character translations (tr///) are usually a PVOP, keeping a
 472              * pointer to a table of shorts used to look up translations.
 473              * Under utf8, however, a simple table isn't practical; instead,
 474              * the OP is an SVOP, and the SV is a reference to a swash
 475              * (i.e., an RV pointing to an HV).
 476              */
 477         return (o->op_private & (OPpTRANS_TO_UTF|OPpTRANS_FROM_UTF))
 478             ? OPc_SVOP : OPc_PVOP;
 479 #endif
 480
 481         case OA_LOOP: TAG;
 482         return OPc_LOOP;
 483
 484         case OA_COP: TAG;
 485         return OPc_COP;
 486
 487         case OA_BASEOP_OR_UNOP: TAG;
 488         /*
 489          * UNI(OP_foo) in toke.c returns token UNI or FUNC1 depending on
 490          * whether parens were seen. perly.y uses OPf_SPECIAL to
 491          * signal whether a BASEOP had empty parens or none.
 492          * Some other UNOPs are created later, though, so the best
 493          * test is OPf_KIDS, which is set in newUNOP.
 494          */
 495         return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
 496
 497         case OA_FILESTATOP: TAG;
 498         /*
 499          * The file stat OPs are created via UNI(OP_foo) in toke.c but use
 500          * the OPf_REF flag to distinguish between OP types instead of the
 501          * usual OPf_SPECIAL flag. As usual, if OPf_KIDS is set, then we
 502          * return OPc_UNOP so that walkoptree can find our children. If
 503          * OPf_KIDS is not set then we check OPf_REF. Without OPf_REF set
 504          * (no argument to the operator) it's an OP; with OPf_REF set it's
 505          * an SVOP (and op_sv is the GV for the filehandle argument).
 506          */
 507         return ((o->op_flags & OPf_KIDS) ? OPc_UNOP :
 508     #ifdef USE_ITHREADS
 509             (o->op_flags & OPf_REF) ? OPc_PADOP : OPc_BASEOP);
 510     #else
 511             (o->op_flags & OPf_REF) ? OPc_SVOP : OPc_BASEOP);
 512     #endif
 513         case OA_LOOPEXOP: TAG;
 514         /*
 515          * next, last, redo, dump and goto use OPf_SPECIAL to indicate that a
 516          * label was omitted (in which case it's a BASEOP) or else a term was
 517          * seen. In this last case, all except goto are definitely PVOP but
 518          * goto is either a PVOP (with an ordinary constant label), an UNOP
 519          * with OPf_STACKED (with a non-constant non-sub) or an UNOP for
 520          * OP_REFGEN (with goto &sub) in which case OPf_STACKED also seems to
 521          * get set.
 522          */
 523         if (o->op_flags & OPf_STACKED)
 524             return OPc_UNOP;
 525         else if (o->op_flags & OPf_SPECIAL)
 526             return OPc_BASEOP;
 527         else
 528             return OPc_PVOP;
 529
 530 #ifdef OA_CONDOP
 531         case OA_CONDOP: TAG;
 532             return OPc_CONDOP;
 533 #endif
 534         }
 535         warn("Devel::Size: Can't determine class of operator %s, assuming BASEOP\n",
 536          PL_op_name[o->op_type]);
 537     }
 538     CAUGHT_EXCEPTION { }
 539     return OPc_BASEOP;
 540 }
 541
 542 /* Figure out how much magic is attached to the SV and return the
 543    size */
 544 static void
 545 magic_size(pTHX_ const SV * const thing, struct state *st, pPATH) {
 546   dNPathNodes(1, NPathArg);
 547   MAGIC *magic_pointer = SvMAGIC(thing);
 548
 549   /* Have we seen the magic pointer?  (NULL has always been seen before)  */
 550   while (check_new(st, magic_pointer)) {
 551
 552     dNPathSetNode(magic_pointer, NPtype_MAGIC);
 553
 554     ADD_SIZE(st, "mg", sizeof(MAGIC));
 555     /* magic vtables aren't freed when magic is freed, so don't count them.
 556        (They are static structures. Anything that assumes otherwise is buggy.)
 557     */
 558
 559
 560     TRY_TO_CATCH_SEGV {
 561         sv_size(aTHX_ st, NPathLink("mg_obj", NPtype_LINK), magic_pointer->mg_obj, TOTAL_SIZE_RECURSION);
 562         if (magic_pointer->mg_len == HEf_SVKEY) {
 563             sv_size(aTHX_ st, NPathLink("mg_ptr", NPtype_LINK), (SV *)magic_pointer->mg_ptr, TOTAL_SIZE_RECURSION);
 564         }
 565 #if defined(PERL_MAGIC_utf8) && defined (PERL_MAGIC_UTF8_CACHESIZE)
 566         else if (magic_pointer->mg_type == PERL_MAGIC_utf8) {
 567             if (check_new(st, magic_pointer->mg_ptr)) {
 568                 ADD_SIZE(st, "PERL_MAGIC_utf8", PERL_MAGIC_UTF8_CACHESIZE * 2 * sizeof(STRLEN));
 569             }
 570         }
 571 #endif
 572         else if (magic_pointer->mg_len > 0) {
 573             if (check_new(st, magic_pointer->mg_ptr)) {
 574                 ADD_SIZE(st, "mg_len", magic_pointer->mg_len);
 575             }
 576         }
 577
 578         /* Get the next in the chain */
 579         magic_pointer = magic_pointer->mg_moremagic;
 580     }
 581     CAUGHT_EXCEPTION {
 582         if (st->dangle_whine)
 583             warn( "Devel::Size: Encountered bad magic at: %p\n", magic_pointer );
 584     }
 585   }
 586 }
 587
 588 static void
 589 check_new_and_strlen(struct state *st, const char *const p, pPATH) {
 590     dNPathNodes(1, NPathArg->prev);
 591     if(check_new(st, p)) {
 592         dNPathSetNode(NPathArg->id, NPtype_NAME);
 593         ADD_SIZE(st, NPathArg->id, 1 + strlen(p));
 594     }
 595 }
 596
 597 static void
 598 regex_size(const REGEXP * const baseregex, struct state *st, pPATH) {
 599     dNPathNodes(1, NPathArg);
 600     if(!check_new(st, baseregex))
 601         return;
 602   dNPathSetNode("regex_size", NPtype_NAME);
 603   ADD_SIZE(st, "REGEXP", sizeof(REGEXP));
 604 #if (PERL_VERSION < 11)
 605   /* Note the size of the paren offset thing */
 606   ADD_SIZE(st, "nparens", sizeof(I32) * baseregex->nparens * 2);
 607   ADD_SIZE(st, "precomp", strlen(baseregex->precomp));
 608 #else
 609   ADD_SIZE(st, "regexp", sizeof(struct regexp));
 610   ADD_SIZE(st, "nparens", sizeof(I32) * SvANY(baseregex)->nparens * 2);
 611   /*ADD_SIZE(st, strlen(SvANY(baseregex)->subbeg));*/
 612 #endif
 613   if (st->go_yell && !st->regex_whine) {
 614     carp("Devel::Size: Calculated sizes for compiled regexes are incompatible, and probably always will be");
 615     st->regex_whine = 1;
 616   }
 617 }
 618
 619 static void
 620 op_size(pTHX_ const OP * const baseop, struct state *st, pPATH)
 621 {
 622     /* op_size recurses to follow the chain of opcodes.
 623      * For the 'path' we don't want the chain to be 'nested' in the path so we
 624      * use ->prev in dNPathNodes.
 625      */
 626     dNPathUseParent(NPathArg);
 627
 628     TRY_TO_CATCH_SEGV {
 629         TAG;
 630         if(!check_new(st, baseop))
 631             return;
 632         TAG;
 633         op_size(aTHX_ baseop->op_next, st, NPathOpLink);
 634         TAG;
 635         switch (cc_opclass(baseop)) {
 636         case OPc_BASEOP: TAG;
 637             ADD_SIZE(st, "op", sizeof(struct op));
 638             TAG;break;
 639         case OPc_UNOP: TAG;
 640             ADD_SIZE(st, "unop", sizeof(struct unop));
 641             op_size(aTHX_ ((UNOP *)baseop)->op_first, st, NPathOpLink);
 642             TAG;break;
 643         case OPc_BINOP: TAG;
 644             ADD_SIZE(st, "binop", sizeof(struct binop));
 645             op_size(aTHX_ ((BINOP *)baseop)->op_first, st, NPathOpLink);
 646             op_size(aTHX_ ((BINOP *)baseop)->op_last, st, NPathOpLink);
 647             TAG;break;
 648         case OPc_LOGOP: TAG;
 649             ADD_SIZE(st, "logop", sizeof(struct logop));
 650             op_size(aTHX_ ((BINOP *)baseop)->op_first, st, NPathOpLink);
 651             op_size(aTHX_ ((LOGOP *)baseop)->op_other, st, NPathOpLink);
 652             TAG;break;
 653 #ifdef OA_CONDOP
 654         case OPc_CONDOP: TAG;
 655             ADD_SIZE(st, "condop", sizeof(struct condop));
 656             op_size(aTHX_ ((BINOP *)baseop)->op_first, st, NPathOpLink);
 657             op_size(aTHX_ ((CONDOP *)baseop)->op_true, st, NPathOpLink);
 658             op_size(aTHX_ ((CONDOP *)baseop)->op_false, st, NPathOpLink);
 659             TAG;break;
 660 #endif
 661         case OPc_LISTOP: TAG;
 662             ADD_SIZE(st, "listop", sizeof(struct listop));
 663             op_size(aTHX_ ((LISTOP *)baseop)->op_first, st, NPathOpLink);
 664             op_size(aTHX_ ((LISTOP *)baseop)->op_last, st, NPathOpLink);
 665             TAG;break;
 666         case OPc_PMOP: TAG;
 667             ADD_SIZE(st, "pmop", sizeof(struct pmop));
 668             op_size(aTHX_ ((PMOP *)baseop)->op_first, st, NPathOpLink);
 669             op_size(aTHX_ ((PMOP *)baseop)->op_last, st, NPathOpLink);
 670 #if PERL_VERSION < 9 || (PERL_VERSION == 9 && PERL_SUBVERSION < 5)
 671             op_size(aTHX_ ((PMOP *)baseop)->op_pmreplroot, st, NPathOpLink);
 672             op_size(aTHX_ ((PMOP *)baseop)->op_pmreplstart, st, NPathOpLink);
 673 #endif
 674             /* This is defined away in perl 5.8.x, but it is in there for
 675                5.6.x */
 676 #ifdef PM_GETRE
 677             regex_size(PM_GETRE((PMOP *)baseop), st, NPathLink("PM_GETRE", NPtype_LINK));
 678 #else
 679             regex_size(((PMOP *)baseop)->op_pmregexp, st, NPathLink("op_pmregexp", NPtype_LINK));
 680 #endif
 681             TAG;break;
 682         case OPc_SVOP: TAG;
 683             ADD_SIZE(st, "svop", sizeof(struct svop));
 684             if (!(baseop->op_type == OP_AELEMFAST
 685                   && baseop->op_flags & OPf_SPECIAL)) {
 686                 /* not an OP_PADAV replacement */
 687                 sv_size(aTHX_ st, NPathLink("SVOP", NPtype_LINK), ((SVOP *)baseop)->op_sv, SOME_RECURSION);
 688             }
 689             TAG;break;
 690 #ifdef OA_PADOP
 691       case OPc_PADOP: TAG;
 692           ADD_SIZE(st, "padop", sizeof(struct padop));
 693           TAG;break;
 694 #endif
 695 #ifdef OA_GVOP
 696       case OPc_GVOP: TAG;
 697           ADD_SIZE(st, "gvop", sizeof(struct gvop));
 698           sv_size(aTHX_ st, NPathLink("GVOP", NPtype_LINK), ((GVOP *)baseop)->op_gv, SOME_RECURSION);
 699           TAG;break;
 700 #endif
 701         case OPc_PVOP: TAG;
 702             check_new_and_strlen(st, ((PVOP *)baseop)->op_pv, NPathLink("op_pv", NPtype_LINK));
 703             TAG;break;
 704         case OPc_LOOP: TAG;
 705             ADD_SIZE(st, "loop", sizeof(struct loop));
 706             op_size(aTHX_ ((LOOP *)baseop)->op_first, st, NPathOpLink);
 707             op_size(aTHX_ ((LOOP *)baseop)->op_last, st, NPathOpLink);
 708             op_size(aTHX_ ((LOOP *)baseop)->op_redoop, st, NPathOpLink);
 709             op_size(aTHX_ ((LOOP *)baseop)->op_nextop, st, NPathOpLink);
 710             op_size(aTHX_ ((LOOP *)baseop)->op_lastop, st, NPathOpLink);
 711             TAG;break;
 712         case OPc_COP: TAG;
 713         {
 714           COP *basecop;
 715           basecop = (COP *)baseop;
 716           ADD_SIZE(st, "cop", sizeof(struct cop));
 717
 718           /* Change 33656 by nicholas@mouse-mill on 2008/04/07 11:29:51
 719           Eliminate cop_label from struct cop by storing a label as the first
 720           entry in the hints hash. Most statements don't have labels, so this
 721           will save memory. Not sure how much.
 722           The check below will be incorrect fail on bleadperls
 723           before 5.11 @33656, but later than 5.10, producing slightly too
 724           small memory sizes on these Perls. */
 725 #if (PERL_VERSION < 11)
 726           check_new_and_strlen(st, basecop->cop_label, NPathLink("cop_label", NPtype_LINK));
 727 #endif
 728 #ifdef USE_ITHREADS
 729           check_new_and_strlen(st, basecop->cop_file, NPathLink("cop_file", NPtype_LINK));
 730           check_new_and_strlen(st, basecop->cop_stashpv, NPathLink("cop_stashpv", NPtype_LINK));
 731 #else
 732           sv_size(aTHX_ st, NPathLink("cop_stash", NPtype_LINK), (SV *)basecop->cop_stash, SOME_RECURSION);
 733           sv_size(aTHX_ st, NPathLink("cop_filegv", NPtype_LINK), (SV *)basecop->cop_filegv, SOME_RECURSION);
 734 #endif
 735
 736         }
 737         TAG;break;
 738       default:
 739         TAG;break;
 740       }
 741   }
 742   CAUGHT_EXCEPTION {
 743       if (st->dangle_whine)
 744           warn( "Devel::Size: Encountered dangling pointer in opcode at: %p\n", baseop );
 745   }
 746 }
 747
 748 static void
 749 hek_size(pTHX_ struct state *st, HEK *hek, U32 shared, pPATH)
 750 {
 751     dNPathUseParent(NPathArg);
 752     /* Hash keys can be shared. Have we seen this before? */
 753     if (!check_new(st, hek))
 754         return;
 755     ADD_SIZE(st, "hek_len", HEK_BASESIZE + hek->hek_len
 756 #if PERL_VERSION < 8
 757         + 1 /* No hash key flags prior to 5.8.0  */
 758 #else
 759         + 2
 760 #endif
 761         );
 762     if (shared) {
 763 #if PERL_VERSION < 10
 764         ADD_SIZE(st, "he", sizeof(struct he));
 765 #else
 766         ADD_SIZE(st, "shared_he", STRUCT_OFFSET(struct shared_he, shared_he_hek));
 767 #endif
 768     }
 769 }
 770
 771
 772 #if PERL_VERSION < 8 || PERL_SUBVERSION < 9
 773 #  define SVt_LAST 16
 774 #endif
 775
 776 #ifdef PURIFY
 777 #  define MAYBE_PURIFY(normal, pure) (pure)
 778 #  define MAYBE_OFFSET(struct_name, member) 0
 779 #else
 780 #  define MAYBE_PURIFY(normal, pure) (normal)
 781 #  define MAYBE_OFFSET(struct_name, member) STRUCT_OFFSET(struct_name, member)
 782 #endif
 783
 784 const U8 body_sizes[SVt_LAST] = {
 785 #if PERL_VERSION < 9
 786      0,                                                       /* SVt_NULL */
 787      MAYBE_PURIFY(sizeof(IV), sizeof(XPVIV)),                 /* SVt_IV */
 788      MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)),                 /* SVt_NV */
 789      sizeof(XRV),                                             /* SVt_RV */
 790      sizeof(XPV),                                             /* SVt_PV */
 791      sizeof(XPVIV),                                           /* SVt_PVIV */
 792      sizeof(XPVNV),                                           /* SVt_PVNV */
 793      sizeof(XPVMG),                                           /* SVt_PVMG */
 794      sizeof(XPVBM),                                           /* SVt_PVBM */
 795      sizeof(XPVLV),                                           /* SVt_PVLV */
 796      sizeof(XPVAV),                                           /* SVt_PVAV */
 797      sizeof(XPVHV),                                           /* SVt_PVHV */
 798      sizeof(XPVCV),                                           /* SVt_PVCV */
 799      sizeof(XPVGV),                                           /* SVt_PVGV */
 800      sizeof(XPVFM),                                           /* SVt_PVFM */
 801      sizeof(XPVIO)                                            /* SVt_PVIO */
 802 #elif PERL_VERSION == 10 && PERL_SUBVERSION == 0
 803      0,                                                       /* SVt_NULL */
 804      0,                                                       /* SVt_BIND */
 805      0,                                                       /* SVt_IV */
 806      MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)),                 /* SVt_NV */
 807      0,                                                       /* SVt_RV */
 808      MAYBE_PURIFY(sizeof(xpv_allocated), sizeof(XPV)),        /* SVt_PV */
 809      MAYBE_PURIFY(sizeof(xpviv_allocated), sizeof(XPVIV)),/* SVt_PVIV */
 810      sizeof(XPVNV),                                           /* SVt_PVNV */
 811      sizeof(XPVMG),                                           /* SVt_PVMG */
 812      sizeof(XPVGV),                                           /* SVt_PVGV */
 813      sizeof(XPVLV),                                           /* SVt_PVLV */
 814      MAYBE_PURIFY(sizeof(xpvav_allocated), sizeof(XPVAV)),/* SVt_PVAV */
 815      MAYBE_PURIFY(sizeof(xpvhv_allocated), sizeof(XPVHV)),/* SVt_PVHV */
 816      MAYBE_PURIFY(sizeof(xpvcv_allocated), sizeof(XPVCV)),/* SVt_PVCV */
 817      MAYBE_PURIFY(sizeof(xpvfm_allocated), sizeof(XPVFM)),/* SVt_PVFM */
 818      sizeof(XPVIO),                                           /* SVt_PVIO */
 819 #elif PERL_VERSION == 10 && PERL_SUBVERSION == 1
 820      0,                                                       /* SVt_NULL */
 821      0,                                                       /* SVt_BIND */
 822      0,                                                       /* SVt_IV */
 823      MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)),                 /* SVt_NV */
 824      0,                                                       /* SVt_RV */
 825      sizeof(XPV) - MAYBE_OFFSET(XPV, xpv_cur),                /* SVt_PV */
 826      sizeof(XPVIV) - MAYBE_OFFSET(XPV, xpv_cur),              /* SVt_PVIV */
 827      sizeof(XPVNV),                                           /* SVt_PVNV */
 828      sizeof(XPVMG),                                           /* SVt_PVMG */
 829      sizeof(XPVGV),                                           /* SVt_PVGV */
 830      sizeof(XPVLV),                                           /* SVt_PVLV */
 831      sizeof(XPVAV) - MAYBE_OFFSET(XPVAV, xav_fill),           /* SVt_PVAV */
 832      sizeof(XPVHV) - MAYBE_OFFSET(XPVHV, xhv_fill),           /* SVt_PVHV */
 833      sizeof(XPVCV) - MAYBE_OFFSET(XPVCV, xpv_cur),            /* SVt_PVCV */
 834      sizeof(XPVFM) - MAYBE_OFFSET(XPVFM, xpv_cur),            /* SVt_PVFM */
 835      sizeof(XPVIO)                                            /* SVt_PVIO */
 836 #elif PERL_VERSION < 13
 837      0,                                                       /* SVt_NULL */
 838      0,                                                       /* SVt_BIND */
 839      0,                                                       /* SVt_IV */
 840      MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)),                 /* SVt_NV */
 841      sizeof(XPV) - MAYBE_OFFSET(XPV, xpv_cur),                /* SVt_PV */
 842      sizeof(XPVIV) - MAYBE_OFFSET(XPV, xpv_cur),              /* SVt_PVIV */
 843      sizeof(XPVNV),                                           /* SVt_PVNV */
 844      sizeof(XPVMG),                                           /* SVt_PVMG */
 845      sizeof(regexp) - MAYBE_OFFSET(regexp, xpv_cur),          /* SVt_REGEXP */
 846      sizeof(XPVGV),                                           /* SVt_PVGV */
 847      sizeof(XPVLV),                                           /* SVt_PVLV */
 848      sizeof(XPVAV) - MAYBE_OFFSET(XPVAV, xav_fill),           /* SVt_PVAV */
 849      sizeof(XPVHV) - MAYBE_OFFSET(XPVHV, xhv_fill),           /* SVt_PVHV */
 850      sizeof(XPVCV) - MAYBE_OFFSET(XPVCV, xpv_cur),            /* SVt_PVCV */
 851      sizeof(XPVFM) - MAYBE_OFFSET(XPVFM, xpv_cur),            /* SVt_PVFM */
 852      sizeof(XPVIO)                                            /* SVt_PVIO */
 853 #else
 854      0,                                                       /* SVt_NULL */
 855      0,                                                       /* SVt_BIND */
 856      0,                                                       /* SVt_IV */
 857      MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)),                 /* SVt_NV */
 858      sizeof(XPV) - MAYBE_OFFSET(XPV, xpv_cur),                /* SVt_PV */
 859      sizeof(XPVIV) - MAYBE_OFFSET(XPV, xpv_cur),              /* SVt_PVIV */
 860      sizeof(XPVNV) - MAYBE_OFFSET(XPV, xpv_cur),              /* SVt_PVNV */
 861      sizeof(XPVMG),                                           /* SVt_PVMG */
 862      sizeof(regexp),                                          /* SVt_REGEXP */
 863      sizeof(XPVGV),                                           /* SVt_PVGV */
 864      sizeof(XPVLV),                                           /* SVt_PVLV */
 865      sizeof(XPVAV),                                           /* SVt_PVAV */
 866      sizeof(XPVHV),                                           /* SVt_PVHV */
 867      sizeof(XPVCV),                                           /* SVt_PVCV */
 868      sizeof(XPVFM),                                           /* SVt_PVFM */
 869      sizeof(XPVIO)                                            /* SVt_PVIO */
 870 #endif
 871 };
 872
 873
 874 static void
 875 padlist_size(pTHX_ struct state *const st, pPATH, PADLIST *padlist,
 876         const int recurse)
 877 {
 878     dNPathUseParent(NPathArg);
 879     /* based on Perl_do_dump_pad() */
 880     const AV *pad_name;
 881     SV **pname;
 882     I32 ix;
 883
 884     if (!padlist) {
 885         return;
 886     }
 887     pad_name = MUTABLE_AV(*av_fetch(MUTABLE_AV(padlist), 0, FALSE));
 888     pname = AvARRAY(pad_name);
 889
 890     for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
 891         const SV *namesv = pname[ix];
 892         if (namesv && namesv == &PL_sv_undef) {
 893             namesv = NULL;
 894         }
 895         if (namesv) {
 896             if (SvFAKE(namesv))
 897                 ADD_ATTR(st, 1, SvPVX_const(namesv), ix);
 898             else
 899                 ADD_ATTR(st, 1, SvPVX_const(namesv), ix);
 900         }
 901         else {
 902             ADD_ATTR(st, 1, "SVs_PADTMP", ix);
 903         }
 904
 905     }
 906     sv_size(aTHX_ st, NPathArg, (SV*)padlist, recurse);
 907 }
 908
 909
 910 static void
 911 sv_size(pTHX_ struct state *const st, pPATH, const SV * const orig_thing,
 912         const int recurse) {
 913   const SV *thing = orig_thing;
 914   dNPathNodes(3, NPathArg);
 915   U32 type;
 916
 917   if(!check_new(st, orig_thing))
 918       return;
 919
 920   type = SvTYPE(thing);
 921   if (type > SVt_LAST) {
 922       warn("Devel::Size: Unknown variable type: %d encountered\n", type);
 923       return;
 924   }
 925   dNPathSetNode(thing, NPtype_SV);
 926   ADD_SIZE(st, "sv", sizeof(SV) + body_sizes[type]);
 927
 928   if (type >= SVt_PVMG) {
 929       magic_size(aTHX_ thing, st, NPathLink(NULL, 0));
 930   }
 931
 932   switch (type) {
 933 #if (PERL_VERSION < 11)
 934     /* Is it a reference? */
 935   case SVt_RV: TAG;
 936 #else
 937   case SVt_IV: TAG;
 938 #endif
 939     if(recurse && SvROK(thing))
 940         sv_size(aTHX_ st, NPathLink("RV", NPtype_LINK), SvRV_const(thing), recurse);
 941     TAG;break;
 942
 943   case SVt_PVAV: TAG;
 944     /* Is there anything in the array? */
 945     if (AvMAX(thing) != -1) {
 946       /* an array with 10 slots has AvMax() set to 9 - te 2007-04-22 */
 947       ADD_SIZE(st, "av_max", sizeof(SV *) * (AvMAX(thing) + 1));
 948       dbg_printf(("total_size: %li AvMAX: %li av_len: $i\n", st->total_size, AvMAX(thing), av_len((AV*)thing)));
 949
 950       if (recurse >= TOTAL_SIZE_RECURSION) {
 951           SSize_t i = AvFILLp(thing) + 1;
 952
 953           while (i--)
 954               sv_size(aTHX_ st, NPathLink("AVelem", NPtype_LINK), AvARRAY(thing)[i], recurse);
 955       }
 956     }
 957     /* Add in the bits on the other side of the beginning */
 958
 959     dbg_printf(("total_size %li, sizeof(SV *) %li, AvARRAY(thing) %li, AvALLOC(thing)%li , sizeof(ptr) %li \n",
 960         st->total_size, sizeof(SV*), AvARRAY(thing), AvALLOC(thing), sizeof( thing )));
 961
 962     /* under Perl 5.8.8 64bit threading, AvARRAY(thing) was a pointer while AvALLOC was 0,
 963        resulting in grossly overstated sized for arrays. Technically, this shouldn't happen... */
 964     if (AvALLOC(thing) != 0) {
 965       ADD_SIZE(st, "AvALLOC", (sizeof(SV *) * (AvARRAY(thing) - AvALLOC(thing))));
 966       }
 967 #if (PERL_VERSION < 9)
 968     /* Is there something hanging off the arylen element?
 969        Post 5.9.something this is stored in magic, so will be found there,
 970        and Perl_av_arylen_p() takes a non-const AV*, hence compilers rightly
 971        complain about AvARYLEN() passing thing to it.  */
 972     sv_size(aTHX_ st, NPathLink("ARYLEN", NPtype_LINK), AvARYLEN(thing), recurse);
 973 #endif
 974     TAG;break;
 975   case SVt_PVHV: TAG;
 976     /* Now the array of buckets */
 977     ADD_SIZE(st, "hv_max", (sizeof(HE *) * (HvMAX(thing) + 1)));
 978     if (HvENAME(thing)) {
 979         ADD_ATTR(st, 1, HvENAME(thing), 0);
 980     }
 981     /* Now walk the bucket chain */
 982     if (HvARRAY(thing)) {
 983       HE *cur_entry;
 984       UV cur_bucket = 0;
 985       dNPathSetNode("HvARRAY", NPtype_LINK);
 986       for (cur_bucket = 0; cur_bucket <= HvMAX(thing); cur_bucket++) {
 987         cur_entry = *(HvARRAY(thing) + cur_bucket);
 988         while (cur_entry) {
 989           ADD_SIZE(st, "he", sizeof(HE));
 990           hek_size(aTHX_ st, cur_entry->hent_hek, HvSHAREKEYS(thing), NPathLink("hent_hek", NPtype_LINK));
 991           if (recurse >= TOTAL_SIZE_RECURSION)
 992               sv_size(aTHX_ st, NPathLink("HeVAL", NPtype_LINK), HeVAL(cur_entry), recurse);
 993           cur_entry = cur_entry->hent_next;
 994         }
 995       }
 996     }
 997 #ifdef HvAUX
 998     if (SvOOK(thing)) {
 999         /* This direct access is arguably "naughty": */
1000         struct mro_meta *meta = HvAUX(thing)->xhv_mro_meta;
1001 #if PERL_VERSION > 13 || PERL_SUBVERSION > 8
1002         /* As is this: */
1003         I32 count = HvAUX(thing)->xhv_name_count;
1004
1005         if (count) {
1006             HEK **names = HvAUX(thing)->xhv_name_u.xhvnameu_names;
1007             if (count < 0)
1008                 count = -count;
1009             while (--count)
1010                 hek_size(aTHX_ st, names[count], 1, NPathLink("HvAUXelem", NPtype_LINK));
1011         }
1012         else
1013 #endif
1014         {
1015             hek_size(aTHX_ st, HvNAME_HEK(thing), 1, NPathLink("HvNAME_HEK", NPtype_LINK));
1016         }
1017
1018         ADD_SIZE(st, "xpvhv_aux", sizeof(struct xpvhv_aux));
1019         if (meta) {
1020             ADD_SIZE(st, "mro_meta", sizeof(struct mro_meta));
1021             sv_size(aTHX_ st, NPathLink("mro_nextmethod", NPtype_LINK), (SV *)meta->mro_nextmethod, TOTAL_SIZE_RECURSION);
1022 #if PERL_VERSION > 10 || (PERL_VERSION == 10 && PERL_SUBVERSION > 0)
1023             sv_size(aTHX_ st, NPathLink("isa", NPtype_LINK), (SV *)meta->isa, TOTAL_SIZE_RECURSION);
1024 #endif
1025 #if PERL_VERSION > 10
1026             sv_size(aTHX_ st, NPathLink("mro_linear_all", NPtype_LINK), (SV *)meta->mro_linear_all, TOTAL_SIZE_RECURSION);
1027             sv_size(aTHX_ st, NPathLink("mro_linear_current", NPtype_LINK), meta->mro_linear_current, TOTAL_SIZE_RECURSION);
1028 #else
1029             sv_size(aTHX_ st, NPathLink("mro_linear_dfs", NPtype_LINK), (SV *)meta->mro_linear_dfs, TOTAL_SIZE_RECURSION);
1030             sv_size(aTHX_ st, NPathLink("mro_linear_c3", NPtype_LINK), (SV *)meta->mro_linear_c3, TOTAL_SIZE_RECURSION);
1031 #endif
1032         }
1033     }
1034 #else
1035     check_new_and_strlen(st, HvNAME_get(thing), NPathLink("HvNAME", NPtype_LINK));
1036 #endif
1037     TAG;break;
1038
1039
1040   case SVt_PVFM: TAG;
1041     padlist_size(aTHX_ st, NPathLink("CvPADLIST", NPtype_LINK), CvPADLIST(thing), SOME_RECURSION);
1042     sv_size(aTHX_ st, NPathLink("CvOUTSIDE", NPtype_LINK), (SV *)CvOUTSIDE(thing), recurse);
1043
1044     if (st->go_yell && !st->fm_whine) {
1045       carp("Devel::Size: Calculated sizes for FMs are incomplete");
1046       st->fm_whine = 1;
1047     }
1048     goto freescalar;
1049
1050   case SVt_PVCV: TAG;
1051     sv_size(aTHX_ st, NPathLink("CvSTASH", NPtype_LINK), (SV *)CvSTASH(thing), SOME_RECURSION);
1052     sv_size(aTHX_ st, NPathLink("SvSTASH", NPtype_LINK), (SV *)SvSTASH(thing), SOME_RECURSION);
1053     sv_size(aTHX_ st, NPathLink("CvGV", NPtype_LINK), (SV *)CvGV(thing), SOME_RECURSION);
1054     padlist_size(aTHX_ st, NPathLink("CvPADLIST", NPtype_LINK), CvPADLIST(thing), SOME_RECURSION);
1055     sv_size(aTHX_ st, NPathLink("CvOUTSIDE", NPtype_LINK), (SV *)CvOUTSIDE(thing), recurse);
1056     if (CvISXSUB(thing)) {
1057         sv_size(aTHX_ st, NPathLink("cv_const_sv", NPtype_LINK), cv_const_sv((CV *)thing), recurse);
1058     } else {
1059         op_size(aTHX_ CvSTART(thing), st, NPathLink("CvSTART", NPtype_LINK));
1060         op_size(aTHX_ CvROOT(thing), st, NPathLink("CvROOT", NPtype_LINK));
1061     }
1062     goto freescalar;
1063
1064   case SVt_PVIO: TAG;
1065     /* Some embedded char pointers */
1066     check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_top_name, NPathLink("xio_top_name", NPtype_LINK));
1067     check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_fmt_name, NPathLink("xio_fmt_name", NPtype_LINK));
1068     check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_bottom_name, NPathLink("xio_bottom_name", NPtype_LINK));
1069     /* Throw the GVs on the list to be walked if they're not-null */
1070     sv_size(aTHX_ st, NPathLink("xio_top_gv", NPtype_LINK), (SV *)((XPVIO *) SvANY(thing))->xio_top_gv, recurse);
1071     sv_size(aTHX_ st, NPathLink("xio_bottom_gv", NPtype_LINK), (SV *)((XPVIO *) SvANY(thing))->xio_bottom_gv, recurse);
1072     sv_size(aTHX_ st, NPathLink("xio_fmt_gv", NPtype_LINK), (SV *)((XPVIO *) SvANY(thing))->xio_fmt_gv, recurse);
1073
1074     /* Only go trotting through the IO structures if they're really
1075        trottable. If USE_PERLIO is defined we can do this. If
1076        not... we can't, so we don't even try */
1077 #ifdef USE_PERLIO
1078     /* Dig into xio_ifp and xio_ofp here */
1079     warn("Devel::Size: Can't size up perlio layers yet\n");
1080 #endif
1081     goto freescalar;
1082
1083   case SVt_PVLV: TAG;
1084 #if (PERL_VERSION < 9)
1085     goto freescalar;
1086 #endif
1087
1088   case SVt_PVGV: TAG;
1089     if(isGV_with_GP(thing)) {
1090 #ifdef GvNAME_HEK
1091         hek_size(aTHX_ st, GvNAME_HEK(thing), 1, NPathLink("GvNAME_HEK", NPtype_LINK));
1092 #else
1093         ADD_SIZE(st, "GvNAMELEN", GvNAMELEN(thing));
1094 #endif
1095         ADD_ATTR(st, 1, GvNAME_get(thing), 0);
1096 #ifdef GvFILE_HEK
1097         hek_size(aTHX_ st, GvFILE_HEK(thing), 1, NPathLink("GvFILE_HEK", NPtype_LINK));
1098 #elif defined(GvFILE)
1099 #  if !defined(USE_ITHREADS) || (PERL_VERSION > 8 || (PERL_VERSION == 8 && PERL_SUBVERSION > 8))
1100         /* With itreads, before 5.8.9, this can end up pointing to freed memory
1101            if the GV was created in an eval, as GvFILE() points to CopFILE(),
1102            and the relevant COP has been freed on scope cleanup after the eval.
1103            5.8.9 adds a binary compatible fudge that catches the vast majority
1104            of cases. 5.9.something added a proper fix, by converting the GP to
1105            use a shared hash key (porperly reference counted), instead of a
1106            char * (owned by who knows? possibly no-one now) */
1107         check_new_and_strlen(st, GvFILE(thing), NPathLink("GvFILE", NPtype_LINK));
1108 #  endif
1109 #endif
1110         /* Is there something hanging off the glob? */
1111         if (check_new(st, GvGP(thing))) {
1112             ADD_SIZE(st, "GP", sizeof(GP));
1113             sv_size(aTHX_ st, NPathLink("gp_sv", NPtype_LINK), (SV *)(GvGP(thing)->gp_sv), recurse);
1114             sv_size(aTHX_ st, NPathLink("gp_form", NPtype_LINK), (SV *)(GvGP(thing)->gp_form), recurse);
1115             sv_size(aTHX_ st, NPathLink("gp_av", NPtype_LINK), (SV *)(GvGP(thing)->gp_av), recurse);
1116             sv_size(aTHX_ st, NPathLink("gp_hv", NPtype_LINK), (SV *)(GvGP(thing)->gp_hv), recurse);
1117             sv_size(aTHX_ st, NPathLink("gp_egv", NPtype_LINK), (SV *)(GvGP(thing)->gp_egv), recurse);
1118             sv_size(aTHX_ st, NPathLink("gp_cv", NPtype_LINK), (SV *)(GvGP(thing)->gp_cv), recurse);
1119         }
1120 #if (PERL_VERSION >= 9)
1121         TAG; break;
1122 #endif
1123     }
1124 #if PERL_VERSION <= 8
1125   case SVt_PVBM: TAG;
1126 #endif
1127   case SVt_PVMG: TAG;
1128   case SVt_PVNV: TAG;
1129   case SVt_PVIV: TAG;
1130   case SVt_PV: TAG;
1131   freescalar:
1132     if(recurse && SvROK(thing))
1133         sv_size(aTHX_ st, NPathLink("RV", NPtype_LINK), SvRV_const(thing), recurse);
1134     else if (SvIsCOW_shared_hash(thing))
1135         hek_size(aTHX_ st, SvSHARED_HEK_FROM_PV(SvPVX(thing)), 1, NPathLink("SvSHARED_HEK_FROM_PV", NPtype_LINK));
1136     else
1137         ADD_SIZE(st, "SvLEN", SvLEN(thing));
1138
1139     if(SvOOK(thing)) {
1140         STRLEN len;
1141         SvOOK_offset(thing, len);
1142         ADD_SIZE(st, "SvOOK", len);
1143     }
1144     TAG;break;
1145
1146   }
1147   return;
1148 }
1149
1150 static struct state *
1151 new_state(pTHX)
1152 {
1153     SV *warn_flag;
1154     struct state *st;
1155
1156     Newxz(st, 1, struct state);
1157     st->go_yell = TRUE;
1158     if (NULL != (warn_flag = perl_get_sv("Devel::Size::warn", FALSE))) {
1159         st->dangle_whine = st->go_yell = SvIV(warn_flag) ? TRUE : FALSE;
1160     }
1161     if (NULL != (warn_flag = perl_get_sv("Devel::Size::dangle", FALSE))) {
1162         st->dangle_whine = SvIV(warn_flag) ? TRUE : FALSE;
1163     }
1164     check_new(st, &PL_sv_undef);
1165     check_new(st, &PL_sv_no);
1166     check_new(st, &PL_sv_yes);
1167 #if PERL_VERSION > 8 || (PERL_VERSION == 8 && PERL_SUBVERSION > 0)
1168     check_new(st, &PL_sv_placeholder);
1169 #endif
1170 #ifdef PATH_TRACKING
1171     st->add_attr_cb = dump_path;
1172 #endif
1173     return st;
1174 }
1175
1176 MODULE = Devel::Size        PACKAGE = Devel::Size
1177
1178 PROTOTYPES: DISABLE
1179
1180 UV
1181 size(orig_thing)
1182      SV *orig_thing
1183 ALIAS:
1184     total_size = TOTAL_SIZE_RECURSION
1185 CODE:
1186 {
1187   SV *thing = orig_thing;
1188   struct state *st = new_state(aTHX);
1189
1190   /* If they passed us a reference then dereference it. This is the
1191      only way we can check the sizes of arrays and hashes */
1192   if (SvROK(thing)) {
1193     thing = SvRV(thing);
1194   }
1195
1196   sv_size(aTHX_ st, NULL, thing, ix);
1197   RETVAL = st->total_size;
1198   free_state(st);
1199 }
1200 OUTPUT:
1201   RETVAL
1202
1203 UV
1204 perl_size()
1205 CODE:
1206 {
1207   dNPathNodes(1, NULL);
1208   struct state *st = new_state(aTHX);
1209
1210   /* start with PL_defstash to get everything reachable from \%main::
1211    * this seems to include PL_defgv, PL_incgv etc but I've listed them anyway
1212    */
1213   sv_size(aTHX_ st, NPathLink("PL_defstash", NPtype_LINK), (SV*)PL_defstash, TOTAL_SIZE_RECURSION);
1214   sv_size(aTHX_ st, NPathLink("PL_defgv", NPtype_LINK), (SV*)PL_defgv, TOTAL_SIZE_RECURSION);
1215   sv_size(aTHX_ st, NPathLink("PL_incgv", NPtype_LINK), (SV*)PL_incgv, TOTAL_SIZE_RECURSION);
1216   sv_size(aTHX_ st, NPathLink("PL_rs", NPtype_LINK), (SV*)PL_rs, TOTAL_SIZE_RECURSION);
1217   sv_size(aTHX_ st, NPathLink("PL_fdpid", NPtype_LINK), (SV*)PL_fdpid, TOTAL_SIZE_RECURSION);
1218   sv_size(aTHX_ st, NPathLink("PL_modglobal", NPtype_LINK), (SV*)PL_modglobal, TOTAL_SIZE_RECURSION);
1219   sv_size(aTHX_ st, NPathLink("PL_errors", NPtype_LINK), (SV*)PL_errors, TOTAL_SIZE_RECURSION);
1220   sv_size(aTHX_ st, NPathLink("PL_stashcache", NPtype_LINK), (SV*)PL_stashcache, TOTAL_SIZE_RECURSION);
1221   sv_size(aTHX_ st, NPathLink("PL_patchlevel", NPtype_LINK), (SV*)PL_patchlevel, TOTAL_SIZE_RECURSION);
1222   sv_size(aTHX_ st, NPathLink("PL_apiversion", NPtype_LINK), (SV*)PL_apiversion, TOTAL_SIZE_RECURSION);
1223   sv_size(aTHX_ st, NPathLink("PL_registered_mros", NPtype_LINK), (SV*)PL_registered_mros, TOTAL_SIZE_RECURSION);
1224 #ifdef USE_ITHREADS
1225   sv_size(aTHX_ st, NPathLink("PL_regex_padav", NPtype_LINK), (SV*)PL_regex_padav, TOTAL_SIZE_RECURSION);
1226 #endif
1227   /* TODO PL_pidstatus */
1228   /* TODO PL_stashpad */
1229
1230   /* in theory we shouldn't have any elements in PL_strtab that haven't been seen yet */
1231   sv_size(aTHX_ st, NPathLink("PL_strtab", NPtype_LINK), (SV*)PL_strtab, TOTAL_SIZE_RECURSION);
1232
1233   /* TODO stacks: cur, main, tmps, mark, scope, save */
1234   /* TODO unused space in arenas */
1235   /* TODO unused space in malloc, for whichever mallocs support it */
1236   /* TODO anything missed? */
1237
1238   RETVAL = st->total_size;
1239   free_state(st);
1240 }
1241 OUTPUT:
1242   RETVAL