This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
fix index(...) == -1 type optimisations
authorDavid Mitchell <davem@iabyn.com>
Mon, 7 Aug 2017 15:58:11 +0000 (16:58 +0100)
committerDavid Mitchell <davem@iabyn.com>
Mon, 7 Aug 2017 16:11:44 +0000 (17:11 +0100)
RT #131851

It was incorrectly optimising some permutations of comparison op and 0/-1
which shouldn't have been, such as

    0 < index(...);

op.c
t/op/index.t
t/perf/opcount.t

diff --git a/op.c b/op.c
index 53a6cfe..99c4db8 100644 (file)
--- 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);
index f02f524..a700666 100644 (file)
@@ -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;
index 414fa8c..0ff4b72 100644 (file)
@@ -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.
+                        });
             }
         }
     }