From 377b6827f718cad71f17dd8c374b62e413c7031a Mon Sep 17 00:00:00 2001 From: Daniel Dragan Date: Thu, 13 Feb 2025 12:17:54 -0500 Subject: [PATCH] add compact vararg impl gv_stashsvpvn_cached_p, add gv_stashhek All the code in gv.c, is very old and has gotten zero optimizing since 5.000 alpha. SV*s are instantly turned into PVNs on the front end instantly loosing and chance of [future] SVPV COW Shared HEK key string optimization. HEK*s are unknown to gv_* API. All inputs are continously parsed for ' and :: without exception, even if they are read only (SEGV) C literals or PP SvREADONLY() SvPROTECT() read only literals or API contract read only HEK* PV buffers. Returned from hv_store*() hv_fetch*(), HE*s, aren't exploited to pass the shared HEK* onto gv_init_*() or gv_name_set(), and gv_name_set() on front end only understands PVNs, but on backend, in the GP struct and GV body struct, ONLY understands HEK*s. Therefore no RC++, and looking up the ShHEK again in PL_strtab. The large amount of tiny extern exported symbols wrapper funs added over the years also causes C dbg call stacks even at -O1/-O2, to be 2-5 call frames deep of 3 line shims/stub functions before reaching the main logic. I can't tell what is a mathom and what isn't. So to lay provisions needed for future commits, that add proper SV*/HEK*/U32 hash precalculation, not to mention the memcmp() in hv_common() is skipped if left and right ptr addr are equal. The front end of gv_* needs cleanup. -move U32 flags to the start of the the func, so flags can encode details what void * #1 means, and if vararg void * #2 exists (PVN with N as size_t is only 2nd arg user right now). Since gv_stashpvs() is very common on core and CPAN, and called over and over in 1 proc, since most interp core and CPAN XS devs don't know GV*s have an RC that can be ++ed and stored in a MY_CXT struct. Also nobody knows "stashes" are HV*s or PP packages/classes are implimented with HV*s. So there is reason to pay extra attention to gv_stashpvs() b/c of its high usage/call sites per library. So if the STRLEN can be CC constant folded, and fits in a U8, store the length in the flags arg. Saves on CPU ops in all the callers to push 2 args, vs 3. Public API gv_stashpvs(str, create)'s create arg [flags in reality] can't be optimized away or removed, so combine the 2 CC time constant args, so they fold/optimize into 1 cpu op. -at some point perl core needs to cache/create/move around C level arrays of RC++ed ShHEKs to pass to the gv_*() APIs. SVPVs aren't exactly the right format for storing sanitized (no */::/'/SUPER/main/UNIVERSAL) and pre-parsed/splitted "package tokens", since SVs easily wind up or escape into PP-state, and SV RO flags/COW flags aren't the most honored and respected parts of the API by CPAN XS/maybe core. ShHEKs escaping into PP-state is rarer than "generic SVs" escaping into PP-state or CPAN XS state. All legacy XS code any quality and entry/beginner XS people, will pick "char *" getter macros vs an unknown opaque "HEK" type (and newSVpvn() to capture/move those char *s). Users who know what a HEK* is and how to RC++ it, know not to write to it. Also a bad write to a ShHEK will cause more PP or SEGV breakage/panics or proc exits, alot faster than a bad write to a SVfRO "SVPV" buffer. Hash doesn't match char string in a ShHEK will term the prc faster. So vararg on gv_*() is a provision for a future prototype, that accepts 1, 2, 3 or more HEK*s passed array style, that already were sanitized to not have ::s. 0xFF length was picked b/c there was bitfield space, shaving to 32/64/128 chars for gv_stashpvs(str, create) is possible if the bits are needed b/c a terminal is 80 chars, would fit almost all absolute ("::") C string package names, and everthing in core and CPAN. -the stubs remain as exported stub funcs, on purpose for now, it makes certain diag tools I use slightly easier to use vs optimized out inlines or macros. In 5.43 or 5.45 the exported stub funcs can be converted to macros no static inline, which is intent of this commit. The vararg is the 1 and only entry point to all of gv_stash* logic. -flipping I32 flags to the front requires "_p" suffixes for private for ABI reasons, public API still thinks I32 flags is always the last arg -since all front end wrappers, are 1-away from instead of multiple frames away, they are more likely to LTO inline away inside of libperl (not XS) on any CC. CCs have cost/benefit/wall time cut offs for scoring potential inlines opportunities. Going 2 layers, or 3+ layers of small inlines, is asking alot from a CC, that has to traverse a tree of nodes to do each inline, and the cut off could be as low as 1 inline fn and no more unrolling or folding. --- embed.fnc | 8 ++++ embed.h | 3 ++ gv.c | 111 ++++++++++++++++++++++++++++++++++++++++++++++++------ gv.h | 22 +++++++++++ handy.h | 8 +++- proto.h | 17 ++++++++- 6 files changed, 155 insertions(+), 14 deletions(-) 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);