Memory.xs

   1 /* -*- mode: C -*- */
   2
   3 /* TODO
   4  *
   5  * Refactor this to split out D:M code from Devel::Size code.
   6  *
   7  * Start migrating Devel::Size's Size.xs towards the new code.
   8  *
   9  * ADD_PRE_ATTR for index should check if the ptr is new first. Currently we're
  10  * generating lots of ADD_PRE_ATTR's for SVs that we've already seen via other paths.
  11  * That's wasteful and likely to cause subtle bugs.
  12  *
  13  * Give HE's their own node so keys and values can be tied together
  14  *
  15  */
  16
  17 #undef NDEBUG /* XXX */
  18 #include <assert.h>
  19
  20 #define PERL_NO_GET_CONTEXT
  21
  22 #include "EXTERN.h"
  23 #include "perl.h"
  24 #include "XSUB.h"
  25 #include "ppport.h"
  26
  27 #include "refcounted_he.h"
  28
  29 /* Not yet in ppport.h */
  30 #ifndef CvISXSUB
  31 #  define CvISXSUB(cv)  (CvXSUB(cv) ? TRUE : FALSE)
  32 #endif
  33 #ifndef SvRV_const
  34 #  define SvRV_const(rv) SvRV(rv)
  35 #endif
  36 #ifndef SvOOK_offset
  37 #  define SvOOK_offset(sv, len) STMT_START { len = SvIVX(sv); } STMT_END
  38 #endif
  39 #ifndef SvIsCOW
  40 #  define SvIsCOW(sv)           ((SvFLAGS(sv) & (SVf_FAKE | SVf_READONLY)) == \
  41                                     (SVf_FAKE | SVf_READONLY))
  42 #endif
  43 #ifndef SvIsCOW_shared_hash
  44 #  define SvIsCOW_shared_hash(sv)   (SvIsCOW(sv) && SvLEN(sv) == 0)
  45 #endif
  46 #ifndef SvSHARED_HEK_FROM_PV
  47 #  define SvSHARED_HEK_FROM_PV(pvx) \
  48         ((struct hek*)(pvx - STRUCT_OFFSET(struct hek, hek_key)))
  49 #endif
  50
  51 #if PERL_VERSION < 6
  52 #  define PL_opargs opargs
  53 #  define PL_op_name op_name
  54 #endif
  55
  56 #ifdef _MSC_VER
  57 /* "structured exception" handling is a Microsoft extension to C and C++.
  58    It's *not* C++ exception handling - C++ exception handling can't capture
  59    SEGVs and suchlike, whereas this can. There's no known analagous
  60     functionality on other platforms.  */
  61 #  include <excpt.h>
  62 #  define TRY_TO_CATCH_SEGV __try
  63 #  define CAUGHT_EXCEPTION __except(EXCEPTION_EXECUTE_HANDLER)
  64 #else
  65 #  define TRY_TO_CATCH_SEGV if(1)
  66 #  define CAUGHT_EXCEPTION else
  67 #endif
  68
  69 #ifdef __GNUC__
  70 # define __attribute__(x)
  71 #endif
  72
  73 #if 0 && defined(DEBUGGING)
  74 #define dbg_printf(x) printf x
  75 #else
  76 #define dbg_printf(x)
  77 #endif
  78
  79 #define TAG /* printf( "# %s(%d)\n", __FILE__, __LINE__ ) */
  80 #define carp puts
  81
  82 /* The idea is to have a tree structure to store 1 bit per possible pointer
  83    address. The lowest 16 bits are stored in a block of 8092 bytes.
  84    The blocks are in a 256-way tree, indexed by the reset of the pointer.
  85    This can cope with 32 and 64 bit pointers, and any address space layout,
  86    without excessive memory needs. The assumption is that your CPU cache
  87    works :-) (And that we're not going to bust it)  */
  88
  89 #define BYTE_BITS    3
  90 #define LEAF_BITS   (16 - BYTE_BITS)
  91 #define LEAF_MASK   0x1FFF
  92
  93 typedef struct npath_node_st npath_node_t;
  94 struct npath_node_st {
  95     npath_node_t *prev;
  96     const void *id;
  97     U8 type;
  98     U8 flags;
  99     UV seqn;
 100     U16 depth;
 101 };
 102
 103 struct state {
 104     UV total_size;
 105     bool regex_whine;
 106     bool fm_whine;
 107     bool dangle_whine;
 108     bool go_yell;
 109     /* My hunch (not measured) is that for most architectures pointers will
 110        start with 0 bits, hence the start of this array will be hot, and the
 111        end unused. So put the flags next to the hot end.  */
 112     void *tracking[256];
 113     int min_recurse_threshold;
 114     /* callback hooks and data */
 115     int (*add_attr_cb)(pTHX_ struct state *st, npath_node_t *npath_node, UV attr_type, const char *name, UV value);
 116     void (*free_state_cb)(pTHX_ struct state *st);
 117     void *state_cb_data; /* free'd by free_state() after free_state_cb() call */
 118     /* this stuff wil be moved to state_cb_data later */
 119     UV seqn;
 120     FILE *node_stream_fh;
 121     char *node_stream_name;
 122 };
 123
 124 #define ADD_SIZE(st, leafname, bytes) (NPathAddSizeCb(st, leafname, bytes) (st)->total_size += (bytes))
 125
 126 #define PATH_TRACKING
 127 #ifdef PATH_TRACKING
 128
 129 #define pPATH npath_node_t *NPathArg
 130
 131 /* A subtle point here is that dNPathNodes and NPathPushNode leave NP pointing
 132  * to the next unused slot (though with prev already filled in)
 133  * whereas NPathLink leaves NP unchanged, it just fills in the slot NP points
 134  * to and passes that NP value to the function being called.
 135  * seqn==0 indicates the node is new (hasn't been output yet)
 136  */
 137 #define dNPathNodes(nodes, prev_np) \
 138             npath_node_t name_path_nodes[nodes+1]; /* +1 for NPathLink */ \
 139             npath_node_t *NP = &name_path_nodes[0]; \
 140             NP->seqn = NP->type = 0; NP->id = Nullch; /* safety/debug */ \
 141             NP->prev = prev_np
 142 #define NPathPushNode(nodeid, nodetype) \
 143             NP->id = nodeid; \
 144             NP->type = nodetype; \
 145             NP->seqn = 0; \
 146             if(0)fprintf(stderr,"NPathPushNode (%p <-) %p <- [%d %s]\n", NP->prev, NP, nodetype,(char*)nodeid);\
 147             NP++; \
 148             NP->id = Nullch; /* safety/debug */ \
 149             NP->seqn = 0; \
 150             NP->prev = (NP-1)
 151 #define NPathSetNode(nodeid, nodetype) \
 152             (NP-1)->id = nodeid; \
 153             (NP-1)->type = nodetype; \
 154             if(0)fprintf(stderr,"NPathSetNode (%p <-) %p <- [%d %s]\n", (NP-1)->prev, (NP-1), nodetype,(char*)nodeid);\
 155             (NP-1)->seqn = 0;
 156 #define NPathPopNode \
 157             --NP
 158
 159 /* dNPathUseParent points NP directly the the parents' name_path_nodes array
 160  * So the function can only safely call ADD_*() but not NPathLink, unless the
 161  * caller has spare nodes in its name_path_nodes.
 162  */
 163 #define dNPathUseParent(prev_np) npath_node_t *NP = (((prev_np+1)->prev = prev_np), prev_np+1)
 164
 165 #define NPtype_NAME     0x01
 166 #define NPtype_LINK     0x02
 167 #define NPtype_SV       0x03
 168 #define NPtype_MAGIC    0x04
 169 #define NPtype_OP       0x05
 170
 171 /* XXX these should probably be generalizes into flag bits */
 172 #define NPattr_LEAFSIZE 0x00
 173 #define NPattr_NAME     0x01
 174 #define NPattr_PADFAKE  0x02
 175 #define NPattr_PADNAME  0x03
 176 #define NPattr_PADTMP   0x04
 177 #define NPattr_NOTE     0x05
 178 #define NPattr_PRE_ATTR 0x06
 179
 180 #define _ADD_ATTR_NP(st, attr_type, attr_name, attr_value, np) (st->add_attr_cb && st->add_attr_cb(aTHX_ st, np, attr_type, attr_name, attr_value))
 181 #define ADD_ATTR(st, attr_type, attr_name, attr_value) _ADD_ATTR_NP(st, attr_type, attr_name, attr_value, NP-1)
 182 #define ADD_PRE_ATTR(st, attr_type, attr_name, attr_value) (assert(!attr_type), _ADD_ATTR_NP(st, NPattr_PRE_ATTR, attr_name, attr_value, NP-1))
 183
 184 #define _NPathLink(np, nid, ntype)   (((np)->id=nid), ((np)->type=ntype), ((np)->seqn=0))
 185 #define NPathLink(nid)               (_NPathLink(NP, nid, NPtype_LINK), NP)
 186 /* add a link and a name node to the path - a special case for op_size */
 187 #define NPathLinkAndNode(nid, nid2)  (_NPathLink(NP, nid, NPtype_LINK), _NPathLink(NP+1, nid2, NPtype_NAME), ((NP+1)->prev=NP), (NP+1))
 188 #define NPathOpLink  (NPathArg)
 189 #define NPathAddSizeCb(st, name, bytes) (st->add_attr_cb && st->add_attr_cb(aTHX_ st, NP-1, NPattr_LEAFSIZE, (name), (bytes))),
 190
 191 #else
 192
 193 #define NPathAddSizeCb(st, name, bytes)
 194 #define pPATH void *npath_dummy /* XXX ideally remove */
 195 #define dNPathNodes(nodes, prev_np)  dNOOP
 196 #define NPathLink(nodeid, nodetype)  NULL
 197 #define NPathOpLink NULL
 198 #define ADD_ATTR(st, attr_type, attr_name, attr_value) NOOP
 199
 200 #endif /* PATH_TRACKING */
 201
 202
 203
 204
 205 #ifdef PATH_TRACKING
 206
 207 static const char *svtypenames[SVt_LAST] = {
 208 #if PERL_VERSION < 9
 209   "NULL", "IV", "NV", "RV", "PV", "PVIV", "PVNV", "PVMG", "PVBM", "PVLV", "PVAV", "PVHV", "PVCV", "PVGV", "PVFM", "PVIO",
 210 #elif PERL_VERSION == 10 && PERL_SUBVERSION == 0
 211   "NULL", "BIND", "IV", "NV", "RV", "PV", "PVIV", "PVNV", "PVMG", "PVGV", "PVLV", "PVAV", "PVHV", "PVCV", "PVFM", "PVIO",
 212 #elif PERL_VERSION == 10 && PERL_SUBVERSION == 1
 213   "NULL", "BIND", "IV", "NV", "RV", "PV", "PVIV", "PVNV", "PVMG", "PVGV", "PVLV", "PVAV", "PVHV", "PVCV", "PVFM", "PVIO",
 214 #elif PERL_VERSION < 13
 215   "NULL", "BIND", "IV", "NV", "PV", "PVIV", "PVNV", "PVMG", "REGEXP", "PVGV", "PVLV", "PVAV", "PVHV", "PVCV", "PVFM", "PVIO",
 216 #else
 217   "NULL", "BIND", "IV", "NV", "PV", "PVIV", "PVNV", "PVMG", "REGEXP", "PVGV", "PVLV", "PVAV", "PVHV", "PVCV", "PVFM", "PVIO",
 218 #endif
 219 };
 220
 221 int
 222 np_print_node_name(pTHX_ FILE *fp, npath_node_t *npath_node)
 223 {
 224     char buf[1024]; /* XXX */
 225
 226     switch (npath_node->type) {
 227     case NPtype_SV: { /* id is pointer to the SV sv_size was called on */
 228         const SV *sv = (SV*)npath_node->id;
 229         int type = SvTYPE(sv);
 230         char *typename = (type == SVt_IV && SvROK(sv)) ? "RV" : svtypenames[type];
 231         fprintf(fp, "SV(%s)", typename);
 232         switch(type) {  /* add some useful details */
 233         case SVt_PVAV: fprintf(fp, " fill=%d/%ld", av_len((AV*)sv), AvMAX((AV*)sv)); break;
 234         case SVt_PVHV: fprintf(fp, " fill=%ld/%ld", HvFILL((HV*)sv), HvMAX((HV*)sv)); break;
 235         }
 236         break;
 237     }
 238     case NPtype_OP: { /* id is pointer to the OP op_size was called on */
 239         const OP *op = (OP*)npath_node->id;
 240         fprintf(fp, "OP(%s)", OP_NAME(op));
 241         break;
 242     }
 243     case NPtype_MAGIC: { /* id is pointer to the MAGIC struct */
 244         MAGIC *magic_pointer = (MAGIC*)npath_node->id;
 245         /* XXX it would be nice if we could reuse mg_names.c [sigh] */
 246         fprintf(fp, "MAGIC(%c)", magic_pointer->mg_type ? magic_pointer->mg_type : '0');
 247         break;
 248     }
 249     case NPtype_LINK:
 250         fprintf(fp, "%s", npath_node->id);
 251         break;
 252     case NPtype_NAME:
 253         fprintf(fp, "%s", npath_node->id);
 254         break;
 255     default:    /* assume id is a string pointer */
 256         fprintf(fp, "UNKNOWN(%d,%p)", npath_node->type, npath_node->id);
 257         break;
 258     }
 259     return 0;
 260 }
 261
 262 void
 263 np_dump_indent(int depth) {
 264     while (depth-- > 0)
 265         fprintf(stderr, ":   ");
 266 }
 267
 268 int
 269 np_walk_new_nodes(pTHX_ struct state *st,
 270     npath_node_t *npath_node,
 271     npath_node_t *npath_node_deeper,
 272     int (*cb)(pTHX_ struct state *st, npath_node_t *npath_node, npath_node_t *npath_node_deeper))
 273 {
 274     if (npath_node->seqn) /* node already output */
 275         return 0;
 276
 277     if (npath_node->prev) {
 278         np_walk_new_nodes(aTHX_ st, npath_node->prev, npath_node, cb); /* recurse */
 279         npath_node->depth = npath_node->prev->depth + 1;
 280     }
 281     else npath_node->depth = 0;
 282     npath_node->seqn = ++st->seqn;
 283
 284     if (cb) {
 285         if (cb(aTHX_ st, npath_node, npath_node_deeper)) {
 286             /* ignore this node */
 287             assert(npath_node->prev);
 288             assert(npath_node->depth);
 289             assert(npath_node_deeper);
 290             npath_node->depth--;
 291             npath_node->seqn = --st->seqn;
 292             npath_node_deeper->prev = npath_node->prev;
 293         }
 294     }
 295
 296     return 0;
 297 }
 298
 299 int
 300 np_dump_formatted_node(pTHX_ struct state *st, npath_node_t *npath_node, npath_node_t *npath_node_deeper) {
 301     if (0 && npath_node->type == NPtype_LINK)
 302         return 1;
 303     np_dump_indent(npath_node->depth);
 304     np_print_node_name(aTHX_ stderr, npath_node);
 305     if (npath_node->type == NPtype_LINK)
 306         fprintf(stderr, "->"); /* cosmetic */
 307     fprintf(stderr, "\t\t[#%ld @%u] ", npath_node->seqn, npath_node->depth);
 308     fprintf(stderr, "\n");
 309     return 0;
 310 }
 311
 312 int
 313 np_dump_node_path_info(pTHX_ struct state *st, npath_node_t *npath_node, UV attr_type, const char *attr_name, UV attr_value)
 314 {
 315     if (attr_type == NPattr_LEAFSIZE && !attr_value)
 316         return 0; /* ignore zero sized leaf items */
 317     np_walk_new_nodes(aTHX_ st, npath_node, NULL, np_dump_formatted_node);
 318     np_dump_indent(npath_node->depth+1);
 319     switch (attr_type) {
 320     case NPattr_LEAFSIZE:
 321         fprintf(stderr, "+%ld %s =%ld", attr_value, attr_name, attr_value+st->total_size);
 322         break;
 323     case NPattr_NAME:
 324         fprintf(stderr, "~NAMED('%s') %lu", attr_name, attr_value);
 325         break;
 326     case NPattr_NOTE:
 327         fprintf(stderr, "~note %s %lu", attr_name, attr_value);
 328         break;
 329     case NPattr_PADTMP:
 330     case NPattr_PADNAME:
 331     case NPattr_PADFAKE:
 332         fprintf(stderr, "~pad%lu %s %lu", attr_type, attr_name, attr_value);
 333         break;
 334     default:
 335         fprintf(stderr, "~??? %s %lu", attr_name, attr_value);
 336         break;
 337     }
 338     fprintf(stderr, "\n");
 339     return 0;
 340 }
 341
 342 int
 343 np_stream_formatted_node(pTHX_ struct state *st, npath_node_t *npath_node, npath_node_t *npath_node_deeper) {
 344     fprintf(st->node_stream_fh, "-%u %lu %u ",
 345         npath_node->type, npath_node->seqn, (unsigned)npath_node->depth
 346     );
 347     np_print_node_name(aTHX_ st->node_stream_fh, npath_node);
 348     fprintf(st->node_stream_fh, "\n");
 349     return 0;
 350 }
 351
 352 int
 353 np_stream_node_path_info(pTHX_ struct state *st, npath_node_t *npath_node, UV attr_type, const char *attr_name, UV attr_value)
 354 {
 355     if (!attr_type && !attr_value)
 356         return 0; /* ignore zero sized leaf items */
 357     np_walk_new_nodes(aTHX_ st, npath_node, NULL, np_stream_formatted_node);
 358     if (attr_type) { /* Attribute type, name and value */
 359         fprintf(st->node_stream_fh, "%lu %lu ", attr_type, npath_node->seqn);
 360     }
 361     else { /* Leaf name and memory size */
 362         fprintf(st->node_stream_fh, "L %lu ", npath_node->seqn);
 363     }
 364     fprintf(st->node_stream_fh, "%lu %s\n", attr_value, attr_name);
 365     return 0;
 366 }
 367
 368
 369 #endif /* PATH_TRACKING */
 370
 371
 372 /*
 373     Checks to see if thing is in the bitstring.
 374     Returns true or false, and
 375     notes thing in the segmented bitstring.
 376  */
 377 static bool
 378 check_new(struct state *st, const void *const p) {
 379     unsigned int bits = 8 * sizeof(void*);
 380     const size_t raw_p = PTR2nat(p);
 381     /* This effectively rotates the value right by the number of low always-0
 382        bits in an aligned pointer. The assmption is that most (if not all)
 383        pointers are aligned, and these will be in the same chain of nodes
 384        (and hence hot in the cache) but we can still deal with any unaligned
 385        pointers.  */
 386     const size_t cooked_p
 387         = (raw_p >> ALIGN_BITS) | (raw_p << (bits - ALIGN_BITS));
 388     const U8 this_bit = 1 << (cooked_p & 0x7);
 389     U8 **leaf_p;
 390     U8 *leaf;
 391     unsigned int i;
 392     void **tv_p = (void **) (st->tracking);
 393
 394     if (NULL == p) return FALSE;
 395     TRY_TO_CATCH_SEGV {
 396         const char c = *(const char *)p;
 397     }
 398     CAUGHT_EXCEPTION {
 399         if (st->dangle_whine)
 400             warn( "Devel::Size: Encountered invalid pointer: %p\n", p );
 401         return FALSE;
 402     }
 403     TAG;
 404
 405     bits -= 8;
 406     /* bits now 24 (32 bit pointers) or 56 (64 bit pointers) */
 407
 408     /* First level is always present.  */
 409     do {
 410         i = (unsigned int)((cooked_p >> bits) & 0xFF);
 411         if (!tv_p[i])
 412             Newxz(tv_p[i], 256, void *);
 413         tv_p = (void **)(tv_p[i]);
 414         bits -= 8;
 415     } while (bits > LEAF_BITS + BYTE_BITS);
 416     /* bits now 16 always */
 417 #if !defined(MULTIPLICITY) || PERL_VERSION > 8 || (PERL_VERSION == 8 && PERL_SUBVERSION > 8)
 418     /* 5.8.8 and early have an assert() macro that uses Perl_croak, hence needs
 419        a my_perl under multiplicity  */
 420     assert(bits == 16);
 421 #endif
 422     leaf_p = (U8 **)tv_p;
 423     i = (unsigned int)((cooked_p >> bits) & 0xFF);
 424     if (!leaf_p[i])
 425         Newxz(leaf_p[i], 1 << LEAF_BITS, U8);
 426     leaf = leaf_p[i];
 427
 428     TAG;
 429
 430     i = (unsigned int)((cooked_p >> BYTE_BITS) & LEAF_MASK);
 431
 432     if(leaf[i] & this_bit)
 433         return FALSE;
 434
 435     leaf[i] |= this_bit;
 436     return TRUE;
 437 }
 438
 439 static void
 440 free_tracking_at(void **tv, int level)
 441 {
 442     int i = 255;
 443
 444     if (--level) {
 445         /* Nodes */
 446         do {
 447             if (tv[i]) {
 448                 free_tracking_at((void **) tv[i], level);
 449                 Safefree(tv[i]);
 450             }
 451         } while (i--);
 452     } else {
 453         /* Leaves */
 454         do {
 455             if (tv[i])
 456                 Safefree(tv[i]);
 457         } while (i--);
 458     }
 459 }
 460
 461 static void
 462 free_state(pTHX_ struct state *st)
 463 {
 464     const int top_level = (sizeof(void *) * 8 - LEAF_BITS - BYTE_BITS) / 8;
 465     if (st->free_state_cb)
 466         st->free_state_cb(aTHX_ st);
 467     if (st->state_cb_data)
 468         Safefree(st->state_cb_data);
 469     free_tracking_at((void **)st->tracking, top_level);
 470     Safefree(st);
 471 }
 472
 473 /* For now, this is somewhat a compatibility bodge until the plan comes
 474    together for fine grained recursion control. total_size() would recurse into
 475    hash and array members, whereas sv_size() would not. However, sv_size() is
 476    called with CvSTASH() of a CV, which means that if it (also) starts to
 477    recurse fully, then the size of any CV now becomes the size of the entire
 478    symbol table reachable from it, and potentially the entire symbol table, if
 479    any subroutine makes a reference to a global (such as %SIG). The historical
 480    implementation of total_size() didn't report "everything", and changing the
 481    only available size to "everything" doesn't feel at all useful.  */
 482
 483 #define NO_RECURSION 0
 484 #define SOME_RECURSION 1
 485 #define TOTAL_SIZE_RECURSION 2
 486
 487 static void sv_size(pTHX_ struct state *, pPATH, const SV *const, const int recurse);
 488
 489 typedef enum {
 490     OPc_NULL,   /* 0 */
 491     OPc_BASEOP, /* 1 */
 492     OPc_UNOP,   /* 2 */
 493     OPc_BINOP,  /* 3 */
 494     OPc_LOGOP,  /* 4 */
 495     OPc_LISTOP, /* 5 */
 496     OPc_PMOP,   /* 6 */
 497     OPc_SVOP,   /* 7 */
 498     OPc_PADOP,  /* 8 */
 499     OPc_PVOP,   /* 9 */
 500     OPc_LOOP,   /* 10 */
 501     OPc_COP /* 11 */
 502 #ifdef OA_CONDOP
 503     , OPc_CONDOP /* 12 */
 504 #endif
 505 #ifdef OA_GVOP
 506     , OPc_GVOP /* 13 */
 507 #endif
 508
 509 } opclass;
 510
 511 static opclass
 512 cc_opclass(const OP * const o)
 513 {
 514     if (!o)
 515     return OPc_NULL;
 516     TRY_TO_CATCH_SEGV {
 517         if (o->op_type == 0)
 518         return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
 519
 520         if (o->op_type == OP_SASSIGN)
 521         return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPc_UNOP : OPc_BINOP);
 522
 523     #ifdef USE_ITHREADS
 524         if (o->op_type == OP_GV || o->op_type == OP_GVSV || o->op_type == OP_AELEMFAST)
 525         return OPc_PADOP;
 526     #endif
 527
 528         if ((o->op_type == OP_TRANS)) {
 529           return OPc_BASEOP;
 530         }
 531
 532         switch (PL_opargs[o->op_type] & OA_CLASS_MASK) {
 533         case OA_BASEOP: TAG;
 534         return OPc_BASEOP;
 535
 536         case OA_UNOP: TAG;
 537         return OPc_UNOP;
 538
 539         case OA_BINOP: TAG;
 540         return OPc_BINOP;
 541
 542         case OA_LOGOP: TAG;
 543         return OPc_LOGOP;
 544
 545         case OA_LISTOP: TAG;
 546         return OPc_LISTOP;
 547
 548         case OA_PMOP: TAG;
 549         return OPc_PMOP;
 550
 551         case OA_SVOP: TAG;
 552         return OPc_SVOP;
 553
 554 #ifdef OA_PADOP
 555         case OA_PADOP: TAG;
 556         return OPc_PADOP;
 557 #endif
 558
 559 #ifdef OA_GVOP
 560         case OA_GVOP: TAG;
 561         return OPc_GVOP;
 562 #endif
 563
 564 #ifdef OA_PVOP_OR_SVOP
 565         case OA_PVOP_OR_SVOP: TAG;
 566             /*
 567              * Character translations (tr///) are usually a PVOP, keeping a
 568              * pointer to a table of shorts used to look up translations.
 569              * Under utf8, however, a simple table isn't practical; instead,
 570              * the OP is an SVOP, and the SV is a reference to a swash
 571              * (i.e., an RV pointing to an HV).
 572              */
 573         return (o->op_private & (OPpTRANS_TO_UTF|OPpTRANS_FROM_UTF))
 574             ? OPc_SVOP : OPc_PVOP;
 575 #endif
 576
 577         case OA_LOOP: TAG;
 578         return OPc_LOOP;
 579
 580         case OA_COP: TAG;
 581         return OPc_COP;
 582
 583         case OA_BASEOP_OR_UNOP: TAG;
 584         /*
 585          * UNI(OP_foo) in toke.c returns token UNI or FUNC1 depending on
 586          * whether parens were seen. perly.y uses OPf_SPECIAL to
 587          * signal whether a BASEOP had empty parens or none.
 588          * Some other UNOPs are created later, though, so the best
 589          * test is OPf_KIDS, which is set in newUNOP.
 590          */
 591         return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
 592
 593         case OA_FILESTATOP: TAG;
 594         /*
 595          * The file stat OPs are created via UNI(OP_foo) in toke.c but use
 596          * the OPf_REF flag to distinguish between OP types instead of the
 597          * usual OPf_SPECIAL flag. As usual, if OPf_KIDS is set, then we
 598          * return OPc_UNOP so that walkoptree can find our children. If
 599          * OPf_KIDS is not set then we check OPf_REF. Without OPf_REF set
 600          * (no argument to the operator) it's an OP; with OPf_REF set it's
 601          * an SVOP (and op_sv is the GV for the filehandle argument).
 602          */
 603         return ((o->op_flags & OPf_KIDS) ? OPc_UNOP :
 604     #ifdef USE_ITHREADS
 605             (o->op_flags & OPf_REF) ? OPc_PADOP : OPc_BASEOP);
 606     #else
 607             (o->op_flags & OPf_REF) ? OPc_SVOP : OPc_BASEOP);
 608     #endif
 609         case OA_LOOPEXOP: TAG;
 610         /*
 611          * next, last, redo, dump and goto use OPf_SPECIAL to indicate that a
 612          * label was omitted (in which case it's a BASEOP) or else a term was
 613          * seen. In this last case, all except goto are definitely PVOP but
 614          * goto is either a PVOP (with an ordinary constant label), an UNOP
 615          * with OPf_STACKED (with a non-constant non-sub) or an UNOP for
 616          * OP_REFGEN (with goto &sub) in which case OPf_STACKED also seems to
 617          * get set.
 618          */
 619         if (o->op_flags & OPf_STACKED)
 620             return OPc_UNOP;
 621         else if (o->op_flags & OPf_SPECIAL)
 622             return OPc_BASEOP;
 623         else
 624             return OPc_PVOP;
 625
 626 #ifdef OA_CONDOP
 627         case OA_CONDOP: TAG;
 628             return OPc_CONDOP;
 629 #endif
 630         }
 631         warn("Devel::Size: Can't determine class of operator %s, assuming BASEOP\n",
 632          PL_op_name[o->op_type]);
 633     }
 634     CAUGHT_EXCEPTION { }
 635     return OPc_BASEOP;
 636 }
 637
 638 /* Figure out how much magic is attached to the SV and return the
 639    size */
 640 static void
 641 magic_size(pTHX_ const SV * const thing, struct state *st, pPATH) {
 642   dNPathNodes(1, NPathArg);
 643   MAGIC *magic_pointer = SvMAGIC(thing); /* caller ensures thing is SvMAGICAL */
 644
 645   /* push a dummy node for NPathSetNode to update inside the while loop */
 646   NPathPushNode("dummy", NPtype_NAME);
 647
 648   /* Have we seen the magic pointer?  (NULL has always been seen before)  */
 649   while (check_new(st, magic_pointer)) {
 650
 651     NPathSetNode(magic_pointer, NPtype_MAGIC);
 652
 653     ADD_SIZE(st, "mg", sizeof(MAGIC));
 654     /* magic vtables aren't freed when magic is freed, so don't count them.
 655        (They are static structures. Anything that assumes otherwise is buggy.)
 656     */
 657
 658
 659     TRY_TO_CATCH_SEGV {
 660         /* XXX only chase mg_obj if mg->mg_flags & MGf_REFCOUNTED ? */
 661         sv_size(aTHX_ st, NPathLink("mg_obj"), magic_pointer->mg_obj, TOTAL_SIZE_RECURSION);
 662         if (magic_pointer->mg_len == HEf_SVKEY) {
 663             sv_size(aTHX_ st, NPathLink("mg_ptr"), (SV *)magic_pointer->mg_ptr, TOTAL_SIZE_RECURSION);
 664         }
 665 #if defined(PERL_MAGIC_utf8) && defined (PERL_MAGIC_UTF8_CACHESIZE)
 666         else if (magic_pointer->mg_type == PERL_MAGIC_utf8) {
 667             if (check_new(st, magic_pointer->mg_ptr)) {
 668                 ADD_SIZE(st, "PERL_MAGIC_utf8", PERL_MAGIC_UTF8_CACHESIZE * 2 * sizeof(STRLEN));
 669             }
 670         }
 671 #endif
 672         /* XXX also handle mg->mg_type == PERL_MAGIC_utf8 ? */
 673         else if (magic_pointer->mg_len > 0) {
 674             if(0)do_magic_dump(0, Perl_debug_log, magic_pointer, 0, 0, FALSE, 0);
 675             if (check_new(st, magic_pointer->mg_ptr)) {
 676                 ADD_SIZE(st, "mg_len", magic_pointer->mg_len);
 677             }
 678         }
 679
 680         /* Get the next in the chain */
 681         magic_pointer = magic_pointer->mg_moremagic;
 682     }
 683     CAUGHT_EXCEPTION {
 684         if (st->dangle_whine)
 685             warn( "Devel::Size: Encountered bad magic at: %p\n", magic_pointer );
 686     }
 687   }
 688 }
 689
 690 #define check_new_and_strlen(st, p, ppath) S_check_new_and_strlen(aTHX_ st, p, ppath)
 691 static void
 692 S_check_new_and_strlen(pTHX_ struct state *st, const char *const p, pPATH) {
 693     dNPathNodes(1, NPathArg->prev);
 694     if(check_new(st, p)) {
 695         NPathPushNode(NPathArg->id, NPtype_NAME);
 696         ADD_SIZE(st, NPathArg->id, 1 + strlen(p));
 697     }
 698 }
 699
 700 static void
 701 regex_size(pTHX_ const REGEXP * const baseregex, struct state *st, pPATH) {
 702     dNPathNodes(1, NPathArg);
 703     if(!check_new(st, baseregex))
 704         return;
 705   NPathPushNode("regex_size", NPtype_NAME);
 706   ADD_SIZE(st, "REGEXP", sizeof(REGEXP));
 707 #if (PERL_VERSION < 11)
 708   /* Note the size of the paren offset thing */
 709   ADD_SIZE(st, "nparens", sizeof(I32) * baseregex->nparens * 2);
 710   ADD_SIZE(st, "precomp", strlen(baseregex->precomp));
 711 #else
 712   ADD_SIZE(st, "regexp", sizeof(struct regexp));
 713   ADD_SIZE(st, "nparens", sizeof(I32) * SvANY(baseregex)->nparens * 2);
 714   /*ADD_SIZE(st, strlen(SvANY(baseregex)->subbeg));*/
 715 #endif
 716   if (st->go_yell && !st->regex_whine) {
 717     carp("Devel::Size: Calculated sizes for compiled regexes are incompatible, and probably always will be");
 718     st->regex_whine = 1;
 719   }
 720 }
 721
 722 static void
 723 hek_size(pTHX_ struct state *st, HEK *hek, U32 shared, pPATH)
 724 {
 725     dNPathNodes(1, NPathArg);
 726
 727     /* Hash keys can be shared. Have we seen this before? */
 728     if (!check_new(st, hek))
 729         return;
 730     NPathPushNode("hek", NPtype_NAME);
 731     ADD_SIZE(st, "hek_len", HEK_BASESIZE + hek->hek_len
 732 #if PERL_VERSION < 8
 733         + 1 /* No hash key flags prior to 5.8.0  */
 734 #else
 735         + 2
 736 #endif
 737         );
 738     if (shared) {
 739 #if PERL_VERSION < 10
 740         ADD_SIZE(st, "he", sizeof(struct he));
 741 #else
 742         ADD_SIZE(st, "shared_he", STRUCT_OFFSET(struct shared_he, shared_he_hek));
 743 #endif
 744     }
 745 }
 746
 747 static void
 748 refcounted_he_size(pTHX_ struct state *st, struct refcounted_he *he, pPATH)
 749 {
 750   dNPathNodes(1, NPathArg);
 751   if (!check_new(st, he))
 752     return;
 753   NPathPushNode("refcounted_he_size", NPtype_NAME);
 754   ADD_SIZE(st, "refcounted_he", sizeof(struct refcounted_he));
 755
 756 #ifdef USE_ITHREADS
 757   ADD_SIZE(st, "refcounted_he_data", NPtype_NAME);
 758 #else
 759   hek_size(aTHX_ st, he->refcounted_he_hek, 0, NPathLink("refcounted_he_hek"));
 760 #endif
 761
 762   if (he->refcounted_he_next)
 763     refcounted_he_size(aTHX_ st, he->refcounted_he_next, NPathLink("refcounted_he_next"));
 764 }
 765
 766 static void op_size_class(pTHX_ const OP * const baseop, opclass op_class, bool skip_op_struct, struct state *st, pPATH);
 767
 768 static void
 769 op_size(pTHX_ const OP * const baseop, struct state *st, pPATH)
 770 {
 771   op_size_class(aTHX_ baseop, cc_opclass(baseop), 0, st, NPathArg);
 772 }
 773
 774 static void
 775 op_size_class(pTHX_ const OP * const baseop, opclass op_class, bool skip_op_struct, struct state *st, pPATH)
 776 {
 777     /* op_size recurses to follow the chain of opcodes.  For the node path we
 778      * don't want the chain to be 'nested' in the path so we use dNPathUseParent().
 779      * Also, to avoid a link-to-a-link the caller should use NPathLinkAndNode()
 780      * instead of NPathLink().
 781      */
 782     dNPathUseParent(NPathArg);
 783
 784     TRY_TO_CATCH_SEGV {
 785         TAG;
 786         if(!check_new(st, baseop))
 787             return;
 788         TAG;
 789         op_size(aTHX_ baseop->op_next, st, NPathOpLink);
 790 #ifdef PELR_MAD
 791         madprop_size(aTHX_ st, NPathOpLink, baseop->op_madprop);
 792 #endif
 793         TAG;
 794         switch (op_class) {
 795         case OPc_BASEOP: TAG;
 796             if (!skip_op_struct)
 797                 ADD_SIZE(st, "op", sizeof(struct op));
 798             TAG;break;
 799         case OPc_UNOP: TAG;
 800             if (!skip_op_struct)
 801                 ADD_SIZE(st, "unop", sizeof(struct unop));
 802             op_size(aTHX_ ((UNOP *)baseop)->op_first, st, NPathOpLink);
 803             TAG;break;
 804         case OPc_BINOP: TAG;
 805             if (!skip_op_struct)
 806                 ADD_SIZE(st, "binop", sizeof(struct binop));
 807             op_size(aTHX_ ((BINOP *)baseop)->op_first, st, NPathOpLink);
 808             op_size(aTHX_ ((BINOP *)baseop)->op_last, st, NPathOpLink);
 809             TAG;break;
 810         case OPc_LOGOP: TAG;
 811             if (!skip_op_struct)
 812                 ADD_SIZE(st, "logop", sizeof(struct logop));
 813             op_size(aTHX_ ((BINOP *)baseop)->op_first, st, NPathOpLink);
 814             op_size(aTHX_ ((LOGOP *)baseop)->op_other, st, NPathOpLink);
 815             TAG;break;
 816 #ifdef OA_CONDOP
 817         case OPc_CONDOP: TAG;
 818             if (!skip_op_struct)
 819                 ADD_SIZE(st, "condop", sizeof(struct condop));
 820             op_size(aTHX_ ((BINOP *)baseop)->op_first, st, NPathOpLink);
 821             op_size(aTHX_ ((CONDOP *)baseop)->op_true, st, NPathOpLink);
 822             op_size(aTHX_ ((CONDOP *)baseop)->op_false, st, NPathOpLink);
 823             TAG;break;
 824 #endif
 825         case OPc_LISTOP: TAG;
 826             if (!skip_op_struct)
 827                 ADD_SIZE(st, "listop", sizeof(struct listop));
 828             op_size(aTHX_ ((LISTOP *)baseop)->op_first, st, NPathOpLink);
 829             op_size(aTHX_ ((LISTOP *)baseop)->op_last, st, NPathOpLink);
 830             TAG;break;
 831         case OPc_PMOP: TAG;
 832             if (!skip_op_struct)
 833                 ADD_SIZE(st, "pmop", sizeof(struct pmop));
 834             op_size(aTHX_ ((PMOP *)baseop)->op_first, st, NPathOpLink);
 835             op_size(aTHX_ ((PMOP *)baseop)->op_last, st, NPathOpLink);
 836 #if PERL_VERSION < 9 || (PERL_VERSION == 9 && PERL_SUBVERSION < 5)
 837             op_size(aTHX_ ((PMOP *)baseop)->op_pmreplroot, st, NPathOpLink);
 838             op_size(aTHX_ ((PMOP *)baseop)->op_pmreplstart, st, NPathOpLink);
 839 #endif
 840             /* This is defined away in perl 5.8.x, but it is in there for
 841                5.6.x */
 842 #ifdef PM_GETRE
 843             regex_size(aTHX_ PM_GETRE((PMOP *)baseop), st, NPathLink("PM_GETRE"));
 844 #else
 845             regex_size(aTHX_ ((PMOP *)baseop)->op_pmregexp, st, NPathLink("op_pmregexp"));
 846 #endif
 847             TAG;break;
 848         case OPc_SVOP: TAG;
 849             if (!skip_op_struct)
 850                 ADD_SIZE(st, "svop", sizeof(struct svop));
 851             if (!(baseop->op_type == OP_AELEMFAST
 852                   && baseop->op_flags & OPf_SPECIAL)) {
 853                 /* not an OP_PADAV replacement */
 854                 sv_size(aTHX_ st, NPathLink("SVOP"), ((SVOP *)baseop)->op_sv, SOME_RECURSION);
 855             }
 856             TAG;break;
 857 #ifdef OA_PADOP
 858         case OPc_PADOP: TAG;
 859             if (!skip_op_struct)
 860                 ADD_SIZE(st, "padop", sizeof(struct padop));
 861             TAG;break;
 862 #endif
 863 #ifdef OA_GVOP
 864         case OPc_GVOP: TAG;
 865             if (!skip_op_struct)
 866                 ADD_SIZE(st, "gvop", sizeof(struct gvop));
 867             sv_size(aTHX_ st, NPathLink("GVOP"), ((GVOP *)baseop)->op_gv, SOME_RECURSION);
 868             TAG;break;
 869 #endif
 870         case OPc_PVOP: TAG;
 871             check_new_and_strlen(st, ((PVOP *)baseop)->op_pv, NPathLink("op_pv"));
 872             TAG;break;
 873         case OPc_LOOP: TAG;
 874             if (!skip_op_struct)
 875                 ADD_SIZE(st, "loop", sizeof(struct loop));
 876             op_size(aTHX_ ((LOOP *)baseop)->op_first, st, NPathOpLink);
 877             op_size(aTHX_ ((LOOP *)baseop)->op_last, st, NPathOpLink);
 878             op_size(aTHX_ ((LOOP *)baseop)->op_redoop, st, NPathOpLink);
 879             op_size(aTHX_ ((LOOP *)baseop)->op_nextop, st, NPathOpLink);
 880             op_size(aTHX_ ((LOOP *)baseop)->op_lastop, st, NPathOpLink);
 881             TAG;break;
 882         case OPc_COP: TAG;
 883         {
 884           COP *basecop;
 885           COPHH *hh;
 886           basecop = (COP *)baseop;
 887           if (!skip_op_struct)
 888             ADD_SIZE(st, "cop", sizeof(struct cop));
 889
 890           /* Change 33656 by nicholas@mouse-mill on 2008/04/07 11:29:51
 891           Eliminate cop_label from struct cop by storing a label as the first
 892           entry in the hints hash. Most statements don't have labels, so this
 893           will save memory. Not sure how much.
 894           The check below will be incorrect fail on bleadperls
 895           before 5.11 @33656, but later than 5.10, producing slightly too
 896           small memory sizes on these Perls. */
 897 #if (PERL_VERSION < 11)
 898           check_new_and_strlen(st, basecop->cop_label, NPathLink("cop_label"));
 899 #endif
 900 #ifdef USE_ITHREADS
 901           check_new_and_strlen(st, basecop->cop_file, NPathLink("cop_file"));
 902           check_new_and_strlen(st, basecop->cop_stashpv, NPathLink("cop_stashpv"));
 903 #else
 904           if (SvREFCNT(basecop->cop_stash) == 1) /* XXX hack? */
 905             sv_size(aTHX_ st, NPathLink("cop_stash"), (SV *)basecop->cop_stash, SOME_RECURSION);
 906           sv_size(aTHX_ st, NPathLink("cop_filegv"), (SV *)basecop->cop_filegv, SOME_RECURSION);
 907 #endif
 908
 909           hh = CopHINTHASH_get(basecop);
 910           refcounted_he_size(aTHX_ st, hh, NPathLink("cop_hints_hash"));
 911         }
 912         TAG;break;
 913       default:
 914         TAG;break;
 915       }
 916   }
 917   CAUGHT_EXCEPTION {
 918       if (st->dangle_whine)
 919           warn( "Devel::Size: Encountered dangling pointer in opcode at: %p\n", baseop );
 920   }
 921 }
 922
 923 #if PERL_VERSION < 8 || PERL_SUBVERSION < 9
 924 #  define SVt_LAST 16
 925 #endif
 926
 927 #ifdef PURIFY
 928 #  define MAYBE_PURIFY(normal, pure) (pure)
 929 #  define MAYBE_OFFSET(struct_name, member) 0
 930 #else
 931 #  define MAYBE_PURIFY(normal, pure) (normal)
 932 #  define MAYBE_OFFSET(struct_name, member) STRUCT_OFFSET(struct_name, member)
 933 #endif
 934
 935 const U8 body_sizes[SVt_LAST] = {
 936 #if PERL_VERSION < 9
 937      0,                                                       /* SVt_NULL */
 938      MAYBE_PURIFY(sizeof(IV), sizeof(XPVIV)),                 /* SVt_IV */
 939      MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)),                 /* SVt_NV */
 940      sizeof(XRV),                                             /* SVt_RV */
 941      sizeof(XPV),                                             /* SVt_PV */
 942      sizeof(XPVIV),                                           /* SVt_PVIV */
 943      sizeof(XPVNV),                                           /* SVt_PVNV */
 944      sizeof(XPVMG),                                           /* SVt_PVMG */
 945      sizeof(XPVBM),                                           /* SVt_PVBM */
 946      sizeof(XPVLV),                                           /* SVt_PVLV */
 947      sizeof(XPVAV),                                           /* SVt_PVAV */
 948      sizeof(XPVHV),                                           /* SVt_PVHV */
 949      sizeof(XPVCV),                                           /* SVt_PVCV */
 950      sizeof(XPVGV),                                           /* SVt_PVGV */
 951      sizeof(XPVFM),                                           /* SVt_PVFM */
 952      sizeof(XPVIO)                                            /* SVt_PVIO */
 953 #elif PERL_VERSION == 10 && PERL_SUBVERSION == 0
 954      0,                                                       /* SVt_NULL */
 955      0,                                                       /* SVt_BIND */
 956      0,                                                       /* SVt_IV */
 957      MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)),                 /* SVt_NV */
 958      0,                                                       /* SVt_RV */
 959      MAYBE_PURIFY(sizeof(xpv_allocated), sizeof(XPV)),        /* SVt_PV */
 960      MAYBE_PURIFY(sizeof(xpviv_allocated), sizeof(XPVIV)),/* SVt_PVIV */
 961      sizeof(XPVNV),                                           /* SVt_PVNV */
 962      sizeof(XPVMG),                                           /* SVt_PVMG */
 963      sizeof(XPVGV),                                           /* SVt_PVGV */
 964      sizeof(XPVLV),                                           /* SVt_PVLV */
 965      MAYBE_PURIFY(sizeof(xpvav_allocated), sizeof(XPVAV)),/* SVt_PVAV */
 966      MAYBE_PURIFY(sizeof(xpvhv_allocated), sizeof(XPVHV)),/* SVt_PVHV */
 967      MAYBE_PURIFY(sizeof(xpvcv_allocated), sizeof(XPVCV)),/* SVt_PVCV */
 968      MAYBE_PURIFY(sizeof(xpvfm_allocated), sizeof(XPVFM)),/* SVt_PVFM */
 969      sizeof(XPVIO),                                           /* SVt_PVIO */
 970 #elif PERL_VERSION == 10 && PERL_SUBVERSION == 1
 971      0,                                                       /* SVt_NULL */
 972      0,                                                       /* SVt_BIND */
 973      0,                                                       /* SVt_IV */
 974      MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)),                 /* SVt_NV */
 975      0,                                                       /* SVt_RV */
 976      sizeof(XPV) - MAYBE_OFFSET(XPV, xpv_cur),                /* SVt_PV */
 977      sizeof(XPVIV) - MAYBE_OFFSET(XPV, xpv_cur),              /* SVt_PVIV */
 978      sizeof(XPVNV),                                           /* SVt_PVNV */
 979      sizeof(XPVMG),                                           /* SVt_PVMG */
 980      sizeof(XPVGV),                                           /* SVt_PVGV */
 981      sizeof(XPVLV),                                           /* SVt_PVLV */
 982      sizeof(XPVAV) - MAYBE_OFFSET(XPVAV, xav_fill),           /* SVt_PVAV */
 983      sizeof(XPVHV) - MAYBE_OFFSET(XPVHV, xhv_fill),           /* SVt_PVHV */
 984      sizeof(XPVCV) - MAYBE_OFFSET(XPVCV, xpv_cur),            /* SVt_PVCV */
 985      sizeof(XPVFM) - MAYBE_OFFSET(XPVFM, xpv_cur),            /* SVt_PVFM */
 986      sizeof(XPVIO)                                            /* SVt_PVIO */
 987 #elif PERL_VERSION < 13
 988      0,                                                       /* SVt_NULL */
 989      0,                                                       /* SVt_BIND */
 990      0,                                                       /* SVt_IV */
 991      MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)),                 /* SVt_NV */
 992      sizeof(XPV) - MAYBE_OFFSET(XPV, xpv_cur),                /* SVt_PV */
 993      sizeof(XPVIV) - MAYBE_OFFSET(XPV, xpv_cur),              /* SVt_PVIV */
 994      sizeof(XPVNV),                                           /* SVt_PVNV */
 995      sizeof(XPVMG),                                           /* SVt_PVMG */
 996      sizeof(regexp) - MAYBE_OFFSET(regexp, xpv_cur),          /* SVt_REGEXP */
 997      sizeof(XPVGV),                                           /* SVt_PVGV */
 998      sizeof(XPVLV),                                           /* SVt_PVLV */
 999      sizeof(XPVAV) - MAYBE_OFFSET(XPVAV, xav_fill),           /* SVt_PVAV */
