add SHORT PVs davem/cow3
authorDavid Mitchell <davem@iabyn.com>
Thu, 27 Apr 2017 15:00:33 +0000 (16:00 +0100)
committerDavid Mitchell <davem@iabyn.com>
Fri, 5 May 2017 11:49:35 +0000 (12:49 +0100)
This commit adds an option for storing small strings (<16 bytes on a
64-bit system) directly in the XPV body of an SV.

It's still work-in-progress. It passes all tests, but could probably
benefit from optimisation work.

It's not enabled by default: perl must be built with the new cpp define
-DPERL_COPY_ON_WRITE3.

As the name implies, this commit is the first part of what's intended to
be a revamp of the COW implementation (COW1 was Nicholas's, COW2 was
sprout's; this is COW3).

The main things this commit does is:

1) Adds an extra pointer-sized field to the XPV structure and all those SV
   types which inherit from it; so there's now (xpv_cur,xpv_len,extra)
   instead of just (xpv_cur,xpv_len) in every string-capable body type.

2) Adds a new SV flag, SVf_SHORTPV, which indicates that the string is
   stored directly in the body.

Under SVf_SHORTPV, sv_any points to the body as normal, but sv_u.svu_pv
points into the middle of the same body, where the (xpv_len,extra) fields
are used as a 16-byte buffer. xpv_cur still holds the current string
length.

The SvLEN() macro has been changed to return a constant value if SVf_SHORTPV.
The SvCUR() and SvPVX() macros are unchanged.

Since derived string types like XPVIV also have the extra field, they can
hold a short string as well as an integer value.

When upgrading a SVf_SHORTPV SV to a new body type, the old body isn't
discarded but remains as the SV's string buffer, so sv_any and sv_u.svu_pv
now point to two different bodies. This means that code calling sv_upgrade
doesn't see the buffer address change. The old body will be freed when the
SV is freed.

Note that nothing under ext/, dist/ or cpan/ needed fixing apart from
ext/PerlIO-encoding/, which did some direct PVX buffer stealing.
(And Peek.t, obviously.)

The main breakages in core itself were places that directly moved a PVX
buffer from one SV to another: typically in the implementation of matching
and substitution - places such as pp_subst.

18 files changed:
dump.c
embed.fnc
ext/Devel-Peek/t/Peek.t
ext/PerlIO-encoding/encoding.pm
ext/PerlIO-encoding/encoding.xs
gv.c
perl.h
pp_ctl.c
pp_hot.c
pp_pack.c
proto.h
regcomp.c
regexec.c
regexp.h
sv.c
sv.h
toke.c
universal.c

diff --git a/dump.c b/dump.c
index 7cdebfe..8f3c8bb 100644 (file)
--- a/dump.c
+++ b/dump.c
@@ -1667,6 +1667,8 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
        if (SvWEAKREF(sv))      sv_catpv(d, "WEAKREF,");
     }
     if (flags & SVf_IsCOW && type != SVt_PVHV) sv_catpvs(d, "IsCOW,");
+    if (SvSHORTPV_TRUELY(sv))
+        sv_catpvs(d, "SHORTPV,");
     append_flags(d, flags, second_sv_flags_names);
     if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)
                           && type != SVt_PVAV) {
@@ -1823,7 +1825,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
                 PerlIO_printf(file, "\n");
             }
            Perl_dump_indent(aTHX_ level, file, "  CUR = %" IVdf "\n", (IV)SvCUR(sv));
-           if (!re)
+           if (!re && !SvSHORTPV_TRUELY(sv))
                Perl_dump_indent(aTHX_ level, file, "  LEN = %" IVdf "\n",
                                       (IV)SvLEN(sv));
 #ifdef PERL_COPY_ON_WRITE
index 654dad9..abb12c0 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -1543,6 +1543,7 @@ poMX      |void   |sv_free2       |NN SV *const sv|const U32 refcnt
 pd     |void   |sv_free_arenas
 Apd    |char*  |sv_gets        |NN SV *const sv|NN PerlIO *const fp|I32 append
 Apd    |char*  |sv_grow        |NN SV *const sv|STRLEN newlen
+Xop    |void   |sv_shortpv_free_any_old_body|NN SV *const sv
 Apd    |void   |sv_inc         |NULLOK SV *const sv
 Apd    |void   |sv_inc_nomg    |NULLOK SV *const sv
 Apmdb  |void   |sv_insert      |NN SV *const bigstr|const STRLEN offset \
index 2b1ed5d..25b35d6 100644 (file)
@@ -17,6 +17,7 @@ use Test::More;
 
 use Devel::Peek;
 
+our $COW3 = ($Config{ccflags} =~ /PERL_COPY_ON_WRITE3\b/);
 our $DEBUG = 0;
 open(SAVERR, ">&STDERR") or die "Can't dup STDERR: $!";
 
@@ -92,8 +93,20 @@ sub do_test {
                if $Config{ccflags} =~
                        /-DPERL_(?:OLD_COPY_ON_WRITE|NO_COW)\b/
                            || $] < 5.019003;
+
+            if ($COW3) {
+                #warn "XXX pat=[$pattern]\n" if ($pattern =~ /COW_REFCNT/);
+                $pattern =~ s/(\bIsCOW\b)/($1|SHORTPV)/mg;
+                $pattern =~ s/(\bPOK,)/$1(SHORTPV,)?/mg;
+                $pattern =~ s/^(\s+COW_REFCNT = .*\n)/($1)\?/mg;
+                $pattern =~ s/^(\s+LEN = \\d\+\n?)/($1)\?/mg;
+            }
+
            print $pattern, "\n" if $DEBUG;
            my ($dump, $dump2) = split m/\*\*\*\*\*\n/, scalar <IN>;
