X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2Findirect.git;a=blobdiff_plain;f=indirect.xs;h=ec570d7fec22ce58d4a4a2f404a57ad66394e28e;hp=beec19f7c470035e994c7d746297862b6d539d4a;hb=0a8741013832fe465960ec1d6c7618f697f3d21e;hpb=838f008dcda56897a619afdd99f450fb62672a15 diff --git a/indirect.xs b/indirect.xs index beec19f..ec570d7 100644 --- a/indirect.xs +++ b/indirect.xs @@ -35,8 +35,12 @@ # define SvPVX_const SvPVX #endif -#ifndef SvREFCNT_inc_simple_NN -# define SvREFCNT_inc_simple_NN SvREFCNT_inc +#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 @@ -59,6 +63,14 @@ # define HvNAMELEN_get(H) strlen(HvNAME_get(H)) #endif +#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) @@ -71,6 +83,9 @@ # ifndef PL_oldbufptr # define PL_oldbufptr PL_parser->oldbufptr # endif +# ifndef PL_lex_inwhat +# define PL_lex_inwhat PL_parser->lex_inwhat +# endif #else # ifndef PL_linestr # define PL_linestr PL_Ilinestr @@ -81,6 +96,9 @@ # 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 @@ -128,6 +146,44 @@ # 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 ------------------------------------------------------------- */ /* ... Thread-safe hints ................................................... */ @@ -182,10 +238,10 @@ typedef SV indirect_hint_t; * thread cleanup. */ typedef struct { + char *buf; STRLEN pos; STRLEN size; STRLEN len; - char *buf; line_t line; } indirect_op_info_t; @@ -212,70 +268,94 @@ typedef struct { tTHX owner; #endif ptable *map; + SV *global_code; } my_cxt_t; START_MY_CXT #if 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; - - if (SvTYPE(sv) == SVt_PVHV && HvNAME_get(sv)) - stashes = newAV(); - - param.stashes = stashes; - param.flags = 0; - param.proto_perl = owner; - - dupsv = sv_dup(sv, ¶m); - - if (stashes) { - av_undef(stashes); - SvREFCNT_dec(stashes); - } - - return SvREFCNT_inc(dupsv); -} +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 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; - - if (ud->owner == aTHX) - return; + indirect_ptable_clone_ud *ud = ud_; + indirect_hint_t *h1 = ent->val; + indirect_hint_t *h2; #if I_HINT_STRUCT - h2 = PerlMemShared_malloc(sizeof *h2); - h2->code = indirect_clone(h1->code, ud->owner); + h2 = PerlMemShared_malloc(sizeof *h2); + h2->code = indirect_dup_inc(h1->code, ud); #if I_WORKAROUND_REQUIRE_PROPAGATION - h2->require_tag = PTR2IV(indirect_clone(INT2PTR(SV *, h1->require_tag), - ud->owner)); + h2->require_tag = PTR2IV(indirect_dup_inc(INT2PTR(SV *, h1->require_tag), ud)); #endif #else /* I_HINT_STRUCT */ - h2 = indirect_clone(h1, ud->owner); + h2 = indirect_dup_inc(h1, ud); #endif /* !I_HINT_STRUCT */ ptable_hints_store(ud->tbl, ent->key, h2); } -#include "reap.h" - STATIC void indirect_thread_cleanup(pTHX_ void *ud) { dMY_CXT; + SvREFCNT_dec(MY_CXT.global_code); + MY_CXT.global_code = NULL; ptable_free(MY_CXT.map); + MY_CXT.map = NULL; ptable_hints_free(MY_CXT.tbl); + MY_CXT.tbl = NULL; } +STATIC int indirect_endav_free(pTHX_ SV *sv, MAGIC *mg) { + SAVEDESTRUCTOR_X(indirect_thread_cleanup, NULL); + + return 0; +} + +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 @@ -327,13 +407,19 @@ get_enclosing_cv: STATIC SV *indirect_tag(pTHX_ SV *value) { #define indirect_tag(V) indirect_tag(aTHX_ (V)) indirect_hint_t *h; - SV *code = NULL; + SV *code = NULL; +#if I_THREADSAFE + dMY_CXT; + + if (!MY_CXT.tbl) + return newSViv(0); +#endif /* I_THREADSAFE */ if (SvROK(value)) { value = SvRV(value); if (SvTYPE(value) >= SVt_PVCV) { code = value; - SvREFCNT_inc_simple_NN(code); + SvREFCNT_inc_simple_void_NN(code); } } @@ -348,13 +434,10 @@ STATIC SV *indirect_tag(pTHX_ SV *value) { #endif /* !I_HINT_STRUCT */ #if I_THREADSAFE - { - dMY_CXT; - /* 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); - } + /* 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)); @@ -363,21 +446,23 @@ STATIC SV *indirect_tag(pTHX_ SV *value) { 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 (!(hint && SvIOK(hint))) +#if I_THREADSAFE + if (!MY_CXT.tbl) return NULL; +#endif /* I_THREADSAFE */ h = INT2PTR(indirect_hint_t *, SvIVX(hint)); #if I_THREADSAFE - { - dMY_CXT; - h = ptable_fetch(MY_CXT.tbl, h); - } + h = ptable_fetch(MY_CXT.tbl, h); #endif /* I_THREADSAFE */ #if I_WORKAROUND_REQUIRE_PROPAGATION if (indirect_require_tag() != h->require_tag) - return NULL; + return MY_CXT.global_code; #endif /* I_WORKAROUND_REQUIRE_PROPAGATION */ return I_HINT_CODE(h); @@ -387,11 +472,16 @@ STATIC U32 indirect_hash = 0; STATIC SV *indirect_hint(pTHX) { #define indirect_hint() indirect_hint(aTHX) - SV *hint; + 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); @@ -404,13 +494,17 @@ STATIC SV *indirect_hint(pTHX) { #else { SV **val = hv_fetch(GvHV(PL_hintgv), __PACKAGE__, __PACKAGE_LEN__, 0); - if (!val) - return 0; - hint = *val; + if (val) + hint = *val; } #endif - return indirect_detag(hint); + if (hint && SvIOK(hint)) + return indirect_detag(hint); + else { + dMY_CXT; + return MY_CXT.global_code; + } } /* ... op -> source position ............................................... */ @@ -422,6 +516,9 @@ STATIC void indirect_map_store(pTHX_ const OP *o, STRLEN pos, SV *sv, line_t lin STRLEN len; dMY_CXT; + /* No need to check for MY_CXT.map != NULL because this code path is always + * guarded by indirect_hint(). */ + if (!(oi = ptable_fetch(MY_CXT.map, o))) { Newx(oi, 1, indirect_op_info_t); ptable_store(MY_CXT.map, o, oi); @@ -452,6 +549,9 @@ 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; + /* No need to check for MY_CXT.map != NULL because this code path is always + * guarded by indirect_hint(). */ + return ptable_fetch(MY_CXT.map, o); } @@ -459,38 +559,47 @@ STATIC void indirect_map_delete(pTHX_ const OP *o) { #define indirect_map_delete(O) indirect_map_delete(aTHX_ (O)) dMY_CXT; - ptable_delete(MY_CXT.map, o); + if (MY_CXT.map) + ptable_delete(MY_CXT.map, o); } /* --- Check functions ----------------------------------------------------- */ -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, *r = SvPV_const(sv, len); - - if (len >= 1 && *r == '$') { - ++r; - --len; - s = strchr(s, '$'); - if (!s) +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; } + name_end = name + name_len; - p = s; + p = line_bufptr; while (1) { - p = strstr(p, r); + p = ninstr(p, line_end, name, name_end); if (!p) return 0; - if (!isALNUM(p[len])) + if (!isALNUM(p[name_len])) break; - /* p points to a word that has r as prefix, skip the rest of the word */ - p += len + 1; + /* p points to a word that has name as prefix, skip the rest of the word */ + p += name_len + 1; while (isALNUM(*p)) ++p; } - *pos = p - SvPVX_const(PL_linestr); + *name_pos = p - line; return 1; } @@ -509,6 +618,26 @@ STATIC OP *indirect_ck_const(pTHX_ OP *o) { 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; } @@ -736,7 +865,7 @@ 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) @@ -769,7 +898,8 @@ STATIC OP *indirect_ck_entersub(pTHX_ OP *o) { /* 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) { + if ( moi->line < ooi->line + || (moi->line == ooi->line && moi->pos <= ooi->pos)) { SV *file; dSP; @@ -817,28 +947,22 @@ STATIC void indirect_teardown(pTHX_ void *root) { { dMY_CXT; ptable_free(MY_CXT.map); + MY_CXT.map = NULL; #if I_THREADSAFE ptable_hints_free(MY_CXT.tbl); + MY_CXT.tbl = NULL; #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_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; } @@ -851,29 +975,25 @@ STATIC void indirect_setup(pTHX) { { MY_CXT_INIT; #if I_THREADSAFE - MY_CXT.tbl = ptable_new(); - MY_CXT.owner = aTHX; + MY_CXT.tbl = ptable_new(); + MY_CXT.owner = aTHX; #endif - MY_CXT.map = ptable_new(); + MY_CXT.map = ptable_new(); + MY_CXT.global_code = NULL; } - 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); + 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_teardown, aTHX); @@ -914,21 +1034,42 @@ CLONE(...) PROTOTYPE: DISABLE PREINIT: ptable *t; + 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.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; + } + 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); } - reap(3, indirect_thread_cleanup, NULL); + XSRETURN(0); + +void +_THREAD_CLEANUP(...) +PROTOTYPE: DISABLE +PPCODE: + indirect_thread_cleanup(aTHX_ NULL); XSRETURN(0); #endif @@ -940,3 +1081,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);