Size.xs

   1 /* -*- mode: C -*- */
   2
   3 #undef NDEBUG /* XXX */
   4 #include <assert.h>
   5
   6 #define PERL_NO_GET_CONTEXT
   7
   8 #include "EXTERN.h"
   9 #include "perl.h"
  10 #include "XSUB.h"
  11 #include "ppport.h"
  12
  13 /* Not yet in ppport.h */
  14 #ifndef CvISXSUB
  15 #  define CvISXSUB(cv)  (CvXSUB(cv) ? TRUE : FALSE)
  16 #endif
  17 #ifndef SvRV_const
  18 #  define SvRV_const(rv) SvRV(rv)
  19 #endif
  20 #ifndef SvOOK_offset
  21 #  define SvOOK_offset(sv, len) STMT_START { len = SvIVX(sv); } STMT_END
  22 #endif
  23 #ifndef SvIsCOW
  24 #  define SvIsCOW(sv)           ((SvFLAGS(sv) & (SVf_FAKE | SVf_READONLY)) == \
  25                                     (SVf_FAKE | SVf_READONLY))
  26 #endif
  27 #ifndef SvIsCOW_shared_hash
  28 #  define SvIsCOW_shared_hash(sv)   (SvIsCOW(sv) && SvLEN(sv) == 0)
  29 #endif
  30 #ifndef SvSHARED_HEK_FROM_PV
  31 #  define SvSHARED_HEK_FROM_PV(pvx) \
  32         ((struct hek*)(pvx - STRUCT_OFFSET(struct hek, hek_key)))
  33 #endif
  34
  35 #if PERL_VERSION < 6
  36 #  define PL_opargs opargs
  37 #  define PL_op_name op_name
  38 #endif
  39
  40 #ifdef _MSC_VER
  41 /* "structured exception" handling is a Microsoft extension to C and C++.
  42    It's *not* C++ exception handling - C++ exception handling can't capture
  43    SEGVs and suchlike, whereas this can. There's no known analagous
  44     functionality on other platforms.  */
  45 #  include <excpt.h>
  46 #  define TRY_TO_CATCH_SEGV __try
  47 #  define CAUGHT_EXCEPTION __except(EXCEPTION_EXECUTE_HANDLER)
  48 #else
  49 #  define TRY_TO_CATCH_SEGV if(1)
  50 #  define CAUGHT_EXCEPTION else
  51 #endif
  52
  53 #ifdef __GNUC__
  54 # define __attribute__(x)
  55 #endif
  56
  57 #if 0 && defined(DEBUGGING)
  58 #define dbg_printf(x) printf x
  59 #else
  60 #define dbg_printf(x)
  61 #endif
  62
  63 #define TAG /* printf( "# %s(%d)\n", __FILE__, __LINE__ ) */
  64 #define carp puts
  65
  66 /* The idea is to have a tree structure to store 1 bit per possible pointer
  67    address. The lowest 16 bits are stored in a block of 8092 bytes.
  68    The blocks are in a 256-way tree, indexed by the reset of the pointer.
  69    This can cope with 32 and 64 bit pointers, and any address space layout,
  70    without excessive memory needs. The assumption is that your CPU cache
  71    works :-) (And that we're not going to bust it)  */
  72
  73 #define BYTE_BITS    3
  74 #define LEAF_BITS   (16 - BYTE_BITS)
  75 #define LEAF_MASK   0x1FFF
  76
  77 typedef struct npath_node_st npath_node_t;
  78 struct npath_node_st {
  79     npath_node_t *prev;
  80     const void *id;
  81     U8 type;
  82     U8 flags;
  83     UV seqn;
  84     U16 depth;
  85 };
  86
  87 struct state {
  88     UV total_size;
  89     bool regex_whine;
  90     bool fm_whine;
  91     bool dangle_whine;
  92     bool go_yell;
  93     /* My hunch (not measured) is that for most architectures pointers will
  94        start with 0 bits, hence the start of this array will be hot, and the
  95        end unused. So put the flags next to the hot end.  */
  96     void *tracking[256];
  97     int min_recurse_threshold;
  98     /* callback hooks and data */
  99     int (*add_attr_cb)(struct state *st, npath_node_t *npath_node, UV attr_type, const char *name, UV value);
 100     void (*free_state_cb)(struct state *st);
 101     UV seqn;
 102     void *state_cb_data; /* free'd by free_state() after free_state_cb() call */
 103     /* this stuff wil be moved to state_cb_data later */
 104     FILE *node_stream;
 105 };
 106
 107 #define ADD_SIZE(st, leafname, bytes) (NPathAddSizeCb(st, leafname, bytes) (st)->total_size += (bytes))
 108
 109 #define PATH_TRACKING
 110 #ifdef PATH_TRACKING
 111
 112 #define pPATH npath_node_t *NPathArg
 113
 114 /* A subtle point here is that dNPathNodes and NPathPushNode leave NP pointing
 115  * to the next unused slot (though with prev already filled in)
 116  * whereas NPathLink leaves NP unchanged, it just fills in the slot NP points
 117  * to and passes that NP value to the function being called.
 118  * seqn==0 indicates the node is new (hasn't been output yet)
 119  */
 120 #define dNPathNodes(nodes, prev_np) \
 121             npath_node_t name_path_nodes[nodes+1]; /* +1 for NPathLink */ \
 122             npath_node_t *NP = &name_path_nodes[0]; \
 123             NP->seqn = NP->type = 0; NP->id = Nullch; /* safety/debug */ \
 124             NP->prev = prev_np
 125 #define NPathPushNode(nodeid, nodetype) \
 126             NP->id = nodeid; \
 127             NP->type = nodetype; \
 128             NP->seqn = 0; \
 129             if(0)fprintf(stderr,"NPathPushNode (%p <-) %p <- [%d %s]\n", NP->prev, NP, nodetype,(char*)nodeid);\
 130             NP++; \
 131             NP->id = Nullch; /* safety/debug */ \
 132             NP->seqn = 0; \
 133             NP->prev = (NP-1)
 134 #define NPathSetNode(nodeid, nodetype) \
 135             (NP-1)->id = nodeid; \
 136             (NP-1)->type = nodetype; \
 137             if(0)fprintf(stderr,"NPathSetNode (%p <-) %p <- [%d %s]\n", (NP-1)->prev, (NP-1), nodetype,(char*)nodeid);\
 138             (NP-1)->seqn = 0;
 139
 140 /* dNPathUseParent points NP directly the the parents' name_path_nodes array
 141  * So the function can only safely call ADD_*() but not NPathLink, unless the
 142  * caller has spare nodes in its name_path_nodes.
 143  */
 144 #define dNPathUseParent(prev_np) npath_node_t *NP = (((prev_np+1)->prev = prev_np), prev_np+1)
 145
 146 #define NPtype_NAME     0x01
 147 #define NPtype_LINK     0x02
 148 #define NPtype_SV       0x03
 149 #define NPtype_MAGIC    0x04
 150 #define NPtype_OP       0x05
 151
 152 #define NPattr_LEAFSIZE 0x00
 153 #define NPattr_NAME     0x01
 154 #define NPattr_PADFAKE  0x02
 155 #define NPattr_PADNAME  0x03
 156 #define NPattr_PADTMP   0x04
 157
 158 #define _NPathLink(np, nid, ntype)   (((np)->id=nid), ((np)->type=ntype), ((np)->seqn=0))
 159 #define NPathLink(nid)               (_NPathLink(NP, nid, NPtype_LINK), NP)
 160 /* add a link and a name node to the path - a special case for op_size */
 161 #define NPathLinkAndNode(nid, nid2)  (_NPathLink(NP, nid, NPtype_LINK), _NPathLink(NP+1, nid2, NPtype_NAME), ((NP+1)->prev=NP), (NP+1))
 162 #define NPathOpLink  (NPathArg)
 163 #define NPathAddSizeCb(st, name, bytes) (st->add_attr_cb && st->add_attr_cb(st, NP-1, NPattr_LEAFSIZE, (name), (bytes))),
 164 #define ADD_ATTR(st, attr_type, attr_name, attr_value) (st->add_attr_cb && st->add_attr_cb(st, NP-1, attr_type, attr_name, attr_value))
 165
 166 #else
 167
 168 #define NPathAddSizeCb(st, name, bytes)
 169 #define pPATH void *npath_dummy /* XXX ideally remove */
 170 #define dNPathNodes(nodes, prev_np)  dNOOP
 171 #define NPathLink(nodeid, nodetype)  NULL
 172 #define NPathOpLink NULL
 173 #define ADD_ATTR(st, attr_type, attr_name, attr_value) NOOP
 174
 175 #endif /* PATH_TRACKING */
 176
 177
 178
 179
 180 #ifdef PATH_TRACKING
 181
 182 static const char *svtypenames[SVt_LAST] = {
 183 #if PERL_VERSION < 9
 184   "NULL", "IV", "NV", "RV", "PV", "PVIV", "PVNV", "PVMG", "PVBM", "PVLV", "PVAV", "PVHV", "PVCV", "PVGV", "PVFM", "PVIO",
 185 #elif PERL_VERSION == 10 && PERL_SUBVERSION == 0
 186   "NULL", "BIND", "IV", "NV", "RV", "PV", "PVIV", "PVNV", "PVMG", "PVGV", "PVLV", "PVAV", "PVHV", "PVCV", "PVFM", "PVIO",
 187 #elif PERL_VERSION == 10 && PERL_SUBVERSION == 1
 188   "NULL", "BIND", "IV", "NV", "RV", "PV", "PVIV", "PVNV", "PVMG", "PVGV", "PVLV", "PVAV", "PVHV", "PVCV", "PVFM", "PVIO",
 189 #elif PERL_VERSION < 13
 190   "NULL", "BIND", "IV", "NV", "PV", "PVIV", "PVNV", "PVMG", "REGEXP", "PVGV", "PVLV", "PVAV", "PVHV", "PVCV", "PVFM", "PVIO",
 191 #else
 192   "NULL", "BIND", "IV", "NV", "PV", "PVIV", "PVNV", "PVMG", "REGEXP", "PVGV", "PVLV", "PVAV", "PVHV", "PVCV", "PVFM", "PVIO",
 193 #endif
 194 };
 195
 196 int
 197 np_print_node_name(FILE *fp, npath_node_t *npath_node)
 198 {
 199     char buf[1024]; /* XXX */
 200
 201     switch (npath_node->type) {
 202     case NPtype_SV: { /* id is pointer to the SV sv_size was called on */
 203         const SV *sv = (SV*)npath_node->id;
 204         int type = SvTYPE(sv);
 205         char *typename = (type == SVt_IV && SvROK(sv)) ? "RV" : svtypenames[type];
 206         fprintf(fp, "SV(%s)", typename);
 207         switch(type) {  /* add some useful details */
 208         case SVt_PVAV: fprintf(fp, " fill=%d/%ld", av_len((AV*)sv), AvMAX((AV*)sv)); break;
 209         case SVt_PVHV: fprintf(fp, " fill=%ld/%ld", HvFILL((HV*)sv), HvMAX((HV*)sv)); break;
 210         }
 211         break;
 212     }
 213     case NPtype_OP: { /* id is pointer to the OP op_size was called on */
 214         const OP *op = (OP*)npath_node->id;
 215         fprintf(fp, "OP(%s)", OP_NAME(op));
 216         break;
 217     }
 218     case NPtype_MAGIC: { /* id is pointer to the MAGIC struct */
 219         MAGIC *magic_pointer = (MAGIC*)npath_node->id;
 220         /* XXX it would be nice if we could reuse mg_names.c [sigh] */
 221         fprintf(fp, "MAGIC(%c)", magic_pointer->mg_type ? magic_pointer->mg_type : '0');
 222         break;
 223     }
 224     case NPtype_LINK:
 225         fprintf(fp, "%s->", npath_node->id);
 226         break;
 227     case NPtype_NAME:
 228         fprintf(fp, "%s", npath_node->id);
 229         break;
 230     default:    /* assume id is a string pointer */
 231         fprintf(fp, "UNKNOWN(%d,%p)", npath_node->type, npath_node->id);
 232         break;
 233     }
 234     return 0;
 235 }
 236
 237 void
 238 np_dump_indent(int depth) {
 239     while (depth-- > 0)
 240         fprintf(stderr, ":   ");
 241 }
 242
 243 int
 244 np_walk_new_nodes(struct state *st,
 245     npath_node_t *npath_node,
 246     npath_node_t *npath_node_deeper,
 247     int (*cb)(struct state *st, npath_node_t *npath_node, npath_node_t *npath_node_deeper))
 248 {
 249     if (npath_node->seqn) /* node already output */
 250         return 0;
 251
 252     if (npath_node->prev) {
 253         np_walk_new_nodes(st, npath_node->prev, npath_node, cb); /* recurse */
 254         npath_node->depth = npath_node->prev->depth + 1;
 255     }
 256     else npath_node->depth = 0;
 257     npath_node->seqn = ++st->seqn;
 258
 259     if (cb) {
 260         if (cb(st, npath_node, npath_node_deeper)) {
 261             /* ignore this node */
 262             assert(npath_node->prev);
 263             assert(npath_node->depth);
 264             assert(npath_node_deeper);
 265             npath_node->depth--;
 266             npath_node->seqn = --st->seqn;
 267             npath_node_deeper->prev = npath_node->prev;
 268         }
 269     }
 270
 271     return 0;
 272 }
 273
 274 int
 275 np_dump_formatted_node(struct state *st, npath_node_t *npath_node, npath_node_t *npath_node_deeper) {
 276     if (0 && npath_node->type == NPtype_LINK)
 277         return 1;
 278     np_dump_indent(npath_node->depth);
 279     np_print_node_name(stderr, npath_node);
 280     fprintf(stderr, "\t\t[#%ld @%u] ", npath_node->seqn, npath_node->depth);
 281     fprintf(stderr, "\n");
 282     return 0;
 283 }
 284
 285 int
 286 np_dump_node_path_info(struct state *st, npath_node_t *npath_node, UV attr_type, const char *attr_name, UV attr_value)
 287 {
 288     if (!attr_type && !attr_value)
 289         return 0; /* ignore zero sized leaf items */
 290     np_walk_new_nodes(st, npath_node, NULL, np_dump_formatted_node);
 291     np_dump_indent(npath_node->depth+1);
 292     if (attr_type) {
 293         fprintf(stderr, "~NAMED('%s') %lu", attr_name, attr_value);
 294     }
 295     else {
 296         fprintf(stderr, "+%ld ", attr_value);
 297         fprintf(stderr, "%s ", attr_name);
 298         fprintf(stderr, "=%ld ", attr_value+st->total_size);
 299     }
 300     fprintf(stderr, "\n");
 301     return 0;
 302 }
 303
 304 int
 305 np_stream_formatted_node(struct state *st, npath_node_t *npath_node, npath_node_t *npath_node_deeper) {
 306     fprintf(st->node_stream, "-%u %lu %u ",
 307         npath_node->type, npath_node->seqn, (unsigned)npath_node->depth
 308     );
 309     np_print_node_name(st->node_stream, npath_node);
 310     fprintf(st->node_stream, "\n");
 311     return 0;
 312 }
 313
 314 int
 315 np_stream_node_path_info(struct state *st, npath_node_t *npath_node, UV attr_type, const char *attr_name, UV attr_value)
 316 {
 317     if (!attr_type && !attr_value)
 318         return 0; /* ignore zero sized leaf items */
 319     np_walk_new_nodes(st, npath_node, NULL, np_stream_formatted_node);
 320     if (attr_type) { /* Attribute type, name and value */
 321         fprintf(st->node_stream, "%lu %lu ", attr_type, npath_node->seqn);
 322     }
 323     else { /* Leaf name and memory size */
 324         fprintf(st->node_stream, "L %lu ", npath_node->seqn);
 325     }
 326     fprintf(st->node_stream, "%lu %s\n", attr_value, attr_name);
 327     return 0;
 328 }
 329
 330 #endif /* PATH_TRACKING */
 331
 332
 333 /*
 334     Checks to see if thing is in the bitstring.
 335     Returns true or false, and
 336     notes thing in the segmented bitstring.
 337  */
 338 static bool
 339 check_new(struct state *st, const void *const p) {
 340     unsigned int bits = 8 * sizeof(void*);
 341     const size_t raw_p = PTR2nat(p);
 342     /* This effectively rotates the value right by the number of low always-0
 343        bits in an aligned pointer. The assmption is that most (if not all)
 344        pointers are aligned, and these will be in the same chain of nodes
 345        (and hence hot in the cache) but we can still deal with any unaligned
 346        pointers.  */
 347     const size_t cooked_p
 348         = (raw_p >> ALIGN_BITS) | (raw_p << (bits - ALIGN_BITS));
 349     const U8 this_bit = 1 << (cooked_p & 0x7);
 350     U8 **leaf_p;
 351     U8 *leaf;
 352     unsigned int i;
 353     void **tv_p = (void **) (st->tracking);
 354
 355     if (NULL == p) return FALSE;
 356     TRY_TO_CATCH_SEGV {
 357         const char c = *(const char *)p;
 358     }
 359     CAUGHT_EXCEPTION {
 360         if (st->dangle_whine)
 361             warn( "Devel::Size: Encountered invalid pointer: %p\n", p );
 362         return FALSE;
 363     }
 364     TAG;
 365
 366     bits -= 8;
 367     /* bits now 24 (32 bit pointers) or 56 (64 bit pointers) */
 368
 369     /* First level is always present.  */
 370     do {
 371         i = (unsigned int)((cooked_p >> bits) & 0xFF);
 372         if (!tv_p[i])
 373             Newxz(tv_p[i], 256, void *);
 374         tv_p = (void **)(tv_p[i]);
 375         bits -= 8;
 376     } while (bits > LEAF_BITS + BYTE_BITS);
 377     /* bits now 16 always */
 378 #if !defined(MULTIPLICITY) || PERL_VERSION > 8 || (PERL_VERSION == 8 && PERL_SUBVERSION > 8)
 379     /* 5.8.8 and early have an assert() macro that uses Perl_croak, hence needs
 380        a my_perl under multiplicity  */
 381     assert(bits == 16);
 382 #endif
 383     leaf_p = (U8 **)tv_p;
 384     i = (unsigned int)((cooked_p >> bits) & 0xFF);
 385     if (!leaf_p[i])
 386         Newxz(leaf_p[i], 1 << LEAF_BITS, U8);
 387     leaf = leaf_p[i];
 388
 389     TAG;
 390
 391     i = (unsigned int)((cooked_p >> BYTE_BITS) & LEAF_MASK);
 392
 393     if(leaf[i] & this_bit)
 394         return FALSE;
 395
 396     leaf[i] |= this_bit;
 397     return TRUE;
 398 }
 399
 400 static void
 401 free_tracking_at(void **tv, int level)
 402 {
 403     int i = 255;
 404
 405     if (--level) {
 406         /* Nodes */
 407         do {
 408             if (tv[i]) {
 409                 free_tracking_at((void **) tv[i], level);
 410                 Safefree(tv[i]);
 411             }
 412         } while (i--);
 413     } else {
 414         /* Leaves */
 415         do {
 416             if (tv[i])
 417                 Safefree(tv[i]);
 418         } while (i--);
 419     }
 420 }
 421
 422 static void
 423 free_state(struct state *st)
 424 {
 425     const int top_level = (sizeof(void *) * 8 - LEAF_BITS - BYTE_BITS) / 8;
 426     if (st->free_state_cb)
 427         st->free_state_cb(st);
 428     if (st->state_cb_data)
 429         Safefree(st->state_cb_data);
 430     free_tracking_at((void **)st->tracking, top_level);
 431     Safefree(st);
 432 }
 433
 434 /* For now, this is somewhat a compatibility bodge until the plan comes
 435    together for fine grained recursion control. total_size() would recurse into
 436    hash and array members, whereas sv_size() would not. However, sv_size() is
 437    called with CvSTASH() of a CV, which means that if it (also) starts to
 438    recurse fully, then the size of any CV now becomes the size of the entire
 439    symbol table reachable from it, and potentially the entire symbol table, if
 440    any subroutine makes a reference to a global (such as %SIG). The historical
 441    implementation of total_size() didn't report "everything", and changing the
 442    only available size to "everything" doesn't feel at all useful.  */
 443
 444 #define NO_RECURSION 0
 445 #define SOME_RECURSION 1
 446 #define TOTAL_SIZE_RECURSION 2
 447
 448 static void sv_size(pTHX_ struct state *, pPATH, const SV *const, const int recurse);
 449
 450 typedef enum {
 451     OPc_NULL,   /* 0 */
 452     OPc_BASEOP, /* 1 */
 453     OPc_UNOP,   /* 2 */
 454     OPc_BINOP,  /* 3 */
 455     OPc_LOGOP,  /* 4 */
 456     OPc_LISTOP, /* 5 */
 457     OPc_PMOP,   /* 6 */
 458     OPc_SVOP,   /* 7 */
 459     OPc_PADOP,  /* 8 */
 460     OPc_PVOP,   /* 9 */
 461     OPc_LOOP,   /* 10 */
 462     OPc_COP /* 11 */
 463 #ifdef OA_CONDOP
 464     , OPc_CONDOP /* 12 */
 465 #endif
 466 #ifdef OA_GVOP
 467     , OPc_GVOP /* 13 */
 468 #endif
 469
 470 } opclass;
 471
 472 static opclass
 473 cc_opclass(const OP * const o)
 474 {
 475     if (!o)
 476     return OPc_NULL;
 477     TRY_TO_CATCH_SEGV {
 478         if (o->op_type == 0)
 479         return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
 480
 481         if (o->op_type == OP_SASSIGN)
 482         return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPc_UNOP : OPc_BINOP);
 483
 484     #ifdef USE_ITHREADS
 485         if (o->op_type == OP_GV || o->op_type == OP_GVSV || o->op_type == OP_AELEMFAST)
 486         return OPc_PADOP;
 487     #endif
 488
 489         if ((o->op_type == OP_TRANS)) {
 490           return OPc_BASEOP;
 491         }
 492
 493         switch (PL_opargs[o->op_type] & OA_CLASS_MASK) {
 494         case OA_BASEOP: TAG;
 495         return OPc_BASEOP;
 496
 497         case OA_UNOP: TAG;
 498         return OPc_UNOP;
 499
 500         case OA_BINOP: TAG;
 501         return OPc_BINOP;
 502
 503         case OA_LOGOP: TAG;
 504         return OPc_LOGOP;
 505
 506         case OA_LISTOP: TAG;
 507         return OPc_LISTOP;
 508
 509         case OA_PMOP: TAG;
 510         return OPc_PMOP;
 511
 512         case OA_SVOP: TAG;
 513         return OPc_SVOP;
 514
 515 #ifdef OA_PADOP
 516         case OA_PADOP: TAG;
 517         return OPc_PADOP;
 518 #endif
 519
 520 #ifdef OA_GVOP
 521         case OA_GVOP: TAG;
 522         return OPc_GVOP;
 523 #endif
 524
 525 #ifdef OA_PVOP_OR_SVOP
 526         case OA_PVOP_OR_SVOP: TAG;
 527             /*
 528              * Character translations (tr///) are usually a PVOP, keeping a
 529              * pointer to a table of shorts used to look up translations.
 530              * Under utf8, however, a simple table isn't practical; instead,
 531              * the OP is an SVOP, and the SV is a reference to a swash
 532              * (i.e., an RV pointing to an HV).
 533              */
 534         return (o->op_private & (OPpTRANS_TO_UTF|OPpTRANS_FROM_UTF))
 535             ? OPc_SVOP : OPc_PVOP;
 536 #endif
 537
 538         case OA_LOOP: TAG;
 539         return OPc_LOOP;
 540
 541         case OA_COP: TAG;
 542         return OPc_COP;
 543
 544         case OA_BASEOP_OR_UNOP: TAG;
 545         /*
 546          * UNI(OP_foo) in toke.c returns token UNI or FUNC1 depending on
 547          * whether parens were seen. perly.y uses OPf_SPECIAL to
 548          * signal whether a BASEOP had empty parens or none.
 549          * Some other UNOPs are created later, though, so the best
 550          * test is OPf_KIDS, which is set in newUNOP.
 551          */
 552         return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
 553
 554         case OA_FILESTATOP: TAG;
 555         /*
 556          * The file stat OPs are created via UNI(OP_foo) in toke.c but use
 557          * the OPf_REF flag to distinguish between OP types instead of the
 558          * usual OPf_SPECIAL flag. As usual, if OPf_KIDS is set, then we
 559          * return OPc_UNOP so that walkoptree can find our children. If
 560          * OPf_KIDS is not set then we check OPf_REF. Without OPf_REF set
 561          * (no argument to the operator) it's an OP; with OPf_REF set it's
 562          * an SVOP (and op_sv is the GV for the filehandle argument).
 563          */
 564         return ((o->op_flags & OPf_KIDS) ? OPc_UNOP :
 565     #ifdef USE_ITHREADS
 566             (o->op_flags & OPf_REF) ? OPc_PADOP : OPc_BASEOP);
 567     #else
 568             (o->op_flags & OPf_REF) ? OPc_SVOP : OPc_BASEOP);
 569     #endif
 570         case OA_LOOPEXOP: TAG;
 571         /*
 572          * next, last, redo, dump and goto use OPf_SPECIAL to indicate that a
 573          * label was omitted (in which case it's a BASEOP) or else a term was
 574          * seen. In this last case, all except goto are definitely PVOP but
 575          * goto is either a PVOP (with an ordinary constant label), an UNOP
 576          * with OPf_STACKED (with a non-constant non-sub) or an UNOP for
 577          * OP_REFGEN (with goto &sub) in which case OPf_STACKED also seems to
 578          * get set.
 579          */
 580         if (o->op_flags & OPf_STACKED)
 581             return OPc_UNOP;
 582         else if (o->op_flags & OPf_SPECIAL)
 583             return OPc_BASEOP;
 584         else
 585             return OPc_PVOP;
 586
 587 #ifdef OA_CONDOP
 588         case OA_CONDOP: TAG;
 589             return OPc_CONDOP;
 590 #endif
 591         }
 592         warn("Devel::Size: Can't determine class of operator %s, assuming BASEOP\n",
 593          PL_op_name[o->op_type]);
 594     }
 595     CAUGHT_EXCEPTION { }
 596     return OPc_BASEOP;
 597 }
 598
 599 /* Figure out how much magic is attached to the SV and return the
 600    size */
 601 static void
 602 magic_size(pTHX_ const SV * const thing, struct state *st, pPATH) {
 603   dNPathNodes(1, NPathArg);
 604   MAGIC *magic_pointer = SvMAGIC(thing);
 605
 606   /* push a dummy node for NPathSetNode to update inside the while loop */
 607   NPathPushNode("dummy", NPtype_NAME);
 608
 609   /* Have we seen the magic pointer?  (NULL has always been seen before)  */
 610   while (check_new(st, magic_pointer)) {
 611
 612     NPathSetNode(magic_pointer, NPtype_MAGIC);
 613
 614     ADD_SIZE(st, "mg", sizeof(MAGIC));
 615     /* magic vtables aren't freed when magic is freed, so don't count them.
 616        (They are static structures. Anything that assumes otherwise is buggy.)
 617     */
 618
 619
 620     TRY_TO_CATCH_SEGV {
 621         sv_size(aTHX_ st, NPathLink("mg_obj"), magic_pointer->mg_obj, TOTAL_SIZE_RECURSION);
 622         if (magic_pointer->mg_len == HEf_SVKEY) {
 623             sv_size(aTHX_ st, NPathLink("mg_ptr"), (SV *)magic_pointer->mg_ptr, TOTAL_SIZE_RECURSION);
 624         }
 625 #if defined(PERL_MAGIC_utf8) && defined (PERL_MAGIC_UTF8_CACHESIZE)
 626         else if (magic_pointer->mg_type == PERL_MAGIC_utf8) {
 627             if (check_new(st, magic_pointer->mg_ptr)) {
 628                 ADD_SIZE(st, "PERL_MAGIC_utf8", PERL_MAGIC_UTF8_CACHESIZE * 2 * sizeof(STRLEN));
 629             }
 630         }
 631 #endif
 632         else if (magic_pointer->mg_len > 0) {
 633             if (check_new(st, magic_pointer->mg_ptr)) {
 634                 ADD_SIZE(st, "mg_len", magic_pointer->mg_len);
 635             }
 636         }
 637
 638         /* Get the next in the chain */
 639         magic_pointer = magic_pointer->mg_moremagic;
 640     }
 641     CAUGHT_EXCEPTION {
 642         if (st->dangle_whine)
 643             warn( "Devel::Size: Encountered bad magic at: %p\n", magic_pointer );
 644     }
 645   }
 646 }
 647
 648 static void
 649 check_new_and_strlen(struct state *st, const char *const p, pPATH) {
 650     dNPathNodes(1, NPathArg->prev);
 651     if(check_new(st, p)) {
 652         NPathPushNode(NPathArg->id, NPtype_NAME);
 653         ADD_SIZE(st, NPathArg->id, 1 + strlen(p));
 654     }
 655 }
 656
 657 static void
 658 regex_size(const REGEXP * const baseregex, struct state *st, pPATH) {
 659     dNPathNodes(1, NPathArg);
 660     if(!check_new(st, baseregex))
 661         return;
 662   NPathPushNode("regex_size", NPtype_NAME);
 663   ADD_SIZE(st, "REGEXP", sizeof(REGEXP));
 664 #if (PERL_VERSION < 11)
 665   /* Note the size of the paren offset thing */
 666   ADD_SIZE(st, "nparens", sizeof(I32) * baseregex->nparens * 2);
 667   ADD_SIZE(st, "precomp", strlen(baseregex->precomp));
 668 #else
 669   ADD_SIZE(st, "regexp", sizeof(struct regexp));
 670   ADD_SIZE(st, "nparens", sizeof(I32) * SvANY(baseregex)->nparens * 2);
 671   /*ADD_SIZE(st, strlen(SvANY(baseregex)->subbeg));*/
 672 #endif
 673   if (st->go_yell && !st->regex_whine) {
 674     carp("Devel::Size: Calculated sizes for compiled regexes are incompatible, and probably always will be");
 675     st->regex_whine = 1;
 676   }
 677 }
 678
 679 static void
 680 op_size(pTHX_ const OP * const baseop, struct state *st, pPATH)
 681 {
 682     /* op_size recurses to follow the chain of opcodes.  For the node path we
 683      * don't want the chain to be 'nested' in the path so we use dNPathUseParent().
 684      * Also, to avoid a link-to-a-link the caller should use NPathLinkAndNode()
 685      * instead of NPathLink().
 686      */
 687     dNPathUseParent(NPathArg);
 688
 689     TRY_TO_CATCH_SEGV {
 690         TAG;
 691         if(!check_new(st, baseop))
 692             return;
 693         TAG;
 694         op_size(aTHX_ baseop->op_next, st, NPathOpLink);
 695         TAG;
 696         switch (cc_opclass(baseop)) {
 697         case OPc_BASEOP: TAG;
 698             ADD_SIZE(st, "op", sizeof(struct op));
 699             TAG;break;
 700         case OPc_UNOP: TAG;
 701             ADD_SIZE(st, "unop", sizeof(struct unop));
 702             op_size(aTHX_ ((UNOP *)baseop)->op_first, st, NPathOpLink);
 703             TAG;break;
 704         case OPc_BINOP: TAG;
 705             ADD_SIZE(st, "binop", sizeof(struct binop));
 706             op_size(aTHX_ ((BINOP *)baseop)->op_first, st, NPathOpLink);
 707             op_size(aTHX_ ((BINOP *)baseop)->op_last, st, NPathOpLink);
 708             TAG;break;
 709         case OPc_LOGOP: TAG;
 710             ADD_SIZE(st, "logop", sizeof(struct logop));
 711             op_size(aTHX_ ((BINOP *)baseop)->op_first, st, NPathOpLink);
 712             op_size(aTHX_ ((LOGOP *)baseop)->op_other, st, NPathOpLink);
 713             TAG;break;
 714 #ifdef OA_CONDOP
 715         case OPc_CONDOP: TAG;
 716             ADD_SIZE(st, "condop", sizeof(struct condop));
 717             op_size(aTHX_ ((BINOP *)baseop)->op_first, st, NPathOpLink);
 718             op_size(aTHX_ ((CONDOP *)baseop)->op_true, st, NPathOpLink);
 719             op_size(aTHX_ ((CONDOP *)baseop)->op_false, st, NPathOpLink);
 720             TAG;break;
 721 #endif
 722         case OPc_LISTOP: TAG;
 723             ADD_SIZE(st, "listop", sizeof(struct listop));
 724             op_size(aTHX_ ((LISTOP *)baseop)->op_first, st, NPathOpLink);
 725             op_size(aTHX_ ((LISTOP *)baseop)->op_last, st, NPathOpLink);
 726             TAG;break;
 727         case OPc_PMOP: TAG;
 728             ADD_SIZE(st, "pmop", sizeof(struct pmop));
 729             op_size(aTHX_ ((PMOP *)baseop)->op_first, st, NPathOpLink);
 730             op_size(aTHX_ ((PMOP *)baseop)->op_last, st, NPathOpLink);
 731 #if PERL_VERSION < 9 || (PERL_VERSION == 9 && PERL_SUBVERSION < 5)
 732             op_size(aTHX_ ((PMOP *)baseop)->op_pmreplroot, st, NPathOpLink);
 733             op_size(aTHX_ ((PMOP *)baseop)->op_pmreplstart, st, NPathOpLink);
 734 #endif
 735             /* This is defined away in perl 5.8.x, but it is in there for
 736                5.6.x */
 737 #ifdef PM_GETRE
 738             regex_size(PM_GETRE((PMOP *)baseop), st, NPathLink("PM_GETRE"));
 739 #else
 740             regex_size(((PMOP *)baseop)->op_pmregexp, st, NPathLink("op_pmregexp"));
 741 #endif
 742             TAG;break;
 743         case OPc_SVOP: TAG;
 744             ADD_SIZE(st, "svop", sizeof(struct svop));
 745             if (!(baseop->op_type == OP_AELEMFAST
 746                   && baseop->op_flags & OPf_SPECIAL)) {
 747                 /* not an OP_PADAV replacement */
 748                 sv_size(aTHX_ st, NPathLink("SVOP"), ((SVOP *)baseop)->op_sv, SOME_RECURSION);
 749             }
 750             TAG;break;
 751 #ifdef OA_PADOP
 752       case OPc_PADOP: TAG;
 753           ADD_SIZE(st, "padop", sizeof(struct padop));
 754           TAG;break;
 755 #endif
 756 #ifdef OA_GVOP
 757       case OPc_GVOP: TAG;
 758           ADD_SIZE(st, "gvop", sizeof(struct gvop));
 759           sv_size(aTHX_ st, NPathLink("GVOP"), ((GVOP *)baseop)->op_gv, SOME_RECURSION);
 760           TAG;break;
 761 #endif
 762         case OPc_PVOP: TAG;
 763             check_new_and_strlen(st, ((PVOP *)baseop)->op_pv, NPathLink("op_pv"));
 764             TAG;break;
 765         case OPc_LOOP: TAG;
 766             ADD_SIZE(st, "loop", sizeof(struct loop));
 767             op_size(aTHX_ ((LOOP *)baseop)->op_first, st, NPathOpLink);
 768             op_size(aTHX_ ((LOOP *)baseop)->op_last, st, NPathOpLink);
 769             op_size(aTHX_ ((LOOP *)baseop)->op_redoop, st, NPathOpLink);
 770             op_size(aTHX_ ((LOOP *)baseop)->op_nextop, st, NPathOpLink);
 771             op_size(aTHX_ ((LOOP *)baseop)->op_lastop, st, NPathOpLink);
 772             TAG;break;
 773         case OPc_COP: TAG;
 774         {
 775           COP *basecop;
 776           basecop = (COP *)baseop;
 777           ADD_SIZE(st, "cop", sizeof(struct cop));
 778
 779           /* Change 33656 by nicholas@mouse-mill on 2008/04/07 11:29:51
 780           Eliminate cop_label from struct cop by storing a label as the first
 781           entry in the hints hash. Most statements don't have labels, so this
 782           will save memory. Not sure how much.
 783           The check below will be incorrect fail on bleadperls
 784           before 5.11 @33656, but later than 5.10, producing slightly too
 785           small memory sizes on these Perls. */
 786 #if (PERL_VERSION < 11)
 787           check_new_and_strlen(st, basecop->cop_label, NPathLink("cop_label"));
 788 #endif
 789 #ifdef USE_ITHREADS
 790           check_new_and_strlen(st, basecop->cop_file, NPathLink("cop_file"));
 791           check_new_and_strlen(st, basecop->cop_stashpv, NPathLink("cop_stashpv"));
 792 #else
 793           sv_size(aTHX_ st, NPathLink("cop_stash"), (SV *)basecop->cop_stash, SOME_RECURSION);
 794           sv_size(aTHX_ st, NPathLink("cop_filegv"), (SV *)basecop->cop_filegv, SOME_RECURSION);
 795 #endif
 796
 797         }
 798         TAG;break;
 799       default:
 800         TAG;break;
 801       }
 802   }
 803   CAUGHT_EXCEPTION {
 804       if (st->dangle_whine)
 805           warn( "Devel::Size: Encountered dangling pointer in opcode at: %p\n", baseop );
 806   }
 807 }
 808
 809 static void
 810 hek_size(pTHX_ struct state *st, HEK *hek, U32 shared, pPATH)
 811 {
 812     dNPathNodes(1, NPathArg);
 813
 814     /* Hash keys can be shared. Have we seen this before? */
 815     if (!check_new(st, hek))
 816         return;
 817     NPathPushNode("hek", NPtype_NAME);
 818     ADD_SIZE(st, "hek_len", HEK_BASESIZE + hek->hek_len
 819 #if PERL_VERSION < 8
 820         + 1 /* No hash key flags prior to 5.8.0  */
 821 #else
 822         + 2
 823 #endif
 824         );
 825     if (shared) {
 826 #if PERL_VERSION < 10
 827         ADD_SIZE(st, "he", sizeof(struct he));
 828 #else
 829         ADD_SIZE(st, "shared_he", STRUCT_OFFSET(struct shared_he, shared_he_hek));
 830 #endif
 831     }
 832 }
 833
 834
 835 #if PERL_VERSION < 8 || PERL_SUBVERSION < 9
 836 #  define SVt_LAST 16
 837 #endif
 838
 839 #ifdef PURIFY
 840 #  define MAYBE_PURIFY(normal, pure) (pure)
 841 #  define MAYBE_OFFSET(struct_name, member) 0
 842 #else
 843 #  define MAYBE_PURIFY(normal, pure) (normal)
 844 #  define MAYBE_OFFSET(struct_name, member) STRUCT_OFFSET(struct_name, member)
 845 #endif
 846
 847 const U8 body_sizes[SVt_LAST] = {
 848 #if PERL_VERSION < 9
 849      0,                                                       /* SVt_NULL */
 850      MAYBE_PURIFY(sizeof(IV), sizeof(XPVIV)),                 /* SVt_IV */
 851      MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)),                 /* SVt_NV */
 852      sizeof(XRV),                                             /* SVt_RV */
 853      sizeof(XPV),                                             /* SVt_PV */
 854      sizeof(XPVIV),                                           /* SVt_PVIV */
 855      sizeof(XPVNV),                                           /* SVt_PVNV */
 856      sizeof(XPVMG),                                           /* SVt_PVMG */
 857      sizeof(XPVBM),                                           /* SVt_PVBM */
 858      sizeof(XPVLV),                                           /* SVt_PVLV */
 859      sizeof(XPVAV),                                           /* SVt_PVAV */
 860      sizeof(XPVHV),                                           /* SVt_PVHV */
 861      sizeof(XPVCV),                                           /* SVt_PVCV */
 862      sizeof(XPVGV),                                           /* SVt_PVGV */
 863      sizeof(XPVFM),                                           /* SVt_PVFM */
 864      sizeof(XPVIO)                                            /* SVt_PVIO */
 865 #elif PERL_VERSION == 10 && PERL_SUBVERSION == 0
 866      0,                                                       /* SVt_NULL */
 867      0,                                                       /* SVt_BIND */
 868      0,                                                       /* SVt_IV */
 869      MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)),                 /* SVt_NV */
 870      0,                                                       /* SVt_RV */
 871      MAYBE_PURIFY(sizeof(xpv_allocated), sizeof(XPV)),        /* SVt_PV */
 872      MAYBE_PURIFY(sizeof(xpviv_allocated), sizeof(XPVIV)),/* SVt_PVIV */
 873      sizeof(XPVNV),                                           /* SVt_PVNV */
 874      sizeof(XPVMG),                                           /* SVt_PVMG */
 875      sizeof(XPVGV),                                           /* SVt_PVGV */
 876      sizeof(XPVLV),                                           /* SVt_PVLV */
 877      MAYBE_PURIFY(sizeof(xpvav_allocated), sizeof(XPVAV)),/* SVt_PVAV */
 878      MAYBE_PURIFY(sizeof(xpvhv_allocated), sizeof(XPVHV)),/* SVt_PVHV */
 879      MAYBE_PURIFY(sizeof(xpvcv_allocated), sizeof(XPVCV)),/* SVt_PVCV */
 880      MAYBE_PURIFY(sizeof(xpvfm_allocated), sizeof(XPVFM)),/* SVt_PVFM */
 881      sizeof(XPVIO),                                           /* SVt_PVIO */
 882 #elif PERL_VERSION == 10 && PERL_SUBVERSION == 1
 883      0,                                                       /* SVt_NULL */
 884      0,                                                       /* SVt_BIND */
 885      0,                                                       /* SVt_IV */
 886      MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)),                 /* SVt_NV */
 887      0,                                                       /* SVt_RV */
 888      sizeof(XPV) - MAYBE_OFFSET(XPV, xpv_cur),                /* SVt_PV */
 889      sizeof(XPVIV) - MAYBE_OFFSET(XPV, xpv_cur),              /* SVt_PVIV */
 890      sizeof(XPVNV),                                           /* SVt_PVNV */
 891      sizeof(XPVMG),                                           /* SVt_PVMG */
 892      sizeof(XPVGV),                                           /* SVt_PVGV */
 893      sizeof(XPVLV),                                           /* SVt_PVLV */
 894      sizeof(XPVAV) - MAYBE_OFFSET(XPVAV, xav_fill),           /* SVt_PVAV */
 895      sizeof(XPVHV) - MAYBE_OFFSET(XPVHV, xhv_fill),           /* SVt_PVHV */
 896      sizeof(XPVCV) - MAYBE_OFFSET(XPVCV, xpv_cur),            /* SVt_PVCV */
 897      sizeof(XPVFM) - MAYBE_OFFSET(XPVFM, xpv_cur),            /* SVt_PVFM */
 898      sizeof(XPVIO)                                            /* SVt_PVIO */
 899 #elif PERL_VERSION < 13
 900      0,                                                       /* SVt_NULL */
 901      0,                                                       /* SVt_BIND */
 902      0,                                                       /* SVt_IV */
 903      MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)),                 /* SVt_NV */
 904      sizeof(XPV) - MAYBE_OFFSET(XPV, xpv_cur),                /* SVt_PV */
 905      sizeof(XPVIV) - MAYBE_OFFSET(XPV, xpv_cur),              /* SVt_PVIV */
 906      sizeof(XPVNV),                                           /* SVt_PVNV */
 907      sizeof(XPVMG),                                           /* SVt_PVMG */
 908      sizeof(regexp) - MAYBE_OFFSET(regexp, xpv_cur),          /* SVt_REGEXP */
 909      sizeof(XPVGV),                                           /* SVt_PVGV */
 910      sizeof(XPVLV),                                           /* SVt_PVLV */
 911      sizeof(XPVAV) - MAYBE_OFFSET(XPVAV, xav_fill),           /* SVt_PVAV */
 912      sizeof(XPVHV) - MAYBE_OFFSET(XPVHV, xhv_fill),           /* SVt_PVHV */
 913      sizeof(XPVCV) - MAYBE_OFFSET(XPVCV, xpv_cur),            /* SVt_PVCV */
 914      sizeof(XPVFM) - MAYBE_OFFSET(XPVFM, xpv_cur),            /* SVt_PVFM */
 915      sizeof(XPVIO)                                            /* SVt_PVIO */
 916 #else
 917      0,                                                       /* SVt_NULL */
 918      0,                                                       /* SVt_BIND */
 919      0,                                                       /* SVt_IV */
 920      MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)),                 /* SVt_NV */
 921      sizeof(XPV) - MAYBE_OFFSET(XPV, xpv_cur),                /* SVt_PV */
 922      sizeof(XPVIV) - MAYBE_OFFSET(XPV, xpv_cur),              /* SVt_PVIV */
 923      sizeof(XPVNV) - MAYBE_OFFSET(XPV, xpv_cur),              /* SVt_PVNV */
 924      sizeof(XPVMG),                                           /* SVt_PVMG */
 925      sizeof(regexp),                                          /* SVt_REGEXP */
 926      sizeof(XPVGV),                                           /* SVt_PVGV */
 927      sizeof(XPVLV),                                           /* SVt_PVLV */
 928      sizeof(XPVAV),                                           /* SVt_PVAV */
 929      sizeof(XPVHV),                                           /* SVt_PVHV */
 930      sizeof(XPVCV),                                           /* SVt_PVCV */
 931      sizeof(XPVFM),                                           /* SVt_PVFM */
 932      sizeof(XPVIO)                                            /* SVt_PVIO */
 933 #endif
 934 };
 935
 936
 937 /* based on Perl_do_dump_pad() - wraps sv_size and adds ADD_ATTR calls for the pad names */
 938 static void
 939 padlist_size(pTHX_ struct state *const st, pPATH, PADLIST *padlist,
 940         const int recurse)
 941 {
 942     dNPathUseParent(NPathArg);
 943     const AV *pad_name;
 944     SV **pname;
 945     I32 ix;
 946
 947     if (!padlist) {
 948         return;
 949     }
 950     pad_name = MUTABLE_AV(*av_fetch(MUTABLE_AV(padlist), 0, FALSE));
 951     pname = AvARRAY(pad_name);
 952
 953     for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
 954         const SV *namesv = pname[ix];
 955         if (namesv && namesv == &PL_sv_undef) {
 956             namesv = NULL;
 957         }
 958         if (namesv) {
 959             if (SvFAKE(namesv))
 960                 ADD_ATTR(st, NPattr_PADFAKE, SvPVX_const(namesv), ix);
 961             else
 962                 ADD_ATTR(st, NPattr_PADNAME, SvPVX_const(namesv), ix);
 963         }
 964         else {
 965             ADD_ATTR(st, NPattr_PADTMP, "SVs_PADTMP", ix);
 966         }
 967
 968     }
 969     sv_size(aTHX_ st, NPathArg, (SV*)padlist, recurse);
 970 }
 971
 972
 973 static void
 974 sv_size(pTHX_ struct state *const st, pPATH, const SV * const orig_thing,
 975         const int recurse) {
 976   const SV *thing = orig_thing;
 977   dNPathNodes(3, NPathArg);
 978   U32 type;
 979
 980   if(!check_new(st, orig_thing))
 981       return;
 982
 983   type = SvTYPE(thing);
 984   if (type > SVt_LAST) {
 985       warn("Devel::Size: Unknown variable type: %d encountered\n", type);
 986       return;
 987   }
 988   NPathPushNode(thing, NPtype_SV);
 989   ADD_SIZE(st, "sv", sizeof(SV) + body_sizes[type]);
 990
 991   if (type >= SVt_PVMG) {
 992       magic_size(aTHX_ thing, st, NPathLink("MG"));
 993   }
 994
 995   switch (type) {
 996 #if (PERL_VERSION < 11)
 997     /* Is it a reference? */
 998   case SVt_RV: TAG;
 999 #else
1000   case SVt_IV: TAG;
1001 #endif
1002     if(recurse && SvROK(thing))
1003         sv_size(aTHX_ st, NPathLink("RV"), SvRV_const(thing), recurse);
1004     TAG;break;
1005
1006   case SVt_PVAV: TAG;
1007     /* Is there anything in the array? */
1008     if (AvMAX(thing) != -1) {
1009       /* an array with 10 slots has AvMax() set to 9 - te 2007-04-22 */
1010       ADD_SIZE(st, "av_max", sizeof(SV *) * (AvMAX(thing) + 1));
1011       dbg_printf(("total_size: %li AvMAX: %li av_len: $i\n", st->total_size, AvMAX(thing), av_len((AV*)thing)));
1012
1013       if (recurse >= st->min_recurse_threshold) {
1014           SSize_t i = AvFILLp(thing) + 1;
1015
1016           while (i--)
1017               sv_size(aTHX_ st, NPathLink("AVelem"), AvARRAY(thing)[i], recurse);
1018       }
1019     }
1020     /* Add in the bits on the other side of the beginning */
1021
1022     dbg_printf(("total_size %li, sizeof(SV *) %li, AvARRAY(thing) %li, AvALLOC(thing)%li , sizeof(ptr) %li \n",
1023         st->total_size, sizeof(SV*), AvARRAY(thing), AvALLOC(thing), sizeof( thing )));
1024
1025     /* under Perl 5.8.8 64bit threading, AvARRAY(thing) was a pointer while AvALLOC was 0,
1026        resulting in grossly overstated sized for arrays. Technically, this shouldn't happen... */
1027     if (AvALLOC(thing) != 0) {
1028       ADD_SIZE(st, "AvALLOC", (sizeof(SV *) * (AvARRAY(thing) - AvALLOC(thing))));
1029       }
1030 #if (PERL_VERSION < 9)
1031     /* Is there something hanging off the arylen element?
1032        Post 5.9.something this is stored in magic, so will be found there,
1033        and Perl_av_arylen_p() takes a non-const AV*, hence compilers rightly
1034        complain about AvARYLEN() passing thing to it.  */
1035     sv_size(aTHX_ st, NPathLink("ARYLEN"), AvARYLEN(thing), recurse);
1036 #endif
1037     TAG;break;
1038   case SVt_PVHV: TAG;
1039     /* Now the array of buckets */
1040     ADD_SIZE(st, "hv_max", (sizeof(HE *) * (HvMAX(thing) + 1)));
1041     if (HvENAME(thing)) {
1042         ADD_ATTR(st, NPattr_NAME, HvENAME(thing), 0);
1043     }
1044     /* Now walk the bucket chain */
1045     if (HvARRAY(thing)) {
1046       HE *cur_entry;
1047       UV cur_bucket = 0;
1048       for (cur_bucket = 0; cur_bucket <= HvMAX(thing); cur_bucket++) {
1049         cur_entry = *(HvARRAY(thing) + cur_bucket);
1050         while (cur_entry) {
1051           ADD_SIZE(st, "he", sizeof(HE));
1052           hek_size(aTHX_ st, cur_entry->hent_hek, HvSHAREKEYS(thing), NPathLink("hent_hek"));
1053           if (recurse >= st->min_recurse_threshold) {
1054 /* I've seen a PL_strtab HeVAL == 0xC and 0x40C etc
1055  * just running perl -Mblib -Mstrict -MDevel::Size=:all -MCarp -e 'warn perl_size()'
1056  * but it seemed like a corruption - it would change come and go with irrelevant code changes.
1057  * so we protect against that here, but I'd like to know the cause.
1058  */
1059 if (PTR2UV(HeVAL(cur_entry)) > 0xFFF)
1060               sv_size(aTHX_ st, NPathLink("HeVAL"), HeVAL(cur_entry), recurse);
1061           }
1062           cur_entry = cur_entry->hent_next;
1063         }
1064       }
1065     }
1066 #ifdef HvAUX
1067     if (SvOOK(thing)) {
1068         /* This direct access is arguably "naughty": */
1069         struct mro_meta *meta = HvAUX(thing)->xhv_mro_meta;
1070 #if PERL_VERSION > 13 || PERL_SUBVERSION > 8
1071         /* As is this: */
1072         I32 count = HvAUX(thing)->xhv_name_count;
1073
1074         if (count) {
1075             HEK **names = HvAUX(thing)->xhv_name_u.xhvnameu_names;
1076             if (count < 0)
1077                 count = -count;
1078             while (--count)
1079                 hek_size(aTHX_ st, names[count], 1, NPathLink("HvAUXelem"));
1080         }
1081         else
1082 #endif
1083         {
1084             hek_size(aTHX_ st, HvNAME_HEK(thing), 1, NPathLink("HvNAME_HEK"));
1085         }
1086
1087         ADD_SIZE(st, "xpvhv_aux", sizeof(struct xpvhv_aux));
1088         if (meta) {
1089             ADD_SIZE(st, "mro_meta", sizeof(struct mro_meta));
1090             sv_size(aTHX_ st, NPathLink("mro_nextmethod"), (SV *)meta->mro_nextmethod, TOTAL_SIZE_RECURSION);
1091 #if PERL_VERSION > 10 || (PERL_VERSION == 10 && PERL_SUBVERSION > 0)
1092             sv_size(aTHX_ st, NPathLink("isa"), (SV *)meta->isa, TOTAL_SIZE_RECURSION);
1093 #endif
1094 #if PERL_VERSION > 10
1095             sv_size(aTHX_ st, NPathLink("mro_linear_all"), (SV *)meta->mro_linear_all, TOTAL_SIZE_RECURSION);
1096             sv_size(aTHX_ st, NPathLink("mro_linear_current"), meta->mro_linear_current, TOTAL_SIZE_RECURSION);
1097 #else
1098             sv_size(aTHX_ st, NPathLink("mro_linear_dfs"), (SV *)meta->mro_linear_dfs, TOTAL_SIZE_RECURSION);
1099             sv_size(aTHX_ st, NPathLink("mro_linear_c3"), (SV *)meta->mro_linear_c3, TOTAL_SIZE_RECURSION);
1100 #endif
1101         }
1102     }
1103 #else
1104     check_new_and_strlen(st, HvNAME_get(thing), NPathLink("HvNAME"));
1105 #endif
1106     TAG;break;
1107
1108
1109   case SVt_PVFM: TAG;
1110     padlist_size(aTHX_ st, NPathLink("CvPADLIST"), CvPADLIST(thing), SOME_RECURSION);
1111     sv_size(aTHX_ st, NPathLink("CvOUTSIDE"), (SV *)CvOUTSIDE(thing), recurse);
1112
1113     if (st->go_yell && !st->fm_whine) {
1114       carp("Devel::Size: Calculated sizes for FMs are incomplete");
1115       st->fm_whine = 1;
1116     }
1117     goto freescalar;
1118
1119   case SVt_PVCV: TAG;
1120     sv_size(aTHX_ st, NPathLink("CvSTASH"), (SV *)CvSTASH(thing), SOME_RECURSION);
1121     sv_size(aTHX_ st, NPathLink("SvSTASH"), (SV *)SvSTASH(thing), SOME_RECURSION);
1122     sv_size(aTHX_ st, NPathLink("CvGV"), (SV *)CvGV(thing), SOME_RECURSION);
1123     padlist_size(aTHX_ st, NPathLink("CvPADLIST"), CvPADLIST(thing), SOME_RECURSION);
1124     sv_size(aTHX_ st, NPathLink("CvOUTSIDE"), (SV *)CvOUTSIDE(thing), recurse);
1125     if (CvISXSUB(thing)) {
1126         sv_size(aTHX_ st, NPathLink("cv_const_sv"), cv_const_sv((CV *)thing), recurse);
1127     } else {
1128         if(1)op_size(aTHX_ CvSTART(thing), st, NPathLinkAndNode("CvSTART", "OPs")); /* XXX ? */
1129         op_size(aTHX_ CvROOT(thing), st, NPathLinkAndNode("CvROOT", "OPs"));
1130     }
1131     goto freescalar;
1132
1133   case SVt_PVIO: TAG;
1134     /* Some embedded char pointers */
1135     check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_top_name, NPathLink("xio_top_name"));
1136     check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_fmt_name, NPathLink("xio_fmt_name"));
1137     check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_bottom_name, NPathLink("xio_bottom_name"));
1138     /* Throw the GVs on the list to be walked if they're not-null */
1139     sv_size(aTHX_ st, NPathLink("xio_top_gv"), (SV *)((XPVIO *) SvANY(thing))->xio_top_gv, recurse);
1140     sv_size(aTHX_ st, NPathLink("xio_bottom_gv"), (SV *)((XPVIO *) SvANY(thing))->xio_bottom_gv, recurse);
1141     sv_size(aTHX_ st, NPathLink("xio_fmt_gv"), (SV *)((XPVIO *) SvANY(thing))->xio_fmt_gv, recurse);
1142
1143     /* Only go trotting through the IO structures if they're really
1144        trottable. If USE_PERLIO is defined we can do this. If
1145        not... we can't, so we don't even try */
1146 #ifdef USE_PERLIO
1147     /* Dig into xio_ifp and xio_ofp here */
1148     warn("Devel::Size: Can't size up perlio layers yet\n");
1149 #endif
1150     goto freescalar;
1151
1152   case SVt_PVLV: TAG;
1153 #if (PERL_VERSION < 9)
1154     goto freescalar;
1155 #endif
1156
1157   case SVt_PVGV: TAG;
1158     if(isGV_with_GP(thing)) {
1159 #ifdef GvNAME_HEK
1160         hek_size(aTHX_ st, GvNAME_HEK(thing), 1, NPathLink("GvNAME_HEK"));
1161 #else
1162         ADD_SIZE(st, "GvNAMELEN", GvNAMELEN(thing));
1163 #endif
1164         ADD_ATTR(st, NPattr_NAME, GvNAME_get(thing), 0);
1165 #ifdef GvFILE_HEK
1166         hek_size(aTHX_ st, GvFILE_HEK(thing), 1, NPathLink("GvFILE_HEK"));
1167 #elif defined(GvFILE)
1168 #  if !defined(USE_ITHREADS) || (PERL_VERSION > 8 || (PERL_VERSION == 8 && PERL_SUBVERSION > 8))
1169         /* With itreads, before 5.8.9, this can end up pointing to freed memory
1170            if the GV was created in an eval, as GvFILE() points to CopFILE(),
1171            and the relevant COP has been freed on scope cleanup after the eval.
1172            5.8.9 adds a binary compatible fudge that catches the vast majority
1173            of cases. 5.9.something added a proper fix, by converting the GP to
1174            use a shared hash key (porperly reference counted), instead of a
1175            char * (owned by who knows? possibly no-one now) */
1176         check_new_and_strlen(st, GvFILE(thing), NPathLink("GvFILE"));
1177 #  endif
1178 #endif
1179         /* Is there something hanging off the glob? */
1180         if (check_new(st, GvGP(thing))) {
1181             ADD_SIZE(st, "GP", sizeof(GP));
1182             sv_size(aTHX_ st, NPathLink("gp_sv"), (SV *)(GvGP(thing)->gp_sv), recurse);
1183             sv_size(aTHX_ st, NPathLink("gp_form"), (SV *)(GvGP(thing)->gp_form), recurse);
1184             sv_size(aTHX_ st, NPathLink("gp_av"), (SV *)(GvGP(thing)->gp_av), recurse);
1185             sv_size(aTHX_ st, NPathLink("gp_hv"), (SV *)(GvGP(thing)->gp_hv), recurse);
1186             sv_size(aTHX_ st, NPathLink("gp_egv"), (SV *)(GvGP(thing)->gp_egv), recurse);
1187             sv_size(aTHX_ st, NPathLink("gp_cv"), (SV *)(GvGP(thing)->gp_cv), recurse);
1188         }
1189 #if (PERL_VERSION >= 9)
1190         TAG; break;
1191 #endif
1192     }
1193 #if PERL_VERSION <= 8
1194   case SVt_PVBM: TAG;
1195 #endif
1196   case SVt_PVMG: TAG;
1197   case SVt_PVNV: TAG;
1198   case SVt_PVIV: TAG;
1199   case SVt_PV: TAG;
1200   freescalar:
1201     if(recurse && SvROK(thing))
1202         sv_size(aTHX_ st, NPathLink("RV"), SvRV_const(thing), recurse);
1203     else if (SvIsCOW_shared_hash(thing))
1204         hek_size(aTHX_ st, SvSHARED_HEK_FROM_PV(SvPVX(thing)), 1, NPathLink("SvSHARED_HEK_FROM_PV"));
1205     else
1206         ADD_SIZE(st, "SvLEN", SvLEN(thing));
1207
1208     if(SvOOK(thing)) {
1209         STRLEN len;
1210         SvOOK_offset(thing, len);
1211         ADD_SIZE(st, "SvOOK", len);
1212     }
1213     TAG;break;
1214
1215   }
1216   return;
1217 }
1218
1219 static struct state *
1220 new_state(pTHX)
1221 {
1222     SV *warn_flag;
1223     struct state *st;
1224
1225     Newxz(st, 1, struct state);
1226     st->go_yell = TRUE;
1227     st->min_recurse_threshold = TOTAL_SIZE_RECURSION;
1228     if (NULL != (warn_flag = perl_get_sv("Devel::Size::warn", FALSE))) {
1229         st->dangle_whine = st->go_yell = SvIV(warn_flag) ? TRUE : FALSE;
1230     }
1231     if (NULL != (warn_flag = perl_get_sv("Devel::Size::dangle", FALSE))) {
1232         st->dangle_whine = SvIV(warn_flag) ? TRUE : FALSE;
1233     }
1234     check_new(st, &PL_sv_undef);
1235     check_new(st, &PL_sv_no);
1236     check_new(st, &PL_sv_yes);
1237 #if PERL_VERSION > 8 || (PERL_VERSION == 8 && PERL_SUBVERSION > 0)
1238     check_new(st, &PL_sv_placeholder);
1239 #endif
1240 #ifdef PATH_TRACKING
1241     if (getenv("M") && atoi(getenv("M"))) /* XXX quick hack */
1242         st->node_stream = stdout;
1243     if (st->node_stream)
1244         st->add_attr_cb = np_stream_node_path_info;
1245     else
1246         st->add_attr_cb = np_dump_node_path_info;
1247 #endif
1248     return st;
1249 }
1250
1251 MODULE = Devel::Size        PACKAGE = Devel::Size
1252
1253 PROTOTYPES: DISABLE
1254
1255 UV
1256 size(orig_thing)
1257      SV *orig_thing
1258 ALIAS:
1259     total_size = TOTAL_SIZE_RECURSION
1260 CODE:
1261 {
1262   SV *thing = orig_thing;
1263   struct state *st = new_state(aTHX);
1264
1265   /* If they passed us a reference then dereference it. This is the
1266      only way we can check the sizes of arrays and hashes */
1267   if (SvROK(thing)) {
1268     thing = SvRV(thing);
1269   }
1270
1271   sv_size(aTHX_ st, NULL, thing, ix);
1272   RETVAL = st->total_size;
1273   free_state(st);
1274 }
1275 OUTPUT:
1276   RETVAL
1277
1278 UV
1279 perl_size()
1280 CODE:
1281 {
1282   dNPathNodes(2, NULL);
1283   struct state *st = new_state(aTHX);
1284   NPathPushNode("perl_size", NPtype_NAME); /* provide a root node */
1285
1286   st->min_recurse_threshold = NO_RECURSION; /* so always recurse */
1287
1288   /* start with PL_defstash to get everything reachable from \%main::
1289    * this seems to include PL_defgv, PL_incgv etc but I've listed them anyway
1290    */
1291   sv_size(aTHX_ st, NPathLink("PL_defstash"), (SV*)PL_defstash, TOTAL_SIZE_RECURSION);
1292
1293   NPathPushNode("others", NPtype_NAME); /* group these (typically much smaller) items */
1294   sv_size(aTHX_ st, NPathLink("PL_defgv"), (SV*)PL_defgv, TOTAL_SIZE_RECURSION);
1295   sv_size(aTHX_ st, NPathLink("PL_incgv"), (SV*)PL_incgv, TOTAL_SIZE_RECURSION);
1296   sv_size(aTHX_ st, NPathLink("PL_rs"), (SV*)PL_rs, TOTAL_SIZE_RECURSION);
1297   sv_size(aTHX_ st, NPathLink("PL_fdpid"), (SV*)PL_fdpid, TOTAL_SIZE_RECURSION);
1298   sv_size(aTHX_ st, NPathLink("PL_modglobal"), (SV*)PL_modglobal, TOTAL_SIZE_RECURSION);
1299   sv_size(aTHX_ st, NPathLink("PL_errors"), (SV*)PL_errors, TOTAL_SIZE_RECURSION);
1300   sv_size(aTHX_ st, NPathLink("PL_stashcache"), (SV*)PL_stashcache, TOTAL_SIZE_RECURSION);
1301   sv_size(aTHX_ st, NPathLink("PL_patchlevel"), (SV*)PL_patchlevel, TOTAL_SIZE_RECURSION);
1302   sv_size(aTHX_ st, NPathLink("PL_apiversion"), (SV*)PL_apiversion, TOTAL_SIZE_RECURSION);
1303   sv_size(aTHX_ st, NPathLink("PL_registered_mros"), (SV*)PL_registered_mros, TOTAL_SIZE_RECURSION);
1304 #ifdef USE_ITHREADS
1305   sv_size(aTHX_ st, NPathLink("PL_regex_padav"), (SV*)PL_regex_padav, TOTAL_SIZE_RECURSION);
1306 #endif
1307   sv_size(aTHX_ st, NPathLink("PL_warnhook"), (SV*)PL_warnhook, TOTAL_SIZE_RECURSION);
1308   sv_size(aTHX_ st, NPathLink("PL_diehook"), (SV*)PL_diehook, TOTAL_SIZE_RECURSION);
1309   sv_size(aTHX_ st, NPathLink("PL_endav"), (SV*)PL_endav, TOTAL_SIZE_RECURSION);
1310   sv_size(aTHX_ st, NPathLink("PL_main_cv"), (SV*)PL_main_cv, TOTAL_SIZE_RECURSION);
1311   sv_size(aTHX_ st, NPathLink("PL_main_root"), (SV*)PL_main_root, TOTAL_SIZE_RECURSION);
1312   sv_size(aTHX_ st, NPathLink("PL_main_start"), (SV*)PL_main_start, TOTAL_SIZE_RECURSION);
1313   /* TODO PL_pidstatus */
1314   /* TODO PL_stashpad */
1315   /* TODO PL_compiling? COP */
1316
1317   /* in theory we shouldn't have any elements in PL_strtab that haven't been seen yet */
1318   sv_size(aTHX_ st, NPathLink("PL_strtab"), (SV*)PL_strtab, TOTAL_SIZE_RECURSION);
1319
1320   /* TODO stacks: cur, main, tmps, mark, scope, save */
1321   /* TODO unused space in arenas */
1322   /* TODO unused space in malloc, for whichever mallocs support it */
1323   /* TODO PL_exitlist */
1324   /* TODO environ */
1325   /* TODO PerlIO? PL_known_layers PL_def_layerlist PL_perlio_fd_refcnt etc */
1326   /* TODO threads? */
1327   /* TODO anything missed? */
1328
1329   RETVAL = st->total_size;
1330   free_state(st);
1331 }
1332 OUTPUT:
1333   RETVAL