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