From: Vincent Pit <vince@profvince.com>
Date: Wed, 26 Oct 2011 13:37:55 +0000 (+0200)
Subject: Share the vtables with threaded perls
X-Git-Tag: v0.47~14
X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FVariable-Magic.git;a=commitdiff_plain;h=75e0226fc114601c5e10d253d55e94e201249151

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 4ac45e7..3fb9739 100644
--- 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 0e47d36..1bfe6b5 100644
--- 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;
+}