Re: [5.8] Change 33727 (op.c) breaks constant folding in "elsif"

Message-ID: <48CAF79A.6000001@profvince.com>

p4raw-id: //depot/perl@34358

diff --git a/embed.fnc b/embed.fnc
index a193ab4..8242c00 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -1271,6 +1271,7 @@ s |void   |cop_free       |NN COP *cop
 s      |OP*    |modkids        |NULLOK OP *o|I32 type
 s      |OP*    |scalarboolean  |NN OP *o
 sR     |OP*    |newDEFSVOP
+sR     |OP*    |search_const   |NN OP *o
 sR     |OP*    |new_logop      |I32 type|I32 flags|NN OP **firstp|NN OP **otherp
 s      |void   |simplify_sort  |NN OP *o
 s      |const char*    |gv_ename       |NN GV *gv

diff --git a/embed.h b/embed.h
index 01f750c..dfe0dea 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -1220,6 +1220,7 @@
 #define modkids                        S_modkids
 #define scalarboolean          S_scalarboolean
 #define newDEFSVOP             S_newDEFSVOP
+#define search_const           S_search_const
 #define new_logop              S_new_logop
 #define simplify_sort          S_simplify_sort
 #define gv_ename               S_gv_ename
@@ -3529,6 +3530,7 @@
 #define modkids(a,b)           S_modkids(aTHX_ a,b)
 #define scalarboolean(a)       S_scalarboolean(aTHX_ a)
 #define newDEFSVOP()           S_newDEFSVOP(aTHX)
+#define search_const(a)                S_search_const(aTHX_ a)
 #define new_logop(a,b,c,d)     S_new_logop(aTHX_ a,b,c,d)
 #define simplify_sort(a)       S_simplify_sort(aTHX_ a)
 #define gv_ename(a)            S_gv_ename(aTHX_ a)

diff --git a/ext/B/t/deparse.t b/ext/B/t/deparse.t
index 42d50ba..c9232a2 100644 (file)
--- a/ext/B/t/deparse.t
+++ b/ext/B/t/deparse.t
@@ -27,7 +27,7 @@ BEGIN {
     require feature;
     feature->import(':5.10');
 }
-use Test::More tests => 66;
+use Test::More tests => 68;
 
 use B::Deparse;
 my $deparse = B::Deparse->new();
@@ -150,6 +150,7 @@ sub getcode {
 package main;
 use strict;
 use warnings;
+use constant GLIPP => 'glipp';
 sub test {
    my $val = shift;
    my $res = B::Deparse::Wrapper::getcode($val);
@@ -487,3 +488,65 @@ x() if $a or $b or $c;
 x() unless $a and $b and $c;
 x() if $a and $b and $c;
 x() unless not $a && $b && $c;
+####
+# 60 tests that should be constant folded
+x() if 1;
+x() if GLIPP;
+x() if !GLIPP;
+x() if GLIPP && GLIPP;
+x() if !GLIPP || GLIPP;
+x() if do { GLIPP };
+x() if do { no warnings 'void'; 5; GLIPP };
+x() if do { !GLIPP };
+if (GLIPP) { x() } else { z() }
+if (!GLIPP) { x() } else { z() }
+if (GLIPP) { x() } elsif (GLIPP) { z() }
+if (!GLIPP) { x() } elsif (GLIPP) { z() }
+if (GLIPP) { x() } elsif (!GLIPP) { z() }
+if (!GLIPP) { x() } elsif (!GLIPP) { z() }
+if (!GLIPP) { x() } elsif (!GLIPP) { z() } elsif (GLIPP) { t() }
+if (!GLIPP) { x() } elsif (!GLIPP) { z() } elsif (!GLIPP) { t() }
+if (!GLIPP) { x() } elsif (!GLIPP) { z() } elsif (!GLIPP) { t() }
+>>>>
+x();
+x();
+'???';
+x();
+x();
+x();
+x();
+do {
+    '???'
+};
+do {
+    x()
+};
+do {
+    z()
+};
+do {
+    x()
+};
+do {
+    z()
+};
+do {
+    x()
+};
+'???';
+do {
+    t()
+};
+'???';
+!1;
+####
+# 61 tests that shouldn't be constant folded
+x() if $a;
+if ($a == 1) { x() } elsif ($b == 2) { z() }
+if (do { foo(); GLIPP }) { x() }
+if (do { $a++; GLIPP }) { x() }
+>>>>
+x() if $a;
+if ($a == 1) { x(); } elsif ($b == 2) { z(); }
+if (do { foo(); 'glipp' }) { x(); }
+if (do { ++$a; 'glipp' }) { x(); }

diff --git a/op.c b/op.c
index d50660d..b8a6143 100644 (file)
--- a/op.c
+++ b/op.c
@@ -4450,17 +4450,64 @@ Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
 }
 
 STATIC OP *
+S_search_const(pTHX_ OP *o)
+{
+    PERL_ARGS_ASSERT_SEARCH_CONST;
+
+    switch (o->op_type) {
+       case OP_CONST:
+           return o;
+       case OP_NULL:
+           if (o->op_flags & OPf_KIDS)
+               return search_const(cUNOPo->op_first);
+           break;
+       case OP_LEAVE:
+       case OP_SCOPE:
+       case OP_LINESEQ:
+       {
+           OP *kid;
+           if (!(o->op_flags & OPf_KIDS))
+               return NULL;
+           kid = cLISTOPo->op_first;
+           do {
+               switch (kid->op_type) {
+                   case OP_ENTER:
+                   case OP_NULL:
+                   case OP_NEXTSTATE:
+                       kid = kid->op_sibling;
+                       break;
+                   default:
+                       if (kid != cLISTOPo->op_last)
+                           return NULL;
+                       goto last;
+               }
+           } while (kid);
+           if (!kid)
+               kid = cLISTOPo->op_last;
+last:
+           return search_const(kid);
+       }
+    }
+
+    return NULL;
+}
+
+STATIC OP *
 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
 {
     dVAR;
     LOGOP *logop;
     OP *o;
-    OP *first = *firstp;
-    OP *other = *otherp;
+    OP *first;
+    OP *other;
+    OP *cstop = NULL;
     int prepend_not = 0;
 
     PERL_ARGS_ASSERT_NEW_LOGOP;
 
+    first = *firstp;
+    other = *otherp;
+
     if (type == OP_XOR)                /* Not short circuit, but here by precedence. */
        return newBINOP(type, flags, scalar(first), scalar(other));
 
@@ -4483,14 +4530,15 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
            }
        }
     }
