New COW mechanism

This was discussed in ticket #114820.

This new copy-on-write mechanism stores a reference count for the
PV inside the PV itself, at the very end.  (I was using SvEND+1
at first, but parts of the regexp engine expect to be able to do
SvCUR_set(sv,0), which causes the wrong byte of the string to be used
as the reference count.)  Only 256 SVs can share the same PV this way.
Also, only strings with allocated space after the trailing null can
be used for copy-on-write.

Much of the code is shared with PERL_OLD_COPY_ON_WRITE.  The restric-
tion against doing copy-on-write with magical variables has hence been
inherited, though it is not necessary.  A future commit will take
care of that.

I had to modify _core_swash_init to handle $@ differently.  The exist-
ing mechanism of copying $@ to a new scalar and back again was very
fragile.  With copy-on-write, $@ =~ s/// can cause pp_subst’s string
pointers to become stale.  So now we remove the scalar from *@ and
allow the utf8-table-loading code to autovivify a new one.  Then we
restore the untouched $@ afterwards if all goes well.

diff --git a/dump.c b/dump.c
index 8ba60cf..f1622a9 100644 (file)
--- a/dump.c
+++ b/dump.c
@@ -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));
            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");
        }
        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));
                                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
            Perl_dump_indent(aTHX_ level, file, "  SAVED_COPY = 0x%"UVxf"\n",
                                PTR2UV(r->saved_copy));
 #endif

diff --git a/embed.fnc b/embed.fnc
index b0ed87a..e4a17b3 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -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
 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
 : Used in pp_hot.c and regexec.c
 pMXE   |SV*    |sv_setsv_cow   |NULLOK SV* dstr|NN SV* sstr
 #endif

diff --git a/embed.h b/embed.h
index e2c2990..c5b169d 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -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
 #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)
 #  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
 #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)
 #endif
 #ifdef PERL_CORE
 #define Slab_Alloc(a)          Perl_Slab_Alloc(aTHX_ a)

diff --git a/makedef.pl b/makedef.pl
index 9550042..7afc35f 100644 (file)
--- 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};
 }
 
     ++$skip{Perl_sv_setsv_cow};
 }
 

diff --git a/perl.h b/perl.h
index 5e28ba7..0f85d28 100644 (file)
--- a/perl.h
+++ b/perl.h
@@ -2494,6 +2494,14 @@ typedef AV PAD;
 typedef AV PADNAMELIST;
 typedef SV PADNAME;
 
 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)
 #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_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
 #  ifdef PERL_POISON
                             " PERL_POISON"
 #  endif

diff --git a/pp_ctl.c b/pp_ctl.c
index c9e4ac4..f889ca8 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -354,7 +354,7 @@ Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
     PERL_UNUSED_CONTEXT;
 
     if (!p || p[1] < RX_NPARENS(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;
        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);
 
     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
     *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++;
 
     *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);
     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
     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
 
        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
         SvREFCNT_dec (INT2PTR(SV*,p[2]));
 #endif
 #ifdef PERL_POISON

diff --git a/pp_hot.c b/pp_hot.c
index 96b81c4..4f9ad84 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -1571,8 +1571,8 @@ yup:                                      /* Confirmed by INTUIT */
     }
     if (PL_sawampersand || RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY) {
        I32 off;
     }
     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",
            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);
        {
 
            RX_SUBBEG(rx) = savepvn(t, strend - t);

-#ifdef PERL_OLD_COPY_ON_WRITE
+#ifdef PERL_ANY_COW

            RX_SAVED_COPY(rx) = NULL;
 #endif
        }
            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 */
     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;
     bool is_cow;
 #endif
     SV *nsv = NULL;


@@ -2167,7 +2167,7 @@ PP(pp_subst)
     }
 
     SvGETMAGIC(TARG); /* must come before cow check */
     }
 
     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;
     /* 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)
        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)
        && !is_cow
 #endif
        && (SvREADONLY(TARG)


@@ -2284,7 +2284,7 @@ PP(pp_subst)
     
     /* can do inplace substitution? */
     if (c
     
     /* can do inplace substitution? */
     if (c

-#ifdef PERL_OLD_COPY_ON_WRITE
+#ifdef PERL_ANY_COW

        && !is_cow
 #endif
         && (I32)clen <= RX_MINLENRET(rx)
        && !is_cow
 #endif
         && (I32)clen <= RX_MINLENRET(rx)


@@ -2294,7 +2294,7 @@ PP(pp_subst)
        && !(rpm->op_pmflags & PMf_NONDESTRUCT))
     {
 
        && !(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;
        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;
        }
            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 */
       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 {
            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
            /* 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

diff --git a/proto.h b/proto.h
index 3089f0a..10d8889 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -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(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);
 #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_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
 #if defined(PERL_USES_PL_PIDSTATUS) && defined(PERL_IN_UTIL_C)
 STATIC void    S_pidgone(pTHX_ Pid_t pid, int status);
 #endif

diff --git a/regcomp.c b/regcomp.c
index 6042a06..9903510 100644 (file)
--- a/regcomp.c
+++ b/regcomp.c
@@ -14192,7 +14192,7 @@ Perl_pregfree2(pTHX_ REGEXP *rx)
        Safefree(r->substrs);
     }
     RX_MATCH_COPY_FREE(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);
     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);
           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);
     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;
        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
 
     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;
     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
 
     PL_nrs = NULL;
 #endif
 

diff --git a/regexec.c b/regexec.c
index 6bf544e..3b2f012 100644 (file)
--- a/regexec.c
+++ b/regexec.c
@@ -2635,9 +2635,8 @@ got_it:
     /* make sure $`, $&, $', and $digit will work later */
     if ( !(flags & REXEC_NOT_FIRST) ) {
        if (flags & REXEC_COPY_STR) {
     /* 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",
                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;
            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);
            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;
            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);
            rex->saved_copy = PL_nrs;
 #endif
            RXp_MATCH_COPIED_on(rex);

diff --git a/regexp.h b/regexp.h
index 5b07a26..8a067eb 100644 (file)
--- a/regexp.h
+++ b/regexp.h
@@ -46,7 +46,7 @@ struct reg_substr_data {
     struct reg_substr_datum data[3];   /* Actual array */
 };
 
     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
 #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 */
 
 
 /* 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)); \
 #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 */
     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
 };
     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
 };

diff --git a/sv.c b/sv.c
index 0a4d26f..3a9824b 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -1502,7 +1502,10 @@ Perl_sv_grow(pTHX_ SV *const sv, STRLEN newlen)
 #endif
     }
     else
 #endif
     }
     else

