Make the op map thread safe

diff --git a/MANIFEST b/MANIFEST
index 634e126279e67f30b7ac9e691b9d34295f09d43c..695b66c9ec62b8a8c469733e1b5f872d5c428c83 100644 (file)
--- 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 b19e11a929114d600a0fccb89489799975424e53..6203d97a4d74679471f6e733771c711aa63c5c2c 100644 (file)
--- 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 (file)
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;