From: Vincent Pit Date: Fri, 28 Aug 2009 20:13:51 +0000 (+0200) Subject: Port to ptable-based thread-safe hints X-Git-Tag: v0.08~13 X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2Fre-engine-Plugin.git;a=commitdiff_plain;h=990ba6fd714681b2a6d50ac5153d654bfea0ccdd Port to ptable-based thread-safe hints This also works around the pre-5.10.1 require propagation bug, which was causing the callback in t/methods/str/undef.t to be fired three times. --- diff --git a/MANIFEST b/MANIFEST index 1661be7..12e38e6 100644 --- a/MANIFEST +++ b/MANIFEST @@ -8,6 +8,7 @@ Plugin.pm Plugin.pod Plugin.xs README +ptable.h t/00-compile.t t/eval-comp.t t/eval-exec.t diff --git a/Plugin.pm b/Plugin.pm index b67bdc1..ef2dbae 100644 --- a/Plugin.pm +++ b/Plugin.pm @@ -15,16 +15,6 @@ BEGIN { my $RE_ENGINE_PLUGIN = ENGINE(); -# How many? Used to cheat %^H -my $callback = 1; - -# Where we store our CODE refs -my %callback; - -# Generate a key to use in the %^H hash from a string, prefix the -# package name like L does -my $key = sub { __PACKAGE__ . "::" . $_[0] }; - sub import { my ($pkg, %sub) = @_; @@ -34,25 +24,20 @@ sub import for (@callback) { next unless exists $sub{$_}; - my $cb = delete $sub{$_}; + my $cb = $sub{$_}; unless (ref $cb eq 'CODE') { require Carp; Carp::croak("'$_' is not CODE"); } + } - # Get an ID to use - my $id = $callback ++; - - # Insert into our callback storage, - $callback{$_}->{$id} = $cb; + $^H |= 0x020000; - # Instert into our cache with a key we can retrive later - # knowing the ID in %^H and what callback we're getting - $^H{ $key->($_) } = $id; - } + $^H{+(__PACKAGE__)} = _tag(@sub{@callback}); + $^H{regcomp} = $RE_ENGINE_PLUGIN; - $^H{regcomp} = $RE_ENGINE_PLUGIN; + return; } sub unimport @@ -60,20 +45,10 @@ sub unimport # Delete the regcomp hook delete $^H{regcomp} if $^H{regcomp} == $RE_ENGINE_PLUGIN; -} - -# Minimal function to get CODE for a given key to be called by the -# get_H_callback C function. -sub _get_callback -{ - my ($name) = @_; # 'comp', 'exec', ... - - my $h = (caller(0))[10]; - my $id = $h->{ $key->($name) }; - my $cb = defined $id ? $callback{$name}->{$id} : 0; + delete $^H{+(__PACKAGE__)}; - return $cb; + return; } sub num_captures diff --git a/Plugin.xs b/Plugin.xs index 544fab8..483d294 100644 --- a/Plugin.xs +++ b/Plugin.xs @@ -1,41 +1,256 @@ #include "EXTERN.h" #include "perl.h" #include "XSUB.h" + #include "Plugin.h" -SV* -get_H_callback(const char* key) -{ - dVAR; - dSP; +#define __PACKAGE__ "re::engine::Plugin" +#define __PACKAGE_LEN__ (sizeof(__PACKAGE__)-1) - SV * callback; +#define REP_HAS_PERL(R, V, S) (PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S)))))) - ENTER; - SAVETMPS; - - PUSHMARK(SP); - XPUSHs(sv_2mortal(newSVpv(key, 0))); - PUTBACK; +#ifndef REP_WORKAROUND_REQUIRE_PROPAGATION +# define REP_WORKAROUND_REQUIRE_PROPAGATION !REP_HAS_PERL(5, 10, 1) +#endif - call_pv("re::engine::Plugin::_get_callback", G_SCALAR); +/* ... Thread safety and multiplicity ...................................... */ - SPAGAIN; +#ifndef REP_MULTIPLICITY +# if defined(MULTIPLICITY) || defined(PERL_IMPLICIT_CONTEXT) +# define REP_MULTIPLICITY 1 +# else +# define REP_MULTIPLICITY 0 +# endif +#endif +#if REP_MULTIPLICITY && !defined(tTHX) +# define tTHX PerlInterpreter* +#endif - callback = POPs; - SvREFCNT_inc(callback); /* refcount++ or FREETMPS below will collect us */ +#if REP_MULTIPLICITY && defined(USE_ITHREADS) && defined(dMY_CXT) && defined(MY_CXT) && defined(START_MY_CXT) && defined(MY_CXT_INIT) && (defined(MY_CXT_CLONE) || defined(dMY_CXT_SV)) +# define REP_THREADSAFE 1 +# ifndef MY_CXT_CLONE +# define MY_CXT_CLONE \ + dMY_CXT_SV; \ + my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1)); \ + Copy(INT2PTR(my_cxt_t*, SvUV(my_cxt_sv)), my_cxtp, 1, my_cxt_t); \ + sv_setuv(my_cxt_sv, PTR2UV(my_cxtp)) +# endif +#else +# define REP_THREADSAFE 0 +# undef dMY_CXT +# define dMY_CXT dNOOP +# undef MY_CXT +# define MY_CXT rep_globaldata +# undef START_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 we don't get a valid CODE value return a NULL callback, in - * that case the hooks won't call back into Perl space */ - if (!SvROK(callback) || SvTYPE(SvRV(callback)) != SVt_PVCV) { - callback = NULL; - } +/* --- Helpers ------------------------------------------------------------- */ + +/* ... Thread-safe hints ................................................... */ - PUTBACK; - FREETMPS; - LEAVE; +typedef struct { + SV *comp; + SV *exec; +#if REP_WORKAROUND_REQUIRE_PROPAGATION + I32 requires; +#endif +} rep_hint_t; - return callback; +#if REP_THREADSAFE + +#define PTABLE_VAL_FREE(V) { \ + rep_hint_t *h = (V); \ + SvREFCNT_dec(h->comp); \ + SvREFCNT_dec(h->exec); \ + PerlMemShared_free(h); \ +} + +#define pPTBL pTHX +#define pPTBL_ pTHX_ +#define aPTBL aTHX +#define aPTBL_ aTHX_ + +#include "ptable.h" + +#define ptable_store(T, K, V) ptable_store(aTHX_ (T), (K), (V)) +#define ptable_free(T) ptable_free(aTHX_ (T)) + +#define MY_CXT_KEY __PACKAGE__ "::_guts" XS_VERSION + +typedef struct { + ptable *tbl; + tTHX owner; +} my_cxt_t; + +START_MY_CXT + +STATIC SV *rep_clone(pTHX_ SV *sv, tTHX owner) { +#define rep_clone(S, O) rep_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); +} + +STATIC void rep_ptable_clone(pTHX_ ptable_ent *ent, void *ud_) { + my_cxt_t *ud = ud_; + rep_hint_t *h1 = ent->val; + rep_hint_t *h2; + + if (ud->owner == aTHX) + return; + + h2 = PerlMemShared_malloc(sizeof *h2); + h2->comp = rep_clone(h1->comp, ud->owner); + SvREFCNT_inc(h2->comp); + h2->exec = rep_clone(h1->exec, ud->owner); + SvREFCNT_inc(h2->exec); +#if REP_WORKAROUND_REQUIRE_PROPAGATION + h2->requires = h1->requires; +#endif + + ptable_store(ud->tbl, ent->key, h2); +} + +STATIC void rep_thread_cleanup(pTHX_ void *); + +STATIC void rep_thread_cleanup(pTHX_ void *ud) { + int *level = ud; + + if (*level) { + *level = 0; + LEAVE; + SAVEDESTRUCTOR_X(rep_thread_cleanup, level); + ENTER; + } else { + dMY_CXT; + PerlMemShared_free(level); + ptable_free(MY_CXT.tbl); + } +} + +#endif /* REP_THREADSAFE */ + +STATIC SV *rep_validate_callback(SV *code) { + if (!SvROK(code)) + return NULL; + + code = SvRV(code); + if (SvTYPE(code) < SVt_PVCV) + return NULL; + + return SvREFCNT_inc_simple_NN(code); +} + +STATIC SV *rep_tag(pTHX_ SV *comp, SV *exec) { +#define rep_tag(C, E) rep_tag(aTHX_ (C), (E)) + rep_hint_t *h; + dMY_CXT; + + h = PerlMemShared_malloc(sizeof *h); + + h->comp = rep_validate_callback(comp); + h->exec = rep_validate_callback(exec); + +#if REP_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 + +#if REP_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_store(MY_CXT.tbl, h, h); +#endif /* REP_THREADSAFE */ + + return newSViv(PTR2IV(h)); +} + +STATIC const rep_hint_t *rep_detag(pTHX_ const SV *hint) { +#define rep_detag(H) rep_detag(aTHX_ (H)) + rep_hint_t *h; + dMY_CXT; + + if (!(hint && SvIOK(hint))) + return NULL; + + h = INT2PTR(rep_hint_t *, SvIVX(hint)); +#if REP_THREADSAFE + h = ptable_fetch(MY_CXT.tbl, h); +#endif /* REP_THREADSAFE */ + +#if REP_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) + return NULL; + } + } + } +#endif + + return h; +} + +STATIC U32 rep_hash = 0; + +STATIC const rep_hint_t *rep_hint(pTHX) { +#define rep_hint() rep_hint(aTHX) + SV *hint; + + /* We already require 5.9.5 for the regexp engine API. */ + hint = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, + NULL, + __PACKAGE__, __PACKAGE_LEN__, + 0, + rep_hash); + + return rep_detag(hint); } REGEXP * @@ -48,8 +263,9 @@ Plugin_comp(pTHX_ SV * const pattern, U32 flags) dSP; struct regexp * rx; REGEXP *RX; - re__engine__Plugin re; I32 buffers; + re__engine__Plugin re; + const rep_hint_t *h; /* exp/xend version of the pattern & length */ STRLEN plen; @@ -96,9 +312,8 @@ Plugin_comp(pTHX_ SV * const pattern, U32 flags) * already set up all the stuff we're going to to need for * subsequent exec and other calls */ - SV * callback = get_H_callback("comp"); - - if (callback) { + h = rep_hint(); + if (h && h->comp) { ENTER; SAVETMPS; @@ -106,7 +321,7 @@ Plugin_comp(pTHX_ SV * const pattern, U32 flags) XPUSHs(obj); PUTBACK; - call_sv(callback, G_DISCARD); + call_sv(h->comp, G_DISCARD); FREETMPS; LEAVE; @@ -129,11 +344,12 @@ Plugin_exec(pTHX_ REGEXP * const RX, char *stringarg, char *strend, { dSP; I32 matched; - SV * callback = get_H_callback("exec"); struct regexp *rx = rxREGEXP(RX); + const rep_hint_t *h; GET_SELF_FROM_PPRIVATE(rx->pprivate); - if (callback) { + h = rep_hint(); + if (h && h->exec) { /* Store the current str for ->str */ self->str = (SV*)sv; SvREFCNT_inc(self->str); @@ -146,7 +362,7 @@ Plugin_exec(pTHX_ REGEXP * const RX, char *stringarg, char *strend, XPUSHs(sv); PUTBACK; - call_sv(callback, G_SCALAR); + call_sv(h->exec, G_SCALAR); SPAGAIN; @@ -353,9 +569,81 @@ Plugin_package(pTHX_ REGEXP * const RX) return newSVpvs("re::engine::Plugin"); } +#if REP_THREADSAFE + +STATIC U32 rep_initialized = 0; + +STATIC void rep_teardown(pTHX_ void *root) { + dMY_CXT; + + if (!rep_initialized || aTHX != root) + return; + + ptable_free(MY_CXT.tbl); + + rep_initialized = 0; +} + +STATIC void rep_setup(pTHX) { +#define rep_setup() rep_setup(aTHX) + if (rep_initialized) + return; + + MY_CXT_INIT; + MY_CXT.tbl = ptable_new(); + MY_CXT.owner = aTHX; + + call_atexit(rep_teardown, aTHX); + + rep_initialized = 1; +} + +#else /* REP_THREADSAFE */ + +#define rep_setup() + +#endif /* !REP_THREADSAFE */ + +STATIC U32 rep_booted = 0; + +/* --- XS ------------------------------------------------------------------ */ + MODULE = re::engine::Plugin PACKAGE = re::engine::Plugin + PROTOTYPES: DISABLE +BOOT: +{ + if (!rep_booted++) { + PERL_HASH(rep_hash, __PACKAGE__, __PACKAGE_LEN__); + } + + rep_setup(); +} + +#if REP_THREADSAFE + +void +CLONE(...) +PREINIT: + ptable *t; + int *level; +CODE: + { + my_cxt_t ud; + dMY_CXT; + ud.tbl = t = ptable_new(); + ud.owner = MY_CXT.owner; + ptable_walk(MY_CXT.tbl, rep_ptable_clone, &ud); + } + { + MY_CXT_CLONE; + MY_CXT.tbl = t; + MY_CXT.owner = aTHX; + } + +#endif + void pattern(re::engine::Plugin self, ...) PPCODE: @@ -476,6 +764,13 @@ PPCODE: SvREFCNT_inc(self->cb_num_capture_buff_LENGTH); } +SV * +_tag(SV *comp, SV *exec) +CODE: + RETVAL = rep_tag(comp, exec); +OUTPUT: + RETVAL + void ENGINE() PPCODE: diff --git a/ptable.h b/ptable.h new file mode 100644 index 0000000..6e24698 --- /dev/null +++ b/ptable.h @@ -0,0 +1,221 @@ +/* This file is part of the re::engine::Plugin Perl module. + * See http://search.cpan.org/dist/re-engine-Plugin/ */ + +/* This is a pointer table implementation essentially copied from the ptr_table + * implementation in perl's sv.c, except that it has been modified to use memory + * shared across threads. + * Copyright goes to the original authors, bug reports to me. */ + +/* This header is designed to be included several times with different + * definitions for PTABLE_NAME and PTABLE_VAL_FREE(). */ + +#undef pPTBLMS +#undef pPTBLMS_ +#undef aPTBLMS +#undef aPTBLMS_ + +/* Context for PerlMemShared_* functions */ + +#ifdef PERL_IMPLICIT_SYS +# define pPTBLMS pTHX +# define pPTBLMS_ pTHX_ +# define aPTBLMS aTHX +# define aPTBLMS_ aTHX_ +#else +# define pPTBLMS +# define pPTBLMS_ +# define aPTBLMS +# define aPTBLMS_ +#endif + +#ifndef pPTBL +# define pPTBL pPTBLMS +#endif +#ifndef pPTBL_ +# define pPTBL_ pPTBLMS_ +#endif +#ifndef aPTBL +# define aPTBL aPTBLMS +#endif +#ifndef aPTBL_ +# define aPTBL_ aPTBLMS_ +#endif + +#ifndef PTABLE_NAME +# define PTABLE_NAME ptable +#endif + +#ifndef PTABLE_VAL_FREE +# define PTABLE_VAL_FREE(V) +#endif + +#ifndef PTABLE_JOIN +# define PTABLE_PASTE(A, B) A ## B +# define PTABLE_JOIN(A, B) PTABLE_PASTE(A, B) +#endif + +#ifndef PTABLE_PREFIX +# define PTABLE_PREFIX(X) PTABLE_JOIN(PTABLE_NAME, X) +#endif + +#ifndef ptable_ent +typedef struct ptable_ent { + struct ptable_ent *next; + const void * key; + void * val; +} ptable_ent; +#define ptable_ent ptable_ent +#endif /* !ptable_ent */ + +#ifndef ptable +typedef struct ptable { + ptable_ent **ary; + UV max; + UV items; +} ptable; +#define ptable ptable +#endif /* !ptable */ + +#ifndef ptable_new +STATIC ptable *ptable_new(pPTBLMS) { +#define ptable_new() ptable_new(aPTBLMS) + ptable *t = PerlMemShared_malloc(sizeof *t); + t->max = 15; + t->items = 0; + t->ary = PerlMemShared_calloc(t->max + 1, sizeof *t->ary); + return t; +} +#endif /* !ptable_new */ + +#ifndef PTABLE_HASH +# define PTABLE_HASH(ptr) \ + ((PTR2UV(ptr) >> 3) ^ (PTR2UV(ptr) >> (3 + 7)) ^ (PTR2UV(ptr) >> (3 + 17))) +#endif + +#ifndef ptable_find +STATIC ptable_ent *ptable_find(const ptable * const t, const void * const key) { +#define ptable_find ptable_find + ptable_ent *ent; + const UV hash = PTABLE_HASH(key); + + ent = t->ary[hash & t->max]; + for (; ent; ent = ent->next) { + if (ent->key == key) + return ent; + } + + return NULL; +} +#endif /* !ptable_find */ + +#ifndef ptable_fetch +STATIC void *ptable_fetch(const ptable * const t, const void * const key) { +#define ptable_fetch ptable_fetch + const ptable_ent *const ent = ptable_find(t, key); + + return ent ? ent->val : NULL; +} +#endif /* !ptable_fetch */ + +#ifndef ptable_split +STATIC void ptable_split(pPTBLMS_ ptable * const t) { +#define ptable_split(T) ptable_split(aPTBLMS_ (T)) + ptable_ent **ary = t->ary; + const UV oldsize = t->max + 1; + UV newsize = oldsize * 2; + UV i; + + ary = PerlMemShared_realloc(ary, newsize * sizeof(*ary)); + Zero(&ary[oldsize], newsize - oldsize, sizeof(*ary)); + t->max = --newsize; + t->ary = ary; + + for (i = 0; i < oldsize; i++, ary++) { + ptable_ent **curentp, **entp, *ent; + if (!*ary) + continue; + curentp = ary + oldsize; + for (entp = ary, ent = *ary; ent; ent = *entp) { + if ((newsize & PTABLE_HASH(ent->key)) != i) { + *entp = ent->next; + ent->next = *curentp; + *curentp = ent; + continue; + } else + entp = &ent->next; + } + } +} +#endif /* !ptable_split */ + +STATIC void PTABLE_PREFIX(_store)(pPTBL_ ptable * const t, const void * const key, void * const val) { + ptable_ent *ent = ptable_find(t, key); + + if (ent) { + void *oldval = ent->val; + PTABLE_VAL_FREE(oldval); + ent->val = val; + } else if (val) { + const UV i = PTABLE_HASH(key) & t->max; + ent = PerlMemShared_malloc(sizeof *ent); + ent->key = key; + ent->val = val; + ent->next = t->ary[i]; + t->ary[i] = ent; + t->items++; + if (ent->next && t->items > t->max) + ptable_split(t); + } +} + +#ifndef ptable_walk +STATIC void ptable_walk(pTHX_ ptable * const t, void (*cb)(pTHX_ ptable_ent *ent, void *userdata), void *userdata) { +#define ptable_walk(T, CB, UD) ptable_walk(aTHX_ (T), (CB), (UD)) + if (t && t->items) { + register ptable_ent ** const array = t->ary; + UV i = t->max; + do { + ptable_ent *entry; + for (entry = array[i]; entry; entry = entry->next) + cb(aTHX_ entry, userdata); + } while (i--); + } +} +#endif /* !ptable_walk */ + +STATIC void PTABLE_PREFIX(_clear)(pPTBL_ ptable * const t) { + if (t && t->items) { + register ptable_ent ** const array = t->ary; + UV i = t->max; + + do { + ptable_ent *entry = array[i]; + while (entry) { + ptable_ent * const oentry = entry; + void *val = oentry->val; + entry = entry->next; + PTABLE_VAL_FREE(val); + PerlMemShared_free(oentry); + } + array[i] = NULL; + } while (i--); + + t->items = 0; + } +} + +STATIC void PTABLE_PREFIX(_free)(pPTBL_ ptable * const t) { + if (!t) + return; + PTABLE_PREFIX(_clear)(aPTBL_ t); + PerlMemShared_free(t->ary); + PerlMemShared_free(t); +} + +#undef pPTBL +#undef pPTBL_ +#undef aPTBL +#undef aPTBL_ + +#undef PTABLE_NAME +#undef PTABLE_VAL_FREE diff --git a/t/methods/str/undef.t b/t/methods/str/undef.t index fe6500a..42ee8bf 100644 --- a/t/methods/str/undef.t +++ b/t/methods/str/undef.t @@ -1,5 +1,5 @@ use strict; -use Test::More tests => ($] <= 5.010 ? 3 : 1); +use Test::More tests => 1; use re::engine::Plugin ( comp => sub { my ($re, $str) = @_;