When deleting CLONE_PARAMS, push any unreferenced SVs onto the temps stack.

Effectively this leaves the cloned-into interpreter in a consistent state.
In the cloned-from interpreter, the SV targets of non-reference owning pointers
*are* referenced and managed by other pointers. SvREFCNT() == 0 SVs in the
cloned-into interpreter result from the non-reference owning pointers being
found and followed, but the reference owning and managing pointers not being
part of the subsection of interpreter state cloned over. Hence, this change
creates reference owning pointers to this SVs on the temps stack, which ensures
that they are correctly cleaned up, and don't "leak" until interpreter
destruction. (Which might be some time away, in a persistent process.)

diff --git a/embed.fnc b/embed.fnc
index 882ea8b..57dd568 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -2360,6 +2360,9 @@ xpoM      |struct refcounted_he *|store_cop_label \
 xpo    |int    |keyword_plugin_standard|NN char* keyword_ptr|STRLEN keyword_len|NN OP** op_ptr
 
 #if defined(USE_ITHREADS)
+#  if defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT)
+s      |void   |unreferenced_to_tmp_stack|NN AV *const unreferenced
+#  endif
 Aanop  |CLONE_PARAMS *|clone_params_new|NN PerlInterpreter *const from \
                |NN PerlInterpreter *const to
 Anop   |void   |clone_params_del|NN CLONE_PARAMS *param

diff --git a/embed.h b/embed.h
index 12b2087..b328914 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -2049,6 +2049,11 @@
 #define boot_core_mro          Perl_boot_core_mro
 #endif
 #if defined(USE_ITHREADS)
+#  if defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT)
+#ifdef PERL_CORE
+#define unreferenced_to_tmp_stack      S_unreferenced_to_tmp_stack
+#endif
+#  endif
 #endif
 #define ck_anoncode            Perl_ck_anoncode
 #define ck_bitop               Perl_ck_bitop
@@ -4491,6 +4496,11 @@
 #ifdef PERL_CORE
 #endif
 #if defined(USE_ITHREADS)
+#  if defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT)
+#ifdef PERL_CORE
+#define unreferenced_to_tmp_stack(a)   S_unreferenced_to_tmp_stack(aTHX_ a)
+#endif
+#  endif
 #endif
 #define ck_anoncode(a)         Perl_ck_anoncode(aTHX_ a)
 #define ck_bitop(a)            Perl_ck_bitop(aTHX_ a)

diff --git a/proto.h b/proto.h
index 014ac97..0acb1c5 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -6888,6 +6888,13 @@ PERL_CALLCONV int        Perl_keyword_plugin_standard(pTHX_ char* keyword_ptr, STRLEN k
 
 
 #if defined(USE_ITHREADS)
+#  if defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT)
+STATIC void    S_unreferenced_to_tmp_stack(pTHX_ AV *const unreferenced)
+                       __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_UNREFERENCED_TO_TMP_STACK     \
+       assert(unreferenced)
+
+#  endif
 PERL_CALLCONV CLONE_PARAMS *   Perl_clone_params_new(PerlInterpreter *const from, PerlInterpreter *const to)
                        __attribute__malloc__
                        __attribute__warn_unused_result__

diff --git a/sv.c b/sv.c
index d559d6b..380f442 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -12634,37 +12634,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     }
 
     if (!(flags & CLONEf_COPY_STACKS)) {
-       /* although we're not duplicating the tmps stack, we should still
-        * add entries for any SVs on the tmps stack that got cloned by a
-        * non-refcount means (eg a temp in @_); otherwise they will be
-        * orphaned.
-        *
-        * This actualy expands to all SVs which are pointed to, without a
-        * reference being owned by that pointer, such as @_ and weak
-        * references. Owners of these references include the tmps stack, the
-        * save stack, and (effectively) the magic backreference structure.
-        */
-       if (AvFILLp(param->unreferenced) > -1) {
-           SV **svp = AvARRAY(param->unreferenced);
-           SV **const last = svp + AvFILLp(param->unreferenced);
-           SSize_t count = 0;
-
-           do {
-               if (!SvREFCNT(*svp))
-                   ++count;
-           } while (++svp <= last);
-
-           EXTEND_MORTAL(count);
-
-           svp = AvARRAY(param->unreferenced);
-
-           do {
-               if (!SvREFCNT(*svp))
-                   PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple_NN(*svp);
-           } while (++svp <= last);
-       }
-
-       SvREFCNT_dec(param->unreferenced);
+       unreferenced_to_tmp_stack(param->unreferenced);
     }
 
     SvREFCNT_dec(param->stashes);
