SizeMe.xs

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