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