In perl.git, the branch blead has been updated
<http://perl5.git.perl.org/perl.git/commitdiff/25f3319bf6686f1a93fcce9f236055c69200c9ea?hp=d819dc506b9fbd0d9bb316e42ca5bbefdd5f1d77>
- Log -----------------------------------------------------------------
commit 25f3319bf6686f1a93fcce9f236055c69200c9ea
Author: David Mitchell <da...@iabyn.com>
Date: Mon Aug 7 16:58:11 2017 +0100
fix index(...) == -1 type optimisations
RT #131851
It was incorrectly optimising some permutations of comparison op and 0/-1
which shouldn't have been, such as
0 < index(...);
-----------------------------------------------------------------------
Summary of changes:
op.c | 54 ++++++++++++++++++++++++++++++++---------------
t/op/index.t | 44 ++++++++++++++++++++++++++++----------
t/perf/opcount.t | 64 +++++++++++++++++++++++++++++---------------------------
3 files changed, 103 insertions(+), 59 deletions(-)
diff --git a/op.c b/op.c
index 53a6cfe778..99c4db8e11 100644
--- a/op.c
+++ b/op.c
@@ -9688,8 +9688,11 @@ Perl_ck_cmp(pTHX_ OP *o)
{
bool is_eq;
bool neg;
+ bool reverse;
+ bool iv0;
OP *indexop, *constop, *start;
SV *sv;
+ IV iv;
PERL_ARGS_ASSERT_CK_CMP;
@@ -9718,6 +9721,8 @@ Perl_ck_cmp(pTHX_ OP *o)
* (r)index/BOOL(,NEG)
*/
+ reverse = FALSE;
+
indexop = cUNOPo->op_first;
constop = OpSIBLING(indexop);
start = NULL;
@@ -9725,6 +9730,7 @@ Perl_ck_cmp(pTHX_ OP *o)
constop = indexop;
indexop = OpSIBLING(constop);
start = constop;
+ reverse = TRUE;
}
if (indexop->op_type != OP_INDEX && indexop->op_type != OP_RINDEX)
@@ -9741,28 +9747,42 @@ Perl_ck_cmp(pTHX_ OP *o)
if (!(sv && SvIOK_notUV(sv)))
return o;
- neg = FALSE;
+ iv = SvIVX(sv);
+ if (iv != -1 && iv != 0)
+ return o;
+ iv0 = (iv == 0);
- if (SvIVX(sv) == -1) {
- if ( o->op_type == OP_EQ || o->op_type == OP_I_EQ
- || o->op_type == OP_LE || o->op_type == OP_I_LE
- )
- neg = TRUE;
- else
- if (!( o->op_type == OP_NE || o->op_type == OP_I_NE
- || o->op_type == OP_GT || o->op_type == OP_I_GT)
- )
+ if (o->op_type == OP_LT || o->op_type == OP_I_LT) {
+ if (!(iv0 ^ reverse))
return o;
+ neg = iv0;
}
- else if (SvIVX(sv) == 0) {
- if (o->op_type == OP_LT || o->op_type == OP_I_LT)
- neg = TRUE;
- else
- if (!(o->op_type == OP_GE || o->op_type == OP_I_GE))
+ else if (o->op_type == OP_LE || o->op_type == OP_I_LE) {
+ if (iv0 ^ reverse)
return o;
+ neg = !iv0;
+ }
+ else if (o->op_type == OP_GE || o->op_type == OP_I_GE) {
+ if (!(iv0 ^ reverse))
+ return o;
+ neg = !iv0;
+ }
+ else if (o->op_type == OP_GT || o->op_type == OP_I_GT) {
+ if (iv0 ^ reverse)
+ return o;
+ neg = iv0;
+ }
+ else if (o->op_type == OP_EQ || o->op_type == OP_I_EQ) {
+ if (iv0)
+ return o;
+ neg = TRUE;
+ }
+ else {
+ assert(o->op_type == OP_NE || o->op_type == OP_I_NE);
+ if (iv0)
+ return o;
+ neg = FALSE;
}
- else
- return o;
indexop->op_flags &= ~OPf_PARENS;
indexop->op_flags |= (o->op_flags & OPf_PARENS);
diff --git a/t/op/index.t b/t/op/index.t
index f02f524b49..a70066606b 100644
--- a/t/op/index.t
+++ b/t/op/index.t
@@ -8,7 +8,7 @@ BEGIN {
}
use strict;
-plan( tests => 268 );
+plan( tests => 412 );
run_tests() unless caller;
@@ -260,21 +260,43 @@ is index($substr, 'a'), 1, 'index reply reflects
characters not octets';
# op_eq, op_const optimised away in (index() == -1) and variants
for my $test (
- # op const match
- [ '<=', -1, 0 ],
- [ '==', -1, 0 ],
- [ '!=', -1, 1 ],
- [ '>', -1, 1 ],
- [ '<', 0, 0 ],
- [ '>=', 0, 1 ],
+ # expect:
+ # F: always false regardless of the expression
+ # T: always true regardless of the expression
+ # f: expect false if the string is found
+ # t: expect true if the string is found
+ #
+ # op const expect
+ [ '<', -1, 'F' ],
+ [ '<', 0, 'f' ],
+
+ [ '<=', -1, 'f' ],
+ [ '<=', 0, 'f' ],
+
+ [ '==', -1, 'f' ],
+ [ '==', 0, 'F' ],
+
+ [ '!=', -1, 't' ],
+ [ '!=', 0, 'T' ],
+
+ [ '>=', -1, 'T' ],
+ [ '>=', 0, 't' ],
+
+ [ '>', -1, 't' ],
+ [ '>', 0, 't' ],
) {
- my ($op, $const, $match) = @$test;
+ my ($op, $const, $expect0) = @$test;
my $s = "abcde";
my $r;
- for my $substr ("a", "z") {
- my $expect = !(($substr eq "a") xor $match);
+ for my $substr ("e", "z") {
+ my $expect =
+ $expect0 eq 'T' ? 1 == 1 :
+ $expect0 eq 'F' ? 0 == 1 :
+ $expect0 eq 't' ? ($substr eq "e") :
+ ($substr ne "e");
+
for my $rindex ("", "r") {
for my $reverse (0, 1) {
my $rop = $op;
diff --git a/t/perf/opcount.t b/t/perf/opcount.t
index 414fa8c61b..0ff4b7246c 100644
--- a/t/perf/opcount.t
+++ b/t/perf/opcount.t
@@ -362,38 +362,40 @@ test_opcount(0, 'barewords can be constant-folded',
my ($x, $y, $z);
for my $assign (0, 1) {
for my $index ('index($x,$y)', 'rindex($x,$y)') {
- for my $cmp_ops (
- [ '<=', -1, ],
- [ '==', -1, ],
- [ '!=', -1, ],
- [ '>', -1, ],
- [ '<', 0, ],
- [ '>=', 0, ],
+ for my $fmt (
+ "%s <= -1",
+ "%s == -1",
+ "%s != -1",
+ "%s > -1",
+
+ "%s < 0",
+ "%s >= 0",
+
+ "-1 < %s",
+ "-1 == %s",
+ "-1 != %s",
+ "-1 >= %s",
+
+ " 0 <= %s",
+ " 0 > %s",
+
) {
- my ($cmp, $const) = @$cmp_ops;
- for my $swap (0, 1) {
- my $rcmp = $cmp;
- if ($swap) {
- $rcmp =~ s/>/</ or $rcmp =~ s/</>/;
- }
- my $expr = $swap ? "($const $cmp $index)"
- : "($index $cmp $const)";
- $expr = "\$z = ($expr)" if $assign;
-
- test_opcount(0, "optimise away compare,const in $expr",
- eval qq{sub { $expr }},
- {
- lt => 0,
- le => 0,
- eq => 0,
- ne => 0,
- ge => 0,
- gt => 0,
- const => 0,
- sassign => 0,
- padsv => 2.
- });
- }
+ my $expr = sprintf $fmt, $index;
+ $expr = "\$z = ($expr)" if $assign;
+
+ test_opcount(0, "optimise away compare,const in $expr",
+ eval qq{sub { $expr }},
+ {
+ lt => 0,
+ le => 0,
+ eq => 0,
+ ne => 0,
+ ge => 0,
+ gt => 0,
+ const => 0,
+ sassign => 0,
+ padsv => 2.
+ });
}
}
}
--
Perl5 Master Repository
