From: Nicholas Clark <nick@ccl4.org>
Date: Sun, 9 Feb 2003 23:00:09 +0000 (+0000)
Subject: COW regexps:
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=ed25273444c5542e4865fbe422e026b78ba33b80;p=p5sagit%2Fp5-mst-13.2.git

COW regexps:
Subject: [PATCH] Copy on write for $& and $1...
Message-ID: <20030209230008.GF299@Bagpuss.unfortu.net>

p4raw-id: //depot/perl@18726
---

diff --git a/embed.fnc b/embed.fnc
index ae820cb..1866e1f 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -1303,6 +1303,9 @@ Apd	|char*	|sv_2pv_flags	|SV* sv|STRLEN* lp|I32 flags
 Apd	|void	|sv_copypv	|SV* dsv|SV* ssv
 Ap	|char*	|my_atof2	|const char *s|NV* value
 Apn	|int	|my_socketpair	|int family|int type|int protocol|int fd[2]
+#ifdef PERL_COPY_ON_WRITE
+Ap	|SV*	|sv_setsv_cow	|SV* dsv|SV* ssv
+#endif
 
 #if defined(USE_PERLIO) && !defined(USE_SFIO)
 Ap	|int	|PerlIO_close		|PerlIO *
diff --git a/embed.h b/embed.h
index 1881499..8cf4bc2 100644
--- a/embed.h
+++ b/embed.h
@@ -2030,6 +2030,9 @@
 #define sv_copypv		Perl_sv_copypv
 #define my_atof2		Perl_my_atof2
 #define my_socketpair		Perl_my_socketpair
+#ifdef PERL_COPY_ON_WRITE
+#define sv_setsv_cow		Perl_sv_setsv_cow
+#endif
 #if defined(USE_PERLIO) && !defined(USE_SFIO)
 #define PerlIO_close		Perl_PerlIO_close
 #define PerlIO_fill		Perl_PerlIO_fill
@@ -4477,6 +4480,9 @@
 #define sv_copypv(a,b)		Perl_sv_copypv(aTHX_ a,b)
 #define my_atof2(a,b)		Perl_my_atof2(aTHX_ a,b)
 #define my_socketpair		Perl_my_socketpair
+#ifdef PERL_COPY_ON_WRITE
+#define sv_setsv_cow(a,b)	Perl_sv_setsv_cow(aTHX_ a,b)
+#endif
 #if defined(USE_PERLIO) && !defined(USE_SFIO)
 #define PerlIO_close(a)		Perl_PerlIO_close(aTHX_ a)
 #define PerlIO_fill(a)		Perl_PerlIO_fill(aTHX_ a)
diff --git a/global.sym b/global.sym
index 3a8b5b9..ca46f6f 100644
--- a/global.sym
+++ b/global.sym
@@ -618,6 +618,7 @@ Perl_sv_2pv_flags
 Perl_sv_copypv
 Perl_my_atof2
 Perl_my_socketpair
+Perl_sv_setsv_cow
 Perl_PerlIO_close
 Perl_PerlIO_fill
 Perl_PerlIO_fileno
diff --git a/pod/perlapi.pod b/pod/perlapi.pod
index 59b80c3..1d61560 100644
--- a/pod/perlapi.pod
+++ b/pod/perlapi.pod
@@ -3764,7 +3764,7 @@ an xpvmg; if we're a copy-on-write scalar, this is the on-write time when
 we do the copy, and is also used locally. If C<SV_COW_DROP_PV> is set
 then a copy-on-write scalar drops its PV buffer (if any) and becomes
 SvPOK_off rather than making a copy. (Used where this scalar is about to be
-set to some other value. In addtion, the C<flags> parameter gets passed to
+set to some other value.) In addtion, the C<flags> parameter gets passed to
 C<sv_unref_flags()> when unrefing. C<sv_force_normal> calls this function
 with flags set to 0.
 
diff --git a/pp_ctl.c b/pp_ctl.c
index 5699b7c..9a807a5 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -181,9 +181,16 @@ PP(pp_substcont)
 	    sv_catpvn(dstr, s, cx->sb_strend - s);
 	    cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
 
