From: Vincent Pit Date: Sun, 3 May 2009 12:24:04 +0000 (+0200) Subject: Make the op map thread safe X-Git-Tag: v0.12~6 X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2Findirect.git;a=commitdiff_plain;h=0df47659c67c30deca9fc06d6c7643a886ddb7d8 Make the op map thread safe --- diff --git a/MANIFEST b/MANIFEST index 634e126..695b66c 100644 --- a/MANIFEST +++ b/MANIFEST @@ -12,6 +12,7 @@ t/20-bad.t t/21-bad-fatal.t t/22-bad-mixed.t t/30-scope.t +t/40-threads.t t/90-boilerplate.t t/91-pod.t t/92-pod-coverage.t diff --git a/indirect.xs b/indirect.xs index b19e11a..6203d97 100644 --- a/indirect.xs +++ b/indirect.xs @@ -11,6 +11,14 @@ /* --- Compatibility wrappers ---------------------------------------------- */ +#ifndef NOOP +# define NOOP +#endif + +#ifndef dNOOP +# define dNOOP +#endif + #ifndef SvPV_const # define SvPV_const SvPV #endif @@ -93,15 +101,23 @@ # endif #else # define I_THREADSAFE 0 +# undef dMY_CXT +# define dMY_CXT dNOOP +# undef MY_CXT +# define MY_CXT indirect_globaldata +# undef START_MY_CXT +# define START_MY_CXT STATIC my_cxt_t MY_CXT; +# undef MY_CXT_INIT +# define MY_CXT_INIT NOOP +# undef MY_CXT_CLONE +# define MY_CXT_CLONE NOOP #endif /* --- Helpers ------------------------------------------------------------- */ -/* ... Thread-safe hints ................................................... */ - -#if I_THREADSAFE +/* ... Pointer table ....................................................... */ -#define PTABLE_NAME ptable_hints +#define PTABLE_NAME ptable #define PTABLE_VAL_FREE(V) if ((V) && !SvIS_FREED((SV *) (V))) SvREFCNT_dec(V) #define pPTBL pTHX @@ -111,19 +127,37 @@ #include "ptable.h" -#define ptable_hints_store(T, K, V) ptable_hints_store(aTHX_ (T), (K), (V)) -#define ptable_hints_free(T) ptable_hints_free(aTHX_ (T)) +#define ptable_store(T, K, V) ptable_store(aTHX_ (T), (K), (V)) +#define ptable_clear(T) ptable_clear(aTHX_ (T)) +#define ptable_free(T) ptable_free(aTHX_ (T)) + +/* ... Thread-safe hints ................................................... */ #define MY_CXT_KEY __PACKAGE__ "::_guts" XS_VERSION +#if I_THREADSAFE + typedef struct { - ptable *tbl; - tTHX owner; + ptable *tbl; + ptable *map; + tTHX owner; + const char *linestr; } my_cxt_t; +#else + +typedef struct { + ptable *map; + const char *linestr; +} my_cxt_t; + +#endif /* I_THREADSAFE */ + START_MY_CXT -STATIC void indirect_ptable_hints_clone(pTHX_ ptable_ent *ent, void *ud_) { +#if I_THREADSAFE + +STATIC void indirect_ptable_clone(pTHX_ ptable_ent *ent, void *ud_) { my_cxt_t *ud = ud_; SV *val = ent->val; @@ -140,7 +174,7 @@ STATIC void indirect_ptable_hints_clone(pTHX_ ptable_ent *ent, void *ud_) { } } - ptable_hints_store(ud->tbl, ent->key, val); + ptable_store(ud->tbl, ent->key, val); SvREFCNT_inc(val); } @@ -158,7 +192,8 @@ STATIC void indirect_thread_cleanup(pTHX_ void *ud) { } else { dMY_CXT; PerlMemShared_free(level); - ptable_hints_free(MY_CXT.tbl); + ptable_free(MY_CXT.map); + ptable_free(MY_CXT.tbl); } } @@ -170,7 +205,7 @@ STATIC SV *indirect_tag(pTHX_ SV *value) { /* We only need for the key to be an unique tag for looking up the value later. * Allocated memory provides convenient unique identifiers, so that's why we * use the value pointer as the key itself. */ - ptable_hints_store(MY_CXT.tbl, value, value); + ptable_store(MY_CXT.tbl, value, value); SvREFCNT_inc(value); return newSVuv(PTR2UV(value)); @@ -235,25 +270,9 @@ STATIC SV *indirect_hint(pTHX) { /* ... op -> source position ............................................... */ -#define PTABLE_NAME ptable_map -#define PTABLE_VAL_FREE(V) SvREFCNT_dec(V) - -#define pPTBL pTHX -#define pPTBL_ pTHX_ -#define aPTBL aTHX -#define aPTBL_ aTHX_ - -#include "ptable.h" - -#define ptable_map_store(T, K, V) ptable_map_store(aTHX_ (T), (K), (V)) -#define ptable_map_clear(T) ptable_map_clear(aTHX_ (T)) - -STATIC ptable *indirect_map = NULL; - -STATIC const char *indirect_linestr = NULL; - STATIC void indirect_map_store(pTHX_ const OP *o, const char *src, SV *sv) { #define indirect_map_store(O, S, N) indirect_map_store(aTHX_ (O), (S), (N)) + dMY_CXT; SV *val; /* When lex_inwhat is set, we're in a quotelike environment (qq, qr, but not q) @@ -262,9 +281,9 @@ STATIC void indirect_map_store(pTHX_ const OP *o, const char *src, SV *sv) { if (!PL_lex_inwhat) { const char *pl_linestr = SvPVX_const(PL_linestr); - if (indirect_linestr != pl_linestr) { - ptable_map_clear(indirect_map); - indirect_linestr = pl_linestr; + if (MY_CXT.linestr != pl_linestr) { + ptable_clear(MY_CXT.map); + MY_CXT.linestr = pl_linestr; } } @@ -274,17 +293,18 @@ STATIC void indirect_map_store(pTHX_ const OP *o, const char *src, SV *sv) { SvIOK_on(val); SvIsUV_on(val); - ptable_map_store(indirect_map, o, val); + ptable_store(MY_CXT.map, o, val); } STATIC const char *indirect_map_fetch(pTHX_ const OP *o, SV ** const name) { #define indirect_map_fetch(O, S) indirect_map_fetch(aTHX_ (O), (S)) + dMY_CXT; SV *val; - if (indirect_linestr != SvPVX_const(PL_linestr)) + if (MY_CXT.linestr != SvPVX_const(PL_linestr)) return NULL; - val = ptable_fetch(indirect_map, o); + val = ptable_fetch(MY_CXT.map, o); if (!val) { *name = NULL; return NULL; @@ -529,14 +549,15 @@ BOOT: { if (!indirect_initialized++) { HV *stash; -#if I_THREADSAFE + MY_CXT_INIT; - MY_CXT.tbl = ptable_new(); - MY_CXT.owner = aTHX; + MY_CXT.map = ptable_new(); + MY_CXT.linestr = NULL; +#if I_THREADSAFE + MY_CXT.tbl = ptable_new(); + MY_CXT.owner = aTHX; #endif - indirect_map = ptable_new(); - PERL_HASH(indirect_hash, __PACKAGE__, __PACKAGE_LEN__); indirect_old_ck_const = PL_check[OP_CONST]; @@ -569,12 +590,14 @@ CODE: dMY_CXT; ud.tbl = t = ptable_new(); ud.owner = MY_CXT.owner; - ptable_walk(MY_CXT.tbl, indirect_ptable_hints_clone, &ud); + ptable_walk(MY_CXT.tbl, indirect_ptable_clone, &ud); } { MY_CXT_CLONE; - MY_CXT.tbl = t; - MY_CXT.owner = aTHX; + MY_CXT.map = ptable_new(); + MY_CXT.linestr = NULL; + MY_CXT.tbl = t; + MY_CXT.owner = aTHX; } { level = PerlMemShared_malloc(sizeof *level); diff --git a/t/40-threads.t b/t/40-threads.t new file mode 100644 index 0000000..14fb8b2 --- /dev/null +++ b/t/40-threads.t @@ -0,0 +1,78 @@ +#!perl -T + +use strict; +use warnings; + +use Config qw/%Config/; + +BEGIN { + if (!$Config{useithreads}) { + require Test::More; + Test::More->import; + plan(skip_all => 'This perl wasn\'t built to support threads'); + } +} + +use threads; + +use Test::More; + +BEGIN { + require indirect; + if (indirect::I_THREADSAFE()) { + plan tests => 10 * 2 * (2 + 3); + defined and diag "Using threads $_" for $threads::VERSION; + } else { + plan skip_all => 'This indirect isn\'t thread safe'; + } +} + +sub expect { + my ($pkg) = @_; + return qr/^Indirect\s+call\s+of\s+method\s+"new"\s+on\s+object\s+"$pkg"/; +} + +{ + no indirect; + + sub try { + my $tid = threads->tid(); + + for (1 .. 2) { + { + my $class = "Coconut$tid"; + my @warns; + { + local $SIG{__WARN__} = sub { push @warns, "@_" }; + eval 'die "the code compiled but it shouldn\'t have\n"; + no indirect ":fatal"; my $x = new ' . $class . ' 1, 2;'; + } + like $@ || '', expect($class), + "\"no indirect\" in eval in thread $tid died as expected"; + is_deeply \@warns, [ ], + "\"no indirect\" in eval in thread $tid didn't warn"; + } + +SKIP: + { + skip 'Hints aren\'t propagated into eval STRING below perl 5.10' => 3 + unless $] >= 5.010; + my $class = "Pineapple$tid"; + my @warns; + { + local $SIG{__WARN__} = sub { push @warns, "@_" }; + eval 'die "ok\n"; my $y = new ' . $class . ' 1, 2;'; + } + is $@, "ok\n", + my $first = shift @warns; + like $first || '', expect($class), + "\"no indirect\" propagated into eval in thread $tid warned once"; + is_deeply \@warns, [ ], + "\"no indirect\" propagated into eval in thread $tid warned just once"; + } + } + } +} + +my @t = map threads->create(\&try), 1 .. 10; +$_->join for @t;