diff --git a/embed.fnc b/embed.fnc index 6a977512583f..42b8a94b5d5b 100644 --- a/embed.fnc +++ b/embed.fnc @@ -1468,11 +1468,15 @@ ep |GV * |gv_override |NN const char * const name \ |const STRLEN len p |void |gv_setref |NN SV * const dsv \ |NN SV * const ssv +Ap |HV * |gv_stashhek |NN HEK *hek \ + |I32 flags Adp |HV * |gv_stashpv |NN const char *name \ |I32 flags Adp |HV * |gv_stashpvn |NN const char *name \ |U32 namelen \ |I32 flags +Xp |HV * |gv_stashpvs_p |I32 flags \ + |NN const char *name Adp |HV * |gv_stashsv |NN SV *sv \ |I32 flags Xdpx |void |gv_try_downgrade \ @@ -4510,6 +4514,10 @@ EGdp |HV * |gv_stashsvpvn_cached \ |const char *name \ |U32 namelen \ |I32 flags +EFXp |HV * |gv_stashsvpvn_cached_p \ + |I32 flags \ + |NN void *namevp \ + |... #endif #if defined(PERL_IN_HV_C) Sx |void |clear_placeholders \ diff --git a/embed.h b/embed.h index b4ec209d8ca4..dbc27e6e2069 100644 --- a/embed.h +++ b/embed.h @@ -294,6 +294,7 @@ # define gv_init_pvn(a,b,c,d,e) Perl_gv_init_pvn(aTHX_ a,b,c,d,e) # define gv_init_sv(a,b,c,d) Perl_gv_init_sv(aTHX_ a,b,c,d) # define gv_name_set(a,b,c,d) Perl_gv_name_set(aTHX_ a,b,c,d) +# define gv_stashhek(a,b) Perl_gv_stashhek(aTHX_ a,b) # define gv_stashpv(a,b) Perl_gv_stashpv(aTHX_ a,b) # define gv_stashpvn(a,b,c) Perl_gv_stashpvn(aTHX_ a,b,c) # define gv_stashsv(a,b) Perl_gv_stashsv(aTHX_ a,b) @@ -1072,6 +1073,7 @@ # define get_opargs() Perl_get_opargs(aTHX) # define gv_override(a,b) Perl_gv_override(aTHX_ a,b) # define gv_setref(a,b) Perl_gv_setref(aTHX_ a,b) +# define gv_stashpvs_p(a,b) Perl_gv_stashpvs_p(aTHX_ a,b) # define gv_try_downgrade(a) Perl_gv_try_downgrade(aTHX_ a) # define hv_ename_add(a,b,c,d) Perl_hv_ename_add(aTHX_ a,b,c,d) # define hv_ename_delete(a,b,c,d) Perl_hv_ename_delete(aTHX_ a,b,c,d) @@ -1937,6 +1939,7 @@ # 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) +# define gv_stashsvpvn_cached_p(a,...) Perl_gv_stashsvpvn_cached_p(aTHX_ a,__VA_ARGS__) # endif # if defined(PERL_IN_OP_C) || defined(PERL_IN_REGCOMP_ANY) # define get_invlist_iter_addr S_get_invlist_iter_addr diff --git a/gv.c b/gv.c index f76a56c56e32..f5bd368f8e72 100644 --- a/gv.c +++ b/gv.c @@ -1621,7 +1621,8 @@ HV* Perl_gv_stashpv(pTHX_ const char *name, I32 create) { PERL_ARGS_ASSERT_GV_STASHPV; - return gv_stashpvn(name, strlen(name), create); + return Perl_gv_stashsvpvn_cached_p(aTHX_ create | GVCf_ISPV | GVCf_HASVA_LEN, + (void*)name, strlen(name)); } /* @@ -1696,15 +1697,73 @@ reasons. HV* Perl_gv_stashsvpvn_cached(pTHX_ SV *namesv, const char *name, U32 namelen, I32 flags) +{ + PERL_ARGS_ASSERT_GV_STASHSVPVN_CACHED; + if(namesv) + return Perl_gv_stashsvpvn_cached_p(aTHX_ flags | GVCf_ISSV, (void*)namesv); + else + return Perl_gv_stashsvpvn_cached_p(aTHX_ flags | GVCf_ISPV | GVCf_HASVA_LEN, + (void*)name, namelen); +} + +/* Not public API, "..." takes exactly 1 optional arg, "U32 namelen" for the + public facing _pvn() variant. All other varieties, pv() pvs() sv() hek() + do not use the optional 3rd arg.*/ +HV* +Perl_gv_stashsvpvn_cached_p(pTHX_ I32 flags, void * namevp, ...) { HV* stash; HE* he; + SV* namesv; + const char* name; + va_list args; + U32 namelen; + U32 hash; - PERL_ARGS_ASSERT_GV_STASHSVPVN_CACHED; + PERL_ARGS_ASSERT_GV_STASHSVPVN_CACHED_P; + va_start(args, namevp); + if(GV_CACHE_ISRC(flags)) { + if(GV_CACHE_ISHEK(flags)) { + HEK* hek = (HEK*)namevp; + I32 hek_len = HEK_LEN(hek); + if(hek_len == HEf_SVKEY) { + namesv = *(SV**)HEK_KEY(hek); + namevp = (void*)namesv; + goto have_sv; + } + namesv = NULL; + name = HEK_KEY(hek); + namelen = hek_len; + flags = (flags & ~SVf_UTF8) | (HEK_UTF8(hek) ? SVf_UTF8 : 0); +/* hv_fetchhek() isn't used here. Its a macro and doesn't currently + do the optimisation you think it is supposed to do. Using macro + hv_fetchhek() in this fn, would add needless indirection through + wrapper hv_common_key_len() instead of centralized single call sites + to hv_common(). */ + hash = HEK_HASH(hek); + } + else { + have_sv: + assert(GV_CACHE_ISSV(flags)); + namesv = (SV*)namevp; + name = NULL; + namelen = 0; + flags = (flags & ~SVf_UTF8) | SvUTF8(namesv); + hash = 0; + } + } + else { + assert(GV_CACHE_ISPV(flags)); + namesv = NULL; + name = (const char *)namevp; + namelen = GV_CACHE_HASVA_LEN(flags) + ? va_arg(args, U32) : GV_CACHE_GET_INL_LEN(flags); + hash = 0; + } he = (HE *)hv_common( PL_stashcache, namesv, name, namelen, - (flags & SVf_UTF8) ? HVhek_UTF8 : 0, 0, NULL, 0 + (flags & SVf_UTF8) ? HVhek_UTF8 : 0, 0, NULL, hash ); if (he) { @@ -1713,28 +1772,39 @@ Perl_gv_stashsvpvn_cached(pTHX_ SV *namesv, const char *name, U32 namelen, I32 f assert(SvIOK(sv)); hv = INT2PTR(HV*, SvIVX(sv)); assert(SvTYPE(hv) == SVt_PVHV); - return hv; + stash = hv; + goto end; + } + else if (flags & GV_CACHE_ONLY) { + stash = NULL; + goto end; } - else if (flags & GV_CACHE_ONLY) return NULL; if (namesv) { if (SvOK(namesv)) { /* prevent double uninit warning */ STRLEN len; name = SvPV_const(namesv, len); namelen = len; - flags |= SvUTF8(namesv); + flags = (flags & ~SVf_UTF8) | SvUTF8(namesv); } else { name = ""; namelen = 0; + namesv = NULL; flags = flags & ~SVf_UTF8; } - } + } /* Turn off bits specific to our call conv so GV_NOADD_MASK works. + Some of our call conv bits are shared with other features from + other front end gv_*() funcs. */ + flags &= ~GV_CACHE_VA_ARGS_MASK; stash = gv_stashpvn_internal(name, namelen, flags); if (stash && namelen) { SV* const ref = newSViv(PTR2IV(stash)); - (void)hv_store(PL_stashcache, name, - (flags & SVf_UTF8) ? -(I32)namelen : (I32)namelen, ref, 0); + hv_common( PL_stashcache, namesv, name, namelen, + (flags & SVf_UTF8) ? HVhek_UTF8 : 0, HV_FETCH_ISSTORE, ref, hash + ); } + end: + va_end(args); return stash; } @@ -1742,15 +1812,34 @@ HV* Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 flags) { PERL_ARGS_ASSERT_GV_STASHPVN; - return gv_stashsvpvn_cached(NULL, name, namelen, flags); + return Perl_gv_stashsvpvn_cached_p(aTHX_ flags | GVCf_ISPV | GVCf_HASVA_LEN, + (void*)name, namelen); +} + +HV* +Perl_gv_stashpvs_p(pTHX_ I32 flags, const char *name) +{ + PERL_ARGS_ASSERT_GV_STASHPVS_P; + return Perl_gv_stashsvpvn_cached_p(aTHX_ flags | GVCf_ISPV, (void*)name); } + HV* Perl_gv_stashsv(pTHX_ SV *sv, I32 flags) { PERL_ARGS_ASSERT_GV_STASHSV; - return gv_stashsvpvn_cached(sv, NULL, 0, flags); + return Perl_gv_stashsvpvn_cached_p(aTHX_ flags | GVCf_ISSV, (void*)sv); } + +HV* +Perl_gv_stashhek(pTHX_ HEK *hek, I32 flags) +{ + PERL_ARGS_ASSERT_GV_STASHHEK; + return Perl_gv_stashsvpvn_cached_p(aTHX_ + flags | GVCf_ISHEK, + (void*)hek); +} + GV * Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 flags, const svtype sv_type) { PERL_ARGS_ASSERT_GV_FETCHPV; diff --git a/gv.h b/gv.h index 1eb6adeb8ee1..07229ef94421 100644 --- a/gv.h +++ b/gv.h @@ -272,6 +272,27 @@ Return the CV from the GV. #define GV_ADDMG 0x400 /* add if magical */ #define GV_NO_SVGMAGIC 0x800 /* Skip get-magic on an SV argument; used only by gv_fetchsv(_nomg) */ +#define GVCf_ISRC 0x2000 +#define GVCf_ISSV GVCf_ISRC +#define GVCf_ISPV 0x0 +#define GVCf_ISHEKORPVN 0x4000 +#define GVCf_ISHEK (GVCf_ISHEKORPVN|GVCf_ISRC) +#define GVCf_HASVA_LEN GVCf_ISHEKORPVN + +#define GV_CACHE_ISPV(_f) (((_f) & GVCf_ISRC)==0) +#define GV_CACHE_HASVA_LEN(_f) (((_f)&(GVCf_ISHEKORPVN|GVCf_ISRC)) == (GVCf_ISHEKORPVN)) +#define GV_CACHE_ISRC(_f) ((_f)&GVCf_ISRC) //0x2000 //sv #50 pv[|n|s] #184 +#define GV_CACHE_ISSV(_f) (((_f)&(GVCf_ISHEKORPVN|GVCf_ISRC)) == GVCf_ISRC) //0x2000 //sv #50 pv[|n|s] #184 +/* core .xs's sv 9, pvn 15, pv 47, pvs 4 + core .c's sv 19, pvn 14, pv 3, pvs 4 */ +#define GV_CACHE_ISHEK(_f) (((_f)&GVCf_ISHEK) == GVCf_ISHEK) +#define GV_CACHE_INL_LEN_MASK 0x00FF0000 +#define GV_CACHE_INL_LEN_MAX 0xFF +#define GV_CACHE_GET_INL_LEN(_f) ((U8)((_f)>>16)) +#define GV_CACHE_FITS_INL_LEN(_f) ((_f) <= GV_CACHE_INL_LEN_MAX) +#define GV_CACHE_PACK_INL_LEN(_f) ((U32)(((U32)((U8)(_f))) << 16)) +#define GV_CACHE_VA_ARGS_MASK (GVCf_ISRC|GVCf_ISHEKORPVN|GV_CACHE_INL_LEN_MASK) + #define GV_CACHE_ONLY 0x1000 /* return stash only if found in cache; used only in flags parameter to gv_stash* family */ @@ -287,6 +308,7 @@ Return the CV from the GV. as a flag to various gv_* functions, so ensure it lies outside this range. */ +#define GV_UTF8fprvt SVf_UTF8 /* 0x20000000 */ /* SvPV is UTF-8 encoded */ #define GV_NOADD_MASK \ (SVf_UTF8|GV_NOADD_NOINIT|GV_NOEXPAND|GV_NOTQUAL|GV_ADDMG|GV_NO_SVGMAGIC) diff --git a/handy.h b/handy.h index e2e5aa9e3e98..13d4d5d7adbd 100644 --- a/handy.h +++ b/handy.h @@ -455,8 +455,12 @@ Perl_xxx(aTHX_ ...) form for any API calls where it's used. =for apidoc_defn Am|HV*|gv_stashpvs|"name"|I32 create =cut */ -#define gv_stashpvs(str, create) \ - Perl_gv_stashpvn(aTHX_ STR_WITH_LEN(str), create) + +#define gv_stashpvs(str, create) Perl_gv_stashpvs_p(aTHX_ \ + ((create) | ( GV_CACHE_FITS_INL_LEN(sizeof(str)-1) \ + ? GV_CACHE_PACK_INL_LEN(sizeof(str)-1) \ + : (Perl_croak_nocontext("panic: gv_stashpvs overflow"), \ + GV_CACHE_INL_LEN_MAX))), ASSERT_IS_LITERAL(str)) /* diff --git a/proto.h b/proto.h index 1e2a0fdb3ccc..58fa2a5d2658 100644 --- a/proto.h +++ b/proto.h @@ -1553,6 +1553,11 @@ Perl_gv_setref(pTHX_ SV * const dsv, SV * const ssv) #define PERL_ARGS_ASSERT_GV_SETREF \ assert(dsv); assert(ssv) +PERL_CALLCONV HV * +Perl_gv_stashhek(pTHX_ HEK *hek, I32 flags); +#define PERL_ARGS_ASSERT_GV_STASHHEK \ + assert(hek) + PERL_CALLCONV HV * Perl_gv_stashpv(pTHX_ const char *name, I32 flags); #define PERL_ARGS_ASSERT_GV_STASHPV \ @@ -1563,6 +1568,11 @@ Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 flags); #define PERL_ARGS_ASSERT_GV_STASHPVN \ assert(name) +PERL_CALLCONV HV * +Perl_gv_stashpvs_p(pTHX_ I32 flags, const char *name); +#define PERL_ARGS_ASSERT_GV_STASHPVS_P \ + assert(name) + PERL_CALLCONV HV * Perl_gv_stashsv(pTHX_ SV *sv, I32 flags); #define PERL_ARGS_ASSERT_GV_STASHSV \ @@ -6903,7 +6913,12 @@ PERL_CALLCONV HV * Perl_gv_stashsvpvn_cached(pTHX_ SV *namesv, const char *name, U32 namelen, I32 flags) __attribute__visibility__("hidden"); -#endif +PERL_CALLCONV HV * +Perl_gv_stashsvpvn_cached_p(pTHX_ I32 flags, void *namevp, ...); +# define PERL_ARGS_ASSERT_GV_STASHSVPVN_CACHED_P \ + assert(namevp) + +#endif /* defined(PERL_IN_GV_C) || defined(PERL_IN_UNIVERSAL_C) */ #if defined(PERL_IN_HV_C) STATIC void S_clear_placeholders(pTHX_ HV *hv, U32 items);