diff --git a/av.c b/av.c index 7e21f220bf9d..0f41f60bfca3 100644 --- a/av.c +++ b/av.c @@ -475,6 +475,8 @@ Perl_av_make(pTHX_ SSize_t size, SV **strp) AvALLOC(av) = ary; AvARRAY(av) = ary; AvMAX(av) = size - 1; + SSize_t *fillp = &AvFILLp(av); + /* avoid av being leaked if croak when calling magic below */ EXTEND_MORTAL(1); PL_tmps_stack[++PL_tmps_ix] = (SV*)av; @@ -486,12 +488,8 @@ Perl_av_make(pTHX_ SSize_t size, SV **strp) /* Don't let sv_setsv swipe, since our source array might have multiple references to the same temp scalar (e.g. from a list slice) */ - - SvGETMAGIC(*strp); /* before newSV, in case it dies */ - AvFILLp(av)++; - ary[i] = newSV_type(SVt_NULL); - sv_setsv_flags(ary[i], *strp, - SV_DO_COW_SVSETSV|SV_NOSTEAL); + ary[i] = newSVsv_flags(*strp, SV_DO_COW_SVSETSV|SV_NOSTEAL|SV_GMAGIC); + *fillp = i; strp++; } /* disarm av's leak guard */ diff --git a/embed.fnc b/embed.fnc index fbe1aef0179a..a09f7e27b448 100644 --- a/embed.fnc +++ b/embed.fnc @@ -2347,7 +2347,10 @@ ARdp |OP * |newSVREF |NN OP *o Adp |SV * |newSVrv |NN SV * const rv \ |NULLOK const char * const classname ARdmp |SV * |newSVsv |NULLOK SV * const old -ARdp |SV * |newSVsv_flags |NULLOK SV * const old \ +ARdip |SV * |newSVsv_flags |NULLOK SV * const old \ + |I32 flags +ARdp |SV * |newSVsv_flags_NN \ + |NN SV * const old \ |I32 flags ARdmp |SV * |newSVsv_nomg |NULLOK SV * const old ARdp |SV * |newSV_true diff --git a/embed.h b/embed.h index ae046a6173e8..fcb30ae46601 100644 --- a/embed.h +++ b/embed.h @@ -462,6 +462,7 @@ # define newSVpvz(a) Perl_newSVpvz(aTHX_ a) # define newSVrv(a,b) Perl_newSVrv(aTHX_ a,b) # define newSVsv_flags(a,b) Perl_newSVsv_flags(aTHX_ a,b) +# define newSVsv_flags_NN(a,b) Perl_newSVsv_flags_NN(aTHX_ a,b) # define newSVuv(a) Perl_newSVuv(aTHX_ a) # define newTRYCATCHOP(a,b,c,d) Perl_newTRYCATCHOP(aTHX_ a,b,c,d) # define newUNOP(a,b,c) Perl_newUNOP(aTHX_ a,b,c) diff --git a/pod/perldelta.pod b/pod/perldelta.pod index 855bfe34da52..1dc2359198d4 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -423,6 +423,19 @@ memory saving is unrealistic. C now substitutes the Unicode REPLACEMENT CHARACTER for malformed input. Previously it used the NUL character. +=item * + +L> is a new function for creating a new SV +and assigning the value(s) of an existing SV to it. + +Historically, C and C would +pass a new SV head and the original SV to C. However, +the latter contains many branches of no relevance to a fresh SV, so they +now make use of the new function to streamline the process. + +C is now essentially a NULL pointer check and wrapper +around the new function, so has been moved into F. + =back =head1 Selected Bug Fixes diff --git a/pp.c b/pp.c index 189b2ddbdd34..a98489ccd26f 100644 --- a/pp.c +++ b/pp.c @@ -6419,10 +6419,11 @@ PP(pp_push) PL_delaymagic = DM_DELAY; for (++MARK; MARK <= PL_stack_sp; MARK++) { SV *sv; - if (*MARK) SvGETMAGIC(*MARK); - sv = newSV_type(SVt_NULL); - if (*MARK) - sv_setsv_nomg(sv, *MARK); + if (*MARK) { + sv = newSVsv_flags(*MARK, SV_DO_COW_SVSETSV|SV_GMAGIC); + } else + sv = newSV_type(SVt_NULL); + av_store(ary, AvFILLp(ary)+1, sv); } if (PL_delaymagic & DM_ARRAY_ISA) diff --git a/pp_ctl.c b/pp_ctl.c index bd83bd2fbd69..1d8a45dceb29 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -4418,13 +4418,11 @@ S_doopen_pm(pTHX_ SV *name) return NULL; if (memENDPs(p, namelen, ".pm")) { - SV *const pmcsv = sv_newmortal(); - PerlIO * pmcio; + SV *const pmcsv = sv_mortalcopy_flags(name, SV_GMAGIC|SV_NOSTEAL|SV_DO_COW_SVSETSV); - SvSetSV_nosteal(pmcsv,name); sv_catpvs(pmcsv, "c"); - pmcio = check_type_and_open(pmcsv); + PerlIO * pmcio = check_type_and_open(pmcsv); if (pmcio) return pmcio; } @@ -4816,8 +4814,7 @@ S_require_file(pTHX_ SV *sv) } if (SvPADTMP(nsv)) { - nsv = sv_newmortal(); - SvSetSV_nosteal(nsv,sv); + nsv = sv_mortalcopy_flags(sv, SV_GMAGIC|SV_NOSTEAL|SV_DO_COW_SVSETSV); } const char *method = NULL; diff --git a/pp_hot.c b/pp_hot.c index 3f6cd29611bc..e4b2e4d9f855 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -5374,8 +5374,7 @@ PP(pp_subst) if (dstr) { /* replacement needing upgrading? */ if (DO_UTF8(TARG) && !doutf8) { - nsv = sv_newmortal(); - SvSetSV(nsv, dstr); + nsv = sv_mortalcopy_flags(dstr, SV_GMAGIC|SV_DO_COW_SVSETSV); sv_utf8_upgrade(nsv); c = SvPV_const(nsv, clen); doutf8 = TRUE; diff --git a/proto.h b/proto.h index 6e4ae660c7bf..b3571a169e70 100644 --- a/proto.h +++ b/proto.h @@ -3171,9 +3171,10 @@ Perl_newSVsv(pTHX_ SV * const old) __attribute__warn_unused_result__; */ PERL_CALLCONV SV * -Perl_newSVsv_flags(pTHX_ SV * const old, I32 flags) +Perl_newSVsv_flags_NN(pTHX_ SV * const old, I32 flags) __attribute__warn_unused_result__; -#define PERL_ARGS_ASSERT_NEWSVSV_FLAGS +#define PERL_ARGS_ASSERT_NEWSVSV_FLAGS_NN \ + assert(old) /* PERL_CALLCONV SV * Perl_newSVsv_nomg(pTHX_ SV * const old) @@ -9921,6 +9922,11 @@ Perl_newSV_type_mortal(pTHX_ const svtype type) __attribute__always_inline__; # define PERL_ARGS_ASSERT_NEWSV_TYPE_MORTAL +PERL_STATIC_INLINE SV * +Perl_newSVsv_flags(pTHX_ SV * const old, I32 flags) + __attribute__warn_unused_result__; +# define PERL_ARGS_ASSERT_NEWSVSV_FLAGS + PERL_STATIC_INLINE SV * Perl_new_sv(pTHX_ const char *file, int line, const char *func); # define PERL_ARGS_ASSERT_NEW_SV \ diff --git a/sv.c b/sv.c index 746bd713d8c6..37fda93b2e2e 100644 --- a/sv.c +++ b/sv.c @@ -4216,6 +4216,28 @@ S_sv_buf_to_rw(pTHX_ SV *sv) && len /* and really is a string */ \ ) +/* The test in this macro was also extracted from Perl_sv_setsv_flags so + * that it could be used elsewhere. */ +#ifdef PERL_COPY_ON_WRITE +#define S_SvPV_shared_hkey_or_CoWable(ssv, dsv, sflags, cur, len) \ + (sflags & SVf_IsCOW \ + ? (!len || \ + ( (CHECK_COWBUF_THRESHOLD(cur,len) || SvLEN(dsv) < cur+1) \ + /* If this is a regular (non-hek) COW, only so */ \ + /* many COW "copies" are possible. */ \ + && CowREFCNT(ssv) != SV_COW_REFCNT_MAX )) \ + : ( (sflags & CAN_COW_MASK) == CAN_COW_FLAGS \ + && !(SvFLAGS(dsv) & SVf_BREAK) \ + && CHECK_COW_THRESHOLD(cur,len) && cur+1 < len \ + && (CHECK_COWBUF_THRESHOLD(cur,len) || SvLEN(dsv) < cur+1) \ + )) +#else +#define S_SvPV_shared_hkey_or_CoWable(ssv, dsv, sflags, cur, len) \ + ( sflags & SVf_IsCOW \ + && !(SvFLAGS(dsv) & SVf_BREAK) \ + ) +#endif + /* Perl_sv_can_swipe_pv_buf was originally created for pp_reverse. */ bool Perl_sv_can_swipe_pv_buf(pTHX_ SV *sv) @@ -4317,25 +4339,19 @@ Perl_sv_setsv_flags(pTHX_ SV *dsv, SV* ssv, const I32 flags) /* Should preserve some dsv flags - at least SVs_TEMP, */ /* so cannot just set SvFLAGS(dsv) = new_dflags */ /* First clear the flags that we do want to clobber */ - (void)SvOK_off(dsv); - SvFLAGS(dsv) &= ~SVTYPEMASK; + SvFLAGS(dsv) &= ~(SVTYPEMASK|SVf_OK|SVf_IVisUV); /* Now set the new flags */ SvFLAGS(dsv) |= new_dflags; SvREFCNT_dec(old_rv); return; } -/* -#if NVSIZE <= IVSIZE - both_type = (stype | dtype); -#endif -*/ + if (UNLIKELY(both_type == SVTYPEMASK)) { croak_sv_setsv_flags(dsv, ssv); NOT_REACHED; } - SV_CHECK_THINKFIRST_COW_DROP(dsv); dtype = SvTYPE(dsv); /* THINKFIRST may have changed type */ @@ -4627,9 +4643,9 @@ Perl_sv_setsv_flags(pTHX_ SV *dsv, SV* ssv, const I32 flags) * */ - /* Whichever path we take through the next code, we want this true, - and doing it now facilitates the COW check. */ - (void)SvPOK_only(dsv); + (void)SvOK_off(dsv); + SvFLAGS(dsv) |= sflags & + (SVf_POK|SVp_POK|SVf_IOK|SVp_IOK|SVf_IVisUV|SVf_NOK|SVp_NOK|SVf_UTF8); if ( !(flags & SV_NOSTEAL) && S_SvPV_can_swipe_buf(ssv, sflags, cur, len) ) { /* Passes the swipe test. */ @@ -4640,7 +4656,11 @@ Perl_sv_setsv_flags(pTHX_ SV *dsv, SV* ssv, const I32 flags) SvCUR_set(dsv, SvCUR(ssv)); SvTEMP_off(dsv); - (void)SvOK_off(ssv); /* NOTE: nukes most SvFLAGS on ssv */ + + assert(!SvOOK(ssv)); /* According to S_SvPV_can_swipe_buf() */ + /* NOTE: nukes most SvFLAGS on ssv */ + SvFLAGS(ssv) &= ~(SVf_OK|SVf_IVisUV|SVf_UTF8); + SvPV_set(ssv, NULL); SvLEN_set(ssv, 0); SvCUR_set(ssv, 0); @@ -4658,25 +4678,8 @@ Perl_sv_setsv_flags(pTHX_ SV *dsv, SV* ssv, const I32 flags) SvCUR_set(dsv, cur); SvFLAGS(dsv) |= (SVf_IsCOW|SVppv_STATIC); } - else if (flags & SV_COW_SHARED_HASH_KEYS - && -#ifdef PERL_COPY_ON_WRITE - (sflags & SVf_IsCOW - ? (!len || - ( (CHECK_COWBUF_THRESHOLD(cur,len) || SvLEN(dsv) < cur+1) - /* If this is a regular (non-hek) COW, only so - many COW "copies" are possible. */ - && CowREFCNT(ssv) != SV_COW_REFCNT_MAX )) - : ( (sflags & CAN_COW_MASK) == CAN_COW_FLAGS - && !(SvFLAGS(dsv) & SVf_BREAK) - && CHECK_COW_THRESHOLD(cur,len) && cur+1 < len - && (CHECK_COWBUF_THRESHOLD(cur,len) || SvLEN(dsv) < cur+1) - )) -#else - sflags & SVf_IsCOW - && !(SvFLAGS(dsv) & SVf_BREAK) -#endif - ) { + else if ((flags & SV_COW_SHARED_HASH_KEYS) && + S_SvPV_shared_hkey_or_CoWable(ssv, dsv, sflags, cur, len)){ /* Either it's a shared hash key, or it's suitable for copy-on-write. */ #ifdef DEBUGGING @@ -4735,22 +4738,20 @@ Perl_sv_setsv_flags(pTHX_ SV *dsv, SV* ssv, const I32 flags) affected by the numeric locale, hence we can cache the stringification. Currently that's +Inf, -Inf and NaN, but conceivably we might extend this to -9 .. +9 (excluding -0). - So mark destination the same: */ - SvFLAGS(dsv) &= ~SVf_POK; + So confirm the destination doesn't have SVf_POK set. */ + assert(!(SvFLAGS(dsv) & SVf_POK)); } } if (sflags & SVp_IOK) { SvIV_set(dsv, SvIVX(ssv)); - if (sflags & SVf_IVisUV) - SvIsUV_on(dsv); if ((sflags & SVf_IOK) && !(sflags & SVf_POK)) { /* Source was SVf_IOK|SVp_IOK|SVp_POK but not SVf_POK, meaning - a value set as an integer and later stringified. So mark - destination the same: */ - SvFLAGS(dsv) &= ~SVf_POK; + a value set as an integer and later stringified. So confirm + the destination doesn't have SVf_POK set. */ + assert(!(SvFLAGS(dsv) & SVf_POK)); } } - SvFLAGS(dsv) |= sflags & (SVf_IOK|SVp_IOK|SVf_NOK|SVp_NOK|SVf_UTF8); + { const char *vstr_pv; STRLEN vstr_len; @@ -4782,6 +4783,442 @@ Perl_sv_setsv_flags(pTHX_ SV *dsv, SV* ssv, const I32 flags) SvTAINT(dsv); } +/* A helper for newSVsv_flags_NN, which does the heavy lifting for + * newSVsv_flags and sv_mortalcopy_flags. This helper function implements + * the swipe/COW/copy operation on pOK SVs. + * The code should heavily track the equivalent code in Perl_sv_setsv_flags, + * and some more detailed comments can be found there. However, this code has + * a number of specific divergences: + * * "dsv" is a newly minted SV, so no need to handle existing buffers + * * similarly, no need to check for the OOK hack + * * The SVppv_STATIC case is not handled here, as it (at time of writing) + * only applies to SVt_PVNVs and the hottest "dsv" path is for SVt_PVs. + * The missing case is implemented in S_newSVsv_flags_NN_PVxx. + * This function is marked for inlining, also to benefit the hot SVt_PV case. + * + * [%] numbers are a rough percentage of calls to this function, as + * measured by a gcov build running the test harness. They are presented + * only for general information and will not be representative of all + * workloads or applications. + */ +PERL_STATIC_FORCE_INLINE SV* +S_newSVsv_flags_NN_POK(pTHX_ SV* dsv, SV* ssv, const I32 flags) +{ + /* SvLEN, SvCUR, SvPVX for dsv are all uninitialized at this point */ + + const U32 sflags = SvFLAGS(ssv); + const STRLEN cur = SvCUR(ssv); + const STRLEN len = SvLEN(ssv); + + assert(!SvIsCOW_static(ssv)); /* SVppv_STATIC: see newSVsv_flags_NN_PVxx */ + + if (!(flags & SV_NOSTEAL) && + UNLIKELY(S_SvPV_can_swipe_buf(ssv, sflags, cur, len)) ) { + /* [ <1% ] */ + /* Passes the swipe test. */ + char * buf = SvPVX_mutable(ssv); + SvLEN_set(dsv, len); + SvCUR_set(dsv, cur); + SvPV_set(dsv, buf); + + assert(!SvOOK(ssv)); /* According to S_SvPV_can_swipe_buf() */ + /* (void)SvOK_off(ssv); but without the superfluous SvOOK_off(ssv)) */ + SvFLAGS(ssv) &= ~(SVf_OK|SVf_IVisUV|SVf_UTF8|SVs_TEMP); + + SvPV_set(ssv, NULL); + SvLEN_set(ssv, 0); + SvCUR_set(ssv, 0); + return dsv; + } + + /* S_SvPV_shared_hkey_or_CoWable() needs an accurate SvLEN(dsv) */ + SvLEN_set(dsv, 0); + + ASSUME(!(SvFLAGS(dsv) & SVf_BREAK)); + + if ((flags & SV_COW_SHARED_HASH_KEYS) && + S_SvPV_shared_hkey_or_CoWable(ssv, dsv, sflags, cur, len) + ) { /* [ 47% ] */ + /* Either it's a shared hash key, or it's suitable for + copy-on-write. */ +#ifdef DEBUGGING + if (DEBUG_C_TEST) { + PerlIO_printf(Perl_debug_log, "Copy on write: ssv --> dsv\n"); + sv_dump(ssv); + sv_dump(dsv); + } +#endif +#ifdef PERL_ANY_COW + if (!(sflags & SVf_IsCOW)) { + SvIsCOW_on(ssv); + CowREFCNT(ssv) = 0; + } + + if (LIKELY(len)) { /* [ 43% ] */ + if (sflags & SVf_IsCOW) { + sv_buf_to_rw(ssv); + } + CowREFCNT(ssv)++; + SvPV_set(dsv, SvPVX_mutable(ssv)); + sv_buf_to_ro(ssv); + } else +#endif + { /* [ 4%] */ + /* SvIsCOW_shared_hash */ + DEBUG_C(PerlIO_printf(Perl_debug_log, + "Copy on write: Sharing hash\n")); + SvPV_set(dsv, + HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(ssv))))); + } + SvLEN_set(dsv, len); + SvIsCOW_on(dsv); + } else { /* [ 52% ] */ + /* Failed the swipe test, and we cannot do copy-on-write either. + Have to copy the string. */ + +#ifdef DEBUGGING + /* Perl_sv_grow_fresh asserts that cur == 0 + * but doesn't actually need it to. */ + SvCUR_set(dsv, 0); +#endif + char * dsvpvx = sv_grow_fresh(dsv, cur + 1); + + ASSUME(SvPVX_const(ssv) != SvPVX(dsv)); + *(dsvpvx + cur) = 0; + Copy(SvPVX_const(ssv),dsvpvx,cur,char); + } + SvCUR_set(dsv, cur); + return dsv; +} + +/* S_newSVsv_flags_NN_PVxx mainly handles source SV types above SVt_PV + * for Perl_newSVsv_flags_NN. This function may get inlined, even + * though it might be preferable if it didn't. + * + * Notes: it is the caller's responsibility to check GET magic. + * Perl_sv_setsv_flags essentially ignores magic, except for + * taint and vstring magic, which are also handled here. + * + * [%] numbers are a rough percentage of calls to this function, as + * measured by a gcov build running the test harness. They are presented + * only for general information and will not be representative of all + * workloads or applications. + */ + +static SV* +S_newSVsv_flags_NN_PVxx(pTHX_ SV* dsv, SV* ssv, const I32 flags) +{ + assert(ssv); + assert(dsv); + + svtype stype = SvTYPE(ssv); + U32 sflags = SvFLAGS(ssv); + + /* Only an SV head has been allocated */ + assert(SvTYPE(dsv) == SVt_NULL); + assert(!SvANY(dsv)); + + switch(stype) { + case SVt_PV: /* [ <0.1% ] */ + { + SvANY(dsv) = new_XPV(); + SV* svrv = NULL; + if (SvROK(ssv) ) { + svrv = SvREFCNT_inc(SvRV(ssv)); + SvFLAGS(dsv) = SVt_PV|SVf_ROK; + } else { + assert(!SvPOK(ssv)); + SvFLAGS(dsv) = SVt_PV; + } + SvRV_set(dsv, svrv); + SvCUR_set(dsv, 0); + SvLEN_set(dsv, 0); + return dsv; + } + case SVt_PVIV: /* [ 9% ] */ + SvANY(dsv) = new_XPVIV(); + SvFLAGS(dsv) = SVt_PVIV; + break; + case SVt_PVNV: /* [ 15 %] */ + SvANY(dsv) = new_XPVNV(); + SvFLAGS(dsv) = SVt_PVNV; + break; + case SVt_PVMG: /* [ 71% ] */ + if (flags & SV_GMAGIC && SvGMAGICAL(ssv)) + goto call_sv_setsv_flags; + + SvANY(dsv) = new_XPVMG(); + SvFLAGS(dsv) = SVt_PVMG; + SvMAGIC(dsv) = NULL; + SvSTASH(dsv) = NULL; + break; + default: /* [ 4% ] */ + if (flags & SV_GMAGIC && SvGMAGICAL(ssv)) { /* [ 3.5% ] */ + call_sv_setsv_flags: + /* Avoid dsv being leaked if SvGETMAGIC croaks. */ + EXTEND_MORTAL(1); + PL_tmps_stack[++PL_tmps_ix] = dsv; + SSize_t orig_ix = PL_tmps_ix; + + SvGETMAGIC(ssv); + /* If we made it, disarm the leak guard */ + if (LIKELY(PL_tmps_ix == orig_ix)) + PL_tmps_ix--; + else + PL_tmps_stack[orig_ix] = &PL_sv_undef; + } + sv_setsv_flags(dsv, ssv, flags & ~SV_GMAGIC); + return dsv; + case SVt_INVLIST: /* [ <<< 0.1% ] */ + invlist_clone(ssv, dsv); + return dsv; + /* The following cases seem relatively rare, so have been kept out of + * Perl_newSVsv_flags_NN. */ + case SVt_IV: /* [ 0.1% ] */ + SET_SVANY_FOR_BODYLESS_IV(dsv); + if (SvROK(ssv) ) { /* SVprv_WEAKREF */ +#if defined (DEBUGGING) || defined (PERL_DEBUG_COW) + dsv->sv_u.svu_rv = SvREFCNT_inc(SvRV(ssv)); +#else + dsv->sv_u.svu_rv = SvREFCNT_inc( ssv->sv_u.svu_rv ); +#endif + SvFLAGS(dsv) = SVt_IV|SVf_ROK; + } else { + assert(!SvOK(ssv)); + SvFLAGS(dsv) = SVt_IV; + } + return dsv; + case SVt_NV: /* [ <<< 1% ] */ + assert(!SvOK(ssv)); +#if NVSIZE <= IVSIZE + SET_SVANY_FOR_BODYLESS_NV(dsv); +#else + SvANY(dsv) = new_XNV(); +#endif + SvFLAGS(dsv) = SVt_NV; + return dsv; + } + assert(SvTYPE(dsv) == SVt_PVIV || SvTYPE(dsv) == SVt_PVNV || SvTYPE(dsv) == SVt_PVMG); + + /* [ 92.5% of calls to this function made it here. ] */ + + /* This is the only place we set dsv's flags, with the exception + of SVf_IsCOW, which can't be on for S_newSVsv_flags_NN_POK */ + SvFLAGS(dsv) |= sflags & ( + SVf_IOK|SVp_IOK|SVf_IVisUV|SVf_NOK|SVp_NOK + |SVf_ROK|SVf_POK|SVp_POK|SVf_UTF8|SVppv_STATIC + ); + + SvPV_set(dsv, NULL); + SvCUR_set(dsv, 0); + SvLEN_set(dsv, 0); + + switch(sflags & (SVp_IOK|SVp_NOK|SVf_ROK|SVp_POK|SVf_FAKE|SVppv_STATIC)) { + case SVp_IOK: /* [ 50% ]*/ + SvIV_set(dsv, SvIVX(ssv)); + return dsv; + case SVp_POK|SVp_IOK|SVp_NOK: /* [ 3% ] */ + ASSUME(SvTYPE(dsv) != SVt_PVIV); + SvNV_set(dsv, SvNVX(ssv)); + /* FALLTHROUGH */ + case SVp_POK|SVp_IOK: /* [ 7% ] */ + SvIV_set(dsv, SvIVX(ssv)); + break; + case SVp_POK: /* [ 28% ] */ + break; + case SVp_POK|SVp_IOK|SVp_NOK|SVppv_STATIC: /* [ 6.5% ]*/ + /* e.g. PL_sv_yes, PL_sv_no */ + ASSUME(!(SvFLAGS(dsv) & SVf_BREAK)); + ASSUME(SvTYPE(dsv) >= SVt_PVNV); + SvFLAGS(dsv) |= SVf_IsCOW; + + SvPV_set(dsv, SvPVX(ssv)); + SvCUR_set(dsv, SvCUR(ssv)); + + SvIV_set(dsv, SvIVX(ssv)); + SvNV_set(dsv, SvNVX(ssv)); + return dsv; + case SVp_POK|SVp_NOK: /* [ 3% ]*/ + SvNV_set(dsv, SvNVX(ssv)); + break; + case SVf_ROK: /* [ 3% ]*/ + SvRV_set(dsv, SvREFCNT_inc(SvRV(ssv))); + return dsv; + default: /* [ 2% ]*/ + if(!SvOK(ssv)) /* [ ~2% ]*/ + return dsv; + /* Some cases seem so rare that we may as well let + * sv_setsv_flags deal with them. For example: + * SVp_IOK|SVp_NOK + * + * Some cases are (currently) not naturally occurring: + * SVp_POK|SVppv_STATIC + * SVp_POK|SVp_IOK|SVppv_STATIC + * SVp_POK|SVp_NOK|SVppv_STATIC + * + * Other cases are also rare but also trickier to handle, + * so keeps this function smaller to not even try. */ + sv_setsv_flags(dsv,ssv,flags); + return dsv; + case SVp_NOK: /* [ << 1% ]*/ + ASSUME(SvTYPE(dsv) != SVt_PVIV); + SvNV_set(dsv, SvNVX(ssv)); + return dsv; + } + assert(SVp_POK); /* All other cases should have returned */ + + S_newSVsv_flags_NN_POK(aTHX_ dsv, ssv, flags); + + if ( (sflags & (SVf_NOK|SVf_IOK)) && !(sflags & SVf_POK) ) { + /* ssv was assigned a numerical value that was later + * stringified, where the value isn't affected by the + * numeric locale and therefore its stringification can + * be cached. See the original checks in Perl_sv_setsv_flags + * for more information. The main point is that the + * SVf_POK should not have been set on dsv either and so + * we assert that here. */ + assert(!(SvFLAGS(dsv) & SVf_POK)); + } + + { + const char *vstr_pv; + STRLEN vstr_len; + if ((vstr_pv = SvVSTRING(ssv, vstr_len))) { /* [ <<< 1% ] */ + sv_magic(dsv, NULL, PERL_MAGIC_vstring, vstr_pv, vstr_len); + SvRMAGICAL_on(dsv); + } + } + if (SvTAINTED(ssv)) /* [ <<< 1% ] */ + SvTAINT(dsv); + return dsv; +} + +/* +=for apidoc newSVsv_flags_NN + +This creates a new SV which contains the values of the original SV. + +It does the bulk of the work for C and C. +Less common cases are passed to C. + +This function accepts the same flags as C, with the single +addition of C, which toggles the treatment of a freed source SV: + * Not present: emulate C by emitting a warning and + returning NULL. + * Present: emulate C behaviour: C. + +=cut +*/ + + /* Note: If a PVIV/PVNV/PVMG is only IOK, NOK, ROK, it is _mostly_ + * possible to create just a headless SV to store that value. + * Some parts of core (Perl_amagic_call in gv.c specifically) do + * assume - and possibly CPAN might - that SvTYPE(dsv) == SvTYPE(ssv) + * though, which is why the code below does not try that type + * simplification. Perhaps this might be worth revisiting in the future. + * -- April 2025. */ +/* + * [%] numbers are a rough percentage of calls to this function, as + * measured by a gcov build running the test harness. They are presented + * only for general information and will not be representative of all + * workloads or applications. +*/ + +SV * +Perl_newSVsv_flags_NN(pTHX_ SV *const old, I32 flags) +{ + PERL_ARGS_ASSERT_NEWSVSV_FLAGS_NN; + SV *dsv; + new_SV(dsv); + + /* new_SV includes default initialization of SvFLAGS and SvANY. + * However, the SVt_IV cases in the switch below are both very common + * and very simple. If we initialize for those cases, a decent compiler + * will hopefully elide new_SVs defaults so no extra work is done. + * For all other cases, SvANY and SvFLAGS will be overwritten anyway. */ + SET_SVANY_FOR_BODYLESS_IV(dsv); + SvFLAGS(dsv) = SVt_IV|SVf_IOK|SVp_IOK; + + const U32 sflags = SvFLAGS(old); + + /* These are the hottest and simplest cases */ + switch( sflags & (SVTYPEMASK|SVf_IOK|SVf_IVisUV|SVf_ROK|SVf_NOK|SVf_POK) ) { + case SVt_IV|SVf_IOK: /* [ 31% ] */ + assert(SvANY(dsv)); + assert(SvFLAGS(dsv) == (SVt_IV|SVf_IOK|SVp_IOK) ); + + assert( &(old->sv_u.svu_iv) + == &(((XPVIV*) SvANY(old))->xiv_iv)); + assert( &(dsv->sv_u.svu_iv) + == &(((XPVIV*) SvANY(dsv))->xiv_iv)); + dsv->sv_u.svu_iv = old->sv_u.svu_iv; + break; + case SVt_IV|SVf_ROK: /* [ 11% ] */ + assert(SvANY(dsv)); + SvFLAGS(dsv) = SVt_IV|SVf_ROK; +#if defined (DEBUGGING) || defined (PERL_DEBUG_COW) + dsv->sv_u.svu_rv = SvREFCNT_inc_NN(SvRV(old)); +#else + dsv->sv_u.svu_rv = SvREFCNT_inc_NN( old->sv_u.svu_rv ); +#endif + break; + case SVt_PV|SVf_POK: /* [ 33% ] */ + SvANY(dsv) = new_XPV(); + SvFLAGS(dsv) = SVt_PV|SVf_POK|SVp_POK|(sflags & SVf_UTF8); + return S_newSVsv_flags_NN_POK(aTHX_ dsv, old, flags); + case SVt_NV|SVf_NOK: /* [ < 1% ] - but won't be in float-heavy code! */ +#if NVSIZE <= IVSIZE + SET_SVANY_FOR_BODYLESS_NV(dsv); +#else + SvANY(dsv) = new_XNV(); +#endif + SvFLAGS(dsv) = SVt_NV|SVf_NOK|SVp_NOK; +#if NVSIZE <= IVSIZE + assert( &(old->sv_u.svu_nv) + == &(((XPVNV*) SvANY(old))->xnv_u.xnv_nv)); + assert( &(dsv->sv_u.svu_nv) + == &(((XPVNV*) SvANY(dsv))->xnv_u.xnv_nv)); + dsv->sv_u.svu_nv = old->sv_u.svu_nv; +#else + SvNV_set(dsv, SvNVX(old)); +#endif + break; + default: /* [ 24% ] */ + SvANY(dsv) = NULL; + goto second_switch; + } + return dsv; + + second_switch: + + /* Try again for SVt_NULL, the SVf_IVisUV case, and SVt_LAST, + * then send everything else to S_newSVsv_flags_NN_PVxx. */ + switch( sflags & (SVTYPEMASK|SVf_IOK|SVf_IVisUV|SVf_ROK|SVf_NOK|SVf_POK) ) { + case SVt_NULL: /* [4%] */ + SvFLAGS(dsv) = SVt_NULL; + break; + case SVt_IV|SVf_IOK|SVf_IVisUV: /* [<1%] */ + SET_SVANY_FOR_BODYLESS_IV(dsv); + dsv->sv_u.svu_uv = old->sv_u.svu_uv; + SvFLAGS(dsv) = SVt_IV|SVf_IOK|SVp_IOK|SVf_IVisUV; + break; + case SVt_LAST: /* [0%] */ + /* Note: sv_mortalcopy_flags sets the SVs_TEMP flag, newSVsv_flags does not. */ + if (!(flags & SVs_TEMP)) { /* This is newSVsv_flags' traditional behaviour */ + del_SV(dsv); + ck_warner_d(packWARN(WARN_INTERNAL), "semi-panic: attempt to dup freed string"); + return NULL; + } + /* sv_mortalcopy_flags traditionally had no special handling. */ + /* FALLTHROUGH */ + default: /* [ 20% ] */ + SvANY(dsv) = NULL; + SvFLAGS(dsv) = SVt_NULL; + return S_newSVsv_flags_NN_PVxx(aTHX_ dsv, old, flags); + } + + return dsv; +} /* =for apidoc sv_set_undef @@ -9627,10 +10064,10 @@ S_push_extend_mortal(pTHX_ SV *const sv) =for apidoc_item sv_mortalcopy_flags These each create a new SV which is a copy of the original SV (using -C>). The new SV is marked as mortal. It will be destroyed -"soon", either by an -explicit call to C, or by an implicit call at places such as -statement boundaries. See also C> and C>. +C>). The new SV is marked as mortal. It will be +destroyed "soon", either by an explicit call to C, or by an +implicit call at places such as statement boundaries. +See also C> and C>. The two forms are identical, except C has an extra C parameter, the contents of which are passed along to @@ -9639,23 +10076,25 @@ C>. =cut */ -/* Make a string that will exist for the duration of the expression +/* Make an SV that will exist for the duration of the expression * evaluation. Actually, it may have to last longer than that, but * hopefully we won't free it until it has been assigned to a * permanent location. */ SV * -Perl_sv_mortalcopy_flags(pTHX_ SV *const oldstr, U32 flags) +Perl_sv_mortalcopy_flags(pTHX_ SV *const old, U32 flags) { - SV *sv; + SV *dsv; - if (flags & SV_GMAGIC) - SvGETMAGIC(oldstr); /* before new_SV, in case it dies */ - new_SV(sv); - sv_setsv_flags(sv,oldstr,flags & ~SV_GMAGIC); - push_extend_mortal(sv); - SvTEMP_on(sv); - return sv; + if (!old) { + new_SV(dsv); + } else { + dsv = newSVsv_flags_NN(old, flags); + } + + push_extend_mortal(dsv); + SvTEMP_on(dsv); + return dsv; } /* @@ -10171,40 +10610,6 @@ Perl_newRV(pTHX_ SV *const sv) return newRV_noinc(SvREFCNT_inc_simple_NN(sv)); } -/* -=for apidoc newSVsv -=for apidoc_item newSVsv_flags -=for apidoc_item newSVsv_nomg - -These create a new SV which is an exact duplicate of the original SV -(using C.) - -They differ only in that C performs 'get' magic; C skips -any magic; and C allows you to explicitly set a C -parameter. - -=cut -*/ - -SV * -Perl_newSVsv_flags(pTHX_ SV *const old, I32 flags) -{ - SV *sv; - - if (!old) - return NULL; - if (SvIS_FREED(old)) { - ck_warner_d(packWARN(WARN_INTERNAL), "semi-panic: attempt to dup freed string"); - return NULL; - } - /* Do this here, otherwise we leak the new SV if this croaks. */ - if (flags & SV_GMAGIC) - SvGETMAGIC(old); - new_SV(sv); - sv_setsv_flags(sv, old, flags & ~SV_GMAGIC); - return sv; -} - /* =for apidoc sv_reset @@ -16625,8 +17030,7 @@ Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding) PUSHSTACK; SAVETMPS; if (SvPADTMP(nsv)) { - nsv = sv_newmortal(); - SvSetSV_nosteal(nsv, sv); + nsv = sv_mortalcopy_flags(sv, SV_GMAGIC|SV_NOSTEAL|SV_DO_COW_SVSETSV); } save_re_context(); PUSHMARK(sp); diff --git a/sv_inline.h b/sv_inline.h index 6989be367081..df002df88815 100644 --- a/sv_inline.h +++ b/sv_inline.h @@ -307,6 +307,8 @@ static const struct body_details bodies_by_type[] = { #if !(NVSIZE <= IVSIZE) # define new_XNV() safemalloc(sizeof(XPVNV)) #endif +#define new_XPV() safemalloc(sizeof(XPV)) +#define new_XPVIV() safemalloc(sizeof(XPVIV)) #define new_XPVNV() safemalloc(sizeof(XPVNV)) #define new_XPVMG() safemalloc(sizeof(XPVMG)) @@ -317,6 +319,8 @@ static const struct body_details bodies_by_type[] = { #if !(NVSIZE <= IVSIZE) # define new_XNV() new_body_allocated(SVt_NV) #endif +#define new_XPV() new_body_allocated(SVt_PV) +#define new_XPVIV() new_body_allocated(SVt_PVIV) #define new_XPVNV() new_body_allocated(SVt_PVNV) #define new_XPVMG() new_body_allocated(SVt_PVMG) @@ -1001,6 +1005,30 @@ Perl_sv_setpv_freshbuf(pTHX_ SV *const sv) return SvPVX(sv); } +/* +=for apidoc newSVsv +=for apidoc_item newSVsv_flags +=for apidoc_item newSVsv_nomg + +These create a new SV which is an exact duplicate of the original SV +(using C.) + +They differ only in that C performs 'get' magic; C skips +any magic; and C allows you to explicitly set a C +parameter. + +=cut +*/ + +PERL_STATIC_INLINE SV * +Perl_newSVsv_flags(pTHX_ SV *const old, I32 flags) +{ + if (!old) + return NULL; + + return newSVsv_flags_NN(old, flags); +} + /* * ex: set ts=8 sts=4 sw=4 et: */