Change 17728 by [EMAIL PROTECTED] on 2002/08/17 02:07:24
Subject: Copy On Write
From: Nicholas Clark <[EMAIL PROTECTED]>
Date: Thu, 15 Aug 2002 00:10:35 +0100
Message-id: <[EMAIL PROTECTED]>
specify "-Accflags='-DPERL_COPY_ON_WRITE'" to use
Affected files ...
.... //depot/perl/doop.c#128 edit
.... //depot/perl/dump.c#120 edit
.... //depot/perl/embed.fnc#48 edit
.... //depot/perl/embed.h#365 edit
.... //depot/perl/mg.c#239 edit
.... //depot/perl/pod/perlapi.pod#141 edit
.... //depot/perl/pp.c#355 edit
.... //depot/perl/pp_hot.c#288 edit
.... //depot/perl/proto.h#406 edit
.... //depot/perl/sv.c#576 edit
.... //depot/perl/sv.h#119 edit
Differences ...
==== //depot/perl/doop.c#128 (text) ====
Index: perl/doop.c
--- perl/doop.c#127~17725~ Fri Aug 16 17:51:19 2002
+++ perl/doop.c Fri Aug 16 19:07:24 2002
@@ -600,8 +600,8 @@
(OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF));
if (SvREADONLY(sv)) {
- if (SvFAKE(sv))
- sv_force_normal(sv);
+ if (SvIsCOW(sv))
+ sv_force_normal_flags(sv, 0);
if (SvREADONLY(sv) && !(PL_op->op_private & OPpTRANS_IDENTICAL))
Perl_croak(aTHX_ PL_no_modify);
}
==== //depot/perl/dump.c#120 (text) ====
Index: perl/dump.c
--- perl/dump.c#119~17725~ Fri Aug 16 17:51:19 2002
+++ perl/dump.c Fri Aug 16 19:07:24 2002
@@ -1083,12 +1083,22 @@
return;
}
if (type >= SVt_PVIV || type == SVt_IV) {
- if (SvIsUV(sv))
+ if (SvIsUV(sv)
+#ifdef PERL_COPY_ON_WRITE
+ || SvIsCOW(sv)
+#endif
+ )
Perl_dump_indent(aTHX_ level, file, " UV = %"UVuf, (UV)SvUVX(sv));
else
Perl_dump_indent(aTHX_ level, file, " IV = %"IVdf, (IV)SvIVX(sv));
if (SvOOK(sv))
PerlIO_printf(file, " (OFFSET)");
+#ifdef PERL_COPY_ON_WRITE
+ if (SvIsCOW_shared_hash(sv))
+ PerlIO_printf(file, " (HASH)");
+ else if (SvIsCOW_normal(sv))
+ PerlIO_printf(file, " (COW from 0x%"UVxf")", (UV)SvUVX(sv));
+#endif
PerlIO_putc(file, '\n');
}
if (type >= SVt_PVNV || type == SVt_NV) {
==== //depot/perl/embed.fnc#48 (text) ====
Index: perl/embed.fnc
--- perl/embed.fnc#47~17725~ Fri Aug 16 17:51:19 2002
+++ perl/embed.fnc Fri Aug 16 19:07:24 2002
@@ -954,6 +954,10 @@
Ap |char * |custom_op_name|OP* op
Ap |char * |custom_op_desc|OP* op
+#if defined(PERL_COPY_ON_WRITE)
+pM |int |sv_release_IVX |SV *sv
+#endif
+
Adp |void |sv_nosharing |SV *
Adp |void |sv_nolocking |SV *
Adp |void |sv_nounlocking |SV *
@@ -1235,6 +1239,10 @@
# if defined(USE_ITHREADS)
s |SV* |gv_share |SV *sv|CLONE_PARAMS *param
# endif
+#if defined(PERL_COPY_ON_WRITE)
+sM |void |sv_release_COW |SV *sv|char *pvx|STRLEN cur|STRLEN len \
+ |U32 hash|SV *after
+#endif
#endif
#if defined(PERL_IN_TOKE_C) || defined(PERL_DECL_PROT)
==== //depot/perl/embed.h#365 (text+w) ====
Index: perl/embed.h
--- perl/embed.h#364~17725~ Fri Aug 16 17:51:19 2002
+++ perl/embed.h Fri Aug 16 19:07:24 2002
@@ -859,6 +859,9 @@
#endif
#define custom_op_name Perl_custom_op_name
#define custom_op_desc Perl_custom_op_desc
+#if defined(PERL_COPY_ON_WRITE)
+#define sv_release_IVX Perl_sv_release_IVX
+#endif
#define sv_nosharing Perl_sv_nosharing
#define sv_nolocking Perl_sv_nolocking
#define sv_nounlocking Perl_sv_nounlocking
@@ -1113,6 +1116,9 @@
# if defined(USE_ITHREADS)
#define gv_share S_gv_share
# endif
+#if defined(PERL_COPY_ON_WRITE)
+#define sv_release_COW S_sv_release_COW
+#endif
#endif
#if defined(PERL_IN_TOKE_C) || defined(PERL_DECL_PROT)
#define check_uni S_check_uni
@@ -2412,6 +2418,9 @@
#endif
#define custom_op_name(a) Perl_custom_op_name(aTHX_ a)
#define custom_op_desc(a) Perl_custom_op_desc(aTHX_ a)
+#if defined(PERL_COPY_ON_WRITE)
+#define sv_release_IVX(a) Perl_sv_release_IVX(aTHX_ a)
+#endif
#define sv_nosharing(a) Perl_sv_nosharing(aTHX_ a)
#define sv_nolocking(a) Perl_sv_nolocking(aTHX_ a)
#define sv_nounlocking(a) Perl_sv_nounlocking(aTHX_ a)
@@ -2665,6 +2674,9 @@
# if defined(USE_ITHREADS)
#define gv_share(a,b) S_gv_share(aTHX_ a,b)
# endif
+#if defined(PERL_COPY_ON_WRITE)
+#define sv_release_COW(a,b,c,d,e,f) S_sv_release_COW(aTHX_ a,b,c,d,e,f)
+#endif
#endif
#if defined(PERL_IN_TOKE_C) || defined(PERL_DECL_PROT)
#define check_uni() S_check_uni(aTHX)
==== //depot/perl/mg.c#239 (text) ====
Index: perl/mg.c
--- perl/mg.c#238~17725~ Fri Aug 16 17:51:19 2002
+++ perl/mg.c Fri Aug 16 19:07:24 2002
@@ -57,6 +57,11 @@
{
MGS* mgs;
assert(SvMAGICAL(sv));
+#ifdef PERL_COPY_ON_WRITE
+ /* Turning READONLY off for a copy-on-write scalar is a bad idea. */
+ if (SvIsCOW(sv))
+ sv_force_normal(sv);
+#endif
SAVEDESTRUCTOR_X(restore_magic, INT2PTR(void*, (IV)mgs_ix));
==== //depot/perl/pod/perlapi.pod#141 (text+w) ====
Index: perl/pod/perlapi.pod
--- perl/pod/perlapi.pod#140~17718~ Mon Aug 12 04:57:17 2002
+++ perl/pod/perlapi.pod Fri Aug 16 19:07:24 2002
@@ -3640,8 +3640,13 @@
Undo various types of fakery on an SV: if the PV is a shared string, make
a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
-an xpvmg. The C<flags> parameter gets passed to C<sv_unref_flags()>
-when unrefing. C<sv_force_normal> calls this function with flags set to 0.
+an xpvmg; if we're a copy-on-write scalar, this is the on-write time when
+we do the copy, and is also used locally. If C<SV_COW_DROP_PV> is set
+then a copy-on-write scalar drops its PV buffer (if any) and becomes
+SvPOK_off rather than making a copy. (Used where this scalar is about to be
+set to some other value. In addtion, the C<flags> parameter gets passed to
+C<sv_unref_flags()> when unrefing. C<sv_force_normal> calls this function
+with flags set to 0.
void sv_force_normal_flags(SV *sv, U32 flags)
==== //depot/perl/pp.c#355 (text) ====
Index: perl/pp.c
--- perl/pp.c#354~17726~ Fri Aug 16 18:17:09 2002
+++ perl/pp.c Fri Aug 16 19:07:24 2002
@@ -764,8 +764,7 @@
if (!sv)
RETPUSHUNDEF;
- if (SvTHINKFIRST(sv))
- sv_force_normal(sv);
+ SV_CHECK_THINKFIRST_COW_DROP(sv);
switch (SvTYPE(sv)) {
case SVt_NULL:
==== //depot/perl/pp_hot.c#288 (text) ====
Index: perl/pp_hot.c
--- perl/pp_hot.c#287~17725~ Fri Aug 16 17:51:19 2002
+++ perl/pp_hot.c Fri Aug 16 19:07:24 2002
@@ -1610,7 +1610,11 @@
U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
U32 defer = PL_op->op_private & OPpLVAL_DEFER;
SV *sv;
+#ifdef PERL_COPY_ON_WRITE
+ U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvUVX(keysv) : 0;
+#else
U32 hash = (SvFAKE(keysv) && SvREADONLY(keysv)) ? SvUVX(keysv) : 0;
+#endif
I32 preeminent = 0;
if (SvTYPE(hv) == SVt_PVHV) {
@@ -1886,8 +1890,8 @@
EXTEND(SP,1);
}
- if (SvFAKE(TARG) && SvREADONLY(TARG))
- sv_force_normal(TARG);
+ if (SvIsCOW(TARG))
+ sv_force_normal_flags(TARG,0);
if (SvREADONLY(TARG)
|| (SvTYPE(TARG) > SVt_PVLV
&& !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG))))
==== //depot/perl/proto.h#406 (text+w) ====
Index: perl/proto.h
--- perl/proto.h#405~17725~ Fri Aug 16 17:51:19 2002
+++ perl/proto.h Fri Aug 16 19:07:24 2002
@@ -996,6 +996,10 @@
PERL_CALLCONV char * Perl_custom_op_name(pTHX_ OP* op);
PERL_CALLCONV char * Perl_custom_op_desc(pTHX_ OP* op);
+#if defined(PERL_COPY_ON_WRITE)
+PERL_CALLCONV int Perl_sv_release_IVX(pTHX_ SV *sv);
+#endif
+
PERL_CALLCONV void Perl_sv_nosharing(pTHX_ SV *);
PERL_CALLCONV void Perl_sv_nolocking(pTHX_ SV *);
PERL_CALLCONV void Perl_sv_nounlocking(pTHX_ SV *);
@@ -1269,6 +1273,9 @@
# if defined(USE_ITHREADS)
STATIC SV* S_gv_share(pTHX_ SV *sv, CLONE_PARAMS *param);
# endif
+#if defined(PERL_COPY_ON_WRITE)
+STATIC void S_sv_release_COW(pTHX_ SV *sv, char *pvx, STRLEN cur, STRLEN len, U32
+hash, SV *after);
+#endif
#endif
#if defined(PERL_IN_TOKE_C) || defined(PERL_DECL_PROT)
==== //depot/perl/sv.c#576 (text) ====
Index: perl/sv.c
--- perl/sv.c#575~17614~ Wed Jul 17 14:51:10 2002
+++ perl/sv.c Fri Aug 16 19:07:24 2002
@@ -22,8 +22,16 @@
#include "regcomp.h"
#define FCALL *f
-#define SV_CHECK_THINKFIRST(sv) if (SvTHINKFIRST(sv)) sv_force_normal(sv)
+#ifdef PERL_COPY_ON_WRITE
+#define SV_COW_NEXT_SV(sv) INT2PTR(SV *,SvUVX(sv))
+/* This is a pessamistic view. Scalar must be purely a read-write PV to copy-
+ on-write. */
+#define CAN_COW_MASK (SVs_OBJECT|SVs_GMG|SVs_SMG|SVf_IOK|SVf_NOK|SVf_POK| \
+ SVf_ROK|SVp_IOK|SVp_NOK|SVp_POK|SVf_FAKE|SVf_OOK| \
+ SVf_BREAK|SVf_READONLY|SVf_AMAGIC)
+#define CAN_COW_FLAGS (SVp_POK|SVf_POK)
+#endif
/* ============================================================================
@@ -1234,8 +1242,8 @@
MAGIC* magic = NULL;
HV* stash = Nullhv;
- if (mt != SVt_PV && SvREADONLY(sv) && SvFAKE(sv)) {
- sv_force_normal(sv);
+ if (mt != SVt_PV && SvIsCOW(sv)) {
+ sv_force_normal_flags(sv, 0);
}
if (SvTYPE(sv) == mt)
@@ -1580,12 +1588,6 @@
Renew(s,newlen,char);
}
else {
- /* sv_force_normal_flags() must not try to unshare the new
- PVX we allocate below. AMS 20010713 */
- if (SvREADONLY(sv) && SvFAKE(sv)) {
- SvFAKE_off(sv);
- SvREADONLY_off(sv);
- }
New(703, s, newlen, char);
if (SvPVX(sv) && SvCUR(sv)) {
Move(SvPVX(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char);
@@ -1609,7 +1611,7 @@
void
Perl_sv_setiv(pTHX_ register SV *sv, IV i)
{
- SV_CHECK_THINKFIRST(sv);
+ SV_CHECK_THINKFIRST_COW_DROP(sv);
switch (SvTYPE(sv)) {
case SVt_NULL:
sv_upgrade(sv, SVt_IV);
@@ -1721,7 +1723,7 @@
void
Perl_sv_setnv(pTHX_ register SV *sv, NV num)
{
- SV_CHECK_THINKFIRST(sv);
+ SV_CHECK_THINKFIRST_COW_DROP(sv);
switch (SvTYPE(sv)) {
case SVt_NULL:
case SVt_IV:
@@ -2032,8 +2034,8 @@
return SvIV(tmpstr);
return PTR2IV(SvRV(sv));
}
- if (SvREADONLY(sv) && SvFAKE(sv)) {
- sv_force_normal(sv);
+ if (SvIsCOW(sv)) {
+ sv_force_normal_flags(sv, 0);
}
if (SvREADONLY(sv) && !SvOK(sv)) {
if (ckWARN(WARN_UNINITIALIZED))
@@ -2329,8 +2331,8 @@
return SvUV(tmpstr);
return PTR2UV(SvRV(sv));
}
- if (SvREADONLY(sv) && SvFAKE(sv)) {
- sv_force_normal(sv);
+ if (SvIsCOW(sv)) {
+ sv_force_normal_flags(sv, 0);
}
if (SvREADONLY(sv) && !SvOK(sv)) {
if (ckWARN(WARN_UNINITIALIZED))
@@ -2617,8 +2619,8 @@
return SvNV(tmpstr);
return PTR2NV(SvRV(sv));
}
- if (SvREADONLY(sv) && SvFAKE(sv)) {
- sv_force_normal(sv);
+ if (SvIsCOW(sv)) {
+ sv_force_normal_flags(sv, 0);
}
if (SvREADONLY(sv) && !SvOK(sv)) {
if (ckWARN(WARN_UNINITIALIZED))
@@ -3380,8 +3382,8 @@
if (SvUTF8(sv))
return SvCUR(sv);
- if (SvREADONLY(sv) && SvFAKE(sv)) {
- sv_force_normal(sv);
+ if (SvIsCOW(sv)) {
+ sv_force_normal_flags(sv, 0);
}
if (PL_encoding)
@@ -3437,8 +3439,9 @@
U8 *s;
STRLEN len;
- if (SvREADONLY(sv) && SvFAKE(sv))
- sv_force_normal(sv);
+ if (SvIsCOW(sv)) {
+ sv_force_normal_flags(sv, 0);
+ }
s = (U8 *) SvPV(sv, len);
if (!utf8_to_bytes(s, &len)) {
if (fail_ok)
@@ -3559,7 +3562,7 @@
if (sstr == dstr)
return;
- SV_CHECK_THINKFIRST(dstr);
+ SV_CHECK_THINKFIRST_COW_DROP(dstr);
if (!sstr)
sstr = &PL_sv_undef;
stype = SvTYPE(sstr);
@@ -3887,6 +3890,7 @@
}
}
else if (sflags & SVp_POK) {
+ bool isSwipe = 0;
/*
* Check to see if we can just swipe the string. If so, it's a
@@ -3895,13 +3899,60 @@
* has to be allocated and SvPVX(sstr) has to be freed.
*/
- if (SvTEMP(sstr) && /* slated for free anyway? */
- SvREFCNT(sstr) == 1 && /* and no other references to it? */
- !(sflags & SVf_OOK) && /* and not involved in OOK hack? */
- SvLEN(sstr) && /* and really is a string */
+ if (
+#ifdef PERL_COPY_ON_WRITE
+ (sflags & (SVf_FAKE | SVf_READONLY)) != (SVf_FAKE | SVf_READONLY)
+ &&
+#endif
+ !(isSwipe =
+ (sflags & SVs_TEMP) && /* slated for free anyway? */
+ !(sflags & SVf_OOK) && /* and not involved in OOK hack? */
+ SvREFCNT(sstr) == 1 && /* and no other references to it? */
+ SvLEN(sstr) && /* and really is a string */
/* and won't be needed again, potentially */
- !(PL_op && PL_op->op_type == OP_AASSIGN))
- {
+ !(PL_op && PL_op->op_type == OP_AASSIGN))
+#ifdef PERL_COPY_ON_WRITE
+ && !((sflags & CAN_COW_MASK) == CAN_COW_FLAGS
+ && SvTYPE(sstr) >= SVt_PVIV)
+#endif
+ ) {
+ /* Failed the swipe test, and it's not a shared hash key either.
+ Have to copy the string. */
+ STRLEN len = SvCUR(sstr);
+ SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
+ Move(SvPVX(sstr),SvPVX(dstr),len,char);
+ SvCUR_set(dstr, len);
+ *SvEND(dstr) = '\0';
+ (void)SvPOK_only(dstr);
+ } else {
+ /* If PERL_COPY_ON_WRITE is not defined, then isSwipe will always
+ be true in here. */
+#ifdef PERL_COPY_ON_WRITE
+ /* Either it's a shared hash key, or it's suitable for
+ copy-on-write or we can swipe the string. */
+#ifdef DEBUG_COW
+ PerlIO_printf(PerlIO_stderr(),"sstr --> dstr\n");
+ Perl_sv_dump(sstr);
+ Perl_sv_dump(dstr);
+#endif
+ if (!isSwipe) {
+ /* I believe I should acquire a global SV mutex if
+ it's a COW sv (not a shared hash key) to stop
+ it going un copy-on-write.
+ If the source SV has gone un copy on write between up there
+ and down here, then (assert() that) it is of the correct
+ form to make it copy on write again */
+ if ((sflags & (SVf_FAKE | SVf_READONLY))
+ != (SVf_FAKE | SVf_READONLY)) {
+ SvREADONLY_on(sstr);
+ SvFAKE_on(sstr);
+ /* Make the source SV into a loop of 1.
+ (about to become 2) */
+ SV_COW_NEXT_SV(sstr) = sstr;
+ }
+ }
+#endif
+ /* Initial code is common. */
if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
if (SvOOK(dstr)) {
SvFLAGS(dstr) &= ~SVf_OOK;
@@ -3911,25 +3962,50 @@
Safefree(SvPVX(dstr));
}
(void)SvPOK_only(dstr);
- SvPV_set(dstr, SvPVX(sstr));
- SvLEN_set(dstr, SvLEN(sstr));
- SvCUR_set(dstr, SvCUR(sstr));
-
- SvTEMP_off(dstr);
- (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
- SvPV_set(sstr, Nullch);
- SvLEN_set(sstr, 0);
- SvCUR_set(sstr, 0);
- SvTEMP_off(sstr);
- }
- else { /* have to copy actual string */
- STRLEN len = SvCUR(sstr);
- SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
- Move(SvPVX(sstr),SvPVX(dstr),len,char);
- SvCUR_set(dstr, len);
- *SvEND(dstr) = '\0';
- (void)SvPOK_only(dstr);
- }
+
+#ifdef PERL_COPY_ON_WRITE
+ if (!isSwipe) {
+ /* making another shared SV. */
+ STRLEN cur = SvCUR(sstr);
+ STRLEN len = SvLEN(sstr);
+ if (len) {
+ /* SvIsCOW_normal */
+ /* splice us in between source and next-after-source. */
+ SV_COW_NEXT_SV(dstr) = SV_COW_NEXT_SV(sstr);
+ SV_COW_NEXT_SV(sstr) = dstr;
+ SvPV_set(dstr, SvPVX(sstr));
+ } else {
+ /* SvIsCOW_shared_hash */
+ UV hash = SvUVX(sstr);
+#ifdef DEBUG_COW
+ PerlIO_printf(PerlIO_stderr(), "Sharing hash\n");
+#endif
+ SvPV_set(dstr,
+ sharepvn(SvPVX(sstr),
+ (sflags & SVf_UTF8?-cur:cur), hash));
+ SvUVX(dstr) = hash;
+ }
+ SvLEN(dstr) = len;
+ SvCUR(dstr) = cur;
+ SvREADONLY_on(dstr);
+ SvFAKE_on(dstr);
+ /* Relesase a global SV mutex. */
+ }
+ else
+#endif
+ { /* Passes the swipe test. */
+ SvPV_set(dstr, SvPVX(sstr));
+ SvLEN_set(dstr, SvLEN(sstr));
+ SvCUR_set(dstr, SvCUR(sstr));
+
+ SvTEMP_off(dstr);
+ (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
+ SvPV_set(sstr, Nullch);
+ SvLEN_set(sstr, 0);
+ SvCUR_set(sstr, 0);
+ SvTEMP_off(sstr);
+ }
+ }
if (sflags & SVf_UTF8)
SvUTF8_on(dstr);
/*SUPPRESS 560*/
@@ -4017,7 +4093,7 @@
{
register char *dptr;
- SV_CHECK_THINKFIRST(sv);
+ SV_CHECK_THINKFIRST_COW_DROP(sv);
if (!ptr) {
(void)SvOK_off(sv);
return;
@@ -4068,7 +4144,7 @@
{
register STRLEN len;
- SV_CHECK_THINKFIRST(sv);
+ SV_CHECK_THINKFIRST_COW_DROP(sv);
if (!ptr) {
(void)SvOK_off(sv);
return;
@@ -4115,7 +4191,7 @@
void
Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
{
- SV_CHECK_THINKFIRST(sv);
+ SV_CHECK_THINKFIRST_COW_DROP(sv);
(void)SvUPGRADE(sv, SVt_PV);
if (!ptr) {
(void)SvOK_off(sv);
@@ -4148,13 +4224,64 @@
SvSETMAGIC(sv);
}
+#ifdef PERL_COPY_ON_WRITE
+/* Need to do this *after* making the SV normal, as we need the buffer
+ pointer to remain valid until after we've copied it. If we let go too early,
+ another thread could invalidate it by unsharing last of the same hash key
+ (which it can do by means other than releasing copy-on-write Svs)
+ or by changing the other copy-on-write SVs in the loop. */
+STATIC void
+S_sv_release_COW(pTHX_ register SV *sv, char *pvx, STRLEN cur, STRLEN len,
+ U32 hash, SV *after)
+{
+ if (len) { /* this SV was SvIsCOW_normal(sv) */
+ /* we need to find the SV pointing to us. */
+ SV *current = SV_COW_NEXT_SV(after);
+
+ if (current == sv) {
+ /* The SV we point to points back to us (there were only two of us
+ in the loop.)
+ Hence other SV is no longer copy on write either. */
+ SvFAKE_off(after);
+ SvREADONLY_off(after);
+ } else {
+ /* We need to follow the pointers around the loop. */
+ SV *next;
+ while ((next = SV_COW_NEXT_SV(current)) != sv) {
+ assert (next);
+ current = next;
+ /* don't loop forever if the structure is bust, and we have
+ a pointer into a closed loop. */
+ assert (current != after);
+ }
+ /* Make the SV before us point to the SV after us. */
+ SV_COW_NEXT_SV(current) = after;
+ }
+ } else {
+ unsharepvn(pvx, SvUTF8(sv) ? -(I32)cur : cur, hash);
+ }
+}
+
+int
+Perl_sv_release_IVX(pTHX_ register SV *sv)
+{
+ if (SvIsCOW(sv))
+ sv_force_normal_flags(sv, 0);
+ return SvOOK_off(sv);
+}
+#endif
/*
=for apidoc sv_force_normal_flags
Undo various types of fakery on an SV: if the PV is a shared string, make
a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
-an xpvmg. The C<flags> parameter gets passed to C<sv_unref_flags()>
-when unrefing. C<sv_force_normal> calls this function with flags set to 0.
+an xpvmg; if we're a copy-on-write scalar, this is the on-write time when
+we do the copy, and is also used locally. If C<SV_COW_DROP_PV> is set
+then a copy-on-write scalar drops its PV buffer (if any) and becomes
+SvPOK_off rather than making a copy. (Used where this scalar is about to be
+set to some other value. In addtion, the C<flags> parameter gets passed to
+C<sv_unref_flags()> when unrefing. C<sv_force_normal> calls this function
+with flags set to 0.
=cut
*/
@@ -4162,6 +4289,43 @@
void
Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
{
+#ifdef PERL_COPY_ON_WRITE
+ if (SvREADONLY(sv)) {
+ /* At this point I believe I should acquire a global SV mutex. */
+ if (SvFAKE(sv)) {
+ char *pvx = SvPVX(sv);
+ STRLEN len = SvLEN(sv);
+ STRLEN cur = SvCUR(sv);
+ U32 hash = SvUVX(sv);
+ SV *next = SV_COW_NEXT_SV(sv); /* next COW sv in the loop. */
+#ifdef DEBUG_COW
+ PerlIO_printf(PerlIO_stderr(), "Force normal %ld\n", flags);
+ Perl_sv_dump(sv);
+#endif
+ SvFAKE_off(sv);
+ SvREADONLY_off(sv);
+ /* This SV doesn't own the buffer, so need to New() a new one: */
+ SvPVX(sv) = 0;
+ SvLEN(sv) = 0;
+ if (flags & SV_COW_DROP_PV) {
+ /* OK, so we don't need to copy our buffer. */
+ SvPOK_off(sv);
+ } else {
+ SvGROW(sv, cur + 1);
+ Move(pvx,SvPVX(sv),cur,char);
+ SvCUR(sv) = cur;
+ *SvEND(sv) = '\0';
+ }
+ S_sv_release_COW(sv, pvx, cur, len, hash, next);
+#ifdef DEBUG_COW
+ Perl_sv_dump(sv);
+#endif
+ }
+ else if (PL_curcop != &PL_compiling)
+ Perl_croak(aTHX_ PL_no_modify);
+ /* At this point I believe that I can drop the global SV mutex. */
+ }
+#else
if (SvREADONLY(sv)) {
if (SvFAKE(sv)) {
char *pvx = SvPVX(sv);
@@ -4177,6 +4341,7 @@
else if (PL_curcop != &PL_compiling)
Perl_croak(aTHX_ PL_no_modify);
}
+#endif
if (SvROK(sv))
sv_unref_flags(sv, flags);
else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
@@ -4515,6 +4680,10 @@
MAGIC* mg;
MGVTBL *vtable = 0;
+#ifdef PERL_COPY_ON_WRITE
+ if (SvIsCOW(sv))
+ sv_force_normal_flags(sv, 0);
+#endif
if (SvREADONLY(sv)) {
if (PL_curcop != &PL_compiling
&& how != PERL_MAGIC_regex_global
@@ -4892,7 +5061,7 @@
Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
{
U32 refcnt = SvREFCNT(sv);
- SV_CHECK_THINKFIRST(sv);
+ SV_CHECK_THINKFIRST_COW_DROP(sv);
if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Reference miscount in
sv_replace()");
if (SvMAGICAL(sv)) {
@@ -5045,6 +5214,24 @@
else
SvREFCNT_dec(SvRV(sv));
}
+#ifdef PERL_COPY_ON_WRITE
+ else if (SvPVX(sv)) {
+ if (SvIsCOW(sv)) {
+ /* I believe I need to grab the global SV mutex here and
+ then recheck the COW status. */
+#ifdef DEBUG_COW
+ PerlIO_printf(PerlIO_stderr(), "Clear\n");
+ Perl_sv_dump(sv);
+#endif
+ S_sv_release_COW(sv, SvPVX(sv), SvCUR(sv), SvLEN(sv),
+ SvUVX(sv), SV_COW_NEXT_SV(sv));
+ /* And drop it here. */
+ SvFAKE_off(sv);
+ } else if (SvLEN(sv)) {
+ Safefree(SvPVX(sv));
+ }
+ }
+#else
else if (SvPVX(sv) && SvLEN(sv))
Safefree(SvPVX(sv));
else if (SvPVX(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
@@ -5053,6 +5240,7 @@
SvUVX(sv));
SvFAKE_off(sv);
}
+#endif
break;
/*
case SVt_NV:
@@ -5409,7 +5597,7 @@
}
if (cur1 == cur2)
- eq = memEQ(pv1, pv2, cur1);
+ eq = (pv1 == pv2) || memEQ(pv1, pv2, cur1);
if (svrecode)
SvREFCNT_dec(svrecode);
@@ -5643,7 +5831,12 @@
I32 i = 0;
I32 rspara = 0;
- SV_CHECK_THINKFIRST(sv);
+ SV_CHECK_THINKFIRST_COW_DROP(sv);
+ /* XXX. If you make this PVIV, then copy on write can copy scalars read
+ from <>.
+ However, perlbench says it's slower, because the existing swipe code
+ is faster than copy on write.
+ Swings and roundabouts. */
(void)SvUPGRADE(sv, SVt_PV);
SvSCREAM_off(sv);
@@ -5957,8 +6150,8 @@
if (SvGMAGICAL(sv))
mg_get(sv);
if (SvTHINKFIRST(sv)) {
- if (SvREADONLY(sv) && SvFAKE(sv))
- sv_force_normal(sv);
+ if (SvIsCOW(sv))
+ sv_force_normal_flags(sv, 0);
if (SvREADONLY(sv)) {
if (PL_curcop != &PL_compiling)
Perl_croak(aTHX_ PL_no_modify);
@@ -6113,8 +6306,8 @@
if (SvGMAGICAL(sv))
mg_get(sv);
if (SvTHINKFIRST(sv)) {
- if (SvREADONLY(sv) && SvFAKE(sv))
- sv_force_normal(sv);
+ if (SvIsCOW(sv))
+ sv_force_normal_flags(sv, 0);
if (SvREADONLY(sv)) {
if (PL_curcop != &PL_compiling)
Perl_croak(aTHX_ PL_no_modify);
@@ -6901,7 +7094,7 @@
char *s = NULL;
if (SvTHINKFIRST(sv) && !SvROK(sv))
- sv_force_normal(sv);
+ sv_force_normal_flags(sv, 0);
if (SvPOK(sv)) {
*lp = SvCUR(sv);
@@ -7123,7 +7316,7 @@
new_SV(sv);
- SV_CHECK_THINKFIRST(rv);
+ SV_CHECK_THINKFIRST_COW_DROP(rv);
SvAMAGIC_off(rv);
if (SvTYPE(rv) >= SVt_PVMG) {
@@ -7367,7 +7560,7 @@
}
SvRV(sv) = 0;
SvROK_off(sv);
- if (SvREFCNT(rv) != 1 || SvREADONLY(rv) || flags) /* SV_IMMEDIATE_UNREF */
+ if (SvREFCNT(rv) != 1 || SvREADONLY(rv) || (flags & SV_IMMEDIATE_UNREF))
SvREFCNT_dec(rv);
else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
sv_2mortal(rv); /* Schedule for freeing later */
==== //depot/perl/sv.h#119 (text) ====
Index: perl/sv.h
--- perl/sv.h#118~17153~ Sun Jun 9 16:25:04 2002
+++ perl/sv.h Fri Aug 16 19:07:24 2002
@@ -556,15 +556,27 @@
#define SvOKp(sv) (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK))
#define SvIOKp(sv) (SvFLAGS(sv) & SVp_IOK)
+#ifdef PERL_COPY_ON_WRITE
+#define SvRELEASE_IVX(sv) ((SvFLAGS(sv) & (SVf_OOK|SVf_READONLY|SVf_FAKE)) \
+ && sv_release_IVX(sv))
+#define SvIOKp_on(sv) ((void)sv_release_IVX(sv), \
+ SvFLAGS(sv) |= SVp_IOK)
+#else
#define SvIOKp_on(sv) ((void)SvOOK_off(sv), SvFLAGS(sv) |= SVp_IOK)
+#endif
#define SvNOKp(sv) (SvFLAGS(sv) & SVp_NOK)
#define SvNOKp_on(sv) (SvFLAGS(sv) |= SVp_NOK)
#define SvPOKp(sv) (SvFLAGS(sv) & SVp_POK)
#define SvPOKp_on(sv) (SvFLAGS(sv) |= SVp_POK)
#define SvIOK(sv) (SvFLAGS(sv) & SVf_IOK)
+#ifdef PERL_COPY_ON_WRITE
+#define SvIOK_on(sv) ((void)sv_release_IVX(sv), \
+ SvFLAGS(sv) |= (SVf_IOK|SVp_IOK))
+#else
#define SvIOK_on(sv) ((void)SvOOK_off(sv), \
SvFLAGS(sv) |= (SVf_IOK|SVp_IOK))
+#endif
#define SvIOK_off(sv) (SvFLAGS(sv) &= ~(SVf_IOK|SVp_IOK|SVf_IVisUV))
#define SvIOK_only(sv) ((void)SvOK_off(sv), \
SvFLAGS(sv) |= (SVf_IOK|SVp_IOK))
@@ -1063,10 +1075,28 @@
# endif /* USE_5005THREADS */
#endif /* __GNU__ */
+#define SvIsCOW(sv) ((SvFLAGS(sv) & (SVf_FAKE | SVf_READONLY)) == \
+ (SVf_FAKE | SVf_READONLY))
/* flag values for sv_*_flags functions */
#define SV_IMMEDIATE_UNREF 1
#define SV_GMAGIC 2
+
+#ifdef PERL_COPY_ON_WRITE
+#define SV_COW_DROP_PV 4
+
+#define SvIsCOW_shared_hash(sv) (SvIsCOW(sv) && SvLEN(sv) == 0)
+#define SvIsCOW_normal(sv) (SvIsCOW(sv) && SvLEN(sv))
+
+#define SV_CHECK_THINKFIRST_COW_DROP(sv) if (SvTHINKFIRST(sv)) \
+ sv_force_normal_flags(sv, SV_COW_DROP_PV)
+#else
+#define SV_CHECK_THINKFIRST_COW_DROP(sv) if (SvTHINKFIRST(sv)) \
+ sv_force_normal_flags(sv, 0)
+#endif /* PERL_COPY_ON_WRITE */
+#define SV_CHECK_THINKFIRST(sv) if (SvTHINKFIRST(sv)) \
+ sv_force_normal_flags(sv, 0)
+
/* all these 'functions' are now just macros */
End of Patch.
