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