Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Bleadperl v5.23.1-199-ga5f4850 breaks BRUMLEVE/ddb-1.3.1.tar.gz #15048

Closed
p5pRT opened this issue Nov 13, 2015 · 24 comments
Closed

Bleadperl v5.23.1-199-ga5f4850 breaks BRUMLEVE/ddb-1.3.1.tar.gz #15048

p5pRT opened this issue Nov 13, 2015 · 24 comments
Labels

Comments

@p5pRT
Copy link
Collaborator

@p5pRT p5pRT commented Nov 13, 2015

Migrated from rt.perl.org#126633 (status was 'resolved')

Searchable as RT126633$

@p5pRT

This comment has been minimized.

Copy link
Collaborator Author

@p5pRT p5pRT commented Nov 13, 2015

From @andk

bisect


commit a5f4850
Author​: David Mitchell <davem@​iabyn.com>
Date​: Thu Aug 13 10​:32​:42 2015 +0100

  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​:
 
  Platform​:
  osname=linux, osvers=3.2.0-4-amd64, archname=x86_64-linux
  uname='linux eserte 3.2.0-4-amd64 #1 smp debian 3.2.68-1+deb7u3 x86_64 gnulinux '
  config_args='-ds -e -Dprefix=/opt/perl-5.23.2 -Dusedevel -Dusemallocwrap=no -Dcf_email=srezic@​cpan.org'
  hint=recommended, useposix=true, d_sigaction=define
  useithreads=undef, usemultiplicity=undef
  use64bitint=define, use64bitall=define, uselongdouble=undef
  usemymalloc=n, bincompat5005=undef
  Compiler​:
  cc='cc', ccflags ='-fwrapv -fno-strict-aliasing -pipe -fstack-protector -I/usr/local/include -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64 -D_FORTIFY_SOURCE=2',
  optimize='-O2',
  cppflags='-fwrapv -fno-strict-aliasing -pipe -fstack-protector -I/usr/local/include'
  ccversion='', gccversion='4.7.2', gccosandvers=''
  intsize=4, longsize=8, ptrsize=8, doublesize=8, byteorder=12345678, doublekind=3
  d_longlong=define, longlongsize=8, d_longdbl=define, longdblsize=16, longdblkind=3
  ivtype='long', ivsize=8, nvtype='double', nvsize=8, Off_t='off_t', lseeksize=8
  alignbytes=8, prototype=define
  Linker and Libraries​:
  ld='cc', ldflags =' -fstack-protector -L/usr/local/lib'
  libpth=/usr/local/lib /usr/lib/gcc/x86_64-linux-gnu/4.7/include-fixed /usr/include/x86_64-linux-gnu /usr/lib /lib/x86_64-linux-gnu /lib/../lib /usr/lib/x86_64-linux-gnu /usr/lib/../lib /lib
  libs=-lpthread -lnsl -ldb -ldl -lm -lcrypt -lutil -lc
  perllibs=-lpthread -lnsl -ldl -lm -lcrypt -lutil -lc
  libc=libc-2.13.so, so=so, useshrplib=false, libperl=libperl.a
  gnulibc_version='2.13'
  Dynamic Linking​:
  dlsrc=dl_dlopen.xs, dlext=so, d_dlsymun=undef, ccdlflags='-Wl,-E'
  cccdlflags='-fPIC', lddlflags='-shared -O2 -L/usr/local/lib -fstack-protector'

Characteristics of this binary (from libperl)​:
  Compile-time options​: HAS_TIMES PERLIO_LAYERS PERL_COPY_ON_WRITE
  PERL_DONT_CREATE_GVSV
  PERL_HASH_FUNC_ONE_AT_A_TIME_HARD PERL_PRESERVE_IVUV
  PERL_USE_DEVEL USE_64_BIT_ALL USE_64_BIT_INT
  USE_LARGE_FILES USE_LOCALE USE_LOCALE_COLLATE
  USE_LOCALE_CTYPE USE_LOCALE_NUMERIC USE_LOCALE_TIME
  USE_PERLIO USE_PERL_ATOF
  Built under linux
  Compiled at Aug 28 2015 18​:37​:25
  %ENV​:
  PERL5LIB=""
  PERL5OPT=""
  PERL5_CPANPLUS_IS_RUNNING="18836"
  PERL5_CPAN_IS_RUNNING="18836"
  PERL5_CPAN_IS_RUNNING_IN_RECURSION="16655,18836"
  PERLDOC="-MPod​::Perldoc​::ToTextOverstrike"
  PERL_BATCH="yes"
  PERL_CANARY_STABILITY_NOPROMPT="1"
  PERL_CPAN_REPORTER_CONFIG="/var/tmp/cpansmoker-1001/2015111221/cpanreporter_003_config.ini"
  PERL_EXTUTILS_AUTOINSTALL="--defaultdeps"
  @​INC​:
  /opt/perl-5.23.2/lib/site_perl/5.23.2/x86_64-linux
  /opt/perl-5.23.2/lib/site_perl/5.23.2
  /opt/perl-5.23.2/lib/5.23.2/x86_64-linux
  /opt/perl-5.23.2/lib/5.23.2
  .

