perl-dev mailing list archives

Site index · List index
Message view « Date » · « Thread »
Top « Date » · « Thread »
From Stas Bekman <s...@stason.org>
Subject Re: [mp2] Our API is not perl thread-safe
Date Tue, 19 Apr 2005 23:30:04 GMT
I'm abandoning the work on trying to get CLONE to work, as it was an 
overkill and was still full of segfaults. Luckily the new CLONE_SKIP 
solution added in perl@24247 should solve most of the current problems 
with ithreads under mod_perl2.

In any case, should we wish to continue to try to make CLONE work to 
support older perls, here is the code and tests I've written so far.

[inlined and attached for the archives]

Index: src/modules/perl/modperl_common_util.c
===================================================================
--- src/modules/perl/modperl_common_util.c	(revision 161975)
+++ src/modules/perl/modperl_common_util.c	(working copy)
@@ -64,8 +64,9 @@
      SV *hv = (SV*)newHV();
      SV *rsv = sv_newmortal();

-    sv_setref_pv(rsv, classname, p);
-
+    SV *rv = sv_setref_pv(rsv, classname, p);
+    MP_CLONE_INSERT_OBJ("APR::Table", rv);
+
      /* Prefetch magic requires perl 5.8 */
  #if ((PERL_REVISION == 5) && (PERL_VERSION >= 8))

Index: src/modules/perl/modperl_common_util.h
===================================================================
--- src/modules/perl/modperl_common_util.h	(revision 161975)
+++ src/modules/perl/modperl_common_util.h	(working copy)
@@ -97,5 +97,128 @@

  SV *modperl_perl_gensym(pTHX_ char *pack);

+/*** ithreads enabled perl CLONE support ***/
+#define MP_CLONE_DEBUG 1
+
+#define MP_CLONE_HASH_NAME "::CLONE_objects"
+#define MP_CLONE_HASH_NAME1 "CLONE_objects"
+#define MP_CLONE_HASH_LEN1 13
+
+/* some classes like APR::Table get the key in a different way and
+ * therefore should redefine this define */
+#define MP_CLONE_KEY_COMMON(obj) SvIVX(SvRV(obj))
+
+#define MP_CLONE_GET_HV(namespace)                                      \
+    get_hv(Perl_form(aTHX_ "%s::%s", namespace, MP_CLONE_HASH_NAME), TRUE);
+
+#if MP_CLONE_DEBUG
+
+#define MP_CLONE_DEBUG_INSERT_KEY(namespace, obj)                       \
+    Perl_warn(aTHX_ "%s %p: insert %s, %p => %p",                       \
+              namespace, aTHX_ SvPV_nolen(sv_key), obj, SvRV(obj));
+
+#define MP_CLONE_DEBUG_HOLLOW_KEY(namespace)                            \
+    Perl_warn(aTHX_ "%s %p: hollow %s", namespace,                      \
+              aTHX_ SvPVX(hv_iterkeysv(he)));
+
+#define MP_CLONE_DEBUG_DELETE_KEY(namespace)                            \
+    Perl_warn(aTHX_ "%s %p: delete %s", namespace, aTHX_ SvPVX(sv_key));
+
+#define MP_CLONE_DEBUG_CLONE(namespace)                                 \
+    Perl_warn(aTHX_ "%s %p: CLONE called", namespace, aTHX);
+
+#define MP_CLONE_DUMP_OBJECTS_HASH(namespace)                           \
+    {                                                                   \
+        HE *he;                                                         \
+        HV *hv = MP_CLONE_GET_HV(namespace);                            \
+        Perl_warn(aTHX_ "%s %p: DUMP", namespace, aTHX);                \
+        hv_iterinit(hv);                                                \
+        while ((he = hv_iternext(hv))) {                                \
+            SV *key = hv_iterkeysv(he);                                 \
+            SV *val = hv_iterval(hv, he);                               \
+            Perl_warn(aTHX_ "\t%s => %p => %p\n", SvPVX(key),           \
+                      val, SvRV(val));                                  \
+        }                                                               \
+    }
+
+#else /* if MP_CLONE_DEBUG */
+
+#define MP_CLONE_DEBUG_INSERT_KEY(namespace, obj)
+#define MP_CLONE_DEBUG_HOLLOW_KEY(namespace)
+#define MP_CLONE_DEBUG_DELETE_KEY(namespace)
+#define MP_CLONE_DEBUG_CLONE(namespace)
+#define MP_CLONE_DUMP_OBJECTS_HASH(namespace)
+
+#endif /* if MP_CLONE_DEBUG */
+
+#ifdef SvWEAKREF
+#define WEAKEN(sv) sv_rvweaken(sv)
+#else
+#error "weak references are not implemented in this release of perl");
+#endif
+
+#define MP_CLONE_INSERT_OBJ(namespace, obj)                             \
+    {                                                                   \
+        SV *weak_rv, *sv_key;                                           \
+        /* $objects{"$$self"} = $self;                                  \
+           Scalar::Util::weaken($objects{"$$self"})                     \
+        */                                                              \
+        HV *hv = MP_CLONE_GET_HV(namespace);                            \
+/* use the real object pointer as a unique key */                       \
+        sv_key = newSVpvf("%p", MP_CLONE_KEY_COMMON((obj)));            \
+        MP_CLONE_DEBUG_INSERT_KEY("a", (obj));                  \
+        weak_rv = newRV(SvRV((obj)));                                   \
+        WEAKEN(weak_rv); /* à la Scalar::Util::weaken */                 \
+        {                                                               \
+            HE *ok = hv_store_ent(hv, sv_key, weak_rv, FALSE);          \
+            sv_free(sv_key);                                            \
+            if (ok == NULL) {                                           \
+                SvREFCNT_dec(weak_rv);                                  \
+                Perl_croak(aTHX_ "failed to insert into %%%s::%s",      \
+                           namespace, MP_CLONE_HASH_NAME);              \
+            }                                                           \
+            MP_CLONE_DUMP_OBJECTS_HASH(namespace);                      \
+        }                                                               \
+    }
+
+#define MP_CLONE_DO_CLONE(namespace, class)                             \
+    {                                                                   \
+        HE *he;                                                         \
+        HV *hv = MP_CLONE_GET_HV(namespace);                            \
+        MP_CLONE_DEBUG_CLONE(namespace);                                \
+        MP_CLONE_DUMP_OBJECTS_HASH(namespace);                          \
+        hv_iterinit(hv);                                                \
+        while ((he = hv_iternext(hv))) {                                \
+            SV *rv = hv_iterval(hv, he);                                \
+            SV *sv = SvRV(rv);                                          \
+            /* sv_dump(rv); */                                          \
+            MP_CLONE_DEBUG_HOLLOW_KEY(namespace);                       \
+            if (sv) {                                                   \
+                /* detach from the C struct and invalidate */           \
+                mg_free(sv); /* remove any magic */                     \
+                SvFLAGS(sv) = 0;  /* invalidate the sv */               \
+                /*  sv_free(sv); */                                     \
+            }                                                           \
+            /* sv_dump(sv); */                                          \
+            /* sv_dump(rv); */                                          \
+            SV *sv_key = hv_iterkeysv(he);                              \
+            hv_delete_ent(hv, sv_key, G_DISCARD, FALSE);                \
+        }                                                               \
+        MP_CLONE_DUMP_OBJECTS_HASH(namespace);                          \
+        class = class; /* unused */                                     \
+    }
+
+/* obj: SvRV'd object */
+#define MP_CLONE_DELETE_OBJ(namespace, obj)                             \
+    {                                                                   \
+        HV *hv = MP_CLONE_GET_HV(namespace);                            \
+        SV *sv_key = newSVpvf("%p", MP_CLONE_KEY_COMMON(obj));          \
+        /* delete $CLONE_objects{"$$self"}; */                          \
+        MP_CLONE_DEBUG_DELETE_KEY(namespace);                           \
+        hv_delete_ent(hv, sv_key, G_DISCARD, FALSE);                    \
+        sv_free(sv_key);                                                \
+        MP_CLONE_DUMP_OBJECTS_HASH(namespace);                          \
+    }
+
  #endif /* MODPERL_COMMON_UTIL_H */

