projects / p5sagit/Devel-Size.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | history | HEAD
Add a comment to force emacs to use C mode.
[p5sagit/Devel-Size.git] / Size.xs
CommitLineData
fd495cc6 1/* -*- mode: C -*- */
2
265a0548 3#define PERL_NO_GET_CONTEXT
4
e98cedbf 5#include "EXTERN.h"
6#include "perl.h"
7#include "XSUB.h"
2eb93d08 8#include "ppport.h"
e98cedbf 9
87372f42 10/* Not yet in ppport.h */
11#ifndef CvISXSUB
12# define CvISXSUB(cv) (CvXSUB(cv) ? TRUE : FALSE)
13#endif
0e1f978f 14#ifndef SvRV_const
15# define SvRV_const(rv) SvRV(rv)
16#endif
95dc1714 17#ifndef SvOOK_offset
18# define SvOOK_offset(sv, len) STMT_START { len = SvIVX(sv); } STMT_END
19#endif
87372f42 20
177ebd37 21#if PERL_VERSION < 6
22# define PL_opargs opargs
23# define PL_op_name op_name
24#endif
25
9fc9ab86 26#ifdef _MSC_VER
1a36ac09 27/* "structured exception" handling is a Microsoft extension to C and C++.
28 It's *not* C++ exception handling - C++ exception handling can't capture
29 SEGVs and suchlike, whereas this can. There's no known analagous
30 functionality on other platforms. */
31# include <excpt.h>
32# define TRY_TO_CATCH_SEGV __try
33# define CAUGHT_EXCEPTION __except(EXCEPTION EXCEPTION_EXECUTE_HANDLER)
9fc9ab86 34#else
1a36ac09 35# define TRY_TO_CATCH_SEGV if(1)
36# define CAUGHT_EXCEPTION else
9fc9ab86 37#endif
38
39#ifdef __GNUC__
40# define __attribute__(x)
41#endif
42
b7621729 43#if 0 && defined(DEBUGGING)
44#define dbg_printf(x) printf x
45#else
46#define dbg_printf(x)
47#endif
98ecbbc6 48
0964064b 49#define TAG /* printf( "# %s(%d)\n", __FILE__, __LINE__ ) */
6a9ad7ec 50#define carp puts
9fc9ab86 51
30fe4f47 52/* The idea is to have a tree structure to store 1 bit per possible pointer
53 address. The lowest 16 bits are stored in a block of 8092 bytes.
54 The blocks are in a 256-way tree, indexed by the reset of the pointer.
55 This can cope with 32 and 64 bit pointers, and any address space layout,
56 without excessive memory needs. The assumption is that your CPU cache
57 works :-) (And that we're not going to bust it) */
58
30fe4f47 59#define BYTE_BITS 3
60#define LEAF_BITS (16 - BYTE_BITS)
61#define LEAF_MASK 0x1FFF
9fc9ab86 62
65db36c0 63struct state {
eee00145 64 UV total_size;
65db36c0 65 bool regex_whine;
66 bool fm_whine;
67 bool dangle_whine;
68 bool go_yell;
69 /* My hunch (not measured) is that for most architectures pointers will
70 start with 0 bits, hence the start of this array will be hot, and the
71 end unused. So put the flags next to the hot end. */
72 void *tracking[256];
73};
74
9fc9ab86 75/*
76 Checks to see if thing is in the bitstring.
77 Returns true or false, and
78 notes thing in the segmented bitstring.
79 */
2eb93d08 80static bool
a4efdff3 81check_new(struct state *st, const void *const p) {
30fe4f47 82 unsigned int bits = 8 * sizeof(void*);
83 const size_t raw_p = PTR2nat(p);
84 /* This effectively rotates the value right by the number of low always-0
85 bits in an aligned pointer. The assmption is that most (if not all)
86 pointers are aligned, and these will be in the same chain of nodes
87 (and hence hot in the cache) but we can still deal with any unaligned
88 pointers. */
89 const size_t cooked_p
f404ed48 90 = (raw_p >> ALIGN_BITS) | (raw_p << (bits - ALIGN_BITS));
30fe4f47 91 const U8 this_bit = 1 << (cooked_p & 0x7);
92 U8 **leaf_p;
93 U8 *leaf;
94 unsigned int i;
302077b6 95 void **tv_p = (void **) (st->tracking);
30fe4f47 96
302077b6 97 if (NULL == p) return FALSE;
1a36ac09 98 TRY_TO_CATCH_SEGV {
2eb93d08 99 const char c = *(const char *)p;
9fc9ab86 100 }
1a36ac09 101 CAUGHT_EXCEPTION {
a4efdff3 102 if (st->dangle_whine)
9fc9ab86 103 warn( "Devel::Size: Encountered invalid pointer: %p\n", p );
104 return FALSE;
105 }
9fc9ab86 106 TAG;
30fe4f47 107
108 bits -= 8;
109 /* bits now 24 (32 bit pointers) or 56 (64 bit pointers) */
110
111 /* First level is always present. */
112 do {
113 i = (unsigned int)((cooked_p >> bits) & 0xFF);
114 if (!tv_p[i])
115 Newxz(tv_p[i], 256, void *);
116 tv_p = (void **)(tv_p[i]);
117 bits -= 8;
118 } while (bits > LEAF_BITS + BYTE_BITS);
119 /* bits now 16 always */
5f04c81d 120#if !defined(MULTIPLICITY) || PERL_VERSION > 8 || (PERL_VERSION == 8 && PERL_SUBVERSION > 8)
121 /* 5.8.8 and early have an assert() macro that uses Perl_croak, hence needs
122 a my_perl under multiplicity */
30fe4f47 123 assert(bits == 16);
5f04c81d 124#endif
30fe4f47 125 leaf_p = (U8 **)tv_p;
126 i = (unsigned int)((cooked_p >> bits) & 0xFF);
127 if (!leaf_p[i])
128 Newxz(leaf_p[i], 1 << LEAF_BITS, U8);
129 leaf = leaf_p[i];
130
9fc9ab86 131 TAG;
30fe4f47 132
133 i = (unsigned int)((cooked_p >> BYTE_BITS) & LEAF_MASK);
134
135 if(leaf[i] & this_bit)
136 return FALSE;
137
138 leaf[i] |= this_bit;
9fc9ab86 139 return TRUE;
140}
141
e9716740 142static void
30fe4f47 143free_tracking_at(void **tv, int level)
144{
145 int i = 255;
146
147 if (--level) {
148 /* Nodes */
149 do {
150 if (tv[i]) {
384ebd3f 151 free_tracking_at((void **) tv[i], level);
30fe4f47 152 Safefree(tv[i]);
153 }
154 } while (i--);
155 } else {
156 /* Leaves */
157 do {
158 if (tv[i])
159 Safefree(tv[i]);
160 } while (i--);
161 }
162}
163
164static void
a4efdff3 165free_state(struct state *st)
e9716740 166{
30fe4f47 167 const int top_level = (sizeof(void *) * 8 - LEAF_BITS - BYTE_BITS) / 8;
a4efdff3 168 free_tracking_at((void **)st->tracking, top_level);
169 Safefree(st);
e9716740 170}
171
f3cf7e20 172/* For now, this is somewhat a compatibility bodge until the plan comes
173 together for fine grained recursion control. total_size() would recurse into
174 hash and array members, whereas sv_size() would not. However, sv_size() is
175 called with CvSTASH() of a CV, which means that if it (also) starts to
176 recurse fully, then the size of any CV now becomes the size of the entire
177 symbol table reachable from it, and potentially the entire symbol table, if
178 any subroutine makes a reference to a global (such as %SIG). The historical
179 implementation of total_size() didn't report "everything", and changing the
180 only available size to "everything" doesn't feel at all useful. */
181
182#define NO_RECURSION 0
183#define SOME_RECURSION 1
184#define TOTAL_SIZE_RECURSION 2
185
a5c6bdd7 186static void sv_size(pTHX_ struct state *, const SV *const, const int recurse);
db519f11 187
7ccc7d88 188typedef enum {
9fc9ab86 189 OPc_NULL, /* 0 */
190 OPc_BASEOP, /* 1 */
191 OPc_UNOP, /* 2 */
192 OPc_BINOP, /* 3 */
193 OPc_LOGOP, /* 4 */
194 OPc_LISTOP, /* 5 */
195 OPc_PMOP, /* 6 */
196 OPc_SVOP, /* 7 */
197 OPc_PADOP, /* 8 */
198 OPc_PVOP, /* 9 */
199 OPc_LOOP, /* 10 */
200 OPc_COP /* 11 */
177ebd37 201#ifdef OA_CONDOP
202 , OPc_CONDOP /* 12 */
203#endif
204#ifdef OA_GVOP
205 , OPc_GVOP /* 13 */
206#endif
207
7ccc7d88 208} opclass;
209
210static opclass
9fc9ab86 211cc_opclass(const OP * const o)
7ccc7d88 212{
213 if (!o)
9fc9ab86 214 return OPc_NULL;
1a36ac09 215 TRY_TO_CATCH_SEGV {
9fc9ab86 216 if (o->op_type == 0)
217 return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
7ccc7d88 218
9fc9ab86 219 if (o->op_type == OP_SASSIGN)
220 return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPc_UNOP : OPc_BINOP);
7ccc7d88 221
9fc9ab86 222 #ifdef USE_ITHREADS
223 if (o->op_type == OP_GV || o->op_type == OP_GVSV || o->op_type == OP_AELEMFAST)
224 return OPc_PADOP;
225 #endif
7ccc7d88 226
9fc9ab86 227 if ((o->op_type == OP_TRANS)) {
228 return OPc_BASEOP;
229 }
7ccc7d88 230
9fc9ab86 231 switch (PL_opargs[o->op_type] & OA_CLASS_MASK) {
232 case OA_BASEOP: TAG;
233 return OPc_BASEOP;
234
235 case OA_UNOP: TAG;
236 return OPc_UNOP;
237
238 case OA_BINOP: TAG;
239 return OPc_BINOP;
62691e7c 240
9fc9ab86 241 case OA_LOGOP: TAG;
242 return OPc_LOGOP;
7ccc7d88 243
9fc9ab86 244 case OA_LISTOP: TAG;
245 return OPc_LISTOP;
7ccc7d88 246
9fc9ab86 247 case OA_PMOP: TAG;
248 return OPc_PMOP;
7ccc7d88 249
9fc9ab86 250 case OA_SVOP: TAG;
251 return OPc_SVOP;
7ccc7d88 252
177ebd37 253#ifdef OA_PADOP
9fc9ab86 254 case OA_PADOP: TAG;
255 return OPc_PADOP;
177ebd37 256#endif
257
258#ifdef OA_GVOP
259 case OA_GVOP: TAG;
260 return OPc_GVOP;
261#endif
7ccc7d88 262
177ebd37 263#ifdef OA_PVOP_OR_SVOP
9fc9ab86 264 case OA_PVOP_OR_SVOP: TAG;
265 /*
266 * Character translations (tr///) are usually a PVOP, keeping a
267 * pointer to a table of shorts used to look up translations.
268 * Under utf8, however, a simple table isn't practical; instead,
269 * the OP is an SVOP, and the SV is a reference to a swash
270 * (i.e., an RV pointing to an HV).
271 */
272 return (o->op_private & (OPpTRANS_TO_UTF|OPpTRANS_FROM_UTF))
273 ? OPc_SVOP : OPc_PVOP;
177ebd37 274#endif
7ccc7d88 275
9fc9ab86 276 case OA_LOOP: TAG;
277 return OPc_LOOP;
7ccc7d88 278
9fc9ab86 279 case OA_COP: TAG;
280 return OPc_COP;
7ccc7d88 281
9fc9ab86 282 case OA_BASEOP_OR_UNOP: TAG;
7ccc7d88 283 /*
9fc9ab86 284 * UNI(OP_foo) in toke.c returns token UNI or FUNC1 depending on
285 * whether parens were seen. perly.y uses OPf_SPECIAL to
286 * signal whether a BASEOP had empty parens or none.
287 * Some other UNOPs are created later, though, so the best
288 * test is OPf_KIDS, which is set in newUNOP.
7ccc7d88 289 */
9fc9ab86 290 return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
291
292 case OA_FILESTATOP: TAG;
293 /*
294 * The file stat OPs are created via UNI(OP_foo) in toke.c but use
295 * the OPf_REF flag to distinguish between OP types instead of the
296 * usual OPf_SPECIAL flag. As usual, if OPf_KIDS is set, then we
297 * return OPc_UNOP so that walkoptree can find our children. If
298 * OPf_KIDS is not set then we check OPf_REF. Without OPf_REF set
299 * (no argument to the operator) it's an OP; with OPf_REF set it's
300 * an SVOP (and op_sv is the GV for the filehandle argument).
301 */
302 return ((o->op_flags & OPf_KIDS) ? OPc_UNOP :
303 #ifdef USE_ITHREADS
304 (o->op_flags & OPf_REF) ? OPc_PADOP : OPc_BASEOP);
305 #else
306 (o->op_flags & OPf_REF) ? OPc_SVOP : OPc_BASEOP);
307 #endif
308 case OA_LOOPEXOP: TAG;
309 /*
310 * next, last, redo, dump and goto use OPf_SPECIAL to indicate that a
311 * label was omitted (in which case it's a BASEOP) or else a term was
312 * seen. In this last case, all except goto are definitely PVOP but
313 * goto is either a PVOP (with an ordinary constant label), an UNOP
314 * with OPf_STACKED (with a non-constant non-sub) or an UNOP for
315 * OP_REFGEN (with goto &sub) in which case OPf_STACKED also seems to
316 * get set.
317 */
318 if (o->op_flags & OPf_STACKED)
319 return OPc_UNOP;
320 else if (o->op_flags & OPf_SPECIAL)
321 return OPc_BASEOP;
322 else
323 return OPc_PVOP;
177ebd37 324
325#ifdef OA_CONDOP
326 case OA_CONDOP: TAG;
327 return OPc_CONDOP;
328#endif
9fc9ab86 329 }
330 warn("Devel::Size: Can't determine class of operator %s, assuming BASEOP\n",
331 PL_op_name[o->op_type]);
332 }
1a36ac09 333 CAUGHT_EXCEPTION { }
7ccc7d88 334 return OPc_BASEOP;
335}
336
6a9ad7ec 337/* Figure out how much magic is attached to the SV and return the
338 size */
eee00145 339static void
b7130948 340magic_size(pTHX_ const SV * const thing, struct state *st) {
980c6576 341 MAGIC *magic_pointer = SvMAGIC(thing);
6a9ad7ec 342
980c6576 343 /* Have we seen the magic pointer? (NULL has always been seen before) */
e5c69bdd 344 while (check_new(st, magic_pointer)) {
eee00145 345 st->total_size += sizeof(MAGIC);
9847261d 346 /* magic vtables aren't freed when magic is freed, so don't count them.
347 (They are static structures. Anything that assumes otherwise is buggy.)
348 */
349
6a9ad7ec 350
1a36ac09 351 TRY_TO_CATCH_SEGV {
b7130948 352 sv_size(aTHX_ st, magic_pointer->mg_obj, TOTAL_SIZE_RECURSION);
d1888d0b 353 if (magic_pointer->mg_len == HEf_SVKEY) {
354 sv_size(aTHX_ st, (SV *)magic_pointer->mg_ptr, TOTAL_SIZE_RECURSION);
355 }
356#if defined(PERL_MAGIC_utf8) && defined (PERL_MAGIC_UTF8_CACHESIZE)
357 else if (magic_pointer->mg_type == PERL_MAGIC_utf8) {
358 if (check_new(st, magic_pointer->mg_ptr)) {
359 st->total_size += PERL_MAGIC_UTF8_CACHESIZE * 2 * sizeof(STRLEN);
360 }
361 }
362#endif
363 else if (magic_pointer->mg_len > 0) {
364 if (check_new(st, magic_pointer->mg_ptr)) {
365 st->total_size += magic_pointer->mg_len;
366 }
367 }
6a9ad7ec 368
0964064b 369 /* Get the next in the chain */
9fc9ab86 370 magic_pointer = magic_pointer->mg_moremagic;
371 }
1a36ac09 372 CAUGHT_EXCEPTION {
a4efdff3 373 if (st->dangle_whine)
9fc9ab86 374 warn( "Devel::Size: Encountered bad magic at: %p\n", magic_pointer );
375 }
6a9ad7ec 376 }
6a9ad7ec 377}
378
eee00145 379static void
99684fd4 380check_new_and_strlen(struct state *st, const char *const p) {
381 if(check_new(st, p))
6ec51ae0 382 st->total_size += 1 + strlen(p);
99684fd4 383}
384
385static void
eee00145 386regex_size(const REGEXP * const baseregex, struct state *st) {
c1bfd7da 387 if(!check_new(st, baseregex))
388 return;
eee00145 389 st->total_size += sizeof(REGEXP);
9fc9ab86 390#if (PERL_VERSION < 11)
6ea94d90 391 /* Note the size of the paren offset thing */
eee00145 392 st->total_size += sizeof(I32) * baseregex->nparens * 2;
393 st->total_size += strlen(baseregex->precomp);
6ea94d90 394#else
eee00145 395 st->total_size += sizeof(struct regexp);
396 st->total_size += sizeof(I32) * SvANY(baseregex)->nparens * 2;
397 /*st->total_size += strlen(SvANY(baseregex)->subbeg);*/
6ea94d90 398#endif
a4efdff3 399 if (st->go_yell && !st->regex_whine) {
6ea94d90 400 carp("Devel::Size: Calculated sizes for compiled regexes are incompatible, and probably always will be");
a4efdff3 401 st->regex_whine = 1;
98ecbbc6 402 }
7ccc7d88 403}
404
eee00145 405static void
1e5a8ad2 406op_size(pTHX_ const OP * const baseop, struct state *st)
407{
408 TRY_TO_CATCH_SEGV {
409 TAG;
410 if(!check_new(st, baseop))
411 return;
412 TAG;
413 op_size(aTHX_ baseop->op_next, st);
414 TAG;
415 switch (cc_opclass(baseop)) {
416 case OPc_BASEOP: TAG;
417 st->total_size += sizeof(struct op);
418 TAG;break;
419 case OPc_UNOP: TAG;
420 st->total_size += sizeof(struct unop);
a0a834e7 421 op_size(aTHX_ ((UNOP *)baseop)->op_first, st);
1e5a8ad2 422 TAG;break;
423 case OPc_BINOP: TAG;
424 st->total_size += sizeof(struct binop);
a0a834e7 425 op_size(aTHX_ ((BINOP *)baseop)->op_first, st);
426 op_size(aTHX_ ((BINOP *)baseop)->op_last, st);
1e5a8ad2 427 TAG;break;
428 case OPc_LOGOP: TAG;
429 st->total_size += sizeof(struct logop);
a0a834e7 430 op_size(aTHX_ ((BINOP *)baseop)->op_first, st);
431 op_size(aTHX_ ((LOGOP *)baseop)->op_other, st);
1e5a8ad2 432 TAG;break;
177ebd37 433#ifdef OA_CONDOP
434 case OPc_CONDOP: TAG;
435 st->total_size += sizeof(struct condop);
436 op_size(aTHX_ ((BINOP *)baseop)->op_first, st);
437 op_size(aTHX_ ((CONDOP *)baseop)->op_true, st);
438 op_size(aTHX_ ((CONDOP *)baseop)->op_false, st);
439 TAG;break;
440#endif
1e5a8ad2 441 case OPc_LISTOP: TAG;
442 st->total_size += sizeof(struct listop);
a0a834e7 443 op_size(aTHX_ ((LISTOP *)baseop)->op_first, st);
444 op_size(aTHX_ ((LISTOP *)baseop)->op_last, st);
1e5a8ad2 445 TAG;break;
446 case OPc_PMOP: TAG;
447 st->total_size += sizeof(struct pmop);
a0a834e7 448 op_size(aTHX_ ((PMOP *)baseop)->op_first, st);
449 op_size(aTHX_ ((PMOP *)baseop)->op_last, st);
5a83b7cf 450#if PERL_VERSION < 9 || (PERL_VERSION == 9 && PERL_SUBVERSION < 5)
a0a834e7 451 op_size(aTHX_ ((PMOP *)baseop)->op_pmreplroot, st);
452 op_size(aTHX_ ((PMOP *)baseop)->op_pmreplstart, st);
5a83b7cf 453#endif
c1bfd7da 454 /* This is defined away in perl 5.8.x, but it is in there for
455 5.6.x */
98ecbbc6 456#ifdef PM_GETRE
a0a834e7 457 regex_size(PM_GETRE((PMOP *)baseop), st);
98ecbbc6 458#else
a0a834e7 459 regex_size(((PMOP *)baseop)->op_pmregexp, st);
98ecbbc6 460#endif
c1bfd7da 461 TAG;break;
81f1c018 462 case OPc_SVOP: TAG;
463 st->total_size += sizeof(struct pmop);
574d9fd9 464 if (!(baseop->op_type == OP_AELEMFAST
465 && baseop->op_flags & OPf_SPECIAL)) {
466 /* not an OP_PADAV replacement */
a0a834e7 467 sv_size(aTHX_ st, ((SVOP *)baseop)->op_sv, SOME_RECURSION);
574d9fd9 468 }
81f1c018 469 TAG;break;
177ebd37 470#ifdef OA_PADOP
9fc9ab86 471 case OPc_PADOP: TAG;
eee00145 472 st->total_size += sizeof(struct padop);
99684fd4 473 TAG;break;
177ebd37 474#endif
475#ifdef OA_GVOP
476 case OPc_GVOP: TAG;
477 st->total_size += sizeof(struct gvop);
478 sv_size(aTHX_ st, ((GVOP *)baseop)->op_gv, SOME_RECURSION);
479 TAG;break;
480#endif
99684fd4 481 case OPc_PVOP: TAG;
a0a834e7 482 check_new_and_strlen(st, ((PVOP *)baseop)->op_pv);
219b7d34 483 TAG;break;
1e5a8ad2 484 case OPc_LOOP: TAG;
485 st->total_size += sizeof(struct loop);
a0a834e7 486 op_size(aTHX_ ((LOOP *)baseop)->op_first, st);
487 op_size(aTHX_ ((LOOP *)baseop)->op_last, st);
488 op_size(aTHX_ ((LOOP *)baseop)->op_redoop, st);
489 op_size(aTHX_ ((LOOP *)baseop)->op_nextop, st);
490 op_size(aTHX_ ((LOOP *)baseop)->op_lastop, st);
1e5a8ad2 491 TAG;break;
492 case OPc_COP: TAG;
9fc9ab86 493 {
494 COP *basecop;
495 basecop = (COP *)baseop;
eee00145 496 st->total_size += sizeof(struct cop);
9fc9ab86 497
498 /* Change 33656 by nicholas@mouse-mill on 2008/04/07 11:29:51
499 Eliminate cop_label from struct cop by storing a label as the first
500 entry in the hints hash. Most statements don't have labels, so this
501 will save memory. Not sure how much.
502 The check below will be incorrect fail on bleadperls
503 before 5.11 @33656, but later than 5.10, producing slightly too
504 small memory sizes on these Perls. */
b7621729 505#if (PERL_VERSION < 11)
99684fd4 506 check_new_and_strlen(st, basecop->cop_label);
b7621729 507#endif
7ccc7d88 508#ifdef USE_ITHREADS
99684fd4 509 check_new_and_strlen(st, basecop->cop_file);
510 check_new_and_strlen(st, basecop->cop_stashpv);
7ccc7d88 511#else
f3cf7e20 512 sv_size(aTHX_ st, (SV *)basecop->cop_stash, SOME_RECURSION);
513 sv_size(aTHX_ st, (SV *)basecop->cop_filegv, SOME_RECURSION);
7ccc7d88 514#endif
515
9fc9ab86 516 }
517 TAG;break;
518 default:
519 TAG;break;
520 }
521 }
1a36ac09 522 CAUGHT_EXCEPTION {
a4efdff3 523 if (st->dangle_whine)
9fc9ab86 524 warn( "Devel::Size: Encountered dangling pointer in opcode at: %p\n", baseop );
7ccc7d88 525 }
7ccc7d88 526}
6a9ad7ec 527
b6558d1d 528#if PERL_VERSION < 8 || PERL_SUBVERSION < 9
529# define SVt_LAST 16
24d37977 530#endif
531
f73dcfce 532#ifdef PURIFY
533# define MAYBE_PURIFY(normal, pure) (pure)
534# define MAYBE_OFFSET(struct_name, member) 0
535#else
536# define MAYBE_PURIFY(normal, pure) (normal)
537# define MAYBE_OFFSET(struct_name, member) STRUCT_OFFSET(struct_name, member)
538#endif
539
b6558d1d 540const U8 body_sizes[SVt_LAST] = {
541#if PERL_VERSION < 9
f73dcfce 542 0, /* SVt_NULL */
543 MAYBE_PURIFY(sizeof(IV), sizeof(XPVIV)), /* SVt_IV */
544 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
545 sizeof(XRV), /* SVt_RV */
546 sizeof(XPV), /* SVt_PV */
547 sizeof(XPVIV), /* SVt_PVIV */
548 sizeof(XPVNV), /* SVt_PVNV */
549 sizeof(XPVMG), /* SVt_PVMG */
550 sizeof(XPVBM), /* SVt_PVBM */
551 sizeof(XPVLV), /* SVt_PVLV */
552 sizeof(XPVAV), /* SVt_PVAV */
553 sizeof(XPVHV), /* SVt_PVHV */
554 sizeof(XPVCV), /* SVt_PVCV */
555 sizeof(XPVGV), /* SVt_PVGV */
556 sizeof(XPVFM), /* SVt_PVFM */
557 sizeof(XPVIO) /* SVt_PVIO */
b6558d1d 558#elif PERL_VERSION == 10 && PERL_SUBVERSION == 0
f73dcfce 559 0, /* SVt_NULL */
560 0, /* SVt_BIND */
561 0, /* SVt_IV */
562 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
563 0, /* SVt_RV */
564 MAYBE_PURIFY(sizeof(xpv_allocated), sizeof(XPV)), /* SVt_PV */
565 MAYBE_PURIFY(sizeof(xpviv_allocated), sizeof(XPVIV)),/* SVt_PVIV */
566 sizeof(XPVNV), /* SVt_PVNV */
567 sizeof(XPVMG), /* SVt_PVMG */
568 sizeof(XPVGV), /* SVt_PVGV */
569 sizeof(XPVLV), /* SVt_PVLV */
570 MAYBE_PURIFY(sizeof(xpvav_allocated), sizeof(XPVAV)),/* SVt_PVAV */
571 MAYBE_PURIFY(sizeof(xpvhv_allocated), sizeof(XPVHV)),/* SVt_PVHV */
572 MAYBE_PURIFY(sizeof(xpvcv_allocated), sizeof(XPVCV)),/* SVt_PVCV */
573 MAYBE_PURIFY(sizeof(xpvfm_allocated), sizeof(XPVFM)),/* SVt_PVFM */
574 sizeof(XPVIO), /* SVt_PVIO */
b6558d1d 575#elif PERL_VERSION == 10 && PERL_SUBVERSION == 1
f73dcfce 576 0, /* SVt_NULL */
577 0, /* SVt_BIND */
578 0, /* SVt_IV */
579 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
580 0, /* SVt_RV */
581 sizeof(XPV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PV */
582 sizeof(XPVIV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PVIV */
583 sizeof(XPVNV), /* SVt_PVNV */
584 sizeof(XPVMG), /* SVt_PVMG */
585 sizeof(XPVGV), /* SVt_PVGV */
586 sizeof(XPVLV), /* SVt_PVLV */
587 sizeof(XPVAV) - MAYBE_OFFSET(XPVAV, xav_fill), /* SVt_PVAV */
588 sizeof(XPVHV) - MAYBE_OFFSET(XPVHV, xhv_fill), /* SVt_PVHV */
589 sizeof(XPVCV) - MAYBE_OFFSET(XPVCV, xpv_cur), /* SVt_PVCV */
590 sizeof(XPVFM) - MAYBE_OFFSET(XPVFM, xpv_cur), /* SVt_PVFM */
591 sizeof(XPVIO) /* SVt_PVIO */
b6558d1d 592#elif PERL_VERSION < 13
f73dcfce 593 0, /* SVt_NULL */
594 0, /* SVt_BIND */
595 0, /* SVt_IV */
596 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
597 sizeof(XPV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PV */
598 sizeof(XPVIV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PVIV */
599 sizeof(XPVNV), /* SVt_PVNV */
600 sizeof(XPVMG), /* SVt_PVMG */
601 sizeof(regexp) - MAYBE_OFFSET(regexp, xpv_cur), /* SVt_REGEXP */
602 sizeof(XPVGV), /* SVt_PVGV */
603 sizeof(XPVLV), /* SVt_PVLV */
604 sizeof(XPVAV) - MAYBE_OFFSET(XPVAV, xav_fill), /* SVt_PVAV */
605 sizeof(XPVHV) - MAYBE_OFFSET(XPVHV, xhv_fill), /* SVt_PVHV */
606 sizeof(XPVCV) - MAYBE_OFFSET(XPVCV, xpv_cur), /* SVt_PVCV */
607 sizeof(XPVFM) - MAYBE_OFFSET(XPVFM, xpv_cur), /* SVt_PVFM */
608 sizeof(XPVIO) /* SVt_PVIO */
b6558d1d 609#else
f73dcfce 610 0, /* SVt_NULL */
611 0, /* SVt_BIND */
612 0, /* SVt_IV */
613 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
614 sizeof(XPV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PV */
615 sizeof(XPVIV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PVIV */
616 sizeof(XPVNV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PVNV */
617 sizeof(XPVMG), /* SVt_PVMG */
618 sizeof(regexp), /* SVt_REGEXP */
619 sizeof(XPVGV), /* SVt_PVGV */
620 sizeof(XPVLV), /* SVt_PVLV */
621 sizeof(XPVAV), /* SVt_PVAV */
622 sizeof(XPVHV), /* SVt_PVHV */
623 sizeof(XPVCV), /* SVt_PVCV */
624 sizeof(XPVFM), /* SVt_PVFM */
625 sizeof(XPVIO) /* SVt_PVIO */
b6558d1d 626#endif
627};
628
a5c6bdd7 629static void
db519f11 630sv_size(pTHX_ struct state *const st, const SV * const orig_thing,
f3cf7e20 631 const int recurse) {
9fc9ab86 632 const SV *thing = orig_thing;
b6558d1d 633 U32 type;
eee00145 634
81f1c018 635 if(!check_new(st, thing))
a5c6bdd7 636 return;
81f1c018 637
b6558d1d 638 type = SvTYPE(thing);
639 if (type > SVt_LAST) {
640 warn("Devel::Size: Unknown variable type: %d encountered\n", type);
a5c6bdd7 641 return;
b6558d1d 642 }
643 st->total_size += sizeof(SV) + body_sizes[type];
b1e5ad85 644
b6558d1d 645 if (type >= SVt_PVMG) {
696b99e2 646 magic_size(aTHX_ thing, st);
647 }
648
b6558d1d 649 switch (type) {
650#if (PERL_VERSION < 11)
e98cedbf 651 /* Is it a reference? */
9fc9ab86 652 case SVt_RV: TAG;
b6558d1d 653#else
654 case SVt_IV: TAG;
24d37977 655#endif
81f1c018 656 if(recurse && SvROK(thing))
f3cf7e20 657 sv_size(aTHX_ st, SvRV_const(thing), recurse);
9fc9ab86 658 TAG;break;
267703fd 659
9fc9ab86 660 case SVt_PVAV: TAG;
e98cedbf 661 /* Is there anything in the array? */
662 if (AvMAX(thing) != -1) {
c8db37d3 663 /* an array with 10 slots has AvMax() set to 9 - te 2007-04-22 */
eee00145 664 st->total_size += sizeof(SV *) * (AvMAX(thing) + 1);
665 dbg_printf(("total_size: %li AvMAX: %li av_len: $i\n", st->total_size, AvMAX(thing), av_len((AV*)thing)));
6c5ddc0d 666
667 if (recurse >= TOTAL_SIZE_RECURSION) {
668 SSize_t i = AvFILLp(thing) + 1;
669
670 while (i--)
671 sv_size(aTHX_ st, AvARRAY(thing)[i], recurse);
672 }
e98cedbf 673 }
674 /* Add in the bits on the other side of the beginning */
0430b7f7 675
b7621729 676 dbg_printf(("total_size %li, sizeof(SV *) %li, AvARRAY(thing) %li, AvALLOC(thing)%li , sizeof(ptr) %li \n",
eee00145 677 st->total_size, sizeof(SV*), AvARRAY(thing), AvALLOC(thing), sizeof( thing )));
0430b7f7 678
679 /* under Perl 5.8.8 64bit threading, AvARRAY(thing) was a pointer while AvALLOC was 0,
b1e5ad85 680 resulting in grossly overstated sized for arrays. Technically, this shouldn't happen... */
0430b7f7 681 if (AvALLOC(thing) != 0) {
eee00145 682 st->total_size += (sizeof(SV *) * (AvARRAY(thing) - AvALLOC(thing)));
0430b7f7 683 }
795fc84c 684#if (PERL_VERSION < 9)
685 /* Is there something hanging off the arylen element?
686 Post 5.9.something this is stored in magic, so will be found there,
687 and Perl_av_arylen_p() takes a non-const AV*, hence compilers rightly
688 complain about AvARYLEN() passing thing to it. */
f3cf7e20 689 sv_size(aTHX_ st, AvARYLEN(thing), recurse);
795fc84c 690#endif
9fc9ab86 691 TAG;break;
692 case SVt_PVHV: TAG;
a6ea0805 693 /* Now the array of buckets */
eee00145 694 st->total_size += (sizeof(HE *) * (HvMAX(thing) + 1));
a6ea0805 695 /* Now walk the bucket chain */
6a9ad7ec 696 if (HvARRAY(thing)) {
a6ea0805 697 HE *cur_entry;
9fc9ab86 698 UV cur_bucket = 0;
a6ea0805 699 for (cur_bucket = 0; cur_bucket <= HvMAX(thing); cur_bucket++) {
9fc9ab86 700 cur_entry = *(HvARRAY(thing) + cur_bucket);
701 while (cur_entry) {
eee00145 702 st->total_size += sizeof(HE);
9fc9ab86 703 if (cur_entry->hent_hek) {
704 /* Hash keys can be shared. Have we seen this before? */
a4efdff3 705 if (check_new(st, cur_entry->hent_hek)) {
eee00145 706 st->total_size += HEK_BASESIZE + cur_entry->hent_hek->hek_len + 2;
9fc9ab86 707 }
708 }
f3cf7e20 709 if (recurse >= TOTAL_SIZE_RECURSION)
710 sv_size(aTHX_ st, HeVAL(cur_entry), recurse);
9fc9ab86 711 cur_entry = cur_entry->hent_next;
712 }
a6ea0805 713 }
714 }
9fc9ab86 715 TAG;break;
267703fd 716
717
718 case SVt_PVFM: TAG;
267703fd 719 sv_size(aTHX_ st, (SV *)CvPADLIST(thing), SOME_RECURSION);
720 sv_size(aTHX_ st, (SV *)CvOUTSIDE(thing), recurse);
721
722 if (st->go_yell && !st->fm_whine) {
723 carp("Devel::Size: Calculated sizes for FMs are incomplete");
724 st->fm_whine = 1;
725 }
726 goto freescalar;
727
9fc9ab86 728 case SVt_PVCV: TAG;
f3cf7e20 729 sv_size(aTHX_ st, (SV *)CvSTASH(thing), SOME_RECURSION);
730 sv_size(aTHX_ st, (SV *)SvSTASH(thing), SOME_RECURSION);
731 sv_size(aTHX_ st, (SV *)CvGV(thing), SOME_RECURSION);
6c5ddc0d 732 sv_size(aTHX_ st, (SV *)CvPADLIST(thing), SOME_RECURSION);
f3cf7e20 733 sv_size(aTHX_ st, (SV *)CvOUTSIDE(thing), recurse);
66f50dda 734 if (CvISXSUB(thing)) {
f3cf7e20 735 sv_size(aTHX_ st, cv_const_sv((CV *)thing), recurse);
66f50dda 736 } else {
1e5a8ad2 737 op_size(aTHX_ CvSTART(thing), st);
738 op_size(aTHX_ CvROOT(thing), st);
7ccc7d88 739 }
267703fd 740 goto freescalar;
741
742 case SVt_PVIO: TAG;
267703fd 743 /* Some embedded char pointers */
744 check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_top_name);
745 check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_fmt_name);
746 check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_bottom_name);
747 /* Throw the GVs on the list to be walked if they're not-null */
748 sv_size(aTHX_ st, (SV *)((XPVIO *) SvANY(thing))->xio_top_gv, recurse);
749 sv_size(aTHX_ st, (SV *)((XPVIO *) SvANY(thing))->xio_bottom_gv, recurse);
750 sv_size(aTHX_ st, (SV *)((XPVIO *) SvANY(thing))->xio_fmt_gv, recurse);
751
752 /* Only go trotting through the IO structures if they're really
753 trottable. If USE_PERLIO is defined we can do this. If
754 not... we can't, so we don't even try */
755#ifdef USE_PERLIO
756 /* Dig into xio_ifp and xio_ofp here */
757 warn("Devel::Size: Can't size up perlio layers yet\n");
758#endif
759 goto freescalar;
760
267703fd 761 case SVt_PVLV: TAG;
267703fd 762#if (PERL_VERSION < 9)
763 goto freescalar;
267703fd 764#endif
7ccc7d88 765
9fc9ab86 766 case SVt_PVGV: TAG;
4a3d023d 767 if(isGV_with_GP(thing)) {
768 st->total_size += GvNAMELEN(thing);
78dfb4e7 769#ifdef GvFILE
2b217e71 770# if !defined(USE_ITHREADS) || (PERL_VERSION > 8 || (PERL_VERSION == 8 && PERL_SUBVERSION > 8))
771 /* With itreads, before 5.8.9, this can end up pointing to freed memory
772 if the GV was created in an eval, as GvFILE() points to CopFILE(),
773 and the relevant COP has been freed on scope cleanup after the eval.
774 5.8.9 adds a binary compatible fudge that catches the vast majority
775 of cases. 5.9.something added a proper fix, by converting the GP to
776 use a shared hash key (porperly reference counted), instead of a
777 char * (owned by who knows? possibly no-one now) */
4a3d023d 778 check_new_and_strlen(st, GvFILE(thing));
2b217e71 779# endif
78dfb4e7 780#endif
4a3d023d 781 /* Is there something hanging off the glob? */
782 if (check_new(st, GvGP(thing))) {
783 st->total_size += sizeof(GP);
f3cf7e20 784 sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_sv), recurse);
785 sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_form), recurse);
786 sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_av), recurse);
787 sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_hv), recurse);
788 sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_egv), recurse);
789 sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_cv), recurse);
4a3d023d 790 }
267703fd 791#if (PERL_VERSION >= 9)
792 TAG; break;
793#endif
5c2e1b12 794 }
b6558d1d 795#if PERL_VERSION <= 8
796 case SVt_PVBM: TAG;
797#endif
267703fd 798 case SVt_PVMG: TAG;
267703fd 799 case SVt_PVNV: TAG;
267703fd 800 case SVt_PVIV: TAG;
267703fd 801 case SVt_PV: TAG;
267703fd 802 freescalar:
803 if(recurse && SvROK(thing))
804 sv_size(aTHX_ st, SvRV_const(thing), recurse);
805 else
806 st->total_size += SvLEN(thing);
807
808 if(SvOOK(thing)) {
95dc1714 809 STRLEN len;
810 SvOOK_offset(thing, len);
811 st->total_size += len;
ebb2c5b9 812 }
9fc9ab86 813 TAG;break;
5073b933 814
e98cedbf 815 }
a5c6bdd7 816 return;
e98cedbf 817}
818
a4efdff3 819static struct state *
820new_state(pTHX)
65db36c0 821{
822 SV *warn_flag;
a4efdff3 823 struct state *st;
d9b022a1 824
a4efdff3 825 Newxz(st, 1, struct state);
826 st->go_yell = TRUE;
65db36c0 827 if (NULL != (warn_flag = perl_get_sv("Devel::Size::warn", FALSE))) {
a4efdff3 828 st->dangle_whine = st->go_yell = SvIV(warn_flag) ? TRUE : FALSE;
65db36c0 829 }
830 if (NULL != (warn_flag = perl_get_sv("Devel::Size::dangle", FALSE))) {
a4efdff3 831 st->dangle_whine = SvIV(warn_flag) ? TRUE : FALSE;
65db36c0 832 }
a52ceccd 833 check_new(st, &PL_sv_undef);
834 check_new(st, &PL_sv_no);
835 check_new(st, &PL_sv_yes);
6389ea67 836#if PERL_VERSION > 8 || (PERL_VERSION == 8 && PERL_SUBVERSION > 0)
837 check_new(st, &PL_sv_placeholder);
838#endif
a4efdff3 839 return st;
65db36c0 840}
841
9fc9ab86 842MODULE = Devel::Size PACKAGE = Devel::Size
e98cedbf 843
fea63ffa 844PROTOTYPES: DISABLE
845
eee00145 846UV
a6ea0805 847size(orig_thing)
848 SV *orig_thing
13683e3a 849ALIAS:
850 total_size = TOTAL_SIZE_RECURSION
e98cedbf 851CODE:
852{
6a9ad7ec 853 SV *thing = orig_thing;
a4efdff3 854 struct state *st = new_state(aTHX);
ebb2c5b9 855
6a9ad7ec 856 /* If they passed us a reference then dereference it. This is the
857 only way we can check the sizes of arrays and hashes */
b7621729 858 if (SvROK(thing)) {
859 thing = SvRV(thing);
860 }
b7621729 861
13683e3a 862 sv_size(aTHX_ st, thing, ix);
eee00145 863 RETVAL = st->total_size;
a4efdff3 864 free_state(st);
6a9ad7ec 865}
866OUTPUT:
867 RETVAL
Unnamed repository; edit this file 'description' to name the repository.