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.

diff --git a/ext/Devel-Peek/t/Peek.t b/ext/Devel-Peek/t/Peek.t
index ed4799c..d0f8270 100644 (file)
--- 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
index 7d38bb2..c06e796 100644 (file)
--- 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
index b873110..4c3fdbb 100644 (file)
--- 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