Min string length for COW

We have two separate length thresholds for when copy-on-write kicks
in, one for when a buffer would have had to be (re)allocated
(SV_COW_THRESHOLD) and another for when there is already a large
enough buffer available (SV_COWBUF_THRESHOLD).

Benchmarking against mktables and against Test.Simple’s test suite
(see JS::Test::Simple on CPAN) run with WWW::Scripter and JE shows
that 0/1250 is the best combination, at least on 32-bit darwin.

Apparently, copying into an existing buffer is much faster than the
bookkeeping overhead of sv_force_normal_flags (which I see no way to
speed up).

I have defined these conditionally with #ifndef, so that platform-spe-
cific hints can override them with values appropriate to the platform.

Also, refactor things in sv_setsv_flags slightly to avoid using SvLEN
and SvCUR repeatedly.

2 files changed, 30 insertions, 9 deletions

diff --git a/sv.c b/sv.c
index 3a9824b548..207b7595ca 100644
--- a/sv.c
+++ b/sv.c
@@ -3913,6 +3913,19 @@ S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr)
     return;
 }
 
+/* Work around compiler warnings about unsigned >= THRESHOLD when thres-
+   hold is 0. */
+#if SV_COW_THRESHOLD
+# define GE_COW_THRESHOLD(len)		((len) >= SV_COW_THRESHOLD)
+#else
+# define GE_COW_THRESHOLD(len)		1
+#endif
+#if SV_COWBUF_THRESHOLD
+# define GE_COWBUF_THRESHOLD(len)	((len) >= SV_COWBUF_THRESHOLD)
+#else
+# define GE_COWBUF_THRESHOLD(len)	1
+#endif
+
 void
 Perl_sv_setsv_flags(pTHX_ SV *dstr, SV* sstr, const I32 flags)
 {
@@ -4178,6 +4191,8 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, SV* sstr, const I32 flags)
     }
     else if (sflags & SVp_POK) {
         bool isSwipe = 0;
+	const STRLEN cur = SvCUR(sstr);
+	const STRLEN len = SvLEN(sstr);
 
 	/*
 	 * Check to see if we can just swipe the string.  If so, it's a
@@ -4202,9 +4217,11 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, SV* sstr, const I32 flags)
             (((flags & SV_COW_SHARED_HASH_KEYS)
 	       ? !(sflags & SVf_IsCOW)
 #ifdef PERL_NEW_COPY_ON_WRITE
+		|| (len &&
+		    ((!GE_COWBUF_THRESHOLD(cur) && SvLEN(dstr) > cur)
 		   /* If this is a regular (non-hek) COW, only so many COW
 		      "copies" are possible. */
-		|| (SvLEN(sstr) && CowREFCNT(sstr) == SV_COW_REFCNT_MAX)
+		    || 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
@@ -4236,7 +4253,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, SV* sstr, const I32 flags)
 	         (!(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 */
+                 len)             /* and really is a string */
 #ifdef PERL_ANY_COW
             && ((flags & SV_COW_SHARED_HASH_KEYS)
 		? (!((sflags & CAN_COW_MASK) == CAN_COW_FLAGS
@@ -4245,7 +4262,8 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, SV* sstr, const I32 flags)
 		     && SvTYPE(sstr) >= SVt_PVIV
 # else
 		     && !(sflags & SVf_IsCOW)
-		     && SvCUR(sstr)+1 < SvLEN(sstr)
+		     && GE_COW_THRESHOLD(cur) && cur+1 < len
+		     && (GE_COWBUF_THRESHOLD(cur) || SvLEN(dstr) < cur+1)
 # endif
 		    ))
 		: 1)
@@ -4253,10 +4271,9 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, SV* sstr, const I32 flags)
             ) {
             /* Failed the swipe test, and it's not a shared hash key either.
                Have to copy the string.  */
-	    STRLEN len = SvCUR(sstr);
-            SvGROW(dstr, len + 1);	/* inlined from sv_setpvn */
-            Move(SvPVX_const(sstr),SvPVX(dstr),len,char);
-            SvCUR_set(dstr, len);
+            SvGROW(dstr, cur + 1);	/* inlined from sv_setpvn */
+            Move(SvPVX_const(sstr),SvPVX(dstr),cur,char);
+            SvCUR_set(dstr, cur);
             *SvEND(dstr) = '\0';
         } else {
             /* If PERL_OLD_COPY_ON_WRITE is not defined, then isSwipe will always
@@ -4289,8 +4306,6 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, SV* sstr, const I32 flags)
 
             if (!isSwipe) {
                 /* making another shared SV.  */
-                STRLEN cur = SvCUR(sstr);
-                STRLEN len = SvLEN(sstr);
 #ifdef PERL_ANY_COW
                 if (len) {
 # ifdef PERL_OLD_COPY_ON_WRITE
diff --git a/sv.h b/sv.h
index c6c05e3e7b..a44b831215 100644
--- a/sv.h
+++ b/sv.h
@@ -1853,6 +1853,12 @@ mg.c:1024: warning: left-hand operand of comma expression has no effect
    /* 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)
+#   ifndef SV_COW_THRESHOLD
+#    define SV_COW_THRESHOLD	0	/* min string length for cow */
+#   endif
+#   ifndef SV_COWBUF_THRESHOLD
+#    define SV_COWBUF_THRESHOLD	1250	/* min string length for cow */
+#   endif				/* over existing buffer */
 #  endif
 #endif /* PERL_OLD_COPY_ON_WRITE */