Factor out common code from sv_derived_from_* subs family

into one that takes both SV*/char*+len arguments, like hv_common,
to be able to use speedups from SV* stash lookup API.

diff --git a/embed.fnc b/embed.fnc
index d140a26..6f62282 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -880,9 +880,11 @@ Xxpd       |void   |gv_try_downgrade|NN GV* gv
 p      |void   |gv_setref      |NN SV *const dstr|NN SV *const sstr
 Apd    |HV*    |gv_stashpv     |NN const char* name|I32 flags
 Apd    |HV*    |gv_stashpvn    |NN const char* name|U32 namelen|I32 flags
+#if defined(PERL_IN_GV_C) || defined(PERL_IN_UNIVERSAL_C)
+EpG    |HV*    |gv_stashsvpvn_cached   |NULLOK SV *namesv|NULLOK const char* name|U32 namelen|I32 flags
+#endif
 #if defined(PERL_IN_GV_C)
 i      |HV*    |gv_stashpvn_internal   |NN const char* name|U32 namelen|I32 flags
-iG     |HV*    |gv_stashsvpvn_cached   |NULLOK SV *namesv|NULLOK const char* name|U32 namelen|I32 flags
 i      |GV*    |gv_fetchmeth_internal  |NULLOK HV* stash|NULLOK SV* meth|NULLOK const char* name \
                                        |STRLEN len|I32 level|U32 flags
 #endif
@@ -2993,8 +2995,9 @@ EdXxp     |bool   |validate_proto |NN SV *name|NULLOK SV *proto|bool warn \
                |bool curstash
 
 #if defined(PERL_IN_UNIVERSAL_C)
-S      |bool   |isa_lookup     |NN HV *stash|NN const char * const name \
+SG     |bool   |isa_lookup     |NULLOK HV *stash|NULLOK SV *namesv|NULLOK const char * name \
                                         |STRLEN len|U32 flags
+SG   |bool   |sv_derived_from_svpvn  |NULLOK SV *sv|NULLOK SV *namesv|NULLOK const char * name|STRLEN len|U32 flags
 #endif
 
 #if defined(PERL_IN_LOCALE_C)

diff --git a/embed.h b/embed.h
index 6f6752a..ccdcd6b 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -1008,6 +1008,9 @@
 #define isSCRIPT_RUN(a,b,c)    Perl_isSCRIPT_RUN(aTHX_ a,b,c)
 #define variant_under_utf8_count       S_variant_under_utf8_count
 #  endif
+#  if defined(PERL_IN_GV_C) || defined(PERL_IN_UNIVERSAL_C)
+#define gv_stashsvpvn_cached(a,b,c,d)  Perl_gv_stashsvpvn_cached(aTHX_ a,b,c,d)
+#  endif
 #  if defined(PERL_IN_PP_C) || defined(PERL_IN_REGCOMP_C) || defined(PERL_IN_TOKE_C) || defined(PERL_IN_UNIVERSAL_C)
 #define get_regex_charset_name S_get_regex_charset_name
 #  endif
@@ -1619,7 +1622,6 @@
 #define gv_magicalize(a,b,c,d,e)       S_gv_magicalize(aTHX_ a,b,c,d,e)
 #define gv_magicalize_isa(a)   S_gv_magicalize_isa(aTHX_ a)
 #define gv_stashpvn_internal(a,b,c)    S_gv_stashpvn_internal(aTHX_ a,b,c)
-#define gv_stashsvpvn_cached(a,b,c,d)  S_gv_stashsvpvn_cached(aTHX_ a,b,c,d)
 #define maybe_multimagic_gv(a,b,c)     S_maybe_multimagic_gv(aTHX_ a,b,c)
 #define parse_gv_stash_name(a,b,c,d,e,f,g,h)   S_parse_gv_stash_name(aTHX_ a,b,c,d,e,f,g,h)
 #define require_tie_mod(a,b,c,d,e)     S_require_tie_mod(aTHX_ a,b,c,d,e)
@@ -1909,7 +1911,8 @@
 #define yywarn(a,b)            S_yywarn(aTHX_ a,b)
 #  endif
 #  if defined(PERL_IN_UNIVERSAL_C)
-#define isa_lookup(a,b,c,d)    S_isa_lookup(aTHX_ a,b,c,d)
+#define isa_lookup(a,b,c,d,e)  S_isa_lookup(aTHX_ a,b,c,d,e)
+#define sv_derived_from_svpvn(a,b,c,d,e)       S_sv_derived_from_svpvn(aTHX_ a,b,c,d,e)
 #  endif
 #  if defined(PERL_IN_UTF8_C)
 #define _to_utf8_case(a,b,c,d,e,f,g,h,i)       S__to_utf8_case(aTHX_ a,b,c,d,e,f,g,h,i)

