]> git.vpit.fr Git - perl/modules/re-engine-Hooks.git/commitdiff
The Big Boilerplate Factorization
authorVincent Pit <perl@profvince.com>
Wed, 4 Nov 2015 13:39:44 +0000 (11:39 -0200)
committerVincent Pit <perl@profvince.com>
Thu, 5 Nov 2015 12:51:47 +0000 (10:51 -0200)
Hooks.xs
MANIFEST
ptable.h [deleted file]
re_defs.h
xsh/caps.h [new file with mode: 0644]
xsh/ptable.h [new file with mode: 0644]
xsh/threads.h [new file with mode: 0644]
xsh/util.h [new file with mode: 0644]

index 9d3c6bac06ae00f4dd5e1471b2fc52cc96d0df61..3f9ce3e1a6039198d6f880c6ce60f97afce73585 100644 (file)
--- a/Hooks.xs
+++ b/Hooks.xs
@@ -6,37 +6,21 @@
 #include "perl.h"
 #include "XSUB.h"
 
 #include "perl.h"
 #include "XSUB.h"
 
-#define __PACKAGE__     "re::engine::Hooks"
-#define __PACKAGE_LEN__ (sizeof(__PACKAGE__)-1)
+/* --- XS helpers ---------------------------------------------------------- */
 
 
-/* --- Compatibility wrappers ---------------------------------------------- */
-
-#define REH_HAS_PERL(R, V, S) (PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S))))))
+#define XSH_PACKAGE "re::engine::Hooks"
 
 
-#ifndef SvPV_const
-# define SvPV_const(S, L) SvPV(S, L)
-#endif
+#include "xsh/caps.h"
+#include "xsh/util.h"
 
 
-/* ... Thread safety and multiplicity ...................................... */
+/* ... Lexical hints ....................................................... */
 
 
-#ifndef REH_MULTIPLICITY
-# if defined(MULTIPLICITY) || defined(PERL_IMPLICIT_CONTEXT)
-#  define REH_MULTIPLICITY 1
-# else
-#  define REH_MULTIPLICITY 0
-# endif
+#if !defined(cop_hints_fetch_pvn) && XSH_HAS_PERL(5, 9, 5)
+# define cop_hints_fetch_pvn(COP, PKG, PKGLEN, PKGHASH, FLAGS) \
+   Perl_refcounted_he_fetch(aTHX_ (COP)->cop_hints_hash, NULL, \
+                                  (PKG), (PKGLEN), (FLAGS), (PKGHASH))
 #endif
 
 #endif
 
-#ifdef USE_ITHREADS
-# define REH_LOCK(M)   MUTEX_LOCK(M)
-# define REH_UNLOCK(M) MUTEX_UNLOCK(M)
-#else
-# define REH_LOCK(M)   NOOP
-# define REH_UNLOCK(M) NOOP
-#endif
-
-/* --- Lexical hints ------------------------------------------------------- */
-
 STATIC U32 reh_hash = 0;
 
 STATIC SV *reh_hint(pTHX) {
 STATIC U32 reh_hash = 0;
 
 STATIC SV *reh_hint(pTHX) {
@@ -44,24 +28,30 @@ STATIC SV *reh_hint(pTHX) {
  SV *hint;
 
 #ifdef cop_hints_fetch_pvn
  SV *hint;
 
 #ifdef cop_hints_fetch_pvn
- hint = cop_hints_fetch_pvn(PL_curcop, __PACKAGE__, __PACKAGE_LEN__,
+ hint = cop_hints_fetch_pvn(PL_curcop, XSH_PACKAGE, XSH_PACKAGE_LEN,
                                        reh_hash, 0);
                                        reh_hash, 0);
-#elif REH_HAS_PERL(5, 9, 5)
- hint = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
-                                       NULL,
-                                       __PACKAGE__, __PACKAGE_LEN__,
-                                       0,
-                                       reh_hash);
 #else
 #else
- SV **val = hv_fetch(GvHV(PL_hintgv), __PACKAGE__, __PACKAGE_LEN__, 0);
- if (!val)
-  return 0;
- hint = *val;
+ SV **val = hv_fetch(GvHV(PL_hintgv), XSH_PACKAGE, XSH_PACKAGE_LEN, 0);
+ hint = val ? *val : NULL;
 #endif
 
  return hint;
 }
 
 #endif
 
  return hint;
 }
 
+/* ... Thread-local storage ................................................ */
+
+#define XSH_THREADS_USER_CONTEXT        0
+#define XSH_THREADS_USER_LOCAL_SETUP    0
+#define XSH_THREADS_USER_LOCAL_TEARDOWN 0
+
+#include "xsh/threads.h"
+
+/* --- Compatibility wrappers ---------------------------------------------- */
+
+#ifndef SvPV_const
+# define SvPV_const(S, L) SvPV(S, L)
+#endif
+
 /* --- Public API ---------------------------------------------------------- */
 
 #include "re_engine_hooks.h"
 /* --- Public API ---------------------------------------------------------- */
 
 #include "re_engine_hooks.h"
@@ -100,10 +90,10 @@ void reh_register(pTHX_ const char *key, reh_config *cfg) {
  a->key  = key_dup;
  a->klen = len;
 
  a->key  = key_dup;
  a->klen = len;
 
REH_LOCK(&reh_action_list_mutex);
XSH_LOCK(&reh_action_list_mutex);
  a->next         = reh_action_list;
  reh_action_list = a;
  a->next         = reh_action_list;
  reh_action_list = a;
REH_UNLOCK(&reh_action_list_mutex);
XSH_UNLOCK(&reh_action_list_mutex);
 
  return;
 }
 
  return;
 }
@@ -121,12 +111,12 @@ EXTERN_C REGEXP *reh_re_compile(pTHX_ const SV * const, const U32);
 #else
 EXTERN_C REGEXP *reh_re_compile(pTHX_ SV * const, U32);
 #endif
 #else
 EXTERN_C REGEXP *reh_re_compile(pTHX_ SV * const, U32);
 #endif
-#if REH_HAS_PERL(5, 19, 4)
+#if XSH_HAS_PERL(5, 19, 4)
 EXTERN_C I32     reh_regexec_flags(pTHX_ REGEXP * const, char *, char *, char *, SSize_t, SV *, void *, U32);
 #else
 EXTERN_C I32     reh_regexec_flags(pTHX_ REGEXP * const, char *, char *, char *, I32, SV *, void *, U32);
 #endif
 EXTERN_C I32     reh_regexec_flags(pTHX_ REGEXP * const, char *, char *, char *, SSize_t, SV *, void *, U32);
 #else
 EXTERN_C I32     reh_regexec_flags(pTHX_ REGEXP * const, char *, char *, char *, I32, SV *, void *, U32);
 #endif
-#if REH_HAS_PERL(5, 19, 1)
+#if XSH_HAS_PERL(5, 19, 1)
 EXTERN_C char *  reh_re_intuit_start(pTHX_ REGEXP * const, SV *, const char * const, char *, char *, U32, re_scream_pos_data *);
 #else
 EXTERN_C char *  reh_re_intuit_start(pTHX_ REGEXP * const, SV *, char *, char *, U32, re_scream_pos_data *);
 EXTERN_C char *  reh_re_intuit_start(pTHX_ REGEXP * const, SV *, const char * const, char *, char *, U32, re_scream_pos_data *);
 #else
 EXTERN_C char *  reh_re_intuit_start(pTHX_ REGEXP * const, SV *, char *, char *, U32, re_scream_pos_data *);
@@ -147,7 +137,7 @@ EXTERN_C SV *    reh_reg_qr_package(pTHX_ REGEXP * const);
 #ifdef USE_ITHREADS
 EXTERN_C void *  reh_re_dupe(pTHX_ REGEXP * const, CLONE_PARAMS *);
 #endif
 #ifdef USE_ITHREADS
 EXTERN_C void *  reh_re_dupe(pTHX_ REGEXP * const, CLONE_PARAMS *);
 #endif
-#if REH_HAS_PERL(5, 17, 1)
+#if XSH_HAS_PERL(5, 17, 1)
 EXTERN_C REGEXP *reh_re_op_compile(pTHX_ SV ** const, int, OP *, const regexp_engine*, REGEXP *VOL, bool *, U32, U32);
 #endif
 
 EXTERN_C REGEXP *reh_re_op_compile(pTHX_ SV ** const, int, OP *, const regexp_engine*, REGEXP *VOL, bool *, U32, U32);
 #endif
 
@@ -166,7 +156,7 @@ const struct regexp_engine reh_regexp_engine = {
 #if defined(USE_ITHREADS)
  , reh_re_dupe
 #endif
 #if defined(USE_ITHREADS)
  , reh_re_dupe
 #endif
-#if REH_HAS_PERL(5, 17, 1)
+#if XSH_HAS_PERL(5, 17, 1)
  , reh_re_op_compile
 #endif
 };
  , reh_re_op_compile
 #endif
 };
