add Perl_re_op_compile function
authorDavid Mitchell <davem@iabyn.com>
Fri, 19 Aug 2011 11:10:01 +0000 (12:10 +0100)
committerDavid Mitchell <davem@iabyn.com>
Wed, 13 Jun 2012 12:25:49 +0000 (13:25 +0100)
Make Perl_re_compile() a thin wrapper around a new function,
Perl_re_op_compile(). This function can take either a string pattern or a
list of ops. Then make pmruntime() pass a list of ops directly to it, rather
concatenating all the consts into a single string and passing the const to
Perl_re_compile(). For now, Perl_re_op_compile just does the same: if its
passed an op tree rather than an SV, then it just concats the consts.

So this is is just the next step towards eventually allowing the regex
engine to use the ops directly.

embed.fnc
embed.h
ext/re/re.xs
ext/re/re_top.h
op.c
proto.h
regcomp.c

index 55345c8..c628e89 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -1058,6 +1058,8 @@ Ap        |void*  |regdupe_internal|NN REGEXP * const r|NN CLONE_PARAMS* param
 #endif
 p      |regexp_engine*|current_re_engine
 Ap     |REGEXP*|pregcomp       |NN SV * const pattern|const U32 flags
+p      |REGEXP*|re_op_compile  |NULLOK SV * const pattern|NULLOK OP *expr \
+                               |U32 flags
 Ap     |REGEXP*|re_compile     |NN SV * const pattern|U32 flags
 Ap     |char*  |re_intuit_start|NN REGEXP * const rx|NULLOK SV* sv|NN char* strpos \
                                |NN char* strend|const U32 flags \
diff --git a/embed.h b/embed.h
index b565bb5..c95756b 100644 (file)
--- a/embed.h
+++ b/embed.h
 #define parser_free(a)         Perl_parser_free(aTHX_ a)
 #define peep(a)                        Perl_peep(aTHX_ a)
 #define pmruntime(a,b,c)       Perl_pmruntime(aTHX_ a,b,c)
+#define re_op_compile(a,b,c)   Perl_re_op_compile(aTHX_ a,b,c)
 #define refcounted_he_chain_2hv(a,b)   Perl_refcounted_he_chain_2hv(aTHX_ a,b)
 #define refcounted_he_fetch_pv(a,b,c,d)        Perl_refcounted_he_fetch_pv(aTHX_ a,b,c,d)
 #define refcounted_he_fetch_pvn(a,b,c,d,e)     Perl_refcounted_he_fetch_pvn(aTHX_ a,b,c,d,e)
index f40e16c..54e3640 100644 (file)
@@ -12,6 +12,7 @@
 START_EXTERN_C
 
 extern REGEXP* my_re_compile (pTHX_ SV * const pattern, const U32 pm_flags);
+extern REGEXP* my_re_op_compile (pTHX_ SV * const pattern, OP *expr, const U32 pm_flags);
 extern I32     my_regexec (pTHX_ REGEXP * const prog, char* stringarg, char* strend,
                            char* strbeg, I32 minend, SV* screamer,
                            void* data, U32 flags);
index 2d26207..e73550f 100644 (file)
@@ -13,6 +13,7 @@
 #define Perl_regprop            my_regprop
 #define Perl_re_intuit_start    my_re_intuit_start
 #define Perl_re_compile         my_re_compile
+#define Perl_re_op_compile      my_re_op_compile
 #define Perl_regfree_internal   my_regfree
 #define Perl_re_intuit_string   my_re_intuit_string
 #define Perl_regdupe_internal   my_regdupe
diff --git a/op.c b/op.c
index d132f5b..5cc9887 100644 (file)
--- a/op.c
+++ b/op.c
@@ -103,6 +103,7 @@ recursive, but it's recursive on basic blocks, not on tree nodes.
 #include "perl.h"
 #include "keywords.h"
 #include "feature.h"
+#include "regcomp.h"
 
 #define CALL_PEEP(o) PL_peepp(aTHX_ o)
 #define CALL_RPEEP(o) PL_rpeepp(aTHX_ o)
