Share the vtables with threaded perls

When a magical variable is cloned into a new thread, the associated vtables
aren't cloned by mg_dup(), but simply shared. This means that if a wizard
is casted upon a variable in the main interpreter, then a thread is created,
then the wizard is destroyed, and then the cloned variant of the magical
variable is manipulated, perl can no longer access the vtable (it was freed
when the wizard was destroyed) and memory misreads happen.

To solve this, the only solution is to make the vtables associated with
wizards shared and reference-counted.

diff --git a/Magic.xs b/Magic.xs
index 4ac45e73ec12e7de3d11e359d26b38742c2fc2a9..3fb9739614332542a19485443cc7d737c4a6fa50 100644 (file)
--- a/Magic.xs
+++ b/Magic.xs
@@ -431,10 +431,79 @@ STATIC const char vmg_argstorefailed[] = "Error while storing arguments";
 #define SIG_WZO ((U16) (0x3891))
 #define SIG_WIZ ((U16) (0x3892))
 
-/* --- MGWIZ structure ----------------------------------------------------- */
+/* --- <vmg_vtable> structure ---------------------------------------------- */
+
+#if VMG_THREADSAFE
 
 typedef struct {
  MGVTBL *vtbl;
+ U32     refcount;
+} vmg_vtable;
+
+STATIC vmg_vtable *vmg_vtable_alloc(pTHX) {
+#define vmg_vtable_alloc() vmg_vtable_alloc(aTHX)
+ vmg_vtable *t;
+
+ t = VOID2(vmg_vtable *, PerlMemShared_malloc(sizeof *t));
+
+ t->vtbl     = VOID2(MGVTBL *, PerlMemShared_malloc(sizeof *t->vtbl));
+ t->refcount = 1;
+
+ return t;
+}
+
+#define vmg_vtable_vtbl(T) (T)->vtbl
+
+#if VMG_THREADSAFE
+STATIC perl_mutex vmg_vtable_refcount_mutex;
+#endif
+
+STATIC vmg_vtable *vmg_vtable_dup(pTHX_ vmg_vtable *t) {
+#define vmg_vtable_dup(T) vmg_vtable_dup(aTHX_ (T))
+ VMG_LOCK(&vmg_vtable_refcount_mutex);
+ ++t->refcount;
+ VMG_UNLOCK(&vmg_vtable_refcount_mutex);
+
+ return t;
+}
+
+STATIC void vmg_vtable_free(pTHX_ vmg_vtable *t) {
+#define vmg_vtable_free(T) vmg_vtable_free(aTHX_ (T))
+ U32 refcount;
+
+ VMG_LOCK(&vmg_vtable_refcount_mutex);
+ refcount = --t->refcount;
+ VMG_UNLOCK(&vmg_vtable_refcount_mutex);
+
+ if (!refcount) {
+  PerlMemShared_free(t->vtbl);
+  PerlMemShared_free(t);
+ }
+}
+
+#else /* VMG_THREADSAFE */
+
+typedef MGVTBL vmg_vtable;
+
+STATIC vmg_vtable *vmg_vtable_alloc(pTHX) {
+#define vmg_vtable_alloc() vmg_vtable_alloc(aTHX)
+ vmg_vtable *t;
+
+ Newx(t, 1, vmg_vtable);
+
+ return t;
+}
+
+#define vmg_vtable_vtbl(T) ((MGVTBL *) (T))
+
+#define vmg_vtable_free(T) Safefree(T)
+
+#endif /* !VMG_THREADSAFE */
+
+/* --- MGWIZ structure ----------------------------------------------------- */
+
+typedef struct {
+ vmg_vtable *vtable;
 
  U8 opinfo;
  U8 uvar;
@@ -469,8 +538,7 @@ STATIC MGWIZ *vmg_mgwiz_alloc(pTHX_ UV opinfo) {
  if (w->opinfo)
   vmg_op_info_init(aTHX_ w->opinfo);
 
- Newx(t, 1, MGVTBL);
- w->vtbl = t;
+ w->vtable = vmg_vtable_alloc();
 
  return w;
 }
@@ -509,7 +577,7 @@ STATIC void vmg_mgwiz_free(pTHX_ MGWIZ *w) {
  SvREFCNT_dec(w->cb_delete);
 #endif /* VMG_UVAR */
 
- Safefree(w->vtbl);
+ vmg_vtable_free(w->vtable);
  Safefree(w);
 
  return;
@@ -523,18 +591,14 @@ STATIC void vmg_mgwiz_free(pTHX_ MGWIZ *w) {
 
 STATIC MGWIZ *vmg_mgwiz_clone(pTHX_ const MGWIZ *w) {
 #define vmg_mgwiz_clone(W) vmg_mgwiz_clone(aTHX_ (W))
- MGVTBL *t;
  MGWIZ *z;
 
  if (!w)
   return NULL;
 
- Newx(t, 1, MGVTBL);
- Copy(w->vtbl, t, 1, MGVTBL);
-
  Newx(z, 1, MGWIZ);
 
- z->vtbl   = t;
+ z->vtable = vmg_vtable_dup(w->vtable);
  z->uvar   = w->uvar;
  z->opinfo = w->opinfo;
 
@@ -799,7 +863,7 @@ STATIC UV vmg_cast(pTHX_ SV *sv, const SV *wiz, SV **args, I32 items) {
 
  data = (w->cb_data) ? vmg_data_new(w->cb_data, sv, args, items) : NULL;
  /* sv_magicext() calls mg_magical and increments data's refcount */
- mg   = sv_magicext(sv, data, PERL_MAGIC_ext, w->vtbl,
+ mg   = sv_magicext(sv, data, PERL_MAGIC_ext, vmg_vtable_vtbl(w->vtable),
                               (const char *) wiz, HEf_SVKEY);
  SvREFCNT_dec(data);
  mg->mg_private = SIG_WIZ;
@@ -1375,6 +1439,7 @@ BOOT:
 #endif
  MY_CXT.b__op_stashes[0] = NULL;
 #if VMG_THREADSAFE
+ MUTEX_INIT(&vmg_vtable_refcount_mutex);
  MUTEX_INIT(&vmg_op_name_init_mutex);
  call_atexit(vmg_cleanup, NULL);
 #endif
@@ -1459,7 +1524,7 @@ CODE:
 
  op_info = ST(i++);
  w = vmg_mgwiz_alloc(SvOK(op_info) ? SvUV(op_info) : 0);
- t = w->vtbl;
+ t = vmg_vtable_vtbl(w->vtable);
 
  VMG_SET_CB(ST(i++), data);
 

diff --git a/t/41-clone.t b/t/41-clone.t
index 0e47d3694819bc8c37a75cdfb411854dd7ab4aa6..1bfe6b5b3f5f53add4816fbf4aae2a131e6b936e 100644 (file)
--- a/t/41-clone.t
+++ b/t/41-clone.t
@@ -97,3 +97,45 @@ for my $dispell (1, 0) {
   }
  }
 }
+
+{
+ my @threads;
+ my $flag : shared = 0;
+ my $destroyed;
+
+ {
+  my $wiz = wizard(
+   set => sub {
+    my $tid = threads->tid;
+    pass "set callback called in thread $tid"
+   },
+   free => sub { ++$destroyed },
+  );
+
+  my $var = 123;
+  cast $var, $wiz;
+
+  @threads = map spawn(
+   sub {
+    my $tid = threads->tid;
+    my $exp = 456 + $tid;
+    {
+     lock $flag;
+     threads::shared::cond_wait($flag) until $flag;
+    }
+    $var = $exp;
+    is $var, $exp, "\$var could be assigned to in thread $tid";
+   }
+  ), 1 .. 5;
+ }
+
+ is $destroyed, 1, 'wizard is destroyed';
+
+ {
+  lock $flag;
+  $flag = 1;
+  threads::shared::cond_broadcast($flag);
+ }
+
+ $_->join for @threads;
+}