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