Index: src/modules/perl/modperl_util.c
===================================================================
--- src/modules/perl/modperl_util.c	(revision 161975)
+++ src/modules/perl/modperl_util.c	(working copy)
@@ -192,11 +192,15 @@
  MP_INLINE SV *modperl_ptr2obj(pTHX_ char *classname, void *ptr)
  {
      SV *sv = newSV(0);
-
+    SV *rv;
+
      MP_TRACE_h(MP_FUNC, "sv_setref_pv(%s, 0x%lx)\n",
                 classname, (unsigned long)ptr);
-    sv_setref_pv(sv, classname, ptr);
-
+    rv = sv_setref_pv(sv, classname, ptr);
+    if (ptr) {
+        MP_CLONE_INSERT_OBJ(classname, rv);
+    }
+
      return sv;
  }

Index: xs/typemap
===================================================================
--- xs/typemap	(revision 161975)
+++ xs/typemap	(working copy)
@@ -6,10 +6,20 @@
  ######################################################################
  OUTPUT
  T_POOLOBJ
-	sv_setref_pv($arg, \"${ntype}\", (void*)$var);
+        {
+            SV *rv = sv_setref_pv($arg, \"${ntype}\", (void*)$var);
+            if ($var) {
+                MP_CLONE_INSERT_OBJ("APR::Pool", rv);
+            }
+        }

  T_APACHEOBJ
-	sv_setref_pv($arg, \"${ntype}\", (void*)$var);
+        {
+            SV *rv = sv_setref_pv($arg, \"${ntype}\", (void*)$var);
+            if ($var) {
+                MP_CLONE_INSERT_OBJ("APR::Pool", rv);
+            }
+        }

  T_HASHOBJ
  	$arg = modperl_hash_tie(aTHX_ \"${ntype}\", $arg, $var);
Index: xs/maps/apr_functions.map
===================================================================
--- xs/maps/apr_functions.map	(revision 161975)
+++ xs/maps/apr_functions.map	(working copy)
@@ -174,6 +174,7 @@
  ~apr_pool_destroy
   DEFINE_destroy | mpxs_apr_pool_DESTROY | SV *:obj
   DEFINE_DESTROY | mpxs_apr_pool_DESTROY | SV *:obj
+ DEFINE_CLONE | | SV *:class
  >apr_pool_destroy_debug
   SV *:DEFINE_new | mpxs_apr_pool_create | SV *:parent_pool_obj
  -apr_pool_create_ex
@@ -246,6 +247,8 @@
   apr_proc_mutex_unlock

  MODULE=APR::Table
+ DEFINE_CLONE | | SV *:class
+ DEFINE_DESTROY | | SV *:obj
   apr_table_clear
  ~apr_table_copy
   mpxs_APR__Table_copy
Index: xs/APR/Table/APR__Table.h
===================================================================
--- xs/APR/Table/APR__Table.h	(revision 161975)
+++ xs/APR/Table/APR__Table.h	(working copy)
@@ -17,11 +17,17 @@
  #define mpxs_APR__Table_DELETE  apr_table_unset
  #define mpxs_APR__Table_CLEAR   apr_table_clear

+/* redefine the key method */
+#undef MP_CLONE_KEY_COMMON
+#define MP_CLONE_KEY_COMMON(obj)                        \
+    modperl_hash_tied_object(aTHX_ "APR::Table", obj)
+
  #define MPXS_DO_TABLE_N_MAGIC_RETURN(call)                              \
      apr_pool_t *p = mp_xs_sv2_APR__Pool(p_sv);                          \
      apr_table_t *t = call;                                              \
      SV *t_sv = modperl_hash_tie(aTHX_ "APR::Table", Nullsv, t);         \
      mpxs_add_pool_magic(t_sv, p_sv);                                    \
+    MP_CLONE_INSERT_OBJ("APR::Table", t_sv);                            \
      return t_sv;

  static MP_INLINE SV *mpxs_APR__Table_make(pTHX_ SV *p_sv, int nelts)
@@ -29,7 +35,6 @@
      MPXS_DO_TABLE_N_MAGIC_RETURN(apr_table_make(p, nelts));
  }

-
  static MP_INLINE SV *mpxs_APR__Table_copy(pTHX_ apr_table_t *base, SV *p_sv)
  {
      MPXS_DO_TABLE_N_MAGIC_RETURN(apr_table_copy(p, base));
@@ -192,7 +197,6 @@
      }
  }

-
  MP_STATIC XS(MPXS_apr_table_get)
  {
      dXSARGS;
@@ -231,3 +235,8 @@
      });

  }
+
+#define mpxs_APR__Table_CLONE(class) MP_CLONE_DO_CLONE("APR::Table", class)
+
+#define mpxs_APR__Table_DESTROY(obj) MP_CLONE_DELETE_OBJ("APR::Table", obj);
+
Index: xs/APR/Pool/APR__Pool.h
===================================================================
--- xs/APR/Pool/APR__Pool.h	(revision 161975)
+++ xs/APR/Pool/APR__Pool.h	(working copy)
@@ -23,20 +23,6 @@
  #endif
  } mpxs_pool_account_t;

