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

diff --git a/embed.fnc b/embed.fnc
index c05c422..914a6ff 100644 (file)
--- 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 95b2dfb..1e1dcc1 100644 (file)
--- 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 b43a5f0..9475f9b 100644 (file)
--- 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 1f25273..771bd89 100644 (file)
--- 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 cc7f00b..a5acbc7 100644 (file)
--- 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 21ac641..dbec48e 100644 (file)
--- 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;