make OP_AELEMFAST work with negative indices

Use aelemfast for literal index array access where the index is in the
range -128..127, rather than 0..255.

You'd expect something like $a[-1] or $a[-2] to be a lot more common than
$a[100] say. In fact a quick CPAN grep shows 66 distributions
matching /\$\w+\[\d{3,}\]/, but "at least" 1000 matching /\$\w+\[\-\d\]/.
And most of the former appear to be table initialisations.

7 files changed, 77 insertions, 16 deletions

diff --git a/ext/B/t/optree_misc.t b/ext/B/t/optree_misc.t
index f012a50c85..f327bfc036 100644
--- a/ext/B/t/optree_misc.t
+++ b/ext/B/t/optree_misc.t
@@ -24,7 +24,7 @@ skip "no perlio in this build", 4 unless $Config::Config{useperlio};
 # All this is much simpler, now that aelemfast_lex has been broken out from
 # aelemfast
 checkOptree ( name	=> 'OP_AELEMFAST opclass',
-	      code	=> sub { my @x; our @y; $x[0] + $y[0]},
+	      code	=> sub { my @x; our @y; $x[127] + $y[-128]},
 	      strip_open_hints => 1,
 	      expect	=> <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 # a  <1> leavesub[1 ref] K/REFC,1 ->(end)
@@ -37,12 +37,12 @@ checkOptree ( name	=> 'OP_AELEMFAST opclass',
 # 6        <;> nextstate(main 636 optree_misc.t:25) v:>,<,%,{ ->7
 # 9        <2> add[t6] sK/2 ->a
 # -           <1> ex-aelem sK/2 ->8
-# 7              <0> aelemfast_lex[@x:634,636] sR ->8
+# 7              <0> aelemfast_lex[@x:634,636] sR/127 ->8
 # -              <0> ex-const s ->-
 # -           <1> ex-aelem sK/2 ->9
 # -              <1> ex-rv2av sKR/1 ->-
-# 8                 <#> aelemfast[*y] s ->9
-# -              <0> ex-const s ->-
+# 8                 <#> aelemfast[*y] s/128 ->9
+# -              <0> ex-const s/FOLD ->-
 EOT_EOT
 # a  <1> leavesub[1 ref] K/REFC,1 ->(end)
 # -     <@> lineseq KP ->a
@@ -54,12 +54,12 @@ EOT_EOT
 # 6        <;> nextstate(main 636 optree_misc.t:27) v:>,<,%,{ ->7
 # 9        <2> add[t4] sK/2 ->a
 # -           <1> ex-aelem sK/2 ->8
-# 7              <0> aelemfast_lex[@x:634,636] sR ->8
+# 7              <0> aelemfast_lex[@x:634,636] sR/127 ->8
 # -              <0> ex-const s ->-
 # -           <1> ex-aelem sK/2 ->9
 # -              <1> ex-rv2av sKR/1 ->-
-# 8                 <$> aelemfast(*y) s ->9
-# -              <0> ex-const s ->-
+# 8                 <$> aelemfast(*y) s/128 ->9
+# -              <0> ex-const s/FOLD ->-
 EONT_EONT
 
 checkOptree ( name	=> 'PMOP children',
diff --git a/lib/B/Deparse.pm b/lib/B/Deparse.pm
index 8ad68ed069..80c6401844 100644
--- a/lib/B/Deparse.pm
+++ b/lib/B/Deparse.pm
@@ -3332,7 +3332,9 @@ sub pp_aelemfast_lex {
     my($op, $cx) = @_;
     my $name = $self->padname($op->targ);
     $name =~ s/^@/\$/;
-    return $name . "[" .  ($op->private + $self->{'arybase'}) . "]";
+    my $i = $op->private;
+    $i -= 256 if $i > 127;
+    return $name . "[" .  ($i + $self->{'arybase'}) . "]";
 }
 
 sub pp_aelemfast {
@@ -3344,7 +3346,9 @@ sub pp_aelemfast {
     my $gv = $self->gv_or_padgv($op);
     my($name,$quoted) = $self->stash_variable_name('@',$gv);
     $name = $quoted ? "$name->" : '$' . $name;
-    return $name . "[" .  ($op->private + $self->{'arybase'}) . "]";
+    my $i = $op->private;
+    $i -= 256 if $i > 127;
+    return $name . "[" .  ($i + $self->{'arybase'}) . "]";
 }
 
 sub rv2x {
diff --git a/lib/B/Deparse.t b/lib/B/Deparse.t
index c7af6a0bf6..811f9602e5 100644
--- a/lib/B/Deparse.t
+++ b/lib/B/Deparse.t
@@ -1437,3 +1437,13 @@ sub _121050empty( ) {}
 >>>>
 _121050 $a, $b;
 () = _121050empty + 1;
+####
+# ensure aelemfast works in the range -128..127 and that there's no
+# funky edge cases
+my $x;
+no strict 'vars';
+$x = $a[-256] + $a[-255] + $a[-129] + $a[-128] + $a[-127] + $a[-1] + $a[0];
+$x = $a[1] + $a[126] + $a[127] + $a[128] + $a[255] + $a[256];
+my @b;
+$x = $b[-256] + $b[-255] + $b[-129] + $b[-128] + $b[-127] + $b[-1] + $b[0];
+$x = $b[1] + $b[126] + $b[127] + $b[128] + $b[255] + $b[256];
diff --git a/op.c b/op.c
index 85158006b7..a6488b065a 100644
--- a/op.c
+++ b/op.c
@@ -11705,7 +11705,7 @@ Perl_rpeep(pTHX_ OP *o)
 		    pop->op_next->op_type == OP_AELEM &&
 		    !(pop->op_next->op_private &
 		      (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
-		    (i = SvIV(((SVOP*)pop)->op_sv)) <= 255 && i >= 0)
+		    (i = SvIV(((SVOP*)pop)->op_sv)) >= -128 && i <= 127)
 		{
 		    GV *gv;
 		    if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
diff --git a/pp_hot.c b/pp_hot.c
index ae88d83f48..36eac2b80b 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -727,8 +727,12 @@ PP(pp_aelemfast)
     AV * const av = PL_op->op_type == OP_AELEMFAST_LEX
 	? MUTABLE_AV(PAD_SV(PL_op->op_targ)) : GvAVn(cGVOP_gv);
     const U32 lval = PL_op->op_flags & OPf_MOD;
-    SV** const svp = av_fetch(av, PL_op->op_private, lval);
+    SV** const svp = av_fetch(av, (I8)PL_op->op_private, lval);
     SV *sv = (svp ? *svp : &PL_sv_undef);
+
+    if (UNLIKELY(!svp && lval))
+        DIE(aTHX_ PL_no_aelem, (int)(I8)PL_op->op_private);
+
     EXTEND(SP, 1);
     if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
 	mg_get(sv);
diff --git a/sv.c b/sv.c
index e277d76a78..a0e0cbe4b5 100644
--- a/sv.c
+++ b/sv.c
@@ -14516,12 +14516,12 @@ S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv,
 	    AV *av = MUTABLE_AV(PAD_SV(obase->op_targ));
 	    if (!av || SvRMAGICAL(av))
 		break;
-	    svp = av_fetch(av, (I32)obase->op_private, FALSE);
+	    svp = av_fetch(av, (I8)obase->op_private, FALSE);
 	    if (!svp || *svp != uninit_sv)
 		break;
 	}
 	return varname(NULL, '$', obase->op_targ,
-		       NULL, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
+		       NULL, (I8)obase->op_private, FUV_SUBSCRIPT_ARRAY);
     case OP_AELEMFAST:
 	{
 	    gv = cGVOPx_gv(obase);
@@ -14532,12 +14532,12 @@ S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv,
 		AV *const av = GvAV(gv);
 		if (!av || SvRMAGICAL(av))
 		    break;
-		svp = av_fetch(av, (I32)obase->op_private, FALSE);
+		svp = av_fetch(av, (I8)obase->op_private, FALSE);
 		if (!svp || *svp != uninit_sv)
 		    break;
 	    }
 	    return varname(gv, '$', 0,
-		    NULL, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
+		    NULL, (I8)obase->op_private, FUV_SUBSCRIPT_ARRAY);
 	}
 	break;
 
diff --git a/t/op/array.t b/t/op/array.t
index 604553ff4d..74868088e4 100644
--- a/t/op/array.t
+++ b/t/op/array.t
@@ -6,7 +6,7 @@ BEGIN {
     require 'test.pl';
 }
 
-plan (137);
+plan (171);
 
 #
 # @foo, @bar, and @ary are also used from tie-stdarray after tie-ing them
@@ -502,4 +502,47 @@ $$_ = \1;
 "$$_";
 pass "no assertion failure after assigning ref to arylen when ary is gone";
 
+
+{
+    # Test aelemfast for both +ve and -ve indices, both lex and package vars.
+    # Make especially careful that we don't have any edge cases around
+    # fitting an I8 into a U8.
+    my @a = (0..299);
+    is($a[-256], 300-256, 'lex -256');
+    is($a[-255], 300-255, 'lex -255');
+    is($a[-254], 300-254, 'lex -254');
+    is($a[-129], 300-129, 'lex -129');
+    is($a[-128], 300-128, 'lex -128');
+    is($a[-127], 300-127, 'lex -127');
+    is($a[-126], 300-126, 'lex -126');
+    is($a[  -1], 300-  1, 'lex   -1');
+    is($a[   0],       0, 'lex    0');
+    is($a[   1],       1, 'lex    1');
+    is($a[ 126],     126, 'lex  126');
+    is($a[ 127],     127, 'lex  127');
+    is($a[ 128],     128, 'lex  128');
+    is($a[ 129],     129, 'lex  129');
+    is($a[ 254],     254, 'lex  254');
+    is($a[ 255],     255, 'lex  255');
+    is($a[ 256],     256, 'lex  256');
+    @aelem =(0..299);
+    is($aelem[-256], 300-256, 'pkg -256');
+    is($aelem[-255], 300-255, 'pkg -255');
+    is($aelem[-254], 300-254, 'pkg -254');
+    is($aelem[-129], 300-129, 'pkg -129');
+    is($aelem[-128], 300-128, 'pkg -128');
+    is($aelem[-127], 300-127, 'pkg -127');
+    is($aelem[-126], 300-126, 'pkg -126');
+    is($aelem[  -1], 300-  1, 'pkg   -1');
+    is($aelem[   0],       0, 'pkg    0');
+    is($aelem[   1],       1, 'pkg    1');
+    is($aelem[ 126],     126, 'pkg  126');
+    is($aelem[ 127],     127, 'pkg  127');
+    is($aelem[ 128],     128, 'pkg  128');
+    is($aelem[ 129],     129, 'pkg  129');
+    is($aelem[ 254],     254, 'pkg  254');
+    is($aelem[ 255],     255, 'pkg  255');
+    is($aelem[ 256],     256, 'pkg  256');
+}
+
 "We're included by lib/Tie/Array/std.t so we need to return something true";