-	    (void)SvOOK_off(targ);
-	    if (SvLEN(targ))
-		Safefree(SvPVX(targ));
+#ifdef PERL_COPY_ON_WRITE
+	    if (SvIsCOW(targ)) {
+		sv_force_normal_flags(targ, SV_COW_DROP_PV);
+	    } else
+#endif
+	    {
+		(void)SvOOK_off(targ);
+		if (SvLEN(targ))
+		    Safefree(SvPVX(targ));
+	    }
 	    SvPVX(targ) = SvPVX(dstr);
 	    SvCUR_set(targ, SvCUR(dstr));
 	    SvLEN_set(targ, SvLEN(dstr));
@@ -244,7 +251,11 @@ Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
     U32 i;
 
     if (!p || p[1] < rx->nparens) {
+#ifdef PERL_COPY_ON_WRITE
+	i = 7 + rx->nparens * 2;
+#else
 	i = 6 + rx->nparens * 2;
+#endif
 	if (!p)
 	    New(501, p, i, UV);
 	else
@@ -255,6 +266,11 @@ Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
     *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : Nullch);
     RX_MATCH_COPIED_off(rx);
 
+#ifdef PERL_COPY_ON_WRITE
+    *p++ = PTR2UV(rx->saved_copy);
+    rx->saved_copy = Nullsv;
+#endif
+
     *p++ = rx->nparens;
 
     *p++ = PTR2UV(rx->subbeg);
@@ -271,11 +287,17 @@ Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
     UV *p = (UV*)*rsp;
     U32 i;
 
-    if (RX_MATCH_COPIED(rx))
-	Safefree(rx->subbeg);
+    RX_MATCH_COPY_FREE(rx);
     RX_MATCH_COPIED_set(rx, *p);
     *p++ = 0;
 
+#ifdef PERL_COPY_ON_WRITE
+    if (rx->saved_copy)
+	SvREFCNT_dec (rx->saved_copy);
+    rx->saved_copy = INT2PTR(SV*,*p);
+    *p++ = 0;
+#endif
+
     rx->nparens = *p++;
 
     rx->subbeg = INT2PTR(char*,*p++);
@@ -293,6 +315,11 @@ Perl_rxres_free(pTHX_ void **rsp)
 
     if (p) {
 	Safefree(INT2PTR(char*,*p));
+#ifdef PERL_COPY_ON_WRITE
+	if (p[1]) {
+	    SvREFCNT_dec (INT2PTR(SV*,p[1]));
+	}
+#endif
 	Safefree(p);
 	*rsp = Null(void*);
     }
diff --git a/pp_hot.c b/pp_hot.c
index 57766e8..63f8b9d 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -1367,8 +1367,26 @@ yup:					/* Confirmed by INTUIT */
     }
     if (PL_sawampersand) {
 	I32 off;
+#ifdef PERL_COPY_ON_WRITE
+	if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
+	    if (DEBUG_C_TEST) {
+		PerlIO_printf(Perl_debug_log,
+			      "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
+			      (int) SvTYPE(TARG), truebase, t,
+			      (int)(t-truebase));
+	    }
+	    rx->saved_copy = sv_setsv_cow(rx->saved_copy, TARG);
+	    rx->subbeg = SvPVX(rx->saved_copy) + (t - truebase);
+	    assert (SvPOKp(rx->saved_copy));
+	} else
+#endif
+	{
 
-	rx->subbeg = savepvn(t, strend - t);
+	    rx->subbeg = savepvn(t, strend - t);
+#ifdef PERL_COPY_ON_WRITE
+	    rx->saved_copy = Nullsv;
+#endif
+	}
 	rx->sublen = strend - t;
 	RX_MATCH_COPIED_on(rx);
 	off = rx->startp[0] = s - t;
@@ -1880,6 +1898,9 @@ PP(pp_subst)
     I32 oldsave = PL_savestack_ix;
     STRLEN slen;
     bool doutf8 = FALSE;
+#ifdef PERL_COPY_ON_WRITE
+    bool is_cow;
+#endif
 
     /* known replacement string? */
     dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
@@ -1890,11 +1911,21 @@ PP(pp_subst)
 	EXTEND(SP,1);
     }
 
+#ifdef PERL_COPY_ON_WRITE
+    /* Awooga. Awooga. "bool" types that are actually char are dangerous,
+       because they make integers such as 256 "false".  */
+    is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
+#else
     if (SvIsCOW(TARG))
 	sv_force_normal_flags(TARG,0);
-    if (SvREADONLY(TARG)
+#endif
+    if (
+#ifdef PERL_COPY_ON_WRITE
+	!is_cow &&
+#endif
+	(SvREADONLY(TARG)
 	|| (SvTYPE(TARG) > SVt_PVLV
-	    && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG))))
+	    && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
 	DIE(aTHX_ PL_no_modify);
     PUTBACK;
 
