From f7fcdd85d2cfd909f47463218d010b53d04968f7 Mon Sep 17 00:00:00 2001 From: Richard Leach Date: Wed, 23 Oct 2024 23:32:04 +0000 Subject: [PATCH 1/4] Perl_sv_setsv_flags: handle mixed IV and NV fast case When the fast code at the start of Perl_sv_setsv_flags was modified to also support bodyless NVs, the simplest possible change was made. However, this meant that there was no fast handling when one SV was an IV and the other a NV. Actually having this seems desirable since it avoids the need to allocate (and later release) an XPVIV or XPVNV body. --- sv.c | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/sv.c b/sv.c index b190a76be06b..a22b2e7d8c57 100644 --- a/sv.c +++ b/sv.c @@ -4201,7 +4201,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dsv, SV* ssv, const I32 flags) STATIC_ASSERT_STMT(SVt_IV == 1); STATIC_ASSERT_STMT(SVt_NV == 2); #if NVSIZE <= IVSIZE - if (both_type <= 2) { + if ((stype <= SVt_NV) & (dtype <= SVt_NV)) { #else if (both_type <= 1) { #endif @@ -4276,6 +4276,10 @@ Perl_sv_setsv_flags(pTHX_ SV *dsv, SV* ssv, const I32 flags) return; } +#if NVSIZE <= IVSIZE + both_type = (stype | dtype); +#endif + if (UNLIKELY(both_type == SVTYPEMASK)) { if (SvIS_FREED(dsv)) { Perl_croak(aTHX_ "panic: attempt to copy value %" SVf From 003dfa68325a4dd4eb46607a8375a2fbb7b6453a Mon Sep 17 00:00:00 2001 From: Richard Leach Date: Wed, 23 Oct 2024 23:57:10 +0000 Subject: [PATCH 2/4] Perl_sv_setsv_flags: remove unreachable NULL/IV/NV code The fast code at the top of Perl_sv_setsv_flags now handles all cases where both SVs are < SVt_NV / SVt_IV, depending on the size of NVs. This means that the subsequent code paths involving those combinations are unreachable and can be removed to streamline there function. Note: Doing this actually made a difference with gcc 12.2.0, which didn't seem to figure out that this was possible by itself. Similarly, sprinking some ASSUME() statements around didn't help. --- sv.c | 20 +++++++++++--------- 1 file changed, 11 insertions(+), 9 deletions(-) diff --git a/sv.c b/sv.c index a22b2e7d8c57..519c9ed9ca06 100644 --- a/sv.c +++ b/sv.c @@ -4310,17 +4310,15 @@ Perl_sv_setsv_flags(pTHX_ SV *dsv, SV* ssv, const I32 flags) break; case SVt_IV: if (SvIOK(ssv)) { + /* Bodiless-SV code above should have handled these cases */ + assert(dtype != SVt_NULL); +#if NVSIZE <= IVSIZE + assert(dtype != SVt_NV); +#endif switch (dtype) { - case SVt_NULL: - /* For performance, we inline promoting to type SVt_IV. */ - /* We're starting from SVt_NULL, so provided that define is - * actual 0, we don't have to unset any SV type flags - * to promote to SVt_IV. */ - STATIC_ASSERT_STMT(SVt_NULL == 0); - SET_SVANY_FOR_BODYLESS_IV(dsv); - SvFLAGS(dsv) |= SVt_IV; - break; +#if NVSIZE > IVSIZE case SVt_NV: +#endif case SVt_PV: sv_upgrade(dsv, SVt_PVIV); break; @@ -4341,17 +4339,21 @@ Perl_sv_setsv_flags(pTHX_ SV *dsv, SV* ssv, const I32 flags) } if (!SvROK(ssv)) goto undef_sstr; +#if NVSIZE > IVSIZE if (dtype < SVt_PV && dtype != SVt_IV) sv_upgrade(dsv, SVt_IV); +#endif break; case SVt_NV: if (LIKELY( SvNOK(ssv) )) { switch (dtype) { +#if NVSIZE > IVSIZE case SVt_NULL: case SVt_IV: sv_upgrade(dsv, SVt_NV); break; +#endif case SVt_PV: case SVt_PVIV: sv_upgrade(dsv, SVt_PVNV); From 84cebbce13a63bf847806558bc1e2a68f4bac7d0 Mon Sep 17 00:00:00 2001 From: Richard Leach Date: Mon, 28 Oct 2024 22:59:10 +0000 Subject: [PATCH 3/4] Perl_sv_setsv_flags: extract croaks to a cold helper function Perl_sv_setsv_flags has a number of fail-safe checks which will croak if triggered. However, these code paths are *really* cold - they aren't even hit by the test harness. Since they are so cold and always result in an immediate croak, they can be pulled out into an unoptimized helper function. This leaves Perl_sv_setsv_flags smaller and therefore more cache friendly. --- embed.fnc | 3 +++ embed.h | 1 + proto.h | 5 ++++ sv.c | 70 +++++++++++++++++++++++++++++++++++-------------------- 4 files changed, 54 insertions(+), 25 deletions(-) diff --git a/embed.fnc b/embed.fnc index 7792a28e7a3c..9c0cf9542547 100644 --- a/embed.fnc +++ b/embed.fnc @@ -5811,6 +5811,9 @@ S |void |assert_uft8_cache_coherent \ |STRLEN from_cache \ |STRLEN real \ |NN SV * const sv +S |void |croak_sv_setsv_flags \ + |NN SV * const dsv \ + |NN SV * const ssv S |bool |curse |NN SV * const sv \ |const bool check_refcnt RS |STRLEN |expect_number |NN const char ** const pattern diff --git a/embed.h b/embed.h index dfcc4f4881e6..245c80152f8f 100644 --- a/embed.h +++ b/embed.h @@ -2157,6 +2157,7 @@ # define F0convert S_F0convert # define anonymise_cv_maybe(a,b) S_anonymise_cv_maybe(aTHX_ a,b) # define assert_uft8_cache_coherent(a,b,c,d) S_assert_uft8_cache_coherent(aTHX_ a,b,c,d) +# define croak_sv_setsv_flags(a,b) S_croak_sv_setsv_flags(aTHX_ a,b) # define curse(a,b) S_curse(aTHX_ a,b) # define expect_number(a) S_expect_number(aTHX_ a) # define find_array_subscript(a,b) S_find_array_subscript(aTHX_ a,b) diff --git a/proto.h b/proto.h index 32e8d48f4fa7..6b29f958b223 100644 --- a/proto.h +++ b/proto.h @@ -8923,6 +8923,11 @@ S_assert_uft8_cache_coherent(pTHX_ const char * const func, STRLEN from_cache, S # define PERL_ARGS_ASSERT_ASSERT_UFT8_CACHE_COHERENT \ assert(func); assert(sv) +STATIC void +S_croak_sv_setsv_flags(pTHX_ SV * const dsv, SV * const ssv); +# define PERL_ARGS_ASSERT_CROAK_SV_SETSV_FLAGS \ + assert(dsv); assert(ssv) + STATIC bool S_curse(pTHX_ SV * const sv, const bool check_refcnt); # define PERL_ARGS_ASSERT_CURSE \ diff --git a/sv.c b/sv.c index 519c9ed9ca06..36131608315e 100644 --- a/sv.c +++ b/sv.c @@ -4275,24 +4275,17 @@ Perl_sv_setsv_flags(pTHX_ SV *dsv, SV* ssv, const I32 flags) SvREFCNT_dec(old_rv); return; } - +/* #if NVSIZE <= IVSIZE both_type = (stype | dtype); #endif - +*/ if (UNLIKELY(both_type == SVTYPEMASK)) { - if (SvIS_FREED(dsv)) { - Perl_croak(aTHX_ "panic: attempt to copy value %" SVf - " to a freed scalar %p", SVfARG(ssv), (void *)dsv); - } - if (SvIS_FREED(ssv)) { - Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p to %p", - (void*)ssv, (void*)dsv); - } + croak_sv_setsv_flags(dsv, ssv); + NOT_REACHED; } - SV_CHECK_THINKFIRST_COW_DROP(dsv); dtype = SvTYPE(dsv); /* THINKFIRST may have changed type */ @@ -4390,14 +4383,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dsv, SV* ssv, const I32 flags) invlist_clone(ssv, dsv); return; default: - { - const char * const type = sv_reftype(ssv,0); - if (PL_op) - /* diag_listed_as: Bizarre copy of %s */ - Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_DESC(PL_op)); - else - Perl_croak(aTHX_ "Bizarre copy of %s", type); - } + croak_sv_setsv_flags(dsv, ssv); NOT_REACHED; /* NOTREACHED */ case SVt_REGEXP: @@ -4451,12 +4437,8 @@ Perl_sv_setsv_flags(pTHX_ SV *dsv, SV* ssv, const I32 flags) else if (UNLIKELY(dtype == SVt_PVAV || dtype == SVt_PVHV || dtype == SVt_PVFM)) { - const char * const type = sv_reftype(dsv,0); - if (PL_op) - /* diag_listed_as: Cannot copy to %s */ - Perl_croak(aTHX_ "Cannot copy to %s in %s", type, OP_DESC(PL_op)); - else - Perl_croak(aTHX_ "Cannot copy to %s", type); + croak_sv_setsv_flags(dsv, ssv); + NOT_REACHED; } else if (sflags & SVf_ROK) { if (isGV_with_GP(dsv) && SvTYPE(SvRV(ssv)) == SVt_PVGV && isGV_with_GP(SvRV(ssv))) { @@ -17736,6 +17718,44 @@ Perl_report_uninit(pTHX_ const SV *uninit_sv) GCC_DIAG_RESTORE_STMT; } +/* This helper function for Perl_sv_setsv_flags is as cold as they come. + * We should almost never call it and it will definitely croak when we do. + * Therefore it should not matter that it is not close to the main function + * or that we make it redo work that the caller already did. + * The main aim is to keep Perl_sv_setsv_flags as slim as possible and this + * includes keeping the call sites for this function small. + */ +void S_croak_sv_setsv_flags(pTHX_ SV * const dsv, SV * const ssv) +{ + OP *op = PL_op; + if (SvIS_FREED(dsv)) { + Perl_croak(aTHX_ "panic: attempt to copy value %" SVf + " to a freed scalar %p", SVfARG(ssv), (void *)dsv); + } + if (SvIS_FREED(ssv)) { + Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p to %p", + (void*)ssv, (void*)dsv); + } + + if (SvTYPE(ssv) > SVt_PVLV) + { + const char * const type = sv_reftype(ssv,0); + if (op) + /* diag_listed_as: Bizarre copy of %s */ + Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_DESC(op)); + else + Perl_croak(aTHX_ "Bizarre copy of %s", type); + } + + const char * const type = sv_reftype(dsv,0); + if (op) + /* diag_listed_as: Cannot copy to %s */ + Perl_croak(aTHX_ "Cannot copy to %s in %s", type, OP_DESC(op)); + else + Perl_croak(aTHX_ "Cannot copy to %s", type); + +} + /* * ex: set ts=8 sts=4 sw=4 et: */ From c0d317f790e54b53c0a83be5025587d2dbfb67b0 Mon Sep 17 00:00:00 2001 From: Richard Leach Date: Wed, 6 Nov 2024 23:44:35 +0000 Subject: [PATCH 4/4] perldelta entry for Perl_sv_setsv_flags changes --- pod/perldelta.pod | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/pod/perldelta.pod b/pod/perldelta.pod index d53738408312..f29ad829ba99 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -503,6 +503,19 @@ L|perlapi/valid_identifier_pvn> and L|perlapi/valid_identifier_sv> have been added, which test if a string would be considered by Perl to be a valid identifier name. +=item * + +When assigning from an SVt_IV into a SVt_NV (or vice versa), providing that +both are "bodyless" types, Perl_sv_setsv_flags will now just change the +destination type to match the source type. Previously, an SVt_IV would have +been upgraded to a SVt_PVNV to store an NV, and an SVt_NV would have been +upgraded to a SVt_PVIV to store an IV. This change prevents the need to +allocate - and later free - the relevant body struct. + +=item * + +XXX + =back =head1 Selected Bug Fixes