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 <[email protected]> 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 <[email protected]> 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 <[email protected]> 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
