From: Vincent Pit 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 -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)