-/* XXX: this implementation has a problem with perl ithreads. if a
- * custom pool is allocated, and then a thread is spawned we now have
- * two copies of the pool object, each living in a different perl
- * interpreter, both pointing to the same memory address of the apr
- * pool.
- *
- * need to write a CLONE class method could properly clone the
- * thread's copied object, but it's tricky:
- * - it needs to call parent_get() on the copied object and allocate a
- *   new pool from that parent's pool
- * - it needs to reinstall any registered cleanup callbacks (can we do
- *   that?) may be we can skip those?
- */
-
  #ifndef MP_SOURCE_SCAN
  #include "apr_optional.h"
  static
@@ -216,6 +202,8 @@
          if (parent_pool) {
              mpxs_add_pool_magic(rv, parent_pool_obj);
          }
+
+        MP_CLONE_INSERT_OBJ("APR::Pool", rv);

          return rv;
      }
@@ -351,7 +339,7 @@
      apr_pool_t *parent_pool = apr_pool_parent_get(child_pool);

      if (parent_pool) {
-        return SvREFCNT_inc(mp_xs_APR__Pool_2obj(parent_pool));
+        return SvREFCNT_inc(mp_xs_APR__Pool_2obj(aTHX_ parent_pool));
      }
      else {
          MP_POOL_TRACE(MP_FUNC, "pool (0x%lx) has no parents",
@@ -368,9 +356,20 @@
  {
      SV *sv = SvRV(obj);

+    MP_CLONE_DELETE_OBJ("APR::Pool", obj);
+
      if (MP_APR_POOL_SV_HAS_OWNERSHIP(sv)) {
+        //Perl_warn(aTHX_ "APR::Pool %p: DESTROY %p => %p", aTHX_ obj, sv);
          apr_pool_t *p = mpxs_sv_object_deref(obj, apr_pool_t);
          apr_pool_destroy(p);
+
      }
+
+    if (MP_APR_POOL_SV_HAS_OWNERSHIP(sv)) {
+        /* do *not* merge this with the next conditional */
+
+    }
+
  }

+#define mpxs_APR__Pool_CLONE(class) MP_CLONE_DO_CLONE("APR::Pool", class)
Index: xs/APR/Bucket/APR__Bucket.h
===================================================================
--- xs/APR/Bucket/APR__Bucket.h	(revision 161975)
+++ xs/APR/Bucket/APR__Bucket.h	(working copy)
@@ -78,6 +78,11 @@
      return APR_BUCKET_IS_EOS(bucket);
  }

+static MP_INLINE int mpxs_APR__Bucket_is_eoc(apr_bucket *bucket)
+{
+    return APR_BUCKET_IS_EOC(bucket);
+}
+
  static MP_INLINE int mpxs_APR__Bucket_is_flush(apr_bucket *bucket)
  {
      return APR_BUCKET_IS_FLUSH(bucket);
Index: t/apr-ext/t2.t
===================================================================
--- t/apr-ext/t2.t	(revision 0)
+++ t/apr-ext/t2.t	(revision 0)
@@ -0,0 +1,80 @@
+#!perl
+
+use strict;
+use warnings FATAL => 'all';
+
+use threads;
+use threads::shared;
+
+use Apache::Test '-withtestmore';
+
+use APR::Table ();
+use APR::Pool ();
+use Apache::TestUtil;
+
+use Config;
+use constant THREADS_OK => $] >= 5.008 && $Config{useithreads};
+
+use Devel::Peek;
+
+use CGI;
+
+#use TestAPRlib::table;
+#plan tests => TestAPRlib::table::num_of_tests();
+#TestAPRlib::table::test();
+
+my $pool = APR::Pool->new;
+my $t = APR::Table::make($pool, 10);
+#Dump $pool;
+use Devel::Leak;
+
+my $handle;
+
+#plan tests => 2*8;
+
+test_threads();
+#undef $pool;
+
+# perl-ithreads specific testing
+sub test_threads {
+
+    my $threads = 1;
+
+    return unless THREADS_OK;
+
+    t_debug "\n\n------------ start parent --------------------";
+    read_test();
+    t_debug "\n\n------------ end   parent --------------------";
+
+    t_debug "\n\n------------ start thread --------------------";
+    my $id = threads->new(\&read_test)->join();
+    t_debug "\n\n------------ end   thread --------------------";
+
+    t_debug "\n\n------------ start parent --------------------";
+    read_test();
+    t_debug "\n\n------------ end   parent --------------------";
+
+#Devel::Leak::NoteSV($handle);
+
+    #my $obj =  $id->join();
+    #Dump $obj;
+
+#Devel::Leak::CheckSV($handle);
+
+}
+
+sub read_test : locked {
+    my $tid = threads->self()->tid();
+    #t_debug "\n\n------------ start $tid --------------------";
+    #t_debug "tid: $tid";
+
+    #Dump $pool;
+    #$pool = APR::Pool->new;
+
+    # this is expected to fail, since $pool was invalidated!
+    $t = APR::Table::make($pool, 10);
+    #Dump $t;
+    #t_debug "\n-------------- end $tid   --------------------\n";
+
+    return undef;
+}

Property changes on: t/apr-ext/t2.t
___________________________________________________________________
Name: svn:eol-style
    + native

Index: t/apr-ext/t3.t
===================================================================
--- t/apr-ext/t3.t	(revision 0)
+++ t/apr-ext/t3.t	(revision 0)
@@ -0,0 +1,33 @@
+#!perl
+
+use strict;
+use warnings FATAL => 'all';
+
+use threads;
+use threads::shared;
+
+use APR::Pool ();
+
+use Devel::Leak;
+use Devel::Peek;
+
+my $handle;
+
+warn "start\n";
+my $id = threads->new(\&read_test);
+
+#Devel::Leak::NoteSV($handle);
+warn "before join\n";
+
+$id->join();
+warn "done\n";
+
+#Devel::Leak::CheckSV($handle);
+
+#Dump \%APR::Pool::CLONE_objects;
+
+sub read_test {
+    my $pool = APR::Pool->new;
+    return 1;
+}
+

Property changes on: t/apr-ext/t3.t
___________________________________________________________________
Name: svn:eol-style
    + native

Index: t/apr-ext/t4.t
===================================================================
--- t/apr-ext/t4.t	(revision 0)
+++ t/apr-ext/t4.t	(revision 0)
@@ -0,0 +1,28 @@
+#!perl
+
+use strict;
+use warnings FATAL => 'all';
+
+use threads;
+
+threads->new(\&read_test)->join;
+
+# this works correctly (only one destroy):
+#threads->new(\&read_test);
+#$_->join() for threads->list();
+
+sub read_test {
+    my $obj = Foo->new;
+    1;
+}
+
+package Foo;
+
+sub new {
+    warn "new was called\n";
+    bless {}, __PACKAGE__;
+}
+
+sub DESTROY {
+    warn "DESTROY called\n";
+}

Property changes on: t/apr-ext/t4.t
___________________________________________________________________
Name: svn:eol-style
    + native

Index: t/apr-ext/table.t
===================================================================
--- t/apr-ext/table.t	(revision 161975)
+++ t/apr-ext/table.t	(working copy)
@@ -2,6 +2,7 @@

  use strict;
  use warnings FATAL => 'all';
+use Test::More ();
  use Apache::Test;

  use TestAPRlib::table;
Index: t/apr-ext/p.t
===================================================================
--- t/apr-ext/p.t	(revision 0)
+++ t/apr-ext/p.t	(revision 0)
@@ -0,0 +1,30 @@
+#!perl -T
+
+use strict;
+use warnings FATAL => 'all';
+
+use Apache::Test;
+
+use threads;
+
+use APR::Pool ();
+
+use TestAPRlib::pool;
+
+use Config;
+use constant THREADS_OK => $] >= 5.008 && $Config{useithreads};
+die "perl w/ ithreads is required" unless THREADS_OK;
+
+plan tests => TestAPRlib::pool::num_of_tests() * 3;
+
+our $p = APR::Pool->new;
+my $threads = 2;
+
+run();
+threads->new(\&run) for 1..$threads;
+
+$_->join() for threads->list();
+
+sub run {
+    TestAPRlib::pool::test();
+}

