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 Mon, 28 Mar 2005 00:23:37 GMT
Stas Bekman wrote:

Have done some good but painfully slow progress, now partially covering 
APR::Table and APR::Pool. In case you care to look here is the work in 
progress. I wonder if I should branch that since there are going to be *a 
lot* of additions if this ever works.

My main obstacle at the moment is the testing environment under threads. I 
get interleaving messages from different threads (SMP/HyperThread CPU here 
so I get real multiple threads running at the same time.). So at times 
Test::Harness get confused:

ok 219
Confused test output: test 218 answered after test 218
# expected: 1
# testing : a dead pool is a dead pool
# expected: (?-xism:invalid pool object)
# received: invalid pool object (already destroyed?) at 
/home/stas/apache.org/mp2-svn/t/lib/TestAPRlib/pool.pm line 197.
# received: inok 220
# testing : should be 1 note
# expected: 1
# received: 1
ok 221

here ok 220 got interleaved with a log from another thread. I'm afraid 
Test::More/Apache::Test need more work and do STDERR locking when working 
in the threaded environment.

Anyway, here is some code:

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

  SV *modperl_perl_gensym(pTHX_ char *pack);

+/*** ithreads enabled perl CLONE support ***/
+#define MP_CLONE_DEBUG 0
+
+#define MP_CLONE_HASH_NAME "::CLONE_objects"
+
+#define MP_CLONE_KEY_COMMON(obj) SvIVX(SvRV(obj))
+
+
+#if MP_CLONE_DEBUG
+
+#define MP_CLONE_DEBUG_INSERT_KEY(namespace, obj)                       \
+    Perl_warn(aTHX_ "%s %p: insert %s, %p => %p\n",                     \
+              namespace, aTHX_ SvPV_nolen(sv_key), obj, SvRV(obj));
+#define MP_CLONE_DEBUG_HOLLOW_KEY(namespace)                            \
+    Perl_warn(aTHX_ "%s %p: hollow %s\n", namespace,                    \
+              aTHX_ SvPVX(hv_iterkeysv(he)));
+#define MP_CLONE_DEBUG_DELETE_KEY(namespace)                            \
+    Perl_warn(aTHX_ "%s %p: delete %s\n", namespace, aTHX_ SvPVX(sv_key));
+
+#define MP_CLONE_DEBUG_CLONE(namespace)                                 \
+        Perl_warn(aTHX_ "%s %p: CLONE called\n", namespace, aTHX);
+
+#define MP_CLONE_DUMP_OBJECTS_HASH(namespace)                           \
+    {                                                                   \
+        HE *he;                                                         \
+        HV *hv = get_hv(namespace MP_CLONE_HASH_NAME, TRUE);            \
+        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
+
+#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
+
+#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 = get_hv(namespace MP_CLONE_HASH_NAME, TRUE);            \
+        /* use the real object pointer as a unique key */               \
+        sv_key = newSVpvf("%p", MP_CLONE_KEY_COMMON(obj));              \
+        MP_CLONE_DEBUG_INSERT_KEY(namespace, obj);                      \
+        weak_rv = newRV(SvRV(obj));                                     \
+        WEAKEN(weak_rv); /* ala 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",          \
+                           namespace MP_CLONE_HASH_NAME);               \
+            }                                                           \
+            MP_CLONE_DUMP_OBJECTS_HASH(namespace);                      \
+        }                                                               \
+    }
+
+#define MP_CLONE_DO_CLONE(namespace, class)                             \
+    {                                                                   \
+        HE *he;                                                         \
+        HV *hv = get_hv(namespace MP_CLONE_HASH_NAME, TRUE);            \
+        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 form the C struct and invalidate */           \
+                mg_free(sv); /* remove any magic */                     \
+                SvOK_off(sv);                                           \
+                SvIVX(sv) = 0;                                          \
+                SvOBJECT_off(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 = get_hv(namespace MP_CLONE_HASH_NAME, TRUE);            \
+        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: xs/maps/apr_functions.map
===================================================================
--- xs/maps/apr_functions.map	(revision 159153)
+++ 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 159153)
+++ 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)
@@ -192,7 +198,6 @@
      }
  }

