/* TODO
*
* Refactor this to split out D:M code from Devel::Size code.
- *
* Start migrating Devel::Size's Size.xs towards the new code.
*
- * ADD_PRE_ATTR for index should check if the ptr is new first. Currently we're
- * generating lots of ADD_PRE_ATTR's for SVs that we've already seen via other paths.
- * That's wasteful and likely to cause subtle bugs.
- *
- * Give HE's their own node so keys and values can be tied together
- *
*/
#undef NDEBUG /* XXX */
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
+
+#define DPPP_PL_parser_NO_DUMMY
+#define NEED_PL_parser
#include "ppport.h"
#include "refcounted_he.h"
# define SvSHARED_HEK_FROM_PV(pvx) \
((struct hek*)(pvx - STRUCT_OFFSET(struct hek, hek_key)))
#endif
+#ifndef MUTABLE_AV
+#define MUTABLE_AV(p) ((AV*)p)
+#endif
+#ifndef MUTABLE_SV
+#define MUTABLE_SV(p) ((SV*)p)
+#endif
#if PERL_VERSION < 6
# define PL_opargs opargs
#define NPtype_MAGIC 0x04
#define NPtype_OP 0x05
-/* XXX these should probably be generalizes into flag bits */
+/* XXX these should probably be generalized into flag bits */
#define NPattr_LEAFSIZE 0x00
#define NPattr_NAME 0x01
#define NPattr_PADFAKE 0x02
#define NPattr_PADNAME 0x03
#define NPattr_PADTMP 0x04
#define NPattr_NOTE 0x05
-#define NPattr_PRE_ATTR 0x06 /* deprecated */
#define _ADD_ATTR_NP(st, attr_type, attr_name, attr_value, np) \
STMT_START { \
} \
} STMT_END
-#define ADD_ATTR(st, attr_type, attr_name, attr_value) _ADD_ATTR_NP(st, attr_type, attr_name, attr_value, NP-1)
+#define ADD_ATTR(st, attr_type, attr_name, attr_value) \
+ _ADD_ATTR_NP(st, attr_type, attr_name, attr_value, NP-1)
+
#define ADD_LINK_ATTR(st, attr_type, attr_name, attr_value) \
STMT_START { \
- assert(NP->seqn); \
+ if (st->add_attr_cb) assert(NP->seqn); \
_ADD_ATTR_NP(st, attr_type, attr_name, attr_value, NP); \
} STMT_END;
-#define ADD_PRE_ATTR(st, attr_type, attr_name, attr_value) \
- STMT_START { \
- assert(!attr_type); \
- _ADD_ATTR_NP(st, NPattr_PRE_ATTR, attr_name, attr_value, NP-1); \
- } STMT_END;
#define _NPathLink(np, nid, ntype) (((np)->id=nid), ((np)->type=ntype), ((np)->seqn=0))
#define NPathLink(nid) (_NPathLink(NP, nid, NPtype_LINK), NP)
}
}
-static void
+static int
hek_size(pTHX_ struct state *st, HEK *hek, U32 shared, pPATH)
{
dNPathNodes(1, NPathArg);
/* Hash keys can be shared. Have we seen this before? */
if (!check_new(st, hek))
- return;
+ return 0;
NPathPushNode("hek", NPtype_NAME);
ADD_SIZE(st, "hek_len", HEK_BASESIZE + hek->hek_len
#if PERL_VERSION < 8
ADD_SIZE(st, "shared_he", STRUCT_OFFSET(struct shared_he, shared_he_hek));
#endif
}
+ return 1;
}
+#if (PERL_BCDVERSION >= 0x5009004)
static void
refcounted_he_size(pTHX_ struct state *st, struct refcounted_he *he, pPATH)
{
if (he->refcounted_he_next)
refcounted_he_size(aTHX_ st, he->refcounted_he_next, NPathLink("refcounted_he_next"));
}
+#endif
static void op_size_class(pTHX_ const OP * const baseop, opclass op_class, bool skip_op_struct, struct state *st, pPATH);
case OPc_COP: TAG;
{
COP *basecop;
- COPHH *hh;
basecop = (COP *)baseop;
if (!skip_op_struct)
ADD_SIZE(st, "cop", sizeof(struct cop));
#endif
#ifdef USE_ITHREADS
check_new_and_strlen(st, basecop->cop_file, NPathLink("cop_file"));
- check_new_and_strlen(st, basecop->cop_stashpv, NPathLink("cop_stashpv"));
+ /*check_new_and_strlen(st, basecop->cop_stashpv, NPathLink("cop_stashpv")); XXX */
#else
if (SvREFCNT(basecop->cop_stash) == 1) /* XXX hack? */
sv_size(aTHX_ st, NPathLink("cop_stash"), (SV *)basecop->cop_stash, SOME_RECURSION);
sv_size(aTHX_ st, NPathLink("cop_filegv"), (SV *)basecop->cop_filegv, SOME_RECURSION);
#endif
- hh = CopHINTHASH_get(basecop);
- refcounted_he_size(aTHX_ st, hh, NPathLink("cop_hints_hash"));
+#if (PERL_BCDVERSION >= 0x5009004)
+# if (PERL_BCDVERSION < 0x5013007)
+# define COPHH struct refcounted_he
+# endif
+# ifndef CopHINTHASH_get
+# define CopHINTHASH_get(c) ((COPHH*)((c)->cop_hints_hash))
+# endif
+ refcounted_he_size(aTHX_ st, CopHINTHASH_get(basecop), NPathLink("cop_hints_hash"));
+#endif
}
TAG;break;
default:
type = SvTYPE(thing);
if (type > SVt_LAST) {
warn("Devel::Size: Unknown variable type: %d encountered\n", type);
- return 1;
+ return 0;
}
NPathPushNode(thing, NPtype_SV);
ADD_SIZE(st, "sv_head", sizeof(SV));
if (AvMAX(thing) != -1) {
/* an array with 10 slots has AvMax() set to 9 - te 2007-04-22 */
ADD_SIZE(st, "av_max", sizeof(SV *) * (AvMAX(thing) + 1));
+ ADD_ATTR(st, NPattr_NOTE, "av_len", av_len((AV*)thing));
dbg_printf(("total_size: %li AvMAX: %li av_len: $i\n", st->total_size, AvMAX(thing), av_len((AV*)thing)));
if (recurse >= st->min_recurse_threshold) {
case SVt_PVHV: TAG;
/* Now the array of buckets */
- if (HvENAME(thing)) {
- ADD_ATTR(st, NPattr_NAME, HvENAME(thing), 0);
- }
+#ifdef HvENAME
+ if (HvENAME(thing)) { ADD_ATTR(st, NPattr_NAME, HvENAME(thing), 0); }
+#else
+ if (HvNAME(thing)) { ADD_ATTR(st, NPattr_NAME, HvNAME(thing), 0); }
+#endif
ADD_SIZE(st, "hv_max", (sizeof(HE *) * (HvMAX(thing) + 1)));
/* Now walk the bucket chain */
if (HvARRAY(thing)) {
#ifdef GvFILE_HEK
hek_size(aTHX_ st, GvFILE_HEK(thing), 1, NPathLink("GvFILE_HEK"));
#elif defined(GvFILE)
-# if !defined(USE_ITHREADS) || (PERL_VERSION > 8 || (PERL_VERSION == 8 && PERL_SUBVERSION > 8))
+/* XXX this coredumped for me in t/recurse.t with a non-threaded 5.8.9
+ * so I've changed the condition to be more restricive
+ *# if !defined(USE_ITHREADS) || (PERL_VERSION > 8 || (PERL_VERSION == 8 && PERL_SUBVERSION > 8))
+ */
+# if (PERL_VERSION > 8 || (PERL_VERSION == 8 && PERL_SUBVERSION > 9))
/* With itreads, before 5.8.9, this can end up pointing to freed memory
if the GV was created in an eval, as GvFILE() points to CopFILE(),
and the relevant COP has been freed on scope cleanup after the eval.
if (type >= SVt_PVMG) {
if (SvMAGICAL(thing))
magic_size(aTHX_ thing, st, NPathLink("MG"));
- if (SvPAD_OUR(thing) && SvOURSTASH(thing))
+ /* SVpad_OUR shares same flag bit as SVpbm_VALID and others */
+ if (type == SVt_PVGV && SvPAD_OUR(thing) && SvOURSTASH(thing))
sv_size(aTHX_ st, NPathLink("SvOURSTASH"), (SV *)SvOURSTASH(thing), SOME_RECURSION);
if (SvSTASH(thing))
sv_size(aTHX_ st, NPathLink("SvSTASH"), (SV *)SvSTASH(thing), SOME_RECURSION);
Newxz(st, 1, struct state);
st->go_yell = TRUE;
st->min_recurse_threshold = TOTAL_SIZE_RECURSION;
- if (NULL != (warn_flag = perl_get_sv("Devel::Size::warn", FALSE))) {
+ if (NULL != (warn_flag = get_sv("Devel::Size::warn", FALSE))) {
st->dangle_whine = st->go_yell = SvIV(warn_flag) ? TRUE : FALSE;
}
- if (NULL != (warn_flag = perl_get_sv("Devel::Size::dangle", FALSE))) {
+ if (NULL != (warn_flag = get_sv("Devel::Size::dangle", FALSE))) {
st->dangle_whine = SvIV(warn_flag) ? TRUE : FALSE;
}
st->start_time_nv = gettimeofday_nv();
/* by this point we should have visited all the SVs
* so now we'll run through all the SVs via the arenas
- * in order to find any thet we've missed for some reason.
- * Once the rest of the code is finding all the SVs then any
+ * in order to find any that we've missed for some reason.
+ * Once the rest of the code is finding ALL the SVs then any
* found here will be leaks.
*/
for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) {
}
#endif
+#if (PERL_BCDVERSION >= 0x5009005)
static void
parser_size(pTHX_ struct state *const st, pPATH, yy_parser *parser)
{
NPathPushNode("stack", NPtype_NAME);
yy_stack_frame *ps;
- //warn("total: %u", parser->stack_size);
- //warn("foo: %u", parser->ps - parser->stack);
+ /*warn("total: %u", parser->stack_size); */
+ /*warn("foo: %u", parser->ps - parser->stack); */
ADD_SIZE(st, "stack_frames", parser->stack_size * sizeof(yy_stack_frame));
for (ps = parser->stack; ps <= parser->ps; ps++) {
- ADD_PRE_ATTR(st, 0, "frame", ps - parser->ps);
- sv_size(aTHX_ st, NPathLink("compcv"), (SV*)ps->compcv, TOTAL_SIZE_RECURSION);
+#if (PERL_BCDVERSION >= 0x5011001) /* roughly */
+ if (sv_size(aTHX_ st, NPathLink("compcv"), (SV*)ps->compcv, TOTAL_SIZE_RECURSION))
+ ADD_LINK_ATTR(st, NPattr_NOTE, "i", ps - parser->ps);
+#else /* prior to perl 8c63ea58 Dec 8 2009 */
+ if (sv_size(aTHX_ st, NPathLink("comppad"), (SV*)ps->comppad, TOTAL_SIZE_RECURSION))
+ ADD_LINK_ATTR(st, NPattr_NOTE, "i", ps - parser->ps);
+#endif
}
NPathPopNode;
sv_size(aTHX_ st, NPathLink("lex_stuff"), (SV*)parser->lex_stuff, TOTAL_SIZE_RECURSION);
sv_size(aTHX_ st, NPathLink("linestr"), (SV*)parser->linestr, TOTAL_SIZE_RECURSION);
sv_size(aTHX_ st, NPathLink("in_my_stash"), (SV*)parser->in_my_stash, TOTAL_SIZE_RECURSION);
- //sv_size(aTHX_ st, NPathLink("rsfp"), parser->rsfp, TOTAL_SIZE_RECURSION);
+ /*sv_size(aTHX_ st, NPathLink("rsfp"), parser->rsfp, TOTAL_SIZE_RECURSION); */
sv_size(aTHX_ st, NPathLink("rsfp_filters"), (SV*)parser->rsfp_filters, TOTAL_SIZE_RECURSION);
#ifdef PERL_MAD
sv_size(aTHX_ st, NPathLink("endwhite"), parser->endwhite, TOTAL_SIZE_RECURSION);
if (parser->old_parser)
parser_size(aTHX_ st, NPathLink("old_parser"), parser->old_parser);
}
+#endif
static void
perl_size(pTHX_ struct state *const st, pPATH)
sv_size(aTHX_ st, NPathLink("PL_errors"), (SV*)PL_errors, TOTAL_SIZE_RECURSION);
sv_size(aTHX_ st, NPathLink("PL_stashcache"), (SV*)PL_stashcache, TOTAL_SIZE_RECURSION);
sv_size(aTHX_ st, NPathLink("PL_patchlevel"), (SV*)PL_patchlevel, TOTAL_SIZE_RECURSION);
+#ifdef PL_apiversion
sv_size(aTHX_ st, NPathLink("PL_apiversion"), (SV*)PL_apiversion, TOTAL_SIZE_RECURSION);
+#endif
+#ifdef PL_registered_mros
sv_size(aTHX_ st, NPathLink("PL_registered_mros"), (SV*)PL_registered_mros, TOTAL_SIZE_RECURSION);
+#endif
#ifdef USE_ITHREADS
sv_size(aTHX_ st, NPathLink("PL_regex_padav"), (SV*)PL_regex_padav, TOTAL_SIZE_RECURSION);
#endif
sv_size(aTHX_ st, NPathLink("PL_hintgv"), (SV*)PL_hintgv, TOTAL_SIZE_RECURSION);
sv_size(aTHX_ st, NPathLink("PL_e_script"), (SV*)PL_e_script, TOTAL_SIZE_RECURSION);
sv_size(aTHX_ st, NPathLink("PL_encoding"), (SV*)PL_encoding, TOTAL_SIZE_RECURSION);
+#ifdef PL_ofsgv
sv_size(aTHX_ st, NPathLink("PL_ofsgv"), (SV*)PL_ofsgv, TOTAL_SIZE_RECURSION);
+#endif
sv_size(aTHX_ st, NPathLink("PL_argvout_stack"), (SV*)PL_argvout_stack, TOTAL_SIZE_RECURSION);
sv_size(aTHX_ st, NPathLink("PL_beginav"), (SV*)PL_beginav, TOTAL_SIZE_RECURSION);
sv_size(aTHX_ st, NPathLink("PL_beginav_save"), (SV*)PL_beginav_save, TOTAL_SIZE_RECURSION);
sv_size(aTHX_ st, NPathLink("PL_checkav_save"), (SV*)PL_checkav_save, TOTAL_SIZE_RECURSION);
+#ifdef PL_unitcheckav
sv_size(aTHX_ st, NPathLink("PL_unitcheckav"), (SV*)PL_unitcheckav, TOTAL_SIZE_RECURSION);
+#endif
+#ifdef PL_unitcheckav_save
sv_size(aTHX_ st, NPathLink("PL_unitcheckav_save"), (SV*)PL_unitcheckav_save, TOTAL_SIZE_RECURSION);
+#endif
sv_size(aTHX_ st, NPathLink("PL_endav"), (SV*)PL_endav, TOTAL_SIZE_RECURSION);
sv_size(aTHX_ st, NPathLink("PL_checkav"), (SV*)PL_checkav, TOTAL_SIZE_RECURSION);
sv_size(aTHX_ st, NPathLink("PL_initav"), (SV*)PL_initav, TOTAL_SIZE_RECURSION);
+#ifdef PL_isarev
sv_size(aTHX_ st, NPathLink("PL_isarev"), (SV*)PL_isarev, TOTAL_SIZE_RECURSION);
+#endif
sv_size(aTHX_ st, NPathLink("PL_fdpid"), (SV*)PL_fdpid, TOTAL_SIZE_RECURSION);
sv_size(aTHX_ st, NPathLink("PL_preambleav"), (SV*)PL_preambleav, TOTAL_SIZE_RECURSION);
sv_size(aTHX_ st, NPathLink("PL_ors_sv"), (SV*)PL_ors_sv, TOTAL_SIZE_RECURSION);
sv_size(aTHX_ st, NPathLink("PL_modglobal"), (SV*)PL_modglobal, TOTAL_SIZE_RECURSION);
sv_size(aTHX_ st, NPathLink("PL_custom_op_names"), (SV*)PL_custom_op_names, TOTAL_SIZE_RECURSION);
sv_size(aTHX_ st, NPathLink("PL_custom_op_descs"), (SV*)PL_custom_op_descs, TOTAL_SIZE_RECURSION);
+#ifdef PL_custom_ops
sv_size(aTHX_ st, NPathLink("PL_custom_ops"), (SV*)PL_custom_ops, TOTAL_SIZE_RECURSION);
+#endif
sv_size(aTHX_ st, NPathLink("PL_compcv"), (SV*)PL_compcv, TOTAL_SIZE_RECURSION);
sv_size(aTHX_ st, NPathLink("PL_DBcv"), (SV*)PL_DBcv, TOTAL_SIZE_RECURSION);
#ifdef PERL_USES_PL_PIDSTATUS
op_size_class(aTHX_ (OP*)&PL_compiling, OPc_COP, 1, st, NPathLink("PL_compiling"));
op_size_class(aTHX_ (OP*)PL_curcopdb, OPc_COP, 0, st, NPathLink("PL_curcopdb"));
+#if (PERL_BCDVERSION >= 0x5009005)
parser_size(aTHX_ st, NPathLink("PL_parser"), PL_parser);
+#endif
+
/* TODO stacks: cur, main, tmps, mark, scope, save */
/* TODO PL_exitlist */
/* TODO PL_reentrant_buffers etc */
projects / p5sagit/Devel-Size.git / blobdiff