SizeMe.xs

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