Property changes on: t/apr-ext/p.t
___________________________________________________________________
Name: svn:eol-style
    + native

Index: t/apr-ext/t.t
===================================================================
--- t/apr-ext/t.t	(revision 0)
+++ t/apr-ext/t.t	(revision 0)
@@ -0,0 +1,59 @@
+#!perl
+
+use strict;
+use warnings FATAL => 'all';
+
+use threads;
+use threads::shared;
+
+use Apache::Test '-withtestmore';
+
+use APR::Table ();
+use APR::Pool ();
+use Apache::TestUtil;
+
+use Config;
+use constant THREADS_OK => $] >= 5.008 && $Config{useithreads};
+
+use Devel::Peek;
+
+#use TestAPRlib::table;
+#plan tests => TestAPRlib::table::num_of_tests();
+#TestAPRlib::table::test();
+
+my $pool = APR::Pool->new;
+my $t = APR::Table::make($pool, 10);
+#Dump $pool;
+undef $pool;
+
+#plan tests => 2*8;
+test_threads();
+
+# perl-ithreads specific testing
+sub test_threads {
+
+    my $threads = 1;
+
+    return unless THREADS_OK;
+
+    read_test();
+    threads->new(\&read_test) for 1..$threads;
+    read_test();
+
+    $_->join() for threads->list();
+
+}
+
+sub read_test : locked {
+    my $tid = threads->self()->tid();
+    t_debug "tid: $tid";
+
+    #Dump $pool;
+    $pool = APR::Pool->new;
+
+    #Dump $t;
+    $t = APR::Table::make($pool, 10);
+    #Dump $t;
+
+    return undef;
+}

