From: Nick Ing-Simmons Date: Mon, 21 Jan 2002 22:34:06 +0000 (+0000) Subject: XS side of new threads::shared designed, coded and compiles, X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=21312124121f8d9d8bc6674291e502b6a45ed0c7;p=p5sagit%2Fp5-mst-13.2.git XS side of new threads::shared designed, coded and compiles, and mostly commented but is totaly untested. submit in case anyone wants a preview. p4raw-id: //depot/perlio@14372 --- diff --git a/MANIFEST b/MANIFEST index c37345c..8868e3c 100644 --- a/MANIFEST +++ b/MANIFEST @@ -610,6 +610,7 @@ ext/threads/shared/t/hv_simple.t Tests for basic shared hash functionality. ext/threads/shared/t/no_share.t Tests for disabled share on variables. ext/threads/shared/t/sv_refs.t thread shared variables ext/threads/shared/t/sv_simple.t thread shared variables +ext/threads/shared/typemap thread::shared types ext/threads/t/basic.t ithreads ext/threads/t/stress_cv.t Test with multiple threads, coderef cv argument. ext/threads/t/stress_re.t Test with multiple threads, string cv argument and regexes. diff --git a/ext/threads/shared/shared.pm b/ext/threads/shared/shared.pm index 62cdbdd..8baa503 100644 --- a/ext/threads/shared/shared.pm +++ b/ext/threads/shared/shared.pm @@ -7,7 +7,7 @@ use Scalar::Util qw(weaken); use attributes qw(reftype); BEGIN { - if($Config{'useithreads'} && $threads::threads) { + if ($Config{'useithreads'} && $threads::threads) { *share = \&share_enabled; *cond_wait = \&cond_wait_enabled; *cond_signal = \&cond_signal_enabled; @@ -38,7 +38,7 @@ sub unlock_disabled { 1 }; sub lock_disabled { 1 } sub share_disabled { return @_} -sub share_enabled (\[$@%]) { # \] +sub share_enabled (\[$@%]) { # \] my $value = $_[0]; my $ref = reftype($value); if($ref eq 'SCALAR') { @@ -55,20 +55,6 @@ sub share_enabled (\[$@%]) { # \] } } -sub CLONE { - return unless($_[0] eq "threads::shared"); - foreach my $ptr (keys %shared) { - if($ptr) { - thrcnt_inc($shared{$ptr},$threads::origthread); - } - } -} - -sub DESTROY { - my $self = shift; - _thrcnt_dec($$self); - delete($shared{$$self}); -} package threads::shared::sv; use base 'threads::shared'; @@ -156,7 +142,7 @@ C places a lock on a variable until the lock goes out of scope. If the variable is locked by another thread, the C call will block until it's available. C is recursive, so multiple calls to C are safe--the variable will remain locked until the outermost lock on the -variable goes out of scope or C is called enough times to match +variable goes out of scope or C is called enough times to match the number of calls to . If a container object, such as a hash or array, is locked, all the elements diff --git a/ext/threads/shared/shared.xs b/ext/threads/shared/shared.xs index 876fb97..79cebfa 100644 --- a/ext/threads/shared/shared.xs +++ b/ext/threads/shared/shared.xs @@ -8,195 +8,561 @@ */ /* -* Contributed by Arthur Bergman arthur@contiller.se -* -* "Hand any two wizards a piece of rope and they would instinctively pull in -* opposite directions." -* --Sourcery -* -*/ + * + * "Hand any two wizards a piece of rope and they would instinctively pull in + * opposite directions." + * --Sourcery + * + * Contributed by Arthur Bergman arthur@contiller.se + * pulled in the (an)other direction by Nick Ing-Simmons nick@ing-simmons.net + */ #define PERL_NO_GET_CONTEXT #include "EXTERN.h" #include "perl.h" #include "XSUB.h" -PerlInterpreter *PL_sharedsv_space; /* The shared sv space */ -perl_mutex PL_sharedsv_space_mutex; /* Mutex protecting the shared sv space */ +#define SHAREDSvPTR(a) ((a)->sv) + +/* + * The shared things need an intepreter to live in ... + */ +PerlInterpreter *PL_sharedsv_space; /* The shared sv space */ +/* To access shared space we fake aTHX in this scope and thread's context */ +#define SHARED_CONTEXT PERL_SET_CONTEXT((aTHX = PL_sharedsv_space)) + +/* So we need a way to switch back to the caller's context... */ +/* So we declare _another_ copy of the aTHX variable ... */ +#define dTHXc PerlInterpreter *caller_perl = aTHX +/* and use it to switch back */ +#define CALLER_CONTEXT PERL_SET_CONTEXT((aTHX = caller_perl)) + +/* + * Only one thread at a time is allowed to mess with shared space. + */ +perl_mutex PL_sharedsv_space_mutex; /* Mutex protecting the shared sv space */ + +#define SHARED_LOCK MUTEX_LOCK(&PL_sharedsv_space_mutex) +#define SHARED_UNLOCK MUTEX_UNLOCK(&PL_sharedsv_space_mutex) + +/* A common idiom is to acquire access and switch in ... */ +#define SHARED_EDIT STMT_START { \ + SHARED_LOCK; \ + SHARED_CONTEXT; \ + } STMT_END + +/* then switch out and release access. */ +#define SHARED_RELEASE STMT_START { \ + CALLER_CONTEXT; \ + SHARED_UNLOCK; \ + } STMT_END + + +/* + + Shared SV + + Shared SV is a structure for keeping the backend storage + of shared svs. + + Shared-ness really only needs the SV * - the rest is for locks. + (Which suggests further space optimization ... ) + +*/ typedef struct { - SV *sv; /* The actual SV */ + SV *sv; /* The actual SV - in shared space */ perl_mutex mutex; /* Our mutex */ perl_cond cond; /* Our condition variable */ perl_cond user_cond; /* For user-level conditions */ IV locks; /* Number of locks held */ PerlInterpreter *owner; /* Who owns the lock? */ - U16 index; /* Update index */ } shared_sv; -#define SHAREDSvGET(a) (a->sv) -#define SHAREDSvLOCK(a) Perl_sharedsv_lock(aTHX_ a) -#define SHAREDSvUNLOCK(a) Perl_sharedsv_unlock(aTHX_ a) - -#define SHAREDSvEDIT(a) STMT_START { \ - MUTEX_LOCK(&PL_sharedsv_space_mutex); \ - SHAREDSvLOCK((a)); \ - PERL_SET_CONTEXT(PL_sharedsv_space); \ - } STMT_END - -#define SHAREDSvRELEASE(a) STMT_START { \ - PERL_SET_CONTEXT((a)->owner); \ - SHAREDSvUNLOCK((a)); \ - MUTEX_UNLOCK(&PL_sharedsv_space_mutex); \ - } STMT_END - -extern void Perl_sharedsv_init(pTHX); -extern shared_sv* Perl_sharedsv_new(pTHX); -extern shared_sv* Perl_sharedsv_find(pTHX_ SV* sv); -extern void Perl_sharedsv_lock(pTHX_ shared_sv* ssv); -extern void Perl_sharedsv_unlock(pTHX_ shared_sv* ssv); -extern void Perl_sharedsv_unlock_scope(pTHX_ shared_sv* ssv); -extern void Perl_sharedsv_thrcnt_inc(pTHX_ shared_sv* ssv); -extern void Perl_sharedsv_thrcnt_dec(pTHX_ shared_sv* ssv); +/* The SV in shared-space has a back-pointer to the shared_sv + struct associated with it PERL_MAGIC_ext. -/* - Shared SV + The vtable used has just one entry - when the SV goes away + we free the memory for the above. - Shared SV is a structure for keeping the backend storage - of shared svs. + */ -*/ +int +sharedsv_shared_mg_free(pTHX_ SV *sv, MAGIC *mg) +{ + shared_sv *shared = (shared_sv *) mg->mg_ptr; + if (shared) { + PerlMemShared_free(shared); + mg->mg_ptr = NULL; + } + return 0; +} + + +MGVTBL sharedsv_shared_vtbl = { + 0, /* get */ + 0, /* set */ + 0, /* len */ + 0, /* clear */ + sharedsv_shared_mg_free, /* free */ + 0, /* copy */ + 0, /* dup */ +}; + +/* Access to shared things is heavily based on MAGIC - in mg.h/mg.c/sv.c sense */ + +/* In any thread that has access to a shared thing there is a "proxy" + for it in its own space which has 'MAGIC' associated which accesses + the shared thing. + */ + +MGVTBL sharedsv_scalar_vtbl; /* scalars have this vtable */ +MGVTBL sharedsv_array_vtbl; /* hashes and arrays have this - like 'tie' */ +MGVTBL sharedsv_elem_vtbl; /* elements of hashes and arrays have this + _AS WELL AS_ the scalar magic */ + +/* The sharedsv_elem_vtbl associates the element with the array/hash and + the sharedsv_scalar_vtbl associates it with the value + */ + +=for apidoc sharedsv_find + +Given a private side SV tries to find if a given SV has a shared backend, +by looking for the magic. + +=cut + +shared_sv * +Perl_sharedsv_find(pTHX_ SV *sv) +{ + MAGIC *mg; + switch(SvTYPE(sv)) { + case SVt_PVAV: + case SVt_PVHV: + if ((mg = mg_find(sv, PERL_MAGIC_tied)) + && mg->mg_virtual == &sharedsv_array_vtbl) { + return (shared_sv *) mg->mg_ptr; + } + break; + default: + if ((mg = mg_find(sv, PERL_MAGIC_shared_scalar)) + && mg->mg_virtual == &sharedsv_scalar_vtbl) { + return (shared_sv *) mg->mg_ptr; + } + } + return NULL; +} /* + * Almost all the pain is in this routine. + * + */ - =head1 Shared SV Functions +shared_sv * +Perl_sharedsv_associate(pTHX_ SV **psv, SV *ssv, shared_sv *data) +{ + /* First try and get global data structure */ + dTHXc; + MAGIC *mg; + SV *sv; + if (aTHX == PL_sharedsv_space) { + croak("panic:Cannot associate from within shared space"); + } + SHARED_LOCK; - =for apidoc sharedsv_init + /* Try shared SV as 1st choice */ + if (!data && ssv) { + if (mg = mg_find(ssv, PERL_MAGIC_ext)) { + data = (shared_sv *) mg->mg_ptr; + } + } + /* Next try private SV */ + if (!data && psv && *psv) { + data = Perl_sharedsv_find(aTHX_ *psv); + } + /* If neither of those then create a new one */ + if (!data) { + data = PerlMemShared_malloc(sizeof(shared_sv)); + Zero(data,1,shared_sv); + MUTEX_INIT(&data->mutex); + COND_INIT(&data->cond); + COND_INIT(&data->user_cond); + data->owner = 0; + data->locks = 0; + } -Saves a space for keeping SVs wider than an interpreter, -currently only stores a pointer to the first interpreter. + if (!ssv) + ssv = SHAREDSvPTR(data); + + /* If we know type allocate shared side SV */ + if (psv && *psv && !ssv) { + SHARED_CONTEXT; + ssv = newSV(0); + sv_upgrade(ssv, SvTYPE(*psv)); + /* Tag shared side SV with data pointer */ + sv_magicext(ssv, ssv, PERL_MAGIC_ext, &sharedsv_shared_vtbl, + (char *)data, 0); + CALLER_CONTEXT; + } - =cut + if (!SHAREDSvPTR(data)) + SHAREDSvPTR(data) = ssv; -*/ + /* Now if requested allocate private SV */ + if (psv && !*psv && ssv) { + sv = newSV(0); + sv_upgrade(sv, SvTYPE(SHAREDSvPTR(data))); + *psv = sv; + } + + /* Finally if private SV exists check and add magic */ + if (psv && *psv) { + SV *sv = *psv; + MAGIC *mg; + switch(SvTYPE(sv)) { + case SVt_PVAV: + case SVt_PVHV: + if (!(mg = mg_find(sv, PERL_MAGIC_tied)) + || mg->mg_virtual != &sharedsv_array_vtbl) { + if (mg) + sv_unmagic(sv, PERL_MAGIC_tied); + mg = sv_magicext(sv, sv, PERL_MAGIC_tied, &sharedsv_array_vtbl, + (char *) data, 0); + mg->mg_flags |= (MGf_COPY|MGf_DUP); + } + break; + + default: + if (!(mg = mg_find(sv, PERL_MAGIC_shared_scalar)) || + mg->mg_virtual != &sharedsv_scalar_vtbl) { + if (mg) + sv_unmagic(sv, PERL_MAGIC_shared_scalar); + mg = sv_magicext(sv, Nullsv, PERL_MAGIC_shared_scalar, + &sharedsv_scalar_vtbl, (char *)data, 0); + mg->mg_flags |= (MGf_COPY|MGf_DUP); + } + break; + } + } + SHARED_UNLOCK; + return data; +} void -Perl_sharedsv_init(pTHX) +Perl_sharedsv_free(pTHX_ shared_sv *shared) { - PerlInterpreter* old_context = PERL_GET_CONTEXT; - PL_sharedsv_space = perl_alloc(); - perl_construct(PL_sharedsv_space); - PERL_SET_CONTEXT(old_context); - MUTEX_INIT(&PL_sharedsv_space_mutex); + if (shared) { + dTHXc; + SHARED_EDIT; + SvREFCNT_dec(SHAREDSvPTR(shared)); + SHARED_RELEASE; + } } -/* - =for apidoc sharedsv_new +void +Perl_sharedsv_share(pTHX_ SV *sv) +{ + switch(SvTYPE(sv)) { + case SVt_PVGV: + Perl_croak(aTHX_ "Cannot share globs yet"); + break; + + case SVt_PVCV: + Perl_croak(aTHX_ "Cannot share subs yet"); + break; + + default: + Perl_sharedsv_associate(aTHX_ &sv, 0, 0); + } +} -Allocates a new shared sv struct, you must yourself create the SV/AV/HV. - =cut -*/ +/* MAGIC (in mg.h sense) hooks */ -shared_sv * -Perl_sharedsv_new(pTHX) +int +sharedsv_scalar_mg_get(pTHX_ SV *sv, MAGIC *mg) { - shared_sv* ssv; - New(2555,ssv,1,shared_sv); - MUTEX_INIT(&ssv->mutex); - COND_INIT(&ssv->cond); - COND_INIT(&ssv->user_cond); - ssv->owner = 0; - ssv->locks = 0; - ssv->index = 0; - return ssv; + shared_sv *shared = (shared_sv *) mg->mg_ptr; + + SHARED_LOCK; + SvOK_off(sv); + if (SHAREDSvPTR(shared)) { + if (SvROK(SHAREDSvPTR(shared))) { + SV *rv = newRV(Nullsv); + Perl_sharedsv_associate(aTHX_ &SvRV(rv), SvRV(SHAREDSvPTR(shared)), NULL); + sv_setsv(sv, rv); + } + else { + sv_setsv(sv, SHAREDSvPTR(shared)); + } + } + SHARED_UNLOCK; + return 0; +} + +int +sharedsv_scalar_mg_set(pTHX_ SV *sv, MAGIC *mg) +{ + dTHXc; + shared_sv *shared = Perl_sharedsv_associate(aTHX_ &sv, Nullsv, + (shared_sv *) mg->mg_ptr); + bool allowed = TRUE; + + SHARED_EDIT; + if (SvROK(sv)) { + shared_sv* target = Perl_sharedsv_find(aTHX_ SvRV(sv)); + if (target) { + SV *tmp = newRV(SHAREDSvPTR(target)); + sv_setsv(SHAREDSvPTR(shared), tmp); + SvREFCNT_dec(tmp); + } + else { + allowed = FALSE; + } + } + else { + sv_setsv(SHAREDSvPTR(shared), sv); + } + SHARED_RELEASE; + + if (!allowed) { + Perl_croak(aTHX_ "Invalid value for shared scalar"); + } + return 0; } +int +sharedsv_scalar_mg_free(pTHX_ SV *sv, MAGIC *mg) +{ + Perl_sharedsv_free(aTHX_ (shared_sv *) mg->mg_ptr); + return 0; +} /* - =for apidoc sharedsv_find + * Called during cloning of new threads + */ +int +sharedsv_scalar_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param) +{ + shared_sv *shared = (shared_sv *) mg->mg_ptr; + if (shared) { + SvREFCNT_inc(SHAREDSvPTR(shared)); + } + return 0; +} -Tries to find if a given SV has a shared backend, either by -looking at magic, or by checking if it is tied again threads::shared. +MGVTBL sharedsv_scalar_vtbl = { + sharedsv_scalar_mg_get, /* get */ + sharedsv_scalar_mg_set, /* set */ + 0, /* len */ + 0, /* clear */ + sharedsv_scalar_mg_free, /* free */ + 0, /* copy */ + sharedsv_scalar_mg_dup /* dup */ +}; - =cut -*/ +/* Now the arrays/hashes stuff */ -shared_sv * -Perl_sharedsv_find(pTHX_ SV* sv) +int +sharedsv_elem_mg_FETCH(pTHX_ SV *sv, MAGIC *mg) { - /* does all it can to find a shared_sv struct, returns NULL otherwise */ - shared_sv* ssv = NULL; - switch (SvTYPE(sv)) { - case SVt_PVMG: - case SVt_PVAV: - case SVt_PVHV: { - MAGIC* mg = mg_find(sv, PERL_MAGIC_ext); - if(mg) { - if(strcmp(mg->mg_ptr,"threads::shared")) - break; - ssv = INT2PTR(shared_sv *, SvIV(mg->mg_obj)); - break; - } - - mg = mg_find(sv,PERL_MAGIC_tied); - if(mg) { - SV* obj = SvTIED_obj(sv,mg); - if(sv_derived_from(obj, "threads::shared")) - ssv = INT2PTR(shared_sv *, SvIV(SvRV(obj))); - break; - } + dTHXc; + shared_sv *shared = Perl_sharedsv_find(aTHX_ mg->mg_obj); + shared_sv *target = Perl_sharedsv_find(aTHX_ sv); + SV** svp; + + SHARED_EDIT; + if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) { + svp = av_fetch((AV*) SHAREDSvPTR(shared), mg->mg_len, 0); + } + else { + svp = hv_fetch((HV*) SHAREDSvPTR(shared), mg->mg_ptr, mg->mg_len, 0); + } + + if (svp) { + if (SHAREDSvPTR(target) != *svp) { + if (SHAREDSvPTR(target)) { + SvREFCNT_dec(SHAREDSvPTR(target)); + } + SHAREDSvPTR(target) = SvREFCNT_inc(*svp); + } + } + else { + if (SHAREDSvPTR(target)) { + SvREFCNT_dec(SHAREDSvPTR(target)); } + SHAREDSvPTR(target) = Nullsv; } - return ssv; + SHARED_RELEASE; + return 0; } -/* - =for apidoc sharedsv_lock +int +sharedsv_elem_mg_STORE(pTHX_ SV *sv, MAGIC *mg) +{ + dTHXc; + shared_sv *shared = Perl_sharedsv_find(aTHX_ mg->mg_obj); + shared_sv *target = Perl_sharedsv_associate(aTHX_ &sv, Nullsv, 0); + /* Theory - SV itself is magically shared - and we have ordered the + magic such that by the time we get here it has been stored + to its shared counterpart + */ + SHARED_EDIT; + if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) { + av_store((AV*) SHAREDSvPTR(shared), mg->mg_len, SHAREDSvPTR(target)); + } + else { + hv_store((HV*) SHAREDSvPTR(shared), mg->mg_ptr, mg->mg_len, + SHAREDSvPTR(target), 0); + } + SHARED_RELEASE; + return 0; +} -Recursive locks on a sharedsv. -Locks are dynamically scoped at the level of the first lock. - =cut -*/ -void -Perl_sharedsv_lock(pTHX_ shared_sv* ssv) +int +sharedsv_elem_mg_DELETE(pTHX_ SV *sv, MAGIC *mg) { - if(!ssv) - return; - MUTEX_LOCK(&ssv->mutex); - if(ssv->owner && ssv->owner == my_perl) { - ssv->locks++; - MUTEX_UNLOCK(&ssv->mutex); - return; + dTHXc; + shared_sv *shared = Perl_sharedsv_find(aTHX_ mg->mg_obj); + SV* ssv; + SHARED_EDIT; + if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) { + ssv = av_delete((AV*) SHAREDSvPTR(shared), mg->mg_len, 0); } - while(ssv->owner) - COND_WAIT(&ssv->cond,&ssv->mutex); - ssv->locks++; - ssv->owner = my_perl; - if(ssv->locks == 1) - SAVEDESTRUCTOR_X(Perl_sharedsv_unlock_scope,ssv); - MUTEX_UNLOCK(&ssv->mutex); + else { + ssv = hv_delete((HV*) SHAREDSvPTR(shared), mg->mg_ptr, mg->mg_len, 0); + } + SHARED_RELEASE; + /* It is no longer in the array - so remove that magic */ + sv_unmagic(sv, PERL_MAGIC_tiedelem); + Perl_sharedsv_associate(aTHX_ &sv, ssv, 0); + return 0; +} + + +int +sharedsv_elem_mg_free(pTHX_ SV *sv, MAGIC *mg) +{ + Perl_sharedsv_free(aTHX_ Perl_sharedsv_find(aTHX_ mg->mg_obj)); + return 0; +} + +int +sharedsv_elem_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param) +{ + shared_sv *shared = Perl_sharedsv_find(aTHX_ mg->mg_obj); + SvREFCNT_inc(SHAREDSvPTR(shared)); + mg->mg_flags |= MGf_DUP; + return 0; +} + +MGVTBL sharedsv_elem_vtbl = { + sharedsv_elem_mg_FETCH, /* get */ + sharedsv_elem_mg_STORE, /* set */ + 0, /* len */ + sharedsv_elem_mg_DELETE, /* clear */ + sharedsv_elem_mg_free, /* free */ + 0, /* copy */ + sharedsv_elem_mg_dup /* dup */ +}; + +U32 +sharedsv_array_mg_FETCHSIZE(pTHX_ SV *sv, MAGIC *mg) +{ + dTHXc; + shared_sv *shared = (shared_sv *) mg->mg_ptr; + U32 val; + SHARED_EDIT; + if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) { + val = av_len((AV*) SHAREDSvPTR(shared)); + } + else { + /* not actually defined by tie API but ... */ + val = HvKEYS((HV*) SHAREDSvPTR(shared)); + } + SHARED_RELEASE; + return val; +} + +int +sharedsv_array_mg_CLEAR(pTHX_ SV *sv, MAGIC *mg) +{ + dTHXc; + shared_sv *shared = (shared_sv *) mg->mg_ptr; + SHARED_EDIT; + if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) { + av_clear((AV*) SHAREDSvPTR(shared)); + } + else { + hv_clear((HV*) SHAREDSvPTR(shared)); + } + SHARED_RELEASE; + return 0; +} + +int +sharedsv_array_mg_free(pTHX_ SV *sv, MAGIC *mg) +{ + Perl_sharedsv_free(aTHX_ (shared_sv *) mg->mg_ptr); + return 0; } /* - =for apidoc sharedsv_unlock + * This is called when perl is about to access an element of + * the array - + */ +int +sharedsv_array_mg_copy(pTHX_ SV *sv, MAGIC* mg, + SV *nsv, const char *name, int namlen) +{ + shared_sv *shared = (shared_sv *) mg->mg_ptr; + MAGIC *nmg = sv_magicext(nsv,mg->mg_obj, + toLOWER(mg->mg_type),&sharedsv_elem_vtbl, + name, namlen); + nmg->mg_flags |= MGf_DUP; +#if 0 + /* Maybe do this to associate shared value immediately ? */ + sharedsv_elem_FIND(aTHX_ nsv, nmg); +#endif + return 1; +} + +int +sharedsv_array_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param) +{ + shared_sv *shared = (shared_sv *) mg->mg_ptr; + SvREFCNT_inc(SHAREDSvPTR(shared)); + mg->mg_flags |= MGf_DUP; + return 0; +} + +MGVTBL sharedsv_array_vtbl = { + 0, /* get */ + 0, /* set */ + sharedsv_array_mg_FETCHSIZE, /* len */ + sharedsv_array_mg_CLEAR, /* clear */ + sharedsv_array_mg_free, /* free */ + sharedsv_array_mg_copy, /* copy */ + sharedsv_array_mg_dup /* dup */ +}; + +=for apidoc sharedsv_unlock Recursively unlocks a shared sv. - =cut -*/ +=cut void Perl_sharedsv_unlock(pTHX_ shared_sv* ssv) { MUTEX_LOCK(&ssv->mutex); - if(ssv->owner != my_perl) { - Perl_croak(aTHX_ "panic: Perl_sharedsv_unlock unlocking mutex that we don't own"); - MUTEX_UNLOCK(&ssv->mutex); - return; + if (ssv->owner != aTHX) { + Perl_croak(aTHX_ "panic: Perl_sharedsv_unlock unlocking mutex that we don't own"); + MUTEX_UNLOCK(&ssv->mutex); + return; } - if(--ssv->locks == 0) { - ssv->owner = NULL; + if (--ssv->locks == 0) { + ssv->owner = NULL; COND_SIGNAL(&ssv->cond); } MUTEX_UNLOCK(&ssv->mutex); @@ -206,9 +572,9 @@ void Perl_sharedsv_unlock_scope(pTHX_ shared_sv* ssv) { MUTEX_LOCK(&ssv->mutex); - if(ssv->owner != my_perl) { - MUTEX_UNLOCK(&ssv->mutex); - return; + if (ssv->owner != aTHX) { + MUTEX_UNLOCK(&ssv->mutex); + return; } ssv->locks = 0; ssv->owner = NULL; @@ -216,293 +582,233 @@ Perl_sharedsv_unlock_scope(pTHX_ shared_sv* ssv) MUTEX_UNLOCK(&ssv->mutex); } -/* - =for apidoc sharedsv_thrcnt_inc - -Increments the threadcount of a sharedsv. - =cut -*/ -void -Perl_sharedsv_thrcnt_inc(pTHX_ shared_sv* ssv) -{ - SHAREDSvLOCK(ssv); - SvREFCNT_inc(ssv->sv); - SHAREDSvUNLOCK(ssv); -} - -/* - =for apidoc sharedsv_thrcnt_dec +=for apidoc sharedsv_lock -Decrements the threadcount of a shared sv. When a threads frontend is freed -this function should be called. +Recursive locks on a sharedsv. +Locks are dynamically scoped at the level of the first lock. - =cut -*/ +=cut void -Perl_sharedsv_thrcnt_dec(pTHX_ shared_sv* ssv) +Perl_sharedsv_lock(pTHX_ shared_sv* ssv) { - SV* sv; - SHAREDSvLOCK(ssv); - sv = SHAREDSvGET(ssv); - if (SvREFCNT(sv) == 1) { - switch (SvTYPE(sv)) { - case SVt_RV: - if (SvROK(sv)) - Perl_sharedsv_thrcnt_dec(aTHX_ INT2PTR(shared_sv *, SvIV(SvRV(sv)))); - break; - case SVt_PVAV: { - SV **src_ary = AvARRAY((AV *)sv); - SSize_t items = AvFILLp((AV *)sv) + 1; - - while (items-- > 0) { - if(SvTYPE(*src_ary)) - Perl_sharedsv_thrcnt_dec(aTHX_ INT2PTR(shared_sv *, SvIV(*src_ary))); - src_ary++; - } - break; - } - case SVt_PVHV: { - HE *entry; - (void)hv_iterinit((HV *)sv); - while ((entry = hv_iternext((HV *)sv))) - Perl_sharedsv_thrcnt_dec( - aTHX_ INT2PTR(shared_sv *, SvIV(hv_iterval((HV *)sv, entry))) - ); - break; - } - } + if (!ssv) + return; + MUTEX_LOCK(&ssv->mutex); + if (ssv->owner && ssv->owner == aTHX) { + ssv->locks++; + MUTEX_UNLOCK(&ssv->mutex); + return; } - Perl_sv_free(PL_sharedsv_space,SHAREDSvGET(ssv)); - SHAREDSvUNLOCK(ssv); + while (ssv->owner) + COND_WAIT(&ssv->cond,&ssv->mutex); + ssv->locks++; + ssv->owner = aTHX; + if (ssv->locks == 1) + SAVEDESTRUCTOR_X(Perl_sharedsv_unlock_scope,ssv); + MUTEX_UNLOCK(&ssv->mutex); } - -MGVTBL svtable; - -#define shared_sv_attach_sv(sv,shared) Perl_shared_sv_attach_sv(aTHX_ sv,shared) - -SV* Perl_shared_sv_attach_sv (pTHX_ SV* sv, shared_sv* shared) { - HV* shared_hv = get_hv("threads::shared::shared", FALSE); - SV* id = newSViv(PTR2IV(shared)); - STRLEN length = sv_len(id); - SV* tiedobject; - SV** tiedobject_ = hv_fetch(shared_hv, SvPV(id,length), length, 0); - if(tiedobject_) { - tiedobject = (*tiedobject_); - if(sv) { - SvROK_on(sv); - SvRV(sv) = SvRV(tiedobject); - } else { - sv = newRV(SvRV(tiedobject)); - } - } else { - switch(SvTYPE(SHAREDSvGET(shared))) { - case SVt_PVAV: { - SV* weakref; - SV* obj_ref = newSViv(0); - SV* obj = newSVrv(obj_ref,"threads::shared::av"); - AV* hv = newAV(); - sv_setiv(obj,PTR2IV(shared)); - weakref = newRV((SV*)hv); - sv = newRV_noinc((SV*)hv); - sv_rvweaken(weakref); - sv_magic((SV*) hv, obj_ref, PERL_MAGIC_tied, Nullch, 0); - hv_store(shared_hv, SvPV(id,length), length, weakref, 0); - Perl_sharedsv_thrcnt_inc(aTHX_ shared); - } - break; - case SVt_PVHV: { - SV* weakref; - SV* obj_ref = newSViv(0); - SV* obj = newSVrv(obj_ref,"threads::shared::hv"); - HV* hv = newHV(); - sv_setiv(obj,PTR2IV(shared)); - weakref = newRV((SV*)hv); - sv = newRV_noinc((SV*)hv); - sv_rvweaken(weakref); - sv_magic((SV*) hv, obj_ref, PERL_MAGIC_tied, Nullch, 0); - hv_store(shared_hv, SvPV(id,length), length, weakref, 0); - Perl_sharedsv_thrcnt_inc(aTHX_ shared); - } - break; - default: { - MAGIC* shared_magic; - SV* value = newSVsv(SHAREDSvGET(shared)); - SV* obj = newSViv(PTR2IV(shared)); - sv_magic(value, 0, PERL_MAGIC_ext, "threads::shared", 16); - shared_magic = mg_find(value, PERL_MAGIC_ext); - shared_magic->mg_virtual = &svtable; - shared_magic->mg_obj = newSViv(PTR2IV(shared)); - shared_magic->mg_flags |= MGf_REFCOUNTED; - shared_magic->mg_private = 0; - SvMAGICAL_on(value); - sv = newRV_noinc(value); - value = newRV(value); - sv_rvweaken(value); - hv_store(shared_hv, SvPV(id,length),length, value, 0); - Perl_sharedsv_thrcnt_inc(aTHX_ shared); - } - - } - } - return sv; +void +Perl_sharedsv_locksv(pTHX_ SV *sv) +{ + Perl_sharedsv_lock(aTHX_ Perl_sharedsv_find(aTHX_ sv)); } +=head1 Shared SV Functions -int shared_sv_fetch_mg (pTHX_ SV* sv, MAGIC *mg) { - shared_sv* shared = INT2PTR(shared_sv*, SvIV(mg->mg_obj)); - SHAREDSvLOCK(shared); - if(mg->mg_private != shared->index) { - if(SvROK(SHAREDSvGET(shared))) { - shared_sv* target = INT2PTR(shared_sv*, SvIV(SvRV(SHAREDSvGET(shared)))); - shared_sv_attach_sv(sv, target); - } else { - sv_setsv(sv, SHAREDSvGET(shared)); - } - mg->mg_private = shared->index; - } - SHAREDSvUNLOCK(shared); +=for apidoc sharedsv_init - return 0; -} +Saves a space for keeping SVs wider than an interpreter, +currently only stores a pointer to the first interpreter. -int shared_sv_store_mg (pTHX_ SV* sv, MAGIC *mg) { - shared_sv* shared = INT2PTR(shared_sv*, SvIV(mg->mg_obj)); - SHAREDSvLOCK(shared); - if(SvROK(SHAREDSvGET(shared))) - Perl_sharedsv_thrcnt_dec(aTHX_ INT2PTR(shared_sv*, SvIV(SvRV(SHAREDSvGET(shared))))); - if(SvROK(sv)) { - shared_sv* target = Perl_sharedsv_find(aTHX_ SvRV(sv)); - if(!target) { - sv_setsv(sv,SHAREDSvGET(shared)); - SHAREDSvUNLOCK(shared); - Perl_croak(aTHX_ "You cannot assign a non shared reference to a shared scalar"); - } - SHAREDSvEDIT(shared); - Perl_sv_free(PL_sharedsv_space,SHAREDSvGET(shared)); - SHAREDSvGET(shared) = newRV_noinc(newSViv(PTR2IV(target))); - } else { - SHAREDSvEDIT(shared); - sv_setsv(SHAREDSvGET(shared), sv); - } - shared->index++; - mg->mg_private = shared->index; - SHAREDSvRELEASE(shared); - if(SvROK(SHAREDSvGET(shared))) - Perl_sharedsv_thrcnt_inc(aTHX_ INT2PTR(shared_sv*, SvIV(SvRV(SHAREDSvGET(shared))))); - SHAREDSvUNLOCK(shared); - return 0; +=cut + +void +Perl_sharedsv_init(pTHX) +{ + dTHXc; + /* This pair leaves us in shared context ... */ + PL_sharedsv_space = perl_alloc(); + perl_construct(PL_sharedsv_space); + CALLER_CONTEXT; + MUTEX_INIT(&PL_sharedsv_space_mutex); + PL_lockhook = &Perl_sharedsv_locksv; + PL_sharehook = &Perl_sharedsv_share; } -int -shared_sv_destroy_mg (pTHX_ SV* sv, MAGIC *mg) +/* Accessor to convert threads::shared::tie objects back shared_sv * */ +shared_sv * +SV_to_sharedsv(pTHX_ SV *sv) { - shared_sv* shared = INT2PTR(shared_sv*, SvIV(mg->mg_obj)); - if (shared) { - HV* shared_hv = get_hv("threads::shared::shared", FALSE); - SV* id = newSViv(PTR2IV(shared)); - STRLEN length = sv_len(id); - hv_delete(shared_hv, SvPV(id,length), length,0); - Perl_sharedsv_thrcnt_dec(aTHX_ shared); - } - return 0; + shared_sv *shared = 0; + if (SvROK(sv)) + { + shared = INT2PTR(shared_sv *, SvIV(SvRV(sv))); + } + return shared; } -MGVTBL svtable = {MEMBER_TO_FPTR(shared_sv_fetch_mg), - MEMBER_TO_FPTR(shared_sv_store_mg), - 0, - 0, - MEMBER_TO_FPTR(shared_sv_destroy_mg) -}; +MODULE = threads::shared PACKAGE = threads::shared::tie -MODULE = threads::shared PACKAGE = threads::shared +PROTOTYPES: DISABLE +void +PUSH(shared_sv *shared, ...) +CODE: + dTHXc; + int i; + SHARED_LOCK; + for(i = 1; i < items; i++) { + SV* tmp = newSVsv(ST(i)); + shared_sv *target = Perl_sharedsv_associate(aTHX_ &tmp, Nullsv, 0); + SHARED_CONTEXT; + av_push((AV*) SHAREDSvPTR(shared), SHAREDSvPTR(target)); + CALLER_CONTEXT; + SvREFCNT_dec(tmp); + } + SHARED_UNLOCK; -PROTOTYPES: ENABLE +void +UNSHIFT(shared_sv *shared, ...) +CODE: + dTHXc; + int i; + SHARED_LOCK; + SHARED_CONTEXT; + av_unshift((AV*)SHAREDSvPTR(shared), items - 1); + CALLER_CONTEXT; + for(i = 1; i < items; i++) { + SV* tmp = newSVsv(ST(i)); + shared_sv *target = Perl_sharedsv_associate(aTHX_ &tmp, Nullsv, 0); + SHARED_CONTEXT; + av_store((AV*) SHAREDSvPTR(shared), i - 1, SHAREDSvPTR(target)); + CALLER_CONTEXT; + SvREFCNT_dec(tmp); + } + SHARED_UNLOCK; +void +POP(shared_sv *shared) +CODE: + dTHXc; + SV* sv; + SHARED_LOCK; + SHARED_CONTEXT; + sv = av_pop((AV*)SHAREDSvPTR(shared)); + CALLER_CONTEXT; + ST(0) = Nullsv; + Perl_sharedsv_associate(aTHX_ &ST(0), sv, 0); + SHARED_UNLOCK; + XSRETURN(1); -SV* -ptr(ref) - SV* ref - CODE: - RETVAL = newSViv(SvIV(SvRV(ref))); - OUTPUT: - RETVAL +void +SHIFT(shared_sv *shared) +CODE: + dTHXc; + SV* sv; + SHARED_LOCK; + SHARED_CONTEXT; + sv = av_shift((AV*)SHAREDSvPTR(shared)); + CALLER_CONTEXT; + ST(0) = Nullsv; + Perl_sharedsv_associate(aTHX_ &ST(0), sv, 0); + SHARED_UNLOCK; + XSRETURN(1); +void +EXTEND(shared_sv *shared, IV count) +CODE: + dTHXc; + SHARED_EDIT; + av_extend((AV*)SHAREDSvPTR(shared), count); + SHARED_RELEASE; -SV* -_thrcnt(ref) - SV* ref - CODE: - shared_sv* shared; - if(SvROK(ref)) - ref = SvRV(ref); - shared = Perl_sharedsv_find(aTHX, ref); - if(!shared) - croak("thrcnt can only be used on shared values"); - SHAREDSvLOCK(shared); - RETVAL = newSViv(SvREFCNT(SHAREDSvGET(shared))); - SHAREDSvUNLOCK(shared); - OUTPUT: - RETVAL +void +EXISTS(shared_sv *shared, SV *index) +CODE: + dTHXc; + bool exists; + SHARED_EDIT; + if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) { + exists = av_exists((AV*) SHAREDSvPTR(shared), SvIV(index)); + } + else { + exists = hv_exists_ent((HV*) SHAREDSvPTR(shared), index, 0); + } + SHARED_RELEASE; + ST(0) = (exists) ? &PL_sv_yes : &PL_sv_no; + XSRETURN(1); +void +STORESIZE(shared_sv *shared,IV count) +CODE: + dTHXc; + SHARED_EDIT; + av_fill((AV*) SHAREDSvPTR(shared), count); + SHARED_RELEASE; void -thrcnt_inc(ref,perl) - SV* ref - SV* perl - CODE: - shared_sv* shared; - PerlInterpreter* origperl = INT2PTR(PerlInterpreter*, SvIV(perl)); - PerlInterpreter* oldperl = PERL_GET_CONTEXT; - if(SvROK(ref)) - ref = SvRV(ref); - shared = Perl_sharedsv_find(aTHX, ref); - if(!shared) - croak("thrcnt can only be used on shared values"); - PERL_SET_CONTEXT(origperl); - Perl_sharedsv_thrcnt_inc(aTHX_ shared); - PERL_SET_CONTEXT(oldperl); +FIRSTKEY(shared_sv *shared) +CODE: + dTHXc; + char* key = NULL; + I32 len = 0; + HE* entry; + SHARED_LOCK; + SHARED_CONTEXT; + hv_iterinit((HV*) SHAREDSvPTR(shared)); + entry = hv_iternext((HV*) SHAREDSvPTR(shared)); + if (entry) { + key = hv_iterkey(entry,&len); + CALLER_CONTEXT; + ST(0) = sv_2mortal(newSVpv(key, len)); + } else { + CALLER_CONTEXT; + ST(0) = &PL_sv_undef; + } + SHARED_UNLOCK; + XSRETURN(1); void -_thrcnt_dec(ref) - SV* ref - CODE: - shared_sv* shared = INT2PTR(shared_sv*, SvIV(ref)); - if(!shared) - croak("thrcnt can only be used on shared values"); - Perl_sharedsv_thrcnt_dec(aTHX_ shared); +NEXTKEY(shared_sv *shared, SV *oldkey) +CODE: + dTHXc; + char* key = NULL; + I32 len = 0; + HE* entry; + SHARED_LOCK; + SHARED_CONTEXT; + entry = hv_iternext((HV*) SHAREDSvPTR(shared)); + if(entry) { + key = hv_iterkey(entry,&len); + CALLER_CONTEXT; + ST(0) = sv_2mortal(newSVpv(key, len)); + } else { + CALLER_CONTEXT; + ST(0) = &PL_sv_undef; + } + SHARED_UNLOCK; + XSRETURN(1); + +MODULE = threads::shared PACKAGE = threads::shared + +PROTOTYPES: ENABLE void -unlock_enabled(ref) - SV* ref +lock_enabled(SV *ref) PROTOTYPE: \[$@%] CODE: shared_sv* shared; if(SvROK(ref)) ref = SvRV(ref); shared = Perl_sharedsv_find(aTHX, ref); - if(!shared) - croak("unlock can only be used on shared values"); - SHAREDSvUNLOCK(shared); - -void -lock_enabled(ref) - SV* ref - CODE: - shared_sv* shared; - if(SvROK(ref)) - ref = SvRV(ref); - shared = Perl_sharedsv_find(aTHX, ref); - if(!shared) - croak("lock can only be used on shared values"); - SHAREDSvLOCK(shared); - + if(!shared) + croak("lock can only be used on shared values"); + Perl_sharedsv_lock(aTHX_ shared); void -cond_wait_enabled(ref) - SV* ref +cond_wait_enabled(SV *ref) PROTOTYPE: \[$@%] CODE: shared_sv* shared; @@ -512,18 +818,18 @@ cond_wait_enabled(ref) shared = Perl_sharedsv_find(aTHX_ ref); if(!shared) croak("cond_wait can only be used on shared values"); - if(shared->owner != PERL_GET_CONTEXT) + if(shared->owner != aTHX) croak("You need a lock before you can cond_wait"); MUTEX_LOCK(&shared->mutex); shared->owner = NULL; locks = shared->locks = 0; COND_WAIT(&shared->user_cond, &shared->mutex); - shared->owner = PERL_GET_CONTEXT; + shared->owner = aTHX; shared->locks = locks; MUTEX_UNLOCK(&shared->mutex); -void cond_signal_enabled(ref) - SV* ref +void +cond_signal_enabled(SV *ref) PROTOTYPE: \[$@%] CODE: shared_sv* shared; @@ -534,9 +840,8 @@ void cond_signal_enabled(ref) croak("cond_signal can only be used on shared values"); COND_SIGNAL(&shared->user_cond); - -void cond_broadcast_enabled(ref) - SV* ref +void +cond_broadcast_enabled(SV *ref) PROTOTYPE: \[$@%] CODE: shared_sv* shared; @@ -547,551 +852,6 @@ void cond_broadcast_enabled(ref) croak("cond_broadcast can only be used on shared values"); COND_BROADCAST(&shared->user_cond); -MODULE = threads::shared PACKAGE = threads::shared::sv - -SV* -new(class, value) - SV* class - SV* value - CODE: - shared_sv* shared = Perl_sharedsv_new(aTHX); - MAGIC* shared_magic; - SV* obj = newSViv(PTR2IV(shared)); - SHAREDSvEDIT(shared); - SHAREDSvGET(shared) = newSVsv(value); - SHAREDSvRELEASE(shared); - sv_magic(value, 0, PERL_MAGIC_ext, "threads::shared", 16); - shared_magic = mg_find(value, PERL_MAGIC_ext); - shared_magic->mg_virtual = &svtable; - shared_magic->mg_obj = newSViv(PTR2IV(shared)); - shared_magic->mg_flags |= MGf_REFCOUNTED; - shared_magic->mg_private = 0; - SvMAGICAL_on(value); - RETVAL = obj; - OUTPUT: - RETVAL - - -MODULE = threads::shared PACKAGE = threads::shared::av - -SV* -new(class, value) - SV* class - SV* value - CODE: - shared_sv* shared = Perl_sharedsv_new(aTHX); - SV* obj = newSViv(PTR2IV(shared)); - SHAREDSvEDIT(shared); - SHAREDSvGET(shared) = (SV*) newAV(); - SHAREDSvRELEASE(shared); - RETVAL = obj; - OUTPUT: - RETVAL - -void -STORE(self, index, value) - SV* self - SV* index - SV* value - CODE: - shared_sv* shared = INT2PTR(shared_sv*, SvIV(SvRV(self))); - shared_sv* slot; - SV* aentry; - SV** aentry_; - if(SvROK(value)) { - shared_sv* target = Perl_sharedsv_find(aTHX_ SvRV(value)); - if(!target) { - Perl_croak(aTHX_ "You cannot assign a non shared reference to a shared array"); - } - value = newRV_noinc(newSViv(PTR2IV(target))); - } - SHAREDSvLOCK(shared); - aentry_ = av_fetch((AV*) SHAREDSvGET(shared), SvIV(index), 0); - if(aentry_ && SvIV((*aentry_))) { - aentry = (*aentry_); - slot = INT2PTR(shared_sv*, SvIV(aentry)); - if(SvROK(SHAREDSvGET(slot))) - Perl_sharedsv_thrcnt_dec(aTHX_ INT2PTR(shared_sv*, SvIV(SvRV(SHAREDSvGET(slot))))); - SHAREDSvEDIT(slot); - sv_setsv(SHAREDSvGET(slot), value); - SHAREDSvRELEASE(slot); - } else { - slot = Perl_sharedsv_new(aTHX); - SHAREDSvEDIT(shared); - SHAREDSvGET(slot) = newSVsv(value); - aentry = newSViv(PTR2IV(slot)); - av_store((AV*) SHAREDSvGET(shared), SvIV(index), aentry); - SHAREDSvRELEASE(shared); - } - if(SvROK(SHAREDSvGET(slot))) - Perl_sharedsv_thrcnt_inc(aTHX_ INT2PTR(shared_sv*, SvIV(SvRV(SHAREDSvGET(slot))))); - - SHAREDSvUNLOCK(shared); - -SV* -FETCH(self, index) - SV* self - SV* index - CODE: - shared_sv* shared = INT2PTR(shared_sv*, SvIV(SvRV(self))); - shared_sv* slot; - SV* aentry; - SV** aentry_; - SV* retval; - SHAREDSvLOCK(shared); - aentry_ = av_fetch((AV*) SHAREDSvGET(shared), SvIV(index),0); - if(aentry_) { - aentry = (*aentry_); - if(SvTYPE(aentry) == SVt_NULL) { - retval = &PL_sv_undef; - } else { - slot = INT2PTR(shared_sv*, SvIV(aentry)); - if(SvROK(SHAREDSvGET(slot))) { - shared_sv* target = INT2PTR(shared_sv*, SvIV(SvRV(SHAREDSvGET(slot)))); - retval = Perl_shared_sv_attach_sv(aTHX_ NULL,target); - } else { - retval = newSVsv(SHAREDSvGET(slot)); - } - } - } else { - retval = &PL_sv_undef; - } - SHAREDSvUNLOCK(shared); - RETVAL = retval; - OUTPUT: - RETVAL - -void -PUSH(self, ...) - SV* self - CODE: - shared_sv* shared = INT2PTR(shared_sv*, SvIV(SvRV(self))); - int i; - SHAREDSvLOCK(shared); - for(i = 1; i < items; i++) { - shared_sv* slot = Perl_sharedsv_new(aTHX); - SV* tmp = ST(i); - if(SvROK(tmp)) { - shared_sv* target = Perl_sharedsv_find(aTHX_ SvRV(tmp)); - if(!target) { - Perl_croak(aTHX_ "You cannot assign a non shared reference to a shared array"); - } - tmp = newRV_noinc(newSViv(PTR2IV(target))); - } - SHAREDSvEDIT(slot); - SHAREDSvGET(slot) = newSVsv(tmp); - av_push((AV*) SHAREDSvGET(shared), newSViv(PTR2IV(slot))); - SHAREDSvRELEASE(slot); - if(SvROK(SHAREDSvGET(slot))) - Perl_sharedsv_thrcnt_inc(aTHX_ INT2PTR(shared_sv*, SvIV(SvRV(SHAREDSvGET(slot))))); - } - SHAREDSvUNLOCK(shared); - -void -UNSHIFT(self, ...) - SV* self - CODE: - shared_sv* shared = INT2PTR(shared_sv*, SvIV(SvRV(self))); - int i; - SHAREDSvLOCK(shared); - SHAREDSvEDIT(shared); - av_unshift((AV*)SHAREDSvGET(shared), items - 1); - SHAREDSvRELEASE(shared); - for(i = 1; i < items; i++) { - shared_sv* slot = Perl_sharedsv_new(aTHX); - SV* tmp = ST(i); - if(SvROK(tmp)) { - shared_sv* target = Perl_sharedsv_find(aTHX_ SvRV(tmp)); - if(!target) { - Perl_croak(aTHX_ "You cannot assign a non shared reference to a shared array"); - } - tmp = newRV_noinc(newSViv(PTR2IV(target))); - } - SHAREDSvEDIT(slot); - SHAREDSvGET(slot) = newSVsv(tmp); - av_store((AV*) SHAREDSvGET(shared), i - 1, newSViv(PTR2IV(slot))); - SHAREDSvRELEASE(slot); - if(SvROK(SHAREDSvGET(slot))) - Perl_sharedsv_thrcnt_inc(aTHX_ INT2PTR(shared_sv*, SvIV(SvRV(SHAREDSvGET(slot))))); - } - SHAREDSvUNLOCK(shared); - -SV* -POP(self) - SV* self - CODE: - shared_sv* shared = INT2PTR(shared_sv*, SvIV(SvRV(self))); - shared_sv* slot; - SV* retval; - SHAREDSvLOCK(shared); - SHAREDSvEDIT(shared); - retval = av_pop((AV*)SHAREDSvGET(shared)); - SHAREDSvRELEASE(shared); - if(retval && SvIV(retval)) { - slot = INT2PTR(shared_sv*, SvIV(retval)); - if(SvROK(SHAREDSvGET(slot))) { - shared_sv* target = INT2PTR(shared_sv*, SvIV(SvRV(SHAREDSvGET(slot)))); - retval = Perl_shared_sv_attach_sv(aTHX_ NULL,target); - } else { - retval = newSVsv(SHAREDSvGET(slot)); - } - Perl_sharedsv_thrcnt_dec(aTHX_ slot); - } else { - retval = &PL_sv_undef; - } - SHAREDSvUNLOCK(shared); - RETVAL = retval; - OUTPUT: - RETVAL - - -SV* -SHIFT(self) - SV* self - CODE: - shared_sv* shared = INT2PTR(shared_sv*, SvIV(SvRV(self))); - shared_sv* slot; - SV* retval; - SHAREDSvLOCK(shared); - SHAREDSvEDIT(shared); - retval = av_shift((AV*)SHAREDSvGET(shared)); - SHAREDSvRELEASE(shared); - if(retval && SvIV(retval)) { - slot = INT2PTR(shared_sv*, SvIV(retval)); - if(SvROK(SHAREDSvGET(slot))) { - shared_sv* target = INT2PTR(shared_sv*, SvIV(SvRV(SHAREDSvGET(slot)))); - retval = Perl_shared_sv_attach_sv(aTHX_ NULL,target); - } else { - retval = newSVsv(SHAREDSvGET(slot)); - } - Perl_sharedsv_thrcnt_dec(aTHX_ slot); - } else { - retval = &PL_sv_undef; - } - SHAREDSvUNLOCK(shared); - RETVAL = retval; - OUTPUT: - RETVAL - -void -CLEAR(self) - SV* self - CODE: - shared_sv* shared = INT2PTR(shared_sv*, SvIV(SvRV(self))); - shared_sv* slot; - SV** svp; - I32 i; - SHAREDSvLOCK(shared); - svp = AvARRAY((AV*)SHAREDSvGET(shared)); - i = AvFILLp((AV*)SHAREDSvGET(shared)); - while ( i >= 0) { - if(SvIV(svp[i])) { - Perl_sharedsv_thrcnt_dec(aTHX_ INT2PTR(shared_sv*, SvIV(svp[i]))); - } - i--; - } - SHAREDSvEDIT(shared); - av_clear((AV*)SHAREDSvGET(shared)); - SHAREDSvRELEASE(shared); - SHAREDSvUNLOCK(shared); - -void -EXTEND(self, count) - SV* self - SV* count - CODE: - shared_sv* shared = INT2PTR(shared_sv*, SvIV(SvRV(self))); - SHAREDSvEDIT(shared); - av_extend((AV*)SHAREDSvGET(shared), (I32) SvIV(count)); - SHAREDSvRELEASE(shared); - - - - -SV* -EXISTS(self, index) - SV* self - SV* index - CODE: - shared_sv* shared = INT2PTR(shared_sv*, SvIV(SvRV(self))); - I32 exists; - SHAREDSvLOCK(shared); - exists = av_exists((AV*) SHAREDSvGET(shared), (I32) SvIV(index)); - if(exists) { - RETVAL = &PL_sv_yes; - } else { - RETVAL = &PL_sv_no; - } - SHAREDSvUNLOCK(shared); - -void -STORESIZE(self,count) - SV* self - SV* count - CODE: - shared_sv* shared = INT2PTR(shared_sv*, SvIV(SvRV(self))); - SHAREDSvEDIT(shared); - av_fill((AV*) SHAREDSvGET(shared), (I32) SvIV(count)); - SHAREDSvRELEASE(shared); - -SV* -FETCHSIZE(self) - SV* self - CODE: - shared_sv* shared = INT2PTR(shared_sv*, SvIV(SvRV(self))); - SHAREDSvLOCK(shared); - RETVAL = newSViv(av_len((AV*) SHAREDSvGET(shared)) + 1); - SHAREDSvUNLOCK(shared); - OUTPUT: - RETVAL - -SV* -DELETE(self,index) - SV* self - SV* index - CODE: - shared_sv* shared = INT2PTR(shared_sv*, SvIV(SvRV(self))); - shared_sv* slot; - SHAREDSvLOCK(shared); - if(av_exists((AV*) SHAREDSvGET(shared), (I32) SvIV(index))) { - SV* tmp; - SHAREDSvEDIT(shared); - tmp = av_delete((AV*)SHAREDSvGET(shared), (I32) SvIV(index),0); - SHAREDSvRELEASE(shared); - if(SvIV(tmp)) { - slot = INT2PTR(shared_sv*, SvIV(tmp)); - if(SvROK(SHAREDSvGET(slot))) { - shared_sv* target = INT2PTR(shared_sv*, SvIV(SvRV(SHAREDSvGET(slot)))); - RETVAL = Perl_shared_sv_attach_sv(aTHX_ NULL,target); - } else { - RETVAL = newSVsv(SHAREDSvGET(slot)); - } - Perl_sharedsv_thrcnt_dec(aTHX_ slot); - } else { - RETVAL = &PL_sv_undef; - } - } else { - RETVAL = &PL_sv_undef; - } - SHAREDSvUNLOCK(shared); - OUTPUT: - RETVAL - -AV* -SPLICE(self, offset, length, ...) - SV* self - SV* offset - SV* length - CODE: - croak("Splice is not implmented for shared arrays"); - -MODULE = threads::shared PACKAGE = threads::shared::hv - -SV* -new(class, value) - SV* class - SV* value - CODE: - shared_sv* shared = Perl_sharedsv_new(aTHX); - SV* obj = newSViv(PTR2IV(shared)); - SHAREDSvEDIT(shared); - SHAREDSvGET(shared) = (SV*) newHV(); - SHAREDSvRELEASE(shared); - RETVAL = obj; - OUTPUT: - RETVAL - -void -STORE(self, key, value) - SV* self - SV* key - SV* value - CODE: - shared_sv* shared = INT2PTR(shared_sv*, SvIV(SvRV(self))); - shared_sv* slot; - SV* hentry; - SV** hentry_; - STRLEN len; - char* ckey = SvPV(key, len); - SHAREDSvLOCK(shared); - if(SvROK(value)) { - shared_sv* target = Perl_sharedsv_find(aTHX_ SvRV(value)); - if(!target) { - Perl_croak(aTHX_ "You cannot assign a non shared reference to a shared hash"); - } - SHAREDSvEDIT(shared); - value = newRV_noinc(newSViv(PTR2IV(target))); - SHAREDSvRELEASE(shared); - } - hentry_ = hv_fetch((HV*) SHAREDSvGET(shared), ckey, len, 0); - if(hentry_ && SvIV((*hentry_))) { - hentry = (*hentry_); - slot = INT2PTR(shared_sv*, SvIV(hentry)); - if(SvROK(SHAREDSvGET(slot))) - Perl_sharedsv_thrcnt_dec(aTHX_ INT2PTR(shared_sv*, SvIV(SvRV(SHAREDSvGET(slot))))); - SHAREDSvEDIT(slot); - sv_setsv(SHAREDSvGET(slot), value); - SHAREDSvRELEASE(slot); - } else { - slot = Perl_sharedsv_new(aTHX); - SHAREDSvEDIT(shared); - SHAREDSvGET(slot) = newSVsv(value); - hentry = newSViv(PTR2IV(slot)); - hv_store((HV*) SHAREDSvGET(shared), ckey,len , hentry, 0); - SHAREDSvRELEASE(shared); - } - if(SvROK(SHAREDSvGET(slot))) - Perl_sharedsv_thrcnt_inc(aTHX_ INT2PTR(shared_sv*, SvIV(SvRV(SHAREDSvGET(slot))))); - SHAREDSvUNLOCK(shared); - - -SV* -FETCH(self, key) - SV* self - SV* key - CODE: - shared_sv* shared = INT2PTR(shared_sv*, SvIV(SvRV(self))); - shared_sv* slot; - SV* hentry; - SV** hentry_; - SV* retval; - STRLEN len; - char* ckey = SvPV(key, len); - SHAREDSvLOCK(shared); - hentry_ = hv_fetch((HV*) SHAREDSvGET(shared), ckey, len,0); - if(hentry_) { - hentry = (*hentry_); - if(SvTYPE(hentry) == SVt_NULL) { - retval = &PL_sv_undef; - } else { - slot = INT2PTR(shared_sv*, SvIV(hentry)); - if(SvROK(SHAREDSvGET(slot))) { - shared_sv* target = INT2PTR(shared_sv*, SvIV(SvRV(SHAREDSvGET(slot)))); - retval = Perl_shared_sv_attach_sv(aTHX_ NULL, target); - } else { - retval = newSVsv(SHAREDSvGET(slot)); - } - } - } else { - retval = &PL_sv_undef; - } - SHAREDSvUNLOCK(shared); - RETVAL = retval; - OUTPUT: - RETVAL - -void -CLEAR(self) - SV* self - CODE: - shared_sv* shared = INT2PTR(shared_sv*, SvIV(SvRV(self))); - shared_sv* slot; - HE* entry; - SHAREDSvLOCK(shared); - Perl_hv_iterinit(PL_sharedsv_space, (HV*) SHAREDSvGET(shared)); - entry = Perl_hv_iternext(PL_sharedsv_space, (HV*) SHAREDSvGET(shared)); - while(entry) { - slot = INT2PTR(shared_sv*, SvIV(Perl_hv_iterval(PL_sharedsv_space, (HV*) SHAREDSvGET(shared), entry))); - Perl_sharedsv_thrcnt_dec(aTHX_ slot); - entry = Perl_hv_iternext(PL_sharedsv_space,(HV*) SHAREDSvGET(shared)); - } - SHAREDSvEDIT(shared); - hv_clear((HV*) SHAREDSvGET(shared)); - SHAREDSvRELEASE(shared); - SHAREDSvUNLOCK(shared); - -SV* -FIRSTKEY(self) - SV* self - CODE: - shared_sv* shared = INT2PTR(shared_sv*, SvIV(SvRV(self))); - char* key = NULL; - I32 len; - HE* entry; - SHAREDSvLOCK(shared); - Perl_hv_iterinit(PL_sharedsv_space, (HV*) SHAREDSvGET(shared)); - entry = Perl_hv_iternext(PL_sharedsv_space, (HV*) SHAREDSvGET(shared)); - if(entry) { - key = Perl_hv_iterkey(PL_sharedsv_space, entry,&len); - RETVAL = newSVpv(key, len); - } else { - RETVAL = &PL_sv_undef; - } - SHAREDSvUNLOCK(shared); - OUTPUT: - RETVAL - - -SV* -NEXTKEY(self, oldkey) - SV* self - SV* oldkey - CODE: - shared_sv* shared = INT2PTR(shared_sv*, SvIV(SvRV(self))); - char* key = NULL; - I32 len; - HE* entry; - SHAREDSvLOCK(shared); - entry = Perl_hv_iternext(PL_sharedsv_space, (HV*) SHAREDSvGET(shared)); - if(entry) { - key = Perl_hv_iterkey(PL_sharedsv_space, entry,&len); - RETVAL = newSVpv(key, len); - } else { - RETVAL = &PL_sv_undef; - } - SHAREDSvUNLOCK(shared); - OUTPUT: - RETVAL - - -SV* -EXISTS(self, key) - SV* self - SV* key - CODE: - shared_sv* shared = INT2PTR(shared_sv*, SvIV(SvRV(self))); - STRLEN len; - char* ckey = SvPV(key, len); - SHAREDSvLOCK(shared); - if(hv_exists((HV*)SHAREDSvGET(shared), ckey, len)) { - RETVAL = &PL_sv_yes; - } else { - RETVAL = &PL_sv_no; - } - SHAREDSvUNLOCK(shared); - OUTPUT: - RETVAL - -SV* -DELETE(self, key) - SV* self - SV* key - CODE: - shared_sv* shared = INT2PTR(shared_sv*, SvIV(SvRV(self))); - shared_sv* slot; - STRLEN len; - char* ckey = SvPV(key, len); - SV* tmp; - SHAREDSvLOCK(shared); - SHAREDSvEDIT(shared); - tmp = hv_delete((HV*) SHAREDSvGET(shared), ckey, len,0); - SHAREDSvRELEASE(shared); - if(tmp) { - slot = INT2PTR(shared_sv*, SvIV(tmp)); - if(SvROK(SHAREDSvGET(slot))) { - shared_sv* target = INT2PTR(shared_sv*, SvIV(SvRV(SHAREDSvGET(slot)))); - RETVAL = Perl_shared_sv_attach_sv(aTHX_ NULL, target); - } else { - RETVAL = newSVsv(SHAREDSvGET(slot)); - } - Perl_sharedsv_thrcnt_dec(aTHX_ slot); - } else { - RETVAL = &PL_sv_undef; - } - SHAREDSvUNLOCK(shared); - OUTPUT: - RETVAL - BOOT: { Perl_sharedsv_init(aTHX); diff --git a/ext/threads/shared/typemap b/ext/threads/shared/typemap new file mode 100644 index 0000000..0202d04 --- /dev/null +++ b/ext/threads/shared/typemap @@ -0,0 +1,7 @@ +shared_sv * T_SHAREDSV + +INPUT +T_SHAREDSV + $var = SV_to_sharedsv(aTHX_ $arg) + +