--
andreas

@p5pRT

This comment has been minimized.

Copy link
Collaborator Author

@p5pRT p5pRT commented Nov 17, 2015

From @tonycoz

On Fri Nov 13 12​:05​:28 2015, andreas.koenig.7os6VVqR@​franz.ak.mind.de wrote​:

bisect
------
commit a5f4850
Author​: David Mitchell <davem@​iabyn.com>
Date​: Thu Aug 13 10​:32​:42 2015 +0100

re-implement OPpASSIGN_COMMON mechanism

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
$VAR1 = {
  'c' => 3,
  'a' => 1,
  'd' => 4,
  'b' => 2
  };
$VAR1 = {
  'c' => 3,
  'a' => 2,
  'd' => 4,
  'b' => 1
  };

With blead​:

tony@​mars​:.../git/perl$ ./perl ../126633.pl
$VAR1 = {
  'c' => 3,
  'd' => 4,
  'b' => 2,
  'a' => 1
  };
$VAR1 = {
  'c' => 3,
  'd' => 4,
  'b' => 2,
  'a' => 2
  };

Tony

@p5pRT

This comment has been minimized.

Copy link
Collaborator Author

@p5pRT p5pRT commented Nov 17, 2015

@p5pRT

This comment has been minimized.

Copy link
Collaborator Author

@p5pRT p5pRT commented Nov 17, 2015

The RT System itself - Status changed from 'new' to 'open'

@p5pRT

This comment has been minimized.

Copy link
Collaborator Author

@p5pRT p5pRT commented Nov 17, 2015

From @tonycoz

On Mon Nov 16 21​:02​:19 2015, tonyc wrote​:

On Fri Nov 13 12​:05​:28 2015, andreas.koenig.7os6VVqR@​franz.ak.mind.de
wrote​:

bisect
------
commit a5f4850
Author​: David Mitchell <davem@​iabyn.com>
Date​: Thu Aug 13 10​:32​:42 2015 +0100

re-implement OPpASSIGN_COMMON mechanism

Looks like this broke aassign involving elements of magic hashs (and
arrays I expect), using attached code, with 5.22.0​:

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

@p5pRT

This comment has been minimized.

Copy link
Collaborator Author

@p5pRT p5pRT commented Nov 17, 2015

From @tonycoz

0001-perl-126633-possible-fix-for-tied-handling.patch
From 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

@p5pRT

This comment has been minimized.

Copy link
Collaborator Author

@p5pRT p5pRT commented Nov 18, 2015

From @iabyn

On Tue, Nov 17, 2015 at 03​:09​:50PM -0800, Tony Cook via RT wrote​:

On Mon Nov 16 21​:02​:19 2015, tonyc wrote​:

On Fri Nov 13 12​:05​:28 2015, andreas.koenig.7os6VVqR@​franz.ak.mind.de
wrote​:

bisect
------
commit a5f4850
Author​: David Mitchell <davem@​iabyn.com>
Date​: Thu Aug 13 10​:32​:42 2015 +0100

re-implement OPpASSIGN_COMMON mechanism

Looks like this broke aassign involving elements of magic hashs (and
arrays I expect), using attached code, with 5.22.0​:

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.

I think that's the wrong way round, so to speak. The real issue is SMG SV's
on the LHS, rather than GMG's on the RHS.

Consider (L1, L2, ...) = (R1, R2, ...) where the L's and R's are
lvalue/rvalue expressions.

In theory that should be functionally equivalent to

  $t1 = R1; $t2 = R2; ...;
  L1 = $t1; L2 = $t2; ...;

except that sometimes we can optimise away the temporary copies, and do
(all or partially)

  L1 = R1; L2 = R2; ....;

The only issue is when we assign to L(n), can it affect any of R(n+1),
R(n+2) etc? If so, we must copy any affected RHS scalars first.

