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