-
  MP_STATIC XS(MPXS_apr_table_get)
  {
      dXSARGS;
@@ -211,7 +216,7 @@

          if (GIMME_V == G_SCALAR) {
              const char *val = apr_table_get(t, key);
-
+
              if (val) {
                  XPUSHs(sv_2mortal(newSVpv((char*)val, 0)));
              }
@@ -231,3 +236,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 159153)
+++ xs/APR/Pool/APR__Pool.h	(working copy)
@@ -216,6 +216,8 @@
          if (parent_pool) {
              mpxs_add_pool_magic(rv, parent_pool_obj);
          }
+
+        MP_CLONE_INSERT_OBJ("APR::Pool", rv);

          return rv;
      }
@@ -368,9 +370,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: t/apr-ext/table.t
===================================================================
--- t/apr-ext/table.t	(revision 159153)
+++ t/apr-ext/table.t	(working copy)
@@ -1,11 +1,70 @@
-#!perl -T
+#!perl

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

-use TestAPRlib::table;
+use threads;
+use threads::shared;

-plan tests => TestAPRlib::table::num_of_tests();
+use Apache::Test '-withtestmore';

-TestAPRlib::table::test();
+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);
+
+plan tests => 2*8;
+test_threads();
+
+# perl-ithreads specific testing
+sub test_threads {
+
+    my $threads = 2;
+
+    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";
+
+    my $pool = APR::Pool->new;
+
+    #Dump $t;
+    $t = APR::Table::make($pool, 10);
+    #Dump $t;
+
+    $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);
+    }
+
+    return undef;
+}
Index: t/apr-ext/pool.t
===================================================================
--- t/apr-ext/pool.t	(revision 159153)
+++ 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 159153)
+++ t/conf/modperl_extra.pl	(working copy)
@@ -35,6 +35,9 @@

  reorg_INC();

+
+use threads; # XXX: must be loaded before Test::Builder gets loaded (via 
A-T or Test::More) so it'll get the threads right.
+
  startup_info();

  test_add_config();
Index: t/response/TestAPR/pool.pm
===================================================================
--- t/response/TestAPR/pool.pm	(revision 159153)
+++ t/response/TestAPR/pool.pm	(working copy)
@@ -3,7 +3,7 @@
  use strict;
  use warnings FATAL => 'all';

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

Index: t/lib/TestCommon/Utils.pm
===================================================================
--- t/lib/TestCommon/Utils.pm	(revision 159153)
+++ t/lib/TestCommon/Utils.pm	(working copy)
@@ -10,6 +10,9 @@
  use Apache::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 159153)
+++ t/lib/TestAPRlib/table.pm	(working copy)
@@ -16,6 +16,9 @@
  use constant TABLE_SIZE => 20;
  our $filter_count;

+use Config;
+use constant THREADS_OK => $] >= 5.008 && $Config{useithreads};
+
  sub num_of_tests {
      my $tests = 56;

@@ -368,4 +371,39 @@
      return $filter_count == int(TABLE_SIZE)/2 ? 0 : 1;
  }

+
+our $t;
+# perl-ithreads specific testing
+sub test_threads {
+
+    my $threads = 2;
+
+    return unless THREADS_OK;
+
+    require threads;
+    require threads::shared;
+
+    $t = APR::Table::make(APR::Pool->new, 10);
+    $t->set($_ => $_) for 1..20;
+
+    read_test();
+    threads->new(\&read_test) for 1..$threads;
+    read_test();
+}
+
+sub read_test : locked {
+    my $tid = threads->self()->tid();
+    for my $count (1..2) {
+        my $expected = 20;
+        my $received = $t->get(20);
+        ok $received, $expected, "tid: $tid: pass 1:";
+        $t->set(20 => 40);
+        $received = $t->get(20);
+        $expected = 40;
+        ok $received, $expected, "tid: $tid: pass 2:";
+        # reset
+        $t->set(20 => 20);
+    }
+}
+
  1;
Index: t/lib/TestAPRlib/pool.pm
===================================================================
--- t/lib/TestAPRlib/pool.pm	(revision 159153)
+++ 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 '-withtestmore'; # 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) 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,


-- 
__________________________________________________________________
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

---------------------------------------------------------------------
To unsubscribe, e-mail: dev-unsubscribe@perl.apache.org
For additional commands, e-mail: dev-help@perl.apache.org


Mime
View raw message