In the following​:

  my $set;
  sub TIEHASH { bless {} }
  sub STORE { $_[0]->{$_[1]} = $_[2]; $set = 1 }
  sub FETCH { $_[0]->{$_[1]} }
  tie %x, 'main';
  $set = 0;
  ($x{a}, $orig) = (1, $set);
  print "$orig\n";

I think that it should print "0". In fact it prints "1", both in blead and
on old perls. (It actually prints "0" in 5.22.0, since the introduction
of OP_MULTIDEREF inadvertently pessimised the aassign).

To fix that, the rule should be that as soon as an SMG SV is spotted on the
LHS, all remaining RHS elements should be copied.
On the other hand, if we're not worried about $orig being 1 above, then
that rule could be relaxed to​: as soon as an SMG SV is spotted on the
LHS, all remaining GMG RHS elements should be copied.

Personally I think we should go with the former.

--
"But Sidley Park is already a picture, and a most amiable picture too.
The slopes are green and gentle. The trees are companionably grouped at
intervals that show them to advantage. The rill is a serpentine ribbon
unwound from the lake peaceably contained by meadows on which the right
amount of sheep are tastefully arranged." -- Lady Croom, "Arcadia"

@p5pRT

This comment has been minimized.

Copy link
Collaborator Author

@p5pRT p5pRT commented Dec 8, 2015

From @tonycoz

On Wed Nov 18 06​:22​:11 2015, davem wrote​:

On Tue, Nov 17, 2015 at 03​:09​:50PM -0800, Tony Cook via RT wrote​:

On Mon Nov 16 21​:02​:19 2015, tonyc wrote​:

On Fri Nov 13 12​:05​:28 2015, andreas.koenig.7os6VVqR@​franz.ak.mind.de
wrote​:

bisect
------
commit a5f4850
Author​: David Mitchell <davem@​iabyn.com>
Date​: Thu Aug 13 10​:32​:42 2015 +0100

re-implement OPpASSIGN_COMMON mechanism

Looks like this broke aassign involving elements of magic hashs (and
arrays I expect), using attached code, with 5.22.0​:

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.

I think that's the wrong way round, so to speak. The real issue is SMG SV's
on the LHS, rather than GMG's on the RHS.

Consider (L1, L2, ...) = (R1, R2, ...) where the L's and R's are
lvalue/rvalue expressions.

In theory that should be functionally equivalent to

$t1 = R1; $t2 = R2; \.\.\.;
L1 = $t1; L2 = $t2; \.\.\.;

except that sometimes we can optimise away the temporary copies, and do
(all or partially)

L1 = R1; L2 = R2; \.\.\.\.;

The only issue is when we assign to L(n), can it affect any of R(n+1),
R(n+2) etc? If so, we must copy any affected RHS scalars first.

Both sides need to be checked, consider​:

  package ArrayProxy {
  sub TIEARRAY { bless [ $_[1] ] }
  sub STORE { $_[0][0]->[$_[1]] = $_[2] }
  sub FETCH { $_[0][0]->[$_[1]] }
  sub CLEAR { @​{$_[0][0]} = () }
  sub EXTEND {}
  };
  my @​real = ( "a", "b" );
  my @​proxy;
  tie @​proxy, "ArrayProxy", \@​real;
  @​real[0, 1] = @​proxy[1, 0];
  is($real[0], "b", "tied right first");
  is($real[1], "a", "tied right second");

If we only check for set magic on the left side, this fails.

In the following​:

my $set;
sub TIEHASH \{ bless \{\} \}
sub STORE \{ $\_\[0\]\->\{$\_\[1\]\} = $\_\[2\]; $set = 1 \}
sub FETCH \{ $\_\[0\]\->\{$\_\[1\]\} \}
tie %x\, 'main';
$set = 0;
\($x\{a\}\, $orig\) = \(1\, $set\);
print "$orig\\n";

I think that it should print "0". In fact it prints "1", both in blead and
on old perls. (It actually prints "0" in 5.22.0, since the introduction
of OP_MULTIDEREF inadvertently pessimised the aassign).

To fix that, the rule should be that as soon as an SMG SV is spotted on the
LHS, all remaining RHS elements should be copied.
On the other hand, if we're not worried about $orig being 1 above, then
that rule could be relaxed to​: as soon as an SMG SV is spotted on the
LHS, all remaining GMG RHS elements should be copied.

Personally I think we should go with the former.

I think the attached covers the cases we've discussed.

