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