In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/defb77b559d3c08f94e6db14937a91a4cac8e204?hp=b28683c9b5d157bf72cd93c7d257ed5b39dad090>
- Log ----------------------------------------------------------------- commit defb77b559d3c08f94e6db14937a91a4cac8e204 Author: David Mitchell <[email protected]> Date: Fri Apr 14 10:51:56 2017 +0100 threads::shared: alloc arenas with correct context RT #131124 In a couple of places in shared.xs, it calls sv_newmortal() with a perl context different from that currently set by PERL_SET_CONTEXT(). If sv_newmortal() happens to trigger the malloc of a new SV HEAD arena, then under PERL_TRACK_MEMPOOL, this will cause panics when the arena is freed or realloced. ----------------------------------------------------------------------- Summary of changes: dist/threads-shared/lib/threads/shared.pm | 4 ++-- dist/threads-shared/shared.xs | 6 ++++-- dist/threads-shared/t/object2.t | 24 +++++++++++++++++++++++- 3 files changed, 29 insertions(+), 5 deletions(-) diff --git a/dist/threads-shared/lib/threads/shared.pm b/dist/threads-shared/lib/threads/shared.pm index 5a203b0cd7..73c4dd997f 100644 --- a/dist/threads-shared/lib/threads/shared.pm +++ b/dist/threads-shared/lib/threads/shared.pm @@ -7,7 +7,7 @@ use warnings; use Scalar::Util qw(reftype refaddr blessed); -our $VERSION = '1.55'; # Please update the pod, too. +our $VERSION = '1.56'; # Please update the pod, too. my $XS_VERSION = $VERSION; $VERSION = eval $VERSION; @@ -195,7 +195,7 @@ threads::shared - Perl extension for sharing data structures between threads =head1 VERSION -This document describes threads::shared version 1.55 +This document describes threads::shared version 1.56 =head1 SYNOPSIS diff --git a/dist/threads-shared/shared.xs b/dist/threads-shared/shared.xs index dab5e362e0..3c1b5e608c 100644 --- a/dist/threads-shared/shared.xs +++ b/dist/threads-shared/shared.xs @@ -1104,8 +1104,9 @@ sharedsv_array_mg_CLEAR(pTHX_ SV *sv, MAGIC *mg) if (!sv) continue; if ( (SvOBJECT(sv) || (SvROK(sv) && (sv = SvRV(sv)))) && SvREFCNT(sv) == 1 ) { - SV *tmp = Perl_sv_newmortal(caller_perl); + SV *tmp; PERL_SET_CONTEXT((aTHX = caller_perl)); + tmp = sv_newmortal(); sv_upgrade(tmp, SVt_RV); get_RV(tmp, sv); PERL_SET_CONTEXT((aTHX = PL_sharedsv_space)); @@ -1384,8 +1385,9 @@ STORESIZE(SV *obj,IV count) if ( (SvOBJECT(sv) || (SvROK(sv) && (sv = SvRV(sv)))) && SvREFCNT(sv) == 1 ) { - SV *tmp = Perl_sv_newmortal(caller_perl); + SV *tmp; PERL_SET_CONTEXT((aTHX = caller_perl)); + tmp = sv_newmortal(); sv_upgrade(tmp, SVt_RV); get_RV(tmp, sv); PERL_SET_CONTEXT((aTHX = PL_sharedsv_space)); diff --git a/dist/threads-shared/t/object2.t b/dist/threads-shared/t/object2.t index 3d795b9208..31c3797431 100644 --- a/dist/threads-shared/t/object2.t +++ b/dist/threads-shared/t/object2.t @@ -17,7 +17,7 @@ use ExtUtils::testlib; BEGIN { $| = 1; - print("1..131\n"); ### Number of tests that will be run ### + print("1..133\n"); ### Number of tests that will be run ### }; use threads; @@ -445,6 +445,28 @@ ok($destroyed[$ID], 'Scalar object removed from shared scalar'); ::ok($count == $n, "remove array object by undef"); } +# RT #131124 +# Emptying a shared array creates new temp SVs. If there are no spare +# SVs, a new arena is allocated. shared.xs was mallocing a new arena +# with the wrong perl context set, meaning that when the arena was later +# freed, it would "panic: realloc from wrong pool" +# + +{ + threads->new(sub { + my @a :shared; + push @a, bless &threads::shared::share({}) for 1..1000; + undef @a; # this creates lots of temp SVs + })->join; + ok(1, "#131124 undef array doesnt panic"); + + threads->new(sub { + my @a :shared; + push @a, bless &threads::shared::share({}) for 1..1000; + @a = (); # this creates lots of temp SVs + })->join; + ok(1, "#131124 clear array doesnt panic"); +} # EOF -- Perl5 Master Repository
