X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2Findirect.git;a=blobdiff_plain;f=indirect.xs;h=f020a1f52508ccdaebef759f8cfa086f160d4bbe;hp=6203d97a4d74679471f6e733771c711aa63c5c2c;hb=0b3fd3ca50b788eb9ba7b9a1a3fbdb2266d6a40f;hpb=0df47659c67c30deca9fc06d6c7643a886ddb7d8 diff --git a/indirect.xs b/indirect.xs index 6203d97..f020a1f 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 @@ -31,10 +35,26 @@ # define SvPVX_const SvPVX #endif +#ifndef SvREFCNT_inc_simple_void_NN +# ifdef SvREFCNT_inc_simple_NN +# define SvREFCNT_inc_simple_void_NN SvREFCNT_inc_simple_NN +# else +# define SvREFCNT_inc_simple_void_NN SvREFCNT_inc +# endif +#endif + #ifndef sv_catpvn_nomg # 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 + #ifndef HvNAME_get # define HvNAME_get(H) HvNAME(H) #endif @@ -43,16 +63,17 @@ # define HvNAMELEN_get(H) strlen(HvNAME_get(H)) #endif -#ifndef SvIS_FREED -# define SvIS_FREED(sv) ((sv)->sv_flags == SVTYPEMASK) +#ifndef OpSIBLING +# ifdef OP_SIBLING +# define OpSIBLING(O) OP_SIBLING(O) +# else +# define OpSIBLING(O) ((O)->op_sibling) +# endif #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) -# ifndef PL_lex_inwhat -# define PL_lex_inwhat PL_parser->lex_inwhat -# endif # ifndef PL_linestr # define PL_linestr PL_parser->linestr # endif @@ -62,10 +83,10 @@ # ifndef PL_oldbufptr # define PL_oldbufptr PL_parser->oldbufptr # endif -#else # ifndef PL_lex_inwhat -# define PL_lex_inwhat PL_Ilex_inwhat +# define PL_lex_inwhat PL_parser->lex_inwhat # endif +#else # ifndef PL_linestr # define PL_linestr PL_Ilinestr # endif @@ -75,17 +96,34 @@ # ifndef PL_oldbufptr # define PL_oldbufptr PL_Ioldbufptr # endif +# ifndef PL_lex_inwhat +# define PL_lex_inwhat PL_Ilex_inwhat +# endif +#endif + +#ifndef I_WORKAROUND_REQUIRE_PROPAGATION +# define I_WORKAROUND_REQUIRE_PROPAGATION !I_HAS_PERL(5, 10, 1) #endif /* ... Thread safety and multiplicity ...................................... */ +/* Safe unless stated otherwise in Makefile.PL */ +#ifndef I_FORKSAFE +# define I_FORKSAFE 1 +#endif + #ifndef I_MULTIPLICITY -# if defined(MULTIPLICITY) || defined(PERL_IMPLICIT_CONTEXT) +# if defined(MULTIPLICITY) # define I_MULTIPLICITY 1 # else # define I_MULTIPLICITY 0 # endif #endif +#if I_MULTIPLICITY +# ifndef PERL_IMPLICIT_CONTEXT +# error MULTIPLICITY builds must set PERL_IMPLICIT_CONTEXT +# endif +#endif #if I_MULTIPLICITY && !defined(tTHX) # define tTHX PerlInterpreter* #endif @@ -106,19 +144,188 @@ # undef MY_CXT # define MY_CXT indirect_globaldata # undef START_MY_CXT -# define START_MY_CXT STATIC my_cxt_t MY_CXT; +# define START_MY_CXT static my_cxt_t MY_CXT; # undef MY_CXT_INIT # define MY_CXT_INIT NOOP # undef MY_CXT_CLONE # define MY_CXT_CLONE NOOP #endif +#if defined(OP_CHECK_MUTEX_LOCK) && defined(OP_CHECK_MUTEX_UNLOCK) +# define I_CHECK_MUTEX_LOCK OP_CHECK_MUTEX_LOCK +# define I_CHECK_MUTEX_UNLOCK OP_CHECK_MUTEX_UNLOCK +#else +# define I_CHECK_MUTEX_LOCK OP_REFCNT_LOCK +# define I_CHECK_MUTEX_UNLOCK OP_REFCNT_UNLOCK +#endif + +typedef OP *(*indirect_ck_t)(pTHX_ OP *); + +#ifdef wrap_op_checker + +# define indirect_ck_replace(T, NC, OCP) wrap_op_checker((T), (NC), (OCP)) + +#else + +static void indirect_ck_replace(pTHX_ OPCODE type, indirect_ck_t new_ck, indirect_ck_t *old_ck_p) { +#define indirect_ck_replace(T, NC, OCP) indirect_ck_replace(aTHX_ (T), (NC), (OCP)) + I_CHECK_MUTEX_LOCK; + if (!*old_ck_p) { + *old_ck_p = PL_check[type]; + PL_check[type] = new_ck; + } + I_CHECK_MUTEX_UNLOCK; +} + +#endif + +static void indirect_ck_restore(pTHX_ OPCODE type, indirect_ck_t *old_ck_p) { +#define indirect_ck_restore(T, OCP) indirect_ck_restore(aTHX_ (T), (OCP)) + I_CHECK_MUTEX_LOCK; + if (*old_ck_p) { + PL_check[type] = *old_ck_p; + *old_ck_p = 0; + } + I_CHECK_MUTEX_UNLOCK; +} + /* --- Helpers ------------------------------------------------------------- */ -/* ... Pointer table ....................................................... */ +/* ... Check if the module is loaded ....................................... */ + +#if I_THREADSAFE + +#define PTABLE_NAME ptable_loaded +#define PTABLE_VAL_FREE(V) NOOP + +#include "ptable.h" + +#define ptable_loaded_store(T, K, V) ptable_loaded_store(aPTBLMS_ (T), (K), (V)) +#define ptable_loaded_delete(T, K) ptable_loaded_delete(aPTBLMS_ (T), (K)) +#define ptable_loaded_free(T) ptable_loaded_free(aPTBLMS_ (T)) + +#define indirect_loaded() + +static ptable *indirect_loaded_cxts = NULL; +static U32 indirect_loaded_cxts_refcount = 0; + +/* We must use preexistent global mutexes or we will never be able to destroy + * them. */ +#if I_HAS_PERL(5, 9, 3) +# define I_LOADED_LOCK MUTEX_LOCK(&PL_my_ctx_mutex) +# define I_LOADED_UNLOCK MUTEX_UNLOCK(&PL_my_ctx_mutex) +#else +# define I_LOADED_LOCK OP_REFCNT_LOCK +# define I_LOADED_UNLOCK OP_REFCNT_UNLOCK +#endif + +static int indirect_is_loaded(pTHX_ void *cxt) { +#define indirect_is_loaded(C) indirect_is_loaded(aTHX_ (C)) + int res = 0; + + I_LOADED_LOCK; + if (indirect_loaded_cxts && ptable_fetch(indirect_loaded_cxts, cxt)) + res = 1; + I_LOADED_UNLOCK; + + return res; +} + +static void indirect_set_loaded(pTHX_ void *cxt) { +#define indirect_set_loaded(C) indirect_set_loaded(aTHX_ (C)) + I_LOADED_LOCK; + if (!indirect_loaded_cxts) { + indirect_loaded_cxts = ptable_new(); + indirect_loaded_cxts_refcount = 0; + } + ++indirect_loaded_cxts_refcount; + ptable_loaded_store(indirect_loaded_cxts, cxt, cxt); + I_LOADED_UNLOCK; +} + +static void indirect_clear_loaded(pTHX_ void *cxt) { +#define indirect_clear_loaded(C) indirect_clear_loaded(aTHX_ (C)) + I_LOADED_LOCK; + if (indirect_loaded_cxts_refcount <= 1) { + ptable_loaded_free(indirect_loaded_cxts); + indirect_loaded_cxts = NULL; + indirect_loaded_cxts_refcount = 0; + } else { + --indirect_loaded_cxts_refcount; + ptable_loaded_delete(indirect_loaded_cxts, cxt); + } + I_LOADED_UNLOCK; +} + +#else + +#define indirect_is_loaded(C) (1) +#define indirect_set_loaded(C) NOOP +#define indirect_clear_loaded(C) NOOP + +#endif + +/* ... Thread-safe hints ................................................... */ + +#if I_WORKAROUND_REQUIRE_PROPAGATION + +typedef struct { + SV *code; + IV require_tag; +} indirect_hint_t; + +#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 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_ +#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 */ + +/* Define the op->str ptable here because we need to be able to clean it during + * thread cleanup. */ + +typedef struct { + char *buf; + STRLEN pos; + STRLEN size; + STRLEN len; + 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_ @@ -128,244 +335,415 @@ #include "ptable.h" #define ptable_store(T, K, V) ptable_store(aTHX_ (T), (K), (V)) +#define ptable_delete(T, K) ptable_delete(aTHX_ (T), (K)) #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; - ptable *map; - tTHX owner; - const char *linestr; +#if I_THREADSAFE + ptable *tbl; /* It really is a ptable_hints */ + tTHX owner; +#endif + ptable *map; + SV *global_code; } my_cxt_t; -#else +START_MY_CXT -typedef struct { - ptable *map; - const char *linestr; -} my_cxt_t; +#if I_THREADSAFE -#endif /* I_THREADSAFE */ +typedef struct { + ptable *tbl; +#if I_HAS_PERL(5, 13, 2) + CLONE_PARAMS *params; +#else + CLONE_PARAMS params; +#endif +} indirect_ptable_clone_ud; + +#if I_HAS_PERL(5, 13, 2) +# define indirect_ptable_clone_ud_init(U, T, O) \ + (U).tbl = (T); \ + (U).params = Perl_clone_params_new((O), aTHX) +# define indirect_ptable_clone_ud_deinit(U) Perl_clone_params_del((U).params) +# define indirect_dup_inc(S, U) SvREFCNT_inc(sv_dup((S), (U)->params)) +#else +# define indirect_ptable_clone_ud_init(U, T, O) \ + (U).tbl = (T); \ + (U).params.stashes = newAV(); \ + (U).params.flags = 0; \ + (U).params.proto_perl = (O) +# define indirect_ptable_clone_ud_deinit(U) SvREFCNT_dec((U).params.stashes) +# define indirect_dup_inc(S, U) SvREFCNT_inc(sv_dup((S), &((U)->params))) +#endif -START_MY_CXT +static void indirect_ptable_clone(pTHX_ ptable_ent *ent, void *ud_) { + indirect_ptable_clone_ud *ud = ud_; + indirect_hint_t *h1 = ent->val; + indirect_hint_t *h2; -#if I_THREADSAFE +#if I_HINT_STRUCT -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); - } - } + h2 = PerlMemShared_malloc(sizeof *h2); + h2->code = indirect_dup_inc(h1->code, ud); +#if I_WORKAROUND_REQUIRE_PROPAGATION + h2->require_tag = PTR2IV(indirect_dup_inc(INT2PTR(SV *, h1->require_tag), ud)); +#endif - ptable_store(ud->tbl, ent->key, val); - SvREFCNT_inc(val); -} +#else /* I_HINT_STRUCT */ -STATIC void indirect_thread_cleanup(pTHX_ void *); + h2 = indirect_dup_inc(h1, ud); -STATIC void indirect_thread_cleanup(pTHX_ void *ud) { - int *level = ud; - SV *id; +#endif /* !I_HINT_STRUCT */ - if (*level) { - *level = 0; - LEAVE; - SAVEDESTRUCTOR_X(indirect_thread_cleanup, level); - ENTER; - } else { - dMY_CXT; - PerlMemShared_free(level); - ptable_free(MY_CXT.map); - ptable_free(MY_CXT.tbl); - } + ptable_hints_store(ud->tbl, ent->key, h2); } -STATIC SV *indirect_tag(pTHX_ SV *value) { -#define indirect_tag(V) indirect_tag(aTHX_ (V)) +static void indirect_thread_cleanup(pTHX_ void *ud) { dMY_CXT; - value = SvOK(value) && SvROK(value) ? SvRV(value) : NULL; - /* 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); + indirect_clear_loaded(&MY_CXT); + + SvREFCNT_dec(MY_CXT.global_code); + MY_CXT.global_code = NULL; - return newSVuv(PTR2UV(value)); + ptable_free(MY_CXT.map); + MY_CXT.map = NULL; + + ptable_hints_free(MY_CXT.tbl); + MY_CXT.tbl = NULL; } -STATIC SV *indirect_detag(pTHX_ const SV *hint) { -#define indirect_detag(H) indirect_detag(aTHX_ (H)) - void *tag; - SV *value; +static int indirect_endav_free(pTHX_ SV *sv, MAGIC *mg) { + SAVEDESTRUCTOR_X(indirect_thread_cleanup, NULL); - if (!hint || !SvOK(hint) || !SvIOK(hint)) - croak("Wrong hint"); + return 0; +} - tag = INT2PTR(void *, SvIVX(hint)); - { - dMY_CXT; - value = ptable_fetch(MY_CXT.tbl, tag); +static MGVTBL indirect_endav_vtbl = { + 0, + 0, + 0, + 0, + indirect_endav_free +#if MGf_COPY + , 0 +#endif +#if MGf_DUP + , 0 +#endif +#if MGf_LOCAL + , 0 +#endif +}; + +#endif /* I_THREADSAFE */ + +#if I_WORKAROUND_REQUIRE_PROPAGATION +static IV indirect_require_tag(pTHX) { +#define indirect_require_tag() indirect_require_tag(aTHX) + 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 value; -} +get_enclosing_cv: + for (outside = CvOUTSIDE(cv); outside; outside = CvOUTSIDE(cv)) + cv = outside; -#else + return PTR2IV(cv); +} +#endif /* I_WORKAROUND_REQUIRE_PROPAGATION */ -STATIC SV *indirect_tag(pTHX_ SV *value) { +static SV *indirect_tag(pTHX_ SV *value) { #define indirect_tag(V) indirect_tag(aTHX_ (V)) - UV tag = 0; + indirect_hint_t *h; + SV *code = NULL; +#if I_THREADSAFE + dMY_CXT; + + if (!MY_CXT.tbl) + return newSViv(0); +#endif /* I_THREADSAFE */ - if (SvOK(value) && SvROK(value)) { + if (SvROK(value)) { value = SvRV(value); - SvREFCNT_inc(value); - tag = PTR2UV(value); + if (SvTYPE(value) >= SVt_PVCV) { + code = value; + SvREFCNT_inc_simple_void_NN(code); + } } - return newSVuv(tag); +#if I_HINT_STRUCT + h = PerlMemShared_malloc(sizeof *h); + h->code = code; +# if I_WORKAROUND_REQUIRE_PROPAGATION + h->require_tag = indirect_require_tag(); +# 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 hint as the key itself. */ + ptable_hints_store(MY_CXT.tbl, h, h); +#endif /* I_THREADSAFE */ + + return newSViv(PTR2IV(h)); } -#define indirect_detag(H) INT2PTR(SV *, SvUVX(H)) +static SV *indirect_detag(pTHX_ const SV *hint) { +#define indirect_detag(H) indirect_detag(aTHX_ (H)) + indirect_hint_t *h; +#if I_THREADSAFE || I_WORKAROUND_REQUIRE_PROPAGATION + dMY_CXT; +#endif + +#if I_THREADSAFE + if (!MY_CXT.tbl) + return NULL; +#endif /* I_THREADSAFE */ + h = INT2PTR(indirect_hint_t *, SvIVX(hint)); +#if I_THREADSAFE + h = ptable_fetch(MY_CXT.tbl, h); #endif /* I_THREADSAFE */ -STATIC U32 indirect_hash = 0; +#if I_WORKAROUND_REQUIRE_PROPAGATION + if (indirect_require_tag() != h->require_tag) + return MY_CXT.global_code; +#endif /* I_WORKAROUND_REQUIRE_PROPAGATION */ -STATIC SV *indirect_hint(pTHX) { + return I_HINT_CODE(h); +} + +static VOL 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 = NULL; + + if (IN_PERL_RUNTIME) + return NULL; + +#if I_HAS_PERL(5, 10, 0) || defined(PL_parser) + if (!PL_parser) + return NULL; +#endif + +#ifdef cop_hints_fetch_pvn + hint = cop_hints_fetch_pvn(PL_curcop, __PACKAGE__, __PACKAGE_LEN__, + indirect_hash, 0); +#elif 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__, - indirect_hash); - if (!val) - return 0; - id = *val; + { + SV **val = hv_fetch(GvHV(PL_hintgv), __PACKAGE__, __PACKAGE_LEN__, 0); + if (val) + hint = *val; + } #endif - return (id && SvOK(id)) ? id : NULL; + + if (hint && SvIOK(hint)) { + return indirect_detag(hint); + } else { + dMY_CXT; + if (indirect_is_loaded(&MY_CXT)) + return MY_CXT.global_code; + else + return NULL; + } } /* ... 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, STRLEN pos, SV *sv, line_t line) { +#define indirect_map_store(O, P, N, L) indirect_map_store(aTHX_ (O), (P), (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 - * still be alive somewhere. */ + /* No need to check for MY_CXT.map != NULL because this code path is always + * guarded by indirect_hint(). */ - if (!PL_lex_inwhat) { - const char *pl_linestr = SvPVX_const(PL_linestr); - if (MY_CXT.linestr != pl_linestr) { - ptable_clear(MY_CXT.map); - MY_CXT.linestr = pl_linestr; - } + 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; + } + + if (sv) { + s = SvPV_const(sv, len); + } else { + s = "{"; + len = 1; } - val = newSVsv(sv); - SvUPGRADE(val, SVt_PVIV); - SvUVX(val) = PTR2UV(src); - SvIOK_on(val); - SvIsUV_on(val); + if (len > oi->size) { + Safefree(oi->buf); + Newx(oi->buf, len, char); + oi->size = len; + } + Copy(s, oi->buf, len, char); - ptable_store(MY_CXT.map, o, val); + oi->len = len; + oi->pos = pos; + 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)) dMY_CXT; - SV *val; - if (MY_CXT.linestr != SvPVX_const(PL_linestr)) - return NULL; + /* No need to check for MY_CXT.map != NULL because this code path is always + * guarded by indirect_hint(). */ - val = ptable_fetch(MY_CXT.map, o); - if (!val) { - *name = NULL; - return NULL; - } + return ptable_fetch(MY_CXT.map, o); +} - *name = val; - return INT2PTR(const char *, SvUVX(val)); +static void indirect_map_delete(pTHX_ const OP *o) { +#define indirect_map_delete(O) indirect_map_delete(aTHX_ (O)) + dMY_CXT; + + if (indirect_is_loaded(&MY_CXT) && MY_CXT.map) + ptable_delete(MY_CXT.map, o); } /* --- Check functions ----------------------------------------------------- */ -STATIC const char *indirect_find(pTHX_ SV *sv, const char *s) { -#define indirect_find(N, S) indirect_find(aTHX_ (N), (S)) - STRLEN len; - const char *p = NULL, *r = SvPV_const(sv, len); - - if (len >= 1 && *r == '$') { - ++r; - --len; - s = strchr(s, '$'); - if (!s) - return NULL; +static int indirect_find(pTHX_ SV *name_sv, const char *line_bufptr, STRLEN *name_pos) { +#define indirect_find(NSV, LBP, NP) indirect_find(aTHX_ (NSV), (LBP), (NP)) + STRLEN name_len, line_len; + const char *name, *name_end; + const char *line, *line_end; + const char *p; + + line = SvPV_const(PL_linestr, line_len); + line_end = line + line_len; + + name = SvPV_const(name_sv, name_len); + if (name_len >= 1 && *name == '$') { + ++name; + --name_len; + while (line_bufptr < line_end && *line_bufptr != '$') + ++line_bufptr; + if (line_bufptr >= line_end) + return 0; } - - p = strstr(s, r); - while (p) { - p += len; - if (!isALNUM(*p)) + name_end = name + name_len; + + p = line_bufptr; + while (1) { + p = ninstr(p, line_end, name, name_end); + if (!p) + return 0; + if (!isALNUM(p[name_len])) break; - p = strstr(p + 1, r); + /* p points to a word that has name as prefix, skip the rest of the word */ + p += name_len + 1; + while (isALNUM(*p)) + ++p; } - return p; + *name_pos = p - line; + + return 1; } /* ... ck_const ............................................................ */ -STATIC OP *(*indirect_old_ck_const)(pTHX_ OP *) = 0; +static OP *(*indirect_old_ck_const)(pTHX_ OP *) = 0; -STATIC OP *indirect_ck_const(pTHX_ OP *o) { - o = CALL_FPTR(indirect_old_ck_const)(aTHX_ o); +static OP *indirect_ck_const(pTHX_ OP *o) { + o = indirect_old_ck_const(aTHX_ 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)) { + STRLEN pos; + + if (indirect_find(sv, PL_oldbufptr, &pos)) { + STRLEN len; + + /* If the constant is equal to the current package name, try to look for + * a "__PACKAGE__" coming before what we got. We only need to check this + * when we already had a match because __PACKAGE__ can only appear in + * direct method calls ("new __PACKAGE__" is a syntax error). */ + len = SvCUR(sv); + if (PL_curstash + && len == (STRLEN) HvNAMELEN_get(PL_curstash) + && memcmp(SvPVX(sv), HvNAME_get(PL_curstash), len) == 0) { + STRLEN pos_pkg; + SV *pkg = sv_newmortal(); + sv_setpvn(pkg, "__PACKAGE__", sizeof("__PACKAGE__")-1); + + if (indirect_find(pkg, PL_oldbufptr, &pos_pkg) && pos_pkg < pos) { + sv = pkg; + pos = pos_pkg; + } + } + + indirect_map_store(o, pos, sv, CopLINE(&PL_compiling)); + return o; + } + } } + indirect_map_delete(o); return o; } /* ... ck_rv2sv ............................................................ */ -STATIC OP *(*indirect_old_ck_rv2sv)(pTHX_ OP *) = 0; +static OP *(*indirect_old_ck_rv2sv)(pTHX_ OP *) = 0; -STATIC OP *indirect_ck_rv2sv(pTHX_ OP *o) { +static OP *indirect_ck_rv2sv(pTHX_ OP *o) { if (indirect_hint()) { OP *op = cUNOPo->op_first; SV *sv; - const char *name = NULL, *s; - STRLEN len; + const char *name = NULL; + STRLEN pos, len; OPCODE type = (OPCODE) op->op_type; switch (type) { @@ -388,8 +766,8 @@ STATIC OP *indirect_ck_rv2sv(pTHX_ OP *o) { sv = sv_2mortal(newSVpvn("$", 1)); sv_catpvn_nomg(sv, name, len); - s = indirect_find(sv, PL_oldbufptr); - if (!s) { /* If it failed, retry without the current stash */ + if (!indirect_find(sv, PL_oldbufptr, &pos)) { + /* If it failed, retry without the current stash */ const char *stash = HvNAME_get(PL_curstash); STRLEN stashlen = HvNAMELEN_get(PL_curstash); @@ -406,26 +784,29 @@ STATIC OP *indirect_ck_rv2sv(pTHX_ OP *o) { sv_setpvn(sv, "$", 1); stashlen += 2; sv_catpvn_nomg(sv, name + stashlen, len - stashlen); - s = indirect_find(sv, PL_oldbufptr); - if (!s) + if (!indirect_find(sv, PL_oldbufptr, &pos)) goto done; } - o = CALL_FPTR(indirect_old_ck_rv2sv)(aTHX_ o); - indirect_map_store(o, s, sv); + o = indirect_old_ck_rv2sv(aTHX_ o); + + indirect_map_store(o, pos, sv, CopLINE(&PL_compiling)); return o; } done: - return CALL_FPTR(indirect_old_ck_rv2sv)(aTHX_ o); + o = indirect_old_ck_rv2sv(aTHX_ o); + + indirect_map_delete(o); + return o; } /* ... ck_padany ........................................................... */ -STATIC OP *(*indirect_old_ck_padany)(pTHX_ OP *) = 0; +static OP *(*indirect_old_ck_padany)(pTHX_ OP *) = 0; -STATIC OP *indirect_ck_padany(pTHX_ OP *o) { - o = CALL_FPTR(indirect_old_ck_padany)(aTHX_ o); +static OP *indirect_ck_padany(pTHX_ OP *o) { + o = indirect_old_ck_padany(aTHX_ o); if (indirect_hint()) { SV *sv; @@ -437,52 +818,130 @@ 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 - SvPVX_const(PL_linestr), + sv, CopLINE(&PL_compiling)); + return o; } } + indirect_map_delete(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 = old_ck(aTHX_ o); + + if (indirect_hint()) { + indirect_map_store(o, PL_oldbufptr - SvPVX_const(PL_linestr), + 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; +static OP *(*indirect_old_ck_method)(pTHX_ OP *) = 0; -STATIC OP *indirect_ck_method(pTHX_ OP *o) { +static OP *indirect_ck_method(pTHX_ OP *o) { if (indirect_hint()) { OP *op = cUNOPo->op_first; - SV *sv; - const char *s = indirect_map_fetch(op, &sv); - if (!s) { - sv = cSVOPx_sv(op); - if (!SvPOK(sv) || (SvTYPE(sv) < SVt_PV)) + + /* Indirect method call is only possible when the method is a bareword, so + * don't trip up on $obj->$meth. */ + if (op && op->op_type == OP_CONST) { + const indirect_op_info_t *oi = indirect_map_fetch(op); + STRLEN pos; + line_t line; + SV *sv; + + if (!oi) goto done; - sv = sv_mortalcopy(sv); - s = indirect_find(sv, PL_oldbufptr); + + sv = sv_2mortal(newSVpvn(oi->buf, oi->len)); + pos = oi->pos; + /* Keep the old line so that we really point to the first line of the + * expression. */ + line = oi->line; + + o = indirect_old_ck_method(aTHX_ o); + /* o may now be a method_named */ + + indirect_map_store(o, pos, sv, line); + return o; } - o = CALL_FPTR(indirect_old_ck_method)(aTHX_ o); - /* o may now be a method_named */ - indirect_map_store(o, s, sv); + } + +done: + o = indirect_old_ck_method(aTHX_ o); + + indirect_map_delete(o); + return o; +} + +/* ... ck_method_named ..................................................... */ + +/* "use foo/no foo" compiles its call to import/unimport directly to a + * method_named op. */ + +static OP *(*indirect_old_ck_method_named)(pTHX_ OP *) = 0; + +static OP *indirect_ck_method_named(pTHX_ OP *o) { + if (indirect_hint()) { + STRLEN pos; + line_t line; + SV *sv; + + sv = cSVOPo_sv; + if (!SvPOK(sv) || (SvTYPE(sv) < SVt_PV)) + goto done; + sv = sv_mortalcopy(sv); + + if (!indirect_find(sv, PL_oldbufptr, &pos)) + goto done; + line = CopLINE(&PL_compiling); + + o = indirect_old_ck_method_named(aTHX_ o); + + indirect_map_store(o, pos, sv, line); return o; } done: - return CALL_FPTR(indirect_old_ck_method)(aTHX_ o); + o = indirect_old_ck_method_named(aTHX_ o); + + indirect_map_delete(o); + return o; } /* ... ck_entersub ......................................................... */ -STATIC OP *(*indirect_old_ck_entersub)(pTHX_ OP *) = 0; +static OP *(*indirect_old_ck_entersub)(pTHX_ OP *) = 0; -STATIC OP *indirect_ck_entersub(pTHX_ OP *o) { - SV *hint = indirect_hint(); +static OP *indirect_ck_entersub(pTHX_ OP *o) { + SV *code = indirect_hint(); - o = CALL_FPTR(indirect_old_ck_entersub)(aTHX_ o); + o = 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; @@ -492,44 +951,67 @@ STATIC OP *indirect_ck_entersub(pTHX_ OP *o) { goto done; oop = lop->op_first; } while (oop->op_type != OP_PUSHMARK); - oop = oop->op_sibling; + oop = OpSIBLING(oop); mop = lop->op_last; + if (!oop) + goto done; + + switch (oop->op_type) { + case OP_CONST: + case OP_RV2SV: + case OP_PADSV: + case OP_SCOPE: + case OP_LEAVE: + 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) goto done; - opos = indirect_map_fetch(oop, &onamesv); - if (!opos) + ooi = indirect_map_fetch(oop); + if (!ooi) goto done; - if (mpos < opos) { - SV *code = indirect_detag(hint); + /* When positions are identical, the method and the object must have the + * same name. But it also means that it is an indirect call, as "foo->foo" + * results in different positions. */ + if ( moi->line < ooi->line + || (moi->line == ooi->line && moi->pos <= ooi->pos)) { + SV *file; + dSP; - if (hint) { - dSP; + ENTER; + SAVETMPS; - ENTER; - SAVETMPS; +#ifdef USE_ITHREADS + file = sv_2mortal(newSVpv(CopFILE(&PL_compiling), 0)); +#else + file = sv_mortalcopy(CopFILESV(&PL_compiling)); +#endif - PUSHMARK(SP); - EXTEND(SP, 2); - PUSHs(onamesv); - PUSHs(mnamesv); - PUTBACK; + PUSHMARK(SP); + EXTEND(SP, 4); + mPUSHp(ooi->buf, ooi->len); + mPUSHp(moi->buf, moi->len); + PUSHs(file); + mPUSHu(moi->line); + PUTBACK; - call_sv(code, G_VOID); + call_sv(code, G_VOID); - PUTBACK; + PUTBACK; - FREETMPS; - LEAVE; - } + FREETMPS; + LEAVE; } } @@ -537,43 +1019,118 @@ done: return o; } -STATIC U32 indirect_initialized = 0; +/* --- Global setup/teardown ------------------------------------------------ */ -/* --- XS ------------------------------------------------------------------ */ +static VOL U32 indirect_initialized = 0; -MODULE = indirect PACKAGE = indirect +static void indirect_global_teardown(pTHX_ void *root) { + if (!indirect_initialized) + return; -PROTOTYPES: ENABLE +#if I_MULTIPLICITY + if (aTHX != root) + return; +#endif -BOOT: -{ - if (!indirect_initialized++) { - HV *stash; + indirect_ck_restore(OP_CONST, &indirect_old_ck_const); + indirect_ck_restore(OP_RV2SV, &indirect_old_ck_rv2sv); + indirect_ck_restore(OP_PADANY, &indirect_old_ck_padany); + indirect_ck_restore(OP_SCOPE, &indirect_old_ck_scope); + indirect_ck_restore(OP_LINESEQ, &indirect_old_ck_lineseq); + + indirect_ck_restore(OP_METHOD, &indirect_old_ck_method); + indirect_ck_restore(OP_METHOD_NAMED, &indirect_old_ck_method_named); + indirect_ck_restore(OP_ENTERSUB, &indirect_old_ck_entersub); + + indirect_initialized = 0; + + return; +} + +static void indirect_global_setup(pTHX) { +#define indirect_global_setup() indirect_global_setup(aTHX) + HV *stash; + + if (indirect_initialized) + return; + + PERL_HASH(indirect_hash, __PACKAGE__, __PACKAGE_LEN__); + + stash = gv_stashpvn(__PACKAGE__, __PACKAGE_LEN__, 1); + newCONSTSUB(stash, "I_THREADSAFE", newSVuv(I_THREADSAFE)); + newCONSTSUB(stash, "I_FORKSAFE", newSVuv(I_FORKSAFE)); + + indirect_ck_replace(OP_CONST, indirect_ck_const, &indirect_old_ck_const); + indirect_ck_replace(OP_RV2SV, indirect_ck_rv2sv, &indirect_old_ck_rv2sv); + indirect_ck_replace(OP_PADANY, indirect_ck_padany, &indirect_old_ck_padany); + indirect_ck_replace(OP_SCOPE, indirect_ck_scope, &indirect_old_ck_scope); + indirect_ck_replace(OP_LINESEQ, indirect_ck_scope, &indirect_old_ck_lineseq); + + indirect_ck_replace(OP_METHOD, indirect_ck_method, + &indirect_old_ck_method); + indirect_ck_replace(OP_METHOD_NAMED, indirect_ck_method_named, + &indirect_old_ck_method_named); + indirect_ck_replace(OP_ENTERSUB, indirect_ck_entersub, + &indirect_old_ck_entersub); + +#if I_MULTIPLICITY + call_atexit(indirect_global_teardown, aTHX); +#else + call_atexit(indirect_global_teardown, NULL); +#endif + + indirect_initialized = 1; + + return; +} + +/* --- Interpreter setup/teardown ------------------------------------------ */ + +static void indirect_local_teardown(pTHX_ void *param) { + dMY_CXT; + + indirect_clear_loaded(&MY_CXT); + + ptable_free(MY_CXT.map); + MY_CXT.map = NULL; - MY_CXT_INIT; - MY_CXT.map = ptable_new(); - MY_CXT.linestr = NULL; #if I_THREADSAFE - MY_CXT.tbl = ptable_new(); - MY_CXT.owner = aTHX; + ptable_hints_free(MY_CXT.tbl); + MY_CXT.tbl = NULL; #endif - PERL_HASH(indirect_hash, __PACKAGE__, __PACKAGE_LEN__); + return; +} - indirect_old_ck_const = PL_check[OP_CONST]; - PL_check[OP_CONST] = MEMBER_TO_FPTR(indirect_ck_const); - indirect_old_ck_rv2sv = PL_check[OP_RV2SV]; - 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_method = PL_check[OP_METHOD]; - PL_check[OP_METHOD] = MEMBER_TO_FPTR(indirect_ck_method); - indirect_old_ck_entersub = PL_check[OP_ENTERSUB]; - PL_check[OP_ENTERSUB] = MEMBER_TO_FPTR(indirect_ck_entersub); +static void indirect_local_setup(pTHX) { +#define indirect_local_setup() indirect_local_setup(aTHX) + MY_CXT_INIT; - stash = gv_stashpvn(__PACKAGE__, __PACKAGE_LEN__, 1); - newCONSTSUB(stash, "I_THREADSAFE", newSVuv(I_THREADSAFE)); - } +#if I_THREADSAFE + MY_CXT.tbl = ptable_new(); + MY_CXT.owner = aTHX; +#endif + + MY_CXT.map = ptable_new(); + MY_CXT.global_code = NULL; + + indirect_set_loaded(&MY_CXT); + + call_atexit(indirect_local_teardown, NULL); + + return; +} + +/* --- XS ------------------------------------------------------------------ */ + +MODULE = indirect PACKAGE = indirect + +PROTOTYPES: ENABLE + +BOOT: +{ + indirect_global_setup(); + indirect_local_setup(); } #if I_THREADSAFE @@ -583,29 +1140,44 @@ CLONE(...) PROTOTYPE: DISABLE PREINIT: ptable *t; - int *level; -CODE: + SV *global_code_dup; + GV *gv; +PPCODE: { - my_cxt_t ud; + indirect_ptable_clone_ud ud; dMY_CXT; - ud.tbl = t = ptable_new(); - ud.owner = MY_CXT.owner; + t = ptable_new(); + indirect_ptable_clone_ud_init(ud, t, MY_CXT.owner); ptable_walk(MY_CXT.tbl, indirect_ptable_clone, &ud); + global_code_dup = indirect_dup_inc(MY_CXT.global_code, &ud); + indirect_ptable_clone_ud_deinit(ud); } { MY_CXT_CLONE; - MY_CXT.map = ptable_new(); - MY_CXT.linestr = NULL; - MY_CXT.tbl = t; - MY_CXT.owner = aTHX; + MY_CXT.map = ptable_new(); + MY_CXT.tbl = t; + MY_CXT.owner = aTHX; + MY_CXT.global_code = global_code_dup; + indirect_set_loaded(&MY_CXT); } - { - level = PerlMemShared_malloc(sizeof *level); - *level = 1; - LEAVE; - SAVEDESTRUCTOR_X(indirect_thread_cleanup, level); - ENTER; + gv = gv_fetchpv(__PACKAGE__ "::_THREAD_CLEANUP", 0, SVt_PVCV); + if (gv) { + CV *cv = GvCV(gv); + if (!PL_endav) + PL_endav = newAV(); + SvREFCNT_inc(cv); + if (!av_store(PL_endav, av_len(PL_endav) + 1, (SV *) cv)) + SvREFCNT_dec(cv); + sv_magicext((SV *) PL_endav, NULL, PERL_MAGIC_ext, &indirect_endav_vtbl, NULL, 0); } + XSRETURN(0); + +void +_THREAD_CLEANUP(...) +PROTOTYPE: DISABLE +PPCODE: + indirect_thread_cleanup(aTHX_ NULL); + XSRETURN(0); #endif @@ -616,3 +1188,18 @@ CODE: RETVAL = indirect_tag(value); OUTPUT: RETVAL + +void +_global(SV *code) +PROTOTYPE: $ +PPCODE: + if (!SvOK(code)) + code = NULL; + else if (SvROK(code)) + code = SvRV(code); + { + dMY_CXT; + SvREFCNT_dec(MY_CXT.global_code); + MY_CXT.global_code = SvREFCNT_inc(code); + } + XSRETURN(0);