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