Property changes on: t/apr-ext/t.t
___________________________________________________________________
Name: svn:eol-style
    + native

Index: t/apr-ext/x.t
===================================================================
--- t/apr-ext/x.t	(revision 0)
+++ t/apr-ext/x.t	(revision 0)
@@ -0,0 +1,63 @@
+#!perl -T
+
+# a few basic tests on how mp2 objects deal with cloning (used
+# APR::Table and APR::Pool for the tests)
+#
+
+package foo;
+
+use strict;
+use warnings FATAL => 'all';
+
+use APR::Table ();
+use APR::Pool ();
+
+use threads;
+
+use Apache::Test;
+use Apache::TestUtil;
+
+use TestCommon::Utils;
+
+use Devel::Peek;
+
+my $pool_ext = APR::Pool->new;
+my $table_ext1 = APR::Table::make($pool_ext, 10);
+my $table_ext2 = APR::Table::make($pool_ext, 10);
+
+my $threads = 2;
+
+run();
+
+sub run {
+
+    my $tests = 10 * (2 + $threads);
+    plan tests => $tests, need
+        need_threads,
+            {"perl >= 5.8.1 is required (this is $])" => ($] >= 5.008001)};
+
+    require threads;
+    threads->import();
+
+    read_test();
+    #Dump $pool_ext;
+    threads->new(sub {})->join() for 1..$threads;
+    #Dump $pool_ext;
+    read_test();
+}
+
+
+# 10 subtests
+sub read_test {
+    $table_ext1->set(1 => 2);
+
+    $table_ext1 = APR::Table::make(APR::Pool->new, 10);
+
+    return undef;
+}
+
+
+1;
+
+__END__
+

Property changes on: t/apr-ext/x.t
___________________________________________________________________
Name: svn:eol-style
    + native

Index: t/apr-ext/pool.t
===================================================================
--- t/apr-ext/pool.t	(revision 161975)
+++ t/apr-ext/pool.t	(working copy)
@@ -2,10 +2,14 @@

  use strict;
  use warnings FATAL => 'all';
-use Apache::Test;

+use threads;
+
  use TestAPRlib::pool;

+use Apache::Test;
+
  plan tests => TestAPRlib::pool::num_of_tests();

  TestAPRlib::pool::test();
+
Index: t/conf/modperl_extra.pl
===================================================================
--- t/conf/modperl_extra.pl	(revision 161975)
+++ t/conf/modperl_extra.pl	(working copy)
@@ -29,6 +29,12 @@
  use Apache2::Process ();
  use Apache2::Log ();

+use TestCommon::Utils;
+# XXX: must be loaded before Test::Builder gets loaded (via A-T or
+# Test::More) so it'll get the threads right.
+require threads if TestCommon::Utils::THREADS_OK;
+# XXX: need to do the same for t/TEST for apr-ext tests
+
  use Apache2::Const -compile => ':common';

  reorg_INC();