@@ -12678,6 +12648,32 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     return my_perl;
 }
 
+static void
+S_unreferenced_to_tmp_stack(pTHX_ AV *const unreferenced)
+{
+    PERL_ARGS_ASSERT_UNREFERENCED_TO_TMP_STACK;
+    
+    if (AvFILLp(unreferenced) > -1) {
+       SV **svp = AvARRAY(unreferenced);
+       SV **const last = svp + AvFILLp(unreferenced);
+       SSize_t count = 0;
+
+       do {
+           if (!SvREFCNT(*svp))
+               ++count;
+       } while (++svp <= last);
+
+       EXTEND_MORTAL(count);
+       svp = AvARRAY(unreferenced);
+
+       do {
+           if (!SvREFCNT(*svp))
+               PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple_NN(*svp);
+       } while (++svp <= last);
+    }
+    SvREFCNT_dec(unreferenced);
+}
+
 void
 Perl_clone_params_del(CLONE_PARAMS *param)
 {
@@ -12692,7 +12688,8 @@ Perl_clone_params_del(CLONE_PARAMS *param)
     }
 
     SvREFCNT_dec(param->stashes);
-    SvREFCNT_dec(param->unreferenced);
+    if (param->unreferenced)
+       unreferenced_to_tmp_stack(param->unreferenced);
 
     Safefree(param);
 

diff --git a/t/op/threads.t b/t/op/threads.t
index 364045d..95f5776 100644 (file)
--- a/t/op/threads.t
+++ b/t/op/threads.t
@@ -116,10 +116,6 @@ print do 'op/threads_create.pl' || die $@;
 EOI
 
 
-TODO: {
-    no strict 'vars';   # Accessing $TODO from test.pl
-    local $TODO = 'refcount issues with threads';
-
 # Scalars leaked: 1
 foreach my $BLOCK (qw(CHECK INIT)) {
     fresh_perl_is(<<EOI, 'ok', { }, "threads in $BLOCK block");
@@ -129,8 +125,6 @@ foreach my $BLOCK (qw(CHECK INIT)) {
 EOI
 }
 
-} # TODO
-
 # Scalars leaked: 1
 fresh_perl_is(<<'EOI', 'ok', { }, 'Bug #41138');
     use threads;
@@ -206,8 +200,8 @@ print "ok";
 EOI
 
 # Another, more reliable test for the same del_backref bug:
-fresh_perl_like(
- <<'   EOJ', qr/ok/, {}, 'No del_backref panic [perl #70748] (2)'
+fresh_perl_is(
+ <<'   EOJ', 'ok', {}, 'No del_backref panic [perl #70748] (2)'
    use threads;
    push @bar, threads->create(sub{sub{}})->join() for 1...10;
    print "ok";
@@ -216,10 +210,10 @@ fresh_perl_like(
 
 # Simple closure-returning test: At least this case works (though it
 # leaks), and we don't want to break it.
-fresh_perl_like(<<'EOJ', qr/^foo\n/, {}, 'returning a closure');
+fresh_perl_is(<<'EOJ', 'foo', {}, 'returning a closure');
 use threads;
 print create threads sub {
- my $x = "foo\n";
+ my $x = 'foo';
  sub{sub{$x}}
 }=>->join->()()
  //"undef"