-    if (first->op_type == OP_CONST) {
-       if (first->op_private & OPpCONST_STRICT)
-           no_bareword_allowed(first);
-       else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
+    /* search for a constant op that could let us fold the test */
+    if ((cstop = search_const(first))) {
+       if (cstop->op_private & OPpCONST_STRICT)
+           no_bareword_allowed(cstop);
+       else if ((cstop->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
                Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
-       if ((type == OP_AND &&  SvTRUE(((SVOP*)first)->op_sv)) ||
-           (type == OP_OR  && !SvTRUE(((SVOP*)first)->op_sv)) ||
-           (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
+       if ((type == OP_AND &&  SvTRUE(((SVOP*)cstop)->op_sv)) ||
+           (type == OP_OR  && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
+           (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
            *firstp = NULL;
            if (other->op_type == OP_CONST)
                other->op_private |= OPpCONST_SHORTCIRCUIT;
@@ -4610,6 +4658,7 @@ Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
     LOGOP *logop;
     OP *start;
     OP *o;
+    OP *cstop;
 
     PERL_ARGS_ASSERT_NEWCONDOP;
 
@@ -4619,14 +4668,14 @@ Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
        return newLOGOP(OP_OR, 0, first, falseop);
 
     scalarboolean(first);
-    if (first->op_type == OP_CONST) {
+    if ((cstop = search_const(first))) {
        /* Left or right arm of the conditional?  */
-       const bool left = SvTRUE(((SVOP*)first)->op_sv);
+       const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
        OP *live = left ? trueop : falseop;
        OP *const dead = left ? falseop : trueop;
-        if (first->op_private & OPpCONST_BARE &&
-           first->op_private & OPpCONST_STRICT) {
-           no_bareword_allowed(first);
+        if (cstop->op_private & OPpCONST_BARE &&
+           cstop->op_private & OPpCONST_STRICT) {
+           no_bareword_allowed(cstop);
        }
        if (PL_madskills) {
            /* This is all dead code when PERL_MAD is not defined.  */

diff --git a/pod/perlapi.pod b/pod/perlapi.pod
index 4cedbc9..8b47295 100644 (file)
--- a/pod/perlapi.pod
+++ b/pod/perlapi.pod
@@ -279,7 +279,8 @@ Found in file av.c
 =item av_shift
 X<av_shift>
 
-Shifts an SV off the beginning of the array.
+Shifts an SV off the beginning of the array. Returns C<&PL_sv_undef> if the 
+array is empty.
 
        SV*     av_shift(AV *av)
 

diff --git a/proto.h b/proto.h
index d106187..f838f5c 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -4616,6 +4616,12 @@ STATIC OP*       S_scalarboolean(pTHX_ OP *o)
 STATIC OP*     S_newDEFSVOP(pTHX)
                        __attribute__warn_unused_result__;
 
+STATIC OP*     S_search_const(pTHX_ OP *o)
+                       __attribute__warn_unused_result__
+                       __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SEARCH_CONST  \
+       assert(o)
+
 STATIC OP*     S_new_logop(pTHX_ I32 type, I32 flags, OP **firstp, OP **otherp)
                        __attribute__warn_unused_result__
                        __attribute__nonnull__(pTHX_3)