+
+
+
            print $dump, "\n"    if $DEBUG;
            like( $dump, qr/\A$pattern\Z/ms, $_[0])
              or note("line " . (caller)[2]);
@@ -186,10 +199,11 @@ do_test('floating point value',
        $d,
        $] < 5.019003
         || $Config{ccflags} =~ /-DPERL_(?:NO_COW|OLD_COPY_ON_WRITE)\b/
+        || $COW3
        ?
 'SV = PVNV\\($ADDR\\) at $ADDR
   REFCNT = 1
-  FLAGS = \\(NOK,pNOK\\)
+  FLAGS = \\(NOK,(SHORTPV,)?pNOK\\)
   IV = \d+
   NV = 789\\.(?:1(?:000+\d+)?|0999+\d+)
   PV = $ADDR "789"\\\0
@@ -344,6 +358,7 @@ do_test('reference to named subroutine without prototype',
        \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$pattern"
        \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$do_eval"
       \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$sub"
+      \\d+\\. $ADDR<\\d+> FAKE "\\$COW3" flags=0x0 index=0
       \\d+\\. $ADDR<\\d+> FAKE "\\$DEBUG" flags=0x0 index=0
       \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$dump"
       \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$dump2"
@@ -604,7 +619,7 @@ if (${^TAINT}) {
           $ENV{PATH}=@ARGV,  # scalar(@ARGV) is a handy known tainted value
 'SV = PVMG\\($ADDR\\) at $ADDR
   REFCNT = 1
-  FLAGS = \\(GMG,SMG,RMG(?:,POK)?(?:,pIOK)?,pPOK\\)
+  FLAGS = \\(GMG,SMG,RMG(?:,POK)?(?:,SHORTPV)?(?:,pIOK)?,pPOK\\)
   IV = 0
   NV = 0
   PV = $ADDR "0"\\\0
index 08d2df4..3d740b1 100644 (file)
@@ -1,7 +1,7 @@
 package PerlIO::encoding;
 
 use strict;
-our $VERSION = '0.25';
+our $VERSION = '0.26';
 our $DEBUG = 0;
 $DEBUG and warn __PACKAGE__, " called by ", join(", ", caller), "\n";
 
index bb4754f..97e61b7 100644 (file)
@@ -307,9 +307,11 @@ PerlIOEncode_fill(pTHX_ PerlIO * f)
                goto end_of_file;
            }
        }
