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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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