@@ -4250,15 +4251,17 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
     LOGOP *rcop;
     I32 repl_has_vars = 0;
     OP* repl = NULL;
-    bool reglist;
+    bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
+    bool is_compiletime;
+    bool has_code;
+    bool ext_eng;
+    regexp_engine *eng;
 
     PERL_ARGS_ASSERT_PMRUNTIME;
 
-    if (
-        o->op_type == OP_SUBST
-     || o->op_type == OP_TRANS || o->op_type == OP_TRANSR
-    ) {
-       /* last element in list is the replacement; pop it */
+    /* for s/// and tr///, last element in list is the replacement; pop it */
+
+    if (is_trans || o->op_type == OP_SUBST) {
        OP* kid;
        repl = cLISTOPx(expr)->op_last;
        kid = cLISTOPx(expr)->op_first;
@@ -4268,9 +4271,50 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
        cLISTOPx(expr)->op_last = kid;
     }
 
-    if (isreg && expr->op_type == OP_LIST) {
-       /* XXX tmp measure; strip all the DOs out and
-        * concatenate adjacent consts */
+    /* for TRANS, convert LIST/PUSH/CONST into CONST, and pass to pmtrans() */
+
+    if (is_trans) {
+       OP* const oe = expr;
+       assert(expr->op_type == OP_LIST);
+       assert(cLISTOPx(expr)->op_first->op_type == OP_PUSHMARK);
+       assert(cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last);
+       expr = cLISTOPx(oe)->op_last;
+       cLISTOPx(oe)->op_first->op_sibling = NULL;
+       cLISTOPx(oe)->op_last = NULL;
+       op_free(oe);
+
+       return pmtrans(o, expr, repl);
+    }
+
+    /* find whether we have any runtime or code elements */
+
+    is_compiletime = 1;
+    has_code = 0;
+    if (expr->op_type == OP_LIST) {
+       OP *o;
+       for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling) {
+           if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL))
+               has_code = 1;
+           else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK)
+               is_compiletime = 0;
+       }
+    }
+    else { assert(expr->op_type != OP_PUSHMARK); if (expr->op_type != OP_CONST && expr->op_type != OP_PUSHMARK)
+       is_compiletime = 0;
+    }
+
+   /* are we using an external (non-perl) re engine? */
+
+   eng = current_re_engine();
+   ext_eng = (eng &&  eng != &PL_core_reg_engine);
+
+    /* concatenate adjacent CONSTs, and for non-perl engines, strip out
+     * any DO blocks */
+
+    if (expr->op_type == OP_LIST
+       && (!is_compiletime || /* XXX TMP until we handle runtime (?{}) */
+          !has_code || ext_eng))
+    {
        OP *o, *kid;
        o = cLISTOPx(expr)->op_first;
        while (o->op_sibling) {
@@ -4296,50 +4340,44 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
        cLISTOPx(expr)->op_last = o;
     }
 
-
-
-    if (isreg && expr->op_type == OP_LIST &&
-       cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
-    {
-       /* convert single element list to element */
-       OP* const oe = expr;
-       expr = cLISTOPx(oe)->op_first->op_sibling;
-       cLISTOPx(oe)->op_first->op_sibling = NULL;
-       cLISTOPx(oe)->op_last = NULL;
-       op_free(oe);
-    }
-
-    if (o->op_type == OP_TRANS || o->op_type == OP_TRANSR) {
-       return pmtrans(o, expr, repl);
-    }
-
-    reglist = isreg && expr->op_type == OP_LIST;
-    if (reglist)
-       op_null(expr);
-
     PL_hints |= HINT_BLOCK_SCOPE;
     pm = (PMOP*)o;
 
-    if (expr->op_type == OP_CONST) {
-       SV *pat = ((SVOP*)expr)->op_sv;
+    if (is_compiletime) {
        U32 pm_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
 
        if (o->op_flags & OPf_SPECIAL)
            pm_flags |= RXf_SPLIT;
 
-       if (DO_UTF8(pat)) {
-           assert (SvUTF8(pat));
-       } else if (SvUTF8(pat)) {
-           /* Not doing UTF-8, despite what the SV says. Is this only if we're
-              trapped in use 'bytes'?  */
-           /* Make a copy of the octet sequence, but without the flag on, as
-              the compiler now honours the SvUTF8 flag on pat.  */
-           STRLEN len;
-           const char *const p = SvPV(pat, len);
-           pat = newSVpvn_flags(p, len, SVs_TEMP);
-       }
+       if (!has_code || ext_eng) {
+           SV *pat;
+           assert(    expr->op_type == OP_CONST
+                   || (   expr->op_type == OP_LIST
+                       && cLISTOPx(expr)->op_first->op_type == OP_PUSHMARK
+                       && cLISTOPx(expr)->op_first->op_sibling
+                       && cLISTOPx(expr)->op_first->op_sibling->op_type == OP_CONST
+                       && !cLISTOPx(expr)->op_first->op_sibling->op_sibling
+                       )
+           );
+           pat = ((SVOP*)(expr->op_type == OP_LIST
+                   ? cLISTOPx(expr)->op_first->op_sibling : expr))->op_sv;
+
+           if (DO_UTF8(pat)) {
+               assert (SvUTF8(pat));
+           } else if (SvUTF8(pat)) {
+               /* Not doing UTF-8, despite what the SV says. Is this only if we're
+                  trapped in use 'bytes'?  */
+               /* Make a copy of the octet sequence, but without the flag on, as
+                  the compiler now honours the SvUTF8 flag on pat.  */
+               STRLEN len;
+               const char *const p = SvPV(pat, len);
+               pat = newSVpvn_flags(p, len, SVs_TEMP);
+           }
 
-       PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
+           PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
+       }
+       else
+           PM_SETRE(pm, re_op_compile(NULL, expr, pm_flags));
 
 #ifdef PERL_MAD
        op_getmad(expr,(OP*)pm,'e');
@@ -4348,6 +4386,12 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
 #endif
     }
     else {
+       bool reglist;
+
+       reglist = isreg && expr->op_type == OP_LIST;
+       if (reglist)
+           op_null(expr);
+
        if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
            expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
                            ? OP_REGCRESET
diff --git a/proto.h b/proto.h
index e52b31b..dd991f3 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -3150,6 +3150,7 @@ PERL_CALLCONV SV* Perl_re_intuit_string(pTHX_ REGEXP  *const r)
 #define PERL_ARGS_ASSERT_RE_INTUIT_STRING      \
        assert(r)
 
+PERL_CALLCONV REGEXP*  Perl_re_op_compile(pTHX_ SV * const pattern, OP *expr, U32 flags);
 PERL_CALLCONV Malloc_t Perl_realloc(Malloc_t where, MEM_SIZE nbytes)
                        __attribute__malloc__
                        __attribute__warn_unused_result__;
index 5b5babf..394502b 100644 (file)
--- a/regcomp.c
+++ b/regcomp.c
@@ -4953,9 +4953,21 @@ Perl_pregcomp(pTHX_ SV * const pattern, const U32 flags)
 }
 #endif
 
+/* public(ish) wrapper for Perl_op_re_compile that only takes an SV
+ * pattern rather than a list of OPs */
+
+REGEXP *
+Perl_re_compile(pTHX_ SV * const pattern, U32 orig_pm_flags)
+{
+    PERL_ARGS_ASSERT_RE_COMPILE;
+    return Perl_re_op_compile(aTHX_ pattern, NULL, orig_pm_flags);
+}
+
 /*
- * Perl_re_compile - the perl internal RE engine's function to compile a
- * regular expression into internal code
+ * Perl_op_re_compile - the perl internal RE engine's function to compile a
+ * regular expression into internal code.
+ * The pattern may be passed either as a single SV string, or a list of
+ * OPs.
  *
  * We can't allocate space until we know how big the compiled form will be,
  * but we can't compile it (and thus know how big it is) until we've got a
@@ -4971,7 +4983,7 @@ Perl_pregcomp(pTHX_ SV * const pattern, const U32 flags)
  */
 
 REGEXP *
-Perl_re_compile(pTHX_ SV * const pattern, U32 orig_pm_flags)
+Perl_re_op_compile(pTHX_ SV * const pattern, OP *expr, U32 orig_pm_flags)
 {
     dVAR;
     REGEXP *rx;
@@ -4984,6 +4996,7 @@ Perl_re_compile(pTHX_ SV * const pattern, U32 orig_pm_flags)
     I32 flags;
     I32 minlen = 0;
     U32 pm_flags;
+    SV *pat;
 
     /* these are all flags - maybe they should be turned
      * into a single int with different bit masks */
@@ -5004,8 +5017,6 @@ Perl_re_compile(pTHX_ SV * const pattern, U32 orig_pm_flags)
 #endif    
     GET_RE_DEBUG_FLAGS_DECL;
 
-    PERL_ARGS_ASSERT_RE_COMPILE;
-
     DEBUG_r(if (!PL_colorset) reginitcolors());
 
 #ifndef PERL_IN_XSUB_RE
@@ -5066,7 +5077,38 @@ Perl_re_compile(pTHX_ SV * const pattern, U32 orig_pm_flags)
     }
 #endif
 
-    RExC_utf8 = RExC_orig_utf8 = SvUTF8(pattern);
+    if (expr) {
+       /* XXX tmp get rid of DO blocks, concat CONSTs */
+       OP *o, *kid;
+       o = cLISTOPx(expr)->op_first;
+       while (o->op_sibling) {
+           kid = o->op_sibling;
+           if (kid->op_type == OP_NULL && (kid->op_flags & OPf_SPECIAL)) {
+               /* do {...} */
+               o->op_sibling = kid->op_sibling;
+               kid->op_sibling = NULL;
+               op_free(kid);
+           }
+           else if (o->op_type == OP_CONST && kid->op_type == OP_CONST){
+               SV* sv = cSVOPo->op_sv;
+               SvREADONLY_off(sv);
+               sv_catsv(sv, cSVOPx(kid)->op_sv);
+               SvREADONLY_on(sv);
+               o->op_sibling = kid->op_sibling;
+               kid->op_sibling = NULL;
+               op_free(kid);
+           }
+           else
+               o = o->op_sibling;
+       }
+       cLISTOPx(expr)->op_last = o;
+       pat = ((SVOP*)(expr->op_type == OP_LIST
+               ? cLISTOPx(expr)->op_first->op_sibling : expr))->op_sv;
+    }
+    else
+       pat = pattern;
+
+    RExC_utf8 = RExC_orig_utf8 = SvUTF8(pat);
     RExC_uni_semantics = 0;
     RExC_contains_locale = 0;
 
@@ -5078,7 +5120,7 @@ Perl_re_compile(pTHX_ SV * const pattern, U32 orig_pm_flags)
     }
 
     if (jump_ret == 0) {    /* First time through */
-       exp = SvPV(pattern, plen);
+       exp = SvPV(pat, plen);
        xend = exp + plen;
        /* ignore the utf8ness if the pattern is 0 length */
        if (plen == 0) {
@@ -5115,7 +5157,7 @@ Perl_re_compile(pTHX_ SV * const pattern, U32 orig_pm_flags)
         -- dmq */
         DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log,
            "UTF8 mismatch! Converting to utf8 for resizing and compile\n"));
-        exp = (char*)Perl_bytes_to_utf8(aTHX_ (U8*)SvPV(pattern, plen), &len);
+        exp = (char*)Perl_bytes_to_utf8(aTHX_ (U8*)SvPV(pat, plen), &len);
         xend = exp + len;
         RExC_orig_utf8 = RExC_utf8 = 1;
         SAVEFREEPV(exp);
@@ -5260,7 +5302,7 @@ Perl_re_compile(pTHX_ SV * const pattern, U32 orig_pm_flags)
 
         p = sv_grow(MUTABLE_SV(rx), wraplen + 1); /* +1 for the ending NUL */
        SvPOK_on(rx);
-       SvFLAGS(rx) |= SvUTF8(pattern);
+       SvFLAGS(rx) |= SvUTF8(pat);
         *p++='('; *p++='?';
 
         /* If a default, cover it using the caret */