@@ -179,8 +169,11 @@ typedef struct {
  U32               refcount;
 } reh_private;
 
  U32               refcount;
 } reh_private;
 
-STATIC void reh_private_free(pTHX_ reh_private *priv) {
-#define reh_private_free(P) reh_private_free(aTHX_ (P))
+STATIC void reh_private_free(pPMS_ reh_private *priv) {
+#define reh_private_free(P) reh_private_free(aPMS_ (P))
+ if (!priv)
+  return;
+
  if (priv->refcount <= 1) {
   PerlMemShared_free((void *) priv->cbs);
   PerlMemShared_free(priv);
  if (priv->refcount <= 1) {
   PerlMemShared_free((void *) priv->cbs);
   PerlMemShared_free(priv);
@@ -189,20 +182,16 @@ STATIC void reh_private_free(pTHX_ reh_private *priv) {
  }
 }
 
  }
 }
 
-#define PTABLE_NAME        ptable_private
-#define PTABLE_VAL_FREE(V) reh_private_free(V)
-
-#define pPTBL  pTHX
-#define pPTBL_ pTHX_
-#define aPTBL  aTHX
-#define aPTBL_ aTHX_
+#define PTABLE_NAME             ptable_private
+#define PTABLE_VAL_FREE(V)      reh_private_free(V)
+#define PTABLE_VAL_NEED_CONTEXT 0
 
 
-#include "ptable.h"
+#include "xsh/ptable.h"
 
 
-#define ptable_private_store(T, K, V) ptable_private_store(aTHX_ (T), (K), (V))
-#define ptable_private_delete(T, K)   ptable_private_delete(aTHX_ (T), (K))
-#define ptable_private_clear(T)       ptable_private_clear(aTHX_ (T))
-#define ptable_private_free(T)        ptable_private_free(aTHX_ (T))
+#define ptable_private_store(T, K, V) ptable_private_store(aPMS_ (T), (K), (V))
+#define ptable_private_delete(T, K)   ptable_private_delete(aPMS_ (T), (K))
+#define ptable_private_clear(T)       ptable_private_clear(aPMS_ (T))
+#define ptable_private_free(T)        ptable_private_free(aPMS_ (T))
 
 STATIC ptable *reh_private_map;
 
 
 STATIC ptable *reh_private_map;
 
@@ -214,7 +203,7 @@ STATIC perl_mutex reh_private_map_mutex;
 
 #define REH_PRIVATE_MAP_FOREACH(C) STMT_START {      \
  reh_private *priv;                                  \
 
 #define REH_PRIVATE_MAP_FOREACH(C) STMT_START {      \
  reh_private *priv;                                  \
REH_LOCK(&reh_private_map_mutex);                   \
XSH_LOCK(&reh_private_map_mutex);                   \
  priv = ptable_fetch(reh_private_map, rx->pprivate); \
  if (priv) {                                         \
   const reh_config *cbs = priv->cbs;                 \
  priv = ptable_fetch(reh_private_map, rx->pprivate); \
  if (priv) {                                         \
   const reh_config *cbs = priv->cbs;                 \
@@ -225,14 +214,14 @@ STATIC perl_mutex reh_private_map_mutex;
    }                                                 \
   }                                                  \
  }                                                   \
    }                                                 \
   }                                                  \
  }                                                   \
REH_UNLOCK(&reh_private_map_mutex);                 \
XSH_UNLOCK(&reh_private_map_mutex);                 \
 } STMT_END
 
 STATIC void reh_private_map_store(pTHX_ void *ri, reh_private *priv) {
 #define reh_private_map_store(R, P) reh_private_map_store(aTHX_ (R), (P))
 } STMT_END
 
 STATIC void reh_private_map_store(pTHX_ void *ri, reh_private *priv) {
 #define reh_private_map_store(R, P) reh_private_map_store(aTHX_ (R), (P))
REH_LOCK(&reh_private_map_mutex);
XSH_LOCK(&reh_private_map_mutex);
  ptable_private_store(reh_private_map, ri, priv);
  ptable_private_store(reh_private_map, ri, priv);
REH_UNLOCK(&reh_private_map_mutex);
XSH_UNLOCK(&reh_private_map_mutex);
 
  return;
 }
 
  return;
 }
@@ -241,20 +230,20 @@ STATIC void reh_private_map_copy(pTHX_ void *ri_from, void *ri_to) {
 #define reh_private_map_copy(F, T) reh_private_map_copy(aTHX_ (F), (T))
  reh_private *priv;
 
 #define reh_private_map_copy(F, T) reh_private_map_copy(aTHX_ (F), (T))
  reh_private *priv;
 
REH_LOCK(&reh_private_map_mutex);
XSH_LOCK(&reh_private_map_mutex);
  priv = ptable_fetch(reh_private_map, ri_from);
  if (priv) {
   ++priv->refcount;
   ptable_private_store(reh_private_map, ri_to, priv);
  }
  priv = ptable_fetch(reh_private_map, ri_from);
  if (priv) {
   ++priv->refcount;
   ptable_private_store(reh_private_map, ri_to, priv);
  }
REH_UNLOCK(&reh_private_map_mutex);
XSH_UNLOCK(&reh_private_map_mutex);
 }
 
 STATIC void reh_private_map_delete(pTHX_ void *ri) {
 #define reh_private_map_delete(R) reh_private_map_delete(aTHX_ (R))
 }
 
 STATIC void reh_private_map_delete(pTHX_ void *ri) {
 #define reh_private_map_delete(R) reh_private_map_delete(aTHX_ (R))
REH_LOCK(&reh_private_map_mutex);
XSH_LOCK(&reh_private_map_mutex);
  ptable_private_delete(reh_private_map, ri);
  ptable_private_delete(reh_private_map, ri);
REH_UNLOCK(&reh_private_map_mutex);
XSH_UNLOCK(&reh_private_map_mutex);
 
  return;
 }
 
  return;
 }
