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.

Author: nwc10

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)

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

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);

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 */

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++;

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	\