Repurpose struct mro_meta to allow it to store cached linear ISA for arbitary

method resolution orders.

mro_linear_dfs becomes a hash holding the different MROs' private data.
mro_linear_c3 becomes a shortcut pointer to the current MRO's private data.

diff --git a/embed.fnc b/embed.fnc
index cc3cf79..bb43543 100644 (file)
--- 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 fe26578..af15270 100644 (file)
--- 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 adb5a4d..d41b978 100644 (file)
--- 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 f92ce9e..66fb6f2 100644 (file)
--- 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 36ad3ba..23070d9 100644 (file)
--- 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 62ddce4..f10ce56 100644 (file)
--- 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 \