summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorDavid Mitchell <davem@iabyn.com>2015-08-13 10:32:42 +0100
committerDavid Mitchell <davem@iabyn.com>2015-08-17 11:16:07 +0100
commita5f48505593c7e1ca478de383e24d5cc2541f3ca (patch)
tree5339f8e5c013dca8735176084621fdc77c0ef386
parent0ba9d88c925494ce5e0e96d4ea3c11637807f08c (diff)
downloadperl-a5f48505593c7e1ca478de383e24d5cc2541f3ca.tar.gz
re-implement OPpASSIGN_COMMON mechanism
This commit almost completely replaces the current mechanism for detecting and handing common vars in list assignment, e.g. ($a,$b) = ($b,$a); In general outline: it creates more false positives at compile-time than before, but also no longer misses some false negatives. In compensation, it considerably reduces the run-time cost of handling potential and real commonality. It does this firstly by splitting the OPpASSIGN_COMMON flag into 3 separate flags: OPpASSIGN_COMMON_AGG OPpASSIGN_COMMON_RC1 OPpASSIGN_COMMON_SCALAR which indicate different classes of commonality that can be handled in different ways at runtime. Most importantly, it distinguishes between two basic cases. Firstly, common scalars (OPpASSIGN_COMMON_SCALAR), e.g. ($x,....) = (....,$x,...) where $x is modified and then sometime later its value is used again, but that value has changed in the meantime. In this case, we need replace such vars on the RHS with mortal copies before processing the assign. The second case is an aggregate on the LHS (OPpASSIGN_COMMON_AGG), e.g. (...,@a) = (...., $a[0],...) In this case, the issue is instead that when @a is cleared, it may free items on the RHS (due to the stack not being ref counted). What is required here is that rather than making of a copy of each RHS element and storing it in the array as we progress, we make *all* the copies *before* clearing the array, but mortalise them in case we die in the meantime. We can further distinguish two scalar cases; sometimes it's possible to confirm non-commonality at run-time merely by checking that all the LHS scalars have a reference count of 1. If this is possible, we set the OPpASSIGN_COMMON_RC1 flag rather than the OPpASSIGN_COMMON_SCALAR flag. The major improvement in the run-time performance in the OPpASSIGN_COMMON_SCALAR case (or OPpASSIGN_COMMON_RC1 if rc>1 scalars are detected), is to use a mark-and-sweep scan of the two lists using the SVf_BREAK flag, to determine which elements are common, and only make mortal copies of those elements. This has a very big effect on run-time performance; for example in the classic ($a,$b) = ($b,$a); it would formerly make temp copies of both $a and $b; now it only copies $a. In more detail, the mark and sweep mechanism in pp_aassign works by looping through each LHS and RHS SV pair in parallel. It temporarily marks each LHS SV with the SVf_BREAK flag, then makes a copy of each RHS element only if it has the SVf_BREAK flag set. When the scan is finished, the flag is unset on all LHS elements. One major change in compile-time flagging is that package scalar vars are now treated as if they could always be aliased. So we don't bother any more to do the compile-time PL_generation checking on package vars (we still do it on lexical vars). We also no longer make use of the run-time PL_sawalias mechanism for detecting aliased package vars (and indeed the next commit but one will remove that mechanism). This means that more list assignment expressions which feature package vars will now need to do a runtime mark-and-sweep (or where appropriate, RC1) test. In compensation, we no longer need to test for aliasing and set PL_sawalias in pp_gvsv and pp_gv, nor reset PL_sawalias in every pp_nextstate. Part of the reasoning behind this is that it's nearly impossible to detect all possible package var aliasing; for example PL_sawalias would fail to detect XS code doing GvSV(gv) = sv. Note that we now scan the two children of the OP_AASSIGN separately, and in particular we mark lexicals with PL_generation only on the LHS and test only on the RHS. So something like ($x,$y) = ($default, $default) will no longer be regarded as having common vars. In terms of performance, running Porting/perlbench.pl on the new expr::aassign:: tests in t/perf/benchmarks show that the biggest slowdown is around 13% more instruction reads and 20% more conditional branches in this: setup => 'my ($v1,$v2,$v3) = 1..3; ($x,$y,$z) = 1..3;', code => '($x,$y,$z) = ($v1,$v2,$v3)', where this is now a false positive due to the presence of package variables. The biggest speedup is 50% less instruction reads and conditional branches in this: setup => '@_ = 1..3; my ($x,$y,$z)', code => '($x,$y,$z) = @_', because formerly the presence of @_ pessimised things if the LHS wasn't a my declaration (it's still pessimised, but the runtime's faster now). Conversely, we pessimise the 'my' variant too now: setup => '@_ = 1..3;', code => 'my ($x,$y,$z) = @_', this gives 5% more instruction reads and 11% more conditional branches now. But see the next commit, which will cheat for that particular construct.
Diffstat
-rw-r--r--MANIFEST1
-rw-r--r--embed.fnc3
-rw-r--r--embed.h1
-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.t20
-rw-r--r--ext/B/t/optree_samples.t8
-rw-r--r--ext/B/t/optree_sort.t8
-rw-r--r--lib/B/Op_private.pm14
-rw-r--r--op.c646
-rw-r--r--opcode.h418
-rw-r--r--pp_hot.c288
-rw-r--r--proto.h1
-rw-r--r--regen/op_private15
-rw-r--r--sv.h4
-rw-r--r--t/op/aassign.t265
-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/benchmarks370
-rw-r--r--t/perf/optree.t84
21 files changed, 1734 insertions, 537 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/embed.fnc b/embed.fnc
index f596b1a270..74011e0442 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
diff --git a/embed.h b/embed.h
index 6cebb1990e..c03c0f5fc6 100644
--- a/embed.h
+++ b/embed.h
@@ -1526,7 +1526,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/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..4f4eaf9f78 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
@@ -266,7 +266,7 @@ checkOptree ( name => 'padrange and @_',
# d <1> leavesub[1 ref] K/REFC,1 ->(end)
# - <@> lineseq KP ->d
# 1 <;> nextstate(main 1 p3:1) v:>,<,% ->2
-# 3 <2> aassign[t5] vKS ->4
+# 3 <2> aassign[t5] vKS/COM_RC1 ->4
# - <1> ex-list lK ->-
# 2 <0> padrange[$a:1,4; $b:1,4] */LVINTRO,2 ->3
# - <1> rv2av[t4] lK/1 ->-
@@ -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
@@ -286,7 +286,7 @@ checkOptree ( name => 'padrange and @_',
# - <0> padsv[$c:2,4] sRM*/LVINTRO ->-
# - <0> padsv[$d:2,4] sRM*/LVINTRO ->-
# a <;> nextstate(Y 3 p3:4) v:>,<,%,{ ->b
-# c <2> aassign[t15] KS ->d
+# c <2> aassign[t15] KS/COM_RC1 ->d
# - <1> ex-list lK ->-
# b <0> padrange[$e:3,4; $f:3,4] */LVINTRO,2 ->c
# - <1> rv2av[t14] lK/1 ->-
@@ -299,7 +299,7 @@ EOT_EOT
# d <1> leavesub[1 ref] K/REFC,1 ->(end)
# - <@> lineseq KP ->d
# 1 <;> nextstate(main 1 p3:1) v:>,<,% ->2
-# 3 <2> aassign[t5] vKS ->4
+# 3 <2> aassign[t5] vKS/COM_RC1 ->4
# - <1> ex-list lK ->-
# 2 <0> padrange[$a:1,4; $b:1,4] */LVINTRO,2 ->3
# - <1> rv2av[t4] lK/1 ->-
@@ -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
@@ -319,7 +319,7 @@ EOT_EOT
# - <0> padsv[$c:2,4] sRM*/LVINTRO ->-
# - <0> padsv[$d:2,4] sRM*/LVINTRO ->-
# a <;> nextstate(Y 3 p3:4) v:>,<,%,{ ->b
-# c <2> aassign[t15] KS ->d
+# c <2> aassign[t15] KS/COM_RC1 ->d
# - <1> ex-list lK ->-
# b <0> padrange[$e:3,4; $f:3,4] */LVINTRO,2 ->c
# - <1> rv2av[t14] lK/1 ->-
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/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..b5ceb59bbd 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,377 @@ 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 */
+};
+
+
+
+/* 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.
+*/
+
+static int
+S_aassign_scan(pTHX_ OP* o, bool rhs, bool top)
+{
+ int flags = 0;
+ bool kid_top = FALSE;
+
+ switch (o->op_type) {
+ case OP_GVSV:
+ return AAS_PKG_SCALAR;
+
+ case OP_PADAV:
+ case OP_PADHV:
+ 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;
+ return (o->op_private & OPpLVAL_INTRO)
+ ? (AAS_MY_SCALAR|comm) : (AAS_LEX_SCALAR|comm);
+ }
+
+ case OP_RV2AV:
+ case OP_RV2HV:
+ 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:
+ if (cUNOPx(o)->op_first->op_type != OP_GV)
+ 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.
+ */
+ 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)
+ return AAS_DANGEROUS;
+
+ if ( (PL_opargs[o->op_type] & OA_TARGLEX)
+ && (o->op_private & OPpTARGET_MY))
+ {
+ 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 */
+ 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);
+ }
+ 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 +14155,82 @@ 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;
+
+ /* 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++;
+ l = S_aassign_scan(aTHX_ cLISTOPo->op_last, FALSE, 1);/* scan LHS */
+ r = S_aassign_scan(aTHX_ cLISTOPo->op_first, TRUE, 1); /* scan RHS */
+ 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); */
+ /*XXX we could also test for:
+ * LHS contains a single scalar element
+ * RHS contains a single element with no aggregate on LHS
+ */
+ )
+ {
+ 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 (r & (AAS_PKG_SCALAR|AAS_PKG_AGG|AAS_DANGEROUS))
+ o->op_private |= 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/pp_hot.c b/pp_hot.c
index 10945101ab..b32a7063d6 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -1003,6 +1003,143 @@ 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. We need a second copy of
+ a temp here, hence the SV_NOSTEAL. */
+ *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 +1158,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 +1207,73 @@ 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++) {
+ *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);
+ sv_setsv_nomg(sv, *relem);
+ *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 +1287,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 +1310,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 +1342,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 +1367,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..5b960a239c 100644
--- a/proto.h
+++ b/proto.h
@@ -4260,7 +4260,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/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..622053c004
--- /dev/null
+++ b/t/op/aassign.t
@@ -0,0 +1,265 @@
+#!./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");
+}
+
+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..2e58849e38 100644
--- a/t/perf/benchmarks
+++ b/t/perf/benchmarks
@@ -242,4 +242,374 @@
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) = @_',
+ },
+
+
];
diff --git a/t/perf/optree.t b/t/perf/optree.t
index 7e3a06e14a..40d2091ac7 100644
--- a/t/perf/optree.t
+++ b/t/perf/optree.t
@@ -10,26 +10,84 @@ BEGIN {
@INC = '../lib';
}
-plan 24;
+plan 51;
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' ],
+ [ "-R-", 'my ($self) = @_', 'LHS lex scalar only' ],
+ [ "-RA", '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' ],
+) {
+ 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