X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2Findirect.git;a=blobdiff_plain;f=indirect.xs;h=45309ce648a1cf43b3b0cccd4a31b076d864a616;hp=b9314ae60a2e92298ff50c63a2c8029373f93a5c;hb=8e1c49f42da7671812398f92d819da04c7a41e1b;hpb=cfbd22399e253cbac1aad5436d2b191082befe14 diff --git a/indirect.xs b/indirect.xs index b9314ae..45309ce 100644 --- a/indirect.xs +++ b/indirect.xs @@ -19,6 +19,10 @@ # define dNOOP #endif +#ifndef Newx +# define Newx(v, n, c) New(0, v, n, c) +#endif + #ifndef SvPV_const # define SvPV_const SvPV #endif @@ -35,6 +39,10 @@ # define sv_catpvn_nomg sv_catpvn #endif +#ifndef mPUSHp +# define mPUSHp(P, L) PUSHs(sv_2mortal(newSVpvn((P), (L)))) +#endif + #ifndef mPUSHu # define mPUSHu(U) PUSHs(sv_2mortal(newSVuv(U))) #endif @@ -47,10 +55,6 @@ # define HvNAMELEN_get(H) strlen(HvNAME_get(H)) #endif -#ifndef SvIS_FREED -# define SvIS_FREED(sv) ((sv)->sv_flags == SVTYPEMASK) -#endif - #define I_HAS_PERL(R, V, S) (PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S)))))) #if I_HAS_PERL(5, 10, 0) || defined(PL_parser) @@ -81,6 +85,10 @@ # endif #endif +#ifndef I_WORKAROUND_REQUIRE_PROPAGATION +# define I_WORKAROUND_REQUIRE_PROPAGATION !I_HAS_PERL(5, 10, 1) +#endif + /* ... Thread safety and multiplicity ...................................... */ #ifndef I_MULTIPLICITY @@ -119,10 +127,48 @@ /* --- Helpers ------------------------------------------------------------- */ -/* ... Pointer table ....................................................... */ +/* ... 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 + +typedef struct { + SV *code; +#if I_WORKAROUND_REQUIRE_PROPAGATION + I32 requires; +#endif +} indirect_hint_t; + +#define PTABLE_NAME ptable_hints + +#define PTABLE_VAL_FREE(V) \ + { indirect_hint_t *h = (V); SvREFCNT_dec(h->code); PerlMemShared_free(h); } + +#define pPTBL pTHX +#define pPTBL_ pTHX_ +#define aPTBL aTHX +#define aPTBL_ aTHX_ + +#include "ptable.h" + +#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 */ + +/* Define the op->str ptable here because we need to be able to clean it during + * thread cleanup. */ + +typedef struct { + const char *pos; + char *buf; + STRLEN len, size; + line_t line; +} indirect_op_info_t; #define PTABLE_NAME ptable -#define PTABLE_VAL_FREE(V) if ((V) && !SvIS_FREED((SV *) (V))) SvREFCNT_dec(V) +#define PTABLE_VAL_FREE(V) if (V) { Safefree(((indirect_op_info_t *) (V))->buf); Safefree(V); } #define pPTBL pTHX #define pPTBL_ pTHX_ @@ -135,58 +181,64 @@ #define ptable_clear(T) ptable_clear(aTHX_ (T)) #define ptable_free(T) ptable_free(aTHX_ (T)) -/* ... Thread-safe hints ................................................... */ - #define MY_CXT_KEY __PACKAGE__ "::_guts" XS_VERSION -#if I_THREADSAFE - typedef struct { - ptable *tbl; +#if I_THREADSAFE || I_WORKAROUND_REQUIRE_PROPAGATION + ptable *tbl; /* It really is a ptable_hints */ +#endif ptable *map; - tTHX owner; const char *linestr; +#if I_THREADSAFE + tTHX owner; +#endif } my_cxt_t; -#else +START_MY_CXT -typedef struct { - ptable *map; - const char *linestr; -} my_cxt_t; +#if I_THREADSAFE -#endif /* I_THREADSAFE */ +STATIC SV *indirect_clone(pTHX_ SV *sv, tTHX owner) { +#define indirect_clone(S, O) indirect_clone(aTHX_ (S), (O)) + CLONE_PARAMS param; + AV *stashes = NULL; + SV *dupsv; -START_MY_CXT + if (SvTYPE(sv) == SVt_PVHV && HvNAME_get(sv)) + stashes = newAV(); -#if I_THREADSAFE + param.stashes = stashes; + param.flags = 0; + param.proto_perl = owner; -STATIC void indirect_ptable_clone(pTHX_ ptable_ent *ent, void *ud_) { - my_cxt_t *ud = ud_; - SV *val = ent->val; - - if (ud->owner != aTHX) { - CLONE_PARAMS param; - AV *stashes = (SvTYPE(val) == SVt_PVHV && HvNAME_get(val)) ? newAV() : NULL; - param.stashes = stashes; - param.flags = 0; - param.proto_perl = ud->owner; - val = sv_dup(val, ¶m); - if (stashes) { - av_undef(stashes); - SvREFCNT_dec(stashes); - } + dupsv = sv_dup(sv, ¶m); + + if (stashes) { + av_undef(stashes); + SvREFCNT_dec(stashes); } - ptable_store(ud->tbl, ent->key, val); - SvREFCNT_inc(val); + return SvREFCNT_inc(dupsv); +} + +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); + + *h2 = *h1; + + if (ud->owner != aTHX) + h2->code = indirect_clone(h1->code, ud->owner); + + ptable_hints_store(ud->tbl, ent->key, h2); + SvREFCNT_inc(h2->code); } STATIC void indirect_thread_cleanup(pTHX_ void *); STATIC void indirect_thread_cleanup(pTHX_ void *ud) { int *level = ud; - SV *id; if (*level) { *level = 0; @@ -197,39 +249,82 @@ STATIC void indirect_thread_cleanup(pTHX_ void *ud) { dMY_CXT; PerlMemShared_free(level); ptable_free(MY_CXT.map); - ptable_free(MY_CXT.tbl); + ptable_hints_free(MY_CXT.tbl); } } +#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; dMY_CXT; value = SvOK(value) && SvROK(value) ? SvRV(value) : NULL; + + h = PerlMemShared_malloc(sizeof *h); + h->code = SvREFCNT_inc(value); + +#if I_WORKAROUND_REQUIRE_PROPAGATION + { + const PERL_SI *si; + I32 requires = 0; + + 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) + ++requires; + } + } + + h->requires = requires; + } +#endif + /* 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_store(MY_CXT.tbl, value, value); - SvREFCNT_inc(value); + ptable_hints_store(MY_CXT.tbl, value, h); return newSVuv(PTR2UV(value)); } STATIC SV *indirect_detag(pTHX_ const SV *hint) { #define indirect_detag(H) indirect_detag(aTHX_ (H)) - void *tag; - SV *value; + indirect_hint_t *h; + dMY_CXT; + + if (!(hint && SvOK(hint) && SvIOK(hint))) + return NULL; - if (!hint || !SvOK(hint) || !SvIOK(hint)) - croak("Wrong hint"); + h = ptable_fetch(MY_CXT.tbl, INT2PTR(void *, SvUVX(hint))); - tag = INT2PTR(void *, SvIVX(hint)); +#if I_WORKAROUND_REQUIRE_PROPAGATION { - dMY_CXT; - value = ptable_fetch(MY_CXT.tbl, tag); + const PERL_SI *si; + I32 requires = 0; + + 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 + && ++requires > h->requires) + return NULL; + } + } } +#endif - return value; + return h->code; } #else @@ -247,37 +342,45 @@ STATIC SV *indirect_tag(pTHX_ SV *value) { return newSVuv(tag); } -#define indirect_detag(H) INT2PTR(SV *, SvUVX(H)) +#define indirect_detag(H) (((H) && SvOK(H)) ? INT2PTR(SV *, SvUVX(H)) : NULL) -#endif /* I_THREADSAFE */ +#endif /* I_THREADSAFE || I_WORKAROUND_REQUIRE_PROPAGATION */ STATIC U32 indirect_hash = 0; STATIC SV *indirect_hint(pTHX) { #define indirect_hint() indirect_hint(aTHX) - SV *id; -#if I_HAS_PERL(5, 10, 0) - id = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, - NULL, - __PACKAGE__, __PACKAGE_LEN__, - 0, - indirect_hash); + 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, + __PACKAGE__, __PACKAGE_LEN__, + 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; - id = *val; + if (!val) + return 0; + hint = *val; + } #endif - return (id && SvOK(id)) ? id : NULL; + 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; dMY_CXT; - SV *val; /* When lex_inwhat is set, we're in a quotelike environment (qq, qr, but not q) * In this case the linestr has temporarly changed, but the old buffer should @@ -291,32 +394,41 @@ STATIC void indirect_map_store(pTHX_ const OP *o, const char *src, SV *sv) { } } - val = newSVsv(sv); - SvUPGRADE(val, SVt_PVIV); - SvUVX(val) = PTR2UV(src); - SvIOK_on(val); - SvIsUV_on(val); - SvREADONLY_on(val); + if (!(oi = ptable_fetch(MY_CXT.map, o))) { + Newx(oi, 1, indirect_op_info_t); + ptable_store(MY_CXT.map, o, oi); + oi->buf = NULL; + oi->size = 0; + } - ptable_store(MY_CXT.map, o, val); + s = SvPV_const(sv, len); + 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; } -STATIC const char *indirect_map_fetch(pTHX_ const OP *o, SV ** const name) { -#define indirect_map_fetch(O, S) indirect_map_fetch(aTHX_ (O), (S)) +STATIC const indirect_op_info_t *indirect_map_fetch(pTHX_ const OP *o) { +#define indirect_map_fetch(O) indirect_map_fetch(aTHX_ (O)) + const indirect_op_info_t *val; dMY_CXT; - SV *val; if (MY_CXT.linestr != SvPVX_const(PL_linestr)) return NULL; - val = ptable_fetch(MY_CXT.map, o); - if (!val) { - *name = NULL; - return NULL; - } + return ptable_fetch(MY_CXT.map, o); +} + +STATIC void indirect_map_delete(pTHX_ const OP *o) { +#define indirect_map_delete(O) indirect_map_delete(aTHX_ (O)) + dMY_CXT; - *name = val; - return INT2PTR(const char *, SvUVX(val)); + ptable_store(MY_CXT.map, o, NULL); } /* --- Check functions ----------------------------------------------------- */ @@ -354,10 +466,14 @@ 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); + if (SvPOK(sv) && (SvTYPE(sv) >= SVt_PV)) { + const char *s = indirect_find(sv, PL_oldbufptr); + indirect_map_store(o, s, sv, CopLINE(&PL_compiling)); + return o; + } } + indirect_map_delete(o); return o; } @@ -417,12 +533,15 @@ 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; } done: - return CALL_FPTR(indirect_old_ck_rv2sv)(aTHX_ o); + o = CALL_FPTR(indirect_old_ck_rv2sv)(aTHX_ o); + + indirect_map_delete(o); + return o; } /* ... ck_padany ........................................................... */ @@ -442,10 +561,12 @@ 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; } } + indirect_map_delete(o); return o; } @@ -456,38 +577,59 @@ STATIC OP *(*indirect_old_ck_method)(pTHX_ OP *) = 0; STATIC OP *indirect_ck_method(pTHX_ OP *o) { if (indirect_hint()) { OP *op = cUNOPo->op_first; + const indirect_op_info_t *oi = indirect_map_fetch(op); + const char *s = NULL; + line_t line; SV *sv; - const char *s = indirect_map_fetch(op, &sv); - if (!s) { + + if (oi && (s = oi->pos)) { + 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; } done: - return CALL_FPTR(indirect_old_ck_method)(aTHX_ o); + o = CALL_FPTR(indirect_old_ck_method)(aTHX_ o); + + indirect_map_delete(o); + return o; } /* ... 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) { - SV *hint = indirect_hint(); + SV *code = indirect_hint(); o = CALL_FPTR(indirect_old_ck_entersub)(aTHX_ o); - if (hint) { - const char *mpos, *opos; - SV *mnamesv, *onamesv; - OP *mop, *oop; + if (code) { + const indirect_op_info_t *moi, *ooi; + OP *mop, *oop; LISTOP *lop; oop = o; @@ -500,55 +642,58 @@ STATIC OP *indirect_ck_entersub(pTHX_ OP *o) { oop = oop->op_sibling; mop = lop->op_last; + if (!oop) + goto done; + + switch (oop->op_type) { + case OP_CONST: + case OP_RV2SV: + case OP_PADSV: + break; + default: + goto done; + } + if (mop->op_type == OP_METHOD) mop = cUNOPx(mop)->op_first; else if (mop->op_type != OP_METHOD_NAMED) goto done; - mpos = indirect_map_fetch(mop, &mnamesv); - if (!mpos) + moi = indirect_map_fetch(mop); + if (!(moi && moi->pos)) goto done; - opos = indirect_map_fetch(oop, &onamesv); - if (!opos) + ooi = indirect_map_fetch(oop); + if (!(ooi && ooi->pos)) goto done; - if (mpos < opos) { - SV *code = indirect_detag(hint); - - if (hint) { - SV *file; - line_t line; - dSP; + if (indirect_is_indirect(moi, ooi)) { + SV *file; + dSP; - onamesv = sv_mortalcopy(onamesv); - mnamesv = sv_mortalcopy(mnamesv); + ENTER; + SAVETMPS; #ifdef USE_ITHREADS - file = newSVpv(CopFILE(&PL_compiling), 0); + file = sv_2mortal(newSVpv(CopFILE(&PL_compiling), 0)); #else - file = sv_mortalcopy(CopFILESV(&PL_compiling)); + file = sv_mortalcopy(CopFILESV(&PL_compiling)); #endif - line = CopLINE(&PL_compiling); - ENTER; - SAVETMPS; + PUSHMARK(SP); + EXTEND(SP, 4); + mPUSHp(ooi->buf, ooi->len); + mPUSHp(moi->buf, moi->len); + PUSHs(file); + mPUSHu(moi->line); + PUTBACK; - PUSHMARK(SP); - EXTEND(SP, 4); - PUSHs(onamesv); - PUSHs(mnamesv); - PUSHs(file); - mPUSHu(line); - PUTBACK; + call_sv(code, G_VOID); - call_sv(code, G_VOID); + PUTBACK; - PUTBACK; - - FREETMPS; - LEAVE; - } + FREETMPS; + LEAVE; } } @@ -572,8 +717,10 @@ BOOT: MY_CXT_INIT; MY_CXT.map = ptable_new(); MY_CXT.linestr = NULL; -#if I_THREADSAFE +#if I_THREADSAFE || I_WORKAROUND_REQUIRE_PROPAGATION MY_CXT.tbl = ptable_new(); +#endif +#if I_THREADSAFE MY_CXT.owner = aTHX; #endif