X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2Findirect.git;a=blobdiff_plain;f=indirect.xs;h=49bdd205288bf20f2d37735e02a13da9f01ec401;hp=4e538b3d63ca7803d4ba7222d9eed839416fba7a;hb=7f2abe70c4334df1462a163d36bd809dd21d915e;hpb=67870a0f2916e9b66e3c4e95e81578a60328b2c0 diff --git a/indirect.xs b/indirect.xs index 4e538b3..49bdd20 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,18 @@ # 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 +#ifndef mPUSHp +# define mPUSHp(P, L) PUSHs(sv_2mortal(newSVpvn((P), (L)))) +#endif + #ifndef mPUSHu # define mPUSHu(U) PUSHs(sv_2mortal(newSVuv(U))) #endif @@ -50,9 +62,6 @@ #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 @@ -63,9 +72,6 @@ # define PL_oldbufptr PL_parser->oldbufptr # endif #else -# ifndef PL_lex_inwhat -# define PL_lex_inwhat PL_Ilex_inwhat -# endif # ifndef PL_linestr # define PL_linestr PL_Ilinestr # endif @@ -78,11 +84,16 @@ #endif #ifndef I_WORKAROUND_REQUIRE_PROPAGATION -# define I_WORKAROUND_REQUIRE_PROPAGATION !I_HAS_PERL(5, 10, 1) +# define I_WORKAROUND_REQUIRE_PROPAGATION !I_HAS_PERL(5, 12, 0) #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) # define I_MULTIPLICITY 1 @@ -121,25 +132,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 + SV *code; + IV require_tag; } indirect_hint_t; -#define PTABLE_NAME ptable_hints +#define I_HINT_STRUCT 1 -#if I_WORKAROUND_REQUIRE_PROPAGATION -# define PTABLE_VAL_FREE(V) \ - { indirect_hint_t *h = (V); SvREFCNT_dec(h->code); PerlMemShared_free(h); } -#else -# define PTABLE_VAL_FREE(V) SvREFCNT_dec(V) -#endif +#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_ @@ -151,13 +176,21 @@ 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. */ +typedef struct { + STRLEN pos; + STRLEN size; + STRLEN len; + char *buf; + line_t line; +} indirect_op_info_t; + #define PTABLE_NAME ptable -#define PTABLE_VAL_FREE(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_ @@ -167,125 +200,97 @@ typedef struct { #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)) #define MY_CXT_KEY __PACKAGE__ "::_guts" XS_VERSION typedef struct { -#if I_THREADSAFE || I_WORKAROUND_REQUIRE_PROPAGATION - ptable *tbl; /* It really is a ptable_hints */ -#endif - ptable *map; - const char *linestr; #if I_THREADSAFE - tTHX owner; + ptable *tbl; /* It really is a ptable_hints */ + tTHX owner; #endif + ptable *map; } my_cxt_t; START_MY_CXT #if I_THREADSAFE -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) { - SV *val = h1->code; - 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; - h2->code = sv_dup(val, ¶m); - if (stashes) { - av_undef(stashes); - SvREFCNT_dec(stashes); - } - } +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; - ptable_hints_store(ud->tbl, ent->key, h2); - SvREFCNT_inc(h2->code); -} + if (SvTYPE(sv) == SVt_PVHV && HvNAME_get(sv)) + stashes = newAV(); -STATIC void indirect_thread_cleanup(pTHX_ void *); + param.stashes = stashes; + param.flags = 0; + param.proto_perl = owner; -STATIC void indirect_thread_cleanup(pTHX_ void *ud) { - int *level = ud; + dupsv = sv_dup(sv, ¶m); - if (*level) { - *level = 0; - LEAVE; - SAVEDESTRUCTOR_X(indirect_thread_cleanup, level); - ENTER; - } else { - dMY_CXT; - PerlMemShared_free(level); - ptable_free(MY_CXT.map); - ptable_hints_free(MY_CXT.tbl); + if (stashes) { + av_undef(stashes); + SvREFCNT_dec(stashes); } -} - -#endif /* I_THREADSAFE */ -#if I_THREADSAFE || I_WORKAROUND_REQUIRE_PROPAGATION + return SvREFCNT_inc(dupsv); +} -STATIC SV *indirect_tag(pTHX_ SV *value) { -#define indirect_tag(V) indirect_tag(aTHX_ (V)) - indirect_hint_t *h; - dMY_CXT; +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; - value = SvOK(value) && SvROK(value) ? SvRV(value) : NULL; + if (ud->owner == aTHX) + return; - h = PerlMemShared_malloc(sizeof *h); - h->code = SvREFCNT_inc(value); +#if I_HINT_STRUCT + h2 = PerlMemShared_malloc(sizeof *h2); + h2->code = indirect_clone(h1->code, ud->owner); + SvREFCNT_inc(h2->code); #if I_WORKAROUND_REQUIRE_PROPAGATION - { - const PERL_SI *si; - I32 requires = 0; - - for (si = PL_curstackinfo; si; si = si->si_prev) { - I32 cxix; + h2->require_tag = PTR2IV(indirect_clone(INT2PTR(SV *, h1->require_tag), + ud->owner)); +#endif - for (cxix = si->si_cxix; cxix >= 0; --cxix) { - const PERL_CONTEXT *cx = si->si_cxstack + cxix; +#else /* I_HINT_STRUCT */ - if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_REQUIRE) - ++requires; - } - } + h2 = indirect_clone(h1, ud->owner); + SvREFCNT_inc(h2); - h->requires = requires; - } -#endif +#endif /* !I_HINT_STRUCT */ - /* 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); - - return newSVuv(PTR2UV(value)); + ptable_hints_store(ud->tbl, ent->key, h2); } -STATIC SV *indirect_detag(pTHX_ const SV *hint) { -#define indirect_detag(H) indirect_detag(aTHX_ (H)) - indirect_hint_t *h; +#include "reap.h" + +STATIC void indirect_thread_cleanup(pTHX_ void *ud) { dMY_CXT; - if (!(hint && SvOK(hint) && SvIOK(hint))) - return NULL; + ptable_free(MY_CXT.map); + ptable_hints_free(MY_CXT.tbl); +} - h = ptable_fetch(MY_CXT.tbl, INT2PTR(void *, SvUVX(hint))); +#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; - I32 requires = 0; for (si = PL_curstackinfo; si; si = si->si_prev) { I32 cxix; @@ -293,128 +298,185 @@ STATIC SV *indirect_detag(pTHX_ const SV *hint) { 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; + 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; } -#endif - return h->code; -} +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) { #define indirect_tag(V) indirect_tag(aTHX_ (V)) - UV tag = 0; + indirect_hint_t *h; + SV *code = NULL; + dMY_CXT; - 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_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) (((H) && SvOK(H)) ? INT2PTR(SV *, SvUVX(H)) : NULL) +STATIC SV *indirect_detag(pTHX_ const SV *hint) { +#define indirect_detag(H) indirect_detag(aTHX_ (H)) + indirect_hint_t *h; + dMY_CXT; -#endif /* I_THREADSAFE || I_WORKAROUND_REQUIRE_PROPAGATION */ + if (!(hint && SvIOK(hint))) + return NULL; + + 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 + if (indirect_require_tag() != h->require_tag) + return NULL; +#endif /* I_WORKAROUND_REQUIRE_PROPAGATION */ + + return I_HINT_CODE(h); +} STATIC U32 indirect_hash = 0; STATIC SV *indirect_hint(pTHX) { #define indirect_hint() indirect_hint(aTHX) - SV *hint, *code; -#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__, - indirect_hash); + SV **val; + + if (IN_PERL_RUNTIME) + return NULL; + + val = hv_fetch(GvHV(PL_hintgv), __PACKAGE__, __PACKAGE_LEN__, indirect_hash); if (!val) - return 0; - hint = *val; -#endif - return indirect_detag(hint); + return NULL; + + return indirect_detag(*val); } /* ... 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. */ + 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 (!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 (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); - SvREADONLY_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; + return ptable_fetch(MY_CXT.map, o); +} - val = ptable_fetch(MY_CXT.map, o); - if (!val) { - *name = NULL; - return NULL; - } +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_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)) +STATIC int indirect_find(pTHX_ SV *sv, const char *s, STRLEN *pos) { +#define indirect_find(N, S, P) indirect_find(aTHX_ (N), (S), (P)) STRLEN len; - const char *p = NULL, *r = SvPV_const(sv, len); + const char *p, *r = SvPV_const(sv, len); if (len >= 1 && *r == '$') { ++r; --len; s = strchr(s, '$'); if (!s) - return NULL; + return 0; } - p = strstr(s, r); - while (p) { - p += len; - if (!isALNUM(*p)) + p = s; + while (1) { + p = strstr(p, r); + if (!p) + return 0; + if (!isALNUM(p[len])) break; - p = strstr(p + 1, r); + /* p points to a word that has r as prefix, skip the rest of the word */ + p += len + 1; + while (isALNUM(*p)) + ++p; } - return p; + *pos = p - SvPVX_const(PL_linestr); + + return 1; } /* ... ck_const ............................................................ */ @@ -422,14 +484,22 @@ STATIC const char *indirect_find(pTHX_ SV *sv, const char *s) { 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); + 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)) { + indirect_map_store(o, pos, sv, CopLINE(&PL_compiling)); + return o; + } + } } + indirect_map_delete(o); return o; } @@ -441,8 +511,8 @@ 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) { @@ -465,8 +535,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); @@ -483,18 +553,21 @@ 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 ........................................................... */ @@ -502,7 +575,7 @@ done: 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); + o = indirect_old_ck_padany(aTHX_ o); if (indirect_hint()) { SV *sv; @@ -514,13 +587,43 @@ 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; @@ -528,23 +631,72 @@ 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; - 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 ......................................................... */ @@ -554,12 +706,11 @@ STATIC OP *(*indirect_old_ck_entersub)(pTHX_ OP *) = 0; 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 (code) { - const char *mpos, *opos; - SV *mnamesv, *onamesv; - OP *mop, *oop; + const indirect_op_info_t *moi, *ooi; + OP *mop, *oop; LISTOP *lop; oop = o; @@ -572,43 +723,55 @@ 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: + 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 *file; - line_t line; + /* 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->pos <= ooi->pos) { + SV *file; dSP; ENTER; SAVETMPS; - onamesv = sv_mortalcopy(onamesv); - mnamesv = sv_mortalcopy(mnamesv); - #ifdef USE_ITHREADS file = sv_2mortal(newSVpv(CopFILE(&PL_compiling), 0)); #else file = sv_mortalcopy(CopFILESV(&PL_compiling)); #endif - line = CopLINE(&PL_compiling); PUSHMARK(SP); EXTEND(SP, 4); - PUSHs(onamesv); - PUSHs(mnamesv); + mPUSHp(ooi->buf, ooi->len); + mPUSHp(moi->buf, moi->len); PUSHs(file); - mPUSHu(line); + mPUSHu(moi->line); PUTBACK; call_sv(code, G_VOID); @@ -626,6 +789,86 @@ done: STATIC U32 indirect_initialized = 0; +STATIC void indirect_teardown(pTHX_ void *root) { + dMY_CXT; + + if (!indirect_initialized) + return; + +#if I_MULTIPLICITY + if (aTHX != root) + return; +#endif + + ptable_free(MY_CXT.map); +#if I_THREADSAFE + ptable_hints_free(MY_CXT.tbl); +#endif + + PL_check[OP_CONST] = MEMBER_TO_FPTR(indirect_old_ck_const); + indirect_old_ck_const = 0; + PL_check[OP_RV2SV] = MEMBER_TO_FPTR(indirect_old_ck_rv2sv); + indirect_old_ck_rv2sv = 0; + PL_check[OP_PADANY] = MEMBER_TO_FPTR(indirect_old_ck_padany); + indirect_old_ck_padany = 0; + PL_check[OP_SCOPE] = MEMBER_TO_FPTR(indirect_old_ck_scope); + indirect_old_ck_scope = 0; + PL_check[OP_LINESEQ] = MEMBER_TO_FPTR(indirect_old_ck_lineseq); + indirect_old_ck_lineseq = 0; + + PL_check[OP_METHOD] = MEMBER_TO_FPTR(indirect_old_ck_method); + indirect_old_ck_method = 0; + PL_check[OP_METHOD_NAMED] = MEMBER_TO_FPTR(indirect_old_ck_method_named); + indirect_old_ck_method_named = 0; + PL_check[OP_ENTERSUB] = MEMBER_TO_FPTR(indirect_old_ck_entersub); + indirect_old_ck_entersub = 0; + + indirect_initialized = 0; +} + +STATIC void indirect_setup(pTHX) { +#define indirect_setup() indirect_setup(aTHX) + if (indirect_initialized) + return; + + { + MY_CXT_INIT; +#if I_THREADSAFE + MY_CXT.tbl = ptable_new(); + MY_CXT.owner = aTHX; +#endif + MY_CXT.map = ptable_new(); + } + + 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_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_method_named = PL_check[OP_METHOD_NAMED]; + PL_check[OP_METHOD_NAMED] = MEMBER_TO_FPTR(indirect_ck_method_named); + indirect_old_ck_entersub = PL_check[OP_ENTERSUB]; + PL_check[OP_ENTERSUB] = MEMBER_TO_FPTR(indirect_ck_entersub); + +#if I_MULTIPLICITY + call_atexit(indirect_teardown, aTHX); +#else + call_atexit(indirect_teardown, NULL); +#endif + + indirect_initialized = 1; +} + +STATIC U32 indirect_booted = 0; + /* --- XS ------------------------------------------------------------------ */ MODULE = indirect PACKAGE = indirect @@ -634,35 +877,17 @@ PROTOTYPES: ENABLE BOOT: { - if (!indirect_initialized++) { + if (!indirect_booted++) { 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.owner = aTHX; -#endif - PERL_HASH(indirect_hash, __PACKAGE__, __PACKAGE_LEN__); - 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); - stash = gv_stashpvn(__PACKAGE__, __PACKAGE_LEN__, 1); newCONSTSUB(stash, "I_THREADSAFE", newSVuv(I_THREADSAFE)); + newCONSTSUB(stash, "I_FORKSAFE", newSVuv(I_FORKSAFE)); } + + indirect_setup(); } #if I_THREADSAFE @@ -672,8 +897,7 @@ CLONE(...) PROTOTYPE: DISABLE PREINIT: ptable *t; - int *level; -CODE: +PPCODE: { my_cxt_t ud; dMY_CXT; @@ -683,18 +907,12 @@ CODE: } { MY_CXT_CLONE; - MY_CXT.map = ptable_new(); - MY_CXT.linestr = NULL; - MY_CXT.tbl = t; - MY_CXT.owner = aTHX; - } - { - level = PerlMemShared_malloc(sizeof *level); - *level = 1; - LEAVE; - SAVEDESTRUCTOR_X(indirect_thread_cleanup, level); - ENTER; + MY_CXT.map = ptable_new(); + MY_CXT.tbl = t; + MY_CXT.owner = aTHX; } + reap(3, indirect_thread_cleanup, NULL); + XSRETURN(0); #endif