X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2Findirect.git;a=blobdiff_plain;f=indirect.xs;h=45c1b50fedd200c8a023a389abb8842b35fb730b;hp=9347467ea034cad3ae3aa75631cd5a2982ae74e9;hb=1efdddc6d7dcbec1d5dfb47938a91cd3483c8ff2;hpb=9e8840b03b5cfb27dc88d7e1e85533fc6bbef6b5 diff --git a/indirect.xs b/indirect.xs index 9347467..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 */ + +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 +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. */ @@ -164,6 +186,7 @@ typedef struct { const char *pos; char *buf; STRLEN len, size; + line_t line; } indirect_op_info_t; #define PTABLE_NAME ptable @@ -183,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 @@ -223,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 *); @@ -254,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 { @@ -284,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) { @@ -299,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 { @@ -321,35 +372,20 @@ STATIC SV *indirect_detag(pTHX_ const SV *hint) { } } } -#endif +#endif /* I_WORKAROUND_REQUIRE_PROPAGATION */ - return h->code; + return I_HINT_CODE(h); } -#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); - } - - return newSVuv(tag); -} - -#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, @@ -357,19 +393,21 @@ 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); } /* ... op -> source position ............................................... */ -STATIC void indirect_map_store(pTHX_ const OP *o, const char *src, SV *sv) { -#define indirect_map_store(O, S, N) indirect_map_store(aTHX_ (O), (S), (N)) +STATIC void indirect_map_store(pTHX_ const OP *o, const char *src, SV *sv, line_t line) { +#define indirect_map_store(O, S, N, L) indirect_map_store(aTHX_ (O), (S), (N), (L)) indirect_op_info_t *oi; const char *s; STRLEN len; @@ -394,15 +432,23 @@ STATIC void indirect_map_store(pTHX_ const OP *o, const char *src, SV *sv) { 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->len = len; + oi->pos = src; + oi->line = line; } STATIC const indirect_op_info_t *indirect_map_fetch(pTHX_ const OP *o) { @@ -459,7 +505,8 @@ STATIC OP *indirect_ck_const(pTHX_ OP *o) { if (indirect_hint()) { SV *sv = cSVOPo_sv; if (SvPOK(sv) && (SvTYPE(sv) >= SVt_PV)) { - indirect_map_store(o, indirect_find(sv, PL_oldbufptr), sv); + const char *s = indirect_find(sv, PL_oldbufptr); + indirect_map_store(o, s, sv, CopLINE(&PL_compiling)); return o; } } @@ -524,7 +571,7 @@ STATIC OP *indirect_ck_rv2sv(pTHX_ OP *o) { } o = CALL_FPTR(indirect_old_ck_rv2sv)(aTHX_ o); - indirect_map_store(o, s, sv); + indirect_map_store(o, s, sv, CopLINE(&PL_compiling)); return o; } @@ -552,7 +599,7 @@ STATIC OP *indirect_ck_padany(pTHX_ OP *o) { while (s < t && isSPACE(*t)) --t; sv = sv_2mortal(newSVpvn("$", 1)); sv_catpvn_nomg(sv, s, t - s + 1); - indirect_map_store(o, s, sv); + indirect_map_store(o, s, sv, CopLINE(&PL_compiling)); return o; } } @@ -561,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; @@ -570,22 +643,25 @@ STATIC OP *indirect_ck_method(pTHX_ OP *o) { OP *op = cUNOPo->op_first; const indirect_op_info_t *oi = indirect_map_fetch(op); const char *s = NULL; + line_t line; SV *sv; if (oi && (s = oi->pos)) { - sv = sv_2mortal(newSVpvn(oi->buf, oi->len)); + sv = sv_2mortal(newSVpvn(oi->buf, oi->len)); + line = oi->line; /* Keep the old line so that we really point to the first */ } else { sv = cSVOPx_sv(op); if (!SvPOK(sv) || (SvTYPE(sv) < SVt_PV)) goto done; - sv = sv_mortalcopy(sv); - s = indirect_find(sv, PL_oldbufptr); + sv = sv_mortalcopy(sv); + s = indirect_find(sv, PL_oldbufptr); + line = CopLINE(&PL_compiling); } o = CALL_FPTR(indirect_old_ck_method)(aTHX_ o); /* o may now be a method_named */ - indirect_map_store(o, s, sv); + indirect_map_store(o, s, sv, line); return o; } @@ -598,6 +674,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) { @@ -627,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; @@ -645,9 +733,8 @@ STATIC OP *indirect_ck_entersub(pTHX_ OP *o) { if (!(ooi && ooi->pos)) goto done; - if (moi->pos < ooi->pos) { - SV *file; - line_t line; + if (indirect_is_indirect(moi, ooi)) { + SV *file; dSP; ENTER; @@ -658,14 +745,13 @@ STATIC OP *indirect_ck_entersub(pTHX_ OP *o) { #else file = sv_mortalcopy(CopFILESV(&PL_compiling)); #endif - line = CopLINE(&PL_compiling); PUSHMARK(SP); EXTEND(SP, 4); mPUSHp(ooi->buf, ooi->len); mPUSHp(moi->buf, moi->len); PUSHs(file); - mPUSHu(line); + mPUSHu(moi->line); PUTBACK; call_sv(code, G_VOID); @@ -695,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__); @@ -712,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];