X-Git-Url: http://git.vpit.fr/?a=blobdiff_plain;f=Types.xs;h=8cf501cc631aec3b350d6baa35c57879ed373b4e;hb=0f014b1bd35a5d46d7dc77599e3e11f1d4cb33bc;hp=a8fb284c35a89b6f8379f04553f51f7f676a54fa;hpb=420f91f3c4f8aa318ede84928eb7c671921500ea;p=perl%2Fmodules%2FLexical-Types.git diff --git a/Types.xs b/Types.xs index a8fb284..8cf501c 100644 --- a/Types.xs +++ b/Types.xs @@ -39,20 +39,6 @@ # define SvREFCNT_inc_simple_NN SvREFCNT_inc #endif -#undef ENTERn -#if defined(ENTER_with_name) && !LT_HAS_PERL(5, 11, 4) -# define ENTERn(N) ENTER_with_name(N) -#else -# define ENTERn(N) ENTER -#endif - -#undef LEAVEn -#if defined(LEAVE_with_name) && !LT_HAS_PERL(5, 11, 4) -# define LEAVEn(N) LEAVE_with_name(N) -#else -# define LEAVEn(N) LEAVE -#endif - /* ... Thread safety and multiplicity ...................................... */ #ifndef LT_MULTIPLICITY @@ -105,7 +91,7 @@ typedef struct { SV *code; - IV cxreq; + IV require_tag; } lt_hint_t; #define LT_HINT_STRUCT 1 @@ -166,50 +152,47 @@ START_MY_CXT #if LT_THREADSAFE -STATIC SV *lt_clone(pTHX_ SV *sv, tTHX owner) { -#define lt_clone(S, O) lt_clone(aTHX_ (S), (O)) - CLONE_PARAMS param; - AV *stashes = NULL; - SV *dupsv; - - if (SvTYPE(sv) == SVt_PVHV && HvNAME_get(sv)) - stashes = newAV(); - - param.stashes = stashes; - param.flags = 0; - param.proto_perl = owner; - - dupsv = sv_dup(sv, ¶m); - - if (stashes) { - av_undef(stashes); - SvREFCNT_dec(stashes); - } - - return SvREFCNT_inc(dupsv); -} +typedef struct { + ptable *tbl; +#if LT_HAS_PERL(5, 13, 2) + CLONE_PARAMS *params; +#else + CLONE_PARAMS params; +#endif +} lt_ptable_clone_ud; + +#if LT_HAS_PERL(5, 13, 2) +# define lt_ptable_clone_ud_init(U, T, O) \ + (U).tbl = (T); \ + (U).params = Perl_clone_params_new((O), aTHX) +# define lt_ptable_clone_ud_deinit(U) Perl_clone_params_del((U).params) +# define lt_dup_inc(S, U) SvREFCNT_inc(sv_dup((S), (U)->params)) +#else +# define lt_ptable_clone_ud_init(U, T, O) \ + (U).tbl = (T); \ + (U).params.stashes = newAV(); \ + (U).params.flags = 0; \ + (U).params.proto_perl = (O) +# define lt_ptable_clone_ud_deinit(U) SvREFCNT_dec((U).params.stashes) +# define lt_dup_inc(S, U) SvREFCNT_inc(sv_dup((S), &((U)->params))) +#endif -STATIC void lt_ptable_hints_clone(pTHX_ ptable_ent *ent, void *ud_) { - my_cxt_t *ud = ud_; +STATIC void lt_ptable_clone(pTHX_ ptable_ent *ent, void *ud_) { + lt_ptable_clone_ud *ud = ud_; lt_hint_t *h1 = ent->val; lt_hint_t *h2; - if (ud->owner == aTHX) - return; - #if LT_HINT_STRUCT - h2 = PerlMemShared_malloc(sizeof *h2); - h2->code = lt_clone(h1->code, ud->owner); - SvREFCNT_inc(h2->code); + h2 = PerlMemShared_malloc(sizeof *h2); + h2->code = lt_dup_inc(h1->code, ud); #if LT_WORKAROUND_REQUIRE_PROPAGATION - h2->cxreq = h1->cxreq; + h2->require_tag = PTR2IV(lt_dup_inc(INT2PTR(SV *, h1->require_tag), ud)); #endif #else /* LT_HINT_STRUCT */ - h2 = lt_clone(h1, ud->owner); - SvREFCNT_inc(h2); + h2 = lt_dup_inc(h1, ud); #endif /* !LT_HINT_STRUCT */ @@ -231,20 +214,46 @@ STATIC void lt_thread_cleanup(pTHX_ void *ud) { #if LT_WORKAROUND_REQUIRE_PROPAGATION STATIC IV lt_require_tag(pTHX) { #define lt_require_tag() lt_require_tag(aTHX) - 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; - - if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_REQUIRE) - return PTR2IV(cx); + 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; } - return PTR2IV(NULL); +get_enclosing_cv: + for (outside = CvOUTSIDE(cv); outside; outside = CvOUTSIDE(cv)) + cv = outside; + + return PTR2IV(cv); } #endif /* LT_WORKAROUND_REQUIRE_PROPAGATION */ @@ -264,9 +273,9 @@ STATIC SV *lt_tag(pTHX_ SV *value) { #if LT_HINT_STRUCT h = PerlMemShared_malloc(sizeof *h); - h->code = code; + h->code = code; # if LT_WORKAROUND_REQUIRE_PROPAGATION - h->cxreq = lt_require_tag(); + h->require_tag = lt_require_tag(); # endif /* LT_WORKAROUND_REQUIRE_PROPAGATION */ #else /* LT_HINT_STRUCT */ h = code; @@ -295,7 +304,7 @@ STATIC SV *lt_detag(pTHX_ const SV *hint) { h = ptable_fetch(MY_CXT.tbl, h); #endif /* LT_THREADSAFE */ #if LT_WORKAROUND_REQUIRE_PROPAGATION - if (lt_require_tag() != h->cxreq) + if (lt_require_tag() != h->require_tag) return NULL; #endif /* LT_WORKAROUND_REQUIRE_PROPAGATION */ @@ -307,7 +316,9 @@ STATIC U32 lt_hash = 0; STATIC SV *lt_hint(pTHX) { #define lt_hint() lt_hint(aTHX) SV *hint; -#if LT_HAS_PERL(5, 9, 5) +#ifdef cop_hints_fetch_pvn + hint = cop_hints_fetch_pvn(PL_curcop, __PACKAGE__, __PACKAGE_LEN__, lt_hash,0); +#elif LT_HAS_PERL(5, 9, 5) hint = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, NULL, __PACKAGE__, __PACKAGE_LEN__, @@ -436,7 +447,7 @@ STATIC void lt_map_delete(pTHX_ const OP *o) { MUTEX_LOCK(<_op_map_mutex); #endif - ptable_map_store(lt_op_map, o, NULL); + ptable_map_delete(lt_op_map, o); #ifdef USE_ITHREADS MUTEX_UNLOCK(<_op_map_mutex); @@ -733,12 +744,14 @@ PREINIT: SV *cloned_default_meth; PPCODE: { - my_cxt_t ud; + lt_ptable_clone_ud ud; dMY_CXT; - ud.tbl = t = ptable_new(); - ud.owner = MY_CXT.owner; - ptable_walk(MY_CXT.tbl, lt_ptable_hints_clone, &ud); - cloned_default_meth = lt_clone(MY_CXT.default_meth, MY_CXT.owner); + + t = ptable_new(); + lt_ptable_clone_ud_init(ud, t, MY_CXT.owner); + ptable_walk(MY_CXT.tbl, lt_ptable_clone, &ud); + cloned_default_meth = lt_dup_inc(MY_CXT.default_meth, &ud); + lt_ptable_clone_ud_deinit(ud); } { MY_CXT_CLONE;