summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorDavid Mitchell <davem@iabyn.com>2017-07-07 14:13:32 +0100
committerDavid Mitchell <davem@iabyn.com>2017-07-27 11:30:21 +0100
commitdf6b4bd56551f2d39f7c0019c23f27181d8c39c4 (patch)
tree760cb0b40c0f202fe06ae67e0a239156b92597fe
parente8f01ee5fa8087b34dfe31b2c53eef0ba8718922 (diff)
downloadperl-df6b4bd56551f2d39f7c0019c23f27181d8c39c4.tar.gz
give REGEXP SVs the POK flag again
Commit v5.17.5-99-g8d919b0 stopped SVt_REGEXP SVs (and PVLVs acting as regexes) from having the POK and pPOK flags set. This made things like SvOK() and SvTRUE() slower, because as well as the quick single test for any I/N/P/R flags, SvOK() also has to test for (SvTYPE(sv) == SVt_REGEXP || (SvFLAGS(sv) & (SVTYPEMASK|SVp_POK|SVpgv_GP|SVf_FAKE)) == (SVt_PVLV|SVf_FAKE)) This commit fixes the issue fixed by g8d919b0 in a slightly different way, which is less invasive and allows the POK flag. Background: PVLV are basically PVMGs with a few extra fields. They are intended to be a superset of all scalar types, so any scalar value can be assigned to a PVLV SV. However, once REGEXPs were made into first-class scalar SVs, this assumption broke - there are a whole bunch of fields in a regex SV body which can't be copied to to a PVLV. So this broke: sub f { my $r = qr/abc/; # $r is reference to an SVt_REGEXP $_[0] = $$r; } f($h{foo}); # the hash access is deferred - a temporary PVLV is # passed instead The basic idea behind the g8d919b0 fix was, for an LV-acting-as-regex, to attach both a PVLV body and a regex body to the SV head. This commit keeps this basic concept; it just changes how the extra body is attached. The original fix changed SVt_REGEXP SVs so that sv.sv_u.svu_pv no longer pointed to the regexp's string representation; instead this pointer was stored in a union made out of the xpv_len field. Doing this necessitated not turning the POK flag on for any REGEXP SVs. This freed up the sv_u to point to the regex body, while the sv_any field could continue to point to the PVLV body. An ReANY() macro was introduced that returned the sv_u field rather than the sv_any field. This commit changes it so that instead, on regexp SVs (and LV-as-regexp SVs), sv_u always points to the string buffer (so they can have POK set again), but on specifically LV-as-regex SVs, the xpv_len_u union of the PVLV body points to the regexp body. This means that SVt_REGEXP SVs are now completely "normal" again, and SVt_PVLV SVs are normal except in the one case where they hold a regex, in which case rather than storing the string buffer's length, the PVLV body stores a pointer to the regex body.
-rw-r--r--ext/B/B/Concise.pm4
-rw-r--r--ext/Devel-Peek/t/Peek.t9
-rw-r--r--inline.h4
-rw-r--r--op.c4
-rw-r--r--perl.h2
-rw-r--r--regcomp.c21
-rw-r--r--regexp.h5
-rw-r--r--sv.c52
-rw-r--r--sv.h20
9 files changed, 59 insertions, 62 deletions
diff --git a/ext/B/B/Concise.pm b/ext/B/B/Concise.pm
index d877219190..6465a3c131 100644
--- a/ext/B/B/Concise.pm
+++ b/ext/B/B/Concise.pm
@@ -730,13 +730,13 @@ sub concise_sv {
$hr->{svval} .= ["Null", "sv_undef", "sv_yes", "sv_no",
'', '', '', "sv_zero"]->[$$sv];
} elsif ($preferpv
- && ($sv->FLAGS & SVf_POK || class($sv) eq "REGEXP")) {
+ && ($sv->FLAGS & SVf_POK)) {
$hr->{svval} .= cstring($sv->PV);
} elsif ($sv->FLAGS & SVf_NOK) {
$hr->{svval} .= $sv->NV;
} elsif ($sv->FLAGS & SVf_IOK) {
$hr->{svval} .= $sv->int_value;
- } elsif ($sv->FLAGS & SVf_POK || class($sv) eq "REGEXP") {
+ } elsif ($sv->FLAGS & SVf_POK) {
$hr->{svval} .= cstring($sv->PV);
} elsif (class($sv) eq "HV") {
$hr->{svval} .= 'HASH';
diff --git a/ext/Devel-Peek/t/Peek.t b/ext/Devel-Peek/t/Peek.t
index 2b1ed5d562..db9354bd0e 100644
--- a/ext/Devel-Peek/t/Peek.t
+++ b/ext/Devel-Peek/t/Peek.t
@@ -359,8 +359,7 @@ do_test('reference to regexp',
RV = $ADDR
SV = REGEXP\\($ADDR\\) at $ADDR
REFCNT = 1
- FLAGS = \\(OBJECT,POK,FAKE,pPOK\\) # $] < 5.017006
- FLAGS = \\(OBJECT,FAKE\\) # $] >= 5.017006
+ FLAGS = \\(OBJECT,POK,FAKE,pPOK\\)
PV = $ADDR "\\(\\?\\^:tic\\)"
CUR = 8
LEN = 0 # $] < 5.017006
@@ -387,7 +386,7 @@ do_test('reference to regexp',
. ($] < 5.019003 ? '' : '
SV = REGEXP\($ADDR\) at $ADDR
REFCNT = 2
- FLAGS = \(\)
+ FLAGS = \(POK,pPOK\)
PV = $ADDR "\(\?\^:tic\)"
CUR = 8
COMPFLAGS = 0x0 \(\)
@@ -1162,7 +1161,7 @@ do_test('UTF-8 in a regular expression',
RV = $ADDR
SV = REGEXP\($ADDR\) at $ADDR
REFCNT = 1
- FLAGS = \(OBJECT,FAKE,UTF8\)
+ FLAGS = \(OBJECT,POK,FAKE,pPOK,UTF8\)
PV = $ADDR "\(\?\^u:\\\\\\\\x\{100\}\)" \[UTF8 "\(\?\^u:\\\\\\\\x\{100\}\)"\]
CUR = 13
STASH = $ADDR "Regexp"
@@ -1186,7 +1185,7 @@ do_test('UTF-8 in a regular expression',
. ($] < 5.019003 ? '' : '
SV = REGEXP\($ADDR\) at $ADDR
REFCNT = 2
- FLAGS = \(UTF8\)
+ FLAGS = \(POK,pPOK,UTF8\)
PV = $ADDR "\(\?\^u:\\\\\\\\x\{100\}\)" \[UTF8 "\(\?\^u:\\\\\\\\x\{100\}\)"\]
CUR = 13
COMPFLAGS = 0x0 \(\)
diff --git a/inline.h b/inline.h
index dc74d1d93d..96a68ea75b 100644
--- a/inline.h
+++ b/inline.h
@@ -153,8 +153,10 @@ S_POPMARK(pTHX)
PERL_STATIC_INLINE struct regexp *
S_ReANY(const REGEXP * const re)
{
+ XPV* const p = (XPV*)SvANY(re);
assert(isREGEXP(re));
- return re->sv_u.svu_rx;
+ return SvTYPE(re) == SVt_PVLV ? p->xpv_len_u.xpvlenu_rx
+ : (struct regexp *)p;
}
/* ------------------------------- sv.h ------------------------------- */
diff --git a/op.c b/op.c
index a5cbfb6a88..1e85dd1830 100644
--- a/op.c
+++ b/op.c
@@ -10428,7 +10428,9 @@ Perl_ck_index(pTHX_ OP *o)
if (kid && kid->op_type == OP_CONST) {
const bool save_taint = TAINT_get;
SV *sv = kSVOP->op_sv;
- if ((!SvPOK(sv) || SvNIOKp(sv)) && SvOK(sv) && !SvROK(sv)) {
+ if ( (!SvPOK(sv) || SvNIOKp(sv) || isREGEXP(sv))
+ && SvOK(sv) && !SvROK(sv))
+ {
sv = newSV(0);
sv_copypv(sv, kSVOP->op_sv);
SvREFCNT_dec_NN(kSVOP->op_sv);
diff --git a/perl.h b/perl.h
index db1b5b318e..c09536bfb1 100644
--- a/perl.h
+++ b/perl.h
@@ -5715,7 +5715,7 @@ PL_valid_types_IVX[] = { 0, 1, 0, 0, 0, 1, 1, 1, 0, 1, 1, 0, 0, 0, 0, 0 };
EXTCONST bool
PL_valid_types_NVX[] = { 0, 0, 1, 0, 0, 0, 1, 1, 0, 1, 1, 0, 0, 0, 0, 0 };
EXTCONST bool
-PL_valid_types_PVX[] = { 0, 0, 0, 1, 1, 1, 1, 1, 0, 1, 1, 0, 0, 1, 1, 1 };
+PL_valid_types_PVX[] = { 0, 0, 0, 1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 1, 1, 1 };
EXTCONST bool
PL_valid_types_RV[] = { 0, 1, 0, 1, 0, 1, 1, 1, 1, 1, 1, 0, 0, 0, 0, 1 };
EXTCONST bool
diff --git a/regcomp.c b/regcomp.c
index 088def552a..e5037fc046 100644
--- a/regcomp.c
+++ b/regcomp.c
@@ -7262,8 +7262,8 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count,
/* make sure PL_bitcount bounds not exceeded */
assert(sizeof(STD_PAT_MODS) <= 8);
- Newx(p, wraplen + 1, char); /* +1 for the ending NUL */
- r->xpv_len_u.xpvlenu_pv = p;
+ p = sv_grow(MUTABLE_SV(rx), wraplen + 1); /* +1 for the ending NUL */
+ SvPOK_on(rx);
if (RExC_utf8)
SvFLAGS(rx) |= SVf_UTF8;
*p++='('; *p++='?';
@@ -19516,7 +19516,6 @@ Perl_pregfree2(pTHX_ REGEXP *rx)
} else {
CALLREGFREE_PVT(rx); /* free the private data */
SvREFCNT_dec(RXp_PAREN_NAMES(r));
- Safefree(r->xpv_len_u.xpvlenu_pv);
}
if (r->substrs) {
int i;
@@ -19534,7 +19533,6 @@ Perl_pregfree2(pTHX_ REGEXP *rx)
SvREFCNT_dec(r->qr_anoncv);
if (r->recurse_locinput)
Safefree(r->recurse_locinput);
- rx->sv_u.svu_rx = 0;
}
/* reg_temp_copy()
@@ -19568,12 +19566,12 @@ Perl_reg_temp_copy (pTHX_ REGEXP *ret_x, REGEXP *rx)
else {
SvOK_off((SV *)ret_x);
if (islv) {
- /* For PVLVs, SvANY points to the xpvlv body while sv_u points
- to the regexp. (For SVt_REGEXPs, sv_upgrade has already
- made both spots point to the same regexp body.) */
+ /* For PVLVs, the head (sv_any) points to an XPVLV, while
+ * the LV's xpvlenu_rx will point to a regexp body, which
+ * we allocate here */
REGEXP *temp = (REGEXP *)newSV_type(SVt_REGEXP);
assert(!SvPVX(ret_x));
- ret_x->sv_u.svu_rx = temp->sv_any;
+ ((XPV*)SvANY(ret_x))->xpv_len_u.xpvlenu_rx = temp->sv_any;
temp->sv_any = NULL;
SvFLAGS(temp) = (SvFLAGS(temp) & ~SVTYPEMASK) | SVt_NULL;
SvREFCNT_dec_NN(temp);
@@ -19587,13 +19585,16 @@ Perl_reg_temp_copy (pTHX_ REGEXP *ret_x, REGEXP *rx)
SvFAKE_on(ret_x);
ret = ReANY(ret_x);
- SvFLAGS(ret_x) |= SvUTF8(rx);
+ SvFLAGS(ret_x) |= SvFLAGS(rx) & (SVf_POK|SVp_POK|SVf_UTF8);
+ SvPV_set(ret_x, RX_WRAPPED(rx));
/* We share the same string buffer as the original regexp, on which we
hold a reference count, incremented when mother_re is set below.
The string pointer is copied here, being part of the regexp struct.
*/
memcpy(&(ret->xpv_cur), &(r->xpv_cur),
sizeof(regexp) - STRUCT_OFFSET(regexp, xpv_cur));
+ if (!islv)
+ SvLEN_set(ret_x, 0);
if (r->offs) {
const I32 npar = r->nparens+1;
Newx(ret->offs, npar, regexp_paren_pair);
@@ -19847,7 +19848,7 @@ Perl_re_dup_guts(pTHX_ const REGEXP *sstr, REGEXP *dstr, CLONE_PARAMS *param)
1: a buffer in a different thread
2: something we no longer hold a reference on
so we need to copy it locally. */
- RX_WRAPPED(dstr) = SAVEPVN(RX_WRAPPED(sstr), SvCUR(sstr)+1);
+ RX_WRAPPED(dstr) = SAVEPVN(RX_WRAPPED_const(sstr), SvCUR(sstr)+1);
ret->mother_re = NULL;
}
#endif /* PERL_IN_XSUB_RE */
diff --git a/regexp.h b/regexp.h
index 9a2b61a18e..2e4c3b805b 100644
--- a/regexp.h
+++ b/regexp.h
@@ -499,8 +499,9 @@ and check for NULL.
writers? Specifically, the value 1 assumes that the wrapped version always
has exactly one character at the end, a ')'. Will that always be true? */
#define RX_PRELEN(prog) (RX_WRAPLEN(prog) - ReANY(prog)->pre_prefix - 1)
-#define RX_WRAPPED(prog) ReANY(prog)->xpv_len_u.xpvlenu_pv
-#define RX_WRAPPED_const(prog) ((const char *)RX_WRAPPED(prog))
+
+#define RX_WRAPPED(prog) SvPVX(prog)
+#define RX_WRAPPED_const(prog) SvPVX_const(prog)
#define RX_WRAPLEN(prog) SvCUR(prog)
#define RX_CHECK_SUBSTR(prog) (ReANY(prog)->check_substr)
#define RX_REFCNT(prog) SvREFCNT(prog)
diff --git a/sv.c b/sv.c
index 70ad03e6c5..887c9e7bd8 100644
--- a/sv.c
+++ b/sv.c
@@ -1462,9 +1462,7 @@ Perl_sv_upgrade(pTHX_ SV *const sv, svtype new_type)
SvSTASH_set(io, MUTABLE_HV(SvREFCNT_inc(GvHV(iogv))));
IoPAGE_LEN(sv) = 60;
}
- if (UNLIKELY(new_type == SVt_REGEXP))
- sv->sv_u.svu_rx = (regexp *)new_body;
- else if (old_type < SVt_PV) {
+ if (old_type < SVt_PV) {
/* referent will be NULL unless the old type was SVt_IV emulating
SVt_RV */
sv->sv_u.svu_rv = referent;
@@ -2463,7 +2461,7 @@ Perl_sv_2iv_flags(pTHX_ SV *const sv, const I32 flags)
Regexps have no SvIVX and SvNVX fields.
*/
- assert(isREGEXP(sv) || SvPOKp(sv));
+ assert(SvPOKp(sv));
{
UV value;
const char * const ptr =
@@ -2551,7 +2549,7 @@ Perl_sv_2uv_flags(pTHX_ SV *const sv, const I32 flags)
/* FBMs use the space for SvIVX and SvNVX for other purposes, and use
the same flag bit as SVf_IVisUV, so must not let them cache IVs.
Regexps have no SvIVX and SvNVX fields. */
- assert(isREGEXP(sv) || SvPOKp(sv));
+ assert(SvPOKp(sv));
{
UV value;
const char * const ptr =
@@ -2627,7 +2625,6 @@ Perl_sv_2nv_flags(pTHX_ SV *const sv, const I32 flags)
return SvNVX(sv);
if (SvPOKp(sv) && !SvIOKp(sv)) {
ptr = SvPVX_const(sv);
- grokpv:
if (!SvIOKp(sv) && ckWARN(WARN_NUMERIC) &&
!grok_number(ptr, SvCUR(sv), NULL))
not_a_number(sv);
@@ -2642,10 +2639,6 @@ Perl_sv_2nv_flags(pTHX_ SV *const sv, const I32 flags)
if (SvROK(sv)) {
goto return_rok;
}
- if (isREGEXP(sv)) {
- ptr = RX_WRAPPED((REGEXP *)sv);
- goto grokpv;
- }
assert(SvTYPE(sv) >= SVt_PVMG);
/* This falls through to the report_uninit near the end of the
function. */
@@ -3191,10 +3184,6 @@ Perl_sv_2pv_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags)
*lp = SvCUR(buffer);
return SvPVX(buffer);
}
- else if (isREGEXP(sv)) {
- if (lp) *lp = RX_WRAPLEN((REGEXP *)sv);
- return RX_WRAPPED((REGEXP *)sv);
- }
else {
if (lp)
*lp = 0;
@@ -4447,15 +4436,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, SV* sstr, const I32 flags)
case SVt_REGEXP:
upgregexp:
if (dtype < SVt_REGEXP)
- {
- if (dtype >= SVt_PV) {
- SvPV_free(dstr);
- SvPV_set(dstr, 0);
- SvLEN_set(dstr, 0);
- SvCUR_set(dstr, 0);
- }
sv_upgrade(dstr, SVt_REGEXP);
- }
break;
case SVt_INVLIST:
@@ -5337,7 +5318,7 @@ Perl_sv_force_normal_flags(pTHX_ SV *const sv, const U32 flags)
const svtype new_type =
islv ? SVt_NULL : SvMAGIC(sv) || SvSTASH(sv) ? SVt_PVMG : SVt_PV;
SV *const temp = newSV_type(new_type);
- regexp *const temp_p = ReANY((REGEXP *)sv);
+ regexp *old_rx_body;
if (new_type == SVt_PVMG) {
SvMAGIC_set(temp, SvMAGIC(sv));
@@ -5345,15 +5326,26 @@ Perl_sv_force_normal_flags(pTHX_ SV *const sv, const U32 flags)
SvSTASH_set(temp, SvSTASH(sv));
SvSTASH_set(sv, NULL);
}
- if (!islv) SvCUR_set(temp, SvCUR(sv));
- /* Remember that SvPVX is in the head, not the body. But
- RX_WRAPPED is in the body. */
+ if (!islv)
+ SvCUR_set(temp, SvCUR(sv));
+ /* Remember that SvPVX is in the head, not the body. */
assert(ReANY((REGEXP *)sv)->mother_re);
+
+ if (islv) {
+ /* LV-as-regex has sv->sv_any pointing to an XPVLV body,
+ * whose xpvlenu_rx field points to the regex body */
+ XPV *xpv = (XPV*)(SvANY(sv));
+ old_rx_body = xpv->xpv_len_u.xpvlenu_rx;
+ xpv->xpv_len_u.xpvlenu_rx = NULL;
+ }
+ else
+ old_rx_body = ReANY((REGEXP *)sv);
+
/* Their buffer is already owned by someone else. */
if (flags & SV_COW_DROP_PV) {
/* SvLEN is already 0. For SVt_REGEXP, we have a brand new
- zeroed body. For SVt_PVLV, it should have been set to 0
- before turning into a regexp. */
+ zeroed body. For SVt_PVLV, we zeroed it above (len field
+ a union with xpvlenu_rx) */
assert(!SvLEN(islv ? sv : temp));
sv->sv_u.svu_pv = 0;
}
@@ -5374,8 +5366,7 @@ Perl_sv_force_normal_flags(pTHX_ SV *const sv, const U32 flags)
SvFLAGS(temp) &= ~(SVTYPEMASK);
SvFLAGS(temp) |= SVt_REGEXP|SVf_FAKE;
- SvANY(temp) = temp_p;
- temp->sv_u.svu_rx = (regexp *)temp_p;
+ SvANY(temp) = old_rx_body;
SvREFCNT_dec_NN(temp);
}
@@ -14229,7 +14220,6 @@ S_sv_dup_common(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
case SVt_REGEXP:
duprex:
/* FIXME for plugins */
- dstr->sv_u.svu_rx = ((REGEXP *)dstr)->sv_any;
re_dup_guts((REGEXP*) sstr, (REGEXP*) dstr, param);
break;
case SVt_PVLV:
diff --git a/sv.h b/sv.h
index 5b11c18f33..b468ad00da 100644
--- a/sv.h
+++ b/sv.h
@@ -208,7 +208,6 @@ typedef struct hek HEK;
UV svu_uv; \
_NV_BODYLESS_UNION \
SV* svu_rv; /* pointer to another SV */ \
- struct regexp* svu_rx; \
SV** svu_array; \
HE** svu_hash; \
GP* svu_gp; \
@@ -402,7 +401,12 @@ perform the upgrade if necessary. See C<L</svtype>>.
refers to an eval or once only
[CvEVAL(cv), CvSPECIAL(cv)]
3: HV: informally reserved by DAPM
- for vtables */
+ for vtables
+ 4: Together with other flags (or
+ lack thereof) indicates a regex,
+ including PVLV-as-regex. See
+ isREGEXP().
+ */
#define SVf_OOK 0x02000000 /* has valid offset value. For a PVHV this
means that a hv_aux struct is present
after the main array */
@@ -473,7 +477,7 @@ perform the upgrade if necessary. See C<L</svtype>>.
STRLEN xpv_cur; /* length of svu_pv as a C string */ \
union { \
STRLEN xpvlenu_len; /* allocated size */ \
- char * xpvlenu_pv; /* regexp string */ \
+ struct regexp* xpvlenu_rx; /* regex when SV body is XPVLV */ \
} xpv_len_u
#define xpv_len xpv_len_u.xpvlenu_len
@@ -847,7 +851,7 @@ Set the size of the string buffer for the SV. See C<L</SvLEN>>.
#define assert_not_ROK(sv) assert_(!SvROK(sv) || !SvRV(sv))
#define assert_not_glob(sv) assert_(!isGV_with_GP(sv))
-#define SvOK(sv) (SvFLAGS(sv) & SVf_OK || isREGEXP(sv))
+#define SvOK(sv) (SvFLAGS(sv) & SVf_OK)
#define SvOK_off(sv) (assert_not_ROK(sv) assert_not_glob(sv) \
SvFLAGS(sv) &= ~(SVf_OK| \
SVf_IVisUV|SVf_UTF8), \
@@ -1181,8 +1185,7 @@ object type. Exposed to perl code via Internals::SvREADONLY().
}))
# define SvCUR(sv) \
(*({ const SV *const _svcur = (const SV *)(sv); \
- assert(PL_valid_types_PVX[SvTYPE(_svcur) & SVt_MASK] \
- || SvTYPE(_svcur) == SVt_REGEXP); \
+ assert(PL_valid_types_PVX[SvTYPE(_svcur) & SVt_MASK]); \
assert(!isGV_with_GP(_svcur)); \
assert(!(SvTYPE(_svcur) == SVt_PVIO \
&& !(IoFLAGS(_svcur) & IOf_FAKE_DIRP))); \
@@ -1312,8 +1315,7 @@ object type. Exposed to perl code via Internals::SvREADONLY().
(((XPVMG*) SvANY(sv))->xmg_stash = (val)); } STMT_END
#define SvCUR_set(sv, val) \
STMT_START { \
- assert(PL_valid_types_PVX[SvTYPE(sv) & SVt_MASK] \
- || SvTYPE(sv) == SVt_REGEXP); \
+ assert(PL_valid_types_PVX[SvTYPE(sv) & SVt_MASK]); \
assert(!isGV_with_GP(sv)); \
assert(!(SvTYPE(sv) == SVt_PVIO \
&& !(IoFLAGS(sv) & IOf_FAKE_DIRP))); \
@@ -2128,7 +2130,7 @@ See also C<L</PL_sv_yes>> and C<L</PL_sv_no>>.
} STMT_END
#define isREGEXP(sv) \
(SvTYPE(sv) == SVt_REGEXP \
- || (SvFLAGS(sv) & (SVTYPEMASK|SVp_POK|SVpgv_GP|SVf_FAKE)) \
+ || (SvFLAGS(sv) & (SVTYPEMASK|SVpgv_GP|SVf_FAKE)) \
== (SVt_PVLV|SVf_FAKE))