Use const repl optimisation with s///e where possible

In those cases where s///e contains a single variable or a sequence
that is folded to a const op, we can do away with substcont.

PMf_EVAL means that there was an /e.  But we don’t actually need to
check that; instead we can just examine the op tree, which we have to
do anyway.

The op tree that s//$x/e and s//"constant"/e compile down to have a
null (a do-block) containing a scope op (block with a single state-
ment, as opposed to op_leave which represents multiple statements)
containing a null followed by the constant or variable.

diff --git a/dist/B-Deparse/Deparse.pm b/dist/B-Deparse/Deparse.pm
index 2a768c0..07386d5 100644 (file)
--- a/dist/B-Deparse/Deparse.pm
+++ b/dist/B-Deparse/Deparse.pm
@@ -4726,19 +4726,19 @@ sub pp_subst {
     my $flags = "";
     my $pmflags = $op->pmflags;
     if (null($op->pmreplroot)) {
-       $repl = $self->dq($kid);
+       $repl = $kid;
        $kid = $kid->sibling;
     } else {
        $repl = $op->pmreplroot->first; # skip substcont
-       while ($repl->name eq "entereval") {
+    }
+    while ($repl->name eq "entereval") {
            $repl = $repl->first;
            $flags .= "e";
-       }
-       if ($pmflags & PMf_EVAL) {
+    }
+    if ($pmflags & PMf_EVAL) {
            $repl = $self->deparse($repl->first, 0);
-       } else {
+    } else {
            $repl = $self->dq($repl);   
-       }
     }
     my $extended = ($pmflags & PMf_EXTENDED);
     if (null $kid) {

diff --git a/dist/B-Deparse/t/deparse.t b/dist/B-Deparse/t/deparse.t
index 3500d5b..d1c6cb0 100644 (file)
--- a/dist/B-Deparse/t/deparse.t
+++ b/dist/B-Deparse/t/deparse.t
@@ -322,6 +322,8 @@ my $foo = "Ab\x{100}\200\x{200}\237Cd\000Ef\x{1000}\cA\x{2000}\cZ";
 ####
 # s///e
 s/x/'y';/e;
+s/x/$a;/e;
+s/x/complex_expression();/e;
 ####
 # block
 { my $x; }

diff --git a/op.c b/op.c
index 7d6b3fc..f1b0d13 100644 (file)
--- a/op.c
+++ b/op.c
@@ -4752,24 +4752,34 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor)
     }
 
     if (repl) {
+       OP *curop = repl;
        bool konst;
        if (pm->op_pmflags & PMf_EVAL) {
-           konst = FALSE;
            if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
                CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
        }
-       else if (repl->op_type == OP_CONST)
+       /* If we are looking at s//.../e with a single statement, get past
+          the implicit do{}. */
+       if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS
+        && cUNOPx(curop)->op_first->op_type == OP_SCOPE
+        && cUNOPx(curop)->op_first->op_flags & OPf_KIDS) {
+           OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first;
+           if (kid->op_type == OP_NULL && kid->op_sibling
+            && !kid->op_sibling->op_sibling)
+               curop = kid->op_sibling;
+       }
+       if (curop->op_type == OP_CONST)
            konst = TRUE;
-       else if (( (repl->op_type == OP_RV2SV ||
-                   repl->op_type == OP_RV2AV ||
-                   repl->op_type == OP_RV2HV ||
-                   repl->op_type == OP_RV2GV)
-                && cUNOPx(repl)->op_first
-                && cUNOPx(repl)->op_first->op_type == OP_GV )
-             || repl->op_type == OP_PADSV
-             || repl->op_type == OP_PADAV
-             || repl->op_type == OP_PADHV
-             || repl->op_type == OP_PADANY) {
+       else if (( (curop->op_type == OP_RV2SV ||
+                   curop->op_type == OP_RV2AV ||
+                   curop->op_type == OP_RV2HV ||
+                   curop->op_type == OP_RV2GV)
+                  && cUNOPx(curop)->op_first
+                  && cUNOPx(curop)->op_first->op_type == OP_GV )
+               || curop->op_type == OP_PADSV
+               || curop->op_type == OP_PADAV
+               || curop->op_type == OP_PADHV
+               || curop->op_type == OP_PADANY) {
            repl_has_vars = 1;
            konst = TRUE;
        }

diff --git a/t/lib/warnings/9uninit b/t/lib/warnings/9uninit
index 717e7f6..43069f5 100644 (file)
--- a/t/lib/warnings/9uninit
+++ b/t/lib/warnings/9uninit
@@ -883,7 +883,7 @@ Use of uninitialized value $m1 in regexp compilation at - line 41.
 Use of uninitialized value $g1 in substitution (s///) at - line 42.
 Use of uninitialized value $m1 in regexp compilation at - line 43.
 Use of uninitialized value $g1 in substitution iterator at - line 43.
-Use of uninitialized value $m1 in substitution iterator at - line 44.
+Use of uninitialized value $m1 in substitution (s///) at - line 44.
 Use of uninitialized value in substitution iterator at - line 47.
 ########
 use warnings 'uninitialized';