From: Nicholas Clark <nick@ccl4.org>
Date: Fri, 12 Sep 2008 00:19:51 +0000 (+0000)
Subject: Create a direct lookup hash for ->isa() lookup, by retaining the
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=a49ba3fcbe357fbacf7b9898df08daa2cbdfc8c4;p=p5sagit%2Fp5-mst-13.2.git

Create a direct lookup hash for ->isa() lookup, by retaining the
de-duping hash used by S_mro_get_linear_isa_dfs(). Provide a new
function Perl_get_isa_hash() to lazily retrieve this. (Which could
actually be static if S_isa_lookup() and Perl_sv_derived_from()
moved into mro.c.) Make S_isa_lookup() use this lookup hash in place
of a linear walk of the linear isa. This should turn isa lookups from
O(n) to O(1), which should make heavy users of ->isa() faster.
(eg PPI, and hence Perl Critic).

p4raw-id: //depot/perl@34354
---

diff --git a/embed.fnc b/embed.fnc
index d680a5b..a193ab4 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -1997,6 +1997,7 @@ ApoM	|const char *|fetch_cop_label|NULLOK struct refcounted_he *const chain \
 		|NULLOK STRLEN *len|NULLOK U32 *flags
 xpoM	|struct refcounted_he *|store_cop_label \
 		|NULLOK struct refcounted_he *const chain|NN const char *label
+poM	|HV *	|get_isa_hash	|NN HV *const stash
 
 END_EXTERN_C
 /*
diff --git a/hv.c b/hv.c
index c394e73..0cbb483 100644
--- a/hv.c
+++ b/hv.c
@@ -1688,6 +1688,7 @@ S_hfreeentries(pTHX_ HV *hv)
                 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);
                 iter->xhv_mro_meta = NULL;
             }
diff --git a/hv.h b/hv.h
index e7d0c76..7f96a13 100644
--- a/hv.h
+++ b/hv.h
@@ -52,6 +52,7 @@ struct mro_meta {
     U32     cache_gen;       /* Bumping this invalidates our method cache */
     U32     pkg_gen;         /* Bumps when local methods/@ISA change */
     const struct mro_alg *mro_which; /* which mro alg is in use? */
+    HV      *isa;            /* Everything this class @ISA */
 };
 
 /* Subject to change.
diff --git a/mro.c b/mro.c
index ffb72ab..da30c4d 100644
--- a/mro.c
+++ b/mro.c
@@ -88,12 +88,29 @@ Perl_mro_meta_dup(pTHX_ struct mro_meta* smeta, CLONE_PARAMS* param)
     if (newmeta->mro_nextmethod)
 	newmeta->mro_nextmethod
 	    = (HV*) SvREFCNT_inc(sv_dup((SV*)newmeta->mro_nextmethod, param));
+    if (newmeta->isa)
+	newmeta->isa
+	    = (HV*) SvREFCNT_inc(sv_dup((SV*)newmeta->isa, param));
 
     return newmeta;
 }
 
 #endif /* USE_ITHREADS */
 
+HV *
+Perl_get_isa_hash(pTHX_ HV *const stash)
+{
+    dVAR;
+    struct mro_meta *const meta = HvMROMETA(stash);
+
+    PERL_ARGS_ASSERT_GET_ISA_HASH;
+
+    if (!meta->isa)
+	mro_get_linear_isa_dfs(stash, 0);
+    assert(meta->isa);
+    return meta->isa;
+}
+
 /*
 =for apidoc mro_get_linear_isa_dfs
 
@@ -119,6 +136,8 @@ S_mro_get_linear_isa_dfs(pTHX_ HV *stash, I32 level)
     AV* av;
     const HEK* stashhek;
     struct mro_meta* meta;
+    SV *our_name;
+    HV *stored;
 
     PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA_DFS;
     assert(HvAUX(stash));
@@ -141,20 +160,25 @@ S_mro_get_linear_isa_dfs(pTHX_ HV *stash, I32 level)
     /* not in cache, make a new one */
 
     retval = (AV*)sv_2mortal((SV *)newAV());
-    av_push(retval, newSVhek(stashhek)); /* add ourselves at the top */
+    /* We use this later in this function, but don't need a reference to it
+       beyond the end of this function, so reference count is fine.  */
+    our_name = newSVhek(stashhek);
+    av_push(retval, our_name); /* add ourselves at the top */
 
     /* fetch our @ISA */
     gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
     av = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
 
