From b024352e692dd231fd32548e325d75b667bff29f Mon Sep 17 00:00:00 2001 From: David Mitchell Date: Sun, 23 Feb 2014 00:53:17 +0000 Subject: [PATCH] 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. --- ext/B/t/optree_misc.t | 14 +++++++------- lib/B/Deparse.pm | 8 ++++++-- lib/B/Deparse.t | 10 ++++++++++ op.c | 2 +- pp_hot.c | 6 +++++- sv.c | 8 ++++---- t/op/array.t | 45 ++++++++++++++++++++++++++++++++++++++++++++- 7 files changed, 77 insertions(+), 16 deletions(-) diff --git a/ext/B/t/optree_misc.t b/ext/B/t/optree_misc.t index f012a50..f327bfc 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 8ad68ed..80c6401 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 c7af6a0..811f960 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 8515800..a6488b0 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 ae88d83..36eac2b 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 e277d76..a0e0cbe 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 604553f..7486808 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"; -- 2.7.4