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.

diff --git a/ext/B/t/optree_misc.t b/ext/B/t/optree_misc.t
index f012a50..f327bfc 100644 (file)
--- 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 8ad68ed..80c6401 100644 (file)
--- 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 c7af6a0..811f960 100644 (file)
--- 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 8515800..a6488b0 100644 (file)
--- 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 ae88d83..36eac2b 100644 (file)
--- 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 e277d76..a0e0cbe 100644 (file)
--- 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 604553f..7486808 100644 (file)
--- 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";