The current implementation of :unique is fundamentally flawed,

because declaring a scalar READONLY does not stop it being modified.
Hence the current implementation of :unique is *not threadsafe*
D'oh!
Better implementations welcome.

p4raw-id: //depot/perl@24962

6 files changed, 23 insertions, 88 deletions

diff --git a/embed.fnc b/embed.fnc
index c05c4220ac..914a6ff65a 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -1244,9 +1244,6 @@ s	|int	|sv_2iuv_non_preserve	|SV *sv|I32 numtype
 #  endif
 sR	|I32	|expect_number	|NN char** pattern
 #
-#  if defined(USE_ITHREADS)
-s	|SV*	|gv_share	|SV *sv|CLONE_PARAMS *param
-#  endif
 s	|bool	|utf8_mg_pos	|NN SV *sv|NN MAGIC **mgp|NN STRLEN **cachep \
 				|I32 i|NN I32 *offsetp|I32 uoff \
 				|NN const U8 **sp|NN const U8 *start \
diff --git a/embed.h b/embed.h
index 95b2dfb98f..1e1dcc136c 100644
--- a/embed.h
+++ b/embed.h
@@ -1307,11 +1307,6 @@
 #ifdef PERL_CORE
 #define expect_number		S_expect_number
 #endif
-#  if defined(USE_ITHREADS)
-#ifdef PERL_CORE
-#define gv_share		S_gv_share
-#endif
-#  endif
 #ifdef PERL_CORE
 #define utf8_mg_pos		S_utf8_mg_pos
 #define utf8_mg_pos_init	S_utf8_mg_pos_init
@@ -3274,11 +3269,6 @@
 #ifdef PERL_CORE
 #define expect_number(a)	S_expect_number(aTHX_ a)
 #endif
-#  if defined(USE_ITHREADS)
-#ifdef PERL_CORE
-#define gv_share(a,b)		S_gv_share(aTHX_ a,b)
-#endif
-#  endif
 #ifdef PERL_CORE
 #define utf8_mg_pos(a,b,c,d,e,f,g,h,i)	S_utf8_mg_pos(aTHX_ a,b,c,d,e,f,g,h,i)
 #define utf8_mg_pos_init(a,b,c,d,e,f,g)	S_utf8_mg_pos_init(aTHX_ a,b,c,d,e,f,g)
diff --git a/ext/threads/t/problems.t b/ext/threads/t/problems.t
index b43a5f0b81..9475f9b3e1 100644
--- a/ext/threads/t/problems.t
+++ b/ext/threads/t/problems.t
@@ -82,14 +82,18 @@ our @unique_array : unique;
 our %unique_hash : unique;
 threads->new(
     sub {
+	my $TODO = ":unique needs to be re-implemented in a non-broken way";
 	eval { $unique_scalar = 1 };
-	print $@ =~ /read-only/  ? '' : 'not ', "ok $test - unique_scalar\n";
+	print $@ =~ /read-only/
+	  ? '' : 'not ', "ok $test # TODO $TODO unique_scalar\n";
 	$test++;
 	eval { $unique_array[0] = 1 };
-	print $@ =~ /read-only/  ? '' : 'not ', "ok $test - unique_array\n";
+	print $@ =~ /read-only/
+	  ? '' : 'not ', "ok $test # TODO $TODO - unique_array\n";
 	$test++;
 	eval { $unique_hash{abc} = 1 };
-	print $@ =~ /disallowed/  ? '' : 'not ', "ok $test - unique_hash\n";
+	print $@ =~ /disallowed/
+	  ? '' : 'not ', "ok $test # TODO $TODO - unique_hash\n";
 	$test++;
     }
 )->join;
diff --git a/pod/perltodo.pod b/pod/perltodo.pod
index 1f252739e7..771bd89457 100644
--- a/pod/perltodo.pod
+++ b/pod/perltodo.pod
@@ -265,7 +265,21 @@ Some more nebulous ideas
 
 =head2 threads
 