Index: t/response/TestPerl/ithreads_cloning.pm
===================================================================
--- t/response/TestPerl/ithreads_cloning.pm	(revision 0)
+++ t/response/TestPerl/ithreads_cloning.pm	(revision 0)
@@ -0,0 +1,135 @@
+package TestPerl::ithreads_cloning;
+
+# a few basic tests on how mp2 objects deal with cloning (used
+# APR::Table and APR::Pool for the tests)
+#
+
+use strict;
+use warnings FATAL => 'all';
+
+use APR::Table ();
+use APR::Pool ();
+
+use Apache::Test;
+use Apache::TestUtil;
+
+use TestCommon::Utils;
+
+use Devel::Peek;
+
+use Apache2::Const -compile => 'OK';
+
+my $pool_ext = APR::Pool->new;
+my $table_ext1 = APR::Table::make($pool_ext, 10);
+my $table_ext2 = APR::Table::make($pool_ext, 10);
+
+my $threads = 2;
+
+sub handler {
+    my $r = shift;
+
+    my $tests = 10 * (2 + $threads);
+    plan $r, tests => $tests, need
+        need_threads,
+        {"perl >= 5.8.1 is required (this is $])" => ($] >= 5.008001)};
+
+    require threads;
+    threads->import();
+
+    read_test();
+    #Dump $pool_ext;
+    #Dump $table_ext1;
+    threads->new(\&read_test)->join() for 1..$threads;
+    #Dump $pool_ext;
+    #Dump $table_ext1;
+    read_test();
+
+    Apache2::Const::OK;
+}
+
+# 10 subtests
+sub read_test {
+    my $tid = threads->self()->tid();
+    t_debug "tid: $tid";
+
+    {
+        # use of invalidated cloned object
+        my $error_msg = q[Can't call method "set" on unblessed reference];
+        eval { $table_ext1->set(1 => 2); };
+        if ($tid > 0) { # child thread
+            # set must fail, since $table_ext1 must have been invalidated
+            ok t_cmp $@, qr/\Q$error_msg/,
+                '$table_ext1 must have been invalidated';
+        }
+        else {
+            # should work just fine for the parent "thread", which
+            # created this variable
+            ok !$@;
+        }
+    }
+
+    {
+        # use of invalidated cloned object as an argument
+        my $error_msg = 'argument is not a blessed reference ' .
+            '(expecting an APR::Pool derived object)';
+        eval { my $table = APR::Table::make($pool_ext, 10) };
+        if ($tid > 0) { # child thread
+            # make() must fail, since $pool_ext must have been invalidated
+            ok t_cmp $@, qr/\Q$error_msg/,
+                '$pool_ext must have been invalidated';
+        }
+        else {
+            # should work just fine for the parent "thread", which
+            # created this variable
+            ok !$@;
+        }
+    }
+
+    {
+        # this is an important test, since the thread assigns a new
+        # value to the cloned $table_ext1 (since it existed before the
+        # thread was started)
+
+        my $save = $table_ext1;
+
+        $table_ext1 = APR::Table::make(APR::Pool->new, 10);
+
+        validate($table_ext1);
+
+        $table_ext1 = $save;
+    }
+
+    {
+        # here $table_ext2 is a private variable, so the cloned
+        # variable $table_ext2 is not touched
+        my $table_ext2 = APR::Table::make(APR::Pool->new, 10);
+
+        validate($table_ext2);
+    }
+
+    return undef;
+}
+
+# 4 subtests
+sub validate {
+    my $t = shift;
+    my $tid = threads->self()->tid();
+
+    $t->set($_ => $_) for 1..20;
+    for my $count (1..2) {
+        my $expected = 20;
+        my $received = $t->get(20);
+        is $received, $expected, "tid: $tid: pass 1:";
+        $t->set(20 => 40);
+        $received = $t->get(20);
+        $expected = 40;
+        is $received, $expected, "tid: $tid: pass 2:";
+        # reset
+        $t->set(20 => 20);
+    }
+}
+
+1;
+
+__END__
+

Property changes on: t/response/TestPerl/ithreads_cloning.pm
___________________________________________________________________
Name: svn:eol-style
    + native

Index: t/response/TestPerl/ithreads_cloning2.pm
===================================================================
--- t/response/TestPerl/ithreads_cloning2.pm	(revision 0)
+++ t/response/TestPerl/ithreads_cloning2.pm	(revision 0)
@@ -0,0 +1,63 @@
+package TestPerl::ithreads_cloning2;
+
+# a few basic tests on how mp2 objects deal with cloning (used
+# APR::Table and APR::Pool for the tests)
+#
+
+use strict;
+use warnings FATAL => 'all';
+
+use APR::Table ();
+use APR::Pool ();
+
+use Apache::Test;
+use Apache::TestUtil;
+
+use TestCommon::Utils;
+
+use Devel::Peek;
+
+use Apache2::Const -compile => 'OK';
+
+my $pool_ext = APR::Pool->new;
+my $table_ext1 = APR::Table::make($pool_ext, 10);
+
+my $threads = 1;
+
+sub handler {
+    my $r = shift;
+
+    my $tests = 10 * (2 + $threads);
+    plan $r, tests => $tests, need
+        need_threads,
+        {"perl >= 5.8.1 is required (this is $])" => ($] >= 5.008001)};
+
+    require threads;
+    threads->import();
+
+    read_test();
+    #Dump $pool_ext;
+    #Dump $table_ext1;
+    threads->new(sub {})->join() for 1..$threads;
+    #Dump $pool_ext;
+    #Dump $table_ext1;
+    read_test();
+
+    Apache2::Const::OK;
+}
+
+# 10 subtests
+sub read_test {
+    $table_ext1->set(1 => 2);
+
+    $table_ext1 = APR::Table::make(APR::Pool->new, 10);
+
+    return undef;
+}
+
+
+
+1;
+
+__END__
+

Property changes on: t/response/TestPerl/ithreads_cloning2.pm
___________________________________________________________________
Name: svn:eol-style
    + native

Index: t/perl/ithreads.t
===================================================================
--- t/perl/ithreads.t	(revision 161975)
+++ t/perl/ithreads.t	(working copy)
@@ -8,9 +8,11 @@

  # perl < 5.6.0 fails to compile code with 'shared' attributes, so we 
must skip
  # it here.
-unless ($] >= 5.008001 && $Config{useithreads}) {
-    plan tests => 1, need
-        {"perl 5.8.1 or higher w/ithreads enabled is required" => 0};
-}
+#unless ($] >= 5.008001 && $Config{useithreads}) {
+#    plan tests => 1, need
+#        {"perl 5.8.1 or higher w/ithreads enabled is required" => 0};
+#}

