Change 34358 by [EMAIL PROTECTED] on 2008/09/13 08:44:30
Subject: Re: [5.8] Change 33727 (op.c) breaks constant folding in
"elsif"
From: Vincent Pit <[EMAIL PROTECTED]>
Date: Sat, 13 Sep 2008 01:13:30 +0200
Message-ID: <[EMAIL PROTECTED]>
Affected files ...
... //depot/perl/embed.fnc#619 edit
... //depot/perl/embed.h#763 edit
... //depot/perl/ext/B/t/deparse.t#41 edit
... //depot/perl/op.c#1009 edit
... //depot/perl/pod/perlapi.pod#333 edit
... //depot/perl/proto.h#953 edit
Differences ...
==== //depot/perl/embed.fnc#619 (text) ====
Index: perl/embed.fnc
--- perl/embed.fnc#618~34354~ 2008-09-11 17:19:51.000000000 -0700
+++ perl/embed.fnc 2008-09-13 01:44:30.000000000 -0700
@@ -1271,6 +1271,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/perl/embed.h#763 (text+w) ====
Index: perl/embed.h
--- perl/embed.h#762~34349~ 2008-09-11 14:12:51.000000000 -0700
+++ perl/embed.h 2008-09-13 01:44:30.000000000 -0700
@@ -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)
==== //depot/perl/ext/B/t/deparse.t#41 (text) ====
Index: perl/ext/B/t/deparse.t
--- perl/ext/B/t/deparse.t#40~34322~ 2008-09-08 13:37:54.000000000 -0700
+++ perl/ext/B/t/deparse.t 2008-09-13 01:44:30.000000000 -0700
@@ -27,7 +27,7 @@
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 @@
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() 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(); }
==== //depot/perl/op.c#1009 (text) ====
Index: perl/op.c
--- perl/op.c#1008~34322~ 2008-09-08 13:37:54.000000000 -0700
+++ perl/op.c 2008-09-13 01:44:30.000000000 -0700
@@ -4450,17 +4450,64 @@
}
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 @@
}
}
}
- 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 @@
LOGOP *logop;
OP *start;
OP *o;
+ OP *cstop;
PERL_ARGS_ASSERT_NEWCONDOP;
@@ -4619,14 +4668,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/perl/pod/perlapi.pod#333 (text+w) ====
Index: perl/pod/perlapi.pod
--- perl/pod/perlapi.pod#332~34201~ 2008-08-11 07:41:47.000000000 -0700
+++ perl/pod/perlapi.pod 2008-09-13 01:44:30.000000000 -0700
@@ -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 *av)
==== //depot/perl/proto.h#953 (text+w) ====
Index: perl/proto.h
--- perl/proto.h#952~34354~ 2008-09-11 17:19:51.000000000 -0700
+++ perl/proto.h 2008-09-13 01:44:30.000000000 -0700
@@ -4616,6 +4616,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.
