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.

1 files changed, 17 insertions, 10 deletions

diff --git a/utf8.c b/utf8.c
index aab7bcf99a..b4810f11e6 100644
--- 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;
-	    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;