-Make threads more robust.
+=over 4
+
+=item *
+
+Re-implement C<:unique> in a way that is actualy thread-safe
+
+=item *
+
+Make C<threads::shared> share aggregates properly
+
+(these two may actually share approach, if not implementation
+
+=back
+
+Generally make threads more robust. See also L<iCOW>
 
 =head2 POSIX memory footprint
 
diff --git a/proto.h b/proto.h
index cc7f00bf48..a5acbc79f8 100644
--- a/proto.h
+++ b/proto.h
@@ -2603,9 +2603,6 @@ STATIC I32	S_expect_number(pTHX_ char** pattern)
 			__attribute__nonnull__(pTHX_1);
 
 #
-#  if defined(USE_ITHREADS)
-STATIC SV*	S_gv_share(pTHX_ SV *sv, CLONE_PARAMS *param);
-#  endif
 STATIC bool	S_utf8_mg_pos(pTHX_ SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i, I32 *offsetp, I32 uoff, const U8 **sp, const U8 *start, const U8 *send)
 			__attribute__nonnull__(pTHX_1)
 			__attribute__nonnull__(pTHX_2)
diff --git a/sv.c b/sv.c
index 21ac641887..dbec48e4f2 100644
--- a/sv.c
+++ b/sv.c
@@ -10221,62 +10221,6 @@ Perl_ptr_table_free(pTHX_ PTR_TBL_t *tbl)
     Safefree(tbl);
 }
 
-/* attempt to make everything in the typeglob readonly */
-
-STATIC SV *
-S_gv_share(pTHX_ SV *sstr, CLONE_PARAMS *param)
-{
-    GV *gv = (GV*)sstr;
-    SV *sv = &param->proto_perl->Isv_no; /* just need SvREADONLY-ness */
-
-    if (GvIO(gv) || GvFORM(gv)) {
-        GvUNIQUE_off(gv); /* GvIOs cannot be shared. nor can GvFORMs */
-    }
-    else if (!GvCV(gv)) {
-        GvCV(gv) = (CV*)sv;
-    }
-    else {
-        /* CvPADLISTs cannot be shared */
-        if (!SvREADONLY(GvCV(gv)) && !CvXSUB(GvCV(gv))) {
-            GvUNIQUE_off(gv);
-        }
-    }
-
-    if (!GvUNIQUE(gv)) {
-#if 0
-        PerlIO_printf(Perl_debug_log, "gv_share: unable to share %s::%s\n",
-                      HvNAME_get(GvSTASH(gv)), GvNAME(gv));
-#endif
-        return Nullsv;
-    }
-
-    /*
-     * write attempts will die with
-     * "Modification of a read-only value attempted"
-     */
-    if (!GvSV(gv)) {
-        GvSV(gv) = sv;
-    }
-    else {
-        SvREADONLY_on(GvSV(gv));
-    }
-
-    if (!GvAV(gv)) {
-        GvAV(gv) = (AV*)sv;
-    }
-    else {
-        SvREADONLY_on(GvAV(gv));
-    }
-
-    if (!GvHV(gv)) {
-        GvHV(gv) = (HV*)sv;
-    }
-    else {
-        SvREADONLY_on(GvHV(gv));
-    }
-
-    return sstr; /* he_dup() will SvREFCNT_inc() */
-}
 
 void
 Perl_rvpv_dup(pTHX_ SV *dstr, SV *sstr, CLONE_PARAMS* param)
@@ -10450,17 +10394,7 @@ Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param)
 		goto new_body;
 	    case SVt_PVGV:
 		if (GvUNIQUE((GV*)sstr)) {
-		    SV *share;
-		    if ((share = gv_share(sstr, param))) {
-			del_SV(dstr);
-			dstr = share;
-			ptr_table_store(PL_ptr_table, sstr, dstr);
-#if 0
-			PerlIO_printf(Perl_debug_log, "sv_dup: sharing %s::%s\n",
-				      HvNAME_get(GvSTASH(share)), GvNAME(share));
-#endif
-			goto done_share;
-		    }
+		    /* Do sharing here.  */
 		}
 		new_body_length = sizeof(XPVGV);
 		new_body_arena = (void **) &PL_xpvgv_root;
@@ -10691,7 +10625,6 @@ Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param)
 	}
     }
 
- done_share:
     if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
 	++PL_sv_objcount;