Allow PADTMPs’ strings to be swiped

While copy-on-write does speed things up, it is not perfect. Take this snippet for example: $a = "$b$c"; $a .= $d; The concatenation operator on the rhs of the first line has its own scalar that it reuses every time that operator is called (its target). When the assignment happens, $a and that target share the same string buffer, which is good, because we didn’t have to copy it. But because it is shared between two scalars, the concatenation on the second line forces it to be copied. While copy-on-write may be fast, string swiping surpasses it, because it has no later bookkeeping overhead. If we allow stealing targets’ strings, then $a = "$b$c" no longer causes $a to share the same string buffer as the target; rather, $a steals that buffer and leaves the tar- get undefined. The result is that neither ‘$a =’ nor ‘$a .= $d’ needs to copy any strings. Only the "$b$c" will copy strings (unavoidably). This commit only applies that to long strings, however. This is why: Simply swiping the string from any swipable TARG (which I tried at first) resulted in a significant slowdown. By swiping the string from a TARG that is going to be reused (as opposed to a TEMP about to be freed, which is where swipe was already happening), we force it to allocate another string next time, greatly increasing the number of malloc calls. malloc overhead exceeds the overhead of copying short strings. I tried swiping TARGs for short strings only when the buffer on the lhs was not big enough for a copy (or there wasn’t one), but simple benchmarks with mktables show that even checking SvLEN(dstr) is enough to slow things down, since the speed-up this provides is minimal where short strings are involved. Then I tried checking just the string length, and saw a consistent speed increase. So that’s what this patch uses. Programs using short strings will not benefit. Programs using long strings may see a 1.5% increase in speed, due to fewer string copies.
Perl · Nov 30, 2013 · 9ffd39a · 9ffd39a
1 parent 0fd5eac
commit 9ffd39a
Show file tree

Hide file tree

Showing 3 changed files with 27 additions and 9 deletions.
diff --git a/ext/Devel-Peek/t/Peek.t b/ext/Devel-Peek/t/Peek.t
@@ -509,7 +509,7 @@ do_test('string with Unicode',
   PV = $ADDR "\\\214\\\101\\\0\\\235\\\101"\\\0 \[UTF8 "\\\x\{100\}\\\x\{0\}\\\x\{200\}"\]
   CUR = 5
   LEN = \\d+
-  COW_REFCNT = 1
+  COW_REFCNT = 1					# $] < 5.019006
 ');
 } else {
 do_test('string with Unicode',
@@ -521,7 +521,7 @@ do_test('string with Unicode',
   PV = $ADDR "\\\304\\\200\\\0\\\310\\\200"\\\0 \[UTF8 "\\\x\{100\}\\\x\{0\}\\\x\{200\}"\]
   CUR = 5
   LEN = \\d+
-  COW_REFCNT = 1
+  COW_REFCNT = 1					# $] < 5.019006
 ');
 }
 
@@ -549,7 +549,7 @@ do_test('reference to hash containing Unicode',
       PV = $ADDR "\\\235\\\101"\\\0 \[UTF8 "\\\x\{200\}"\]
       CUR = 2
       LEN = \\d+
-      COW_REFCNT = 1
+      COW_REFCNT = 1				# $] < 5.019006
 ',      '',
 	$] > 5.009
 	? $] >= 5.015
@@ -580,7 +580,7 @@ do_test('reference to hash containing Unicode',
       PV = $ADDR "\\\310\\\200"\\\0 \[UTF8 "\\\x\{200\}"\]
       CUR = 2
       LEN = \\d+
-      COW_REFCNT = 1
+      COW_REFCNT = 1				# $] < 5.019006
 ',      '',
 	$] > 5.009
 	? $] >= 5.015

diff --git a/pp_ctl.c b/pp_ctl.c
@@ -3810,6 +3810,7 @@ PP(pp_require)
 	if (vms_unixname)
 #endif
 	{
+	    SV *nsv = sv;
 	    namesv = newSV_type(SVt_PV);
 	    for (i = 0; i <= AvFILL(ar); i++) {
 		SV * const dirsv = *av_fetch(ar, i, TRUE);
@@ -3834,11 +3835,15 @@ PP(pp_require)
 
 		    ENTER_with_name("call_INC");
 		    SAVETMPS;
+		    if (SvPADTMP(nsv)) {
+			nsv = sv_newmortal();
+			SvSetSV_nosteal(nsv,sv);
+		    }
 		    EXTEND(SP, 2);
 
 		    PUSHMARK(SP);
 		    PUSHs(dirsv);
-		    PUSHs(sv);
+		    PUSHs(nsv);
 		    PUTBACK;
 		    if (sv_isobject(loader))
 			count = call_method("INC", G_ARRAY);

diff --git a/sv.c b/sv.c
@@ -4358,12 +4358,20 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, SV* sstr, const I32 flags)
 	     )
             &&
             !(isSwipe =
+                 (              /* Either ... */
 #ifdef PERL_NEW_COPY_ON_WRITE
 				/* slated for free anyway (and not COW)? */
-                 (sflags & (SVs_TEMP|SVf_IsCOW)) == SVs_TEMP &&
+                    (sflags & (SVs_TEMP|SVf_IsCOW)) == SVs_TEMP
 #else
-                 (sflags & SVs_TEMP) &&   /* slated for free anyway? */
-#endif
+                    (sflags & SVs_TEMP)   /* slated for free anyway? */
+#endif
+                                /* or a swipable TARG */
+                 || ((sflags & (SVs_PADTMP|SVf_READONLY|SVf_IsCOW))
+                       == SVs_PADTMP
+                                /* whose buffer is worth stealing */
+                     && GE_COWBUF_THRESHOLD(cur)
+                    )
+                 ) &&
                  !(sflags & SVf_OOK) &&   /* and not involved in OOK hack? */
 	         (!(flags & SV_NOSTEAL)) &&
 					/* and we're allowed to steal temps */
@@ -14085,14 +14093,19 @@ Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding)
 	STRLEN len;
 	const char *s;
 	dSP;
+	SV *nsv = sv;
 	ENTER;
 	PUSHSTACK;
 	SAVETMPS;
+	if (SvPADTMP(nsv)) {
+	    nsv = sv_newmortal();
+	    SvSetSV_nosteal(nsv, sv);
+	}
 	save_re_context();
 	PUSHMARK(sp);
 	EXTEND(SP, 3);
 	PUSHs(encoding);
-	PUSHs(sv);
+	PUSHs(nsv);
 /*
   NI-S 2002/07/09
   Passing sv_yes is wrong - it needs to be or'ed set of constants