From: Nicholas Clark <nick@ccl4.org>
Date: Wed, 24 Feb 2010 17:15:41 +0000 (+0000)
Subject: Better ithreads cloning - add all SVs with a 0 refcnt to the temps stack.
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=d08d57ef17162c52e2024a3ba6755f778acbc697;p=p5sagit%2Fp5-mst-13.2.git

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
--- 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
--- 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
--- 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
--- 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
--- 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
--- 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