X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2Findirect.git;a=blobdiff_plain;f=indirect.xs;h=ec570d7fec22ce58d4a4a2f404a57ad66394e28e;hp=e1961194bf1585b083f947d0201ceaca4bfed003;hb=0a8741013832fe465960ec1d6c7618f697f3d21e;hpb=4e6baf6fb7035144cc8ae87da292f7db4e9f5713 diff --git a/indirect.xs b/indirect.xs index e196119..ec570d7 100644 --- a/indirect.xs +++ b/indirect.xs @@ -63,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) @@ -75,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 @@ -85,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 @@ -132,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 ................................................... */ @@ -223,68 +275,87 @@ 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 (!sv) - return NULL; - - 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 @@ -336,7 +407,13 @@ 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); @@ -357,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)); @@ -376,6 +450,11 @@ STATIC SV *indirect_detag(pTHX_ const SV *hint) { 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); @@ -437,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); @@ -467,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); } @@ -474,32 +559,18 @@ 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 STRLEN indirect_nextline(const char *s, STRLEN len) { - STRLEN i; - - for (i = 0; i < len; ++i) { - if (s[i] == '\n') { - ++i; - while (i < len && s[i] == '\r') - ++i; - break; - } - } - - return i; -} - 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, *t, *u; + const char *p; line = SvPV_const(PL_linestr, line_len); line_end = line + line_len; @@ -528,17 +599,7 @@ STATIC int indirect_find(pTHX_ SV *name_sv, const char *line_bufptr, STRLEN *nam ++p; } - t = line; - u = t; - while (t <= p) { - STRLEN i = indirect_nextline(t, line_len); - if (i >= line_len) - break; - u = t; - t += i; - line_len -= i; - } - *name_pos = p - u; + *name_pos = p - line; return 1; } @@ -557,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; } @@ -784,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) @@ -866,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; } @@ -907,23 +982,18 @@ STATIC void indirect_setup(pTHX) { 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); @@ -965,14 +1035,16 @@ 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_clone(MY_CXT.global_code, MY_CXT.owner); + global_code_dup = indirect_dup_inc(MY_CXT.global_code, &ud); + indirect_ptable_clone_ud_deinit(ud); } { MY_CXT_CLONE; @@ -981,7 +1053,23 @@ PPCODE: MY_CXT.owner = aTHX; MY_CXT.global_code = global_code_dup; } - reap(3, indirect_thread_cleanup, NULL); + 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