Change 24714 was arguably over-ambitious, in that non-core modules

can't be expected to know that sv_setsv() may now not "really" copy a
scalar. So arrange things so that COW of shared hash key scalars is
only done for calls within the the PERL_CORE.

p4raw-id: //depot/perl@29248

diff --git a/MANIFEST b/MANIFEST
index 6ae4cf2..9987b37 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -1199,9 +1199,12 @@ ext/Unicode/Normalize/t/tie.t    Unicode::Normalize
 ext/util/make_ext              Used by Makefile to execute extension Makefiles
 ext/XS/APItest/APItest.pm      XS::APItest extension
 ext/XS/APItest/APItest.xs      XS::APItest extension
+ext/XS/APItest/core.c          Test API functions when PERL_CORE is defined
+ext/XS/APItest/core_or_not.inc Code common to core.c and notcore.c
 ext/XS/APItest/exception.c     XS::APItest extension
 ext/XS/APItest/Makefile.PL     XS::APItest extension
 ext/XS/APItest/MANIFEST                XS::APItest extension
+ext/XS/APItest/notcore.c       Test API functions when PERL_CORE is not defined
 ext/XS/APItest/README          XS::APItest extension
 ext/XS/APItest/t/call.t                XS::APItest extension
 ext/XS/APItest/t/exception.t   XS::APItest extension
@@ -1210,6 +1213,7 @@ ext/XS/APItest/t/my_cxt.t XS::APItest: test MY_CXT interface
 ext/XS/APItest/t/op.t          XS::APItest: tests for OP related APIs
 ext/XS/APItest/t/printf.t      XS::APItest extension
 ext/XS/APItest/t/push.t                XS::APItest extension
+ext/XS/APItest/t/svsetsv.t     Test behaviour of sv_setsv with/without PERL_CORE
 ext/XS/Typemap/Makefile.PL     XS::Typemap extension
 ext/XS/Typemap/README          XS::Typemap extension
 ext/XS/Typemap/stdio.c         XS::Typemap extension

diff --git a/ext/XS/APItest/APItest.pm b/ext/XS/APItest/APItest.pm
index 9591257..668c7a9 100644 (file)
--- a/ext/XS/APItest/APItest.pm
+++ b/ext/XS/APItest/APItest.pm
@@ -21,6 +21,7 @@ our @EXPORT = qw( print_double print_int print_long
                  G_KEEPERR G_NODEBUG G_METHOD
                  exception mycroak strtab
                  my_cxt_getint my_cxt_getsv my_cxt_setint my_cxt_setsv
+                 sv_setsv_cow_hashkey_core sv_setsv_cow_hashkey_notcore
 );
 
 # from cop.h 
@@ -34,7 +35,7 @@ sub G_KEEPERR()       {  16 }
 sub G_NODEBUG()        {  32 }
 sub G_METHOD() {  64 }
 
-our $VERSION = '0.10';
+our $VERSION = '0.11';
 
 bootstrap XS::APItest $VERSION;
 

diff --git a/ext/XS/APItest/APItest.xs b/ext/XS/APItest/APItest.xs
index d83e32f..8e9d2ff 100644 (file)
--- a/ext/XS/APItest/APItest.xs
+++ b/ext/XS/APItest/APItest.xs
@@ -556,3 +556,9 @@ my_cxt_setsv(sv)
        SvREFCNT_dec(MY_CXT.sv);
        my_cxt_setsv_p(sv _aMY_CXT);
        SvREFCNT_inc(sv);
+
+bool
+sv_setsv_cow_hashkey_core()
+
+bool
+sv_setsv_cow_hashkey_notcore()

diff --git a/ext/XS/APItest/Makefile.PL b/ext/XS/APItest/Makefile.PL
index e49da36..76aa60a 100644 (file)
--- a/ext/XS/APItest/Makefile.PL
+++ b/ext/XS/APItest/Makefile.PL
@@ -9,7 +9,7 @@ WriteMakefile(
     ($] >= 5.005 ?    ## Add these new keywords supported since 5.005
       (ABSTRACT_FROM => 'APItest.pm', # retrieve abstract from module
        AUTHOR     => 'Tim Jenness <t.jenness@jach.hawaii.edu>, Christian Soeller <csoelle@mph.auckland.ac.nz>, Hugo van der Sanden <hv@crypt.compulink.co.uk>') : ()),
-    'C'                 => ['exception.c'],
+    'C'                 => ['exception.c', 'core.c', 'notcore.c'],
     'OBJECT'            => '$(BASEEXT)$(OBJ_EXT) $(O_FILES)',
     'LIBS'             => [''], # e.g., '-lm'
     'DEFINE'           => '', # e.g., '-DHAVE_SOMETHING'

diff --git a/sv.c b/sv.c
index 66d29e4..ad31ce1 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -3610,6 +3610,9 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
         * possible small lose on short strings, but a big win on long ones.
         * It might even be a win on short strings if SvPVX_const(dstr)
         * has to be allocated and SvPVX_const(sstr) has to be freed.
