Bleadperl v5.23.1-199-ga5f4850 breaks BRUMLEVE/ddb-1.3.1.tar.gz #15048
Comments
From @andkbisect commit a5f4850 re-implement OPpASSIGN_COMMON mechanism cpantesters http://www.cpantesters.org/cpan/report/f8960df8-898b-11e5-bf4d-7c3ae0bfc7aa discovered by Slaven: https://rt.cpan.org/Ticket/Display.html?id=108870 perl -V Summary of my perl5 (revision 5 version 23 subversion 2) configuration: Characteristics of this binary (from libperl): -- |
From @tonycozOn Fri Nov 13 12:05:28 2015, andreas.koenig.7os6VVqR@franz.ak.mind.de wrote:
Looks like this broke aassign involving elements of magic hashs (and arrays I expect), using attached code, with 5.22.0: tony@mars:.../git/perl$ ~/perl/5.22.0/bin/perl ../126633.pl With blead: tony@mars:.../git/perl$ ./perl ../126633.pl Tony |
|
The RT System itself - Status changed from 'new' to 'open' |
From @tonycozOn Mon Nov 16 21:02:19 2015, tonyc wrote:
The attached allows my test case to work and ddb to pass its tests. I'm not sure it's a complete fix, and it might be copying in cases where it's unnecessary too. Tony |
From @tonycoz0001-perl-126633-possible-fix-for-tied-handling.patchFrom c8205f4d03fd2491cb1d060de0316581647ecf22 Mon Sep 17 00:00:00 2001
From: Tony Cook <tony@develop-help.com>
Date: Wed, 18 Nov 2015 10:06:34 +1100
Subject: [perl #126633] possible fix for tied handling
This fix is probably incomplete.
---
pp_hot.c | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/pp_hot.c b/pp_hot.c
index ff9e594..5deb5fe 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -1169,10 +1169,10 @@ S_aassign_copy_common(pTHX_ SV **firstlelem, SV **lastlelem,
svr = *relem;
assert(svr);
- if (UNLIKELY(SvFLAGS(svr) & SVf_BREAK)) {
+ if (UNLIKELY(SvFLAGS(svr) & (SVf_BREAK|SVs_GMG))) {
#ifdef DEBUGGING
- if (fake) {
+ if (fake && !SvGMAGICAL(svr)) {
/* op_dump(PL_op); */
Perl_croak(aTHX_
"panic: aassign skipped needed copy of common RH elem %"
--
2.1.4
|
From @iabynOn Tue, Nov 17, 2015 at 03:09:50PM -0800, Tony Cook via RT wrote:
I think that's the wrong way round, so to speak. The real issue is SMG SV's Consider (L1, L2, ...) = (R1, R2, ...) where the L's and R's are In theory that should be functionally equivalent to $t1 = R1; $t2 = R2; ...; except that sometimes we can optimise away the temporary copies, and do L1 = R1; L2 = R2; ....; The only issue is when we assign to L(n), can it affect any of R(n+1), In the following: my $set; I think that it should print "0". In fact it prints "1", both in blead and To fix that, the rule should be that as soon as an SMG SV is spotted on the Personally I think we should go with the former. -- |
From @tonycozOn Wed Nov 18 06:22:11 2015, davem wrote:
Both sides need to be checked, consider: package ArrayProxy { If we only check for set magic on the left side, this fails.
I think the attached covers the cases we've discussed. Tony |
From @tonycoz0003-perl-126633-copy-anything-gmagical-on-the-right.patchFrom b1faa876348665b2fe464c23bc6e264a8d775698 Mon Sep 17 00:00:00 2001
From: Tony Cook <tony@develop-help.com>
Date: Tue, 8 Dec 2015 10:45:28 +1100
Subject: [perl #126633] copy anything gmagical on the right
It could retrieve something that has set magic from the left.
---
pp_hot.c | 6 +++++-
t/op/aassign.t | 2 --
2 files changed, 5 insertions(+), 3 deletions(-)
diff --git a/pp_hot.c b/pp_hot.c
index d1bbdd2..f30f3b5 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -1173,7 +1173,7 @@ S_aassign_copy_common(pTHX_ SV **firstlelem, SV **lastlelem,
svr = *relem;
assert(svr);
- if (UNLIKELY(SvFLAGS(svr) & SVf_BREAK || copy_all)) {
+ if (UNLIKELY(SvFLAGS(svr) & (SVf_BREAK|SVs_GMG) || copy_all)) {
#ifdef DEBUGGING
if (fake) {
@@ -1265,6 +1265,10 @@ PP(pp_aassign)
/* at least 2 LH and RH elements, or commonality isn't an issue */
if (firstlelem < lastlelem && firstrelem < lastrelem) {
+ for (relem = firstrelem+1; relem <= lastrelem; relem++) {
+ if (SvGMAGICAL(*relem))
+ goto do_scan;
+ }
for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
if (*lelem && SvSMAGICAL(*lelem))
goto do_scan;
diff --git a/t/op/aassign.t b/t/op/aassign.t
index d6a1a42..ec3b796 100644
--- a/t/op/aassign.t
+++ b/t/op/aassign.t
@@ -363,9 +363,7 @@ SKIP: {
@real = @base;
@real[0, 1] = @proxy[1, 0];
is($real[0], "b", "tied right first");
- { local $::TODO = "#126633";
is($real[1], "a", "tied right second");
- }
@real = @base;
@proxy[0, 1] = @proxy[1, 0];
is($real[0], "b", "tied both first");
--
2.1.4
|
From @tonycozOn Mon Dec 07 16:24:47 2015, tonyc wrote:
I know I attached all three, I saw them in the form. Trying again. Tony |
From @tonycoz0001-perl-126633-TODO-tests.patchFrom cd9dea13d693e661a08046e532f04d932a827f07 Mon Sep 17 00:00:00 2001
From: Tony Cook <tony@develop-help.com>
Date: Mon, 7 Dec 2015 16:22:38 +1100
Subject: [perl #126633] TODO tests
---
t/op/aassign.t | 41 +++++++++++++++++++++++++++++++++++++++++
1 file changed, 41 insertions(+)
diff --git a/t/op/aassign.t b/t/op/aassign.t
index 7b245cd..8e3087e 100644
--- a/t/op/aassign.t
+++ b/t/op/aassign.t
@@ -343,5 +343,46 @@ SKIP: {
is($y, 1, 'single scalar on RHS, but two on LHS: y');
}
+{ # magic handling, see #126633
+ use v5.22;
+ package ArrayProxy {
+ sub TIEARRAY { bless [ $_[1] ] }
+ sub STORE { $_[0][0]->[$_[1]] = $_[2] }
+ sub FETCH { $_[0][0]->[$_[1]] }
+ sub CLEAR { @{$_[0][0]} = () }
+ sub EXTEND {}
+ };
+ my @base = ( "a", "b" );
+ my @real = @base;
+ my @proxy;
+ my $temp;
+ tie @proxy, "ArrayProxy", \@real;
+ @proxy[0, 1] = @real[1, 0];
+ is($real[0], "b", "tied left first");
+ { local $::TODO = "#126633";
+ is($real[1], "a", "tied left second");
+ }
+ @real = @base;
+ @real[0, 1] = @proxy[1, 0];
+ is($real[0], "b", "tied right first");
+ { local $::TODO = "#126633";
+ is($real[1], "a", "tied right second");
+ }
+ @real = @base;
+ @proxy[0, 1] = @proxy[1, 0];
+ is($real[0], "b", "tied both first");
+ { local $::TODO = "#126633";
+ is($real[1], "a", "tied both b");
+ }
+ @real = @base;
+ ($temp, @real) = @proxy[1, 0];
+ is($real[0], "a", "scalar/array tied right");
+ @real = @base;
+ ($temp, @proxy) = @real[1, 0];
+ is($real[0], "a", "scalar/array tied left");
+ @real = @base;
+ ($temp, @proxy) = @proxy[1, 0];
+ is($real[0], "a", "scalar/array tied both");
+}
done_testing();
--
2.1.4
|
From @tonycoz0002-perl-126633-if-we-see-smagic-on-the-left-copy-the-re.patchFrom fb14da8d435916c7319ffc8b58ee24a76f9d2887 Mon Sep 17 00:00:00 2001
From: Tony Cook <tony@develop-help.com>
Date: Mon, 7 Dec 2015 16:24:52 +1100
Subject: [perl #126633] if we see smagic on the left copy the rest on the
right
---
pp_hot.c | 50 +++++++++++++++++++++++++++++---------------------
t/op/aassign.t | 6 +-----
2 files changed, 30 insertions(+), 26 deletions(-)
diff --git a/pp_hot.c b/pp_hot.c
index ff9e594..d1bbdd2 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -1110,6 +1110,7 @@ S_aassign_copy_common(pTHX_ SV **firstlelem, SV **lastlelem,
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);
+ bool copy_all = FALSE;
assert(!PL_in_clean_all); /* SVf_BREAK not already in use */
assert(firstlelem < lastlelem); /* at least 2 LH elements */
@@ -1138,6 +1139,9 @@ S_aassign_copy_common(pTHX_ SV **firstlelem, SV **lastlelem,
}
assert(svl);
+ if (SvSMAGICAL(svl)) {
+ copy_all = TRUE;
+ }
if (SvTYPE(svl) == SVt_PVAV || SvTYPE(svl) == SVt_PVHV) {
if (!marked)
return;
@@ -1169,7 +1173,7 @@ S_aassign_copy_common(pTHX_ SV **firstlelem, SV **lastlelem,
svr = *relem;
assert(svr);
- if (UNLIKELY(SvFLAGS(svr) & SVf_BREAK)) {
+ if (UNLIKELY(SvFLAGS(svr) & SVf_BREAK || copy_all)) {
#ifdef DEBUGGING
if (fake) {
@@ -1259,29 +1263,33 @@ PP(pp_aassign)
* clobber a value on the right that's used later in the list.
*/
- 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)
- ) {
- 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;
- }
+ /* at least 2 LH and RH elements, or commonality isn't an issue */
+ if (firstlelem < lastlelem && firstrelem < lastrelem) {
+ for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
+ if (*lelem && SvSMAGICAL(*lelem))
+ goto do_scan;
}
- else {
- do_scan:
- S_aassign_copy_common(aTHX_
- firstlelem, lastlelem, firstrelem, lastrelem
+ if ( PL_op->op_private & (OPpASSIGN_COMMON_SCALAR|OPpASSIGN_COMMON_RC1) ) {
+ 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
#ifdef DEBUGGING
- , fake
+ , fake
#endif
- );
+ );
+ }
}
}
#ifdef DEBUGGING
diff --git a/t/op/aassign.t b/t/op/aassign.t
index 8e3087e..d6a1a42 100644
--- a/t/op/aassign.t
+++ b/t/op/aassign.t
@@ -359,9 +359,7 @@ SKIP: {
tie @proxy, "ArrayProxy", \@real;
@proxy[0, 1] = @real[1, 0];
is($real[0], "b", "tied left first");
- { local $::TODO = "#126633";
is($real[1], "a", "tied left second");
- }
@real = @base;
@real[0, 1] = @proxy[1, 0];
is($real[0], "b", "tied right first");
@@ -371,9 +369,7 @@ SKIP: {
@real = @base;
@proxy[0, 1] = @proxy[1, 0];
is($real[0], "b", "tied both first");
- { local $::TODO = "#126633";
- is($real[1], "a", "tied both b");
- }
+ is($real[1], "a", "tied both second");
@real = @base;
($temp, @real) = @proxy[1, 0];
is($real[0], "a", "scalar/array tied right");
--
2.1.4
|
From @tonycoz0003-perl-126633-copy-anything-gmagical-on-the-right.patchFrom 1bc8e7d86c18547b7fce8d5a6a99239315459505 Mon Sep 17 00:00:00 2001
From: Tony Cook <tony@develop-help.com>
Date: Tue, 8 Dec 2015 11:19:48 +1100
Subject: [perl #126633] copy anything gmagical on the right
It could retrieve something that has set magic from the left.
---
pp_hot.c | 6 +++++-
t/op/aassign.t | 9 ++++++---
2 files changed, 11 insertions(+), 4 deletions(-)
diff --git a/pp_hot.c b/pp_hot.c
index d1bbdd2..f30f3b5 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -1173,7 +1173,7 @@ S_aassign_copy_common(pTHX_ SV **firstlelem, SV **lastlelem,
svr = *relem;
assert(svr);
- if (UNLIKELY(SvFLAGS(svr) & SVf_BREAK || copy_all)) {
+ if (UNLIKELY(SvFLAGS(svr) & (SVf_BREAK|SVs_GMG) || copy_all)) {
#ifdef DEBUGGING
if (fake) {
@@ -1265,6 +1265,10 @@ PP(pp_aassign)
/* at least 2 LH and RH elements, or commonality isn't an issue */
if (firstlelem < lastlelem && firstrelem < lastrelem) {
+ for (relem = firstrelem+1; relem <= lastrelem; relem++) {
+ if (SvGMAGICAL(*relem))
+ goto do_scan;
+ }
for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
if (*lelem && SvSMAGICAL(*lelem))
goto do_scan;
diff --git a/t/op/aassign.t b/t/op/aassign.t
index d6a1a42..03cc84c 100644
--- a/t/op/aassign.t
+++ b/t/op/aassign.t
@@ -345,9 +345,10 @@ SKIP: {
{ # magic handling, see #126633
use v5.22;
+ my $set;
package ArrayProxy {
sub TIEARRAY { bless [ $_[1] ] }
- sub STORE { $_[0][0]->[$_[1]] = $_[2] }
+ sub STORE { $_[0][0]->[$_[1]] = $_[2]; $set = 1 }
sub FETCH { $_[0][0]->[$_[1]] }
sub CLEAR { @{$_[0][0]} = () }
sub EXTEND {}
@@ -363,9 +364,7 @@ SKIP: {
@real = @base;
@real[0, 1] = @proxy[1, 0];
is($real[0], "b", "tied right first");
- { local $::TODO = "#126633";
is($real[1], "a", "tied right second");
- }
@real = @base;
@proxy[0, 1] = @proxy[1, 0];
is($real[0], "b", "tied both first");
@@ -379,6 +378,10 @@ SKIP: {
@real = @base;
($temp, @proxy) = @proxy[1, 0];
is($real[0], "a", "scalar/array tied both");
+ $set = 0;
+ my $orig;
+ ($proxy[0], $orig) = (1, $set);
+ is($orig, 0, 'previous value of $set');
}
done_testing();
--
2.1.4
|
From @iabynOn Mon, Dec 07, 2015 at 04:24:47PM -0800, Tony Cook via RT wrote:
Oh yeah :-(
The 3 patches in your next entry look good to me. -- |
From @andkAlso related: https://rt.cpan.org/Ticket/Display.html?id=110278 executive summary: C<< ($x,$y) = (min($y), min($x)); >> broken with List::Util::min Still broken in v5.23.5-182-gfacc1dc, bisect points to v5.23.1-199-ga5f4850 -- |
From @tonycozOn Fri Dec 11 05:25:41 2015, andreas.koenig.7os6VVqR@franz.ak.mind.de wrote:
My patch doesn't appear to fix this, I'll look into it. Tony |
From @tonycozOn Mon Dec 14 17:19:38 2015, tonyc wrote:
I suspect the OPpASSIGN_COMMON_RC1 optimization is simply wrong. min($y) always returns $y's SV, so we get on the stack for pp_aassign: lastlelem -> $x both $x and $y have a ref count of 1, and PL_op->op_private is The loop check in pp_aassign then checks that all of the left side Tony |
From @iabynOn Mon, Dec 14, 2015 at 08:38:52PM -0800, Tony Cook via RT wrote:
It's salvageable. The following fixes it: @@ -12344,7 +12344,8 @@ S_aassign_scan(pTHX_ OP* o, bool rhs, bool top, int *sca if ( (PL_opargs[o->op_type] & OA_TARGLEX) The issue is that I had assumed that a sub (even an lvalue one) can't min() shows that XS subs can break this assumption. However they should $ p -MO=Concise -e'my($x,$y); ($x,$y)=f()' | grep aassign $ p -MO=Concise -e'my($x,$y); ($x,$y)=f($x,$y)' | grep aassign As an aside, I'm more and more beginning to think that the OA_DANGEROUS Anyway, do you want me to go ahead and apply the above fix and followups, -- |
From @tonycozOn Tue Dec 15 06:04:01 2015, davem wrote:
That works for me and I couldn't find a new case that breaks it (but users I've attached a format-patch version of your patch with a test.
Sorry I missed this follow-up. I'll apply it next week, unless someone objects, along with your change. Tony |
From @tonycoz0004-perl-126633-check-children-of-OA_DANGEROUS-ops-for-c.patchFrom 2f9365dc3b09bdf83c00a6d176d882057608308e Mon Sep 17 00:00:00 2001
From: Dave Mitchell <davem@iabyn.com>
Date: Thu, 7 Jan 2016 11:36:10 +1100
Subject: [perl #126633] check children of OA_DANGEROUS ops for common scalars
Tony Cook: added tests
---
op.c | 3 ++-
t/op/aassign.t | 8 ++++++++
2 files changed, 10 insertions(+), 1 deletion(-)
diff --git a/op.c b/op.c
index 1b78a4c..ee31adc 100644
--- a/op.c
+++ b/op.c
@@ -12343,7 +12343,8 @@ S_aassign_scan(pTHX_ OP* o, bool rhs, bool top, int *scalars_p)
default:
if (PL_opargs[o->op_type] & OA_DANGEROUS) {
(*scalars_p) += 2;
- return AAS_DANGEROUS;
+ flags = AAS_DANGEROUS;
+ break;
}
if ( (PL_opargs[o->op_type] & OA_TARGLEX)
diff --git a/t/op/aassign.t b/t/op/aassign.t
index 03cc84c..e1c687c 100644
--- a/t/op/aassign.t
+++ b/t/op/aassign.t
@@ -382,6 +382,14 @@ SKIP: {
my $orig;
($proxy[0], $orig) = (1, $set);
is($orig, 0, 'previous value of $set');
+
+ # from cpan #110278
+ use List::Util qw(min);
+ my $x = 1;
+ my $y = 2;
+ ( $x, $y ) = ( min($y), min($x) );
+ is($x, 2, "check swap for \$x");
+ is($y, 1, "check swap for \$y");
}
done_testing();
--
2.1.4
|
|
@tonycoz - Status changed from 'open' to 'pending release' |
From @khwilliamsonThank you for submitting this report. You have helped make Perl better. Perl 5.24.0 may be downloaded via https://metacpan.org/release/RJBS/perl-5.24.0 |
|
@khwilliamson - Status changed from 'pending release' to 'resolved' |
Migrated from rt.perl.org#126633 (status was 'resolved')
Searchable as RT126633$
The text was updated successfully, but these errors were encountered: