X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2Findirect.git;a=blobdiff_plain;f=indirect.xs;h=a38186e3968ed110bc388fb075bf9437337c22e8;hp=01b4a77ab3494923b1b1297b39a662f9c3029744;hb=7724326af5714845b7de9dd6ded67536f96ac2fc;hpb=eb4b05d5ad6eec232107b4688e59685bc54f7a65 diff --git a/indirect.xs b/indirect.xs index 01b4a77..a38186e 100644 --- a/indirect.xs +++ b/indirect.xs @@ -35,6 +35,10 @@ # define SvPVX_const SvPVX #endif +#ifndef SvREFCNT_inc_simple_NN +# define SvREFCNT_inc_simple_NN SvREFCNT_inc +#endif + #ifndef sv_catpvn_nomg # define sv_catpvn_nomg sv_catpvn #endif @@ -55,6 +59,14 @@ # define HvNAMELEN_get(H) strlen(HvNAME_get(H)) #endif +#ifndef ENTER_with_name +# define ENTER_with_name(N) ENTER +#endif + +#ifndef LEAVE_with_name +# define LEAVE_with_name(N) LEAVE +#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) @@ -91,6 +103,11 @@ /* ... 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) || defined(PERL_IMPLICIT_CONTEXT) # define I_MULTIPLICITY 1 @@ -129,21 +146,39 @@ /* ... Thread-safe hints ................................................... */ -/* If any of those are true, we need to store the hint in a global table. */ - -#if I_THREADSAFE || I_WORKAROUND_REQUIRE_PROPAGATION +#if I_WORKAROUND_REQUIRE_PROPAGATION typedef struct { - SV *code; -#if I_WORKAROUND_REQUIRE_PROPAGATION - I32 requires; -#endif + SV *code; + IV cxreq; } indirect_hint_t; -#define PTABLE_NAME ptable_hints +#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 PTABLE_VAL_FREE(V) \ - { indirect_hint_t *h = (V); SvREFCNT_dec(h->code); PerlMemShared_free(h); } +#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 pPTBL pTHX #define pPTBL_ pTHX_ @@ -155,7 +190,7 @@ typedef struct { #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 */ +#endif /* I_THREADSAFE */ /* Define the op->str ptable here because we need to be able to clean it during * thread cleanup. */ @@ -184,14 +219,12 @@ typedef struct { #define MY_CXT_KEY __PACKAGE__ "::_guts" XS_VERSION typedef struct { -#if I_THREADSAFE || I_WORKAROUND_REQUIRE_PROPAGATION +#if I_THREADSAFE ptable *tbl; /* It really is a ptable_hints */ + tTHX owner; #endif ptable *map; const char *linestr; -#if I_THREADSAFE - tTHX owner; -#endif } my_cxt_t; START_MY_CXT @@ -224,15 +257,28 @@ STATIC SV *indirect_clone(pTHX_ SV *sv, tTHX owner) { 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); + indirect_hint_t *h2; - *h2 = *h1; + if (ud->owner == aTHX) + return; - if (ud->owner != aTHX) - h2->code = indirect_clone(h1->code, ud->owner); +#if I_HINT_STRUCT - ptable_hints_store(ud->tbl, ent->key, h2); + h2 = PerlMemShared_malloc(sizeof *h2); + h2->code = indirect_clone(h1->code, ud->owner); SvREFCNT_inc(h2->code); +#if I_WORKAROUND_REQUIRE_PROPAGATION + h2->cxreq = h1->cxreq; +#endif + +#else /* I_HINT_STRUCT */ + + h2 = indirect_clone(h1, ud->owner); + SvREFCNT_inc(h2); + +#endif /* !I_HINT_STRUCT */ + + ptable_hints_store(ud->tbl, ent->key, h2); } STATIC void indirect_thread_cleanup(pTHX_ void *); @@ -255,44 +301,58 @@ STATIC void indirect_thread_cleanup(pTHX_ void *ud) { #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; +#if I_WORKAROUND_REQUIRE_PROPAGATION +STATIC IV indirect_require_tag(pTHX) { +#define indirect_require_tag() indirect_require_tag(aTHX) + const PERL_SI *si; - value = SvOK(value) && SvROK(value) ? SvRV(value) : NULL; + for (si = PL_curstackinfo; si; si = si->si_prev) { + I32 cxix; - h = PerlMemShared_malloc(sizeof *h); - h->code = SvREFCNT_inc(value); + for (cxix = si->si_cxix; cxix >= 0; --cxix) { + const PERL_CONTEXT *cx = si->si_cxstack + cxix; -#if I_WORKAROUND_REQUIRE_PROPAGATION - { - const PERL_SI *si; - I32 requires = 0; + if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_REQUIRE) + return PTR2IV(cx); + } + } - for (si = PL_curstackinfo; si; si = si->si_prev) { - I32 cxix; + return PTR2IV(NULL); +} +#endif /* I_WORKAROUND_REQUIRE_PROPAGATION */ - for (cxix = si->si_cxix; cxix >= 0; --cxix) { - const PERL_CONTEXT *cx = si->si_cxstack + cxix; +STATIC SV *indirect_tag(pTHX_ SV *value) { +#define indirect_tag(V) indirect_tag(aTHX_ (V)) + indirect_hint_t *h; + SV *code = NULL; + dMY_CXT; - if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_REQUIRE) - ++requires; - } + if (SvROK(value)) { + value = SvRV(value); + if (SvTYPE(value) >= SVt_PVCV) { + code = value; + SvREFCNT_inc_simple_NN(code); } - - h->requires = requires; } -#endif +#if I_HINT_STRUCT + h = PerlMemShared_malloc(sizeof *h); + h->code = code; +# if I_WORKAROUND_REQUIRE_PROPAGATION + h->cxreq = 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 value pointer as the key itself. */ - ptable_hints_store(MY_CXT.tbl, value, h); + * use the hint as the key itself. */ + ptable_hints_store(MY_CXT.tbl, h, h); +#endif /* I_THREADSAFE */ - return newSVuv(PTR2UV(value)); + return newSViv(PTR2IV(h)); } STATIC SV *indirect_detag(pTHX_ const SV *hint) { @@ -300,57 +360,31 @@ STATIC SV *indirect_detag(pTHX_ const SV *hint) { indirect_hint_t *h; dMY_CXT; - if (!(hint && SvOK(hint) && SvIOK(hint))) + if (!(hint && SvIOK(hint))) return NULL; - h = ptable_fetch(MY_CXT.tbl, INT2PTR(void *, SvUVX(hint))); + 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 - { - 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 h->code; -} - -#else - -STATIC SV *indirect_tag(pTHX_ SV *value) { -#define indirect_tag(V) indirect_tag(aTHX_ (V)) - UV tag = 0; - - if (SvOK(value) && SvROK(value)) { - value = SvRV(value); - SvREFCNT_inc(value); - tag = PTR2UV(value); - } + if (indirect_require_tag() != h->cxreq) + return NULL; +#endif /* I_WORKAROUND_REQUIRE_PROPAGATION */ - return newSVuv(tag); + return I_HINT_CODE(h); } -#define indirect_detag(H) (((H) && SvOK(H)) ? INT2PTR(SV *, SvUVX(H)) : NULL) - -#endif /* I_THREADSAFE || I_WORKAROUND_REQUIRE_PROPAGATION */ - STATIC U32 indirect_hash = 0; STATIC SV *indirect_hint(pTHX) { #define indirect_hint() indirect_hint(aTHX) SV *hint; + + if (IN_PERL_RUNTIME) + return NULL; + #if I_HAS_PERL(5, 9, 5) hint = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, NULL, @@ -358,11 +392,13 @@ STATIC SV *indirect_hint(pTHX) { 0, indirect_hash); #else - SV **val = hv_fetch(GvHV(PL_hintgv), __PACKAGE__, __PACKAGE_LEN__, + { + SV **val = hv_fetch(GvHV(PL_hintgv), __PACKAGE__, __PACKAGE_LEN__, indirect_hash); - if (!val) - return 0; - hint = *val; + if (!val) + return 0; + hint = *val; + } #endif return indirect_detag(hint); } @@ -395,13 +431,20 @@ STATIC void indirect_map_store(pTHX_ const OP *o, const char *src, SV *sv, line_ oi->size = 0; } - s = SvPV_const(sv, len); + 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 = src; oi->line = line; @@ -564,6 +607,32 @@ STATIC OP *indirect_ck_padany(pTHX_ OP *o) { return o; } +/* ... ck_scope ............................................................ */ + +STATIC OP *(*indirect_old_ck_scope) (pTHX_ OP *) = 0; +STATIC OP *(*indirect_old_ck_lineseq)(pTHX_ OP *) = 0; + +STATIC OP *indirect_ck_scope(pTHX_ OP *o) { + OP *(*old_ck)(pTHX_ OP *) = 0; + + switch (o->op_type) { + case OP_SCOPE: old_ck = indirect_old_ck_scope; break; + case OP_LINESEQ: old_ck = indirect_old_ck_lineseq; break; + } + o = CALL_FPTR(old_ck)(aTHX_ o); + + if (indirect_hint()) { + indirect_map_store(o, PL_oldbufptr, NULL, CopLINE(&PL_compiling)); + return o; + } + + indirect_map_delete(o); + return o; +} + +/* We don't need to clean the map entries for leave ops because they can only + * be created by mutating from a lineseq. */ + /* ... ck_method ........................................................... */ STATIC OP *(*indirect_old_ck_method)(pTHX_ OP *) = 0; @@ -604,6 +673,16 @@ done: /* ... ck_entersub ......................................................... */ +STATIC int indirect_is_indirect(const indirect_op_info_t *moi, const indirect_op_info_t *ooi) { + if (moi->pos > ooi->pos) + return 0; + + if (moi->pos == ooi->pos) + return moi->len == ooi->len && !memcmp(moi->buf, ooi->buf, moi->len); + + return 1; +} + STATIC OP *(*indirect_old_ck_entersub)(pTHX_ OP *) = 0; STATIC OP *indirect_ck_entersub(pTHX_ OP *o) { @@ -633,6 +712,8 @@ STATIC OP *indirect_ck_entersub(pTHX_ OP *o) { case OP_CONST: case OP_RV2SV: case OP_PADSV: + case OP_SCOPE: + case OP_LEAVE: break; default: goto done; @@ -651,7 +732,7 @@ STATIC OP *indirect_ck_entersub(pTHX_ OP *o) { if (!(ooi && ooi->pos)) goto done; - if (moi->pos < ooi->pos) { + if (indirect_is_indirect(moi, ooi)) { SV *file; dSP; @@ -687,6 +768,81 @@ done: STATIC U32 indirect_initialized = 0; +STATIC void indirect_teardown(pTHX_ void *root) { + dMY_CXT; + + if (!indirect_initialized) + return; + +#if I_MULTIPLICITY + if (aTHX != root) + return; +#endif + + ptable_free(MY_CXT.map); +#if I_THREADSAFE + ptable_hints_free(MY_CXT.tbl); +#endif + + PL_check[OP_CONST] = MEMBER_TO_FPTR(indirect_old_ck_const); + indirect_old_ck_const = 0; + PL_check[OP_RV2SV] = MEMBER_TO_FPTR(indirect_old_ck_rv2sv); + indirect_old_ck_rv2sv = 0; + PL_check[OP_PADANY] = MEMBER_TO_FPTR(indirect_old_ck_padany); + indirect_old_ck_padany = 0; + PL_check[OP_SCOPE] = MEMBER_TO_FPTR(indirect_old_ck_scope); + indirect_old_ck_scope = 0; + PL_check[OP_LINESEQ] = MEMBER_TO_FPTR(indirect_old_ck_lineseq); + indirect_old_ck_lineseq = 0; + + PL_check[OP_METHOD] = MEMBER_TO_FPTR(indirect_old_ck_method); + indirect_old_ck_method = 0; + PL_check[OP_ENTERSUB] = MEMBER_TO_FPTR(indirect_old_ck_entersub); + indirect_old_ck_entersub = 0; + + indirect_initialized = 0; +} + +STATIC void indirect_setup(pTHX) { +#define indirect_setup() indirect_setup(aTHX) + if (indirect_initialized) + return; + + MY_CXT_INIT; +#if I_THREADSAFE + MY_CXT.tbl = ptable_new(); + MY_CXT.owner = aTHX; +#endif + MY_CXT.map = ptable_new(); + MY_CXT.linestr = NULL; + + indirect_old_ck_const = PL_check[OP_CONST]; + PL_check[OP_CONST] = MEMBER_TO_FPTR(indirect_ck_const); + indirect_old_ck_rv2sv = PL_check[OP_RV2SV]; + PL_check[OP_RV2SV] = MEMBER_TO_FPTR(indirect_ck_rv2sv); + indirect_old_ck_padany = PL_check[OP_PADANY]; + PL_check[OP_PADANY] = MEMBER_TO_FPTR(indirect_ck_padany); + indirect_old_ck_scope = PL_check[OP_SCOPE]; + PL_check[OP_SCOPE] = MEMBER_TO_FPTR(indirect_ck_scope); + indirect_old_ck_lineseq = PL_check[OP_LINESEQ]; + PL_check[OP_LINESEQ] = MEMBER_TO_FPTR(indirect_ck_scope); + + indirect_old_ck_method = PL_check[OP_METHOD]; + PL_check[OP_METHOD] = MEMBER_TO_FPTR(indirect_ck_method); + indirect_old_ck_entersub = PL_check[OP_ENTERSUB]; + PL_check[OP_ENTERSUB] = MEMBER_TO_FPTR(indirect_ck_entersub); + +#if I_MULTIPLICITY + call_atexit(indirect_teardown, aTHX); +#else + call_atexit(indirect_teardown, NULL); +#endif + + indirect_initialized = 1; +} + +STATIC U32 indirect_booted = 0; + /* --- XS ------------------------------------------------------------------ */ MODULE = indirect PACKAGE = indirect @@ -695,35 +851,17 @@ PROTOTYPES: ENABLE BOOT: { - if (!indirect_initialized++) { + if (!indirect_booted++) { HV *stash; - MY_CXT_INIT; - 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 - PERL_HASH(indirect_hash, __PACKAGE__, __PACKAGE_LEN__); - indirect_old_ck_const = PL_check[OP_CONST]; - PL_check[OP_CONST] = MEMBER_TO_FPTR(indirect_ck_const); - indirect_old_ck_rv2sv = PL_check[OP_RV2SV]; - PL_check[OP_RV2SV] = MEMBER_TO_FPTR(indirect_ck_rv2sv); - indirect_old_ck_padany = PL_check[OP_PADANY]; - PL_check[OP_PADANY] = MEMBER_TO_FPTR(indirect_ck_padany); - indirect_old_ck_method = PL_check[OP_METHOD]; - PL_check[OP_METHOD] = MEMBER_TO_FPTR(indirect_ck_method); - indirect_old_ck_entersub = PL_check[OP_ENTERSUB]; - PL_check[OP_ENTERSUB] = MEMBER_TO_FPTR(indirect_ck_entersub); - stash = gv_stashpvn(__PACKAGE__, __PACKAGE_LEN__, 1); newCONSTSUB(stash, "I_THREADSAFE", newSVuv(I_THREADSAFE)); + newCONSTSUB(stash, "I_FORKSAFE", newSVuv(I_FORKSAFE)); } + + indirect_setup(); } #if I_THREADSAFE @@ -752,9 +890,9 @@ CODE: { level = PerlMemShared_malloc(sizeof *level); *level = 1; - LEAVE; + LEAVE_with_name("sub"); SAVEDESTRUCTOR_X(indirect_thread_cleanup, level); - ENTER; + ENTER_with_name("sub"); } #endif