* 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_vnewSVpvf
+# define NEED_warner
# 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);
}
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:
+extern MGVTBL sharedsv_scalar_vtbl; /* Scalars have this vtable */
+extern MGVTBL sharedsv_array_vtbl; /* Hashes and arrays have this
+ - like 'tie' */
+extern 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
*/
/* 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:
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));
#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
-
-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)
char* key = NULL;
I32 len = 0;
HE* entry;
+
+ PERL_UNUSED_VAR(oldkey);
+
ENTER_LOCK;
SHARED_CONTEXT;
entry = hv_iternext((HV*) sobj);
ref = SvRV(ref);
ssv = Perl_sharedsv_find(aTHX_ ref);
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)));
}
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) {
projects / p5sagit/p5-mst-13.2.git / blobdiff