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