+plan tests => 1, under_construction;
+
  print GET_BODY_ASSERT "/TestPerl__ithreads";
Index: t/perl/ithreads_cloning.t
===================================================================
--- t/perl/ithreads_cloning.t	(revision 0)
+++ t/perl/ithreads_cloning.t	(revision 0)
@@ -0,0 +1,16 @@
+# WARNING: this file is generated, do not edit
+# 01: /home/stas/apache.org/mp2-svn/Apache-Test/lib/Apache/TestConfig.pm:927
+# 02: /home/stas/apache.org/mp2-svn/Apache-Test/lib/Apache/TestConfig.pm:945
+# 03: 
/home/stas/apache.org/mp2-svn/Apache-Test/lib/Apache/TestConfigPerl.pm:135
+# 04: 
/home/stas/apache.org/mp2-svn/Apache-Test/lib/Apache/TestConfigPerl.pm:550
+# 05: /home/stas/apache.org/mp2-svn/Apache-Test/lib/Apache/TestConfig.pm:613
+# 06: /home/stas/apache.org/mp2-svn/Apache-Test/lib/Apache/TestConfig.pm:628
+# 07: /home/stas/apache.org/mp2-svn/Apache-Test/lib/Apache/TestConfig.pm:1562
+# 08: /home/stas/apache.org/mp2-svn/Apache-Test/lib/Apache/TestRun.pm:506
+# 09: /home/stas/apache.org/mp2-svn/Apache-Test/lib/Apache/TestRunPerl.pm:84
+# 10: /home/stas/apache.org/mp2-svn/Apache-Test/lib/Apache/TestRun.pm:725
+# 11: /home/stas/apache.org/mp2-svn/Apache-Test/lib/Apache/TestRun.pm:725
+# 12: t/TEST:21
+
+use Apache::TestRequest 'GET_BODY_ASSERT';
+print GET_BODY_ASSERT "/TestPerl__ithreads_cloning";

Property changes on: t/perl/ithreads_cloning.t
___________________________________________________________________
Name: svn:eol-style
    + native

Index: t/lib/TestCommon/Utils.pm
===================================================================
--- t/lib/TestCommon/Utils.pm	(revision 161975)
+++ t/lib/TestCommon/Utils.pm	(working copy)
@@ -11,6 +11,9 @@
  use Apache2::Const -compile => qw(MODE_READBYTES);
  use APR::Const    -compile => qw(SUCCESS BLOCK_READ);

+use Config;
+use constant THREADS_OK => $] >= 5.008 && $Config{useithreads};
+
  use constant IOBUFSIZE => 8192;

  # perl 5.6.x only triggers taint protection on strings which are at
Index: t/lib/TestAPRlib/table.pm
===================================================================
--- t/lib/TestAPRlib/table.pm	(revision 161975)
+++ t/lib/TestAPRlib/table.pm	(working copy)
@@ -5,29 +5,51 @@
  use strict;
  use warnings FATAL => 'all';

+use Test::More ();
  use Apache::Test;
  use Apache::TestUtil;

  use APR::Table ();
  use APR::Pool ();

+use TestCommon::Utils;
+
  use APR::Const -compile => ':table';

  use constant TABLE_SIZE => 20;
  our $filter_count;

  sub num_of_tests {
+    my $runs = 1;
+    $runs += 3 if TestCommon::Utils::THREADS_OK;
+
      my $tests = 56;
-
      # tied hash values() for a table w/ multiple values for the same
      # key
      $tests += 2 if $] >= 5.008;

-    return $tests;
+    return $tests * $runs;
  }

  sub test {
+    test_set();

+    return unless TestCommon::Utils::THREADS_OK;
+
+    require threads;
+    our $p = APR::Pool->new;
+    my $threads = 2;
+
+    threads->new(\&test_set)->join for 1..$threads;
+    test_set(); # parent again
+
+    # XXX: at the moment serializing each run, since ok's gets
+    # interleaved with other otput when multple threads run at the
+    # same time
+    #$_->join() for threads->list();
+}
+
+sub test_set {
      $filter_count = 0;
      my $pool = APR::Pool->new();
      my $table = APR::Table::make($pool, TABLE_SIZE);
Index: t/lib/TestAPRlib/pool.pm
===================================================================
--- t/lib/TestAPRlib/pool.pm	(revision 161975)
+++ t/lib/TestAPRlib/pool.pm	(working copy)
@@ -3,7 +3,9 @@
  use strict;
  use warnings FATAL => 'all';

-use Apache::Test;
+use TestCommon::Utils;
+
+use Apache::Test; # for a shared test counter under ithreads
  use Apache::TestUtil;
  use Apache::TestTrace;

@@ -11,11 +13,28 @@
  use APR::Table ();

  sub num_of_tests {
-    return 75;
+    my $runs = 1;
+    $runs += 3 if TestCommon::Utils::THREADS_OK;
+
+    return $runs * 75;
  }

  sub test {
+    test_set();

+    return unless TestCommon::Utils::THREADS_OK;
+
+    require threads;
+    our $p = APR::Pool->new;
+    my $threads = 2;
+
+    threads->new(\&test_set)->join for 1..$threads;
+    test_set(); # parent again
+
+    #$_->join() for threads->list();
+}
+
+sub test_set {
      my $pool = APR::Pool->new();
      my $table = APR::Table::make($pool, 2);

@@ -407,6 +426,8 @@
          #ok $num_bytes;

      }
+
+    return undef; # a must for thread callback
  }

  # returns how many ancestor generations the pool has (parent,