-    if(av && AvFILLp(av) >= 0) {
+    /* "stored" is used to keep track of all of the classnames we have added to
+       the MRO so far, so we can do a quick exists check and avoid adding
+       duplicate classnames to the MRO as we go.
+       It's then retained to be re-used as a fast lookup for ->isa(), by adding
+       our own name and "UNIVERSAL" to it.  */
 
-        /* "stored" is used to keep track of all of the classnames
-           we have added to the MRO so far, so we can do a quick
-           exists check and avoid adding duplicate classnames to
-           the MRO as we go. */
+    stored = (HV*)sv_2mortal((SV*)newHV());
+
+    if(av && AvFILLp(av) >= 0) {
 
-        HV* const stored = (HV*)sv_2mortal((SV*)newHV());
         SV **svp = AvARRAY(av);
         I32 items = AvFILLp(av) + 1;
 
@@ -221,12 +245,19 @@ S_mro_get_linear_isa_dfs(pTHX_ HV *stash, I32 level)
        mortals' stack will be released soon, so everything will balance.  */
     SvREFCNT_inc_simple_void_NN(retval);
     SvTEMP_off(retval);
+    SvREFCNT_inc_simple_void_NN(stored);
+    SvTEMP_off(stored);
+
+    hv_store_ent(stored, our_name, &PL_sv_undef, 0);
+    hv_store(stored, "UNIVERSAL", 9, &PL_sv_undef, 0);
 
     /* we don't want anyone modifying the cache entry but us,
        and we do so by replacing it completely */
     SvREADONLY_on(retval);
+    SvREADONLY_on(stored);
 
     meta->mro_linear_dfs = retval;
+    meta->isa = stored;
     return retval;
 }
 
diff --git a/proto.h b/proto.h
index 59080ec..d106187 100644
--- a/proto.h
+++ b/proto.h
@@ -6597,6 +6597,11 @@ PERL_CALLCONV struct refcounted_he *	Perl_store_cop_label(pTHX_ struct refcounte
 #define PERL_ARGS_ASSERT_STORE_COP_LABEL	\
 	assert(label)
 
+PERL_CALLCONV HV *	Perl_get_isa_hash(pTHX_ HV *const stash)
+			__attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_GET_ISA_HASH	\
+	assert(stash)
+
 
 END_EXTERN_C
 /*
diff --git a/universal.c b/universal.c
index 08dad15..de928f7 100644
--- a/universal.c
+++ b/universal.c
@@ -40,35 +40,32 @@ STATIC bool
 S_isa_lookup(pTHX_ HV *stash, const char * const name)
 {
     dVAR;
-    AV* stash_linear_isa;
-    SV** svp;
-    const char *hvname;
-    I32 items;
-    const HV *const name_stash = gv_stashpv(name, 0);
+    const struct mro_meta *const meta = HvMROMETA(stash);
+    HV *const isa = meta->isa ? meta->isa : Perl_get_isa_hash(aTHX_ stash);
+    STRLEN len = strlen(name);
+    const HV *our_stash;
 
     PERL_ARGS_ASSERT_ISA_LOOKUP;
 
-    /* A stash/class can go by many names (ie. User == main::User), so 
-       we compare the stash itself just in case */
-    if ((const HV *)stash == name_stash)
-        return TRUE;
-
-    hvname = HvNAME_get(stash);
-
-    if (strEQ(hvname, name))
+    if (hv_common(isa, NULL, name, len, 0 /* No "UTF-8" flag possible with only
+					     a char * argument*/,
+		  HV_FETCH_ISEXISTS, NULL, 0)) {
+	/* Direct name lookup worked.  */
 	return TRUE;
+    }
 
-    if (strEQ(name, "UNIVERSAL"))
-	return TRUE;
+    /* A stash/class can go by many names (ie. User == main::User), so 
+       we use the name in the stash itself, which is canonical.  */
+    our_stash = gv_stashpvn(name, len, 0);
 
-    stash_linear_isa = mro_get_linear_isa(stash);
-    svp = AvARRAY(stash_linear_isa) + 1;
-    items = AvFILLp(stash_linear_isa);
-    while (items--) {
-	SV* const basename_sv = *svp++;
-        HV* const basestash = gv_stashsv(basename_sv, 0);
-        if(name_stash == basestash || strEQ(name, SvPVX(basename_sv)))
+    if (our_stash) {
+	HEK *const canon_name = HvNAME_HEK(our_stash);
+
+	if (hv_common(isa, NULL, HEK_KEY(canon_name), HEK_LEN(canon_name),
+		      HEK_FLAGS(canon_name),
+		      HV_FETCH_ISEXISTS, NULL, HEK_HASH(canon_name))) {
 	    return TRUE;
+	}
     }
 
     return FALSE;