Better ithreads cloning - add all SVs with a 0 refcnt to the temps stack.

Track all SVs created by sv_dup() that have a 0 reference count. If they still
have a 0 reference count at the end of cloning, assign a reference to each to
the temps stack. As the temps stack is cleared at thread exit, SVs book keeping
will be correct and consistent before perl_destruct() makes its check for
leaked scalars.

Remove special case code for checking each @_ and the parent's temp stack.

diff --git a/embed.fnc b/embed.fnc
index b35ad7e..882ea8b 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -1421,6 +1421,10 @@ ApR      |MAGIC* |mg_dup         |NULLOK MAGIC *mg|NN CLONE_PARAMS *const param
 s      |SV **  |sv_dup_inc_multiple|NN SV *const *source|NN SV **dest \
                                |SSize_t items|NN CLONE_PARAMS *const param
 #endif
+#if defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT)
+sR     |SV*    |sv_dup_common  |NN const SV *const sstr \
+                               |NN CLONE_PARAMS *const param
+#endif
 ApR    |SV*    |sv_dup         |NULLOK const SV *const sstr|NN CLONE_PARAMS *const param
 ApR    |SV*    |sv_dup_inc     |NULLOK const SV *const sstr \
                                |NN CLONE_PARAMS *const param

diff --git a/embed.h b/embed.h
index 819f76a..12b2087 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -1180,6 +1180,11 @@
 #define sv_dup_inc_multiple    S_sv_dup_inc_multiple
 #endif
 #endif
+#if defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT)
+#ifdef PERL_CORE
+#define sv_dup_common          S_sv_dup_common
+#endif
+#endif
 #define sv_dup                 Perl_sv_dup
 #define sv_dup_inc             Perl_sv_dup_inc
 #define rvpv_dup               Perl_rvpv_dup
@@ -3592,6 +3597,11 @@
 #define sv_dup_inc_multiple(a,b,c,d)   S_sv_dup_inc_multiple(aTHX_ a,b,c,d)
 #endif
 #endif
+#if defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT)
+#ifdef PERL_CORE
+#define sv_dup_common(a,b)     S_sv_dup_common(aTHX_ a,b)
+#endif
+#endif
 #define sv_dup(a,b)            Perl_sv_dup(aTHX_ a,b)
 #define sv_dup_inc(a,b)                Perl_sv_dup_inc(aTHX_ a,b)
 #define rvpv_dup(a,b,c)                Perl_rvpv_dup(aTHX_ a,b,c)

