From: Vincent Pit <vince@profvince.com>
Date: Mon, 16 Feb 2009 18:26:17 +0000 (+0100)
Subject: Make op_info thread safe
X-Git-Tag: v0.31~10
X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FVariable-Magic.git;a=commitdiff_plain;h=ed45fb4404201c2e17ffa5c26a2320ceeb132e61

Make op_info thread safe
---

diff --git a/Magic.xs b/Magic.xs
index d9eab57..f034a28 100644
--- a/Magic.xs
+++ b/Magic.xs
@@ -203,7 +203,10 @@ STATIC void vmg_sv_magicuvar(pTHX_ SV *sv, const char *uf, I32 len) {
 
 #define MY_CXT_KEY __PACKAGE__ "::_guts" XS_VERSION
 
-typedef HV * my_cxt_t;
+typedef struct {
+ HV *wizards;
+ HV *b__op_stash;
+} my_cxt_t;
 
 START_MY_CXT
 
@@ -224,7 +227,7 @@ STATIC U16 vmg_gensig(pTHX) {
 
  do {
   sig = SIG_NBR * Drand01() + SIG_MIN;
- } while (hv_exists(MY_CXT, buf, sprintf(buf, "%u", sig)));
+ } while (hv_exists(MY_CXT.wizards, buf, sprintf(buf, "%u", sig)));
 
  return sig;
 }
