This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Reënable qr caching for (??{}) retval where possible
authorFather Chrysostomos <sprout@cpan.org>
Mon, 25 Nov 2013 07:11:57 +0000 (23:11 -0800)
committerFather Chrysostomos <sprout@cpan.org>
Mon, 25 Nov 2013 07:24:03 +0000 (23:24 -0800)
When a scalar is returned from (??{...}) inside a regexp, it gets com-
piled into a regexp if it is not one already.  Then the regexp is sup-
posed to be cached on that scalar (in magic), so that the same scalar
returned again will not require another compilation.

Commit e4bfbed39b disabled caching except on references to overloaded
objects.  But in that one case the caching caused erroneous behaviour,
which was just fixed by 636209429f and this commit’s parent, effect-
ively disabling the cache altogether.

The cache is disabled because it does not apply to TEMP variables
(those about to be freed anyway, for which caching would be a waste
of CPU), and all non-overloaded non-qr thingies get copied into
new mortal (TEMP) scalars (as of e4bfbed39b) before reaching the
caching code.

This commit skips the copy if the return value is already a non-magi-
cal string or number.  It also allows the caching to happen on con-
stants, which has never been permitted before.  (There is actually no
reason for disallowing qr magic on read-only variables.)

mg_raw.h
regen/mg_vtable.pl
regexec.c
t/re/recompile.t

index 487e209..f508ad0 100644 (file)
--- a/mg_raw.h
+++ b/mg_raw.h
@@ -60,7 +60,7 @@
       "/* tiedelem 'p' Tied array or hash element */" },
     { 'q', "want_vtbl_packelem",
       "/* tiedscalar 'q' Tied scalar or handle */" },
       "/* tiedelem 'p' Tied array or hash element */" },
     { 'q', "want_vtbl_packelem",
       "/* tiedscalar 'q' Tied scalar or handle */" },
-    { 'r', "want_vtbl_regexp | PERL_MAGIC_VALUE_MAGIC",
+    { 'r', "want_vtbl_regexp | PERL_MAGIC_READONLY_ACCEPTABLE | PERL_MAGIC_VALUE_MAGIC",
       "/* qr 'r' precompiled qr// regex */" },
     { 'S', "magic_vtable_max",
       "/* sig 'S' %SIG hash */" },
       "/* qr 'r' precompiled qr// regex */" },
     { 'S', "magic_vtable_max",
       "/* sig 'S' %SIG hash */" },
index d8217a8..0bbfbfd 100644 (file)
@@ -72,7 +72,7 @@ my %mg =
      tiedscalar => { char => 'q', vtable => 'packelem',
                     desc => 'Tied scalar or handle' },
      qr => { char => 'r', vtable => 'regexp', value_magic => 1, 
      tiedscalar => { char => 'q', vtable => 'packelem',
                     desc => 'Tied scalar or handle' },
      qr => { char => 'r', vtable => 'regexp', value_magic => 1, 
-            desc => 'precompiled qr// regex' },
+            readonly_acceptable => 1, desc => 'precompiled qr// regex' },
      sig => { char => 'S', desc => '%SIG hash' },
      sigelem => { char => 's', vtable => 'sigelem',
                  desc => '%SIG hash element' },
      sig => { char => 'S', desc => '%SIG hash' },
      sigelem => { char => 's', vtable => 'sigelem',
                  desc => '%SIG hash element' },
index c03179e..13ab3e1 100644 (file)
--- a/regexec.c
+++ b/regexec.c
@@ -5103,8 +5103,7 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog)
                else {                   /*  /(??{})  */
                    /*  if its overloaded, let the regex compiler handle
                     *  it; otherwise extract regex, or stringify  */
                else {                   /*  /(??{})  */
                    /*  if its overloaded, let the regex compiler handle
                     *  it; otherwise extract regex, or stringify  */
-                   const bool gmg = cBOOL(SvGMAGICAL(ret));
-                   if (gmg)
+                   if (SvGMAGICAL(ret))
                        ret = sv_mortalcopy(ret);
                    if (!SvAMAGIC(ret)) {
                        SV *sv = ret;
                        ret = sv_mortalcopy(ret);
                    if (!SvAMAGIC(ret)) {
                        SV *sv = ret;
@@ -5119,8 +5118,8 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog)
                        }
 
                        /* force any undef warnings here */
                        }
 
                        /* force any undef warnings here */
-                       if (!re_sv) {
-                           if (!gmg) ret = sv_mortalcopy(ret);
+                       if (!re_sv && !SvPOK(ret) && !SvNIOK(ret)) {
+                           ret = sv_mortalcopy(ret);
                            (void) SvPV_force_nolen(ret);
                        }
                    }
                            (void) SvPV_force_nolen(ret);
                        }
                    }
@@ -5173,8 +5172,8 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog)
                                     pm_flags);
 
                        if (!(SvFLAGS(ret)
                                     pm_flags);
 
                        if (!(SvFLAGS(ret)
-                             & (SVs_TEMP | SVs_PADTMP | SVf_READONLY
-                                | SVs_GMG | SVf_ROK))) {
+                             & (SVs_TEMP | SVs_GMG | SVf_ROK))
+                        && (!SvPADTMP(ret) || SvREADONLY(ret))) {
                            /* This isn't a first class regexp. Instead, it's
                               caching a regexp onto an existing, Perl visible
                               scalar.  */
                            /* This isn't a first class regexp. Instead, it's
                               caching a regexp onto an existing, Perl visible
                               scalar.  */
index 63a7068..f026fae 100644 (file)
@@ -22,7 +22,7 @@ BEGIN {
 }
 
 
 }
 
 
-plan tests => 38;
+plan tests => 46;
 
 my $results = runperl(
                        switches => [ '-Dr' ],
 
 my $results = runperl(
                        switches => [ '-Dr' ],
@@ -193,3 +193,20 @@ my $x = qr/a/i;
 my $y = qr/a/;
 "a" =~ qr/a$_/ for $x, $y, $x, $y;
 CODE
 my $y = qr/a/;
 "a" =~ qr/a$_/ for $x, $y, $x, $y;
 CODE
+
+comp_n(2, <<'CODE', '(??{"constant"})');
+"bb" =~ /(??{"abc"})/;
+CODE
+
+comp_n(2, <<'CODE', '(??{"folded"."constant"})');
+"bb" =~ /(??{"ab"."c"})/;
+CODE
+
+comp_n(2, <<'CODE', '(??{$preused_scalar})');
+$s = "abc";
+"bb" =~ /(??{$s})/;
+CODE
+
+comp_n(2, <<'CODE', '(??{number})');
+"bb" =~ /(??{123})/;
+CODE