From: Nicholas Clark Date: Thu, 23 Jun 2005 18:00:38 +0000 (+0000) Subject: The current implementation of :unique is fundamentally flawed, X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=0abe3f7c711f6721217c5d47ec581395dd1981da;p=p5sagit%2Fp5-mst-13.2.git 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 --- 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 --- 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 --- 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 --- 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 share aggregates properly + +(these two may actually share approach, if not implementation + +=back + +Generally make threads more robust. See also L =head2 POSIX memory footprint diff --git a/proto.h b/proto.h index cc7f00b..a5acbc7 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 21ac641..dbec48e 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 = ¶m->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;