diff --git a/proto.h b/proto.h
index 4efc502..014ac97 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -4289,6 +4289,15 @@ STATIC SV **     S_sv_dup_inc_multiple(pTHX_ SV *const *source, SV **dest, SSize_t i
        assert(source); assert(dest); assert(param)
 
 #endif
+#if defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT)
+STATIC SV*     S_sv_dup_common(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
+                       __attribute__warn_unused_result__
+                       __attribute__nonnull__(pTHX_1)
+                       __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_SV_DUP_COMMON \
+       assert(sstr); assert(param)
+
+#endif
 PERL_CALLCONV SV*      Perl_sv_dup(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
                        __attribute__warn_unused_result__
                        __attribute__nonnull__(pTHX_2);

diff --git a/sv.c b/sv.c
index d21c945..d559d6b 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -11005,16 +11005,14 @@ S_sv_dup_inc_multiple(pTHX_ SV *const *source, SV **dest,
 
 /* duplicate an SV of any type (including AV, HV etc) */
 
-SV *
-Perl_sv_dup(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
+static SV *
+S_sv_dup_common(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
 {
     dVAR;
     SV *dstr;
 
-    PERL_ARGS_ASSERT_SV_DUP;
+    PERL_ARGS_ASSERT_SV_DUP_COMMON;
 
-    if (!sstr)
-       return NULL;
     if (SvTYPE(sstr) == SVTYPEMASK) {
 #ifdef DEBUG_LEAKING_SCALARS_ABORT
        abort();
@@ -11245,11 +11243,6 @@ Perl_sv_dup(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
                    else {
                        while (items-- > 0)
                            *dst_ary++ = sv_dup(*src_ary++, param);
-                       if (!(param->flags & CLONEf_COPY_STACKS)
-                            && AvREIFY(sstr))
-                       {
-                           av_reify(MUTABLE_AV(dstr)); /* #41138 */
-                       }
                    }
                    items = AvMAX((const AV *)sstr) - AvFILLp((const AV *)sstr);
                    while (items-- > 0) {
@@ -11355,7 +11348,22 @@ SV *
 Perl_sv_dup_inc(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
 {
     PERL_ARGS_ASSERT_SV_DUP_INC;
-    return SvREFCNT_inc(sv_dup(sstr,param));
+    return sstr ? SvREFCNT_inc(sv_dup_common(sstr, param)) : NULL;
+}
+
+SV *
+Perl_sv_dup(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
+{
+    SV *dstr = sstr ? sv_dup_common(sstr, param) : NULL;
+    PERL_ARGS_ASSERT_SV_DUP;
+
+    /* Track every SV that (at least initially) had a reference count of 0.  */
+    if (dstr && !(param->flags & CLONEf_COPY_STACKS) && !SvREFCNT(dstr)) {
+       assert(param->unreferenced);
+       av_push(param->unreferenced, dstr);
+    }
+
+    return dstr;
 }
 
 /* duplicate a context */
@@ -12018,6 +12026,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     /* Likely nothing will use this, but it is initialised to be consistent
        with Perl_clone_params_new().  */
     param->proto_perl = my_perl;
+    param->unreferenced = NULL;
 
     INIT_TRACK_MEMPOOL(my_perl->Imemory_debug_header, my_perl);
 
@@ -12119,6 +12128,11 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
        &PL_sv_undef, and SvREFCNT_dec()ing those.  */
     AvREAL_off(param->stashes);
 
+    if (!(flags & CLONEf_COPY_STACKS)) {
+       param->unreferenced = newAV();
+       AvREAL_off(param->unreferenced);
+    }
+
     /* Set tainting stuff before PerlIO_debug can possibly get called */
     PL_tainting                = proto_perl->Itainting;
     PL_taint_warn      = proto_perl->Itaint_warn;
@@ -12513,19 +12527,6 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     else {
        init_stacks();
        ENTER;                  /* perl_destruct() wants to LEAVE; */
-
-       /* 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
-        */
-       for (i = 0; i<= proto_perl->Itmps_ix; i++) {
-           SV * const nsv = MUTABLE_SV(ptr_table_fetch(PL_ptr_table,
-                   proto_perl->Itmps_stack[i]));
-           if (nsv && !SvREFCNT(nsv)) {
-               PUSH_EXTEND_MORTAL__SV_C(SvREFCNT_inc_simple(nsv));
-           }
-       }
     }
 
     PL_start_env       = proto_perl->Istart_env;       /* XXXXXX */
@@ -12632,6 +12633,39 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
         PL_ptr_table = NULL;
     }
 
+    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);
+    }
 
     SvREFCNT_dec(param->stashes);
 
@@ -12658,6 +12692,7 @@ Perl_clone_params_del(CLONE_PARAMS *param)
     }
 
     SvREFCNT_dec(param->stashes);
+    SvREFCNT_dec(param->unreferenced);
 
     Safefree(param);
 
@@ -12690,6 +12725,8 @@ Perl_clone_params_new(PerlInterpreter *const from, PerlInterpreter *const to)
     param->new_perl = to;
     param->stashes = (AV *)Perl_newSV_type(to, SVt_PVAV);
     AvREAL_off(param->stashes);
+    param->unreferenced = (AV *)Perl_newSV_type(to, SVt_PVAV);
+    AvREAL_off(param->unreferenced);
 
     if (was != to) {
        PERL_SET_THX(was);

diff --git a/sv.h b/sv.h
index 744687a..3f31920 100644 (file)
--- a/sv.h
+++ b/sv.h
@@ -1940,6 +1940,7 @@ struct clone_params {
   UV  flags;
   PerlInterpreter *proto_perl;
   PerlInterpreter *new_perl;
+  AV *unreferenced;
 };
 
 /*

diff --git a/t/op/threads.t b/t/op/threads.t
index d9fed9b..364045d 100644 (file)
--- a/t/op/threads.t
+++ b/t/op/threads.t
@@ -16,7 +16,7 @@ BEGIN {
        exit 0;
      }
 
-     plan(19);
+     plan(20);
 }
 
 use strict;
@@ -253,4 +253,14 @@ fresh_perl_like(<<'EOI', qr/\AThread 1 terminated abnormally: Not a CODE referen
     print "end";
 EOI
 
+fresh_perl_is(<<'EOI', 'ok', { }, '0 refcnt neither on tmps stack nor in @_');
+    use threads;
+    my %h = (1, []);
+    use Scalar::Util 'weaken';
+    my $a = $h{1};
+    weaken($a);
+    delete $h{1} && threads->create(sub {}, shift)->join();
+    print 'ok';
+EOI
+
 # EOF