X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2Findirect.git;a=blobdiff_plain;f=indirect.xs;h=f36c179e8537e024c75b414f90bb1e4d1eeefc2f;hp=49bdd205288bf20f2d37735e02a13da9f01ec401;hb=122a05bdb9134d5f644ac55e2db7e9479f9f2d0e;hpb=642dc0c5f40eee8c85ff496a6b1bd43201be7199 diff --git a/indirect.xs b/indirect.xs index 49bdd20..f36c179 100644 --- a/indirect.xs +++ b/indirect.xs @@ -35,8 +35,12 @@ # define SvPVX_const SvPVX #endif -#ifndef SvREFCNT_inc_simple_NN -# define SvREFCNT_inc_simple_NN SvREFCNT_inc +#ifndef SvREFCNT_inc_simple_void_NN +# ifdef SvREFCNT_inc_simple_NN +# define SvREFCNT_inc_simple_void_NN SvREFCNT_inc_simple_NN +# else +# define SvREFCNT_inc_simple_void_NN SvREFCNT_inc +# endif #endif #ifndef sv_catpvn_nomg @@ -84,7 +88,7 @@ #endif #ifndef I_WORKAROUND_REQUIRE_PROPAGATION -# define I_WORKAROUND_REQUIRE_PROPAGATION !I_HAS_PERL(5, 12, 0) +# define I_WORKAROUND_REQUIRE_PROPAGATION !I_HAS_PERL(5, 10, 1) #endif /* ... Thread safety and multiplicity ...................................... */ @@ -182,10 +186,10 @@ typedef SV indirect_hint_t; * thread cleanup. */ typedef struct { + char *buf; STRLEN pos; STRLEN size; STRLEN len; - char *buf; line_t line; } indirect_op_info_t; @@ -212,6 +216,7 @@ typedef struct { tTHX owner; #endif ptable *map; + SV *global_code; } my_cxt_t; START_MY_CXT @@ -224,6 +229,9 @@ STATIC SV *indirect_clone(pTHX_ SV *sv, tTHX owner) { AV *stashes = NULL; SV *dupsv; + if (!sv) + return NULL; + if (SvTYPE(sv) == SVt_PVHV && HvNAME_get(sv)) stashes = newAV(); @@ -253,7 +261,6 @@ STATIC void indirect_ptable_clone(pTHX_ ptable_ent *ent, void *ud_) { h2 = PerlMemShared_malloc(sizeof *h2); h2->code = indirect_clone(h1->code, ud->owner); - SvREFCNT_inc(h2->code); #if I_WORKAROUND_REQUIRE_PROPAGATION h2->require_tag = PTR2IV(indirect_clone(INT2PTR(SV *, h1->require_tag), ud->owner)); @@ -262,7 +269,6 @@ STATIC void indirect_ptable_clone(pTHX_ ptable_ent *ent, void *ud_) { #else /* I_HINT_STRUCT */ h2 = indirect_clone(h1, ud->owner); - SvREFCNT_inc(h2); #endif /* !I_HINT_STRUCT */ @@ -274,6 +280,7 @@ STATIC void indirect_ptable_clone(pTHX_ ptable_ent *ent, void *ud_) { STATIC void indirect_thread_cleanup(pTHX_ void *ud) { dMY_CXT; + SvREFCNT_dec(MY_CXT.global_code); ptable_free(MY_CXT.map); ptable_hints_free(MY_CXT.tbl); } @@ -330,13 +337,12 @@ 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 (SvROK(value)) { value = SvRV(value); if (SvTYPE(value) >= SVt_PVCV) { code = value; - SvREFCNT_inc_simple_NN(code); + SvREFCNT_inc_simple_void_NN(code); } } @@ -351,10 +357,13 @@ STATIC SV *indirect_tag(pTHX_ SV *value) { #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); + { + dMY_CXT; + /* 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)); @@ -363,10 +372,9 @@ STATIC SV *indirect_tag(pTHX_ SV *value) { 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; - - if (!(hint && SvIOK(hint))) - return NULL; +#endif h = INT2PTR(indirect_hint_t *, SvIVX(hint)); #if I_THREADSAFE @@ -375,7 +383,7 @@ STATIC SV *indirect_detag(pTHX_ const SV *hint) { #if I_WORKAROUND_REQUIRE_PROPAGATION if (indirect_require_tag() != h->require_tag) - return NULL; + return MY_CXT.global_code; #endif /* I_WORKAROUND_REQUIRE_PROPAGATION */ return I_HINT_CODE(h); @@ -385,16 +393,39 @@ STATIC U32 indirect_hash = 0; STATIC SV *indirect_hint(pTHX) { #define indirect_hint() indirect_hint(aTHX) - SV **val; + SV *hint = NULL; if (IN_PERL_RUNTIME) return NULL; - val = hv_fetch(GvHV(PL_hintgv), __PACKAGE__, __PACKAGE_LEN__, indirect_hash); - if (!val) +#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 - return indirect_detag(*val); + if (hint && SvIOK(hint)) + return indirect_detag(hint); + else { + dMY_CXT; + return MY_CXT.global_code; + } } /* ... op -> source position ............................................... */ @@ -790,8 +821,6 @@ done: STATIC U32 indirect_initialized = 0; STATIC void indirect_teardown(pTHX_ void *root) { - dMY_CXT; - if (!indirect_initialized) return; @@ -800,10 +829,13 @@ STATIC void indirect_teardown(pTHX_ void *root) { return; #endif - ptable_free(MY_CXT.map); + { + dMY_CXT; + ptable_free(MY_CXT.map); #if I_THREADSAFE - ptable_hints_free(MY_CXT.tbl); + ptable_hints_free(MY_CXT.tbl); #endif + } PL_check[OP_CONST] = MEMBER_TO_FPTR(indirect_old_ck_const); indirect_old_ck_const = 0; @@ -834,10 +866,11 @@ STATIC void indirect_setup(pTHX) { { MY_CXT_INIT; #if I_THREADSAFE - MY_CXT.tbl = ptable_new(); - MY_CXT.owner = aTHX; + MY_CXT.tbl = ptable_new(); + MY_CXT.owner = aTHX; #endif - MY_CXT.map = ptable_new(); + MY_CXT.map = ptable_new(); + MY_CXT.global_code = NULL; } indirect_old_ck_const = PL_check[OP_CONST]; @@ -897,6 +930,7 @@ CLONE(...) PROTOTYPE: DISABLE PREINIT: ptable *t; + SV *global_code_dup; PPCODE: { my_cxt_t ud; @@ -904,12 +938,14 @@ PPCODE: ud.tbl = t = ptable_new(); ud.owner = MY_CXT.owner; ptable_walk(MY_CXT.tbl, indirect_ptable_clone, &ud); + global_code_dup = indirect_clone(MY_CXT.global_code, MY_CXT.owner); } { MY_CXT_CLONE; - MY_CXT.map = ptable_new(); - MY_CXT.tbl = t; - MY_CXT.owner = aTHX; + MY_CXT.map = ptable_new(); + MY_CXT.tbl = t; + MY_CXT.owner = aTHX; + MY_CXT.global_code = global_code_dup; } reap(3, indirect_thread_cleanup, NULL); XSRETURN(0); @@ -923,3 +959,18 @@ CODE: RETVAL = indirect_tag(value); OUTPUT: RETVAL + +void +_global(SV *code) +PROTOTYPE: $ +PPCODE: + if (!SvOK(code)) + code = NULL; + else if (SvROK(code)) + code = SvRV(code); + { + dMY_CXT; + SvREFCNT_dec(MY_CXT.global_code); + MY_CXT.global_code = SvREFCNT_inc(code); + } + XSRETURN(0);