summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--embed.fnc5
-rw-r--r--global.sym2
-rw-r--r--hv.c1
-rw-r--r--hv.h2
-rw-r--r--mro.c81
-rw-r--r--proto.h13
6 files changed, 90 insertions, 14 deletions
diff --git a/embed.fnc b/embed.fnc
index cc3cf79edb..bb43543ddd 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -2184,6 +2184,11 @@ XEMop |void |emulate_cop_io |NN const COP *const c|NN SV *const sv
: Used by SvRX and SvRXOK
XEMop |REGEXP *|get_re_arg|NULLOK SV *sv
+Aop |SV* |mro_get_private_data|NN struct mro_meta *const smeta \
+ |NN const struct mro_alg *const which
+Aop |SV* |mro_set_private_data|NN struct mro_meta *const smeta \
+ |NN const struct mro_alg *const which \
+ |NN SV *const data
: Used in HvMROMETA() in gv.c, pp_hot.c, universal.c
p |struct mro_meta* |mro_meta_init |NN HV* stash
#if defined(USE_ITHREADS)
diff --git a/global.sym b/global.sym
index fe26578fb3..af15270e35 100644
--- a/global.sym
+++ b/global.sym
@@ -769,6 +769,8 @@ Perl_my_strlcpy
Perl_signbit
Perl_emulate_cop_io
Perl_get_re_arg
+Perl_mro_get_private_data
+Perl_mro_set_private_data
Perl_mro_get_linear_isa
Perl_mro_method_changed_in
Perl_sys_init
diff --git a/hv.c b/hv.c
index adb5a4d777..d41b9788e1 100644
--- a/hv.c
+++ b/hv.c
@@ -1695,7 +1695,6 @@ S_hfreeentries(pTHX_ HV *hv)
if((meta = iter->xhv_mro_meta)) {
if(meta->mro_linear_dfs) SvREFCNT_dec(meta->mro_linear_dfs);
- if(meta->mro_linear_c3) SvREFCNT_dec(meta->mro_linear_c3);
if(meta->mro_nextmethod) SvREFCNT_dec(meta->mro_nextmethod);
SvREFCNT_dec(meta->isa);
Safefree(meta);
diff --git a/hv.h b/hv.h
index f92ce9e9fd..66fb6f2d8e 100644
--- a/hv.h
+++ b/hv.h
@@ -46,7 +46,9 @@ struct shared_he {
struct mro_alg;
struct mro_meta {
+ /* repurposed as a hash holding the different MROs private data. */
AV *mro_linear_dfs; /* cached dfs @ISA linearization */
+ /* repurposed as a pointer directly to the current MROs private data. */
AV *mro_linear_c3; /* cached c3 @ISA linearization */
HV *mro_nextmethod; /* next::method caching */
U32 cache_gen; /* Bumping this invalidates our method cache */
diff --git a/mro.c b/mro.c
index 36ad3bac1f..23070d990d 100644
--- a/mro.c
+++ b/mro.c
@@ -28,18 +28,74 @@ These functions are related to the method resolution order of perl classes
#include "perl.h"
struct mro_alg {
- const char *name;
AV *(*resolve)(pTHX_ HV* stash, U32 level);
+ const char *name;
+ U16 length;
+ U16 kflags; /* For the hash API - set HVhek_UTF8 if name is UTF-8 */
+ U32 hash; /* or 0 */
};
/* First one is the default */
static struct mro_alg mros[] = {
- {"dfs", S_mro_get_linear_isa_dfs},
- {"c3", S_mro_get_linear_isa_c3}
+ {S_mro_get_linear_isa_dfs, "dfs", 3, 0, 0},
+ {S_mro_get_linear_isa_c3, "c3", 2, 0, 0}
};
#define NUMBER_OF_MROS (sizeof(mros)/sizeof(struct mro_alg))
+#define dfs_alg (&mros[0])
+#define c3_alg (&mros[1])
+
+SV *
+Perl_mro_get_private_data(pTHX_ struct mro_meta *const smeta,
+ const struct mro_alg *const which)
+{
+ SV **data;
+ PERL_ARGS_ASSERT_MRO_GET_PRIVATE_DATA;
+
+ data = Perl_hv_common(aTHX_ MUTABLE_HV(smeta->mro_linear_dfs), NULL,
+ which->name, which->length, which->kflags,
+ HV_FETCH_JUST_SV, NULL, which->hash);
+ if (!data)
+ return NULL;
+
+ /* If we've been asked to look up the private data for the current MRO, then
+ cache it. */
+ if (smeta->mro_which == which)
+ smeta->mro_linear_c3 = MUTABLE_AV(*data);
+
+ return *data;
+}
+
+SV *
+Perl_mro_set_private_data(pTHX_ struct mro_meta *const smeta,
+ const struct mro_alg *const which, SV *const data)
+{
+ PERL_ARGS_ASSERT_MRO_SET_PRIVATE_DATA;
+
+ /* If we've been asked to look up the private data for the current MRO, then
+ cache it. */
+ if (smeta->mro_which == which)
+ smeta->mro_linear_c3 = MUTABLE_AV(data);
+
+ if (!smeta->mro_linear_dfs) {
+ HV *const hv = newHV();
+ HvMAX(hv) = 0; /* Start with 1 bucket. It's unlikely we'll need more.
+ */
+ smeta->mro_linear_dfs = MUTABLE_AV(hv);
+ }
+
+ if (!Perl_hv_common(aTHX_ MUTABLE_HV(smeta->mro_linear_dfs), NULL,
+ which->name, which->length, which->kflags,
+ HV_FETCH_ISSTORE, data, which->hash)) {
+ Perl_croak(aTHX_ "panic: hv_store() failed in set_mro_private_data() "
+ "for '%.*s' %d", (int) which->length, which->name,
+ which->kflags);
+ }
+
+ return data;
+}
+
static const struct mro_alg *
S_get_mro_from_name(pTHX_ const char *const name) {
const struct mro_alg *algo = mros;
@@ -85,9 +141,7 @@ Perl_mro_meta_dup(pTHX_ struct mro_meta* smeta, CLONE_PARAMS* param)
if (newmeta->mro_linear_dfs)
newmeta->mro_linear_dfs
= MUTABLE_AV(SvREFCNT_inc(sv_dup((const SV *)newmeta->mro_linear_dfs, param)));
- if (newmeta->mro_linear_c3)
- newmeta->mro_linear_c3
- = MUTABLE_AV(SvREFCNT_inc(sv_dup((const SV *)newmeta->mro_linear_c3, param)));
+ newmeta->mro_linear_c3 = NULL;
if (newmeta->mro_nextmethod)
newmeta->mro_nextmethod
= MUTABLE_HV(SvREFCNT_inc(sv_dup((const SV *)newmeta->mro_nextmethod, param)));
@@ -177,7 +231,7 @@ S_mro_get_linear_isa_dfs(pTHX_ HV *stash, U32 level)
meta = HvMROMETA(stash);
/* return cache if valid */
- if((retval = meta->mro_linear_dfs)) {
+ if((retval = MUTABLE_AV(Perl_mro_get_private_data(aTHX_ meta, dfs_alg)))) {
return retval;
}
@@ -283,8 +337,8 @@ S_mro_get_linear_isa_dfs(pTHX_ HV *stash, U32 level)
and we do so by replacing it completely */
SvREADONLY_on(retval);
- meta->mro_linear_dfs = retval;
- return retval;
+ return MUTABLE_AV(Perl_mro_set_private_data(aTHX_ meta, dfs_alg,
+ MUTABLE_SV(retval)));
}
/*
@@ -328,7 +382,7 @@ S_mro_get_linear_isa_c3(pTHX_ HV* stash, U32 level)
meta = HvMROMETA(stash);
/* return cache if valid */
- if((retval = meta->mro_linear_c3)) {
+ if((retval = MUTABLE_AV(Perl_mro_get_private_data(aTHX_ meta, c3_alg)))) {
return retval;
}
@@ -501,7 +555,8 @@ S_mro_get_linear_isa_c3(pTHX_ HV* stash, U32 level)
and we do so by replacing it completely */
SvREADONLY_on(retval);
- meta->mro_linear_c3 = retval;
+ return MUTABLE_AV(Perl_mro_set_private_data(aTHX_ meta, c3_alg,
+ MUTABLE_SV(retval)));
return retval;
}
@@ -569,7 +624,6 @@ Perl_mro_isa_changed_in(pTHX_ HV* stash)
/* wipe out the cached linearizations for this stash */
meta = HvMROMETA(stash);
SvREFCNT_dec(MUTABLE_SV(meta->mro_linear_dfs));
- SvREFCNT_dec(MUTABLE_SV(meta->mro_linear_c3));
meta->mro_linear_dfs = NULL;
meta->mro_linear_c3 = NULL;
if (meta->isa) {
@@ -612,7 +666,6 @@ Perl_mro_isa_changed_in(pTHX_ HV* stash)
if(!revstash) continue;
revmeta = HvMROMETA(revstash);
SvREFCNT_dec(MUTABLE_SV(revmeta->mro_linear_dfs));
- SvREFCNT_dec(MUTABLE_SV(revmeta->mro_linear_c3));
revmeta->mro_linear_dfs = NULL;
revmeta->mro_linear_c3 = NULL;
if(!is_universal)
@@ -845,6 +898,8 @@ XS(XS_mro_set_mro)
if(meta->mro_which != which) {
meta->mro_which = which;
+ /* Scrub our cached pointer to the private data. */
+ meta->mro_linear_c3 = NULL;
/* Only affects local method cache, not
even child classes */
meta->cache_gen++;
diff --git a/proto.h b/proto.h
index 62ddce4ff0..f10ce56a1a 100644
--- a/proto.h
+++ b/proto.h
@@ -6554,6 +6554,19 @@ PERL_CALLCONV void Perl_emulate_cop_io(pTHX_ const COP *const c, SV *const sv)
PERL_CALLCONV REGEXP * Perl_get_re_arg(pTHX_ SV *sv);
+PERL_CALLCONV SV* Perl_mro_get_private_data(pTHX_ struct mro_meta *const smeta, const struct mro_alg *const which)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_MRO_GET_PRIVATE_DATA \
+ assert(smeta); assert(which)
+
+PERL_CALLCONV SV* Perl_mro_set_private_data(pTHX_ struct mro_meta *const smeta, const struct mro_alg *const which, SV *const data)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_MRO_SET_PRIVATE_DATA \
+ assert(smeta); assert(which); assert(data)
+
PERL_CALLCONV struct mro_meta* Perl_mro_meta_init(pTHX_ HV* stash)
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_MRO_META_INIT \
View Lorry Controller Status