This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
extend index(...) == -1 optimisation
authorDavid Mitchell <davem@iabyn.com>
Sat, 5 Aug 2017 11:12:42 +0000 (12:12 +0100)
committerDavid Mitchell <davem@iabyn.com>
Sat, 5 Aug 2017 11:12:42 +0000 (12:12 +0100)
Recently I made it so that in expression like index(...) == -1, the
const and eq ops are optimised away and a BOOL flag is set on the index
op.

This commit expands this to various permutations of relational ops too,
such as

    index(...) >=  0
    index(...) <   0
    index(...) <= -1

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

diff --git a/op.c b/op.c
index 9e05afa..53a6cfe 100644 (file)
--- a/op.c
+++ b/op.c
@@ -9687,6 +9687,7 @@ OP *
 Perl_ck_cmp(pTHX_ OP *o)
 {
     bool is_eq;
+    bool neg;
     OP *indexop, *constop, *start;
     SV *sv;
 
@@ -9712,8 +9713,6 @@ Perl_ck_cmp(pTHX_ OP *o)
            Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
                        "$[ used in %s (did you mean $] ?)", OP_DESC(o));
     }
-    if (!is_eq)
-        return o;
 
     /* convert (index(...) == -1) and variations into
      *   (r)index/BOOL(,NEG)
@@ -9731,21 +9730,44 @@ Perl_ck_cmp(pTHX_ OP *o)
     if (indexop->op_type != OP_INDEX && indexop->op_type != OP_RINDEX)
         return o;
 
+    /* ($lex = index(....)) == -1 */
+    if (indexop->op_private & OPpTARGET_MY)
+        return o;
+
     if (constop->op_type != OP_CONST)
         return o;
 
     sv = cSVOPx_sv(constop);
-    if (!(sv && SvIOK_notUV(sv) && SvIVX(sv) == -1))
+    if (!(sv && SvIOK_notUV(sv)))
         return o;
 
-    /* ($lex = index(....)) == -1 */
-    if (indexop->op_private & OPpTARGET_MY)
+    neg = FALSE;
+
+    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)
+        )
+            return o;
+    }
+    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))
+            return o;
+    }
+    else
         return o;
 
     indexop->op_flags &= ~OPf_PARENS;
     indexop->op_flags |= (o->op_flags & OPf_PARENS);
     indexop->op_private |= OPpTRUEBOOL;
-    if (o->op_type == OP_EQ || o->op_type == OP_I_EQ)
+    if (neg)
         indexop->op_private |= OPpINDEX_BOOLNEG;
     /* cut out the index op and free the eq,const ops */
     (void)op_sibling_splice(o, start, 1, NULL);
index 33b0faf..f02f524 100644 (file)
@@ -8,7 +8,7 @@ BEGIN {
 }
 
 use strict;
-plan( tests => 172 );
+plan( tests => 268 );
 
 run_tests() unless caller;
 
@@ -261,8 +261,12 @@ is index($substr, 'a'), 1, 'index reply reflects characters not octets';
 
 for my $test (
       # op  const  match
+    [ '<=',   -1,      0 ],
     [ '==',   -1,      0 ],
     [ '!=',   -1,      1 ],
+    [ '>',    -1,      1 ],
+    [ '<',     0,      0 ],
+    [ '>=',    0,      1 ],
 ) {
     my ($op, $const, $match) = @$test;
 
@@ -273,9 +277,13 @@ for my $test (
         my $expect = !(($substr eq "a") xor $match);
         for my $rindex ("", "r") {
             for my $reverse (0, 1) {
+                my $rop = $op;
+                if ($reverse) {
+                    $rop =~ s/>/</ or  $rop =~ s/</>/;
+                }
                 for my $targmy (0, 1) {
                     my $index = "${rindex}index(\$s, '$substr')";
-                    my $expr = $reverse ? "$const $op $index" : "$index $op $const";
+                    my $expr = $reverse ? "$const $rop $index" : "$index $rop $const";
                     # OPpTARGET_MY variant: the '$r = ' is optimised away too
                     $expr = "\$r = ($expr)" if $targmy;
 
index b81892b..4a7f2b5 100644 (file)
@@ -20,7 +20,7 @@ BEGIN {
 use warnings;
 use strict;
 
-plan 2277;
+plan 2309;
 
 use B ();
 
@@ -351,7 +351,7 @@ test_opcount(0, 'barewords can be constant-folded',
     }
 }
 
-# index(...) == -1 and variants optimise away the EQ and CONST
+# index(...) == -1 and variants optimise away the EQ/NE/etc and CONST
 # and with $lex = (index(...) == -1), the assignment is optimised away
 # too
 
@@ -361,17 +361,34 @@ test_opcount(0, 'barewords can be constant-folded',
 
     my ($x, $y, $z);
     for my $assign (0, 1) {
-        for my $op ('index($x,$y)', 'rindex($x,$y)') {
-            for my $eq ('==', '!=') {
+        for my $index ('index($x,$y)', 'rindex($x,$y)') {
+            for my $cmp_ops (
+                    [ '<=',   -1, ],
+                    [ '==',   -1, ],
+                    [ '!=',   -1, ],
+                    [ '>',    -1, ],
+                    [ '<',     0, ],
+                    [ '>=',    0, ],
+            ) {
+                my ($cmp, $const) = @$cmp_ops;
                 for my $swap (0, 1) {
-                    my $expr = $swap ? "(-1 $eq $op)" : "($op $eq -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 qe,const in $expr",
+                    test_opcount(0, "optimise away compare,const in $expr",
                             eval qq{sub { $expr }},
                             {
+                                le      => 0,
+                                le      => 0,
                                 eq      => 0,
                                 ne      => 0,
+                                ge      => 0,
+                                gt      => 0,
                                 const   => 0,
                                 sassign => 0,
                                 padsv   => 2.