@@ -273,9 +262,9 @@ void reh_call_comp_begin_hook(pTHX_ regexp *rx) {
   reh_config  *cbs = NULL;
   reh_action  *a, *root;
 
   reh_config  *cbs = NULL;
   reh_action  *a, *root;
 
-  REH_LOCK(&reh_action_list_mutex);
+  XSH_LOCK(&reh_action_list_mutex);
   root = reh_action_list;
   root = reh_action_list;
-  REH_UNLOCK(&reh_action_list_mutex);
+  XSH_UNLOCK(&reh_action_list_mutex);
 
   for (a = root; a; a = a->next) {
    char *p = strstr(keys, a->key);
 
   for (a = root; a; a = a->next) {
    char *p = strstr(keys, a->key);
@@ -343,13 +332,30 @@ void *reh_re_dupe(pTHX_ REGEXP * const RX, CLONE_PARAMS *param) {
 
 #endif
 
 
 #endif
 
-STATIC void reh_teardown(pTHX_ void *root) {
-#if REH_MULTIPLICITY
- if (aTHX != root)
-  return;
+/* --- Module setup/teardown ----------------------------------------------- */
+
+STATIC void xsh_user_global_setup(pTHX) {
+ PERL_HASH(reh_hash, XSH_PACKAGE, XSH_PACKAGE_LEN);
+
+ reh_private_map = ptable_new(8);
+
+#ifdef USE_ITHREADS
+ MUTEX_INIT(&reh_action_list_mutex);
+ MUTEX_INIT(&reh_private_map_mutex);
 #endif
 
 #endif
 
+ return;
+}
+
+STATIC void xsh_user_global_teardown(pTHX) {
  ptable_private_free(reh_private_map);
  ptable_private_free(reh_private_map);
+
+#ifdef USE_ITHREADS
+ MUTEX_DESTROY(&reh_private_map_mutex);
+ MUTEX_DESTROY(&reh_action_list_mutex);
+#endif
+
+ return;
 }
 
 /* --- XS ------------------------------------------------------------------ */
 }
 
 /* --- XS ------------------------------------------------------------------ */
@@ -360,17 +366,7 @@ PROTOTYPES: ENABLE
 
 BOOT:
 {
 
 BOOT:
 {
- reh_private_map = ptable_new();
-#ifdef USE_ITHREADS
- MUTEX_INIT(&reh_action_list_mutex);
- MUTEX_INIT(&reh_private_map_mutex);
-#endif
- PERL_HASH(reh_hash, __PACKAGE__, __PACKAGE_LEN__);
-#if REH_MULTIPLICITY
- call_atexit(reh_teardown, aTHX);
-#else
- call_atexit(reh_teardown, NULL);
-#endif
+ xsh_setup();
 }
 
 void
 }
 
 void
@@ -388,9 +384,9 @@ PREINIT:
  STRLEN      len;
  const char *s;
 PPCODE:
  STRLEN      len;
  const char *s;
 PPCODE:
REH_LOCK(&reh_action_list_mutex);
XSH_LOCK(&reh_action_list_mutex);
  a = reh_action_list;
  a = reh_action_list;
REH_UNLOCK(&reh_action_list_mutex);
XSH_UNLOCK(&reh_action_list_mutex);
  s = SvPV_const(key, len);
  while (a && !ret) {
   if (a->klen == len && memcmp(a->key, s, len) == 0)
  s = SvPV_const(key, len);
  while (a && !ret) {
   if (a->klen == len && memcmp(a->key, s, len) == 0)
index 5c87d6e8b6b61ef78a625a7290887c289220b271..1b75a0cb996e54138a00b919d9d9bf07c66fbd30 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -7,7 +7,6 @@ Makefile.PL
 README
 configure_test.pl
 lib/re/engine/Hooks.pm
 README
 configure_test.pl
 lib/re/engine/Hooks.pm
-ptable.h
 re_defs.h
 re_engine_hooks.h
 re_top.h
 re_defs.h
 re_engine_hooks.h
 re_top.h
@@ -106,3 +105,7 @@ t/20-multi.t
 t/re-engine-Hooks-TestDist/Makefile.PL
 t/re-engine-Hooks-TestDist/TestDist.xs
 t/re-engine-Hooks-TestDist/lib/re/engine/Hooks/TestDist.pm
 t/re-engine-Hooks-TestDist/Makefile.PL
 t/re-engine-Hooks-TestDist/TestDist.xs
 t/re-engine-Hooks-TestDist/lib/re/engine/Hooks/TestDist.pm
+xsh/caps.h
+xsh/ptable.h
+xsh/threads.h
+xsh/util.h
diff --git a/ptable.h b/ptable.h
deleted file mode 100644 (file)
index 30d0df4..0000000
--- a/ptable.h
+++ /dev/null
@@ -1,251 +0,0 @@
-/* This file is part of the re::engine::Hooks Perl module.
- * See http://search.cpan.org/dist/re-engine-Hooks/ */
-
-/* This is a pointer table implementation essentially copied from the ptr_table
- * implementation in perl's sv.c, except that it has been modified to use memory
- * shared across threads.
- * Copyright goes to the original authors, bug reports to me. */
-
-/* This header is designed to be included several times with different
- * definitions for PTABLE_NAME and PTABLE_VAL_FREE(). */
-
-#undef VOID2
-#ifdef __cplusplus
-# define VOID2(T, P) static_cast<T>(P)
-#else
-# define VOID2(T, P) (P)
-#endif
-
-#undef pPTBLMS
-#undef pPTBLMS_
-#undef aPTBLMS
-#undef aPTBLMS_
-
-/* Context for PerlMemShared_* functions */
-
-#ifdef PERL_IMPLICIT_SYS
-# define pPTBLMS  pTHX
-# define pPTBLMS_ pTHX_
-# define aPTBLMS  aTHX
-# define aPTBLMS_ aTHX_
-#else
-# define pPTBLMS  void
-# define pPTBLMS_
-# define aPTBLMS
-# define aPTBLMS_
-#endif
-
-#ifndef pPTBL
-# define pPTBL  pPTBLMS
-#endif
-#ifndef pPTBL_
-# define pPTBL_ pPTBLMS_
-#endif
-#ifndef aPTBL
-# define aPTBL  aPTBLMS
-#endif
-#ifndef aPTBL_
-# define aPTBL_ aPTBLMS_
-#endif
-
-#ifndef PTABLE_NAME
-# define PTABLE_NAME ptable
-#endif
-
-#ifndef PTABLE_VAL_FREE
-# define PTABLE_VAL_FREE(V)
-#endif
-
-#ifndef PTABLE_JOIN
-# define PTABLE_PASTE(A, B) A ## B
-# define PTABLE_JOIN(A, B)  PTABLE_PASTE(A, B)
-#endif
-
-#ifndef PTABLE_PREFIX
-# define PTABLE_PREFIX(X) PTABLE_JOIN(PTABLE_NAME, X)
-#endif
-
-#ifndef ptable_ent
-typedef struct ptable_ent {
- struct ptable_ent *next;
- const void *       key;
- void *             val;
-} ptable_ent;
-#define ptable_ent ptable_ent
-#endif /* !ptable_ent */
-
-#ifndef ptable
-typedef struct ptable {
- ptable_ent **ary;
- size_t       max;
- size_t       items;
-} ptable;
-#define ptable ptable
-#endif /* !ptable */
-
-#ifndef ptable_new
-STATIC ptable *ptable_new(pPTBLMS) {
-#define ptable_new() ptable_new(aPTBLMS)
- ptable *t = VOID2(ptable *, PerlMemShared_malloc(sizeof *t));
- t->max    = 15;
- t->items  = 0;
- t->ary    = VOID2(ptable_ent **,
-                              PerlMemShared_calloc(t->max + 1, sizeof *t->ary));
- return t;
-}
-#endif /* !ptable_new */
-
-#ifndef PTABLE_HASH
-# define PTABLE_HASH(ptr) \
-     ((PTR2UV(ptr) >> 3) ^ (PTR2UV(ptr) >> (3 + 7)) ^ (PTR2UV(ptr) >> (3 + 17)))
-#endif
-
-#ifndef ptable_find
-STATIC ptable_ent *ptable_find(const ptable * const t, const void * const key) {
-#define ptable_find ptable_find
- ptable_ent *ent;
- const UV hash = PTABLE_HASH(key);
-
- ent = t->ary[hash & t->max];
- for (; ent; ent = ent->next) {
-  if (ent->key == key)
-   return ent;
- }
-
- return NULL;
-}
-#endif /* !ptable_find */
-
-#ifndef ptable_fetch
-STATIC void *ptable_fetch(const ptable * const t, const void * const key) {
-#define ptable_fetch ptable_fetch
- const ptable_ent *const ent = ptable_find(t, key);
-
- return ent ? ent->val : NULL;
-}
-#endif /* !ptable_fetch */
-
-#ifndef ptable_split
-STATIC void ptable_split(pPTBLMS_ ptable * const t) {
-#define ptable_split(T) ptable_split(aPTBLMS_ (T))
- ptable_ent **ary = t->ary;
- const size_t oldsize = t->max + 1;
- size_t newsize = oldsize * 2;
- size_t i;
-
- ary = VOID2(ptable_ent **, PerlMemShared_realloc(ary, newsize * sizeof(*ary)));
- Zero(&ary[oldsize], newsize - oldsize, sizeof(*ary));
- t->max = --newsize;
- t->ary = ary;
-
- for (i = 0; i < oldsize; i++, ary++) {
-  ptable_ent **curentp, **entp, *ent;
-  if (!*ary)
-   continue;
-  curentp = ary + oldsize;
-  for (entp = ary, ent = *ary; ent; ent = *entp) {
-   if ((newsize & PTABLE_HASH(ent->key)) != i) {
-    *entp     = ent->next;
-    ent->next = *curentp;
-    *curentp  = ent;
-    continue;
-   } else
-    entp = &ent->next;
-  }
- }
-}
-#endif /* !ptable_split */
-
-STATIC void PTABLE_PREFIX(_store)(pPTBL_ ptable * const t, const void * const key, void * const val) {
- ptable_ent *ent = ptable_find(t, key);
-
- if (ent) {
-  void *oldval = ent->val;
-  PTABLE_VAL_FREE(oldval);
-  ent->val = val;
- } else if (val) {
-  const size_t i = PTABLE_HASH(key) & t->max;
-  ent = VOID2(ptable_ent *, PerlMemShared_malloc(sizeof *ent));
-  ent->key  = key;
-  ent->val  = val;
-  ent->next = t->ary[i];
-  t->ary[i] = ent;
-  t->items++;
-  if (ent->next && t->items > t->max)
-   ptable_split(t);
- }
-}
-
-STATIC void PTABLE_PREFIX(_delete)(pPTBL_ ptable * const t, const void * const key) {
- ptable_ent *prev, *ent;
- const size_t i = PTABLE_HASH(key) & t->max;
-
- prev = NULL;
- ent  = t->ary[i];
- for (; ent; prev = ent, ent = ent->next) {
-  if (ent->key == key)
-   break;
- }
-
- if (ent) {
-  if (prev)
-   prev->next = ent->next;
-  else
-   t->ary[i]  = ent->next;
-  PTABLE_VAL_FREE(ent->val);
-  PerlMemShared_free(ent);
- }
-}
-
-#ifndef ptable_walk
-STATIC void ptable_walk(pTHX_ ptable * const t, void (*cb)(pTHX_ ptable_ent *ent, void *userdata), void *userdata) {
-#define ptable_walk(T, CB, UD) ptable_walk(aTHX_ (T), (CB), (UD))
- if (t && t->items) {
-  register ptable_ent ** const array = t->ary;
-  size_t i = t->max;
-  do {
-   ptable_ent *entry;
-   for (entry = array[i]; entry; entry = entry->next)
-    if (entry->val)
-     cb(aTHX_ entry, userdata);
-  } while (i--);
- }
-}
-#endif /* !ptable_walk */
-
-STATIC void PTABLE_PREFIX(_clear)(pPTBL_ ptable * const t) {
- if (t && t->items) {
-  register ptable_ent ** const array = t->ary;
-  size_t i = t->max;
-
-  do {
-   ptable_ent *entry = array[i];
-   while (entry) {
-    ptable_ent * const oentry = entry;
-    void *val = oentry->val;
-    entry = entry->next;
-    PTABLE_VAL_FREE(val);
-    PerlMemShared_free(oentry);
-   }
-   array[i] = NULL;
-  } while (i--);
-
-  t->items = 0;
- }
-}
-
-STATIC void PTABLE_PREFIX(_free)(pPTBL_ ptable * const t) {
- if (!t)
-  return;
- PTABLE_PREFIX(_clear)(aPTBL_ t);
- PerlMemShared_free(t->ary);
- PerlMemShared_free(t);
-}
-
-#undef pPTBL
-#undef pPTBL_
-#undef aPTBL
-#undef aPTBL_
-
-#undef PTABLE_NAME
-#undef PTABLE_VAL_FREE
index 6e749d3f97735a7d03af64a8fdcaa80be1003327..1df3739f4371ec1748d587a2f407ec0b2648ab83 100644 (file)
--- a/re_defs.h
+++ b/re_defs.h
@@ -1,20 +1,18 @@
-#ifndef REH_HAS_PERL
-# define REH_HAS_PERL(R, V, S) (PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S))))))
-#endif
+#include "xsh/caps.h" /* XSH_HAS_PERL() */
 
 EXTERN_C void     reh_save_re_context(pTHX);
 EXTERN_C regnode *reh_regnext(pTHX_ register regnode *);
 
 EXTERN_C void     reh_save_re_context(pTHX);
 EXTERN_C regnode *reh_regnext(pTHX_ register regnode *);
-#if REH_HAS_PERL(5, 11, 0)
+#if XSH_HAS_PERL(5, 11, 0)
 EXTERN_C REGEXP  *reh_pregcomp(pTHX_ SV * const, const U32);
 #else
 EXTERN_C REGEXP  *reh_pregcomp(pTHX_ const SV * const, const U32);
 #endif
 EXTERN_C REGEXP  *reh_pregcomp(pTHX_ SV * const, const U32);
 #else
 EXTERN_C REGEXP  *reh_pregcomp(pTHX_ const SV * const, const U32);
 #endif
-#if REH_HAS_PERL(5, 11, 2)
+#if XSH_HAS_PERL(5, 11, 2)
 EXTERN_C REGEXP  *reh_reg_temp_copy(pTHX_ REGEXP *, REGEXP *);
 #else
 EXTERN_C REGEXP  *reh_reg_temp_copy(pTHX_ REGEXP *);
 #endif
 EXTERN_C REGEXP  *reh_reg_temp_copy(pTHX_ REGEXP *, REGEXP *);
 #else
 EXTERN_C REGEXP  *reh_reg_temp_copy(pTHX_ REGEXP *);
 #endif
-#if REH_HAS_PERL(5, 15, 7)
+#if XSH_HAS_PERL(5, 15, 7)
 EXTERN_C SV      *reh__invlist_contents(pTHX_ SV* const);
 #endif
 
 EXTERN_C SV      *reh__invlist_contents(pTHX_ SV* const);
 #endif
 
diff --git a/xsh/caps.h b/xsh/caps.h
new file mode 100644 (file)
index 0000000..4559524
--- /dev/null
@@ -0,0 +1,47 @@
+#ifndef XSH_CAPS_H
+#define XSH_CAPS_H 1
+
+#define XSH_HAS_PERL(R, V, S) (PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S))))))
+
+#define XSH_HAS_PERL_BRANCH(R, V, S) (PERL_REVISION == (R) && PERL_VERSION == (V) && PERL_SUBVERSION >= (S))
+
+#define XSH_HAS_PERL_EXACT(R, V, S) ((PERL_REVISION == (R)) && (PERL_VERSION == (V)) && (PERL_SUBVERSION == (S)))
+
+#ifndef XSH_PERL_PATCHLEVEL
+# ifdef PERL_PATCHNUM
+#  define XSH_PERL_PATCHLEVEL PERL_PATCHNUM
+# else
+#  define XSH_PERL_PATCHLEVEL 0
+# endif
+#endif
+
+#define XSH_HAS_PERL_MAINT(R, V, S, P) (PERL_REVISION == (R) && PERL_VERSION == (V) && (XSH_PERL_PATCHLEVEL >= (P) || (!XSH_PERL_PATCHLEVEL && PERL_SUBVERSION >= (S))))
+
+#ifndef XSH_MULTIPLICITY
+# if defined(MULTIPLICITY)
+#  define XSH_MULTIPLICITY 1
+# else
+#  define XSH_MULTIPLICITY 0
+# endif
+#endif
+#if XSH_MULTIPLICITY
+# ifndef PERL_IMPLICIT_CONTEXT
+#  error MULTIPLICITY builds must set PERL_IMPLICIT_CONTEXT
+# endif
+# ifndef tTHX
+#  define tTHX PerlInterpreter*
+# endif
+#endif
+
+#if XSH_MULTIPLICITY && defined(USE_ITHREADS) && defined(dMY_CXT) && defined(MY_CXT) && defined(START_MY_CXT) && defined(MY_CXT_INIT) && (defined(MY_CXT_CLONE) || defined(dMY_CXT_SV))
+# define XSH_THREADSAFE 1
+#else
+# define XSH_THREADSAFE 0
+#endif
+
+/* Safe unless stated otherwise in Makefile.PL */
+#ifndef XSH_FORKSAFE
+# define XSH_FORKSAFE 1
+#endif
+
+#endif /* XSH_CAPS_H */
diff --git a/xsh/ptable.h b/xsh/ptable.h
new file mode 100644 (file)
index 0000000..af2e168
--- /dev/null
@@ -0,0 +1,466 @@
+/* This is a pointer table implementation essentially copied from the ptr_table
+ * implementation in perl's sv.c, except that it has been modified to use memory
+ * shared across threads.
+ * Copyright goes to the original authors, bug reports to me. */
+
+/* This header is designed to be included several times with different
+ * definitions for PTABLE_NAME and PTABLE_VAL_ALLOC/FREE(). */
+
+#include "util.h" /* VOID2(), XSH_ASSERT(), xPMS */
+
+/* --- Configuration ------------------------------------------------------- */
+
+#ifndef PTABLE_USE_DEFAULT
+# define PTABLE_USE_DEFAULT 0
+#endif
+
+#if PTABLE_USE_DEFAULT
+# if defined(PTABLE_VAL_ALLOC) || defined(PTABLE_VAL_FREE)
+#  error the default ptable is only available when PTABLE_VAL_ALLOC/FREE are unset
+# endif
+# undef  PTABLE_NAME
+# define PTABLE_NAME ptable_default
+# undef  PTABLE_VAL_NEED_CONTEXT
+# define PTABLE_VAL_NEED_CONTEXT 0
+#else
+# ifndef PTABLE_NAME
+#  error PTABLE_NAME must be defined
+# endif
+# ifndef PTABLE_VAL_NEED_CONTEXT
+#  define PTABLE_VAL_NEED_CONTEXT 1
+# endif
+#endif
+
+#ifndef PTABLE_JOIN
+# define PTABLE_PASTE(A, B) A ## B
+# define PTABLE_JOIN(A, B)  PTABLE_PASTE(A, B)
+#endif
+
+#ifndef PTABLE_PREFIX
+# define PTABLE_PREFIX(X) PTABLE_JOIN(PTABLE_NAME, X)
+#endif
+
+#ifndef PTABLE_NEED_SPLICE
+# define PTABLE_NEED_SPLICE 0
+#endif
+
+#ifndef PTABLE_NEED_WALK
+# define PTABLE_NEED_WALK 0
+#endif
+
+#ifndef PTABLE_NEED_STORE
+# define PTABLE_NEED_STORE 1
+#endif
+
+#ifndef PTABLE_NEED_VIVIFY
+# define PTABLE_NEED_VIVIFY 0
+#elif PTABLE_NEED_VIVIFY
+# undef  PTABLE_NEED_VIVIFY
+# ifndef PTABLE_VAL_ALLOC
+#  error need to define PTABLE_VAL_ALLOC() to use ptable_vivify()
+# endif
+# define PTABLE_NEED_VIVIFY 1
+#endif
+
+#ifndef PTABLE_NEED_DELETE
+# define PTABLE_NEED_DELETE 1
+#endif
+
+#ifndef PTABLE_NEED_CLEAR
+# define PTABLE_NEED_CLEAR 1
+#endif
+
+#undef PTABLE_NEED_ENT_VIVIFY
+#if PTABLE_NEED_SPLICE || PTABLE_NEED_STORE || PTABLE_NEED_VIVIFY
+# define PTABLE_NEED_ENT_VIVIFY 1
+#else
+# define PTABLE_NEED_ENT_VIVIFY 0
+#endif
+
+#undef PTABLE_NEED_ENT_DETACH
+#if PTABLE_NEED_SPLICE || PTABLE_NEED_DELETE
+# define PTABLE_NEED_ENT_DETACH 1
+#else
+# define PTABLE_NEED_ENT_DETACH 0
+#endif
+
+/* ... Context for ptable_*() functions calling PTABLE_VAL_ALLOC/FREE() .... */
+
+#undef pPTBL
+#undef pPTBL_
+#undef aPTBL
+#undef aPTBL_
+
+#if PTABLE_VAL_NEED_CONTEXT
+# define pPTBL  pTHX
+# define pPTBL_ pTHX_
+# define aPTBL  aTHX
+# define aPTBL_ aTHX_
+#else
+# define pPTBL  pPMS
+# define pPTBL_ pPMS_
+# define aPTBL  aPMS
+# define aPTBL_ aPMS_
+#endif
+
+/* --- <ptable> struct ----------------------------------------------------- */
+
+#ifndef ptable_ent
+typedef struct ptable_ent {
+ struct ptable_ent *next;
+ const void *       key;
+ void *             val;
+} ptable_ent;
+#define ptable_ent ptable_ent
+#endif /* !ptable_ent */
+
+#ifndef ptable
+typedef struct ptable {
+ ptable_ent **ary;
+ size_t       max;
+ size_t       items;
+} ptable;
+#define ptable ptable
+#endif /* !ptable */
+
+/* --- Private interface --------------------------------------------------- */
+
+#ifndef PTABLE_HASH
+# define PTABLE_HASH(ptr) \
+     ((PTR2UV(ptr) >> 3) ^ (PTR2UV(ptr) >> (3 + 7)) ^ (PTR2UV(ptr) >> (3 + 17)))
+#endif
+
+#ifndef ptable_bucket
+# define ptable_bucket(T, K) (PTABLE_HASH(K) & (T)->max)
+#endif
+
+#ifndef ptable_ent_find
+static ptable_ent *ptable_ent_find(const ptable *t, const void *key) {
+#define ptable_ent_find ptable_ent_find
+ ptable_ent  *ent;
+ const size_t idx = ptable_bucket(t, key);
+
+ ent = t->ary[idx];
+ for (; ent; ent = ent->next) {
+  if (ent->key == key)
+   return ent;
+ }
+
+ return NULL;
+}
+#endif /* !ptable_ent_find */
+
+#if PTABLE_NEED_ENT_VIVIFY
+
+#ifndef ptable_split
+static void ptable_split(pPMS_ ptable *t) {
+#define ptable_split(T) ptable_split(aPMS_ (T))
+ ptable_ent      **ary = t->ary;
+ const size_t old_size = t->max + 1;
+ size_t       new_size = old_size * 2;
+ size_t       i;
+
+ ary = VOID2(ptable_ent **,
+             PerlMemShared_realloc(ary, new_size * sizeof *ary));
+ Zero(ary + old_size, new_size - old_size, sizeof *ary);
+ t->max = --new_size;
+ t->ary = ary;
+
+ for (i = 0; i < old_size; i++, ary++) {
+  ptable_ent **curentp, **entp, *ent;
+
+  ent = *ary;
+  if (!ent)
+   continue;
+  entp    = ary;
+  curentp = ary + old_size;
+
+  do {
+   if ((new_size & PTABLE_HASH(ent->key)) != i) {
+    *entp     = ent->next;
+    ent->next = *curentp;
+    *curentp  = ent;
+   } else {
+    entp = &ent->next;
+   }
+   ent = *entp;
+  } while (ent);
+ }
+}
+#endif /* !ptable_split */
+
+#ifndef ptable_ent_vivify
+static ptable_ent *ptable_ent_vivify(pPMS_ ptable *t, const void *key) {
+#define ptable_ent_vivify(T, K) ptable_ent_vivify(aPMS_ (T), (K))
+ ptable_ent  *ent;
+ const size_t idx = ptable_bucket(t, key);
+
+ ent = t->ary[idx];
+ for (; ent; ent = ent->next) {
+  if (ent->key == key)
+   return ent;
+ }
+
+ ent = VOID2(ptable_ent *, PerlMemShared_malloc(sizeof *ent));
+
+ ent->key    = key;
+ ent->val    = NULL;
+ ent->next   = t->ary[idx];
+ t->ary[idx] = ent;
+
+ t->items++;
+ if (ent->next && t->items > t->max)
+  ptable_split(t);
+
+ return ent;
+}
+#endif /* !ptable_ent_vivify */
+
+#endif /* PTABLE_NEED_ENT_VIVIFY */
+
+#if PTABLE_NEED_ENT_DETACH
+
+#ifndef ptable_ent_detach
+static ptable_ent *ptable_ent_detach(ptable *t, const void *key) {
+#define ptable_ent_detach ptable_ent_detach
+ ptable_ent  *prev, *ent;
+ const size_t idx = ptable_bucket(t, key);
+
+ prev = NULL;
+ ent  = t->ary[idx];
+ for (; ent; prev = ent, ent = ent->next) {
+  if (ent->key == key) {
+   if (prev)
+    prev->next  = ent->next;
+   else
+    t->ary[idx] = ent->next;
+   break;
+  }
+ }
+
+ return ent;
+}
+#endif /* !ptable_ent_detach */
+
+#endif /* PTABLE_NEED_ENT_DETACH */
+
+/* --- Public interface ---------------------------------------------------- */
+
+/* ... Common symbols ...................................................... */
+
+#ifndef ptable_new
+static ptable *ptable_new(pPMS_ size_t init_buckets) {
+#define ptable_new(B) ptable_new(aPMS_ (B))
+ ptable *t;
+
+ if (init_buckets < 4) {
+  init_buckets = 4;
+ } else {
+  init_buckets--;
+  init_buckets |= init_buckets >> 1;
+  init_buckets |= init_buckets >> 2;
+  init_buckets |= init_buckets >> 4;
+  init_buckets |= init_buckets >> 8;
+  init_buckets |= init_buckets >> 16;
+  if (sizeof(init_buckets) > 4)
+   init_buckets |= init_buckets >> 32;
+  init_buckets++;
+ }
+
+ XSH_ASSERT(init_buckets >= 4 && ((init_buckets & (init_buckets - 1)) == 0));
+
+ t        = VOID2(ptable *, PerlMemShared_malloc(sizeof *t));
+ t->max   = init_buckets - 1;
+ t->items = 0;
+ t->ary   = VOID2(ptable_ent **,
+                              PerlMemShared_calloc(t->max + 1, sizeof *t->ary));
+ return t;
+}
+#endif /* !ptable_new */
+
+#ifndef ptable_fetch
+static void *ptable_fetch(const ptable *t, const void *key) {
+#define ptable_fetch ptable_fetch
+ const ptable_ent *ent = ptable_ent_find(t, key);
+
+ return ent ? ent->val : NULL;
+}
+#endif /* !ptable_fetch */
+
+#if PTABLE_NEED_SPLICE
+
+#ifndef ptable_splice
+static void *ptable_splice(pPMS_ ptable *t, const void *key, void *new_val) {
+#define ptable_splice(T, K, V) ptable_splice(aPMS_ (T), (K), (V))
+ ptable_ent *ent;
+ void       *old_val = NULL;
+
+ if (new_val) {
+  ent      = ptable_ent_vivify(t, key);
+  old_val  = ent->val;
+  ent->val = new_val;
+ } else {
+  ent = ptable_ent_detach(t, key);
+  if (ent) {
+   old_val = ent->val;
+   PerlMemShared_free(ent);
+  }
+ }
+
+ return old_val;
+}
+#endif /* !ptable_splice */
+
+#endif /* PTABLE_NEED_SPLICE */
+
+#if PTABLE_NEED_WALK
+
+#ifndef ptable_walk
+static void ptable_walk(pTHX_ ptable *t, void (*cb)(pTHX_ ptable_ent *ent, void *userdata), void *userdata) {
+#define ptable_walk(T, CB, UD) ptable_walk(aTHX_ (T), (CB), (UD))
+ if (t && t->items) {
+  register ptable_ent **array = t->ary;
+  size_t i = t->max;
+  do {
+   ptable_ent *entry;
+   for (entry = array[i]; entry; entry = entry->next)
+    if (entry->val)
+     cb(aTHX_ entry, userdata);
+  } while (i--);
+ }
+}
+#endif /* !ptable_walk */
+
+#endif /* PTABLE_NEED_WALK */
+
+/* ... Specialized symbols ................................................. */
+
+#if PTABLE_NEED_STORE
+
+#if !PTABLE_USE_DEFAULT || !defined(ptable_default_store)
+static void PTABLE_PREFIX(_store)(pPTBL_ ptable *t, const void *key, void *val){
+ ptable_ent *ent = ptable_ent_vivify(t, key);
+
+#ifdef PTABLE_VAL_FREE
+ PTABLE_VAL_FREE(ent->val);
+#endif
+
+ ent->val = val;
+
+ return;
+}
+# if PTABLE_USE_DEFAULT
+#  define ptable_default_store ptable_default_store
+# endif
+#endif /* !PTABLE_USE_DEFAULT || !defined(ptable_default_store) */
+
+#endif /* PTABLE_NEED_STORE */
+
+#if PTABLE_NEED_VIVIFY
+
+#if !PTABLE_USE_DEFAULT || !defined(ptable_default_vivify)
+static void *PTABLE_PREFIX(_vivify)(pPTBL_ ptable *t, const void *key) {
+ ptable_ent *ent = ptable_ent_vivify(t, key);
+
+ if (!ent->val) {
+  PTABLE_VAL_ALLOC(ent->val);
+ }
+
+ return ent->val;
+}
+# if PTABLE_USE_DEFAULT
+#  define ptable_default_vivify ptable_default_vivify
+# endif
+#endif /* !PTABLE_USE_DEFAULT || !defined(ptable_default_vivify) */
+
+#endif /* PTABLE_NEED_VIVIFY */
+
+#if PTABLE_NEED_DELETE
+
+#if !PTABLE_USE_DEFAULT || !defined(ptable_default_delete)
+static void PTABLE_PREFIX(_delete)(pPTBL_ ptable *t, const void *key) {
+ ptable_ent *ent = ptable_ent_detach(t, key);
+
+#ifdef PTABLE_VAL_FREE
+ if (ent) {
+  PTABLE_VAL_FREE(ent->val);
+ }
+#endif
+
+ PerlMemShared_free(ent);
+}
+# if PTABLE_USE_DEFAULT
+#  define ptable_default_delete ptable_default_delete
+# endif
+#endif /* !PTABLE_USE_DEFAULT || !defined(ptable_default_delete) */
+
+#endif /* PTABLE_NEED_DELETE */
+
+#if PTABLE_NEED_CLEAR
+
+#if !PTABLE_USE_DEFAULT || !defined(ptable_default_clear)
+static void PTABLE_PREFIX(_clear)(pPTBL_ ptable *t) {
+ if (t && t->items) {
+  register ptable_ent **array = t->ary;
+  size_t idx = t->max;
+
+  do {
+   ptable_ent *entry = array[idx];
+   while (entry) {
+    ptable_ent *nentry = entry->next;
+#ifdef PTABLE_VAL_FREE
+    PTABLE_VAL_FREE(entry->val);
+#endif
+    PerlMemShared_free(entry);
+    entry = nentry;
+   }
+   array[idx] = NULL;
+  } while (idx--);
+
+  t->items = 0;
+ }
+}
+# if PTABLE_USE_DEFAULT
+#  define ptable_default_clear ptable_default_clear
+# endif
+#endif /* !PTABLE_USE_DEFAULT || !defined(ptable_default_clear) */
+
+#endif /* PTABLE_NEED_CLEAR */
+
+#if !PTABLE_USE_DEFAULT || !defined(ptable_default_free)
+static void PTABLE_PREFIX(_free)(pPTBL_ ptable *t) {
+ if (!t)
+  return;
+ PTABLE_PREFIX(_clear)(aPTBL_ t);
+ PerlMemShared_free(t->ary);
+ PerlMemShared_free(t);
+}
+# if PTABLE_USE_DEFAULT
+#  define ptable_default_free ptable_default_free
+# endif
+#endif /* !PTABLE_USE_DEFAULT || !defined(ptable_default_free) */
+
+/* --- Cleanup ------------------------------------------------------------- */
+
+#undef PTABLE_WAS_DEFAULT
+#if PTABLE_USE_DEFAULT
+# define PTABLE_WAS_DEFAULT 1
+#else
+# define PTABLE_WAS_DEFAULT 0
+#endif
+
+#undef PTABLE_NAME
+#undef PTABLE_VAL_ALLOC
+#undef PTABLE_VAL_FREE
+#undef PTABLE_VAL_NEED_CONTEXT
+#undef PTABLE_USE_DEFAULT
+
+#undef PTABLE_NEED_SPLICE
+#undef PTABLE_NEED_WALK
+#undef PTABLE_NEED_STORE
+#undef PTABLE_NEED_VIVIFY
+#undef PTABLE_NEED_DELETE
+#undef PTABLE_NEED_CLEAR
+
+#undef PTABLE_NEED_ENT_VIVIFY
+#undef PTABLE_NEED_ENT_DETACH
diff --git a/xsh/threads.h b/xsh/threads.h
new file mode 100644 (file)
index 0000000..b72c63b
--- /dev/null
@@ -0,0 +1,501 @@
+#ifndef XSH_THREADS_H
+#define XSH_THREADS_H 1
+
+#include "caps.h" /* XSH_HAS_PERL(), XSH_THREADSAFE */
+#include "util.h" /* XSH_PACKAGE, dNOOP, NOOP */
+
+#ifndef XSH_THREADS_COMPILE_TIME_PROTECTION
+# define XSH_THREADS_COMPILE_TIME_PROTECTION 0
+#endif
+
+#ifndef XSH_THREADS_USER_CONTEXT
+# define XSH_THREADS_USER_CONTEXT 1
+#endif
+
+#ifndef XSH_THREADS_USER_GLOBAL_SETUP
+# define XSH_THREADS_USER_GLOBAL_SETUP 1
+#endif
+
+#ifndef XSH_THREADS_USER_LOCAL_SETUP
+# define XSH_THREADS_USER_LOCAL_SETUP 1
+#endif
+
+#ifndef XSH_THREADS_USER_LOCAL_TEARDOWN
+# define XSH_THREADS_USER_LOCAL_TEARDOWN 1
+#endif
+
+#ifndef XSH_THREADS_USER_GLOBAL_TEARDOWN
+# define XSH_THREADS_USER_GLOBAL_TEARDOWN 1
+#endif
+
+#ifndef XSH_THREADS_PEEP_CONTEXT
+# define XSH_THREADS_PEEP_CONTEXT 0
+#endif
+
+#ifndef XSH_THREADS_HINTS_CONTEXT
+# define XSH_THREADS_HINTS_CONTEXT 0
+#endif
+
+#ifndef XSH_THREADS_USER_CLONE_NEEDS_DUP
+# define XSH_THREADS_USER_CLONE_NEEDS_DUP 0
+#endif
+
+#if XSH_THREADSAFE && (XSH_THREADS_HINTS_CONTEXT || XSH_THREADS_USER_CLONE_NEEDS_DUP)
+# define XSH_THREADS_CLONE_NEEDS_DUP 1
+#else
+# define XSH_THREADS_CLONE_NEEDS_DUP 0
+#endif
+
+#if defined(XSH_OPS_H) && (!XSH_THREADS_GLOBAL_SETUP || !XSH_THREADS_GLOBAL_TEARDOWN)
+# error settting up hook check functions require global setup/teardown
+#endif
+
+#ifndef XSH_THREADS_NEED_TEARDOWN_LATE
+# define XSH_THREADS_NEED_TEARDOWN_LATE 0
+#endif
+
+#if XSH_THREADS_NEED_TEARDOWN_LATE && (!XSH_THREADS_USER_LOCAL_TEARDOWN || !XSH_THREADS_USER_GLOBAL_TEARDOWN)
+# error you need to declare local or global teardown handlers to use the late teardown feature
+#endif
+
+#if XSH_THREADSAFE
+# ifndef MY_CXT_CLONE
+#  define MY_CXT_CLONE \
+    dMY_CXT_SV;                                                      \
+    my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1)); \
+    Copy(INT2PTR(my_cxt_t*, SvUV(my_cxt_sv)), my_cxtp, 1, my_cxt_t); \
+    sv_setuv(my_cxt_sv, PTR2UV(my_cxtp))
+# endif
+#else
+# undef  dMY_CXT
+# define dMY_CXT      dNOOP
+# undef  MY_CXT
+# define MY_CXT       xsh_globaldata
+# undef  START_MY_CXT
+# define START_MY_CXT static my_cxt_t MY_CXT;
+# undef  MY_CXT_INIT
+# define MY_CXT_INIT  NOOP
+# undef  MY_CXT_CLONE
+# define MY_CXT_CLONE NOOP
+#endif
+
+#if XSH_THREADSAFE
+/* We must use preexistent global mutexes or we will never be able to destroy
+ * them. */
+# if XSH_HAS_PERL(5, 9, 3)
+#  define XSH_LOADED_LOCK   MUTEX_LOCK(&PL_my_ctx_mutex)
+#  define XSH_LOADED_UNLOCK MUTEX_UNLOCK(&PL_my_ctx_mutex)
+# else
+#  define XSH_LOADED_LOCK   OP_REFCNT_LOCK
+#  define XSH_LOADED_UNLOCK OP_REFCNT_UNLOCK
+# endif
+#else
+# define XSH_LOADED_LOCK   NOOP
+# define XSH_LOADED_UNLOCK NOOP
+#endif
+
+static I32 xsh_loaded = 0;
+
+#if XSH_THREADSAFE && XSH_THREADS_COMPILE_TIME_PROTECTION
+
+#define PTABLE_USE_DEFAULT 1
+
+#include "ptable.h"
+
+#define ptable_loaded_store(T, K, V) ptable_default_store(aPTBL_ (T), (K), (V))
+#define ptable_loaded_delete(T, K)   ptable_default_delete(aPTBL_ (T), (K))
+#define ptable_loaded_free(T)        ptable_default_free(aPTBL_ (T))
+
+static ptable *xsh_loaded_cxts = NULL;
+
+static int xsh_is_loaded(pTHX_ void *cxt) {
+#define xsh_is_loaded(C) xsh_is_loaded(aTHX_ (C))
+ int res = 0;
+
+ XSH_LOADED_LOCK;
+ if (xsh_loaded_cxts && ptable_fetch(xsh_loaded_cxts, cxt))
+  res = 1;
+ XSH_LOADED_UNLOCK;
+
+ return res;
+}
+
+static int xsh_set_loaded_locked(pTHX_ void *cxt) {
+#define xsh_set_loaded_locked(C) xsh_set_loaded_locked(aTHX_ (C))
+ int global_setup = 0;
+
+ if (xsh_loaded <= 0) {
+  XSH_ASSERT(xsh_loaded == 0);
+  XSH_ASSERT(!xsh_loaded_cxts);
+  xsh_loaded_cxts = ptable_new(4);
+  global_setup   = 1;
+ }
+ ++xsh_loaded;
+ XSH_ASSERT(xsh_loaded_cxts);
+ ptable_loaded_store(xsh_loaded_cxts, cxt, cxt);
+
+ return global_setup;
+}
+
+static int xsh_clear_loaded_locked(pTHX_ void *cxt) {
+#define xsh_clear_loaded_locked(C) xsh_clear_loaded_locked(aTHX_ (C))
+ int global_teardown = 0;
+
+ if (xsh_loaded > 1) {
+  XSH_ASSERT(xsh_loaded_cxts);
+  ptable_loaded_delete(xsh_loaded_cxts, cxt);
+  --xsh_loaded;
+ } else if (xsh_loaded_cxts) {
+  XSH_ASSERT(xsh_loaded == 1);
+  ptable_loaded_free(xsh_loaded_cxts);
+  xsh_loaded_cxts = NULL;
+  xsh_loaded      = 0;
+  global_teardown = 1;
+ }
+
+ return global_teardown;
+}
+
+#else  /*  XSH_THREADS_COMPILE_TIME_PROTECTION */
+
+#define xsh_is_loaded_locked(C)    (xsh_loaded > 0)
+#define xsh_set_loaded_locked(C)   ((xsh_loaded++ <= 0) ? 1 : 0)
+#define xsh_clear_loaded_locked(C) ((--xsh_loaded <= 0) ? 1 : 0)
+
+#if XSH_THREADSAFE
+
+static int xsh_is_loaded(pTHX_ void *cxt) {
+#define xsh_is_loaded(C) xsh_is_loaded(aTHX_ (C))
+ int res = 0;
+
+ XSH_LOADED_LOCK;
+ res = xsh_is_loaded_locked(cxt);
+ XSH_LOADED_UNLOCK;
+
+ return res;
+}
+
+#else
+
+#define xsh_is_loaded(C) xsh_is_loaded_locked(C)
+
+#endif
+
+#endif /* !XSH_THREADS_COMPILE_TIME_PROTECTION */
+
+#define MY_CXT_KEY XSH_PACKAGE "::_guts" XS_VERSION
+
+typedef struct {
+#if XSH_THREADS_USER_CONTEXT
+ xsh_user_cxt_t  cxt_user;
+#endif
+#if XSH_THREADS_PEEP_CONTEXT
+ xsh_peep_cxt_t  cxt_peep;
+#endif
+#if XSH_THREADS_HINTS_CONTEXT
+ xsh_hints_cxt_t cxt_hints;
+#endif
+#if XSH_THREADS_CLONE_NEEDS_DUP
+ tTHX            owner;
+#endif
+#if !(XSH_THREADS_USER_CONTEXT || XSH_THREADS_PEEP_CONTEXT || XSH_THREADS_HINTS_CONTEXT || XSH_THREADS_CLONE_NEEDS_DUP)
+ int             dummy;
+#endif
+} my_cxt_t;
+
+START_MY_CXT
+
+#if XSH_THREADS_USER_CONTEXT
+# define dXSH_CXT dMY_CXT
+# define XSH_CXT  (MY_CXT.cxt_user)
+#endif
+
+#if XSH_THREADS_USER_GLOBAL_SETUP
+static void xsh_user_global_setup(pTHX);
+#endif
+
+#if XSH_THREADS_USER_LOCAL_SETUP
+# if XSH_THREADS_USER_CONTEXT
+static void xsh_user_local_setup(pTHX_ xsh_user_cxt_t *cxt);
+# else
+static void xsh_user_local_setup(pTHX);
+# endif
+#endif
+
+#if XSH_THREADS_USER_LOCAL_TEARDOWN
+# if XSH_THREADS_USER_CONTEXT
+static void xsh_user_local_teardown(pTHX_ xsh_user_cxt_t *cxt);
+# else
+static void xsh_user_local_teardown(pTHX);
+# endif
+#endif
+
+#if XSH_THREADS_USER_GLOBAL_TEARDOWN
+static void xsh_user_global_teardown(pTHX);
+#endif
+
+#if XSH_THREADSAFE && XSH_THREADS_USER_CONTEXT
+# if XSH_THREADS_USER_CLONE_NEEDS_DUP
+static void xsh_user_clone(pTHX_ const xsh_user_cxt_t *old_cxt, xsh_user_cxt_t *new_cxt, CLONE_PARAMS *params);
+# else
+static void xsh_user_clone(pTHX_ const xsh_user_cxt_t *old_cxt, xsh_user_cxt_t *new_cxt);
+# endif
+#endif
+
+#if XSH_THREADS_PEEP_CONTEXT
+static xsh_peep_cxt_t *xsh_peep_get_cxt(pTHX) {
+ dMY_CXT;
+ XSH_ASSERT(xsh_is_loaded(&MY_CXT));
+ return &MY_CXT.cxt_peep;
+}
+#endif
+
+#if XSH_THREADS_HINTS_CONTEXT
+static xsh_hints_cxt_t *xsh_hints_get_cxt(pTHX) {
+ dMY_CXT;
+ XSH_ASSERT(xsh_is_loaded(&MY_CXT));
+ return &MY_CXT.cxt_hints;
+}
+#endif
+
+#if XSH_THREADS_NEED_TEARDOWN_LATE
+
+typedef void (*xsh_teardown_late_cb)(pTHX_ void *ud);
+
+static int xsh_teardown_late_simple_free(pTHX_ SV *sv, MAGIC *mg) {
+ xsh_teardown_late_cb cb;
+
+ cb = DPTR2FPTR(xsh_teardown_late_cb, mg->mg_ptr);
+
+ XSH_LOADED_LOCK;
+ if (xsh_loaded == 0)
+  cb(aTHX_ NULL);
+ XSH_LOADED_UNLOCK;
+
+ return 0;
+}
+
+static MGVTBL xsh_teardown_late_simple_vtbl = {
+ 0,
+ 0,
+ 0,
+ 0,
+ xsh_teardown_late_simple_free
+#if MGf_COPY
+ , 0
+#endif
+#if MGf_DUP
+ , 0
+#endif
+#if MGf_LOCAL
+ , 0
+#endif
+};
+
+typedef struct {
+ xsh_teardown_late_cb  cb;
+ void                 *ud;
+} xsh_teardown_late_token;
+
+static int xsh_teardown_late_arg_free(pTHX_ SV *sv, MAGIC *mg) {
+ xsh_teardown_late_token *tok;
+
+ tok = (xsh_teardown_late_token *) mg->mg_ptr;
+
+ XSH_LOADED_LOCK;
+ if (xsh_loaded == 0)
+  tok->cb(aTHX_ tok->ud);
+ XSH_LOADED_UNLOCK;
+
+ PerlMemShared_free(tok);
+
+ return 0;
+}
+
+static MGVTBL xsh_teardown_late_arg_vtbl = {
+ 0,
+ 0,
+ 0,
+ 0,
+ xsh_teardown_late_arg_free
+#if MGf_COPY
+ , 0
+#endif
+#if MGf_DUP
+ , 0
+#endif
+#if MGf_LOCAL
+ , 0
+#endif
+};
+
+static void xsh_teardown_late_register(pTHX_ xsh_teardown_late_cb cb, void *ud){
+#define xsh_teardown_late_register(CB, UD) xsh_teardown_late_register(aTHX_ (CB), (UD))
+ void *ptr;
+
+ if (!ud) {
+  ptr = FPTR2DPTR(void *, cb);
+ } else {
+  xsh_teardown_late_token *tok;
+
+  tok     = PerlMemShared_malloc(sizeof *tok);
+  tok->cb = cb;
+  tok->ud = ud;
+
+  ptr = tok;
+ }
+
+ if (!PL_strtab)
+  PL_strtab = newHV();
+
+ sv_magicext((SV *) PL_strtab, NULL, PERL_MAGIC_ext,
+             ud ? &xsh_teardown_late_arg_vtbl : &xsh_teardown_late_simple_vtbl,
+             ptr, 0);
+
+ return;
+}
+
+#endif /* XSH_THREADS_NEED_TEARDOWN_LATE */
+
+static void xsh_teardown(pTHX_ void *root) {
+ dMY_CXT;
+
+#if XSH_THREADS_USER_LOCAL_TEARDOWN
+# if XSH_THREADS_USER_CONTEXT
+ xsh_user_local_teardown(aTHX_ &XSH_CXT);
+# else
+ xsh_user_local_teardown(aTHX);
+# endif
+#endif
+
+#if XSH_THREADS_PEEP_CONTEXT
+ xsh_peep_local_teardown(aTHX_ &MY_CXT.cxt_peep);
+#endif
+
+#if XSH_THREADS_HINTS_CONTEXT
+ xsh_hints_local_teardown(aTHX_ &MY_CXT.cxt_hints);
+#endif
+
+ XSH_LOADED_LOCK;
+
+ if (xsh_clear_loaded_locked(&MY_CXT)) {
+#if XSH_THREADS_USER_GLOBAL_TEARDOWN
+  xsh_user_global_teardown(aTHX);
+#endif
+
+#if XSH_THREADS_HINTS_CONTEXT
+  xsh_hints_global_teardown(aTHX);
+#endif
+ }
+
+ XSH_LOADED_UNLOCK;
+
+ return;
+}
+
+static void xsh_setup(pTHX) {
+#define xsh_setup() xsh_setup(aTHX)
+ MY_CXT_INIT; /* Takes/release PL_my_ctx_mutex */
+
+ XSH_LOADED_LOCK;
+
+ if (xsh_set_loaded_locked(&MY_CXT)) {
+#if XSH_THREADS_HINTS_CONTEXT
+  xsh_hints_global_setup(aTHX);
+#endif
+
+#if XSH_THREADS_USER_GLOBAL_SETUP
+  xsh_user_global_setup(aTHX);
+#endif
+ }
+
+ XSH_LOADED_UNLOCK;
+
+#if XSH_THREADS_CLONE_NEEDS_DUP
+ MY_CXT.owner = aTHX;
+#endif
+
+#if XSH_THREADS_HINTS_CONTEXT
+ xsh_hints_local_setup(aTHX_ &MY_CXT.cxt_hints);
+#endif
+
+#if XSH_THREADS_PEEP_CONTEXT
+ xsh_peep_local_setup(aTHX_ &MY_CXT.cxt_peep);
+#endif
+
+#if XSH_THREADS_USER_LOCAL_SETUP
+# if XSH_THREADS_USER_CONTEXT
+ xsh_user_local_setup(aTHX_ &XSH_CXT);
+# else
+ xsh_user_local_setup(aTHX);
+# endif
+#endif
+
+ call_atexit(xsh_teardown, NULL);
+
+ return;
+}
+
+#if XSH_THREADSAFE
+
+static void xsh_clone(pTHX) {
+#define xsh_clone() xsh_clone(aTHX)
+ const my_cxt_t *old_cxt;
+ my_cxt_t       *new_cxt;
+
+ {
+  dMY_CXT;
+  old_cxt = &MY_CXT;
+ }
+
+ {
+  int global_setup;
+
+  MY_CXT_CLONE;
+  new_cxt = &MY_CXT;
+
+  XSH_LOADED_LOCK;
+  global_setup = xsh_set_loaded_locked(new_cxt);
+  XSH_ASSERT(!global_setup);
+  XSH_LOADED_UNLOCK;
+
+#if XSH_THREADS_CLONE_NEEDS_DUP
+  new_cxt->owner = aTHX;
+#endif
+ }
+
+ {
+#if XSH_THREADS_CLONE_NEEDS_DUP
+  XSH_DUP_PARAMS_TYPE params;
+  xsh_dup_params_init(params, old_cxt->owner);
+#endif
+
+#if XSH_THREADS_PEEP_CONTEXT
+  xsh_peep_clone(aTHX_ &old_cxt->cxt_peep, &new_cxt->cxt_peep);
+#endif
+
+#if XSH_THREADS_HINTS_CONTEXT
+  xsh_hints_clone(aTHX_ &old_cxt->cxt_hints, &new_cxt->cxt_hints,
+                        xsh_dup_params_ptr(params));
+#endif
+
+#if XSH_THREADS_USER_CONTEXT
+# if XSH_THREADS_USER_CLONE_NEEDS_DUP
+  xsh_user_clone(aTHX_ &old_cxt->cxt_user, &new_cxt->cxt_user,
+                       xsh_dup_params_ptr(params));
+# else
+  xsh_user_clone(aTHX_ &old_cxt->cxt_user, &new_cxt->cxt_user);
+# endif
+#endif
+
+#if XSH_THREADS_CLONE_NEEDS_DUP
+  xsh_dup_params_deinit(params);
+#endif
+ }
+
+ return;
+}
+
+#endif /* XSH_THREADSAFE */
+
+#endif /* XSH_THREADS_H */
diff --git a/xsh/util.h b/xsh/util.h
new file mode 100644 (file)
index 0000000..dcc142c
--- /dev/null
@@ -0,0 +1,97 @@
+#ifndef XSH_UTIL_H
+#define XSH_UTIL_H 1
+
+#include "caps.h" /* XSH_HAS_PERL() */
+
+#ifndef XSH_PACKAGE
+# error XSH_PACKAGE must be defined
+#endif
+
+#define XSH_PACKAGE_LEN (sizeof(XSH_PACKAGE)-1)
+
+#ifdef DEBUGGING
+# if XSH_HAS_PERL(5, 8, 9) || XSH_HAS_PERL(5, 9, 3)
+#  define XSH_ASSERT(C) assert(C)
+# else
+#  define XSH_ASSERT(C) PERL_DEB( \
+   ((C) ? ((void) 0)           \
+        : (Perl_croak_nocontext("Assertion %s failed: file \"" __FILE__  \
+                                 "\", line %d", STRINGIFY(C), __LINE__), \
+           (void) 0)))
+# endif
+#else
+# define XSH_ASSERT(C)
+#endif
+
+#undef VOID2
+#ifdef __cplusplus
+# define VOID2(T, P) static_cast<T>(P)
+#else
+# define VOID2(T, P) (P)
+#endif
+
+#ifndef STMT_START
+# define STMT_START do
+#endif
+
+#ifndef STMT_END
+# define STMT_END while (0)
+#endif
+
+#ifndef dNOOP
+# define dNOOP
+#endif
+
+#ifndef NOOP
+# define NOOP
+#endif
+
+#if XSH_HAS_PERL(5, 13, 2)
+# define XSH_DUP_PARAMS_TYPE       CLONE_PARAMS *
+# define xsh_dup_params_init(P, O) ((P) = Perl_clone_params_new((O), aTHX))
+# define xsh_dup_params_deinit(P)  Perl_clone_params_del(P)
+# define xsh_dup_params_ptr(P)     (P)
+#else
+# define XSH_DUP_PARAMS_TYPE       CLONE_PARAMS
+# define xsh_dup_params_init(P, O) \
+      ((P).stashes = newAV()); (P).flags = 0; ((P).proto_perl = (O))
+# define xsh_dup_params_deinit(P)  SvREFCNT_dec((P).stashes)
+# define xsh_dup_params_ptr(P)     &(P)
+#endif
+#define xsh_dup(S, P)     sv_dup((S), (P))
+#define xsh_dup_inc(S, P) SvREFCNT_inc(xsh_dup((S), (P)))
+
+/* Context for PerlMemShared_*() functions */
+#ifdef PERL_IMPLICIT_SYS
+# define pPMS  pTHX
+# define pPMS_ pTHX_
+# define aPMS  aTHX
+# define aPMS_ aTHX_
+#else
+# define pPMS  void
+# define pPMS_
+# define aPMS
+# define aPMS_
+#endif
+
+#ifdef USE_ITHREADS
+# define XSH_LOCK(M)   MUTEX_LOCK(M)
+# define XSH_UNLOCK(M) MUTEX_UNLOCK(M)
+#else
+# define XSH_LOCK(M)   NOOP
+# define XSH_UNLOCK(M) NOOP
+#endif
+
+#ifndef PTR2nat
+# define PTR2nat(p) (PTRV)(p)
+#endif
+
+#ifndef DPTR2FPTR
+# define DPTR2FPTR(t,p) ((t)PTR2nat(p))
+#endif
+
+#ifndef FPTR2DPTR
+# define FPTR2DPTR(t,p) ((t)PTR2nat(p))
+#endif
+
+#endif /* XSH_UTIL_H */