In perl.git, the branch blead has been updated

<http://perl5.git.perl.org/perl.git/commitdiff/400ffcff649c80c7986e4790a425796a250f2d97?hp=02960b52b40b494fa4f6e1be81db5f3459ab91a9>

- Log -----------------------------------------------------------------
commit 400ffcff649c80c7986e4790a425796a250f2d97
Author: David Mitchell <da...@iabyn.com>
Date:   Sat Aug 5 12:12:42 2017 +0100

    extend index(...) == -1 optimisation
    
    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

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

commit c87834ab4b25b86c759f200680f2de176c7c217c
Author: David Mitchell <da...@iabyn.com>
Date:   Sat Aug 5 08:28:22 2017 +0100

    t/op/index.t: automate a block of tests
    
    A block of tests I added recently tests that (index(...) == -1) style
    optimisations don't break things.
    
    Each test was hard-coded. Instead, use some nested loops and eval
    to test all the combinations.
    
    This commit does just the same tests as before, but it will allow us to
    easily add more tests without lots of duplication.

M       t/op/index.t

commit ce5a07d9cd0cec76841f293b1e6146a52b8da8de
Author: David Mitchell <da...@iabyn.com>
Date:   Fri Aug 4 16:40:15 2017 +0100

    merge Perl_ck_cmp() and Perl_ck_eq()
    
    I added ck_eq() recently; it's used for the EQ and NE ops, while ck_cmp()
    is used for LT, GT, LE, GE.
    
    This commit eliminates the ck_eq() function and makes ck_cmp() handle
    EQ/NE too.
    
    This will will make it easier to extend the index() == -1 optimisation
    to handle index() >= 0 etc too.
    
    At the moment there should be no functional differences.

M       embed.h
M       op.c
M       opcode.h
M       proto.h
M       regen/opcodes
-----------------------------------------------------------------------

Summary of changes:
 embed.h          |   1 -
 op.c             | 127 +++++++++++++++++++++++++++++++++----------------------
 opcode.h         |   8 ++--
 proto.h          |   5 ---
 regen/opcodes    |   8 ++--
 t/op/index.t     | 102 ++++++++++++++++++--------------------------
 t/perf/opcount.t |  29 ++++++++++---
 7 files changed, 149 insertions(+), 131 deletions(-)

diff --git a/embed.h b/embed.h
index a41020d6e0..cbef9aa265 100644
--- a/embed.h
+++ b/embed.h
@@ -1171,7 +1171,6 @@
 #define ck_delete(a)           Perl_ck_delete(aTHX_ a)
 #define ck_each(a)             Perl_ck_each(aTHX_ a)
 #define ck_eof(a)              Perl_ck_eof(aTHX_ a)
-#define ck_eq(a)               Perl_ck_eq(aTHX_ a)
 #define ck_eval(a)             Perl_ck_eval(aTHX_ a)
 #define ck_exec(a)             Perl_ck_exec(aTHX_ a)
 #define ck_exists(a)           Perl_ck_exists(aTHX_ a)
diff --git a/op.c b/op.c
index a72dd13b3c..53a6cfe778 100644
--- a/op.c
+++ b/op.c
@@ -9681,11 +9681,24 @@ is_dollar_bracket(pTHX_ const OP * const o)
        && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
 }
 
