From: Vincent Pit Date: Sat, 2 Jan 2010 00:10:03 +0000 (+0100) Subject: Store the custom op name in a pointer table X-Git-Tag: v0.01~14 X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FSub-Op.git;a=commitdiff_plain;h=61188a20996808b5a4ad19cc35d272ff7d83b8f1 Store the custom op name in a pointer table We can't use the PL_custom_op_names hash because its keys are the ppaddr functions and two keywords can share the same pp implementation. --- diff --git a/MANIFEST b/MANIFEST index bd44863..8f9a604 100644 --- a/MANIFEST +++ b/MANIFEST @@ -6,6 +6,7 @@ Op.xs README configure_test.pl lib/Sub/Op.pm +ptable.h sub_op.h samples/try.pl t/10-base.t diff --git a/Op.xs b/Op.xs index b1ecdb4..fe67d08 100644 --- a/Op.xs +++ b/Op.xs @@ -92,6 +92,25 @@ STATIC SV *so_clone(pTHX_ SV *sv, tTHX owner) { #endif /* SO_THREADSAFE */ +#define PTABLE_NAME ptable +#define PTABLE_VAL_FREE(V) PerlMemShared_free(V) + +#include "ptable.h" + +/* PerlMemShared_free() needs the [ap]PTBLMS_? default values */ +#define ptable_store(T, K, V) ptable_store(aPTBLMS_ (T), (K), (V)) + +STATIC ptable *sub_op_name = NULL; + +#ifdef USE_ITHREADS +STATIC perl_mutex sub_op_name_mutex; +#endif + +typedef struct { + STRLEN len; + char buf; +} sub_op_name_t; + /* --- Public API ---------------------------------------------------------- */ #include "sub_op.h" @@ -255,6 +274,20 @@ STATIC OP *sub_op_ck_entersub(pTHX_ OP *o) { } sub_op_linklist(o); + + { + sub_op_name_t *on = PerlMemShared_malloc(sizeof(*on) + len); + Copy(name, &on->buf, len, char); + (&on->buf)[len] = '\0'; + on->len = len; +#ifdef USE_ITHREADS + MUTEX_LOCK(&sub_op_name_mutex); +#endif /* USE_ITHREADS */ + ptable_store(sub_op_name, o, on); +#ifdef USE_ITHREADS + MUTEX_UNLOCK(&sub_op_name_mutex); +#endif /* USE_ITHREADS */ + } } } @@ -309,6 +342,11 @@ PROTOTYPES: ENABLE BOOT: { + sub_op_name = ptable_new(); +#ifdef USE_ITHREADS + MUTEX_INIT(&sub_op_name_mutex); +#endif + MY_CXT_INIT; MY_CXT.map = newHV(); MY_CXT.next_pkg = newAV(); @@ -370,18 +408,21 @@ _custom_name(SV *op) PROTOTYPE: $ PREINIT: OP *o; - SV *key; - HE *he; + sub_op_name_t *on; PPCODE: if (!SvROK(op)) XSRETURN_UNDEF; o = INT2PTR(OP *, SvIV(SvRV(op))); if (!o || o->op_type != OP_CUSTOM) XSRETURN_UNDEF; - key = newSViv(PTR2IV(o->op_ppaddr)); - he = hv_fetch_ent(PL_custom_op_names, key, 0, 0); - SvREFCNT_dec(key); - if (!he) +#ifdef USE_ITHREADS + MUTEX_LOCK(&sub_op_name_mutex); +#endif /* USE_ITHREADS */ + on = ptable_fetch(sub_op_name, o); +#ifdef USE_ITHREADS + MUTEX_UNLOCK(&sub_op_name_mutex); +#endif /* USE_ITHREADS */ + if (!on) XSRETURN_UNDEF; - ST(0) = sv_mortalcopy(HeVAL(he)); + ST(0) = sv_2mortal(newSVpvn(&on->buf, on->len)); XSRETURN(1); diff --git a/ptable.h b/ptable.h new file mode 100644 index 0000000..857dd53 --- /dev/null +++ b/ptable.h @@ -0,0 +1,221 @@ +/* This file is part of the Sub::Op Perl module. + * See http://search.cpan.org/dist/Sub-Op/ */ + +/* 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; + size_t max; + size_t 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 size_t oldsize = t->max + 1; + size_t newsize = oldsize * 2; + size_t 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 size_t 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; + size_t 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; + size_t 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