From: Nicholas Clark Date: Sun, 12 Nov 2006 20:22:28 +0000 (+0000) Subject: Change 24714 was arguably over-ambitious, in that non-core modules X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=34482cd6991b4dc2f3757baff881b50e6de59592;p=p5sagit%2Fp5-mst-13.2.git 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 --- 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 --- 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 --- 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 --- 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 , Christian Soeller , Hugo van der Sanden ') : ()), - '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 --- 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 --- a/sv.h +++ b/sv.h @@ -1679,6 +1679,21 @@ Like C 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 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