X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2Findirect.git;a=blobdiff_plain;f=indirect.xs;fp=indirect.xs;h=0545e0149a56a33fa28e35cdfc382a3a1a1283f4;hp=ec533170104b8d1479aa1f7e894701d3cc92d911;hb=7b9a8ae944bb32360e3a8807ec6cb05376fd4183;hpb=dac575f9b1194a2f6fdec8b07b27bac62ecbe30c diff --git a/indirect.xs b/indirect.xs index ec53317..0545e01 100644 --- a/indirect.xs +++ b/indirect.xs @@ -6,19 +6,92 @@ #include "perl.h" #include "XSUB.h" -#define __PACKAGE__ "indirect" -#define __PACKAGE_LEN__ (sizeof(__PACKAGE__)-1) +/* --- XS helpers ---------------------------------------------------------- */ -/* --- Compatibility wrappers ---------------------------------------------- */ +#define XSH_PACKAGE "indirect" -#ifndef NOOP -# define NOOP -#endif +#include "xsh/caps.h" +#include "xsh/util.h" +#include "xsh/ops.h" + +/* ... op => source position map ........................................... */ + +typedef struct { + char *buf; + STRLEN pos; + STRLEN size; + STRLEN len; + line_t line; +} indirect_op_info_t; + +#define PTABLE_NAME ptable +#define PTABLE_VAL_FREE(V) if (V) { Safefree(((indirect_op_info_t *) (V))->buf); Safefree(V); } +#define PTABLE_NEED_DELETE 1 +#define PTABLE_NEED_WALK 0 + +#include "xsh/ptable.h" + +/* Safefree() always need aTHX */ +#define ptable_store(T, K, V) ptable_store(aTHX_ (T), (K), (V)) +#define ptable_delete(T, K) ptable_delete(aTHX_ (T), (K)) +#define ptable_clear(T) ptable_clear(aTHX_ (T)) +#define ptable_free(T) ptable_free(aTHX_ (T)) + +/* ... Lexical hints ....................................................... */ -#ifndef dNOOP -# define dNOOP +#define XSH_HINTS_TYPE_SV 1 + +#include "xsh/hints.h" + +/* ... Thread-local storage ................................................ */ + +typedef struct { + ptable *map; + SV *global_code; +} xsh_user_cxt_t; + +#define XSH_THREADS_USER_CONTEXT 1 +#define XSH_THREADS_USER_CLONE_NEEDS_DUP 1 +#define XSH_THREADS_COMPILE_TIME_PROTECTION 1 + +#if XSH_THREADSAFE + +static void xsh_user_clone(pTHX_ const xsh_user_cxt_t *old_cxt, xsh_user_cxt_t *new_cxt, CLONE_PARAMS *params) { + new_cxt->map = ptable_new(32); + new_cxt->global_code = xsh_dup_inc(old_cxt->global_code, params); + + return; +} + +#endif /* XSH_THREADSAFE */ + +#include "xsh/threads.h" + +/* ... Lexical hints, continued ............................................ */ + +static SV *indirect_hint(pTHX) { +#define indirect_hint() indirect_hint(aTHX) + SV *hint; + +#if XSH_HAS_PERL(5, 10, 0) || defined(PL_parser) + if (!PL_parser) + return NULL; #endif + hint = xsh_hints_fetch(); + if (hint && SvOK(hint)) { + return xsh_hints_detag(hint); + } else { + dXSH_CXT; + if (xsh_is_loaded(&XSH_CXT)) + return XSH_CXT.global_code; + else + return NULL; + } +} + +/* --- Compatibility wrappers ---------------------------------------------- */ + #ifndef Newx # define Newx(v, n, c) New(0, v, n, c) #endif @@ -63,17 +136,7 @@ # 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 - -#define I_HAS_PERL(R, V, S) (PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S)))))) - -#if I_HAS_PERL(5, 10, 0) || defined(PL_parser) +#if XSH_HAS_PERL(5, 10, 0) || defined(PL_parser) # ifndef PL_linestr # define PL_linestr PL_parser->linestr # endif @@ -101,550 +164,7 @@ # endif #endif -#ifdef DEBUGGING -# define I_ASSERT(C) assert(C) -#else -# define I_ASSERT(C) -#endif - -#ifndef I_WORKAROUND_REQUIRE_PROPAGATION -# define I_WORKAROUND_REQUIRE_PROPAGATION !I_HAS_PERL(5, 10, 1) -#endif - -/* ... Thread safety and multiplicity ...................................... */ - -/* Safe unless stated otherwise in Makefile.PL */ -#ifndef I_FORKSAFE -# define I_FORKSAFE 1 -#endif - -#ifndef I_MULTIPLICITY -# if defined(MULTIPLICITY) -# define I_MULTIPLICITY 1 -# else -# define I_MULTIPLICITY 0 -# endif -#endif -#if I_MULTIPLICITY -# ifndef PERL_IMPLICIT_CONTEXT -# error MULTIPLICITY builds must set PERL_IMPLICIT_CONTEXT -# endif -#endif -#if I_MULTIPLICITY && !defined(tTHX) -# define tTHX PerlInterpreter* -#endif - -#if I_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 I_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 I_THREADSAFE 0 -# undef dMY_CXT -# define dMY_CXT dNOOP -# undef MY_CXT -# define MY_CXT indirect_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 I_THREADSAFE -/* We must use preexistent global mutexes or we will never be able to destroy - * them. */ -# if I_HAS_PERL(5, 9, 3) -# define I_LOADED_LOCK MUTEX_LOCK(&PL_my_ctx_mutex) -# define I_LOADED_UNLOCK MUTEX_UNLOCK(&PL_my_ctx_mutex) -# else -# define I_LOADED_LOCK OP_REFCNT_LOCK -# define I_LOADED_UNLOCK OP_REFCNT_UNLOCK -# endif -#else -# define I_LOADED_LOCK NOOP -# define I_LOADED_UNLOCK NOOP -#endif - -#if defined(OP_CHECK_MUTEX_LOCK) && defined(OP_CHECK_MUTEX_UNLOCK) -# define I_CHECK_LOCK OP_CHECK_MUTEX_LOCK -# define I_CHECK_UNLOCK OP_CHECK_MUTEX_UNLOCK -#elif I_HAS_PERL(5, 9, 3) -# define I_CHECK_LOCK OP_REFCNT_LOCK -# define I_CHECK_UNLOCK OP_REFCNT_UNLOCK -#else -/* Before perl 5.9.3, indirect_ck_*() calls are already protected by the - * I_LOADED mutex, which falls back to the OP_REFCNT mutex. Make sure we don't - * lock it twice. */ -# define I_CHECK_LOCK NOOP -# define I_CHECK_UNLOCK NOOP -#endif - -typedef OP *(*indirect_ck_t)(pTHX_ OP *); - -#ifdef wrap_op_checker - -# define indirect_ck_replace(T, NC, OCP) wrap_op_checker((T), (NC), (OCP)) - -#else - -static void indirect_ck_replace(pTHX_ OPCODE type, indirect_ck_t new_ck, indirect_ck_t *old_ck_p) { -#define indirect_ck_replace(T, NC, OCP) indirect_ck_replace(aTHX_ (T), (NC), (OCP)) - I_CHECK_LOCK; - if (!*old_ck_p) { - *old_ck_p = PL_check[type]; - PL_check[type] = new_ck; - } - I_CHECK_UNLOCK; -} - -#endif - -static void indirect_ck_restore(pTHX_ OPCODE type, indirect_ck_t *old_ck_p) { -#define indirect_ck_restore(T, OCP) indirect_ck_restore(aTHX_ (T), (OCP)) - I_CHECK_LOCK; - if (*old_ck_p) { - PL_check[type] = *old_ck_p; - *old_ck_p = 0; - } - I_CHECK_UNLOCK; -} - -/* --- Helpers ------------------------------------------------------------- */ - -/* ... Check if the module is loaded ....................................... */ - -static I32 indirect_loaded = 0; - -#if I_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 *indirect_loaded_cxts = NULL; - -static int indirect_is_loaded(pTHX_ void *cxt) { -#define indirect_is_loaded(C) indirect_is_loaded(aTHX_ (C)) - int res = 0; - - I_LOADED_LOCK; - if (indirect_loaded_cxts && ptable_fetch(indirect_loaded_cxts, cxt)) - res = 1; - I_LOADED_UNLOCK; - - return res; -} - -static int indirect_set_loaded_locked(pTHX_ void *cxt) { -#define indirect_set_loaded_locked(C) indirect_set_loaded_locked(aTHX_ (C)) - int global_setup = 0; - - if (indirect_loaded <= 0) { - I_ASSERT(indirect_loaded == 0); - I_ASSERT(!indirect_loaded_cxts); - indirect_loaded_cxts = ptable_new(); - global_setup = 1; - } - ++indirect_loaded; - I_ASSERT(indirect_loaded_cxts); - ptable_loaded_store(indirect_loaded_cxts, cxt, cxt); - - return global_setup; -} - -static int indirect_clear_loaded_locked(pTHX_ void *cxt) { -#define indirect_clear_loaded_locked(C) indirect_clear_loaded_locked(aTHX_ (C)) - int global_teardown = 0; - - if (indirect_loaded > 1) { - I_ASSERT(indirect_loaded_cxts); - ptable_loaded_delete(indirect_loaded_cxts, cxt); - --indirect_loaded; - } else if (indirect_loaded_cxts) { - I_ASSERT(indirect_loaded == 1); - ptable_loaded_free(indirect_loaded_cxts); - indirect_loaded_cxts = NULL; - indirect_loaded = 0; - global_teardown = 1; - } - - return global_teardown; -} - -#else - -#define indirect_is_loaded(C) (indirect_loaded > 0) -#define indirect_set_loaded_locked(C) ((indirect_loaded++ <= 0) ? 1 : 0) -#define indirect_clear_loaded_locked(C) ((--indirect_loaded <= 0) ? 1 : 0) - -#endif - -/* ... Thread-safe hints ................................................... */ - -#if I_WORKAROUND_REQUIRE_PROPAGATION - -typedef struct { - SV *code; - IV require_tag; -} indirect_hint_t; - -#define I_HINT_STRUCT 1 - -#define I_HINT_CODE(H) ((H)->code) - -#define I_HINT_FREE(H) { \ - indirect_hint_t *h = (H); \ - SvREFCNT_dec(h->code); \ - PerlMemShared_free(h); \ -} - -#else /* I_WORKAROUND_REQUIRE_PROPAGATION */ - -typedef SV indirect_hint_t; - -#define I_HINT_STRUCT 0 - -#define I_HINT_CODE(H) (H) - -#define I_HINT_FREE(H) SvREFCNT_dec(H); - -#endif /* !I_WORKAROUND_REQUIRE_PROPAGATION */ - -#if I_THREADSAFE - -#define PTABLE_NAME ptable_hints -#define PTABLE_VAL_FREE(V) I_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 /* I_THREADSAFE */ - -/* Define the op->str ptable here because we need to be able to clean it during - * thread cleanup. */ - -typedef struct { - char *buf; - STRLEN pos; - STRLEN size; - STRLEN len; - line_t line; -} indirect_op_info_t; - -#define PTABLE_NAME ptable -#define PTABLE_VAL_FREE(V) if (V) { Safefree(((indirect_op_info_t *) (V))->buf); Safefree(V); } -#define PTABLE_NEED_DELETE 1 -#define PTABLE_NEED_WALK 0 - -#define pPTBL pTHX -#define pPTBL_ pTHX_ -#define aPTBL aTHX -#define aPTBL_ aTHX_ - -#include "ptable.h" - -#define ptable_store(T, K, V) ptable_store(aTHX_ (T), (K), (V)) -#define ptable_delete(T, K) ptable_delete(aTHX_ (T), (K)) -#define ptable_clear(T) ptable_clear(aTHX_ (T)) -#define ptable_free(T) ptable_free(aTHX_ (T)) - -#define MY_CXT_KEY __PACKAGE__ "::_guts" XS_VERSION - -typedef struct { -#if I_THREADSAFE - ptable *tbl; /* It really is a ptable_hints */ - tTHX owner; -#endif - ptable *map; - SV *global_code; -} my_cxt_t; - -START_MY_CXT - -#if I_THREADSAFE - -typedef struct { - ptable *tbl; -#if I_HAS_PERL(5, 13, 2) - CLONE_PARAMS *params; -#else - CLONE_PARAMS params; -#endif -} indirect_ptable_clone_ud; - -#if I_HAS_PERL(5, 13, 2) -# define indirect_ptable_clone_ud_init(U, T, O) \ - (U).tbl = (T); \ - (U).params = Perl_clone_params_new((O), aTHX) -# define indirect_ptable_clone_ud_deinit(U) Perl_clone_params_del((U).params) -# define indirect_dup_inc(S, U) SvREFCNT_inc(sv_dup((S), (U)->params)) -#else -# define indirect_ptable_clone_ud_init(U, T, O) \ - (U).tbl = (T); \ - (U).params.stashes = newAV(); \ - (U).params.flags = 0; \ - (U).params.proto_perl = (O) -# define indirect_ptable_clone_ud_deinit(U) SvREFCNT_dec((U).params.stashes) -# define indirect_dup_inc(S, U) SvREFCNT_inc(sv_dup((S), &((U)->params))) -#endif - -static void indirect_ptable_clone(pTHX_ ptable_ent *ent, void *ud_) { - indirect_ptable_clone_ud *ud = ud_; - indirect_hint_t *h1 = ent->val; - indirect_hint_t *h2; - -#if I_HINT_STRUCT - - h2 = PerlMemShared_malloc(sizeof *h2); - h2->code = indirect_dup_inc(h1->code, ud); -#if I_WORKAROUND_REQUIRE_PROPAGATION - h2->require_tag = PTR2IV(indirect_dup_inc(INT2PTR(SV *, h1->require_tag), ud)); -#endif - -#else /* I_HINT_STRUCT */ - - h2 = indirect_dup_inc(h1, ud); - -#endif /* !I_HINT_STRUCT */ - - ptable_hints_store(ud->tbl, ent->key, h2); -} - -#endif /* I_THREADSAFE */ - -#if I_WORKAROUND_REQUIRE_PROPAGATION - -static IV indirect_require_tag(pTHX) { -#define indirect_require_tag() indirect_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); -} - -#endif /* I_WORKAROUND_REQUIRE_PROPAGATION */ - -static SV *indirect_tag(pTHX_ SV *value) { -#define indirect_tag(V) indirect_tag(aTHX_ (V)) - indirect_hint_t *h; - SV *code = NULL; -#if I_THREADSAFE - dMY_CXT; - - if (!MY_CXT.tbl) - return newSViv(0); -#endif /* I_THREADSAFE */ - - if (SvROK(value)) { - value = SvRV(value); - if (SvTYPE(value) >= SVt_PVCV) { - code = value; - SvREFCNT_inc_simple_void_NN(code); - } - } - -#if I_HINT_STRUCT - h = PerlMemShared_malloc(sizeof *h); - h->code = code; -# if I_WORKAROUND_REQUIRE_PROPAGATION - h->require_tag = indirect_require_tag(); -# endif /* I_WORKAROUND_REQUIRE_PROPAGATION */ -#else /* I_HINT_STRUCT */ - h = code; -#endif /* !I_HINT_STRUCT */ - -#if I_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 /* I_THREADSAFE */ - - return newSViv(PTR2IV(h)); -} - -static SV *indirect_detag(pTHX_ const SV *hint) { -#define indirect_detag(H) indirect_detag(aTHX_ (H)) - indirect_hint_t *h; -#if I_THREADSAFE || I_WORKAROUND_REQUIRE_PROPAGATION - dMY_CXT; -#endif - -#if I_THREADSAFE - if (!MY_CXT.tbl) - return NULL; -#endif /* I_THREADSAFE */ - - h = INT2PTR(indirect_hint_t *, SvIVX(hint)); -#if I_THREADSAFE - h = ptable_fetch(MY_CXT.tbl, h); -#endif /* I_THREADSAFE */ - -#if I_WORKAROUND_REQUIRE_PROPAGATION - if (indirect_require_tag() != h->require_tag) - return MY_CXT.global_code; -#endif /* I_WORKAROUND_REQUIRE_PROPAGATION */ - - return I_HINT_CODE(h); -} - -static VOL U32 indirect_hash = 0; - -static SV *indirect_hint(pTHX) { -#define indirect_hint() indirect_hint(aTHX) - SV *hint = NULL; - - if (IN_PERL_RUNTIME) - return NULL; - -#if I_HAS_PERL(5, 10, 0) || defined(PL_parser) - if (!PL_parser) - return NULL; -#endif - -#ifdef cop_hints_fetch_pvn - hint = cop_hints_fetch_pvn(PL_curcop, __PACKAGE__, __PACKAGE_LEN__, - indirect_hash, 0); -#elif I_HAS_PERL(5, 9, 5) - hint = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, - NULL, - __PACKAGE__, __PACKAGE_LEN__, - 0, - indirect_hash); -#else - { - SV **val = hv_fetch(GvHV(PL_hintgv), __PACKAGE__, __PACKAGE_LEN__, 0); - if (val) - hint = *val; - } -#endif - - if (hint && SvIOK(hint)) { - return indirect_detag(hint); - } else { - dMY_CXT; - if (indirect_is_loaded(&MY_CXT)) - return MY_CXT.global_code; - else - return NULL; - } -} - -/* ... op -> source position ............................................... */ - -static void indirect_map_store(pTHX_ const OP *o, STRLEN pos, SV *sv, line_t line) { -#define indirect_map_store(O, P, N, L) indirect_map_store(aTHX_ (O), (P), (N), (L)) - indirect_op_info_t *oi; - const char *s; - STRLEN len; - dMY_CXT; - - /* No need to check for MY_CXT.map != NULL because this code path is always - * guarded by indirect_hint(). */ - - if (!(oi = ptable_fetch(MY_CXT.map, o))) { - Newx(oi, 1, indirect_op_info_t); - ptable_store(MY_CXT.map, o, oi); - oi->buf = NULL; - oi->size = 0; - } - - if (sv) { - s = SvPV_const(sv, len); - } else { - s = "{"; - len = 1; - } - - if (len > oi->size) { - Safefree(oi->buf); - Newx(oi->buf, len, char); - oi->size = len; - } - Copy(s, oi->buf, len, char); - - oi->len = len; - oi->pos = pos; - oi->line = line; -} - -static const indirect_op_info_t *indirect_map_fetch(pTHX_ const OP *o) { -#define indirect_map_fetch(O) indirect_map_fetch(aTHX_ (O)) - dMY_CXT; - - /* No need to check for MY_CXT.map != NULL because this code path is always - * guarded by indirect_hint(). */ - - return ptable_fetch(MY_CXT.map, o); -} - -static void indirect_map_delete(pTHX_ const OP *o) { -#define indirect_map_delete(O) indirect_map_delete(aTHX_ (O)) - dMY_CXT; - - if (indirect_is_loaded(&MY_CXT) && MY_CXT.map) - ptable_delete(MY_CXT.map, o); -} - -/* --- Safe version of call_sv() ------------------------------------------- */ +/* ... Safe version of call_sv() ........................................... */ static I32 indirect_call_sv(pTHX_ SV *sv, I32 flags) { #define indirect_call_sv(S, F) indirect_call_sv(aTHX_ (S), (F)) @@ -679,7 +199,7 @@ static I32 indirect_call_sv(pTHX_ SV *sv, I32 flags) { SvCUR_set(ERRSV, 0); /* Immediately flush all errors. */ if (IN_PERL_COMPILETIME) { -#if I_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) @@ -708,6 +228,64 @@ static I32 indirect_call_sv(pTHX_ SV *sv, I32 flags) { /* --- Check functions ----------------------------------------------------- */ +/* ... op => source position map, continued ................................ */ + +static void indirect_map_store(pTHX_ const OP *o, STRLEN pos, SV *sv, line_t line) { +#define indirect_map_store(O, P, N, L) indirect_map_store(aTHX_ (O), (P), (N), (L)) + indirect_op_info_t *oi; + const char *s; + STRLEN len; + dXSH_CXT; + + /* No need to check for XSH_CXT.map != NULL because this code path is always + * guarded by indirect_hint(). */ + + if (!(oi = ptable_fetch(XSH_CXT.map, o))) { + Newx(oi, 1, indirect_op_info_t); + ptable_store(XSH_CXT.map, o, oi); + oi->buf = NULL; + oi->size = 0; + } + + if (sv) { + s = SvPV_const(sv, len); + } else { + s = "{"; + len = 1; + } + + if (len > oi->size) { + Safefree(oi->buf); + Newx(oi->buf, len, char); + oi->size = len; + } + Copy(s, oi->buf, len, char); + + oi->len = len; + oi->pos = pos; + oi->line = line; +} + +static const indirect_op_info_t *indirect_map_fetch(pTHX_ const OP *o) { +#define indirect_map_fetch(O) indirect_map_fetch(aTHX_ (O)) + dXSH_CXT; + + /* No need to check for XSH_CXT.map != NULL because this code path is always + * guarded by indirect_hint(). */ + + return ptable_fetch(XSH_CXT.map, o); +} + +static void indirect_map_delete(pTHX_ const OP *o) { +#define indirect_map_delete(O) indirect_map_delete(aTHX_ (O)) + dXSH_CXT; + + if (xsh_is_loaded(&XSH_CXT) && XSH_CXT.map) + ptable_delete(XSH_CXT.map, o); +} + +/* ... Heuristics for finding a string in the source buffer ................ */ + static int indirect_find(pTHX_ SV *name_sv, const char *line_bufptr, STRLEN *name_pos) { #define indirect_find(NSV, LBP, NP) indirect_find(aTHX_ (NSV), (LBP), (NP)) STRLEN name_len, line_len; @@ -1078,81 +656,56 @@ done: /* --- Module setup/teardown ----------------------------------------------- */ -static void indirect_teardown(pTHX_ void *interp) { - dMY_CXT; - - I_LOADED_LOCK; - - if (indirect_clear_loaded_locked(&MY_CXT)) { - indirect_ck_restore(OP_CONST, &indirect_old_ck_const); - indirect_ck_restore(OP_RV2SV, &indirect_old_ck_rv2sv); - indirect_ck_restore(OP_PADANY, &indirect_old_ck_padany); - indirect_ck_restore(OP_SCOPE, &indirect_old_ck_scope); - indirect_ck_restore(OP_LINESEQ, &indirect_old_ck_lineseq); - - indirect_ck_restore(OP_METHOD, &indirect_old_ck_method); - indirect_ck_restore(OP_METHOD_NAMED, &indirect_old_ck_method_named); - indirect_ck_restore(OP_ENTERSUB, &indirect_old_ck_entersub); - } - - I_LOADED_UNLOCK; +static void xsh_user_global_setup(pTHX) { + xsh_ck_replace(OP_CONST, indirect_ck_const, &indirect_old_ck_const); + xsh_ck_replace(OP_RV2SV, indirect_ck_rv2sv, &indirect_old_ck_rv2sv); + xsh_ck_replace(OP_PADANY, indirect_ck_padany, &indirect_old_ck_padany); + xsh_ck_replace(OP_SCOPE, indirect_ck_scope, &indirect_old_ck_scope); + xsh_ck_replace(OP_LINESEQ, indirect_ck_scope, &indirect_old_ck_lineseq); - SvREFCNT_dec(MY_CXT.global_code); - MY_CXT.global_code = NULL; - - ptable_free(MY_CXT.map); - MY_CXT.map = NULL; - -#if I_THREADSAFE - ptable_hints_free(MY_CXT.tbl); - MY_CXT.tbl = NULL; -#endif + xsh_ck_replace(OP_METHOD, indirect_ck_method, + &indirect_old_ck_method); + xsh_ck_replace(OP_METHOD_NAMED, indirect_ck_method_named, + &indirect_old_ck_method_named); + xsh_ck_replace(OP_ENTERSUB, indirect_ck_entersub, + &indirect_old_ck_entersub); return; } -static void indirect_setup(pTHX) { -#define indirect_setup() indirect_setup(aTHX) - MY_CXT_INIT; /* Takes/release PL_my_ctx_mutex */ +static void xsh_user_local_setup(pTHX_ xsh_user_cxt_t *cxt) { + HV *stash; - I_LOADED_LOCK; + stash = gv_stashpvn(XSH_PACKAGE, XSH_PACKAGE_LEN, 1); + newCONSTSUB(stash, "I_THREADSAFE", newSVuv(XSH_THREADSAFE)); + newCONSTSUB(stash, "I_FORKSAFE", newSVuv(XSH_FORKSAFE)); - if (indirect_set_loaded_locked(&MY_CXT)) { - PERL_HASH(indirect_hash, __PACKAGE__, __PACKAGE_LEN__); - - indirect_ck_replace(OP_CONST, indirect_ck_const, &indirect_old_ck_const); - indirect_ck_replace(OP_RV2SV, indirect_ck_rv2sv, &indirect_old_ck_rv2sv); - indirect_ck_replace(OP_PADANY, indirect_ck_padany, &indirect_old_ck_padany); - indirect_ck_replace(OP_SCOPE, indirect_ck_scope, &indirect_old_ck_scope); - indirect_ck_replace(OP_LINESEQ, indirect_ck_scope, &indirect_old_ck_lineseq); - - indirect_ck_replace(OP_METHOD, indirect_ck_method, - &indirect_old_ck_method); - indirect_ck_replace(OP_METHOD_NAMED, indirect_ck_method_named, - &indirect_old_ck_method_named); - indirect_ck_replace(OP_ENTERSUB, indirect_ck_entersub, - &indirect_old_ck_entersub); - } + cxt->map = ptable_new(32); + cxt->global_code = NULL; - I_LOADED_UNLOCK; + return; +} - { - HV *stash; +static void xsh_user_local_teardown(pTHX_ xsh_user_cxt_t *cxt) { + SvREFCNT_dec(cxt->global_code); + cxt->global_code = NULL; - stash = gv_stashpvn(__PACKAGE__, __PACKAGE_LEN__, 1); - newCONSTSUB(stash, "I_THREADSAFE", newSVuv(I_THREADSAFE)); - newCONSTSUB(stash, "I_FORKSAFE", newSVuv(I_FORKSAFE)); + ptable_free(cxt->map); + cxt->map = NULL; -#if I_THREADSAFE - MY_CXT.tbl = ptable_new(); - MY_CXT.owner = aTHX; -#endif + return; +} - MY_CXT.map = ptable_new(); - MY_CXT.global_code = NULL; - } +static void xsh_user_global_teardown(pTHX) { + xsh_ck_restore(OP_CONST, &indirect_old_ck_const); + xsh_ck_restore(OP_RV2SV, &indirect_old_ck_rv2sv); + xsh_ck_restore(OP_PADANY, &indirect_old_ck_padany); + xsh_ck_restore(OP_SCOPE, &indirect_old_ck_scope); + xsh_ck_restore(OP_LINESEQ, &indirect_old_ck_lineseq); - call_atexit(indirect_teardown, NULL); + xsh_ck_restore(OP_METHOD, &indirect_old_ck_method); + xsh_ck_restore(OP_METHOD_NAMED, &indirect_old_ck_method_named); + xsh_ck_restore(OP_ENTERSUB, &indirect_old_ck_entersub); return; } @@ -1165,50 +718,29 @@ PROTOTYPES: ENABLE BOOT: { - indirect_setup(); + xsh_setup(); } -#if I_THREADSAFE +#if XSH_THREADSAFE void CLONE(...) PROTOTYPE: DISABLE -PREINIT: - ptable *t; - SV *global_code_dup; PPCODE: - { - indirect_ptable_clone_ud ud; - dMY_CXT; - t = ptable_new(); - indirect_ptable_clone_ud_init(ud, t, MY_CXT.owner); - ptable_walk(MY_CXT.tbl, indirect_ptable_clone, &ud); - global_code_dup = indirect_dup_inc(MY_CXT.global_code, &ud); - indirect_ptable_clone_ud_deinit(ud); - } - { - MY_CXT_CLONE; - MY_CXT.map = ptable_new(); - MY_CXT.tbl = t; - MY_CXT.owner = aTHX; - MY_CXT.global_code = global_code_dup; - { - int global_setup; - I_LOADED_LOCK; - global_setup = indirect_set_loaded_locked(&MY_CXT); - I_ASSERT(!global_setup); - I_LOADED_UNLOCK; - } - } + xsh_clone(); XSRETURN(0); -#endif /* I_THREADSAFE */ +#endif /* XSH_THREADSAFE */ SV * -_tag(SV *value) +_tag(SV *code) PROTOTYPE: $ CODE: - RETVAL = indirect_tag(value); + if (!SvOK(code)) + code = NULL; + else if (SvROK(code)) + code = SvRV(code); + RETVAL = xsh_hints_tag(code); OUTPUT: RETVAL @@ -1221,8 +753,8 @@ PPCODE: else if (SvROK(code)) code = SvRV(code); { - dMY_CXT; - SvREFCNT_dec(MY_CXT.global_code); - MY_CXT.global_code = SvREFCNT_inc(code); + dXSH_CXT; + SvREFCNT_dec(XSH_CXT.global_code); + XSH_CXT.global_code = SvREFCNT_inc(code); } XSRETURN(0);