Tony

@p5pRT

This comment has been minimized.

Copy link
Collaborator Author

@p5pRT p5pRT commented Dec 8, 2015

From @tonycoz

0003-perl-126633-copy-anything-gmagical-on-the-right.patch
From 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

@p5pRT

This comment has been minimized.

Copy link
Collaborator Author

@p5pRT p5pRT commented Dec 8, 2015

From @tonycoz

On Mon Dec 07 16​:24​:47 2015, tonyc wrote​:

I think the attached covers the cases we've discussed.

I know I attached all three, I saw them in the form.

Trying again.

Tony

@p5pRT

This comment has been minimized.

Copy link
Collaborator Author

@p5pRT p5pRT commented Dec 8, 2015

From @tonycoz

0001-perl-126633-TODO-tests.patch
From 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

@p5pRT

This comment has been minimized.

Copy link
Collaborator Author

@p5pRT p5pRT commented Dec 8, 2015

From @tonycoz

0002-perl-126633-if-we-see-smagic-on-the-left-copy-the-re.patch
From 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

@p5pRT

This comment has been minimized.

Copy link
Collaborator Author

@p5pRT p5pRT commented Dec 8, 2015

From @tonycoz

0003-perl-126633-copy-anything-gmagical-on-the-right.patch
From 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

@p5pRT

This comment has been minimized.

Copy link
Collaborator Author

@p5pRT p5pRT commented Dec 9, 2015

From @iabyn

On Mon, Dec 07, 2015 at 04​:24​:47PM -0800, Tony Cook via RT wrote​:

Both sides need to be checked, consider​:

