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