projects / p5sagit/Devel-Size.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | history | HEAD
Mark suspect PERL_SUBVERSION macros
[p5sagit/Devel-Size.git] / Memory.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{
fc6614ee 884 dNPathNodes(1, NPathArg);
885
3d18ea10 886 /* Hash keys can be shared. Have we seen this before? */
887 if (!check_new(st, hek))
888 return;
fc6614ee 889 NPathPushNode("hek", NPtype_NAME);
c07e8ef8 890 ADD_SIZE(st, "hek_len", HEK_BASESIZE + hek->hek_len
3d18ea10 891#if PERL_VERSION < 8
892 + 1 /* No hash key flags prior to 5.8.0 */
893#else
894 + 2
895#endif
c07e8ef8 896 );
3d18ea10 897 if (shared) {
898#if PERL_VERSION < 10
c07e8ef8 899 ADD_SIZE(st, "he", sizeof(struct he));
3d18ea10 900#else
c07e8ef8 901 ADD_SIZE(st, "shared_he", STRUCT_OFFSET(struct shared_he, shared_he_hek));
3d18ea10 902#endif
903 }
904}
905
906
24638fb4 907#if PERL_VERSION < 8 || PERL_SUBVERSION < 9 /* XXX plain || seems like a bug */
b6558d1d 908# define SVt_LAST 16
24d37977 909#endif
910
f73dcfce 911#ifdef PURIFY
912# define MAYBE_PURIFY(normal, pure) (pure)
913# define MAYBE_OFFSET(struct_name, member) 0
914#else
915# define MAYBE_PURIFY(normal, pure) (normal)
916# define MAYBE_OFFSET(struct_name, member) STRUCT_OFFSET(struct_name, member)
917#endif
918
b6558d1d 919const U8 body_sizes[SVt_LAST] = {
920#if PERL_VERSION < 9
f73dcfce 921 0, /* SVt_NULL */
922 MAYBE_PURIFY(sizeof(IV), sizeof(XPVIV)), /* SVt_IV */
923 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
924 sizeof(XRV), /* SVt_RV */
925 sizeof(XPV), /* SVt_PV */
926 sizeof(XPVIV), /* SVt_PVIV */
927 sizeof(XPVNV), /* SVt_PVNV */
928 sizeof(XPVMG), /* SVt_PVMG */
929 sizeof(XPVBM), /* SVt_PVBM */
930 sizeof(XPVLV), /* SVt_PVLV */
931 sizeof(XPVAV), /* SVt_PVAV */
932 sizeof(XPVHV), /* SVt_PVHV */
933 sizeof(XPVCV), /* SVt_PVCV */
934 sizeof(XPVGV), /* SVt_PVGV */
935 sizeof(XPVFM), /* SVt_PVFM */
936 sizeof(XPVIO) /* SVt_PVIO */
b6558d1d 937#elif PERL_VERSION == 10 && PERL_SUBVERSION == 0
f73dcfce 938 0, /* SVt_NULL */
939 0, /* SVt_BIND */
940 0, /* SVt_IV */
941 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
942 0, /* SVt_RV */
943 MAYBE_PURIFY(sizeof(xpv_allocated), sizeof(XPV)), /* SVt_PV */
944 MAYBE_PURIFY(sizeof(xpviv_allocated), sizeof(XPVIV)),/* SVt_PVIV */
945 sizeof(XPVNV), /* SVt_PVNV */
946 sizeof(XPVMG), /* SVt_PVMG */
947 sizeof(XPVGV), /* SVt_PVGV */
948 sizeof(XPVLV), /* SVt_PVLV */
949 MAYBE_PURIFY(sizeof(xpvav_allocated), sizeof(XPVAV)),/* SVt_PVAV */
950 MAYBE_PURIFY(sizeof(xpvhv_allocated), sizeof(XPVHV)),/* SVt_PVHV */
951 MAYBE_PURIFY(sizeof(xpvcv_allocated), sizeof(XPVCV)),/* SVt_PVCV */
952 MAYBE_PURIFY(sizeof(xpvfm_allocated), sizeof(XPVFM)),/* SVt_PVFM */
953 sizeof(XPVIO), /* SVt_PVIO */
b6558d1d 954#elif PERL_VERSION == 10 && PERL_SUBVERSION == 1
f73dcfce 955 0, /* SVt_NULL */
956 0, /* SVt_BIND */
957 0, /* SVt_IV */
958 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
959 0, /* SVt_RV */
960 sizeof(XPV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PV */
961 sizeof(XPVIV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PVIV */
962 sizeof(XPVNV), /* SVt_PVNV */
963 sizeof(XPVMG), /* SVt_PVMG */
964 sizeof(XPVGV), /* SVt_PVGV */
965 sizeof(XPVLV), /* SVt_PVLV */
966 sizeof(XPVAV) - MAYBE_OFFSET(XPVAV, xav_fill), /* SVt_PVAV */
967 sizeof(XPVHV) - MAYBE_OFFSET(XPVHV, xhv_fill), /* SVt_PVHV */
968 sizeof(XPVCV) - MAYBE_OFFSET(XPVCV, xpv_cur), /* SVt_PVCV */
969 sizeof(XPVFM) - MAYBE_OFFSET(XPVFM, xpv_cur), /* SVt_PVFM */
970 sizeof(XPVIO) /* SVt_PVIO */
b6558d1d 971#elif PERL_VERSION < 13
f73dcfce 972 0, /* SVt_NULL */
973 0, /* SVt_BIND */
974 0, /* SVt_IV */
975 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
976 sizeof(XPV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PV */
977 sizeof(XPVIV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PVIV */
978 sizeof(XPVNV), /* SVt_PVNV */
979 sizeof(XPVMG), /* SVt_PVMG */
980 sizeof(regexp) - MAYBE_OFFSET(regexp, xpv_cur), /* SVt_REGEXP */
981 sizeof(XPVGV), /* SVt_PVGV */
982 sizeof(XPVLV), /* SVt_PVLV */
983 sizeof(XPVAV) - MAYBE_OFFSET(XPVAV, xav_fill), /* SVt_PVAV */
984 sizeof(XPVHV) - MAYBE_OFFSET(XPVHV, xhv_fill), /* SVt_PVHV */
985 sizeof(XPVCV) - MAYBE_OFFSET(XPVCV, xpv_cur), /* SVt_PVCV */
986 sizeof(XPVFM) - MAYBE_OFFSET(XPVFM, xpv_cur), /* SVt_PVFM */
987 sizeof(XPVIO) /* SVt_PVIO */
b6558d1d 988#else
f73dcfce 989 0, /* SVt_NULL */
990 0, /* SVt_BIND */
991 0, /* SVt_IV */
992 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
993 sizeof(XPV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PV */
994 sizeof(XPVIV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PVIV */
995 sizeof(XPVNV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PVNV */
996 sizeof(XPVMG), /* SVt_PVMG */
997 sizeof(regexp), /* SVt_REGEXP */
998 sizeof(XPVGV), /* SVt_PVGV */
999 sizeof(XPVLV), /* SVt_PVLV */
1000 sizeof(XPVAV), /* SVt_PVAV */
1001 sizeof(XPVHV), /* SVt_PVHV */
1002 sizeof(XPVCV), /* SVt_PVCV */
1003 sizeof(XPVFM), /* SVt_PVFM */
1004 sizeof(XPVIO) /* SVt_PVIO */
b6558d1d 1005#endif
1006};
1007
c07e8ef8 1008
8a087ef5 1009/* based on Perl_do_dump_pad() - wraps sv_size and adds ADD_ATTR calls for the pad names */
c07e8ef8 1010static void
1011padlist_size(pTHX_ struct state *const st, pPATH, PADLIST *padlist,
1012 const int recurse)
1013{
1014 dNPathUseParent(NPathArg);
c07e8ef8 1015 const AV *pad_name;
1016 SV **pname;
1017 I32 ix;
1018
d2181def 1019 if (!padlist)
1020 return;
1021 if( 0 && !check_new(st, padlist))
c07e8ef8 1022 return;
1869f459 1023
c07e8ef8 1024 pad_name = MUTABLE_AV(*av_fetch(MUTABLE_AV(padlist), 0, FALSE));
1025 pname = AvARRAY(pad_name);
1026
1027 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
1028 const SV *namesv = pname[ix];
1029 if (namesv && namesv == &PL_sv_undef) {
1030 namesv = NULL;
1031 }
1032 if (namesv) {
d2181def 1033 /* SvFAKE: On a pad name SV, that slot in the frame AV is a REFCNT'ed reference to a lexical from "outside" */
c07e8ef8 1034 if (SvFAKE(namesv))
e8f4c506 1035 ADD_ATTR(st, NPattr_PADFAKE, SvPVX_const(namesv), ix);
c07e8ef8 1036 else
e8f4c506 1037 ADD_ATTR(st, NPattr_PADNAME, SvPVX_const(namesv), ix);
c07e8ef8 1038 }
1039 else {
e8f4c506 1040 ADD_ATTR(st, NPattr_PADTMP, "SVs_PADTMP", ix);
c07e8ef8 1041 }
1042
1043 }
1044 sv_size(aTHX_ st, NPathArg, (SV*)padlist, recurse);
1045}
1046
1047
e386ab55 1048static bool
c07e8ef8 1049sv_size(pTHX_ struct state *const st, pPATH, const SV * const orig_thing,
f3cf7e20 1050 const int recurse) {
9fc9ab86 1051 const SV *thing = orig_thing;
c07e8ef8 1052 dNPathNodes(3, NPathArg);
b6558d1d 1053 U32 type;
eee00145 1054
c07e8ef8 1055 if(!check_new(st, orig_thing))
e386ab55 1056 return 0;
81f1c018 1057
b6558d1d 1058 type = SvTYPE(thing);
1059 if (type > SVt_LAST) {
1060 warn("Devel::Size: Unknown variable type: %d encountered\n", type);
e386ab55 1061 return 1;
b6558d1d 1062 }
012b5f33 1063 NPathPushNode(thing, NPtype_SV);
df9491fe 1064 ADD_SIZE(st, "sv_head", sizeof(SV));
1065 ADD_SIZE(st, "sv_body", body_sizes[type]);
b1e5ad85 1066
b6558d1d 1067 switch (type) {
1068#if (PERL_VERSION < 11)
e98cedbf 1069 /* Is it a reference? */
9fc9ab86 1070 case SVt_RV: TAG;
b6558d1d 1071#else
1072 case SVt_IV: TAG;
24d37977 1073#endif
d2181def 1074 if(recurse && SvROK(thing)) /* XXX maybe don't follow weakrefs */
1075 sv_size(aTHX_ st, (SvWEAKREF(thing) ? NPathLink("weakRV") : NPathLink("RV")), SvRV_const(thing), recurse);
9fc9ab86 1076 TAG;break;
267703fd 1077
9fc9ab86 1078 case SVt_PVAV: TAG;
e98cedbf 1079 /* Is there anything in the array? */
1080 if (AvMAX(thing) != -1) {
c8db37d3 1081 /* an array with 10 slots has AvMax() set to 9 - te 2007-04-22 */
c07e8ef8 1082 ADD_SIZE(st, "av_max", sizeof(SV *) * (AvMAX(thing) + 1));
eee00145 1083 dbg_printf(("total_size: %li AvMAX: %li av_len: $i\n", st->total_size, AvMAX(thing), av_len((AV*)thing)));
6c5ddc0d 1084
05f432c0 1085 if (recurse >= st->min_recurse_threshold) {
6c5ddc0d 1086 SSize_t i = AvFILLp(thing) + 1;
1087
93a78808 1088 while (i--) {
09c6d3bb 1089 if (sv_size(aTHX_ st, NPathLink("AVelem"), AvARRAY(thing)[i], recurse))
1090 ADD_LINK_ATTR(st, NPattr_NOTE, "i", i);
93a78808 1091 }
6c5ddc0d 1092 }
e98cedbf 1093 }
1094 /* Add in the bits on the other side of the beginning */
0430b7f7 1095
b7621729 1096 dbg_printf(("total_size %li, sizeof(SV *) %li, AvARRAY(thing) %li, AvALLOC(thing)%li , sizeof(ptr) %li \n",
c07e8ef8 1097 st->total_size, sizeof(SV*), AvARRAY(thing), AvALLOC(thing), sizeof( thing )));
0430b7f7 1098
1099 /* under Perl 5.8.8 64bit threading, AvARRAY(thing) was a pointer while AvALLOC was 0,
b1e5ad85 1100 resulting in grossly overstated sized for arrays. Technically, this shouldn't happen... */
0430b7f7 1101 if (AvALLOC(thing) != 0) {
c07e8ef8 1102 ADD_SIZE(st, "AvALLOC", (sizeof(SV *) * (AvARRAY(thing) - AvALLOC(thing))));
0430b7f7 1103 }
795fc84c 1104#if (PERL_VERSION < 9)
1105 /* Is there something hanging off the arylen element?
1106 Post 5.9.something this is stored in magic, so will be found there,
1107 and Perl_av_arylen_p() takes a non-const AV*, hence compilers rightly
1108 complain about AvARYLEN() passing thing to it. */
fc6614ee 1109 sv_size(aTHX_ st, NPathLink("ARYLEN"), AvARYLEN(thing), recurse);
795fc84c 1110#endif
9fc9ab86 1111 TAG;break;
49beddc6 1112
9fc9ab86 1113 case SVt_PVHV: TAG;
a6ea0805 1114 /* Now the array of buckets */
c07e8ef8 1115 ADD_SIZE(st, "hv_max", (sizeof(HE *) * (HvMAX(thing) + 1)));
1116 if (HvENAME(thing)) {
e8f4c506 1117 ADD_ATTR(st, NPattr_NAME, HvENAME(thing), 0);
c07e8ef8 1118 }
a6ea0805 1119 /* Now walk the bucket chain */
6a9ad7ec 1120 if (HvARRAY(thing)) {
a6ea0805 1121 HE *cur_entry;
9fc9ab86 1122 UV cur_bucket = 0;
a6ea0805 1123 for (cur_bucket = 0; cur_bucket <= HvMAX(thing); cur_bucket++) {
9fc9ab86 1124 cur_entry = *(HvARRAY(thing) + cur_bucket);
1125 while (cur_entry) {
b6ec3c3a 1126/* XXX a HE should probably be a node so the keys and values are seen as pairs */
c07e8ef8 1127 ADD_SIZE(st, "he", sizeof(HE));
fc6614ee 1128 hek_size(aTHX_ st, cur_entry->hent_hek, HvSHAREKEYS(thing), NPathLink("hent_hek"));
05f432c0 1129 if (recurse >= st->min_recurse_threshold) {
d3b8a135 1130 if (orig_thing == (SV*)PL_strtab) {
df9491fe 1131 /* For PL_strtab the HeVAL is used as a refcnt */
1132 ADD_SIZE(st, "shared_hek", HeKLEN(cur_entry));
1133 }
1134 else {
2c631ee0 1135/* I've seen a PL_strtab HeVAL == 0xC and 0x40C etc
5e486cae 1136 * just running perl -Mblib -Mstrict -MDevel::Size=:all -MCarp -e 'warn perl_size()'
1137 * but it seemed like a corruption - it would change come and go with irrelevant code changes.
1138 * so we protect against that here, but I'd like to know the cause.
1139 */
2c631ee0 1140if (PTR2UV(HeVAL(cur_entry)) > 0xFFF)
fc6614ee 1141 sv_size(aTHX_ st, NPathLink("HeVAL"), HeVAL(cur_entry), recurse);
b6ec3c3a 1142else warn("skipped suspect HeVAL %p", HeVAL(cur_entry));
df9491fe 1143 }
5e486cae 1144 }
9fc9ab86 1145 cur_entry = cur_entry->hent_next;
1146 }
a6ea0805 1147 }
1148 }
78037efb 1149#ifdef HvAUX
1150 if (SvOOK(thing)) {
1151 /* This direct access is arguably "naughty": */
1152 struct mro_meta *meta = HvAUX(thing)->xhv_mro_meta;
24638fb4 1153#if PERL_VERSION > 13 || PERL_SUBVERSION > 8 /* XXX plain || seems like a bug */
b3a37f1a 1154 /* As is this: */
1155 I32 count = HvAUX(thing)->xhv_name_count;
1156
1157 if (count) {
1158 HEK **names = HvAUX(thing)->xhv_name_u.xhvnameu_names;
1159 if (count < 0)
1160 count = -count;
1161 while (--count)
fc6614ee 1162 hek_size(aTHX_ st, names[count], 1, NPathLink("HvAUXelem"));
b3a37f1a 1163 }
1164 else
1165#endif
1166 {
fc6614ee 1167 hek_size(aTHX_ st, HvNAME_HEK(thing), 1, NPathLink("HvNAME_HEK"));
b3a37f1a 1168 }
1169
c07e8ef8 1170 ADD_SIZE(st, "xpvhv_aux", sizeof(struct xpvhv_aux));
78037efb 1171 if (meta) {
c07e8ef8 1172 ADD_SIZE(st, "mro_meta", sizeof(struct mro_meta));
fc6614ee 1173 sv_size(aTHX_ st, NPathLink("mro_nextmethod"), (SV *)meta->mro_nextmethod, TOTAL_SIZE_RECURSION);
78037efb 1174#if PERL_VERSION > 10 || (PERL_VERSION == 10 && PERL_SUBVERSION > 0)
fc6614ee 1175 sv_size(aTHX_ st, NPathLink("isa"), (SV *)meta->isa, TOTAL_SIZE_RECURSION);
78037efb 1176#endif
1177#if PERL_VERSION > 10
fc6614ee 1178 sv_size(aTHX_ st, NPathLink("mro_linear_all"), (SV *)meta->mro_linear_all, TOTAL_SIZE_RECURSION);
1179 sv_size(aTHX_ st, NPathLink("mro_linear_current"), meta->mro_linear_current, TOTAL_SIZE_RECURSION);
78037efb 1180#else
fc6614ee 1181 sv_size(aTHX_ st, NPathLink("mro_linear_dfs"), (SV *)meta->mro_linear_dfs, TOTAL_SIZE_RECURSION);
1182 sv_size(aTHX_ st, NPathLink("mro_linear_c3"), (SV *)meta->mro_linear_c3, TOTAL_SIZE_RECURSION);
78037efb 1183#endif
1184 }
1185 }
1186#else
fc6614ee 1187 check_new_and_strlen(st, HvNAME_get(thing), NPathLink("HvNAME"));
78037efb 1188#endif
9fc9ab86 1189 TAG;break;
267703fd 1190
1191
1192 case SVt_PVFM: TAG;
eb73dc89 1193 padlist_size(aTHX_ st, NPathLink("CvPADLIST"), CvPADLIST(thing), recurse);
36a03132 1194 sv_size(aTHX_ st, NPathLink("CvOUTSIDE"), (SV *)CvOUTSIDE(thing), SOME_RECURSION);
267703fd 1195
1196 if (st->go_yell && !st->fm_whine) {
1197 carp("Devel::Size: Calculated sizes for FMs are incomplete");
1198 st->fm_whine = 1;
1199 }
1200 goto freescalar;
1201
9fc9ab86 1202 case SVt_PVCV: TAG;
336fdadd 1203 /* not CvSTASH, per https://rt.cpan.org/Ticket/Display.html?id=79366 */
93a78808 1204 ADD_ATTR(st, NPattr_NAME, CvGV(thing) ? GvNAME(CvGV(thing)) : "UNDEFINED", 0);
fc6614ee 1205 sv_size(aTHX_ st, NPathLink("SvSTASH"), (SV *)SvSTASH(thing), SOME_RECURSION);
1206 sv_size(aTHX_ st, NPathLink("CvGV"), (SV *)CvGV(thing), SOME_RECURSION);
eb73dc89 1207 padlist_size(aTHX_ st, NPathLink("CvPADLIST"), CvPADLIST(thing), recurse);
36a03132 1208 sv_size(aTHX_ st, NPathLink("CvOUTSIDE"), (SV *)CvOUTSIDE(thing), SOME_RECURSION);
66f50dda 1209 if (CvISXSUB(thing)) {
fc6614ee 1210 sv_size(aTHX_ st, NPathLink("cv_const_sv"), cv_const_sv((CV *)thing), recurse);
66f50dda 1211 } else {
ce5aa2b7 1212 if(1)op_size(aTHX_ CvSTART(thing), st, NPathLinkAndNode("CvSTART", "OPs")); /* XXX ? */
1213 op_size(aTHX_ CvROOT(thing), st, NPathLinkAndNode("CvROOT", "OPs"));
7ccc7d88 1214 }
267703fd 1215 goto freescalar;
1216
1217 case SVt_PVIO: TAG;
267703fd 1218 /* Some embedded char pointers */
fc6614ee 1219 check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_top_name, NPathLink("xio_top_name"));
1220 check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_fmt_name, NPathLink("xio_fmt_name"));
1221 check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_bottom_name, NPathLink("xio_bottom_name"));
267703fd 1222 /* Throw the GVs on the list to be walked if they're not-null */
fc6614ee 1223 sv_size(aTHX_ st, NPathLink("xio_top_gv"), (SV *)((XPVIO *) SvANY(thing))->xio_top_gv, recurse);
1224 sv_size(aTHX_ st, NPathLink("xio_bottom_gv"), (SV *)((XPVIO *) SvANY(thing))->xio_bottom_gv, recurse);
1225 sv_size(aTHX_ st, NPathLink("xio_fmt_gv"), (SV *)((XPVIO *) SvANY(thing))->xio_fmt_gv, recurse);
267703fd 1226
1227 /* Only go trotting through the IO structures if they're really
1228 trottable. If USE_PERLIO is defined we can do this. If
1229 not... we can't, so we don't even try */
1230#ifdef USE_PERLIO
1231 /* Dig into xio_ifp and xio_ofp here */
1232 warn("Devel::Size: Can't size up perlio layers yet\n");
1233#endif
1234 goto freescalar;
1235
267703fd 1236 case SVt_PVLV: TAG;
267703fd 1237#if (PERL_VERSION < 9)
1238 goto freescalar;
267703fd 1239#endif
7ccc7d88 1240
9fc9ab86 1241 case SVt_PVGV: TAG;
4a3d023d 1242 if(isGV_with_GP(thing)) {
638a265a 1243#ifdef GvNAME_HEK
fc6614ee 1244 hek_size(aTHX_ st, GvNAME_HEK(thing), 1, NPathLink("GvNAME_HEK"));
638a265a 1245#else
c07e8ef8 1246 ADD_SIZE(st, "GvNAMELEN", GvNAMELEN(thing));
638a265a 1247#endif
e8f4c506 1248 ADD_ATTR(st, NPattr_NAME, GvNAME_get(thing), 0);
15588e9c 1249#ifdef GvFILE_HEK
fc6614ee 1250 hek_size(aTHX_ st, GvFILE_HEK(thing), 1, NPathLink("GvFILE_HEK"));
15588e9c 1251#elif defined(GvFILE)
2b217e71 1252# if !defined(USE_ITHREADS) || (PERL_VERSION > 8 || (PERL_VERSION == 8 && PERL_SUBVERSION > 8))
1253 /* With itreads, before 5.8.9, this can end up pointing to freed memory
1254 if the GV was created in an eval, as GvFILE() points to CopFILE(),
1255 and the relevant COP has been freed on scope cleanup after the eval.
1256 5.8.9 adds a binary compatible fudge that catches the vast majority
1257 of cases. 5.9.something added a proper fix, by converting the GP to
1258 use a shared hash key (porperly reference counted), instead of a
1259 char * (owned by who knows? possibly no-one now) */
fc6614ee 1260 check_new_and_strlen(st, GvFILE(thing), NPathLink("GvFILE"));
2b217e71 1261# endif
78dfb4e7 1262#endif
4a3d023d 1263 /* Is there something hanging off the glob? */
1264 if (check_new(st, GvGP(thing))) {
c07e8ef8 1265 ADD_SIZE(st, "GP", sizeof(GP));
fc6614ee 1266 sv_size(aTHX_ st, NPathLink("gp_sv"), (SV *)(GvGP(thing)->gp_sv), recurse);
fc6614ee 1267 sv_size(aTHX_ st, NPathLink("gp_av"), (SV *)(GvGP(thing)->gp_av), recurse);
1268 sv_size(aTHX_ st, NPathLink("gp_hv"), (SV *)(GvGP(thing)->gp_hv), recurse);
fc6614ee 1269 sv_size(aTHX_ st, NPathLink("gp_cv"), (SV *)(GvGP(thing)->gp_cv), recurse);
49beddc6 1270 sv_size(aTHX_ st, NPathLink("gp_egv"), (SV *)(GvGP(thing)->gp_egv), recurse);
1271 sv_size(aTHX_ st, NPathLink("gp_form"), (SV *)(GvGP(thing)->gp_form), recurse);
4a3d023d 1272 }
267703fd 1273#if (PERL_VERSION >= 9)
1274 TAG; break;
1275#endif
5c2e1b12 1276 }
b6558d1d 1277#if PERL_VERSION <= 8
1278 case SVt_PVBM: TAG;
1279#endif
267703fd 1280 case SVt_PVMG: TAG;
267703fd 1281 case SVt_PVNV: TAG;
267703fd 1282 case SVt_PVIV: TAG;
267703fd 1283 case SVt_PV: TAG;
267703fd 1284 freescalar:
1285 if(recurse && SvROK(thing))
fc6614ee 1286 sv_size(aTHX_ st, NPathLink("RV"), SvRV_const(thing), recurse);
924d9c4e 1287 else if (SvIsCOW_shared_hash(thing))
fc6614ee 1288 hek_size(aTHX_ st, SvSHARED_HEK_FROM_PV(SvPVX(thing)), 1, NPathLink("SvSHARED_HEK_FROM_PV"));
267703fd 1289 else
c07e8ef8 1290 ADD_SIZE(st, "SvLEN", SvLEN(thing));
267703fd 1291
1292 if(SvOOK(thing)) {
95dc1714 1293 STRLEN len;
1294 SvOOK_offset(thing, len);
c07e8ef8 1295 ADD_SIZE(st, "SvOOK", len);
ebb2c5b9 1296 }
9fc9ab86 1297 TAG;break;
5073b933 1298
e98cedbf 1299 }
49beddc6 1300
1301 if (type >= SVt_PVMG) {
1302 magic_size(aTHX_ thing, st, NPathLink("MG"));
1303 }
1304
e386ab55 1305 return 1;
e98cedbf 1306}
1307
1abba8e9 1308static void
1309free_memnode_state(pTHX_ struct state *st)
1310{
d3b8a135 1311 if (st->node_stream_fh && st->node_stream_name && *st->node_stream_name) {
09c6d3bb 1312 fprintf(st->node_stream_fh, "E %d %f %s\n",
5e2e22f3 1313 getpid(), gettimeofday_nv()-st->start_time_nv, "unnamed");
1abba8e9 1314 if (*st->node_stream_name == '|') {
1315 if (pclose(st->node_stream_fh))
1316 warn("%s exited with an error status\n", st->node_stream_name);
1317 }
1318 else {
1319 if (fclose(st->node_stream_fh))
1320 warn("Error closing %s: %s\n", st->node_stream_name, strerror(errno));
1321 }
1322 }
1323}
1324
a4efdff3 1325static struct state *
1326new_state(pTHX)
65db36c0 1327{
1328 SV *warn_flag;
a4efdff3 1329 struct state *st;
d9b022a1 1330
a4efdff3 1331 Newxz(st, 1, struct state);
1332 st->go_yell = TRUE;
05f432c0 1333 st->min_recurse_threshold = TOTAL_SIZE_RECURSION;
65db36c0 1334 if (NULL != (warn_flag = perl_get_sv("Devel::Size::warn", FALSE))) {
a4efdff3 1335 st->dangle_whine = st->go_yell = SvIV(warn_flag) ? TRUE : FALSE;
65db36c0 1336 }
1337 if (NULL != (warn_flag = perl_get_sv("Devel::Size::dangle", FALSE))) {
a4efdff3 1338 st->dangle_whine = SvIV(warn_flag) ? TRUE : FALSE;
65db36c0 1339 }
5e2e22f3 1340 st->start_time_nv = gettimeofday_nv();
a52ceccd 1341 check_new(st, &PL_sv_undef);
1342 check_new(st, &PL_sv_no);
1343 check_new(st, &PL_sv_yes);
6389ea67 1344#if PERL_VERSION > 8 || (PERL_VERSION == 8 && PERL_SUBVERSION > 0)
1345 check_new(st, &PL_sv_placeholder);
1346#endif
d3b8a135 1347
33f2f60c 1348#ifdef PATH_TRACKING
d3b8a135 1349 /* XXX quick hack */
0e977dbc 1350 st->node_stream_name = getenv("SIZEME");
d3b8a135 1351 if (st->node_stream_name) {
1352 if (*st->node_stream_name) {
1353 if (*st->node_stream_name == '|')
1354 st->node_stream_fh = popen(st->node_stream_name+1, "w");
1355 else
1356 st->node_stream_fh = fopen(st->node_stream_name, "wb");
1357 if (!st->node_stream_fh)
1358 croak("Can't open '%s' for writing: %s", st->node_stream_name, strerror(errno));
5e2e22f3 1359 if(0)setlinebuf(st->node_stream_fh); /* XXX temporary for debugging */
d3b8a135 1360 st->add_attr_cb = np_stream_node_path_info;
09c6d3bb 1361 fprintf(st->node_stream_fh, "S %d %f %s\n",
5e2e22f3 1362 getpid(), st->start_time_nv, "unnamed");
d3b8a135 1363 }
1364 else
1365 st->add_attr_cb = np_dump_node_path_info;
1abba8e9 1366 }
1abba8e9 1367 st->free_state_cb = free_memnode_state;
33f2f60c 1368#endif
d3b8a135 1369
a4efdff3 1370 return st;
65db36c0 1371}
1372
1abba8e9 1373/* XXX based on S_visit() in sv.c */
1374static void
1375unseen_sv_size(pTHX_ struct state *st, pPATH)
1376{
1377 dVAR;
1378 SV* sva;
1379 I32 visited = 0;
1380 dNPathNodes(1, NPathArg);
1381
1382 NPathPushNode("unseen", NPtype_NAME);
1383
1384 /* by this point we should have visited all the SVs
1385 * so now we'll run through all the SVs via the arenas
1386 * in order to find any thet we've missed for some reason.
1387 * Once the rest of the code is finding all the SVs then any
1388 * found here will be leaks.
1389 */
1390 for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) {
1391 const SV * const svend = &sva[SvREFCNT(sva)];
1392 SV* sv;
1393 for (sv = sva + 1; sv < svend; ++sv) {
1394 if (SvTYPE(sv) != (svtype)SVTYPEMASK && SvREFCNT(sv)) {
49beddc6 1395 sv_size(aTHX_ st, NPathLink("arena"), sv, TOTAL_SIZE_RECURSION);
1abba8e9 1396 }
1397 else if (check_new(st, sv)) { /* sanity check */
1abba8e9 1398 sv_dump(sv);
df9491fe 1399 warn("unseen_sv_size encountered freed SV unexpectedly"); /* XXX warn uses an SV, I think */
1abba8e9 1400 }
1401 }
1402 }
1403}
1404
df9491fe 1405static void
1406perl_size(pTHX_ struct state *const st, pPATH)
33f2f60c 1407{
df9491fe 1408 dNPathNodes(3, NPathArg);
05f432c0 1409
df9491fe 1410 /* if(!check_new(st, interp)) return; */
1411 NPathPushNode("perl", NPtype_NAME);
1abba8e9 1412
df9491fe 1413/*
1414 * perl
1415 * PL_defstash
1416 * others
1417 * unknown <== = O/S Heap size - perl - free_malloc_space
1418 */
1abba8e9 1419 /* start with PL_defstash to get everything reachable from \%main:: */
fc6614ee 1420 sv_size(aTHX_ st, NPathLink("PL_defstash"), (SV*)PL_defstash, TOTAL_SIZE_RECURSION);
e8f4c506 1421
1422 NPathPushNode("others", NPtype_NAME); /* group these (typically much smaller) items */
fc6614ee 1423 sv_size(aTHX_ st, NPathLink("PL_defgv"), (SV*)PL_defgv, TOTAL_SIZE_RECURSION);
1424 sv_size(aTHX_ st, NPathLink("PL_incgv"), (SV*)PL_incgv, TOTAL_SIZE_RECURSION);
1425 sv_size(aTHX_ st, NPathLink("PL_rs"), (SV*)PL_rs, TOTAL_SIZE_RECURSION);
1426 sv_size(aTHX_ st, NPathLink("PL_fdpid"), (SV*)PL_fdpid, TOTAL_SIZE_RECURSION);
1427 sv_size(aTHX_ st, NPathLink("PL_modglobal"), (SV*)PL_modglobal, TOTAL_SIZE_RECURSION);
1428 sv_size(aTHX_ st, NPathLink("PL_errors"), (SV*)PL_errors, TOTAL_SIZE_RECURSION);
1429 sv_size(aTHX_ st, NPathLink("PL_stashcache"), (SV*)PL_stashcache, TOTAL_SIZE_RECURSION);
1430 sv_size(aTHX_ st, NPathLink("PL_patchlevel"), (SV*)PL_patchlevel, TOTAL_SIZE_RECURSION);
1431 sv_size(aTHX_ st, NPathLink("PL_apiversion"), (SV*)PL_apiversion, TOTAL_SIZE_RECURSION);
1432 sv_size(aTHX_ st, NPathLink("PL_registered_mros"), (SV*)PL_registered_mros, TOTAL_SIZE_RECURSION);
33f2f60c 1433#ifdef USE_ITHREADS
fc6614ee 1434 sv_size(aTHX_ st, NPathLink("PL_regex_padav"), (SV*)PL_regex_padav, TOTAL_SIZE_RECURSION);
33f2f60c 1435#endif
8a087ef5 1436 sv_size(aTHX_ st, NPathLink("PL_warnhook"), (SV*)PL_warnhook, TOTAL_SIZE_RECURSION);
1437 sv_size(aTHX_ st, NPathLink("PL_diehook"), (SV*)PL_diehook, TOTAL_SIZE_RECURSION);
1438 sv_size(aTHX_ st, NPathLink("PL_endav"), (SV*)PL_endav, TOTAL_SIZE_RECURSION);
1439 sv_size(aTHX_ st, NPathLink("PL_main_cv"), (SV*)PL_main_cv, TOTAL_SIZE_RECURSION);
1440 sv_size(aTHX_ st, NPathLink("PL_main_root"), (SV*)PL_main_root, TOTAL_SIZE_RECURSION);
1441 sv_size(aTHX_ st, NPathLink("PL_main_start"), (SV*)PL_main_start, TOTAL_SIZE_RECURSION);
33f2f60c 1442 /* TODO PL_pidstatus */
1443 /* TODO PL_stashpad */
8a087ef5 1444 /* TODO PL_compiling? COP */
33f2f60c 1445
33f2f60c 1446 /* TODO stacks: cur, main, tmps, mark, scope, save */
8a087ef5 1447 /* TODO PL_exitlist */
1abba8e9 1448 /* TODO PL_reentrant_buffers etc */
8a087ef5 1449 /* TODO environ */
1450 /* TODO PerlIO? PL_known_layers PL_def_layerlist PL_perlio_fd_refcnt etc */
5e486cae 1451 /* TODO threads? */
33f2f60c 1452 /* TODO anything missed? */
1453
1abba8e9 1454 /* --- by this point we should have seen all reachable SVs --- */
1455
1456 /* in theory we shouldn't have any elements in PL_strtab that haven't been seen yet */
df9491fe 1457 sv_size(aTHX_ st, NPathLink("PL_strtab-unseen"), (SV*)PL_strtab, TOTAL_SIZE_RECURSION);
1abba8e9 1458
1459 /* unused space in sv head arenas */
1460 if (PL_sv_root) {
1461 SV *p = PL_sv_root;
1462 UV free_heads = 1;
df9491fe 1463# define SvARENA_CHAIN(sv) SvANY(sv) /* XXX breaks encapsulation*/
1abba8e9 1464 while ((p = MUTABLE_SV(SvARENA_CHAIN(p)))) {
1465 if (!check_new(st, p)) /* sanity check */
1466 warn("Free'd SV head unexpectedly already seen");
1467 ++free_heads;
1468 }
1469 NPathPushNode("unused_sv_heads", NPtype_NAME);
1470 ADD_SIZE(st, "sv", free_heads * sizeof(SV));
1471 NPathPopNode;
1472 }
1473 /* XXX iterate over bodies_by_type and crawl the free chains for each */
1474
1475 /* iterate over all SVs to find any we've not accounted for yet */
1476 /* once the code above is visiting all SVs, any found here have been leaked */
1477 unseen_sv_size(aTHX_ st, NPathLink("unaccounted"));
df9491fe 1478}
1479
1480
d3b8a135 1481MODULE = Devel::Memory PACKAGE = Devel::Memory
df9491fe 1482
1483PROTOTYPES: DISABLE
1abba8e9 1484
df9491fe 1485UV
1486size(orig_thing)
1487 SV *orig_thing
1488ALIAS:
1489 total_size = TOTAL_SIZE_RECURSION
1490CODE:
1491{
1492 SV *thing = orig_thing;
1493 struct state *st = new_state(aTHX);
1494
1495 /* If they passed us a reference then dereference it. This is the
1496 only way we can check the sizes of arrays and hashes */
1497 if (SvROK(thing)) {
1498 thing = SvRV(thing);
1abba8e9 1499 }
1500
df9491fe 1501 sv_size(aTHX_ st, NULL, thing, ix);
1502 RETVAL = st->total_size;
1503 free_state(st);
1504}
1505OUTPUT:
1506 RETVAL
1507
1508UV
1509perl_size()
1510CODE:
1511{
1512 /* just the current perl interpreter */
1513 struct state *st = new_state(aTHX);
1514 st->min_recurse_threshold = NO_RECURSION; /* so always recurse */
1515 perl_size(aTHX_ st, NULL);
1516 RETVAL = st->total_size;
1517 free_state(st);
1518}
1519OUTPUT:
1520 RETVAL
1521
1522UV
1523heap_size()
1524CODE:
1525{
1526 /* the current perl interpreter plus malloc, in the context of total heap size */
6a9ab1d2 1527# ifdef _MALLOC_MALLOC_H_ /* OSX. Now sure where else mstats is available */
1528# define HAS_MSTATS
1529# endif
1530# ifdef HAS_MSTATS
1531 /* some systems have the SVID2/XPG mallinfo structure and function */
df9491fe 1532 struct mstats ms = mstats(); /* mstats() first */
6a9ab1d2 1533# endif
df9491fe 1534 struct state *st = new_state(aTHX);
1535 dNPathNodes(1, NULL);
1536 NPathPushNode("heap", NPtype_NAME);
1537
1538 st->min_recurse_threshold = NO_RECURSION; /* so always recurse */
1539
1540 perl_size(aTHX_ st, NPathLink("perl_interp"));
21920e7f 1541# ifdef HAS_MSTATS
df9491fe 1542 NPathSetNode("free_malloc_space", NPtype_NAME);
1543 ADD_SIZE(st, "bytes_free", ms.bytes_free);
1544 ADD_ATTR(st, NPattr_NOTE, "bytes_total", ms.bytes_total);
1545 ADD_ATTR(st, NPattr_NOTE, "bytes_used", ms.bytes_used);
1546 ADD_ATTR(st, NPattr_NOTE, "chunks_used", ms.chunks_used);
1547 ADD_ATTR(st, NPattr_NOTE, "chunks_free", ms.chunks_free);
df9491fe 1548 /* TODO get heap size from OS and add a node: unknown = heapsize - perl - ms.bytes_free */
1549 /* for now we use bytes_total as an approximation */
1550 NPathSetNode("unknown", NPtype_NAME);
1551 ADD_SIZE(st, "unknown", ms.bytes_total - st->total_size);
6a9ab1d2 1552# else
1553 /* XXX ? */
1554# endif
df9491fe 1555
33f2f60c 1556 RETVAL = st->total_size;
1557 free_state(st);
1558}
1559OUTPUT:
1560 RETVAL
Unnamed repository; edit this file 'description' to name the repository.