-       if (SvCUR(e->dataSV)) {
+       if (SvCUR(e->dataSV) || SvSHORTPV(e->dataSV)) {
            /* something left over from last time - create a normal
-              SV with new data appended
+              SV with new data appended. Or it's a (possibly empty)
+               short PV, in which case avoid the branch below that
+               directly manipulates SvPVX.
             */
            if (use + SvCUR(e->dataSV) > e->base.bufsiz) {
                if (e->flags & NEEDS_LINES) {
diff --git a/gv.c b/gv.c
index d32a9c5..04aa86e 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -366,7 +366,7 @@ Perl_gv_init_pvn(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, U32 flag
 {
     const U32 old_type = SvTYPE(gv);
     const bool doproto = old_type > SVt_NULL;
-    char * const proto = (doproto && SvPOK(gv))
+    char * proto = (doproto && SvPOK(gv))
        ? ((void)(SvIsCOW(gv) && (sv_force_normal((SV *)gv), 0)), SvPVX(gv))
        : NULL;
     const STRLEN protolen = proto ? SvCUR(gv) : 0;
@@ -399,6 +399,21 @@ Perl_gv_init_pvn(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, U32 flag
            SvCUR_set(gv, 0);
        sv_upgrade(MUTABLE_SV(gv), SVt_PVGV);
     }
+
+#ifdef PERL_COPY_ON_WRITE3
+    if (SvSHORTPV(gv)) {
+        if (proto) {
+            /* After the upgrade to GV, PVX points to the old PV body
+             * containing the proto. Copy the proto before freeing the
+             * old body */
+            proto = (char*)safemalloc(protolen + 1);
+            Copy(SvPVX_const(gv), proto, protolen + 1, char);
+        }
+        SvPV_free((SV*)gv);
+        SvPOK_off(gv);
+    }
+    else
+#endif
     if (SvLEN(gv)) {
        if (proto) {
            SvPV_set(gv, NULL);
@@ -1262,7 +1277,11 @@ Perl_gv_autoload_pvn(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags)
            sv_setsv_nomg((SV *)cv, tmpsv);
            SvTEMP_off(tmpsv);
            SvREFCNT_dec_NN(tmpsv);
-           SvLEN(cv) = SvCUR(cv) + 1;
+            if (SvSHORTPV(cv))
+                /* SHORTPVs have a fixed len which can't be set. Force it
+                 * to be a non-short PV by growing it beyond its max size */
+                sv_grow((SV*)cv, SvSHORTPV_BUFSIZE + 1);
+            SvLEN_set(cv, SvCUR(cv) + 1);
            SvCUR(cv) = ulen;
        }
        else {
diff --git a/perl.h b/perl.h
index a4f095c..fb31a2a 100644 (file)
--- a/perl.h
+++ b/perl.h
@@ -2685,7 +2685,7 @@ typedef struct padname PADNAME;
 #  define PERL_COPY_ON_WRITE
 #endif
 
-#ifdef PERL_COPY_ON_WRITE
+#if defined(PERL_COPY_ON_WRITE) || defined(PERL_COPY_ON_WRITE3)
 #  define PERL_ANY_COW
 #else
 # define PERL_SAWAMPERSAND
index e75e151..5987455 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -247,13 +247,28 @@ PP(pp_substcont)
            else {
                SV_CHECK_THINKFIRST_COW_DROP(targ);
                if (isGV(targ)) Perl_croak_no_modify();
-               SvPV_free(targ);
-               SvPV_set(targ, SvPVX(dstr));
-               SvCUR_set(targ, SvCUR(dstr));
-               SvLEN_set(targ, SvLEN(dstr));
+
+                /* transfer dstr's string buffer to targ */
+                SvPV_free(targ);
+#ifdef PERL_COPY_ON_WRITE3
+                if (SvSHORTPV(dstr)) {
+                    /* convert targ to SHORTPV */
+                    SvSHORTPV_SET_PV(targ);
+                    SvSHORTPV_on(targ);
+                    SvSHORTPV_COPY(SvPVX_const(dstr), SvPVX_const(targ));
+                    SvCUR_set(targ, SvCUR(dstr));
+                }
+                else
+#endif
+                {
+                    SvPV_set(targ, SvPVX(dstr));
+                    SvCUR_set(targ, SvCUR(dstr));
+                    SvLEN_set(targ, SvLEN(dstr));
+                    SvPV_set(dstr, NULL);
+                }
+
                if (DO_UTF8(dstr))
                    SvUTF8_on(targ);
-               SvPV_set(dstr, NULL);
 
                PL_tainted = 0;
                mPUSHi(saviters - 1);
index 44705b3..9a71861 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -3453,11 +3453,25 @@ PP(pp_subst)
            {
                SvPV_free(TARG);
            }
-           SvPV_set(TARG, SvPVX(dstr));
-           SvCUR_set(TARG, SvCUR(dstr));
-           SvLEN_set(TARG, SvLEN(dstr));
+
+            /* transfer dstr's string buffer to targ */
+#ifdef PERL_COPY_ON_WRITE3
+            if (SvSHORTPV(dstr)) {
+                /* convert TARG to SHORTPV */
+                SvSHORTPV_SET_PV(TARG);
+                SvSHORTPV_on(TARG);
+                SvSHORTPV_COPY(SvPVX_const(dstr), SvPVX_const(TARG));
+                SvCUR_set(TARG, SvCUR(dstr));
+            }
+            else
+#endif
+            {
+                SvPV_set(TARG, SvPVX(dstr));
+                SvCUR_set(TARG, SvCUR(dstr));
+                SvLEN_set(TARG, SvLEN(dstr));
+                SvPV_set(dstr, NULL);
+            }
            SvFLAGS(TARG) |= SvUTF8(dstr);
-           SvPV_set(dstr, NULL);
 
            SPAGAIN;
            mPUSHi(iters);
index 86d138b..806d912 100644 (file)
--- a/pp_pack.c
+++ b/pp_pack.c
@@ -2029,16 +2029,7 @@ marked_upgrade(pTHX_ SV *sv, tempsym_t *sym_ptr) {
        group->strbeg = marks[group->level] - to_start;
     Safefree(marks);
 
-    if (SvOOK(sv)) {
-       if (SvIVX(sv)) {
-           SvLEN_set(sv, SvLEN(sv) + SvIVX(sv));
-           from_start -= SvIVX(sv);
-           SvIV_set(sv, 0);
-       }
-       SvFLAGS(sv) &= ~SVf_OOK;
-    }
-    if (SvLEN(sv) != 0)
-       Safefree(from_start);
+    SvPV_free(sv);
     SvPV_set(sv, to_start);
     SvCUR_set(sv, to_ptr - to_start);
     SvLEN_set(sv, len);
diff --git a/proto.h b/proto.h
index f1d6181..d38d32a 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -3377,6 +3377,9 @@ PERL_CALLCONV void        Perl_sv_setuv(pTHX_ SV *const sv, const UV num);
 PERL_CALLCONV void     Perl_sv_setuv_mg(pTHX_ SV *const sv, const UV u);
 #define PERL_ARGS_ASSERT_SV_SETUV_MG   \
        assert(sv)
+PERL_CALLCONV void     Perl_sv_shortpv_free_any_old_body(pTHX_ SV *const sv);
+#define PERL_ARGS_ASSERT_SV_SHORTPV_FREE_ANY_OLD_BODY  \
+       assert(sv)
 #ifndef NO_MATHOMS
 PERL_CALLCONV void     Perl_sv_taint(pTHX_ SV* sv);
 #define PERL_ARGS_ASSERT_SV_TAINT      \
index 54d641d..790f988 100644 (file)
--- a/regcomp.c
+++ b/regcomp.c
@@ -7209,7 +7209,7 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count,
         assert(sizeof(STD_PAT_MODS) <= 8);
 
         Newx(p, wraplen + 1, char); /* +1 for the ending NUL */
-       r->xpv_len_u.xpvlenu_pv = p;
+       r->xpv_bufu.xpv_bufu_nonbuf.xpv_len_u.xpvlenu_pv = p;
        if (RExC_utf8)
            SvFLAGS(rx) |= SVf_UTF8;
         *p++='('; *p++='?';
@@ -19410,7 +19410,7 @@ Perl_pregfree2(pTHX_ REGEXP *rx)
     } else {
         CALLREGFREE_PVT(rx); /* free the private data */
         SvREFCNT_dec(RXp_PAREN_NAMES(r));
-       Safefree(r->xpv_len_u.xpvlenu_pv);
+       Safefree(r->xpv_bufu.xpv_bufu_nonbuf.xpv_len_u.xpvlenu_pv);
     }
     if (r->substrs) {
         SvREFCNT_dec(r->anchored_substr);
index 35b88d7..2a6ff3f 100644 (file)
--- a/regexec.c
+++ b/regexec.c
@@ -2741,10 +2741,41 @@ S_reg_set_capture_string(pTHX_ REGEXP * const rx,
                             bool utf8_target)
 {
     struct regexp *const prog = ReANY(rx);
+    SSize_t strlen = strend - strbeg;
 
     if (flags & REXEC_COPY_STR) {
+#ifdef PERL_COPY_ON_WRITE3
+        /* the "- 1" is for the \0 */
+        if (!SvIsCOW(sv) && strlen <= (SSize_t)(SvSHORTPV_BUFSIZE - 1)) {
+            SV *copy = prog->saved_copy;
+
+            RX_MATCH_COPY_FREE(rx);
+
+            /* convert copy to, or a create, an SvSHORTPV */
+            if (copy) {
+                if (!SvSHORTPV(copy) && SvPVX_const(copy))
+                    SvPV_free(copy);
+                SvFLAGS(copy) |= (SVf_POK|SVp_POK|SVf_SHORTPV);
+            }
+            else {
+                copy = newSV_type(SVt_PV);
+                SvFLAGS(copy) = (SVf_POK|SVp_POK|SVf_SHORTPV|SVt_PV);
+                prog->saved_copy = copy;
+            }
+            SvSHORTPV_SET_PV(copy);
+
+            if (SvSHORTPV(sv) && SvPVX_const(sv) == strbeg)
+                SvSHORTPV_COPY(SvPVX_const(sv), SvPVX_const(copy));
+            else
+                Copy(strbeg, SvPVX_const(copy), strlen, char);
+            SvCUR_set(copy, strlen);
+            (SvPVX_mutable(copy))[strlen] = '\0';
+            goto common_savedcopy;
+        }
+        else
+#endif
 #ifdef PERL_ANY_COW
-        if (SvCANCOW(sv)) {
+        if (!SvSHORTPV(sv) && SvCANCOW(sv)) {
             DEBUG_C(Perl_re_printf( aTHX_
                               "Copy on write: regexp capture, type %d\n",
                                     (int) SvTYPE(sv)));
@@ -2769,16 +2800,19 @@ S_reg_set_capture_string(pTHX_ REGEXP * const rx,
                 RX_MATCH_COPY_FREE(rx);
                 prog->saved_copy = sv_setsv_cow(prog->saved_copy, sv);
             }
+#ifdef PERL_COPY_ON_WRITE3
+          common_savedcopy:
+#endif
             prog->subbeg = (char *)SvPVX_const(prog->saved_copy);
             assert (SvPOKp(prog->saved_copy));
-            prog->sublen  = strend - strbeg;
+            prog->sublen  = strlen;
             prog->suboffset = 0;
             prog->subcoffset = 0;
         } else
 #endif
         {
             SSize_t min = 0;
-            SSize_t max = strend - strbeg;
+            SSize_t max = strlen;
             SSize_t sublen;
 
             if (    (flags & REXEC_COPY_SKIP_POST)
@@ -2799,7 +2833,7 @@ S_reg_set_capture_string(pTHX_ REGEXP * const rx,
                     max = (PL_sawampersand & SAWAMPERSAND_LEFT)
                             ? prog->offs[0].start
                             : 0;
-                assert(max >= 0 && max <= strend - strbeg);
+                assert(max >= 0 && max <= strlen);
             }
 
             if (    (flags & REXEC_COPY_SKIP_PRE)
@@ -2826,7 +2860,7 @@ S_reg_set_capture_string(pTHX_ REGEXP * const rx,
 
             }
 
-            assert(min >= 0 && min <= max && min <= strend - strbeg);
+            assert(min >= 0 && min <= max && min <= strlen);
             sublen = max - min;
 
             if (RX_MATCH_COPIED(rx)) {
@@ -2842,6 +2876,7 @@ S_reg_set_capture_string(pTHX_ REGEXP * const rx,
             prog->sublen = sublen;
             RX_MATCH_COPIED_on(rx);
         }
+
         prog->subcoffset = prog->suboffset;
         if (prog->suboffset && utf8_target) {
             /* Convert byte offset to chars.
@@ -2871,7 +2906,7 @@ S_reg_set_capture_string(pTHX_ REGEXP * const rx,
         prog->subbeg = strbeg;
         prog->suboffset = 0;
         prog->subcoffset = 0;
-        prog->sublen = strend - strbeg;
+        prog->sublen = strlen;
     }
 }
 
index 9a2b61a..5396691 100644 (file)
--- a/regexp.h
+++ b/regexp.h
@@ -499,7 +499,7 @@ and check for NULL.
    writers? Specifically, the value 1 assumes that the wrapped version always
    has exactly one character at the end, a ')'. Will that always be true?  */
 #define RX_PRELEN(prog)                (RX_WRAPLEN(prog) - ReANY(prog)->pre_prefix - 1)
-#define RX_WRAPPED(prog)       ReANY(prog)->xpv_len_u.xpvlenu_pv
+#define RX_WRAPPED(prog)       ReANY(prog)->xpv_bufu.xpv_bufu_nonbuf.xpv_len_u.xpvlenu_pv
 #define RX_WRAPPED_const(prog) ((const char *)RX_WRAPPED(prog))
 #define RX_WRAPLEN(prog)       SvCUR(prog)
 #define RX_CHECK_SUBSTR(prog)  (ReANY(prog)->check_substr)
diff --git a/sv.c b/sv.c
index f0994ac..b9cc24c 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -949,7 +949,7 @@ static const struct body_details bodies_by_type[] = {
 #endif
 
     { sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur),
-      copy_length(XPV, xpv_len) - STRUCT_OFFSET(XPV, xpv_cur),
+      copy_length(XPV, xpv_bufu) - STRUCT_OFFSET(XPV, xpv_cur),
       + STRUCT_OFFSET(XPV, xpv_cur),
       SVt_PV, FALSE, NONV, HASARENA,
       FIT_ARENA(0, sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur)) },
@@ -1478,6 +1478,21 @@ Perl_sv_upgrade(pTHX_ SV *const sv, svtype new_type)
     /* if this is zero, this is a body-less SVt_NULL, SVt_IV/SVt_RV,
        and sometimes SVt_NV */
     if (old_type_details->body_size) {
+        /* If the PVX is stored in the old body, keep the old body around
+         * (pointed to by SvPVX) with the buffer, so code doesn't see
+         * the buffer address change when the SV is upgraded.
+         * We store the old body type in the old cur field.
+         * The old body will be freed when we free the SV.
+         *
+         * NB the SVf_SHORTPV flag bit has a different meaning for AVs and
+         * HVs, but they're unlikely to have [AH]vARRAY stored in the body
+         */
+        if (   SvSHORTPV(sv)
+            && SvSHORTPV_BODY_FROM_PV(sv->sv_u.svu_pv) == old_body)
+        {
+            ((XPV*)old_body)->xpv_cur = (STRLEN)old_type;
+        }
+        else {
 #ifdef PURIFY
        safefree(old_body);
 #else
@@ -1488,6 +1503,7 @@ Perl_sv_upgrade(pTHX_ SV *const sv, svtype new_type)
        del_body((void*)((char*)old_body + old_type_details->offset),
                 &PL_body_roots[old_type]);
 #endif
+        }
     }
 }
 
@@ -1525,6 +1541,34 @@ Perl_sv_backoff(SV *const sv)
     return;
 }
 
+
+#ifdef PERL_COPY_ON_WRITE3
+
+/* After an upgrade an SvSHORTPV, the SV may have it's PVX pointing to
+ * the old body. If so return it to the appropriate body arena.
+ */
+/* XXX this should really be PERL_STATIC_INLINE, but bodies_by_type isn't
+ * global (yet) */
+void
+Perl_sv_shortpv_free_any_old_body(pTHX_ SV *const sv)
+{
+    void* old_body;
+
+    PERL_ARGS_ASSERT_SV_SHORTPV_FREE_ANY_OLD_BODY;
+    assert(SvSHORTPV(sv));
+    assert(SvPVX_const(sv));
+    old_body = SvSHORTPV_BODY_FROM_PV(SvPVX_mutable(sv));
+    if (SvANY(sv) != old_body) {
+        const svtype old_type = (svtype)(((XPV*)old_body)->xpv_cur);
+        del_body(
+            (void*)(
+              (char*)old_body + bodies_by_type[old_type].offset),
+            &PL_body_roots[old_type]);
+    }
+}
+#endif
+
+
 /*
 =for apidoc sv_grow
 
@@ -1562,6 +1606,23 @@ Perl_sv_grow(pTHX_ SV *const sv, STRLEN newlen)
        s = SvPVX_mutable(sv);
     }
 
+#ifdef PERL_COPY_ON_WRITE3
+    /* try to use a SHORTPV where possible */
+    if (newlen <= SvSHORTPV_BUFSIZE) {
+        if (SvSHORTPV(sv))
+            /* XXX should sv_grow ever be called in this case?
+             * if not, turn into an assert? */
+            return s; /* already set up */
+        if (!s && SvTYPE(sv) != SVt_INVLIST) {
+            /* XXX if already got a buffer, is it worth freeing it
+             * and converting to SHORTPV rather than reallocing? */
+            SvSHORTPV_on(sv);
+            SvSHORTPV_SET_PV(sv);
+            return SvPVX_mutable(sv);
+        }
+    }
+#endif
+
 #ifdef PERL_COPY_ON_WRITE
     /* the new COW scheme uses SvPVX(sv)[SvLEN(sv)-1] (if spare)
      * to store the COW count. So in general, allocate one more byte than
@@ -1594,6 +1655,24 @@ Perl_sv_grow(pTHX_ SV *const sv, STRLEN newlen)
                 newlen = rounded;
         }
 #endif
+
+#ifdef PERL_COPY_ON_WRITE3
+        if (SvSHORTPV(sv)) {
+            /* too long for SHORTPV, convert to a real PV */
+            char *buf = SvPVX_mutable(sv);
+           s = (char*)safemalloc(newlen);
+            /* SvCUR() may not be valid at this point, so copy the whole
+             * buffer, */
+            assert(newlen >= SvSHORTPV_BUFSIZE);
+            Copy(buf, s, SvSHORTPV_BUFSIZE, char);
+            Perl_sv_shortpv_free_any_old_body(aTHX_ sv);
+            SvSHORTPV_off(sv);
+            SvPV_set(sv, s);
+            SvLEN_set(sv, newlen);
+            return s;
+        }
+#endif
+
        if (SvLEN(sv) && s) {
            s = (char*)saferealloc(s, newlen);
        }
@@ -1603,6 +1682,7 @@ Perl_sv_grow(pTHX_ SV *const sv, STRLEN newlen)
                 Move(SvPVX_const(sv), s, SvCUR(sv), char);
            }
        }
+
        SvPV_set(sv, s);
 #ifdef PERL_UNWARANTED_CHUMMINESS_WITH_MALLOC
        /* Do this here, do it once, do it right, and then we will never get
@@ -4645,6 +4725,27 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, SV* sstr, const I32 flags)
           and doing it now facilitates the COW check.  */
        (void)SvPOK_only(dstr);
 
+#ifdef PERL_COPY_ON_WRITE3
+        if (SvSHORTPV(sstr) && (SvSHORTPV(dstr) || !SvPVX_const(dstr))) {
+            /* for short strings, if possible just make the dest a short
+             * string and copy the buffer.
+             * XXX would it be cost-effective to free the buffer if dstr
+             * has one? i.e. skip the !SvPVX_const test above.
+             */
+            if (!SvSHORTPV(dstr)) {
+                /* convert dstr to SHORTPV */
+                assert(!SvPVX_const(dstr));
+                SvSHORTPV_SET_PV(dstr);
+                SvSHORTPV_on(dstr);
+            }
+            SvSHORTPV_COPY(SvPVX_const(sstr), SvPVX_const(dstr));
+           SvCUR_set(dstr, cur);
+            /* should we have inherited the \0 from sstr??? */
+           *SvEND(dstr) = '\0';
+        }
+        else
+#endif
+
        if (
                  (              /* Either ... */
                                /* slated for free anyway (and not COW)? */
@@ -4657,6 +4758,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, SV* sstr, const I32 flags)
                      && CHECK_COWBUF_THRESHOLD(cur,len)
                     )
                  ) &&
+                 !(sflags & SVf_SHORTPV) &&
                  !(sflags & SVf_OOK) &&   /* and not involved in OOK hack? */
                 (!(flags & SV_NOSTEAL)) &&
                                        /* and we're allowed to steal temps */
@@ -4694,6 +4796,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, SV* sstr, const I32 flags)
                 sflags & SVf_IsCOW
              && !(SvFLAGS(dstr) & SVf_BREAK)
 #endif
+              && !(sflags & SVf_SHORTPV)
             ) {
             /* Either it's a shared hash key, or it's suitable for
                copy-on-write.  */
@@ -4887,6 +4990,10 @@ Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
     if (dstr) {
        if (SvTHINKFIRST(dstr))
            sv_force_normal_flags(dstr, SV_COW_DROP_PV);
+       else if (SvSHORTPV(dstr)) {
+            SvSHORTPV_off(dstr);
+            SvPV_set(dstr, NULL);
+        }
        else if (SvPVX_const(dstr))
            Safefree(SvPVX_mutable(dstr));
     }
@@ -5423,6 +5530,18 @@ Perl_sv_chop(pTHX_ SV *const sv, const char *const ptr)
     SvPOK_only_UTF8(sv);
 
     if (!SvOOK(sv)) {
+#ifdef PERL_COPY_ON_WRITE3
+        if (SvSHORTPV(sv)) {
+            /* for short strings, just shift the buffer rather than
+             * doing the OOK hack */
+           const STRLEN len = SvCUR(sv) - delta;
+            if (len > 0)
+                Move(ptr, SvPVX_mutable(sv), len, char);
+            SvCUR_set(sv, len);
+           *SvEND(sv) = '\0';
+            return;
+        }
+#endif
        if (!SvLEN(sv)) { /* make copy of shared string */
            const char *pvx = SvPVX_const(sv);
            const STRLEN len = SvCUR(sv);
@@ -6746,6 +6865,10 @@ Perl_sv_clear(pTHX_ SV *const orig_sv)
                        next_sv = target;
                }
            }
+#ifdef PERL_COPY_ON_WRITE3
+           else if (SvSHORTPV(sv))
+                Perl_sv_shortpv_free_any_old_body(aTHX_ sv);
+#endif
 #ifdef PERL_ANY_COW
            else if (SvPVX_const(sv)
                     && !(SvTYPE(sv) == SVt_PVIO
@@ -13710,6 +13833,18 @@ Perl_rvpv_dup(pTHX_ SV *const dstr, const SV *const sstr, CLONE_PARAMS *const pa
        else
            SvRV_set(dstr, sv_dup_inc(SvRV_const(sstr), param));
     }
+#ifdef PERL_COPY_ON_WRITE3
+    else if (SvSHORTPV(sstr)) {
+        SvSHORTPV_SET_PV(dstr);
+        /* usually the string is in the body, so will already have been
+         * copied when the body was copied, except... */
+        if (SvANY(sstr) != SvSHORTPV_BODY_FROM_PV(SvPVX_mutable(sstr))) {
+            /* ... sstr had SvPVX pointing to an old body containing the
+             * buffer, so need to copy the string */
+            SvSHORTPV_COPY(SvPVX_const(sstr), SvPVX_const(dstr));
+        }
+    }
+#endif
     else if (SvPVX_const(sstr)) {
        /* Has something there */
        if (SvLEN(sstr)) {
diff --git a/sv.h b/sv.h
index 51e9b0b..796d9ba 100644 (file)
--- a/sv.h
+++ b/sv.h
@@ -456,6 +456,8 @@ perform the upgrade if necessary.  See C<L</svtype>>.
 #define SVpav_REAL     0x40000000  /* free old entries */
 /* PVHV */
 #define SVphv_LAZYDEL  0x40000000  /* entry in xhv_eiter must be deleted */
+/* for POK strings */
+#define SVf_SHORTPV    0x40000000  /* string is stored in XPV body */
 
 /* IV, PVIV, PVNV, PVMG, PVGV and (I assume) PVLV  */
 #define SVf_IVisUV     0x80000000  /* use XPVUV instead of XPVIV */
@@ -467,16 +469,40 @@ perform the upgrade if necessary.  See C<L</svtype>>.
 #define SVprv_WEAKREF   0x80000000  /* Weak reference */
 /* pad name vars only */
 
+/* the len+other part of an XPV */
+struct xpv_nonbuf {
+    union {
+        STRLEN xpvlenu_len; /* allocated size */
+        char * xpvlenu_pv;  /* regexp string */
+    } xpv_len_u;
+#ifdef PERL_COPY_ON_WRITE3
+    void* xpv_bufu_unused;   /* XXX reserved for future use */
+#endif
+};                                              \
+
 #define _XPV_HEAD                                                      \
     HV*                xmg_stash;      /* class package */                     \
     union _xmgu        xmg_u;                                                  \
     STRLEN     xpv_cur;        /* length of svu_pv as a C string */    \
+    /* either (len + other), or a small buffer for SVf_SHORTPV */       \
     union {                                                            \
-       STRLEN  xpvlenu_len;    /* allocated size */                    \
-       char *  xpvlenu_pv;     /* regexp string */                     \
-    } xpv_len_u        
+        struct xpv_nonbuf  xpv_bufu_nonbuf;                             \
+        char xpv_bufu_buf[1];        /* Unwarranted chumminess */       \
+    } xpv_bufu;
+
+#define xpv_len        xpv_bufu.xpv_bufu_nonbuf.xpv_len_u.xpvlenu_len
+
+#define SvSHORTPV_BUFSIZE      (sizeof(struct xpv_nonbuf))
+#define SvSHORTPV_BODY_FROM_PV(pv) \
+       ((XPV*)(pv - STRUCT_OFFSET(XPV, xpv_bufu.xpv_bufu_buf)))
+#define SvSHORTPV_PV_FROM_BODY(xpv) \
+       ((char*)xpv + STRUCT_OFFSET(XPV, xpv_bufu.xpv_bufu_buf))
+
+#define SvSHORTPV_SET_PV(sv) \
+    ((sv)->sv_u.svu_pv = SvSHORTPV_PV_FROM_BODY(SvANY(sv)))
 
-#define xpv_len        xpv_len_u.xpvlenu_len
+#define SvSHORTPV_COPY(src_xpv, dst_xpv) \
+        StructCopy(src_xpv, dst_xpv, struct xpv_nonbuf)
 
 union _xnvu {
     NV     xnv_nv;             /* numeric value, if any */
@@ -1069,6 +1095,21 @@ C<sv_force_normal> does nothing.
 # define SvPADMY_on(sv)                SvPADTMP_off(sv)
 #endif
 
+#ifdef PERL_COPY_ON_WRITE3
+#  define SvSHORTPV(sv)         (SvFLAGS(sv) &   SVf_SHORTPV)
+#  define SvSHORTPV_on(sv)      (SvFLAGS(sv) |=  SVf_SHORTPV)
+#  define SvSHORTPV_off(sv)     (SvFLAGS(sv) &= ~SVf_SHORTPV)
+/* this checks the flag only on SV types for which it is valid */
+#  define SvSHORTPV_TRUELY(sv)  (   SvSHORTPV(sv)            \
+                                && (SvTYPE(sv) != SVt_PVAV)  \
+                                && (SvTYPE(sv) != SVt_PVHV))
+#else
+#  define SvSHORTPV(sv)         0
+#  define SvSHORTPV_TRUELY(sv)  0
+#  define SvSHORTPV_on(sv)      NOOP
+#  define SvSHORTPV_off(sv)     NOOP
+#endif
+
 #define SvPADTMP(sv)           (SvFLAGS(sv) & (SVs_PADTMP))
 #define SvPADSTALE(sv)         (SvFLAGS(sv) & (SVs_PADSTALE))
 
@@ -1160,13 +1201,11 @@ object type. Exposed to perl code via Internals::SvREADONLY().
 #  define SvPVX(sv) SvPVX_mutable(sv)
 #  endif
 #  define SvCUR(sv) (0 + ((XPV*) SvANY(sv))->xpv_cur)
-#  define SvLEN(sv) (0 + ((XPV*) SvANY(sv))->xpv_len)
 #  define SvEND(sv) ((sv)->sv_u.svu_pv + ((XPV*)SvANY(sv))->xpv_cur)
 
 #  define SvMAGIC(sv)  (0 + *(assert_(SvTYPE(sv) >= SVt_PVMG) &((XPVMG*)  SvANY(sv))->xmg_u.xmg_magic))
 #  define SvSTASH(sv)  (0 + *(assert_(SvTYPE(sv) >= SVt_PVMG) &((XPVMG*)  SvANY(sv))->xmg_stash))
 #else
-#  define SvLEN(sv) ((XPV*) SvANY(sv))->xpv_len
 #  define SvEND(sv) ((sv)->sv_u.svu_pv + ((XPV*)SvANY(sv))->xpv_cur)
 
 #  if defined (DEBUGGING) && defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
@@ -1245,6 +1284,9 @@ object type. Exposed to perl code via Internals::SvREADONLY().
 #  endif
 #endif
 
+#define SvLEN(sv) (SvSHORTPV(sv) ? SvSHORTPV_BUFSIZE \
+                                 : ((XPV*) SvANY(sv))->xpv_len)
+
 #ifndef PERL_POISON
 /* Given that these two are new, there can't be any existing code using them
  *  as LVALUEs  */
@@ -1288,6 +1330,7 @@ object type. Exposed to perl code via Internals::SvREADONLY().
 #define SvPV_set(sv, val) \
        STMT_START { \
                assert(PL_valid_types_PVX[SvTYPE(sv) & SVt_MASK]);      \
+               assert(!SvSHORTPV(sv)); \
                assert(!isGV_with_GP(sv));              \
                assert(!(SvTYPE(sv) == SVt_PVIO         \
                     && !(IoFLAGS(sv) & IOf_FAKE_DIRP))); \
@@ -1321,6 +1364,7 @@ object type. Exposed to perl code via Internals::SvREADONLY().
 #define SvLEN_set(sv, val) \
        STMT_START { \
                assert(PL_valid_types_PVX[SvTYPE(sv) & SVt_MASK]);      \
+               assert(!SvSHORTPV(sv)); \
                assert(!isGV_with_GP(sv));      \
                assert(!(SvTYPE(sv) == SVt_PVIO         \
                     && !(IoFLAGS(sv) & IOf_FAKE_DIRP))); \
@@ -1330,21 +1374,34 @@ object type. Exposed to perl code via Internals::SvREADONLY().
                SvCUR_set(sv, (val) - SvPVX(sv)); } STMT_END
 
 #define SvPV_renew(sv,n) \
-       STMT_START { SvLEN_set(sv, n); \
+       STMT_START {                                                    \
+                if (SvSHORTPV(sv)) {                                    \
+                    /* force it to be a non-shortpv */                  \
+                    dTHX;                                               \
+                    sv_grow(sv, n > SvSHORTPV_BUFSIZE + 1               \
+                                    ? n : SvSHORTPV_BUFSIZE + 1);       \
+                }                                                       \
+                SvLEN_set(sv, n);                                       \
                SvPV_set((sv), (MEM_WRAP_CHECK_(n,char)                 \
                                (char*)saferealloc((Malloc_t)SvPVX(sv), \
                                                   (MEM_SIZE)((n)))));  \
                 } STMT_END
 
-#define SvPV_shrink_to_cur(sv) STMT_START { \
-                  const STRLEN _lEnGtH = SvCUR(sv) + 1; \
-                  SvPV_renew(sv, _lEnGtH); \
-                } STMT_END
+#define SvPV_shrink_to_cur(sv) \
+                if (!SvSHORTPV(sv)) {                        \
+                       const STRLEN _lEnGtH = SvCUR(sv) + 1; \
+                       SvPV_renew(sv, _lEnGtH); \
+                }
 
 #define SvPV_free(sv)                                                  \
     STMT_START {                                                       \
                     assert(SvTYPE(sv) >= SVt_PV);                      \
-                    if (SvLEN(sv)) {                                   \
+                    if (SvSHORTPV(sv)) {                                \
+                        assert(!SvIsCOW(sv));                           \
+                        Perl_sv_shortpv_free_any_old_body(aTHX_ sv);    \
+                        SvSHORTPV_off(sv);                              \
+                    }                                                   \
+                    else if (SvLEN(sv)) {                              \
                         assert(!SvROK(sv));                            \
                         if(UNLIKELY(SvOOK(sv))) {                      \
                             STRLEN zok;                                \
@@ -1889,7 +1946,7 @@ Like C<sv_utf8_upgrade>, but doesn't do magic on C<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)
-#   define CAN_COW_MASK        (SVf_POK|SVf_ROK|SVp_POK|SVf_FAKE| \
+#   define CAN_COW_MASK        (SVf_POK|SVf_ROK|SVp_POK|SVf_FAKE|SVf_SHORTPV| \
                         SVf_OOK|SVf_BREAK|SVf_READONLY|SVf_PROTECT)
 #endif
 
diff --git a/toke.c b/toke.c
index ee18153..c7af372 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -4432,7 +4432,7 @@ Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
                    PL_parser->last_uni = buf + last_uni_pos;
                if (PL_parser->last_lop)
                    PL_parser->last_lop = buf + last_lop_pos;
-               SvLEN(linestr) = SvCUR(linestr);
+                SvLEN_set(linestr, SvCUR(linestr));
                SvCUR(linestr) = s-SvPVX(linestr);
                PL_parser->filtered = 1;
                break;
index be39310..4a8da44 100644 (file)
@@ -225,8 +225,9 @@ Perl_sv_does_sv(pTHX_ SV *sv, SV *namesv, U32 flags)
     /* create a PV with value "isa", but with a special address
      * so that perl knows we're really doing "DOES" instead */
     methodname = newSV_type(SVt_PV);
-    SvLEN(methodname) = 0;
+    SvLEN_set(methodname, 0);
     SvCUR(methodname) = strlen(PL_isa_DOES);
+    assert(!SvSHORTPV(methodname));
     SvPVX(methodname) = (char *)PL_isa_DOES; /* discard 'const' qualifier */
     SvPOK_on(methodname);
     sv_2mortal(methodname);