diff options
| -rw-r--r-- | doop.c | 4 | ||||
| -rw-r--r-- | dump.c | 12 | ||||
| -rw-r--r-- | embed.fnc | 8 | ||||
| -rw-r--r-- | embed.h | 12 | ||||
| -rw-r--r-- | mg.c | 5 | ||||
| -rw-r--r-- | pod/perlapi.pod | 9 | ||||
| -rw-r--r-- | pp.c | 3 | ||||
| -rw-r--r-- | pp_hot.c | 8 | ||||
| -rw-r--r-- | proto.h | 7 | ||||
| -rw-r--r-- | sv.c | 317 | ||||
| -rw-r--r-- | sv.h | 30 |
11 files changed, 344 insertions, 71 deletions
@@ -600,8 +600,8 @@ Perl_do_trans(pTHX_ SV *sv) (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); } @@ -1083,12 +1083,22 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo 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) { @@ -954,6 +954,10 @@ Ap |void |sys_intern_init 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 @@ s |I32 |expect_number |char** pattern # 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) @@ -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) @@ -57,6 +57,11 @@ S_save_magic(pTHX_ I32 mgs_ix, SV *sv) { 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)); diff --git a/pod/perlapi.pod b/pod/perlapi.pod index 585c1ace04..464a30dbee 100644 --- a/pod/perlapi.pod +++ b/pod/perlapi.pod @@ -3640,8 +3640,13 @@ Found in file sv.c 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) @@ -764,8 +764,7 @@ PP(pp_undef) if (!sv) RETPUSHUNDEF; - if (SvTHINKFIRST(sv)) - sv_force_normal(sv); + SV_CHECK_THINKFIRST_COW_DROP(sv); switch (SvTYPE(sv)) { case SVt_NULL: @@ -1610,7 +1610,11 @@ PP(pp_helem) 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 @@ PP(pp_subst) 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)))) @@ -996,6 +996,10 @@ PERL_CALLCONV void Perl_sys_intern_init(pTHX); 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 @@ STATIC I32 S_expect_number(pTHX_ char** pattern); # 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) @@ -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 @@ Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt) 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 @@ Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen) 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 @@ Does not handle 'set' magic. See also C<sv_setiv_mg>. 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 @@ Does not handle 'set' magic. See also C<sv_setnv_mg>. 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 @@ Perl_sv_2iv(pTHX_ register SV *sv) 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 @@ Perl_sv_2uv(pTHX_ register SV *sv) 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 @@ Perl_sv_2nv(pTHX_ register SV *sv) 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 @@ Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags) 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 @@ Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok) 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 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) 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 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) } } 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 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) * 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 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) 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 @@ Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN { register char *dptr; - SV_CHECK_THINKFIRST(sv); + SV_CHECK_THINKFIRST_COW_DROP(sv); if (!ptr) { (void)SvOK_off(sv); return; @@ -4068,7 +4144,7 @@ Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr) { register STRLEN len; - SV_CHECK_THINKFIRST(sv); + SV_CHECK_THINKFIRST_COW_DROP(sv); if (!ptr) { (void)SvOK_off(sv); return; @@ -4115,7 +4191,7 @@ See C<sv_usepvn_mg>. 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 @@ Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len 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 @@ when unrefing. C<sv_force_normal> calls this function with flags set to 0. 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 @@ Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags) 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 @@ Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 nam 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 @@ void 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 @@ Perl_sv_clear(pTHX_ register SV *sv) 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 @@ Perl_sv_clear(pTHX_ register SV *sv) SvUVX(sv)); SvFAKE_off(sv); } +#endif break; /* case SVt_NV: @@ -5409,7 +5597,7 @@ Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2) } if (cur1 == cur2) - eq = memEQ(pv1, pv2, cur1); + eq = (pv1 == pv2) || memEQ(pv1, pv2, cur1); if (svrecode) SvREFCNT_dec(svrecode); @@ -5643,7 +5831,12 @@ Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append) 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 @@ Perl_sv_inc(pTHX_ register SV *sv) 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 @@ Perl_sv_dec(pTHX_ register SV *sv) 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 @@ Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags) 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 @@ Perl_newSVrv(pTHX_ SV *rv, const char *classname) 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 @@ Perl_sv_unref_flags(pTHX_ SV *sv, U32 flags) } 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 */ @@ -556,15 +556,27 @@ Set the length of the string which is in the SV. See C<SvCUR>. #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,11 +1075,29 @@ otherwise. # 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 */ #define sv_pv(sv) SvPV_nolen(sv) |