Skip Menu |
Report information
Id: 126633
Status: resolved
Priority: 0/
Queue: perl5

Owner: Nobody
Requestors: andreas.koenig.7os6VVqR [at] franz.ak.mind.de
Cc:
AdminCc:

Operating System: (no value)
PatchStatus: (no value)
Severity: low
Type: unknown
Perl Version: (no value)
Fixed In: (no value)



Subject: Bleadperl v5.23.1-199-ga5f4850 breaks BRUMLEVE/ddb-1.3.1.tar.gz
Date: Fri, 13 Nov 2015 21:05:00 +0100
From: Andreas Koenig <andreas.koenig.7os6VVqR [...] franz.ak.mind.de>
To: perlbug [...] perl.org
Download (untitled) / with headers
text/plain 3.3k
bisect ------ commit a5f48505593c7e1ca478de383e24d5cc2541f3ca 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
RT-Send-CC: perl5-porters [...] perl.org
Download (untitled) / with headers
text/plain 922b
On Fri Nov 13 12:05:28 2015, andreas.koenig.7os6VVqR@franz.ak.mind.de wrote: Show quoted text
> bisect > ------ > commit a5f48505593c7e1ca478de383e24d5cc2541f3ca > 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
Subject: 126633.pl
Download 126633.pl
text/x-perl 395b
use Data::Dumper; tie %x, "SomeHash"; @x{"a" .. "d"} = 1 .. 4; print Dumper(\%x); my ($key1, $key2) = ("a", "b"); @x{$key1, $key2} = @x{$key2, $key1}; print Dumper(\%x); package SomeHash; sub TIEHASH { bless {}, __PACKAGE__; } sub STORE { $_[0]->{$_[1]} = $_[2]; } sub FETCH { $_[0]->{$_[1]}; } sub FIRSTKEY { keys %{$_[0]}; each %{$_[0]}; } sub NEXTKEY { each %{$_[0]}; }
RT-Send-CC: perl5-porters [...] perl.org, davem [...] iabyn.com
Download (untitled) / with headers
text/plain 631b
On Mon Nov 16 21:02:19 2015, tonyc wrote: Show quoted text
> On Fri Nov 13 12:05:28 2015, andreas.koenig.7os6VVqR@franz.ak.mind.de > wrote:
> > bisect > > ------ > > commit a5f48505593c7e1ca478de383e24d5cc2541f3ca > > 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
Subject: 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
To: Tony Cook via RT <perlbug-followup [...] perl.org>
CC: perl5-porters [...] perl.org
Subject: Re: [perl #126633] Bleadperl v5.23.1-199-ga5f4850 breaks BRUMLEVE/ddb-1.3.1.tar.gz
From: Dave Mitchell <davem [...] iabyn.com>
Date: Wed, 18 Nov 2015 14:21:27 +0000
Download (untitled) / with headers
text/plain 2.4k
On Tue, Nov 17, 2015 at 03:09:50PM -0800, Tony Cook via RT wrote: Show quoted text
> 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 a5f48505593c7e1ca478de383e24d5cc2541f3ca > > > 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"
RT-Send-CC: perl5-porters [...] perl.org
Download (untitled) / with headers
text/plain 2.8k
On Wed Nov 18 06:22:11 2015, davem wrote: Show quoted text
> 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 a5f48505593c7e1ca478de383e24d5cc2541f3ca > > > > 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. Show quoted text
> > 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
Subject: 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
RT-Send-CC: perl5-porters [...] perl.org
Download (untitled) / with headers
text/plain 175b
On Mon Dec 07 16:24:47 2015, tonyc wrote: Show quoted text
> 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
Subject: 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
Subject: 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
Subject: 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
From: Dave Mitchell <davem [...] iabyn.com>
Date: Wed, 9 Dec 2015 09:28:53 +0000
CC: perl5-porters [...] perl.org
To: Tony Cook via RT <perlbug-followup [...] perl.org>
Subject: Re: [perl #126633] Bleadperl v5.23.1-199-ga5f4850 breaks BRUMLEVE/ddb-1.3.1.tar.gz
Download (untitled) / with headers
text/plain 856b
On Mon, Dec 07, 2015 at 04:24:47PM -0800, Tony Cook via RT wrote: Show quoted text
> 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.
Oh yeah :-( Show quoted text
> 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.
Subject: Re: [perl #126633] Bleadperl v5.23.1-199-ga5f4850 breaks BRUMLEVE/ddb-1.3.1.tar.gz
Date: Fri, 11 Dec 2015 11:45:45 +0100
CC: perl5-porters [...] perl.org
From: Andreas Koenig <andreas.koenig.7os6VVqR [...] franz.ak.mind.de>
To: "Tony Cook via RT" <perlbug-followup [...] perl.org>
Download (untitled) / with headers
text/plain 241b
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
RT-Send-CC: perl5-porters [...] perl.org
Download (untitled) / with headers
text/plain 385b
On Fri Dec 11 05:25:41 2015, andreas.koenig.7os6VVqR@franz.ak.mind.de wrote: Show quoted text
> 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
RT-Send-CC: davem [...] iabyn.com, perl5-porters [...] perl.org
Download (untitled) / with headers
text/plain 901b
On Mon Dec 14 17:19:38 2015, tonyc wrote: Show quoted text
> 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
Subject: Re: [perl #126633] Bleadperl v5.23.1-199-ga5f4850 breaks BRUMLEVE/ddb-1.3.1.tar.gz
To: Tony Cook via RT <perlbug-followup [...] perl.org>
CC: perl5-porters [...] perl.org
Date: Tue, 15 Dec 2015 14:03:18 +0000
From: Dave Mitchell <davem [...] iabyn.com>
Download (untitled) / with headers
text/plain 2.7k
On Mon, Dec 14, 2015 at 08:38:52PM -0800, Tony Cook via RT wrote: Show quoted text
> 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.
RT-Send-CC: perl5-porters [...] perl.org
Download (untitled) / with headers
text/plain 884b
On Tue Dec 15 06:04:01 2015, davem wrote: Show quoted text
> 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. Show quoted text
> 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
RT-Send-CC: perl5-porters [...] perl.org
Download (untitled) / with headers
text/plain 419b
On Wed Jan 06 16:38:20 2016, tonyc wrote: Show quoted text
> I've attached a format-patch version of your patch with a test.
which I managed to not attach. Show quoted text
> I'll apply it next week, unless someone objects, along with your change.
Four patches applied as 0072721ceb719c27771e260b6e8516b947c4bb94, beb08a1e6d63c1eed4da66e066991eb58afccde7, 5c1db5695506e43718a1575bebb1ecf2675e3798 and 2f9365dc3b09bdf83c00a6d176d882057608308e. Tony
Subject: 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
Download (untitled) / with headers
text/plain 252b
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


This service is sponsored and maintained by Best Practical Solutions and runs on Perl.org infrastructure.

For issues related to this RT instance (aka "perlbug"), please contact perlbug-admin at perl.org