X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2Findirect.git;a=blobdiff_plain;f=indirect.xs;h=45c1b50fedd200c8a023a389abb8842b35fb730b;hp=45309ce648a1cf43b3b0cccd4a31b076d864a616;hb=1efdddc6d7dcbec1d5dfb47938a91cd3483c8ff2;hpb=8e1c49f42da7671812398f92d819da04c7a41e1b diff --git a/indirect.xs b/indirect.xs index 45309ce..45c1b50 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 @@ -129,21 +133,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 } 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 */ -#define PTABLE_VAL_FREE(V) \ - { indirect_hint_t *h = (V); SvREFCNT_dec(h->code); PerlMemShared_free(h); } +typedef SV indirect_hint_t; + +#define I_HINT_STRUCT 0 + +#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 +177,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 +206,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 +244,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->requires = h1->requires; +#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,17 +288,25 @@ 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; + SV *code = NULL; dMY_CXT; - value = SvOK(value) && SvROK(value) ? SvRV(value) : NULL; + if (SvROK(value)) { + value = SvRV(value); + if (SvTYPE(value) >= SVt_PVCV) { + code = value; + if (CvANON(code) && !CvCLONED(code)) + CvCLONE_on(code); + SvREFCNT_inc_simple_NN(code); + } + } +#if I_HINT_STRUCT h = PerlMemShared_malloc(sizeof *h); - h->code = SvREFCNT_inc(value); + h->code = code; #if I_WORKAROUND_REQUIRE_PROPAGATION { @@ -285,14 +326,20 @@ STATIC SV *indirect_tag(pTHX_ SV *value) { h->requires = requires; } -#endif +#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,10 +347,13 @@ 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 { @@ -322,30 +372,11 @@ STATIC SV *indirect_detag(pTHX_ const SV *hint) { } } } -#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); - } +#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) { @@ -401,13 +432,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; @@ -570,6 +608,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; @@ -649,6 +713,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; @@ -715,14 +781,12 @@ BOOT: 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.tbl = ptable_new(); MY_CXT.owner = aTHX; #endif + MY_CXT.map = ptable_new(); + MY_CXT.linestr = NULL; PERL_HASH(indirect_hash, __PACKAGE__, __PACKAGE_LEN__); @@ -732,6 +796,11 @@ BOOT: 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];