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.

diff --git a/ext/B/B/Concise.pm b/ext/B/B/Concise.pm
index d877219..6465a3c 100644 (file)
--- 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 2b1ed5d..db9354b 100644 (file)
--- 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 dc74d1d..96a68ea 100644 (file)
--- 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 a5cbfb6..1e85dd1 100644 (file)
--- 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 db1b5b3..c09536b 100644 (file)
--- 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 088def5..e5037fc 100644 (file)
--- 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 9a2b61a..2e4c3b8 100644 (file)
--- 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 70ad03e..887c9e7 100644 (file)
--- 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 5b11c18..b468ad0 100644 (file)
--- 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))