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.

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