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