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