[prev in list] [next in list] [prev in thread] [next in thread] 

List:       perl5-changes
Subject:    Change 35116: Integrate:
From:       Dave Mitchell <davem () iabyn ! com>
Date:       2008-12-16 1:15:03
Message-ID: 20081216011503.23B9814017 () mx ! activestate ! com
[Download RAW message or body]

Change 35116 by davem@davem-pigeon on 2008/12/16 01:03:17

	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>

Affected files ...

... //depot/maint-5.10/perl/embed.fnc#14 integrate
... //depot/maint-5.10/perl/embed.h#10 integrate
... //depot/maint-5.10/perl/ext/B/B/Deparse.pm#8 integrate
... //depot/maint-5.10/perl/ext/B/t/deparse.t#7 integrate
... //depot/maint-5.10/perl/op.c#20 integrate
... //depot/maint-5.10/perl/pod/perlapi.pod#7 integrate
... //depot/maint-5.10/perl/proto.h#13 integrate

Differences ...

==== //depot/maint-5.10/perl/embed.fnc#14 (text) ====
Index: perl/embed.fnc
--- perl/embed.fnc#13~34495~	2008-10-16 13:45:27.000000000 -0700
+++ perl/embed.fnc	2008-12-15 17:03:17.000000000 -0800
@@ -1228,6 +1228,7 @@
 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

==== //depot/maint-5.10/perl/embed.h#10 (text+w) ====
Index: perl/embed.h
--- perl/embed.h#9~34599~	2008-10-26 14:44:48.000000000 -0700
+++ perl/embed.h	2008-12-15 17:03:17.000000000 -0800
@@ -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)

==== //depot/maint-5.10/perl/ext/B/B/Deparse.pm#8 (text) ====
Index: perl/ext/B/B/Deparse.pm
--- perl/ext/B/B/Deparse.pm#7~33955~	2008-05-30 18:54:46.000000000 -0700
+++ perl/ext/B/B/Deparse.pm	2008-12-15 17:03:17.000000000 -0800
@@ -4802,6 +4802,8 @@
 
     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 @@
 
 which is not, consequently, deparsed correctly.
 
+    foreach my $i (@_) { 0 }
+  =>
+    foreach my $i (@_) { '???' }
+
 =item *
 
 Lexical (my) variables declared in scopes external to a subroutine

==== //depot/maint-5.10/perl/ext/B/t/deparse.t#7 (text) ====
Index: perl/ext/B/t/deparse.t
--- perl/ext/B/t/deparse.t#6~33955~	2008-05-30 18:54:46.000000000 -0700
+++ perl/ext/B/t/deparse.t	2008-12-15 17:03:17.000000000 -0800
@@ -27,7 +27,7 @@
     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 @@
 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 @@
 # 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(); }

==== //depot/maint-5.10/perl/op.c#20 (text) ====
Index: perl/op.c
--- perl/op.c#19~34898~	2008-11-21 02:22:59.000000000 -0800
+++ perl/op.c	2008-12-15 17:03:17.000000000 -0800
@@ -4311,13 +4311,60 @@
 }
 
 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 @@
 	    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 @@
     LOGOP *logop;
     OP *start;
     OP *o;
+    OP *cstop;
 
     if (!falseop)
 	return newLOGOP(OP_AND, 0, first, trueop);
@@ -4475,14 +4524,14 @@
 	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.  */

==== //depot/maint-5.10/perl/pod/perlapi.pod#7 (text+w) ====
Index: perl/pod/perlapi.pod
--- perl/pod/perlapi.pod#6~34659~	2008-10-30 04:07:58.000000000 -0700
+++ perl/pod/perlapi.pod	2008-12-15 17:03:17.000000000 -0800
@@ -279,7 +279,8 @@
 =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)
 

==== //depot/maint-5.10/perl/proto.h#13 (text+w) ====
Index: perl/proto.h
--- perl/proto.h#12~34599~	2008-10-26 14:44:48.000000000 -0700
+++ perl/proto.h	2008-12-15 17:03:17.000000000 -0800
@@ -3305,6 +3305,12 @@
 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)
End of Patch.
[prev in list] [next in list] [prev in thread] [next in thread]