X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2Findirect.git;a=blobdiff_plain;f=indirect.xs;h=4e538b3d63ca7803d4ba7222d9eed839416fba7a;hp=b19e11a929114d600a0fccb89489799975424e53;hb=67870a0f2916e9b66e3c4e95e81578a60328b2c0;hpb=a6e7df84c1196a8c6d12692a06d913a24c5d530a diff --git a/indirect.xs b/indirect.xs index b19e11a..4e538b3 100644 --- a/indirect.xs +++ b/indirect.xs @@ -11,6 +11,14 @@ /* --- Compatibility wrappers ---------------------------------------------- */ +#ifndef NOOP +# define NOOP +#endif + +#ifndef dNOOP +# define dNOOP +#endif + #ifndef SvPV_const # define SvPV_const SvPV #endif @@ -27,6 +35,10 @@ # define sv_catpvn_nomg sv_catpvn #endif +#ifndef mPUSHu +# define mPUSHu(U) PUSHs(sv_2mortal(newSVuv(U))) +#endif + #ifndef HvNAME_get # define HvNAME_get(H) HvNAME(H) #endif @@ -35,10 +47,6 @@ # define HvNAMELEN_get(H) strlen(HvNAME_get(H)) #endif -#ifndef SvIS_FREED -# define SvIS_FREED(sv) ((sv)->sv_flags == SVTYPEMASK) -#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) @@ -69,6 +77,10 @@ # endif #endif +#ifndef I_WORKAROUND_REQUIRE_PROPAGATION +# define I_WORKAROUND_REQUIRE_PROPAGATION !I_HAS_PERL(5, 10, 1) +#endif + /* ... Thread safety and multiplicity ...................................... */ #ifndef I_MULTIPLICITY @@ -93,16 +105,41 @@ # 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 /* --- Helpers ------------------------------------------------------------- */ /* ... Thread-safe hints ................................................... */ -#if I_THREADSAFE +/* If any of those are true, we need to store the hint in a global table. */ -#define PTABLE_NAME ptable_hints -#define PTABLE_VAL_FREE(V) if ((V) && !SvIS_FREED((SV *) (V))) SvREFCNT_dec(V) +#if I_THREADSAFE || I_WORKAROUND_REQUIRE_PROPAGATION + +typedef struct { + SV *code; +#if I_WORKAROUND_REQUIRE_PROPAGATION + I32 requires; +#endif +} indirect_hint_t; + +#define PTABLE_NAME ptable_hints + +#if I_WORKAROUND_REQUIRE_PROPAGATION +# define PTABLE_VAL_FREE(V) \ + { indirect_hint_t *h = (V); SvREFCNT_dec(h->code); PerlMemShared_free(h); } +#else +# define PTABLE_VAL_FREE(V) SvREFCNT_dec(V) +#endif #define pPTBL pTHX #define pPTBL_ pTHX_ @@ -114,41 +151,71 @@ #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 || I_WORKAROUND_REQUIRE_PROPAGATION */ + +/* Define the op->str ptable here because we need to be able to clean it during + * thread cleanup. */ + +#define PTABLE_NAME ptable +#define PTABLE_VAL_FREE(V) SvREFCNT_dec(V) + +#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_clear(T) ptable_clear(aTHX_ (T)) +#define ptable_free(T) ptable_free(aTHX_ (T)) + #define MY_CXT_KEY __PACKAGE__ "::_guts" XS_VERSION typedef struct { - ptable *tbl; - tTHX owner; +#if I_THREADSAFE || I_WORKAROUND_REQUIRE_PROPAGATION + ptable *tbl; /* It really is a ptable_hints */ +#endif + ptable *map; + const char *linestr; +#if I_THREADSAFE + tTHX owner; +#endif } my_cxt_t; START_MY_CXT -STATIC void indirect_ptable_hints_clone(pTHX_ ptable_ent *ent, void *ud_) { - my_cxt_t *ud = ud_; - SV *val = ent->val; +#if I_THREADSAFE + +STATIC void indirect_ptable_clone(pTHX_ ptable_ent *ent, void *ud_) { + my_cxt_t *ud = ud_; + indirect_hint_t *h1 = ent->val; + indirect_hint_t *h2 = PerlMemShared_malloc(sizeof *h2); + + *h2 = *h1; if (ud->owner != aTHX) { + SV *val = h1->code; CLONE_PARAMS param; AV *stashes = (SvTYPE(val) == SVt_PVHV && HvNAME_get(val)) ? newAV() : NULL; param.stashes = stashes; param.flags = 0; param.proto_perl = ud->owner; - val = sv_dup(val, ¶m); + h2->code = sv_dup(val, ¶m); if (stashes) { av_undef(stashes); SvREFCNT_dec(stashes); } } - ptable_hints_store(ud->tbl, ent->key, val); - SvREFCNT_inc(val); + ptable_hints_store(ud->tbl, ent->key, h2); + SvREFCNT_inc(h2->code); } STATIC void indirect_thread_cleanup(pTHX_ void *); STATIC void indirect_thread_cleanup(pTHX_ void *ud) { int *level = ud; - SV *id; if (*level) { *level = 0; @@ -158,39 +225,83 @@ STATIC void indirect_thread_cleanup(pTHX_ void *ud) { } else { dMY_CXT; PerlMemShared_free(level); + ptable_free(MY_CXT.map); ptable_hints_free(MY_CXT.tbl); } } +#endif /* I_THREADSAFE */ + +#if I_THREADSAFE || I_WORKAROUND_REQUIRE_PROPAGATION + STATIC SV *indirect_tag(pTHX_ SV *value) { #define indirect_tag(V) indirect_tag(aTHX_ (V)) + indirect_hint_t *h; dMY_CXT; value = SvOK(value) && SvROK(value) ? SvRV(value) : NULL; + + h = PerlMemShared_malloc(sizeof *h); + h->code = SvREFCNT_inc(value); + +#if I_WORKAROUND_REQUIRE_PROPAGATION + { + const PERL_SI *si; + I32 requires = 0; + + 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; + + if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_REQUIRE) + ++requires; + } + } + + h->requires = requires; + } +#endif + /* 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 value pointer as the key itself. */ - ptable_hints_store(MY_CXT.tbl, value, value); - SvREFCNT_inc(value); + ptable_hints_store(MY_CXT.tbl, value, h); return newSVuv(PTR2UV(value)); } STATIC SV *indirect_detag(pTHX_ const SV *hint) { #define indirect_detag(H) indirect_detag(aTHX_ (H)) - void *tag; - SV *value; + indirect_hint_t *h; + dMY_CXT; + + if (!(hint && SvOK(hint) && SvIOK(hint))) + return NULL; - if (!hint || !SvOK(hint) || !SvIOK(hint)) - croak("Wrong hint"); + h = ptable_fetch(MY_CXT.tbl, INT2PTR(void *, SvUVX(hint))); - tag = INT2PTR(void *, SvIVX(hint)); +#if I_WORKAROUND_REQUIRE_PROPAGATION { - dMY_CXT; - value = ptable_fetch(MY_CXT.tbl, tag); + const PERL_SI *si; + I32 requires = 0; + + 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; + + if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_REQUIRE + && ++requires > h->requires) + return NULL; + } + } } +#endif - return value; + return h->code; } #else @@ -208,52 +319,36 @@ STATIC SV *indirect_tag(pTHX_ SV *value) { return newSVuv(tag); } -#define indirect_detag(H) INT2PTR(SV *, SvUVX(H)) +#define indirect_detag(H) (((H) && SvOK(H)) ? INT2PTR(SV *, SvUVX(H)) : NULL) -#endif /* I_THREADSAFE */ +#endif /* I_THREADSAFE || I_WORKAROUND_REQUIRE_PROPAGATION */ STATIC U32 indirect_hash = 0; STATIC SV *indirect_hint(pTHX) { #define indirect_hint() indirect_hint(aTHX) - SV *id; -#if I_HAS_PERL(5, 10, 0) - id = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, - NULL, - __PACKAGE__, __PACKAGE_LEN__, - 0, - indirect_hash); + SV *hint, *code; +#if 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__, indirect_hash); if (!val) return 0; - id = *val; + hint = *val; #endif - return (id && SvOK(id)) ? id : NULL; + return indirect_detag(hint); } /* ... op -> source position ............................................... */ -#define PTABLE_NAME ptable_map -#define PTABLE_VAL_FREE(V) SvREFCNT_dec(V) - -#define pPTBL pTHX -#define pPTBL_ pTHX_ -#define aPTBL aTHX -#define aPTBL_ aTHX_ - -#include "ptable.h" - -#define ptable_map_store(T, K, V) ptable_map_store(aTHX_ (T), (K), (V)) -#define ptable_map_clear(T) ptable_map_clear(aTHX_ (T)) - -STATIC ptable *indirect_map = NULL; - -STATIC const char *indirect_linestr = NULL; - STATIC void indirect_map_store(pTHX_ const OP *o, const char *src, SV *sv) { #define indirect_map_store(O, S, N) indirect_map_store(aTHX_ (O), (S), (N)) + dMY_CXT; SV *val; /* When lex_inwhat is set, we're in a quotelike environment (qq, qr, but not q) @@ -262,9 +357,9 @@ STATIC void indirect_map_store(pTHX_ const OP *o, const char *src, SV *sv) { if (!PL_lex_inwhat) { const char *pl_linestr = SvPVX_const(PL_linestr); - if (indirect_linestr != pl_linestr) { - ptable_map_clear(indirect_map); - indirect_linestr = pl_linestr; + if (MY_CXT.linestr != pl_linestr) { + ptable_clear(MY_CXT.map); + MY_CXT.linestr = pl_linestr; } } @@ -273,18 +368,20 @@ STATIC void indirect_map_store(pTHX_ const OP *o, const char *src, SV *sv) { SvUVX(val) = PTR2UV(src); SvIOK_on(val); SvIsUV_on(val); + SvREADONLY_on(val); - ptable_map_store(indirect_map, o, val); + ptable_store(MY_CXT.map, o, val); } STATIC const char *indirect_map_fetch(pTHX_ const OP *o, SV ** const name) { #define indirect_map_fetch(O, S) indirect_map_fetch(aTHX_ (O), (S)) + dMY_CXT; SV *val; - if (indirect_linestr != SvPVX_const(PL_linestr)) + if (MY_CXT.linestr != SvPVX_const(PL_linestr)) return NULL; - val = ptable_fetch(indirect_map, o); + val = ptable_fetch(MY_CXT.map, o); if (!val) { *name = NULL; return NULL; @@ -455,11 +552,11 @@ done: STATIC OP *(*indirect_old_ck_entersub)(pTHX_ OP *) = 0; STATIC OP *indirect_ck_entersub(pTHX_ OP *o) { - SV *hint = indirect_hint(); + SV *code = indirect_hint(); o = CALL_FPTR(indirect_old_ck_entersub)(aTHX_ o); - if (hint) { + if (code) { const char *mpos, *opos; SV *mnamesv, *onamesv; OP *mop, *oop; @@ -489,27 +586,37 @@ STATIC OP *indirect_ck_entersub(pTHX_ OP *o) { goto done; if (mpos < opos) { - SV *code = indirect_detag(hint); + SV *file; + line_t line; + dSP; - if (hint) { - dSP; + ENTER; + SAVETMPS; - ENTER; - SAVETMPS; + onamesv = sv_mortalcopy(onamesv); + mnamesv = sv_mortalcopy(mnamesv); - PUSHMARK(SP); - EXTEND(SP, 2); - PUSHs(onamesv); - PUSHs(mnamesv); - PUTBACK; +#ifdef USE_ITHREADS + file = sv_2mortal(newSVpv(CopFILE(&PL_compiling), 0)); +#else + file = sv_mortalcopy(CopFILESV(&PL_compiling)); +#endif + line = CopLINE(&PL_compiling); - call_sv(code, G_VOID); + PUSHMARK(SP); + EXTEND(SP, 4); + PUSHs(onamesv); + PUSHs(mnamesv); + PUSHs(file); + mPUSHu(line); + PUTBACK; - PUTBACK; + call_sv(code, G_VOID); - FREETMPS; - LEAVE; - } + PUTBACK; + + FREETMPS; + LEAVE; } } @@ -529,13 +636,16 @@ BOOT: { if (!indirect_initialized++) { HV *stash; -#if I_THREADSAFE + MY_CXT_INIT; - MY_CXT.tbl = ptable_new(); - MY_CXT.owner = aTHX; + MY_CXT.map = ptable_new(); + MY_CXT.linestr = NULL; +#if I_THREADSAFE || I_WORKAROUND_REQUIRE_PROPAGATION + MY_CXT.tbl = ptable_new(); +#endif +#if I_THREADSAFE + MY_CXT.owner = aTHX; #endif - - indirect_map = ptable_new(); PERL_HASH(indirect_hash, __PACKAGE__, __PACKAGE_LEN__); @@ -569,12 +679,14 @@ CODE: dMY_CXT; ud.tbl = t = ptable_new(); ud.owner = MY_CXT.owner; - ptable_walk(MY_CXT.tbl, indirect_ptable_hints_clone, &ud); + ptable_walk(MY_CXT.tbl, indirect_ptable_clone, &ud); } { MY_CXT_CLONE; - MY_CXT.tbl = t; - MY_CXT.owner = aTHX; + MY_CXT.map = ptable_new(); + MY_CXT.linestr = NULL; + MY_CXT.tbl = t; + MY_CXT.owner = aTHX; } { level = PerlMemShared_malloc(sizeof *level);