@@ -1924,7 +1955,7 @@ PP(pp_subst)
 	rx = PM_GETRE(pm);
     }
     r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
-		? REXEC_COPY_STR : 0;
+	       ? REXEC_COPY_STR : 0;
     if (SvSCREAM(TARG))
 	r_flags |= REXEC_SCREAM;
     if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
@@ -1975,7 +2006,11 @@ PP(pp_subst)
     }
     
     /* can do inplace substitution? */
-    if (c && (I32)clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
+    if (c
+#ifdef PERL_COPY_ON_WRITE
+	&& !is_cow
+#endif
+	&& (I32)clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
 	&& !(rx->reganch & ROPT_LOOKBEHIND_SEEN)) {
 	if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
 			 r_flags | REXEC_CHECKED))
@@ -1985,6 +2020,12 @@ PP(pp_subst)
 	    LEAVE_SCOPE(oldsave);
 	    RETURN;
 	}
+#ifdef PERL_COPY_ON_WRITE
+	if (SvIsCOW(TARG)) {
+	    assert (!force_on_match);
+	    goto have_a_cow;
+	}
+#endif
 	if (force_on_match) {
 	    force_on_match = 0;
 	    s = SvPV_force(TARG, len);
@@ -2086,6 +2127,9 @@ PP(pp_subst)
 	    s = SvPV_force(TARG, len);
 	    goto force_it;
 	}
+#ifdef PERL_COPY_ON_WRITE
+      have_a_cow:
+#endif
 	rxtainted |= RX_MATCH_TAINTED(rx);
 	dstr = NEWSV(25, len);
 	sv_setpvn(dstr, m, s-m);
@@ -2128,9 +2172,21 @@ PP(pp_subst)
 	else
 	    sv_catpvn(dstr, s, strend - s);
 
-	(void)SvOOK_off(TARG);
-	if (SvLEN(TARG))
-	    Safefree(SvPVX(TARG));
+#ifdef PERL_COPY_ON_WRITE
+	/* 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 than the
+	   regexp malloc()ing a buffer and copying our original, only for
+	   us to throw it away here during the substitution.  */
+	if (SvIsCOW(TARG)) {
+	    sv_force_normal_flags(TARG, SV_COW_DROP_PV);
+	} else
+#endif
+	{
+	    (void)SvOOK_off(TARG);
+	    if (SvLEN(TARG))
+		Safefree(SvPVX(TARG));
+	}
 	SvPVX(TARG) = SvPVX(dstr);
 	SvCUR_set(TARG, SvCUR(dstr));
 	SvLEN_set(TARG, SvLEN(dstr));
diff --git a/proto.h b/proto.h
index 2abd2d9..ec3fd34 100644
--- a/proto.h
+++ b/proto.h
@@ -1333,6 +1333,9 @@ PERL_CALLCONV char*	Perl_sv_2pv_flags(pTHX_ SV* sv, STRLEN* lp, I32 flags);
 PERL_CALLCONV void	Perl_sv_copypv(pTHX_ SV* dsv, SV* ssv);
 PERL_CALLCONV char*	Perl_my_atof2(pTHX_ const char *s, NV* value);
 PERL_CALLCONV int	Perl_my_socketpair(int family, int type, int protocol, int fd[2]);
+#ifdef PERL_COPY_ON_WRITE
+PERL_CALLCONV SV*	Perl_sv_setsv_cow(pTHX_ SV* dsv, SV* ssv);
+#endif
 
 #if defined(USE_PERLIO) && !defined(USE_SFIO)
 PERL_CALLCONV int	Perl_PerlIO_close(pTHX_ PerlIO *);
diff --git a/regcomp.c b/regcomp.c
index 6ecb978..e49c46b 100644
--- a/regcomp.c
+++ b/regcomp.c
@@ -1778,6 +1778,9 @@ Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm)
     r->prelen = xend - exp;
     r->precomp = savepvn(RExC_precomp, r->prelen);
     r->subbeg = NULL;
+#ifdef PERL_COPY_ON_WRITE
+    r->saved_copy = Nullsv;
+#endif
     r->reganch = pm->op_pmflags & PMf_COMPILETIME;
     r->nparens = RExC_npar - 1;	/* set early to validate backrefs */
 
@@ -4900,8 +4903,11 @@ Perl_pregfree(pTHX_ struct regexp *r)
 	Safefree(r->precomp);
     if (r->offsets)             /* 20010421 MJD */
 	Safefree(r->offsets);
