diff options
author | Dave Mitchell <davem@fdisolutions.com> | 2008-12-16 01:03:17 +0000 |
---|---|---|
committer | Dave Mitchell <davem@fdisolutions.com> | 2008-12-16 01:03:17 +0000 |
commit | c461bd4fb19684925ca9b57ae9d3c97c6b48bf51 (patch) | |
tree | abe1f43c068a12209924a15824f28aa915b2d139 | |
parent | f1fd152fe26ffcd38ad572e98384968309dc4e6a (diff) | |
download | perl-c461bd4fb19684925ca9b57ae9d3c97c6b48bf51.tar.gz |
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..)
-rw-r--r-- | embed.fnc | 1 | ||||
-rw-r--r-- | embed.h | 2 | ||||
-rw-r--r-- | ext/B/B/Deparse.pm | 6 | ||||
-rw-r--r-- | ext/B/t/deparse.t | 77 | ||||
-rw-r--r-- | op.c | 77 | ||||
-rw-r--r-- | pod/perlapi.pod | 3 | ||||
-rw-r--r-- | proto.h | 6 |
7 files changed, 156 insertions, 16 deletions
@@ -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 @@ -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(); } @@ -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) @@ -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) |