README
Types.xs
lib/Lexical/Types.pm
-ptable.h
samples/basic.pl
t/00-load.t
t/09-load-threads.t
t/lib/Lexical/Types/TestRequired3Y.pm
t/lib/Test/Leaner.pm
t/lib/VPIT/TestHelpers.pm
+xsh/caps.h
+xsh/debug.h
+xsh/hints.h
+xsh/ops.h
+xsh/peep.h
+xsh/ptable.h
+xsh/threads.h
+xsh/util.h
# Threads, Windows and 5.8.x don't seem to be best friends
if ($^O eq 'MSWin32' && "$]" < 5.009) {
- push @DEFINES, '-DLT_MULTIPLICITY=0';
+ push @DEFINES, '-DXSH_MULTIPLICITY=0';
}
# Fork emulation got "fixed" in 5.10.1
if ($^O eq 'MSWin32' && "$]" < 5.010_001) {
- push @DEFINES, '-DLT_FORKSAFE=0';
+ push @DEFINES, '-DXSH_FORKSAFE=0';
}
@DEFINES = (DEFINE => join ' ', @DEFINES) if @DEFINES;
#include "perl.h"
#include "XSUB.h"
-#define __PACKAGE__ "Lexical::Types"
-#define __PACKAGE_LEN__ (sizeof(__PACKAGE__)-1)
+/* --- XS helpers ---------------------------------------------------------- */
-/* --- Compatibility wrappers ---------------------------------------------- */
-
-#define LT_HAS_PERL(R, V, S) (PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S))))))
-
-#if LT_HAS_PERL(5, 10, 0) || defined(PL_parser)
-# ifndef PL_in_my_stash
-# define PL_in_my_stash PL_parser->in_my_stash
-# endif
-#else
-# ifndef PL_in_my_stash
-# define PL_in_my_stash PL_Iin_my_stash
-# endif
-#endif
-
-#ifndef LT_WORKAROUND_REQUIRE_PROPAGATION
-# define LT_WORKAROUND_REQUIRE_PROPAGATION !LT_HAS_PERL(5, 10, 1)
-#endif
-
-#ifndef LT_HAS_RPEEP
-# define LT_HAS_RPEEP LT_HAS_PERL(5, 13, 5)
-#endif
-
-#ifndef HvNAME_get
-# define HvNAME_get(H) HvNAME(H)
-#endif
-
-#ifndef HvNAMELEN_get
-# define HvNAMELEN_get(H) strlen(HvNAME_get(H))
-#endif
-
-#ifndef OpSIBLING
-# ifdef OP_SIBLING
-# define OpSIBLING(O) OP_SIBLING(O)
-# else
-# define OpSIBLING(O) ((O)->op_sibling)
-# endif
-#endif
-
-#ifndef SvREFCNT_inc_simple_void_NN
-# define SvREFCNT_inc_simple_void_NN(S) ((void) SvREFCNT_inc(S))
-#endif
-
-#ifdef DEBUGGING
-# define LT_ASSERT(C) assert(C)
-#else
-# define LT_ASSERT(C)
-#endif
-
-/* ... Thread safety and multiplicity ...................................... */
-
-/* Safe unless stated otherwise in Makefile.PL */
-#ifndef LT_FORKSAFE
-# define LT_FORKSAFE 1
-#endif
-
-#ifndef LT_MULTIPLICITY
-# if defined(MULTIPLICITY) || defined(PERL_IMPLICIT_CONTEXT)
-# define LT_MULTIPLICITY 1
-# else
-# define LT_MULTIPLICITY 0
-# endif
-#endif
-
-#ifndef tTHX
-# define tTHX PerlInterpreter*
-#endif
-
-#if LT_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 LT_THREADSAFE 1
-# 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
-# define LT_THREADSAFE 0
-# undef dMY_CXT
-# define dMY_CXT dNOOP
-# undef MY_CXT
-# define MY_CXT lt_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
-# undef pMY_CXT
-# define pMY_CXT
-# undef pMY_CXT_
-# define pMY_CXT_
-# undef aMY_CXT
-# define aMY_CXT
-# undef aMY_CXT_
-# define aMY_CXT_
-#endif
-
-#if LT_THREADSAFE
-/* We must use preexistent global mutexes or we will never be able to destroy
- * them. */
-# if LT_HAS_PERL(5, 9, 3)
-# define LT_LOADED_LOCK MUTEX_LOCK(&PL_my_ctx_mutex)
-# define LT_LOADED_UNLOCK MUTEX_UNLOCK(&PL_my_ctx_mutex)
-# else
-# define LT_LOADED_LOCK OP_REFCNT_LOCK
-# define LT_LOADED_UNLOCK OP_REFCNT_UNLOCK
-# endif
-#else
-# define LT_LOADED_LOCK NOOP
-# define LT_LOADED_UNLOCK NOOP
-#endif
-
-#if defined(OP_CHECK_MUTEX_LOCK) && defined(OP_CHECK_MUTEX_UNLOCK)
-# define LT_CHECK_LOCK OP_CHECK_MUTEX_LOCK
-# define LT_CHECK_UNLOCK OP_CHECK_MUTEX_UNLOCK
-#elif LT_HAS_PERL(5, 9, 3)
-# define LT_CHECK_LOCK OP_REFCNT_LOCK
-# define LT_CHECK_UNLOCK OP_REFCNT_UNLOCK
-#else
-/* Before perl 5.9.3, lt_ck_*() calls are already protected by the LT_LOADED
- * mutex, which falls back to the OP_REFCNT mutex. Make sure we don't lock it
- * twice. */
-# define LT_CHECK_LOCK NOOP
-# define LT_CHECK_UNLOCK NOOP
-#endif
-
-typedef OP *(*lt_ck_t)(pTHX_ OP *);
-
-#ifdef wrap_op_checker
-
-# define lt_ck_replace(T, NC, OCP) wrap_op_checker((T), (NC), (OCP))
-
-#else
-
-static void lt_ck_replace(pTHX_ OPCODE type, lt_ck_t new_ck, lt_ck_t *old_ck_p){
-#define lt_ck_replace(T, NC, OCP) lt_ck_replace(aTHX_ (T), (NC), (OCP))
- LT_CHECK_LOCK;
- if (!*old_ck_p) {
- *old_ck_p = PL_check[type];
- PL_check[type] = new_ck;
- }
- LT_CHECK_UNLOCK;
-}
-
-#endif
-
-static void lt_ck_restore(pTHX_ OPCODE type, lt_ck_t *old_ck_p) {
-#define lt_ck_restore(T, OCP) lt_ck_restore(aTHX_ (T), (OCP))
- LT_CHECK_LOCK;
- if (*old_ck_p) {
- PL_check[type] = *old_ck_p;
- *old_ck_p = 0;
- }
- LT_CHECK_UNLOCK;
-}
-
-/* --- Helpers ------------------------------------------------------------- */
-
-/* ... Check if the module is loaded ....................................... */
-
-static I32 lt_loaded = 0;
-
-#if LT_THREADSAFE
-
-#define PTABLE_NAME ptable_loaded
-#define PTABLE_NEED_DELETE 1
-#define PTABLE_NEED_WALK 0
-
-#include "ptable.h"
-
-#define ptable_loaded_store(T, K, V) ptable_loaded_store(aPTBLMS_ (T), (K), (V))
-#define ptable_loaded_delete(T, K) ptable_loaded_delete(aPTBLMS_ (T), (K))
-#define ptable_loaded_free(T) ptable_loaded_free(aPTBLMS_ (T))
-
-static ptable *lt_loaded_cxts = NULL;
-
-#ifdef DEBUGGING
-
-static int lt_is_loaded(pTHX_ void *cxt) {
-#define lt_is_loaded(C) lt_is_loaded(aTHX_ (C))
- int res = 0;
-
- LT_LOADED_LOCK;
- if (lt_loaded_cxts && ptable_fetch(lt_loaded_cxts, cxt))
- res = 1;
- LT_LOADED_UNLOCK;
-
- return res;
-}
-
-#endif /* DEBUGGING */
-
-static int lt_set_loaded_locked(pTHX_ void *cxt) {
-#define lt_set_loaded_locked(C) lt_set_loaded_locked(aTHX_ (C))
- int global_setup = 0;
-
- if (lt_loaded <= 0) {
- LT_ASSERT(lt_loaded == 0);
- LT_ASSERT(!lt_loaded_cxts);
- lt_loaded_cxts = ptable_new();
- global_setup = 1;
- }
- ++lt_loaded;
- LT_ASSERT(lt_loaded_cxts);
- ptable_loaded_store(lt_loaded_cxts, cxt, cxt);
-
- return global_setup;
-}
-
-static int lt_clear_loaded_locked(pTHX_ void *cxt) {
-#define lt_clear_loaded_locked(C) lt_clear_loaded_locked(aTHX_ (C))
- int global_teardown = 0;
-
- if (lt_loaded > 1) {
- LT_ASSERT(lt_loaded_cxts);
- ptable_loaded_delete(lt_loaded_cxts, cxt);
- --lt_loaded;
- } else if (lt_loaded_cxts) {
- LT_ASSERT(lt_loaded == 1);
- ptable_loaded_free(lt_loaded_cxts);
- lt_loaded_cxts = NULL;
- lt_loaded = 0;
- global_teardown = 1;
- }
-
- return global_teardown;
-}
-
-#else
-
-#define lt_is_loaded(C) (lt_loaded > 0)
-#define lt_set_loaded_locked(C) ((lt_loaded++ <= 0) ? 1 : 0)
-#define lt_clear_loaded_locked(C) ((--lt_loaded <= 0) ? 1 : 0)
-
-#endif
-
-/* ... Thread-safe hints ................................................... */
-
-#if LT_WORKAROUND_REQUIRE_PROPAGATION
-
-typedef struct {
- SV *code;
- IV require_tag;
-} lt_hint_t;
-
-#define LT_HINT_STRUCT 1
-
-#define LT_HINT_CODE(H) ((H)->code)
-
-#define LT_HINT_FREE(H) { \
- lt_hint_t *h = (H); \
- SvREFCNT_dec(h->code); \
- PerlMemShared_free(h); \
-}
-
-#else /* LT_WORKAROUND_REQUIRE_PROPAGATION */
-
-typedef SV lt_hint_t;
-
-#define LT_HINT_STRUCT 0
-
-#define LT_HINT_CODE(H) (H)
-
-#define LT_HINT_FREE(H) SvREFCNT_dec(H);
-
-#endif /* !LT_WORKAROUND_REQUIRE_PROPAGATION */
-
-#if LT_THREADSAFE
-
-#define PTABLE_NAME ptable_hints
-#define PTABLE_VAL_FREE(V) LT_HINT_FREE(V)
-#define PTABLE_NEED_DELETE 0
-#define PTABLE_NEED_WALK 1
-
-#define pPTBL pTHX
-#define pPTBL_ pTHX_
-#define aPTBL aTHX
-#define aPTBL_ aTHX_
-
-#include "ptable.h"
-
-#define ptable_hints_store(T, K, V) ptable_hints_store(aTHX_ (T), (K), (V))
-#define ptable_hints_free(T) ptable_hints_free(aTHX_ (T))
-
-#endif /* LT_THREADSAFE */
-
-/* ... "Seen" pointer table ................................................ */
-
-#define PTABLE_NAME ptable_seen
-#define PTABLE_NEED_DELETE 0
-#define PTABLE_NEED_WALK 0
-
-#include "ptable.h"
-
-/* PerlMemShared_free() needs the [ap]PTBLMS_? default values */
-#define ptable_seen_store(T, K, V) ptable_seen_store(aPTBLMS_ (T), (K), (V))
-#define ptable_seen_clear(T) ptable_seen_clear(aPTBLMS_ (T))
-#define ptable_seen_free(T) ptable_seen_free(aPTBLMS_ (T))
+#define XSH_PACKAGE "Lexical::Types"
-/* ... Global data ......................................................... */
+#include "xsh/caps.h"
+#include "xsh/util.h"
+#include "xsh/ops.h"
+#include "xsh/peep.h"
-#define MY_CXT_KEY __PACKAGE__ "::_guts" XS_VERSION
+/* ... Lexical hints ....................................................... */
-typedef struct {
- peep_t old_peep;
- ptable *seen; /* It really is a ptable_seen */
-#if LT_THREADSAFE
- ptable *tbl; /* It really is a ptable_hints */
- tTHX owner;
-#endif
- SV *default_meth;
-} my_cxt_t;
+#define XSH_HINTS_TYPE_SV 1
-START_MY_CXT
+#include "xsh/hints.h"
-/* ... Cloning global data ................................................. */
+#define lt_hint() xsh_hints_detag(xsh_hints_fetch())
-#if LT_THREADSAFE
+/* ... Thread-local storage ................................................ */
typedef struct {
- ptable *tbl;
-#if LT_HAS_PERL(5, 13, 2)
- CLONE_PARAMS *params;
-#else
- CLONE_PARAMS params;
-#endif
-} lt_ptable_clone_ud;
-
-#if LT_HAS_PERL(5, 13, 2)
-# define lt_ptable_clone_ud_init(U, T, O) \
- (U).tbl = (T); \
- (U).params = Perl_clone_params_new((O), aTHX)
-# define lt_ptable_clone_ud_deinit(U) Perl_clone_params_del((U).params)
-# define lt_dup_inc(S, U) SvREFCNT_inc(sv_dup((S), (U)->params))
-#else
-# define lt_ptable_clone_ud_init(U, T, O) \
- (U).tbl = (T); \
- (U).params.stashes = newAV(); \
- (U).params.flags = 0; \
- (U).params.proto_perl = (O)
-# define lt_ptable_clone_ud_deinit(U) SvREFCNT_dec((U).params.stashes)
-# define lt_dup_inc(S, U) SvREFCNT_inc(sv_dup((S), &((U)->params)))
-#endif
-
-static void lt_ptable_clone(pTHX_ ptable_ent *ent, void *ud_) {
- lt_ptable_clone_ud *ud = ud_;
- lt_hint_t *h1 = ent->val;
- lt_hint_t *h2;
-
-#if LT_HINT_STRUCT
-
- h2 = PerlMemShared_malloc(sizeof *h2);
- h2->code = lt_dup_inc(h1->code, ud);
-#if LT_WORKAROUND_REQUIRE_PROPAGATION
- h2->require_tag = PTR2IV(lt_dup_inc(INT2PTR(SV *, h1->require_tag), ud));
-#endif
-
-#else /* LT_HINT_STRUCT */
-
- h2 = lt_dup_inc(h1, ud);
-
-#endif /* !LT_HINT_STRUCT */
-
- ptable_hints_store(ud->tbl, ent->key, h2);
-}
+ SV *default_meth;
+} xsh_user_cxt_t;
-#endif /* LT_THREADSAFE */
+#define XSH_THREADS_COMPILE_TIME_PROTECTION 1
+#define XSH_THREADS_USER_CLONE_NEEDS_DUP 1
-/* ... Hint tags ........................................................... */
-
-#if LT_WORKAROUND_REQUIRE_PROPAGATION
-
-static IV lt_require_tag(pTHX) {
-#define lt_require_tag() lt_require_tag(aTHX)
- const CV *cv, *outside;
-
- cv = PL_compcv;
-
- if (!cv) {
- /* If for some reason the pragma is operational at run-time, try to discover
- * the current cv in use. */
- const PERL_SI *si;
-
- for (si = PL_curstackinfo; si; si = si->si_prev) {
- I32 cxix;
-
- for (cxix = si->si_cxix; cxix >= 0; --cxix) {
- const PERL_CONTEXT *cx = si->si_cxstack + cxix;
-
- switch (CxTYPE(cx)) {
- case CXt_SUB:
- case CXt_FORMAT:
- /* The propagation workaround is only needed up to 5.10.0 and at that
- * time format and sub contexts were still identical. And even later the
- * cv members offsets should have been kept the same. */
- cv = cx->blk_sub.cv;
- goto get_enclosing_cv;
- case CXt_EVAL:
- cv = cx->blk_eval.cv;
- goto get_enclosing_cv;
- default:
- break;
- }
- }
- }
-
- cv = PL_main_cv;
- }
-
-get_enclosing_cv:
- for (outside = CvOUTSIDE(cv); outside; outside = CvOUTSIDE(cv))
- cv = outside;
-
- return PTR2IV(cv);
-}
+#if XSH_THREADSAFE
-#endif /* LT_WORKAROUND_REQUIRE_PROPAGATION */
+static void xsh_user_clone(pTHX_ const xsh_user_cxt_t *old_cxt, xsh_user_cxt_t *new_cxt, CLONE_PARAMS *params) {
+ new_cxt->default_meth = xsh_dup_inc(old_cxt->default_meth, params);
-static SV *lt_tag(pTHX_ SV *value) {
-#define lt_tag(V) lt_tag(aTHX_ (V))
- lt_hint_t *h;
- SV *code = NULL;
-#if LT_THREADSAFE
- dMY_CXT;
-
- if (!MY_CXT.tbl)
- return newSViv(0);
-#endif /* LT_THREADSAFE */
-
- if (SvROK(value)) {
- value = SvRV(value);
- if (SvTYPE(value) >= SVt_PVCV) {
- code = value;
- SvREFCNT_inc_simple_void_NN(code);
- }
- }
-
-#if LT_HINT_STRUCT
- h = PerlMemShared_malloc(sizeof *h);
- h->code = code;
-# if LT_WORKAROUND_REQUIRE_PROPAGATION
- h->require_tag = lt_require_tag();
-# endif /* LT_WORKAROUND_REQUIRE_PROPAGATION */
-#else /* LT_HINT_STRUCT */
- h = code;
-#endif /* !LT_HINT_STRUCT */
-
-#if LT_THREADSAFE
- /* We only need for the key to be an unique tag for looking up the value later
- * Allocated memory provides convenient unique identifiers, so that's why we
- * use the hint as the key itself. */
- ptable_hints_store(MY_CXT.tbl, h, h);
-#endif /* LT_THREADSAFE */
-
- return newSViv(PTR2IV(h));
+ return;
}
-static SV *lt_detag(pTHX_ const SV *hint) {
-#define lt_detag(H) lt_detag(aTHX_ (H))
- lt_hint_t *h;
-#if LT_THREADSAFE
- dMY_CXT;
-
- if (!MY_CXT.tbl)
- return NULL;
-#endif /* LT_THREADSAFE */
-
- if (!(hint && SvIOK(hint)))
- return NULL;
-
- h = INT2PTR(lt_hint_t *, SvIVX(hint));
-#if LT_THREADSAFE
- h = ptable_fetch(MY_CXT.tbl, h);
-#endif /* LT_THREADSAFE */
-#if LT_WORKAROUND_REQUIRE_PROPAGATION
- if (lt_require_tag() != h->require_tag)
- return NULL;
-#endif /* LT_WORKAROUND_REQUIRE_PROPAGATION */
-
- return LT_HINT_CODE(h);
-}
+#endif /* XSH_THREADSAFE */
-static VOL U32 lt_hash = 0;
-
-static SV *lt_hint(pTHX) {
-#define lt_hint() lt_hint(aTHX)
- SV *hint;
-#ifdef cop_hints_fetch_pvn
- hint = cop_hints_fetch_pvn(PL_curcop, __PACKAGE__, __PACKAGE_LEN__, lt_hash,0);
-#elif LT_HAS_PERL(5, 9, 5)
- hint = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
- NULL,
- __PACKAGE__, __PACKAGE_LEN__,
- 0,
- lt_hash);
-#else
- SV **val = hv_fetch(GvHV(PL_hintgv), __PACKAGE__, __PACKAGE_LEN__, 0);
- if (!val)
- return 0;
- hint = *val;
-#endif
- return lt_detag(hint);
-}
+#include "xsh/threads.h"
/* ... op => info map ...................................................... */
-#define PTABLE_NAME ptable_map
-#define PTABLE_VAL_FREE(V) PerlMemShared_free(V)
-#define PTABLE_NEED_DELETE 1
-#define PTABLE_NEED_WALK 0
+#define PTABLE_NAME ptable_map
+#define PTABLE_VAL_FREE(V) PerlMemShared_free(V)
+#define PTABLE_VAL_NEED_CONTEXT 0
+#define PTABLE_NEED_DELETE 1
+#define PTABLE_NEED_WALK 0
-#include "ptable.h"
+#include "xsh/ptable.h"
-/* PerlMemShared_free() needs the [ap]PTBLMS_? default values */
-#define ptable_map_store(T, K, V) ptable_map_store(aPTBLMS_ (T), (K), (V))
-#define ptable_map_delete(T, K) ptable_map_delete(aPTBLMS_ (T), (K))
+#define ptable_map_store(T, K, V) ptable_map_store(aPMS_ (T), (K), (V))
+#define ptable_map_delete(T, K) ptable_map_delete(aPMS_ (T), (K))
+#define ptable_map_free(T) ptable_map_free(aPMS_ (T))
#ifdef USE_ITHREADS
static perl_mutex lt_op_map_mutex;
-#define LT_LOCK(M) MUTEX_LOCK(M)
-#define LT_UNLOCK(M) MUTEX_UNLOCK(M)
-
-#else /* USE_ITHREADS */
-
-#define LT_LOCK(M)
-#define LT_UNLOCK(M)
-
-#endif /* !USE_ITHREADS */
+#endif /* USE_ITHREADS */
static ptable *lt_op_padxv_map = NULL;
#define lt_padxv_map_store(O, OP, TP, TM, PP) lt_padxv_map_store(aTHX_ (O), (OP), (TP), (TM), (PP))
lt_op_padxv_info *oi;
- LT_LOCK(<_op_map_mutex);
+ XSH_LOCK(<_op_map_mutex);
if (!(oi = ptable_fetch(lt_op_padxv_map, o))) {
oi = PerlMemShared_malloc(sizeof *oi);
oi->old_pp = old_pp;
- LT_UNLOCK(<_op_map_mutex);
+ XSH_UNLOCK(<_op_map_mutex);
}
static const lt_op_padxv_info *lt_padxv_map_fetch(const OP *o, lt_op_padxv_info *oi) {
const lt_op_padxv_info *val;
- LT_LOCK(<_op_map_mutex);
+ XSH_LOCK(<_op_map_mutex);
val = ptable_fetch(lt_op_padxv_map, o);
if (val) {
val = oi;
}
- LT_UNLOCK(<_op_map_mutex);
+ XSH_UNLOCK(<_op_map_mutex);
return val;
}
-#if LT_HAS_PERL(5, 17, 6)
+#if XSH_HAS_PERL(5, 17, 6)
static ptable *lt_op_padrange_map = NULL;
#define lt_padrange_map_store(O, S, PP) lt_padrange_map_store(aTHX_ (O), (S), (PP))
lt_op_padrange_info *oi;
- LT_LOCK(<_op_map_mutex);
+ XSH_LOCK(<_op_map_mutex);
if (!(oi = ptable_fetch(lt_op_padrange_map, o))) {
oi = PerlMemShared_malloc(sizeof *oi);
oi->old_pp = old_pp;
oi->padxv_start = s;
- LT_UNLOCK(<_op_map_mutex);
+ XSH_UNLOCK(<_op_map_mutex);
}
static const lt_op_padrange_info *lt_padrange_map_fetch(const OP *o, lt_op_padrange_info *oi) {
const lt_op_padrange_info *val;
- LT_LOCK(<_op_map_mutex);
+ XSH_LOCK(<_op_map_mutex);
val = ptable_fetch(lt_op_padrange_map, o);
if (val) {
val = oi;
}
- LT_UNLOCK(<_op_map_mutex);
+ XSH_UNLOCK(<_op_map_mutex);
return val;
}
static void lt_map_delete(pTHX_ const OP *o) {
#define lt_map_delete(O) lt_map_delete(aTHX_ (O))
- LT_LOCK(<_op_map_mutex);
+ XSH_LOCK(<_op_map_mutex);
ptable_map_delete(lt_op_padxv_map, o);
-#if LT_HAS_PERL(5, 17, 6)
+#if XSH_HAS_PERL(5, 17, 6)
ptable_map_delete(lt_op_padrange_map, o);
#endif
- LT_UNLOCK(<_op_map_mutex);
+ XSH_UNLOCK(<_op_map_mutex);
}
-/* --- Hooks --------------------------------------------------------------- */
+/* --- Compatibility wrappers ---------------------------------------------- */
+
+#if XSH_HAS_PERL(5, 10, 0) || defined(PL_parser)
+# ifndef PL_in_my_stash
+# define PL_in_my_stash PL_parser->in_my_stash
+# endif
+#else
+# ifndef PL_in_my_stash
+# define PL_in_my_stash PL_Iin_my_stash
+# endif
+#endif
+
+#ifndef HvNAME_get
+# define HvNAME_get(H) HvNAME(H)
+#endif
+
+#ifndef HvNAMELEN_get
+# define HvNAMELEN_get(H) strlen(HvNAME_get(H))
+#endif
+
+#ifndef SvREFCNT_inc_simple_void_NN
+# define SvREFCNT_inc_simple_void_NN(S) ((void) SvREFCNT_inc(S))
+#endif
+
+/* --- PP functions -------------------------------------------------------- */
-/* ... Our pp_padsv ........................................................ */
+/* ... pp_padsv ............................................................ */
static OP *lt_pp_padsv(pTHX) {
lt_op_padxv_info oi;
return PL_op->op_ppaddr(aTHX);
}
-/* ... Our pp_padrange (on perl 5.17.6 and above) .......................... */
+/* ... pp_padrange (on perl 5.17.6 and above) .............................. */
-#if LT_HAS_PERL(5, 17, 6)
+#if XSH_HAS_PERL(5, 17, 6)
static OP *lt_pp_padrange(pTHX) {
lt_op_padrange_info roi;
#endif
-/* ... Our ck_pad{any,sv} .................................................. */
+/* --- Check functions ----------------------------------------------------- */
+
+/* ... ck_pad{any,sv} ...................................................... */
/* Sadly, the padsv OPs we are interested in don't trigger the padsv check
* function, but are instead manually mutated from a padany. So we store
stash = PL_in_my_stash;
if (stash && (code = lt_hint())) {
- dMY_CXT;
+ dXSH_CXT;
SV *orig_pkg = newSVpvn(HvNAME_get(stash), HvNAMELEN_get(stash));
- SV *orig_meth = MY_CXT.default_meth; /* Guarded by lt_hint() */
+ SV *orig_meth = XSH_CXT.default_meth; /* Guarded by lt_hint() */
SV *type_pkg = NULL;
SV *type_meth = NULL;
int items;
SPAGAIN;
if (items > 2)
- croak(__PACKAGE__ " mangler should return zero, one or two scalars, but got %d", items);
+ croak(XSH_PACKAGE " mangler should return zero, one or two scalars, but got %d", items);
if (items == 0) {
SvREFCNT_dec(orig_pkg);
FREETMPS;
return lt_old_ck_padsv(aTHX_ o);
}
-/* ... Our peephole optimizer .............................................. */
+/* --- Our peephole optimizer ---------------------------------------------- */
-#if LT_HAS_PERL(5, 17, 6)
+#if XSH_HAS_PERL(5, 17, 6)
static int lt_maybe_padrange_setup(pTHX_ OP *o, const OP *start) {
#define lt_maybe_padrange_setup(O, S) lt_maybe_padrange_setup(aTHX_ (O), (S))
/* In a padrange sequence, either all lexicals are typed, or none are.
* Thus we can stop at the first padsv op. However, note that these
* lexicals can need to call different methods in different packages. */
- LT_LOCK(<_op_map_mutex);
+ XSH_LOCK(<_op_map_mutex);
if (ptable_fetch(lt_op_padxv_map, p)) {
- LT_UNLOCK(<_op_map_mutex);
+ XSH_UNLOCK(<_op_map_mutex);
lt_padrange_map_store(o, start, o->op_ppaddr);
o->op_ppaddr = lt_pp_padrange;
} else {
- LT_UNLOCK(<_op_map_mutex);
+ XSH_UNLOCK(<_op_map_mutex);
}
return 1;
}
#endif
-static void lt_peep_rec(pTHX_ OP *o, ptable *seen) {
-#define lt_peep_rec(O) lt_peep_rec(aTHX_ (O), seen)
+static void xsh_peep_rec(pTHX_ OP *o, ptable *seen) {
for (; o; o = o->op_next) {
- if (ptable_fetch(seen, o))
+ if (xsh_peep_seen(o, seen))
break;
- ptable_seen_store(seen, o, o);
switch (o->op_type) {
case OP_PADSV:
if (o->op_ppaddr != lt_pp_padsv && o->op_private & OPpLVAL_INTRO) {
lt_op_padxv_info *oi;
- LT_LOCK(<_op_map_mutex);
+ XSH_LOCK(<_op_map_mutex);
oi = ptable_fetch(lt_op_padxv_map, o);
if (oi) {
oi->old_pp = o->op_ppaddr;
o->op_ppaddr = lt_pp_padsv;
}
- LT_UNLOCK(<_op_map_mutex);
+ XSH_UNLOCK(<_op_map_mutex);
}
break;
-#if LT_HAS_PERL(5, 17, 6)
+#if XSH_HAS_PERL(5, 17, 6)
case OP_PADRANGE:
/* We deal with special padrange ops later, in the aassign op they belong
* to. */
break;
}
#endif
-#if !LT_HAS_RPEEP
- case OP_MAPWHILE:
- case OP_GREPWHILE:
- case OP_AND:
- case OP_OR:
- case OP_ANDASSIGN:
- case OP_ORASSIGN:
- case OP_COND_EXPR:
- case OP_RANGE:
-# if LT_HAS_PERL(5, 10, 0)
- case OP_ONCE:
- case OP_DOR:
- case OP_DORASSIGN:
-# endif
- lt_peep_rec(cLOGOPo->op_other);
- break;
- case OP_ENTERLOOP:
- case OP_ENTERITER:
- lt_peep_rec(cLOOPo->op_redoop);
- lt_peep_rec(cLOOPo->op_nextop);
- lt_peep_rec(cLOOPo->op_lastop);
- break;
-# if LT_HAS_PERL(5, 9, 5)
- case OP_SUBST:
- lt_peep_rec(cPMOPo->op_pmstashstartu.op_pmreplstart);
- break;
-# else
- case OP_QR:
- case OP_MATCH:
- case OP_SUBST:
- lt_peep_rec(cPMOPo->op_pmreplstart);
- break;
-# endif
-#endif /* !LT_HAS_RPEEP */
default:
+ xsh_peep_maybe_recurse(o, seen);
break;
}
}
}
-static void lt_peep(pTHX_ OP *o) {
- ptable *seen;
- dMY_CXT;
-
- LT_ASSERT(lt_is_loaded(&MY_CXT));
-
- MY_CXT.old_peep(aTHX_ o);
-
- seen = MY_CXT.seen;
- if (seen) {
- ptable_seen_clear(seen);
- lt_peep_rec(o);
- ptable_seen_clear(seen);
- }
-}
-
/* --- Module setup/teardown ----------------------------------------------- */
-static void lt_teardown(pTHX_ void *root) {
- dMY_CXT;
-
- LT_LOADED_LOCK;
-
- if (lt_clear_loaded_locked(&MY_CXT)) {
- lt_ck_restore(OP_PADANY, <_old_ck_padany);
- lt_ck_restore(OP_PADSV, <_old_ck_padsv);
-
- ptable_map_free(lt_op_padxv_map);
- lt_op_padxv_map = NULL;
-
-#if LT_HAS_PERL(5, 17, 6)
- ptable_map_free(lt_op_padrange_map);
- lt_op_padrange_map = NULL;
+static void xsh_user_global_setup(pTHX) {
+ lt_op_padxv_map = ptable_new(32);
+#if XSH_HAS_PERL(5, 17, 6)
+ lt_op_padrange_map = ptable_new(32);
#endif
#ifdef USE_ITHREADS
- MUTEX_DESTROY(<_op_map_mutex);
+ MUTEX_INIT(<_op_map_mutex);
#endif
- }
-
- LT_LOADED_UNLOCK;
-
- if (MY_CXT.old_peep) {
-#if LT_HAS_RPEEP
- PL_rpeepp = MY_CXT.old_peep;
-#else
- PL_peepp = MY_CXT.old_peep;
-#endif
- MY_CXT.old_peep = 0;
- }
- ptable_seen_free(MY_CXT.seen);
- MY_CXT.seen = NULL;
-
-#if LT_THREADSAFE
- ptable_hints_free(MY_CXT.tbl);
- MY_CXT.tbl = NULL;
-#endif
-
- SvREFCNT_dec(MY_CXT.default_meth);
- MY_CXT.default_meth = NULL;
+ xsh_ck_replace(OP_PADANY, lt_ck_padany, <_old_ck_padany);
+ xsh_ck_replace(OP_PADSV, lt_ck_padsv, <_old_ck_padsv);
return;
}
-static void lt_setup(pTHX) {
-#define lt_setup() lt_setup(aTHX)
- MY_CXT_INIT; /* Takes/release PL_my_ctx_mutex */
-
- LT_LOADED_LOCK;
+static void xsh_user_local_setup(pTHX_ xsh_user_cxt_t *cxt) {
+ HV *stash;
- if (lt_set_loaded_locked(&MY_CXT)) {
- PERL_HASH(lt_hash, __PACKAGE__, __PACKAGE_LEN__);
+ stash = gv_stashpvn(XSH_PACKAGE, XSH_PACKAGE_LEN, 1);
+ newCONSTSUB(stash, "LT_THREADSAFE", newSVuv(XSH_THREADSAFE));
+ newCONSTSUB(stash, "LT_FORKSAFE", newSVuv(XSH_FORKSAFE));
- lt_op_padxv_map = ptable_new();
-#if LT_HAS_PERL(5, 17, 6)
- lt_op_padrange_map = ptable_new();
-#endif
+ cxt->default_meth = newSVpvn("TYPEDSCALAR", 11);
+ SvREADONLY_on(cxt->default_meth);
-#ifdef USE_ITHREADS
- MUTEX_INIT(<_op_map_mutex);
-#endif
+ return;
+}
- lt_ck_replace(OP_PADANY, lt_ck_padany, <_old_ck_padany);
- lt_ck_replace(OP_PADSV, lt_ck_padsv, <_old_ck_padsv);
- }
+static void xsh_user_local_teardown(pTHX_ xsh_user_cxt_t *cxt) {
+ SvREFCNT_dec(cxt->default_meth);
+ cxt->default_meth = NULL;
- LT_LOADED_UNLOCK;
+ return;
+}
- {
- HV *stash;
+static void xsh_user_global_teardown(pTHX) {
+ xsh_ck_restore(OP_PADANY, <_old_ck_padany);
+ xsh_ck_restore(OP_PADSV, <_old_ck_padsv);
- stash = gv_stashpvn(__PACKAGE__, __PACKAGE_LEN__, 1);
- newCONSTSUB(stash, "LT_THREADSAFE", newSVuv(LT_THREADSAFE));
- newCONSTSUB(stash, "LT_FORKSAFE", newSVuv(LT_FORKSAFE));
- }
+ ptable_map_free(lt_op_padxv_map);
+ lt_op_padxv_map = NULL;
-#if LT_HAS_RPEEP
- if (PL_rpeepp != lt_peep) {
- MY_CXT.old_peep = PL_rpeepp;
- PL_rpeepp = lt_peep;
- }
-#else
- if (PL_peepp != lt_peep) {
- MY_CXT.old_peep = PL_peepp;
- PL_peepp = lt_peep;
- }
+#if XSH_HAS_PERL(5, 17, 6)
+ ptable_map_free(lt_op_padrange_map);
+ lt_op_padrange_map = NULL;
#endif
- else {
- MY_CXT.old_peep = 0;
- }
- MY_CXT.seen = ptable_new();
-
-#if LT_THREADSAFE
- MY_CXT.tbl = ptable_new();
- MY_CXT.owner = aTHX;
+#ifdef USE_ITHREADS
+ MUTEX_DESTROY(<_op_map_mutex);
#endif
- MY_CXT.default_meth = newSVpvn("TYPEDSCALAR", 11);
- SvREADONLY_on(MY_CXT.default_meth);
-
- call_atexit(lt_teardown, NULL);
-
return;
}
BOOT:
{
- lt_setup();
+ xsh_setup();
}
-#if LT_THREADSAFE
+#if XSH_THREADSAFE
void
CLONE(...)
PROTOTYPE: DISABLE
-PREINIT:
- ptable *t;
- ptable *s;
- SV *cloned_default_meth;
PPCODE:
- {
- {
- lt_ptable_clone_ud ud;
- dMY_CXT;
-
- t = ptable_new();
- lt_ptable_clone_ud_init(ud, t, MY_CXT.owner);
- ptable_walk(MY_CXT.tbl, lt_ptable_clone, &ud);
- cloned_default_meth = lt_dup_inc(MY_CXT.default_meth, &ud);
- lt_ptable_clone_ud_deinit(ud);
- }
- s = ptable_new();
- }
- {
- MY_CXT_CLONE;
- MY_CXT.seen = s;
- MY_CXT.tbl = t;
- MY_CXT.owner = aTHX;
- MY_CXT.default_meth = cloned_default_meth;
- {
- int global_setup;
- LT_LOADED_LOCK;
- global_setup = lt_set_loaded_locked(&MY_CXT);
- LT_ASSERT(!global_setup);
- LT_LOADED_UNLOCK;
- }
- }
+ xsh_clone();
XSRETURN(0);
#endif
SV *
-_tag(SV *value)
+_tag(SV *code)
PROTOTYPE: $
CODE:
- RETVAL = lt_tag(value);
+ if (!SvOK(code))
+ code = NULL;
+ else if (SvROK(code))
+ code = SvRV(code);
+ RETVAL = xsh_hints_tag(code);
OUTPUT:
RETVAL
+++ /dev/null
-/* This file is part of the Lexical::Types Perl module.
- * See http://search.cpan.org/dist/Lexical-Types/ */
-
-/* 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_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_DELETE
-# define PTABLE_NEED_DELETE 1
-#endif
-
-#ifndef PTABLE_NEED_WALK
-# define PTABLE_NEED_WALK 1
-#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) {
-#ifdef PTABLE_VAL_FREE
- void *oldval = ent->val;
- PTABLE_VAL_FREE(oldval);
-#endif
- 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);
- }
-}
-
-#if PTABLE_NEED_DELETE
-
-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;
-#ifdef PTABLE_VAL_FREE
- PTABLE_VAL_FREE(ent->val);
-#endif
- PerlMemShared_free(ent);
- }
-}
-
-#endif /* PTABLE_NEED_DELETE */
-
-#if PTABLE_NEED_WALK && !defined(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_NEED_WALK && !defined(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 nentry = entry->next;
-#ifdef PTABLE_VAL_FREE
- PTABLE_VAL_FREE(entry->val);
-#endif
- PerlMemShared_free(entry);
- entry = nentry;
- }
- 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
-
-#undef PTABLE_NEED_DELETE
-#undef PTABLE_NEED_WALK
--- /dev/null
+#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 */
--- /dev/null
+#ifndef XSH_DEBUG_H
+#define XSH_DEBUG_H 1
+
+#include "util.h" /* XSH_PACKAGE, STMT_* */
+
+#ifndef XSH_DEBUG
+# define XSH_DEBUG 0
+#endif
+
+#if XSH_DEBUG
+# define XSH_D(X) STMT_START X STMT_END
+static void xsh_debug_log(const char *fmt, ...) {
+ va_list va;
+ SV *sv;
+ dTHX;
+ va_start(va, fmt);
+ sv = get_sv(XSH_PACKAGE "::DEBUG", 0);
+ if (sv && SvTRUE(sv))
+ PerlIO_vprintf(Perl_debug_log, fmt, va);
+ va_end(va);
+ return;
+}
+#else
+# define XSH_D(X)
+#endif
+
+#endif /* XSH_DEBUG_H */
--- /dev/null
+#ifndef XSH_HINTS_H
+#define XSH_HINTS_H 1
+
+#include "caps.h" /* XSH_HAS_PERL(), XSH_THREADSAFE, tTHX */
+
+#ifdef XSH_THREADS_H
+# error threads.h must be loaded at the very end
+#endif
+
+#define XSH_HINTS_KEY XSH_PACKAGE
+#define XSH_HINTS_KEY_LEN (sizeof(XSH_HINTS_KEY)-1)
+
+#ifndef XSH_WORKAROUND_REQUIRE_PROPAGATION
+# define XSH_WORKAROUND_REQUIRE_PROPAGATION !XSH_HAS_PERL(5, 10, 1)
+#endif
+
+#ifndef XSH_HINTS_ONLY_COMPILE_TIME
+# define XSH_HINTS_ONLY_COMPILE_TIME 1
+#endif
+
+#ifdef XSH_HINTS_TYPE_UV
+# ifdef XSH_HINTS_TYPE_VAL
+# error hint type can only be set once
+# endif
+# undef XSH_HINTS_TYPE_UV
+# define XSH_HINTS_TYPE_UV 1
+# define XSH_HINTS_TYPE_STRUCT UV
+# define XSH_HINTS_TYPE_COMPACT UV
+# define XSH_HINTS_NEED_STRUCT 0
+# define XSH_HINTS_VAL_STRUCT_REF 0
+# define XSH_HINTS_VAL_NONE 0
+# define XSH_HINTS_VAL_PACK(T, V) INT2PTR(T, (V))
+# define XSH_HINTS_VAL_UNPACK(V) ((XSH_HINTS_TYPE_VAL) PTR2UV(V))
+# define XSH_HINTS_VAL_INIT(HV, V) ((HV) = (V))
+# undef XSH_HINTS_VAL_CLONE
+# undef XSH_HINTS_VAL_DEINIT
+#endif
+
+#ifdef XSH_HINTS_TYPE_SV
+# ifdef XSH_HINTS_TYPE_VAL
+# error hint type can only be set once
+# endif
+# undef XSH_HINTS_TYPE_SV
+# define XSH_HINTS_TYPE_SV 1
+# define XSH_HINTS_TYPE_STRUCT SV *
+# define XSH_HINTS_TYPE_COMPACT SV
+# define XSH_HINTS_NEED_STRUCT 0
+# define XSH_HINTS_VAL_STRUCT_REF 0
+# define XSH_HINTS_VAL_NONE NULL
+# define XSH_HINTS_VAL_PACK(T, V) (V)
+# define XSH_HINTS_VAL_UNPACK(V) (V)
+# define XSH_HINTS_VAL_INIT(HV, V) ((HV) = (((V) != XSH_HINTS_VAL_NONE) ? SvREFCNT_inc(V) : XSH_HINTS_VAL_NONE))
+# define XSH_HINTS_VAL_CLONE(N, O) ((N) = xsh_dup_inc((O), ud->params))
+# define XSH_HINTS_VAL_DEINIT(V) SvREFCNT_dec(V)
+#endif
+
+#ifdef XSH_HINTS_TYPE_USER
+# ifdef XSH_HINTS_TYPE_VAL
+# error hint type can only be set once
+# endif
+# undef XSH_HINTS_TYPE_USER
+# define XSH_HINTS_TYPE_USER 1
+# define XSH_HINTS_TYPE_STRUCT xsh_hints_user_t
+# undef XSH_HINTS_TYPE_COMPACT /* not used */
+# define XSH_HINTS_NEED_STRUCT 1
+# define XSH_HINTS_VAL_STRUCT_REF 1
+# define XSH_HINTS_VAL_NONE NULL
+# define XSH_HINTS_VAL_PACK(T, V) (V)
+# define XSH_HINTS_VAL_UNPACK(V) (V)
+# define XSH_HINTS_VAL_INIT(HV, V) xsh_hints_user_init(aTHX_ (HV), (V))
+# define XSH_HINTS_VAL_CLONE(NV, OV) xsh_hints_user_clone(aTHX_ (NV), (OV), ud->params)
+# define XSH_HINTS_VAL_DEINIT(V) xsh_hints_user_deinit(aTHX_ (V))
+#endif
+
+#ifndef XSH_HINTS_TYPE_STRUCT
+# error hint type was not set
+#endif
+
+#if XSH_HINTS_VAL_STRUCT_REF
+# define XSH_HINTS_TYPE_VAL XSH_HINTS_TYPE_STRUCT *
+#else
+# define XSH_HINTS_TYPE_VAL XSH_HINTS_TYPE_STRUCT
+#endif
+
+#if XSH_WORKAROUND_REQUIRE_PROPAGATION
+# undef XSH_HINTS_NEED_STRUCT
+# define XSH_HINTS_NEED_STRUCT 1
+#endif
+
+#if XSH_THREADSAFE && (defined(XSH_HINTS_VAL_CLONE) || XSH_WORKAROUND_REQUIRE_PROPAGATION)
+# define XSH_HINTS_NEED_CLONE 1
+#else
+# define XSH_HINTS_NEED_CLONE 0
+#endif
+
+#if XSH_WORKAROUND_REQUIRE_PROPAGATION
+
+static UV xsh_require_tag(pTHX) {
+#define xsh_require_tag() xsh_require_tag(aTHX)
+ const CV *cv, *outside;
+
+ cv = PL_compcv;
+
+ if (!cv) {
+ /* If for some reason the pragma is operational at run-time, try to discover
+ * the current cv in use. */
+ const PERL_SI *si;
+
+ for (si = PL_curstackinfo; si; si = si->si_prev) {
+ I32 cxix;
+
+ for (cxix = si->si_cxix; cxix >= 0; --cxix) {
+ const PERL_CONTEXT *cx = si->si_cxstack + cxix;
+
+ switch (CxTYPE(cx)) {
+ case CXt_SUB:
+ case CXt_FORMAT:
+ /* The propagation workaround is only needed up to 5.10.0 and at that
+ * time format and sub contexts were still identical. And even later the
+ * cv members offsets should have been kept the same. */
+ cv = cx->blk_sub.cv;
+ goto get_enclosing_cv;
+ case CXt_EVAL:
+ cv = cx->blk_eval.cv;
+ goto get_enclosing_cv;
+ default:
+ break;
+ }
+ }
+ }
+
+ cv = PL_main_cv;
+ }
+
+get_enclosing_cv:
+ for (outside = CvOUTSIDE(cv); outside; outside = CvOUTSIDE(cv))
+ cv = outside;
+
+ return PTR2UV(cv);
+}
+
+#endif /* XSH_WORKAROUND_REQUIRE_PROPAGATION */
+
+#if XSH_HINTS_NEED_STRUCT
+
+typedef struct {
+ XSH_HINTS_TYPE_STRUCT val;
+#if XSH_WORKAROUND_REQUIRE_PROPAGATION
+ UV require_tag;
+#endif
+} xsh_hints_t;
+
+#if XSH_HINTS_VAL_STRUCT_REF
+# define XSH_HINTS_VAL_GET(H) (&(H)->val)
+#else
+# define XSH_HINTS_VAL_GET(H) ((H)->val)
+#endif
+
+#define XSH_HINTS_VAL_SET(H, V) XSH_HINTS_VAL_INIT(XSH_HINTS_VAL_GET(H), (V))
+
+#ifdef XSH_HINTS_VAL_DEINIT
+# define XSH_HINTS_FREE(H) \
+ if (H) XSH_HINTS_VAL_DEINIT(XSH_HINTS_VAL_GET(H)); \
+ PerlMemShared_free(H)
+#else
+# define XSH_HINTS_FREE(H) PerlMemShared_free(H)
+#endif
+
+#else /* XSH_HINTS_NEED_STRUCT */
+
+typedef XSH_HINTS_TYPE_COMPACT xsh_hints_t;
+
+#define XSH_HINTS_VAL_GET(H) XSH_HINTS_VAL_UNPACK(H)
+#define XSH_HINTS_VAL_SET(H, V) STMT_START { XSH_HINTS_TYPE_VAL tmp; XSH_HINTS_VAL_INIT(tmp, (V)); (H) = XSH_HINTS_VAL_PACK(xsh_hints_t *, tmp); } STMT_END
+
+#undef XSH_HINTS_FREE
+
+#endif /* !XSH_HINTS_NEED_STRUCT */
+
+/* ... Thread safety ....................................................... */
+
+#if XSH_HINTS_NEED_CLONE
+
+#ifdef XSH_HINTS_FREE
+# define PTABLE_NAME ptable_hints
+# define PTABLE_VAL_FREE(V) XSH_HINTS_FREE((xsh_hints_t *) (V))
+#else
+# define PTABLE_USE_DEFAULT 1
+#endif
+
+#define PTABLE_NEED_WALK 1
+#define PTABLE_NEED_DELETE 0
+
+#include "ptable.h"
+
+#if PTABLE_WAS_DEFAULT
+# define ptable_hints_store(T, K, V) ptable_default_store(aPTBL_ (T), (K), (V))
+# define ptable_hints_free(T) ptable_default_free(aPTBL_ (T))
+#else
+# define ptable_hints_store(T, K, V) ptable_hints_store(aPTBL_ (T), (K), (V))
+# define ptable_hints_free(T) ptable_hints_free(aPTBL_ (T))
+#endif
+
+#define XSH_THREADS_HINTS_CONTEXT 1
+
+typedef struct {
+ ptable *tbl; /* It really is a ptable_hints */
+ tTHX owner;
+} xsh_hints_cxt_t;
+
+static xsh_hints_cxt_t *xsh_hints_get_cxt(pTHX);
+
+static void xsh_hints_local_setup(pTHX_ xsh_hints_cxt_t *cxt) {
+ cxt->tbl = ptable_new(4);
+ cxt->owner = aTHX;
+}
+
+static void xsh_hints_local_teardown(pTHX_ xsh_hints_cxt_t *cxt) {
+ ptable_hints_free(cxt->tbl);
+ cxt->owner = NULL;
+}
+
+typedef struct {
+ ptable *tbl; /* It really is a ptable_hints */
+ CLONE_PARAMS *params;
+} xsh_ptable_clone_ud;
+
+static void xsh_ptable_clone(pTHX_ ptable_ent *ent, void *ud_) {
+ xsh_ptable_clone_ud *ud = ud_;
+ xsh_hints_t *h1 = ent->val;
+ xsh_hints_t *h2;
+
+#if XSH_HINTS_NEED_STRUCT
+ h2 = PerlMemShared_malloc(sizeof *h2);
+# if XSH_WORKAROUND_REQUIRE_PROPAGATION
+ h2->require_tag = PTR2UV(xsh_dup_inc(INT2PTR(SV *, h1->require_tag), ud->params));
+# endif
+#endif /* XSH_HINTS_NEED_STRUCT */
+
+#ifdef XSH_HINTS_VAL_CLONE
+ XSH_HINTS_VAL_CLONE(XSH_HINTS_VAL_GET(h2), XSH_HINTS_VAL_GET(h1));
+#endif /* defined(XSH_HINTS_VAL_CLONE) */
+
+ ptable_hints_store(ud->tbl, ent->key, h2);
+}
+
+static void xsh_hints_clone(pTHX_ const xsh_hints_cxt_t *old_cxt, xsh_hints_cxt_t *new_cxt, CLONE_PARAMS *params) {
+ xsh_ptable_clone_ud ud;
+
+ new_cxt->tbl = ptable_new(4);
+ new_cxt->owner = aTHX;
+
+ ud.tbl = new_cxt->tbl;
+ ud.params = params;
+
+ ptable_walk(old_cxt->tbl, xsh_ptable_clone, &ud);
+}
+
+#endif /* XSH_HINTS_NEED_CLONE */
+
+/* ... tag hints ........................................................... */
+
+static SV *xsh_hints_tag(pTHX_ XSH_HINTS_TYPE_VAL val) {
+#define xsh_hints_tag(V) xsh_hints_tag(aTHX_ (V))
+ xsh_hints_t *h;
+
+ if (val == XSH_HINTS_VAL_NONE)
+ return newSVuv(0);
+
+#if XSH_HINTS_NEED_STRUCT
+ h = PerlMemShared_malloc(sizeof *h);
+# if XSH_WORKAROUND_REQUIRE_PROPAGATION
+ h->require_tag = xsh_require_tag();
+# endif
+#endif /* XSH_HINTS_NEED_STRUCT */
+
+ XSH_HINTS_VAL_SET(h, val);
+
+#if XSH_HINTS_NEED_CLONE
+ /* We only need for the key to be an unique tag for looking up the value later
+ * Allocated memory provides convenient unique identifiers, so that's why we
+ * use the hint as the key itself. */
+ {
+ xsh_hints_cxt_t *cxt = xsh_hints_get_cxt(aTHX);
+ XSH_ASSERT(cxt->tbl);
+ ptable_hints_store(cxt->tbl, h, h);
+ }
+#endif /* !XSH_HINTS_NEED_CLONE */
+
+ return newSVuv(PTR2UV(h));
+}
+
+/* ... detag hints ......................................................... */
+
+#define xsh_hints_2uv(H) \
+ ((H) \
+ ? (SvIOK(H) \
+ ? SvUVX(H) \
+ : (SvPOK(H) \
+ ? sv_2uv(SvLEN(H) ? (H) : sv_mortalcopy(H)) \
+ : 0 \
+ ) \
+ ) \
+ : 0)
+
+static XSH_HINTS_TYPE_VAL xsh_hints_detag(pTHX_ SV *hint) {
+#define xsh_hints_detag(H) xsh_hints_detag(aTHX_ (H))
+ xsh_hints_t *h;
+ UV hint_uv;
+
+ hint_uv = xsh_hints_2uv(hint);
+ h = INT2PTR(xsh_hints_t *, hint_uv);
+ if (!h)
+ return XSH_HINTS_VAL_NONE;
+
+#if XSH_HINTS_NEED_CLONE
+ {
+ xsh_hints_cxt_t *cxt = xsh_hints_get_cxt(aTHX);
+ XSH_ASSERT(cxt->tbl);
+ h = ptable_fetch(cxt->tbl, h);
+ }
+#endif /* XSH_HINTS_NEED_CLONE */
+
+#if XSH_WORKAROUND_REQUIRE_PROPAGATION
+ if (xsh_require_tag() != h->require_tag)
+ return XSH_HINTS_VAL_NONE;
+#endif
+
+ return XSH_HINTS_VAL_GET(h);
+}
+
+/* ... fetch hints ......................................................... */
+
+#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
+
+#ifdef cop_hints_fetch_pvn
+
+static U32 xsh_hints_key_hash = 0;
+# define xsh_hints_global_setup(my_perl) \
+ PERL_HASH(xsh_hints_key_hash, XSH_HINTS_KEY, XSH_HINTS_KEY_LEN)
+
+#else /* defined(cop_hints_fetch_pvn) */
+
+# define xsh_hints_global_setup(my_perl)
+
+#endif /* !defined(cop_hints_fetch_pvn) */
+
+#define xsh_hints_global_teardown(my_perl)
+
+static SV *xsh_hints_fetch(pTHX) {
+#define xsh_hints_fetch() xsh_hints_fetch(aTHX)
+#if XSH_HINTS_ONLY_COMPILE_TIME
+ if (IN_PERL_RUNTIME)
+ return NULL;
+#endif
+
+#ifdef cop_hints_fetch_pvn
+ return cop_hints_fetch_pvn(PL_curcop, XSH_HINTS_KEY, XSH_HINTS_KEY_LEN,
+ xsh_hints_key_hash, 0);
+#else
+ {
+ SV **val = hv_fetch(GvHV(PL_hintgv), XSH_HINTS_KEY, XSH_HINTS_KEY_LEN, 0);
+ return val ? *val : NULL;
+ }
+#endif
+}
+
+#endif /* XSH_HINTS_H */
--- /dev/null
+#ifndef XSH_OPS_H
+#define XSH_OPS_H 1
+
+#include "caps.h" /* XSH_HAS_PERL() */
+#include "util.h" /* NOOP */
+
+#ifdef XSH_THREADS_H
+# error threads.h must be loaded at the very end
+#endif
+
+#ifndef XSH_THREADS_GLOBAL_SETUP
+# define XSH_THREADS_GLOBAL_SETUP 1
+#endif
+
+#ifndef XSH_THREADS_GLOBAL_TEARDOWN
+# define XSH_THREADS_GLOBAL_TEARDOWN 1
+#endif
+
+#ifndef OpSIBLING
+# ifdef OP_SIBLING
+# define OpSIBLING(O) OP_SIBLING(O)
+# else
+# define OpSIBLING(O) ((O)->op_sibling)
+# endif
+#endif
+
+#ifndef OpMAYBESIB_set
+# define OpMAYBESIB_set(O, S, P) ((O)->op_sibling = (S))
+#endif
+
+#ifndef OP_NAME
+# define OP_NAME(O) (PL_op_name[(O)->op_type])
+#endif
+
+#ifndef OP_CLASS
+# define OP_CLASS(O) (PL_opargs[(O)->op_type] & OA_CLASS_MASK)
+#endif
+
+#if defined(OP_CHECK_MUTEX_LOCK) && defined(OP_CHECK_MUTEX_UNLOCK)
+# define XSH_CHECK_LOCK OP_CHECK_MUTEX_LOCK
+# define XSH_CHECK_UNLOCK OP_CHECK_MUTEX_UNLOCK
+#elif XSH_HAS_PERL(5, 9, 3)
+# define XSH_CHECK_LOCK OP_REFCNT_LOCK
+# define XSH_CHECK_UNLOCK OP_REFCNT_UNLOCK
+#else
+/* Before perl 5.9.3, da_ck_*() calls are already protected by the XSH_LOADED
+ * mutex, which falls back to the OP_REFCNT mutex. Make sure we don't lock it
+ * twice. */
+# define XSH_CHECK_LOCK NOOP
+# define XSH_CHECK_UNLOCK NOOP
+#endif
+
+typedef OP *(*xsh_check_t)(pTHX_ OP *);
+
+#ifdef wrap_op_checker
+
+# define xsh_ck_replace(T, NC, OCP) wrap_op_checker((T), (NC), (OCP))
+
+#else
+
+static void xsh_ck_replace(pTHX_ OPCODE type, xsh_check_t new_ck, xsh_check_t *old_ck_p) {
+#define xsh_ck_replace(T, NC, OCP) xsh_ck_replace(aTHX_ (T), (NC), (OCP))
+ XSH_CHECK_LOCK;
+ if (!*old_ck_p) {
+ *old_ck_p = PL_check[type];
+ PL_check[type] = new_ck;
+ }
+ XSH_CHECK_UNLOCK;
+}
+
+#endif
+
+static void xsh_ck_restore(pTHX_ OPCODE type, xsh_check_t *old_ck_p) {
+#define xsh_ck_restore(T, OCP) xsh_ck_restore(aTHX_ (T), (OCP))
+ XSH_CHECK_LOCK;
+ if (*old_ck_p) {
+ PL_check[type] = *old_ck_p;
+ *old_ck_p = 0;
+ }
+ XSH_CHECK_UNLOCK;
+}
+
+#endif /* XSH_OPS_H */
--- /dev/null
+#ifndef XSH_PEEP_H
+#define XSH_PEEP_H 1
+
+#include "caps.h" /* XSH_HAS_PERL(), XSH_THREADSAFE */
+#include "util.h" /* XSH_ASSERT(), NOOP */
+
+#ifdef XSH_THREADS_H
+# error threads.h must be loaded at the very end
+#endif
+
+#ifndef XSH_HAS_RPEEP
+# define XSH_HAS_RPEEP XSH_HAS_PERL(5, 13, 5)
+#endif
+
+#define PTABLE_USE_DEFAULT 1
+#define PTABLE_NEED_DELETE 0
+
+#include "ptable.h"
+
+#define ptable_seen_store(T, K, V) ptable_default_store(aPTBL_ (T), (K), (V))
+#define ptable_seen_clear(T) ptable_default_clear(aPTBL_ (T))
+#define ptable_seen_free(T) ptable_default_free(aPTBL_ (T))
+
+#define XSH_THREADS_PEEP_CONTEXT 1
+
+typedef struct {
+#if XSH_HAS_RPEEP
+ peep_t old_rpeep;
+#else
+ peep_t old_peep;
+#endif
+ ptable *seen;
+} xsh_peep_cxt_t;
+
+static xsh_peep_cxt_t *xsh_peep_get_cxt(pTHX);
+
+static void xsh_peep_rec(pTHX_ OP *o, ptable *seen);
+
+#if XSH_HAS_RPEEP
+
+static void xsh_rpeep(pTHX_ OP *o) {
+ ptable *seen;
+ xsh_peep_cxt_t *cxt = xsh_peep_get_cxt(aTHX);
+
+ cxt->old_rpeep(aTHX_ o);
+
+ seen = cxt->seen;
+ XSH_ASSERT(seen);
+
+ ptable_seen_clear(seen);
+
+ xsh_peep_rec(aTHX_ o, seen);
+
+ ptable_seen_clear(seen);
+
+ return;
+}
+
+#define xsh_peep_maybe_recurse(O, S) NOOP
+
+#else /* XSH_HAS_RPEEP */
+
+static void xsh_peep(pTHX_ OP *o) {
+ ptable *seen;
+ xsh_peep_cxt_t *cxt = xsh_peep_get_cxt(aTHX);
+
+ cxt->old_peep(aTHX_ o); /* Will call the rpeep */
+
+ seen = cxt->seen;
+ XSH_ASSERT(seen);
+
+ ptable_seen_clear(seen);
+
+ xsh_peep_rec(aTHX_ o, seen);
+
+ ptable_seen_clear(seen);
+
+ return;
+}
+
+static void xsh_peep_maybe_recurse(pTHX_ OP *o, ptable *seen) {
+#define xsh_peep_maybe_recurse(O, S) xsh_peep_maybe_recurse(aTHX_ (O), (S))
+ switch (o->op_type) {
+ case OP_MAPWHILE:
+ case OP_GREPWHILE:
+ case OP_AND:
+ case OP_OR:
+ case OP_ANDASSIGN:
+ case OP_ORASSIGN:
+ case OP_COND_EXPR:
+ case OP_RANGE:
+#if XSH_HAS_PERL(5, 10, 0)
+ case OP_ONCE:
+ case OP_DOR:
+ case OP_DORASSIGN:
+#endif
+ xsh_peep_rec(aTHX_ cLOGOPo->op_other, seen);
+ break;
+ case OP_ENTERLOOP:
+ case OP_ENTERITER:
+ xsh_peep_rec(aTHX_ cLOOPo->op_redoop, seen);
+ xsh_peep_rec(aTHX_ cLOOPo->op_nextop, seen);
+ xsh_peep_rec(aTHX_ cLOOPo->op_lastop, seen);
+ break;
+#if XSH_HAS_PERL(5, 9, 5)
+ case OP_SUBST:
+ xsh_peep_rec(aTHX_ cPMOPo->op_pmstashstartu.op_pmreplstart, seen);
+ break;
+#else
+ case OP_QR:
+ case OP_MATCH:
+ case OP_SUBST:
+ xsh_peep_rec(aTHX_ cPMOPo->op_pmreplstart, seen);
+ break;
+#endif
+ }
+
+ return;
+}
+
+#endif /* !XSH_HAS_RPEEP */
+
+static int xsh_peep_seen(pTHX_ OP *o, ptable *seen) {
+#define xsh_peep_seen(O, S) xsh_peep_seen(aTHX_ (O), (S))
+#if XSH_HAS_RPEEP
+ switch (o->op_type) {
+ case OP_NEXTSTATE:
+ case OP_DBSTATE:
+ case OP_UNSTACK:
+ case OP_STUB:
+ break;
+ default:
+ return 0;
+ }
+#endif /* XSH_HAS_RPEEP */
+
+ if (ptable_fetch(seen, o))
+ return 1;
+
+ ptable_seen_store(seen, o, o);
+
+ return 0;
+}
+
+static void xsh_peep_local_setup(pTHX_ xsh_peep_cxt_t *cxt) {
+#if XSH_HAS_RPEEP
+ if (PL_rpeepp != xsh_rpeep) {
+ cxt->old_rpeep = PL_rpeepp;
+ PL_rpeepp = xsh_rpeep;
+ } else {
+ cxt->old_rpeep = 0;
+ }
+#else
+ if (PL_peepp != xsh_peep) {
+ cxt->old_peep = PL_peepp;
+ PL_peepp = xsh_peep;
+ } else {
+ cxt->old_peep = 0;
+ }
+#endif
+
+ cxt->seen = ptable_new(32);
+}
+
+static void xsh_peep_local_teardown(pTHX_ xsh_peep_cxt_t *cxt) {
+ ptable_seen_free(cxt->seen);
+ cxt->seen = NULL;
+
+#if XSH_HAS_RPEEP
+ if (cxt->old_rpeep) {
+ PL_rpeepp = cxt->old_rpeep;
+ cxt->old_rpeep = 0;
+ }
+#else
+ if (cxt->old_peep) {
+ PL_peepp = cxt->old_peep;
+ cxt->old_peep = 0;
+ }
+#endif
+
+ return;
+}
+
+static void xsh_peep_clone(pTHX_ const xsh_peep_cxt_t *old_cxt, xsh_peep_cxt_t *new_cxt) {
+ new_cxt->seen = ptable_new(32);
+
+ return;
+}
+
+#endif /* XSH_PEEP_H */
--- /dev/null
+/* 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
--- /dev/null
+#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 */
--- /dev/null
+#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 */
projects / perl / modules / Lexical-Types.git / commitdiff