+/* for lt, gt, le, ge, eq, ne and their i_ variants */
+
 OP *
 Perl_ck_cmp(pTHX_ OP *o)
 {
+    bool is_eq;
+    bool neg;
+    OP *indexop, *constop, *start;
+    SV *sv;
+
     PERL_ARGS_ASSERT_CK_CMP;
-    if (ckWARN(WARN_SYNTAX)) {
+
+    is_eq = (   o->op_type == OP_EQ
+             || o->op_type == OP_NE
+             || o->op_type == OP_I_EQ
+             || o->op_type == OP_I_NE);
+
+    if (!is_eq && ckWARN(WARN_SYNTAX)) {
        const OP *kid = cUNOPo->op_first;
        if (kid &&
             (
@@ -9700,9 +9713,70 @@ Perl_ck_cmp(pTHX_ OP *o)
            Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
                        "$[ used in %s (did you mean $] ?)", OP_DESC(o));
     }
-    return o;
+
+    /* convert (index(...) == -1) and variations into
+     *   (r)index/BOOL(,NEG)
+     */
+
+    indexop = cUNOPo->op_first;
+    constop = OpSIBLING(indexop);
+    start = NULL;
+    if (indexop->op_type == OP_CONST) {
+        constop = indexop;
+        indexop = OpSIBLING(constop);
+        start = constop;
+    }
+
+    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)))
+        return o;
+
+    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 (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);
+    op_free(o);
+
+    return indexop;
 }
 
+
 OP *
 Perl_ck_concat(pTHX_ OP *o)
 {
@@ -9816,55 +9890,6 @@ Perl_ck_eof(pTHX_ OP *o)
 }
 
 