+        * Likewise if we can set up COW rather than doing an actual copy, we
+        * drop to the else clause, as the swipe code and the COW setup code
+        * have much in common.
         */
 
        /* Whichever path we take through the next code, we want this true,
@@ -3617,10 +3620,28 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
        (void)SvPOK_only(dstr);
 
        if (
-           /* We're not already COW  */
-            ((sflags & (SVf_FAKE | SVf_READONLY)) != (SVf_FAKE | SVf_READONLY)
+           /* If we're already COW then this clause is not true, and if COW
+              is allowed then we drop down to the else and make dest COW 
+              with us.  If caller hasn't said that we're allowed to COW
+              shared hash keys then we don't do the COW setup, even if the
+              source scalar is a shared hash key scalar.  */
+            (((flags & SV_COW_SHARED_HASH_KEYS)
+              ? (sflags & (SVf_FAKE|SVf_READONLY)) != (SVf_FAKE|SVf_READONLY)
+              : 1 /* If making a COW copy is forbidden then the behaviour we
+                      desire is as if the source SV isn't actually already
+                      COW, even if it is.  So we act as if the source flags
+                      are not COW, rather than actually testing them.  */
+             )
 #ifndef PERL_OLD_COPY_ON_WRITE
-            /* or we are, but dstr isn't a suitable target.  */
+            /* The change that added SV_COW_SHARED_HASH_KEYS makes the logic
+               when PERL_OLD_COPY_ON_WRITE is defined a little wrong.
+               Conceptually PERL_OLD_COPY_ON_WRITE being defined should
+               override SV_COW_SHARED_HASH_KEYS, because it means "always COW"
+               but in turn, it's somewhat dead code, never expected to go
+               live, but more kept as a placeholder on how to do it better
+               in a newer implementation.  */
+            /* If we are COW and dstr is a suitable target then we drop down
+               into the else and make dest a COW of us.  */
             || (SvFLAGS(dstr) & CAN_COW_MASK) != CAN_COW_FLAGS
 #endif
             )

diff --git a/sv.h b/sv.h
index eabc2bf..57911d3 100644 (file)
--- a/sv.h
+++ b/sv.h
@@ -1679,6 +1679,21 @@ Like C<sv_catsv> but doesn't process magic.
 #define SV_MUTABLE_RETURN      64
 #define SV_SMAGIC              128
 #define SV_HAS_TRAILING_NUL    256
+#define SV_COW_SHARED_HASH_KEYS        512
+
+/* The core is safe for this COW optimisation. XS code on CPAN may not be.
+   So only default to doing the COW setup if we're in the core.
+ */
+#ifdef PERL_CORE
+#  ifndef SV_DO_COW_SVSETSV
+#    define SV_DO_COW_SVSETSV  SV_COW_SHARED_HASH_KEYS
+#  endif
+#endif
+
+#ifndef SV_DO_COW_SVSETSV
+#  define SV_DO_COW_SVSETSV    0
+#endif
+
 
 #define sv_unref(sv)           sv_unref_flags(sv, 0)
 #define sv_force_normal(sv)    sv_force_normal_flags(sv, 0)
@@ -1720,8 +1735,9 @@ Like C<sv_catsv> but doesn't process magic.
 #define sv_pvn_force_nomg(sv, lp) sv_pvn_force_flags(sv, lp, 0)
 #define sv_utf8_upgrade_nomg(sv) sv_utf8_upgrade_flags(sv, 0)
 #define sv_catpvn_nomg(dsv, sstr, slen) sv_catpvn_flags(dsv, sstr, slen, 0)
-#define sv_setsv(dsv, ssv) sv_setsv_flags(dsv, ssv, SV_GMAGIC)
-#define sv_setsv_nomg(dsv, ssv) sv_setsv_flags(dsv, ssv, 0)
+#define sv_setsv(dsv, ssv) \
+       sv_setsv_flags(dsv, ssv, SV_GMAGIC|SV_DO_COW_SVSETSV)
+#define sv_setsv_nomg(dsv, ssv) sv_setsv_flags(dsv, ssv, SV_DO_COW_SVSETSV)
 #define sv_catsv(dsv, ssv) sv_catsv_flags(dsv, ssv, SV_GMAGIC)
 #define sv_catsv_nomg(dsv, ssv) sv_catsv_flags(dsv, ssv, 0)
 #define sv_catsv_mg(dsv, ssv) sv_catsv_flags(dsv, ssv, SV_GMAGIC|SV_SMAGIC)
@@ -1828,7 +1844,7 @@ Returns a pointer to the character buffer.
 #define SvSetSV_nosteal_and(dst,src,finally) \
        STMT_START {                                    \
            if ((dst) != (src)) {                       \
-               sv_setsv_flags(dst, src, SV_GMAGIC | SV_NOSTEAL);       \
+               sv_setsv_flags(dst, src, SV_GMAGIC | SV_NOSTEAL | SV_DO_COW_SVSETSV);   \
                finally;                                \
            }                                           \
        } STMT_END