Apd |void |sv_copypv |SV* dsv|SV* ssv
Ap |char* |my_atof2 |const char *s|NV* value
Apn |int |my_socketpair |int family|int type|int protocol|int fd[2]
+#ifdef PERL_COPY_ON_WRITE
+Ap |SV* |sv_setsv_cow |SV* dsv|SV* ssv
+#endif
#if defined(USE_PERLIO) && !defined(USE_SFIO)
Ap |int |PerlIO_close |PerlIO *
#define sv_copypv Perl_sv_copypv
#define my_atof2 Perl_my_atof2
#define my_socketpair Perl_my_socketpair
+#ifdef PERL_COPY_ON_WRITE
+#define sv_setsv_cow Perl_sv_setsv_cow
+#endif
#if defined(USE_PERLIO) && !defined(USE_SFIO)
#define PerlIO_close Perl_PerlIO_close
#define PerlIO_fill Perl_PerlIO_fill
#define sv_copypv(a,b) Perl_sv_copypv(aTHX_ a,b)
#define my_atof2(a,b) Perl_my_atof2(aTHX_ a,b)
#define my_socketpair Perl_my_socketpair
+#ifdef PERL_COPY_ON_WRITE
+#define sv_setsv_cow(a,b) Perl_sv_setsv_cow(aTHX_ a,b)
+#endif
#if defined(USE_PERLIO) && !defined(USE_SFIO)
#define PerlIO_close(a) Perl_PerlIO_close(aTHX_ a)
#define PerlIO_fill(a) Perl_PerlIO_fill(aTHX_ a)
Perl_sv_copypv
Perl_my_atof2
Perl_my_socketpair
+Perl_sv_setsv_cow
Perl_PerlIO_close
Perl_PerlIO_fill
Perl_PerlIO_fileno
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
+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.
sv_catpvn(dstr, s, cx->sb_strend - s);
cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
- (void)SvOOK_off(targ);
- if (SvLEN(targ))
- Safefree(SvPVX(targ));
+#ifdef PERL_COPY_ON_WRITE
+ if (SvIsCOW(targ)) {
+ sv_force_normal_flags(targ, SV_COW_DROP_PV);
+ } else
+#endif
+ {
+ (void)SvOOK_off(targ);
+ if (SvLEN(targ))
+ Safefree(SvPVX(targ));
+ }
SvPVX(targ) = SvPVX(dstr);
SvCUR_set(targ, SvCUR(dstr));
SvLEN_set(targ, SvLEN(dstr));
U32 i;
if (!p || p[1] < rx->nparens) {
+#ifdef PERL_COPY_ON_WRITE
+ i = 7 + rx->nparens * 2;
+#else
i = 6 + rx->nparens * 2;
+#endif
if (!p)
New(501, p, i, UV);
else
*p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : Nullch);
RX_MATCH_COPIED_off(rx);
+#ifdef PERL_COPY_ON_WRITE
+ *p++ = PTR2UV(rx->saved_copy);
+ rx->saved_copy = Nullsv;
+#endif
+
*p++ = rx->nparens;
*p++ = PTR2UV(rx->subbeg);
UV *p = (UV*)*rsp;
U32 i;
- if (RX_MATCH_COPIED(rx))
- Safefree(rx->subbeg);
+ RX_MATCH_COPY_FREE(rx);
RX_MATCH_COPIED_set(rx, *p);
*p++ = 0;
+#ifdef PERL_COPY_ON_WRITE
+ if (rx->saved_copy)
+ SvREFCNT_dec (rx->saved_copy);
+ rx->saved_copy = INT2PTR(SV*,*p);
+ *p++ = 0;
+#endif
+
rx->nparens = *p++;
rx->subbeg = INT2PTR(char*,*p++);
if (p) {
Safefree(INT2PTR(char*,*p));
+#ifdef PERL_COPY_ON_WRITE
+ if (p[1]) {
+ SvREFCNT_dec (INT2PTR(SV*,p[1]));
+ }
+#endif
Safefree(p);
*rsp = Null(void*);
}
}
if (PL_sawampersand) {
I32 off;
+#ifdef PERL_COPY_ON_WRITE
+ if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
+ if (DEBUG_C_TEST) {
+ PerlIO_printf(Perl_debug_log,
+ "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
+ (int) SvTYPE(TARG), truebase, t,
+ (int)(t-truebase));
+ }
+ rx->saved_copy = sv_setsv_cow(rx->saved_copy, TARG);
+ rx->subbeg = SvPVX(rx->saved_copy) + (t - truebase);
+ assert (SvPOKp(rx->saved_copy));
+ } else
+#endif
+ {
- rx->subbeg = savepvn(t, strend - t);
+ rx->subbeg = savepvn(t, strend - t);
+#ifdef PERL_COPY_ON_WRITE
+ rx->saved_copy = Nullsv;
+#endif
+ }
rx->sublen = strend - t;
RX_MATCH_COPIED_on(rx);
off = rx->startp[0] = s - t;
I32 oldsave = PL_savestack_ix;
STRLEN slen;
bool doutf8 = FALSE;
+#ifdef PERL_COPY_ON_WRITE
+ bool is_cow;
+#endif
/* known replacement string? */
dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
EXTEND(SP,1);
}
+#ifdef PERL_COPY_ON_WRITE
+ /* Awooga. Awooga. "bool" types that are actually char are dangerous,
+ because they make integers such as 256 "false". */
+ is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
+#else
if (SvIsCOW(TARG))
sv_force_normal_flags(TARG,0);
- if (SvREADONLY(TARG)
+#endif
+ if (
+#ifdef PERL_COPY_ON_WRITE
+ !is_cow &&
+#endif
+ (SvREADONLY(TARG)
|| (SvTYPE(TARG) > SVt_PVLV
- && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG))))
+ && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
DIE(aTHX_ PL_no_modify);
PUTBACK;
rx = PM_GETRE(pm);
}
r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
- ? REXEC_COPY_STR : 0;
+ ? REXEC_COPY_STR : 0;
if (SvSCREAM(TARG))
r_flags |= REXEC_SCREAM;
if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
}
/* can do inplace substitution? */
- if (c && (I32)clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
+ if (c
+#ifdef PERL_COPY_ON_WRITE
+ && !is_cow
+#endif
+ && (I32)clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
&& !(rx->reganch & ROPT_LOOKBEHIND_SEEN)) {
if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
r_flags | REXEC_CHECKED))
LEAVE_SCOPE(oldsave);
RETURN;
}
+#ifdef PERL_COPY_ON_WRITE
+ if (SvIsCOW(TARG)) {
+ assert (!force_on_match);
+ goto have_a_cow;
+ }
+#endif
if (force_on_match) {
force_on_match = 0;
s = SvPV_force(TARG, len);
s = SvPV_force(TARG, len);
goto force_it;
}
+#ifdef PERL_COPY_ON_WRITE
+ have_a_cow:
+#endif
rxtainted |= RX_MATCH_TAINTED(rx);
dstr = NEWSV(25, len);
sv_setpvn(dstr, m, s-m);
else
sv_catpvn(dstr, s, strend - s);
- (void)SvOOK_off(TARG);
- if (SvLEN(TARG))
- Safefree(SvPVX(TARG));
+#ifdef PERL_COPY_ON_WRITE
+ /* The match may make the string COW. If so, brilliant, because that's
+ just saved us one malloc, copy and free - the regexp has donated
+ the old buffer, and we malloc an entirely new one, rather than the
+ regexp malloc()ing a buffer and copying our original, only for
+ us to throw it away here during the substitution. */
+ if (SvIsCOW(TARG)) {
+ sv_force_normal_flags(TARG, SV_COW_DROP_PV);
+ } else
+#endif
+ {
+ (void)SvOOK_off(TARG);
+ if (SvLEN(TARG))
+ Safefree(SvPVX(TARG));
+ }
SvPVX(TARG) = SvPVX(dstr);
SvCUR_set(TARG, SvCUR(dstr));
SvLEN_set(TARG, SvLEN(dstr));
PERL_CALLCONV void Perl_sv_copypv(pTHX_ SV* dsv, SV* ssv);
PERL_CALLCONV char* Perl_my_atof2(pTHX_ const char *s, NV* value);
PERL_CALLCONV int Perl_my_socketpair(int family, int type, int protocol, int fd[2]);
+#ifdef PERL_COPY_ON_WRITE
+PERL_CALLCONV SV* Perl_sv_setsv_cow(pTHX_ SV* dsv, SV* ssv);
+#endif
#if defined(USE_PERLIO) && !defined(USE_SFIO)
PERL_CALLCONV int Perl_PerlIO_close(pTHX_ PerlIO *);
r->prelen = xend - exp;
r->precomp = savepvn(RExC_precomp, r->prelen);
r->subbeg = NULL;
+#ifdef PERL_COPY_ON_WRITE
+ r->saved_copy = Nullsv;
+#endif
r->reganch = pm->op_pmflags & PMf_COMPILETIME;
r->nparens = RExC_npar - 1; /* set early to validate backrefs */
Safefree(r->precomp);
if (r->offsets) /* 20010421 MJD */
Safefree(r->offsets);
- if (RX_MATCH_COPIED(r))
- Safefree(r->subbeg);
+ RX_MATCH_COPY_FREE(r);
+#ifdef PERL_COPY_ON_WRITE
+ if (r->saved_copy)
+ SvREFCNT_dec(r->saved_copy);
+#endif
if (r->substrs) {
if (r->anchored_substr)
SvREFCNT_dec(r->anchored_substr);
PL_reg_oldsaved = Nullch;
SAVEI32(PL_reg_oldsavedlen); /* old length of saved substr during match */
PL_reg_oldsavedlen = 0;
+#ifdef PERL_COPY_ON_WRITE
+ SAVESPTR(PL_nrs);
+ PL_nrs = Nullsv;
+#endif
SAVEI32(PL_reg_maxiter); /* max wait until caching pos */
PL_reg_maxiter = 0;
SAVEI32(PL_reg_leftiter); /* wait until caching pos */
/* make sure $`, $&, $', and $digit will work later */
if ( !(flags & REXEC_NOT_FIRST) ) {
- if (RX_MATCH_COPIED(prog)) {
- Safefree(prog->subbeg);
- RX_MATCH_COPIED_off(prog);
- }
+ RX_MATCH_COPY_FREE(prog);
if (flags & REXEC_COPY_STR) {
I32 i = PL_regeol - startpos + (stringarg - strbeg);
-
- s = savepvn(strbeg, i);
- prog->subbeg = s;
+#ifdef PERL_COPY_ON_WRITE
+ if ((SvIsCOW(sv)
+ || (SvFLAGS(sv) & CAN_COW_MASK) == CAN_COW_FLAGS)) {
+ if (DEBUG_C_TEST) {
+ PerlIO_printf(Perl_debug_log,
+ "Copy on write: regexp capture, type %d\n",
+ (int) SvTYPE(sv));
+ }
+ prog->saved_copy = sv_setsv_cow(prog->saved_copy, sv);
+ prog->subbeg = SvPVX(prog->saved_copy);
+ assert (SvPOKp(prog->saved_copy));
+ } else
+#endif
+ {
+ RX_MATCH_COPIED_on(prog);
+ s = savepvn(strbeg, i);
+ prog->subbeg = s;
+ }
prog->sublen = i;
- RX_MATCH_COPIED_on(prog);
}
else {
prog->subbeg = strbeg;
$` inside (?{}) could fail... */
PL_reg_oldsaved = prog->subbeg;
PL_reg_oldsavedlen = prog->sublen;
+#ifdef PERL_COPY_ON_WRITE
+ PL_nrs = prog->saved_copy;
+#endif
RX_MATCH_COPIED_off(prog);
}
else
if (PL_reg_oldsaved) {
PL_reg_re->subbeg = PL_reg_oldsaved;
PL_reg_re->sublen = PL_reg_oldsavedlen;
+#ifdef PERL_COPY_ON_WRITE
+ PL_reg_re->saved_copy = PL_nrs;
+#endif
RX_MATCH_COPIED_on(PL_reg_re);
}
PL_reg_magic->mg_len = PL_reg_oldpos;
struct reg_data *data; /* Additional data. */
char *subbeg; /* saved or original string
so \digit works forever. */
+#ifdef PERL_COPY_ON_WRITE
+ SV *saved_copy; /* If non-NULL, SV which is COW from original */
+#endif
U32 *offsets; /* offset annotations 20001228 MJD */
I32 sublen; /* Length of string pointed by subbeg */
I32 refcnt;
? RX_MATCH_COPIED_on(prog) \
: RX_MATCH_COPIED_off(prog))
+#ifdef PERL_COPY_ON_WRITE
+#define RX_MATCH_COPY_FREE(rx) \
+ STMT_START {if (rx->saved_copy) { \
+ SV_CHECK_THINKFIRST_COW_DROP(rx->saved_copy); \
+ } \
+ if (RX_MATCH_COPIED(rx)) { \
+ Safefree(rx->subbeg); \
+ RX_MATCH_COPIED_off(rx); \
+ }} STMT_END
+#else
+#define RX_MATCH_COPY_FREE(rx) \
+ STMT_START {if (RX_MATCH_COPIED(rx)) { \
+ Safefree(rx->subbeg); \
+ RX_MATCH_COPIED_off(rx); \
+ }} STMT_END
+#endif
+
#define RX_MATCH_UTF8(prog) ((prog)->reganch & ROPT_MATCH_UTF8)
#define RX_MATCH_UTF8_on(prog) ((prog)->reganch |= ROPT_MATCH_UTF8)
#define RX_MATCH_UTF8_off(prog) ((prog)->reganch &= ~ROPT_MATCH_UTF8)
#define SV_COW_NEXT_SV_SET(current,next) SvUVX(current) = PTR2UV(next)
/* This is a pessimistic view. Scalar must be purely a read-write PV to copy-
on-write. */
-#define CAN_COW_MASK (SVs_OBJECT|SVs_GMG|SVs_SMG|SVs_RMG|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
/* ============================================================================
{
register char *s;
-
-
#ifdef HAS_64K_LIMIT
if (newlen >= 0x10000) {
PerlIO_printf(Perl_debug_log,
/* Either it's a shared hash key, or it's suitable for
copy-on-write or we can swipe the string. */
if (DEBUG_C_TEST) {
- PerlIO_printf(Perl_debug_log,
- "Copy on write: sstr --> dstr\n");
+ PerlIO_printf(Perl_debug_log, "Copy on write: sstr --> dstr\n");
sv_dump(sstr);
sv_dump(dstr);
}
SvSETMAGIC(dstr);
}
+#ifdef PERL_COPY_ON_WRITE
+SV *
+Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
+{
+ STRLEN cur = SvCUR(sstr);
+ STRLEN len = SvLEN(sstr);
+ register char *new_pv;
+
+ if (DEBUG_C_TEST) {
+ PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n",
+ sstr, dstr);
+ sv_dump(sstr);
+ if (dstr)
+ sv_dump(dstr);
+ }
+
+ if (dstr) {
+ if (SvTHINKFIRST(dstr))
+ sv_force_normal_flags(dstr, SV_COW_DROP_PV);
+ else if (SvPVX(dstr))
+ Safefree(SvPVX(dstr));
+ }
+ else
+ new_SV(dstr);
+ SvUPGRADE (dstr, SVt_PVIV);
+
+ assert (SvPOK(sstr));
+ assert (SvPOKp(sstr));
+ assert (!SvIOK(sstr));
+ assert (!SvIOKp(sstr));
+ assert (!SvNOK(sstr));
+ assert (!SvNOKp(sstr));
+
+ if (SvIsCOW(sstr)) {
+
+ if (SvLEN(sstr) == 0) {
+ /* source is a COW shared hash key. */
+ UV hash = SvUVX(sstr);
+ DEBUG_C(PerlIO_printf(Perl_debug_log,
+ "Fast copy on write: Sharing hash\n"));
+ SvUVX(dstr) = hash;
+ new_pv = sharepvn(SvPVX(sstr), (SvUTF8(sstr)?-cur:cur), hash);
+ goto common_exit;
+ }
+ SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
+ } else {
+ assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS);
+ SvUPGRADE (sstr, SVt_PVIV);
+ SvREADONLY_on(sstr);
+ SvFAKE_on(sstr);
+ DEBUG_C(PerlIO_printf(Perl_debug_log,
+ "Fast copy on write: Converting sstr to COW\n"));
+ SV_COW_NEXT_SV_SET(dstr, sstr);
+ }
+ SV_COW_NEXT_SV_SET(sstr, dstr);
+ new_pv = SvPVX(sstr);
+
+ common_exit:
+ SvPV_set(dstr, new_pv);
+ SvFLAGS(dstr) = (SVt_PVIV|SVf_POK|SVp_POK|SVf_FAKE|SVf_READONLY);
+ if (SvUTF8(sstr))
+ SvUTF8_on(dstr);
+ SvLEN(dstr) = len;
+ SvCUR(dstr) = cur;
+ if (DEBUG_C_TEST) {
+ sv_dump(dstr);
+ }
+ return dstr;
+}
+#endif
+
/*
=for apidoc sv_setpvn
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
+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.
PL_reg_curpm = (PMOP*)NULL;
PL_reg_oldsaved = Nullch;
PL_reg_oldsavedlen = 0;
+#ifdef PERL_COPY_ON_WRITE
+ PL_nrs = NullSv;
+#endif
PL_reg_maxiter = 0;
PL_reg_leftiter = 0;
PL_reg_poscache = Nullch;
# define SvRELEASE_IVX(sv) ((void)((SvFLAGS(sv) & (SVf_OOK|SVf_READONLY|SVf_FAKE)) \
&& Perl_sv_release_IVX(aTHX_ sv)))
# define SvIsCOW_normal(sv) (SvIsCOW(sv) && SvLEN(sv))
+
+#define CAN_COW_MASK (SVs_OBJECT|SVs_GMG|SVs_SMG|SVs_RMG|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)
+
#else
# define SvRELEASE_IVX(sv) ((void)SvOOK_off(sv))
#endif /* PERL_COPY_ON_WRITE */
/* Fields used by magic variables such as $@, $/ and so on */
PERLVAR(Ttainted, bool) /* using variables controlled by $< */
PERLVAR(Tcurpm, PMOP *) /* what to do \ interps in REs from */
-PERLVAR(Tnrs, SV *) /* placeholder: unused since 5.8.0 (5.7.2 patch #12027 for bug ID 20010815.012) */
+PERLVAR(Tnrs, SV *) /* was placeholder: unused since 5.8.0 (5.7.2 patch #12027 for bug ID 20010815.012). Used to save rx->saved_copy */
/*
=for apidoc mn|SV*|PL_rs
projects / p5sagit/p5-mst-13.2.git / commitdiff