package ArrayProxy \{
    sub TIEARRAY \{ bless \[ $\_\[1\] \] \}
    sub STORE \{ $\_\[0\]\[0\]\->\[$\_\[1\]\] = $\_\[2\] \}
    sub FETCH \{ $\_\[0\]\[0\]\->\[$\_\[1\]\] \}
    sub CLEAR \{ @&#8203;\{$\_\[0\]\[0\]\} = \(\) \}
    sub EXTEND \{\}
\};
my @&#8203;real = \( "a"\, "b" \);
my @&#8203;proxy;
tie @&#8203;proxy\, "ArrayProxy"\, \\@&#8203;real;
@&#8203;real\[0\, 1\] = @&#8203;proxy\[1\, 0\];
is\($real\[0\]\, "b"\, "tied right first"\);
is\($real\[1\]\, "a"\, "tied right second"\);

If we only check for set magic on the left side, this fails.

Oh yeah :-(

I think the attached covers the cases we've discussed.

The 3 patches in your next entry look good to me.

--
A walk of a thousand miles begins with a single step...
then continues for another 1,999,999 or so.

@p5pRT

This comment has been minimized.

Copy link
Collaborator Author

@p5pRT p5pRT commented Dec 11, 2015

From @andk

Also 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

--
andreas

@p5pRT

This comment has been minimized.

Copy link
Collaborator Author

@p5pRT p5pRT commented Dec 15, 2015

From @tonycoz

On Fri Dec 11 05​:25​:41 2015, andreas.koenig.7os6VVqR@​franz.ak.mind.de wrote​:

Also 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

My patch doesn't appear to fix this, I'll look into it.

Tony

@p5pRT

This comment has been minimized.

Copy link
Collaborator Author

@p5pRT p5pRT commented Dec 15, 2015

From @tonycoz

On Mon Dec 14 17​:19​:38 2015, tonyc wrote​:

On Fri Dec 11 05​:25​:41 2015, andreas.koenig.7os6VVqR@​franz.ak.mind.de wrote​:

Also 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

My patch doesn't appear to fix this, I'll look into it.

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
  firstlelem -> $y
  lastrelem -> $y
  firstlelem -> $x

both $x and $y have a ref count of 1, and PL_op->op_private is
OPpASSIGN_COMMON_RC1.

The loop check in pp_aassign then checks that all of the left side
elements have a refcount of 1 and bypasses the call to
S_aassign_copy_common().

Tony

@p5pRT

This comment has been minimized.

Copy link
Collaborator Author

@p5pRT p5pRT commented Dec 15, 2015

From @iabyn

On Mon, Dec 14, 2015 at 08​:38​:52PM -0800, Tony Cook via RT wrote​:

On Mon Dec 14 17​:19​:38 2015, tonyc wrote​:

On Fri Dec 11 05​:25​:41 2015, andreas.koenig.7os6VVqR@​franz.ak.mind.de wrote​:

Also 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

My patch doesn't appear to fix this, I'll look into it.

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
firstlelem -> $y
lastrelem -> $y
firstlelem -> $x

both $x and $y have a ref count of 1, and PL_op->op_private is
OPpASSIGN_COMMON_RC1.

The loop check in pp_aassign then checks that all of the left side
elements have a refcount of 1 and bypasses the call to
S_aassign_copy_common().

It's salvageable. The following fixes it​:

@​@​ -12344,7 +12344,8 @​@​ S_aassign_scan(pTHX_ OP* o, bool rhs, bool top, int *sca
  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)

The issue is that I had assumed that a sub (even an lvalue one) can't
return a lexical without its ref count having been bumped somewhere along
the line (e.g. by making a closure, or mortalizing for :lvalue return).

min() shows that XS subs can break this assumption. However they should
only be able to do so if the lex var appears as an arg to that sub. By
continuing to scan the children of dangerous ops (e.g. entersub) on the RHS
rather than just immediately returning, the diff above continues the
common var detection that was otherwise being skipped. With the above
diff, these give​:

  $ p -MO=Concise -e'my($x,$y); ($x,$y)=f()' | grep aassign
  aassign[t5] vKS/COM_RC1

  $ p -MO=Concise -e'my($x,$y); ($x,$y)=f($x,$y)' | grep aassign
  aassign[t5] vKS/COM_SCALAR

As an aside, I'm more and more beginning to think that the OA_DANGEROUS
flag for ops ('d' in regen/opcodes) is obsolete / meaningless, and we
probably want to replace it with a flag indicating that the op is capable
of 'passing through' one or more of its args; such as grep. Especially now
that package vars are always treated as aliasable without needing a ref
count bump.

Anyway, do you want me to go ahead and apply the above fix and followups,
or leave this part of the ticket in your court? Ditto for your fix.

--
Never work with children, animals, or actors.

@p5pRT

This comment has been minimized.

Copy link
Collaborator Author

@p5pRT p5pRT commented Jan 7, 2016

From @tonycoz

On Tue Dec 15 06​:04​:01 2015, davem wrote​:

It's salvageable. The following fixes it​:

@​@​ -12344,7 +12344,8 @​@​ S_aassign_scan(pTHX_ OP* o, bool rhs, bool
top, int *sca
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)

That works for me and I couldn't find a new case that breaks it (but users
are ever inventive, so we see what happens.)

I've attached a format-patch version of your patch with a test.

Anyway, do you want me to go ahead and apply the above fix and
followups,
or leave this part of the ticket in your court? Ditto for your fix.

Sorry I missed this follow-up.

I'll apply it next week, unless someone objects, along with your change.

Tony

@p5pRT

This comment has been minimized.

Copy link
Collaborator Author

@p5pRT p5pRT commented Jan 10, 2016

From @tonycoz

On Wed Jan 06 16​:38​:20 2016, tonyc wrote​:

I've attached a format-patch version of your patch with a test.

which I managed to not attach.

I'll apply it next week, unless someone objects, along with your change.

Four patches applied as 0072721, beb08a1, 5c1db56 and 2f9365d.

Tony

@p5pRT

This comment has been minimized.

Copy link
Collaborator Author

@p5pRT p5pRT commented Jan 10, 2016

From @tonycoz

0004-perl-126633-check-children-of-OA_DANGEROUS-ops-for-c.patch
From 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

@p5pRT

This comment has been minimized.

Copy link
Collaborator Author

@p5pRT p5pRT commented Jan 10, 2016

@tonycoz - Status changed from 'open' to 'pending release'

@p5pRT

This comment has been minimized.

Copy link
Collaborator Author

@p5pRT p5pRT commented May 13, 2016

From @khwilliamson

Thank you for submitting this report. You have helped make Perl better.
 
With the release of Perl 5.24.0 on May 9, 2016, this and 149 other issues have been resolved.

Perl 5.24.0 may be downloaded via https://metacpan.org/release/RJBS/perl-5.24.0

@p5pRT

This comment has been minimized.

Copy link
Collaborator Author

@p5pRT p5pRT commented May 13, 2016

@khwilliamson - Status changed from 'pending release' to 'resolved'

@p5pRT p5pRT closed this May 13, 2016
@p5pRT p5pRT added the Severity Low label Oct 19, 2019
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
Projects
None yet
Linked pull requests

Successfully merging a pull request may close this issue.

None yet
1 participant
You can’t perform that action at this time.