diff --git a/gv.c b/gv.c
index 1a49d5e..53099e0 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -1528,8 +1528,8 @@ Note the sv interface is strongly preferred for performance reasons.
 #define PERL_ARGS_ASSERT_GV_STASHSVPVN_CACHED \
     assert(namesv || name)
 
-PERL_STATIC_INLINE HV*
-S_gv_stashsvpvn_cached(pTHX_ SV *namesv, const char *name, U32 namelen, I32 flags)
+HV*
+Perl_gv_stashsvpvn_cached(pTHX_ SV *namesv, const char *name, U32 namelen, I32 flags)
 {
     HV* stash;
     HE* he;

diff --git a/proto.h b/proto.h
index 78d4bfa..135ef89 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -4932,9 +4932,6 @@ PERL_STATIC_INLINE HV*    S_gv_stashpvn_internal(pTHX_ const char* name, U32 namele
 #define PERL_ARGS_ASSERT_GV_STASHPVN_INTERNAL  \
        assert(name)
 #endif
-#ifndef PERL_NO_INLINE_FUNCTIONS
-PERL_STATIC_INLINE HV* S_gv_stashsvpvn_cached(pTHX_ SV *namesv, const char* name, U32 namelen, I32 flags);
-#endif
 STATIC void    S_maybe_multimagic_gv(pTHX_ GV *gv, const char *name, const svtype sv_type);
 #define PERL_ARGS_ASSERT_MAYBE_MULTIMAGIC_GV   \
        assert(gv); assert(name)
@@ -4950,6 +4947,9 @@ PERL_CALLCONV void        Perl_sv_add_backref(pTHX_ SV *const tsv, SV *const sv);
 #define PERL_ARGS_ASSERT_SV_ADD_BACKREF        \
        assert(tsv); assert(sv)
 #endif
+#if defined(PERL_IN_GV_C) || defined(PERL_IN_UNIVERSAL_C)
+PERL_CALLCONV HV*      Perl_gv_stashsvpvn_cached(pTHX_ SV *namesv, const char* name, U32 namelen, I32 flags);
+#endif
 #if defined(PERL_IN_HV_C)
 STATIC void    S_clear_placeholders(pTHX_ HV *hv, U32 items);
 #define PERL_ARGS_ASSERT_CLEAR_PLACEHOLDERS    \
@@ -6335,9 +6335,8 @@ STATIC int        S_yywarn(pTHX_ const char *const s, U32 flags);
        assert(s)
 #endif
 #if defined(PERL_IN_UNIVERSAL_C)
-STATIC bool    S_isa_lookup(pTHX_ HV *stash, const char * const name, STRLEN len, U32 flags);
-#define PERL_ARGS_ASSERT_ISA_LOOKUP    \
-       assert(stash); assert(name)
+STATIC bool    S_isa_lookup(pTHX_ HV *stash, SV *namesv, const char * name, STRLEN len, U32 flags);
+STATIC bool    S_sv_derived_from_svpvn(pTHX_ SV *sv, SV *namesv, const char * name, STRLEN len, U32 flags);
 #endif
 #if defined(PERL_IN_UTF8_C)
 STATIC UV      S__to_utf8_case(pTHX_ const UV uv1, const U8 *p, U8* ustrp, STRLEN *lenp, SV *invlist, const int * const invmap, const unsigned int * const * const aux_tables, const U8 * const aux_table_lengths, const char * const normal);

diff --git a/universal.c b/universal.c
index 66eafc5..34a63e8 100644 (file)
--- a/universal.c
+++ b/universal.c
@@ -38,8 +38,13 @@
  * The main guts of traverse_isa was actually copied from gv_fetchmeth
  */
 
+#define PERL_ARGS_ASSERT_ISA_LOOKUP \
+    assert(stash); \
+    assert(namesv || name)
+
+
 STATIC bool
-S_isa_lookup(pTHX_ HV *stash, const char * const name, STRLEN len, U32 flags)
+S_isa_lookup(pTHX_ HV *stash, SV *namesv, const char * name, STRLEN len, U32 flags)
 {
     const struct mro_meta *const meta = HvMROMETA(stash);
     HV *isa = meta->isa;
@@ -52,7 +57,7 @@ S_isa_lookup(pTHX_ HV *stash, const char * const name, STRLEN len, U32 flags)
        isa = meta->isa;
     }
 
-    if (hv_common(isa, NULL, name, len, ( flags & SVf_UTF8 ? HVhek_UTF8 : 0),
+    if (hv_common(isa, namesv, name, len, ( flags & SVf_UTF8 ? HVhek_UTF8 : 0),
                  HV_FETCH_ISEXISTS, NULL, 0)) {
        /* Direct name lookup worked.  */
        return TRUE;
@@ -61,7 +66,7 @@ S_isa_lookup(pTHX_ HV *stash, const char * const name, STRLEN len, U32 flags)
     /* A stash/class can go by many names (ie. User == main::User), so 
        we use the HvENAME in the stash itself, which is canonical, falling
        back to HvNAME if necessary.  */
-    our_stash = gv_stashpvn(name, len, flags);
+    our_stash = gv_stashsvpvn_cached(namesv, name, len, flags);
 
     if (our_stash) {
        HEK *canon_name = HvENAME_HEK(our_stash);
@@ -77,6 +82,43 @@ S_isa_lookup(pTHX_ HV *stash, const char * const name, STRLEN len, U32 flags)
     return FALSE;
 }
 
+#define PERL_ARGS_ASSERT_SV_DERIVED_FROM_SVPVN \
+    assert(sv); \
+    assert(namesv || name)
+
+STATIC bool
+S_sv_derived_from_svpvn(pTHX_ SV *sv, SV *namesv, const char * name, const STRLEN len, U32 flags)
+{
+    HV* stash;
+
+    PERL_ARGS_ASSERT_SV_DERIVED_FROM_SVPVN;
+    SvGETMAGIC(sv);
+
+    if (SvROK(sv)) {
+        const char *type;
+        sv = SvRV(sv);
+        type = sv_reftype(sv,0);
+        if (type) {
+            if (namesv)
+                name = SvPV_nolen(namesv);
+            if (strEQ(name, type))
+                return TRUE;
+        }
+        if (!SvOBJECT(sv))
+            return FALSE;
+        stash = SvSTASH(sv);
+    }
+    else {
+        stash = gv_stashsv(sv, 0);
+    }
+
+    if (stash && isa_lookup(stash, namesv, name, len, flags))
+        return TRUE;
+
+    stash = gv_stashpvs("UNIVERSAL", 0);
+    return stash && isa_lookup(stash, namesv, name, len, flags);
+}
+
 /*
 =head1 SV Manipulation Functions
 
@@ -93,7 +135,7 @@ Currently, the only significant value for C<flags> is SVf_UTF8.
 =for apidoc sv_derived_from_sv
 
 Exactly like L</sv_derived_from_pvn>, but takes the name string in the form
-of an SV instead of a string/length pair.
+of an SV instead of a string/length pair. This is the advised form.
 
 =cut
 
@@ -102,13 +144,8 @@ of an SV instead of a string/length pair.
 bool
 Perl_sv_derived_from_sv(pTHX_ SV *sv, SV *namesv, U32 flags)
 {
-    char *namepv;
-    STRLEN namelen;
     PERL_ARGS_ASSERT_SV_DERIVED_FROM_SV;
-    namepv = SvPV(namesv, namelen);
-    if (SvUTF8(namesv))
-       flags |= SVf_UTF8;
-    return sv_derived_from_pvn(sv, namepv, namelen, flags);
+    return sv_derived_from_svpvn(sv, namesv, NULL, 0, flags);
 }
 
 /*
@@ -123,7 +160,7 @@ bool
 Perl_sv_derived_from(pTHX_ SV *sv, const char *const name)
 {
     PERL_ARGS_ASSERT_SV_DERIVED_FROM;
-    return sv_derived_from_pvn(sv, name, strlen(name), 0);
+    return sv_derived_from_svpvn(sv, NULL, name, strlen(name), 0);
 }
 
 /*
@@ -140,37 +177,14 @@ bool
 Perl_sv_derived_from_pv(pTHX_ SV *sv, const char *const name, U32 flags)
 {
     PERL_ARGS_ASSERT_SV_DERIVED_FROM_PV;
-    return sv_derived_from_pvn(sv, name, strlen(name), flags);
+    return sv_derived_from_svpvn(sv, NULL, name, strlen(name), flags);
 }
 
 bool
 Perl_sv_derived_from_pvn(pTHX_ SV *sv, const char *const name, const STRLEN len, U32 flags)
 {
-    HV *stash;
-
     PERL_ARGS_ASSERT_SV_DERIVED_FROM_PVN;
-
-    SvGETMAGIC(sv);
-
-    if (SvROK(sv)) {
-       const char *type;
-        sv = SvRV(sv);
-        type = sv_reftype(sv,0);
-       if (type && strEQ(type,name))
-           return TRUE;
-        if (!SvOBJECT(sv))
-            return FALSE;
-       stash = SvSTASH(sv);
-    }
-    else {
-        stash = gv_stashsv(sv, 0);
-    }
-
-    if (stash && isa_lookup(stash, name, len, flags))
-        return TRUE;
-
-    stash = gv_stashpvs("UNIVERSAL", 0);
-    return stash && isa_lookup(stash, name, len, flags);
+    return sv_derived_from_svpvn(sv, NULL, name, len, flags);
 }
 
 /*