+    {
+       if (SvIsCOW(sv)) sv_force_normal(sv);

        s = SvPVX_mutable(sv);
        s = SvPVX_mutable(sv);

+    }

 
     if (newlen > SvLEN(sv)) {          /* need more room? */
        STRLEN minlen = SvCUR(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)
               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.  */
              )
               : 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
             /* 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 =
             )
             &&
             !(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? */
                  (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 */
                  !(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
             && ((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
             ) {
                : 1)
 #endif
             ) {


@@ -4249,13 +4268,17 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, SV* sstr, const I32 flags)
                 sv_dump(sstr);
                 sv_dump(dstr);
             }
                 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);
             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);
                     /* 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
                 }
             }
 #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);
                 /* making another shared SV.  */
                 STRLEN cur = SvCUR(sstr);
                 STRLEN len = SvLEN(sstr);

-#ifdef PERL_OLD_COPY_ON_WRITE
+#ifdef PERL_ANY_COW

                 if (len) {
                 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);
                    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
                     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);
 }
 
     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)
 {
 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);
     }
     else
        new_SV(dstr);

-    SvUPGRADE(dstr, SVt_PVIV);
+    SvUPGRADE(dstr, SVt_COW);

 
     assert (SvPOK(sstr));
     assert (SvPOKp(sstr));
 
     assert (SvPOK(sstr));
     assert (SvPOKp(sstr));

+# ifdef PERL_OLD_COPY_ON_WRITE

     assert (!SvIOK(sstr));
     assert (!SvIOKp(sstr));
     assert (!SvNOK(sstr));
     assert (!SvNOKp(sstr));
     assert (!SvIOK(sstr));
     assert (!SvIOKp(sstr));
     assert (!SvNOK(sstr));
     assert (!SvNOKp(sstr));

+# endif

 
     if (SvIsCOW(sstr)) {
 
 
     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;
        }
            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));
        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);
     } 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"));
        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);
        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);
     SV_COW_NEXT_SV_SET(sstr, dstr);

+# else
+    CowREFCNT(sstr)++; 
+# endif

     new_pv = SvPVX_mutable(sstr);
 
   common_exit:
     SvPV_set(dstr, new_pv);
     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);
     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;
 
 
     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();
     }
     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);
                 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:  */
             /* 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) {
             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) {
                 *SvEND(sv) = '\0';
             }
            if (len) {

+# ifdef PERL_OLD_COPY_ON_WRITE

                sv_release_COW(sv, pvx, next);
                sv_release_COW(sv, pvx, next);

+# endif

            } else {
                unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
            }
            } 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);
             }
        }
                 sv_dump(sv);
             }
        }

+    }

 #else
     if (SvREADONLY(sv)) {
        if (IN_PERL_RUNTIME)
 #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;
 
     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
     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;
                }
            }
                        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)))
            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)) {
                        sv_dump(sv);
                    }
                    if (SvLEN(sv)) {

+# ifdef PERL_OLD_COPY_ON_WRITE

                        sv_release_COW(sv, SvPVX_const(sv), SV_COW_NEXT_SV(sv));
                        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 {
                        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));
                }
            }
                    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);
                    = 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
                new_state->re_state_nrs
                    = sv_dup(old_state->re_state_nrs, param);
 #endif

diff --git a/sv.h b/sv.h
index 25ceff9..c6c05e3 100644 (file)
--- a/sv.h
+++ b/sv.h
@@ -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),
     ((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:
 #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)  /**/
 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-
 #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))
 
 
         == (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
 #define SvGROW_mutable(sv,len) \
     (SvLEN(sv) < (len) ? sv_grow(sv,len) : SvPVX_mutable(sv))
 #define Sv_Grow sv_grow

diff --git a/utf8.c b/utf8.c
index aab7bcf..b4810f1 100644 (file)
--- a/utf8.c
+++ b/utf8.c
@@ -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;
        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
            /* 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);
            {
            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;
        }
            }
            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;
        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
        /* 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);
        }
        {
            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;
        }
        LEAVE;
        POPSTACK;