Index: todo/release
===================================================================
--- todo/release	(revision 161975)
+++ todo/release	(working copy)
@@ -44,3 +44,91 @@
  happy). Not sure what's the best solution here.

  ---------------
+
+Making mp2 API perl-thread-safe
+owner: stas
+
+Status:
+
+V = done
+N = creates no objects
+- = not started
++ = in progress
+
+1)
+
+-- APR::Bucket
+-- APR::BucketType
+V- APR::Pool
+-- APR::SockAddr
+-- APR::Socket
+V- APR::Table
+-- APR::UUID
+
+2)
+
+-- APR::Brigade xs/APR/Brigade/APR__Brigade.h:    SV *bb_sv = 
sv_setref_pv(NEWSV(0, 0), "APR::Brigade", (void*)bb);
+-- APR::BucketAlloc xs/APR/BucketAlloc/APR__BucketAlloc.h: SV *ba_sv = 
sv_setref_pv(NEWSV(0, 0), "APR::BucketAlloc", (void*)ba);
+-- APR::Error (not sure about this one, should probably handle as well)
+-- APR::Finfo xs/APR/Finfo/APR__Finfo.h:    finfo_sv = 
sv_setref_pv(NEWSV(0, 0), "APR::Finfo", (void*)finfo);
+-- APR::IpSubnet xs/APR/IpSubnet/APR__IpSubnet.h:    ipsub_sv = 
sv_setref_pv(NEWSV(0, 0), "APR::IpSubnet", (void*)ipsub);
+-- APR::ThreadMutex xs/APR/ThreadMutex/APR__ThreadMutex.h:    mutex_sv = 
sv_setref_pv(NEWSV(0, 0), "APR::ThreadMutex", (void*)mutex);
+-- APR::URI xs/APR/URI/APR__URI.h:    uri_sv = sv_setref_pv(NEWSV(0, 0), 
"APR::URI", (void*)uri);
+
+3)
+
+-- Apache::CmdParms
+-- Apache::Command
+-- Apache::Connection
+-- Apache::Directive
+-- Apache::Filter
+-- Apache::FilterRec
+-- Apache::ServerRec
+-- Apache::SubRequest
+-- Apache::Module
+-- Apache::Process
+
+4)
+-- Apache::Log xs/Apache/Log/Apache__Log.h:    sv_setref_pv(svretval, 
pclass, (void*)retval);
+-- Apache::RequestRec
+     src/modules/perl/modperl_io.c:    sv_setref_pv(sv, 
"Apache::RequestRec", (void*)r);
+     src/modules/perl/modperl_io.c:    sv_setref_pv(sv, 
"Apache::RequestRec", (void*)r);
+     src/modules/perl/modperl_io_apache.c:    sv_setref_pv(sv, 
"Apache::RequestRec", (void*)(st->r));
+     xs/Apache/RequestUtil/Apache__RequestUtil.h:    r_sv = 
sv_setref_pv(NEWSV(0, 0), "Apache::RequestRec", (void*)r);
+
+
+4) The following too (needs more detailed lookthrough):
+
+V- src/modules/perl/modperl_util.c:    sv_setref_pv(sv, classname, ptr);
+V- src/modules/perl/modperl_common_util.c:    sv_setref_pv(rsv, 
classname, p);
+V- xs/typemap:   sv_setref_pv($arg, \"${ntype}\", (void*)$var);
+V- xs/typemap:   sv_setref_pv($arg, \"${ntype}\", (void*)$var);
+
+XXX: also grep for sv_bless
+
++ need to add DESTROY and CLONE methods to all the classes that we
+have the objects blessed into
+
+None of the following classes is used to bless object and therefore
+they require no special CLONE handling:
+
+N- Apache::Access
+N- Apache::HookRun
+N- Apache::MPM
+N- Apache::RequestIO
+N- Apache::RequestUtil
+N- Apache::Response
+N- Apache::ServerUtil
+N- Apache::SubProcess
+N- Apache::URI
+N- Apache::Util
+N- APR::Base64
+N- APR::Date
+N- APR::OS
+N- APR::String
+N- APR::Util
+N- ModPerl::Global
+N- ModPerl::Util
+
+
+
Index: lib/ModPerl/TypeMap.pm
===================================================================
--- lib/ModPerl/TypeMap.pm	(revision 161975)
+++ lib/ModPerl/TypeMap.pm	(working copy)
@@ -499,8 +499,15 @@
              $define = "mp_xs_${ptype}_2obj";

              $code .= <<EOF;
-#define $define(ptr) \\
-sv_setref_pv(sv_newmortal(), "$class", (void*)ptr)
+MP_INLINE SV *$define(pTHX_ void *ptr);
+MP_INLINE SV *$define(pTHX_ void *ptr)
+{
+    SV *rv = sv_setref_pv(sv_newmortal(), "$class", ptr);
+    if (ptr) {
+        MP_CLONE_INSERT_OBJ("$class", rv);
+    }
+    return rv;
+}

  EOF



-- 
__________________________________________________________________
Stas Bekman            JAm_pH ------> Just Another mod_perl Hacker
http://stason.org/     mod_perl Guide ---> http://perl.apache.org
mailto:stas@stason.org http://use.perl.org http://apacheweek.com
http://modperlbook.org http://apache.org   http://ticketmaster.com

Mime
View raw message