-    if (RX_MATCH_COPIED(r))
-	Safefree(r->subbeg);
+    RX_MATCH_COPY_FREE(r);
+#ifdef PERL_COPY_ON_WRITE
+    if (r->saved_copy)
+	SvREFCNT_dec(r->saved_copy);
+#endif
     if (r->substrs) {
 	if (r->anchored_substr)
 	    SvREFCNT_dec(r->anchored_substr);
@@ -5054,6 +5060,10 @@ Perl_save_re_context(pTHX)
     PL_reg_oldsaved = Nullch;
     SAVEI32(PL_reg_oldsavedlen);	/* old length of saved substr during match */
     PL_reg_oldsavedlen = 0;
+#ifdef PERL_COPY_ON_WRITE
+    SAVESPTR(PL_nrs);
+    PL_nrs = Nullsv;
+#endif
     SAVEI32(PL_reg_maxiter);		/* max wait until caching pos */
     PL_reg_maxiter = 0;
     SAVEI32(PL_reg_leftiter);		/* wait until caching pos */
diff --git a/regexec.c b/regexec.c
index 40f33d4..4135d36 100644
--- a/regexec.c
+++ b/regexec.c
@@ -2023,17 +2023,28 @@ got_it:
 
     /* make sure $`, $&, $', and $digit will work later */
     if ( !(flags & REXEC_NOT_FIRST) ) {
-	if (RX_MATCH_COPIED(prog)) {
-	    Safefree(prog->subbeg);
-	    RX_MATCH_COPIED_off(prog);
-	}
+	RX_MATCH_COPY_FREE(prog);
 	if (flags & REXEC_COPY_STR) {
 	    I32 i = PL_regeol - startpos + (stringarg - strbeg);
-
-	    s = savepvn(strbeg, i);
-	    prog->subbeg = s;
+#ifdef PERL_COPY_ON_WRITE
+	    if ((SvIsCOW(sv)
+		 || (SvFLAGS(sv) & CAN_COW_MASK) == CAN_COW_FLAGS)) {
+		if (DEBUG_C_TEST) {
+		    PerlIO_printf(Perl_debug_log,
+				  "Copy on write: regexp capture, type %d\n",
+				  (int) SvTYPE(sv));
+		}
+		prog->saved_copy = sv_setsv_cow(prog->saved_copy, sv);
+		prog->subbeg = SvPVX(prog->saved_copy);
+		assert (SvPOKp(prog->saved_copy));
+	    } else
+#endif
+	    {
+		RX_MATCH_COPIED_on(prog);
+		s = savepvn(strbeg, i);
+		prog->subbeg = s;
+	    }
 	    prog->sublen = i;
-	    RX_MATCH_COPIED_on(prog);
 	}
 	else {
 	    prog->subbeg = strbeg;
@@ -2123,6 +2134,9 @@ S_regtry(pTHX_ regexp *prog, char *startpos)
 		$` inside (?{}) could fail... */
 	    PL_reg_oldsaved = prog->subbeg;
 	    PL_reg_oldsavedlen = prog->sublen;
+#ifdef PERL_COPY_ON_WRITE
+	    PL_nrs = prog->saved_copy;
+#endif
 	    RX_MATCH_COPIED_off(prog);
 	}
 	else
@@ -4555,6 +4569,9 @@ restore_pos(pTHX_ void *arg)
 	if (PL_reg_oldsaved) {
 	    PL_reg_re->subbeg = PL_reg_oldsaved;
 	    PL_reg_re->sublen = PL_reg_oldsavedlen;
+#ifdef PERL_COPY_ON_WRITE
+	    PL_reg_re->saved_copy = PL_nrs;
+#endif
 	    RX_MATCH_COPIED_on(PL_reg_re);
 	}
 	PL_reg_magic->mg_len = PL_reg_oldpos;
diff --git a/regexp.h b/regexp.h
index 0564054..36c03a4 100644
--- a/regexp.h
+++ b/regexp.h
@@ -36,6 +36,9 @@ typedef struct regexp {
         struct reg_data *data;	/* Additional data. */
 	char *subbeg;		/* saved or original string 
 				   so \digit works forever. */
+#ifdef PERL_COPY_ON_WRITE
+        SV *saved_copy;         /* If non-NULL, SV which is COW from original */
+#endif
         U32 *offsets;           /* offset annotations 20001228 MJD */
 	I32 sublen;		/* Length of string pointed by subbeg */
 	I32 refcnt;
@@ -100,6 +103,23 @@ typedef struct regexp {
 					 ? RX_MATCH_COPIED_on(prog) \
 					 : RX_MATCH_COPIED_off(prog))
 
+#ifdef PERL_COPY_ON_WRITE
+#define RX_MATCH_COPY_FREE(rx) \
+	STMT_START {if (rx->saved_copy) { \
+	    SV_CHECK_THINKFIRST_COW_DROP(rx->saved_copy); \
+	} \
+	if (RX_MATCH_COPIED(rx)) { \
+	    Safefree(rx->subbeg); \
+	    RX_MATCH_COPIED_off(rx); \
+	}} STMT_END
+#else
+#define RX_MATCH_COPY_FREE(rx) \
+	STMT_START {if (RX_MATCH_COPIED(rx)) { \
+	    Safefree(rx->subbeg); \
+	    RX_MATCH_COPIED_off(rx); \
+	}} STMT_END
+#endif
+
 #define RX_MATCH_UTF8(prog)		((prog)->reganch & ROPT_MATCH_UTF8)
 #define RX_MATCH_UTF8_on(prog)		((prog)->reganch |= ROPT_MATCH_UTF8)
 #define RX_MATCH_UTF8_off(prog)		((prog)->reganch &= ~ROPT_MATCH_UTF8)
diff --git a/sv.c b/sv.c
index b67b435..aa2b2f5 100644
--- a/sv.c
+++ b/sv.c
@@ -28,10 +28,6 @@
 #define SV_COW_NEXT_SV_SET(current,next)	SvUVX(current) = PTR2UV(next)
 /* This is a pessimistic view. Scalar must be purely a read-write PV to copy-
    on-write.  */
-#define CAN_COW_MASK	(SVs_OBJECT|SVs_GMG|SVs_SMG|SVs_RMG|SVf_IOK|SVf_NOK| \
-			 SVf_POK|SVf_ROK|SVp_IOK|SVp_NOK|SVp_POK|SVf_FAKE| \
-			 SVf_OOK|SVf_BREAK|SVf_READONLY|SVf_AMAGIC)
-#define CAN_COW_FLAGS	(SVp_POK|SVf_POK)
 #endif
 
 /* ============================================================================
@@ -1566,8 +1562,6 @@ Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
 {
     register char *s;
 
-
-
 #ifdef HAS_64K_LIMIT
     if (newlen >= 0x10000) {
 	PerlIO_printf(Perl_debug_log,
@@ -3944,8 +3938,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
             /* Either it's a shared hash key, or it's suitable for
                copy-on-write or we can swipe the string.  */
             if (DEBUG_C_TEST) {
-                PerlIO_printf(Perl_debug_log,
-                              "Copy on write: sstr --> dstr\n");
+                PerlIO_printf(Perl_debug_log, "Copy on write: sstr --> dstr\n");
                 sv_dump(sstr);
                 sv_dump(dstr);
             }
@@ -4098,6 +4091,77 @@ Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
     SvSETMAGIC(dstr);
 }
 
+#ifdef PERL_COPY_ON_WRITE
+SV *
+Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
+{
+    STRLEN cur = SvCUR(sstr);
+    STRLEN len = SvLEN(sstr);
+    register char *new_pv;
+
+    if (DEBUG_C_TEST) {
+	PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n",
+		      sstr, dstr);
+	sv_dump(sstr);
+	if (dstr)
+		    sv_dump(dstr);
+    }
+
+    if (dstr) {
+	if (SvTHINKFIRST(dstr))
+	    sv_force_normal_flags(dstr, SV_COW_DROP_PV);
+	else if (SvPVX(dstr))
+	    Safefree(SvPVX(dstr));
+    }
+    else
+	new_SV(dstr);
+    SvUPGRADE (dstr, SVt_PVIV);
+
+    assert (SvPOK(sstr));
+    assert (SvPOKp(sstr));
+    assert (!SvIOK(sstr));
+    assert (!SvIOKp(sstr));
+    assert (!SvNOK(sstr));
+    assert (!SvNOKp(sstr));
+
+    if (SvIsCOW(sstr)) {
+
+	if (SvLEN(sstr) == 0) {
+	    /* source is a COW shared hash key.  */
+	    UV hash = SvUVX(sstr);
+	    DEBUG_C(PerlIO_printf(Perl_debug_log,
+				  "Fast copy on write: Sharing hash\n"));
+	    SvUVX(dstr) = hash;
+	    new_pv = sharepvn(SvPVX(sstr), (SvUTF8(sstr)?-cur:cur), hash);
+	    goto common_exit;
+	}
+	SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
+    } else {
+	assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS);
+	SvUPGRADE (sstr, SVt_PVIV);
+	SvREADONLY_on(sstr);
+	SvFAKE_on(sstr);
+	DEBUG_C(PerlIO_printf(Perl_debug_log,
+			      "Fast copy on write: Converting sstr to COW\n"));
+	SV_COW_NEXT_SV_SET(dstr, sstr);
+    }
+    SV_COW_NEXT_SV_SET(sstr, dstr);
+    new_pv = SvPVX(sstr);
+
+  common_exit:
+    SvPV_set(dstr, new_pv);
+    SvFLAGS(dstr) = (SVt_PVIV|SVf_POK|SVp_POK|SVf_FAKE|SVf_READONLY);
+    if (SvUTF8(sstr))
+	SvUTF8_on(dstr);
+    SvLEN(dstr) = len;
+    SvCUR(dstr) = cur;
+    if (DEBUG_C_TEST) {
+	sv_dump(dstr);
+    }
+    return dstr;
+}
+#endif
+
 /*
 =for apidoc sv_setpvn
 
@@ -4299,7 +4363,7 @@ an xpvmg; if we're a copy-on-write scalar, this is the on-write time when
 we do the copy, and is also used locally. If C<SV_COW_DROP_PV> is set
 then a copy-on-write scalar drops its PV buffer (if any) and becomes
 SvPOK_off rather than making a copy. (Used where this scalar is about to be
-set to some other value. In addtion, the C<flags> parameter gets passed to
+set to some other value.) In addtion, the C<flags> parameter gets passed to
 C<sv_unref_flags()> when unrefing. C<sv_force_normal> calls this function
 with flags set to 0.
 
@@ -11120,6 +11184,9 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     PL_reg_curpm	= (PMOP*)NULL;
     PL_reg_oldsaved	= Nullch;
     PL_reg_oldsavedlen	= 0;
+#ifdef PERL_COPY_ON_WRITE
+    PL_nrs		= NullSv;
+#endif
     PL_reg_maxiter	= 0;
     PL_reg_leftiter	= 0;
     PL_reg_poscache	= Nullch;
diff --git a/sv.h b/sv.h
index cf408e8..956340a 100644
--- a/sv.h
+++ b/sv.h
@@ -1069,6 +1069,12 @@ otherwise.
 #  define SvRELEASE_IVX(sv)   ((void)((SvFLAGS(sv) & (SVf_OOK|SVf_READONLY|SVf_FAKE)) \
 				&& Perl_sv_release_IVX(aTHX_ sv)))
 #  define SvIsCOW_normal(sv)	(SvIsCOW(sv) && SvLEN(sv))
+
+#define CAN_COW_MASK	(SVs_OBJECT|SVs_GMG|SVs_SMG|SVs_RMG|SVf_IOK|SVf_NOK| \
+			 SVf_POK|SVf_ROK|SVp_IOK|SVp_NOK|SVp_POK|SVf_FAKE| \
+			 SVf_OOK|SVf_BREAK|SVf_READONLY|SVf_AMAGIC)
+#define CAN_COW_FLAGS	(SVp_POK|SVf_POK)
+
 #else
 #  define SvRELEASE_IVX(sv)   ((void)SvOOK_off(sv))
 #endif /* PERL_COPY_ON_WRITE */
diff --git a/thrdvar.h b/thrdvar.h
index 6058642..db38d2f 100644
--- a/thrdvar.h
+++ b/thrdvar.h
@@ -90,7 +90,7 @@ PERLVAR(Ttimesbuf,	struct tms)
 /* Fields used by magic variables such as $@, $/ and so on */
 PERLVAR(Ttainted,	bool)		/* using variables controlled by $< */
 PERLVAR(Tcurpm,		PMOP *)		/* what to do \ interps in REs from */
-PERLVAR(Tnrs,		SV *)		/* placeholder: unused since 5.8.0 (5.7.2 patch #12027 for bug ID 20010815.012) */
+PERLVAR(Tnrs,		SV *)		/* was placeholder: unused since 5.8.0 (5.7.2 patch #12027 for bug ID 20010815.012). Used to save rx->saved_copy */
 
 /*
 =for apidoc mn|SV*|PL_rs