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