Integrate:

[ 34063]
Subject: [PATCH] TODO B-Deparse cpan-bug 33708
From: "Reini Urban" <rurban@x-ray.at>
Date: Mon, 16 Jun 2008 14:40:35 +0200
Message-ID: <6910a60806160540v21c7affbte54ef0eedb0cb64d@mail.gmail.com>

[ 34358]
Subject: Re: [5.8] Change 33727 (op.c) breaks constant folding in "elsif"
From: Vincent Pit <perl@profvince.com>
Date: Sat, 13 Sep 2008 01:13:30 +0200
Message-ID: <48CAF79A.6000001@profvince.com>
p4raw-link: @34358 on //depot/perl: 71c4dbc37189d1d137ba8e40103273462dd96945
p4raw-link: @34063 on //depot/perl: 227375e110cf4ab60e97c3894326008fde5077e0

p4raw-id: //depot/maint-5.10/perl@35116
p4raw-integrated: from //depot/perl@34358 'edit in' op.c (@34322..)
	'merge in' pod/perlapi.pod (@34201..) embed.h (@34349..)
	embed.fnc proto.h (@34354..)
p4raw-integrated: from //depot/perl@34063 'copy in' ext/B/B/Deparse.pm
	(@33851..) 'edit in' ext/B/t/deparse.t (@33851..)

7 files changed, 156 insertions, 16 deletions

diff --git a/embed.fnc b/embed.fnc
index e7710c2a95..9b2a2a539d 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -1228,6 +1228,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 228ea4ce10..32bd0c9180 100644
--- a/embed.h
+++ b/embed.h
@@ -1216,6 +1216,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
@@ -3518,6 +3519,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/B/Deparse.pm b/ext/B/B/Deparse.pm
index b70a17ce75..0401ea36f9 100644
--- a/ext/B/B/Deparse.pm
+++ b/ext/B/B/Deparse.pm
@@ -4802,6 +4802,8 @@ dual-valued scalars correctly, as in:
 
     use constant E2BIG => ($!=7); $y = E2BIG; print $y, 0+$y;
 
+    use constant H => { "#" => 1 }; H->{"#"};
+
 =item *
 
 An input file that uses source filtering probably won't be deparsed into
@@ -4818,6 +4820,10 @@ have a compile-time side-effect, such as the obscure
 
 which is not, consequently, deparsed correctly.
 
+    foreach my $i (@_) { 0 }
+  =>
+    foreach my $i (@_) { '???' }
+
 =item *
 
 Lexical (my) variables declared in scopes external to a subroutine
diff --git a/ext/B/t/deparse.t b/ext/B/t/deparse.t
index 13c6e2caca..eb0f00be9c 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 => 61;
+use Test::More tests => 66;
 
 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);
@@ -420,3 +421,77 @@ else { x(); }
 # 54 interpolation in regexps
 my($y, $t);
 /x${y}z$t/;
+####
+# SKIP ?$B::Deparse::VERSION <= 0.87 && "TODO new undocumented cpan-bug #33708"
+# 55  (cpan-bug #33708)
+%{$_ || {}}
+####
+# SKIP ?$B::Deparse::VERSION <= 0.87 && "TODO hash constants not yet fixed"
+# 56  (cpan-bug #33708)
+use constant H => { "#" => 1 }; H->{"#"}
+####
+# SKIP ?$B::Deparse::VERSION <= 0.87 && "TODO optimized away 0 not yet fixed"
+# 57  (cpan-bug #33708)
+foreach my $i (@_) { 0 }
+####
+# 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 4ea1dc0426..e4e6e8183a 100644
--- a/op.c
+++ b/op.c
@@ -4311,13 +4311,60 @@ 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 * const other = *otherp;
+    OP *first;
+    OP *other;
+    OP *cstop = NULL;
+
+    first = *firstp;
+    other = *otherp;
 
     if (type == OP_XOR)		/* Not short circuit, but here by precedence. */
 	return newBINOP(type, flags, scalar(first), scalar(other));
@@ -4341,14 +4388,15 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
 	    op_free(o);
 	}
     }
-    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;
@@ -4468,6 +4516,7 @@ Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
     LOGOP *logop;
     OP *start;
     OP *o;
+    OP *cstop;
 
     if (!falseop)
 	return newLOGOP(OP_AND, 0, first, trueop);
@@ -4475,14 +4524,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 a1d112c69d..d3b1c3e119 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* ar)
 
diff --git a/proto.h b/proto.h
index e478e985f1..d0bf86738a 100644
--- a/proto.h
+++ b/proto.h
@@ -3305,6 +3305,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)