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
  47 #if PERL_VERSION < 6
  48 #  define PL_opargs opargs
  49 #  define PL_op_name op_name
  50 #endif
  51
  52 #ifdef _MSC_VER
  53 /* "structured exception" handling is a Microsoft extension to C and C++.
  54    It's *not* C++ exception handling - C++ exception handling can't capture
  55    SEGVs and suchlike, whereas this can. There's no known analagous
  56     functionality on other platforms.  */
  57 #  include <excpt.h>
  58 #  define TRY_TO_CATCH_SEGV __try
  59 #  define CAUGHT_EXCEPTION __except(EXCEPTION_EXECUTE_HANDLER)
  60 #else
  61 #  define TRY_TO_CATCH_SEGV if(1)
  62 #  define CAUGHT_EXCEPTION else
  63 #endif
  64
  65 #ifdef __GNUC__
  66 # define __attribute__(x)
  67 #endif
  68
  69 #if 0 && defined(DEBUGGING)
  70 #define dbg_printf(x) printf x
  71 #else
  72 #define dbg_printf(x)
  73 #endif
  74
  75 #define TAG /* printf( "# %s(%d)\n", __FILE__, __LINE__ ) */
  76 #define carp puts
  77
  78 /* The idea is to have a tree structure to store 1 bit per possible pointer
  79    address. The lowest 16 bits are stored in a block of 8092 bytes.
  80    The blocks are in a 256-way tree, indexed by the reset of the pointer.
  81    This can cope with 32 and 64 bit pointers, and any address space layout,
  82    without excessive memory needs. The assumption is that your CPU cache
  83    works :-) (And that we're not going to bust it)  */
  84
  85 #define BYTE_BITS    3
  86 #define LEAF_BITS   (16 - BYTE_BITS)
  87 #define LEAF_MASK   0x1FFF
  88
  89 typedef struct npath_node_st npath_node_t;
  90 struct npath_node_st {
  91     npath_node_t *prev;
  92     const void *id;
  93     U8 type;
  94     U8 flags;
  95     UV seqn;
  96     U16 depth;
  97 };
  98
  99 struct state {
 100     UV total_size;
 101     bool regex_whine;
 102     bool fm_whine;
 103     bool dangle_whine;
 104     bool go_yell;
 105     /* My hunch (not measured) is that for most architectures pointers will
 106        start with 0 bits, hence the start of this array will be hot, and the
 107        end unused. So put the flags next to the hot end.  */
 108     void *tracking[256];
 109     NV start_time_nv;
 110     int min_recurse_threshold;
 111     /* callback hooks and data */
 112     void (*add_attr_cb)(pTHX_ struct state *st, npath_node_t *npath_node, UV attr_type, const char *name, UV value);
 113     void (*free_state_cb)(pTHX_ struct state *st);
 114     void *state_cb_data; /* free'd by free_state() after free_state_cb() call */
 115     /* this stuff wil be moved to state_cb_data later */
 116     UV seqn;
 117     FILE *node_stream_fh;
 118     char *node_stream_name;
 119 };
 120
 121 #define ADD_SIZE(st, leafname, bytes) \
 122   STMT_START { \
 123     NPathAddSizeCb(st, leafname, bytes); \
 124     (st)->total_size += (bytes); \
 125   } STMT_END
 126
 127
 128 #define PATH_TRACKING
 129 #ifdef PATH_TRACKING
 130
 131 #define pPATH npath_node_t *NPathArg
 132
 133 /* A subtle point here is that dNPathNodes and NPathPushNode leave NP pointing
 134  * to the next unused slot (though with prev already filled in)
 135  * whereas NPathLink leaves NP unchanged, it just fills in the slot NP points
 136  * to and passes that NP value to the function being called.
 137  * seqn==0 indicates the node is new (hasn't been output yet)
 138  */
 139 #define dNPathNodes(nodes, prev_np) \
 140             npath_node_t name_path_nodes[nodes+1]; /* +1 for NPathLink */ \
 141             npath_node_t *NP = &name_path_nodes[0]; \
 142             NP->seqn = NP->type = 0; NP->id = Nullch; /* safety/debug */ \
 143             NP->prev = prev_np
 144 #define NPathPushNode(nodeid, nodetype) \
 145             NP->id = nodeid; \
 146             NP->type = nodetype; \
 147             NP->seqn = 0; \
 148             if(0)fprintf(stderr,"NPathPushNode (%p <-) %p <- [%d %s]\n", NP->prev, NP, nodetype,(char*)nodeid);\
 149             NP++; \
 150             NP->id = Nullch; /* safety/debug */ \
 151             NP->seqn = 0; \
 152             NP->prev = (NP-1)
 153 #define NPathSetNode(nodeid, nodetype) \
 154             (NP-1)->id = nodeid; \
 155             (NP-1)->type = nodetype; \
 156             if(0)fprintf(stderr,"NPathSetNode (%p <-) %p <- [%d %s]\n", (NP-1)->prev, (NP-1), nodetype,(char*)nodeid);\
 157             (NP-1)->seqn = 0;
 158 #define NPathPopNode \
 159             --NP
 160
 161 /* dNPathUseParent points NP directly the the parents' name_path_nodes array
 162  * So the function can only safely call ADD_*() but not NPathLink, unless the
 163  * caller has spare nodes in its name_path_nodes.
 164  */
 165 #define dNPathUseParent(prev_np) npath_node_t *NP = (((prev_np+1)->prev = prev_np), prev_np+1)
 166
 167 #define NPtype_NAME     0x01
 168 #define NPtype_LINK     0x02
 169 #define NPtype_SV       0x03
 170 #define NPtype_MAGIC    0x04
 171 #define NPtype_OP       0x05
 172
 173 /* XXX these should probably be generalized into flag bits */
 174 #define NPattr_LEAFSIZE 0x00
 175 #define NPattr_NAME     0x01
 176 #define NPattr_PADFAKE  0x02
 177 #define NPattr_PADNAME  0x03
 178 #define NPattr_PADTMP   0x04
 179 #define NPattr_NOTE     0x05
 180
 181 #define _ADD_ATTR_NP(st, attr_type, attr_name, attr_value, np) \
 182   STMT_START { \
 183     if (st->add_attr_cb) { \
 184       st->add_attr_cb(aTHX_ st, np, attr_type, attr_name, attr_value); \
 185     } \
 186   } STMT_END
 187
 188 #define ADD_ATTR(st, attr_type, attr_name, attr_value) \
 189     _ADD_ATTR_NP(st, attr_type, attr_name, attr_value, NP-1)
 190
 191 #define ADD_LINK_ATTR(st, attr_type, attr_name, attr_value)             \
 192   STMT_START {                                                          \
 193     if (st->add_attr_cb) assert(NP->seqn);                              \
 194     _ADD_ATTR_NP(st, attr_type, attr_name, attr_value, NP);             \
 195   } STMT_END;
 196
 197 #define _NPathLink(np, nid, ntype)   (((np)->id=nid), ((np)->type=ntype), ((np)->seqn=0))
 198 #define NPathLink(nid)               (_NPathLink(NP, nid, NPtype_LINK), NP)
 199 /* add a link and a name node to the path - a special case for op_size */
 200 #define NPathLinkAndNode(nid, nid2)  (_NPathLink(NP, nid, NPtype_LINK), _NPathLink(NP+1, nid2, NPtype_NAME), ((NP+1)->prev=NP), (NP+1))
 201 #define NPathOpLink  (NPathArg)
 202 #define NPathAddSizeCb(st, name, bytes) \
 203   STMT_START { \
 204     if (st->add_attr_cb) { \
 205       st->add_attr_cb(aTHX_ st, NP-1, NPattr_LEAFSIZE, (name), (bytes)); \
 206     } \
 207   } STMT_END
 208
 209 #else
 210
 211 #define NPathAddSizeCb(st, name, bytes)
 212 #define pPATH void *npath_dummy /* XXX ideally remove */
 213 #define dNPathNodes(nodes, prev_np)  dNOOP
 214 #define NPathLink(nodeid, nodetype)  NULL
 215 #define NPathOpLink NULL
 216 #define ADD_ATTR(st, attr_type, attr_name, attr_value) NOOP
 217
 218 #endif /* PATH_TRACKING */
 219
 220
 221
 222
 223 #ifdef PATH_TRACKING
 224
 225 static const char *svtypenames[SVt_LAST] = {
 226 #if PERL_VERSION < 9
 227   "NULL", "IV", "NV", "RV", "PV", "PVIV", "PVNV", "PVMG", "PVBM", "PVLV", "PVAV", "PVHV", "PVCV", "PVGV", "PVFM", "PVIO",
 228 #elif PERL_VERSION == 10 && PERL_SUBVERSION == 0
 229   "NULL", "BIND", "IV", "NV", "RV", "PV", "PVIV", "PVNV", "PVMG", "PVGV", "PVLV", "PVAV", "PVHV", "PVCV", "PVFM", "PVIO",
 230 #elif PERL_VERSION == 10 && PERL_SUBVERSION == 1
 231   "NULL", "BIND", "IV", "NV", "RV", "PV", "PVIV", "PVNV", "PVMG", "PVGV", "PVLV", "PVAV", "PVHV", "PVCV", "PVFM", "PVIO",
 232 #elif PERL_VERSION < 13
 233   "NULL", "BIND", "IV", "NV", "PV", "PVIV", "PVNV", "PVMG", "REGEXP", "PVGV", "PVLV", "PVAV", "PVHV", "PVCV", "PVFM", "PVIO",
 234 #else
 235   "NULL", "BIND", "IV", "NV", "PV", "PVIV", "PVNV", "PVMG", "REGEXP", "PVGV", "PVLV", "PVAV", "PVHV", "PVCV", "PVFM", "PVIO",
 236 #endif
 237 };
 238
 239 static NV
 240 gettimeofday_nv(void)
 241 {
 242 #ifdef HAS_GETTIMEOFDAY
 243     struct timeval when;
 244     gettimeofday(&when, (struct timezone *) 0);
 245     return when.tv_sec + (when.tv_usec / 1000000.0);
 246 #else
 247     if (u2time) {
 248         UV time_of_day[2];
 249         (*u2time)(aTHX_ &time_of_day);
 250         return time_of_day[0] + (time_of_day[1] / 1000000.0);
 251     }
 252     return (NV)time();
 253 #endif
 254 }
 255
 256
 257 int
 258 np_print_node_name(pTHX_ FILE *fp, npath_node_t *npath_node)
 259 {
 260     switch (npath_node->type) {
 261     case NPtype_SV: { /* id is pointer to the SV sv_size was called on */
 262         const SV *sv = (SV*)npath_node->id;
 263         int type = SvTYPE(sv);
 264         const char *typename = (type == SVt_IV && SvROK(sv)) ? "RV" : svtypenames[type];
 265         fprintf(fp, "SV(%s)", typename);
 266         switch(type) {  /* add some useful details */
 267         case SVt_PVAV: fprintf(fp, " fill=%d/%ld", av_len((AV*)sv), AvMAX((AV*)sv)); break;
 268         case SVt_PVHV: fprintf(fp, " fill=%ld/%ld", HvFILL((HV*)sv), HvMAX((HV*)sv)); break;
 269         }
 270         break;
 271     }
 272     case NPtype_OP: { /* id is pointer to the OP op_size was called on */
 273         const OP *op = (OP*)npath_node->id;
 274         fprintf(fp, "OP(%s)", OP_NAME(op));
 275         break;
 276     }
 277     case NPtype_MAGIC: { /* id is pointer to the MAGIC struct */
 278         MAGIC *magic_pointer = (MAGIC*)npath_node->id;
 279         /* XXX it would be nice if we could reuse mg_names.c [sigh] */
 280         fprintf(fp, "MAGIC(%c)", magic_pointer->mg_type ? magic_pointer->mg_type : '0');
 281         break;
 282     }
 283     case NPtype_LINK:
 284         fprintf(fp, "%s", (const char *)npath_node->id);
 285         break;
 286     case NPtype_NAME:
 287         fprintf(fp, "%s", (const char *)npath_node->id);
 288         break;
 289     default:    /* assume id is a string pointer */
 290         fprintf(fp, "UNKNOWN(%d,%p)", npath_node->type, npath_node->id);
 291         break;
 292     }
 293     return 0;
 294 }
 295
 296 void
 297 np_dump_indent(int depth) {
 298     while (depth-- > 0)
 299         fprintf(stderr, ":   ");
 300 }
 301
 302 int
 303 np_walk_new_nodes(pTHX_ struct state *st,
 304     npath_node_t *npath_node,
 305     npath_node_t *npath_node_deeper,
 306     int (*cb)(pTHX_ struct state *st, npath_node_t *npath_node, npath_node_t *npath_node_deeper))
 307 {
 308     if (npath_node->seqn) /* node already output */
 309         return 0;
 310
 311     if (npath_node->prev) {
 312         np_walk_new_nodes(aTHX_ st, npath_node->prev, npath_node, cb); /* recurse */
 313         npath_node->depth = npath_node->prev->depth + 1;
 314     }
 315     else npath_node->depth = 0;
 316     npath_node->seqn = ++st->seqn;
 317
 318     if (cb) {
 319         if (cb(aTHX_ st, npath_node, npath_node_deeper)) {
 320             /* ignore this node */
 321             assert(npath_node->prev);
 322             assert(npath_node->depth);
 323             assert(npath_node_deeper);
 324             npath_node->depth--;
 325             npath_node->seqn = --st->seqn;
 326             npath_node_deeper->prev = npath_node->prev;
 327         }
 328     }
 329
 330     return 0;
 331 }
 332
 333 int
 334 np_dump_formatted_node(pTHX_ struct state *st, npath_node_t *npath_node, npath_node_t *npath_node_deeper) {
 335     PERL_UNUSED_ARG(st);
 336     PERL_UNUSED_ARG(npath_node_deeper);
 337     if (0 && npath_node->type == NPtype_LINK)
 338         return 1;
 339     np_dump_indent(npath_node->depth);
 340     np_print_node_name(aTHX_ stderr, npath_node);
 341     if (npath_node->type == NPtype_LINK)
 342         fprintf(stderr, "->"); /* cosmetic */
 343     fprintf(stderr, "\t\t[#%ld @%u] ", npath_node->seqn, npath_node->depth);
 344     fprintf(stderr, "\n");
 345     return 0;
 346 }
 347
 348 void
 349 np_dump_node_path_info(pTHX_ struct state *st, npath_node_t *npath_node, UV attr_type, const char *attr_name, UV attr_value)
 350 {
 351     if (attr_type == NPattr_LEAFSIZE && !attr_value)
 352         return; /* ignore zero sized leaf items */
 353     np_walk_new_nodes(aTHX_ st, npath_node, NULL, np_dump_formatted_node);
 354     np_dump_indent(npath_node->depth+1);
 355     switch (attr_type) {
 356     case NPattr_LEAFSIZE:
 357         fprintf(stderr, "+%ld %s =%ld", attr_value, attr_name, attr_value+st->total_size);
 358         break;
 359     case NPattr_NAME:
 360         fprintf(stderr, "~NAMED('%s') %lu", attr_name, attr_value);
 361         break;
 362     case NPattr_NOTE:
 363         fprintf(stderr, "~note %s %lu", attr_name, attr_value);
 364         break;
 365     case NPattr_PADTMP:
 366     case NPattr_PADNAME:
 367     case NPattr_PADFAKE:
 368         fprintf(stderr, "~pad%lu %s %lu", attr_type, attr_name, attr_value);
 369         break;
 370     default:
 371         fprintf(stderr, "~??? %s %lu", attr_name, attr_value);
 372         break;
 373     }
 374     fprintf(stderr, "\n");
 375 }
 376
 377 int
 378 np_stream_formatted_node(pTHX_ struct state *st, npath_node_t *npath_node, npath_node_t *npath_node_deeper) {
 379     PERL_UNUSED_ARG(npath_node_deeper);
 380     fprintf(st->node_stream_fh, "-%u %lu %u ",
 381         npath_node->type, npath_node->seqn, (unsigned)npath_node->depth
 382     );
 383     np_print_node_name(aTHX_ st->node_stream_fh, npath_node);
 384     fprintf(st->node_stream_fh, "\n");
 385     return 0;
 386 }
 387
 388 void
 389 np_stream_node_path_info(pTHX_ struct state *st, npath_node_t *npath_node, UV attr_type, const char *attr_name, UV attr_value)
 390 {
 391     if (!attr_type && !attr_value)
 392         return; /* ignore zero sized leaf items */
 393     np_walk_new_nodes(aTHX_ st, npath_node, NULL, np_stream_formatted_node);
 394     if (attr_type) { /* Attribute type, name and value */
 395         fprintf(st->node_stream_fh, "%lu %lu ", attr_type, npath_node->seqn);
 396     }
 397     else { /* Leaf name and memory size */
 398         fprintf(st->node_stream_fh, "L %lu ", npath_node->seqn);
 399     }
 400     fprintf(st->node_stream_fh, "%lu %s\n", attr_value, attr_name);
 401 }
 402
 403
 404 #endif /* PATH_TRACKING */
 405
 406
 407 /*
 408     Checks to see if thing is in the bitstring.
 409     Returns true or false, and
 410     notes thing in the segmented bitstring.
 411  */
 412 static bool
 413 check_new(struct state *st, const void *const p) {
 414     unsigned int bits = 8 * sizeof(void*);
 415     const size_t raw_p = PTR2nat(p);
 416     /* This effectively rotates the value right by the number of low always-0
 417        bits in an aligned pointer. The assmption is that most (if not all)
 418        pointers are aligned, and these will be in the same chain of nodes
 419        (and hence hot in the cache) but we can still deal with any unaligned
 420        pointers.  */
 421     const size_t cooked_p
 422         = (raw_p >> ALIGN_BITS) | (raw_p << (bits - ALIGN_BITS));
 423     const U8 this_bit = 1 << (cooked_p & 0x7);
 424     U8 **leaf_p;
 425     U8 *leaf;
 426     unsigned int i;
 427     void **tv_p = (void **) (st->tracking);
 428
 429     if (NULL == p) return FALSE;
 430     TRY_TO_CATCH_SEGV {
 431         const char c = *(const char *)p;
 432         PERL_UNUSED_VAR(c);
 433     }
 434     CAUGHT_EXCEPTION {
 435         if (st->dangle_whine)
 436             warn( "Devel::Size: Encountered invalid pointer: %p\n", p );
 437         return FALSE;
 438     }
 439     TAG;
 440
 441     bits -= 8;
 442     /* bits now 24 (32 bit pointers) or 56 (64 bit pointers) */
 443
 444     /* First level is always present.  */
 445     do {
 446         i = (unsigned int)((cooked_p >> bits) & 0xFF);
 447         if (!tv_p[i])
 448             Newxz(tv_p[i], 256, void *);
 449         tv_p = (void **)(tv_p[i]);
 450         bits -= 8;
 451     } while (bits > LEAF_BITS + BYTE_BITS);
 452     /* bits now 16 always */
 453 #if !defined(MULTIPLICITY) || PERL_VERSION > 8 || (PERL_VERSION == 8 && PERL_SUBVERSION > 8)
 454     /* 5.8.8 and early have an assert() macro that uses Perl_croak, hence needs
 455        a my_perl under multiplicity  */
 456     assert(bits == 16);
 457 #endif
 458     leaf_p = (U8 **)tv_p;
 459     i = (unsigned int)((cooked_p >> bits) & 0xFF);
 460     if (!leaf_p[i])
 461         Newxz(leaf_p[i], 1 << LEAF_BITS, U8);
 462     leaf = leaf_p[i];
 463
 464     TAG;
 465
 466     i = (unsigned int)((cooked_p >> BYTE_BITS) & LEAF_MASK);
 467
 468     if(leaf[i] & this_bit)
 469         return FALSE;
 470
 471     leaf[i] |= this_bit;
 472     return TRUE;
 473 }
 474
 475 static void
 476 free_tracking_at(void **tv, int level)
 477 {
 478     int i = 255;
 479
 480     if (--level) {
 481         /* Nodes */
 482         do {
 483             if (tv[i]) {
 484                 free_tracking_at((void **) tv[i], level);
 485                 Safefree(tv[i]);
 486             }
 487         } while (i--);
 488     } else {
 489         /* Leaves */
 490         do {
 491             if (tv[i])
 492                 Safefree(tv[i]);
 493         } while (i--);
 494     }
 495 }
 496
 497 static void
 498 free_state(pTHX_ struct state *st)
 499 {
 500     const int top_level = (sizeof(void *) * 8 - LEAF_BITS - BYTE_BITS) / 8;
 501     if (st->free_state_cb)
 502         st->free_state_cb(aTHX_ st);
 503     if (st->state_cb_data)
 504         Safefree(st->state_cb_data);
 505     free_tracking_at((void **)st->tracking, top_level);
 506     Safefree(st);
 507 }
 508
 509 /* For now, this is somewhat a compatibility bodge until the plan comes
 510    together for fine grained recursion control. total_size() would recurse into
 511    hash and array members, whereas sv_size() would not. However, sv_size() is
 512    called with CvSTASH() of a CV, which means that if it (also) starts to
 513    recurse fully, then the size of any CV now becomes the size of the entire
 514    symbol table reachable from it, and potentially the entire symbol table, if
 515    any subroutine makes a reference to a global (such as %SIG). The historical
 516    implementation of total_size() didn't report "everything", and changing the
 517    only available size to "everything" doesn't feel at all useful.  */
 518
 519 #define NO_RECURSION 0
 520 #define SOME_RECURSION 1
 521 #define TOTAL_SIZE_RECURSION 2
 522
 523 static bool sv_size(pTHX_ struct state *, pPATH, const SV *const, const int recurse);
 524
 525 typedef enum {
 526     OPc_NULL,   /* 0 */
 527     OPc_BASEOP, /* 1 */
 528     OPc_UNOP,   /* 2 */
 529     OPc_BINOP,  /* 3 */
 530     OPc_LOGOP,  /* 4 */
 531     OPc_LISTOP, /* 5 */
 532     OPc_PMOP,   /* 6 */
 533     OPc_SVOP,   /* 7 */
 534     OPc_PADOP,  /* 8 */
 535     OPc_PVOP,   /* 9 */
 536     OPc_LOOP,   /* 10 */
 537     OPc_COP /* 11 */
 538 #ifdef OA_CONDOP
 539     , OPc_CONDOP /* 12 */
 540 #endif
 541 #ifdef OA_GVOP
 542     , OPc_GVOP /* 13 */
 543 #endif
 544
 545 } opclass;
 546
 547 static opclass
 548 cc_opclass(const OP * const o)
 549 {
 550     if (!o)
 551     return OPc_NULL;
 552     TRY_TO_CATCH_SEGV {
 553         if (o->op_type == 0)
 554         return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
 555
 556         if (o->op_type == OP_SASSIGN)
 557         return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPc_UNOP : OPc_BINOP);
 558
 559     #ifdef USE_ITHREADS
 560         if (o->op_type == OP_GV || o->op_type == OP_GVSV || o->op_type == OP_AELEMFAST)
 561         return OPc_PADOP;
 562     #endif
 563
 564         if ((o->op_type == OP_TRANS)) {
 565           return OPc_BASEOP;
 566         }
 567
 568         switch (PL_opargs[o->op_type] & OA_CLASS_MASK) {
 569         case OA_BASEOP: TAG;
 570         return OPc_BASEOP;
 571
 572         case OA_UNOP: TAG;
 573         return OPc_UNOP;
 574
 575         case OA_BINOP: TAG;
 576         return OPc_BINOP;
 577
 578         case OA_LOGOP: TAG;
 579         return OPc_LOGOP;
 580
 581         case OA_LISTOP: TAG;
 582         return OPc_LISTOP;
 583
 584         case OA_PMOP: TAG;
 585         return OPc_PMOP;
 586
 587         case OA_SVOP: TAG;
 588         return OPc_SVOP;
 589
 590 #ifdef OA_PADOP
 591         case OA_PADOP: TAG;
 592         return OPc_PADOP;
 593 #endif
 594
 595 #ifdef OA_GVOP
 596         case OA_GVOP: TAG;
 597         return OPc_GVOP;
 598 #endif
 599
 600 #ifdef OA_PVOP_OR_SVOP
 601         case OA_PVOP_OR_SVOP: TAG;
 602             /*
 603              * Character translations (tr///) are usually a PVOP, keeping a
 604              * pointer to a table of shorts used to look up translations.
 605              * Under utf8, however, a simple table isn't practical; instead,
 606              * the OP is an SVOP, and the SV is a reference to a swash
 607              * (i.e., an RV pointing to an HV).
 608              */
 609         return (o->op_private & (OPpTRANS_TO_UTF|OPpTRANS_FROM_UTF))
 610             ? OPc_SVOP : OPc_PVOP;
 611 #endif
 612
 613         case OA_LOOP: TAG;
 614         return OPc_LOOP;
 615
 616         case OA_COP: TAG;
 617         return OPc_COP;
 618
 619         case OA_BASEOP_OR_UNOP: TAG;
 620         /*
 621          * UNI(OP_foo) in toke.c returns token UNI or FUNC1 depending on
 622          * whether parens were seen. perly.y uses OPf_SPECIAL to
 623          * signal whether a BASEOP had empty parens or none.
 624          * Some other UNOPs are created later, though, so the best
 625          * test is OPf_KIDS, which is set in newUNOP.
 626          */
 627         return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
 628
 629         case OA_FILESTATOP: TAG;
 630         /*
 631          * The file stat OPs are created via UNI(OP_foo) in toke.c but use
 632          * the OPf_REF flag to distinguish between OP types instead of the
 633          * usual OPf_SPECIAL flag. As usual, if OPf_KIDS is set, then we
 634          * return OPc_UNOP so that walkoptree can find our children. If
 635          * OPf_KIDS is not set then we check OPf_REF. Without OPf_REF set
 636          * (no argument to the operator) it's an OP; with OPf_REF set it's
 637          * an SVOP (and op_sv is the GV for the filehandle argument).
 638          */
 639         return ((o->op_flags & OPf_KIDS) ? OPc_UNOP :
 640     #ifdef USE_ITHREADS
 641             (o->op_flags & OPf_REF) ? OPc_PADOP : OPc_BASEOP);
 642     #else
 643             (o->op_flags & OPf_REF) ? OPc_SVOP : OPc_BASEOP);
 644     #endif
 645         case OA_LOOPEXOP: TAG;
 646         /*
 647          * next, last, redo, dump and goto use OPf_SPECIAL to indicate that a
 648          * label was omitted (in which case it's a BASEOP) or else a term was
 649          * seen. In this last case, all except goto are definitely PVOP but
 650          * goto is either a PVOP (with an ordinary constant label), an UNOP
 651          * with OPf_STACKED (with a non-constant non-sub) or an UNOP for
 652          * OP_REFGEN (with goto &sub) in which case OPf_STACKED also seems to
 653          * get set.
 654          */
 655         if (o->op_flags & OPf_STACKED)
 656             return OPc_UNOP;
 657         else if (o->op_flags & OPf_SPECIAL)
 658             return OPc_BASEOP;
 659         else
 660             return OPc_PVOP;
 661
 662 #ifdef OA_CONDOP
 663         case OA_CONDOP: TAG;
 664             return OPc_CONDOP;
 665 #endif
 666         }
 667         warn("Devel::Size: Can't determine class of operator %s, assuming BASEOP\n",
 668          PL_op_name[o->op_type]);
 669     }
 670     CAUGHT_EXCEPTION { }
 671     return OPc_BASEOP;
 672 }
 673
 674 /* Figure out how much magic is attached to the SV and return the
 675    size */
 676 static void
 677 magic_size(pTHX_ const SV * const thing, struct state *st, pPATH) {
 678   dNPathNodes(1, NPathArg);
 679   MAGIC *magic_pointer = SvMAGIC(thing); /* caller ensures thing is SvMAGICAL */
 680
 681   /* push a dummy node for NPathSetNode to update inside the while loop */
 682   NPathPushNode("dummy", NPtype_NAME);
 683
 684   /* Have we seen the magic pointer?  (NULL has always been seen before)  */
 685   while (check_new(st, magic_pointer)) {
 686
 687     NPathSetNode(magic_pointer, NPtype_MAGIC);
 688
 689     ADD_SIZE(st, "mg", sizeof(MAGIC));
 690     /* magic vtables aren't freed when magic is freed, so don't count them.
 691        (They are static structures. Anything that assumes otherwise is buggy.)
 692     */
 693
 694
 695     TRY_TO_CATCH_SEGV {
 696         /* XXX only chase mg_obj if mg->mg_flags & MGf_REFCOUNTED ? */
 697         sv_size(aTHX_ st, NPathLink("mg_obj"), magic_pointer->mg_obj, TOTAL_SIZE_RECURSION);
 698         if (magic_pointer->mg_len == HEf_SVKEY) {
 699             sv_size(aTHX_ st, NPathLink("mg_ptr"), (SV *)magic_pointer->mg_ptr, TOTAL_SIZE_RECURSION);
 700         }
 701 #if defined(PERL_MAGIC_utf8) && defined (PERL_MAGIC_UTF8_CACHESIZE)
 702         else if (magic_pointer->mg_type == PERL_MAGIC_utf8) {
 703             if (check_new(st, magic_pointer->mg_ptr)) {
 704                 ADD_SIZE(st, "PERL_MAGIC_utf8", PERL_MAGIC_UTF8_CACHESIZE * 2 * sizeof(STRLEN));
 705             }
 706         }
 707 #endif
 708         /* XXX also handle mg->mg_type == PERL_MAGIC_utf8 ? */
 709         else if (magic_pointer->mg_len > 0) {
 710             if(0)do_magic_dump(0, Perl_debug_log, magic_pointer, 0, 0, FALSE, 0);
 711             if (check_new(st, magic_pointer->mg_ptr)) {
 712                 ADD_SIZE(st, "mg_len", magic_pointer->mg_len);
 713             }
 714         }
 715
 716         /* Get the next in the chain */
 717         magic_pointer = magic_pointer->mg_moremagic;
 718     }
 719     CAUGHT_EXCEPTION {
 720         if (st->dangle_whine)
 721             warn( "Devel::Size: Encountered bad magic at: %p\n", magic_pointer );
 722     }
 723   }
 724 }
 725
 726 #define check_new_and_strlen(st, p, ppath) S_check_new_and_strlen(aTHX_ st, p, ppath)
 727 static void
 728 S_check_new_and_strlen(pTHX_ struct state *st, const char *const p, pPATH) {
 729     dNPathNodes(1, NPathArg->prev);
 730     if(check_new(st, p)) {
 731         NPathPushNode(NPathArg->id, NPtype_NAME);
 732         ADD_SIZE(st, NPathArg->id, 1 + strlen(p));
 733     }
 734 }
 735
 736 static void
 737 regex_size(pTHX_ const REGEXP * const baseregex, struct state *st, pPATH) {
 738     dNPathNodes(1, NPathArg);
 739     if(!check_new(st, baseregex))
 740         return;
 741   NPathPushNode("regex_size", NPtype_NAME);
 742   ADD_SIZE(st, "REGEXP", sizeof(REGEXP));
 743 #if (PERL_VERSION < 11)
 744   /* Note the size of the paren offset thing */
 745   ADD_SIZE(st, "nparens", sizeof(I32) * baseregex->nparens * 2);
 746   ADD_SIZE(st, "precomp", strlen(baseregex->precomp));
 747 #else
 748   ADD_SIZE(st, "regexp", sizeof(struct regexp));
 749   ADD_SIZE(st, "nparens", sizeof(I32) * SvANY(baseregex)->nparens * 2);
 750   /*ADD_SIZE(st, strlen(SvANY(baseregex)->subbeg));*/
 751 #endif
 752   if (st->go_yell && !st->regex_whine) {
 753     carp("Devel::Size: Calculated sizes for compiled regexes are incompatible, and probably always will be");
 754     st->regex_whine = 1;
 755   }
 756 }
 757
 758 static int
 759 hek_size(pTHX_ struct state *st, HEK *hek, U32 shared, pPATH)
 760 {
 761     dNPathNodes(1, NPathArg);
 762
 763     /* Hash keys can be shared. Have we seen this before? */
 764     if (!check_new(st, hek))
 765         return 0;
 766     NPathPushNode("hek", NPtype_NAME);
 767     ADD_SIZE(st, "hek_len", HEK_BASESIZE + hek->hek_len
 768 #if PERL_VERSION < 8
 769         + 1 /* No hash key flags prior to 5.8.0  */
 770 #else
 771         + 2
 772 #endif
 773         );
 774     if (shared) {
 775 #if PERL_VERSION < 10
 776         ADD_SIZE(st, "he", sizeof(struct he));
 777 #else
 778         ADD_SIZE(st, "shared_he", STRUCT_OFFSET(struct shared_he, shared_he_hek));
 779 #endif
 780     }
 781     return 1;
 782 }
 783
 784 static void
 785 refcounted_he_size(pTHX_ struct state *st, struct refcounted_he *he, pPATH)
 786 {
 787   dNPathNodes(1, NPathArg);
 788   if (!check_new(st, he))
 789     return;
 790   NPathPushNode("refcounted_he_size", NPtype_NAME);
 791   ADD_SIZE(st, "refcounted_he", sizeof(struct refcounted_he));
 792
 793 #ifdef USE_ITHREADS
 794   ADD_SIZE(st, "refcounted_he_data", NPtype_NAME);
 795 #else
 796   hek_size(aTHX_ st, he->refcounted_he_hek, 0, NPathLink("refcounted_he_hek"));
 797 #endif
 798
 799   if (he->refcounted_he_next)
 800     refcounted_he_size(aTHX_ st, he->refcounted_he_next, NPathLink("refcounted_he_next"));
 801 }
 802
 803 static void op_size_class(pTHX_ const OP * const baseop, opclass op_class, bool skip_op_struct, struct state *st, pPATH);
 804
 805 static void
 806 op_size(pTHX_ const OP * const baseop, struct state *st, pPATH)
 807 {
 808   op_size_class(aTHX_ baseop, cc_opclass(baseop), 0, st, NPathArg);
 809 }
 810
 811 static void
 812 op_size_class(pTHX_ const OP * const baseop, opclass op_class, bool skip_op_struct, struct state *st, pPATH)
 813 {
 814     /* op_size recurses to follow the chain of opcodes.  For the node path we
 815      * don't want the chain to be 'nested' in the path so we use dNPathUseParent().
 816      * Also, to avoid a link-to-a-link the caller should use NPathLinkAndNode()
 817      * instead of NPathLink().
 818      */
 819     dNPathUseParent(NPathArg);
 820
 821     TRY_TO_CATCH_SEGV {
 822         TAG;
 823         if(!check_new(st, baseop))
 824             return;
 825         TAG;
 826         op_size(aTHX_ baseop->op_next, st, NPathOpLink);
 827 #ifdef PELR_MAD
 828         madprop_size(aTHX_ st, NPathOpLink, baseop->op_madprop);
 829 #endif
 830         TAG;
 831         switch (op_class) {
 832         case OPc_BASEOP: TAG;
 833             if (!skip_op_struct)
 834                 ADD_SIZE(st, "op", sizeof(struct op));
 835             TAG;break;
 836         case OPc_UNOP: TAG;
 837             if (!skip_op_struct)
 838                 ADD_SIZE(st, "unop", sizeof(struct unop));
 839             op_size(aTHX_ ((UNOP *)baseop)->op_first, st, NPathOpLink);
 840             TAG;break;
 841         case OPc_BINOP: TAG;
 842             if (!skip_op_struct)
 843                 ADD_SIZE(st, "binop", sizeof(struct binop));
 844             op_size(aTHX_ ((BINOP *)baseop)->op_first, st, NPathOpLink);
 845             op_size(aTHX_ ((BINOP *)baseop)->op_last, st, NPathOpLink);
 846             TAG;break;
 847         case OPc_LOGOP: TAG;
 848             if (!skip_op_struct)
 849                 ADD_SIZE(st, "logop", sizeof(struct logop));
 850             op_size(aTHX_ ((BINOP *)baseop)->op_first, st, NPathOpLink);
 851             op_size(aTHX_ ((LOGOP *)baseop)->op_other, st, NPathOpLink);
 852             TAG;break;
 853 #ifdef OA_CONDOP
 854         case OPc_CONDOP: TAG;
 855             if (!skip_op_struct)
 856                 ADD_SIZE(st, "condop", sizeof(struct condop));
 857             op_size(aTHX_ ((BINOP *)baseop)->op_first, st, NPathOpLink);
 858             op_size(aTHX_ ((CONDOP *)baseop)->op_true, st, NPathOpLink);
 859             op_size(aTHX_ ((CONDOP *)baseop)->op_false, st, NPathOpLink);
 860             TAG;break;
 861 #endif
 862         case OPc_LISTOP: TAG;
 863             if (!skip_op_struct)
 864                 ADD_SIZE(st, "listop", sizeof(struct listop));
 865             op_size(aTHX_ ((LISTOP *)baseop)->op_first, st, NPathOpLink);
 866             op_size(aTHX_ ((LISTOP *)baseop)->op_last, st, NPathOpLink);
 867             TAG;break;
 868         case OPc_PMOP: TAG;
 869             if (!skip_op_struct)
 870                 ADD_SIZE(st, "pmop", sizeof(struct pmop));
 871             op_size(aTHX_ ((PMOP *)baseop)->op_first, st, NPathOpLink);
 872             op_size(aTHX_ ((PMOP *)baseop)->op_last, st, NPathOpLink);
 873 #if PERL_VERSION < 9 || (PERL_VERSION == 9 && PERL_SUBVERSION < 5)
 874             op_size(aTHX_ ((PMOP *)baseop)->op_pmreplroot, st, NPathOpLink);
 875             op_size(aTHX_ ((PMOP *)baseop)->op_pmreplstart, st, NPathOpLink);
 876 #endif
 877             /* This is defined away in perl 5.8.x, but it is in there for
 878                5.6.x */
 879 #ifdef PM_GETRE
 880             regex_size(aTHX_ PM_GETRE((PMOP *)baseop), st, NPathLink("PM_GETRE"));
 881 #else
 882             regex_size(aTHX_ ((PMOP *)baseop)->op_pmregexp, st, NPathLink("op_pmregexp"));
 883 #endif
 884             TAG;break;
 885         case OPc_SVOP: TAG;
 886             if (!skip_op_struct)
 887                 ADD_SIZE(st, "svop", sizeof(struct svop));
 888             if (!(baseop->op_type == OP_AELEMFAST
 889                   && baseop->op_flags & OPf_SPECIAL)) {
 890                 /* not an OP_PADAV replacement */
 891                 sv_size(aTHX_ st, NPathLink("SVOP"), ((SVOP *)baseop)->op_sv, SOME_RECURSION);
 892             }
 893             TAG;break;
 894 #ifdef OA_PADOP
 895         case OPc_PADOP: TAG;
 896             if (!skip_op_struct)
 897                 ADD_SIZE(st, "padop", sizeof(struct padop));
 898             TAG;break;
 899 #endif
 900 #ifdef OA_GVOP
 901         case OPc_GVOP: TAG;
 902             if (!skip_op_struct)
 903                 ADD_SIZE(st, "gvop", sizeof(struct gvop));
 904             sv_size(aTHX_ st, NPathLink("GVOP"), ((GVOP *)baseop)->op_gv, SOME_RECURSION);
 905             TAG;break;
 906 #endif
 907         case OPc_PVOP: TAG;
 908             check_new_and_strlen(st, ((PVOP *)baseop)->op_pv, NPathLink("op_pv"));
 909             TAG;break;
 910         case OPc_LOOP: TAG;
 911             if (!skip_op_struct)
 912                 ADD_SIZE(st, "loop", sizeof(struct loop));
 913             op_size(aTHX_ ((LOOP *)baseop)->op_first, st, NPathOpLink);
 914             op_size(aTHX_ ((LOOP *)baseop)->op_last, st, NPathOpLink);
 915             op_size(aTHX_ ((LOOP *)baseop)->op_redoop, st, NPathOpLink);
 916             op_size(aTHX_ ((LOOP *)baseop)->op_nextop, st, NPathOpLink);
 917             op_size(aTHX_ ((LOOP *)baseop)->op_lastop, st, NPathOpLink);
 918             TAG;break;
 919         case OPc_COP: TAG;
 920         {
 921           COP *basecop;
 922           COPHH *hh;
 923           basecop = (COP *)baseop;
 924           if (!skip_op_struct)
 925             ADD_SIZE(st, "cop", sizeof(struct cop));
 926
 927           /* Change 33656 by nicholas@mouse-mill on 2008/04/07 11:29:51
 928           Eliminate cop_label from struct cop by storing a label as the first
 929           entry in the hints hash. Most statements don't have labels, so this
 930           will save memory. Not sure how much.
 931           The check below will be incorrect fail on bleadperls
 932           before 5.11 @33656, but later than 5.10, producing slightly too
 933           small memory sizes on these Perls. */
 934 #if (PERL_VERSION < 11)
 935           check_new_and_strlen(st, basecop->cop_label, NPathLink("cop_label"));
 936 #endif
 937 #ifdef USE_ITHREADS
 938           check_new_and_strlen(st, basecop->cop_file, NPathLink("cop_file"));
 939           check_new_and_strlen(st, basecop->cop_stashpv, NPathLink("cop_stashpv"));
 940 #else
 941           if (SvREFCNT(basecop->cop_stash) == 1) /* XXX hack? */
 942             sv_size(aTHX_ st, NPathLink("cop_stash"), (SV *)basecop->cop_stash, SOME_RECURSION);
 943           sv_size(aTHX_ st, NPathLink("cop_filegv"), (SV *)basecop->cop_filegv, SOME_RECURSION);
 944 #endif
 945
 946           hh = CopHINTHASH_get(basecop);
 947           refcounted_he_size(aTHX_ st, hh, 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 (sv_size(aTHX_ st, NPathLink("compcv"), (SV*)ps->compcv, TOTAL_SIZE_RECURSION))
1503         ADD_LINK_ATTR(st, NPattr_NOTE, "i", ps - parser->ps);
1504   }
1505   NPathPopNode;
1506
1507   sv_size(aTHX_ st, NPathLink("lex_repl"), (SV*)parser->lex_repl, TOTAL_SIZE_RECURSION);
1508   sv_size(aTHX_ st, NPathLink("lex_stuff"), (SV*)parser->lex_stuff, TOTAL_SIZE_RECURSION);
1509   sv_size(aTHX_ st, NPathLink("linestr"), (SV*)parser->linestr, TOTAL_SIZE_RECURSION);
1510   sv_size(aTHX_ st, NPathLink("in_my_stash"), (SV*)parser->in_my_stash, TOTAL_SIZE_RECURSION);
1511   /*sv_size(aTHX_ st, NPathLink("rsfp"), parser->rsfp, TOTAL_SIZE_RECURSION); */
1512   sv_size(aTHX_ st, NPathLink("rsfp_filters"), (SV*)parser->rsfp_filters, TOTAL_SIZE_RECURSION);
1513 #ifdef PERL_MAD
1514   sv_size(aTHX_ st, NPathLink("endwhite"), parser->endwhite, TOTAL_SIZE_RECURSION);
1515   sv_size(aTHX_ st, NPathLink("nextwhite"), parser->nextwhite, TOTAL_SIZE_RECURSION);
1516   sv_size(aTHX_ st, NPathLink("skipwhite"), parser->skipwhite, TOTAL_SIZE_RECURSION);
1517   sv_size(aTHX_ st, NPathLink("thisclose"), parser->thisclose, TOTAL_SIZE_RECURSION);
1518   madprop_size(aTHX_ st, NPathLink("thismad"), parser->thismad);
1519   sv_size(aTHX_ st, NPathLink("thisopen"), parser->thisopen, TOTAL_SIZE_RECURSION);
1520   sv_size(aTHX_ st, NPathLink("thisstuff"), parser->thisstuff, TOTAL_SIZE_RECURSION);
1521   sv_size(aTHX_ st, NPathLink("thistoken"), parser->thistoken, TOTAL_SIZE_RECURSION);
1522   sv_size(aTHX_ st, NPathLink("thiswhite"), parser->thiswhite, TOTAL_SIZE_RECURSION);
1523 #endif
1524   op_size_class(aTHX_ (OP*)parser->saved_curcop, OPc_COP, 0,
1525                 st, NPathLink("saved_curcop"));
1526
1527   if (parser->old_parser)
1528     parser_size(aTHX_ st, NPathLink("old_parser"), parser->old_parser);
1529 }
1530
1531 static void
1532 perl_size(pTHX_ struct state *const st, pPATH)
1533 {
1534   dNPathNodes(3, NPathArg);
1535
1536   /* if(!check_new(st, interp)) return; */
1537   NPathPushNode("perl", NPtype_NAME);
1538 #if defined(MULTIPLICITY)
1539   ADD_SIZE(st, "PerlInterpreter", sizeof(PerlInterpreter));
1540 #endif
1541 /*
1542  *      perl
1543  *          PL_defstash
1544  *          others
1545  *      unknown <== = O/S Heap size - perl - free_malloc_space
1546  */
1547   /* start with PL_defstash to get everything reachable from \%main:: */
1548   sv_size(aTHX_ st, NPathLink("PL_defstash"), (SV*)PL_defstash, TOTAL_SIZE_RECURSION);
1549
1550   NPathPushNode("others", NPtype_NAME); /* group these (typically much smaller) items */
1551   sv_size(aTHX_ st, NPathLink("PL_defgv"), (SV*)PL_defgv, TOTAL_SIZE_RECURSION);
1552   sv_size(aTHX_ st, NPathLink("PL_incgv"), (SV*)PL_incgv, TOTAL_SIZE_RECURSION);
1553   sv_size(aTHX_ st, NPathLink("PL_rs"), (SV*)PL_rs, TOTAL_SIZE_RECURSION);
1554   sv_size(aTHX_ st, NPathLink("PL_fdpid"), (SV*)PL_fdpid, TOTAL_SIZE_RECURSION);
1555   sv_size(aTHX_ st, NPathLink("PL_modglobal"), (SV*)PL_modglobal, TOTAL_SIZE_RECURSION);
1556   sv_size(aTHX_ st, NPathLink("PL_errors"), (SV*)PL_errors, TOTAL_SIZE_RECURSION);
1557   sv_size(aTHX_ st, NPathLink("PL_stashcache"), (SV*)PL_stashcache, TOTAL_SIZE_RECURSION);
1558   sv_size(aTHX_ st, NPathLink("PL_patchlevel"), (SV*)PL_patchlevel, TOTAL_SIZE_RECURSION);
1559   sv_size(aTHX_ st, NPathLink("PL_apiversion"), (SV*)PL_apiversion, TOTAL_SIZE_RECURSION);
1560   sv_size(aTHX_ st, NPathLink("PL_registered_mros"), (SV*)PL_registered_mros, TOTAL_SIZE_RECURSION);
1561 #ifdef USE_ITHREADS
1562   sv_size(aTHX_ st, NPathLink("PL_regex_padav"), (SV*)PL_regex_padav, TOTAL_SIZE_RECURSION);
1563 #endif
1564   sv_size(aTHX_ st, NPathLink("PL_warnhook"), (SV*)PL_warnhook, TOTAL_SIZE_RECURSION);
1565   sv_size(aTHX_ st, NPathLink("PL_diehook"), (SV*)PL_diehook, TOTAL_SIZE_RECURSION);
1566   sv_size(aTHX_ st, NPathLink("PL_endav"), (SV*)PL_endav, TOTAL_SIZE_RECURSION);
1567   sv_size(aTHX_ st, NPathLink("PL_main_cv"), (SV*)PL_main_cv, TOTAL_SIZE_RECURSION);
1568   sv_size(aTHX_ st, NPathLink("PL_main_root"), (SV*)PL_main_root, TOTAL_SIZE_RECURSION);
1569   sv_size(aTHX_ st, NPathLink("PL_main_start"), (SV*)PL_main_start, TOTAL_SIZE_RECURSION);
1570   sv_size(aTHX_ st, NPathLink("PL_envgv"), (SV*)PL_envgv, TOTAL_SIZE_RECURSION);
1571   sv_size(aTHX_ st, NPathLink("PL_hintgv"), (SV*)PL_hintgv, TOTAL_SIZE_RECURSION);
1572   sv_size(aTHX_ st, NPathLink("PL_e_script"), (SV*)PL_e_script, TOTAL_SIZE_RECURSION);
1573   sv_size(aTHX_ st, NPathLink("PL_encoding"), (SV*)PL_encoding, TOTAL_SIZE_RECURSION);
1574   sv_size(aTHX_ st, NPathLink("PL_ofsgv"), (SV*)PL_ofsgv, TOTAL_SIZE_RECURSION);
1575   sv_size(aTHX_ st, NPathLink("PL_argvout_stack"), (SV*)PL_argvout_stack, TOTAL_SIZE_RECURSION);
1576   sv_size(aTHX_ st, NPathLink("PL_beginav"), (SV*)PL_beginav, TOTAL_SIZE_RECURSION);
1577   sv_size(aTHX_ st, NPathLink("PL_beginav_save"), (SV*)PL_beginav_save, TOTAL_SIZE_RECURSION);
1578   sv_size(aTHX_ st, NPathLink("PL_checkav_save"), (SV*)PL_checkav_save, TOTAL_SIZE_RECURSION);
1579   sv_size(aTHX_ st, NPathLink("PL_unitcheckav"), (SV*)PL_unitcheckav, TOTAL_SIZE_RECURSION);
1580   sv_size(aTHX_ st, NPathLink("PL_unitcheckav_save"), (SV*)PL_unitcheckav_save, TOTAL_SIZE_RECURSION);
1581   sv_size(aTHX_ st, NPathLink("PL_endav"), (SV*)PL_endav, TOTAL_SIZE_RECURSION);
1582   sv_size(aTHX_ st, NPathLink("PL_checkav"), (SV*)PL_checkav, TOTAL_SIZE_RECURSION);
1583   sv_size(aTHX_ st, NPathLink("PL_initav"), (SV*)PL_initav, TOTAL_SIZE_RECURSION);
1584   sv_size(aTHX_ st, NPathLink("PL_isarev"), (SV*)PL_isarev, TOTAL_SIZE_RECURSION);
1585   sv_size(aTHX_ st, NPathLink("PL_fdpid"), (SV*)PL_fdpid, TOTAL_SIZE_RECURSION);
1586   sv_size(aTHX_ st, NPathLink("PL_preambleav"), (SV*)PL_preambleav, TOTAL_SIZE_RECURSION);
1587   sv_size(aTHX_ st, NPathLink("PL_ors_sv"), (SV*)PL_ors_sv, TOTAL_SIZE_RECURSION);
1588   sv_size(aTHX_ st, NPathLink("PL_modglobal"), (SV*)PL_modglobal, TOTAL_SIZE_RECURSION);
1589   sv_size(aTHX_ st, NPathLink("PL_custom_op_names"), (SV*)PL_custom_op_names, TOTAL_SIZE_RECURSION);
1590   sv_size(aTHX_ st, NPathLink("PL_custom_op_descs"), (SV*)PL_custom_op_descs, TOTAL_SIZE_RECURSION);
1591   sv_size(aTHX_ st, NPathLink("PL_custom_ops"), (SV*)PL_custom_ops, TOTAL_SIZE_RECURSION);
1592   sv_size(aTHX_ st, NPathLink("PL_compcv"), (SV*)PL_compcv, TOTAL_SIZE_RECURSION);
1593   sv_size(aTHX_ st, NPathLink("PL_DBcv"), (SV*)PL_DBcv, TOTAL_SIZE_RECURSION);
1594 #ifdef PERL_USES_PL_PIDSTATUS
1595   sv_size(aTHX_ st, NPathLink("PL_pidstatus"), (SV*)PL_pidstatus, TOTAL_SIZE_RECURSION);
1596 #endif
1597   sv_size(aTHX_ st, NPathLink("PL_subname"), (SV*)PL_subname, TOTAL_SIZE_RECURSION);
1598 #ifdef USE_LOCALE_NUMERIC
1599   sv_size(aTHX_ st, NPathLink("PL_numeric_radix_sv"), (SV*)PL_numeric_radix_sv, TOTAL_SIZE_RECURSION);
1600   check_new_and_strlen(st, PL_numeric_name, NPathLink("PL_numeric_name"));
1601 #endif
1602 #ifdef USE_LOCALE_COLLATE
1603   check_new_and_strlen(st, PL_collation_name, NPathLink("PL_collation_name"));
1604 #endif
1605   check_new_and_strlen(st, PL_origfilename, NPathLink("PL_origfilename"));
1606   check_new_and_strlen(st, PL_inplace, NPathLink("PL_inplace"));
1607   check_new_and_strlen(st, PL_osname, NPathLink("PL_osname"));
1608   if (PL_op_mask && check_new(st, PL_op_mask))
1609     ADD_SIZE(st, "PL_op_mask", PL_maxo);
1610   if (PL_exitlistlen && check_new(st, PL_exitlist))
1611     ADD_SIZE(st, "PL_exitlist", (PL_exitlistlen * sizeof(PerlExitListEntry *))
1612                               + (PL_exitlistlen * sizeof(PerlExitListEntry)));
1613 #ifdef PERL_IMPLICIT_CONTEXT
1614   if (PL_my_cxt_size && check_new(st, PL_my_cxt_list)) {
1615     ADD_SIZE(st, "PL_my_cxt_list", (PL_my_cxt_size * sizeof(void *)));
1616 #ifdef PERL_GLOBAL_STRUCT_PRIVATE
1617     ADD_SIZE(st, "PL_my_cxt_keys", (PL_my_cxt_size * sizeof(char *)));
1618 #endif
1619   }
1620 #endif
1621   /* TODO PL_stashpad */
1622   op_size_class(aTHX_ (OP*)&PL_compiling, OPc_COP, 1, st, NPathLink("PL_compiling"));
1623   op_size_class(aTHX_ (OP*)PL_curcopdb, OPc_COP, 0, st, NPathLink("PL_curcopdb"));
1624
1625   parser_size(aTHX_ st, NPathLink("PL_parser"), PL_parser);
1626   /* TODO stacks: cur, main, tmps, mark, scope, save */
1627   /* TODO PL_exitlist */
1628   /* TODO PL_reentrant_buffers etc */
1629   /* TODO environ */
1630   /* TODO PerlIO? PL_known_layers PL_def_layerlist PL_perlio_fd_refcnt etc */
1631   /* TODO threads? */
1632   /* TODO anything missed? */
1633
1634   /* --- by this point we should have seen all reachable SVs --- */
1635
1636   /* in theory we shouldn't have any elements in PL_strtab that haven't been seen yet */
1637   sv_size(aTHX_ st, NPathLink("PL_strtab-unseen"), (SV*)PL_strtab, TOTAL_SIZE_RECURSION);
1638
1639   /* unused space in sv head arenas */
1640   if (PL_sv_root) {
1641     SV *p = PL_sv_root;
1642     UV free_heads = 1;
1643 #  define SvARENA_CHAIN(sv)     SvANY(sv) /* XXX breaks encapsulation*/
1644     while ((p = MUTABLE_SV(SvARENA_CHAIN(p)))) {
1645         if (!check_new(st, p)) /* sanity check */
1646             warn("Free'd SV head unexpectedly already seen");
1647         ++free_heads;
1648     }
1649     NPathPushNode("unused_sv_heads", NPtype_NAME);
1650     ADD_SIZE(st, "sv", free_heads * sizeof(SV));
1651     NPathPopNode;
1652   }
1653   /* XXX iterate over bodies_by_type and crawl the free chains for each */
1654
1655   /* iterate over all SVs to find any we've not accounted for yet */
1656   /* once the code above is visiting all SVs, any found here have been leaked */
1657   unseen_sv_size(aTHX_ st, NPathLink("unaccounted"));
1658 }
1659
1660
1661 MODULE = Devel::SizeMe        PACKAGE = Devel::SizeMe
1662
1663 PROTOTYPES: DISABLE
1664
1665 UV
1666 size(orig_thing)
1667      SV *orig_thing
1668 ALIAS:
1669     total_size = TOTAL_SIZE_RECURSION
1670 CODE:
1671 {
1672   SV *thing = orig_thing;
1673   struct state *st = new_state(aTHX);
1674
1675   /* If they passed us a reference then dereference it. This is the
1676      only way we can check the sizes of arrays and hashes */
1677   if (SvROK(thing)) {
1678     thing = SvRV(thing);
1679   }
1680
1681   sv_size(aTHX_ st, NULL, thing, ix);
1682   RETVAL = st->total_size;
1683   free_state(aTHX_ st);
1684 }
1685 OUTPUT:
1686   RETVAL
1687
1688 UV
1689 perl_size()
1690 CODE:
1691 {
1692   /* just the current perl interpreter */
1693   struct state *st = new_state(aTHX);
1694   st->min_recurse_threshold = NO_RECURSION; /* so always recurse */
1695   perl_size(aTHX_ st, NULL);
1696   RETVAL = st->total_size;
1697   free_state(aTHX_ st);
1698 }
1699 OUTPUT:
1700   RETVAL
1701
1702 UV
1703 heap_size()
1704 CODE:
1705 {
1706   /* the current perl interpreter plus malloc, in the context of total heap size */
1707 # ifdef _MALLOC_MALLOC_H_ /* OSX. Now sure where else mstats is available */
1708 # define HAS_MSTATS
1709 # endif
1710 # ifdef HAS_MSTATS
1711   /* some systems have the SVID2/XPG mallinfo structure and function */
1712   struct mstats ms = mstats(); /* mstats() first */
1713 # endif
1714   struct state *st = new_state(aTHX);
1715   dNPathNodes(1, NULL);
1716   NPathPushNode("heap", NPtype_NAME);
1717
1718   st->min_recurse_threshold = NO_RECURSION; /* so always recurse */
1719
1720   perl_size(aTHX_ st, NPathLink("perl_interp"));
1721 # ifdef HAS_MSTATS
1722   NPathSetNode("free_malloc_space", NPtype_NAME);
1723   ADD_SIZE(st, "bytes_free", ms.bytes_free);
1724   ADD_ATTR(st, NPattr_NOTE, "bytes_total", ms.bytes_total);
1725   ADD_ATTR(st, NPattr_NOTE, "bytes_used",  ms.bytes_used);
1726   ADD_ATTR(st, NPattr_NOTE, "chunks_used", ms.chunks_used);
1727   ADD_ATTR(st, NPattr_NOTE, "chunks_free", ms.chunks_free);
1728   /* TODO get heap size from OS and add a node: unknown = heapsize - perl - ms.bytes_free */
1729   /* for now we use bytes_total as an approximation */
1730   NPathSetNode("unknown", NPtype_NAME);
1731   ADD_SIZE(st, "unknown", ms.bytes_total - st->total_size);
1732 # else
1733     /* XXX ? */
1734 # endif
1735
1736   RETVAL = st->total_size;
1737   free_state(aTHX_ st);
1738 }
1739 OUTPUT:
1740   RETVAL