diff options
| -rw-r--r-- | dump.c | 7 | ||||
| -rw-r--r-- | embed.fnc | 2 | ||||
| -rw-r--r-- | embed.h | 6 | ||||
| -rw-r--r-- | makedef.pl | 3 | ||||
| -rw-r--r-- | perl.h | 11 | ||||
| -rw-r--r-- | pp_ctl.c | 10 | ||||
| -rw-r--r-- | pp_hot.c | 20 | ||||
| -rw-r--r-- | proto.h | 14 | ||||
| -rw-r--r-- | regcomp.c | 8 | ||||
| -rw-r--r-- | regexec.c | 9 | ||||
| -rw-r--r-- | regexp.h | 6 | ||||
| -rw-r--r-- | sv.c | 126 | ||||
| -rw-r--r-- | sv.h | 19 | ||||
| -rw-r--r-- | utf8.c | 27 |
14 files changed, 191 insertions, 77 deletions
@@ -1679,6 +1679,11 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo if (!re) Perl_dump_indent(aTHX_ level, file, " LEN = %"IVdf"\n", (IV)SvLEN(sv)); +#ifdef PERL_NEW_COPY_ON_WRITE + if (SvIsCOW(sv) && SvLEN(sv)) + Perl_dump_indent(aTHX_ level, file, " COW_REFCNT = %d\n", + CowREFCNT(sv)); +#endif } else Perl_dump_indent(aTHX_ level, file, " PV = 0\n"); @@ -2125,7 +2130,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo PTR2UV(r->offs)); Perl_dump_indent(aTHX_ level, file, " QR_ANONCV = 0x%"UVxf"\n", PTR2UV(r->qr_anoncv)); -#ifdef PERL_OLD_COPY_ON_WRITE +#ifdef PERL_ANY_COW Perl_dump_indent(aTHX_ level, file, " SAVED_COPY = 0x%"UVxf"\n", PTR2UV(r->saved_copy)); #endif @@ -2239,7 +2239,7 @@ Apd |void |sv_copypv_flags |NN SV *const dsv|NN SV *const ssv|const I32 flags Ap |char* |my_atof2 |NN const char *s|NN NV* value Apn |int |my_socketpair |int family|int type|int protocol|int fd[2] Ap |int |my_dirfd |NULLOK DIR* dir -#ifdef PERL_OLD_COPY_ON_WRITE +#ifdef PERL_ANY_COW : Used in pp_hot.c and regexec.c pMXE |SV* |sv_setsv_cow |NULLOK SV* dstr|NN SV* sstr #endif @@ -879,6 +879,9 @@ #define dump_exec_pos(a,b,c,d,e,f) S_dump_exec_pos(aTHX_ a,b,c,d,e,f) # endif # endif +# if defined(PERL_ANY_COW) +#define sv_setsv_cow(a,b) Perl_sv_setsv_cow(aTHX_ a,b) +# endif # if defined(PERL_IN_DQUOTE_STATIC_C) #define grok_bslash_c(a,b,c) S_grok_bslash_c(aTHX_ a,b,c) #define grok_bslash_o(a,b,c,d,e) S_grok_bslash_o(aTHX_ a,b,c,d,e) @@ -982,9 +985,6 @@ #define is_utf8_X_extend(a) Perl_is_utf8_X_extend(aTHX_ a) #define is_utf8_X_regular_begin(a) Perl_is_utf8_X_regular_begin(aTHX_ a) # endif -# if defined(PERL_OLD_COPY_ON_WRITE) -#define sv_setsv_cow(a,b) Perl_sv_setsv_cow(aTHX_ a,b) -# endif #endif #ifdef PERL_CORE #define Slab_Alloc(a) Perl_Slab_Alloc(aTHX_ a) diff --git a/makedef.pl b/makedef.pl index 9550042f2d..7afc35ff04 100644 --- a/makedef.pl +++ b/makedef.pl @@ -274,7 +274,8 @@ else { ); } -unless ($define{'PERL_OLD_COPY_ON_WRITE'}) { +unless ($define{'PERL_OLD_COPY_ON_WRITE'} + || $define{'PERL_NEW_COPY_ON_WRITE'}) { ++$skip{Perl_sv_setsv_cow}; } @@ -2494,6 +2494,14 @@ typedef AV PAD; typedef AV PADNAMELIST; typedef SV PADNAME; +#if defined(PERL_OLD_COPY_ON_WRITE) || defined(PERL_NEW_COPY_ON_WRITE) +# if defined(PERL_OLD_COPY_ON_WRITE) && defined(PERL_NEW_COPY_ON_WRITE) +# error PERL_OLD_COPY_ON_WRITE and PERL_NEW_COPY_ON_WRITE are exclusive +# else +# define PERL_ANY_COW +# endif +#endif + #include "handy.h" #if defined(USE_LARGE_FILES) && !defined(NO_64_BIT_RAWIO) @@ -4707,6 +4715,9 @@ EXTCONST char PL_bincompat_options[] = # ifdef PERL_OLD_COPY_ON_WRITE " PERL_OLD_COPY_ON_WRITE" # endif +# ifdef PERL_NEW_COPY_ON_WRITE + " PERL_NEW_COPY_ON_WRITE" +# endif # ifdef PERL_POISON " PERL_POISON" # endif @@ -354,7 +354,7 @@ Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx) PERL_UNUSED_CONTEXT; if (!p || p[1] < RX_NPARENS(rx)) { -#ifdef PERL_OLD_COPY_ON_WRITE +#ifdef PERL_ANY_COW i = 7 + (RX_NPARENS(rx)+1) * 2; #else i = 6 + (RX_NPARENS(rx)+1) * 2; @@ -371,7 +371,7 @@ Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx) RX_MATCH_COPIED_off(rx); *p++ = RX_NPARENS(rx); -#ifdef PERL_OLD_COPY_ON_WRITE +#ifdef PERL_ANY_COW *p++ = PTR2UV(RX_SAVED_COPY(rx)); RX_SAVED_COPY(rx) = NULL; #endif @@ -400,7 +400,7 @@ S_rxres_restore(pTHX_ void **rsp, REGEXP *rx) *p++ = 0; RX_NPARENS(rx) = *p++; -#ifdef PERL_OLD_COPY_ON_WRITE +#ifdef PERL_ANY_COW if (RX_SAVED_COPY(rx)) SvREFCNT_dec (RX_SAVED_COPY(rx)); RX_SAVED_COPY(rx) = INT2PTR(SV*,*p); @@ -428,14 +428,14 @@ S_rxres_free(pTHX_ void **rsp) if (p) { void *tmp = INT2PTR(char*,*p); #ifdef PERL_POISON -#ifdef PERL_OLD_COPY_ON_WRITE +#ifdef PERL_ANY_COW U32 i = 9 + p[1] * 2; #else U32 i = 8 + p[1] * 2; #endif #endif -#ifdef PERL_OLD_COPY_ON_WRITE +#ifdef PERL_ANY_COW SvREFCNT_dec (INT2PTR(SV*,p[2])); #endif #ifdef PERL_POISON @@ -1571,8 +1571,8 @@ yup: /* Confirmed by INTUIT */ } if (PL_sawampersand || RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY) { I32 off; -#ifdef PERL_OLD_COPY_ON_WRITE - if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) { +#ifdef PERL_ANY_COW + if (SvCANCOW(TARG)) { if (DEBUG_C_TEST) { PerlIO_printf(Perl_debug_log, "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n", @@ -1588,7 +1588,7 @@ yup: /* Confirmed by INTUIT */ { RX_SUBBEG(rx) = savepvn(t, strend - t); -#ifdef PERL_OLD_COPY_ON_WRITE +#ifdef PERL_ANY_COW RX_SAVED_COPY(rx) = NULL; #endif } @@ -2148,7 +2148,7 @@ PP(pp_subst) const I32 oldsave = PL_savestack_ix; STRLEN slen; bool doutf8 = FALSE; /* whether replacement is in utf8 */ -#ifdef PERL_OLD_COPY_ON_WRITE +#ifdef PERL_ANY_COW bool is_cow; #endif SV *nsv = NULL; @@ -2167,7 +2167,7 @@ PP(pp_subst) } SvGETMAGIC(TARG); /* must come before cow check */ -#ifdef PERL_OLD_COPY_ON_WRITE +#ifdef PERL_ANY_COW /* Awooga. Awooga. "bool" types that are actually char are dangerous, because they make integers such as 256 "false". */ is_cow = SvIsCOW(TARG) ? TRUE : FALSE; @@ -2176,7 +2176,7 @@ PP(pp_subst) sv_force_normal_flags(TARG,0); #endif if (!(rpm->op_pmflags & PMf_NONDESTRUCT) -#ifdef PERL_OLD_COPY_ON_WRITE +#ifdef PERL_ANY_COW && !is_cow #endif && (SvREADONLY(TARG) @@ -2284,7 +2284,7 @@ PP(pp_subst) /* can do inplace substitution? */ if (c -#ifdef PERL_OLD_COPY_ON_WRITE +#ifdef PERL_ANY_COW && !is_cow #endif && (I32)clen <= RX_MINLENRET(rx) @@ -2294,7 +2294,7 @@ PP(pp_subst) && !(rpm->op_pmflags & PMf_NONDESTRUCT)) { -#ifdef PERL_OLD_COPY_ON_WRITE +#ifdef PERL_ANY_COW if (SvIsCOW(TARG)) { assert (!force_on_match); goto have_a_cow; @@ -2390,7 +2390,7 @@ PP(pp_subst) s = SvPV_force_nomg(TARG, len); goto force_it; } -#ifdef PERL_OLD_COPY_ON_WRITE +#ifdef PERL_ANY_COW have_a_cow: #endif if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */ @@ -2456,7 +2456,7 @@ PP(pp_subst) SPAGAIN; PUSHs(dstr); } else { -#ifdef PERL_OLD_COPY_ON_WRITE +#ifdef PERL_ANY_COW /* The match may make the string COW. If so, brilliant, because that's just saved us one malloc, copy and free - the regexp has donated the old buffer, and we malloc an entirely new one, rather @@ -5235,6 +5235,13 @@ PERL_CALLCONV short Perl_my_swap(pTHX_ short s) #if defined(NO_MATHOMS) /* PERL_CALLCONV void Perl_sv_nounlocking(pTHX_ SV *sv); */ #endif +#if defined(PERL_ANY_COW) +PERL_CALLCONV SV* Perl_sv_setsv_cow(pTHX_ SV* dstr, SV* sstr) + __attribute__nonnull__(pTHX_2); +#define PERL_ARGS_ASSERT_SV_SETSV_COW \ + assert(sstr) + +#endif #if defined(PERL_CORE) PERL_CALLCONV void Perl_opslab_force_free(pTHX_ OPSLAB *slab) __attribute__nonnull__(pTHX_1); @@ -7511,13 +7518,6 @@ PERL_CALLCONV long Perl_my_letohl(long n); #if defined(PERL_NEED_MY_LETOHS) PERL_CALLCONV short Perl_my_letohs(short n); #endif -#if defined(PERL_OLD_COPY_ON_WRITE) -PERL_CALLCONV SV* Perl_sv_setsv_cow(pTHX_ SV* dstr, SV* sstr) - __attribute__nonnull__(pTHX_2); -#define PERL_ARGS_ASSERT_SV_SETSV_COW \ - assert(sstr) - -#endif #if defined(PERL_USES_PL_PIDSTATUS) && defined(PERL_IN_UTIL_C) STATIC void S_pidgone(pTHX_ Pid_t pid, int status); #endif @@ -14192,7 +14192,7 @@ Perl_pregfree2(pTHX_ REGEXP *rx) Safefree(r->substrs); } RX_MATCH_COPY_FREE(rx); -#ifdef PERL_OLD_COPY_ON_WRITE +#ifdef PERL_ANY_COW SvREFCNT_dec(r->saved_copy); #endif Safefree(r->offs); @@ -14275,7 +14275,7 @@ Perl_reg_temp_copy (pTHX_ REGEXP *ret_x, REGEXP *rx) anchored or float namesakes, and don't hold a second reference. */ } RX_MATCH_COPIED_off(ret_x); -#ifdef PERL_OLD_COPY_ON_WRITE +#ifdef PERL_ANY_COW ret->saved_copy = NULL; #endif ret->mother_re = ReREFCNT_inc(r->mother_re ? r->mother_re : rx); @@ -14483,7 +14483,7 @@ Perl_re_dup_guts(pTHX_ const REGEXP *sstr, REGEXP *dstr, CLONE_PARAMS *param) ret->subbeg = SAVEPVN(ret->subbeg, ret->sublen); else ret->subbeg = NULL; -#ifdef PERL_OLD_COPY_ON_WRITE +#ifdef PERL_ANY_COW ret->saved_copy = NULL; #endif @@ -14704,7 +14704,7 @@ Perl_save_re_context(pTHX) PL_reg_leftiter = 0; PL_reg_poscache = NULL; PL_reg_poscache_size = 0; -#ifdef PERL_OLD_COPY_ON_WRITE +#ifdef PERL_ANY_COW PL_nrs = NULL; #endif @@ -2635,9 +2635,8 @@ got_it: /* make sure $`, $&, $', and $digit will work later */ if ( !(flags & REXEC_NOT_FIRST) ) { if (flags & REXEC_COPY_STR) { -#ifdef PERL_OLD_COPY_ON_WRITE - if ((SvIsCOW(sv) - || (SvFLAGS(sv) & CAN_COW_MASK) == CAN_COW_FLAGS)) { +#ifdef PERL_ANY_COW + if (SvCANCOW(sv)) { if (DEBUG_C_TEST) { PerlIO_printf(Perl_debug_log, "Copy on write: regexp capture, type %d\n", @@ -2852,7 +2851,7 @@ S_regtry(pTHX_ regmatch_info *reginfo, char **startposp) PL_reg_oldsavedlen = prog->sublen; PL_reg_oldsavedoffset = prog->suboffset; PL_reg_oldsavedcoffset = prog->suboffset; -#ifdef PERL_OLD_COPY_ON_WRITE +#ifdef PERL_ANY_COW PL_nrs = prog->saved_copy; #endif RXp_MATCH_COPIED_off(prog); @@ -7617,7 +7616,7 @@ restore_pos(pTHX_ void *arg) rex->sublen = PL_reg_oldsavedlen; rex->suboffset = PL_reg_oldsavedoffset; rex->subcoffset = PL_reg_oldsavedcoffset; -#ifdef PERL_OLD_COPY_ON_WRITE +#ifdef PERL_ANY_COW rex->saved_copy = PL_nrs; #endif RXp_MATCH_COPIED_on(rex); @@ -46,7 +46,7 @@ struct reg_substr_data { struct reg_substr_datum data[3]; /* Actual array */ }; -#ifdef PERL_OLD_COPY_ON_WRITE +#ifdef PERL_ANY_COW #define SV_SAVED_COPY SV *saved_copy; /* If non-NULL, SV which is COW from original */ #else #define SV_SAVED_COPY @@ -495,7 +495,7 @@ get_regex_charset_name(const U32 flags, STRLEN* const lenp) /* Stuff that needs to be included in the pluggable extension goes below here */ -#ifdef PERL_OLD_COPY_ON_WRITE +#ifdef PERL_ANY_COW #define RX_MATCH_COPY_FREE(rx) \ STMT_START {if (RX_SAVED_COPY(rx)) { \ SV_CHECK_THINKFIRST_COW_DROP(RX_SAVED_COPY(rx)); \ @@ -790,7 +790,7 @@ struct re_save_state { U32 re_state_regsize; /* from regexec.c */ char *re_state_reg_poscache; /* cache of pos of WHILEM */ char *re_state_reg_starttry; /* from regexec.c */ -#ifdef PERL_OLD_COPY_ON_WRITE +#ifdef PERL_ANY_COW SV *re_state_nrs; /* was placeholder: unused since 5.8.0 (5.7.2 patch #12027 for bug ID 20010815.012). Used to save rx->saved_copy */ #endif }; @@ -1502,7 +1502,10 @@ Perl_sv_grow(pTHX_ SV *const sv, STRLEN newlen) #endif } else + { + if (SvIsCOW(sv)) sv_force_normal(sv); s = SvPVX_mutable(sv); + } if (newlen > SvLEN(sv)) { /* need more room? */ STRLEN minlen = SvCUR(sv); @@ -4198,12 +4201,17 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, SV* sstr, const I32 flags) source scalar is a shared hash key scalar. */ (((flags & SV_COW_SHARED_HASH_KEYS) ? !(sflags & SVf_IsCOW) +#ifdef PERL_NEW_COPY_ON_WRITE + /* If this is a regular (non-hek) COW, only so many COW + "copies" are possible. */ + || (SvLEN(sstr) && CowREFCNT(sstr) == SV_COW_REFCNT_MAX) +#endif : 1 /* If making a COW copy is forbidden then the behaviour we desire is as if the source SV isn't actually already COW, even if it is. So we act as if the source flags are not COW, rather than actually testing them. */ ) -#ifndef PERL_OLD_COPY_ON_WRITE +#ifndef PERL_ANY_COW /* The change that added SV_COW_SHARED_HASH_KEYS makes the logic when PERL_OLD_COPY_ON_WRITE is defined a little wrong. Conceptually PERL_OLD_COPY_ON_WRITE being defined should @@ -4218,17 +4226,28 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, SV* sstr, const I32 flags) ) && !(isSwipe = +#ifdef PERL_NEW_COPY_ON_WRITE + /* slated for free anyway (and not COW)? */ + (sflags & (SVs_TEMP|SVf_IsCOW)) == SVs_TEMP && +#else (sflags & SVs_TEMP) && /* slated for free anyway? */ +#endif !(sflags & SVf_OOK) && /* and not involved in OOK hack? */ (!(flags & SV_NOSTEAL)) && /* and we're allowed to steal temps */ SvREFCNT(sstr) == 1 && /* and no other references to it? */ SvLEN(sstr)) /* and really is a string */ -#ifdef PERL_OLD_COPY_ON_WRITE +#ifdef PERL_ANY_COW && ((flags & SV_COW_SHARED_HASH_KEYS) ? (!((sflags & CAN_COW_MASK) == CAN_COW_FLAGS && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS - && SvTYPE(sstr) >= SVt_PVIV)) +# ifdef PERL_OLD_COPY_ON_WRITE + && SvTYPE(sstr) >= SVt_PVIV +# else + && !(sflags & SVf_IsCOW) + && SvCUR(sstr)+1 < SvLEN(sstr) +# endif + )) : 1) #endif ) { @@ -4249,13 +4268,17 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, SV* sstr, const I32 flags) sv_dump(sstr); sv_dump(dstr); } -#ifdef PERL_OLD_COPY_ON_WRITE +#ifdef PERL_ANY_COW if (!isSwipe) { if (!(sflags & SVf_IsCOW)) { SvIsCOW_on(sstr); +# ifdef PERL_OLD_COPY_ON_WRITE /* Make the source SV into a loop of 1. (about to become 2) */ SV_COW_NEXT_SV_SET(sstr, sstr); +# else + CowREFCNT(sstr) = 0; +# endif } } #endif @@ -4268,13 +4291,17 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, SV* sstr, const I32 flags) /* making another shared SV. */ STRLEN cur = SvCUR(sstr); STRLEN len = SvLEN(sstr); -#ifdef PERL_OLD_COPY_ON_WRITE +#ifdef PERL_ANY_COW if (len) { +# ifdef PERL_OLD_COPY_ON_WRITE assert (SvTYPE(dstr) >= SVt_PVIV); /* SvIsCOW_normal */ /* splice us in between source and next-after-source. */ SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr)); SV_COW_NEXT_SV_SET(sstr, dstr); +# else + CowREFCNT(sstr)++; +# endif SvPV_set(dstr, SvPVX_mutable(sstr)); } else #endif @@ -4364,7 +4391,12 @@ Perl_sv_setsv_mg(pTHX_ SV *const dstr, SV *const sstr) SvSETMAGIC(dstr); } -#ifdef PERL_OLD_COPY_ON_WRITE +#ifdef PERL_ANY_COW +# ifdef PERL_OLD_COPY_ON_WRITE +# define SVt_COW SVt_PVIV +# else +# define SVt_COW SVt_PV +# endif SV * Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr) { @@ -4390,14 +4422,16 @@ Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr) } else new_SV(dstr); - SvUPGRADE(dstr, SVt_PVIV); + SvUPGRADE(dstr, SVt_COW); assert (SvPOK(sstr)); assert (SvPOKp(sstr)); +# ifdef PERL_OLD_COPY_ON_WRITE assert (!SvIOK(sstr)); assert (!SvIOKp(sstr)); assert (!SvNOK(sstr)); assert (!SvNOKp(sstr)); +# endif if (SvIsCOW(sstr)) { @@ -4408,21 +4442,34 @@ Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr) new_pv = HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)))); goto common_exit; } +# ifdef PERL_OLD_COPY_ON_WRITE SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr)); +# else + assert(SvCUR(sstr)+1 < SvLEN(sstr)); + assert(CowREFCNT(sstr) < SV_COW_REFCNT_MAX); +# endif } else { assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS); - SvUPGRADE(sstr, SVt_PVIV); + SvUPGRADE(sstr, SVt_COW); SvIsCOW_on(sstr); DEBUG_C(PerlIO_printf(Perl_debug_log, "Fast copy on write: Converting sstr to COW\n")); +# ifdef PERL_OLD_COPY_ON_WRITE SV_COW_NEXT_SV_SET(dstr, sstr); +# else + CowREFCNT(sstr) = 0; +# endif } +# ifdef PERL_OLD_COPY_ON_WRITE SV_COW_NEXT_SV_SET(sstr, dstr); +# else + CowREFCNT(sstr)++; +# endif new_pv = SvPVX_mutable(sstr); common_exit: SvPV_set(dstr, new_pv); - SvFLAGS(dstr) = (SVt_PVIV|SVf_POK|SVp_POK|SVf_IsCOW); + SvFLAGS(dstr) = (SVt_COW|SVf_POK|SVp_POK|SVf_IsCOW); if (SvUTF8(sstr)) SvUTF8_on(dstr); SvLEN_set(dstr, len); @@ -4736,29 +4783,42 @@ Perl_sv_force_normal_flags(pTHX_ SV *const sv, const U32 flags) PERL_ARGS_ASSERT_SV_FORCE_NORMAL_FLAGS; -#ifdef PERL_OLD_COPY_ON_WRITE +#ifdef PERL_ANY_COW if (SvREADONLY(sv)) { if (IN_PERL_RUNTIME) Perl_croak_no_modify(); } - else - if (SvIsCOW(sv)) { - const char * const pvx = SvPVX_const(sv); - const STRLEN len = SvLEN(sv); - const STRLEN cur = SvCUR(sv); - /* next COW sv in the loop. If len is 0 then this is a shared-hash - key scalar, so we mustn't attempt to call SV_COW_NEXT_SV(), as - we'll fail an assertion. */ - SV * const next = len ? SV_COW_NEXT_SV(sv) : 0; + else if (SvIsCOW(sv)) { + const char * const pvx = SvPVX_const(sv); + const STRLEN len = SvLEN(sv); + const STRLEN cur = SvCUR(sv); +# ifdef PERL_OLD_COPY_ON_WRITE + /* next COW sv in the loop. If len is 0 then this is a shared-hash + key scalar, so we mustn't attempt to call SV_COW_NEXT_SV(), as + we'll fail an assertion. */ + SV * const next = len ? SV_COW_NEXT_SV(sv) : 0; +# endif - if (DEBUG_C_TEST) { + if (DEBUG_C_TEST) { PerlIO_printf(Perl_debug_log, "Copy on write: Force normal %ld\n", (long) flags); sv_dump(sv); - } - SvIsCOW_off(sv); + } + SvIsCOW_off(sv); +# ifdef PERL_NEW_COPY_ON_WRITE + if (len && CowREFCNT(sv) == 0) + /* We own the buffer ourselves. */ + NOOP; + else +# endif + { + /* This SV doesn't own the buffer, so need to Newx() a new one: */ +# ifdef PERL_NEW_COPY_ON_WRITE + /* Must do this first, since the macro uses SvPVX. */ + if (len) CowREFCNT(sv)--; +# endif SvPV_set(sv, NULL); SvLEN_set(sv, 0); if (flags & SV_COW_DROP_PV) { @@ -4771,7 +4831,9 @@ Perl_sv_force_normal_flags(pTHX_ SV *const sv, const U32 flags) *SvEND(sv) = '\0'; } if (len) { +# ifdef PERL_OLD_COPY_ON_WRITE sv_release_COW(sv, pvx, next); +# endif } else { unshare_hek(SvSHARED_HEK_FROM_PV(pvx)); } @@ -4779,6 +4841,7 @@ Perl_sv_force_normal_flags(pTHX_ SV *const sv, const U32 flags) sv_dump(sv); } } + } #else if (SvREADONLY(sv)) { if (IN_PERL_RUNTIME) @@ -5299,7 +5362,7 @@ Perl_sv_magic(pTHX_ SV *const sv, SV *const obj, const int how, vtable = (vtable_index == magic_vtable_max) ? NULL : PL_magic_vtables + vtable_index; -#ifdef PERL_OLD_COPY_ON_WRITE +#ifdef PERL_ANY_COW if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0); #endif @@ -6185,7 +6248,7 @@ Perl_sv_clear(pTHX_ SV *const orig_sv) next_sv = target; } } -#ifdef PERL_OLD_COPY_ON_WRITE +#ifdef PERL_ANY_COW else if (SvPVX_const(sv) && !(SvTYPE(sv) == SVt_PVIO && !(IoFLAGS(sv) & IOf_FAKE_DIRP))) @@ -6196,12 +6259,23 @@ Perl_sv_clear(pTHX_ SV *const orig_sv) sv_dump(sv); } if (SvLEN(sv)) { +# ifdef PERL_OLD_COPY_ON_WRITE sv_release_COW(sv, SvPVX_const(sv), SV_COW_NEXT_SV(sv)); +# else + if (CowREFCNT(sv)) { + CowREFCNT(sv)--; + SvLEN_set(sv, 0); + } +# endif } else { unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv))); } - } else if (SvLEN(sv)) { + } +# ifdef PERL_OLD_COPY_ON_WRITE + else +# endif + if (SvLEN(sv)) { Safefree(SvPVX_mutable(sv)); } } @@ -12708,7 +12782,7 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) = pv_dup(old_state->re_state_bostr); new_state->re_state_regeol = pv_dup(old_state->re_state_regeol); -#ifdef PERL_OLD_COPY_ON_WRITE +#ifdef PERL_ANY_COW new_state->re_state_nrs = sv_dup(old_state->re_state_nrs, param); #endif @@ -1835,6 +1835,8 @@ Like sv_utf8_upgrade, but doesn't do magic on C<sv>. ((SvIsCOW(sv) ? sv_force_normal_flags(sv, 0) : (void) 0), 0) # define SvIsCOW_normal(sv) (SvIsCOW(sv) && SvLEN(sv)) # define SvRELEASE_IVX_(sv) SvRELEASE_IVX(sv), +# define SvCANCOW(sv) \ + (SvIsCOW(sv) || (SvFLAGS(sv) & CAN_COW_MASK) == CAN_COW_FLAGS) #else # define SvRELEASE_IVX(sv) 0 /* This little game brought to you by the need to shut this warning up: @@ -1842,6 +1844,16 @@ mg.c: In function 'Perl_magic_get': mg.c:1024: warning: left-hand operand of comma expression has no effect */ # define SvRELEASE_IVX_(sv) /**/ +# ifdef PERL_NEW_COPY_ON_WRITE +# define SvCANCOW(sv) \ + (SvIsCOW(sv) \ + ? SvLEN(sv) ? CowREFCNT(sv) != SV_COW_REFCNT_MAX : 1 \ + : (SvFLAGS(sv) & CAN_COW_MASK) == CAN_COW_FLAGS \ + && SvCUR(sv)+1 < SvLEN(sv)) + /* Note: To allow 256 COW "copies", a refcnt of 0 means 1. */ +# define CowREFCNT(sv) (*(U8 *)(SvPVX(sv)+SvLEN(sv)-1)) +# define SV_COW_REFCNT_MAX ((1 << sizeof(U8)*8) - 1) +# endif #endif /* PERL_OLD_COPY_ON_WRITE */ /* This is a pessimistic view. Scalar must be purely a read-write PV to copy- @@ -2062,7 +2074,12 @@ See also C<PL_sv_yes> and C<PL_sv_no>. == (SVt_PVLV|SVf_FAKE)) -#define SvGROW(sv,len) (SvLEN(sv) < (len) ? sv_grow(sv,len) : SvPVX(sv)) +#ifdef PERL_NEW_COPY_ON_WRITE +# define SvGROW(sv,len) \ + (SvIsCOW(sv) || SvLEN(sv) < (len) ? sv_grow(sv,len) : SvPVX(sv)) +#else +# define SvGROW(sv,len) (SvLEN(sv) < (len) ? sv_grow(sv,len) : SvPVX(sv)) +#endif #define SvGROW_mutable(sv,len) \ (SvLEN(sv) < (len) ? sv_grow(sv,len) : SvPVX_mutable(sv)) #define Sv_Grow sv_grow @@ -2849,8 +2849,8 @@ Perl__core_swash_init(pTHX_ const char* pkg, const char* name, SV *listsv, I32 m method = gv_fetchmeth(stash, "SWASHNEW", 8, -1); if (!method) { /* demand load utf8 */ ENTER; - errsv_save = newSVsv(ERRSV); - SAVEFREESV(errsv_save); + if ((errsv_save = GvSV(PL_errgv))) SAVEFREESV(errsv_save); + GvSV(PL_errgv) = NULL; /* It is assumed that callers of this routine are not passing in * any user derived data. */ /* Need to do this after save_re_context() as it will set @@ -2864,9 +2864,13 @@ Perl__core_swash_init(pTHX_ const char* pkg, const char* name, SV *listsv, I32 m Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn(pkg,pkg_len), NULL); { - SV * const errsv = ERRSV; - if (!SvTRUE_NN(errsv)) - sv_setsv(errsv, errsv_save); + /* Not ERRSV, as there is no need to vivify a scalar we are + about to discard. */ + SV * const errsv = GvSV(PL_errgv); + if (!SvTRUE(errsv)) { + GvSV(PL_errgv) = SvREFCNT_inc_simple(errsv_save); + SvREFCNT_dec(errsv); + } } LEAVE; } @@ -2879,8 +2883,8 @@ Perl__core_swash_init(pTHX_ const char* pkg, const char* name, SV *listsv, I32 m mPUSHi(minbits); mPUSHi(none); PUTBACK; - errsv_save = newSVsv(ERRSV); - SAVEFREESV(errsv_save); + if ((errsv_save = GvSV(PL_errgv))) SAVEFREESV(errsv_save); + GvSV(PL_errgv) = NULL; /* If we already have a pointer to the method, no need to use * call_method() to repeat the lookup. */ if (method @@ -2891,9 +2895,12 @@ Perl__core_swash_init(pTHX_ const char* pkg, const char* name, SV *listsv, I32 m SvREFCNT_inc(retval); } { - SV * const errsv = ERRSV; - if (!SvTRUE_NN(errsv)) - sv_setsv(errsv, errsv_save); + /* Not ERRSV. See above. */ + SV * const errsv = GvSV(PL_errgv); + if (!SvTRUE(errsv)) { + GvSV(PL_errgv) = SvREFCNT_inc_simple(errsv_save); + SvREFCNT_dec(errsv); + } } LEAVE; POPSTACK; |