From: Nicholas Clark Date: Thu, 3 Jan 2008 17:15:53 +0000 (+0000) Subject: Extend newSVpvn_flags() to also call sv_2mortal() if SVs_TEMP is set in X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=59cd0e26eb6c10499b25d783562357dd68cc16f2;p=p5sagit%2Fp5-mst-13.2.git Extend newSVpvn_flags() to also call sv_2mortal() if SVs_TEMP is set in the flags. Move its implementation just ahead of sv_2mortal()'s for CPU cache locality. Refactor all code that can be to use this. p4raw-id: //depot/perl@32818 --- diff --git a/doio.c b/doio.c index 5e7a5a1..ba096ef 100644 --- a/doio.c +++ b/doio.c @@ -176,7 +176,7 @@ Perl_do_openn(pTHX_ GV *gv, register const char *oname, I32 len, int as_raw, IoTYPE(io) = PerlIO_intmode2str(rawmode, &mode[ix], &writing); - namesv = sv_2mortal(newSVpvn(oname,len)); + namesv = newSVpvn_flags(oname, len, SVs_TEMP); num_svs = 1; svp = &namesv; type = NULL; @@ -399,7 +399,7 @@ Perl_do_openn(pTHX_ GV *gv, register const char *oname, I32 len, int as_raw, } else { if (!num_svs) { - namesv = sv_2mortal(newSVpvn(type,tend - type)); + namesv = newSVpvn_flags(type, tend - type, SVs_TEMP); num_svs = 1; svp = &namesv; type = NULL; @@ -432,7 +432,7 @@ Perl_do_openn(pTHX_ GV *gv, register const char *oname, I32 len, int as_raw, } else { if (!num_svs) { - namesv = sv_2mortal(newSVpvn(type,tend - type)); + namesv = newSVpvn_flags(type, tend - type, SVs_TEMP); num_svs = 1; svp = &namesv; type = NULL; @@ -511,7 +511,7 @@ Perl_do_openn(pTHX_ GV *gv, register const char *oname, I32 len, int as_raw, } else { if (!num_svs) { - namesv = sv_2mortal(newSVpvn(type,tend - type)); + namesv = newSVpvn_flags(type, tend - type, SVs_TEMP); num_svs = 1; svp = &namesv; type = NULL; diff --git a/doop.c b/doop.c index 6ae9239..59aa807 100644 --- a/doop.c +++ b/doop.c @@ -1217,13 +1217,13 @@ Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right) /* Avoid triggering overloading again by using temporaries. Maybe there should be a variant of sv_utf8_upgrade that takes pvn */ - right = sv_2mortal(newSVpvn(rsave, rightlen)); + right = newSVpvn_flags(rsave, rightlen, SVs_TEMP); sv_utf8_upgrade(right); rsave = rc = SvPV_nomg_const(right, rightlen); right_utf = TRUE; } else if (!left_utf && right_utf) { - left = sv_2mortal(newSVpvn(lsave, leftlen)); + left = newSVpvn_flags(lsave, leftlen, SVs_TEMP); sv_utf8_upgrade(left); lsave = lc = SvPV_nomg_const(left, leftlen); left_utf = TRUE; diff --git a/gv.c b/gv.c index 88e9993..ebcfabb 100644 --- a/gv.c +++ b/gv.c @@ -2057,8 +2057,8 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) PUSHs(lr>0? left: right); PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no )); if (notfound) { - PUSHs( sv_2mortal(newSVpvn(AMG_id2name(method + assignshift), - AMG_id2namelen(method + assignshift)))); + PUSHs(newSVpvn_flags(AMG_id2name(method + assignshift), + AMG_id2namelen(method + assignshift), SVs_TEMP)); } PUSHs((SV*)cv); PUTBACK; diff --git a/hv.c b/hv.c index 63e1049..f0d8033 100644 --- a/hv.c +++ b/hv.c @@ -350,8 +350,9 @@ Perl_hv_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, SV* obj = mg->mg_obj; if (!keysv) { - keysv = sv_2mortal(newSVpvn_utf8(key, klen, - flags & HVhek_UTF8)); + keysv = newSVpvn_flags(key, klen, SVs_TEMP | + ((flags & HVhek_UTF8) + ? SVf_UTF8 : 0)); } mg->mg_obj = keysv; /* pass key */ @@ -913,7 +914,7 @@ S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, #ifdef ENV_IS_CASELESS else if (mg_find((SV*)hv, PERL_MAGIC_env)) { /* XXX This code isn't UTF8 clean. */ - keysv = sv_2mortal(newSVpvn(key,klen)); + keysv = newSVpvn_flags(key, klen, SVs_TEMP); if (k_flags & HVhek_FREEKEY) { Safefree(key); } diff --git a/mg.c b/mg.c index 48618c0..3cd278c 100644 --- a/mg.c +++ b/mg.c @@ -1607,7 +1607,7 @@ S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int if (n > 1) { if (mg->mg_ptr) { if (mg->mg_len >= 0) - PUSHs(sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len))); + PUSHs(newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP)); else if (mg->mg_len == HEf_SVKEY) PUSHs((SV*)mg->mg_ptr); } @@ -2305,9 +2305,9 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) /* Opening for input is more common than opening for output, so ensure that hints for input are sooner on linked list. */ - tmp = sv_2mortal(out ? newSVpvn(out + 1, start + len - out - 1) - : newSVpvs("")); - SvFLAGS(tmp) |= SvUTF8(sv); + tmp = out ? newSVpvn_flags(out + 1, start + len - out - 1, + SVs_TEMP | SvUTF8(sv)) + : newSVpvn_flags("", 0, SVs_TEMP | SvUTF8(sv)); tmp_he = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash, @@ -2960,7 +2960,7 @@ Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg) { dVAR; SV *key = (mg->mg_len == HEf_SVKEY) ? (SV *)mg->mg_ptr - : sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len)); + : newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP); /* mg->mg_obj isn't being used. If needed, it would be possible to store an alternative leaf in there, with PL_compiling.cop_hints being used if diff --git a/mro.c b/mro.c index f4014a8..9c57b79 100644 --- a/mro.c +++ b/mro.c @@ -1049,7 +1049,7 @@ XS(XS_mro_nextcan) /* beyond here is just for cache misses, so perf isn't as critical */ stashname_len = subname - fq_subname - 2; - stashname = sv_2mortal(newSVpvn(fq_subname, stashname_len)); + stashname = newSVpvn_flags(fq_subname, stashname_len, SVs_TEMP); linear_av = mro_get_linear_isa_c3(selfstash, 0); /* has ourselves at the top of the list */ diff --git a/pod/perlapi.pod b/pod/perlapi.pod index 8546d4f..d9a2eeb 100644 --- a/pod/perlapi.pod +++ b/pod/perlapi.pod @@ -5173,9 +5173,10 @@ Creates a new SV and copies a string into it. The reference count for the SV is set to 1. Note that if C is zero, Perl will create a zero length string. You are responsible for ensuring that the source string is at least C bytes long. If the C argument is NULL the new SV will be undefined. -Currently the only flag bit accepted is SVf_UTF8. If this is set, then it -will be set on the new SV. C is a convenience wrapper for -this function, defined as +Currently the only flag bits accepted are C and C. +If C is set, then C is called on the result before +returning. If C is set, then it will be set on the new SV. +C is a convenience wrapper for this function, defined as #define newSVpvn_utf8(s, len, u) \ newSVpvn_flags((s), (len), (u) ? SVf_UTF8 : 0) diff --git a/pp.c b/pp.c index 1202fb1..d25a55c 100644 --- a/pp.c +++ b/pp.c @@ -449,7 +449,7 @@ PP(pp_prototype) if (defgv && str[n - 1] == '$') str[n - 1] = '_'; str[n++] = '\0'; - ret = sv_2mortal(newSVpvn(str, n - 1)); + ret = newSVpvn_flags(str, n - 1, SVs_TEMP); } else if (code) /* Non-Overridable */ goto set; @@ -461,7 +461,7 @@ PP(pp_prototype) } cv = sv_2cv(TOPs, &stash, &gv, 0); if (cv && SvPOK(cv)) - ret = sv_2mortal(newSVpvn(SvPVX_const(cv), SvCUR(cv))); + ret = newSVpvn_flags(SvPVX_const(cv), SvCUR(cv), SVs_TEMP); set: SETs(ret); RETURN; @@ -3312,7 +3312,8 @@ PP(pp_index) Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously) will trigger magic and overloading again, as will fbm_instr() */ - big = sv_2mortal(newSVpvn_utf8(big_p, biglen, big_utf8)); + big = newSVpvn_flags(big_p, biglen, + SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0)); big_p = SvPVX(big); } if (SvGAMAGIC(little) || (is_index && !SvOK(little))) { @@ -3324,7 +3325,8 @@ PP(pp_index) This is all getting to messy. The API isn't quite clean enough, because data access has side effects. */ - little = sv_2mortal(newSVpvn_utf8(little_p, llen, little_utf8)); + little = newSVpvn_flags(little_p, llen, + SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0)); little_p = SvPVX(little); } diff --git a/pp_hot.c b/pp_hot.c index bf8f2fb..efdb8a4 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -248,7 +248,7 @@ PP(pp_concat) /* mg_get(right) may happen here ... */ rpv = SvPV_const(right, rlen); rbyte = !DO_UTF8(right); - right = sv_2mortal(newSVpvn(rpv, rlen)); + right = newSVpvn_flags(rpv, rlen, SVs_TEMP); rpv = SvPV_const(right, rlen); /* no point setting UTF-8 here */ rcopied = TRUE; } @@ -287,7 +287,7 @@ PP(pp_concat) sv_utf8_upgrade_nomg(TARG); else { if (!rcopied) - right = sv_2mortal(newSVpvn(rpv, rlen)); + right = newSVpvn_flags(rpv, rlen, SVs_TEMP); sv_utf8_upgrade_nomg(right); rpv = SvPV_const(right, rlen); } diff --git a/pp_pack.c b/pp_pack.c index 0d456bd..21e6494 100644 --- a/pp_pack.c +++ b/pp_pack.c @@ -2010,7 +2010,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c SHIFT_VAR(utf8, s, strend, aptr, datumtype); DO_BO_UNPACK_PC(aptr); /* newSVpvn generates undef if aptr is NULL */ - PUSHs(sv_2mortal(newSVpvn(aptr, len))); + PUSHs(newSVpvn_flags(aptr, len, SVs_TEMP)); } break; #ifdef HAS_QUAD @@ -2511,8 +2511,8 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) STRLEN len; const char *const pv = SvPV_const(*beglist, len); SV *const temp - = sv_2mortal(newSVpvn_flags(pv, len, - SvUTF8(*beglist))); + = newSVpvn_flags(pv, len, + SVs_TEMP | SvUTF8(*beglist)); *beglist = temp; } count = DO_UTF8(*beglist) ? diff --git a/pp_sys.c b/pp_sys.c index 6aa8645..36e5638 100644 --- a/pp_sys.c +++ b/pp_sys.c @@ -4697,7 +4697,7 @@ PP(pp_ghostent) PUSHs(sv_2mortal(newSViv((IV)len))); #ifdef h_addr for (elem = hent->h_addr_list; elem && *elem; elem++) { - XPUSHs(sv_2mortal(newSVpvn(*elem, len))); + XPUSHs(newSVpvn_flags(*elem, len, SVs_TEMP)); } #else if (hent->h_addr) diff --git a/regcomp.c b/regcomp.c index 6d75613..b7fd317 100644 --- a/regcomp.c +++ b/regcomp.c @@ -5249,8 +5249,9 @@ S_reg_scan_name(pTHX_ RExC_state_t *pRExC_state, U32 flags) { } if ( flags ) { - SV* sv_name = sv_2mortal(newSVpvn_utf8(name_start, - (int)(RExC_parse - name_start), UTF)); + SV* sv_name + = newSVpvn_flags(name_start, (int)(RExC_parse - name_start), + SVs_TEMP | (UTF ? SVf_UTF8 : 0)); if ( flags == REG_RSN_RETURN_NAME) return sv_name; else if (flags==REG_RSN_RETURN_DATA) { @@ -6742,7 +6743,7 @@ STATIC UV S_reg_recode(pTHX_ const char value, SV **encp) { STRLEN numlen = 1; - SV * const sv = sv_2mortal(newSVpvn(&value, numlen)); + SV * const sv = newSVpvn_flags(&value, numlen, SVs_TEMP); const char * const s = *encp ? sv_recode_to_utf8(sv, *encp) : SvPVX(sv); const STRLEN newlen = SvCUR(sv); UV uv = UNICODE_REPLACEMENT; diff --git a/sv.c b/sv.c index 6010e4f..c50eef0 100644 --- a/sv.c +++ b/sv.c @@ -4344,7 +4344,7 @@ Perl_sv_catsv_flags(pTHX_ SV *dsv, register SV *ssv, I32 flags) if (dutf8 != sutf8) { if (dutf8) { /* Not modifying source SV, so taking a temporary copy. */ - SV* const csv = sv_2mortal(newSVpvn(spv, slen)); + SV* const csv = newSVpvn_flags(spv, slen, SVs_TEMP); sv_utf8_upgrade(csv); spv = SvPV_const(csv, slen); @@ -6042,7 +6042,7 @@ Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2) * invalidate pv1, so we may need to make a copy */ if (sv1 == sv2 && (SvTHINKFIRST(sv1) || SvGMAGICAL(sv1))) { pv1 = SvPV_const(sv1, cur1); - sv1 = sv_2mortal(newSVpvn_flags(pv1, cur1, SvUTF8(sv2))); + sv1 = newSVpvn_flags(pv1, cur1, SVs_TEMP | SvUTF8(sv2)); } pv1 = SvPV_const(sv1, cur1); } @@ -6998,6 +6998,40 @@ Perl_sv_newmortal(pTHX) return sv; } + +/* +=for apidoc newSVpvn_flags + +Creates a new SV and copies a string into it. The reference count for the +SV is set to 1. Note that if C is zero, Perl will create a zero length +string. You are responsible for ensuring that the source string is at least +C bytes long. If the C argument is NULL the new SV will be undefined. +Currently the only flag bits accepted are C and C. +If C is set, then C is called on the result before +returning. If C is set, then it will be set on the new SV. +C is a convenience wrapper for this function, defined as + + #define newSVpvn_utf8(s, len, u) \ + newSVpvn_flags((s), (len), (u) ? SVf_UTF8 : 0) + +=cut +*/ + +SV * +Perl_newSVpvn_flags(pTHX_ const char *s, STRLEN len, U32 flags) +{ + dVAR; + register SV *sv; + + /* All the flags we don't support must be zero. + And we're new code so I'm going to assert this from the start. */ + assert(!(flags & ~(SVf_UTF8|SVs_TEMP))); + new_SV(sv); + sv_setpvn(sv,s,len); + SvFLAGS(sv) |= (flags & SVf_UTF8); + return (flags & SVs_TEMP) ? sv_2mortal(sv) : sv; +} + /* =for apidoc sv_2mortal @@ -7068,38 +7102,6 @@ Perl_newSVpvn(pTHX_ const char *s, STRLEN len) } /* -=for apidoc newSVpvn_flags - -Creates a new SV and copies a string into it. The reference count for the -SV is set to 1. Note that if C is zero, Perl will create a zero length -string. You are responsible for ensuring that the source string is at least -C bytes long. If the C argument is NULL the new SV will be undefined. -Currently the only flag bit accepted is SVf_UTF8. If this is set, then it -will be set on the new SV. C is a convenience wrapper for -this function, defined as - - #define newSVpvn_utf8(s, len, u) \ - newSVpvn_flags((s), (len), (u) ? SVf_UTF8 : 0) - -=cut -*/ - -SV * -Perl_newSVpvn_flags(pTHX_ const char *s, STRLEN len, U32 flags) -{ - dVAR; - register SV *sv; - - /* All the flags we don't support must be zero. - And we're new code so I'm going to assert this from the start. */ - assert(!(flags & ~SVf_UTF8)); - new_SV(sv); - sv_setpvn(sv,s,len); - SvFLAGS(sv) |= flags; - return sv; -} - -/* =for apidoc newSVhek Creates a new SV from the hash key structure. It will generate scalars that @@ -9529,7 +9531,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV } else { const STRLEN old_elen = elen; - SV * const nsv = sv_2mortal(newSVpvn(eptr, elen)); + SV * const nsv = newSVpvn_flags(eptr, elen, SVs_TEMP); sv_utf8_upgrade(nsv); eptr = SvPVX_const(nsv); elen = SvCUR(nsv); @@ -11782,7 +11784,7 @@ Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding, XPUSHs(dsv); XPUSHs(ssv); XPUSHs(offsv = sv_2mortal(newSViv(*offset))); - XPUSHs(sv_2mortal(newSVpvn(tstr, tlen))); + XPUSHs(newSVpvn_flags(tstr, tlen, SVs_TEMP)); PUTBACK; call_method("cat_decode", G_SCALAR); SPAGAIN; diff --git a/toke.c b/toke.c index 410e4d6..08e9acd 100644 --- a/toke.c +++ b/toke.c @@ -1570,7 +1570,7 @@ S_tokeq(pTHX_ SV *sv) goto finish; d = s; if ( PL_hints & HINT_NEW_STRING ) { - pv = sv_2mortal(newSVpvn_flags(SvPVX_const(pv), len, SvUTF8(sv))); + pv = newSVpvn_flags(SvPVX_const(pv), len, SVs_TEMP | SvUTF8(sv)); } while (s < send) { if (*s == '\\') { @@ -10551,9 +10551,9 @@ S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, STRLEN keylen, sv_2mortal(sv); /* Parent created it permanently */ cv = *cvp; if (!pv && s) - pv = sv_2mortal(newSVpvn(s, len)); + pv = newSVpvn_flags(s, len, SVs_TEMP); if (type && pv) - typesv = sv_2mortal(newSVpvn(type, typelen)); + typesv = newSVpvn_flags(type, typelen, SVs_TEMP); else typesv = &PL_sv_undef; diff --git a/utf8.c b/utf8.c index 7bc2b09..efd894d 100644 --- a/utf8.c +++ b/utf8.c @@ -1587,8 +1587,8 @@ Perl_swash_init(pTHX_ const char* pkg, const char* name, SV *listsv, I32 minbits SPAGAIN; PUSHMARK(SP); EXTEND(SP,5); - PUSHs(sv_2mortal(newSVpvn(pkg, pkg_len))); - PUSHs(sv_2mortal(newSVpvn(name, name_len))); + PUSHs(newSVpvn_flags(pkg, pkg_len, SVs_TEMP)); + PUSHs(newSVpvn_flags(name, name_len, SVs_TEMP)); PUSHs(listsv); PUSHs(sv_2mortal(newSViv(minbits))); PUSHs(sv_2mortal(newSViv(none))); diff --git a/util.c b/util.c index 6c7e338..f2039da 100644 --- a/util.c +++ b/util.c @@ -1216,7 +1216,7 @@ Perl_write_to_stderr(pTHX_ const char* message, int msglen) PUSHMARK(SP); EXTEND(SP,2); PUSHs(SvTIED_obj((SV*)io, mg)); - PUSHs(sv_2mortal(newSVpvn(message, msglen))); + PUSHs(newSVpvn_flags(message, msglen, SVs_TEMP)); PUTBACK; call_method("PRINT", G_SCALAR);