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