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