summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--MANIFEST1
-rw-r--r--Porting/deparse-skips.txt2
-rw-r--r--dist/Safe/t/safeops.t3
-rw-r--r--dump.c193
-rw-r--r--embed.fnc4
-rw-r--r--embed.h3
-rw-r--r--embedvar.h1
-rw-r--r--ext/B/B.xs100
-rw-r--r--ext/B/B/Concise.pm2
-rw-r--r--ext/B/t/OptreeCheck.pm4
-rw-r--r--ext/B/t/concise-xs.t30
-rw-r--r--ext/B/t/f_sort.t52
-rw-r--r--ext/Opcode/Opcode.pm2
-rw-r--r--intrpvar.h3
-rw-r--r--lib/B/Deparse.pm200
-rw-r--r--lib/B/Deparse.t78
-rw-r--r--lib/B/Op_private.pm23
-rw-r--r--op.c891
-rw-r--r--op.h56
-rw-r--r--opcode.h262
-rw-r--r--opnames.h485
-rw-r--r--perl.h7
-rw-r--r--pp.c7
-rw-r--r--pp_hot.c436
-rw-r--r--pp_proto.h1
-rw-r--r--proto.h12
-rw-r--r--regen/op_private16
-rw-r--r--regen/opcodes4
-rw-r--r--sv.c226
-rw-r--r--t/lib/warnings/9uninit77
-rw-r--r--t/op/multideref.t187
-rw-r--r--t/op/svleak.t16
-rw-r--r--t/perf/benchmarks168
-rw-r--r--t/perf/opcount.t151
34 files changed, 3231 insertions, 472 deletions
diff --git a/MANIFEST b/MANIFEST
index 4775d8ee96..7d04e1f4a9 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -5269,6 +5269,7 @@ t/op/magic-27839.t Test for #27839, skipped for minitest
t/op/magic.t See if magic variables work
t/op/method.t See if method calls work
t/op/mkdir.t See if mkdir works
+t/op/multideref.t See if "$a[0]{foo}[$i]{$k}" etc works
t/op/mydef.t See if "my $_" works
t/op/my_stash.t See if my Package works
t/op/my.t See if lexical scoping works
diff --git a/Porting/deparse-skips.txt b/Porting/deparse-skips.txt
index c7aaf7e527..526bdc2ed4 100644
--- a/Porting/deparse-skips.txt
+++ b/Porting/deparse-skips.txt
@@ -434,7 +434,6 @@ op/closure.t
op/concat2.t
op/coreamp.t
op/crypt.t
-op/die.t
op/do.t
op/each.t
op/eval.t
@@ -455,7 +454,6 @@ op/lexsub.t
op/local.t
op/magic.t
op/method.t
-op/my.t
op/mydef.t
op/not.t
op/ord.t
diff --git a/dist/Safe/t/safeops.t b/dist/Safe/t/safeops.t
index cb37445c1d..2133bde16b 100644
--- a/dist/Safe/t/safeops.t
+++ b/dist/Safe/t/safeops.t
@@ -56,7 +56,7 @@ foreach (@op) {
if ($_->[2]) {
testop @$_;
} else {
- local our $TODO = "No test yet for $_->[1]";
+ local our $TODO = "No test yet for $_->[0] ($_->[1])";
fail();
}
}
@@ -235,6 +235,7 @@ exists exists $h{Key}
rv2hv %h
helem $h{kEy}
hslice @h{kEy}
+multideref SKIP (set by optimizer)
unpack unpack
pack pack
split split /foo/
diff --git a/dump.c b/dump.c
index daeedf493f..9abfbb12bc 100644
--- a/dump.c
+++ b/dump.c
@@ -952,6 +952,18 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
}
#endif
break;
+
+ case OP_MULTIDEREF:
+ {
+ UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
+ UV i, count = items[-1].uv;
+
+ Perl_dump_indent(aTHX_ level, file, "ARGS = \n");
+ for (i=0; i < count; i++)
+ Perl_dump_indent(aTHX_ level+1, file, "%"UVuf" => 0x%"UVxf"\n",
+ i, items[i].uv);
+ }
+
case OP_CONST:
case OP_HINTSEVAL:
case OP_METHOD_NAMED:
@@ -2254,6 +2266,181 @@ S_deb_padvar(pTHX_ PADOFFSET off, int n, bool paren)
}
+/* append to the out SV, the name of the lexical at offset off in the CV
+ * cv */
+
+void
+S_append_padvar(pTHX_ PADOFFSET off, CV *cv, SV *out, int n,
+ bool paren, bool is_scalar)
+{
+ PADNAME *sv;
+ PADNAMELIST *namepad = NULL;
+ int i;
+
+ if (cv) {
+ PADLIST * const padlist = CvPADLIST(cv);
+ namepad = PadlistNAMES(padlist);
+ }
+
+ if (paren)
+ sv_catpvs_nomg(out, "(");
+ for (i = 0; i < n; i++) {
+ if (namepad && (sv = padnamelist_fetch(namepad, off + i)))
+ {
+ STRLEN cur = SvCUR(out);
+ Perl_sv_catpvf(aTHX_ out, "[%"PNf, PNfARG(sv));
+ if (is_scalar)
+ SvPVX(out)[cur] = '$';
+ }
+ else
+ Perl_sv_catpvf(aTHX_ out, "[%"UVuf"]", (UV)(off+i));
+ if (i < n - 1)
+ sv_catpvs_nomg(out, ",");
+ }
+ if (paren)
+ sv_catpvs_nomg(out, "(");
+}
+
+
+void
+S_print_gv_name(pTHX_ GV *gv, SV *out, char sigil)
+{
+ SV *sv;
+ if (!gv) {
+ sv_catpvs_nomg(out, "<NULLGV>");
+ return;
+ }
+ sv = newSV(0);
+ gv_fullname4(sv, gv, NULL, FALSE);
+ Perl_sv_catpvf(aTHX_ out, "%c%-p", sigil, sv);
+ SvREFCNT_dec_NN(sv);
+}
+
+#ifdef USE_ITHREADS
+# define ITEM_SV(item) *av_fetch(comppad, (item)->pad_offset, FALSE);
+#else
+# define ITEM_SV(item) UNOP_AUX_item_sv(item)
+#endif
+
+
+/* return a temporary SV containing a stringified representation of
+ * the op_aux field of a UNOP_AUX op, associated with CV cv
+ */
+
+SV*
+Perl_unop_aux_stringify(pTHX_ const OP *o, CV *cv)
+{
+ UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
+ UV actions = items->uv;
+ SV *sv;
+ bool last = 0;
+ bool is_hash = FALSE;
+ int derefs = 0;
+ SV *out = sv_2mortal(newSVpv("",0));
+#ifdef USE_ITHREADS
+ PADLIST * const padlist = CvPADLIST(cv);
+ PAD *comppad = comppad = PadlistARRAY(padlist)[1];
+#endif
+
+ PERL_ARGS_ASSERT_UNOP_AUX_STRINGIFY;
+
+ while (!last) {
+ switch (actions & MDEREF_ACTION_MASK) {
+
+ case MDEREF_reload:
+ actions = (++items)->uv;
+ continue;
+
+ case MDEREF_HV_padhv_helem:
+ is_hash = TRUE;
+ case MDEREF_AV_padav_aelem:
+ derefs = 1;
+ S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
+ goto do_elem;
+
+ case MDEREF_HV_gvhv_helem:
+ is_hash = TRUE;
+ case MDEREF_AV_gvav_aelem:
+ derefs = 1;
+ sv = ITEM_SV(++items);
+ S_print_gv_name(aTHX_ (GV*)sv, out, '$');
+ goto do_elem;
+
+ case MDEREF_HV_gvsv_vivify_rv2hv_helem:
+ is_hash = TRUE;
+ case MDEREF_AV_gvsv_vivify_rv2av_aelem:
+ sv = ITEM_SV(++items);
+ S_print_gv_name(aTHX_ (GV*)sv, out, '$');
+ goto do_vivify_rv2xv_elem;
+
+ case MDEREF_HV_padsv_vivify_rv2hv_helem:
+ is_hash = TRUE;
+ case MDEREF_AV_padsv_vivify_rv2av_aelem:
+ S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
+ goto do_vivify_rv2xv_elem;
+
+ case MDEREF_HV_pop_rv2hv_helem:
+ case MDEREF_HV_vivify_rv2hv_helem:
+ is_hash = TRUE;
+ do_vivify_rv2xv_elem:
+ case MDEREF_AV_pop_rv2av_aelem:
+ case MDEREF_AV_vivify_rv2av_aelem:
+ if (!derefs++)
+ sv_catpvs_nomg(out, "->");
+ do_elem:
+ if ((actions & MDEREF_INDEX_MASK)== MDEREF_INDEX_none) {
+ sv_catpvs_nomg(out, "->");
+ last = 1;
+ break;
+ }
+
+ sv_catpvn_nomg(out, (is_hash ? "{" : "["), 1);
+ switch (actions & MDEREF_INDEX_MASK) {
+ case MDEREF_INDEX_const:
+ if (is_hash) {
+ STRLEN cur;
+ char *s;
+ sv = ITEM_SV(++items);
+ s = SvPV(sv, cur);
+ pv_pretty(out, s, cur, 30,
+ NULL, NULL,
+ (PERL_PV_PRETTY_NOCLEAR
+ |PERL_PV_PRETTY_QUOTE
+ |PERL_PV_PRETTY_ELLIPSES));
+ }
+ else
+ Perl_sv_catpvf(aTHX_ out, "%"IVdf, (++items)->iv);
+ break;
+ case MDEREF_INDEX_padsv:
+ S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
+ break;
+ case MDEREF_INDEX_gvsv:
+ sv = ITEM_SV(++items);
+ S_print_gv_name(aTHX_ (GV*)sv, out, '$');
+ break;
+ }
+ sv_catpvn_nomg(out, (is_hash ? "}" : "]"), 1);
+
+ if (actions & MDEREF_FLAG_last)
+ last = 1;
+ is_hash = FALSE;
+
+ break;
+
+ default:
+ PerlIO_printf(Perl_debug_log, "UNKNOWN(%d)",
+ (int)(actions & MDEREF_ACTION_MASK));
+ last = 1;
+ break;
+
+ } /* switch */
+
+ actions >>= MDEREF_SHIFT;
+ } /* while */
+ return out;
+}
+
+
I32
Perl_debop(pTHX_ const OP *o)
{
@@ -2300,11 +2487,17 @@ Perl_debop(pTHX_ const OP *o)
case OP_PADHV:
S_deb_padvar(aTHX_ o->op_targ, 1, 1);
break;
+
case OP_PADRANGE:
S_deb_padvar(aTHX_ o->op_targ,
o->op_private & OPpPADRANGE_COUNTMASK, 1);
break;
+ case OP_MULTIDEREF:
+ PerlIO_printf(Perl_debug_log, "(%-p)",
+ unop_aux_stringify(o, deb_curcv(cxstack_ix)));
+ break;
+
default:
break;
}
diff --git a/embed.fnc b/embed.fnc
index 26d893d13d..c7b283b9f6 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -330,6 +330,7 @@ ApR |I32 |cxinc
Afp |void |deb |NN const char* pat|...
Ap |void |vdeb |NN const char* pat|NULLOK va_list* args
Ap |void |debprofdump
+EXp |SV* |unop_aux_stringify |NN const OP* o|NN CV *cv
Ap |I32 |debop |NN const OP* o
Ap |I32 |debstack
Ap |I32 |debstackptrs
@@ -2651,7 +2652,8 @@ s |SV * |find_hash_subscript|NULLOK const HV *const hv \
s |I32 |find_array_subscript|NULLOK const AV *const av \
|NN const SV *const val
sMd |SV* |find_uninit_var|NULLOK const OP *const obase \
- |NULLOK const SV *const uninit_sv|bool top
+ |NULLOK const SV *const uninit_sv|bool match \
+ |NN const char **desc_p
#endif
Ap |GV* |gv_fetchpvn_flags|NN const char* name|STRLEN len|I32 flags|const svtype sv_type
diff --git a/embed.h b/embed.h
index 7108b3e331..02d25be1cb 100644
--- a/embed.h
+++ b/embed.h
@@ -911,6 +911,7 @@
#define reg_temp_copy(a,b) Perl_reg_temp_copy(aTHX_ a,b)
#define report_uninit(a) Perl_report_uninit(aTHX_ a)
#define sv_magicext_mglob(a) Perl_sv_magicext_mglob(aTHX_ a)
+#define unop_aux_stringify(a,b) Perl_unop_aux_stringify(aTHX_ a,b)
#define validate_proto(a,b,c) Perl_validate_proto(aTHX_ a,b,c)
#define vivify_defelem(a) Perl_vivify_defelem(aTHX_ a)
#define yylex() Perl_yylex(aTHX)
@@ -1662,7 +1663,7 @@
#define expect_number(a) S_expect_number(aTHX_ a)
#define find_array_subscript(a,b) S_find_array_subscript(aTHX_ a,b)
#define find_hash_subscript(a,b) S_find_hash_subscript(aTHX_ a,b)
-#define find_uninit_var(a,b,c) S_find_uninit_var(aTHX_ a,b,c)
+#define find_uninit_var(a,b,c,d) S_find_uninit_var(aTHX_ a,b,c,d)
#define glob_2number(a) S_glob_2number(aTHX_ a)
#define glob_assign_glob(a,b,c) S_glob_assign_glob(aTHX_ a,b,c)
#define more_sv() S_more_sv(aTHX)
diff --git a/embedvar.h b/embedvar.h
index 9e4a910a57..32a8b9b327 100644
--- a/embedvar.h
+++ b/embedvar.h
@@ -205,6 +205,7 @@
#define PL_minus_p (vTHX->Iminus_p)
#define PL_modcount (vTHX->Imodcount)
#define PL_modglobal (vTHX->Imodglobal)
+#define PL_multideref_pc (vTHX->Imultideref_pc)
#define PL_my_cxt_keys (vTHX->Imy_cxt_keys)
#define PL_my_cxt_list (vTHX->Imy_cxt_list)
#define PL_my_cxt_size (vTHX->Imy_cxt_size)
diff --git a/ext/B/B.xs b/ext/B/B.xs
index 937ef2c43f..14bd7163b7 100644
--- a/ext/B/B.xs
+++ b/ext/B/B.xs
@@ -8,6 +8,7 @@
*/
#define PERL_NO_GET_CONTEXT
+#define PERL_EXT
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
@@ -1342,6 +1343,9 @@ string(o, cv)
SV *ret;
PPCODE:
switch (o->op_type) {
+ case OP_MULTIDEREF:
+ ret = unop_aux_stringify(o, cv);
+ break;
default:
ret = sv_2mortal(newSVpvn("", 0));
}
@@ -1359,9 +1363,105 @@ aux_list(o, cv)
B::OP o
B::CV cv
PPCODE:
+ PERL_UNUSED_VAR(cv); /* not needed on unthreaded builds */
switch (o->op_type) {
default:
XSRETURN(0); /* by default, an empty list */
+
+ case OP_MULTIDEREF:
+#ifdef USE_ITHREADS
+# define ITEM_SV(item) *av_fetch(comppad, (item)->pad_offset, FALSE);
+#else
+# define ITEM_SV(item) UNOP_AUX_item_sv(item)
+#endif
+ {
+ UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
+ UV actions = items->uv;
+ UV len = items[-1].uv;
+ SV *sv;
+ bool last = 0;
+ bool is_hash = FALSE;
+#ifdef USE_ITHREADS
+ PADLIST * const padlist = CvPADLIST(cv);
+ PAD *comppad = comppad = PadlistARRAY(padlist)[1];
+#endif
+
+ EXTEND(SP, len);
+ PUSHs(sv_2mortal(newSViv(actions)));
+
+ while (!last) {
+ switch (actions & MDEREF_ACTION_MASK) {
+
+ case MDEREF_reload:
+ actions = (++items)->uv;
+ PUSHs(sv_2mortal(newSVuv(actions)));
+ continue;
+
+ case MDEREF_HV_padhv_helem:
+ is_hash = TRUE;
+ case MDEREF_AV_padav_aelem:
+ PUSHs(sv_2mortal(newSVuv((++items)->pad_offset)));
+ goto do_elem;
+
+ case MDEREF_HV_gvhv_helem:
+ is_hash = TRUE;
+ case MDEREF_AV_gvav_aelem:
+ sv = ITEM_SV(++items);
+ PUSHs(make_sv_object(aTHX_ sv));
+ goto do_elem;
+
+ case MDEREF_HV_gvsv_vivify_rv2hv_helem:
+ is_hash = TRUE;
+ case MDEREF_AV_gvsv_vivify_rv2av_aelem:
+ sv = ITEM_SV(++items);
+ PUSHs(make_sv_object(aTHX_ sv));
+ goto do_vivify_rv2xv_elem;
+
+ case MDEREF_HV_padsv_vivify_rv2hv_helem:
+ is_hash = TRUE;
+ case MDEREF_AV_padsv_vivify_rv2av_aelem:
+ PUSHs(sv_2mortal(newSVuv((++items)->pad_offset)));
+ goto do_vivify_rv2xv_elem;
+
+ case MDEREF_HV_pop_rv2hv_helem:
+ case MDEREF_HV_vivify_rv2hv_helem:
+ is_hash = TRUE;
+ do_vivify_rv2xv_elem:
+ case MDEREF_AV_pop_rv2av_aelem:
+ case MDEREF_AV_vivify_rv2av_aelem:
+ do_elem:
+ switch (actions & MDEREF_INDEX_MASK) {
+ case MDEREF_INDEX_none:
+ last = 1;
+ break;
+ case MDEREF_INDEX_const:
+ if (is_hash) {
+ sv = ITEM_SV(++items);
+ PUSHs(make_sv_object(aTHX_ sv));
+ }
+ else
+ PUSHs(sv_2mortal(newSViv((++items)->iv)));
+ break;
+ case MDEREF_INDEX_padsv:
+ PUSHs(sv_2mortal(newSVuv((++items)->pad_offset)));
+ break;
+ case MDEREF_INDEX_gvsv:
+ sv = ITEM_SV(++items);
+ PUSHs(make_sv_object(aTHX_ sv));
+ break;
+ }
+ if (actions & MDEREF_FLAG_last)
+ last = 1;
+ is_hash = FALSE;
+
+ break;
+ } /* switch */
+
+ actions >>= MDEREF_SHIFT;
+ } /* while */
+ XSRETURN(len);
+
+ } /* OP_MULTIDEREF */
} /* switch */
diff --git a/ext/B/B/Concise.pm b/ext/B/B/Concise.pm
index 381181e6d2..311e0e738a 100644
--- a/ext/B/B/Concise.pm
+++ b/ext/B/B/Concise.pm
@@ -916,7 +916,7 @@ sub concise_op {
}
}
elsif ($h{class} eq "UNOP_AUX") {
- $h{arg} = "(" . $op->string . ")";
+ $h{arg} = "(" . $op->string($curcv) . ")";
}
$h{seq} = $h{hyphseq} = seq($op);
diff --git a/ext/B/t/OptreeCheck.pm b/ext/B/t/OptreeCheck.pm
index 0537a8d7a8..eac73baa73 100644
--- a/ext/B/t/OptreeCheck.pm
+++ b/ext/B/t/OptreeCheck.pm
@@ -5,7 +5,7 @@ use warnings;
use vars qw($TODO $Level $using_open);
require "test.pl";
-our $VERSION = '0.11';
+our $VERSION = '0.12';
# now export checkOptree, and those test.pl functions used by tests
our @EXPORT = qw( checkOptree plan skip skip_all pass is like unlike
@@ -669,6 +669,8 @@ sub mkCheckRex {
$tc->{wantstr} = $str;
+ # make UNOP_AUX flag type literal
+ $str =~ s/<\+>/<\\+>/;
# make targ args wild
$str =~ s/\[t\d+\]/[t\\d+]/msg;
diff --git a/ext/B/t/concise-xs.t b/ext/B/t/concise-xs.t
index 365951d0bc..289f909cc9 100644
--- a/ext/B/t/concise-xs.t
+++ b/ext/B/t/concise-xs.t
@@ -159,6 +159,7 @@ my $testpkgs = {
constant => [qw/ ASSIGN CVf_LVALUE
CVf_METHOD LIST_CONTEXT OP_CONST OP_LIST OP_RV2SV
OP_AELEM OP_CUSTOM OP_NEXTSTATE OP_DBSTATE
+ OP_HELEM OP_RV2AV OP_RV2HV
OP_STRINGIFY OPf_KIDS OPf_MOD OPf_REF OPf_SPECIAL
OPf_PARENS
OPf_STACKED OPf_WANT OPf_WANT_LIST OPf_WANT_SCALAR
@@ -169,6 +170,8 @@ my $testpkgs = {
OPpSORT_REVERSE OPpREVERSE_INPLACE OPpTARGET_MY
OPpTRANS_COMPLEMENT OPpTRANS_DELETE OPpTRANS_SQUASH
OPpREPEAT_DOLIST
+ OPpMULTIDEREF_EXISTS
+ OPpMULTIDEREF_DELETE
PMf_CONTINUE PMf_EVAL PMf_EXTENDED PMf_EXTENDED_MORE
PMf_FOLD PMf_GLOBAL
PMf_KEEP PMf_NONDESTRUCT
@@ -176,7 +179,32 @@ my $testpkgs = {
POSTFIX SVf_FAKE SVf_IOK SVf_NOK SVf_POK SVf_ROK
SVpad_STATE
SVpad_OUR SVs_RMG SVs_SMG SWAP_CHILDREN OPpPAD_STATE
- OPpCONST_ARYBASE RXf_SKIPWHITE SVpad_TYPED/,
+ OPpCONST_ARYBASE RXf_SKIPWHITE SVpad_TYPED
+
+ MDEREF_reload
+ MDEREF_AV_pop_rv2av_aelem
+ MDEREF_AV_gvsv_vivify_rv2av_aelem
+ MDEREF_AV_padsv_vivify_rv2av_aelem
+ MDEREF_AV_vivify_rv2av_aelem
+ MDEREF_AV_padav_aelem
+ MDEREF_AV_gvav_aelem
+ MDEREF_HV_pop_rv2hv_helem
+ MDEREF_HV_gvsv_vivify_rv2hv_helem
+ MDEREF_HV_padsv_vivify_rv2hv_helem
+ MDEREF_HV_vivify_rv2hv_helem
+ MDEREF_HV_padhv_helem
+ MDEREF_HV_gvhv_helem
+ MDEREF_ACTION_MASK
+ MDEREF_INDEX_none
+ MDEREF_INDEX_const
+ MDEREF_INDEX_padsv
+ MDEREF_INDEX_gvsv
+ MDEREF_INDEX_MASK
+ MDEREF_FLAG_last
+ MDEREF_MASK
+ MDEREF_SHIFT
+ /,
+
$] >= 5.015 ? qw(
OP_GLOB PMf_SKIPWHITE RXf_PMf_CHARSET RXf_PMf_KEEPCOPY
OPpEVAL_BYTES OPpSUBSTR_REPL_FIRST) : (),
diff --git a/ext/B/t/f_sort.t b/ext/B/t/f_sort.t
index 7205a94e44..55811eda93 100644
--- a/ext/B/t/f_sort.t
+++ b/ext/B/t/f_sort.t
@@ -510,10 +510,8 @@ checkOptree(name => q{Compound sort/map Expression },
# 5 <0> pushmark s
# 6 <#> gv[*old] s
# 7 <1> rv2av[t19] lKM/1
-# 8 <@> mapstart lK* < 5.017002
-# 8 <@> mapstart lK >=5.017002
-# 9 <|> mapwhile(other->a)[t20] lK < 5.019002
-# 9 <|> mapwhile(other->a)[t20] lKM >=5.019002
+# 8 <@> mapstart lK
+# 9 <|> mapwhile(other->a)[t20] lKM
# a <0> enter l
# b <;> nextstate(main 608 (eval 34):2) v:{
# c <0> pushmark s
@@ -525,21 +523,15 @@ checkOptree(name => q{Compound sort/map Expression },
# i <@> leave lKP
# goto 9
# j <@> sort lKMS*
-# k <@> mapstart lK* < 5.017002
-# k <@> mapstart lK >=5.017002
+# k <@> mapstart lK
# l <|> mapwhile(other->m)[t26] lK
-# m <#> gv[*_] s
-# n <1> rv2sv sKM/DREFAV,1
-# o <1> rv2av[t4] sKR/1
-# p <$> const[IV 0] s
-# q <2> aelem sK/2
-# - <@> scope lK < 5.017002
+# m <+> multideref($_->[0]) sK
# goto l
-# r <0> pushmark s
-# s <#> gv[*new] s
-# t <1> rv2av[t2] lKRM*/1
-# u <2> aassign[t27] KS/COMMON
-# v <1> leavesub[1 ref] K/REFC,1
+# n <0> pushmark s
+# o <#> gv[*new] s
+# p <1> rv2av[t2] lKRM*/1
+# q <2> aassign[t22] KS/COMMON
+# r <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 609 (eval 34):3) v:{
# 2 <0> pushmark s
@@ -548,10 +540,8 @@ EOT_EOT
# 5 <0> pushmark s
# 6 <$> gv(*old) s
# 7 <1> rv2av[t10] lKM/1
-# 8 <@> mapstart lK* < 5.017002
-# 8 <@> mapstart lK >=5.017002
-# 9 <|> mapwhile(other->a)[t11] lK < 5.019002
-# 9 <|> mapwhile(other->a)[t11] lKM >=5.019002
+# 8 <@> mapstart lK
+# 9 <|> mapwhile(other->a)[t11] lKM
# a <0> enter l
# b <;> nextstate(main 608 (eval 34):2) v:{
# c <0> pushmark s
@@ -563,21 +553,15 @@ EOT_EOT
# i <@> leave lKP
# goto 9
# j <@> sort lKMS*
-# k <@> mapstart lK* < 5.017002
-# k <@> mapstart lK >=5.017002
+# k <@> mapstart lK
# l <|> mapwhile(other->m)[t12] lK
-# m <$> gv(*_) s
-# n <1> rv2sv sKM/DREFAV,1
-# o <1> rv2av[t2] sKR/1
-# p <$> const(IV 0) s
-# q <2> aelem sK/2
-# - <@> scope lK < 5.017002
+# m <+> multideref($_->[0]) sK
# goto l
-# r <0> pushmark s
-# s <$> gv(*new) s
-# t <1> rv2av[t1] lKRM*/1
-# u <2> aassign[t13] KS/COMMON
-# v <1> leavesub[1 ref] K/REFC,1
+# n <0> pushmark s
+# o <$> gv(*new) s
+# p <1> rv2av[t1] lKRM*/1
+# q <2> aassign[t13] KS/COMMON
+# r <1> leavesub[1 ref] K/REFC,1
EONT_EONT
diff --git a/ext/Opcode/Opcode.pm b/ext/Opcode/Opcode.pm
index b1813e072c..b9f67dd324 100644
--- a/ext/Opcode/Opcode.pm
+++ b/ext/Opcode/Opcode.pm
@@ -312,7 +312,7 @@ invert_opset function.
av2arylen
rv2hv helem hslice kvhslice each values keys exists delete
- aeach akeys avalues reach rvalues rkeys
+ aeach akeys avalues reach rvalues rkeys multideref
preinc i_preinc predec i_predec postinc i_postinc
postdec i_postdec int hex oct abs pow multiply i_multiply
diff --git a/intrpvar.h b/intrpvar.h
index 39eac06454..ffb1172c9f 100644
--- a/intrpvar.h
+++ b/intrpvar.h
@@ -70,6 +70,9 @@ PERLVARI(I, hash_rand_bits_enabled, U8, 1) /* used to randomize hash stuff 0 ==
PERLVARI(I, hash_rand_bits, UV, 0) /* used to randomize hash stuff */
#endif
PERLVAR(I, strtab, HV *) /* shared string table */
+/* prog counter for the currently executing OP_MULTIDEREF Used to signal
+ * to S_find_uninit_var() where we are */
+PERLVAR(I, multideref_pc, UNOP_AUX_item *)
/* Fields used by magic variables such as $@, $/ and so on */
PERLVAR(I, curpm, PMOP *) /* what to do \ interps in REs from */
diff --git a/lib/B/Deparse.pm b/lib/B/Deparse.pm
index 74562c58e3..267c0cdb6a 100644
--- a/lib/B/Deparse.pm
+++ b/lib/B/Deparse.pm
@@ -15,12 +15,36 @@ use B qw(class main_root main_start main_cv svref_2object opnumber perlstring
OPpLVAL_INTRO OPpOUR_INTRO OPpENTERSUB_AMPER OPpSLICE OPpCONST_BARE
OPpTRANS_SQUASH OPpTRANS_DELETE OPpTRANS_COMPLEMENT OPpTARGET_MY
OPpEXISTS_SUB OPpSORT_NUMERIC OPpSORT_INTEGER OPpREPEAT_DOLIST
- OPpSORT_REVERSE
+ OPpSORT_REVERSE OPpMULTIDEREF_EXISTS OPpMULTIDEREF_DELETE
SVf_IOK SVf_NOK SVf_ROK SVf_POK SVpad_OUR SVf_FAKE SVs_RMG SVs_SMG
SVpad_TYPED
CVf_METHOD CVf_LVALUE
PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE
- PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED PMf_EXTENDED_MORE);
+ PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED PMf_EXTENDED_MORE
+ MDEREF_reload
+ MDEREF_AV_pop_rv2av_aelem
+ MDEREF_AV_gvsv_vivify_rv2av_aelem
+ MDEREF_AV_padsv_vivify_rv2av_aelem
+ MDEREF_AV_vivify_rv2av_aelem
+ MDEREF_AV_padav_aelem
+ MDEREF_AV_gvav_aelem
+ MDEREF_HV_pop_rv2hv_helem
+ MDEREF_HV_gvsv_vivify_rv2hv_helem
+ MDEREF_HV_padsv_vivify_rv2hv_helem
+ MDEREF_HV_vivify_rv2hv_helem
+ MDEREF_HV_padhv_helem
+ MDEREF_HV_gvhv_helem
+ MDEREF_ACTION_MASK
+ MDEREF_INDEX_none
+ MDEREF_INDEX_const
+ MDEREF_INDEX_padsv
+ MDEREF_INDEX_gvsv
+ MDEREF_INDEX_MASK
+ MDEREF_FLAG_last
+ MDEREF_MASK
+ MDEREF_SHIFT
+ );
+
$VERSION = '1.31';
use strict;
use vars qw/$AUTOLOAD/;
@@ -334,7 +358,7 @@ BEGIN {
BEGIN { for (qw[ const stringify rv2sv list glob pushmark null aelem
- custom nextstate dbstate ]) {
+ nextstate dbstate rv2av rv2hv helem custom ]) {
eval "sub OP_\U$_ () { " . opnumber($_) . "}"
}}
@@ -3729,7 +3753,7 @@ sub pp_rv2av {
sub is_subscriptable {
my $op = shift;
- if ($op->name =~ /^[ahg]elem/) {
+ if ($op->name =~ /^([ahg]elem|multideref$)/) {
return 1;
} elsif ($op->name eq "entersub") {
my $kid = $op->first;
@@ -3834,6 +3858,145 @@ sub elem {
}
+# a simplified version of elem_or_slice_array_name()
+# for the use of pp_multideref
+
+sub multideref_var_name {
+ my $self = shift;
+ my ($gv, $is_hash) = @_;
+
+ my ($name, $quoted) =
+ $self->stash_variable_name( $is_hash ? '%' : '@', $gv);
+ return $quoted ? "$name->"
+ : $name eq '#'
+ ? '${#}' # avoid ${#}[1] => $#[1]
+ : '$' . $name;
+}
+
+
+sub pp_multideref {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my $text = "";
+
+ if ($op->private & OPpMULTIDEREF_EXISTS) {
+ $text = $self->keyword("exists"). " ";
+ }
+ elsif ($op->private & OPpMULTIDEREF_DELETE) {
+ $text = $self->keyword("delete"). " ";
+ }
+ elsif ($op->private & OPpLVAL_INTRO) {
+ $text = $self->keyword("local"). " ";
+ }
+
+ if ($op->first && ($op->first->flags & OPf_KIDS)) {
+ # arbitrary initial expression, e.g. f(1,2,3)->[...]
+ $text .= $self->deparse($op->first, 24);
+ }
+
+ my @items = $op->aux_list($self->{curcv});
+ my $actions = shift @items;
+
+ my $is_hash;
+ my $derefs = 0;
+
+ while (1) {
+ if (($actions & MDEREF_ACTION_MASK) == MDEREF_reload) {
+ $actions = shift @items;
+ next;
+ }
+
+ $is_hash = (
+ ($actions & MDEREF_ACTION_MASK) == MDEREF_HV_pop_rv2hv_helem
+ || ($actions & MDEREF_ACTION_MASK) == MDEREF_HV_gvsv_vivify_rv2hv_helem
+ || ($actions & MDEREF_ACTION_MASK) == MDEREF_HV_padsv_vivify_rv2hv_helem
+ || ($actions & MDEREF_ACTION_MASK) == MDEREF_HV_vivify_rv2hv_helem
+ || ($actions & MDEREF_ACTION_MASK) == MDEREF_HV_padhv_helem
+ || ($actions & MDEREF_ACTION_MASK) == MDEREF_HV_gvhv_helem
+ );
+
+ if ( ($actions & MDEREF_ACTION_MASK) == MDEREF_AV_padav_aelem
+ || ($actions & MDEREF_ACTION_MASK) == MDEREF_HV_padhv_helem)
+ {
+ $derefs = 1;
+ $text .= '$' . substr($self->padname(shift @items), 1);
+ }
+ elsif ( ($actions & MDEREF_ACTION_MASK) == MDEREF_AV_gvav_aelem
+ || ($actions & MDEREF_ACTION_MASK) == MDEREF_HV_gvhv_helem)
+ {
+ $derefs = 1;
+ $text .= $self->multideref_var_name(shift @items, $is_hash);
+ }
+ else {
+ if ( ($actions & MDEREF_ACTION_MASK) ==
+ MDEREF_AV_padsv_vivify_rv2av_aelem
+ || ($actions & MDEREF_ACTION_MASK) ==
+ MDEREF_HV_padsv_vivify_rv2hv_helem)
+ {
+ $text .= $self->padname(shift @items);
+ }
+ elsif ( ($actions & MDEREF_ACTION_MASK) ==
+ MDEREF_AV_gvsv_vivify_rv2av_aelem
+ || ($actions & MDEREF_ACTION_MASK) ==
+ MDEREF_HV_gvsv_vivify_rv2hv_helem)
+ {
+ $text .= $self->multideref_var_name(shift @items, $is_hash);
+ }
+ elsif ( ($actions & MDEREF_ACTION_MASK) ==
+ MDEREF_AV_pop_rv2av_aelem
+ || ($actions & MDEREF_ACTION_MASK) ==
+ MDEREF_HV_pop_rv2hv_helem)
+ {
+ if ( ($op->flags & OPf_KIDS)
+ && ( _op_is_or_was($op->first, OP_RV2AV)
+ || _op_is_or_was($op->first, OP_RV2HV))
+ && ($op->first->flags & OPf_KIDS)
+ && ( _op_is_or_was($op->first->first, OP_AELEM)
+ || _op_is_or_was($op->first->first, OP_HELEM))
+ )
+ {
+ $derefs++;
+ }
+ }
+
+ $text .= '->' if !$derefs++;
+ }
+
+
+ if (($actions & MDEREF_INDEX_MASK) == MDEREF_INDEX_none) {
+ last;
+ }
+
+ $text .= $is_hash ? '{' : '[';
+
+ if (($actions & MDEREF_INDEX_MASK) == MDEREF_INDEX_const) {
+ my $key = shift @items;
+ if ($is_hash) {
+ $text .= $self->const($key, $cx);
+ }
+ else {
+ $text .= $key;
+ }
+ }
+ elsif (($actions & MDEREF_INDEX_MASK) == MDEREF_INDEX_padsv) {
+ $text .= $self->padname(shift @items);
+ }
+ elsif (($actions & MDEREF_INDEX_MASK) == MDEREF_INDEX_gvsv) {
+ $text .= '$' . ($self->stash_variable_name('$', shift @items))[0];
+ }
+
+ $text .= $is_hash ? '}' : ']';
+
+ if ($actions & MDEREF_FLAG_last) {
+ last;
+ }
+ $actions >>= MDEREF_SHIFT;
+ }
+
+ return $text;
+}
+
+
sub pp_aelem { maybe_local(@_, elem(@_, "[", "]", "padav")) }
sub pp_helem { maybe_local(@_, elem(@_, "{", "}", "padhv")) }
@@ -4727,7 +4890,7 @@ sub pp_stringify {
while ($kid->name eq 'null' && !null($kid->first)) {
$kid = $kid->first;
}
- if ($kid->name =~ /^(?:const|padsv|rv2sv|av2arylen|gvsv
+ if ($kid->name =~ /^(?:const|padsv|rv2sv|av2arylen|gvsv|multideref
|aelemfast(?:_lex)?|[ah]elem|join|concat)\z/x) {
maybe_targmy(@_, \&dquote);
}
@@ -5075,20 +5238,23 @@ sub pure_string {
elsif (is_scalar($op) || $type =~ /^[ah]elem$/) {
return 1;
}
- elsif ($type eq "null" and $op->can('first') and not null $op->first and
- ($op->first->name eq "null" and $op->first->can('first')
- and not null $op->first->first and
- $op->first->first->name eq "aelemfast"
- or
- $op->first->name =~ /^aelemfast(?:_lex)?\z/
- )) {
- return 1;
- }
- else {
- return 0;
+ elsif ($type eq "null" and $op->can('first') and not null $op->first) {
+ my $first = $op->first;
+
+ return 1 if $first->name eq "multideref";
+ return 1 if $first->name eq "aelemfast_lex";
+
+ if ( $first->name eq "null"
+ and $first->can('first')
+ and not null $first->first
+ and $first->first->name eq "aelemfast"
+ )
+ {
+ return 1;
+ }
}
- return 1;
+ return 0;
}
sub code_list {
diff --git a/lib/B/Deparse.t b/lib/B/Deparse.t
index f14c2abf1f..ef19f7163e 100644
--- a/lib/B/Deparse.t
+++ b/lib/B/Deparse.t
@@ -2088,3 +2088,81 @@ $_ = join $foo, pos
>>>>
my $foo;
$_ = join('???', pos $_);
+####
+# exists $a[0]
+our @a;
+exists $a[0];
+####
+# my @a; exists $a[0]
+my @a;
+exists $a[0];
+####
+# delete $a[0]
+our @a;
+delete $a[0];
+####
+# my @a; delete $a[0]
+my @a;
+delete $a[0];
+####
+# $_[0][$_[1]]
+$_[0][$_[1]];
+####
+# f($a[0]);
+my @a;
+f($a[0]);
+####
+#qr/\Q$h{'key'}\E/;
+my %h;
+qr/\Q$h{'key'}\E/;
+####
+# my $x = "$h{foo}";
+my %h;
+my $x = "$h{'foo'}";
+####
+# weird constant hash key
+my %h;
+my $x = $h{"\000\t\x{100}"};
+####
+# multideref and packages
+package foo;
+my(%bar) = ('a', 'b');
+our(@bar) = (1, 2);
+$bar{'k'} = $bar[200];
+$main::bar{'k'} = $main::bar[200];
+$foo::bar{'k'} = $foo::bar[200];
+package foo2;
+$bar{'k'} = $bar[200];
+$main::bar{'k'} = $main::bar[200];
+$foo::bar{'k'} = $foo::bar[200];
+>>>>
+package foo;
+my(%bar) = ('a', 'b');
+our(@bar) = (1, 2);
+$bar{'k'} = $bar[200];
+$main::bar{'k'} = $main::bar[200];
+$foo::bar{'k'} = $bar[200];
+package foo2;
+$bar{'k'} = $foo::bar[200];
+$main::bar{'k'} = $main::bar[200];
+$foo::bar{'k'} = $foo::bar[200];
+####
+# multideref and local
+my %h;
+local $h{'foo'}[0] = 1;
+####
+# multideref and exists
+my(%h, $i);
+my $e = exists $h{'foo'}[$i];
+####
+# multideref and delete
+my(%h, $i);
+my $e = delete $h{'foo'}[$i];
+####
+# multideref with leading expression
+my $r;
+my $x = ($r // [])->{'foo'}[0];
+####
+# multideref with complex middle index
+my(%h, $i, $j, $k);
+my $x = $h{'foo'}[$i + $j]{$k};
diff --git a/lib/B/Op_private.pm b/lib/B/Op_private.pm
index e8e63a2e32..e7383644b7 100644
--- a/lib/B/Op_private.pm
+++ b/lib/B/Op_private.pm
@@ -129,15 +129,15 @@ $bits{$_}{4} = 'OPpFT_AFTER_t' for qw(ftatime ftbinary ftblk ftchr ftctime ftdir
$bits{$_}{2} = 'OPpFT_STACKED' for qw(ftatime ftbinary ftblk ftchr ftctime ftdir fteexec fteowned fteread ftewrite ftfile ftis ftlink ftmtime ftpipe ftrexec ftrowned ftrread ftrwrite ftsgid ftsize ftsock ftsuid ftsvtx fttext fttty ftzero);
$bits{$_}{3} = 'OPpFT_STACKING' for qw(ftatime ftbinary ftblk ftchr ftctime ftdir fteexec fteowned fteread ftewrite ftfile ftis ftlink ftmtime ftpipe ftrexec ftrowned ftrread ftrwrite ftsgid ftsize ftsock ftsuid ftsvtx fttext fttty ftzero);
$bits{$_}{1} = 'OPpGREP_LEX' for qw(grepstart grepwhile mapstart mapwhile);
-$bits{$_}{1} = 'OPpHINT_STRICT_REFS' for qw(entersub rv2av rv2cv rv2gv rv2hv rv2sv);
+$bits{$_}{1} = 'OPpHINT_STRICT_REFS' for qw(entersub multideref rv2av rv2cv rv2gv rv2hv rv2sv);
$bits{$_}{5} = 'OPpHUSH_VMSISH' for qw(dbstate nextstate);
$bits{$_}{2} = 'OPpITER_REVERSED' for qw(enteriter iter);
$bits{$_}{7} = 'OPpLVALUE' for qw(leave leaveloop);
-$bits{$_}{6} = 'OPpLVAL_DEFER' for qw(aelem helem);
-$bits{$_}{7} = 'OPpLVAL_INTRO' for qw(aelem aslice cond_expr delete enteriter entersub gvsv helem hslice list lvavref lvref lvrefslice padav padhv padrange padsv pushmark refassign rv2av rv2gv rv2hv rv2sv);
+$bits{$_}{6} = 'OPpLVAL_DEFER' for qw(aelem helem multideref);
+$bits{$_}{7} = 'OPpLVAL_INTRO' for qw(aelem aslice cond_expr delete enteriter entersub gvsv helem hslice list lvavref lvref lvrefslice multideref padav padhv padrange padsv pushmark refassign rv2av rv2gv rv2hv rv2sv);
$bits{$_}{2} = 'OPpLVREF_ELEM' for qw(lvref refassign);
$bits{$_}{3} = 'OPpLVREF_ITER' for qw(lvref refassign);
-$bits{$_}{3} = 'OPpMAYBE_LVSUB' for qw(aassign aelem aslice av2arylen helem hslice keys kvaslice kvhslice padav padhv pos rkeys rv2av rv2gv rv2hv substr vec);
+$bits{$_}{3} = 'OPpMAYBE_LVSUB' for qw(aassign aelem aslice av2arylen helem hslice keys kvaslice kvhslice multideref padav padhv pos rkeys rv2av rv2gv rv2hv substr vec);
$bits{$_}{4} = 'OPpMAYBE_TRUEBOOL' for qw(padhv rv2hv);
$bits{$_}{7} = 'OPpOFFBYONE' for qw(caller runcv wantarray);
$bits{$_}{5} = 'OPpOPEN_IN_CRLF' for qw(backtick open);
@@ -415,6 +415,7 @@ $bits{method_super}{0} = $bf[0];
@{$bits{msgget}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
@{$bits{msgrcv}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
@{$bits{msgsnd}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{multideref}}{5,4,0} = ('OPpMULTIDEREF_DELETE', 'OPpMULTIDEREF_EXISTS', $bf[0]);
@{$bits{multiply}}{1,0} = ($bf[1], $bf[1]);
@{$bits{ncmp}}{1,0} = ($bf[1], $bf[1]);
@{$bits{ne}}{1,0} = ($bf[1], $bf[1]);
@@ -610,6 +611,8 @@ our %defines = (
OPpMAYBE_LVSUB => 8,
OPpMAYBE_TRUEBOOL => 16,
OPpMAY_RETURN_CONSTANT => 32,
+ OPpMULTIDEREF_DELETE => 32,
+ OPpMULTIDEREF_EXISTS => 16,
OPpOFFBYONE => 128,
OPpOPEN_IN_CRLF => 32,
OPpOPEN_IN_RAW => 16,
@@ -699,6 +702,8 @@ our %labels = (
OPpMAYBE_LVSUB => 'LVSUB',
OPpMAYBE_TRUEBOOL => 'BOOL?',
OPpMAY_RETURN_CONSTANT => 'CONST',
+ OPpMULTIDEREF_DELETE => 'DELETE',
+ OPpMULTIDEREF_EXISTS => 'EXISTS',
OPpOFFBYONE => '+1',
OPpOPEN_IN_CRLF => 'INCR',
OPpOPEN_IN_RAW => 'INBIN',
@@ -750,17 +755,18 @@ our %ops_using = (
OPpFT_ACCESS => [qw(fteexec fteread ftewrite ftrexec ftrread ftrwrite)],
OPpFT_AFTER_t => [qw(ftatime ftbinary ftblk ftchr ftctime ftdir fteexec fteowned fteread ftewrite ftfile ftis ftlink ftmtime ftpipe ftrexec ftrowned ftrread ftrwrite ftsgid ftsize ftsock ftsuid ftsvtx fttext fttty ftzero)],
OPpGREP_LEX => [qw(grepstart grepwhile mapstart mapwhile)],
- OPpHINT_STRICT_REFS => [qw(entersub rv2av rv2cv rv2gv rv2hv rv2sv)],
+ OPpHINT_STRICT_REFS => [qw(entersub multideref rv2av rv2cv rv2gv rv2hv rv2sv)],
OPpHUSH_VMSISH => [qw(dbstate nextstate)],
OPpITER_DEF => [qw(enteriter)],
OPpITER_REVERSED => [qw(enteriter iter)],
OPpLIST_GUESSED => [qw(list)],
OPpLVALUE => [qw(leave leaveloop)],
- OPpLVAL_DEFER => [qw(aelem helem)],
- OPpLVAL_INTRO => [qw(aelem aslice cond_expr delete enteriter entersub gvsv helem hslice list lvavref lvref lvrefslice padav padhv padrange padsv pushmark refassign rv2av rv2gv rv2hv rv2sv)],
+ OPpLVAL_DEFER => [qw(aelem helem multideref)],
+ OPpLVAL_INTRO => [qw(aelem aslice cond_expr delete enteriter entersub gvsv helem hslice list lvavref lvref lvrefslice multideref padav padhv padrange padsv pushmark refassign rv2av rv2gv rv2hv rv2sv)],
OPpLVREF_ELEM => [qw(lvref refassign)],
- OPpMAYBE_LVSUB => [qw(aassign aelem aslice av2arylen helem hslice keys kvaslice kvhslice padav padhv pos rkeys rv2av rv2gv rv2hv substr vec)],
+ OPpMAYBE_LVSUB => [qw(aassign aelem aslice av2arylen helem hslice keys kvaslice kvhslice multideref padav padhv pos rkeys rv2av rv2gv rv2hv substr vec)],
OPpMAYBE_TRUEBOOL => [qw(padhv rv2hv)],
+ OPpMULTIDEREF_DELETE => [qw(multideref)],
OPpOFFBYONE => [qw(caller runcv wantarray)],
OPpOPEN_IN_CRLF => [qw(backtick open)],
OPpOUR_INTRO => [qw(enteriter gvsv rv2av rv2hv rv2sv split)],
@@ -798,6 +804,7 @@ $ops_using{OPpFT_STACKED} = $ops_using{OPpFT_AFTER_t};
$ops_using{OPpFT_STACKING} = $ops_using{OPpFT_AFTER_t};
$ops_using{OPpLVREF_ITER} = $ops_using{OPpLVREF_ELEM};
$ops_using{OPpMAY_RETURN_CONSTANT} = $ops_using{OPpENTERSUB_NOPAREN};
+$ops_using{OPpMULTIDEREF_EXISTS} = $ops_using{OPpMULTIDEREF_DELETE};
$ops_using{OPpOPEN_IN_RAW} = $ops_using{OPpOPEN_IN_CRLF};
$ops_using{OPpOPEN_OUT_CRLF} = $ops_using{OPpOPEN_IN_CRLF};
$ops_using{OPpOPEN_OUT_RAW} = $ops_using{OPpOPEN_IN_CRLF};
diff --git a/op.c b/op.c
index f34e9326f7..16ebd4244b 100644
--- a/op.c
+++ b/op.c
@@ -797,7 +797,8 @@ void S_op_clear_gv(pTHX_ OP *o, SV**svp)
#endif
{
- GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV)
+ GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV
+ || o->op_type == OP_MULTIDEREF)
#ifdef USE_ITHREADS
&& PL_curpad
? ((GV*)PAD_SVl(*ixp)) : NULL;
@@ -975,6 +976,109 @@ clear_pmop:
#endif
break;
+
+ case OP_MULTIDEREF:
+ {
+ UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
+ UV actions = items->uv;
+ bool last = 0;
+ bool is_hash = FALSE;
+
+ while (!last) {
+ switch (actions & MDEREF_ACTION_MASK) {
+
+ case MDEREF_reload:
+ actions = (++items)->uv;
+ continue;
+
+ case MDEREF_HV_padhv_helem:
+ is_hash = TRUE;
+ case MDEREF_AV_padav_aelem:
+ pad_free((++items)->pad_offset);
+ goto do_elem;
+
+ case MDEREF_HV_gvhv_helem:
+ is_hash = TRUE;
+ case MDEREF_AV_gvav_aelem:
+#ifdef USE_ITHREADS
+ S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
+#else
+ S_op_clear_gv(aTHX_ o, &((++items)->sv));
+#endif
+ goto do_elem;
+
+ case MDEREF_HV_gvsv_vivify_rv2hv_helem:
+ is_hash = TRUE;
+ case MDEREF_AV_gvsv_vivify_rv2av_aelem:
+#ifdef USE_ITHREADS
+ S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
+#else
+ S_op_clear_gv(aTHX_ o, &((++items)->sv));
+#endif
+ goto do_vivify_rv2xv_elem;
+
+ case MDEREF_HV_padsv_vivify_rv2hv_helem:
+ is_hash = TRUE;
+ case MDEREF_AV_padsv_vivify_rv2av_aelem:
+ pad_free((++items)->pad_offset);
+ goto do_vivify_rv2xv_elem;
+
+ case MDEREF_HV_pop_rv2hv_helem:
+ case MDEREF_HV_vivify_rv2hv_helem:
+ is_hash = TRUE;
+ do_vivify_rv2xv_elem:
+ case MDEREF_AV_pop_rv2av_aelem:
+ case MDEREF_AV_vivify_rv2av_aelem:
+ do_elem:
+ switch (actions & MDEREF_INDEX_MASK) {
+ case MDEREF_INDEX_none:
+ last = 1;
+ break;
+ case MDEREF_INDEX_const:
+ if (is_hash) {
+#ifdef USE_ITHREADS
+ /* see RT #15654 */
+ pad_swipe((++items)->pad_offset, 1);
+#else
+ SvREFCNT_dec((++items)->sv);
+#endif
+ }
+ else
+ items++;
+ break;
+ case MDEREF_INDEX_padsv:
+ pad_free((++items)->pad_offset);
+ break;
+ case MDEREF_INDEX_gvsv:
+#ifdef USE_ITHREADS
+ S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
+#else
+ S_op_clear_gv(aTHX_ o, &((++items)->sv));
+#endif
+ break;
+ }
+
+ if (actions & MDEREF_FLAG_last)
+ last = 1;
+ is_hash = FALSE;
+
+ break;
+
+ default:
+ assert(0);
+ last = 1;
+ break;
+
+ } /* switch */
+
+ actions >>= MDEREF_SHIFT;
+ } /* while */
+
+ /* start of malloc is at op_aux[-1], where the length is
+ * stored */
+ PerlMemShared_free(cUNOP_AUXo->op_aux - 1);
+ }
+ break;
}
if (o->op_targ > 0) {
@@ -2171,7 +2275,7 @@ S_modkids(pTHX_ OP *o, I32 type)
*/
void
-S_check_hash_fields(pTHX_ UNOP *rop, SVOP *key_op)
+S_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op)
{
PADNAME *lexname;
GV **fields;
@@ -2379,7 +2483,7 @@ S_finalize_op(pTHX_ OP* o)
check_keys:
if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
rop = NULL;
- S_check_hash_fields(aTHX_ rop, key_op);
+ S_check_hash_fields_and_hekify(aTHX_ rop, key_op);
break;
}
case OP_ASLICE:
@@ -4705,7 +4809,7 @@ Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
}
/*
-=for apidoc
+=for apidoc newUNOP_AUX
Similar to C<newUNOP>, but creates an UNOP_AUX struct instead, with op_aux
initialised to aux
@@ -12065,6 +12169,608 @@ S_inplace_aassign(pTHX_ OP *o) {
+/* S_maybe_multideref(): given an op_next chain of ops beginning at 'start'
+ * that potentially represent a series of one or more aggregate derefs
+ * (such as $a->[1]{$key}), examine the chain, and if appropriate, convert
+ * the whole chain to a single OP_MULTIDEREF op (maybe with a few
+ * additional ops left in too).
+ *
+ * The caller will have already verified that the first few ops in the
+ * chain following 'start' indicate a multideref candidate, and will have
+ * set 'orig_o' to the point further on in the chain where the first index
+ * expression (if any) begins. 'orig_action' specifies what type of
+ * beginning has already been determined by the ops between start..orig_o
+ * (e.g. $lex_ary[], $pkg_ary->{}, expr->[], etc).
+ *
+ * 'hints' contains any hints flags that need adding (currently just
+ * OPpHINT_STRICT_REFS) as found in any rv2av/hv skipped by the caller.
+ */
+
+void
+S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints)
+{
+ dVAR;
+ int pass;
+ UNOP_AUX_item *arg_buf = NULL;
+ bool reset_start_targ = FALSE; /* start->op_targ needs zeroing */
+ int index_skip = -1; /* don't output index arg on this action */
+
+ /* similar to regex compiling, do two passes; the first pass
+ * determines whether the op chain is convertible and calculates the
+ * buffer size; the second pass populates the buffer and makes any
+ * changes necessary to ops (such as moving consts to the pad on
+ * threaded builds)
+ */
+ for (pass = 0; pass < 2; pass++) {
+ OP *o = orig_o;
+ UV action = orig_action;
+ OP *first_elem_op = NULL; /* first seen aelem/helem */
+ OP *top_op = NULL; /* highest [ah]elem/exists/del/rv2[ah]v */
+ int action_count = 0; /* number of actions seen so far */
+ int action_ix = 0; /* action_count % (actions per IV) */
+ bool next_is_hash = FALSE; /* is the next lookup to be a hash? */
+ bool is_last = FALSE; /* no more derefs to follow */
+ bool maybe_aelemfast = FALSE; /* we can replace with aelemfast? */
+ UNOP_AUX_item *arg = arg_buf;
+ UNOP_AUX_item *action_ptr = arg_buf;
+
+ if (pass)
+ action_ptr->uv = 0;
+ arg++;
+
+ switch (action) {
+ case MDEREF_HV_gvsv_vivify_rv2hv_helem:
+ case MDEREF_HV_gvhv_helem:
+ next_is_hash = TRUE;
+ /* FALLTHROUGH */
+ case MDEREF_AV_gvsv_vivify_rv2av_aelem:
+ case MDEREF_AV_gvav_aelem:
+ if (pass) {
+#ifdef USE_ITHREADS
+ arg->pad_offset = cPADOPx(start)->op_padix;
+ /* stop it being swiped when nulled */
+ cPADOPx(start)->op_padix = 0;
+#else
+ arg->sv = cSVOPx(start)->op_sv;
+ cSVOPx(start)->op_sv = NULL;
+#endif
+ }
+ arg++;
+ break;
+
+ case MDEREF_HV_padhv_helem:
+ case MDEREF_HV_padsv_vivify_rv2hv_helem:
+ next_is_hash = TRUE;
+ /* FALLTHROUGH */
+ case MDEREF_AV_padav_aelem:
+ case MDEREF_AV_padsv_vivify_rv2av_aelem:
+ if (pass) {
+ arg->pad_offset = start->op_targ;
+ /* we skip setting op_targ = 0 for now, since the intact
+ * OP_PADXV is needed by S_check_hash_fields_and_hekify */
+ reset_start_targ = TRUE;
+ }
+ arg++;
+ break;
+
+ case MDEREF_HV_pop_rv2hv_helem:
+ next_is_hash = TRUE;
+ /* FALLTHROUGH */
+ case MDEREF_AV_pop_rv2av_aelem:
+ break;
+
+ default:
+ assert(0);
+ return;
+ }
+
+ while (!is_last) {
+ /* look for another (rv2av/hv; get index;
+ * aelem/helem/exists/delele) sequence */
+
+ IV iv;
+ OP *kid;
+ bool is_deref;
+ bool ok;
+ UV index_type = MDEREF_INDEX_none;
+
+ if (action_count) {
+ /* if this is not the first lookup, consume the rv2av/hv */
+
+ /* for N levels of aggregate lookup, we normally expect
+ * that the first N-1 [ah]elem ops will be flagged as
+ * /DEREF (so they autovivifiy if necessary), and the last
+ * lookup op not to be.
+ * For other things (like @{$h{k1}{k2}}) extra scope or
+ * leave ops can appear, so abandon the effort in that
+ * case */
+ if (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
+ return;
+
+ /* rv2av or rv2hv sKR/1 */
+
+ assert(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
+ |OPf_REF|OPf_MOD|OPf_SPECIAL)));
+ if (o->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
+ return;
+
+ /* at this point, we wouldn't expect any of these
+ * possible private flags:
+ * OPpMAYBE_LVSUB, OPpOUR_INTRO, OPpLVAL_INTRO
+ * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL (rv2hv only)
+ */
+ assert(!(o->op_private &
+ ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING)));
+
+ hints = (o->op_private & OPpHINT_STRICT_REFS);
+
+ /* make sure the type of the previous /DEREF matches the
+ * type of the next lookup */
+ assert(o->op_type == (next_is_hash ? OP_RV2HV : OP_RV2AV));
+ top_op = o;
+
+ action = next_is_hash
+ ? MDEREF_HV_vivify_rv2hv_helem
+ : MDEREF_AV_vivify_rv2av_aelem;
+ o = o->op_next;
+ }
+
+ /* if this is the second pass, and we're at the depth where
+ * previously we encountered a non-simple index expression,
+ * stop processing the index at this point */
+ if (action_count != index_skip) {
+
+ /* look for one or more simple ops that return an array
+ * index or hash key */
+
+ switch (o->op_type) {
+ case OP_PADSV:
+ /* it may be a lexical var index */
+ assert(!(o->op_flags & ~(OPf_WANT|OPf_PARENS
+ |OPf_REF|OPf_MOD|OPf_SPECIAL)));
+ assert(!(o->op_private &
+ ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
+
+ if ( o->op_flags == OPf_WANT_SCALAR
+ && o->op_private == 0)
+ {
+ if (pass)
+ arg->pad_offset = o->op_targ;
+ arg++;
+ index_type = MDEREF_INDEX_padsv;
+ o = o->op_next;
+ }
+ break;
+
+ case OP_CONST:
+ if (next_is_hash) {
+ /* it's a constant hash index */
+ if (!(SvFLAGS(cSVOPo_sv) & (SVf_IOK|SVf_NOK|SVf_POK)))
+ /* "use constant foo => FOO; $h{+foo}" for
+ * some weird FOO, can leave you with constants
+ * that aren't simple strings. It's not worth
+ * the extra hassle for those edge cases */
+ break;
+
+ if (pass) {
+ UNOP *rop = NULL;
+ OP * helem_op = o->op_next;
+
+ assert( helem_op->op_type == OP_HELEM
+ || helem_op->op_type == OP_NULL);
+ if (helem_op->op_type == OP_HELEM) {
+ rop = (UNOP*)(((BINOP*)helem_op)->op_first);
+ if ( helem_op->op_private & OPpLVAL_INTRO
+ || rop->op_type != OP_RV2HV
+ )
+ rop = NULL;
+ }
+ S_check_hash_fields_and_hekify(aTHX_ rop, cSVOPo);
+
+#ifdef USE_ITHREADS
+ /* Relocate sv to the pad for thread safety */
+ op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
+ arg->pad_offset = o->op_targ;
+ o->op_targ = 0;
+#else
+ arg->sv = cSVOPx_sv(o);
+#endif
+ }
+ }
+ else {
+ /* it's a constant array index */
+ SV *ix_sv = cSVOPo->op_sv;
+ if (UNLIKELY(SvROK(ix_sv) && !SvGAMAGIC(ix_sv)
+ && ckWARN(WARN_MISC)))
+ Perl_warner(aTHX_ packWARN(WARN_MISC),
+ "Use of reference \"%"SVf"\" as array index",
+ SVfARG(ix_sv));
+ iv = SvIV(ix_sv);
+
+ if ( action_count == 0
+ && iv >= -128
+ && iv <= 127
+ && ( action == MDEREF_AV_padav_aelem
+ || action == MDEREF_AV_gvav_aelem)
+ )
+ maybe_aelemfast = TRUE;
+
+ if (pass) {
+ arg->iv = iv;
+ SvREFCNT_dec_NN(cSVOPo->op_sv);
+ }
+ }
+ if (pass)
+ /* we've taken ownership of the SV */
+ cSVOPo->op_sv = NULL;
+ arg++;
+ index_type = MDEREF_INDEX_const;
+ o = o->op_next;
+ break;
+
+ case OP_GV:
+ /* it may be a package var index */
+
+ assert(!(o->op_flags & ~(OPf_WANT)));
+ assert(!(o->op_private & ~(OPpEARLY_CV)));
+ if ( o->op_flags != OPf_WANT_SCALAR
+ || o->op_private != 0
+ )
+ break;
+
+ kid = o->op_next;
+ if (kid->op_type != OP_RV2SV)
+ break;
+
+ assert(!(kid->op_flags &
+ ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_REF|OPf_SPECIAL)));
+ assert(!(kid->op_private &
+ ~(OPpARG1_MASK
+ |OPpHINT_STRICT_REFS|OPpOUR_INTRO
+ |OPpDEREF|OPpLVAL_INTRO)));
+ if( kid->op_flags != (OPf_WANT_SCALAR|OPf_KIDS)
+ || (kid->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS))
+ )
+ break;
+
+ if (pass) {
+#ifdef USE_ITHREADS
+ arg->pad_offset = cPADOPx(o)->op_padix;
+ /* stop it being swiped when nulled */
+ cPADOPx(o)->op_padix = 0;
+#else
+ arg->sv = cSVOPx(o)->op_sv;
+ cSVOPo->op_sv = NULL;
+#endif
+ }
+ arg++;
+ index_type = MDEREF_INDEX_gvsv;
+ o = kid->op_next;
+ break;
+
+ } /* switch */
+ } /* action_count != index_skip */
+
+ action |= index_type;
+
+
+ /* at this point we have either:
+ * * detected what looks like a simple index expression,
+ * and expect the next op to be an [ah]elem, or
+ * an nulled [ah]elem followed by a delete or exists;
+ * * found a more complex expression, so something other
+ * than the above follows.
+ */
+
+ /* possibly an optimised away [ah]elem (where op_next is
+ * exists or delete) */
+ if (o->op_type == OP_NULL)
+ o = o->op_next;
+
+ /* at this point we're looking for an OP_AELEM, OP_HELEM,
+ * OP_EXISTS or OP_DELETE */
+
+ /* if something like arybase (a.k.a $[ ) is in scope,
+ * abandon optimisation attempt */
+ if (o->op_type == OP_AELEM && PL_check[OP_AELEM] != Perl_ck_null)
+ return;
+
+ if ( o->op_type != OP_AELEM
+ || (o->op_private &
+ (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB))
+ )
+ maybe_aelemfast = FALSE;
+
+ /* look for aelem/helem/exists/delete. If it's not the last elem
+ * lookup, it *must* have OPpDEREF_AV/HV, but not many other
+ * flags; if it's the last, then it mustn't have
+ * OPpDEREF_AV/HV, but may have lots of other flags, like
+ * OPpLVAL_INTRO etc
+ */
+
+ if ( index_type == MDEREF_INDEX_none
+ || ( o->op_type != OP_AELEM && o->op_type != OP_HELEM
+ && o->op_type != OP_EXISTS && o->op_type != OP_DELETE)
+ )
+ ok = FALSE;
+ else {
+ /* we have aelem/helem/exists/delete with valid simple index */
+
+ is_deref = (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
+ && ( (o->op_private & OPpDEREF) == OPpDEREF_AV
+ || (o->op_private & OPpDEREF) == OPpDEREF_HV);
+
+ if (is_deref) {
+ assert(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_MOD)));
+ assert(!(o->op_private & ~(OPpARG2_MASK|OPpDEREF)));
+
+ ok = o->op_flags == (OPf_WANT_SCALAR|OPf_KIDS|OPf_MOD)
+ && !(o->op_private & ~(OPpDEREF|OPpARG2_MASK));
+ }
+ else if (o->op_type == OP_EXISTS) {
+ assert(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
+ |OPf_REF|OPf_MOD|OPf_SPECIAL)));
+ assert(!(o->op_private & ~(OPpARG1_MASK|OPpEXISTS_SUB)));
+ ok = !(o->op_private & ~OPpARG1_MASK);
+ }
+ else if (o->op_type == OP_DELETE) {
+ assert(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
+ |OPf_REF|OPf_MOD|OPf_SPECIAL)));
+ assert(!(o->op_private &
+ ~(OPpARG1_MASK|OPpSLICE|OPpLVAL_INTRO)));
+ /* don't handle slices or 'local delete'; the latter
+ * is fairly rare, and has a complex runtime */
+ ok = !(o->op_private & ~OPpARG1_MASK);
+ if (OP_TYPE_IS_OR_WAS(cUNOPo->op_first, OP_AELEM))
+ /* skip handling run-tome error */
+ ok = (ok && cBOOL(o->op_flags & OPf_SPECIAL));
+ }
+ else {
+ assert(o->op_type == OP_AELEM || o->op_type == OP_HELEM);
+ assert(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_MOD
+ |OPf_PARENS|OPf_REF|OPf_SPECIAL)));
+ assert(!(o->op_private & ~(OPpARG2_MASK|OPpMAYBE_LVSUB
+ |OPpLVAL_DEFER|OPpDEREF|OPpLVAL_INTRO)));
+ ok = (o->op_private & OPpDEREF) != OPpDEREF_SV;
+ }
+ }
+
+ if (ok) {
+ if (!first_elem_op)
+ first_elem_op = o;
+ top_op = o;
+ if (is_deref) {
+ next_is_hash = cBOOL((o->op_private & OPpDEREF) == OPpDEREF_HV);
+ o = o->op_next;
+ }
+ else {
+ is_last = TRUE;
+ action |= MDEREF_FLAG_last;
+ }
+ }
+ else {
+ /* at this point we have something that started
+ * promisingly enough (with rv2av or whatever), but failed
+ * to find a simple index followed by an
+ * aelem/helem/exists/delete. If this is the first action,
+ * give up; but if we've already seen at least one
+ * aelem/helem, then keep them and add a new action with
+ * MDEREF_INDEX_none, which causes it to do the vivify
+ * from the end of the previous lookup, and do the deref,
+ * but stop at that point. So $a[0][expr] will do one
+ * av_fetch, vivify and deref, then continue executing at
+ * expr */
+ if (!action_count)
+ return;
+ is_last = TRUE;
+ index_skip = action_count;
+ action |= MDEREF_FLAG_last;
+ }
+
+ if (pass)
+ action_ptr->uv |= (action << (action_ix * MDEREF_SHIFT));
+ action_ix++;
+ action_count++;
+ /* if there's no space for the next action, create a new slot
+ * for it *before* we start adding args for that action */
+ if ((action_ix + 1) * MDEREF_SHIFT > UVSIZE*8) {
+ action_ptr = arg;
+ if (pass)
+ arg->uv = 0;
+ arg++;
+ action_ix = 0;
+ }
+ } /* while !is_last */
+
+ /* success! */
+
+ if (pass) {
+ OP *mderef;
+ OP *p;
+
+ mderef = newUNOP_AUX(OP_MULTIDEREF, 0, NULL, arg_buf);
+ if (index_skip == -1) {
+ mderef->op_flags = o->op_flags
+ & (OPf_WANT|OPf_MOD|(next_is_hash ? OPf_SPECIAL : 0));
+ if (o->op_type == OP_EXISTS)
+ mderef->op_private = OPpMULTIDEREF_EXISTS;
+ else if (o->op_type == OP_DELETE)
+ mderef->op_private = OPpMULTIDEREF_DELETE;
+ else
+ mderef->op_private = o->op_private
+ & (OPpMAYBE_LVSUB|OPpLVAL_DEFER|OPpLVAL_INTRO);
+ }
+ /* accumulate strictness from every level (although I don't think
+ * they can actually vary) */
+ mderef->op_private |= hints;
+
+ /* integrate the new multideref op into the optree and the
+ * op_next chain.
+ *
+ * In general an op like aelem or helem has two child
+ * sub-trees: the aggregate expression (a_expr) and the
+ * index expression (i_expr):
+ *
+ * aelem
+ * |
+ * a_expr - i_expr
+ *
+ * The a_expr returns an AV or HV, while the i-expr returns an
+ * index. In general a multideref replaces most or all of a
+ * multi-level tree, e.g.
+ *
+ * exists
+ * |
+ * ex-aelem
+ * |
+ * rv2av - i_expr1
+ * |
+ * helem
+ * |
+ * rv2hv - i_expr2
+ * |
+ * aelem
+ * |
+ * a_expr - i_expr3
+ *
+ * With multideref, all the i_exprs will be simple vars or
+ * constants, except that i_expr1 may be arbitrary in the case
+ * of MDEREF_INDEX_none.
+ *
+ * The bottom-most a_expr will be either:
+ * 1) a simple var (so padXv or gv+rv2Xv);
+ * 2) a simple scalar var dereferenced (e.g. $r->[0]):
+ * so a simple var with an extra rv2Xv;
+ * 3) or an arbitrary expression.
+ *
+ * 'start', the first op in the execution chain, will point to
+ * 1),2): the padXv or gv op;
+ * 3): the rv2Xv which forms the last op in the a_expr
+ * execution chain, and the top-most op in the a_expr
+ * subtree.
+ *
+ * For all cases, the 'start' node is no longer required,
+ * but we can't free it since one or more external nodes
+ * may point to it. E.g. consider
+ * $h{foo} = $a ? $b : $c
+ * Here, both the op_next and op_other branches of the
+ * cond_expr point to the gv[*h] of the hash expression, so
+ * we can't free the 'start' op.
+ *
+ * For expr->[...], we need to save the subtree containing the
+ * expression; for the other cases, we just need to save the
+ * start node.
+ * So in all cases, we null the start op and keep it around by
+ * making it the child of the multideref op; for the expr->
+ * case, the expr will be a subtree of the start node.
+ *
+ * So in the simple 1,2 case the optree above changes to
+ *
+ * ex-exists
+ * |
+ * multideref
+ * |
+ * ex-gv (or ex-padxv)
+ *
+ * with the op_next chain being
+ *
+ * -> ex-gv -> multideref -> op-following-ex-exists ->
+ *
+ * In the 3 case, we have
+ *
+ * ex-exists
+ * |
+ * multideref
+ * |
+ * ex-rv2xv
+ * |
+ * rest-of-a_expr
+ * subtree
+ *
+ * and
+ *
+ * -> rest-of-a_expr subtree ->
+ * ex-rv2xv -> multideref -> op-following-ex-exists ->
+ *
+ *
+ * Where the last i_expr is non-simple (i.e. MDEREF_INDEX_none,
+ * e.g. $a[0]{foo}[$x+1], the next rv2xv is nulled and the
+ * multideref attached as the child, e.g.
+ *
+ * exists
+ * |
+ * ex-aelem
+ * |
+ * ex-rv2av - i_expr1
+ * |
+ * multideref
+ * |
+ * ex-whatever
+ *
+ */
+
+ /* if we free this op, don't free the pad entry */
+ if (reset_start_targ)
+ start->op_targ = 0;
+
+
+ /* Cut the bit we need to save out of the tree and attach to
+ * the multideref op, then free the rest of the tree */
+
+ /* find parent of node to be detached (for use by splice) */
+ p = first_elem_op;
+ if ( orig_action == MDEREF_AV_pop_rv2av_aelem
+ || orig_action == MDEREF_HV_pop_rv2hv_helem)
+ {
+ /* there is an arbitrary expression preceding us, e.g.
+ * expr->[..]? so we need to save the 'expr' subtree */
+ if (p->op_type == OP_EXISTS || p->op_type == OP_DELETE)
+ p = cUNOPx(p)->op_first;
+ assert( start->op_type == OP_RV2AV
+ || start->op_type == OP_RV2HV);
+ }
+ else {
+ /* either a padXv or rv2Xv+gv, maybe with an ex-Xelem
+ * above for exists/delete. */
+ while ( (p->op_flags & OPf_KIDS)
+ && cUNOPx(p)->op_first != start
+ )
+ p = cUNOPx(p)->op_first;
+ }
+ assert(cUNOPx(p)->op_first == start);
+
+ /* detach from main tree, and re-attach under the multideref */
+ op_sibling_splice(mderef, NULL, 0,
+ op_sibling_splice(p, NULL, 1, NULL));
+ op_null(start);
+
+ start->op_next = mderef;
+
+ mderef->op_next = index_skip == -1 ? o->op_next : o;
+
+ /* excise and free the original tree, and replace with
+ * the multideref op */
+ op_free(op_sibling_splice(top_op, NULL, -1, mderef));
+ op_null(top_op);
+ }
+ else {
+ Size_t size = arg - arg_buf;
+
+ if (maybe_aelemfast && action_count == 1)
+ return;
+
+ arg_buf = (UNOP_AUX_item*)PerlMemShared_malloc(
+ sizeof(UNOP_AUX_item) * (size + 1));
+ /* for dumping etc: store the length in a hidden first slot;
+ * we set the op_aux pointer to the second slot */
+ arg_buf->uv = size;
+ arg_buf++;
+ }
+ } /* for (pass = ...) */
+}
+
+
+
/* mechanism for deferring recursion in rpeep() */
#define MAX_DEFERRED 4
@@ -12125,6 +12831,183 @@ Perl_rpeep(pTHX_ OP *o)
o->op_opt = 1;
PL_op = o;
+ /* look for a series of 1 or more aggregate derefs, e.g.
+ * $a[1]{foo}[$i]{$k}
+ * and replace with a single OP_MULTIDEREF op.
+ * Each index must be either a const, or a simple variable,
+ *
+ * First, look for likely combinations of starting ops,
+ * corresponding to (global and lexical variants of)
+ * $a[...] $h{...}
+ * $r->[...] $r->{...}
+ * (preceding expression)->[...]
+ * (preceding expression)->{...}
+ * and if so, call maybe_multideref() to do a full inspection
+ * of the op chain and if appropriate, replace with an
+ * OP_MULTIDEREF
+ */
+ {
+ UV action;
+ OP *o2 = o;
+ U8 hints = 0;
+
+ switch (o2->op_type) {
+ case OP_GV:
+ /* $pkg[..] : gv[*pkg]
+ * $pkg->[...]: gv[*pkg]; rv2sv sKM/DREFAV */
+
+ /* Fail if there are new op flag combinations that we're
+ * not aware of, rather than:
+ * * silently failing to optimise, or
+ * * silently optimising the flag away.
+ * If this assert starts failing, examine what new flag
+ * has been added to the op, and decide whether the
+ * optimisation should still occur with that flag, then
+ * update the code accordingly. This applies to all the
+ * other asserts in the block of code too.
+ */
+ assert(!(o2->op_flags & ~(OPf_WANT|OPf_MOD)));
+ assert(!(o2->op_private & ~OPpEARLY_CV));
+
+ o2 = o2->op_next;
+
+ if (o2->op_type == OP_RV2AV) {
+ action = MDEREF_AV_gvav_aelem;
+ goto do_deref;
+ }
+
+ if (o2->op_type == OP_RV2HV) {
+ action = MDEREF_HV_gvhv_helem;
+ goto do_deref;
+ }
+
+ if (o2->op_type != OP_RV2SV)
+ break;
+
+ /* at this point we've seen gv,rv2sv, so the only valid
+ * construct left is $pkg->[] or $pkg->{} */
+
+ assert(!(o2->op_flags & OPf_STACKED));
+ if ((o2->op_flags & (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
+ != (OPf_WANT_SCALAR|OPf_MOD))
+ break;
+
+ assert(!(o2->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS
+ |OPpOUR_INTRO|OPpDEREF|OPpLVAL_INTRO)));
+ if (o2->op_private & (OPpOUR_INTRO|OPpLVAL_INTRO))
+ break;
+ if ( (o2->op_private & OPpDEREF) != OPpDEREF_AV
+ && (o2->op_private & OPpDEREF) != OPpDEREF_HV)
+ break;
+
+ o2 = o2->op_next;
+ if (o2->op_type == OP_RV2AV) {
+ action = MDEREF_AV_gvsv_vivify_rv2av_aelem;
+ goto do_deref;
+ }
+ if (o2->op_type == OP_RV2HV) {
+ action = MDEREF_HV_gvsv_vivify_rv2hv_helem;
+ goto do_deref;
+ }
+ break;
+
+ case OP_PADSV:
+ /* $lex->[...]: padsv[$lex] sM/DREFAV */
+
+ assert(!(o2->op_flags &
+ ~(OPf_WANT|OPf_PARENS|OPf_REF|OPf_MOD|OPf_SPECIAL)));
+ if ((o2->op_flags &
+ (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
+ != (OPf_WANT_SCALAR|OPf_MOD))
+ break;
+
+ assert(!(o2->op_private &
+ ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
+ /* skip if state or intro, or not a deref */
+ if ( o2->op_private != OPpDEREF_AV
+ && o2->op_private != OPpDEREF_HV)
+ break;
+
+ o2 = o2->op_next;
+ if (o2->op_type == OP_RV2AV) {
+ action = MDEREF_AV_padsv_vivify_rv2av_aelem;
+ goto do_deref;
+ }
+ if (o2->op_type == OP_RV2HV) {
+ action = MDEREF_HV_padsv_vivify_rv2hv_helem;
+ goto do_deref;
+ }
+ break;
+
+ case OP_PADAV:
+ case OP_PADHV:
+ /* $lex[..]: padav[@lex:1,2] sR *
+ * or $lex{..}: padhv[%lex:1,2] sR */
+ assert(!(o2->op_flags & ~(OPf_WANT|OPf_MOD|OPf_PARENS|
+ OPf_REF|OPf_SPECIAL)));
+ if ((o2->op_flags &
+ (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
+ != (OPf_WANT_SCALAR|OPf_REF))
+ break;
+ if (o2->op_flags != (OPf_WANT_SCALAR|OPf_REF))
+ break;
+ /* OPf_PARENS isn't currently used in this case;
+ * if that changes, let us know! */
+ assert(!(o2->op_flags & OPf_PARENS));
+
+ /* at this point, we wouldn't expect any of the remaining
+ * possible private flags:
+ * OPpPAD_STATE, OPpLVAL_INTRO, OPpTRUEBOOL,
+ * OPpMAYBE_TRUEBOOL, OPpMAYBE_LVSUB
+ *
+ * OPpSLICEWARNING shouldn't affect runtime
+ */
+ assert(!(o2->op_private & ~(OPpSLICEWARNING)));
+
+ action = o2->op_type == OP_PADAV
+ ? MDEREF_AV_padav_aelem
+ : MDEREF_HV_padhv_helem;
+ o2 = o2->op_next;
+ S_maybe_multideref(aTHX_ o, o2, action, 0);
+ break;
+
+
+ case OP_RV2AV:
+ case OP_RV2HV:
+ action = o2->op_type == OP_RV2AV
+ ? MDEREF_AV_pop_rv2av_aelem
+ : MDEREF_HV_pop_rv2hv_helem;
+ /* FALLTHROUGH */
+ do_deref:
+ /* (expr)->[...]: rv2av sKR/1;
+ * (expr)->{...}: rv2hv sKR/1; */
+
+ assert(o2->op_type == OP_RV2AV || o2->op_type == OP_RV2HV);
+
+ assert(!(o2->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
+ |OPf_REF|OPf_MOD|OPf_STACKED|OPf_SPECIAL)));
+ if (o2->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
+ break;
+
+ /* at this point, we wouldn't expect any of these
+ * possible private flags:
+ * OPpMAYBE_LVSUB, OPpOUR_INTRO, OPpLVAL_INTRO
+ * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL, (rv2hv only)
+ */
+ assert(!(o2->op_private &
+ ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING)));
+ hints |= (o2->op_private & OPpHINT_STRICT_REFS);
+
+ o2 = o2->op_next;
+
+ S_maybe_multideref(aTHX_ o, o2, action, hints);
+ break;
+
+ default:
+ break;
+ }
+ }
+
switch (o->op_type) {
case OP_DBSTATE:
diff --git a/op.h b/op.h
index 61a382fb76..9e60beb64d 100644
--- a/op.h
+++ b/op.h
@@ -124,9 +124,10 @@ Deprecated. Use C<GIMME_V> instead.
/* On OP_SMARTMATCH, an implicit smartmatch */
/* On OP_ANONHASH and OP_ANONLIST, create a
reference to the new anon hash or array */
- /* On OP_HELEM and OP_HSLICE, localization will be followed
- by assignment, so do not wipe the target if it is special
- (e.g. a glob or a magic SV) */
+ /* On OP_HELEM, OP_MULTIDEREF and OP_HSLICE,
+ localization will be followed by assignment,
+ so do not wipe the target if it is special
+ (e.g. a glob or a magic SV) */
/* On OP_MATCH, OP_SUBST & OP_TRANS, the
operand of a logical or conditional
that was optimised away, so it should
@@ -177,6 +178,14 @@ typedef union {
UV uv;
} UNOP_AUX_item;
+#ifdef USE_ITHREADS
+# define UNOP_AUX_item_sv(item) PAD_SVl((item)->pad_offset);
+#else
+# define UNOP_AUX_item_sv(item) ((item)->sv);
+#endif
+
+
+
struct op {
BASEOP
@@ -988,6 +997,47 @@ Sets the sibling of o to sib
# define OP_CHECK_MUTEX_TERM NOOP
#endif
+
+/* Stuff for OP_MULTDEREF/pp_multideref. */
+
+/* actions */
+
+/* Load another word of actions/flag bits. Must be 0 */
+#define MDEREF_reload 0
+
+#define MDEREF_AV_pop_rv2av_aelem 1
+#define MDEREF_AV_gvsv_vivify_rv2av_aelem 2
+#define MDEREF_AV_padsv_vivify_rv2av_aelem 3
+#define MDEREF_AV_vivify_rv2av_aelem 4
+#define MDEREF_AV_padav_aelem 5
+#define MDEREF_AV_gvav_aelem 6
+
+#define MDEREF_HV_pop_rv2hv_helem 8
+#define MDEREF_HV_gvsv_vivify_rv2hv_helem 9
+#define MDEREF_HV_padsv_vivify_rv2hv_helem 10
+#define MDEREF_HV_vivify_rv2hv_helem 11
+#define MDEREF_HV_padhv_helem 12
+#define MDEREF_HV_gvhv_helem 13
+
+#define MDEREF_ACTION_MASK 0xf
+
+/* key / index type */
+
+#define MDEREF_INDEX_none 0x00 /* run external ops to generate index */
+#define MDEREF_INDEX_const 0x10 /* index is const PV/UV */
+#define MDEREF_INDEX_padsv 0x20 /* index is lexical var */
+#define MDEREF_INDEX_gvsv 0x30 /* index is GV */
+
+#define MDEREF_INDEX_MASK 0x30
+
+/* bit flags */
+
+#define MDEREF_FLAG_last 0x40 /* the last [ah]elem; PL_op flags apply */
+
+#define MDEREF_MASK 0x7F
+#define MDEREF_SHIFT 7
+
+
/*
* Local variables:
* c-indentation-style: bsd
diff --git a/opcode.h b/opcode.h
index e67318ffc8..4266c49cf6 100644
--- a/opcode.h
+++ b/opcode.h
@@ -293,6 +293,7 @@ EXTCONST char* const PL_op_name[] = {
"helem",
"hslice",
"kvhslice",
+ "multideref",
"unpack",
"pack",
"split",
@@ -687,6 +688,7 @@ EXTCONST char* const PL_op_desc[] = {
"hash element",
"hash slice",
"key/value hash slice",
+ "array or hash lookup",
"unpack",
"pack",
"split",
@@ -1095,6 +1097,7 @@ EXT Perl_ppaddr_t PL_ppaddr[] /* or perlvars.h */
Perl_pp_helem,
Perl_pp_hslice,
Perl_pp_kvhslice,
+ Perl_pp_multideref,
Perl_pp_unpack,
Perl_pp_pack,
Perl_pp_split,
@@ -1499,6 +1502,7 @@ EXT Perl_check_t PL_check[] /* or perlvars.h */
Perl_ck_null, /* helem */
Perl_ck_null, /* hslice */
Perl_ck_null, /* kvhslice */
+ Perl_ck_null, /* multideref */
Perl_ck_fun, /* unpack */
Perl_ck_fun, /* pack */
Perl_ck_split, /* split */
@@ -1897,6 +1901,7 @@ EXTCONST U32 PL_opargs[] = {
0x00014204, /* helem */
0x00024401, /* hslice */
0x00024401, /* kvhslice */
+ 0x00000f44, /* multideref */
0x00091480, /* unpack */
0x0002140f, /* pack */
0x00111418, /* split */
@@ -2190,6 +2195,7 @@ END_EXTERN_C
#define OPpFT_AFTER_t 0x10
#define OPpLVREF_AV 0x10
#define OPpMAYBE_TRUEBOOL 0x10
+#define OPpMULTIDEREF_EXISTS 0x10
#define OPpOPEN_IN_RAW 0x10
#define OPpSORT_DESCEND 0x10
#define OPpSUBSTR_REPL_FIRST 0x10
@@ -2200,6 +2206,7 @@ END_EXTERN_C
#define OPpHUSH_VMSISH 0x20
#define OPpLVREF_HV 0x20
#define OPpMAY_RETURN_CONSTANT 0x20
+#define OPpMULTIDEREF_DELETE 0x20
#define OPpOPEN_IN_CRLF 0x20
#define OPpSORT_QSORT 0x20
#define OPpTRANS_COMPLEMENT 0x20
@@ -2282,6 +2289,7 @@ EXTCONST char PL_op_private_labels[] = {
'D','B','G','\0',
'D','E','F','\0',
'D','E','L','\0',
+ 'D','E','L','E','T','E','\0',
'D','E','R','E','F','1','\0',
'D','E','R','E','F','2','\0',
'D','E','S','C','\0',
@@ -2292,6 +2300,7 @@ EXTCONST char PL_op_private_labels[] = {
'E','A','R','L','Y','C','V','\0',
'E','L','E','M','\0',
'E','N','T','E','R','E','D','\0',
+ 'E','X','I','S','T','S','\0',
'F','A','K','E','\0',
'F','T','A','C','C','E','S','S','\0',
'F','T','A','F','T','E','R','t','\0',
@@ -2366,8 +2375,8 @@ EXTCONST I16 PL_op_private_bitfields[] = {
0, 8, -1,
0, 8, -1,
0, 8, -1,
- 4, -1, 1, 130, 2, 137, 3, 144, -1,
- 4, -1, 0, 481, 1, 26, 2, 250, 3, 83, -1,
+ 4, -1, 1, 137, 2, 144, 3, 151, -1,
+ 4, -1, 0, 495, 1, 26, 2, 264, 3, 83, -1,
};
@@ -2521,11 +2530,12 @@ EXTCONST I16 PL_op_private_bitdef_ix[] = {
94, /* helem */
99, /* hslice */
102, /* kvhslice */
+ 116, /* multideref */
48, /* unpack */
48, /* pack */
- 116, /* split */
+ 123, /* split */
48, /* join */
- 119, /* list */
+ 126, /* list */
12, /* lslice */
48, /* anonlist */
48, /* anonhash */
@@ -2534,48 +2544,48 @@ EXTCONST I16 PL_op_private_bitdef_ix[] = {
0, /* pop */
0, /* shift */
79, /* unshift */
- 121, /* sort */
- 128, /* reverse */
- 130, /* grepstart */
- 131, /* grepwhile */
- 130, /* mapstart */
- 131, /* mapwhile */
+ 128, /* sort */
+ 135, /* reverse */
+ 137, /* grepstart */
+ 138, /* grepwhile */
+ 137, /* mapstart */
+ 138, /* mapwhile */
0, /* range */
- 133, /* flip */
- 133, /* flop */
+ 140, /* flip */
+ 140, /* flop */
0, /* and */
0, /* or */
12, /* xor */
0, /* dor */
- 135, /* cond_expr */
+ 142, /* cond_expr */
0, /* andassign */
0, /* orassign */
0, /* dorassign */
0, /* method */
- 137, /* entersub */
- 144, /* leavesub */
- 144, /* leavesublv */
- 146, /* caller */
+ 144, /* entersub */
+ 151, /* leavesub */
+ 151, /* leavesublv */
+ 153, /* caller */
48, /* warn */
48, /* die */
48, /* reset */
-1, /* lineseq */
- 148, /* nextstate */
- 148, /* dbstate */
+ 155, /* nextstate */
+ 155, /* dbstate */
-1, /* unstack */
-1, /* enter */
- 149, /* leave */
+ 156, /* leave */
-1, /* scope */
- 151, /* enteriter */
- 155, /* iter */
+ 158, /* enteriter */
+ 162, /* iter */
-1, /* enterloop */
- 156, /* leaveloop */
+ 163, /* leaveloop */
-1, /* return */
- 158, /* last */
- 158, /* next */
- 158, /* redo */
- 158, /* dump */
- 158, /* goto */
+ 165, /* last */
+ 165, /* next */
+ 165, /* redo */
+ 165, /* dump */
+ 165, /* goto */
48, /* exit */
0, /* method_named */
0, /* method_super */
@@ -2587,7 +2597,7 @@ EXTCONST I16 PL_op_private_bitdef_ix[] = {
0, /* leavewhen */
-1, /* break */
-1, /* continue */
- 160, /* open */
+ 167, /* open */
48, /* close */
48, /* pipe_op */
48, /* fileno */
@@ -2603,7 +2613,7 @@ EXTCONST I16 PL_op_private_bitdef_ix[] = {
48, /* getc */
48, /* read */
48, /* enterwrite */
- 144, /* leavewrite */
+ 151, /* leavewrite */
-1, /* prtf */
-1, /* print */
-1, /* say */
@@ -2633,33 +2643,33 @@ EXTCONST I16 PL_op_private_bitdef_ix[] = {
0, /* getpeername */
0, /* lstat */
0, /* stat */
- 165, /* ftrread */
- 165, /* ftrwrite */
- 165, /* ftrexec */
- 165, /* fteread */
- 165, /* ftewrite */
- 165, /* fteexec */
- 170, /* ftis */
- 170, /* ftsize */
- 170, /* ftmtime */
- 170, /* ftatime */
- 170, /* ftctime */
- 170, /* ftrowned */
- 170, /* fteowned */
- 170, /* ftzero */
- 170, /* ftsock */
- 170, /* ftchr */
- 170, /* ftblk */
- 170, /* ftfile */
- 170, /* ftdir */
- 170, /* ftpipe */
- 170, /* ftsuid */
- 170, /* ftsgid */
- 170, /* ftsvtx */
- 170, /* ftlink */
- 170, /* fttty */
- 170, /* fttext */
- 170, /* ftbinary */
+ 172, /* ftrread */
+ 172, /* ftrwrite */
+ 172, /* ftrexec */
+ 172, /* fteread */
+ 172, /* ftewrite */
+ 172, /* fteexec */
+ 177, /* ftis */
+ 177, /* ftsize */
+ 177, /* ftmtime */
+ 177, /* ftatime */
+ 177, /* ftctime */
+ 177, /* ftrowned */
+ 177, /* fteowned */
+ 177, /* ftzero */
+ 177, /* ftsock */
+ 177, /* ftchr */
+ 177, /* ftblk */
+ 177, /* ftfile */
+ 177, /* ftdir */
+ 177, /* ftpipe */
+ 177, /* ftsuid */
+ 177, /* ftsgid */
+ 177, /* ftsvtx */
+ 177, /* ftlink */
+ 177, /* fttty */
+ 177, /* fttext */
+ 177, /* ftbinary */
79, /* chdir */
79, /* chown */
72, /* chroot */
@@ -2679,17 +2689,17 @@ EXTCONST I16 PL_op_private_bitdef_ix[] = {
0, /* rewinddir */
0, /* closedir */
-1, /* fork */
- 174, /* wait */
+ 181, /* wait */
79, /* waitpid */
79, /* system */
79, /* exec */
79, /* kill */
- 174, /* getppid */
+ 181, /* getppid */
79, /* getpgrp */
79, /* setpgrp */
79, /* getpriority */
79, /* setpriority */
- 174, /* time */
+ 181, /* time */
-1, /* tms */
0, /* localtime */
48, /* gmtime */
@@ -2709,8 +2719,8 @@ EXTCONST I16 PL_op_private_bitdef_ix[] = {
0, /* require */
0, /* dofile */
-1, /* hintseval */
- 175, /* entereval */
- 144, /* leaveeval */
+ 182, /* entereval */
+ 151, /* leaveeval */
0, /* entertry */
-1, /* leavetry */
0, /* ghbyname */
@@ -2751,17 +2761,17 @@ EXTCONST I16 PL_op_private_bitdef_ix[] = {
0, /* reach */
39, /* rkeys */
0, /* rvalues */
- 181, /* coreargs */
+ 188, /* coreargs */
3, /* runcv */
0, /* fc */
-1, /* padcv */
-1, /* introcv */
-1, /* clonecv */
- 185, /* padrange */
- 187, /* refassign */
- 193, /* lvref */
- 199, /* lvrefslice */
- 200, /* lvavref */
+ 192, /* padrange */
+ 194, /* refassign */
+ 200, /* lvref */
+ 206, /* lvrefslice */
+ 207, /* lvavref */
};
@@ -2781,69 +2791,70 @@ EXTCONST I16 PL_op_private_bitdef_ix[] = {
EXTCONST U16 PL_op_private_bitdefs[] = {
0x0003, /* scalar, prototype, refgen, srefgen, ref, readline, regcmaybe, regcreset, regcomp, chop, schop, defined, undef, study, preinc, i_preinc, predec, i_predec, postinc, i_postinc, postdec, i_postdec, negate, i_negate, not, complement, ucfirst, lcfirst, uc, lc, quotemeta, aeach, akeys, avalues, each, values, pop, shift, range, and, or, dor, andassign, orassign, dorassign, method, method_named, method_super, method_redir, method_redir_super, entergiven, leavegiven, enterwhen, leavewhen, untie, tied, dbmclose, getsockname, getpeername, lstat, stat, readlink, readdir, telldir, rewinddir, closedir, localtime, alarm, require, dofile, entertry, ghbyname, gnbyname, gpbyname, shostent, snetent, sprotoent, sservent, gpwnam, gpwuid, ggrnam, ggrgid, lock, once, reach, rvalues, fc */
- 0x281c, 0x3a19, /* pushmark */
+ 0x29dc, 0x3bd9, /* pushmark */
0x00bd, /* wantarray, runcv */
- 0x03b8, 0x1490, 0x3acc, 0x3588, 0x2be5, /* const */
- 0x281c, 0x2d39, /* gvsv */
- 0x12f5, /* gv */
+ 0x03b8, 0x1570, 0x3c8c, 0x3748, 0x2da5, /* const */
+ 0x29dc, 0x2ef9, /* gvsv */
+ 0x13d5, /* gv */
0x0067, /* gelem, lt, i_lt, gt, i_gt, le, i_le, ge, i_ge, eq, i_eq, ne, i_ne, ncmp, i_ncmp, slt, sgt, sle, sge, seq, sne, scmp, bit_and, bit_xor, bit_or, smartmatch, lslice, xor */
- 0x281c, 0x3a18, 0x0257, /* padsv */
- 0x281c, 0x3a18, 0x290c, 0x3709, /* padav */
- 0x281c, 0x3a18, 0x0534, 0x05d0, 0x290c, 0x3709, /* padhv */
- 0x34d9, /* pushre, qr */
- 0x281c, 0x1598, 0x0256, 0x290c, 0x2b08, 0x3ac4, 0x0003, /* rv2gv */
- 0x281c, 0x2d38, 0x0256, 0x3ac4, 0x0003, /* rv2sv */
- 0x290c, 0x0003, /* av2arylen, pos, keys, rkeys */
- 0x2a7c, 0x0b98, 0x08f4, 0x028c, 0x3c88, 0x3ac4, 0x0003, /* rv2cv */
+ 0x29dc, 0x3bd8, 0x0257, /* padsv */
+ 0x29dc, 0x3bd8, 0x2acc, 0x38c9, /* padav */
+ 0x29dc, 0x3bd8, 0x0534, 0x05d0, 0x2acc, 0x38c9, /* padhv */
+ 0x3699, /* pushre, qr */
+ 0x29dc, 0x1758, 0x0256, 0x2acc, 0x2cc8, 0x3c84, 0x0003, /* rv2gv */
+ 0x29dc, 0x2ef8, 0x0256, 0x3c84, 0x0003, /* rv2sv */
+ 0x2acc, 0x0003, /* av2arylen, pos, keys, rkeys */
+ 0x2c3c, 0x0b98, 0x08f4, 0x028c, 0x3e48, 0x3c84, 0x0003, /* rv2cv */
0x012f, /* bless, glob, sprintf, formline, unpack, pack, join, anonlist, anonhash, splice, warn, die, reset, exit, close, pipe_op, fileno, umask, binmode, tie, dbmopen, sselect, select, getc, read, enterwrite, sysopen, sysseek, sysread, syswrite, eof, tell, seek, truncate, fcntl, ioctl, send, recv, socket, sockpair, bind, connect, listen, accept, shutdown, gsockopt, ssockopt, open_dir, seekdir, gmtime, shmget, shmctl, shmread, shmwrite, msgget, msgctl, msgsnd, msgrcv, semop, semget, semctl, ghbyaddr, gnbyaddr, gpbynumber, gsbyname, gsbyport, syscall */
- 0x2f1c, 0x2e38, 0x22f4, 0x2230, 0x0003, /* backtick */
- 0x34d8, 0x3d31, /* match, subst */
- 0x34d8, 0x0003, /* substcont */
- 0x0c9c, 0x1c18, 0x0834, 0x3d30, 0x384c, 0x1fa8, 0x01e4, 0x0141, /* trans, transr */
+ 0x30dc, 0x2ff8, 0x24b4, 0x23f0, 0x0003, /* backtick */
+ 0x3698, 0x3ef1, /* match, subst */
+ 0x3698, 0x0003, /* substcont */
+ 0x0c9c, 0x1dd8, 0x0834, 0x3ef0, 0x3a0c, 0x2168, 0x01e4, 0x0141, /* trans, transr */
0x0adc, 0x0458, 0x0067, /* sassign */
- 0x0758, 0x290c, 0x0067, /* aassign */
- 0x3d30, 0x0003, /* chomp, schomp, sin, cos, exp, log, sqrt, int, hex, oct, abs, length, ord, chr, chroot, rmdir */
- 0x3d30, 0x0067, /* pow, multiply, i_multiply, divide, i_divide, modulo, i_modulo, add, i_add, subtract, i_subtract, concat, left_shift, right_shift */
- 0x0f78, 0x3d30, 0x0067, /* repeat */
- 0x3d30, 0x012f, /* stringify, atan2, rand, srand, index, rindex, crypt, push, unshift, flock, chdir, chown, unlink, chmod, utime, rename, link, symlink, mkdir, waitpid, system, exec, kill, getpgrp, setpgrp, getpriority, setpriority, sleep */
- 0x3230, 0x290c, 0x00cb, /* substr */
- 0x3d30, 0x290c, 0x0067, /* vec */
- 0x281c, 0x2d38, 0x290c, 0x3708, 0x3ac4, 0x0003, /* rv2av */
+ 0x0758, 0x2acc, 0x0067, /* aassign */
+ 0x3ef0, 0x0003, /* chomp, schomp, sin, cos, exp, log, sqrt, int, hex, oct, abs, length, ord, chr, chroot, rmdir */
+ 0x3ef0, 0x0067, /* pow, multiply, i_multiply, divide, i_divide, modulo, i_modulo, add, i_add, subtract, i_subtract, concat, left_shift, right_shift */
+ 0x1058, 0x3ef0, 0x0067, /* repeat */
+ 0x3ef0, 0x012f, /* stringify, atan2, rand, srand, index, rindex, crypt, push, unshift, flock, chdir, chown, unlink, chmod, utime, rename, link, symlink, mkdir, waitpid, system, exec, kill, getpgrp, setpgrp, getpriority, setpriority, sleep */
+ 0x33f0, 0x2acc, 0x00cb, /* substr */
+ 0x3ef0, 0x2acc, 0x0067, /* vec */
+ 0x29dc, 0x2ef8, 0x2acc, 0x38c8, 0x3c84, 0x0003, /* rv2av */
0x01ff, /* aelemfast, aelemfast_lex */
- 0x281c, 0x2718, 0x0256, 0x290c, 0x0067, /* aelem, helem */
- 0x281c, 0x290c, 0x3709, /* aslice, hslice */
- 0x290d, /* kvaslice, kvhslice */
- 0x281c, 0x3658, 0x0003, /* delete */
- 0x3bb8, 0x0003, /* exists */
- 0x281c, 0x2d38, 0x0534, 0x05d0, 0x290c, 0x3708, 0x3ac4, 0x0003, /* rv2hv */
- 0x207c, 0x2d38, 0x3d31, /* split */
- 0x281c, 0x1cd9, /* list */
- 0x3938, 0x2fd4, 0x0ed0, 0x238c, 0x3328, 0x2484, 0x2ca1, /* sort */
- 0x238c, 0x0003, /* reverse */
- 0x1b05, /* grepstart, mapstart */
- 0x1b04, 0x0003, /* grepwhile, mapwhile */
- 0x25b8, 0x0003, /* flip, flop */
- 0x281c, 0x0003, /* cond_expr */
- 0x281c, 0x0b98, 0x0256, 0x028c, 0x3c88, 0x3ac4, 0x2141, /* entersub */
- 0x3098, 0x0003, /* leavesub, leavesublv, leavewrite, leaveeval */
+ 0x29dc, 0x28d8, 0x0256, 0x2acc, 0x0067, /* aelem, helem */
+ 0x29dc, 0x2acc, 0x38c9, /* aslice, hslice */
+ 0x2acd, /* kvaslice, kvhslice */
+ 0x29dc, 0x3818, 0x0003, /* delete */
+ 0x3d78, 0x0003, /* exists */
+ 0x29dc, 0x2ef8, 0x0534, 0x05d0, 0x2acc, 0x38c8, 0x3c84, 0x0003, /* rv2hv */
+ 0x29dc, 0x28d8, 0x0d14, 0x1670, 0x2acc, 0x3c84, 0x0003, /* multideref */
+ 0x223c, 0x2ef8, 0x3ef1, /* split */
+ 0x29dc, 0x1e99, /* list */
+ 0x3af8, 0x3194, 0x0fb0, 0x254c, 0x34e8, 0x2644, 0x2e61, /* sort */
+ 0x254c, 0x0003, /* reverse */
+ 0x1cc5, /* grepstart, mapstart */
+ 0x1cc4, 0x0003, /* grepwhile, mapwhile */
+ 0x2778, 0x0003, /* flip, flop */
+ 0x29dc, 0x0003, /* cond_expr */
+ 0x29dc, 0x0b98, 0x0256, 0x028c, 0x3e48, 0x3c84, 0x2301, /* entersub */
+ 0x3258, 0x0003, /* leavesub, leavesublv, leavewrite, leaveeval */
0x00bc, 0x012f, /* caller */
- 0x1eb5, /* nextstate, dbstate */
- 0x26bc, 0x3099, /* leave */
- 0x281c, 0x2d38, 0x0c0c, 0x33a9, /* enteriter */
- 0x33a9, /* iter */
- 0x26bc, 0x0067, /* leaveloop */
- 0x3e9c, 0x0003, /* last, next, redo, dump, goto */
- 0x2f1c, 0x2e38, 0x22f4, 0x2230, 0x012f, /* open */
- 0x1750, 0x19ac, 0x1868, 0x1624, 0x0003, /* ftrread, ftrwrite, ftrexec, fteread, ftewrite, fteexec */
- 0x1750, 0x19ac, 0x1868, 0x0003, /* ftis, ftsize, ftmtime, ftatime, ftctime, ftrowned, fteowned, ftzero, ftsock, ftchr, ftblk, ftfile, ftdir, ftpipe, ftsuid, ftsgid, ftsvtx, ftlink, fttty, fttext, ftbinary */
- 0x3d31, /* wait, getppid, time */
- 0x3134, 0x09b0, 0x068c, 0x3e08, 0x1dc4, 0x0003, /* entereval */
- 0x29dc, 0x0018, 0x0de4, 0x0d01, /* coreargs */
- 0x281c, 0x019b, /* padrange */
- 0x281c, 0x3a18, 0x0376, 0x250c, 0x13e8, 0x0067, /* refassign */
- 0x281c, 0x3a18, 0x0376, 0x250c, 0x13e8, 0x0003, /* lvref */
- 0x281d, /* lvrefslice */
- 0x281c, 0x3a18, 0x0003, /* lvavref */
+ 0x2075, /* nextstate, dbstate */
+ 0x287c, 0x3259, /* leave */
+ 0x29dc, 0x2ef8, 0x0c0c, 0x3569, /* enteriter */
+ 0x3569, /* iter */
+ 0x287c, 0x0067, /* leaveloop */
+ 0x405c, 0x0003, /* last, next, redo, dump, goto */
+ 0x30dc, 0x2ff8, 0x24b4, 0x23f0, 0x012f, /* open */
+ 0x1910, 0x1b6c, 0x1a28, 0x17e4, 0x0003, /* ftrread, ftrwrite, ftrexec, fteread, ftewrite, fteexec */
+ 0x1910, 0x1b6c, 0x1a28, 0x0003, /* ftis, ftsize, ftmtime, ftatime, ftctime, ftrowned, fteowned, ftzero, ftsock, ftchr, ftblk, ftfile, ftdir, ftpipe, ftsuid, ftsgid, ftsvtx, ftlink, fttty, fttext, ftbinary */
+ 0x3ef1, /* wait, getppid, time */
+ 0x32f4, 0x09b0, 0x068c, 0x3fc8, 0x1f84, 0x0003, /* entereval */
+ 0x2b9c, 0x0018, 0x0ec4, 0x0de1, /* coreargs */
+ 0x29dc, 0x019b, /* padrange */
+ 0x29dc, 0x3bd8, 0x0376, 0x26cc, 0x14c8, 0x0067, /* refassign */
+ 0x29dc, 0x3bd8, 0x0376, 0x26cc, 0x14c8, 0x0003, /* lvref */
+ 0x29dd, /* lvrefslice */
+ 0x29dc, 0x3bd8, 0x0003, /* lvavref */
};
@@ -2997,6 +3008,7 @@ EXTCONST U8 PL_op_private_valid[] = {
/* HELEM */ (OPpARG2_MASK|OPpMAYBE_LVSUB|OPpDEREF|OPpLVAL_DEFER|OPpLVAL_INTRO),
/* HSLICE */ (OPpSLICEWARNING|OPpMAYBE_LVSUB|OPpLVAL_INTRO),
/* KVHSLICE */ (OPpMAYBE_LVSUB),
+ /* MULTIDEREF */ (OPpARG1_MASK|OPpHINT_STRICT_REFS|OPpMAYBE_LVSUB|OPpMULTIDEREF_EXISTS|OPpMULTIDEREF_DELETE|OPpLVAL_DEFER|OPpLVAL_INTRO),
/* UNPACK */ (OPpARG4_MASK),
/* PACK */ (OPpARG4_MASK),
/* SPLIT */ (OPpTARGET_MY|OPpOUR_INTRO|OPpSPLIT_IMPLIM),
diff --git a/opnames.h b/opnames.h
index dce44f19e9..1d259a15dd 100644
--- a/opnames.h
+++ b/opnames.h
@@ -159,251 +159,252 @@ typedef enum opcode {
OP_HELEM = 142,
OP_HSLICE = 143,
OP_KVHSLICE = 144,
- OP_UNPACK = 145,
- OP_PACK = 146,
- OP_SPLIT = 147,
- OP_JOIN = 148,
- OP_LIST = 149,
- OP_LSLICE = 150,
- OP_ANONLIST = 151,
- OP_ANONHASH = 152,
- OP_SPLICE = 153,
- OP_PUSH = 154,
- OP_POP = 155,
- OP_SHIFT = 156,
- OP_UNSHIFT = 157,
- OP_SORT = 158,
- OP_REVERSE = 159,
- OP_GREPSTART = 160,
- OP_GREPWHILE = 161,
- OP_MAPSTART = 162,
- OP_MAPWHILE = 163,
- OP_RANGE = 164,
- OP_FLIP = 165,
- OP_FLOP = 166,
- OP_AND = 167,
- OP_OR = 168,
- OP_XOR = 169,
- OP_DOR = 170,
- OP_COND_EXPR = 171,
- OP_ANDASSIGN = 172,
- OP_ORASSIGN = 173,
- OP_DORASSIGN = 174,
- OP_METHOD = 175,
- OP_ENTERSUB = 176,
- OP_LEAVESUB = 177,
- OP_LEAVESUBLV = 178,
- OP_CALLER = 179,
- OP_WARN = 180,
- OP_DIE = 181,
- OP_RESET = 182,
- OP_LINESEQ = 183,
- OP_NEXTSTATE = 184,
- OP_DBSTATE = 185,
- OP_UNSTACK = 186,
- OP_ENTER = 187,
- OP_LEAVE = 188,
- OP_SCOPE = 189,
- OP_ENTERITER = 190,
- OP_ITER = 191,
- OP_ENTERLOOP = 192,
- OP_LEAVELOOP = 193,
- OP_RETURN = 194,
- OP_LAST = 195,
- OP_NEXT = 196,
- OP_REDO = 197,
- OP_DUMP = 198,
- OP_GOTO = 199,
- OP_EXIT = 200,
- OP_METHOD_NAMED = 201,
- OP_METHOD_SUPER = 202,
- OP_METHOD_REDIR = 203,
- OP_METHOD_REDIR_SUPER = 204,
- OP_ENTERGIVEN = 205,
- OP_LEAVEGIVEN = 206,
- OP_ENTERWHEN = 207,
- OP_LEAVEWHEN = 208,
- OP_BREAK = 209,
- OP_CONTINUE = 210,
- OP_OPEN = 211,
- OP_CLOSE = 212,
- OP_PIPE_OP = 213,
- OP_FILENO = 214,
- OP_UMASK = 215,
- OP_BINMODE = 216,
- OP_TIE = 217,
- OP_UNTIE = 218,
- OP_TIED = 219,
- OP_DBMOPEN = 220,
- OP_DBMCLOSE = 221,
- OP_SSELECT = 222,
- OP_SELECT = 223,
- OP_GETC = 224,
- OP_READ = 225,
- OP_ENTERWRITE = 226,
- OP_LEAVEWRITE = 227,
- OP_PRTF = 228,
- OP_PRINT = 229,
- OP_SAY = 230,
- OP_SYSOPEN = 231,
- OP_SYSSEEK = 232,
- OP_SYSREAD = 233,
- OP_SYSWRITE = 234,
- OP_EOF = 235,
- OP_TELL = 236,
- OP_SEEK = 237,
- OP_TRUNCATE = 238,
- OP_FCNTL = 239,
- OP_IOCTL = 240,
- OP_FLOCK = 241,
- OP_SEND = 242,
- OP_RECV = 243,
- OP_SOCKET = 244,
- OP_SOCKPAIR = 245,
- OP_BIND = 246,
- OP_CONNECT = 247,
- OP_LISTEN = 248,
- OP_ACCEPT = 249,
- OP_SHUTDOWN = 250,
- OP_GSOCKOPT = 251,
- OP_SSOCKOPT = 252,
- OP_GETSOCKNAME = 253,
- OP_GETPEERNAME = 254,
- OP_LSTAT = 255,
- OP_STAT = 256,
- OP_FTRREAD = 257,
- OP_FTRWRITE = 258,
- OP_FTREXEC = 259,
- OP_FTEREAD = 260,
- OP_FTEWRITE = 261,
- OP_FTEEXEC = 262,
- OP_FTIS = 263,
- OP_FTSIZE = 264,
- OP_FTMTIME = 265,
- OP_FTATIME = 266,
- OP_FTCTIME = 267,
- OP_FTROWNED = 268,
- OP_FTEOWNED = 269,
- OP_FTZERO = 270,
- OP_FTSOCK = 271,
- OP_FTCHR = 272,
- OP_FTBLK = 273,
- OP_FTFILE = 274,
- OP_FTDIR = 275,
- OP_FTPIPE = 276,
- OP_FTSUID = 277,
- OP_FTSGID = 278,
- OP_FTSVTX = 279,
- OP_FTLINK = 280,
- OP_FTTTY = 281,
- OP_FTTEXT = 282,
- OP_FTBINARY = 283,
- OP_CHDIR = 284,
- OP_CHOWN = 285,
- OP_CHROOT = 286,
- OP_UNLINK = 287,
- OP_CHMOD = 288,
- OP_UTIME = 289,
- OP_RENAME = 290,
- OP_LINK = 291,
- OP_SYMLINK = 292,
- OP_READLINK = 293,
- OP_MKDIR = 294,
- OP_RMDIR = 295,
- OP_OPEN_DIR = 296,
- OP_READDIR = 297,
- OP_TELLDIR = 298,
- OP_SEEKDIR = 299,
- OP_REWINDDIR = 300,
- OP_CLOSEDIR = 301,
- OP_FORK = 302,
- OP_WAIT = 303,
- OP_WAITPID = 304,
- OP_SYSTEM = 305,
- OP_EXEC = 306,
- OP_KILL = 307,
- OP_GETPPID = 308,
- OP_GETPGRP = 309,
- OP_SETPGRP = 310,
- OP_GETPRIORITY = 311,
- OP_SETPRIORITY = 312,
- OP_TIME = 313,
- OP_TMS = 314,
- OP_LOCALTIME = 315,
- OP_GMTIME = 316,
- OP_ALARM = 317,
- OP_SLEEP = 318,
- OP_SHMGET = 319,
- OP_SHMCTL = 320,
- OP_SHMREAD = 321,
- OP_SHMWRITE = 322,
- OP_MSGGET = 323,
- OP_MSGCTL = 324,
- OP_MSGSND = 325,
- OP_MSGRCV = 326,
- OP_SEMOP = 327,
- OP_SEMGET = 328,
- OP_SEMCTL = 329,
- OP_REQUIRE = 330,
- OP_DOFILE = 331,
- OP_HINTSEVAL = 332,
- OP_ENTEREVAL = 333,
- OP_LEAVEEVAL = 334,
- OP_ENTERTRY = 335,
- OP_LEAVETRY = 336,
- OP_GHBYNAME = 337,
- OP_GHBYADDR = 338,
- OP_GHOSTENT = 339,
- OP_GNBYNAME = 340,
- OP_GNBYADDR = 341,
- OP_GNETENT = 342,
- OP_GPBYNAME = 343,
- OP_GPBYNUMBER = 344,
- OP_GPROTOENT = 345,
- OP_GSBYNAME = 346,
- OP_GSBYPORT = 347,
- OP_GSERVENT = 348,
- OP_SHOSTENT = 349,
- OP_SNETENT = 350,
- OP_SPROTOENT = 351,
- OP_SSERVENT = 352,
- OP_EHOSTENT = 353,
- OP_ENETENT = 354,
- OP_EPROTOENT = 355,
- OP_ESERVENT = 356,
- OP_GPWNAM = 357,
- OP_GPWUID = 358,
- OP_GPWENT = 359,
- OP_SPWENT = 360,
- OP_EPWENT = 361,
- OP_GGRNAM = 362,
- OP_GGRGID = 363,
- OP_GGRENT = 364,
- OP_SGRENT = 365,
- OP_EGRENT = 366,
- OP_GETLOGIN = 367,
- OP_SYSCALL = 368,
- OP_LOCK = 369,
- OP_ONCE = 370,
- OP_CUSTOM = 371,
- OP_REACH = 372,
- OP_RKEYS = 373,
- OP_RVALUES = 374,
- OP_COREARGS = 375,
- OP_RUNCV = 376,
- OP_FC = 377,
- OP_PADCV = 378,
- OP_INTROCV = 379,
- OP_CLONECV = 380,
- OP_PADRANGE = 381,
- OP_REFASSIGN = 382,
- OP_LVREF = 383,
- OP_LVREFSLICE = 384,
- OP_LVAVREF = 385,
+ OP_MULTIDEREF = 145,
+ OP_UNPACK = 146,
+ OP_PACK = 147,
+ OP_SPLIT = 148,
+ OP_JOIN = 149,
+ OP_LIST = 150,
+ OP_LSLICE = 151,
+ OP_ANONLIST = 152,
+ OP_ANONHASH = 153,
+ OP_SPLICE = 154,
+ OP_PUSH = 155,
+ OP_POP = 156,
+ OP_SHIFT = 157,
+ OP_UNSHIFT = 158,
+ OP_SORT = 159,
+ OP_REVERSE = 160,
+ OP_GREPSTART = 161,
+ OP_GREPWHILE = 162,
+ OP_MAPSTART = 163,
+ OP_MAPWHILE = 164,
+ OP_RANGE = 165,
+ OP_FLIP = 166,
+ OP_FLOP = 167,
+ OP_AND = 168,
+ OP_OR = 169,
+ OP_XOR = 170,
+ OP_DOR = 171,
+ OP_COND_EXPR = 172,
+ OP_ANDASSIGN = 173,
+ OP_ORASSIGN = 174,
+ OP_DORASSIGN = 175,
+ OP_METHOD = 176,
+ OP_ENTERSUB = 177,
+ OP_LEAVESUB = 178,
+ OP_LEAVESUBLV = 179,
+ OP_CALLER = 180,
+ OP_WARN = 181,
+ OP_DIE = 182,
+ OP_RESET = 183,
+ OP_LINESEQ = 184,
+ OP_NEXTSTATE = 185,
+ OP_DBSTATE = 186,
+ OP_UNSTACK = 187,
+ OP_ENTER = 188,
+ OP_LEAVE = 189,
+ OP_SCOPE = 190,
+ OP_ENTERITER = 191,
+ OP_ITER = 192,
+ OP_ENTERLOOP = 193,
+ OP_LEAVELOOP = 194,
+ OP_RETURN = 195,
+ OP_LAST = 196,
+ OP_NEXT = 197,
+ OP_REDO = 198,
+ OP_DUMP = 199,
+ OP_GOTO = 200,
+ OP_EXIT = 201,
+ OP_METHOD_NAMED = 202,
+ OP_METHOD_SUPER = 203,
+ OP_METHOD_REDIR = 204,
+ OP_METHOD_REDIR_SUPER = 205,
+ OP_ENTERGIVEN = 206,
+ OP_LEAVEGIVEN = 207,
+ OP_ENTERWHEN = 208,
+ OP_LEAVEWHEN = 209,
+ OP_BREAK = 210,
+ OP_CONTINUE = 211,
+ OP_OPEN = 212,
+ OP_CLOSE = 213,
+ OP_PIPE_OP = 214,
+ OP_FILENO = 215,
+ OP_UMASK = 216,
+ OP_BINMODE = 217,
+ OP_TIE = 218,
+ OP_UNTIE = 219,
+ OP_TIED = 220,
+ OP_DBMOPEN = 221,
+ OP_DBMCLOSE = 222,
+ OP_SSELECT = 223,
+ OP_SELECT = 224,
+ OP_GETC = 225,
+ OP_READ = 226,
+ OP_ENTERWRITE = 227,
+ OP_LEAVEWRITE = 228,
+ OP_PRTF = 229,
+ OP_PRINT = 230,
+ OP_SAY = 231,
+ OP_SYSOPEN = 232,
+ OP_SYSSEEK = 233,
+ OP_SYSREAD = 234,
+ OP_SYSWRITE = 235,
+ OP_EOF = 236,
+ OP_TELL = 237,
+ OP_SEEK = 238,
+ OP_TRUNCATE = 239,
+ OP_FCNTL = 240,
+ OP_IOCTL = 241,
+ OP_FLOCK = 242,
+ OP_SEND = 243,
+ OP_RECV = 244,
+ OP_SOCKET = 245,
+ OP_SOCKPAIR = 246,
+ OP_BIND = 247,
+ OP_CONNECT = 248,
+ OP_LISTEN = 249,
+ OP_ACCEPT = 250,
+ OP_SHUTDOWN = 251,
+ OP_GSOCKOPT = 252,
+ OP_SSOCKOPT = 253,
+ OP_GETSOCKNAME = 254,
+ OP_GETPEERNAME = 255,
+ OP_LSTAT = 256,
+ OP_STAT = 257,
+ OP_FTRREAD = 258,
+ OP_FTRWRITE = 259,
+ OP_FTREXEC = 260,
+ OP_FTEREAD = 261,
+ OP_FTEWRITE = 262,
+ OP_FTEEXEC = 263,
+ OP_FTIS = 264,
+ OP_FTSIZE = 265,
+ OP_FTMTIME = 266,
+ OP_FTATIME = 267,
+ OP_FTCTIME = 268,
+ OP_FTROWNED = 269,
+ OP_FTEOWNED = 270,
+ OP_FTZERO = 271,
+ OP_FTSOCK = 272,
+ OP_FTCHR = 273,
+ OP_FTBLK = 274,
+ OP_FTFILE = 275,
+ OP_FTDIR = 276,
+ OP_FTPIPE = 277,
+ OP_FTSUID = 278,
+ OP_FTSGID = 279,
+ OP_FTSVTX = 280,
+ OP_FTLINK = 281,
+ OP_FTTTY = 282,
+ OP_FTTEXT = 283,
+ OP_FTBINARY = 284,
+ OP_CHDIR = 285,
+ OP_CHOWN = 286,
+ OP_CHROOT = 287,
+ OP_UNLINK = 288,
+ OP_CHMOD = 289,
+ OP_UTIME = 290,
+ OP_RENAME = 291,
+ OP_LINK = 292,
+ OP_SYMLINK = 293,
+ OP_READLINK = 294,
+ OP_MKDIR = 295,
+ OP_RMDIR = 296,
+ OP_OPEN_DIR = 297,
+ OP_READDIR = 298,
+ OP_TELLDIR = 299,
+ OP_SEEKDIR = 300,
+ OP_REWINDDIR = 301,
+ OP_CLOSEDIR = 302,
+ OP_FORK = 303,
+ OP_WAIT = 304,
+ OP_WAITPID = 305,
+ OP_SYSTEM = 306,
+ OP_EXEC = 307,
+ OP_KILL = 308,
+ OP_GETPPID = 309,
+ OP_GETPGRP = 310,
+ OP_SETPGRP = 311,
+ OP_GETPRIORITY = 312,
+ OP_SETPRIORITY = 313,
+ OP_TIME = 314,
+ OP_TMS = 315,
+ OP_LOCALTIME = 316,
+ OP_GMTIME = 317,
+ OP_ALARM = 318,
+ OP_SLEEP = 319,
+ OP_SHMGET = 320,
+ OP_SHMCTL = 321,
+ OP_SHMREAD = 322,
+ OP_SHMWRITE = 323,
+ OP_MSGGET = 324,
+ OP_MSGCTL = 325,
+ OP_MSGSND = 326,
+ OP_MSGRCV = 327,
+ OP_SEMOP = 328,
+ OP_SEMGET = 329,
+ OP_SEMCTL = 330,
+ OP_REQUIRE = 331,
+ OP_DOFILE = 332,
+ OP_HINTSEVAL = 333,
+ OP_ENTEREVAL = 334,
+ OP_LEAVEEVAL = 335,
+ OP_ENTERTRY = 336,
+ OP_LEAVETRY = 337,
+ OP_GHBYNAME = 338,
+ OP_GHBYADDR = 339,
+ OP_GHOSTENT = 340,
+ OP_GNBYNAME = 341,
+ OP_GNBYADDR = 342,
+ OP_GNETENT = 343,
+ OP_GPBYNAME = 344,
+ OP_GPBYNUMBER = 345,
+ OP_GPROTOENT = 346,
+ OP_GSBYNAME = 347,
+ OP_GSBYPORT = 348,
+ OP_GSERVENT = 349,
+ OP_SHOSTENT = 350,
+ OP_SNETENT = 351,
+ OP_SPROTOENT = 352,
+ OP_SSERVENT = 353,
+ OP_EHOSTENT = 354,
+ OP_ENETENT = 355,
+ OP_EPROTOENT = 356,
+ OP_ESERVENT = 357,
+ OP_GPWNAM = 358,
+ OP_GPWUID = 359,
+ OP_GPWENT = 360,
+ OP_SPWENT = 361,
+ OP_EPWENT = 362,
+ OP_GGRNAM = 363,
+ OP_GGRGID = 364,
+ OP_GGRENT = 365,
+ OP_SGRENT = 366,
+ OP_EGRENT = 367,
+ OP_GETLOGIN = 368,
+ OP_SYSCALL = 369,
+ OP_LOCK = 370,
+ OP_ONCE = 371,
+ OP_CUSTOM = 372,
+ OP_REACH = 373,
+ OP_RKEYS = 374,
+ OP_RVALUES = 375,
+ OP_COREARGS = 376,
+ OP_RUNCV = 377,
+ OP_FC = 378,
+ OP_PADCV = 379,
+ OP_INTROCV = 380,
+ OP_CLONECV = 381,
+ OP_PADRANGE = 382,
+ OP_REFASSIGN = 383,
+ OP_LVREF = 384,
+ OP_LVREFSLICE = 385,
+ OP_LVAVREF = 386,
OP_max
} opcode;
-#define MAXO 386
+#define MAXO 387
#define OP_FREED MAXO
/* the OP_IS_* macros are optimized to a simple range check because
diff --git a/perl.h b/perl.h
index 2a77522c5e..ac674c1aa9 100644
--- a/perl.h
+++ b/perl.h
@@ -4605,12 +4605,13 @@ EXTCONST char PL_warn_nl[]
INIT("Unsuccessful %s on filename containing newline");
EXTCONST char PL_no_wrongref[]
INIT("Can't use %s ref as %s ref");
-/* The core no longer needs these here. If you require the string constant,
+/* The core no longer needs this here. If you require the string constant,
please inline a copy into your own code. */
EXTCONST char PL_no_symref[] __attribute__deprecated__
INIT("Can't use string (\"%.32s\") as %s ref while \"strict refs\" in use");
-EXTCONST char PL_no_symref_sv[] __attribute__deprecated__
- INIT("Can't use string (\"%" SVf32 "\") as %s ref while \"strict refs\" in use");
+EXTCONST char PL_no_symref_sv[]
+ INIT("Can't use string (\"%" SVf32 "\"%s) as %s ref while \"strict refs\" in use");
+
EXTCONST char PL_no_usym[]
INIT("Can't use an undefined value as %s reference");
EXTCONST char PL_no_aelem[]
diff --git a/pp.c b/pp.c
index 97ad595119..6772999463 100644
--- a/pp.c
+++ b/pp.c
@@ -195,9 +195,6 @@ PP(pp_clonecv)
/* Translations. */
-static const char S_no_symref_sv[] =
- "Can't use string (\"%" SVf32 "\"%s) as %s ref while \"strict refs\" in use";
-
/* In some cases this function inspects PL_op. If this function is called
for new op types, more bool parameters may need to be added in place of
the checks.
@@ -274,7 +271,7 @@ S_rv2gv(pTHX_ SV *sv, const bool vivify_sv, const bool strict,
else {
if (strict) {
Perl_die(aTHX_
- S_no_symref_sv,
+ PL_no_symref_sv,
sv,
(SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""),
"a symbol"
@@ -329,7 +326,7 @@ Perl_softref2xv(pTHX_ SV *const sv, const char *const what,
if (PL_op->op_private & HINT_STRICT_REFS) {
if (SvOK(sv))
- Perl_die(aTHX_ S_no_symref_sv, sv,
+ Perl_die(aTHX_ PL_no_symref_sv, sv,
(SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""), what);
else
Perl_die(aTHX_ PL_no_usym, what);
diff --git a/pp_hot.c b/pp_hot.c
index 35493eb1b4..24bf8e9086 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -1857,6 +1857,442 @@ PP(pp_helem)
RETURN;
}
+
+/* a stripped-down version of Perl_softref2xv() for use by
+ * pp_multideref(), which doesn't use PL_op->op_flags */
+
+GV *
+S_softref2xv_lite(pTHX_ SV *const sv, const char *const what,
+ const svtype type)
+{
+ if (PL_op->op_private & HINT_STRICT_REFS) {
+ if (SvOK(sv))
+ Perl_die(aTHX_ PL_no_symref_sv, sv,
+ (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""), what);
+ else
+ Perl_die(aTHX_ PL_no_usym, what);
+ }
+ if (!SvOK(sv))
+ Perl_die(aTHX_ PL_no_usym, what);
+ return gv_fetchsv_nomg(sv, GV_ADD, type);
+}
+
+
+/* handle one or more derefs and array/hash indexings, e.g.
+ * $h->{foo} or $a[0]{$key}[$i] or f()->[1]
+ *
+ * op_aux points to an array of unions of UV / IV / SV* / PADOFFSET.
+ * Each of these either contains an action, or an argument, such as
+ * a UV to use as an array index, or a lexical var to retrieve.
+ * In fact, several actions re stored per UV; we keep shifting new actions
+ * of the one UV, and only reload when it becomes zero.
+ */
+
+PP(pp_multideref)
+{
+ SV *sv = NULL; /* init to avoid spurious 'may be used uninitialized' */
+ UNOP_AUX_item *items = cUNOP_AUXx(PL_op)->op_aux;
+ UV actions = items->uv;
+
+ assert(actions);
+ /* this tells find_uninit_var() where we're up to */
+ PL_multideref_pc = items;
+
+ while (1) {
+ /* there are three main classes of action; the first retrieve
+ * the initial AV or HV from a variable or the stack; the second
+ * does the equivalent of an unrolled (/DREFAV, rv2av, aelem),
+ * the third an unrolled (/DREFHV, rv2hv, helem).
+ */
+ switch (actions & MDEREF_ACTION_MASK) {
+
+ case MDEREF_reload:
+ actions = (++items)->uv;
+ continue;
+
+ case MDEREF_AV_padav_aelem: /* $lex[...] */
+ sv = PAD_SVl((++items)->pad_offset);
+ goto do_AV_aelem;
+
+ case MDEREF_AV_gvav_aelem: /* $pkg[...] */
+ sv = UNOP_AUX_item_sv(++items);
+ assert(isGV_with_GP(sv));
+ sv = (SV*)GvAVn((GV*)sv);
+ goto do_AV_aelem;
+
+ case MDEREF_AV_pop_rv2av_aelem: /* expr->[...] */
+ {
+ dSP;
+ sv = POPs;
+ PUTBACK;
+ goto do_AV_rv2av_aelem;
+ }
+
+ case MDEREF_AV_gvsv_vivify_rv2av_aelem: /* $pkg->[...] */
+ sv = UNOP_AUX_item_sv(++items);
+ assert(isGV_with_GP(sv));
+ sv = GvSVn((GV*)sv);
+ goto do_AV_vivify_rv2av_aelem;
+
+ case MDEREF_AV_padsv_vivify_rv2av_aelem: /* $lex->[...] */
+ sv = PAD_SVl((++items)->pad_offset);
+ /* FALLTHROUGH */
+
+ do_AV_vivify_rv2av_aelem:
+ case MDEREF_AV_vivify_rv2av_aelem: /* vivify, ->[...] */
+ /* this is the OPpDEREF action normally found at the end of
+ * ops like aelem, helem, rv2sv */
+ sv = vivify_ref(sv, OPpDEREF_AV);
+ /* FALLTHROUGH */
+
+ do_AV_rv2av_aelem:
+ /* this is basically a copy of pp_rv2av when it just has the
+ * sKR/1 flags */
+ SvGETMAGIC(sv);
+ if (LIKELY(SvROK(sv))) {
+ if (UNLIKELY(SvAMAGIC(sv))) {
+ sv = amagic_deref_call(sv, to_av_amg);
+ }
+ sv = SvRV(sv);
+ if (UNLIKELY(SvTYPE(sv) != SVt_PVAV))
+ DIE(aTHX_ "Not an ARRAY reference");
+ }
+ else if (SvTYPE(sv) != SVt_PVAV) {
+ if (!isGV_with_GP(sv))
+ sv = (SV*)S_softref2xv_lite(aTHX_ sv, "an ARRAY", SVt_PVAV);
+ sv = MUTABLE_SV(GvAVn((GV*)sv));
+ }
+ /* FALLTHROUGH */
+
+ do_AV_aelem:
+ {
+ /* retrieve the key; this may be either a lexical or package
+ * var (whose index/ptr is stored as an item) or a signed
+ * integer constant stored as an item.
+ */
+ SV *elemsv;
+ IV elem = 0; /* to shut up stupid compiler warnings */
+
+
+ assert(SvTYPE(sv) == SVt_PVAV);
+
+ switch (actions & MDEREF_INDEX_MASK) {
+ case MDEREF_INDEX_none:
+ goto finish;
+ case MDEREF_INDEX_const:
+ elem = (++items)->iv;
+ break;
+ case MDEREF_INDEX_padsv:
+ elemsv = PAD_SVl((++items)->pad_offset);
+ goto check_elem;
+ case MDEREF_INDEX_gvsv:
+ elemsv = UNOP_AUX_item_sv(++items);
+ assert(isGV_with_GP(elemsv));
+ elemsv = GvSVn((GV*)elemsv);
+ check_elem:
+ if (UNLIKELY(SvROK(elemsv) && !SvGAMAGIC(elemsv)
+ && ckWARN(WARN_MISC)))
+ Perl_warner(aTHX_ packWARN(WARN_MISC),
+ "Use of reference \"%"SVf"\" as array index",
+ SVfARG(elemsv));
+ /* the only time that S_find_uninit_var() needs this
+ * is to determine which index value triggered the
+ * undef warning. So just update it here. Note that
+ * since we don't save and restore this var (e.g. for
+ * tie or overload execution), its value will be
+ * meaningless apart from just here */
+ PL_multideref_pc = items;
+ elem = SvIV(elemsv);
+ break;
+ }
+
+
+ /* this is basically a copy of pp_aelem with OPpDEREF skipped */
+
+ if (!(actions & MDEREF_FLAG_last)) {
+ SV** svp = av_fetch((AV*)sv, elem, 1);
+ if (!svp || ! (sv=*svp))
+ DIE(aTHX_ PL_no_aelem, elem);
+ break;
+ }
+
+ if (PL_op->op_private &
+ (OPpMULTIDEREF_EXISTS|OPpMULTIDEREF_DELETE))
+ {
+ if (PL_op->op_private & OPpMULTIDEREF_EXISTS) {
+ sv = av_exists((AV*)sv, elem) ? &PL_sv_yes : &PL_sv_no;
+ }
+ else {
+ I32 discard = (GIMME_V == G_VOID) ? G_DISCARD : 0;
+ sv = av_delete((AV*)sv, elem, discard);
+ if (discard)
+ return NORMAL;
+ if (!sv)
+ sv = &PL_sv_undef;
+ }
+ }
+ else {
+ const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
+ const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
+ const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
+ bool preeminent = TRUE;
+ AV *const av = (AV*)sv;
+ SV** svp;
+
+ if (UNLIKELY(localizing)) {
+ MAGIC *mg;
+ HV *stash;
+
+ /* If we can determine whether the element exist,
+ * Try to preserve the existenceness of a tied array
+ * element by using EXISTS and DELETE if possible.
+ * Fallback to FETCH and STORE otherwise. */
+ if (SvCANEXISTDELETE(av))
+ preeminent = av_exists(av, elem);
+ }
+
+ svp = av_fetch(av, elem, lval && !defer);
+
+ if (lval) {
+ if (!svp || !(sv = *svp)) {
+ IV len;
+ if (!defer)
+ DIE(aTHX_ PL_no_aelem, elem);
+ len = av_tindex(av);
+ sv = sv_2mortal(newSVavdefelem(av,
+ /* Resolve a negative index now, unless it points
+ * before the beginning of the array, in which
+ * case record it for error reporting in
+ * magic_setdefelem. */
+ elem < 0 && len + elem >= 0
+ ? len + elem : elem, 1));
+ }
+ else {
+ if (UNLIKELY(localizing)) {
+ if (preeminent) {
+ save_aelem(av, elem, svp);
+ sv = *svp; /* may have changed */
+ }
+ else
+ SAVEADELETE(av, elem);
+ }
+ }
+ }
+ else {
+ sv = (svp ? *svp : &PL_sv_undef);
+ /* see note in pp_helem() */
+ if (SvRMAGICAL(av) && SvGMAGICAL(sv))
+ mg_get(sv);
+ }
+ }
+
+ }
+ finish:
+ {
+ dSP;
+ XPUSHs(sv);
+ RETURN;
+ }
+ /* NOTREACHED */
+
+
+
+
+ case MDEREF_HV_padhv_helem: /* $lex{...} */
+ sv = PAD_SVl((++items)->pad_offset);
+ goto do_HV_helem;
+
+ case MDEREF_HV_gvhv_helem: /* $pkg{...} */
+ sv = UNOP_AUX_item_sv(++items);
+ assert(isGV_with_GP(sv));
+ sv = (SV*)GvHVn((GV*)sv);
+ goto do_HV_helem;
+
+ case MDEREF_HV_pop_rv2hv_helem: /* expr->{...} */
+ {
+ dSP;
+ sv = POPs;
+ PUTBACK;
+ goto do_HV_rv2hv_helem;
+ }
+
+ case MDEREF_HV_gvsv_vivify_rv2hv_helem: /* $pkg->{...} */
+ sv = UNOP_AUX_item_sv(++items);
+ assert(isGV_with_GP(sv));
+ sv = GvSVn((GV*)sv);
+ goto do_HV_vivify_rv2hv_helem;
+
+ case MDEREF_HV_padsv_vivify_rv2hv_helem: /* $lex->{...} */
+ sv = PAD_SVl((++items)->pad_offset);
+ /* FALLTHROUGH */
+
+ do_HV_vivify_rv2hv_helem:
+ case MDEREF_HV_vivify_rv2hv_helem: /* vivify, ->{...} */
+ /* this is the OPpDEREF action normally found at the end of
+ * ops like aelem, helem, rv2sv */
+ sv = vivify_ref(sv, OPpDEREF_HV);
+ /* FALLTHROUGH */
+
+ do_HV_rv2hv_helem:
+ /* this is basically a copy of pp_rv2hv when it just has the
+ * sKR/1 flags (and pp_rv2hv is aliased to pp_rv2av) */
+
+ SvGETMAGIC(sv);
+ if (LIKELY(SvROK(sv))) {
+ if (UNLIKELY(SvAMAGIC(sv))) {
+ sv = amagic_deref_call(sv, to_hv_amg);
+ }
+ sv = SvRV(sv);
+ if (UNLIKELY(SvTYPE(sv) != SVt_PVHV))
+ DIE(aTHX_ "Not a HASH reference");
+ }
+ else if (SvTYPE(sv) != SVt_PVHV) {
+ if (!isGV_with_GP(sv))
+ sv = (SV*)S_softref2xv_lite(aTHX_ sv, "a HASH", SVt_PVHV);
+ sv = MUTABLE_SV(GvHVn((GV*)sv));
+ }
+ /* FALLTHROUGH */
+
+ do_HV_helem:
+ {
+ /* retrieve the key; this may be either a lexical / package
+ * var or a string constant, whose index/ptr is stored as an
+ * item
+ */
+ SV *keysv = NULL; /* to shut up stupid compiler warnings */
+
+ assert(SvTYPE(sv) == SVt_PVHV);
+
+ switch (actions & MDEREF_INDEX_MASK) {
+ case MDEREF_INDEX_none:
+ goto finish;
+
+ case MDEREF_INDEX_const:
+ keysv = UNOP_AUX_item_sv(++items);
+ break;
+
+ case MDEREF_INDEX_padsv:
+ keysv = PAD_SVl((++items)->pad_offset);
+ break;
+
+ case MDEREF_INDEX_gvsv:
+ keysv = UNOP_AUX_item_sv(++items);
+ keysv = GvSVn((GV*)keysv);
+ break;
+ }
+
+ /* see comment above about setting this var */
+ PL_multideref_pc = items;
+
+
+ /* ensure that candidate CONSTs have been HEKified */
+ assert( ((actions & MDEREF_INDEX_MASK) != MDEREF_INDEX_const)
+ || SvTYPE(keysv) >= SVt_PVMG
+ || !SvOK(keysv)
+ || SvROK(keysv)
+ || SvIsCOW_shared_hash(keysv));
+
+ /* this is basically a copy of pp_helem with OPpDEREF skipped */
+
+ if (!(actions & MDEREF_FLAG_last)) {
+ HE *he = hv_fetch_ent((HV*)sv, keysv, 1, 0);
+ if (!he || !(sv=HeVAL(he)) || sv == &PL_sv_undef)
+ DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
+ break;
+ }
+
+ if (PL_op->op_private &
+ (OPpMULTIDEREF_EXISTS|OPpMULTIDEREF_DELETE))
+ {
+ if (PL_op->op_private & OPpMULTIDEREF_EXISTS) {
+ sv = hv_exists_ent((HV*)sv, keysv, 0)
+ ? &PL_sv_yes : &PL_sv_no;
+ }
+ else {
+ I32 discard = (GIMME_V == G_VOID) ? G_DISCARD : 0;
+ sv = hv_delete_ent((HV*)sv, keysv, discard, 0);
+ if (discard)
+ return NORMAL;
+ if (!sv)
+ sv = &PL_sv_undef;
+ }
+ }
+ else {
+ const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
+ const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
+ const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
+ bool preeminent = TRUE;
+ SV **svp;
+ HV * const hv = (HV*)sv;
+ HE* he;
+
+ if (UNLIKELY(localizing)) {
+ MAGIC *mg;
+ HV *stash;
+
+ /* If we can determine whether the element exist,
+ * Try to preserve the existenceness of a tied hash
+ * element by using EXISTS and DELETE if possible.
+ * Fallback to FETCH and STORE otherwise. */
+ if (SvCANEXISTDELETE(hv))
+ preeminent = hv_exists_ent(hv, keysv, 0);
+ }
+
+ he = hv_fetch_ent(hv, keysv, lval && !defer, 0);
+ svp = he ? &HeVAL(he) : NULL;
+
+
+ if (lval) {
+ if (!svp || !(sv = *svp) || sv == &PL_sv_undef) {
+ SV* lv;
+ SV* key2;
+ if (!defer)
+ DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
+ lv = sv_newmortal();
+ sv_upgrade(lv, SVt_PVLV);
+ LvTYPE(lv) = 'y';
+ sv_magic(lv, key2 = newSVsv(keysv),
+ PERL_MAGIC_defelem, NULL, 0);
+ /* sv_magic() increments refcount */
+ SvREFCNT_dec_NN(key2);
+ LvTARG(lv) = SvREFCNT_inc_simple(hv);
+ LvTARGLEN(lv) = 1;
+ sv = lv;
+ }
+ else {
+ if (localizing) {
+ if (HvNAME_get(hv) && isGV(sv))
+ save_gp(MUTABLE_GV(sv),
+ !(PL_op->op_flags & OPf_SPECIAL));
+ else if (preeminent) {
+ save_helem_flags(hv, keysv, svp,
+ (PL_op->op_flags & OPf_SPECIAL)
+ ? 0 : SAVEf_SETMAGIC);
+ sv = *svp; /* may have changed */
+ }
+ else
+ SAVEHDELETE(hv, keysv);
+ }
+ }
+ }
+ else {
+ sv = (svp && *svp ? *svp : &PL_sv_undef);
+ /* see note in pp_helem() */
+ if (SvRMAGICAL(hv) && SvGMAGICAL(sv))
+ mg_get(sv);
+ }
+ }
+ goto finish;
+ }
+
+ } /* switch */
+
+ actions >>= MDEREF_SHIFT;
+ } /* while */
+ /* NOTREACHED */
+}
+
+
PP(pp_iter)
{
dSP;
diff --git a/pp_proto.h b/pp_proto.h
index 6959357dd2..074f4ab8a3 100644
--- a/pp_proto.h
+++ b/pp_proto.h
@@ -157,6 +157,7 @@ PERL_CALLCONV OP *Perl_pp_method_redir_super(pTHX);
PERL_CALLCONV OP *Perl_pp_method_super(pTHX);
PERL_CALLCONV OP *Perl_pp_mkdir(pTHX);
PERL_CALLCONV OP *Perl_pp_modulo(pTHX);
+PERL_CALLCONV OP *Perl_pp_multideref(pTHX);
PERL_CALLCONV OP *Perl_pp_multiply(pTHX);
PERL_CALLCONV OP *Perl_pp_ncmp(pTHX);
PERL_CALLCONV OP *Perl_pp_ne(pTHX);
diff --git a/proto.h b/proto.h
index eb2ba5a9ad..f2be12dff5 100644
--- a/proto.h
+++ b/proto.h
@@ -4946,6 +4946,12 @@ PERL_CALLCONV UV Perl_to_utf8_case(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp, S
PERL_CALLCONV bool Perl_try_amagic_bin(pTHX_ int method, int flags);
PERL_CALLCONV bool Perl_try_amagic_un(pTHX_ int method, int flags);
+PERL_CALLCONV SV* Perl_unop_aux_stringify(pTHX_ const OP* o, CV *cv)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_UNOP_AUX_STRINGIFY \
+ assert(o); assert(cv)
+
PERL_CALLCONV I32 Perl_unpack_str(pTHX_ const char *pat, const char *patend, const char *s, const char *strbeg, const char *strend, char **new_s, I32 ocnt, U32 flags)
__attribute__nonnull__(pTHX_1)
__attribute__nonnull__(pTHX_2)
@@ -7543,7 +7549,11 @@ STATIC SV * S_find_hash_subscript(pTHX_ const HV *const hv, const SV *const val)
#define PERL_ARGS_ASSERT_FIND_HASH_SUBSCRIPT \
assert(val)
-STATIC SV* S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv, bool top);
+STATIC SV* S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv, bool match, const char **desc_p)
+ __attribute__nonnull__(pTHX_4);
+#define PERL_ARGS_ASSERT_FIND_UNINIT_VAR \
+ assert(desc_p)
+
STATIC bool S_glob_2number(pTHX_ GV* const gv)
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_GLOB_2NUMBER \
diff --git a/regen/op_private b/regen/op_private
index 731c4fb490..4b7c42522e 100644
--- a/regen/op_private
+++ b/regen/op_private
@@ -299,7 +299,7 @@ for (qw(nextstate dbstate)) {
addbits($_, 7 => qw(OPpLVAL_INTRO LVINTRO))
for qw(gvsv rv2sv rv2hv rv2gv rv2av aelem helem aslice
hslice delete padsv padav padhv enteriter entersub padrange
- pushmark cond_expr refassign lvref lvrefslice lvavref),
+ pushmark cond_expr refassign lvref lvrefslice lvavref multideref),
'list', # this gets set in my_attrs() for some reason
;
@@ -418,7 +418,7 @@ for (qw(rv2gv rv2sv padsv aelem helem entersub)) {
# Defer creation of array/hash elem
-addbits($_, 6 => qw(OPpLVAL_DEFER LVDEFER)) for qw(aelem helem);
+addbits($_, 6 => qw(OPpLVAL_DEFER LVDEFER)) for qw(aelem helem multideref);
@@ -437,7 +437,7 @@ addbits($_, 6 => qw(OPpOUR_INTRO OURINTR)) # Variable was in an our()
# We might be an lvalue to return
addbits($_, 3 => qw(OPpMAYBE_LVSUB LVSUB))
for qw(aassign rv2av rv2gv rv2hv padav padhv aelem helem aslice hslice
- av2arylen keys rkeys kvaslice kvhslice substr pos vec);
+ av2arylen keys rkeys kvaslice kvhslice substr pos vec multideref);
@@ -450,7 +450,8 @@ for (qw(rv2hv padhv)) {
-addbits($_, 1 => qw(OPpHINT_STRICT_REFS STRICT)) for qw(rv2sv rv2av rv2hv rv2gv);
+addbits($_, 1 => qw(OPpHINT_STRICT_REFS STRICT))
+ for qw(rv2sv rv2av rv2hv rv2gv multideref);
@@ -734,6 +735,13 @@ addbits($_,
#7 => qw(OPpLVAL_INTRO LVINTRO),
) for 'refassign', 'lvref';
+
+
+addbits('multideref',
+ 4 => qw(OPpMULTIDEREF_EXISTS EXISTS), # deref is actually exists
+ 5 => qw(OPpMULTIDEREF_DELETE DELETE), # deref is actually delete
+);
+
1;
# ex: set ts=8 sts=4 sw=4 et:
diff --git a/regen/opcodes b/regen/opcodes
index 4731fa7b56..49e6c297cc 100644
--- a/regen/opcodes
+++ b/regen/opcodes
@@ -236,6 +236,10 @@ helem hash element ck_null s2 H S
hslice hash slice ck_null m@ H L
kvhslice key/value hash slice ck_null m@ H L
+# mixed array and hash access
+
+multideref array or hash lookup ck_null ds+
+
# Explosives and implosives.
unpack unpack ck_fun u@ S S?
diff --git a/sv.c b/sv.c
index 5a73d9565c..b08899fc99 100644
--- a/sv.c
+++ b/sv.c
@@ -15456,6 +15456,8 @@ warning, then following the direct child of the op may yield an
OP_PADSV or OP_GV that gives the name of the undefined variable. On the
other hand, with OP_ADD there are two branches to follow, so we only print
the variable name if we get an exact match.
+desc_p points to a string pointer holding the description of the op.
+This may be updated if needed.
The name is returned as a mortal SV.
@@ -15467,13 +15469,15 @@ PL_comppad/PL_curpad points to the currently executing pad.
STATIC SV *
S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv,
- bool match)
+ bool match, const char **desc_p)
{
dVAR;
SV *sv;
const GV *gv;
const OP *o, *o2, *kid;
+ PERL_ARGS_ASSERT_FIND_UNINIT_VAR;
+
if (!obase || (match && (!uninit_sv || uninit_sv == &PL_sv_undef ||
uninit_sv == &PL_sv_placeholder)))
return NULL;
@@ -15513,7 +15517,7 @@ S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv,
}
else if (obase == PL_op) /* @{expr}, %{expr} */
return find_uninit_var(cUNOPx(obase)->op_first,
- uninit_sv, match);
+ uninit_sv, match, desc_p);
else /* @{expr}, %{expr} as a sub-expression */
return NULL;
}
@@ -15548,7 +15552,7 @@ S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv,
return varname(gv, '$', 0, NULL, 0, FUV_SUBSCRIPT_NONE);
}
/* ${expr} */
- return find_uninit_var(cUNOPx(obase)->op_first, uninit_sv, 1);
+ return find_uninit_var(cUNOPx(obase)->op_first, uninit_sv, 1, desc_p);
case OP_PADSV:
if (match && PAD_SVl(obase->op_targ) != uninit_sv)
@@ -15598,7 +15602,7 @@ S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv,
if (!o || o->op_type != OP_NULL ||
! (o->op_targ == OP_AELEM || o->op_targ == OP_HELEM))
break;
- return find_uninit_var(cBINOPo->op_last, uninit_sv, match);
+ return find_uninit_var(cBINOPo->op_last, uninit_sv, match, desc_p);
case OP_AELEM:
case OP_HELEM:
@@ -15607,7 +15611,8 @@ S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv,
if (PL_op == obase)
/* $a[uninit_expr] or $h{uninit_expr} */
- return find_uninit_var(cBINOPx(obase)->op_last, uninit_sv, match);
+ return find_uninit_var(cBINOPx(obase)->op_last,
+ uninit_sv, match, desc_p);
gv = NULL;
o = cBINOPx(obase)->op_first;
@@ -15696,9 +15701,205 @@ S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv,
NOT_REACHED; /* NOTREACHED */
}
+ case OP_MULTIDEREF: {
+ /* If we were executing OP_MULTIDEREF when the undef warning
+ * triggered, then it must be one of the index values within
+ * that triggered it. If not, then the only possibility is that
+ * the value retrieved by the last aggregate lookup might be the
+ * culprit. For the former, we set PL_multideref_pc each time before
+ * using an index, so work though the item list until we reach
+ * that point. For the latter, just work through the entire item
+ * list; the last aggregate retrieved will be the candidate.
+ */
+
+ /* the named aggregate, if any */
+ PADOFFSET agg_targ = 0;
+ GV *agg_gv = NULL;
+ /* the last-seen index */
+ UV index_type;
+ PADOFFSET index_targ;
+ GV *index_gv;
+ IV index_const_iv = 0; /* init for spurious compiler warn */
+ SV *index_const_sv;
+ int depth = 0; /* how many array/hash lookups we've done */
+
+ UNOP_AUX_item *items = cUNOP_AUXx(obase)->op_aux;
+ UNOP_AUX_item *last = NULL;
+ UV actions = items->uv;
+ bool is_hv;
+
+ if (PL_op == obase) {
+ last = PL_multideref_pc;
+ assert(last >= items && last <= items + items[-1].uv);
+ }
+
+ assert(actions);
+
+ while (1) {
+ is_hv = FALSE;
+ switch (actions & MDEREF_ACTION_MASK) {
+
+ case MDEREF_reload:
+ actions = (++items)->uv;
+ continue;
+
+ case MDEREF_HV_padhv_helem: /* $lex{...} */
+ is_hv = TRUE;
+ /* FALLTHROUGH */
+ case MDEREF_AV_padav_aelem: /* $lex[...] */
+ agg_targ = (++items)->pad_offset;
+ agg_gv = NULL;
+ break;
+
+ case MDEREF_HV_gvhv_helem: /* $pkg{...} */
+ is_hv = TRUE;
+ /* FALLTHROUGH */
+ case MDEREF_AV_gvav_aelem: /* $pkg[...] */
+ agg_targ = 0;
+ agg_gv = (GV*)UNOP_AUX_item_sv(++items);
+ assert(isGV_with_GP(agg_gv));
+ break;
+
+ case MDEREF_HV_gvsv_vivify_rv2hv_helem: /* $pkg->{...} */
+ case MDEREF_HV_padsv_vivify_rv2hv_helem: /* $lex->{...} */
+ ++items;
+ /* FALLTHROUGH */
+ case MDEREF_HV_pop_rv2hv_helem: /* expr->{...} */
+ case MDEREF_HV_vivify_rv2hv_helem: /* vivify, ->{...} */
+ agg_targ = 0;
+ agg_gv = NULL;
+ is_hv = TRUE;
+ break;
+
+ case MDEREF_AV_gvsv_vivify_rv2av_aelem: /* $pkg->[...] */
+ case MDEREF_AV_padsv_vivify_rv2av_aelem: /* $lex->[...] */
+ ++items;
+ /* FALLTHROUGH */
+ case MDEREF_AV_pop_rv2av_aelem: /* expr->[...] */
+ case MDEREF_AV_vivify_rv2av_aelem: /* vivify, ->[...] */
+ agg_targ = 0;
+ agg_gv = NULL;
+ } /* switch */
+
+ index_targ = 0;
+ index_gv = NULL;
+ index_const_sv = NULL;
+
+ index_type = (actions & MDEREF_INDEX_MASK);
+ switch (index_type) {
+ case MDEREF_INDEX_none:
+ break;
+ case MDEREF_INDEX_const:
+ if (is_hv)
+ index_const_sv = UNOP_AUX_item_sv(++items)
+ else
+ index_const_iv = (++items)->iv;
+ break;
+ case MDEREF_INDEX_padsv:
+ index_targ = (++items)->pad_offset;
+ break;
+ case MDEREF_INDEX_gvsv:
+ index_gv = (GV*)UNOP_AUX_item_sv(++items);
+ assert(isGV_with_GP(index_gv));
+ break;
+ }
+
+ if (index_type != MDEREF_INDEX_none)
+ depth++;
+
+ if ( index_type == MDEREF_INDEX_none
+ || (actions & MDEREF_FLAG_last)
+ || (last && items == last)
+ )
+ break;
+
+ actions >>= MDEREF_SHIFT;
+ } /* while */
+
+ if (PL_op == obase) {
+ /* index was undef */
+
+ *desc_p = ( (actions & MDEREF_FLAG_last)
+ && (obase->op_private
+ & (OPpMULTIDEREF_EXISTS|OPpMULTIDEREF_DELETE)))
+ ?
+ (obase->op_private & OPpMULTIDEREF_EXISTS)
+ ? "exists"
+ : "delete"
+ : is_hv ? "hash element" : "array element";
+ assert(index_type != MDEREF_INDEX_none);
+ if (index_gv)
+ return varname(index_gv, '$', 0, NULL, 0, FUV_SUBSCRIPT_NONE);
+ if (index_targ)
+ return varname(NULL, '$', index_targ,
+ NULL, 0, FUV_SUBSCRIPT_NONE);
+ assert(is_hv); /* AV index is an IV and can't be undef */
+ /* can a const HV index ever be undef? */
+ return NULL;
+ }
+
+ /* the SV returned by pp_multideref() was undef, if anything was */
+
+ if (depth != 1)
+ break;
+
+ if (agg_targ)
+ sv = PAD_SV(agg_targ);
+ else if (agg_gv)
+ sv = is_hv ? MUTABLE_SV(GvHV(agg_gv)) : MUTABLE_SV(GvAV(agg_gv));
+ else
+ break;
+
+ if (index_type == MDEREF_INDEX_const) {
+ if (match) {
+ if (SvMAGICAL(sv))
+ break;
+ if (is_hv) {
+ HE* he = hv_fetch_ent(MUTABLE_HV(sv), index_const_sv, 0, 0);
+ if (!he || HeVAL(he) != uninit_sv)
+ break;
+ }
+ else {
+ SV * const * const svp =
+ av_fetch(MUTABLE_AV(sv), index_const_iv, FALSE);
+ if (!svp || *svp != uninit_sv)
+ break;
+ }
+ }
+ return is_hv
+ ? varname(agg_gv, '%', agg_targ,
+ index_const_sv, 0, FUV_SUBSCRIPT_HASH)
+ : varname(agg_gv, '@', agg_targ,
+ NULL, index_const_iv, FUV_SUBSCRIPT_ARRAY);
+ }
+ else {
+ /* index is an var */
+ if (is_hv) {
+ SV * const keysv = find_hash_subscript((const HV*)sv, uninit_sv);
+ if (keysv)
+ return varname(agg_gv, '%', agg_targ,
+ keysv, 0, FUV_SUBSCRIPT_HASH);
+ }
+ else {
+ const I32 index
+ = find_array_subscript((const AV *)sv, uninit_sv);
+ if (index >= 0)
+ return varname(agg_gv, '@', agg_targ,
+ NULL, index, FUV_SUBSCRIPT_ARRAY);
+ }
+ if (match)
+ break;
+ return varname(agg_gv,
+ is_hv ? '%' : '@',
+ agg_targ, NULL, 0, FUV_SUBSCRIPT_WITHIN);
+ }
+ NOT_REACHED; /* NOTREACHED */
+ }
+
case OP_AASSIGN:
/* only examine RHS */
- return find_uninit_var(cBINOPx(obase)->op_first, uninit_sv, match);
+ return find_uninit_var(cBINOPx(obase)->op_first, uninit_sv,
+ match, desc_p);
case OP_OPEN:
o = cUNOPx(obase)->op_first;
@@ -15897,11 +16098,11 @@ S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv,
o2 = kid;
}
if (o2)
- return find_uninit_var(o2, uninit_sv, match);
+ return find_uninit_var(o2, uninit_sv, match, desc_p);
/* scan all args */
while (o) {
- sv = find_uninit_var(o, uninit_sv, 1);
+ sv = find_uninit_var(o, uninit_sv, 1, desc_p);
if (sv)
return sv;
o = OP_SIBLING(o);
@@ -15926,14 +16127,15 @@ Perl_report_uninit(pTHX_ const SV *uninit_sv)
if (PL_op) {
SV* varname = NULL;
const char *desc;
+
+ desc = PL_op->op_type == OP_STRINGIFY && PL_op->op_folded
+ ? "join or string"
+ : OP_DESC(PL_op);
if (uninit_sv && PL_curpad) {
- varname = find_uninit_var(PL_op, uninit_sv,0);
+ varname = find_uninit_var(PL_op, uninit_sv, 0, &desc);
if (varname)
sv_insert(varname, 0, 0, " ", 1);
}
- desc = PL_op->op_type == OP_STRINGIFY && PL_op->op_folded
- ? "join or string"
- : OP_DESC(PL_op);
/* PL_warn_uninit_sv is constant */
GCC_DIAG_IGNORE(-Wformat-nonliteral);
/* diag_listed_as: Use of uninitialized value%s */
diff --git a/t/lib/warnings/9uninit b/t/lib/warnings/9uninit
index c1a1dfcfc6..d26d6ca0ba 100644
--- a/t/lib/warnings/9uninit
+++ b/t/lib/warnings/9uninit
@@ -2091,3 +2091,80 @@ tie $t, "";
$v = 1.1 * $t; # sv_2nv on a tied regexp
EXPECT
+########
+# multi-level uninitialised array/hash indexes
+use warnings 'uninitialized';
+
+our ($i0, $i2, $i4, $i6, $i8, $i10, $i12);
+my ($i1, $i3, $i5, $i7, $i9, $i11, $i13);
+
+my (@a,%h);
+my $v;
+
+
+# use enough depth that OP_MULTIDEREF needs more than one action word
+
+$v = $a[$i0]{$i1}[$i2]{$i3}[$i4]{$i5}[$i6]{$i7}[$i8]{$i9}[$i10]{$i11}[$i12]{$i13};
+$v = $h{$i0}[$i1]{$i2}[$i3]{$i4}[$i5]{$i6}[$i7]{$i8}[$i9]{$i10}[$i11]{$i12}[$i13];
+
+EXPECT
+Use of uninitialized value $i0 in array element at - line 13.
+Use of uninitialized value $i1 in hash element at - line 13.
+Use of uninitialized value $i2 in array element at - line 13.
+Use of uninitialized value $i3 in hash element at - line 13.
+Use of uninitialized value $i4 in array element at - line 13.
+Use of uninitialized value $i5 in hash element at - line 13.
+Use of uninitialized value $i6 in array element at - line 13.
+Use of uninitialized value $i7 in hash element at - line 13.
+Use of uninitialized value $i8 in array element at - line 13.
+Use of uninitialized value $i9 in hash element at - line 13.
+Use of uninitialized value $i10 in array element at - line 13.
+Use of uninitialized value $i11 in hash element at - line 13.
+Use of uninitialized value $i12 in array element at - line 13.
+Use of uninitialized value $i13 in hash element at - line 13.
+Use of uninitialized value $i0 in hash element at - line 14.
+Use of uninitialized value $i1 in array element at - line 14.
+Use of uninitialized value $i2 in hash element at - line 14.
+Use of uninitialized value $i3 in array element at - line 14.
+Use of uninitialized value $i4 in hash element at - line 14.
+Use of uninitialized value $i5 in array element at - line 14.
+Use of uninitialized value $i6 in hash element at - line 14.
+Use of uninitialized value $i7 in array element at - line 14.
+Use of uninitialized value $i8 in hash element at - line 14.
+Use of uninitialized value $i9 in array element at - line 14.
+Use of uninitialized value $i10 in hash element at - line 14.
+Use of uninitialized value $i11 in array element at - line 14.
+Use of uninitialized value $i12 in hash element at - line 14.
+Use of uninitialized value $i13 in array element at - line 14.
+########
+# misc multideref
+use warnings 'uninitialized';
+my ($i,$j,$k);
+my @a;
+my @ra = \@a;
+my $v;
+$v = exists $a[$i]{$k};
+$v = delete $a[$i]{$k};
+$v = local $a[$i]{$k};
+delete $a[$i]{$k};
+$v = $ra->[$i+$j]{$k};
+$v = ($ra//0)->[$i]{$k};
+$v = $a[length $i]{$k}
+EXPECT
+Use of uninitialized value $i in array element at - line 7.
+Use of uninitialized value $k in exists at - line 7.
+Use of uninitialized value $i in array element at - line 8.
+Use of uninitialized value $k in delete at - line 8.
+Use of uninitialized value $i in array element at - line 9.
+Use of uninitialized value $k in hash element at - line 9.
+Use of uninitialized value $k in hash element at - line 9.
+Use of uninitialized value $k in hash element at - line 9.
+Use of uninitialized value $i in array element at - line 10.
+Use of uninitialized value $k in delete at - line 10.
+Use of uninitialized value $j in addition (+) at - line 11.
+Use of uninitialized value $i in addition (+) at - line 11.
+Use of uninitialized value $k in hash element at - line 11.
+Use of uninitialized value $i in array element at - line 12.
+Use of uninitialized value $k in hash element at - line 12.
+Use of uninitialized value $i in array element at - line 13.
+Use of uninitialized value $k in hash element at - line 13.
diff --git a/t/op/multideref.t b/t/op/multideref.t
new file mode 100644
index 0000000000..1ae0843aa8
--- /dev/null
+++ b/t/op/multideref.t
@@ -0,0 +1,187 @@
+#!./perl
+#
+# test OP_MULTIDEREF.
+#
+# This optimising op is used when one or more array or hash aggregate
+# lookups / derefs are performed, and where each key/index is a simple
+# constant or scalar var; e.g.
+#
+# $r->{foo}[0]{$k}[$i]
+
+
+BEGIN {
+ chdir 't';
+ require './test.pl';
+ set_up_inc("../lib");
+}
+
+use warnings;
+use strict;
+
+plan 56;
+
+
+# check that strict refs hint is handled
+
+{
+ package strict_refs;
+
+ our %foo;
+ my @a = ('foo');
+ eval {
+ $a[0]{k} = 7;
+ };
+ ::like($@, qr/Can't use string/, "strict refs");
+ ::ok(!exists $foo{k}, "strict refs, not exist");
+
+ no strict 'refs';
+
+ $a[0]{k} = 13;
+ ::is($foo{k}, 13, "no strict refs, exist");
+}
+
+# check the basics of multilevel lookups
+
+{
+ package basic;
+
+ # build up the multi-level structure piecemeal to try and avoid
+ # relying on what we're testing
+
+ my @a;
+ my $r = \@a;
+ my $rh = {};
+ my $ra = [];
+ my %h = qw(a 1 b 2 c 3 d 4 e 5 f 6);
+ push @a, 66, 77, 'abc', $rh;
+ %$rh = (foo => $ra, bar => 'BAR');
+ push @$ra, 'def', \%h;
+
+ our ($i1, $i2, $k1, $k2) = (3, 1, 'foo', 'c');
+ my ($li1, $li2, $lk1, $lk2) = (3, 1, 'foo', 'c');
+ my $z = 0;
+
+ # fetch
+
+ ::is($a[3]{foo}[1]{c}, 3, 'fetch: const indices');
+ ::is($a[$i1]{$k1}[$i2]{$k2}, 3, 'fetch: pkg indices');
+ ::is($r->[$i1]{$k1}[$i2]{$k2}, 3, 'fetch: deref pkg indices');
+ ::is($a[$li1]{$lk1}[$li2]{$lk2}, 3, 'fetch: lexical indices');
+ ::is($r->[$li1]{$lk1}[$li2]{$lk2}, 3, 'fetch: deref lexical indices');
+ ::is(($r//0)->[$li1]{$lk1}[$li2+$z]{$lk2}, 3,
+ 'fetch: general expression and index');
+
+
+ # store
+
+ ::is($a[3]{foo}[1]{c} = 5, 5, 'store: const indices');
+ ::is($a[3]{foo}[1]{c}, 5, 'store: const indices 2');
+ ::is($a[$i1]{$k1}[$i2]{$k2} = 7, 7, 'store: pkg indices');
+ ::is($a[$i1]{$k1}[$i2]{$k2}, 7, 'store: pkg indices 2');
+ ::is($r->[$i1]{$k1}[$i2]{$k2} = 9, 9, 'store: deref pkg indices');
+ ::is($r->[$i1]{$k1}[$i2]{$k2}, 9, 'store: deref pkg indices 2');
+ ::is($a[$li1]{$lk1}[$li2]{$lk2} = 11, 11, 'store: lexical indices');
+ ::is($a[$li1]{$lk1}[$li2]{$lk2}, 11, 'store: lexical indices 2');
+ ::is($r->[$li1]{$lk1}[$li2]{$lk2} = 13, 13, 'store: deref lexical indices');
+ ::is($r->[$li1]{$lk1}[$li2]{$lk2}, 13, 'store: deref lexical indices 2');
+ ::is(($r//0)->[$li1]{$lk1}[$li2+$z]{$lk2} = 15, 15,
+ 'store: general expression and index');
+ ::is(($r//0)->[$li1]{$lk1}[$li2+$z]{$lk2}, 15,
+ 'store: general expression and index 2');
+
+
+ # local
+
+ {
+ ::is(local $a[3]{foo}[1]{c} = 19, 19, 'local const indices');
+ ::is($a[3]{foo}[1]{c}, 19, 'local const indices 2');
+ }
+ ::is($a[3]{foo}[1]{c}, 15, 'local const indices 3');
+ {
+ ::is(local $a[$i1]{$k1}[$i2]{$k2} = 21, 21, 'local pkg indices');
+ ::is($a[$i1]{$k1}[$i2]{$k2}, 21, 'local pkg indices 2');
+ }
+ ::is($a[$i1]{$k1}[$i2]{$k2}, 15, 'local pkg indices 3');
+ {
+ ::is(local $a[$li1]{$lk1}[$li2]{$lk2} = 23, 23, 'local lexical indices');
+ ::is($a[$li1]{$lk1}[$li2]{$lk2}, 23, 'local lexical indices 2');
+ }
+ ::is($a[$li1]{$lk1}[$li2]{$lk2}, 15, 'local lexical indices 3');
+ {
+ ::is(local+($r//0)->[$li1]{$lk1}[$li2+$z]{$lk2} = 25, 25,
+ 'local general');
+ ::is(($r//0)->[$li1]{$lk1}[$li2+$z]{$lk2}, 25, 'local general 2');
+ }
+ ::is(($r//0)->[$li1]{$lk1}[$li2+$z]{$lk2}, 15, 'local general 3');
+
+
+ # exists
+
+ ::ok(exists $a[3]{foo}[1]{c}, 'exists: const indices');
+ ::ok(exists $a[$i1]{$k1}[$i2]{$k2}, 'exists: pkg indices');
+ ::ok(exists $r->[$i1]{$k1}[$i2]{$k2}, 'exists: deref pkg indices');
+ ::ok(exists $a[$li1]{$lk1}[$li2]{$lk2}, 'exists: lexical indices');
+ ::ok(exists $r->[$li1]{$lk1}[$li2]{$lk2}, 'exists: deref lexical indices');
+ ::ok(exists +($r//0)->[$li1]{$lk1}[$li2+$z]{$lk2}, 'exists: general');
+
+ # delete
+
+ our $k3 = 'a';
+ my $lk4 = 'b';
+ ::is(delete $a[3]{foo}[1]{c}, 15, 'delete: const indices');
+ ::is(delete $a[$i1]{$k1}[$i2]{$k3}, 1, 'delete: pkg indices');
+ ::is(delete $r->[$i1]{$k1}[$i2]{d}, 4, 'delete: deref pkg indices');
+ ::is(delete $a[$li1]{$lk1}[$li2]{$lk4}, 2, 'delete: lexical indices');
+ ::is(delete $r->[$li1]{$lk1}[$li2]{e}, 5, 'delete: deref lexical indices');
+ ::is(delete +($r//0)->[$li1]{$lk1}[$li2+$z]{f}, 6, 'delete: general');
+
+ # !exists
+
+ ::ok(!exists $a[3]{foo}[1]{c}, '!exists: const indices');
+ ::ok(!exists $a[$i1]{$k1}[$i2]{$k3}, '!exists: pkg indices');
+ ::ok(!exists $r->[$i1]{$k1}[$i2]{$k3}, '!exists: deref pkg indices');
+ ::ok(!exists $a[$li1]{$lk1}[$li2]{$lk4}, '!exists: lexical indices');
+ ::ok(!exists $r->[$li1]{$lk1}[$li2]{$lk4},'!exists: deref lexical indices');
+ ::ok(!exists +($r//0)->[$li1]{$lk1}[$li2+$z]{$lk4},'!exists: general');
+}
+
+
+# weird "constant" keys
+
+{
+ use constant my_undef => undef;
+ use constant my_ref => [];
+ no warnings 'uninitialized';
+ my %h1;
+ $h1{+my_undef} = 1;
+ is(join(':', keys %h1), '', "+my_undef");
+ my %h2;
+ $h2{+my_ref} = 1;
+ like(join(':', keys %h2), qr/x/, "+my_ref");
+}
+
+
+
+{
+ # test that multideref is marked OA_DANGEROUS, i.e. its one of the ops
+ # that should set the OPpASSIGN_COMMON flag in list assignments
+
+ my $x = {};
+ $x->{a} = [ 1 ];
+ $x->{b} = [ 2 ];
+ ($x->{a}, $x->{b}) = ($x->{b}, $x->{a});
+ is($x->{a}[0], 2, "OA_DANGEROUS a");
+ is($x->{b}[0], 1, "OA_DANGEROUS b");
+}
+
+# defer
+
+
+sub defer {}
+
+{
+ my %h;
+ $h{foo} = {};
+ defer($h{foo}{bar});
+ ok(!exists $h{foo}{bar}, "defer");
+}
diff --git a/t/op/svleak.t b/t/op/svleak.t
index 8d42265b8f..076f2bfdaf 100644
--- a/t/op/svleak.t
+++ b/t/op/svleak.t
@@ -15,7 +15,7 @@ BEGIN {
use Config;
-plan tests => 128;
+plan tests => 129;
# run some code N times. If the number of SVs at the end of loop N is
# greater than (N-1)*delta at the end of loop 1, we've got a leak
@@ -479,3 +479,17 @@ leak(2,0,sub{eval{require untohunothu}}, 'requiring nonexistent module');
# [perl #120939]
use constant const_av_xsub_leaked => 1 .. 3;
leak(5, 0, sub { scalar &const_av_xsub_leaked }, "const_av_sub in scalar context");
+
+# check that OP_MULTIDEREF doesn't leak when compiled and then freed
+
+eleak(2, 0, <<'EOF', 'OP_MULTIDEREF');
+no strict;
+no warnings;
+my ($x, @a, %h, $r, $k, $i);
+$x = $a[0]{foo}{$k}{$i};
+$x = $h[0]{foo}{$k}{$i};
+$x = $r->[0]{foo}{$k}{$i};
+$x = $mdr::a[0]{foo}{$mdr::k}{$mdr::i};
+$x = $mdr::h[0]{foo}{$mdr::k}{$mdr::i};
+$x = $mdr::r->[0]{foo}{$mdr::k}{$mdr::i};
+EOF
diff --git a/t/perf/benchmarks b/t/perf/benchmarks
index 52e2af9400..1e4cd72533 100644
--- a/t/perf/benchmarks
+++ b/t/perf/benchmarks
@@ -59,6 +59,95 @@
code => 'f(1,2,3)',
},
+
+ 'expr::array::lex_1const_0' => {
+ desc => 'lexical $array[0]',
+ setup => 'my @a = (1)',
+ code => '$a[0]',
+ },
+ 'expr::array::lex_1const_m1' => {
+ desc => 'lexical $array[-1]',
+ setup => 'my @a = (1)',
+ code => '$a[-1]',
+ },
+ 'expr::array::lex_2const' => {
+ desc => 'lexical $array[const][const]',
+ setup => 'my @a = ([1,2])',
+ code => '$a[0][1]',
+ },
+ 'expr::array::lex_2var' => {
+ desc => 'lexical $array[$i1][$i2]',
+ setup => 'my ($i1,$i2) = (0,1); my @a = ([1,2])',
+ code => '$a[$i1][$i2]',
+ },
+ 'expr::array::ref_lex_2var' => {
+ desc => 'lexical $arrayref->[$i1][$i2]',
+ setup => 'my ($i1,$i2) = (0,1); my $r = [[1,2]]',
+ code => '$r->[$i1][$i2]',
+ },
+ 'expr::array::ref_lex_3const' => {
+ desc => 'lexical $arrayref->[const][const][const]',
+ setup => 'my $r = [[[1,2]]]',
+ code => '$r->[0][0][0]',
+ },
+ 'expr::array::ref_expr_lex_3const' => {
+ desc => '(lexical expr)->[const][const][const]',
+ setup => 'my $r = [[[1,2]]]',
+ code => '($r//0)->[0][0][0]',
+ },
+
+
+ 'expr::array::pkg_1const_0' => {
+ desc => 'package $array[0]',
+ setup => 'our @a = (1)',
+ code => '$a[0]',
+ },
+ 'expr::array::pkg_1const_m1' => {
+ desc => 'package $array[-1]',
+ setup => 'our @a = (1)',
+ code => '$a[-1]',
+ },
+ 'expr::array::pkg_2const' => {
+ desc => 'package $array[const][const]',
+ setup => 'our @a = ([1,2])',
+ code => '$a[0][1]',
+ },
+ 'expr::array::pkg_2var' => {
+ desc => 'package $array[$i1][$i2]',
+ setup => 'our ($i1,$i2) = (0,1); our @a = ([1,2])',
+ code => '$a[$i1][$i2]',
+ },
+ 'expr::array::ref_pkg_2var' => {
+ desc => 'package $arrayref->[$i1][$i2]',
+ setup => 'our ($i1,$i2) = (0,1); our $r = [[1,2]]',
+ code => '$r->[$i1][$i2]',
+ },
+ 'expr::array::ref_pkg_3const' => {
+ desc => 'package $arrayref->[const][const][const]',
+ setup => 'our $r = [[[1,2]]]',
+ code => '$r->[0][0][0]',
+ },
+ 'expr::array::ref_expr_pkg_3const' => {
+ desc => '(package expr)->[const][const][const]',
+ setup => 'our $r = [[[1,2]]]',
+ code => '($r//0)->[0][0][0]',
+ },
+
+
+ 'expr::arrayhash::lex_3var' => {
+ desc => 'lexical $h{$k1}[$i]{$k2}',
+ setup => 'my ($i, $k1, $k2) = (0,"foo","bar");'
+ . 'my %h = (foo => [ { bar => 1 } ])',
+ code => '$h{$k1}[$i]{$k2}',
+ },
+ 'expr::arrayhash::pkg_3var' => {
+ desc => 'package $h{$k1}[$i]{$k2}',
+ setup => 'our ($i, $k1, $k2) = (0,"foo","bar");'
+ . 'our %h = (foo => [ { bar => 1 } ])',
+ code => '$h{$k1}[$i]{$k2}',
+ },
+
+
'expr::assign::scalar_lex' => {
desc => 'lexical $x = 1',
setup => 'my $x',
@@ -70,10 +159,87 @@
code => '($x, $y) = (1, 2)',
},
+
+ 'expr::hash::lex_1const' => {
+ desc => 'lexical $hash{const}',
+ setup => 'my %h = ("foo" => 1)',
+ code => '$h{foo}',
+ },
+ 'expr::hash::lex_2const' => {
+ desc => 'lexical $hash{const}{const}',
+ setup => 'my %h = (foo => { bar => 1 })',
+ code => '$h{foo}{bar}',
+ },
+ 'expr::hash::lex_2var' => {
+ desc => 'lexical $hash{$k1}{$k2}',
+ setup => 'my ($k1,$k2) = qw(foo bar); my %h = ($k1 => { $k2 => 1 })',
+ code => '$h{$k1}{$k2}',
+ },
+ 'expr::hash::ref_lex_2var' => {
+ desc => 'lexical $hashref->{$k1}{$k2}',
+ setup => 'my ($k1,$k2) = qw(foo bar); my $r = {$k1 => { $k2 => 1 }}',
+ code => '$r->{$k1}{$k2}',
+ },
+ 'expr::hash::ref_lex_3const' => {
+ desc => 'lexical $hashref->{const}{const}{const}',
+ setup => 'my $r = {foo => { bar => { baz => 1 }}}',
+ code => '$r->{foo}{bar}{baz}',
+ },
+ 'expr::hash::ref_expr_lex_3const' => {
+ desc => '(lexical expr)->{const}{const}{const}',
+ setup => 'my $r = {foo => { bar => { baz => 1 }}}',
+ code => '($r//0)->{foo}{bar}{baz}',
+ },
+
+
+ 'expr::hash::pkg_1const' => {
+ desc => 'package $hash{const}',
+ setup => 'our %h = ("foo" => 1)',
+ code => '$h{foo}',
+ },
+ 'expr::hash::pkg_2const' => {
+ desc => 'package $hash{const}{const}',
+ setup => 'our %h = (foo => { bar => 1 })',
+ code => '$h{foo}{bar}',
+ },
+ 'expr::hash::pkg_2var' => {
+ desc => 'package $hash{$k1}{$k2}',
+ setup => 'our ($k1,$k2) = qw(foo bar); our %h = ($k1 => { $k2 => 1 })',
+ code => '$h{$k1}{$k2}',
+ },
+ 'expr::hash::ref_pkg_2var' => {
+ desc => 'package $hashref->{$k1}{$k2}',
+ setup => 'our ($k1,$k2) = qw(foo bar); our $r = {$k1 => { $k2 => 1 }}',
+ code => '$r->{$k1}{$k2}',
+ },
+ 'expr::hash::ref_pkg_3const' => {
+ desc => 'package $hashref->{const}{const}{const}',
+ setup => 'our $r = {foo => { bar => { baz => 1 }}}',
+ code => '$r->{foo}{bar}{baz}',
+ },
+ 'expr::hash::ref_expr_pkg_3const' => {
+ desc => '(package expr)->{const}{const}{const}',
+ setup => 'our $r = {foo => { bar => { baz => 1 }}}',
+ code => '($r//0)->{foo}{bar}{baz}',
+ },
+
+
+ 'expr::hash::exists_lex_2var' => {
+ desc => 'lexical exists $hash{$k1}{$k2}',
+ setup => 'my ($k1,$k2) = qw(foo bar); my %h = ($k1 => { $k2 => 1 });',
+ code => 'exists $h{$k1}{$k2}',
+ },
+ 'expr::hash::delete_lex_2var' => {
+ desc => 'lexical delete $hash{$k1}{$k2}',
+ setup => 'my ($k1,$k2) = qw(foo bar); my %h = ($k1 => { $k2 => 1 });',
+ code => 'delete $h{$k1}{$k2}',
+ },
+
+
'expr::index::utf8_postion_1' => {
desc => 'index of a utf8 string, matching at position 1',
setup => 'utf8::upgrade my $x = "abc"',
code => 'index $x, "b"',
},
-];
+];
diff --git a/t/perf/opcount.t b/t/perf/opcount.t
index 659a80ee12..f3c0badcb6 100644
--- a/t/perf/opcount.t
+++ b/t/perf/opcount.t
@@ -17,7 +17,10 @@ BEGIN {
@INC = '../lib';
}
-plan 28;
+use warnings;
+use strict;
+
+plan 2249;
use B ();
@@ -56,8 +59,16 @@ use B ();
note(sprintf "%3d %s", $counts{$_}, $_) for sort keys %counts;
}
+ my @exp;
for (sort keys %$expected_counts) {
- is ($counts{$_}//0, $expected_counts->{$_}, "$desc: $_");
+ my ($c, $e) = ($counts{$_}//0, $expected_counts->{$_});
+ if ($c != $e) {
+ push @exp, "expected $e, got $c: $_";
+ }
+ }
+ ok(!@exp, $desc);
+ if (@exp) {
+ diag($_) for @exp;
}
}
}
@@ -65,7 +76,7 @@ use B ();
# aelem => aelemfast: a basic test that this test file works
test_opcount(0, "basic aelemfast",
- sub { $a[0] = 1 },
+ sub { our @a; $a[0] = 1 },
{
aelem => 0,
aelemfast => 1,
@@ -96,6 +107,7 @@ test_opcount(0, "basic aelemfast",
}
);
+ no warnings 'void';
test_opcount(0, "bench.pl active loop",
sub { for my $x (1..$ARGV[0]) { $x; } },
{
@@ -115,3 +127,136 @@ test_opcount(0, "basic aelemfast",
}
);
}
+
+#
+# multideref
+#
+# try many permutations of aggregate lookup expressions
+
+{
+ package Foo;
+
+ my (@agg_lex, %agg_lex, $i_lex, $r_lex);
+ our (@agg_pkg, %agg_pkg, $i_pkg, $r_pkg);
+
+ my $f;
+ my @bodies = ('[0]', '[128]', '[$i_lex]', '[$i_pkg]',
+ '{foo}', '{$i_lex}', '{$i_pkg}',
+ );
+
+ for my $prefix ('$f->()->', '$agg_lex', '$agg_pkg', '$r_lex->', '$r_pkg->')
+ {
+ for my $mod ('', 'local', 'exists', 'delete') {
+ for my $body0 (@bodies) {
+ for my $body1 ('', @bodies) {
+ for my $body2 ('', '[2*$i_lex]') {
+ my $code = "$mod $prefix$body0$body1$body2";
+ my $sub = "sub { $code }";
+ my $coderef = eval $sub
+ or die "eval '$sub': $@";
+
+ my %c = (aelem => 0,
+ aelemfast => 0,
+ aelemfast_lex => 0,
+ exists => 0,
+ delete => 0,
+ helem => 0,
+ multideref => 0,
+ );
+
+ my $top = 'aelem';
+ if ($code =~ /^\s*\$agg_...\[0\]$/) {
+ # we should expect aelemfast rather than multideref
+ $top = $code =~ /lex/ ? 'aelemfast_lex'
+ : 'aelemfast';
+ $c{$top} = 1;
+ }
+ else {
+ $c{multideref} = 1;
+ }
+
+ if ($body2 ne '') {
+ # trailing index; top aelem/exists/whatever
+ # node is kept
+ $top = $mod unless $mod eq '' or $mod eq 'local';
+ $c{$top} = 1
+ }
+
+ ::test_opcount(0, $sub, $coderef, \%c);
+ }
+ }
+ }
+ }
+ }
+}
+
+
+# multideref: ensure that the prefix expression and trailing index
+# expression are optimised (include aelemfast in those expressions)
+
+
+test_opcount(0, 'multideref expressions',
+ sub { ($_[0] // $_)->[0]{2*$_[0]} },
+ {
+ aelemfast => 2,
+ helem => 1,
+ multideref => 1,
+ },
+ );
+
+# multideref with interesting constant indices
+
+
+test_opcount(0, 'multideref const index',
+ sub { $_->{1}{1.1} },
+ {
+ helem => 0,
+ multideref => 1,
+ },
+ );
+
+use constant my_undef => undef;
+test_opcount(0, 'multideref undef const index',
+ sub { $_->{+my_undef} },
+ {
+ helem => 1,
+ multideref => 0,
+ },
+ );
+
+# multideref when its the first op in a subchain
+
+test_opcount(0, 'multideref op_other etc',
+ sub { $_{foo} = $_ ? $_{bar} : $_{baz} },
+ {
+ helem => 0,
+ multideref => 3,
+ },
+ );
+
+# multideref without hints
+
+{
+ no strict;
+ no warnings;
+
+ test_opcount(0, 'multideref no hints',
+ sub { $_{foo}[0] },
+ {
+ aelem => 0,
+ helem => 0,
+ multideref => 1,
+ },
+ );
+}
+
+# exists shouldn't clash with aelemfast
+
+test_opcount(0, 'multideref exists',
+ sub { exists $_[0] },
+ {
+ aelem => 0,
+ aelemfast => 0,
+ multideref => 1,
+ },
+ );
View Lorry Controller Status