@@ -498,45 +501,28 @@ STATIC UV vmg_dispell(pTHX_ SV *sv, U16 sig) {
 #define VMG_OP_INFO_NAME   1
 #define VMG_OP_INFO_OBJECT 2
 
-STATIC U32     vmg_op_name_refcnt = 0;
-STATIC STRLEN *vmg_op_name_len    = NULL;
-
-STATIC HV *vmg_b__op_stash = NULL;
+STATIC U32           vmg_op_name_init      = 0;
+STATIC unsigned char vmg_op_name_len[MAXO] = { 0 };
 
 STATIC void vmg_op_info_init(pTHX_ unsigned int opinfo) {
 #define vmg_op_info_init(W) vmg_op_info_init(aTHX_ (W))
  switch (opinfo) {
   case VMG_OP_INFO_NAME:
-   if (!vmg_op_name_len) {
+   if (!vmg_op_name_init) {
     OPCODE t;
-    Newx(vmg_op_name_len, MAXO, STRLEN);
     for (t = 0; t < OP_max; ++t)
      vmg_op_name_len[t] = strlen(PL_op_name[t]);
+    vmg_op_name_init = 1;
    }
-   ++vmg_op_name_refcnt;
    break;
-  case VMG_OP_INFO_OBJECT:
-   if (!vmg_b__op_stash) {
+  case VMG_OP_INFO_OBJECT: {
+   dMY_CXT;
+   if (!MY_CXT.b__op_stash) {
     require_pv("B.pm");
-    vmg_b__op_stash = gv_stashpv("B::OP", 1);
+    MY_CXT.b__op_stash = gv_stashpv("B::OP", 1);
    }
    break;
-  default:
-   break;
- }
-}
-
-STATIC void vmg_op_info_deinit(unsigned int opinfo) {
- switch (opinfo) {
-  case VMG_OP_INFO_NAME:
-   if (vmg_op_name_refcnt > 0)
-    --vmg_op_name_refcnt;
-   if (!vmg_op_name_refcnt && vmg_op_name_len) {
-    Safefree(vmg_op_name_len);
-    vmg_op_name_len = NULL;
-   }
-   break;
-  case VMG_OP_INFO_OBJECT:
+  }
   default:
    break;
  }
@@ -552,9 +538,11 @@ STATIC SV *vmg_op_info(pTHX_ unsigned int opinfo) {
    OPCODE t = PL_op->op_type;
    return sv_2mortal(newSVpvn(PL_op_name[t], vmg_op_name_len[t]));
   }
-  case VMG_OP_INFO_OBJECT:
+  case VMG_OP_INFO_OBJECT: {
+   dMY_CXT;
    return sv_bless(sv_2mortal(newRV_noinc(newSViv(PTR2IV(PL_op)))),
-                              vmg_b__op_stash);
+                              MY_CXT.b__op_stash);
+  }
   default:
    break;
  }
@@ -867,7 +855,7 @@ STATIC int vmg_wizard_free(pTHX_ SV *wiz, MAGIC *mg) {
 
  {
   dMY_CXT;
-  if (hv_delete(MY_CXT, buf, sprintf(buf, "%u", w->sig), 0) != wiz)
+  if (hv_delete(MY_CXT.wizards, buf, sprintf(buf, "%u", w->sig), 0) != wiz)
    return 0;
  }
  SvFLAGS(wiz) |= SVf_BREAK;
@@ -895,9 +883,6 @@ STATIC int vmg_wizard_free(pTHX_ SV *wiz, MAGIC *mg) {
  if (w->cb_delete != NULL) { SvREFCNT_dec(SvRV(w->cb_delete)); }
 #endif /* VMG_UVAR */
 
- if (w->opinfo)
-  vmg_op_info_deinit(w->opinfo);
-
  Safefree(w->vtbl);
  Safefree(w);
 
@@ -962,7 +947,7 @@ STATIC U16 vmg_wizard_sig(pTHX_ SV *wiz) {
 
  {
   dMY_CXT;
-  if (!hv_fetch(MY_CXT, buf, sprintf(buf, "%u", sig), 0))
+  if (!hv_fetch(MY_CXT.wizards, buf, sprintf(buf, "%u", sig), 0))
    sig = 0;
  }
  return sig;
@@ -989,7 +974,7 @@ STATIC SV *vmg_wizard_wiz(pTHX_ SV *wiz) {
 
  {
   dMY_CXT;
-  return (old = hv_fetch(MY_CXT, buf, sprintf(buf, "%u", sig), 0))
+  return (old = hv_fetch(MY_CXT.wizards, buf, sprintf(buf, "%u", sig), 0))
           ? *old : NULL;
  }
 }
@@ -1066,8 +1051,9 @@ BOOT:
 {
  HV *stash;
  MY_CXT_INIT;
- MY_CXT = newHV();
- hv_iterinit(MY_CXT); /* Allocate iterator */
+ MY_CXT.wizards = newHV();
+ hv_iterinit(MY_CXT.wizards); /* Allocate iterator */
+ MY_CXT.b__op_stash = NULL;
  stash = gv_stashpv(__PACKAGE__, 1);
  newCONSTSUB(stash, "SIG_MIN",   newSVuv(SIG_MIN));
  newCONSTSUB(stash, "SIG_MAX",   newSVuv(SIG_MAX));
@@ -1097,14 +1083,15 @@ CLONE(...)
 PROTOTYPE: DISABLE
 PREINIT:
  HV *hv;
+ U32 had_b__op_stash = 0;
 CODE:
  {
   HE *key;
   dMY_CXT;
   hv = newHV();
   hv_iterinit(hv); /* Allocate iterator */
-  hv_iterinit(MY_CXT);
-  while ((key = hv_iternext(MY_CXT))) {
+  hv_iterinit(MY_CXT.wizards);
+  while ((key = hv_iternext(MY_CXT.wizards))) {
    STRLEN len;
    char *sig = HePV(key, len);
    SV *sv;
@@ -1118,10 +1105,13 @@ CODE:
    SvREADONLY_on(sv);
    if (!hv_store(hv, sig, len, sv, HeHASH(key))) croak("%s during CLONE", vmg_globstorefail);
   }
+  if (MY_CXT.b__op_stash)
+   had_b__op_stash = 1;
  }
  {
   MY_CXT_CLONE;
-  MY_CXT = hv;
+  MY_CXT.wizards     = hv;
+  MY_CXT.b__op_stash = had_b__op_stash ? gv_stashpv("B::OP", 1) : NULL;
  }
 
 #endif /* VMG_THREADSAFE */
@@ -1160,12 +1150,12 @@ CODE:
  if (SvOK(svsig)) {
   SV **old;
   sig = vmg_sv2sig(svsig);
-  if ((old = hv_fetch(MY_CXT, buf, sprintf(buf, "%u", sig), 0))) {
+  if ((old = hv_fetch(MY_CXT.wizards, buf, sprintf(buf, "%u", sig), 0))) {
    ST(0) = sv_2mortal(newRV_inc(*old));
    XSRETURN(1);
   }
  } else {
-  if (HvKEYS(MY_CXT) >= SIG_NBR) { croak(vmg_toomanysigs); }
+  if (HvKEYS(MY_CXT.wizards) >= SIG_NBR) { croak(vmg_toomanysigs); }
   sig = vmg_gensig();
  }
  
@@ -1216,7 +1206,7 @@ CODE:
  mg->mg_private = SIG_WIZ;
  SvREADONLY_on(sv);
 
- if (!hv_store(MY_CXT, buf, sprintf(buf, "%u", sig), sv, 0)) croak(vmg_globstorefail);
+ if (!hv_store(MY_CXT.wizards, buf, sprintf(buf, "%u", sig), sv, 0)) croak(vmg_globstorefail);
 
  RETVAL = newRV_noinc(sv);
 OUTPUT:
@@ -1226,7 +1216,7 @@ SV *gensig()
 PROTOTYPE:
 CODE:
  dMY_CXT;
- if (HvKEYS(MY_CXT) >= SIG_NBR) { croak(vmg_toomanysigs); }
+ if (HvKEYS(MY_CXT.wizards) >= SIG_NBR) { croak(vmg_toomanysigs); }
  RETVAL = newSVuv(vmg_gensig());
 OUTPUT:
  RETVAL
diff --git a/t/40-threads.t b/t/40-threads.t
index 2482e61..7c6203d 100644
--- a/t/40-threads.t
+++ b/t/40-threads.t
@@ -18,10 +18,10 @@ use threads::shared;
 
 use Test::More;
 
-use Variable::Magic qw/wizard cast dispell getdata VMG_THREADSAFE/;
+use Variable::Magic qw/wizard cast dispell getdata VMG_THREADSAFE VMG_OP_INFO_NAME VMG_OP_INFO_OBJECT/;
 
 if (VMG_THREADSAFE) {
- plan tests => 2 * (2 * 16 + 1) + 2 * (2 * 11 + 1);
+ plan tests => 2 * (4 * 18 + 1) + 2 * (4 * 13 + 1);
  my $v = $threads::VERSION;
  diag "Using threads $v" if defined $v;
  $v = $threads::shared::VERSION;
@@ -34,14 +34,21 @@ my $destroyed : shared = 0;
 my $sig = undef;
 
 sub try {
- my ($dispell) = @_;
+ my ($dispell, $op_info) = @_;
  my $tid = threads->tid();
  my $c   = 0;
  my $wiz = eval {
-  wizard get  => sub { ++$c },
-         data => sub { $_[1] + $tid },
-         free => sub { ++$destroyed },
-         sig  => $sig;
+  wizard data    => sub { $_[1] + $tid },
+         sig     => $sig,
+         get     => sub { ++$c; 0 },
+         set     => sub {
+                     my $name = $_[-1];
+                     $name = $name->name if $op_info == VMG_OP_INFO_OBJECT;
+                     is $name, 'sassign', "opname for op_info $op_info in thread $tid is correct";
+                     0
+                    },
+         free    => sub { ++$destroyed; 0 },
+         op_info => $op_info
  };
  is($@,     '',    "wizard in thread $tid doesn't croak");
  isnt($wiz, undef, "wizard in thread $tid is defined");
@@ -59,6 +66,8 @@ sub try {
  is($@, '',       "getdata in thread $tid doesn't croak");
  is($d, 5 + $tid, "getdata in thread $tid returns the right thing");
  is($c, 1,        "getdata in thread $tid doesn't trigger magic");
+ eval { $a = 9 };
+ is($@, '', "set in thread $tid (check opname) doesn't croak");
  if ($dispell) {
   $res = eval { dispell $a, $wiz };
   is($@, '', "dispell in thread $tid doesn't croak");
@@ -66,28 +75,18 @@ sub try {
   undef $b;
   eval { $b = $a };
   is($@, '', "get in thread $tid after dispell doesn't croak");
-  is($b, 3,  "get in thread $tid after dispell returns the right thing");
+  is($b, 9,  "get in thread $tid after dispell returns the right thing");
   is($c, 1,  "get in thread $tid after dispell doesn't trigger magic");
  }
  return; # Ugly if not here
 }
 
 for my $dispell (1, 0) {
- $destroyed = 0;
- $sig = undef;
-
- my @t = map { threads->create(\&try, $dispell) } 1 .. 2;
- $t[0]->join;
- $t[1]->join;
-
- is($destroyed, (1 - $dispell) * 2, 'destructors');
-
- $destroyed = 0;
- $sig = Variable::Magic::gensig();
-
- @t = map { threads->create(\&try, $dispell) } 1 .. 2;
- $t[0]->join;
- $t[1]->join;
-
- is($destroyed, (1 - $dispell) * 2, 'destructors');
+ for my $sig (undef, Variable::Magic::gensig()) {
+  $destroyed = 0;
+  my @t = map { threads->create(\&try, $dispell, $_) }
+                               (VMG_OP_INFO_NAME) x 2, (VMG_OP_INFO_OBJECT) x 2;
+  $_->join for @t;
+  is($destroyed, (1 - $dispell) * 4, 'destructors');
+ }
 }
diff --git a/t/41-clone.t b/t/41-clone.t
index c3c4822..90f15e0 100644
--- a/t/41-clone.t
+++ b/t/41-clone.t
@@ -18,10 +18,10 @@ use threads::shared;
 
 use Test::More;
 
-use Variable::Magic qw/wizard cast dispell getdata getsig VMG_THREADSAFE/;
+use Variable::Magic qw/wizard cast dispell getdata getsig VMG_THREADSAFE VMG_OP_INFO_NAME VMG_OP_INFO_OBJECT/;
 
 if (VMG_THREADSAFE) {
- plan tests => 3 + 2 * (2 * 8 + 2) + 2 * (2 * 5 + 2);
+ plan tests => 2 * 3 + 4 * (2 * 10 + 2) + 4 * (2 * 7 + 2);
  my $v = $threads::VERSION;
  diag "Using threads $v" if defined $v;
  $v = $threads::shared::VERSION;
@@ -32,19 +32,32 @@ if (VMG_THREADSAFE) {
 
 my $destroyed : shared = 0;
 my $c         : shared = 0;
-my $wiz = eval {
- wizard get  => sub { ++$c },
-        data => sub { $_[1] + threads->tid() },
-        free => sub { ++$destroyed }
-};
-is($@,     '',    "wizard in main thread doesn't croak");
-isnt($wiz, undef, "wizard in main thread is defined");
-is($c,     0,     "wizard in main thread doesn't trigger magic");
 
-my $sig;
+sub spawn_wiz {
+ my ($op_info) = @_;
+
+ my $wiz = eval {
+  wizard data    => sub { $_[1] + threads->tid() },
+         get     => sub { ++$c; 0 },
+         set     => sub {
+                     my $name = $_[-1];
+                     $name = $name->name if $op_info == VMG_OP_INFO_OBJECT;
+                     my $tid = threads->tid();
+                     is $name, 'sassign', "opname for op_info $op_info in thread $tid is correct";
+                     0
+                    },
+         free    => sub { ++$destroyed; 0 },
+         op_info => $op_info
+ };
+ is($@,     '',    "wizard with op_info $op_info in main thread doesn't croak");
+ isnt($wiz, undef, "wizard with op_info $op_info in main thread is defined");
+ is($c,     0,     "wizard with op_info $op_info in main thread doesn't trigger magic");
+
+ return $wiz;
+}
 
 sub try {
- my ($dispell) = @_;
+ my ($dispell, $sig) = @_;
  my $tid = threads->tid();
  my $a   = 3;
  my $res = eval { cast $a, $sig, sub { 5 }->() };
@@ -56,37 +69,31 @@ sub try {
  my $d = eval { getdata $a, $sig };
  is($@, '',       "getdata in thread $tid doesn't croak");
  is($d, 5 + $tid, "getdata in thread $tid returns the right thing");
+ eval { $a = 9 };
+ is($@, '', "set in thread $tid (check opname) doesn't croak");
  if ($dispell) {
   $res = eval { dispell $a, $sig };
   is($@, '', "dispell in thread $tid doesn't croak");
   undef $b;
   eval { $b = $a };
   is($@, '', "get in thread $tid after dispell doesn't croak");
-  is($b, 3,  "get in thread $tid after dispell returns the right thing");
+  is($b, 9,  "get in thread $tid after dispell returns the right thing");
  }
  return; # Ugly if not here
 }
 
-for my $dispell (1, 0) {
- $c = 0;
- $destroyed = 0;
- $sig = $wiz;
-
- my @t = map { threads->create(\&try, $dispell) } 1 .. 2;
- $t[0]->join;
- $t[1]->join;
+my $wiz_name = spawn_wiz VMG_OP_INFO_NAME;
+my $wiz_obj  = spawn_wiz VMG_OP_INFO_OBJECT;
 
- is($c, 2, "get triggered twice");
- is($destroyed, (1 - $dispell) * 2, 'destructors');
-
- $c = 0;
- $destroyed = 0;
- $sig = getsig $wiz;
+for my $dispell (1, 0) {
+ for my $sig ($wiz_name, getsig($wiz_name), $wiz_obj, getsig($wiz_obj)) {
+  $c = 0;
+  $destroyed = 0;
 
- @t = map { threads->create(\&try, $dispell) } 1 .. 2;
- $t[0]->join;
- $t[1]->join;
+  my @t = map { threads->create(\&try, $dispell, $sig) } 1 .. 2;
+  $_->join for @t;
 
- is($c, 2, "get triggered twice");
- is($destroyed, (1 - $dispell) * 2, 'destructors');
+  is($c, 2, "get triggered twice");
+  is($destroyed, (1 - $dispell) * 2, 'destructors');
+ }
 }