summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorDavid Mitchell <davem@iabyn.com>2015-08-17 11:17:01 +0100
committerDavid Mitchell <davem@iabyn.com>2015-08-17 11:17:01 +0100
commitfba30c6930fff718653b59c3aedac3438defabe3 (patch)
tree94a78d29407e0e9a39ad37a16c2d882125106244
parent0ba9d88c925494ce5e0e96d4ea3c11637807f08c (diff)
parent8c1e192faf1bea909b6379b9cc795ad3cfffd43c (diff)
downloadperl-fba30c6930fff718653b59c3aedac3438defabe3.tar.gz
[MERGE] re-implement OPpASSIGN_COMMON mechanism
Diffstat
-rw-r--r--MANIFEST1
-rw-r--r--dump.c2
-rw-r--r--embed.fnc4
-rw-r--r--embed.h2
-rw-r--r--embedvar.h1
-rw-r--r--ext/B/t/b.t6
-rw-r--r--ext/B/t/f_map.t32
-rw-r--r--ext/B/t/f_sort.t60
-rw-r--r--ext/B/t/optree_misc.t12
-rw-r--r--ext/B/t/optree_samples.t8
-rw-r--r--ext/B/t/optree_sort.t8
-rw-r--r--gv.h11
-rw-r--r--intrpvar.h6
-rw-r--r--lib/B/Op_private.pm14
-rw-r--r--op.c704
-rw-r--r--opcode.h418
-rw-r--r--pad.h5
-rw-r--r--pp_ctl.c1
-rw-r--r--pp_hot.c303
-rw-r--r--proto.h4
-rw-r--r--regen/op_private15
-rw-r--r--scope.c28
-rw-r--r--scope.h2
-rw-r--r--sv.c21
-rw-r--r--sv.h4
-rw-r--r--t/op/aassign.t335
-rw-r--r--t/op/array.t8
-rw-r--r--t/op/hash.t7
-rw-r--r--t/op/sort.t18
-rw-r--r--t/perf/benchmarks380
-rw-r--r--t/perf/optree.t87
31 files changed, 1887 insertions, 620 deletions
diff --git a/MANIFEST b/MANIFEST
index c570662015..097427f1df 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -5150,6 +5150,7 @@ t/mro/vulcan_dfs.t mro tests
t/mro/vulcan_dfs_utf8.t utf8 mro tests
toke.c The tokener
t/op/64bitint.t See if 64 bit integers work
+t/op/aassign.t test list assign
t/op/alarm.t See if alarm works
t/op/anonconst.t See if :const works
t/op/anonsub.t See if anonymous subroutines work
diff --git a/dump.c b/dump.c
index 7369a9a5ca..778e34507c 100644
--- a/dump.c
+++ b/dump.c
@@ -2032,7 +2032,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
Perl_dump_indent(aTHX_ level, file, " GPFLAGS = 0x%"UVxf
" (%s)\n",
(UV)GvGPFLAGS(sv),
- GvALIASED_SV(sv) ? "ALIASED_SV" : "");
+ "");
Perl_dump_indent(aTHX_ level, file, " LINE = %"IVdf"\n", (IV)GvLINE(sv));
Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv));
do_gv_dump (level, file, " EGV", GvEGV(sv));
diff --git a/embed.fnc b/embed.fnc
index f596b1a270..12c0551963 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -962,9 +962,6 @@ ADMnoPR |UV |ASCII_TO_NEED |const UV enc|const UV ch
Apa |OP* |newANONLIST |NULLOK OP* o
Apa |OP* |newANONHASH |NULLOK OP* o
Ap |OP* |newANONSUB |I32 floor|NULLOK OP* proto|NULLOK OP* block
-#if defined(PERL_IN_OP_C)
-i |bool |aassign_common_vars |NULLOK OP* o
-#endif
Apda |OP* |newASSIGNOP |I32 flags|NULLOK OP* left|I32 optype|NULLOK OP* right
Apda |OP* |newCONDOP |I32 flags|NN OP* first|NULLOK OP* trueop|NULLOK OP* falseop
Apd |CV* |newCONSTSUB |NULLOK HV* stash|NULLOK const char* name|NULLOK SV* sv
@@ -1260,7 +1257,6 @@ Ap |void |savestack_grow_cnt |I32 need
Amp |void |save_aelem |NN AV* av|SSize_t idx|NN SV **sptr
Ap |void |save_aelem_flags|NN AV* av|SSize_t idx|NN SV **sptr \
|const U32 flags
-p |void |save_aliased_sv|NN GV* gv
Ap |I32 |save_alloc |I32 size|I32 pad
Ap |void |save_aptr |NN AV** aptr
Ap |AV* |save_ary |NN GV* gv
diff --git a/embed.h b/embed.h
index 6cebb1990e..0611ea9327 100644
--- a/embed.h
+++ b/embed.h
@@ -1304,7 +1304,6 @@
#define rsignal_restore(a,b) Perl_rsignal_restore(aTHX_ a,b)
#define rsignal_save(a,b,c) Perl_rsignal_save(aTHX_ a,b,c)
#define rxres_save(a,b) Perl_rxres_save(aTHX_ a,b)
-#define save_aliased_sv(a) Perl_save_aliased_sv(aTHX_ a)
#define save_strlen(a) Perl_save_strlen(aTHX_ a)
#define sawparens(a) Perl_sawparens(aTHX_ a)
#define scalar(a) Perl_scalar(aTHX_ a)
@@ -1526,7 +1525,6 @@
#define mro_get_linear_isa_dfs(a,b) S_mro_get_linear_isa_dfs(aTHX_ a,b)
# endif
# if defined(PERL_IN_OP_C)
-#define aassign_common_vars(a) S_aassign_common_vars(aTHX_ a)
#define apply_attrs(a,b,c) S_apply_attrs(aTHX_ a,b,c)
#define apply_attrs_my(a,b,c,d) S_apply_attrs_my(aTHX_ a,b,c,d)
#define assignment_type(a) S_assignment_type(aTHX_ a)
diff --git a/embedvar.h b/embedvar.h
index 9ed30e02df..c6213c090f 100644
--- a/embedvar.h
+++ b/embedvar.h
@@ -270,7 +270,6 @@
#define PL_savestack (vTHX->Isavestack)
#define PL_savestack_ix (vTHX->Isavestack_ix)
#define PL_savestack_max (vTHX->Isavestack_max)
-#define PL_sawalias (vTHX->Isawalias)
#ifndef PL_sawampersand
#define PL_sawampersand (vTHX->Isawampersand)
#endif
diff --git a/ext/B/t/b.t b/ext/B/t/b.t
index 1420f91fcf..4638c3e577 100644
--- a/ext/B/t/b.t
+++ b/ext/B/t/b.t
@@ -209,12 +209,6 @@ is($gv_ref->SAFENAME(), "gv", "Test SAFENAME()");
like($gv_ref->FILE(), qr/b\.t$/, "Testing FILE()");
is($gv_ref->SvTYPE(), B::SVt_PVGV, "Test SvTYPE()");
is($gv_ref->FLAGS() & B::SVTYPEMASK, B::SVt_PVGV, "Test SVTYPEMASK");
-is($gv_ref->GPFLAGS & B::GPf_ALIASED_SV, 0, 'GPFLAGS are unset');
-{
- local *gv = \my $x;
- is($gv_ref->GPFLAGS & B::GPf_ALIASED_SV, B::GPf_ALIASED_SV,
- 'GPFLAGS gets GPf_ALIASED_SV set');
-}
# The following return B::SPECIALs.
is(ref B::sv_yes(), "B::SPECIAL", "B::sv_yes()");
diff --git a/ext/B/t/f_map.t b/ext/B/t/f_map.t
index 4f194270ba..a1cbc38c01 100644
--- a/ext/B/t/f_map.t
+++ b/ext/B/t/f_map.t
@@ -59,7 +59,7 @@ checkOptree(note => q{},
# a <0> pushmark s
# b <#> gv[*chars] s
# c <1> rv2av[t2] lKRM*/1
-# d <2> aassign[t9] KS/COMMON
+# d <2> aassign[t9] KS/COM_AGG
# e <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 559 (eval 15):1) v
@@ -75,7 +75,7 @@ EOT_EOT
# a <0> pushmark s
# b <$> gv(*chars) s
# c <1> rv2av[t1] lKRM*/1
-# d <2> aassign[t6] KS/COMMON
+# d <2> aassign[t6] KS/COM_AGG
# e <1> leavesub[1 ref] K/REFC,1
EONT_EONT
@@ -109,7 +109,7 @@ checkOptree(note => q{},
# g <0> pushmark s
# h <#> gv[*hash] s
# i <1> rv2hv lKRM*/1
-# j <2> aassign[t10] KS/COMMON
+# j <2> aassign[t10] KS/COM_AGG
# k <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 560 (eval 15):1) v:{
@@ -131,7 +131,7 @@ EOT_EOT
# g <0> pushmark s
# h <$> gv(*hash) s
# i <1> rv2hv lKRM*/1
-# j <2> aassign[t5] KS/COMMON
+# j <2> aassign[t5] KS/COM_AGG
# k <1> leavesub[1 ref] K/REFC,1
EONT_EONT
@@ -244,7 +244,7 @@ checkOptree(note => q{},
# b <0> pushmark s
# c <#> gv[*hash] s
# d <1> rv2hv lKRM*/1
-# e <2> aassign[t10] KS/COMMON
+# e <2> aassign[t10] KS/COM_AGG
# f <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 560 (eval 15):1) v
@@ -261,7 +261,7 @@ EOT_EOT
# b <0> pushmark s
# c <$> gv(*hash) s
# d <1> rv2hv lKRM*/1
-# e <2> aassign[t6] KS/COMMON
+# e <2> aassign[t6] KS/COM_AGG
# f <1> leavesub[1 ref] K/REFC,1
EONT_EONT
@@ -290,7 +290,7 @@ checkOptree(note => q{},
# b <0> pushmark s
# c <#> gv[*hash] s
# d <1> rv2hv lKRM*/1
-# e <2> aassign[t10] KS/COMMON
+# e <2> aassign[t10] KS/COM_AGG
# f <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 560 (eval 15):1) v
@@ -307,7 +307,7 @@ EOT_EOT
# b <0> pushmark s
# c <$> gv(*hash) s
# d <1> rv2hv lKRM*/1
-# e <2> aassign[t6] KS/COMMON
+# e <2> aassign[t6] KS/COM_AGG
# f <1> leavesub[1 ref] K/REFC,1
EONT_EONT
@@ -336,7 +336,7 @@ checkOptree(note => q{},
# b <0> pushmark s
# c <#> gv[*hash] s
# d <1> rv2hv lKRM*/1
-# e <2> aassign[t9] KS/COMMON
+# e <2> aassign[t9] KS/COM_AGG
# f <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 589 (eval 26):1) v
@@ -353,7 +353,7 @@ EOT_EOT
# b <0> pushmark s
# c <$> gv(*hash) s
# d <1> rv2hv lKRM*/1
-# e <2> aassign[t5] KS/COMMON
+# e <2> aassign[t5] KS/COM_AGG
# f <1> leavesub[1 ref] K/REFC,1
EONT_EONT
@@ -382,7 +382,7 @@ checkOptree(note => q{},
# b <0> pushmark s
# c <#> gv[*hash] s
# d <1> rv2hv lKRM*/1
-# e <2> aassign[t8] KS/COMMON
+# e <2> aassign[t8] KS/COM_AGG
# f <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 593 (eval 28):1) v
@@ -399,7 +399,7 @@ EOT_EOT
# b <0> pushmark s
# c <$> gv(*hash) s
# d <1> rv2hv lKRM*/1
-# e <2> aassign[t5] KS/COMMON
+# e <2> aassign[t5] KS/COM_AGG
# f <1> leavesub[1 ref] K/REFC,1
EONT_EONT
@@ -427,7 +427,7 @@ checkOptree(note => q{},
# a <0> pushmark s
# b <#> gv[*hash] s
# c <1> rv2hv lKRM*/1
-# d <2> aassign[t6] KS/COMMON
+# d <2> aassign[t6] KS/COM_AGG
# e <#> gv[*array] s
# f <1> rv2av[t8] K/1
# g <@> list K
@@ -446,7 +446,7 @@ EOT_EOT
# a <0> pushmark s
# b <$> gv(*hash) s
# c <1> rv2hv lKRM*/1
-# d <2> aassign[t4] KS/COMMON
+# d <2> aassign[t4] KS/COM_AGG
# e <$> gv(*array) s
# f <1> rv2av[t5] K/1
# g <@> list K
@@ -480,7 +480,7 @@ checkOptree(note => q{},
# d <0> pushmark s
# e <#> gv[*hashes] s
# f <1> rv2av[t2] lKRM*/1
-# g <2> aassign[t8] KS/COMMON
+# g <2> aassign[t8] KS/COM_AGG
# h <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 601 (eval 32):1) v
@@ -499,6 +499,6 @@ EOT_EOT
# d <0> pushmark s
# e <$> gv(*hashes) s
# f <1> rv2av[t1] lKRM*/1
-# g <2> aassign[t5] KS/COMMON
+# g <2> aassign[t5] KS/COM_AGG
# h <1> leavesub[1 ref] K/REFC,1
EONT_EONT
diff --git a/ext/B/t/f_sort.t b/ext/B/t/f_sort.t
index 55811eda93..eda5a21cc5 100644
--- a/ext/B/t/f_sort.t
+++ b/ext/B/t/f_sort.t
@@ -60,7 +60,7 @@ checkOptree(note => q{},
# 7 <0> pushmark s
# 8 <#> gv[*articles] s
# 9 <1> rv2av[t2] lKRM*/1
-# a <2> aassign[t5] KS
+# a <2> aassign[t5] KS/COM_AGG
# b <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 545 (eval 15):1) v
@@ -72,7 +72,7 @@ EOT_EOT
# 7 <0> pushmark s
# 8 <$> gv(*articles) s
# 9 <1> rv2av[t1] lKRM*/1
-# a <2> aassign[t3] KS
+# a <2> aassign[t3] KS/COM_AGG
# b <1> leavesub[1 ref] K/REFC,1
EONT_EONT
@@ -97,7 +97,7 @@ checkOptree(note => q{},
# 7 <0> pushmark s
# 8 <#> gv[*articles] s
# 9 <1> rv2av[t2] lKRM*/1
-# a <2> aassign[t3] KS
+# a <2> aassign[t3] KS/COM_AGG
# b <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 546 (eval 15):1) v
@@ -109,7 +109,7 @@ EOT_EOT
# 7 <0> pushmark s
# 8 <$> gv(*articles) s
# 9 <1> rv2av[t1] lKRM*/1
-# a <2> aassign[t2] KS
+# a <2> aassign[t2] KS/COM_AGG
# b <1> leavesub[1 ref] K/REFC,1
EONT_EONT
@@ -135,7 +135,7 @@ checkOptree(note => q{},
# 7 <0> pushmark s
# 8 <#> gv[*articles] s
# 9 <1> rv2av[t2] lKRM*/1
-# a <2> aassign[t10] KS
+# a <2> aassign[t10] KS/COM_AGG
# b <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 546 (eval 15):1) v
@@ -148,7 +148,7 @@ EOT_EOT
# 7 <0> pushmark s
# 8 <$> gv(*articles) s
# 9 <1> rv2av[t1] lKRM*/1
-# a <2> aassign[t6] KS
+# a <2> aassign[t6] KS/COM_AGG
# b <1> leavesub[1 ref] K/REFC,1
EONT_EONT
@@ -173,7 +173,7 @@ checkOptree(note => q{},
# 7 <0> pushmark s
# 8 <#> gv[*articles] s
# 9 <1> rv2av[t2] lKRM*/1
-# a <2> aassign[t3] KS
+# a <2> aassign[t3] KS/COM_AGG
# b <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 546 (eval 15):1) v
@@ -185,7 +185,7 @@ EOT_EOT
# 7 <0> pushmark s
# 8 <$> gv(*articles) s
# 9 <1> rv2av[t1] lKRM*/1
-# a <2> aassign[t2] KS
+# a <2> aassign[t2] KS/COM_AGG
# b <1> leavesub[1 ref] K/REFC,1
EONT_EONT
@@ -210,7 +210,7 @@ checkOptree(note => q{},
# 7 <0> pushmark s
# 8 <#> gv[*articles] s
# 9 <1> rv2av[t2] lKRM*/1
-# a <2> aassign[t3] KS
+# a <2> aassign[t3] KS/COM_AGG
# b <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 546 (eval 15):1) v
@@ -222,7 +222,7 @@ EOT_EOT
# 7 <0> pushmark s
# 8 <$> gv(*articles) s
# 9 <1> rv2av[t1] lKRM*/1
-# a <2> aassign[t2] KS
+# a <2> aassign[t2] KS/COM_AGG
# b <1> leavesub[1 ref] K/REFC,1
EONT_EONT
@@ -247,7 +247,7 @@ checkOptree(note => q{},
# 7 <0> pushmark s
# 8 <#> gv[*articles] s
# 9 <1> rv2av[t2] lKRM*/1
-# a <2> aassign[t3] KS
+# a <2> aassign[t3] KS/COM_AGG
# b <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 546 (eval 15):1) v
@@ -259,7 +259,7 @@ EOT_EOT
# 7 <0> pushmark s
# 8 <$> gv(*articles) s
# 9 <1> rv2av[t1] lKRM*/1
-# a <2> aassign[t2] KS
+# a <2> aassign[t2] KS/COM_AGG
# b <1> leavesub[1 ref] K/REFC,1
EONT_EONT
@@ -288,7 +288,7 @@ checkOptree(note => q{},
# 8 <0> pushmark s
# 9 <#> gv[*eldest] s
# a <1> rv2av[t2] lKRM*/1
-# b <2> aassign[t11] KS/COMMON
+# b <2> aassign[t11] KS/COM_AGG
# c <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 546 (eval 15):1) v
@@ -303,7 +303,7 @@ EOT_EOT
# 8 <0> pushmark s
# 9 <$> gv(*eldest) s
# a <1> rv2av[t1] lKRM*/1
-# b <2> aassign[t5] KS/COMMON
+# b <2> aassign[t5] KS/COM_AGG
# c <1> leavesub[1 ref] K/REFC,1
EONT_EONT
@@ -333,7 +333,7 @@ checkOptree(note => q{},
# 8 <0> pushmark s
# 9 <#> gv[*sortedclass] s
# a <1> rv2av[t2] lKRM*/1
-# b <2> aassign[t5] KS
+# b <2> aassign[t5] KS/COM_AGG
# c <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 546 (eval 15):1) v
@@ -347,7 +347,7 @@ EOT_EOT
# 8 <0> pushmark s
# 9 <$> gv(*sortedclass) s
# a <1> rv2av[t1] lKRM*/1
-# b <2> aassign[t3] KS
+# b <2> aassign[t3] KS/COM_AGG
# c <1> leavesub[1 ref] K/REFC,1
EONT_EONT
@@ -530,7 +530,7 @@ checkOptree(name => q{Compound sort/map Expression },
# n <0> pushmark s
# o <#> gv[*new] s
# p <1> rv2av[t2] lKRM*/1
-# q <2> aassign[t22] KS/COMMON
+# q <2> aassign[t22] KS/COM_AGG
# r <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 609 (eval 34):3) v:{
@@ -560,7 +560,7 @@ EOT_EOT
# n <0> pushmark s
# o <$> gv(*new) s
# p <1> rv2av[t1] lKRM*/1
-# q <2> aassign[t13] KS/COMMON
+# q <2> aassign[t13] KS/COM_AGG
# r <1> leavesub[1 ref] K/REFC,1
EONT_EONT
@@ -592,7 +592,7 @@ checkOptree(name => q{sort other::sub LIST },
# 8 <0> pushmark s
# 9 <#> gv[*new] s
# a <1> rv2av[t2] lKRM*/1
-# b <2> aassign[t5] KS
+# b <2> aassign[t5] KS/COM_AGG
# c <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 614 (eval 36):2) v:{
@@ -606,7 +606,7 @@ EOT_EOT
# 8 <0> pushmark s
# 9 <$> gv(*new) s
# a <1> rv2av[t1] lKRM*/1
-# b <2> aassign[t3] KS
+# b <2> aassign[t3] KS/COM_AGG
# c <1> leavesub[1 ref] K/REFC,1
EONT_EONT
@@ -634,7 +634,7 @@ checkOptree(note => q{},
# 8 <0> pushmark s
# 9 <#> gv[*new] s
# a <1> rv2av[t2] lKRM*/1
-# b <2> aassign[t5] KS
+# b <2> aassign[t5] KS/COM_AGG
# c <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 546 (eval 15):1) v
@@ -648,7 +648,7 @@ EOT_EOT
# 8 <0> pushmark s
# 9 <$> gv(*new) s
# a <1> rv2av[t1] lKRM*/1
-# b <2> aassign[t3] KS
+# b <2> aassign[t3] KS/COM_AGG
# c <1> leavesub[1 ref] K/REFC,1
EONT_EONT
@@ -672,7 +672,7 @@ my ($expect, $expect_nt) = (<<'EOT_EOT', <<'EONT_EONT');
# 7 <0> pushmark s
# 8 <#> gv[*new] s
# 9 <1> rv2av[t2] lKRM*/1
-# a <2> aassign[t14] KS
+# a <2> aassign[t14] KS/COM_AGG
# b <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 578 (eval 15):1) v:%,{
@@ -685,7 +685,7 @@ EOT_EOT
# 7 <0> pushmark s
# 8 <$> gv(*new) s
# 9 <1> rv2av[t1] lKRM*/1
-# a <2> aassign[t6] KS
+# a <2> aassign[t6] KS/COM_AGG
# b <1> leavesub[1 ref] K/REFC,1
EONT_EONT
@@ -717,7 +717,7 @@ checkOptree(note => q{},
# 7 <0> pushmark s
# 8 <#> gv[*new] s
# 9 <1> rv2av[t2] lKRM*/1
-# a <2> aassign[t14] KS
+# a <2> aassign[t14] KS/COM_AGG
# b <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 578 (eval 15):1) v:%,{
@@ -730,7 +730,7 @@ EOT_EOT
# 7 <0> pushmark s
# 8 <$> gv(*new) s
# 9 <1> rv2av[t1] lKRM*/1
-# a <2> aassign[t6] KS
+# a <2> aassign[t6] KS/COM_AGG
# b <1> leavesub[1 ref] K/REFC,1
EONT_EONT
@@ -756,7 +756,7 @@ checkOptree(note => q{},
# 7 <0> pushmark s
# 8 <#> gv[*articles] s
# 9 <1> rv2av[t2] lKRM*/1
-# a <2> aassign[t8] KS
+# a <2> aassign[t8] KS/COM_AGG
# b <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 546 (eval 15):1) v
@@ -769,7 +769,7 @@ EOT_EOT
# 7 <0> pushmark s
# 8 <$> gv(*articles) s
# 9 <1> rv2av[t1] lKRM*/1
-# a <2> aassign[t4] KS
+# a <2> aassign[t4] KS/COM_AGG
# b <1> leavesub[1 ref] K/REFC,1
EONT_EONT
@@ -803,7 +803,7 @@ checkOptree(note => q{},
# d <0> pushmark s
# e <#> gv[*result] s
# f <1> rv2av[t2] lKRM*/1
-# g <2> aassign[t3] KS/COMMON
+# g <2> aassign[t3] KS/COM_AGG
# h <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 547 (eval 15):1) v
@@ -824,7 +824,7 @@ EOT_EOT
# d <0> pushmark s
# e <$> gv(*result) s
# f <1> rv2av[t1] lKRM*/1
-# g <2> aassign[t2] KS/COMMON
+# g <2> aassign[t2] KS/COM_AGG
# h <1> leavesub[1 ref] K/REFC,1
EONT_EONT
diff --git a/ext/B/t/optree_misc.t b/ext/B/t/optree_misc.t
index 9bfcc4905a..2d6b80f820 100644
--- a/ext/B/t/optree_misc.t
+++ b/ext/B/t/optree_misc.t
@@ -205,7 +205,7 @@ checkOptree ( name => 'padrange',
# - <0> padsv[$x:1,2] vM/LVINTRO ->-
# - <0> padsv[$y:1,2] vM/LVINTRO ->-
# 3 <;> nextstate(main 2 -e:1) v:>,<,% ->4
-# 8 <2> aassign[t4] vKS ->9
+# 8 <2> aassign[t4] vKS/COM_AGG ->9
# - <1> ex-list lKP ->5
# 4 <0> padrange[$x:1,2; $y:1,2] /2 ->5
# - <0> padsv[$x:1,2] s ->-
@@ -215,7 +215,7 @@ checkOptree ( name => 'padrange',
# 7 <1> rv2av[t3] lKRM*/1 ->8
# 6 <#> gv[*a] s ->7
# 9 <;> nextstate(main 2 -e:1) v:>,<,%,{ ->a
-# e <2> aassign[t6] KS ->f
+# e <2> aassign[t6] KS/COM_RC1 ->f
# - <1> ex-list lK ->d
# a <0> pushmark s ->b
# c <1> rv2av[t5] lK/1 ->d
@@ -233,7 +233,7 @@ EOT_EOT
# - <0> padsv[$x:1,2] vM/LVINTRO ->-
# - <0> padsv[$y:1,2] vM/LVINTRO ->-
# 3 <;> nextstate(main 2 -e:1) v:>,<,% ->4
-# 8 <2> aassign[t4] vKS ->9
+# 8 <2> aassign[t4] vKS/COM_AGG ->9
# - <1> ex-list lKP ->5
# 4 <0> padrange[$x:1,2; $y:1,2] /2 ->5
# - <0> padsv[$x:1,2] s ->-
@@ -243,7 +243,7 @@ EOT_EOT
# 7 <1> rv2av[t3] lKRM*/1 ->8
# 6 <$> gv(*a) s ->7
# 9 <;> nextstate(main 2 -e:1) v:>,<,%,{ ->a
-# e <2> aassign[t6] KS ->f
+# e <2> aassign[t6] KS/COM_RC1 ->f
# - <1> ex-list lK ->d
# a <0> pushmark s ->b
# c <1> rv2av[t5] lK/1 ->d
@@ -276,7 +276,7 @@ checkOptree ( name => 'padrange and @_',
# - <0> padsv[$a:1,4] sRM*/LVINTRO ->-
# - <0> padsv[$b:1,4] sRM*/LVINTRO ->-
# 4 <;> nextstate(main 2 p3:2) v:>,<,% ->5
-# 9 <2> aassign[t10] vKS ->a
+# 9 <2> aassign[t10] vKS/COM_RC1 ->a
# - <1> ex-list lK ->8
# 5 <0> pushmark s ->6
# 7 <1> rv2av[t9] lK/1 ->8
@@ -309,7 +309,7 @@ EOT_EOT
# - <0> padsv[$a:1,4] sRM*/LVINTRO ->-
# - <0> padsv[$b:1,4] sRM*/LVINTRO ->-
# 4 <;> nextstate(main 2 p3:2) v:>,<,% ->5
-# 9 <2> aassign[t10] vKS ->a
+# 9 <2> aassign[t10] vKS/COM_RC1 ->a
# - <1> ex-list lK ->8
# 5 <0> pushmark s ->6
# 7 <1> rv2av[t9] lK/1 ->8
diff --git a/ext/B/t/optree_samples.t b/ext/B/t/optree_samples.t
index d259bf91a0..c6288d940b 100644
--- a/ext/B/t/optree_samples.t
+++ b/ext/B/t/optree_samples.t
@@ -437,7 +437,7 @@ checkOptree ( name => '@foo = grep(!/^\#/, @bar)',
# a <0> pushmark s
# b <#> gv[*foo] s
# c <1> rv2av[t2] lKRM*/1
-# d <2> aassign[t6] KS
+# d <2> aassign[t6] KS/COM_AGG
# e <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 496 (eval 20):1) v:{
@@ -453,7 +453,7 @@ EOT_EOT
# a <0> pushmark s
# b <$> gv(*foo) s
# c <1> rv2av[t1] lKRM*/1
-# d <2> aassign[t4] KS
+# d <2> aassign[t4] KS/COM_AGG
# e <1> leavesub[1 ref] K/REFC,1
EONT_EONT
@@ -485,7 +485,7 @@ checkOptree ( name => '%h = map { getkey($_) => $_ } @a',
# h <#> gv[*h] s
# i <1> rv2hv[t2] lKRM*/1 < 5.019006
# i <1> rv2hv lKRM*/1 >=5.019006
-# j <2> aassign[t10] KS/COMMON
+# j <2> aassign[t10] KS/COM_AGG
# k <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 501 (eval 22):1) v:{
@@ -509,7 +509,7 @@ EOT_EOT
# h <$> gv(*h) s
# i <1> rv2hv[t1] lKRM*/1 < 5.019006
# i <1> rv2hv lKRM*/1 >=5.019006
-# j <2> aassign[t5] KS/COMMON
+# j <2> aassign[t5] KS/COM_AGG
# k <1> leavesub[1 ref] K/REFC,1
EONT_EONT
diff --git a/ext/B/t/optree_sort.t b/ext/B/t/optree_sort.t
index 660d9b2161..0b5897d575 100644
--- a/ext/B/t/optree_sort.t
+++ b/ext/B/t/optree_sort.t
@@ -77,7 +77,7 @@ checkOptree ( name => 'sub {@a = sort @a}',
7 <0> pushmark s
8 <#> gv[*a] s
9 <1> rv2av[t2] lKRM*/1
-a <2> aassign[t5] KS/COMMON
+a <2> aassign[t5] KS/COM_AGG
b <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 65 optree.t:311) v:>,<,%
@@ -89,7 +89,7 @@ EOT_EOT
# 7 <0> pushmark s
# 8 <$> gv(*a) s
# 9 <1> rv2av[t1] lKRM*/1
-# a <2> aassign[t3] KS/COMMON
+# a <2> aassign[t3] KS/COM_AGG
# b <1> leavesub[1 ref] K/REFC,1
EONT_EONT
@@ -198,7 +198,7 @@ checkOptree ( name => 'sub {my @a; @a = sort @a}',
7 <@> sort lK
8 <0> pushmark s
9 <0> padav[@a:-437,-436] lRM*
-a <2> aassign[t2] KS/COMMON
+a <2> aassign[t2] KS/COM_AGG
b <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 427 optree_sort.t:172) v:>,<,%
@@ -210,7 +210,7 @@ EOT_EOT
# 7 <@> sort lK
# 8 <0> pushmark s
# 9 <0> padav[@a:-437,-436] lRM*
-# a <2> aassign[t2] KS/COMMON
+# a <2> aassign[t2] KS/COM_AGG
# b <1> leavesub[1 ref] K/REFC,1
EONT_EONT
diff --git a/gv.h b/gv.h
index a6bb749443..a6b695ed3d 100644
--- a/gv.h
+++ b/gv.h
@@ -72,11 +72,6 @@ struct gp {
#define GvNAME(gv) GvNAME_get(gv)
#define GvNAMELEN(gv) GvNAMELEN_get(gv)
-#define GvASSIGN_GENERATION(gv) (0 + ((XPV*) SvANY(gv))->xpv_len)
-#define GvASSIGN_GENERATION_set(gv,val) \
- STMT_START { assert(SvTYPE(gv) == SVt_PVGV); \
- (((XPV*) SvANY(gv))->xpv_len = (val)); } STMT_END
-
/*
=head1 GV Functions
@@ -198,12 +193,6 @@ Return the CV from the GV.
#define GvIMPORTED_CV_on(gv) (GvFLAGS(gv) |= GVf_IMPORTED_CV)
#define GvIMPORTED_CV_off(gv) (GvFLAGS(gv) &= ~GVf_IMPORTED_CV)
-#define GPf_ALIASED_SV 1
-
-#define GvALIASED_SV(gv) (GvGPFLAGS(gv) & GPf_ALIASED_SV)
-#define GvALIASED_SV_on(gv) (GvGPFLAGS(gv) |= GPf_ALIASED_SV)
-#define GvALIASED_SV_off(gv) (GvGPFLAGS(gv) &= ~GPf_ALIASED_SV)
-
#ifndef PERL_CORE
# define GvIN_PAD(gv) 0
# define GvIN_PAD_on(gv) NOOP
diff --git a/intrpvar.h b/intrpvar.h
index 6ee88b31d2..20fd4df6ea 100644
--- a/intrpvar.h
+++ b/intrpvar.h
@@ -60,9 +60,6 @@ PERLVAR(I, markstack, I32 *) /* stack_sp locations we're
PERLVAR(I, markstack_ptr, I32 *)
PERLVAR(I, markstack_max, I32 *)
-PERLVARI(I, sawalias, bool, FALSE) /* must enable common-vars
- pessimisation */
-
#ifdef PERL_HASH_RANDOMIZE_KEYS
#ifdef USE_PERL_PERTURB_KEYS
PERLVARI(I, hash_rand_bits_enabled, U8, 1) /* used to randomize hash stuff 0 == no-random, 1 == random, 2 == determinsitic */
@@ -492,7 +489,8 @@ PERLVAR(I, sys_intern, struct interp_intern)
/* more statics moved here */
PERLVAR(I, DBcv, CV *) /* from perl.c */
-PERLVARI(I, generation, int, 100) /* from op.c */
+PERLVARI(I, generation, int, 100) /* scan sequence# for OP_AASSIGN
+ compile-time common elem detection */
PERLVAR(I, unicode, U32) /* Unicode features: $ENV{PERL_UNICODE} or -C */
diff --git a/lib/B/Op_private.pm b/lib/B/Op_private.pm
index c300a9d189..f889efcec3 100644
--- a/lib/B/Op_private.pm
+++ b/lib/B/Op_private.pm
@@ -228,7 +228,7 @@ my @bf = (
},
);
-@{$bits{aassign}}{6,1,0} = ('OPpASSIGN_COMMON', $bf[1], $bf[1]);
+@{$bits{aassign}}{6,5,4,1,0} = ('OPpASSIGN_COMMON_SCALAR', 'OPpASSIGN_COMMON_RC1', 'OPpASSIGN_COMMON_AGG', $bf[1], $bf[1]);
$bits{abs}{0} = $bf[0];
@{$bits{accept}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
@{$bits{add}}{1,0} = ($bf[1], $bf[1]);
@@ -567,7 +567,9 @@ our %defines = (
OPpARG3_MASK => 7,
OPpARG4_MASK => 15,
OPpASSIGN_BACKWARDS => 64,
- OPpASSIGN_COMMON => 64,
+ OPpASSIGN_COMMON_AGG => 16,
+ OPpASSIGN_COMMON_RC1 => 32,
+ OPpASSIGN_COMMON_SCALAR => 64,
OPpASSIGN_CV_TO_GV => 128,
OPpCONST_BARE => 64,
OPpCONST_ENTERED => 16,
@@ -660,7 +662,9 @@ our %defines = (
our %labels = (
OPpALLOW_FAKE => 'FAKE',
OPpASSIGN_BACKWARDS => 'BKWARD',
- OPpASSIGN_COMMON => 'COMMON',
+ OPpASSIGN_COMMON_AGG => 'COM_AGG',
+ OPpASSIGN_COMMON_RC1 => 'COM_RC1',
+ OPpASSIGN_COMMON_SCALAR => 'COM_SCALAR',
OPpASSIGN_CV_TO_GV => 'CV2GV',
OPpCONST_BARE => 'BARE',
OPpCONST_ENTERED => 'ENTERED',
@@ -750,7 +754,7 @@ our %labels = (
our %ops_using = (
OPpALLOW_FAKE => [qw(rv2gv)],
OPpASSIGN_BACKWARDS => [qw(sassign)],
- OPpASSIGN_COMMON => [qw(aassign)],
+ OPpASSIGN_COMMON_AGG => [qw(aassign)],
OPpCONST_BARE => [qw(const)],
OPpCOREARGS_DEREF1 => [qw(coreargs)],
OPpEARLY_CV => [qw(gv)],
@@ -793,6 +797,8 @@ our %ops_using = (
OPpTRANS_COMPLEMENT => [qw(trans transr)],
);
+$ops_using{OPpASSIGN_COMMON_RC1} = $ops_using{OPpASSIGN_COMMON_AGG};
+$ops_using{OPpASSIGN_COMMON_SCALAR} = $ops_using{OPpASSIGN_COMMON_AGG};
$ops_using{OPpASSIGN_CV_TO_GV} = $ops_using{OPpASSIGN_BACKWARDS};
$ops_using{OPpCONST_ENTERED} = $ops_using{OPpCONST_BARE};
$ops_using{OPpCONST_NOVER} = $ops_using{OPpCONST_BARE};
diff --git a/op.c b/op.c
index ae1eb300d8..2d51b6ddaa 100644
--- a/op.c
+++ b/op.c
@@ -6303,132 +6303,6 @@ S_assignment_type(pTHX_ const OP *o)
return ret;
}
-/*
- Helper function for newASSIGNOP to detect commonality between the
- lhs and the rhs. (It is actually called very indirectly. newASSIGNOP
- flags the op and the peephole optimizer calls this helper function
- if the flag is set.) Marks all variables with PL_generation. If it
- returns TRUE the assignment must be able to handle common variables.
-
- PL_generation sorcery:
- An assignment like ($a,$b) = ($c,$d) is easier than
- ($a,$b) = ($c,$a), since there is no need for temporary vars.
- To detect whether there are common vars, the global var
- PL_generation is incremented for each assign op we compile.
- Then, while compiling the assign op, we run through all the
- variables on both sides of the assignment, setting a spare slot
- in each of them to PL_generation. If any of them already have
- that value, we know we've got commonality. Also, if the
- generation number is already set to PERL_INT_MAX, then
- the variable is involved in aliasing, so we also have
- potential commonality in that case. We could use a
- single bit marker, but then we'd have to make 2 passes, first
- to clear the flag, then to test and set it. And that
- wouldn't help with aliasing, either. To find somewhere
- to store these values, evil chicanery is done with SvUVX().
-*/
-PERL_STATIC_INLINE bool
-S_aassign_common_vars(pTHX_ OP* o)
-{
- OP *curop;
- for (curop = cUNOPo->op_first; curop; curop = OpSIBLING(curop)) {
- if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
- if (curop->op_type == OP_GV || curop->op_type == OP_GVSV
- || curop->op_type == OP_AELEMFAST) {
- GV *gv = cGVOPx_gv(curop);
- if (gv == PL_defgv
- || (int)GvASSIGN_GENERATION(gv) == PL_generation)
- return TRUE;
- GvASSIGN_GENERATION_set(gv, PL_generation);
- }
- else if (curop->op_type == OP_PADSV ||
- curop->op_type == OP_PADAV ||
- curop->op_type == OP_PADHV ||
- curop->op_type == OP_AELEMFAST_LEX ||
- curop->op_type == OP_PADANY)
- {
- padcheck:
- if (PAD_COMPNAME_GEN(curop->op_targ)
- == (STRLEN)PL_generation
- || PAD_COMPNAME_GEN(curop->op_targ) == PERL_INT_MAX)
- return TRUE;
- PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
-
- }
- else if (curop->op_type == OP_RV2CV)
- return TRUE;
- else if (curop->op_type == OP_RV2SV ||
- curop->op_type == OP_RV2AV ||
- curop->op_type == OP_RV2HV ||
- curop->op_type == OP_RV2GV) {
- if (cUNOPx(curop)->op_first->op_type != OP_GV) /* funny deref? */
- return TRUE;
- }
- else if (curop->op_type == OP_PUSHRE) {
- GV *const gv =
-#ifdef USE_ITHREADS
- ((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff
- ? MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff))
- : NULL;
-#else
- ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
-#endif
- if (gv) {
- if (gv == PL_defgv
- || (int)GvASSIGN_GENERATION(gv) == PL_generation)
- return TRUE;
- GvASSIGN_GENERATION_set(gv, PL_generation);
- }
- else if (curop->op_targ)
- goto padcheck;
- }
- else if (curop->op_type == OP_PADRANGE)
- /* Ignore padrange; checking its siblings is sufficient. */
- continue;
- else
- return TRUE;
- }
- else if (PL_opargs[curop->op_type] & OA_TARGLEX
- && curop->op_private & OPpTARGET_MY)
- goto padcheck;
-
- if (curop->op_flags & OPf_KIDS) {
- if (aassign_common_vars(curop))
- return TRUE;
- }
- }
- return FALSE;
-}
-
-/* This variant only handles lexical aliases. It is called when
- newASSIGNOP decides that we don’t have any common vars, as lexical ali-
- ases trump that decision. */
-PERL_STATIC_INLINE bool
-S_aassign_common_vars_aliases_only(pTHX_ OP *o)
-{
- OP *curop;
- for (curop = cUNOPo->op_first; curop; curop = OpSIBLING(curop)) {
- if ((curop->op_type == OP_PADSV ||
- curop->op_type == OP_PADAV ||
- curop->op_type == OP_PADHV ||
- curop->op_type == OP_AELEMFAST_LEX ||
- curop->op_type == OP_PADANY ||
- ( PL_opargs[curop->op_type] & OA_TARGLEX
- && curop->op_private & OPpTARGET_MY ))
- && PAD_COMPNAME_GEN(curop->op_targ) == PERL_INT_MAX)
- return TRUE;
-
- if (curop->op_type == OP_PUSHRE && curop->op_targ
- && PAD_COMPNAME_GEN(curop->op_targ) == PERL_INT_MAX)
- return TRUE;
-
- if (curop->op_flags & OPf_KIDS) {
- if (S_aassign_common_vars_aliases_only(aTHX_ curop))
- return TRUE;
- }
- }
- return FALSE;
-}
/*
=for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
@@ -6475,7 +6349,6 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
static const char no_list_state[] = "Initialization of state variables"
" in list context currently forbidden";
OP *curop;
- bool maybe_common_vars = TRUE;
if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE)
left->op_private &= ~ OPpSLICEWARNING;
@@ -6489,47 +6362,24 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
if (OP_TYPE_IS_OR_WAS(left, OP_LIST))
{
OP* lop = ((LISTOP*)left)->op_first;
- maybe_common_vars = FALSE;
while (lop) {
- if (lop->op_type == OP_PADSV ||
- lop->op_type == OP_PADAV ||
- lop->op_type == OP_PADHV ||
- lop->op_type == OP_PADANY) {
- if (!(lop->op_private & OPpLVAL_INTRO))
- maybe_common_vars = TRUE;
-
- if (lop->op_private & OPpPAD_STATE) {
- if (left->op_private & OPpLVAL_INTRO) {
- /* Each variable in state($a, $b, $c) = ... */
- }
- else {
- /* Each state variable in
- (state $a, my $b, our $c, $d, undef) = ... */
- }
- yyerror(no_list_state);
- } else {
- /* Each my variable in
- (state $a, my $b, our $c, $d, undef) = ... */
- }
- } else if (lop->op_type == OP_UNDEF ||
- OP_TYPE_IS_OR_WAS(lop, OP_PUSHMARK)) {
- /* undef may be interesting in
- (state $a, undef, state $c) */
- } else {
- /* Other ops in the list. */
- maybe_common_vars = TRUE;
- }
+ if ((lop->op_type == OP_PADSV ||
+ lop->op_type == OP_PADAV ||
+ lop->op_type == OP_PADHV ||
+ lop->op_type == OP_PADANY)
+ && (lop->op_private & OPpPAD_STATE)
+ )
+ yyerror(no_list_state);
lop = OpSIBLING(lop);
}
}
- else if ((left->op_private & OPpLVAL_INTRO)
+ else if ( (left->op_private & OPpLVAL_INTRO)
+ && (left->op_private & OPpPAD_STATE)
&& ( left->op_type == OP_PADSV
|| left->op_type == OP_PADAV
|| left->op_type == OP_PADHV
- || left->op_type == OP_PADANY))
- {
- if (left->op_type == OP_PADSV) maybe_common_vars = FALSE;
- if (left->op_private & OPpPAD_STATE) {
+ || left->op_type == OP_PADANY)
+ ) {
/* All single variable list context state assignments, hence
state ($a) = ...
(state $a) = ...
@@ -6541,13 +6391,6 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
(state %a) = ...
*/
yyerror(no_list_state);
- }
- }
-
- if (maybe_common_vars) {
- /* The peephole optimizer will do the full check and pos-
- sibly turn this off. */
- o->op_private |= OPpASSIGN_COMMON;
}
if (right && right->op_type == OP_SPLIT
@@ -12097,6 +11940,418 @@ Perl_ck_length(pTHX_ OP *o)
return o;
}
+
+
+/*
+ ---------------------------------------------------------
+
+ Common vars in list assignment
+
+ There now follows some enums and static functions for detecting
+ common variables in list assignments. Here is a little essay I wrote
+ for myself when trying to get my head around this. DAPM.
+
+ ----
+
+ First some random observations:
+
+ * If a lexical var is an alias of something else, e.g.
+ for my $x ($lex, $pkg, $a[0]) {...}
+ then the act of aliasing will increase the reference count of the SV
+
+ * If a package var is an alias of something else, it may still have a
+ reference count of 1, depending on how the alias was created, e.g.
+ in *a = *b, $a may have a refcount of 1 since the GP is shared
+ with a single GvSV pointer to the SV. So If it's an alias of another
+ package var, then RC may be 1; if it's an alias of another scalar, e.g.
+ a lexical var or an array element, then it will have RC > 1.
+
+ * There are many ways to create a package alias; ultimately, XS code
+ may quite legally do GvSV(gv) = SvREFCNT_inc(sv) for example, so
+ run-time tracing mechanisms are unlikely to be able to catch all cases.
+
+ * When the LHS is all my declarations, the same vars can't appear directly
+ on the RHS, but they can indirectly via closures, aliasing and lvalue
+ subs. But those techniques all involve an increase in the lexical
+ scalar's ref count.
+
+ * When the LHS is all lexical vars (but not necessarily my declarations),
+ it is possible for the same lexicals to appear directly on the RHS, and
+ without an increased ref count, since the stack isn't refcounted.
+ This case can be detected at compile time by scanning for common lex
+ vars with PL_generation.
+
+ * lvalue subs defeat common var detection, but they do at least
+ return vars with a temporary ref count increment. Also, you can't
+ tell at compile time whether a sub call is lvalue.
+
+
+ So...
+
+ A: There are a few circumstances where there definitely can't be any
+ commonality:
+
+ LHS empty: () = (...);
+ RHS empty: (....) = ();
+ RHS contains only constants or other 'can't possibly be shared'
+ elements (e.g. ops that return PADTMPs): (...) = (1,2, length)
+ i.e. they only contain ops not marked as dangerous, whose children
+ are also not dangerous;
+ LHS ditto;
+ LHS contains a single scalar element: e.g. ($x) = (....); because
+ after $x has been modified, it won't be used again on the RHS;
+ RHS contains a single element with no aggregate on LHS: e.g.
+ ($a,$b,$c) = ($x); again, once $a has been modified, its value
+ won't be used again.
+
+ B: If LHS are all 'my' lexical var declarations (or safe ops, which
+ we can ignore):
+
+ my ($a, $b, @c) = ...;
+
+ Due to closure and goto tricks, these vars may already have content.
+ For the same reason, an element on the RHS may be a lexical or package
+ alias of one of the vars on the left, or share common elements, for
+ example:
+
+ my ($x,$y) = f(); # $x and $y on both sides
+ sub f : lvalue { ($x,$y) = (1,2); $y, $x }
+
+ and
+
+ my $ra = f();
+ my @a = @$ra; # elements of @a on both sides
+ sub f { @a = 1..4; \@a }
+
+
+ First, just consider scalar vars on LHS:
+
+ RHS is safe only if (A), or in addition,
+ * contains only lexical *scalar* vars, where neither side's
+ lexicals have been flagged as aliases
+
+ If RHS is not safe, then it's always legal to check LHS vars for
+ RC==1, since the only RHS aliases will always be associated
+ with an RC bump.
+
+ Note that in particular, RHS is not safe if:
+
+ * it contains package scalar vars; e.g.:
+
+ f();
+ my ($x, $y) = (2, $x_alias);
+ sub f { $x = 1; *x_alias = \$x; }
+
+ * It contains other general elements, such as flattened or
+ * spliced or single array or hash elements, e.g.
+
+ f();
+ my ($x,$y) = @a; # or $a[0] or @a{@b} etc
+
+ sub f {
+ ($x, $y) = (1,2);
+ use feature 'refaliasing';
+ \($a[0], $a[1]) = \($y,$x);
+ }
+
+ It doesn't matter if the array/hash is lexical or package.
+
+ * it contains a function call that happens to be an lvalue
+ sub which returns one or more of the above, e.g.
+
+ f();
+ my ($x,$y) = f();
+
+ sub f : lvalue {
+ ($x, $y) = (1,2);
+ *x1 = \$x;
+ $y, $x1;
+ }
+
+ (so a sub call on the RHS should be treated the same
+ as having a package var on the RHS).
+
+ * any other "dangerous" thing, such an op or built-in that
+ returns one of the above, e.g. pp_preinc
+
+
+ If RHS is not safe, what we can do however is at compile time flag
+ that the LHS are all my declarations, and at run time check whether
+ all the LHS have RC == 1, and if so skip the full scan.
+
+ Now consider array and hash vars on LHS: e.g. my (...,@a) = ...;
+
+ Here the issue is whether there can be elements of @a on the RHS
+ which will get prematurely freed when @a is cleared prior to
+ assignment. This is only a problem if the aliasing mechanism
+ is one which doesn't increase the refcount - only if RC == 1
+ will the RHS element be prematurely freed.
+
+ Because the array/hash is being INTROed, it or its elements
+ can't directly appear on the RHS:
+
+ my (@a) = ($a[0], @a, etc) # NOT POSSIBLE
+
+ but can indirectly, e.g.:
+
+ my $r = f();
+ my (@a) = @$r;
+ sub f { @a = 1..3; \@a }
+
+ So if the RHS isn't safe as defined by (A), we must always
+ mortalise and bump the ref count of any remaining RHS elements
+ when assigning to a non-empty LHS aggregate.
+
+ Lexical scalars on the RHS aren't safe if they've been involved in
+ aliasing, e.g.
+
+ use feature 'refaliasing';
+
+ f();
+ \(my $lex) = \$pkg;
+ my @a = ($lex,3); # equivalent to ($a[0],3)
+
+ sub f {
+ @a = (1,2);
+ \$pkg = \$a[0];
+ }
+
+ Similarly with lexical arrays and hashes on the RHS:
+
+ f();
+ my @b;
+ my @a = (@b);
+
+ sub f {
+ @a = (1,2);
+ \$b[0] = \$a[1];
+ \$b[1] = \$a[0];
+ }
+
+
+
+ C: As (B), but in addition the LHS may contain non-intro lexicals, e.g.
+ my $a; ($a, my $b) = (....);
+
+ The difference between (B) and (C) is that it is now physically
+ possible for the LHS vars to appear on the RHS too, where they
+ are not reference counted; but in this case, the compile-time
+ PL_generation sweep will detect such common vars.
+
+ So the rules for (C) differ from (B) in that if common vars are
+ detected, the runtime "test RC==1" optimisation can no longer be used,
+ and a full mark and sweep is required
+
+ D: As (C), but in addition the LHS may contain package vars.
+
+ Since package vars can be aliased without a corresponding refcount
+ increase, all bets are off. It's only safe if (A). E.g.
+
+ my ($x, $y) = (1,2);
+
+ for $x_alias ($x) {
+ ($x_alias, $y) = (3, $x); # whoops
+ }
+
+ Ditto for LHS aggregate package vars.
+
+ E: Any other dangerous ops on LHS, e.g.
+ (f(), $a[0], @$r) = (...);
+
+ this is similar to (E) in that all bets are off. In addition, it's
+ impossible to determine at compile time whether the LHS
+ contains a scalar or an aggregate, e.g.
+
+ sub f : lvalue { @a }
+ (f()) = 1..3;
+
+* ---------------------------------------------------------
+*/
+
+
+/* A set of bit flags returned by S_aassign_scan(). Each flag indicates
+ * that at least one of the things flagged was seen.
+ */
+
+enum {
+ AAS_MY_SCALAR = 0x001, /* my $scalar */
+ AAS_MY_AGG = 0x002, /* aggregate: my @array or my %hash */
+ AAS_LEX_SCALAR = 0x004, /* $lexical */
+ AAS_LEX_AGG = 0x008, /* @lexical or %lexical aggregate */
+ AAS_LEX_SCALAR_COMM = 0x010, /* $lexical seen on both sides */
+ AAS_PKG_SCALAR = 0x020, /* $scalar (where $scalar is pkg var) */
+ AAS_PKG_AGG = 0x040, /* package @array or %hash aggregate */
+ AAS_DANGEROUS = 0x080, /* an op (other than the above)
+ that's flagged OA_DANGEROUS */
+ AAS_SAFE_SCALAR = 0x100, /* produces at least one scalar SV that's
+ not in any of the categories above */
+ AAS_DEFAV = 0x200, /* contains just a single '@_' on RHS */
+};
+
+
+
+/* helper function for S_aassign_scan().
+ * check a PAD-related op for commonality and/or set its generation number.
+ * Returns a boolean indicating whether its shared */
+
+static bool
+S_aassign_padcheck(pTHX_ OP* o, bool rhs)
+{
+ if (PAD_COMPNAME_GEN(o->op_targ) == PERL_INT_MAX)
+ /* lexical used in aliasing */
+ return TRUE;
+
+ if (rhs)
+ return cBOOL(PAD_COMPNAME_GEN(o->op_targ) == (STRLEN)PL_generation);
+ else
+ PAD_COMPNAME_GEN_set(o->op_targ, PL_generation);
+
+ return FALSE;
+}
+
+
+/*
+ Helper function for OPpASSIGN_COMMON* detection in rpeep().
+ It scans the left or right hand subtree of the aassign op, and returns a
+ set of flags indicating what sorts of things it found there.
+ 'rhs' indicates whether we're scanning the LHS or RHS. If the former, we
+ set PL_generation on lexical vars; if the latter, we see if
+ PL_generation matches.
+ 'top' indicates whether we're recursing or at the top level.
+ 'scalars_p' is a pointer to a counter of the number of scalar SVs seen.
+ This fn will increment it by the number seen. It's not intended to
+ be an accurate count (especially as many ops can push a variable
+ number of SVs onto the stack); rather it's used as to test whether there
+ can be at most 1 SV pushed; so it's only meanings are "0, 1, many".
+*/
+
+static int
+S_aassign_scan(pTHX_ OP* o, bool rhs, bool top, int *scalars_p)
+{
+ int flags = 0;
+ bool kid_top = FALSE;
+
+ /* first, look for a solitary @_ on the RHS */
+ if ( rhs
+ && top
+ && (o->op_flags & OPf_KIDS)
+ && OP_TYPE_IS_OR_WAS(o, OP_LIST)
+ ) {
+ OP *kid = cUNOPo->op_first;
+ if ( ( kid->op_type == OP_PUSHMARK
+ || kid->op_type == OP_PADRANGE) /* ex-pushmark */
+ && ((kid = OpSIBLING(kid)))
+ && !OpHAS_SIBLING(kid)
+ && kid->op_type == OP_RV2AV
+ && !(kid->op_flags & OPf_REF)
+ && !(kid->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
+ && ((kid->op_flags & OPf_WANT) == OPf_WANT_LIST)
+ && ((kid = cUNOPx(kid)->op_first))
+ && kid->op_type == OP_GV
+ && cGVOPx_gv(kid) == PL_defgv
+ )
+ flags |= AAS_DEFAV;
+ }
+
+ switch (o->op_type) {
+ case OP_GVSV:
+ (*scalars_p)++;
+ return AAS_PKG_SCALAR;
+
+ case OP_PADAV:
+ case OP_PADHV:
+ (*scalars_p) += 2;
+ if (top && (o->op_flags & OPf_REF))
+ return (o->op_private & OPpLVAL_INTRO)
+ ? AAS_MY_AGG : AAS_LEX_AGG;
+ return AAS_DANGEROUS;
+
+ case OP_PADSV:
+ {
+ int comm = S_aassign_padcheck(aTHX_ o, rhs)
+ ? AAS_LEX_SCALAR_COMM : 0;
+ (*scalars_p)++;
+ return (o->op_private & OPpLVAL_INTRO)
+ ? (AAS_MY_SCALAR|comm) : (AAS_LEX_SCALAR|comm);
+ }
+
+ case OP_RV2AV:
+ case OP_RV2HV:
+ (*scalars_p) += 2;
+ if (cUNOPx(o)->op_first->op_type != OP_GV)
+ return AAS_DANGEROUS; /* @{expr}, %{expr} */
+ /* @pkg, %pkg */
+ if (top && (o->op_flags & OPf_REF))
+ return AAS_PKG_AGG;
+ return AAS_DANGEROUS;
+
+ case OP_RV2SV:
+ (*scalars_p)++;
+ if (cUNOPx(o)->op_first->op_type != OP_GV) {
+ (*scalars_p) += 2;
+ return AAS_DANGEROUS; /* ${expr} */
+ }
+ return AAS_PKG_SCALAR; /* $pkg */
+
+ case OP_SPLIT:
+ if (cLISTOPo->op_first->op_type == OP_PUSHRE) {
+ /* "@foo = split... " optimises away the aassign and stores its
+ * destination array in the OP_PUSHRE that precedes it.
+ * A flattened array is always dangerous.
+ */
+ (*scalars_p) += 2;
+ return AAS_DANGEROUS;
+ }
+ break;
+
+ case OP_UNDEF:
+ case OP_PUSHMARK:
+ case OP_STUB:
+ /* these are all no-ops; they don't push a potentially common SV
+ * onto the stack, so they are neither AAS_DANGEROUS nor
+ * AAS_SAFE_SCALAR */
+ return 0;
+
+ case OP_PADRANGE: /* Ignore padrange; checking its siblings is enough */
+ break;
+
+ case OP_NULL:
+ case OP_LIST:
+ /* these do nothing but may have children; but their children
+ * should also be treated as top-level */
+ kid_top = top;
+ break;
+
+ default:
+ if (PL_opargs[o->op_type] & OA_DANGEROUS) {
+ (*scalars_p) += 2;
+ return AAS_DANGEROUS;
+ }
+
+ if ( (PL_opargs[o->op_type] & OA_TARGLEX)
+ && (o->op_private & OPpTARGET_MY))
+ {
+ (*scalars_p)++;
+ return S_aassign_padcheck(aTHX_ o, rhs)
+ ? AAS_LEX_SCALAR_COMM : AAS_LEX_SCALAR;
+ }
+
+ /* if its an unrecognised, non-dangerous op, assume that it
+ * it the cause of at least one safe scalar */
+ (*scalars_p)++;
+ flags = AAS_SAFE_SCALAR;
+ break;
+ }
+
+ if (o->op_flags & OPf_KIDS) {
+ OP *kid;
+ for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
+ flags |= S_aassign_scan(aTHX_ kid, rhs, kid_top, scalars_p);
+ }
+ return flags;
+}
+
+
/* Check for in place reverse and sort assignments like "@a = reverse @a"
and modify the optree to make them work inplace */
@@ -13941,28 +14196,99 @@ Perl_rpeep(pTHX_ OP *o)
}
break;
- case OP_AASSIGN:
- /* We do the common-vars check here, rather than in newASSIGNOP
- (as formerly), so that all lexical vars that get aliased are
- marked as such before we do the check. */
- /* There can’t be common vars if the lhs is a stub. */
- if (OpSIBLING(cLISTOPx(cBINOPo->op_last)->op_first)
- == cLISTOPx(cBINOPo->op_last)->op_last
- && cLISTOPx(cBINOPo->op_last)->op_last->op_type == OP_STUB)
- {
- o->op_private &=~ OPpASSIGN_COMMON;
- break;
- }
- if (o->op_private & OPpASSIGN_COMMON) {
- /* See the comment before S_aassign_common_vars concerning
- PL_generation sorcery. */
- PL_generation++;
- if (!aassign_common_vars(o))
- o->op_private &=~ OPpASSIGN_COMMON;
- }
- else if (S_aassign_common_vars_aliases_only(aTHX_ o))
- o->op_private |= OPpASSIGN_COMMON;
+ case OP_AASSIGN: {
+ int l, r, lr, lscalars, rscalars;
+
+ /* handle common vars detection, e.g. ($a,$b) = ($b,$a).
+ Note that we do this now rather than in newASSIGNOP(),
+ since only by now are aliased lexicals flagged as such
+
+ See the essay "Common vars in list assignment" above for
+ the full details of the rationale behind all the conditions
+ below.
+
+ PL_generation sorcery:
+ To detect whether there are common vars, the global var
+ PL_generation is incremented for each assign op we scan.
+ Then we run through all the lexical variables on the LHS,
+ of the assignment, setting a spare slot in each of them to
+ PL_generation. Then we scan the RHS, and if any lexicals
+ already have that value, we know we've got commonality.
+ Also, if the generation number is already set to
+ PERL_INT_MAX, then the variable is involved in aliasing, so
+ we also have potential commonality in that case.
+ */
+
+ PL_generation++;
+ /* scan LHS */
+ lscalars = 0;
+ l = S_aassign_scan(aTHX_ cLISTOPo->op_last, FALSE, 1, &lscalars);
+ /* scan RHS */
+ rscalars = 0;
+ r = S_aassign_scan(aTHX_ cLISTOPo->op_first, TRUE, 1, &rscalars);
+ lr = (l|r);
+
+
+ /* After looking for things which are *always* safe, this main
+ * if/else chain selects primarily based on the type of the
+ * LHS, gradually working its way down from the more dangerous
+ * to the more restrictive and thus safer cases */
+
+ if ( !l /* () = ....; */
+ || !r /* .... = (); */
+ || !(l & ~AAS_SAFE_SCALAR) /* (undef, pos()) = ...; */
+ || !(r & ~AAS_SAFE_SCALAR) /* ... = (1,2,length,undef); */
+ || (lscalars < 2) /* ($x) = ... */
+ ) {
+ NOOP; /* always safe */
+ }
+ else if (l & AAS_DANGEROUS) {
+ /* always dangerous */
+ o->op_private |= OPpASSIGN_COMMON_SCALAR;
+ o->op_private |= OPpASSIGN_COMMON_AGG;
+ }
+ else if (l & (AAS_PKG_SCALAR|AAS_PKG_AGG)) {
+ /* package vars are always dangerous - too many
+ * aliasing possibilities */
+ if (l & AAS_PKG_SCALAR)
+ o->op_private |= OPpASSIGN_COMMON_SCALAR;
+ if (l & AAS_PKG_AGG)
+ o->op_private |= OPpASSIGN_COMMON_AGG;
+ }
+ else if (l & ( AAS_MY_SCALAR|AAS_MY_AGG
+ |AAS_LEX_SCALAR|AAS_LEX_AGG))
+ {
+ /* LHS contains only lexicals and safe ops */
+
+ if (l & (AAS_MY_AGG|AAS_LEX_AGG))
+ o->op_private |= OPpASSIGN_COMMON_AGG;
+
+ if (l & (AAS_MY_SCALAR|AAS_LEX_SCALAR)) {
+ if (lr & AAS_LEX_SCALAR_COMM)
+ o->op_private |= OPpASSIGN_COMMON_SCALAR;
+ else if ( !(l & AAS_LEX_SCALAR)
+ && (r & AAS_DEFAV))
+ {
+ /* falsely mark
+ * my (...) = @_
+ * as scalar-safe for performance reasons.
+ * (it will still have been marked _AGG if necessary */
+ NOOP;
+ }
+ else if (r & (AAS_PKG_SCALAR|AAS_PKG_AGG|AAS_DANGEROUS))
+ o->op_private |= OPpASSIGN_COMMON_RC1;
+ }
+ }
+
+ /* ... = ($x)
+ * may have to handle aggregate on LHS, but we can't
+ * have common scalars*/
+ if (rscalars < 2)
+ o->op_private &=
+ ~(OPpASSIGN_COMMON_SCALAR|OPpASSIGN_COMMON_RC1);
+
break;
+ }
case OP_CUSTOM: {
Perl_cpeep_t cpeep =
diff --git a/opcode.h b/opcode.h
index d314035521..d6fd6830c7 100644
--- a/opcode.h
+++ b/opcode.h
@@ -2219,6 +2219,7 @@ END_EXTERN_C
#define OPpSORT_INPLACE 0x08
#define OPpTRANS_SQUASH 0x08
#define OPpARG4_MASK 0x0f
+#define OPpASSIGN_COMMON_AGG 0x10
#define OPpCONST_ENTERED 0x10
#define OPpDEREF_AV 0x10
#define OPpEVAL_COPHH 0x10
@@ -2230,6 +2231,7 @@ END_EXTERN_C
#define OPpSORT_DESCEND 0x10
#define OPpSUBSTR_REPL_FIRST 0x10
#define OPpTARGET_MY 0x10
+#define OPpASSIGN_COMMON_RC1 0x20
#define OPpDEREF_HV 0x20
#define OPpEARLY_CV 0x20
#define OPpEVAL_RE_REPARSING 0x20
@@ -2247,7 +2249,7 @@ END_EXTERN_C
#define OPpLVREF_TYPE 0x30
#define OPpALLOW_FAKE 0x40
#define OPpASSIGN_BACKWARDS 0x40
-#define OPpASSIGN_COMMON 0x40
+#define OPpASSIGN_COMMON_SCALAR 0x40
#define OPpCONST_BARE 0x40
#define OPpCOREARGS_SCALARMOD 0x40
#define OPpENTERSUB_DB 0x40
@@ -2310,8 +2312,10 @@ EXTCONST char PL_op_private_labels[] = {
'B','O','O','L','\0',
'B','O','O','L','?','\0',
'B','Y','T','E','S','\0',
- 'C','O','M','M','O','N','\0',
'C','O','M','P','L','\0',
+ 'C','O','M','_','A','G','G','\0',
+ 'C','O','M','_','R','C','1','\0',
+ 'C','O','M','_','S','C','A','L','A','R','\0',
'C','O','N','S','T','\0',
'C','O','P','H','H','\0',
'C','V','\0',
@@ -2405,8 +2409,8 @@ EXTCONST I16 PL_op_private_bitfields[] = {
0, 8, -1,
0, 8, -1,
0, 8, -1,
- 4, -1, 1, 137, 2, 144, 3, 151, -1,
- 4, -1, 0, 495, 1, 26, 2, 264, 3, 83, -1,
+ 4, -1, 1, 157, 2, 164, 3, 171, -1,
+ 4, -1, 0, 515, 1, 26, 2, 284, 3, 103, -1,
};
@@ -2456,8 +2460,8 @@ EXTCONST I16 PL_op_private_bitdef_ix[] = {
68, /* aassign */
0, /* chop */
0, /* schop */
- 71, /* chomp */
- 71, /* schomp */
+ 73, /* chomp */
+ 73, /* schomp */
0, /* defined */
0, /* undef */
0, /* study */
@@ -2470,22 +2474,22 @@ EXTCONST I16 PL_op_private_bitdef_ix[] = {
0, /* i_postinc */
0, /* postdec */
0, /* i_postdec */
- 73, /* pow */
- 73, /* multiply */
- 73, /* i_multiply */
- 73, /* divide */
- 73, /* i_divide */
- 73, /* modulo */
- 73, /* i_modulo */
- 75, /* repeat */
- 73, /* add */
- 73, /* i_add */
- 73, /* subtract */
- 73, /* i_subtract */
- 73, /* concat */
- 77, /* stringify */
- 73, /* left_shift */
- 73, /* right_shift */
+ 75, /* pow */
+ 75, /* multiply */
+ 75, /* i_multiply */
+ 75, /* divide */
+ 75, /* i_divide */
+ 75, /* modulo */
+ 75, /* i_modulo */
+ 77, /* repeat */
+ 75, /* add */
+ 75, /* i_add */
+ 75, /* subtract */
+ 75, /* i_subtract */
+ 75, /* concat */
+ 79, /* stringify */
+ 75, /* left_shift */
+ 75, /* right_shift */
12, /* lt */
12, /* i_lt */
12, /* gt */
@@ -2510,9 +2514,9 @@ EXTCONST I16 PL_op_private_bitdef_ix[] = {
12, /* bit_and */
12, /* bit_xor */
12, /* bit_or */
- 73, /* nbit_and */
- 73, /* nbit_xor */
- 73, /* nbit_or */
+ 75, /* nbit_and */
+ 75, /* nbit_xor */
+ 75, /* nbit_or */
12, /* sbit_and */
12, /* sbit_xor */
12, /* sbit_or */
@@ -2520,110 +2524,110 @@ EXTCONST I16 PL_op_private_bitdef_ix[] = {
0, /* i_negate */
0, /* not */
0, /* complement */
- 71, /* ncomplement */
- 71, /* scomplement */
+ 73, /* ncomplement */
+ 73, /* scomplement */
12, /* smartmatch */
- 77, /* atan2 */
- 71, /* sin */
- 71, /* cos */
- 77, /* rand */
- 77, /* srand */
- 71, /* exp */
- 71, /* log */
- 71, /* sqrt */
- 71, /* int */
- 71, /* hex */
- 71, /* oct */
- 71, /* abs */
- 71, /* length */
- 79, /* substr */
- 82, /* vec */
- 77, /* index */
- 77, /* rindex */
+ 79, /* atan2 */
+ 73, /* sin */
+ 73, /* cos */
+ 79, /* rand */
+ 79, /* srand */
+ 73, /* exp */
+ 73, /* log */
+ 73, /* sqrt */
+ 73, /* int */
+ 73, /* hex */
+ 73, /* oct */
+ 73, /* abs */
+ 73, /* length */
+ 81, /* substr */
+ 84, /* vec */
+ 79, /* index */
+ 79, /* rindex */
49, /* sprintf */
49, /* formline */
- 71, /* ord */
- 71, /* chr */
- 77, /* crypt */
+ 73, /* ord */
+ 73, /* chr */
+ 79, /* crypt */
0, /* ucfirst */
0, /* lcfirst */
0, /* uc */
0, /* lc */
0, /* quotemeta */
- 84, /* rv2av */
- 90, /* aelemfast */
- 90, /* aelemfast_lex */
- 91, /* aelem */
- 96, /* aslice */
- 99, /* kvaslice */
+ 86, /* rv2av */
+ 92, /* aelemfast */
+ 92, /* aelemfast_lex */
+ 93, /* aelem */
+ 98, /* aslice */
+ 101, /* kvaslice */
0, /* aeach */
0, /* akeys */
0, /* avalues */
0, /* each */
0, /* values */
40, /* keys */
- 100, /* delete */
- 103, /* exists */
- 105, /* rv2hv */
- 91, /* helem */
- 96, /* hslice */
- 99, /* kvhslice */
- 113, /* multideref */
+ 102, /* delete */
+ 105, /* exists */
+ 107, /* rv2hv */
+ 93, /* helem */
+ 98, /* hslice */
+ 101, /* kvhslice */
+ 115, /* multideref */
49, /* unpack */
49, /* pack */
- 120, /* split */
+ 122, /* split */
49, /* join */
- 122, /* list */
+ 124, /* list */
12, /* lslice */
49, /* anonlist */
49, /* anonhash */
49, /* splice */
- 77, /* push */
+ 79, /* push */
0, /* pop */
0, /* shift */
- 77, /* unshift */
- 124, /* sort */
- 131, /* reverse */
- 133, /* grepstart */
- 133, /* grepwhile */
- 133, /* mapstart */
- 133, /* mapwhile */
+ 79, /* unshift */
+ 126, /* sort */
+ 133, /* reverse */
+ 135, /* grepstart */
+ 135, /* grepwhile */
+ 135, /* mapstart */
+ 135, /* mapwhile */
0, /* range */
- 135, /* flip */
- 135, /* flop */
+ 137, /* flip */
+ 137, /* flop */
0, /* and */
0, /* or */
12, /* xor */
0, /* dor */
- 137, /* cond_expr */
+ 139, /* cond_expr */
0, /* andassign */
0, /* orassign */
0, /* dorassign */
0, /* method */
- 139, /* entersub */
- 146, /* leavesub */
- 146, /* leavesublv */
- 148, /* caller */
+ 141, /* entersub */
+ 148, /* leavesub */
+ 148, /* leavesublv */
+ 150, /* caller */
49, /* warn */
49, /* die */
49, /* reset */
-1, /* lineseq */
- 150, /* nextstate */
- 150, /* dbstate */
+ 152, /* nextstate */
+ 152, /* dbstate */
-1, /* unstack */
-1, /* enter */
- 151, /* leave */
+ 153, /* leave */
-1, /* scope */
- 153, /* enteriter */
- 157, /* iter */
+ 155, /* enteriter */
+ 159, /* iter */
-1, /* enterloop */
- 158, /* leaveloop */
+ 160, /* leaveloop */
-1, /* return */
- 160, /* last */
- 160, /* next */
- 160, /* redo */
- 160, /* dump */
- 160, /* goto */
+ 162, /* last */
+ 162, /* next */
+ 162, /* redo */
+ 162, /* dump */
+ 162, /* goto */
49, /* exit */
0, /* method_named */
0, /* method_super */
@@ -2635,7 +2639,7 @@ EXTCONST I16 PL_op_private_bitdef_ix[] = {
0, /* leavewhen */
-1, /* break */
-1, /* continue */
- 162, /* open */
+ 164, /* open */
49, /* close */
49, /* pipe_op */
49, /* fileno */
@@ -2651,7 +2655,7 @@ EXTCONST I16 PL_op_private_bitdef_ix[] = {
49, /* getc */
49, /* read */
49, /* enterwrite */
- 146, /* leavewrite */
+ 148, /* leavewrite */
-1, /* prtf */
-1, /* print */
-1, /* say */
@@ -2665,7 +2669,7 @@ EXTCONST I16 PL_op_private_bitdef_ix[] = {
49, /* truncate */
49, /* fcntl */
49, /* ioctl */
- 77, /* flock */
+ 79, /* flock */
49, /* send */
49, /* recv */
49, /* socket */
@@ -2681,45 +2685,45 @@ EXTCONST I16 PL_op_private_bitdef_ix[] = {
0, /* getpeername */
0, /* lstat */
0, /* stat */
- 167, /* ftrread */
- 167, /* ftrwrite */
- 167, /* ftrexec */
- 167, /* fteread */
- 167, /* ftewrite */
- 167, /* fteexec */
- 172, /* ftis */
- 172, /* ftsize */
- 172, /* ftmtime */
- 172, /* ftatime */
- 172, /* ftctime */
- 172, /* ftrowned */
- 172, /* fteowned */
- 172, /* ftzero */
- 172, /* ftsock */
- 172, /* ftchr */
- 172, /* ftblk */
- 172, /* ftfile */
- 172, /* ftdir */
- 172, /* ftpipe */
- 172, /* ftsuid */
- 172, /* ftsgid */
- 172, /* ftsvtx */
- 172, /* ftlink */
- 172, /* fttty */
- 172, /* fttext */
- 172, /* ftbinary */
- 77, /* chdir */
- 77, /* chown */
- 71, /* chroot */
- 77, /* unlink */
- 77, /* chmod */
- 77, /* utime */
- 77, /* rename */
- 77, /* link */
- 77, /* symlink */
+ 169, /* ftrread */
+ 169, /* ftrwrite */
+ 169, /* ftrexec */
+ 169, /* fteread */
+ 169, /* ftewrite */
+ 169, /* fteexec */
+ 174, /* ftis */
+ 174, /* ftsize */
+ 174, /* ftmtime */
+ 174, /* ftatime */
+ 174, /* ftctime */
+ 174, /* ftrowned */
+ 174, /* fteowned */
+ 174, /* ftzero */
+ 174, /* ftsock */
+ 174, /* ftchr */
+ 174, /* ftblk */
+ 174, /* ftfile */
+ 174, /* ftdir */
+ 174, /* ftpipe */
+ 174, /* ftsuid */
+ 174, /* ftsgid */
+ 174, /* ftsvtx */
+ 174, /* ftlink */
+ 174, /* fttty */
+ 174, /* fttext */
+ 174, /* ftbinary */
+ 79, /* chdir */
+ 79, /* chown */
+ 73, /* chroot */
+ 79, /* unlink */
+ 79, /* chmod */
+ 79, /* utime */
+ 79, /* rename */
+ 79, /* link */
+ 79, /* symlink */
0, /* readlink */
- 77, /* mkdir */
- 71, /* rmdir */
+ 79, /* mkdir */
+ 73, /* rmdir */
49, /* open_dir */
0, /* readdir */
0, /* telldir */
@@ -2727,22 +2731,22 @@ EXTCONST I16 PL_op_private_bitdef_ix[] = {
0, /* rewinddir */
0, /* closedir */
-1, /* fork */
- 176, /* wait */
- 77, /* waitpid */
- 77, /* system */
- 77, /* exec */
- 77, /* kill */
- 176, /* getppid */
- 77, /* getpgrp */
- 77, /* setpgrp */
- 77, /* getpriority */
- 77, /* setpriority */
- 176, /* time */
+ 178, /* wait */
+ 79, /* waitpid */
+ 79, /* system */
+ 79, /* exec */
+ 79, /* kill */
+ 178, /* getppid */
+ 79, /* getpgrp */
+ 79, /* setpgrp */
+ 79, /* getpriority */
+ 79, /* setpriority */
+ 178, /* time */
-1, /* tms */
0, /* localtime */
49, /* gmtime */
0, /* alarm */
- 77, /* sleep */
+ 79, /* sleep */
49, /* shmget */
49, /* shmctl */
49, /* shmread */
@@ -2757,8 +2761,8 @@ EXTCONST I16 PL_op_private_bitdef_ix[] = {
0, /* require */
0, /* dofile */
-1, /* hintseval */
- 177, /* entereval */
- 146, /* leaveeval */
+ 179, /* entereval */
+ 148, /* leaveeval */
0, /* entertry */
-1, /* leavetry */
0, /* ghbyname */
@@ -2796,17 +2800,17 @@ EXTCONST I16 PL_op_private_bitdef_ix[] = {
0, /* lock */
0, /* once */
-1, /* custom */
- 183, /* coreargs */
+ 185, /* coreargs */
3, /* runcv */
0, /* fc */
-1, /* padcv */
-1, /* introcv */
-1, /* clonecv */
- 187, /* padrange */
- 189, /* refassign */
- 195, /* lvref */
- 201, /* lvrefslice */
- 202, /* lvavref */
+ 189, /* padrange */
+ 191, /* refassign */
+ 197, /* lvref */
+ 203, /* lvrefslice */
+ 204, /* lvavref */
0, /* anonconst */
};
@@ -2827,68 +2831,68 @@ 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, fc, anonconst */
- 0x29dc, 0x3bd9, /* pushmark */
+ 0x2c5c, 0x3e59, /* pushmark */
0x00bd, /* wantarray, runcv */
- 0x03b8, 0x1570, 0x3c8c, 0x3748, 0x2da5, /* const */
- 0x29dc, 0x2ef9, /* gvsv */
- 0x13d5, /* gv */
+ 0x03b8, 0x17f0, 0x3f0c, 0x39c8, 0x3025, /* const */
+ 0x2c5c, 0x3179, /* gvsv */
+ 0x1655, /* 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, sbit_and, sbit_xor, sbit_or, smartmatch, lslice, xor */
- 0x29dc, 0x3bd8, 0x0257, /* padsv */
- 0x29dc, 0x3bd8, 0x2acc, 0x38c9, /* padav */
- 0x29dc, 0x3bd8, 0x0534, 0x05d0, 0x2acc, 0x38c9, /* padhv */
- 0x3698, 0x3ef1, /* pushre, match, qr, subst */
- 0x29dc, 0x1758, 0x0256, 0x2acc, 0x2cc8, 0x3c84, 0x0003, /* rv2gv */
- 0x29dc, 0x2ef8, 0x0256, 0x3c84, 0x0003, /* rv2sv */
- 0x2acc, 0x0003, /* av2arylen, pos, keys */
- 0x2c3c, 0x0b98, 0x08f4, 0x028c, 0x3e48, 0x3c84, 0x0003, /* rv2cv */
+ 0x2c5c, 0x3e58, 0x0257, /* padsv */
+ 0x2c5c, 0x3e58, 0x2d4c, 0x3b49, /* padav */
+ 0x2c5c, 0x3e58, 0x0534, 0x05d0, 0x2d4c, 0x3b49, /* padhv */
+ 0x3918, 0x4171, /* pushre, match, qr, subst */
+ 0x2c5c, 0x19d8, 0x0256, 0x2d4c, 0x2f48, 0x3f04, 0x0003, /* rv2gv */
+ 0x2c5c, 0x3178, 0x0256, 0x3f04, 0x0003, /* rv2sv */
+ 0x2d4c, 0x0003, /* av2arylen, pos, keys */
+ 0x2ebc, 0x0e18, 0x0b74, 0x028c, 0x40c8, 0x3f04, 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 */
- 0x30dc, 0x2ff8, 0x24b4, 0x23f0, 0x0003, /* backtick */
- 0x3698, 0x0003, /* substcont */
- 0x0c9c, 0x1dd8, 0x0834, 0x3ef0, 0x3a0c, 0x2168, 0x01e4, 0x0141, /* trans, transr */
- 0x0adc, 0x0458, 0x0067, /* sassign */
- 0x0758, 0x2acc, 0x0067, /* aassign */
- 0x3ef0, 0x0003, /* chomp, schomp, ncomplement, scomplement, 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, nbit_and, nbit_xor, nbit_or */
- 0x1058, 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 */
- 0x2acc, 0x0067, /* vec */
- 0x29dc, 0x2ef8, 0x2acc, 0x38c8, 0x3c84, 0x0003, /* rv2av */
+ 0x335c, 0x3278, 0x2734, 0x2670, 0x0003, /* backtick */
+ 0x3918, 0x0003, /* substcont */
+ 0x0f1c, 0x2058, 0x0754, 0x4170, 0x3c8c, 0x23e8, 0x01e4, 0x0141, /* trans, transr */
+ 0x0d5c, 0x0458, 0x0067, /* sassign */
+ 0x0a18, 0x0914, 0x0810, 0x2d4c, 0x0067, /* aassign */
+ 0x4170, 0x0003, /* chomp, schomp, ncomplement, scomplement, sin, cos, exp, log, sqrt, int, hex, oct, abs, length, ord, chr, chroot, rmdir */
+ 0x4170, 0x0067, /* pow, multiply, i_multiply, divide, i_divide, modulo, i_modulo, add, i_add, subtract, i_subtract, concat, left_shift, right_shift, nbit_and, nbit_xor, nbit_or */
+ 0x12d8, 0x0067, /* repeat */
+ 0x4170, 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 */
+ 0x3670, 0x2d4c, 0x00cb, /* substr */
+ 0x2d4c, 0x0067, /* vec */
+ 0x2c5c, 0x3178, 0x2d4c, 0x3b48, 0x3f04, 0x0003, /* rv2av */
0x01ff, /* aelemfast, aelemfast_lex */
- 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, 0x2ef9, /* split */
- 0x29dc, 0x1e99, /* list */
- 0x3af8, 0x3194, 0x0fb0, 0x254c, 0x34e8, 0x2644, 0x2e61, /* sort */
- 0x254c, 0x0003, /* reverse */
- 0x1cc4, 0x0003, /* grepstart, grepwhile, mapstart, mapwhile */
- 0x2778, 0x0003, /* flip, flop */
- 0x29dc, 0x0003, /* cond_expr */
- 0x29dc, 0x0b98, 0x0256, 0x028c, 0x3e48, 0x3c84, 0x2301, /* entersub */
- 0x3258, 0x0003, /* leavesub, leavesublv, leavewrite, leaveeval */
+ 0x2c5c, 0x2b58, 0x0256, 0x2d4c, 0x0067, /* aelem, helem */
+ 0x2c5c, 0x2d4c, 0x3b49, /* aslice, hslice */
+ 0x2d4d, /* kvaslice, kvhslice */
+ 0x2c5c, 0x3a98, 0x0003, /* delete */
+ 0x3ff8, 0x0003, /* exists */
+ 0x2c5c, 0x3178, 0x0534, 0x05d0, 0x2d4c, 0x3b48, 0x3f04, 0x0003, /* rv2hv */
+ 0x2c5c, 0x2b58, 0x0f94, 0x18f0, 0x2d4c, 0x3f04, 0x0003, /* multideref */
+ 0x24bc, 0x3179, /* split */
+ 0x2c5c, 0x2119, /* list */
+ 0x3d78, 0x3414, 0x1230, 0x27cc, 0x3768, 0x28c4, 0x30e1, /* sort */
+ 0x27cc, 0x0003, /* reverse */
+ 0x1f44, 0x0003, /* grepstart, grepwhile, mapstart, mapwhile */
+ 0x29f8, 0x0003, /* flip, flop */
+ 0x2c5c, 0x0003, /* cond_expr */
+ 0x2c5c, 0x0e18, 0x0256, 0x028c, 0x40c8, 0x3f04, 0x2581, /* entersub */
+ 0x34d8, 0x0003, /* leavesub, leavesublv, leavewrite, leaveeval */
0x00bc, 0x012f, /* caller */
- 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 */
+ 0x22f5, /* nextstate, dbstate */
+ 0x2afc, 0x34d9, /* leave */
+ 0x2c5c, 0x3178, 0x0e8c, 0x37e9, /* enteriter */
+ 0x37e9, /* iter */
+ 0x2afc, 0x0067, /* leaveloop */
+ 0x42dc, 0x0003, /* last, next, redo, dump, goto */
+ 0x335c, 0x3278, 0x2734, 0x2670, 0x012f, /* open */
+ 0x1b90, 0x1dec, 0x1ca8, 0x1a64, 0x0003, /* ftrread, ftrwrite, ftrexec, fteread, ftewrite, fteexec */
+ 0x1b90, 0x1dec, 0x1ca8, 0x0003, /* ftis, ftsize, ftmtime, ftatime, ftctime, ftrowned, fteowned, ftzero, ftsock, ftchr, ftblk, ftfile, ftdir, ftpipe, ftsuid, ftsgid, ftsvtx, ftlink, fttty, fttext, ftbinary */
+ 0x4171, /* wait, getppid, time */
+ 0x3574, 0x0c30, 0x068c, 0x4248, 0x2204, 0x0003, /* entereval */
+ 0x2e1c, 0x0018, 0x1144, 0x1061, /* coreargs */
+ 0x2c5c, 0x019b, /* padrange */
+ 0x2c5c, 0x3e58, 0x0376, 0x294c, 0x1748, 0x0067, /* refassign */
+ 0x2c5c, 0x3e58, 0x0376, 0x294c, 0x1748, 0x0003, /* lvref */
+ 0x2c5d, /* lvrefslice */
+ 0x2c5c, 0x3e58, 0x0003, /* lvavref */
};
@@ -2935,7 +2939,7 @@ EXTCONST U8 PL_op_private_valid[] = {
/* TRANS */ (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF|OPpTRANS_IDENTICAL|OPpTRANS_SQUASH|OPpTARGET_MY|OPpTRANS_COMPLEMENT|OPpTRANS_GROWS|OPpTRANS_DELETE),
/* TRANSR */ (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF|OPpTRANS_IDENTICAL|OPpTRANS_SQUASH|OPpTARGET_MY|OPpTRANS_COMPLEMENT|OPpTRANS_GROWS|OPpTRANS_DELETE),
/* SASSIGN */ (OPpARG2_MASK|OPpASSIGN_BACKWARDS|OPpASSIGN_CV_TO_GV),
- /* AASSIGN */ (OPpARG2_MASK|OPpMAYBE_LVSUB|OPpASSIGN_COMMON),
+ /* AASSIGN */ (OPpARG2_MASK|OPpMAYBE_LVSUB|OPpASSIGN_COMMON_AGG|OPpASSIGN_COMMON_RC1|OPpASSIGN_COMMON_SCALAR),
/* CHOP */ (OPpARG1_MASK),
/* SCHOP */ (OPpARG1_MASK),
/* CHOMP */ (OPpARG1_MASK|OPpTARGET_MY),
diff --git a/pad.h b/pad.h
index 9e3caa65d0..ab46cf4688 100644
--- a/pad.h
+++ b/pad.h
@@ -441,12 +441,11 @@ Assumes the slot entry is a valid C<our> lexical.
=for apidoc m|STRLEN|PAD_COMPNAME_GEN|PADOFFSET po
The generation number of the name at offset C<po> in the current
-compiling pad (lvalue). Note that C<SvUVX> is hijacked for this purpose.
+compiling pad (lvalue).
=for apidoc m|STRLEN|PAD_COMPNAME_GEN_set|PADOFFSET po|int gen
Sets the generation number of the name at offset C<po> in the current
-ling pad (lvalue) to C<gen>. Note that C<SvUV_set> is hijacked for this purpose.
-
+ling pad (lvalue) to C<gen>.
=cut
*/
diff --git a/pp_ctl.c b/pp_ctl.c
index cc6a55f76e..5b58f47684 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -2145,7 +2145,6 @@ PP(pp_enteriter)
save_pushptrptr(gv, SvREFCNT_inc(*svp), SAVEt_GVSV);
*svp = newSV(0);
itervar = (void *)gv;
- save_aliased_sv(gv);
}
else {
SV * const sv = POPs;
diff --git a/pp_hot.c b/pp_hot.c
index 10945101ab..e8fd4aec12 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -47,7 +47,6 @@ PP(pp_const)
PP(pp_nextstate)
{
PL_curcop = (COP*)PL_op;
- PL_sawalias = 0;
TAINT_NOT; /* Each statement is presumed innocent */
PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
FREETMPS;
@@ -63,8 +62,6 @@ PP(pp_gvsv)
PUSHs(save_scalar(cGVOP_gv));
else
PUSHs(GvSVn(cGVOP_gv));
- if (GvREFCNT(cGVOP_gv) > 1 || GvALIASED_SV(cGVOP_gv))
- PL_sawalias = TRUE;
RETURN;
}
@@ -99,9 +96,6 @@ PP(pp_gv)
{
dSP;
XPUSHs(MUTABLE_SV(cGVOP_gv));
- if (isGV(cGVOP_gv)
- && (GvREFCNT(cGVOP_gv) > 1 || GvALIASED_SV(cGVOP_gv)))
- PL_sawalias = TRUE;
RETURN;
}
@@ -1003,6 +997,148 @@ S_do_oddball(pTHX_ SV **oddkey, SV **firstkey)
}
}
+
+/* Do a mark and sweep with the SVf_BREAK flag to detect elements which
+ * are common to both the LHS and RHS of an aassign, and replace them
+ * with copies. All these copies are made before the actual list assign is
+ * done.
+ *
+ * For example in ($a,$b) = ($b,$a), assigning the value of the first RHS
+ * element ($b) to the first LH element ($a), modifies $a; when the
+ * second assignment is done, the second RH element now has the wrong
+ * value. So we initially replace the RHS with ($b, mortalcopy($a)).
+ * Note that we don't need to make a mortal copy of $b.
+ *
+ * The algorithm below works by, for every RHS element, mark the
+ * corresponding LHS target element with SVf_BREAK. Then if the RHS
+ * element is found with SVf_BREAK set, it means it would have been
+ * modified, so make a copy.
+ * Note that by scanning both LHS and RHS in lockstep, we avoid
+ * unnecessary copies (like $b above) compared with a naive
+ * "mark all LHS; copy all marked RHS; unmark all LHS".
+ *
+ * If the LHS element is a 'my' declaration' and has a refcount of 1, then
+ * it can't be common and can be skipped.
+ */
+
+PERL_STATIC_INLINE void
+S_aassign_copy_common(pTHX_ SV **firstlelem, SV **lastlelem,
+ SV **firstrelem, SV **lastrelem)
+{
+ dVAR;
+ SV **relem;
+ SV **lelem;
+ SSize_t lcount = lastlelem - firstlelem + 1;
+ bool marked = FALSE; /* have we marked any LHS with SVf_BREAK ? */
+ bool const do_rc1 = cBOOL(PL_op->op_private & OPpASSIGN_COMMON_RC1);
+
+ assert(!PL_in_clean_all); /* SVf_BREAK not already in use */
+ assert(firstlelem < lastlelem); /* at least 2 LH elements */
+ assert(firstrelem < lastrelem); /* at least 2 RH elements */
+
+ /* we never have to copy the first RH element; it can't be corrupted
+ * by assigning something to the corresponding first LH element.
+ * So this scan does in a loop: mark LHS[N]; test RHS[N+1]
+ */
+ firstrelem++;
+
+ lelem = firstlelem;
+ relem = firstrelem;
+
+ for (; relem <= lastrelem; relem++) {
+ SV *svr;
+
+ /* mark next LH element */
+
+ if (--lcount >= 0) {
+ SV *svl = *lelem++;
+
+ if (UNLIKELY(!svl)) {/* skip AV alias marker */
+ assert (lelem <= lastlelem);
+ svl = *lelem++;
+ lcount--;
+ }
+
+ assert(svl);
+ if (SvTYPE(svl) == SVt_PVAV || SvTYPE(svl) == SVt_PVHV) {
+ if (!marked)
+ return;
+ /* this LH element will consume all further args;
+ * no need to mark any further LH elements (if any).
+ * But we still need to scan any remaining RHS elements;
+ * set lcount negative to distinguish from lcount == 0,
+ * so the loop condition continues being true
+ */
+ lcount = -1;
+ lelem--; /* no need to unmark this element */
+ }
+ else if (!(do_rc1 && SvREFCNT(svl) == 1) && svl != &PL_sv_undef) {
+ assert(!SvIMMORTAL(svl));
+ SvFLAGS(svl) |= SVf_BREAK;
+ marked = TRUE;
+ }
+ else if (!marked) {
+ /* don't check RH element if no SVf_BREAK flags set yet */
+ if (!lcount)
+ break;
+ continue;
+ }
+ }
+
+ /* see if corresponding RH element needs copying */
+
+ assert(marked);
+ svr = *relem;
+ assert(svr);
+
+ if (UNLIKELY(SvFLAGS(svr) & SVf_BREAK)) {
+
+ TAINT_NOT; /* Each item is independent */
+
+ /* Dear TODO test in t/op/sort.t, I love you.
+ (It's relying on a panic, not a "semi-panic" from newSVsv()
+ and then an assertion failure below.) */
+ if (UNLIKELY(SvIS_FREED(svr))) {
+ Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p",
+ (void*)svr);
+ }
+ /* avoid break flag while copying; otherwise COW etc
+ * disabled... */
+ SvFLAGS(svr) &= ~SVf_BREAK;
+ /* Not newSVsv(), as it does not allow copy-on-write,
+ resulting in wasteful copies.
+ Also, we use SV_NOSTEAL in case the SV is used more than
+ once, e.g. (...) = (f())[0,0]
+ Where the same SV appears twice on the RHS without a ref
+ count bump. (Although I suspect that the SV won't be
+ stealable here anyway - DAPM).
+ */
+ *relem = sv_mortalcopy_flags(svr,
+ SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL);
+ /* ... but restore afterwards in case it's needed again,
+ * e.g. ($a,$b,$c) = (1,$a,$a)
+ */
+ SvFLAGS(svr) |= SVf_BREAK;
+ }
+
+ if (!lcount)
+ break;
+ }
+
+ if (!marked)
+ return;
+
+ /*unmark LHS */
+
+ while (lelem > firstlelem) {
+ SV * const svl = *(--lelem);
+ if (svl)
+ SvFLAGS(svl) &= ~SVf_BREAK;
+ }
+}
+
+
+
PP(pp_aassign)
{
dVAR; dSP;
@@ -1021,50 +1157,40 @@ PP(pp_aassign)
HV *hash;
SSize_t i;
int magic;
- U32 lval = 0;
+ U32 lval;
PL_delaymagic = DM_DELAY; /* catch simultaneous items */
- gimme = GIMME_V;
- if (gimme == G_ARRAY)
- lval = PL_op->op_flags & OPf_MOD || LVRET;
/* If there's a common identifier on both sides we have to take
* special care that assigning the identifier on the left doesn't
* clobber a value on the right that's used later in the list.
- * Don't bother if LHS is just an empty hash or array.
*/
- if ( (PL_op->op_private & OPpASSIGN_COMMON || PL_sawalias)
- && (
- firstlelem != lastlelem
- || ! ((sv = *firstlelem))
- || SvMAGICAL(sv)
- || ! (SvTYPE(sv) == SVt_PVAV || SvTYPE(sv) == SVt_PVHV)
- || (SvTYPE(sv) == SVt_PVAV && AvFILL((AV*)sv) != -1)
- || (SvTYPE(sv) == SVt_PVHV && HvUSEDKEYS((HV*)sv) != 0)
- )
+ if ( (PL_op->op_private & (OPpASSIGN_COMMON_SCALAR|OPpASSIGN_COMMON_RC1))
+ /* at least 2 LH and RH elements, or commonality isn't an issue */
+ && (firstlelem < lastlelem && firstrelem < lastrelem)
) {
- EXTEND_MORTAL(lastrelem - firstrelem + 1);
- for (relem = firstrelem; relem <= lastrelem; relem++) {
- if (LIKELY((sv = *relem))) {
- TAINT_NOT; /* Each item is independent */
-
- /* Dear TODO test in t/op/sort.t, I love you.
- (It's relying on a panic, not a "semi-panic" from newSVsv()
- and then an assertion failure below.) */
- if (UNLIKELY(SvIS_FREED(sv))) {
- Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p",
- (void*)sv);
- }
- /* Not newSVsv(), as it does not allow copy-on-write,
- resulting in wasteful copies. We need a second copy of
- a temp here, hence the SV_NOSTEAL. */
- *relem = sv_mortalcopy_flags(sv,SV_GMAGIC|SV_DO_COW_SVSETSV
- |SV_NOSTEAL);
- }
- }
+ if (PL_op->op_private & OPpASSIGN_COMMON_RC1) {
+ /* skip the scan if all scalars have a ref count of 1 */
+ for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
+ sv = *lelem;
+ if (!sv || SvREFCNT(sv) == 1)
+ continue;
+ if (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVAV)
+ goto do_scan;
+ break;
+ }
+ }
+ else {
+ do_scan:
+ S_aassign_copy_common(aTHX_
+ firstlelem, lastlelem, firstrelem, lastrelem);
+ }
}
+ gimme = GIMME_V;
+ lval = (gimme == G_ARRAY) ? (PL_op->op_flags & OPf_MOD || LVRET) : 0;
+
relem = firstrelem;
lelem = firstlelem;
ary = NULL;
@@ -1080,36 +1206,77 @@ PP(pp_aassign)
ASSUME(SvTYPE(sv) == SVt_PVAV);
}
switch (SvTYPE(sv)) {
- case SVt_PVAV:
+ case SVt_PVAV: {
+ bool already_copied = FALSE;
ary = MUTABLE_AV(sv);
magic = SvMAGICAL(ary) != 0;
ENTER;
SAVEFREESV(SvREFCNT_inc_simple_NN(sv));
- av_clear(ary);
+
+ /* We need to clear ary. The is a danger that if we do this,
+ * elements on the RHS may be prematurely freed, e.g.
+ * @a = ($a[0]);
+ * In the case of possible commonality, make a copy of each
+ * RHS SV *before* clearing the array, and add a reference
+ * from the tmps stack, so that it doesn't leak on death.
+ * Otherwise, make a copy of each RHS SV only as we're storing
+ * it into the array - that way we don't have to worry about
+ * it being leaked if we die, but don't incur the cost of
+ * mortalising everything.
+ */
+
+ if ( (PL_op->op_private & OPpASSIGN_COMMON_AGG)
+ && (relem <= lastrelem)
+ && (magic || AvFILL(ary) != -1))
+ {
+ SV **svp;
+ EXTEND_MORTAL(lastrelem - relem + 1);
+ for (svp = relem; svp <= lastrelem; svp++) {
+ /* see comment in S_aassign_copy_common about SV_NOSTEAL */
+ *svp = sv_mortalcopy_flags(*svp,
+ SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL);
+ TAINT_NOT;
+ }
+ already_copied = TRUE;
+ }
+
+ av_clear(ary);
av_extend(ary, lastrelem - relem);
i = 0;
while (relem <= lastrelem) { /* gobble up all the rest */
SV **didstore;
- if (LIKELY(*relem))
- SvGETMAGIC(*relem); /* before newSV, in case it dies */
if (LIKELY(!alias)) {
- sv = newSV(0);
- sv_setsv_nomg(sv, *relem);
- *relem = sv;
+ if (already_copied)
+ sv = *relem;
+ else {
+ if (LIKELY(*relem))
+ /* before newSV, in case it dies */
+ SvGETMAGIC(*relem);
+ sv = newSV(0);
+ /* see comment in S_aassign_copy_common about
+ * SV_NOSTEAL */
+ sv_setsv_flags(sv, *relem,
+ (SV_DO_COW_SVSETSV|SV_NOSTEAL));
+ *relem = sv;
+ }
}
else {
+ if (!already_copied)
+ SvGETMAGIC(*relem);
if (!SvROK(*relem))
DIE(aTHX_ "Assigned value is not a reference");
if (SvTYPE(SvRV(*relem)) > SVt_PVLV)
/* diag_listed_as: Assigned value is not %s reference */
DIE(aTHX_
"Assigned value is not a SCALAR reference");
- if (lval)
+ if (lval && !already_copied)
*relem = sv_mortalcopy(*relem);
/* XXX else check for weak refs? */
sv = SvREFCNT_inc_simple_NN(SvRV(*relem));
}
relem++;
+ if (already_copied)
+ SvREFCNT_inc_simple_NN(sv); /* undo mortal free */
didstore = av_store(ary,i++,sv);
if (magic) {
if (!didstore)
@@ -1123,12 +1290,15 @@ PP(pp_aassign)
SvSETMAGIC(MUTABLE_SV(ary));
LEAVE;
break;
+ }
+
case SVt_PVHV: { /* normal hash */
SV *tmpstr;
int odd;
int duplicates = 0;
SV** topelem = relem;
SV **firsthashrelem = relem;
+ bool already_copied = FALSE;
hash = MUTABLE_HV(sv);
magic = SvMAGICAL(hash) != 0;
@@ -1143,7 +1313,31 @@ PP(pp_aassign)
ENTER;
SAVEFREESV(SvREFCNT_inc_simple_NN(sv));
+
+ /* We need to clear hash. The is a danger that if we do this,
+ * elements on the RHS may be prematurely freed, e.g.
+ * %h = (foo => $h{bar});
+ * In the case of possible commonality, make a copy of each
+ * RHS SV *before* clearing the hash, and add a reference
+ * from the tmps stack, so that it doesn't leak on death.
+ */
+
+ if ( (PL_op->op_private & OPpASSIGN_COMMON_AGG)
+ && (relem <= lastrelem)
+ && (magic || HvUSEDKEYS(hash)))
+ {
+ SV **svp;
+ EXTEND_MORTAL(lastrelem - relem + 1);
+ for (svp = relem; svp <= lastrelem; svp++) {
+ *svp = sv_mortalcopy_flags(*svp,
+ SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL);
+ TAINT_NOT;
+ }
+ already_copied = TRUE;
+ }
+
hv_clear(hash);
+
while (LIKELY(relem < lastrelem+odd)) { /* gobble up all the rest */
HE *didstore;
assert(*relem);
@@ -1151,14 +1345,19 @@ PP(pp_aassign)
to avoid having the next op modify our rhs. Copy
it also if it is gmagical, lest it make the
hv_store_ent call below croak, leaking the value. */
- sv = lval || SvGMAGICAL(*relem)
+ sv = (lval || SvGMAGICAL(*relem)) && !already_copied
? sv_mortalcopy(*relem)
: *relem;
relem++;
assert(*relem);
- SvGETMAGIC(*relem);
- tmpstr = newSV(0);
- sv_setsv_nomg(tmpstr,*relem++); /* value */
+ if (already_copied)
+ tmpstr = *relem++;
+ else {
+ SvGETMAGIC(*relem);
+ tmpstr = newSV(0);
+ sv_setsv_nomg(tmpstr,*relem++); /* value */
+ }
+
if (gimme == G_ARRAY) {
if (hv_exists_ent(hash, sv, 0))
/* key overwrites an existing entry */
@@ -1171,6 +1370,8 @@ PP(pp_aassign)
*topelem++ = tmpstr;
}
}
+ if (already_copied)
+ SvREFCNT_inc_simple_NN(tmpstr); /* undo mortal free */
didstore = hv_store_ent(hash,sv,tmpstr,0);
if (magic) {
if (!didstore) sv_2mortal(tmpstr);
diff --git a/proto.h b/proto.h
index 12bbb2e991..a3bd488b44 100644
--- a/proto.h
+++ b/proto.h
@@ -2659,9 +2659,6 @@ PERL_CALLCONV void Perl_save_adelete(pTHX_ AV *av, SSize_t key);
PERL_CALLCONV void Perl_save_aelem_flags(pTHX_ AV* av, SSize_t idx, SV **sptr, const U32 flags);
#define PERL_ARGS_ASSERT_SAVE_AELEM_FLAGS \
assert(av); assert(sptr)
-PERL_CALLCONV void Perl_save_aliased_sv(pTHX_ GV* gv);
-#define PERL_ARGS_ASSERT_SAVE_ALIASED_SV \
- assert(gv)
PERL_CALLCONV I32 Perl_save_alloc(pTHX_ I32 size, I32 pad);
PERL_CALLCONV void Perl_save_aptr(pTHX_ AV** aptr);
#define PERL_ARGS_ASSERT_SAVE_APTR \
@@ -4260,7 +4257,6 @@ STATIC AV* S_mro_get_linear_isa_dfs(pTHX_ HV* stash, U32 level);
assert(stash)
#endif
#if defined(PERL_IN_OP_C)
-PERL_STATIC_INLINE bool S_aassign_common_vars(pTHX_ OP* o);
STATIC void S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs);
#define PERL_ARGS_ASSERT_APPLY_ATTRS \
assert(stash); assert(target)
diff --git a/regen/op_private b/regen/op_private
index bcc1c212fa..54980f0630 100644
--- a/regen/op_private
+++ b/regen/op_private
@@ -480,11 +480,24 @@ addbits($_, 7 => qw(OPpPV_IS_UTF8 UTF)) for qw(last redo next goto dump);
addbits($_, 6 => qw(OPpPAD_STATE STATE)) for qw(padav padhv padsv lvavref
lvref refassign pushmark);
+# NB: both sassign and aassign use the 'OPpASSIGN' naming convention
+# for their private flags
+# there *may* be common scalar items on both sides of a list assign:
+# run-time checking will be needed.
+addbits('aassign', 6 => qw(OPpASSIGN_COMMON_SCALAR COM_SCALAR));
+#
+# as above, but it's possible to check for non-commonality with just
+# a SvREFCNT(lhs) == 1 test for each lhs element
+addbits('aassign', 5 => qw(OPpASSIGN_COMMON_RC1 COM_RC1));
+
+# run-time checking is required for an aggregate on the LHS
+addbits('aassign', 4 => qw(OPpASSIGN_COMMON_AGG COM_AGG));
-addbits('aassign', 6 => qw(OPpASSIGN_COMMON COMMON));
+# NB: both sassign and aassign use the 'OPpASSIGN' naming convention
+# for their private flags
addbits('sassign',
6 => qw(OPpASSIGN_BACKWARDS BKWARD), # Left & right switched
diff --git a/scope.c b/scope.c
index 5699d7cbd7..9768c30734 100644
--- a/scope.c
+++ b/scope.c
@@ -720,16 +720,6 @@ Perl_save_alloc(pTHX_ I32 size, I32 pad)
return start;
}
-void
-Perl_save_aliased_sv(pTHX_ GV *gv)
-{
- dSS_ADD;
- PERL_ARGS_ASSERT_SAVE_ALIASED_SV;
- SS_ADD_PTR(gp_ref(GvGP(gv)));
- SS_ADD_UV(SAVEt_GP_ALIASED_SV | cBOOL(GvALIASED_SV(gv)) << 8);
- SS_ADD_END(2);
-}
-
#define ARG0_SV MUTABLE_SV(arg0.any_ptr)
@@ -1252,24 +1242,6 @@ Perl_leave_scope(pTHX_ I32 base)
case SAVEt_READONLY_OFF:
SvREADONLY_off(ARG0_SV);
break;
- case SAVEt_GP_ALIASED_SV: {
- /* The GP may have been abandoned, leaving the savestack with
- the only remaining reference to it. */
- GP * const gp = (GP *)ARG0_PTR;
- if (gp->gp_refcnt == 1) {
- GV * const gv = (GV *)sv_2mortal(newSV_type(SVt_PVGV));
- isGV_with_GP_on(gv);
- GvGP_set(gv,gp);
- gp_free(gv);
- isGV_with_GP_off(gv);
- }
- else {
- gp->gp_refcnt--;
- if (uv >> 8) gp->gp_flags |= GPf_ALIASED_SV;
- else gp->gp_flags &= ~GPf_ALIASED_SV;
- }
- break;
- }
default:
Perl_croak(aTHX_ "panic: leave_scope inconsistency %u", type);
}
diff --git a/scope.h b/scope.h
index 97ef3faa91..0de5b7777a 100644
--- a/scope.h
+++ b/scope.h
@@ -21,7 +21,7 @@
/* one arg */
-#define SAVEt_GP_ALIASED_SV 4
+/*** SPARE 4 ***/
#define SAVEt_BOOL 5
#define SAVEt_COMPILE_WARNINGS 6
#define SAVEt_COMPPAD 7
diff --git a/sv.c b/sv.c
index 79d2719da8..cd1bbf528e 100644
--- a/sv.c
+++ b/sv.c
@@ -4119,18 +4119,7 @@ Perl_gv_setref(pTHX_ SV *const dstr, SV *const sstr)
&& CopSTASH_ne(PL_curcop, GvSTASH(dstr))) {
GvFLAGS(dstr) |= import_flag;
}
- if (import_flag == GVf_IMPORTED_SV) {
- if (intro) {
- save_aliased_sv((GV *)dstr);
- }
- /* Turn off the flag if sref is not referenced elsewhere,
- even by weak refs. (SvRMAGICAL is a pessimistic check for
- back refs.) */
- if (SvREFCNT(sref) <= 2 && !SvRMAGICAL(sref))
- GvALIASED_SV_off(dstr);
- else
- GvALIASED_SV_on(dstr);
- }
+
if (stype == SVt_PVHV) {
const char * const name = GvNAME((GV*)dstr);
const STRLEN len = GvNAMELEN(dstr);
@@ -14163,13 +14152,6 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
ptr = POPPTR(ss,ix);
TOPPTR(nss,ix) = parser_dup((const yy_parser*)ptr, param);
break;
- case SAVEt_GP_ALIASED_SV: {
- GP * gp_ptr = (GP *)POPPTR(ss,ix);
- GP * new_gp_ptr = gp_dup(gp_ptr, param);
- TOPPTR(nss,ix) = new_gp_ptr;
- new_gp_ptr->gp_refcnt++;
- break;
- }
default:
Perl_croak(aTHX_
"panic: ss_dup inconsistency (%"IVdf")", (IV) type);
@@ -14404,7 +14386,6 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
PL_minus_F = proto_perl->Iminus_F;
PL_doswitches = proto_perl->Idoswitches;
PL_dowarn = proto_perl->Idowarn;
- PL_sawalias = proto_perl->Isawalias;
#ifdef PERL_SAWAMPERSAND
PL_sawampersand = proto_perl->Isawampersand;
#endif
diff --git a/sv.h b/sv.h
index c84d73c6e4..bc5daa9212 100644
--- a/sv.h
+++ b/sv.h
@@ -399,7 +399,9 @@ perform the upgrade if necessary. See C<svtype>.
#define SVf_BREAK 0x04000000 /* refcnt is artificially low - used by
SVs in final arena cleanup.
Set in S_regtry on PL_reg_curpm, so that
- perl_destruct will skip it. */
+ perl_destruct will skip it.
+ Used for mark and sweep by OP_AASSIGN
+ */
#define SVf_READONLY 0x08000000 /* may not be modified */
diff --git a/t/op/aassign.t b/t/op/aassign.t
new file mode 100644
index 0000000000..e73e172ed2
--- /dev/null
+++ b/t/op/aassign.t
@@ -0,0 +1,335 @@
+#!./perl -w
+
+# Some miscellaneous checks for the list assignment operator, OP_AASSIGN.
+#
+# This file was only added in 2015; before then, such tests were
+# typically in various other random places like op/array.t. This test file
+# doesn't therefore attempt to be comprehensive; it merely provides a
+# central place to new put additional tests, especially those related to
+# the trickiness of commonality, e.g. ($a,$b) = ($b,$a).
+#
+# In particular, it's testing the flags
+# OPpASSIGN_COMMON_SCALAR
+# OPpASSIGN_COMMON_RC1
+# OPpASSIGN_COMMON_AGG
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require './test.pl';
+}
+
+use warnings;
+use strict;
+
+# general purpose package vars
+
+our $pkg_scalar;
+our @pkg_array;
+our %pkg_hash;
+
+sub f_ret_14 { return 1..4 }
+
+# stringify a hash ref
+
+sub sh {
+ my $rh = $_[0];
+ join ',', map "$_:$rh->{$_}", sort keys %$rh;
+}
+
+
+# where the RHS has surplus elements
+
+{
+ my ($a,$b);
+ ($a,$b) = f_ret_14();
+ is("$a:$b", "1:2", "surplus");
+}
+
+# common with slices
+
+{
+ my @a = (1,2);
+ @a[0,1] = @a[1,0];
+ is("$a[0]:$a[1]", "2:1", "lex array slice");
+}
+
+# package alias
+
+{
+ my ($a, $b) = 1..2;
+ for $pkg_scalar ($a) {
+ ($pkg_scalar, $b) = (3, $a);
+ is($pkg_scalar, 3, "package alias pkg");
+ is("$a:$b", "3:1", "package alias a:b");
+ }
+}
+
+# my array/hash populated via closure
+
+{
+ my $ra = f1();
+ my ($x, @a) = @$ra;
+ sub f1 { $x = 1; @a = 2..4; \@a }
+ is($x, 2, "my: array closure x");
+ is("@a", "3 4", "my: array closure a");
+
+ my $rh = f2();
+ my ($k, $v, %h) = (d => 4, %$rh, e => 6);
+ sub f2 { $k = 'a'; $v = 1; %h = qw(b 2 c 3); \%h }
+ is("$k:$v", "d:4", "my: hash closure k:v");
+ is(sh(\%h), "b:2,c:3,e:6", "my: hash closure h");
+}
+
+
+# various shared element scenarios within a my (...)
+
+{
+ my ($x,$y) = f3(); # $x and $y on both sides
+ sub f3 : lvalue { ($x,$y) = (1,2); $y, $x }
+ is ("$x:$y", "2:1", "my: scalar and lvalue sub");
+}
+
+{
+ my $ra = f4();
+ my @a = @$ra; # elements of @a on both sides
+ sub f4 { @a = 1..4; \@a }
+ is("@a", "1 2 3 4", "my: array and elements");
+}
+
+{
+ my $rh = f5();
+ my %h = %$rh; # elements of %h on both sides
+ sub f5 { %h = qw(a 1 b 2 c 3); \%h }
+ is(sh(\%h), "a:1,b:2,c:3", "my: hash and elements");
+}
+
+{
+ f6();
+ our $xalias6;
+ my ($x, $y) = (2, $xalias6);
+ sub f6 { $x = 1; *xalias6 = \$x; }
+ is ("$x:$y", "2:1", "my: pkg var aliased to lexical");
+}
+
+
+{
+ my @a;
+ f7();
+ my ($x,$y) = @a;
+ is ("$x:$y", "2:1", "my: lex array elements aliased");
+
+ sub f7 {
+ ($x, $y) = (1,2);
+ use feature 'refaliasing';
+ no warnings 'experimental';
+ \($a[0], $a[1]) = \($y,$x);
+ }
+}
+
+{
+ @pkg_array = ();
+ f8();
+ my ($x,$y) = @pkg_array;
+ is ("$x:$y", "2:1", "my: pkg array elements aliased");
+
+ sub f8 {
+ ($x, $y) = (1,2);
+ use feature 'refaliasing';
+ no warnings 'experimental';
+ \($pkg_array[0], $pkg_array[1]) = \($y,$x);
+ }
+}
+
+{
+ f9();
+ my ($x,$y) = f9();
+ is ("$x:$y", "2:1", "my: pkg scalar alias");
+
+ our $xalias9;
+ sub f9 : lvalue {
+ ($x, $y) = (1,2);
+ *xalias9 = \$x;
+ $y, $xalias9;
+ }
+}
+
+{
+ use feature 'refaliasing';
+ no warnings 'experimental';
+
+ f10();
+ our $pkg10;
+ \(my $lex) = \$pkg10;
+ my @a = ($lex,3); # equivalent to ($a[0],3)
+ is("@a", "1 3", "my: lex alias of array alement");
+
+ sub f10 {
+ @a = (1,2);
+ \$pkg10 = \$a[0];
+ }
+
+}
+
+{
+ use feature 'refaliasing';
+ no warnings 'experimental';
+
+ f11();
+ my @b;
+ my @a = (@b);
+ is("@a", "2 1", "my: lex alias of array alements");
+
+ sub f11 {
+ @a = (1,2);
+ \$b[0] = \$a[1];
+ \$b[1] = \$a[0];
+ }
+}
+
+# package aliasing
+
+{
+ my ($x, $y) = (1,2);
+
+ for $pkg_scalar ($x) {
+ ($pkg_scalar, $y) = (3, $x);
+ is("$pkg_scalar,$y", "3,1", "package scalar aliased");
+ }
+}
+
+# lvalue subs on LHS
+
+{
+ my @a;
+ sub f12 : lvalue { @a }
+ (f12()) = 1..3;
+ is("@a", "1 2 3", "lvalue sub on RHS returns array");
+}
+
+{
+ my ($x,$y);
+ sub f13 : lvalue { $x,$y }
+ (f13()) = 1..3;
+ is("$x:$y", "1:2", "lvalue sub on RHS returns scalars");
+}
+
+
+# package shared scalar vars
+
+{
+ our $pkg14a = 1;
+ our $pkg14b = 2;
+ ($pkg14a,$pkg14b) = ($pkg14b,$pkg14a);
+ is("$pkg14a:$pkg14b", "2:1", "shared package scalars");
+}
+
+# lexical shared scalar vars
+
+{
+ my $a = 1;
+ my $b = 2;
+ ($a,$b) = ($b,$a);
+ is("$a:$b", "2:1", "shared lexical scalars");
+}
+
+
+# lexical nested array elem swap
+
+{
+ my @a;
+ $a[0][0] = 1;
+ $a[0][1] = 2;
+ ($a[0][0],$a[0][1]) = ($a[0][1],$a[0][0]);
+ is("$a[0][0]:$a[0][1]", "2:1", "lexical nested array elem swap");
+}
+
+# package nested array elem swap
+
+{
+ our @a15;
+ $a15[0][0] = 1;
+ $a15[0][1] = 2;
+ ($a15[0][0],$a15[0][1]) = ($a15[0][1],$a15[0][0]);
+ is("$a15[0][0]:$a15[0][1]", "2:1", "package nested array elem swap");
+}
+
+# surplus RHS junk
+#
+{
+ our ($a16, $b16);
+ ($a16, undef, $b16) = 1..30;
+ is("$a16:$b16", "1:3", "surplus RHS junk");
+}
+
+# my ($scalar,....) = @_
+#
+# technically this is an unsafe usage commonality-wise, but
+# a) you have to try really hard to break it, as this test shows;
+# b) it's such an important usage that for performance reasons we
+# mark it as safe even though it isn't really. Hence it's a TODO.
+
+{
+ local $::TODO = 'cheat and optimise my (....) = @_';
+ local @_ = 1..3;
+ &f17;
+ my ($a, @b) = @_;
+ is("($a)(@b)", "(3)(2 1)", 'my (....) = @_');
+
+ sub f17 {
+ use feature 'refaliasing';
+ no warnings 'experimental';
+ ($a, @b) = @_;
+ \($_[2], $_[1], $_[0]) = \($a, $b[0], $b[1]);
+ }
+}
+
+# single scalar on RHS that's in an aggregate on LHS
+
+{
+ my @a = 1..3;
+ for my $x ($a[0]) {
+ (@a) = ($x);
+ is ("(@a)", "(1)", 'single scalar on RHS, agg');
+ }
+}
+
+# TEMP buffer stealing.
+# In something like
+# (...) = (f())[0,0]
+# the same TEMP RHS element may be used more than once, so when copying
+# it, we mustn't steal its buffer.
+
+{
+ # a string long enough for COW and buffer stealing to be enabled
+ my $long = 'def' . ('x' x 2000);
+
+ # a sub that is intended to return a TEMP string that isn't COW
+ # the concat returns a non-COW PADTMP; pp_leavesub sees a long
+ # stealable string, so creates a TEMP with the stolen buffer from the
+ # PADTMP - hence it returns a non-COW string
+ sub f18 {
+ my $x = "abc";
+ $x . $long;
+ }
+
+ my @a;
+
+ # with @a initially empty,the code path creates a new copy of each
+ # RHS element to store in the array
+
+ @a = (f18())[0,0];
+ is (substr($a[0], 0, 7), "abcdefx", 'NOSTEAL empty $a[0]');
+ is (substr($a[1], 0, 7), "abcdefx", 'NOSTEAL empty $a[1]');
+
+ # with @a initially non-empty, it takes a different code path that
+ # makes a mortal copy of each RHS element
+ @a = 1..3;
+ @a = (f18())[0,0];
+ is (substr($a[0], 0, 7), "abcdefx", 'NOSTEAL non-empty $a[0]');
+ is (substr($a[1], 0, 7), "abcdefx", 'NOSTEAL non-empty $a[1]');
+
+}
+
+
+done_testing();
diff --git a/t/op/array.t b/t/op/array.t
index 7239d482fc..4f0a772aba 100644
--- a/t/op/array.t
+++ b/t/op/array.t
@@ -6,7 +6,7 @@ BEGIN {
require './test.pl';
}
-plan (172);
+plan (173);
#
# @foo, @bar, and @ary are also used from tie-stdarray after tie-ing them
@@ -549,4 +549,10 @@ is "@ary", 'b a',
for(scalar $#foo) { $_ = 3 }
is $#foo, 3, 'assigning to arylen aliased in foreach(scalar $#arylen)';
+{
+ my @a = qw(a b c);
+ @a = @a;
+ is "@a", 'a b c', 'assigning to itself';
+}
+
"We're included by lib/Tie/Array/std.t so we need to return something true";
diff --git a/t/op/hash.t b/t/op/hash.t
index 429eb38ce2..b4d6c2585f 100644
--- a/t/op/hash.t
+++ b/t/op/hash.t
@@ -207,4 +207,11 @@ torture_hash('a .. zz', 'a' .. 'zz');
torture_hash('0 .. 9', 0 .. 9);
torture_hash("'Perl'", 'Rules');
+{
+ my %h = qw(a x b y c z);
+ no warnings qw(misc uninitialized);
+ %h = $h{a};
+ is(join(':', %h), 'x:', 'hash self-assign');
+}
+
done_testing();
diff --git a/t/op/sort.t b/t/op/sort.t
index 01227e3ff6..2e3ba68828 100644
--- a/t/op/sort.t
+++ b/t/op/sort.t
@@ -6,7 +6,7 @@ BEGIN {
set_up_inc('../lib');
}
use warnings;
-plan(tests => 190);
+plan(tests => 189);
# these shouldn't hang
{
@@ -778,12 +778,16 @@ cmp_ok($answer,'eq','good','sort subr called from other package');
is $@, "", 'abrupt scope exit turns off readonliness';
}
-{
- local $TODO = "sort should make sure elements are not freed in the sort block";
- eval { @nomodify_x=(1..8);
- our @copy = sort { undef @nomodify_x; 1 } (@nomodify_x, 3); };
- is($@, "");
-}
+# I commented out this TODO test because messing with FREEd scalars on the
+# stack can have all sorts of strange side-effects, not made safe by eval
+# - DAPM.
+#
+#{
+# local $TODO = "sort should make sure elements are not freed in the sort block";
+# eval { @nomodify_x=(1..8);
+# our @copy = sort { undef @nomodify_x; 1 } (@nomodify_x, 3); };
+# is($@, "");
+#}
# Sorting shouldn't increase the refcount of a sub
diff --git a/t/perf/benchmarks b/t/perf/benchmarks
index 144b58cb96..ae0f274dcc 100644
--- a/t/perf/benchmarks
+++ b/t/perf/benchmarks
@@ -242,4 +242,384 @@
code => 'index $x, "b"',
},
+
+ # list assign, OP_AASSIGN
+
+
+ # (....) = ()
+
+ 'expr::aassign::ma_empty' => {
+ desc => 'my array assigned empty',
+ setup => '',
+ code => 'my @a = ()',
+ },
+ 'expr::aassign::lax_empty' => {
+ desc => 'non-empty lexical array assigned empty',
+ setup => 'my @a = 1..3;',
+ code => '@a = ()',
+ },
+ 'expr::aassign::llax_empty' => {
+ desc => 'non-empty lexical var and array assigned empty',
+ setup => 'my ($x, @a) = 1..4;',
+ code => '($x, @a) = ()',
+ },
+ 'expr::aassign::3m_empty' => {
+ desc => 'three my vars assigned empty',
+ setup => '',
+ code => 'my ($x,$y,$z) = ()',
+ },
+ 'expr::aassign::3l_empty' => {
+ desc => 'three lexical vars assigned empty',
+ setup => 'my ($x,$y,$z)',
+ code => '($x,$y,$z) = ()',
+ },
+ 'expr::aassign::pa_empty' => {
+ desc => 'package array assigned empty',
+ setup => '',
+ code => '@a = ()',
+ },
+ 'expr::aassign::pax_empty' => {
+ desc => 'non-empty package array assigned empty',
+ setup => '@a = (1,2,3)',
+ code => '@a = ()',
+ },
+ 'expr::aassign::3p_empty' => {
+ desc => 'three package vars assigned empty',
+ setup => '($x,$y,$z) = 1..3;',
+ code => '($x,$y,$z) = ()',
+ },
+
+ # (....) = (1,2,3)
+
+ 'expr::aassign::ma_3c' => {
+ desc => 'my array assigned 3 consts',
+ setup => '',
+ code => 'my @a = (1,2,3)',
+ },
+ 'expr::aassign::lax_3c' => {
+ desc => 'non-empty lexical array assigned 3 consts',
+ setup => 'my @a = 1..3;',
+ code => '@a = (1,2,3)',
+ },
+ 'expr::aassign::llax_3c' => {
+ desc => 'non-empty lexical var and array assigned 3 consts',
+ setup => 'my ($x, @a) = 1..4;',
+ code => '($x, @a) = (1,2,3)',
+ },
+ 'expr::aassign::3m_3c' => {
+ desc => 'three my vars assigned 3 consts',
+ setup => '',
+ code => 'my ($x,$y,$z) = (1,2,3)',
+ },
+ 'expr::aassign::3l_3c' => {
+ desc => 'three lexical vars assigned 3 consts',
+ setup => 'my ($x,$y,$z)',
+ code => '($x,$y,$z) = (1,2,3)',
+ },
+ 'expr::aassign::pa_3c' => {
+ desc => 'package array assigned 3 consts',
+ setup => '',
+ code => '@a = (1,2,3)',
+ },
+ 'expr::aassign::pax_3c' => {
+ desc => 'non-empty package array assigned 3 consts',
+ setup => '@a = (1,2,3)',
+ code => '@a = (1,2,3)',
+ },
+ 'expr::aassign::3p_3c' => {
+ desc => 'three package vars assigned 3 consts',
+ setup => '($x,$y,$z) = 1..3;',
+ code => '($x,$y,$z) = (1,2,3)',
+ },
+
+ # (....) = @lexical
+
+ 'expr::aassign::ma_la' => {
+ desc => 'my array assigned lexical array',
+ setup => 'my @init = 1..3;',
+ code => 'my @a = @init',
+ },
+ 'expr::aassign::lax_la' => {
+ desc => 'non-empty lexical array assigned lexical array',
+ setup => 'my @init = 1..3; my @a = 1..3;',
+ code => '@a = @init',
+ },
+ 'expr::aassign::llax_la' => {
+ desc => 'non-empty lexical var and array assigned lexical array',
+ setup => 'my @init = 1..3; my ($x, @a) = 1..4;',
+ code => '($x, @a) = @init',
+ },
+ 'expr::aassign::3m_la' => {
+ desc => 'three my vars assigned lexical array',
+ setup => 'my @init = 1..3;',
+ code => 'my ($x,$y,$z) = @init',
+ },
+ 'expr::aassign::3l_la' => {
+ desc => 'three lexical vars assigned lexical array',
+ setup => 'my @init = 1..3; my ($x,$y,$z)',
+ code => '($x,$y,$z) = @init',
+ },
+ 'expr::aassign::pa_la' => {
+ desc => 'package array assigned lexical array',
+ setup => 'my @init = 1..3;',
+ code => '@a = @init',
+ },
+ 'expr::aassign::pax_la' => {
+ desc => 'non-empty package array assigned lexical array',
+ setup => 'my @init = 1..3; @a = @init',
+ code => '@a = @init',
+ },
+ 'expr::aassign::3p_la' => {
+ desc => 'three package vars assigned lexical array',
+ setup => 'my @init = 1..3; ($x,$y,$z) = 1..3;',
+ code => '($x,$y,$z) = @init',
+ },
+
+ # (....) = @package
+
+ 'expr::aassign::ma_pa' => {
+ desc => 'my array assigned package array',
+ setup => '@init = 1..3;',
+ code => 'my @a = @init',
+ },
+ 'expr::aassign::lax_pa' => {
+ desc => 'non-empty lexical array assigned package array',
+ setup => '@init = 1..3; my @a = 1..3;',
+ code => '@a = @init',
+ },
+ 'expr::aassign::llax_pa' => {
+ desc => 'non-empty lexical var and array assigned package array',
+ setup => '@init = 1..3; my ($x, @a) = 1..4;',
+ code => '($x, @a) = @init',
+ },
+ 'expr::aassign::3m_pa' => {
+ desc => 'three my vars assigned package array',
+ setup => '@init = 1..3;',
+ code => 'my ($x,$y,$z) = @init',
+ },
+ 'expr::aassign::3l_pa' => {
+ desc => 'three lexical vars assigned package array',
+ setup => '@init = 1..3; my ($x,$y,$z)',
+ code => '($x,$y,$z) = @init',
+ },
+ 'expr::aassign::pa_pa' => {
+ desc => 'package array assigned package array',
+ setup => '@init = 1..3;',
+ code => '@a = @init',
+ },
+ 'expr::aassign::pax_pa' => {
+ desc => 'non-empty package array assigned package array',
+ setup => '@init = 1..3; @a = @init',
+ code => '@a = @init',
+ },
+ 'expr::aassign::3p_pa' => {
+ desc => 'three package vars assigned package array',
+ setup => '@init = 1..3; ($x,$y,$z) = 1..3;',
+ code => '($x,$y,$z) = @init',
+ },
+
+ # (....) = @_;
+
+ 'expr::aassign::ma_defary' => {
+ desc => 'my array assigned @_',
+ setup => '@_ = 1..3;',
+ code => 'my @a = @_',
+ },
+ 'expr::aassign::lax_defary' => {
+ desc => 'non-empty lexical array assigned @_',
+ setup => '@_ = 1..3; my @a = 1..3;',
+ code => '@a = @_',
+ },
+ 'expr::aassign::llax_defary' => {
+ desc => 'non-empty lexical var and array assigned @_',
+ setup => '@_ = 1..3; my ($x, @a) = 1..4;',
+ code => '($x, @a) = @_',
+ },
+ 'expr::aassign::3m_defary' => {
+ desc => 'three my vars assigned @_',
+ setup => '@_ = 1..3;',
+ code => 'my ($x,$y,$z) = @_',
+ },
+ 'expr::aassign::3l_defary' => {
+ desc => 'three lexical vars assigned @_',
+ setup => '@_ = 1..3; my ($x,$y,$z)',
+ code => '($x,$y,$z) = @_',
+ },
+ 'expr::aassign::pa_defary' => {
+ desc => 'package array assigned @_',
+ setup => '@_ = 1..3;',
+ code => '@a = @_',
+ },
+ 'expr::aassign::pax_defary' => {
+ desc => 'non-empty package array assigned @_',
+ setup => '@_ = 1..3; @a = @_',
+ code => '@a = @_',
+ },
+ 'expr::aassign::3p_defary' => {
+ desc => 'three package vars assigned @_',
+ setup => '@_ = 1..3; ($x,$y,$z) = 1..3;',
+ code => '($x,$y,$z) = @_',
+ },
+
+
+ # (....) = ($lex1,$lex2,$lex3);
+
+ 'expr::aassign::ma_3l' => {
+ desc => 'my array assigned lexicals',
+ setup => 'my ($v1,$v2,$v3) = 1..3;',
+ code => 'my @a = ($v1,$v2,$v3)',
+ },
+ 'expr::aassign::lax_3l' => {
+ desc => 'non-empty lexical array assigned lexicals',
+ setup => 'my ($v1,$v2,$v3) = 1..3; my @a = 1..3;',
+ code => '@a = ($v1,$v2,$v3)',
+ },
+ 'expr::aassign::llax_3l' => {
+ desc => 'non-empty lexical var and array assigned lexicals',
+ setup => 'my ($v1,$v2,$v3) = 1..3; my ($x, @a) = 1..4;',
+ code => '($x, @a) = ($v1,$v2,$v3)',
+ },
+ 'expr::aassign::3m_3l' => {
+ desc => 'three my vars assigned lexicals',
+ setup => 'my ($v1,$v2,$v3) = 1..3;',
+ code => 'my ($x,$y,$z) = ($v1,$v2,$v3)',
+ },
+ 'expr::aassign::3l_3l' => {
+ desc => 'three lexical vars assigned lexicals',
+ setup => 'my ($v1,$v2,$v3) = 1..3; my ($x,$y,$z)',
+ code => '($x,$y,$z) = ($v1,$v2,$v3)',
+ },
+ 'expr::aassign::pa_3l' => {
+ desc => 'package array assigned lexicals',
+ setup => 'my ($v1,$v2,$v3) = 1..3;',
+ code => '@a = ($v1,$v2,$v3)',
+ },
+ 'expr::aassign::pax_3l' => {
+ desc => 'non-empty package array assigned lexicals',
+ setup => 'my ($v1,$v2,$v3) = 1..3; @a = @_',
+ code => '@a = ($v1,$v2,$v3)',
+ },
+ 'expr::aassign::3p_3l' => {
+ desc => 'three package vars assigned lexicals',
+ setup => 'my ($v1,$v2,$v3) = 1..3; ($x,$y,$z) = 1..3;',
+ code => '($x,$y,$z) = ($v1,$v2,$v3)',
+ },
+
+
+ # (....) = ($pkg1,$pkg2,$pkg3);
+
+ 'expr::aassign::ma_3p' => {
+ desc => 'my array assigned 3 package vars',
+ setup => '($v1,$v2,$v3) = 1..3;',
+ code => 'my @a = ($v1,$v2,$v3)',
+ },
+ 'expr::aassign::lax_3p' => {
+ desc => 'non-empty lexical array assigned 3 package vars',
+ setup => '($v1,$v2,$v3) = 1..3; my @a = 1..3;',
+ code => '@a = ($v1,$v2,$v3)',
+ },
+ 'expr::aassign::llax_3p' => {
+ desc => 'non-empty lexical var and array assigned 3 package vars',
+ setup => '($v1,$v2,$v3) = 1..3; my ($x, @a) = 1..4;',
+ code => '($x, @a) = ($v1,$v2,$v3)',
+ },
+ 'expr::aassign::3m_3p' => {
+ desc => 'three my vars assigned 3 package vars',
+ setup => '($v1,$v2,$v3) = 1..3;',
+ code => 'my ($x,$y,$z) = ($v1,$v2,$v3)',
+ },
+ 'expr::aassign::3l_3p' => {
+ desc => 'three lexical vars assigned 3 package vars',
+ setup => '($v1,$v2,$v3) = 1..3; my ($x,$y,$z)',
+ code => '($x,$y,$z) = ($v1,$v2,$v3)',
+ },
+ 'expr::aassign::pa_3p' => {
+ desc => 'package array assigned 3 package vars',
+ setup => '($v1,$v2,$v3) = 1..3;',
+ code => '@a = ($v1,$v2,$v3)',
+ },
+ 'expr::aassign::pax_3p' => {
+ desc => 'non-empty package array assigned 3 package vars',
+ setup => '($v1,$v2,$v3) = 1..3; @a = @_',
+ code => '@a = ($v1,$v2,$v3)',
+ },
+ 'expr::aassign::3p_3p' => {
+ desc => 'three package vars assigned 3 package vars',
+ setup => '($v1,$v2,$v3) = 1..3; ($x,$y,$z) = 1..3;',
+ code => '($x,$y,$z) = ($v1,$v2,$v3)',
+ },
+
+
+ # (....) = (1,2,$shared);
+
+ 'expr::aassign::llax_2c1s' => {
+ desc => 'non-empty lexical var and array assigned 2 consts and 1 shared var',
+ setup => 'my ($x, @a) = 1..4;',
+ code => '($x, @a) = (1,2,$x)',
+ },
+ 'expr::aassign::3l_2c1s' => {
+ desc => 'three lexical vars assigned 2 consts and 1 shared var',
+ setup => 'my ($x,$y,$z) = 1..3;',
+ code => '($x,$y,$z) = (1,2,$x)',
+ },
+ 'expr::aassign::3p_2c1s' => {
+ desc => 'three package vars assigned 2 consts and 1 shared var',
+ setup => '($x,$y,$z) = 1..3;',
+ code => '($x,$y,$z) = (1,2,$x)',
+ },
+
+
+ # ($a,$b) = ($b,$a);
+
+ 'expr::aassign::2l_swap' => {
+ desc => 'swap two lexical vars',
+ setup => 'my ($a,$b) = (1,2)',
+ code => '($a,$b) = ($b,$a)',
+ },
+ 'expr::aassign::2p_swap' => {
+ desc => 'swap two package vars',
+ setup => '($a,$b) = (1,2)',
+ code => '($a,$b) = ($b,$a)',
+ },
+ 'expr::aassign::2laelem_swap' => {
+ desc => 'swap two lexical vars',
+ setup => 'my @a = (1,2)',
+ code => '($a[0],$a[1]) = ($a[1],$a[0])',
+ },
+
+ # misc list assign
+
+ 'expr::aassign::5l_4l1s' => {
+ desc => 'long list of lexical vars, 1 shared',
+ setup => 'my ($a,$b,$c,$d,$e) = 1..5',
+ code => '($a,$b,$c,$d,$e) = ($a,$a,$c,$d,$e)',
+ },
+
+ 'expr::aassign::5p_4p1s' => {
+ desc => 'long list of package vars, 1 shared',
+ setup => '($a,$b,$c,$d,$e) = 1..5',
+ code => '($a,$b,$c,$d,$e) = ($a,$a,$c,$d,$e)',
+ },
+ 'expr::aassign::5l_defary' => {
+ desc => 'long list of lexical vars to assign @_ to',
+ setup => '@_ = 1..5',
+ code => 'my ($a,$b,$c,$d,$e) = @_',
+ },
+ 'expr::aassign::5l1la_defary' => {
+ desc => 'long list of lexical vars plus long slurp to assign @_ to',
+ setup => '@_ = 1..20',
+ code => 'my ($a,$b,$c,$d,$e,@rest) = @_',
+ },
+ 'expr::aassign::1l_2l' => {
+ desc => 'single lexical LHS',
+ setup => 'my $x = 1;',
+ code => '(undef,$x) = ($x,$x)',
+ },
+ 'expr::aassign::2l_1l' => {
+ desc => 'single lexical RHS',
+ setup => 'my $x = 1;',
+ code => '($x,$x) = (undef, $x)',
+ },
+
+
];
diff --git a/t/perf/optree.t b/t/perf/optree.t
index 7e3a06e14a..a2ff7f283c 100644
--- a/t/perf/optree.t
+++ b/t/perf/optree.t
@@ -10,26 +10,87 @@ BEGIN {
@INC = '../lib';
}
-plan 24;
+plan 54;
use v5.10; # state
-use B qw 'svref_2object OPpASSIGN_COMMON';
-
+use B qw(svref_2object
+ OPpASSIGN_COMMON_SCALAR
+ OPpASSIGN_COMMON_RC1
+ OPpASSIGN_COMMON_AGG
+ );
+
+
+# Test that OP_AASSIGN gets the appropriate
+# OPpASSIGN_COMMON* flags set.
+#
+# Too few flags set is likely to cause code to misbehave;
+# too many flags set unnecessarily slows things down.
+# See also the tests in t/op/aassign.t
+
+for my $test (
+ # Each anon array contains:
+ # [
+ # expected flags:
+ # a 3 char string, each char showing whether we expect a
+ # particular flag to be set:
+ # '-' indicates any char not set, while
+ # 'S': char 0: OPpASSIGN_COMMON_SCALAR,
+ # 'R': char 1: OPpASSIGN_COMMON_RC1,
+ # 'A' char 2: OPpASSIGN_COMMON_AGG,
+ # code to eval,
+ # description,
+ # ]
+
+ [ "---", '() = (1, $x, my $y, @z, f($p))', 'no LHS' ],
+ [ "---", '(undef, $x, my $y, @z, ($a ? $b : $c)) = ()', 'no RHS' ],
+ [ "---", '(undef, $x, my $y, @z, ($a ? $b : $c)) = (1,2)', 'safe RHS' ],
+ [ "---", 'my @a = (1,2)', 'safe RHS: my array' ],
+ [ "---", 'my %h = (1,2)', 'safe RHS: my hash' ],
+ [ "---", 'my ($a,$b,$c,$d) = 1..6; ($a,$b) = ($c,$d);', 'non-common lex' ],
+ [ "---", '($x,$y) = (1,2)', 'pkg var LHS only' ],
+ [ "---", 'my $p; my ($x,$y) = ($p, $p)', 'my; dup lex var on RHS' ],
+ [ "---", 'my $p; my ($x,$y); ($x,$y) = ($p, $p)', 'dup lex var on RHS' ],
+ [ "---", 'my ($self) = @_', 'LHS lex scalar only' ],
+ [ "--A", 'my ($self, @rest) = @_', 'LHS lex mixed' ],
+ [ "-R-", 'my ($x,$y) = ($p, $q)', 'pkg var RHS only' ],
+ [ "S--", '($x,$y) = ($p, $q)', 'pkg scalar both sides' ],
+ [ "--A", 'my (@a, @b); @a = @b', 'lex ary both sides' ],
+ [ "-R-", 'my ($x,$y,$z,@a); ($x,$y,$z) = @a ', 'lex vars to lex ary' ],
+ [ "--A", '@a = @b', 'pkg ary both sides' ],
+ [ "--A", 'my (%a,%b); %a = %b', 'lex hash both sides' ],
+ [ "--A", '%a = %b', 'pkg hash both sides' ],
+ [ "--A", 'my $x; @a = ($a[0], $a[$x])', 'common ary' ],
+ [ "--A", 'my ($x,@a); @a = ($a[0], $a[$x])', 'common lex ary' ],
+ [ "S-A", 'my $x; ($a[$x], $a[0]) = ($a[0], $a[$x])', 'common ary elems' ],
+ [ "S-A", 'my ($x,@a); ($a[$x], $a[0]) = ($a[0], $a[$x])',
+ 'common lex ary elems' ],
+ [ "--A", 'my $x; my @a = @$x', 'lex ary may have stuff' ],
+ [ "-RA", 'my $x; my ($b, @a) = @$x', 'lex ary may have stuff' ],
+ [ "--A", 'my $x; my %a = @$x', 'lex hash may have stuff' ],
+ [ "-RA", 'my $x; my ($b, %a) = @$x', 'lex hash may have stuff' ],
+ [ "--A", 'my (@a,@b); @a = ($b[0])', 'lex ary and elem' ],
+ [ "S-A", 'my @a; ($a[1],$a[0]) = @a', 'lex ary and elem' ],
+ [ "--A", 'my @x; @y = $x[0]', 'pkg ary from lex elem' ],
+ [ "---", '(undef,$x) = f()', 'single scalar on LHS' ],
+ [ "---", '($x,$y) = ($x)', 'single scalar on RHS, no AGG' ],
+ [ "--A", '($x,@b) = ($x)', 'single scalar on RHS' ],
+) {
+ my ($exp, $code, $desc) = @$test;
+ my $sub = eval "sub { $code }"
+ or die
+ "aassign eval('$code') failed: this test needs to be rewritten:\n"
+ . $@;
-# aassign with no common vars
-for ('my ($self) = @_',
- 'my @x; @y = $x[0]', # aelemfast_lex
- )
-{
- my $sub = eval "sub { $_ }";
- my $last_expr =
- svref_2object($sub)->ROOT->first->last;
+ my $last_expr = svref_2object($sub)->ROOT->first->last;
if ($last_expr->name ne 'aassign') {
die "Expected aassign but found ", $last_expr->name,
"; this test needs to be rewritten"
}
- is $last_expr->private & OPpASSIGN_COMMON, 0,
- "no ASSIGN_COMMON for $_";
+ my $got =
+ (($last_expr->private & OPpASSIGN_COMMON_SCALAR) ? 'S' : '-')
+ . (($last_expr->private & OPpASSIGN_COMMON_RC1) ? 'R' : '-')
+ . (($last_expr->private & OPpASSIGN_COMMON_AGG) ? 'A' : '-');
+ is $got, $exp, "OPpASSIGN_COMMON: $desc: '$code'";
}
View Lorry Controller Status