-/* for OP_EQ, OP_NE, OP_I_EQ, OP_I_NE */
-
-OP *
-Perl_ck_eq(pTHX_ OP *o)
-{
-    OP *indexop, *constop, *start;
-    SV *sv;
-    PERL_ARGS_ASSERT_CK_EQ;
-
-    /* convert (index(...) == -1) and variations into
-     *   (r)index/BOOL(,NEG)
-     */
-
-    indexop = cUNOPo->op_first;
-    constop = OpSIBLING(indexop);
-    start = NULL;
-    if (indexop->op_type == OP_CONST) {
-        constop = indexop;
-        indexop = OpSIBLING(constop);
-        start = constop;
-    }
-
-    if (indexop->op_type != OP_INDEX && indexop->op_type != OP_RINDEX)
-        return o;
-
-    if (constop->op_type != OP_CONST)
-        return o;
-
-    sv = cSVOPx_sv(constop);
-    if (!(sv && SvIOK_notUV(sv) && SvIVX(sv) == -1))
-        return o;
-
-    /* ($lex = index(....)) == -1 */
-    if (indexop->op_private & OPpTARGET_MY)
-        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)
-        indexop->op_private |= OPpINDEX_BOOLNEG;
-    /* cut out the index op and free the eq,const ops */
-    (void)op_sibling_splice(o, start, 1, NULL);
-    op_free(o);
-
-    return indexop;
-}
-
-
 OP *
 Perl_ck_eval(pTHX_ OP *o)
 {
diff --git a/opcode.h b/opcode.h
index 23595c14f5..bd8de366e5 100644
--- a/opcode.h
+++ b/opcode.h
@@ -1460,10 +1460,10 @@ EXT Perl_check_t PL_check[] /* or perlvars.h */
        Perl_ck_cmp,            /* i_le */
        Perl_ck_cmp,            /* ge */
        Perl_ck_cmp,            /* i_ge */
-       Perl_ck_eq,             /* eq */
-       Perl_ck_eq,             /* i_eq */
-       Perl_ck_eq,             /* ne */
-       Perl_ck_eq,             /* i_ne */
+       Perl_ck_cmp,            /* eq */
+       Perl_ck_cmp,            /* i_eq */
+       Perl_ck_cmp,            /* ne */
+       Perl_ck_cmp,            /* i_ne */
        Perl_ck_null,           /* ncmp */
        Perl_ck_null,           /* i_ncmp */
        Perl_ck_null,           /* slt */
diff --git a/proto.h b/proto.h
index efbc52ba27..e667d4f255 100644
--- a/proto.h
+++ b/proto.h
@@ -363,11 +363,6 @@ PERL_CALLCONV OP * Perl_ck_eof(pTHX_ OP *o)
 #define PERL_ARGS_ASSERT_CK_EOF        \
        assert(o)
 
-PERL_CALLCONV OP *     Perl_ck_eq(pTHX_ OP *o)
-                       __attribute__warn_unused_result__;
-#define PERL_ARGS_ASSERT_CK_EQ \
-       assert(o)
-
 PERL_CALLCONV OP *     Perl_ck_eval(pTHX_ OP *o)
                        __attribute__warn_unused_result__;
 #define PERL_ARGS_ASSERT_CK_EVAL       \
diff --git a/regen/opcodes b/regen/opcodes
index 137a44f6b9..096c6fe823 100644
--- a/regen/opcodes
+++ b/regen/opcodes
@@ -144,10 +144,10 @@ le                numeric le (<=)         ck_cmp          
Iifs2   S S<
 i_le           integer le (<=)         ck_cmp          ifs2    S S<
 ge             numeric ge (>=)         ck_cmp          Iifs2   S S<
 i_ge           integer ge (>=)         ck_cmp          ifs2    S S<
-eq             numeric eq (==)         ck_eq           Iifs2   S S<
-i_eq           integer eq (==)         ck_eq           ifs2    S S<
-ne             numeric ne (!=)         ck_eq           Iifs2   S S<
-i_ne           integer ne (!=)         ck_eq           ifs2    S S<
+eq             numeric eq (==)         ck_cmp          Iifs2   S S<
+i_eq           integer eq (==)         ck_cmp          ifs2    S S<
+ne             numeric ne (!=)         ck_cmp          Iifs2   S S<
+i_ne           integer ne (!=)         ck_cmp          ifs2    S S<
 ncmp           numeric comparison (<=>)        ck_null         Iifst2  S S<
 i_ncmp         integer comparison (<=>)        ck_null         ifst2   S S<
 
diff --git a/t/op/index.t b/t/op/index.t
index cf165de600..f02f524b49 100644
--- a/t/op/index.t
+++ b/t/op/index.t
@@ -8,7 +8,7 @@ BEGIN {
 }
 
 use strict;
-plan( tests => 172 );
+plan( tests => 268 );
 
 run_tests() unless caller;
 
@@ -259,70 +259,52 @@ is index($substr, 'a'), 1, 'index reply reflects 
characters not octets';
 
 # op_eq, op_const optimised away in (index() == -1) and variants
 
-{
-    my $s = "abxyz";
-    ok(!(index($s,"a") == -1),  "index(a) == -1");
-    ok( (index($s,"a") != -1),  "index(a) != -1");
-    ok( (index($s,"c") == -1),  "index(c) == -1");
-    ok(!(index($s,"c") != -1),  "index(c) != -1");
-
-    ok(!(rindex($s,"a") == -1), "rindex(a) == -1");
-    ok( (rindex($s,"a") != -1), "rindex(a) != -1");
-    ok( (rindex($s,"c") == -1), "rindex(c) == -1");
-    ok(!(rindex($s,"c") != -1), "rindex(c) != -1");
-
-    ok(!(-1 == index($s,"a")),  "-1 == index(a)");
-    ok( (-1 != index($s,"a")),  "-1 != index(a)");
-    ok( (-1 == index($s,"c")),  "-1 == index(c)");
-    ok(!(-1 != index($s,"c")),  "-1 != index(c)");
-
-    ok(!(-1 == rindex($s,"a")), "-1 == rindex(a)");
-    ok( (-1 != rindex($s,"a")), "-1 != rindex(a)");
-    ok( (-1 == rindex($s,"c")), "-1 == rindex(c)");
-    ok(!(-1 != rindex($s,"c")), "-1 != rindex(c)");
-
-    # OPpTARGET_MY variant: the '$r = ' is optimised away too
-
+for my $test (
+      # op  const  match
+    [ '<=',   -1,      0 ],
+    [ '==',   -1,      0 ],
+    [ '!=',   -1,      1 ],
+    [ '>',    -1,      1 ],
+    [ '<',     0,      0 ],
+    [ '>=',    0,      1 ],
+) {
+    my ($op, $const, $match) = @$test;
+
+    my $s = "abcde";
     my $r;
 
-    ok(!($r = index($s,"a") == -1),  "r = index(a) == -1");
-    ok(!$r,                          "r = index(a) == -1 - r value");
-    ok( ($r = index($s,"a") != -1),  "r = index(a) != -1");
-    ok( $r,                          "r = index(a) != -1 - r value");
-    ok( ($r = index($s,"c") == -1),  "r = index(c) == -1");
-    ok( $r,                          "r = index(c) == -1 - r value");
-    ok(!($r = index($s,"c") != -1),  "r = index(c) != -1");
-    ok(!$r,                          "r = index(c) != -1 - r value");
-
-    ok(!($r = rindex($s,"a") == -1), "r = rindex(a) == -1");
-    ok(!$r,                         "r = rindex(a) == -1 - r value");
-    ok( ($r = rindex($s,"a") != -1), "r = rindex(a) != -1");
-    ok( $r,                         "r = rindex(a) != -1 - r value");
-    ok( ($r = rindex($s,"c") == -1), "r = rindex(c) == -1");
-    ok( $r,                         "r = rindex(c) == -1 - r value");
-    ok(!($r = rindex($s,"c") != -1), "r = rindex(c) != -1");
-    ok(!$r,                         "r = rindex(c) != -1 - r value");
-
-    ok(!($r = -1 == index($s,"a")),  "r = -1 == index(a)");
-    ok(!$r,                          "r = -1 == index(a) - r value");
-    ok( ($r = -1 != index($s,"a")),  "r = -1 != index(a)");
-    ok( $r,                          "r = -1 != index(a) - r value");
-    ok( ($r = -1 == index($s,"c")),  "r = -1 == index(c)");
-    ok( $r,                          "r = -1 == index(c) - r value");
-    ok(!($r = -1 != index($s,"c")),  "r = -1 != index(c)");
-    ok(!$r,                          "r = -1 != index(c) - r value");
-
-    ok(!($r = -1 == rindex($s,"a")), "r = -1 == rindex(a)");
-    ok(!$r,                         "r = -1 == rindex(a) - r value");
-    ok( ($r = -1 != rindex($s,"a")), "r = -1 != rindex(a)");
-    ok( $r,                         "r = -1 != rindex(a) - r value");
-    ok( ($r = -1 == rindex($s,"c")), "r = -1 == rindex(c)");
-    ok( $r,                         "r = -1 == rindex(c) - r value");
-    ok(!($r = -1 != rindex($s,"c")), "r = -1 != rindex(c)");
-    ok(!$r,                         "r = -1 != rindex(c) - r value");
+    for my $substr ("a", "z") {
+        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 $rop $index" : "$index $rop 
$const";
+                    # OPpTARGET_MY variant: the '$r = ' is optimised away too
+                    $expr = "\$r = ($expr)" if $targmy;
+
+                    my $got = eval $expr;
+                    die "eval of <$expr> gave: $@\n" if $@ ne "";
+
+                    is !!$got, $expect, $expr;
+                    if ($targmy) {
+                        is !!$r, $expect, "$expr - r value";
+                    }
+                }
+            }
+        }
+    }
+}
 
+{
     # RT #131823
     # index with OPpTARGET_MY shouldn't do the '== -1' optimisation
+    my $s = "abxyz";
+    my $r;
 
     ok(!(($r = index($s,"z")) == -1),  "(r = index(a)) == -1");
     is($r, 4,                          "(r = index(a)) == -1 - r value");
diff --git a/t/perf/opcount.t b/t/perf/opcount.t
index b81892b73e..4a7f2b5a47 100644
--- a/t/perf/opcount.t
+++ b/t/perf/opcount.t
@@ -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.

--
Perl5 Master Repository

Reply via email to