1000      sizeof(XPVHV) - MAYBE_OFFSET(XPVHV, xhv_fill),           /* SVt_PVHV */
1001      sizeof(XPVCV) - MAYBE_OFFSET(XPVCV, xpv_cur),            /* SVt_PVCV */
1002      sizeof(XPVFM) - MAYBE_OFFSET(XPVFM, xpv_cur),            /* SVt_PVFM */
1003      sizeof(XPVIO)                                            /* SVt_PVIO */
1004 #else
1005      0,                                                       /* SVt_NULL */
1006      0,                                                       /* SVt_BIND */
1007      0,                                                       /* SVt_IV */
1008      MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)),                 /* SVt_NV */
1009      sizeof(XPV) - MAYBE_OFFSET(XPV, xpv_cur),                /* SVt_PV */
1010      sizeof(XPVIV) - MAYBE_OFFSET(XPV, xpv_cur),              /* SVt_PVIV */
1011      sizeof(XPVNV) - MAYBE_OFFSET(XPV, xpv_cur),              /* SVt_PVNV */
1012      sizeof(XPVMG),                                           /* SVt_PVMG */
1013      sizeof(regexp),                                          /* SVt_REGEXP */
1014      sizeof(XPVGV),                                           /* SVt_PVGV */
1015      sizeof(XPVLV),                                           /* SVt_PVLV */
1016      sizeof(XPVAV),                                           /* SVt_PVAV */
1017      sizeof(XPVHV),                                           /* SVt_PVHV */
1018      sizeof(XPVCV),                                           /* SVt_PVCV */
1019      sizeof(XPVFM),                                           /* SVt_PVFM */
1020      sizeof(XPVIO)                                            /* SVt_PVIO */
1021 #endif
1022 };
1023
1024
1025 /* based on Perl_do_dump_pad() - wraps sv_size and adds ADD_ATTR calls for the pad names */
1026 static void
1027 padlist_size(pTHX_ struct state *const st, pPATH, PADLIST *padlist,
1028         const int recurse)
1029 {
1030     dNPathUseParent(NPathArg);
1031     const AV *pad_name;
1032     SV **pname;
1033     I32 ix;
1034
1035     if (!padlist)
1036         return;
1037     if( 0 && !check_new(st, padlist))
1038         return;
1039
1040     pad_name = MUTABLE_AV(*av_fetch(MUTABLE_AV(padlist), 0, FALSE));
1041     pname = AvARRAY(pad_name);
1042
1043     for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
1044         const SV *namesv = pname[ix];
1045         if (namesv && namesv == &PL_sv_undef) {
1046             namesv = NULL;
1047         }
1048         if (namesv) {
1049             /* SvFAKE: On a pad name SV, that slot in the frame AV is a REFCNT'ed reference to a lexical from "outside" */
1050             if (SvFAKE(namesv))
1051                 ADD_ATTR(st, NPattr_PADFAKE, SvPVX_const(namesv), ix);
1052             else
1053                 ADD_ATTR(st, NPattr_PADNAME, SvPVX_const(namesv), ix);
1054         }
1055         else {
1056             ADD_ATTR(st, NPattr_PADTMP, "SVs_PADTMP", ix);
1057         }
1058
1059     }
1060     sv_size(aTHX_ st, NPathArg, (SV*)padlist, recurse);
1061 }
1062
1063
1064 static void
1065 sv_size(pTHX_ struct state *const st, pPATH, const SV * const orig_thing,
1066         const int recurse) {
1067   const SV *thing = orig_thing;
1068   dNPathNodes(3, NPathArg);
1069   U32 type;
1070
1071   if(!check_new(st, orig_thing))
1072       return;
1073
1074   type = SvTYPE(thing);
1075   if (type > SVt_LAST) {
1076       warn("Devel::Size: Unknown variable type: %d encountered\n", type);
1077       return;
1078   }
1079   NPathPushNode(thing, NPtype_SV);
1080   ADD_SIZE(st, "sv_head", sizeof(SV));
1081   ADD_SIZE(st, "sv_body", body_sizes[type]);
1082
1083   switch (type) {
1084 #if (PERL_VERSION < 11)
1085     /* Is it a reference? */
1086   case SVt_RV: TAG;
1087 #else
1088   case SVt_IV: TAG;
1089 #endif
1090     if(recurse && SvROK(thing)) /* XXX maybe don't follow weakrefs */
1091         sv_size(aTHX_ st, (SvWEAKREF(thing) ? NPathLink("weakRV") : NPathLink("RV")), SvRV_const(thing), recurse);
1092     TAG;break;
1093
1094   case SVt_PVAV: TAG;
1095     /* Is there anything in the array? */
1096     if (AvMAX(thing) != -1) {
1097       /* an array with 10 slots has AvMax() set to 9 - te 2007-04-22 */
1098       ADD_SIZE(st, "av_max", sizeof(SV *) * (AvMAX(thing) + 1));
1099       dbg_printf(("total_size: %li AvMAX: %li av_len: $i\n", st->total_size, AvMAX(thing), av_len((AV*)thing)));
1100
1101       if (recurse >= st->min_recurse_threshold) {
1102           SSize_t i = AvFILLp(thing) + 1;
1103
1104           while (i--) {
1105               ADD_PRE_ATTR(st, 0, "index", i);
1106               sv_size(aTHX_ st, NPathLink("AVelem"), AvARRAY(thing)[i], recurse);
1107           }
1108       }
1109     }
1110     /* Add in the bits on the other side of the beginning */
1111
1112     dbg_printf(("total_size %li, sizeof(SV *) %li, AvARRAY(thing) %li, AvALLOC(thing)%li , sizeof(ptr) %li \n",
1113         st->total_size, sizeof(SV*), AvARRAY(thing), AvALLOC(thing), sizeof( thing )));
1114
1115     /* under Perl 5.8.8 64bit threading, AvARRAY(thing) was a pointer while AvALLOC was 0,
1116        resulting in grossly overstated sized for arrays. Technically, this shouldn't happen... */
1117     if (AvALLOC(thing) != 0) {
1118       ADD_SIZE(st, "AvALLOC", (sizeof(SV *) * (AvARRAY(thing) - AvALLOC(thing))));
1119       }
1120 #if (PERL_VERSION < 9)
1121     /* Is there something hanging off the arylen element?
1122        Post 5.9.something this is stored in magic, so will be found there,
1123        and Perl_av_arylen_p() takes a non-const AV*, hence compilers rightly
1124        complain about AvARYLEN() passing thing to it.  */
1125     sv_size(aTHX_ st, NPathLink("ARYLEN"), AvARYLEN(thing), recurse);
1126 #endif
1127     TAG;break;
1128
1129   case SVt_PVHV: TAG;
1130     /* Now the array of buckets */
1131     ADD_SIZE(st, "hv_max", (sizeof(HE *) * (HvMAX(thing) + 1)));
1132     if (HvENAME(thing)) {
1133         ADD_ATTR(st, NPattr_NAME, HvENAME(thing), 0);
1134     }
1135     /* Now walk the bucket chain */
1136     if (HvARRAY(thing)) {
1137       HE *cur_entry;
1138       UV cur_bucket = 0;
1139       for (cur_bucket = 0; cur_bucket <= HvMAX(thing); cur_bucket++) {
1140         cur_entry = *(HvARRAY(thing) + cur_bucket);
1141         while (cur_entry) {
1142 /* XXX a HE should probably be a node so the keys and values are seen as pairs */
1143           ADD_SIZE(st, "he", sizeof(HE));
1144           hek_size(aTHX_ st, cur_entry->hent_hek, HvSHAREKEYS(thing), NPathLink("hent_hek"));
1145           if (recurse >= st->min_recurse_threshold) {
1146             if (orig_thing == (SV*)PL_strtab) {
1147                 /* For PL_strtab the HeVAL is used as a refcnt */
1148                 ADD_SIZE(st, "shared_hek", HeKLEN(cur_entry));
1149             }
1150             else {
1151 /* I've seen a PL_strtab HeVAL == 0xC and 0x40C etc
1152  * just running perl -Mblib -Mstrict -MDevel::Size=:all -MCarp -e 'warn perl_size()'
1153  * but it seemed like a corruption - it would change come and go with irrelevant code changes.
1154  * so we protect against that here, but I'd like to know the cause.
1155  */
1156 if (PTR2UV(HeVAL(cur_entry)) > 0xFFF)
1157               sv_size(aTHX_ st, NPathLink("HeVAL"), HeVAL(cur_entry), recurse);
1158 else warn("skipped suspect HeVAL %p", HeVAL(cur_entry));
1159             }
1160           }
1161           cur_entry = cur_entry->hent_next;
1162         }
1163       }
1164     }
1165 #ifdef HvAUX
1166     if (SvOOK(thing)) {
1167         /* This direct access is arguably "naughty": */
1168         struct mro_meta *meta = HvAUX(thing)->xhv_mro_meta;
1169 #if PERL_VERSION > 13 || PERL_SUBVERSION > 8
1170         /* As is this: */
1171         I32 count = HvAUX(thing)->xhv_name_count;
1172
1173         if (count) {
1174             HEK **names = HvAUX(thing)->xhv_name_u.xhvnameu_names;
1175             if (count < 0)
1176                 count = -count;
1177             while (--count)
1178                 hek_size(aTHX_ st, names[count], 1, NPathLink("HvAUXelem"));
1179         }
1180         else
1181 #endif
1182         {
1183             hek_size(aTHX_ st, HvNAME_HEK(thing), 1, NPathLink("HvNAME_HEK"));
1184         }
1185
1186         ADD_SIZE(st, "xpvhv_aux", sizeof(struct xpvhv_aux));
1187         if (meta) {
1188             ADD_SIZE(st, "mro_meta", sizeof(struct mro_meta));
1189             sv_size(aTHX_ st, NPathLink("mro_nextmethod"), (SV *)meta->mro_nextmethod, TOTAL_SIZE_RECURSION);
1190 #if PERL_VERSION > 10 || (PERL_VERSION == 10 && PERL_SUBVERSION > 0)
1191             sv_size(aTHX_ st, NPathLink("isa"), (SV *)meta->isa, TOTAL_SIZE_RECURSION);
1192 #endif
1193 #if PERL_VERSION > 10
1194             sv_size(aTHX_ st, NPathLink("mro_linear_all"), (SV *)meta->mro_linear_all, TOTAL_SIZE_RECURSION);
1195             sv_size(aTHX_ st, NPathLink("mro_linear_current"), meta->mro_linear_current, TOTAL_SIZE_RECURSION);
1196 #else
1197             sv_size(aTHX_ st, NPathLink("mro_linear_dfs"), (SV *)meta->mro_linear_dfs, TOTAL_SIZE_RECURSION);
1198             sv_size(aTHX_ st, NPathLink("mro_linear_c3"), (SV *)meta->mro_linear_c3, TOTAL_SIZE_RECURSION);
1199 #endif
1200         }
1201     }
1202 #else
1203     check_new_and_strlen(st, HvNAME_get(thing), NPathLink("HvNAME"));
1204 #endif
1205     TAG;break;
1206
1207
1208   case SVt_PVFM: TAG;
1209     padlist_size(aTHX_ st, NPathLink("CvPADLIST"), CvPADLIST(thing), recurse);
1210     sv_size(aTHX_ st, NPathLink("CvOUTSIDE"), (SV *)CvOUTSIDE(thing), SOME_RECURSION);
1211
1212     if (st->go_yell && !st->fm_whine) {
1213       carp("Devel::Size: Calculated sizes for FMs are incomplete");
1214       st->fm_whine = 1;
1215     }
1216     goto freescalar;
1217
1218   case SVt_PVCV: TAG;
1219     /* not CvSTASH, per https://rt.cpan.org/Ticket/Display.html?id=79366 */
1220     ADD_ATTR(st, NPattr_NAME, CvGV(thing) ? GvNAME(CvGV(thing)) : "UNDEFINED", 0);
1221     sv_size(aTHX_ st, NPathLink("CvGV"), (SV *)CvGV(thing), SOME_RECURSION);
1222     padlist_size(aTHX_ st, NPathLink("CvPADLIST"), CvPADLIST(thing), recurse);
1223     sv_size(aTHX_ st, NPathLink("CvOUTSIDE"), (SV *)CvOUTSIDE(thing), SOME_RECURSION);
1224     if (CvISXSUB(thing)) {
1225         sv_size(aTHX_ st, NPathLink("cv_const_sv"), cv_const_sv((CV *)thing), recurse);
1226     } else {
1227         if(1)op_size(aTHX_ CvSTART(thing), st, NPathLinkAndNode("CvSTART", "OPs")); /* XXX ? */
1228         op_size(aTHX_ CvROOT(thing), st, NPathLinkAndNode("CvROOT", "OPs"));
1229     }
1230     goto freescalar;
1231
1232   case SVt_PVIO: TAG;
1233     /* Some embedded char pointers */
1234     check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_top_name, NPathLink("xio_top_name"));
1235     check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_fmt_name, NPathLink("xio_fmt_name"));
1236     check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_bottom_name, NPathLink("xio_bottom_name"));
1237     /* Throw the GVs on the list to be walked if they're not-null */
1238     sv_size(aTHX_ st, NPathLink("xio_top_gv"), (SV *)((XPVIO *) SvANY(thing))->xio_top_gv, recurse);
1239     sv_size(aTHX_ st, NPathLink("xio_bottom_gv"), (SV *)((XPVIO *) SvANY(thing))->xio_bottom_gv, recurse);
1240     sv_size(aTHX_ st, NPathLink("xio_fmt_gv"), (SV *)((XPVIO *) SvANY(thing))->xio_fmt_gv, recurse);
1241
1242     /* Only go trotting through the IO structures if they're really
1243        trottable. If USE_PERLIO is defined we can do this. If
1244        not... we can't, so we don't even try */
1245 #ifdef USE_PERLIO
1246     /* Dig into xio_ifp and xio_ofp here */
1247     warn("Devel::Size: Can't size up perlio layers yet\n");
1248 #endif
1249     goto freescalar;
1250
1251   case SVt_PVLV: TAG;
1252 #if (PERL_VERSION < 9)
1253     goto freescalar;
1254 #endif
1255
1256   case SVt_PVGV: TAG;
1257     if(isGV_with_GP(thing)) {
1258 #ifdef GvNAME_HEK
1259         hek_size(aTHX_ st, GvNAME_HEK(thing), 1, NPathLink("GvNAME_HEK"));
1260 #else
1261         ADD_SIZE(st, "GvNAMELEN", GvNAMELEN(thing));
1262 #endif
1263         ADD_ATTR(st, NPattr_NAME, GvNAME_get(thing), 0);
1264 #ifdef GvFILE_HEK
1265         hek_size(aTHX_ st, GvFILE_HEK(thing), 1, NPathLink("GvFILE_HEK"));
1266 #elif defined(GvFILE)
1267 #  if !defined(USE_ITHREADS) || (PERL_VERSION > 8 || (PERL_VERSION == 8 && PERL_SUBVERSION > 8))
1268         /* With itreads, before 5.8.9, this can end up pointing to freed memory
1269            if the GV was created in an eval, as GvFILE() points to CopFILE(),
1270            and the relevant COP has been freed on scope cleanup after the eval.
1271            5.8.9 adds a binary compatible fudge that catches the vast majority
1272            of cases. 5.9.something added a proper fix, by converting the GP to
1273            use a shared hash key (porperly reference counted), instead of a
1274            char * (owned by who knows? possibly no-one now) */
1275         check_new_and_strlen(st, GvFILE(thing), NPathLink("GvFILE"));
1276 #  endif
1277 #endif
1278         /* Is there something hanging off the glob? */
1279         if (check_new(st, GvGP(thing))) {
1280             ADD_SIZE(st, "GP", sizeof(GP));
1281             sv_size(aTHX_ st, NPathLink("gp_sv"), (SV *)(GvGP(thing)->gp_sv), recurse);
1282             sv_size(aTHX_ st, NPathLink("gp_av"), (SV *)(GvGP(thing)->gp_av), recurse);
1283             sv_size(aTHX_ st, NPathLink("gp_hv"), (SV *)(GvGP(thing)->gp_hv), recurse);
1284             sv_size(aTHX_ st, NPathLink("gp_cv"), (SV *)(GvGP(thing)->gp_cv), recurse);
1285             sv_size(aTHX_ st, NPathLink("gp_egv"), (SV *)(GvGP(thing)->gp_egv), recurse);
1286             sv_size(aTHX_ st, NPathLink("gp_form"), (SV *)(GvGP(thing)->gp_form), recurse);
1287         }
1288 #if (PERL_VERSION >= 9)
1289         TAG; break;
1290 #endif
1291     }
1292 #if PERL_VERSION <= 8
1293   case SVt_PVBM: TAG;
1294 #endif
1295   case SVt_PVMG: TAG;
1296   case SVt_PVNV: TAG;
1297   case SVt_PVIV: TAG;
1298   case SVt_PV: TAG;
1299   freescalar:
1300     if(recurse && SvROK(thing))
1301         sv_size(aTHX_ st, NPathLink("RV"), SvRV_const(thing), recurse);
1302     else if (SvIsCOW_shared_hash(thing))
1303         hek_size(aTHX_ st, SvSHARED_HEK_FROM_PV(SvPVX(thing)), 1, NPathLink("SvSHARED_HEK_FROM_PV"));
1304     else
1305         ADD_SIZE(st, "SvLEN", SvLEN(thing));
1306
1307     if(SvOOK(thing)) {
1308         STRLEN len;
1309         SvOOK_offset(thing, len);
1310         ADD_SIZE(st, "SvOOK", len);
1311     }
1312     TAG;break;
1313
1314   }
1315
1316   if (type >= SVt_PVMG) {
1317     if (SvMAGICAL(thing))
1318       magic_size(aTHX_ thing, st, NPathLink("MG"));
1319     if (SvPAD_OUR(thing) && SvOURSTASH(thing))
1320       sv_size(aTHX_ st, NPathLink("SvOURSTASH"), (SV *)SvOURSTASH(thing), SOME_RECURSION);
1321     if (SvSTASH(thing))
1322       sv_size(aTHX_ st, NPathLink("SvSTASH"), (SV *)SvSTASH(thing), SOME_RECURSION);
1323   }
1324
1325   return;
1326 }
1327
1328 static void
1329 free_memnode_state(pTHX_ struct state *st)
1330 {
1331     if (st->node_stream_fh && st->node_stream_name && *st->node_stream_name) {
1332         if (*st->node_stream_name == '|') {
1333             if (pclose(st->node_stream_fh))
1334                 warn("%s exited with an error status\n", st->node_stream_name);
1335         }
1336         else {
1337             if (fclose(st->node_stream_fh))
1338                 warn("Error closing %s: %s\n", st->node_stream_name, strerror(errno));
1339         }
1340     }
1341 }
1342
1343 static struct state *
1344 new_state(pTHX)
1345 {
1346     SV *warn_flag;
1347     struct state *st;
1348
1349     Newxz(st, 1, struct state);
1350     st->go_yell = TRUE;
1351     st->min_recurse_threshold = TOTAL_SIZE_RECURSION;
1352     if (NULL != (warn_flag = perl_get_sv("Devel::Size::warn", FALSE))) {
1353         st->dangle_whine = st->go_yell = SvIV(warn_flag) ? TRUE : FALSE;
1354     }
1355     if (NULL != (warn_flag = perl_get_sv("Devel::Size::dangle", FALSE))) {
1356         st->dangle_whine = SvIV(warn_flag) ? TRUE : FALSE;
1357     }
1358     check_new(st, &PL_sv_undef);
1359     check_new(st, &PL_sv_no);
1360     check_new(st, &PL_sv_yes);
1361 #if PERL_VERSION > 8 || (PERL_VERSION == 8 && PERL_SUBVERSION > 0)
1362     check_new(st, &PL_sv_placeholder);
1363 #endif
1364
1365 #ifdef PATH_TRACKING
1366     /* XXX quick hack */
1367     st->node_stream_name = getenv("PERL_DMEM");
1368     if (st->node_stream_name) {
1369         if (*st->node_stream_name) {
1370             if (*st->node_stream_name == '|')
1371                 st->node_stream_fh = popen(st->node_stream_name+1, "w");
1372             else
1373                 st->node_stream_fh = fopen(st->node_stream_name, "wb");
1374             if (!st->node_stream_fh)
1375                 croak("Can't open '%s' for writing: %s", st->node_stream_name, strerror(errno));
1376             setlinebuf(st->node_stream_fh); /* XXX temporary for debugging */
1377             st->add_attr_cb = np_stream_node_path_info;
1378         }
1379         else
1380             st->add_attr_cb = np_dump_node_path_info;
1381     }
1382     st->free_state_cb = free_memnode_state;
1383 #endif
1384
1385     return st;
1386 }
1387
1388 /* XXX based on S_visit() in sv.c */
1389 static void
1390 unseen_sv_size(pTHX_ struct state *st, pPATH)
1391 {
1392     dVAR;
1393     SV* sva;
1394     I32 visited = 0;
1395     dNPathNodes(1, NPathArg);
1396
1397     NPathPushNode("unseen", NPtype_NAME);
1398
1399     /* by this point we should have visited all the SVs
1400      * so now we'll run through all the SVs via the arenas
1401      * in order to find any thet we've missed for some reason.
1402      * Once the rest of the code is finding all the SVs then any
1403      * found here will be leaks.
1404      */
1405     for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) {
1406         const SV * const svend = &sva[SvREFCNT(sva)];
1407         SV* sv;
1408         for (sv = sva + 1; sv < svend; ++sv) {
1409             if (SvTYPE(sv) != (svtype)SVTYPEMASK && SvREFCNT(sv)) {
1410                 sv_size(aTHX_ st, NPathLink("arena"), sv, TOTAL_SIZE_RECURSION);
1411             }
1412             else if (check_new(st, sv)) { /* sanity check */
1413                 sv_dump(sv);
1414                 warn("unseen_sv_size encountered freed SV unexpectedly"); /* XXX warn uses an SV, I think */
1415             }
1416         }
1417     }
1418 }
1419
1420 #ifdef PERL_MAD
1421 static void
1422 madprop_size(pTHX_ struct state *const st, pPath, MADPROP *prop)
1423 {
1424   dPathNodes(2, NPathArg);
1425   if (!check_new(st, prop))
1426     return;
1427   NPathPushNode("madprop_size", NPtype_NAME);
1428   ADD_SIZE(st, "MADPROP", sizeof(MADPROP));
1429
1430   NPathPushNode("val");
1431   ADD_SIZE(st, "val", prop->mad_val);
1432   if (prop->mad_next)
1433     madprop_size(aTHX_ st, NPathLink("mad_next"), prop->mad_next);
1434 }
1435 #endif
1436
1437 static void
1438 parser_size(pTHX_ struct state *const st, pPATH, yy_parser *parser)
1439 {
1440   dNPathNodes(2, NPathArg);
1441   int i;
1442   if (!check_new(st, parser))
1443     return;
1444   NPathPushNode("parser_size", NPtype_NAME);
1445   ADD_SIZE(st, "yy_parser", sizeof(yy_parser));
1446
1447   NPathPushNode("stack", NPtype_NAME);
1448   yy_stack_frame *ps;
1449   //warn("total: %u", parser->stack_size);
1450   //warn("foo: %u", parser->ps - parser->stack);
1451   for (ps = parser->stack; ps <= parser->ps; ps++) {
1452     ADD_PRE_ATTR(st, 0, "frame", i);
1453     ADD_SIZE(st, "yy_stack_frame", sizeof(yy_stack_frame));
1454     sv_size(aTHX_ st, NPathLink("compcv"), (SV*)ps->compcv, TOTAL_SIZE_RECURSION);
1455   }
1456   NPathPopNode;
1457
1458   sv_size(aTHX_ st, NPathLink("lex_repl"), (SV*)parser->lex_repl, TOTAL_SIZE_RECURSION);
1459   sv_size(aTHX_ st, NPathLink("lex_stuff"), (SV*)parser->lex_stuff, TOTAL_SIZE_RECURSION);
1460   sv_size(aTHX_ st, NPathLink("linestr"), (SV*)parser->linestr, TOTAL_SIZE_RECURSION);
1461   sv_size(aTHX_ st, NPathLink("in_my_stash"), (SV*)parser->in_my_stash, TOTAL_SIZE_RECURSION);
1462   sv_size(aTHX_ st, NPathLink("rsfp"), parser->rsfp, TOTAL_SIZE_RECURSION);
1463   sv_size(aTHX_ st, NPathLink("rsfp_filters"), parser->rsfp_filters, TOTAL_SIZE_RECURSION);
1464 #ifdef PERL_MAD
1465   sv_size(aTHX_ st, NPathLink("endwhite"), parser->endwhite, TOTAL_SIZE_RECURSION);
1466   sv_size(aTHX_ st, NPathLink("nextwhite"), parser->nextwhite, TOTAL_SIZE_RECURSION);
1467   sv_size(aTHX_ st, NPathLink("skipwhite"), parser->skipwhite, TOTAL_SIZE_RECURSION);
1468   sv_size(aTHX_ st, NPathLink("thisclose"), parser->thisclose, TOTAL_SIZE_RECURSION);
1469   madprop_size(aTHX_ st, NPathLink("thismad"), parser->thismad);
1470   sv_size(aTHX_ st, NPathLink("thisopen"), parser->thisopen, TOTAL_SIZE_RECURSION);
1471   sv_size(aTHX_ st, NPathLink("thisstuff"), parser->thisstuff, TOTAL_SIZE_RECURSION);
1472   sv_size(aTHX_ st, NPathLink("thistoken"), parser->thistoken, TOTAL_SIZE_RECURSION);
1473   sv_size(aTHX_ st, NPathLink("thiswhite"), parser->thiswhite, TOTAL_SIZE_RECURSION);
1474 #endif
1475   op_size_class(aTHX_ (OP*)parser->saved_curcop, OPc_COP, 0,
1476                 st, NPathLink("saved_curcop"));
1477
1478   if (parser->old_parser)
1479     parser_size(aTHX_ st, NPathLink("old_parser"), parser->old_parser);
1480 }
1481
1482 static void
1483 perl_size(pTHX_ struct state *const st, pPATH)
1484 {
1485   dNPathNodes(3, NPathArg);
1486
1487   /* if(!check_new(st, interp)) return; */
1488   NPathPushNode("perl", NPtype_NAME);
1489 #if defined(MULTIPLICITY)
1490   ADD_SIZE(st, "PerlInterpreter", sizeof(PerlInterpreter));
1491 #endif
1492 /*
1493  *      perl
1494  *          PL_defstash
1495  *          others
1496  *      unknown <== = O/S Heap size - perl - free_malloc_space
1497  */
1498   /* start with PL_defstash to get everything reachable from \%main:: */
1499   sv_size(aTHX_ st, NPathLink("PL_defstash"), (SV*)PL_defstash, TOTAL_SIZE_RECURSION);
1500
1501   NPathPushNode("others", NPtype_NAME); /* group these (typically much smaller) items */
1502   sv_size(aTHX_ st, NPathLink("PL_defgv"), (SV*)PL_defgv, TOTAL_SIZE_RECURSION);
1503   sv_size(aTHX_ st, NPathLink("PL_incgv"), (SV*)PL_incgv, TOTAL_SIZE_RECURSION);
1504   sv_size(aTHX_ st, NPathLink("PL_rs"), (SV*)PL_rs, TOTAL_SIZE_RECURSION);
1505   sv_size(aTHX_ st, NPathLink("PL_fdpid"), (SV*)PL_fdpid, TOTAL_SIZE_RECURSION);
1506   sv_size(aTHX_ st, NPathLink("PL_modglobal"), (SV*)PL_modglobal, TOTAL_SIZE_RECURSION);
1507   sv_size(aTHX_ st, NPathLink("PL_errors"), (SV*)PL_errors, TOTAL_SIZE_RECURSION);
1508   sv_size(aTHX_ st, NPathLink("PL_stashcache"), (SV*)PL_stashcache, TOTAL_SIZE_RECURSION);
1509   sv_size(aTHX_ st, NPathLink("PL_patchlevel"), (SV*)PL_patchlevel, TOTAL_SIZE_RECURSION);
1510   sv_size(aTHX_ st, NPathLink("PL_apiversion"), (SV*)PL_apiversion, TOTAL_SIZE_RECURSION);
1511   sv_size(aTHX_ st, NPathLink("PL_registered_mros"), (SV*)PL_registered_mros, TOTAL_SIZE_RECURSION);
1512 #ifdef USE_ITHREADS
1513   sv_size(aTHX_ st, NPathLink("PL_regex_padav"), (SV*)PL_regex_padav, TOTAL_SIZE_RECURSION);
1514 #endif
1515   sv_size(aTHX_ st, NPathLink("PL_warnhook"), (SV*)PL_warnhook, TOTAL_SIZE_RECURSION);
1516   sv_size(aTHX_ st, NPathLink("PL_diehook"), (SV*)PL_diehook, TOTAL_SIZE_RECURSION);
1517   sv_size(aTHX_ st, NPathLink("PL_endav"), (SV*)PL_endav, TOTAL_SIZE_RECURSION);
1518   sv_size(aTHX_ st, NPathLink("PL_main_cv"), (SV*)PL_main_cv, TOTAL_SIZE_RECURSION);
1519   sv_size(aTHX_ st, NPathLink("PL_main_root"), (SV*)PL_main_root, TOTAL_SIZE_RECURSION);
1520   sv_size(aTHX_ st, NPathLink("PL_main_start"), (SV*)PL_main_start, TOTAL_SIZE_RECURSION);
1521   sv_size(aTHX_ st, NPathLink("PL_envgv"), (SV*)PL_envgv, TOTAL_SIZE_RECURSION);
1522   sv_size(aTHX_ st, NPathLink("PL_hintgv"), (SV*)PL_hintgv, TOTAL_SIZE_RECURSION);
1523   sv_size(aTHX_ st, NPathLink("PL_e_script"), (SV*)PL_e_script, TOTAL_SIZE_RECURSION);
1524   sv_size(aTHX_ st, NPathLink("PL_encoding"), (SV*)PL_encoding, TOTAL_SIZE_RECURSION);
1525   sv_size(aTHX_ st, NPathLink("PL_ofsgv"), (SV*)PL_ofsgv, TOTAL_SIZE_RECURSION);
1526   sv_size(aTHX_ st, NPathLink("PL_argvout_stack"), (SV*)PL_argvout_stack, TOTAL_SIZE_RECURSION);
1527   sv_size(aTHX_ st, NPathLink("PL_beginav"), (SV*)PL_beginav, TOTAL_SIZE_RECURSION);
1528   sv_size(aTHX_ st, NPathLink("PL_beginav_save"), (SV*)PL_beginav_save, TOTAL_SIZE_RECURSION);
1529   sv_size(aTHX_ st, NPathLink("PL_checkav_save"), (SV*)PL_checkav_save, TOTAL_SIZE_RECURSION);
1530   sv_size(aTHX_ st, NPathLink("PL_unitcheckav"), (SV*)PL_unitcheckav, TOTAL_SIZE_RECURSION);
1531   sv_size(aTHX_ st, NPathLink("PL_unitcheckav_save"), (SV*)PL_unitcheckav_save, TOTAL_SIZE_RECURSION);
1532   sv_size(aTHX_ st, NPathLink("PL_endav"), (SV*)PL_endav, TOTAL_SIZE_RECURSION);
1533   sv_size(aTHX_ st, NPathLink("PL_checkav"), (SV*)PL_checkav, TOTAL_SIZE_RECURSION);
1534   sv_size(aTHX_ st, NPathLink("PL_initav"), (SV*)PL_initav, TOTAL_SIZE_RECURSION);
1535   sv_size(aTHX_ st, NPathLink("PL_isarev"), (SV*)PL_isarev, TOTAL_SIZE_RECURSION);
1536   sv_size(aTHX_ st, NPathLink("PL_fdpid"), (SV*)PL_fdpid, TOTAL_SIZE_RECURSION);
1537   sv_size(aTHX_ st, NPathLink("PL_preambleav"), (SV*)PL_preambleav, TOTAL_SIZE_RECURSION);
1538   sv_size(aTHX_ st, NPathLink("PL_ors_sv"), (SV*)PL_ors_sv, TOTAL_SIZE_RECURSION);
1539   sv_size(aTHX_ st, NPathLink("PL_modglobal"), (SV*)PL_modglobal, TOTAL_SIZE_RECURSION);
1540   sv_size(aTHX_ st, NPathLink("PL_custom_op_names"), (SV*)PL_custom_op_names, TOTAL_SIZE_RECURSION);
1541   sv_size(aTHX_ st, NPathLink("PL_custom_op_descs"), (SV*)PL_custom_op_descs, TOTAL_SIZE_RECURSION);
1542   sv_size(aTHX_ st, NPathLink("PL_custom_ops"), (SV*)PL_custom_ops, TOTAL_SIZE_RECURSION);
1543   sv_size(aTHX_ st, NPathLink("PL_compcv"), (SV*)PL_compcv, TOTAL_SIZE_RECURSION);
1544   sv_size(aTHX_ st, NPathLink("PL_DBcv"), (SV*)PL_DBcv, TOTAL_SIZE_RECURSION);
1545 #ifdef PERL_USES_PL_PIDSTATUS
1546   sv_size(aTHX_ st, NPathLink("PL_pidstatus"), (SV*)PL_pidstatus, TOTAL_SIZE_RECURSION);
1547 #endif
1548   sv_size(aTHX_ st, NPathLink("PL_subname"), (SV*)PL_subname, TOTAL_SIZE_RECURSION);
1549 #ifdef USE_LOCALE_NUMERIC
1550   sv_size(aTHX_ st, NPathLink("PL_numeric_radix_sv"), (SV*)PL_numeric_radix_sv, TOTAL_SIZE_RECURSION);
1551   check_new_and_strlen(st, PL_numeric_name, NPathLink("PL_numeric_name"));
1552 #endif
1553 #ifdef USE_LOCALE_COLLATE
1554   check_new_and_strlen(st, PL_collation_name, NPathLink("PL_collation_name"));
1555 #endif
1556   check_new_and_strlen(st, PL_origfilename, NPathLink("PL_origfilename"));
1557   check_new_and_strlen(st, PL_inplace, NPathLink("PL_inplace"));
1558   check_new_and_strlen(st, PL_osname, NPathLink("PL_osname"));
1559   if (PL_op_mask && check_new(st, PL_op_mask))
1560     ADD_SIZE(st, "PL_op_mask", PL_maxo);
1561   if (PL_exitlistlen && check_new(st, PL_exitlist))
1562     ADD_SIZE(st, "PL_exitlist", (PL_exitlistlen * sizeof(PerlExitListEntry *))
1563                               + (PL_exitlistlen * sizeof(PerlExitListEntry)));
1564   if (PL_my_cxt_size && check_new(st, PL_my_cxt_list)) {
1565     ADD_SIZE(st, "PL_my_cxt_list", (PL_my_cxt_size * sizeof(void *)));
1566 #ifdef PERL_GLOBAL_STRUCT_PRIVATE
1567     ADD_SIZE(st, "PL_my_cxt_keys", (PL_my_cxt_size * sizeof(char *)));
1568 #endif
1569   }
1570   /* TODO PL_stashpad */
1571   op_size_class(aTHX_ &PL_compiling, OPc_COP, 1, st, NPathLink("PL_compiling"));
1572   op_size_class(aTHX_ PL_curcopdb, OPc_COP, 0, st, NPathLink("PL_curcopdb"));
1573
1574   parser_size(aTHX_ st, NPathLink("PL_parser"), PL_parser);
1575   /* TODO stacks: cur, main, tmps, mark, scope, save */
1576   /* TODO PL_exitlist */
1577   /* TODO PL_reentrant_buffers etc */
1578   /* TODO environ */
1579   /* TODO PerlIO? PL_known_layers PL_def_layerlist PL_perlio_fd_refcnt etc */
1580   /* TODO threads? */
1581   /* TODO anything missed? */
1582
1583   /* --- by this point we should have seen all reachable SVs --- */
1584
1585   /* in theory we shouldn't have any elements in PL_strtab that haven't been seen yet */
1586   sv_size(aTHX_ st, NPathLink("PL_strtab-unseen"), (SV*)PL_strtab, TOTAL_SIZE_RECURSION);
1587
1588   /* unused space in sv head arenas */
1589   if (PL_sv_root) {
1590     SV *p = PL_sv_root;
1591     UV free_heads = 1;
1592 #  define SvARENA_CHAIN(sv)     SvANY(sv) /* XXX breaks encapsulation*/
1593     while ((p = MUTABLE_SV(SvARENA_CHAIN(p)))) {
1594         if (!check_new(st, p)) /* sanity check */
1595             warn("Free'd SV head unexpectedly already seen");
1596         ++free_heads;
1597     }
1598     NPathPushNode("unused_sv_heads", NPtype_NAME);
1599     ADD_SIZE(st, "sv", free_heads * sizeof(SV));
1600     NPathPopNode;
1601   }
1602   /* XXX iterate over bodies_by_type and crawl the free chains for each */
1603
1604   /* iterate over all SVs to find any we've not accounted for yet */
1605   /* once the code above is visiting all SVs, any found here have been leaked */
1606   unseen_sv_size(aTHX_ st, NPathLink("unaccounted"));
1607 }
1608
1609
1610 MODULE = Devel::Memory        PACKAGE = Devel::Memory
1611
1612 PROTOTYPES: DISABLE
1613
1614 UV
1615 size(orig_thing)
1616      SV *orig_thing
1617 ALIAS:
1618     total_size = TOTAL_SIZE_RECURSION
1619 CODE:
1620 {
1621   SV *thing = orig_thing;
1622   struct state *st = new_state(aTHX);
1623
1624   /* If they passed us a reference then dereference it. This is the
1625      only way we can check the sizes of arrays and hashes */
1626   if (SvROK(thing)) {
1627     thing = SvRV(thing);
1628   }
1629
1630   sv_size(aTHX_ st, NULL, thing, ix);
1631   RETVAL = st->total_size;
1632   free_state(aTHX_ st);
1633 }
1634 OUTPUT:
1635   RETVAL
1636
1637 UV
1638 perl_size()
1639 CODE:
1640 {
1641   /* just the current perl interpreter */
1642   struct state *st = new_state(aTHX);
1643   st->min_recurse_threshold = NO_RECURSION; /* so always recurse */
1644   perl_size(aTHX_ st, NULL);
1645   RETVAL = st->total_size;
1646   free_state(aTHX_ st);
1647 }
1648 OUTPUT:
1649   RETVAL
1650
1651 UV
1652 heap_size()
1653 CODE:
1654 {
1655   /* the current perl interpreter plus malloc, in the context of total heap size */
1656 # ifdef _MALLOC_MALLOC_H_ /* OSX. Now sure where else mstats is available */
1657 # define HAS_MSTATS
1658 # endif
1659 # ifdef HAS_MSTATS
1660   /* some systems have the SVID2/XPG mallinfo structure and function */
1661   struct mstats ms = mstats(); /* mstats() first */
1662 # endif
1663   struct state *st = new_state(aTHX);
1664   dNPathNodes(1, NULL);
1665   NPathPushNode("heap", NPtype_NAME);
1666
1667   st->min_recurse_threshold = NO_RECURSION; /* so always recurse */
1668
1669   perl_size(aTHX_ st, NPathLink("perl_interp"));
1670 # ifdef HAS_MSTATS
1671   NPathSetNode("free_malloc_space", NPtype_NAME);
1672   ADD_SIZE(st, "bytes_free", ms.bytes_free);
1673   ADD_ATTR(st, NPattr_NOTE, "bytes_total", ms.bytes_total);
1674   ADD_ATTR(st, NPattr_NOTE, "bytes_used",  ms.bytes_used);
1675   ADD_ATTR(st, NPattr_NOTE, "chunks_used", ms.chunks_used);
1676   ADD_ATTR(st, NPattr_NOTE, "chunks_free", ms.chunks_free);
1677   /* TODO get heap size from OS and add a node: unknown = heapsize - perl - ms.bytes_free */
1678   /* for now we use bytes_total as an approximation */
1679   NPathSetNode("unknown", NPtype_NAME);
1680   ADD_SIZE(st, "unknown", ms.bytes_total - st->total_size);
1681 # else
1682     /* XXX ? */
1683 # endif
1684
1685   RETVAL = st->total_size;
1686   free_state(aTHX_ st);
1687 }
1688 OUTPUT:
1689   RETVAL