X-Git-Url: http://git.vpit.fr/?a=blobdiff_plain;f=Types.xs;h=375d771176f12c374f8b84b8fd09a94756d17b0b;hb=c530c61ff04bdbd8bc101a3e88273fc4219d963e;hp=324594905e298dee7eae05ceb6a0fa335fa93512;hpb=b4e0a25b8c7e0703aeb75dc53b344a7d898832bf;p=perl%2Fmodules%2FLexical-Types.git diff --git a/Types.xs b/Types.xs index 3245949..375d771 100644 --- a/Types.xs +++ b/Types.xs @@ -91,7 +91,7 @@ typedef struct { SV *code; - IV cxreq; + IV require_tag; } lt_hint_t; #define LT_HINT_STRUCT 1 @@ -185,11 +185,11 @@ STATIC void lt_ptable_hints_clone(pTHX_ ptable_ent *ent, void *ud_) { #if LT_HINT_STRUCT - h2 = PerlMemShared_malloc(sizeof *h2); - h2->code = lt_clone(h1->code, ud->owner); + h2 = PerlMemShared_malloc(sizeof *h2); + h2->code = lt_clone(h1->code, ud->owner); SvREFCNT_inc(h2->code); #if LT_WORKAROUND_REQUIRE_PROPAGATION - h2->cxreq = h1->cxreq; + h2->require_tag = PTR2IV(lt_clone(INT2PTR(SV *, h1->require_tag), ud->owner)); #endif #else /* LT_HINT_STRUCT */ @@ -202,21 +202,12 @@ STATIC void lt_ptable_hints_clone(pTHX_ ptable_ent *ent, void *ud_) { ptable_hints_store(ud->tbl, ent->key, h2); } -STATIC void lt_thread_cleanup(pTHX_ void *); +#include "reap.h" STATIC void lt_thread_cleanup(pTHX_ void *ud) { - int *level = ud; + dMY_CXT; - if (*level) { - *level = 0; - LEAVE; - SAVEDESTRUCTOR_X(lt_thread_cleanup, level); - ENTER; - } else { - dMY_CXT; - PerlMemShared_free(level); - ptable_hints_free(MY_CXT.tbl); - } + ptable_hints_free(MY_CXT.tbl); } #endif /* LT_THREADSAFE */ @@ -226,20 +217,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 */ @@ -259,9 +276,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; @@ -290,7 +307,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 */ @@ -342,10 +359,10 @@ typedef struct { SV *type_pkg; SV *type_meth; #endif /* !MULTIPLICITY */ - OP *(*pp_padsv)(pTHX); + OP *(*old_pp_padsv)(pTHX); } lt_op_info; -STATIC void lt_map_store(pTHX_ const OP *o, SV *orig_pkg, SV *type_pkg, SV *type_meth, OP *(*pp_padsv)(pTHX)) { +STATIC void lt_map_store(pTHX_ const OP *o, SV *orig_pkg, SV *type_pkg, SV *type_meth, OP *(*old_pp_padsv)(pTHX)) { #define lt_map_store(O, OP, TP, TM, PP) lt_map_store(aTHX_ (O), (OP), (TP), (TM), (PP)) lt_op_info *oi; @@ -398,7 +415,7 @@ STATIC void lt_map_store(pTHX_ const OP *o, SV *orig_pkg, SV *type_pkg, SV *type oi->type_meth = type_meth; #endif /* !MULTIPLICITY */ - oi->pp_padsv = pp_padsv; + oi->old_pp_padsv = old_pp_padsv; #ifdef USE_ITHREADS MUTEX_UNLOCK(<_op_map_mutex); @@ -501,7 +518,7 @@ STATIC OP *lt_pp_padsv(pTHX) { LEAVE; } - return CALL_FPTR(oi.pp_padsv)(aTHX); + return CALL_FPTR(oi.old_pp_padsv)(aTHX); } return CALL_FPTR(PL_ppaddr[OP_PADSV])(aTHX); @@ -579,6 +596,8 @@ STATIC OP *lt_ck_padany(pTHX_ OP *o) { croak(__PACKAGE__ " mangler should return zero, one or two scalars, but got %d", items); if (items == 0) { SvREFCNT_dec(orig_pkg); + FREETMPS; + LEAVE; goto skip; } else { SV *rsv; @@ -659,19 +678,21 @@ STATIC void lt_teardown(pTHX_ void *root) { lt_initialized = 0; } -STATIC lt_setup(pTHX) { +STATIC void lt_setup(pTHX) { #define lt_setup() lt_setup(aTHX) if (lt_initialized) return; - MY_CXT_INIT; + { + MY_CXT_INIT; #if LT_THREADSAFE - MY_CXT.tbl = ptable_new(); - MY_CXT.owner = aTHX; + MY_CXT.tbl = ptable_new(); + MY_CXT.owner = aTHX; #endif - MY_CXT.pp_padsv_saved = 0; - MY_CXT.default_meth = newSVpvn("TYPEDSCALAR", 11); - SvREADONLY_on(MY_CXT.default_meth); + MY_CXT.pp_padsv_saved = 0; + MY_CXT.default_meth = newSVpvn("TYPEDSCALAR", 11); + SvREADONLY_on(MY_CXT.default_meth); + } lt_old_ck_padany = PL_check[OP_PADANY]; PL_check[OP_PADANY] = MEMBER_TO_FPTR(lt_ck_padany); @@ -695,8 +716,8 @@ MODULE = Lexical::Types PACKAGE = Lexical::Types PROTOTYPES: ENABLE -BOOT: -{ +BOOT: +{ if (!lt_booted++) { HV *stash; @@ -721,9 +742,8 @@ CLONE(...) PROTOTYPE: DISABLE PREINIT: ptable *t; - int *level; SV *cloned_default_meth; -CODE: +PPCODE: { my_cxt_t ud; dMY_CXT; @@ -739,13 +759,8 @@ CODE: MY_CXT.pp_padsv_saved = 0; MY_CXT.default_meth = cloned_default_meth; } - { - level = PerlMemShared_malloc(sizeof *level); - *level = 1; - LEAVE; - SAVEDESTRUCTOR_X(lt_thread_cleanup, level); - ENTER; - } + reap(3, lt_thread_cleanup, NULL); + XSRETURN(0); #endif