* without the prefix (e.g., sv, tmp or obj).
*/
-/* Patch status:
- *
- * Perl 5.8.8 contains threads::shared patches up to 26626 (equivalent to
- * blead patches 26350+26351).
- *
- * The CPAN version of threads::shared contains the following blead patches:
- * 26569 (applicable to 5.9.3 only)
- * 26684
- * 26693
- * 26695
- */
-
#define PERL_NO_GET_CONTEXT
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#ifdef HAS_PPPORT_H
-#define NEED_vnewSVpvf
-#define NEED_warner
+# define NEED_sv_2pv_flags
+# define NEED_vnewSVpvf
+# define NEED_warner
+# define NEED_newSVpvn_flags
# include "ppport.h"
# include "shared.h"
#endif
#ifdef USE_ITHREADS
+/* Magic signature(s) for mg_private to make PERL_MAGIC_ext magic safer */
+#define UL_MAGIC_SIG 0x554C /* UL = user lock */
+
/*
* The shared things need an intepreter to live in ...
*/
recursive_lock_release(pTHX_ recursive_lock_t *lock)
{
MUTEX_LOCK(&lock->mutex);
- if (lock->owner != aTHX) {
- MUTEX_UNLOCK(&lock->mutex);
- } else if (--lock->locks == 0) {
- lock->owner = NULL;
- COND_SIGNAL(&lock->cond);
+ if (lock->owner == aTHX) {
+ if (--lock->locks == 0) {
+ lock->owner = NULL;
+ COND_SIGNAL(&lock->cond);
+ }
}
MUTEX_UNLOCK(&lock->mutex);
}
/* XXX Redesign the storage of user locks so we don't need a global
* lock to access them ???? DAPM */
ENTER_LOCK;
- mg = mg_find(ssv, PERL_MAGIC_ext);
+
+ /* Version of mg_find that also checks the private signature */
+ for (mg = SvMAGIC(ssv); mg; mg = mg->mg_moremagic) {
+ if ((mg->mg_type == PERL_MAGIC_ext) &&
+ (mg->mg_private == UL_MAGIC_SIG))
+ {
+ break;
+ }
+ }
+
if (mg) {
ul = (user_lock*)(mg->mg_ptr);
} else if (create) {
ul = (user_lock *) PerlMemShared_malloc(sizeof(user_lock));
Zero(ul, 1, user_lock);
/* Attach to shared SV using ext magic */
- sv_magicext(ssv, NULL, PERL_MAGIC_ext, &sharedsv_userlock_vtbl,
- (char *)ul, 0);
+ mg = sv_magicext(ssv, NULL, PERL_MAGIC_ext, &sharedsv_userlock_vtbl,
+ (char *)ul, 0);
+ mg->mg_private = UL_MAGIC_SIG; /* Set private signature */
recursive_lock_init(aTHX_ &ul->lock);
COND_INIT(&ul->user_cond);
CALLER_CONTEXT;
}
-=for apidoc sharedsv_find
-
-Given a private side SV tries to find if the SV has a shared backend,
-by looking for the magic.
-
-=cut
-
+/* Given a private side SV tries to find if the SV has a shared backend,
+ * by looking for the magic.
+ */
SV *
Perl_sharedsv_find(pTHX_ SV *sv)
{
void
Perl_sharedsv_associate(pTHX_ SV *sv, SV *ssv)
{
- dTHXc;
MAGIC *mg = 0;
/* If we are asked for any private ops we need a thread */
}
-#if defined(WIN32) || defined(OS2)
+#ifdef WIN32
+/* Number of milliseconds from 1/1/1601 to 1/1/1970 */
+#define EPOCH_BIAS 11644473600000.
+
+/* Returns relative time in milliseconds. (Adapted from Time::HiRes.) */
+STATIC DWORD
+S_abs_2_rel_milli(double abs)
+{
+ double rel;
+
+ /* Get current time (in units of 100 nanoseconds since 1/1/1601) */
+ union {
+ FILETIME ft;
+ __int64 i64; /* 'signed' to keep compilers happy */
+ } now;
+
+ GetSystemTimeAsFileTime(&now.ft);
+
+ /* Relative time in milliseconds */
+ rel = (abs * 1000.) - (((double)now.i64 / 10000.) - EPOCH_BIAS);
+ if (rel <= 0.0) {
+ return (0);
+ }
+ return (DWORD)rel;
+}
+
+#else
+# if defined(OS2)
# define ABS2RELMILLI(abs) \
do { \
abs -= (double)time(NULL); \
if (abs > 0) { abs *= 1000; } \
else { abs = 0; } \
} while (0)
-#endif /* WIN32 || OS2 */
+# endif /* OS2 */
+#endif /* WIN32 */
/* Do OS-specific condition timed wait */
# ifdef WIN32
int got_it = 0;
- ABS2RELMILLI(abs);
-
cond->waiters++;
MUTEX_UNLOCK(mut);
/* See comments in win32/win32thread.h COND_WAIT vis-a-vis race */
- switch (WaitForSingleObject(cond->sem, (DWORD)abs)) {
+ switch (WaitForSingleObject(cond->sem, S_abs_2_rel_milli(abs))) {
case WAIT_OBJECT_0: got_it = 1; break;
case WAIT_TIMEOUT: break;
default:
ENTER_LOCK;
if (SvROK(ssv)) {
S_get_RV(aTHX_ sv, ssv);
+ /* Look ahead for refs of refs */
+ if (SvROK(SvRV(ssv))) {
+ SvROK_on(SvRV(sv));
+ S_get_RV(aTHX_ SvRV(sv), SvRV(ssv));
+ }
} else {
sv_setsv_nomg(sv, ssv);
}
SV *sobj = Perl_sharedsv_find(aTHX_ obj);
if (sobj) {
SHARED_CONTEXT;
- SvUPGRADE(ssv, SVt_RV);
+ (void)SvUPGRADE(ssv, SVt_RV);
sv_setsv_nomg(ssv, &PL_sv_undef);
SvRV_set(ssv, SvREFCNT_inc(sobj));
svp = av_fetch((AV*) saggregate, mg->mg_len, 0);
} else {
char *key = mg->mg_ptr;
- STRLEN len = mg->mg_len;
+ I32 len = mg->mg_len;
assert ( mg->mg_ptr != 0 );
if (mg->mg_len == HEf_SVKEY) {
- key = SvPV((SV *) mg->mg_ptr, len);
+ STRLEN slen;
+ key = SvPV((SV *)mg->mg_ptr, slen);
+ len = slen;
+ if (SvUTF8((SV *)mg->mg_ptr)) {
+ len = -len;
+ }
}
SHARED_CONTEXT;
svp = hv_fetch((HV*) saggregate, key, len, 0);
/* Exists in the array */
if (SvROK(*svp)) {
S_get_RV(aTHX_ sv, *svp);
+ /* Look ahead for refs of refs */
+ if (SvROK(SvRV(*svp))) {
+ SvROK_on(SvRV(sv));
+ S_get_RV(aTHX_ SvRV(sv), SvRV(*svp));
+ }
} else {
- /* XXX Can this branch ever happen? DAPM */
- /* XXX assert("no such branch"); */
+ /* $ary->[elem] or $ary->{elem} is a scalar */
Perl_sharedsv_associate(aTHX_ sv, *svp);
sv_setsv(sv, *svp);
}
svp = av_fetch((AV*) saggregate, mg->mg_len, 1);
} else {
char *key = mg->mg_ptr;
- STRLEN len = mg->mg_len;
+ I32 len = mg->mg_len;
assert ( mg->mg_ptr != 0 );
- if (mg->mg_len == HEf_SVKEY)
- key = SvPV((SV *) mg->mg_ptr, len);
+ if (mg->mg_len == HEf_SVKEY) {
+ STRLEN slen;
+ key = SvPV((SV *)mg->mg_ptr, slen);
+ len = slen;
+ if (SvUTF8((SV *)mg->mg_ptr)) {
+ len = -len;
+ }
+ }
SHARED_CONTEXT;
svp = hv_fetch((HV*) saggregate, key, len, 1);
}
av_delete((AV*) saggregate, mg->mg_len, G_DISCARD);
} else {
char *key = mg->mg_ptr;
- STRLEN len = mg->mg_len;
+ I32 len = mg->mg_len;
assert ( mg->mg_ptr != 0 );
- if (mg->mg_len == HEf_SVKEY)
- key = SvPV((SV *) mg->mg_ptr, len);
+ if (mg->mg_len == HEf_SVKEY) {
+ STRLEN slen;
+ key = SvPV((SV *)mg->mg_ptr, slen);
+ len = slen;
+ if (SvUTF8((SV *)mg->mg_ptr)) {
+ len = -len;
+ }
+ }
SHARED_CONTEXT;
hv_delete((HV*) saggregate, key, len, G_DISCARD);
}
* This is called when perl is about to access an element of
* the array -
*/
+#if PERL_VERSION >= 11
+int
+sharedsv_array_mg_copy(pTHX_ SV *sv, MAGIC* mg,
+ SV *nsv, const char *name, I32 namlen)
+#else
int
sharedsv_array_mg_copy(pTHX_ SV *sv, MAGIC* mg,
SV *nsv, const char *name, int namlen)
+#endif
{
MAGIC *nmg = sv_magicext(nsv,mg->mg_obj,
toLOWER(mg->mg_type),&sharedsv_elem_vtbl,
#endif
};
-=for apidoc sharedsv_unlock
-Recursively unlocks a shared sv.
-
-=cut
+/* Recursively unlocks a shared sv. */
void
Perl_sharedsv_unlock(pTHX_ SV *ssv)
recursive_lock_release(aTHX_ &ul->lock);
}
-=for apidoc sharedsv_lock
-
-Recursive locks on a sharedsv.
-Locks are dynamically scoped at the level of the first lock.
-
-=cut
+/* Recursive locks on a sharedsv.
+ * Locks are dynamically scoped at the level of the first lock.
+ */
void
Perl_sharedsv_lock(pTHX_ SV *ssv)
{
Perl_sharedsv_lock(aTHX_ ssv);
}
-=head1 Shared SV Functions
-=for apidoc sharedsv_init
+/* Can a shared object be destroyed?
+ * True if not a shared,
+ * or if detroying last proxy on a shared object
+ */
+#ifdef PL_destroyhook
+bool
+Perl_shared_object_destroy(pTHX_ SV *sv)
+{
+ SV *ssv;
+
+ if (SvROK(sv))
+ sv = SvRV(sv);
+ ssv = Perl_sharedsv_find(aTHX_ sv);
+ return (!ssv || (SvREFCNT(ssv) <= 1));
+}
+#endif
-Saves a space for keeping SVs wider than an interpreter.
-=cut
+/* Saves a space for keeping SVs wider than an interpreter. */
void
Perl_sharedsv_init(pTHX)
recursive_lock_init(aTHX_ &PL_sharedsv_lock);
PL_lockhook = &Perl_sharedsv_locksv;
PL_sharehook = &Perl_sharedsv_share;
+#ifdef PL_destroyhook
+ PL_destroyhook = &Perl_shared_object_destroy;
+#endif
}
#endif /* USE_ITHREADS */
SHARED_EDIT;
exists = av_exists((AV*) sobj, SvIV(index));
} else {
- STRLEN len;
- char *key = SvPV(index,len);
+ I32 len;
+ STRLEN slen;
+ char *key = SvPVutf8(index, slen);
+ len = slen;
+ if (SvUTF8(index)) {
+ len = -len;
+ }
SHARED_EDIT;
exists = hv_exists((HV*) sobj, key, len);
}
hv_iterinit((HV*) sobj);
entry = hv_iternext((HV*) sobj);
if (entry) {
+ I32 utf8 = HeKUTF8(entry);
key = hv_iterkey(entry,&len);
CALLER_CONTEXT;
- ST(0) = sv_2mortal(newSVpv(key, len));
+ ST(0) = sv_2mortal(newSVpvn_utf8(key, len, utf8));
} else {
CALLER_CONTEXT;
ST(0) = &PL_sv_undef;
char* key = NULL;
I32 len = 0;
HE* entry;
+
+ PERL_UNUSED_VAR(oldkey);
+
ENTER_LOCK;
SHARED_CONTEXT;
entry = hv_iternext((HV*) sobj);
if (entry) {
+ I32 utf8 = HeKUTF8(entry);
key = hv_iterkey(entry,&len);
CALLER_CONTEXT;
- ST(0) = sv_2mortal(newSVpv(key, len));
+ ST(0) = sv_2mortal(newSVpvn_utf8(key, len, utf8));
} else {
CALLER_CONTEXT;
ST(0) = &PL_sv_undef;
PROTOTYPES: ENABLE
void
-_id(SV *ref)
+_id(SV *myref)
PROTOTYPE: \[$@%]
PREINIT:
SV *ssv;
CODE:
- ref = SvRV(ref);
- if (SvROK(ref))
- ref = SvRV(ref);
- ssv = Perl_sharedsv_find(aTHX_ ref);
+ myref = SvRV(myref);
+ if (SvMAGICAL(myref))
+ mg_get(myref);
+ if (SvROK(myref))
+ myref = SvRV(myref);
+ ssv = Perl_sharedsv_find(aTHX_ myref);
if (! ssv)
XSRETURN_UNDEF;
ST(0) = sv_2mortal(newSVuv(PTR2UV(ssv)));
void
-_refcnt(SV *ref)
+_refcnt(SV *myref)
PROTOTYPE: \[$@%]
PREINIT:
SV *ssv;
CODE:
- ref = SvRV(ref);
- if (SvROK(ref))
- ref = SvRV(ref);
- ssv = Perl_sharedsv_find(aTHX_ ref);
+ myref = SvRV(myref);
+ if (SvROK(myref))
+ myref = SvRV(myref);
+ ssv = Perl_sharedsv_find(aTHX_ myref);
if (! ssv) {
- Perl_warn(aTHX_ "%" SVf " is not shared", ST(0));
+ if (ckWARN(WARN_THREADS)) {
+ Perl_warner(aTHX_ packWARN(WARN_THREADS),
+ "%" SVf " is not shared", ST(0));
+ }
XSRETURN_UNDEF;
}
ST(0) = sv_2mortal(newSViv(SvREFCNT(ssv)));
void
-share(SV *ref)
+share(SV *myref)
PROTOTYPE: \[$@%]
CODE:
- if (! SvROK(ref))
+ if (! SvROK(myref))
Perl_croak(aTHX_ "Argument to share needs to be passed as ref");
- ref = SvRV(ref);
- if (SvROK(ref))
- ref = SvRV(ref);
- Perl_sharedsv_share(aTHX_ ref);
- ST(0) = sv_2mortal(newRV_inc(ref));
+ myref = SvRV(myref);
+ if (SvROK(myref))
+ myref = SvRV(myref);
+ Perl_sharedsv_share(aTHX_ myref);
+ ST(0) = sv_2mortal(newRV_inc(myref));
/* XSRETURN(1); - implied */
}
if (ul->lock.owner != aTHX)
croak("You need a lock before you can cond_wait");
+
/* Stealing the members of the lock object worries me - NI-S */
MUTEX_LOCK(&ul->lock.mutex);
ul->lock.owner = NULL;
locks = ul->lock.locks;
ul->lock.locks = 0;
- /* Since we are releasing the lock here we need to tell other
- * people that is ok to go ahead and use it */
+ /* Since we are releasing the lock here, we need to tell other
+ * people that it is ok to go ahead and use it */
COND_SIGNAL(&ul->lock.cond);
COND_WAIT(user_condition, &ul->lock.mutex);
- while(ul->lock.owner != NULL) {
+ while (ul->lock.owner != NULL) {
/* OK -- must reacquire the lock */
COND_WAIT(&ul->lock.cond, &ul->lock.mutex);
}
ul->lock.owner = NULL;
locks = ul->lock.locks;
ul->lock.locks = 0;
- /* Since we are releasing the lock here we need to tell other
- * people that is ok to go ahead and use it */
+ /* Since we are releasing the lock here, we need to tell other
+ * people that it is ok to go ahead and use it */
COND_SIGNAL(&ul->lock.cond);
RETVAL = Perl_sharedsv_cond_timedwait(user_condition, &ul->lock.mutex, abs);
while (ul->lock.owner != NULL) {
void
-cond_signal(SV *ref)
+cond_signal(SV *myref)
PROTOTYPE: \[$@%]
PREINIT:
SV *ssv;
user_lock *ul;
CODE:
- if (! SvROK(ref))
+ if (! SvROK(myref))
Perl_croak(aTHX_ "Argument to cond_signal needs to be passed as ref");
- ref = SvRV(ref);
- if (SvROK(ref))
- ref = SvRV(ref);
- ssv = Perl_sharedsv_find(aTHX_ ref);
+ myref = SvRV(myref);
+ if (SvROK(myref))
+ myref = SvRV(myref);
+ ssv = Perl_sharedsv_find(aTHX_ myref);
if (! ssv)
Perl_croak(aTHX_ "cond_signal can only be used on shared values");
ul = S_get_userlock(aTHX_ ssv, 1);
void
-cond_broadcast(SV *ref)
+cond_broadcast(SV *myref)
PROTOTYPE: \[$@%]
PREINIT:
SV *ssv;
user_lock *ul;
CODE:
- if (! SvROK(ref))
+ if (! SvROK(myref))
Perl_croak(aTHX_ "Argument to cond_broadcast needs to be passed as ref");
- ref = SvRV(ref);
- if (SvROK(ref))
- ref = SvRV(ref);
- ssv = Perl_sharedsv_find(aTHX_ ref);
+ myref = SvRV(myref);
+ if (SvROK(myref))
+ myref = SvRV(myref);
+ ssv = Perl_sharedsv_find(aTHX_ myref);
if (! ssv)
Perl_croak(aTHX_ "cond_broadcast can only be used on shared values");
ul = S_get_userlock(aTHX_ ssv, 1);
void
-bless(SV* ref, ...);
+bless(SV* myref, ...);
PROTOTYPE: $;$
PREINIT:
HV* stash;
}
stash = gv_stashpvn(ptr, len, TRUE);
}
- SvREFCNT_inc_void(ref);
- (void)sv_bless(ref, stash);
- ST(0) = sv_2mortal(ref);
- ssv = Perl_sharedsv_find(aTHX_ ref);
+ SvREFCNT_inc_void(myref);
+ (void)sv_bless(myref, stash);
+ ST(0) = sv_2mortal(myref);
+ ssv = Perl_sharedsv_find(aTHX_ myref);
if (ssv) {
dTHXc;
ENTER_LOCK;
projects / p5sagit/p5-mst-13.2.git / blobdiff