From: Vincent Pit Date: Wed, 4 Nov 2015 13:34:25 +0000 (-0200) Subject: The Big Boilerplate Factorization X-Git-Tag: rt117081~3 X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FVariable-Magic.git;a=commitdiff_plain;h=d0d2f5ac7d4406b6158a57cddde7535285703c5e The Big Boilerplate Factorization --- diff --git a/MANIFEST b/MANIFEST index c052756..3a657b9 100644 --- a/MANIFEST +++ b/MANIFEST @@ -48,3 +48,6 @@ t/lib/Variable/Magic/TestGlobalDestruction.pm t/lib/Variable/Magic/TestScopeEnd.pm t/lib/Variable/Magic/TestValue.pm t/lib/Variable/Magic/TestWatcher.pm +xsh/caps.h +xsh/threads.h +xsh/util.h diff --git a/Magic.xs b/Magic.xs index 483431e..116eb8a 100644 --- a/Magic.xs +++ b/Magic.xs @@ -10,158 +10,30 @@ #include "perl.h" #include "XSUB.h" -#define __PACKAGE__ "Variable::Magic" +/* --- XS helpers ---------------------------------------------------------- */ -#undef VOID2 -#ifdef __cplusplus -# define VOID2(T, P) static_cast(P) -#else -# define VOID2(T, P) (P) -#endif - -#ifndef VMG_PERL_PATCHLEVEL -# ifdef PERL_PATCHNUM -# define VMG_PERL_PATCHLEVEL PERL_PATCHNUM -# else -# define VMG_PERL_PATCHLEVEL 0 -# endif -#endif - -#define VMG_HAS_PERL(R, V, S) (PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S)))))) - -#define VMG_HAS_PERL_BRANCH(R, V, S) (PERL_REVISION == (R) && PERL_VERSION == (V) && PERL_SUBVERSION >= (S)) - -#define VMG_HAS_PERL_MAINT(R, V, S, P) (PERL_REVISION == (R) && PERL_VERSION == (V) && (VMG_PERL_PATCHLEVEL >= (P) || (!VMG_PERL_PATCHLEVEL && PERL_SUBVERSION >= (S)))) - -/* --- Threads and multiplicity -------------------------------------------- */ - -#ifndef NOOP -# define NOOP -#endif - -#ifndef dNOOP -# define dNOOP -#endif - -/* Safe unless stated otherwise in Makefile.PL */ -#ifndef VMG_FORKSAFE -# define VMG_FORKSAFE 1 -#endif - -#ifndef VMG_MULTIPLICITY -# if defined(MULTIPLICITY) -# define VMG_MULTIPLICITY 1 -# else -# define VMG_MULTIPLICITY 0 -# endif -#endif -#if VMG_MULTIPLICITY -# ifndef PERL_IMPLICIT_CONTEXT -# error MULTIPLICITY builds must set PERL_IMPLICIT_CONTEXT -# endif -#endif - -#if VMG_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)) -# ifndef VMG_THREADSAFE -# define VMG_THREADSAFE 1 -# endif -# 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 VMG_THREADSAFE -# define VMG_THREADSAFE 0 -# undef dMY_CXT -# define dMY_CXT dNOOP -# undef MY_CXT -# define MY_CXT vmg_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 VMG_THREADSAFE -# define VMG_LOCK(M) MUTEX_LOCK(M) -# define VMG_UNLOCK(M) MUTEX_UNLOCK(M) -#else -# define VMG_LOCK(M) -# define VMG_UNLOCK(M) -#endif - -/* --- Compatibility ------------------------------------------------------- */ +#define XSH_PACKAGE "Variable::Magic" -#ifndef Newx -# define Newx(v, n, c) New(0, v, n, c) -#endif - -#ifndef SvMAGIC_set -# define SvMAGIC_set(sv, val) (SvMAGIC(sv) = (val)) -#endif - -#ifndef SvRV_const -# define SvRV_const(sv) SvRV((SV *) sv) -#endif - -#ifndef SvREFCNT_inc_simple_void -# define SvREFCNT_inc_simple_void(sv) ((void) SvREFCNT_inc(sv)) -#endif - -#ifndef mPUSHu -# define mPUSHu(U) PUSHs(sv_2mortal(newSVuv(U))) -#endif - -#ifndef PERL_MAGIC_ext -# define PERL_MAGIC_ext '~' -#endif - -#ifndef PERL_MAGIC_tied -# define PERL_MAGIC_tied 'P' -#endif +#include "xsh/caps.h" +#include "xsh/util.h" -#ifndef MGf_LOCAL -# define MGf_LOCAL 0 -#endif - -#ifndef IN_PERL_COMPILETIME -# define IN_PERL_COMPILETIME (PL_curcop == &PL_compiling) -#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 - -#ifdef DEBUGGING -# define VMG_ASSERT(C) assert(C) -#else -# define VMG_ASSERT(C) -#endif +/* ... Features ............................................................ */ /* uvar magic and Hash::Util::FieldHash were commited with 28419, but we only * enable them on 5.10 */ -#if VMG_HAS_PERL(5, 10, 0) +#if XSH_HAS_PERL(5, 10, 0) # define VMG_UVAR 1 #else # define VMG_UVAR 0 #endif -#if VMG_HAS_PERL_MAINT(5, 11, 0, 32969) || VMG_HAS_PERL(5, 12, 0) +#if XSH_HAS_PERL_MAINT(5, 11, 0, 32969) || XSH_HAS_PERL(5, 12, 0) # define VMG_COMPAT_SCALAR_LENGTH_NOLEN 1 #else # define VMG_COMPAT_SCALAR_LENGTH_NOLEN 0 #endif -#if VMG_HAS_PERL(5, 17, 4) +#if XSH_HAS_PERL(5, 17, 4) # define VMG_COMPAT_SCALAR_NOLEN 1 #else # define VMG_COMPAT_SCALAR_NOLEN 0 @@ -169,9 +41,9 @@ /* Applied to dev-5.9 as 25854, integrated to maint-5.8 as 28160, partially * reverted to dev-5.11 as 9cdcb38b */ -#if VMG_HAS_PERL_MAINT(5, 8, 9, 28160) || VMG_HAS_PERL_MAINT(5, 9, 3, 25854) || VMG_HAS_PERL(5, 10, 0) +#if XSH_HAS_PERL_MAINT(5, 8, 9, 28160) || XSH_HAS_PERL_MAINT(5, 9, 3, 25854) || XSH_HAS_PERL(5, 10, 0) # ifndef VMG_COMPAT_ARRAY_PUSH_NOLEN -# if VMG_HAS_PERL(5, 11, 0) +# if XSH_HAS_PERL(5, 11, 0) # define VMG_COMPAT_ARRAY_PUSH_NOLEN 0 # else # define VMG_COMPAT_ARRAY_PUSH_NOLEN 1 @@ -190,76 +62,43 @@ #endif /* Applied to dev-5.11 as 34908 */ -#if VMG_HAS_PERL_MAINT(5, 11, 0, 34908) || VMG_HAS_PERL(5, 12, 0) +#if XSH_HAS_PERL_MAINT(5, 11, 0, 34908) || XSH_HAS_PERL(5, 12, 0) # define VMG_COMPAT_ARRAY_UNSHIFT_NOLEN_VOID 1 #else # define VMG_COMPAT_ARRAY_UNSHIFT_NOLEN_VOID 0 #endif /* Applied to dev-5.9 as 31473 (see #43357), integrated to maint-5.8 as 32542 */ -#if VMG_HAS_PERL_MAINT(5, 8, 9, 32542) || VMG_HAS_PERL_MAINT(5, 9, 5, 31473) || VMG_HAS_PERL(5, 10, 0) +#if XSH_HAS_PERL_MAINT(5, 8, 9, 32542) || XSH_HAS_PERL_MAINT(5, 9, 5, 31473) || XSH_HAS_PERL(5, 10, 0) # define VMG_COMPAT_ARRAY_UNDEF_CLEAR 1 #else # define VMG_COMPAT_ARRAY_UNDEF_CLEAR 0 #endif -#if VMG_HAS_PERL(5, 11, 0) +#if XSH_HAS_PERL(5, 11, 0) # define VMG_COMPAT_HASH_DELETE_NOUVAR_VOID 1 #else # define VMG_COMPAT_HASH_DELETE_NOUVAR_VOID 0 #endif -#if VMG_HAS_PERL(5, 17, 0) +#if XSH_HAS_PERL(5, 17, 0) # define VMG_COMPAT_CODE_COPY_CLONE 1 #else # define VMG_COMPAT_CODE_COPY_CLONE 0 #endif -#if VMG_HAS_PERL(5, 13, 2) +#if XSH_HAS_PERL(5, 13, 2) # define VMG_COMPAT_GLOB_GET 1 #else # define VMG_COMPAT_GLOB_GET 0 #endif -#define VMG_PROPAGATE_ERRSV_NEEDS_TRAMPOLINE (VMG_HAS_PERL(5, 10, 0) && !VMG_HAS_PERL(5, 10, 1)) - -/* NewOp() isn't public in perl 5.8.0. */ -#define VMG_RESET_RMG_NEEDS_TRAMPOLINE (VMG_UVAR && (VMG_THREADSAFE || !VMG_HAS_PERL(5, 8, 1))) - -/* ... Bug-free mg_magical ................................................. */ - -/* See the discussion at http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2008-01/msg00036.html */ - -#if VMG_HAS_PERL(5, 11, 3) - -#define vmg_mg_magical(S) mg_magical(S) - -#else +/* ... Trampoline ops ...................................................... */ -static void vmg_mg_magical(SV *sv) { - const MAGIC *mg; +#define VMG_PROPAGATE_ERRSV_NEEDS_TRAMPOLINE (XSH_HAS_PERL(5, 10, 0) && !XSH_HAS_PERL(5, 10, 1)) - SvMAGICAL_off(sv); - if ((mg = SvMAGIC(sv))) { - do { - const MGVTBL* const vtbl = mg->mg_virtual; - if (vtbl) { - if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP)) - SvGMAGICAL_on(sv); - if (vtbl->svt_set) - SvSMAGICAL_on(sv); - if (vtbl->svt_clear) - SvRMAGICAL_on(sv); - } - } while ((mg = mg->mg_moremagic)); - if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG))) - SvRMAGICAL_on(sv); - } -} - -#endif - -/* --- Trampoline ops ------------------------------------------------------ */ +/* NewOp() isn't public in perl 5.8.0. */ +#define VMG_RESET_RMG_NEEDS_TRAMPOLINE (VMG_UVAR && (XSH_THREADSAFE || !XSH_HAS_PERL(5, 8, 1))) #define VMG_NEEDS_TRAMPOLINE VMG_PROPAGATE_ERRSV_NEEDS_TRAMPOLINE || VMG_RESET_RMG_NEEDS_TRAMPOLINE @@ -298,7 +137,86 @@ static OP *vmg_trampoline_bump(pTHX_ vmg_trampoline *t, SV *sv, OP *o) { #endif /* VMG_NEEDS_TRAMPOLINE */ -/* --- Cleaner version of sv_magicext() ------------------------------------ */ +/* --- Compatibility ------------------------------------------------------- */ + +#ifndef Newx +# define Newx(v, n, c) New(0, v, n, c) +#endif + +#ifndef SvMAGIC_set +# define SvMAGIC_set(sv, val) (SvMAGIC(sv) = (val)) +#endif + +#ifndef SvRV_const +# define SvRV_const(sv) SvRV((SV *) sv) +#endif + +#ifndef SvREFCNT_inc_simple_void +# define SvREFCNT_inc_simple_void(sv) ((void) SvREFCNT_inc(sv)) +#endif + +#ifndef mPUSHu +# define mPUSHu(U) PUSHs(sv_2mortal(newSVuv(U))) +#endif + +#ifndef PERL_MAGIC_ext +# define PERL_MAGIC_ext '~' +#endif + +#ifndef PERL_MAGIC_tied +# define PERL_MAGIC_tied 'P' +#endif + +#ifndef MGf_LOCAL +# define MGf_LOCAL 0 +#endif + +#ifndef IN_PERL_COMPILETIME +# define IN_PERL_COMPILETIME (PL_curcop == &PL_compiling) +#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 + +/* ... Bug-free mg_magical ................................................. */ + +/* See the discussion at http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2008-01/msg00036.html */ + +#if XSH_HAS_PERL(5, 11, 3) + +#define vmg_mg_magical(S) mg_magical(S) + +#else + +static void vmg_mg_magical(SV *sv) { + const MAGIC *mg; + + SvMAGICAL_off(sv); + if ((mg = SvMAGIC(sv))) { + do { + const MGVTBL* const vtbl = mg->mg_virtual; + if (vtbl) { + if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP)) + SvGMAGICAL_on(sv); + if (vtbl->svt_set) + SvSMAGICAL_on(sv); + if (vtbl->svt_clear) + SvRMAGICAL_on(sv); + } + } while ((mg = mg->mg_moremagic)); + if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG))) + SvRMAGICAL_on(sv); + } +} + +#endif + +/* ... Cleaner version of sv_magicext() .................................... */ static MAGIC *vmg_sv_magicext(pTHX_ SV *sv, SV *obj, const MGVTBL *vtbl, const void *ptr, I32 len) { #define vmg_sv_magicext(S, O, V, P, L) vmg_sv_magicext(aTHX_ (S), (O), (V), (P), (L)) @@ -327,7 +245,7 @@ static MAGIC *vmg_sv_magicext(pTHX_ SV *sv, SV *obj, const MGVTBL *vtbl, const v return mg; } -/* --- Safe version of call_sv() ------------------------------------------- */ +/* ... Safe version of call_sv() ........................................... */ static I32 vmg_call_sv(pTHX_ SV *sv, I32 flags, int (*cleanup)(pTHX_ void *), void *ud) { #define vmg_call_sv(S, F, C, U) vmg_call_sv(aTHX_ (S), (F), (C), (U)) @@ -352,7 +270,7 @@ static I32 vmg_call_sv(pTHX_ SV *sv, I32 flags, int (*cleanup)(pTHX_ void *), vo Perl_warn(aTHX_ "%s", SvPV_nolen(ERRSV)); SvCUR_set(ERRSV, 0); } -#if VMG_HAS_PERL(5, 10, 0) || defined(PL_parser) +#if XSH_HAS_PERL(5, 10, 0) || defined(PL_parser) if (PL_parser) ++PL_parser->error_count; #elif defined(PL_error_count) @@ -389,10 +307,10 @@ typedef enum { OPc_PVOP, OPc_LOOP, OPc_COP, -#if VMG_HAS_PERL(5, 21, 5) +#if XSH_HAS_PERL(5, 21, 5) OPc_METHOP, #endif -#if VMG_HAS_PERL(5, 21, 7) +#if XSH_HAS_PERL(5, 21, 7) OPc_UNOP_AUX, #endif OPc_MAX @@ -411,10 +329,10 @@ static const char *const vmg_opclassnames[] = { "B::PVOP", "B::LOOP", "B::COP", -#if VMG_HAS_PERL(5, 21, 5) +#if XSH_HAS_PERL(5, 21, 5) "B::METHOP", #endif -#if VMG_HAS_PERL(5, 21, 7) +#if XSH_HAS_PERL(5, 21, 7) "B::UNOP_AUX", #endif NULL @@ -428,7 +346,7 @@ static opclass vmg_opclass(pTHX_ const OP *o) { #endif if (o->op_type == 0) { -#if VMG_HAS_PERL(5, 21, 7) +#if XSH_HAS_PERL(5, 21, 7) if (o->op_targ == OP_NEXTSTATE || o->op_targ == OP_DBSTATE) return OPc_COP; #endif @@ -475,11 +393,11 @@ static opclass vmg_opclass(pTHX_ const OP *o) { return OPc_PADOP; case OA_PVOP_OR_SVOP: return ( -#if VMG_HAS_PERL(5, 13, 7) +#if XSH_HAS_PERL(5, 13, 7) (o->op_type != OP_CUSTOM) && #endif (o->op_private & (OPpTRANS_TO_UTF|OPpTRANS_FROM_UTF))) -#if defined(USE_ITHREADS) && VMG_HAS_PERL(5, 8, 9) +#if defined(USE_ITHREADS) && XSH_HAS_PERL(5, 8, 9) ? OPc_PADOP : OPc_PVOP; #else ? OPc_SVOP : OPc_PVOP; @@ -504,11 +422,11 @@ static opclass vmg_opclass(pTHX_ const OP *o) { return OPc_BASEOP; else return OPc_PVOP; -#if VMG_HAS_PERL(5, 21, 5) +#if XSH_HAS_PERL(5, 21, 5) case OA_METHOP: return OPc_METHOP; #endif -#if VMG_HAS_PERL(5, 21, 7) +#if XSH_HAS_PERL(5, 21, 7) case OA_UNOP_AUX: return OPc_UNOP_AUX; #endif @@ -522,9 +440,7 @@ static opclass vmg_opclass(pTHX_ const OP *o) { static const char vmg_invalid_wiz[] = "Invalid wizard object"; static const char vmg_wrongargnum[] = "Wrong number of arguments"; -/* --- Context-safe global data -------------------------------------------- */ - -#define MY_CXT_KEY __PACKAGE__ "::_guts" XS_VERSION +/* --- Thread-local storage ------------------------------------------------ */ typedef struct { HV *b__op_stashes[OPc_MAX]; @@ -536,13 +452,35 @@ typedef struct { #if VMG_RESET_RMG_NEEDS_TRAMPOLINE vmg_trampoline reset_rmg; #endif -} my_cxt_t; +} xsh_user_cxt_t; + +#if XSH_THREADSAFE + +static void xsh_user_clone(pTHX_ const xsh_user_cxt_t *old_cxt, xsh_user_cxt_t *new_cxt) { + int c; + + for (c = OPc_NULL; c < OPc_MAX; ++c) { + new_cxt->b__op_stashes[c] = old_cxt->b__op_stashes[c] + ? gv_stashpv(vmg_opclassnames[c], 1) + : NULL; + } + + new_cxt->depth = old_cxt->depth; + new_cxt->freed_tokens = NULL; + + return; +} + + +#endif /* XSH_THREADSAFE */ -START_MY_CXT +#define XSH_THREADS_NEED_TEARDOWN_LATE 1 + +#include "xsh/threads.h" /* --- structure ---------------------------------------------- */ -#if VMG_THREADSAFE +#if XSH_THREADSAFE typedef struct { MGVTBL *vtbl; @@ -567,9 +505,9 @@ static perl_mutex vmg_vtable_refcount_mutex; static vmg_vtable *vmg_vtable_dup(pTHX_ vmg_vtable *t) { #define vmg_vtable_dup(T) vmg_vtable_dup(aTHX_ (T)) - VMG_LOCK(&vmg_vtable_refcount_mutex); + XSH_LOCK(&vmg_vtable_refcount_mutex); ++t->refcount; - VMG_UNLOCK(&vmg_vtable_refcount_mutex); + XSH_UNLOCK(&vmg_vtable_refcount_mutex); return t; } @@ -578,9 +516,9 @@ static void vmg_vtable_free(pTHX_ vmg_vtable *t) { #define vmg_vtable_free(T) vmg_vtable_free(aTHX_ (T)) U32 refcount; - VMG_LOCK(&vmg_vtable_refcount_mutex); + XSH_LOCK(&vmg_vtable_refcount_mutex); refcount = --t->refcount; - VMG_UNLOCK(&vmg_vtable_refcount_mutex); + XSH_UNLOCK(&vmg_vtable_refcount_mutex); if (!refcount) { PerlMemShared_free(t->vtbl); @@ -588,7 +526,7 @@ static void vmg_vtable_free(pTHX_ vmg_vtable *t) { } } -#else /* VMG_THREADSAFE */ +#else /* XSH_THREADSAFE */ typedef MGVTBL vmg_vtable; @@ -605,7 +543,7 @@ static vmg_vtable *vmg_vtable_alloc(pTHX) { #define vmg_vtable_free(T) Safefree(T) -#endif /* !VMG_THREADSAFE */ +#endif /* !XSH_THREADSAFE */ /* --- structure ---------------------------------------------- */ @@ -682,7 +620,7 @@ static void vmg_wizard_free(pTHX_ vmg_wizard *w) { return; } -#if VMG_THREADSAFE +#if XSH_THREADSAFE #define VMG_CLONE_CB(N) \ z->cb_ ## N = (w->cb_ ## N) ? SvREFCNT_inc(sv_dup(w->cb_ ## N, params)) \ @@ -722,7 +660,7 @@ static const vmg_wizard *vmg_wizard_dup(pTHX_ const vmg_wizard *w, CLONE_PARAMS return z; } -#endif /* VMG_THREADSAFE */ +#endif /* XSH_THREADSAFE */ #define vmg_wizard_id(W) PTR2IV(vmg_vtable_vtbl((W)->vtable)) @@ -734,7 +672,7 @@ static int vmg_wizard_sv_free(pTHX_ SV *sv, MAGIC *mg) { return 0; } -#if VMG_THREADSAFE +#if XSH_THREADSAFE static int vmg_wizard_sv_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *params) { mg->mg_ptr = (char *) vmg_wizard_dup((const vmg_wizard *) mg->mg_ptr, params); @@ -742,7 +680,7 @@ static int vmg_wizard_sv_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *params) { return 0; } -#endif /* VMG_THREADSAFE */ +#endif /* XSH_THREADSAFE */ static MGVTBL vmg_wizard_sv_vtbl = { NULL, /* get */ @@ -751,7 +689,7 @@ static MGVTBL vmg_wizard_sv_vtbl = { NULL, /* clear */ vmg_wizard_sv_free, /* free */ NULL, /* copy */ -#if VMG_THREADSAFE +#if XSH_THREADSAFE vmg_wizard_sv_dup, /* dup */ #else NULL, /* dup */ @@ -765,7 +703,7 @@ static SV *vmg_wizard_sv_new(pTHX_ const vmg_wizard *w) { #define vmg_wizard_sv_new(W) vmg_wizard_sv_new(aTHX_ (W)) SV *wiz; -#if VMG_THREADSAFE +#if XSH_THREADSAFE wiz = newSV(0); #else wiz = newSViv(PTR2IV(w)); @@ -778,7 +716,7 @@ static SV *vmg_wizard_sv_new(pTHX_ const vmg_wizard *w) { return wiz; } -#if VMG_THREADSAFE +#if XSH_THREADSAFE #define vmg_sv_has_wizard_type(S) (SvTYPE(S) >= SVt_PVMG) @@ -793,13 +731,13 @@ static const vmg_wizard *vmg_wizard_from_sv_nocheck(const SV *wiz) { return NULL; } -#else /* VMG_THREADSAFE */ +#else /* XSH_THREADSAFE */ #define vmg_sv_has_wizard_type(S) SvIOK(S) #define vmg_wizard_from_sv_nocheck(W) INT2PTR(const vmg_wizard *, SvIVX(W)) -#endif /* !VMG_THREADSAFE */ +#endif /* !XSH_THREADSAFE */ #define vmg_wizard_from_sv(W) (vmg_sv_has_wizard_type(W) ? vmg_wizard_from_sv_nocheck(W) : NULL) @@ -862,7 +800,7 @@ static SV *vmg_data_new(pTHX_ SV *ctor, SV *sv, SV **args, I32 items) { SPAGAIN; nsv = POPs; -#if VMG_HAS_PERL(5, 8, 3) +#if XSH_HAS_PERL(5, 8, 3) SvREFCNT_inc_simple_void(nsv); /* Or it will be destroyed in FREETMPS */ #else nsv = sv_newref(nsv); /* Workaround some bug in SvREFCNT_inc() */ @@ -899,7 +837,7 @@ typedef struct { static void vmg_mg_del(pTHX_ SV *sv, MAGIC *prevmagic, MAGIC *mg, MAGIC *moremagic) { #define vmg_mg_del(S, P, M, N) vmg_mg_del(aTHX_ (S), (P), (M), (N)) - dMY_CXT; + dXSH_CXT; if (prevmagic) prevmagic->mg_moremagic = moremagic; @@ -923,9 +861,9 @@ static void vmg_mg_del(pTHX_ SV *sv, MAGIC *prevmagic, MAGIC *mg, MAGIC *moremag } #endif /* VMG_UVAR */ - if (MY_CXT.depth) { - mg->mg_moremagic = MY_CXT.freed_tokens; - MY_CXT.freed_tokens = mg; + if (XSH_CXT.depth) { + mg->mg_moremagic = XSH_CXT.freed_tokens; + XSH_CXT.freed_tokens = mg; } else { mg->mg_moremagic = NULL; Safefree(mg); @@ -1110,7 +1048,7 @@ static UV vmg_dispell(pTHX_ SV *sv, const vmg_wizard *w) { #define VMG_OP_INFO_NAME 1 #define VMG_OP_INFO_OBJECT 2 -#if VMG_THREADSAFE +#if XSH_THREADSAFE static perl_mutex vmg_op_name_init_mutex; #endif @@ -1121,22 +1059,22 @@ static void vmg_op_info_init(pTHX_ unsigned int opinfo) { #define vmg_op_info_init(W) vmg_op_info_init(aTHX_ (W)) switch (opinfo) { case VMG_OP_INFO_NAME: - VMG_LOCK(&vmg_op_name_init_mutex); + XSH_LOCK(&vmg_op_name_init_mutex); if (!vmg_op_name_init) { OPCODE t; for (t = 0; t < OP_max; ++t) vmg_op_name_len[t] = strlen(PL_op_name[t]); vmg_op_name_init = 1; } - VMG_UNLOCK(&vmg_op_name_init_mutex); + XSH_UNLOCK(&vmg_op_name_init_mutex); break; case VMG_OP_INFO_OBJECT: { - dMY_CXT; - if (!MY_CXT.b__op_stashes[0]) { + dXSH_CXT; + if (!XSH_CXT.b__op_stashes[0]) { int c; require_pv("B.pm"); for (c = OPc_NULL; c < OPc_MAX; ++c) - MY_CXT.b__op_stashes[c] = gv_stashpv(vmg_opclassnames[c], 1); + XSH_CXT.b__op_stashes[c] = gv_stashpv(vmg_opclassnames[c], 1); } break; } @@ -1160,9 +1098,9 @@ static SV *vmg_op_info(pTHX_ unsigned int opinfo) { return sv_2mortal(newSVpvn(name, name_len)); } case VMG_OP_INFO_OBJECT: { - dMY_CXT; + dXSH_CXT; return sv_bless(sv_2mortal(newRV_noinc(newSViv(PTR2IV(PL_op)))), - MY_CXT.b__op_stashes[vmg_opclass(PL_op)]); + XSH_CXT.b__op_stashes[vmg_opclass(PL_op)]); } default: break; @@ -1179,16 +1117,16 @@ static SV *vmg_op_info(pTHX_ unsigned int opinfo) { #define VMG_CB_CALL_GUARD 4 static int vmg_dispell_guard_oncroak(pTHX_ void *ud) { - dMY_CXT; + dXSH_CXT; - MY_CXT.depth--; + XSH_CXT.depth--; /* If we're at the upmost magic call and we're about to die, we can just free * the tokens right now, since we will jump past the problematic part of our * caller. */ - if (MY_CXT.depth == 0 && MY_CXT.freed_tokens) { - vmg_magic_chain_free(MY_CXT.freed_tokens, NULL); - MY_CXT.freed_tokens = NULL; + if (XSH_CXT.depth == 0 && XSH_CXT.freed_tokens) { + vmg_magic_chain_free(XSH_CXT.freed_tokens, NULL); + XSH_CXT.freed_tokens = NULL; } return 1; @@ -1200,7 +1138,7 @@ static int vmg_dispell_guard_free(pTHX_ SV *sv, MAGIC *mg) { return 0; } -#if VMG_THREADSAFE +#if XSH_THREADSAFE static int vmg_dispell_guard_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *params) { /* The freed magic tokens aren't cloned by perl because it cannot reach them @@ -1211,7 +1149,7 @@ static int vmg_dispell_guard_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *params) { return 0; } -#endif /* VMG_THREADSAFE */ +#endif /* XSH_THREADSAFE */ static MGVTBL vmg_dispell_guard_vtbl = { NULL, /* get */ @@ -1220,7 +1158,7 @@ static MGVTBL vmg_dispell_guard_vtbl = { NULL, /* clear */ vmg_dispell_guard_free, /* free */ NULL, /* copy */ -#if VMG_THREADSAFE +#if XSH_THREADSAFE vmg_dispell_guard_dup, /* dup */ #else NULL, /* dup */ @@ -1272,12 +1210,12 @@ static int vmg_cb_call(pTHX_ SV *cb, unsigned int flags, SV *sv, ...) { PUTBACK; if (flags & VMG_CB_CALL_GUARD) { - dMY_CXT; - MY_CXT.depth++; + dXSH_CXT; + XSH_CXT.depth++; vmg_call_sv(cb, G_SCALAR, vmg_dispell_guard_oncroak, NULL); - MY_CXT.depth--; - if (MY_CXT.depth == 0 && MY_CXT.freed_tokens) - chain = &MY_CXT.freed_tokens; + XSH_CXT.depth--; + if (XSH_CXT.depth == 0 && XSH_CXT.freed_tokens) + chain = &XSH_CXT.freed_tokens; } else { vmg_call_sv(cb, G_SCALAR, 0, NULL); } @@ -1349,7 +1287,7 @@ static int vmg_svt_set(pTHX_ SV *sv, MAGIC *mg) { static U32 vmg_sv_len(pTHX_ SV *sv) { #define vmg_sv_len(S) vmg_sv_len(aTHX_ (S)) STRLEN len; -#if VMG_HAS_PERL(5, 9, 3) +#if XSH_HAS_PERL(5, 9, 3) const U8 *s = VOID2(const U8 *, VOID2(const void *, SvPV_const(sv, len))); #else U8 *s = SvPV(sv, len); @@ -1426,7 +1364,7 @@ static int vmg_svt_clear(pTHX_ SV *sv, MAGIC *mg) { const vmg_wizard *w = vmg_wizard_from_mg_nocheck(mg); unsigned int flags = w->opinfo; -#if !VMG_HAS_PERL(5, 12, 0) +#if !XSH_HAS_PERL(5, 12, 0) flags |= VMG_CB_CALL_GUARD; #endif @@ -1496,14 +1434,14 @@ static int vmg_svt_free_cleanup(pTHX_ void *ud_) { #if VMG_PROPAGATE_ERRSV_NEEDS_TRAMPOLINE if (optype == OP_LEAVETRY) { - dMY_CXT; - PL_op = vmg_trampoline_bump(&MY_CXT.propagate_errsv, errsv, PL_op); + dXSH_CXT; + PL_op = vmg_trampoline_bump(&XSH_CXT.propagate_errsv, errsv, PL_op); } else if (optype == OP_LEAVEEVAL) { SV *guard = sv_newmortal(); vmg_sv_magicext(guard, errsv, &vmg_propagate_errsv_vtbl, NULL, 0); } #else /* !VMG_PROPAGATE_ERRSV_NEEDS_TRAMPOLINE */ -# if !VMG_HAS_PERL(5, 8, 9) +# if !XSH_HAS_PERL(5, 8, 9) { SV *guard = sv_newmortal(); vmg_sv_magicext(guard, errsv, &vmg_propagate_errsv_vtbl, NULL, 0); @@ -1556,7 +1494,7 @@ static int vmg_svt_free(pTHX_ SV *sv, MAGIC *mg) { /* So that it survives the temp cleanup below */ SvREFCNT_inc_simple_void(sv); -#if !(VMG_HAS_PERL_MAINT(5, 11, 0, 32686) || VMG_HAS_PERL(5, 12, 0)) +#if !(XSH_HAS_PERL_MAINT(5, 11, 0, 32686) || XSH_HAS_PERL(5, 12, 0)) /* The previous magic tokens were freed but the magic chain wasn't updated, so * if you access the sv from the callback the old deleted magics will trigger * and cause memory misreads. Change 32686 solved it that way : */ @@ -1586,15 +1524,15 @@ static int vmg_svt_free(pTHX_ SV *sv, MAGIC *mg) { PUTBACK; { - dMY_CXT; - MY_CXT.depth++; + dXSH_CXT; + XSH_CXT.depth++; vmg_call_sv(w->cb_free, G_SCALAR, vmg_svt_free_cleanup, &ud); - MY_CXT.depth--; - if (MY_CXT.depth == 0 && MY_CXT.freed_tokens) { + XSH_CXT.depth--; + if (XSH_CXT.depth == 0 && XSH_CXT.freed_tokens) { /* Free all the tokens in the chain but the current one (if it's present). * It will be taken care of by our caller, Perl_mg_free(). */ - vmg_magic_chain_free(MY_CXT.freed_tokens, mg); - MY_CXT.freed_tokens = NULL; + vmg_magic_chain_free(XSH_CXT.freed_tokens, mg); + XSH_CXT.freed_tokens = NULL; } } @@ -1620,7 +1558,7 @@ static int vmg_svt_free(pTHX_ SV *sv, MAGIC *mg) { #define vmg_svt_free_noop vmg_svt_default_noop -#if VMG_HAS_PERL_MAINT(5, 11, 0, 33256) || VMG_HAS_PERL(5, 12, 0) +#if XSH_HAS_PERL_MAINT(5, 11, 0, 33256) || XSH_HAS_PERL(5, 12, 0) # define VMG_SVT_COPY_KEYLEN_TYPE I32 #else # define VMG_SVT_COPY_KEYLEN_TYPE int @@ -1771,9 +1709,9 @@ static I32 vmg_svt_val(pTHX_ IV action, SV *sv) { #if VMG_RESET_RMG_NEEDS_TRAMPOLINE - dMY_CXT; + dXSH_CXT; - PL_op = vmg_trampoline_bump(&MY_CXT.reset_rmg, sv, PL_op); + PL_op = vmg_trampoline_bump(&XSH_CXT.reset_rmg, sv, PL_op); #else /* !VMG_RESET_RMG_NEEDS_TRAMPOLINE */ @@ -1807,56 +1745,16 @@ static I32 vmg_svt_val(pTHX_ IV action, SV *sv) { /* --- Module setup/teardown ----------------------------------------------- */ -#if VMG_THREADSAFE - -static I32 vmg_loaded = 0; - -/* We must use preexistent global mutexes or we will never be able to destroy - * them. */ -# if VMG_HAS_PERL(5, 9, 3) -# define VMG_LOADED_LOCK MUTEX_LOCK(&PL_my_ctx_mutex) -# define VMG_LOADED_UNLOCK MUTEX_UNLOCK(&PL_my_ctx_mutex) -# else -# define VMG_LOADED_LOCK OP_REFCNT_LOCK -# define VMG_LOADED_UNLOCK OP_REFCNT_UNLOCK -# endif +#if XSH_THREADSAFE -static void vmg_global_teardown_late_locked(pTHX) { -#define vmg_global_teardown_late_locked() vmg_global_teardown_late_locked(aTHX) +static void vmg_global_teardown_late_locked(pTHX_ void *ud) { +#define vmg_global_teardown_late_locked(UD) vmg_global_teardown_late_locked(aTHX_ (UD)) MUTEX_DESTROY(&vmg_op_name_init_mutex); MUTEX_DESTROY(&vmg_vtable_refcount_mutex); return; } -static int vmg_global_teardown_free(pTHX_ SV *sv, MAGIC *mg) { - VMG_LOADED_LOCK; - - if (vmg_loaded == 0) - vmg_global_teardown_late_locked(); - - VMG_LOADED_UNLOCK; - - return 0; -} - -static MGVTBL vmg_global_teardown_vtbl = { - 0, - 0, - 0, - 0, - vmg_global_teardown_free -#if MGf_COPY - , 0 -#endif -#if MGf_DUP - , 0 -#endif -#if MGf_LOCAL - , 0 -#endif -}; - static signed char vmg_destruct_level(pTHX) { #define vmg_destruct_level() vmg_destruct_level(aTHX) signed char lvl; @@ -1868,21 +1766,21 @@ static signed char vmg_destruct_level(pTHX) { const char *s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL"); if (s) { int i; -#if VMG_HAS_PERL(5, 21, 3) +#if XSH_HAS_PERL(5, 21, 3) if (strEQ(s, "-1")) { i = -1; } else { -# if VMG_HAS_PERL(5, 21, 10) +# if XSH_HAS_PERL(5, 21, 10) UV uv; if (Perl_grok_atoUV(s, &uv, NULL) && uv <= INT_MAX) i = (int) uv; else i = 0; -# else /* VMG_HAS_PERL(5, 21, 3) && !VMG_HAS_PERL(5, 21, 10) */ +# else /* XSH_HAS_PERL(5, 21, 3) && !XSH_HAS_PERL(5, 21, 10) */ i = Perl_grok_atou(s, NULL); # endif } -#else /* !VMG_HAS_PERL(5, 21, 3) */ +#else /* !XSH_HAS_PERL(5, 21, 3) */ i = atoi(s); #endif if (lvl < i) @@ -1894,74 +1792,35 @@ static signed char vmg_destruct_level(pTHX) { return lvl; } -#endif /* VMG_THREADSAFE */ - -static void vmg_teardown(pTHX_ void *param) { - dMY_CXT; - -#if VMG_THREADSAFE - VMG_LOADED_LOCK; +#endif /* XSH_THREADSAFE */ - if (vmg_loaded == 1) { - vmg_loaded = 0; - if (vmg_destruct_level() == 0) { - vmg_global_teardown_late_locked(); - } else { - if (!PL_strtab) - PL_strtab = newHV(); - vmg_sv_magicext((SV *) PL_strtab, NULL, &vmg_global_teardown_vtbl, NULL, 0); - } - } else { - VMG_ASSERT(vmg_loaded > 1); - --vmg_loaded; - } - - VMG_LOADED_UNLOCK; +static void xsh_user_global_setup(pTHX) { +#if XSH_THREADSAFE + MUTEX_INIT(&vmg_vtable_refcount_mutex); + MUTEX_INIT(&vmg_op_name_init_mutex); #endif - if (MY_CXT.depth == 0 && MY_CXT.freed_tokens) { - vmg_magic_chain_free(MY_CXT.freed_tokens, NULL); - MY_CXT.freed_tokens = NULL; - } - return; } -static void vmg_setup(pTHX) { -#define vmg_setup() vmg_setup(aTHX) +static void xsh_user_local_setup(pTHX_ xsh_user_cxt_t *cxt) { HV *stash; int c; - MY_CXT_INIT; - -#if VMG_THREADSAFE - VMG_LOADED_LOCK; - - if (vmg_loaded == 0) { - MUTEX_INIT(&vmg_vtable_refcount_mutex); - MUTEX_INIT(&vmg_op_name_init_mutex); - vmg_loaded = 1; - } else { - VMG_ASSERT(vmg_loaded > 0); - ++vmg_loaded; - } - - VMG_LOADED_UNLOCK; -#endif for (c = OPc_NULL; c < OPc_MAX; ++c) - MY_CXT.b__op_stashes[c] = NULL; + cxt->b__op_stashes[c] = NULL; - MY_CXT.depth = 0; - MY_CXT.freed_tokens = NULL; + cxt->depth = 0; + cxt->freed_tokens = NULL; #if VMG_PROPAGATE_ERRSV_NEEDS_TRAMPOLINE - vmg_trampoline_init(&MY_CXT.propagate_errsv, vmg_pp_propagate_errsv); + vmg_trampoline_init(&cxt->propagate_errsv, vmg_pp_propagate_errsv); #endif #if VMG_RESET_RMG_NEEDS_TRAMPOLINE - vmg_trampoline_init(&MY_CXT.reset_rmg, vmg_pp_reset_rmg); + vmg_trampoline_init(&cxt->reset_rmg, vmg_pp_reset_rmg); #endif - stash = gv_stashpv(__PACKAGE__, 1); + stash = gv_stashpv(XSH_PACKAGE, 1); newCONSTSUB(stash, "MGf_COPY", newSVuv(MGf_COPY)); newCONSTSUB(stash, "MGf_DUP", newSVuv(MGf_DUP)); newCONSTSUB(stash, "MGf_LOCAL", newSVuv(MGf_LOCAL)); @@ -1983,13 +1842,31 @@ static void vmg_setup(pTHX) { newCONSTSUB(stash, "VMG_COMPAT_CODE_COPY_CLONE", newSVuv(VMG_COMPAT_CODE_COPY_CLONE)); newCONSTSUB(stash, "VMG_COMPAT_GLOB_GET", newSVuv(VMG_COMPAT_GLOB_GET)); - newCONSTSUB(stash, "VMG_PERL_PATCHLEVEL", newSVuv(VMG_PERL_PATCHLEVEL)); - newCONSTSUB(stash, "VMG_THREADSAFE", newSVuv(VMG_THREADSAFE)); - newCONSTSUB(stash, "VMG_FORKSAFE", newSVuv(VMG_FORKSAFE)); + newCONSTSUB(stash, "VMG_PERL_PATCHLEVEL", newSVuv(XSH_PERL_PATCHLEVEL)); + newCONSTSUB(stash, "VMG_THREADSAFE", newSVuv(XSH_THREADSAFE)); + newCONSTSUB(stash, "VMG_FORKSAFE", newSVuv(XSH_FORKSAFE)); newCONSTSUB(stash, "VMG_OP_INFO_NAME", newSVuv(VMG_OP_INFO_NAME)); newCONSTSUB(stash, "VMG_OP_INFO_OBJECT", newSVuv(VMG_OP_INFO_OBJECT)); - call_atexit(vmg_teardown, NULL); + return; +} + +static void xsh_user_local_teardown(pTHX_ xsh_user_cxt_t *cxt) { + if (cxt->depth == 0 && cxt->freed_tokens) { + vmg_magic_chain_free(cxt->freed_tokens, NULL); + cxt->freed_tokens = NULL; + } + + return; +} + +static void xsh_user_global_teardown(pTHX) { +#if XSH_THREADSAFE + if (vmg_destruct_level() == 0) + vmg_global_teardown_late_locked(NULL); + else + xsh_teardown_late_register(vmg_global_teardown_late_locked, NULL); +#endif return; } @@ -2045,43 +1922,19 @@ PROTOTYPES: ENABLE BOOT: { - vmg_setup(); + xsh_setup(); } -#if VMG_THREADSAFE +#if XSH_THREADSAFE void CLONE(...) PROTOTYPE: DISABLE -PREINIT: - U32 had_b__op_stash = 0; - I32 old_depth; - int c; PPCODE: - { - dMY_CXT; - for (c = OPc_NULL; c < OPc_MAX; ++c) { - if (MY_CXT.b__op_stashes[c]) - had_b__op_stash |= (((U32) 1) << c); - } - old_depth = MY_CXT.depth; - } - { - MY_CXT_CLONE; - for (c = OPc_NULL; c < OPc_MAX; ++c) { - MY_CXT.b__op_stashes[c] = (had_b__op_stash & (((U32) 1) << c)) - ? gv_stashpv(vmg_opclassnames[c], 1) : NULL; - } - MY_CXT.depth = old_depth; - MY_CXT.freed_tokens = NULL; - VMG_LOADED_LOCK; - VMG_ASSERT(vmg_loaded > 0); - ++vmg_loaded; - VMG_LOADED_UNLOCK; - } + xsh_clone(); XSRETURN(0); -#endif /* VMG_THREADSAFE */ +#endif /* XSH_THREADSAFE */ SV *_wizard(...) PROTOTYPE: DISABLE diff --git a/Makefile.PL b/Makefile.PL index 4efbec5..9abd407 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -52,13 +52,13 @@ print $is_gcc_34 ? "yes\n" : "no\n"; # Threads, Windows and 5.8.x don't seem to be best friends if ($^O eq 'MSWin32' && "$]" < 5.009) { - push @DEFINES, '-DVMG_MULTIPLICITY=0'; + push @DEFINES, '-DXSH_MULTIPLICITY=0'; print "Thread safety disabled for perl 5.8.x on Windows.\n" } # Fork emulation got "fixed" in 5.10.1 if ($^O eq 'MSWin32' && "$]" < 5.010_001) { - push @DEFINES, '-DVMG_FORKSAFE=0'; + push @DEFINES, '-DXSH_FORKSAFE=0'; print "Fork safety not ensured for perl 5.8.x and 5.10.0 on Windows.\n"; } diff --git a/xsh/caps.h b/xsh/caps.h new file mode 100644 index 0000000..4559524 --- /dev/null +++ b/xsh/caps.h @@ -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/threads.h b/xsh/threads.h new file mode 100644 index 0000000..b72c63b --- /dev/null +++ b/xsh/threads.h @@ -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 index 0000000..dcc142c --- /dev/null +++ b/xsh/util.h @@ -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(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 */