From: Vincent Pit <perl@profvince.com>
Date: Sat, 13 Sep 2008 01:13:30 +0000 (+0200)
Subject: Re: [5.8] Change 33727 (op.c) breaks constant folding in "elsif"
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=71c4dbc37189d1d137ba8e40103273462dd96945;p=p5sagit%2Fp5-mst-13.2.git

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
--- 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
--- 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
--- 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
--- 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
--- 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
--- 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)