newCONTSUB() wasn't thread-safe ([perl #45053])

p4raw-id: //depot/perl@32091

2 files changed, 25 insertions, 2 deletions

diff --git a/ext/threads/t/problems.t b/ext/threads/t/problems.t
index d979b3a512..2cbab0007b 100644
--- a/ext/threads/t/problems.t
+++ b/ext/threads/t/problems.t
@@ -29,9 +29,9 @@ BEGIN {
 
     $| = 1;
     if ($] == 5.008) {
-        print("1..11\n");   ### Number of tests that will be run ###
+        print("1..12\n");   ### Number of tests that will be run ###
     } else {
-        print("1..15\n");   ### Number of tests that will be run ###
+        print("1..16\n");   ### Number of tests that will be run ###
     }
 };
 
@@ -178,4 +178,20 @@ is(keys(%h), 1, "keys correct in parent with restricted hash");
 $child = threads->create(sub { return (scalar(keys(%h))); })->join;
 is($child, 1, "keys correct in child with restricted hash");
 
+
+# [perl #45053] Memory corruption with heavy module loading in threads
+#
+# run-time usage of newCONSTSUB (as done by the IO boot code) wasn't
+# thread-safe - got occasional coredumps or malloc corruption
+
+{
+    my @t;
+    push @t, threads->create( sub { require IO }) for 1..100;
+    $_->join for @t;
+    print("ok $test - [perl #45053]\n");
+    $test++;
+}
+
+
+
 # EOF
diff --git a/op.c b/op.c
index a74743ed5b..15510b27c4 100644
--- a/op.c
+++ b/op.c
@@ -5696,6 +5696,13 @@ Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
 
     ENTER;
 
+    if (IN_PERL_RUNTIME) {
+	/* at runtime, it's not safe to manipulate PL_curcop: it may be
+	 * an op shared between threads. Use a non-shared COP for our
+	 * dirty work */
+	 SAVEVPTR(PL_curcop);
+	 PL_curcop = &PL_compiling;
+    }
     SAVECOPLINE(PL_curcop);
     CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);