From: Vincent Pit Date: Sat, 7 Mar 2009 00:49:24 +0000 (+0100) Subject: Use a pointer table allocated on shared memory X-Git-Tag: v0.04~9 X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FLexical-Types.git;a=commitdiff_plain;h=311cc872692b73075296805143f6a2d8c4074254 Use a pointer table allocated on shared memory --- diff --git a/MANIFEST b/MANIFEST index 17dfcba..89831d7 100644 --- a/MANIFEST +++ b/MANIFEST @@ -5,6 +5,7 @@ Makefile.PL README Types.xs lib/Lexical/Types.pm +ptable.h samples/basic.pl t/00-load.t t/10-base.t diff --git a/Types.xs b/Types.xs index 8895acb..a6df2b9 100644 --- a/Types.xs +++ b/Types.xs @@ -61,10 +61,11 @@ STATIC SV *lt_hint(pTHX) { /* ... op => info map ...................................................... */ -#define OP2STR_BUF char buf[(CHAR_BIT * sizeof(UV)) / 2] -#define OP2STR(O) (sprintf(buf, "%"UVxf, PTR2UV(O))) +#define PTABLE_VAL_FREE(V) PerlMemShared_free(V) -STATIC HV *lt_op_map = NULL; +#include "ptable.h" + +STATIC ptable *lt_op_map = NULL; typedef struct { SV *orig_pkg; @@ -73,30 +74,26 @@ typedef struct { OP *(*pp_padsv)(pTHX); } lt_op_info; -STATIC void lt_map_store(pTHX_ const OP *o, SV *orig_pkg, SV *type_pkg, SV *type_meth, OP *(*pp_padsv)(pTHX)) { -#define lt_map_store(O, P1, P2, M, PP) lt_map_store(aTHX_ (O), (P1), (P2), (M), (PP)) - OP2STR_BUF; - SV *val; - lt_op_info *oi; +STATIC void lt_map_store(const OP *o, SV *orig_pkg, SV *type_pkg, SV *type_meth, OP *(*pp_padsv)(pTHX)) { + lt_op_info *oi = ptable_fetch(lt_op_map, o); + + if (!oi) { + oi = PerlMemShared_malloc(sizeof *oi); + ptable_store(lt_op_map, o, oi); + } - Newx(oi, 1, lt_op_info); oi->orig_pkg = orig_pkg; oi->type_pkg = type_pkg; oi->type_meth = type_meth; oi->pp_padsv = pp_padsv; - val = newSVuv(PTR2UV(oi)); - - (void)hv_store(lt_op_map, buf, OP2STR(o), val, 0); } -STATIC const lt_op_info *lt_map_fetch(pTHX_ const OP *o) { -#define lt_map_fetch(O) lt_map_fetch(aTHX_ (O)) - OP2STR_BUF; - SV **svp; +STATIC const lt_op_info *lt_map_fetch(const OP *o) { + const lt_op_info *oi; - svp = hv_fetch(lt_op_map, buf, OP2STR(o), 0); + oi = ptable_fetch(lt_op_map, o); - return svp ? INT2PTR(const lt_op_info *, SvUVX(*svp)) : NULL; + return oi; } /* --- Hooks --------------------------------------------------------------- */ @@ -281,11 +278,12 @@ PROTOTYPES: DISABLE BOOT: { if (!lt_initialized++) { + lt_op_map = ptable_new(); + lt_default_meth = newSVpvn("TYPEDSCALAR", 11); SvREADONLY_on(lt_default_meth); PERL_HASH(lt_hash, __PACKAGE__, __PACKAGE_LEN__); - lt_op_map = newHV(); lt_old_ck_padany = PL_check[OP_PADANY]; PL_check[OP_PADANY] = MEMBER_TO_FPTR(lt_ck_padany); diff --git a/ptable.h b/ptable.h new file mode 100644 index 0000000..70d1b88 --- /dev/null +++ b/ptable.h @@ -0,0 +1,126 @@ +typedef struct ptable_ent { + struct ptable_ent *next; + const void * key; + void * val; +} ptable_ent; + +typedef struct ptable { + ptable_ent **ary; + UV max; + UV items; +} ptable; + +#ifndef PTABLE_VAL_FREE +# define PTABLE_VAL_FREE(V) +#endif + +STATIC ptable *ptable_new(void) { + ptable *t = PerlMemShared_malloc(sizeof *t); + t->max = 127; + t->items = 0; + t->ary = PerlMemShared_calloc(t->max + 1, sizeof *t->ary); + return t; +} + +#define PTABLE_HASH(ptr) \ + ((PTR2UV(ptr) >> 3) ^ (PTR2UV(ptr) >> (3 + 7)) ^ (PTR2UV(ptr) >> (3 + 17))) + +STATIC ptable_ent *ptable_find(const ptable * const t, const void * const key) { + 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; +} + +STATIC void *ptable_fetch(const ptable * const t, const void * const key) { + const ptable_ent *const ent = ptable_find(t, key); + + return ent ? ent->val : NULL; +} + +STATIC void ptable_split(ptable * const 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; + } + } +} + +STATIC void ptable_store(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 { + 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); + } +} + +#if 0 + +STATIC void ptable_clear(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(entry); + } + array[i] = NULL; + } while (i--); + + t->items = 0; + } +} + +STATIC void ptable_free(ptable * const t) { + if (!t) + return; + ptable_clear(t); + PerlMemShared_free(t->ary); + PerlMemShared_free(t); +} + +#endif diff --git a/t/13-padsv.t b/t/13-padsv.t index 5e5cc3d..ae3cbff 100644 --- a/t/13-padsv.t +++ b/t/13-padsv.t @@ -3,6 +3,8 @@ use strict; use warnings; +use Config qw/%Config/; + use Test::More tests => 4; sub Str::TYPEDSCALAR { @@ -30,7 +32,10 @@ my @lines; sub Int::TYPEDSCALAR { push @lines, (caller(0))[2]; () } -{ +SKIP: { + skip 'Broken with threaded perls before 5.8.4' => 1 + if $Config{useithreads} and $] < 5.008004; + use Lexical::Types as => sub { # In 5.10, this closure is compiled before hints are enabled, so no hintseval # op is added at compile time to propagate the hints inside the eval. diff --git a/t/30-threads.t b/t/30-threads.t index 32bdf80..5c4b8d1 100644 --- a/t/30-threads.t +++ b/t/30-threads.t @@ -15,15 +15,17 @@ BEGIN { use threads; -use Test::More tests => 10 * 2 * (1 + 2); +use Test::More tests => 10 * 2 * 2 * (1 + 2); { package Lexical::Types::Test::Tag; sub TYPEDSCALAR { my $tid = threads->tid(); - Test::More::is($_[0], __PACKAGE__, "base type is correct in thread $tid"); - Test::More::is($_[2], 'Tag', "original type is correct in thread $tid"); + my ($file, $line) = (caller(0))[1, 2]; + my $where = "at $file line $line in thread $tid"; + Test::More::is($_[0], __PACKAGE__, "base type is correct $where"); + Test::More::is($_[2], 'Tag', "original type is correct $where"); $_[1] = $tid; (); } @@ -34,10 +36,18 @@ use Test::More tests => 10 * 2 * (1 + 2); use Lexical::Types as => 'Lexical::Types::Test::'; sub try { + my $tid = threads->tid(); + for (1 .. 2) { my Tag $t; - my $tid = threads->tid(); is $t, $tid, "typed lexical correctly initialized at run $_ in thread $tid"; + + eval <<'EVALD'; + use Lexical::Types as => "Lexical::Types::Test::"; + my Tag $t2; + is $t2, $tid, "typed lexical correctly initialized in eval at run $_ in thread $tid"; +EVALD + diag $@ if $@; } }