summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--generic/tclInt.h3
-rw-r--r--generic/tclThread.c37
-rw-r--r--tests/thread.test26
-rwxr-xr-xunix/configure231
-rw-r--r--unix/configure.in6
-rw-r--r--unix/tcl.m442
-rw-r--r--unix/tclUnixNotfy.c16
-rw-r--r--unix/tclUnixThrd.c111
-rw-r--r--win/tclWinThrd.c83
9 files changed, 543 insertions, 12 deletions
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 18574c3..f39e77d 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -2681,6 +2681,9 @@ MODULE_SCOPE void TclpInitUnlock(void);
MODULE_SCOPE Tcl_Obj * TclpObjListVolumes(void);
MODULE_SCOPE void TclpMasterLock(void);
MODULE_SCOPE void TclpMasterUnlock(void);
+MODULE_SCOPE void TclpMutexLock(void);
+MODULE_SCOPE void TclpMutexUnlock(void);
+MODULE_SCOPE void TclMutexUnlockAndFinalize(Tcl_Mutex *mutex);
MODULE_SCOPE int TclpMatchFiles(Tcl_Interp *interp, char *separators,
Tcl_DString *dirPtr, char *pattern, char *tail);
MODULE_SCOPE int TclpObjNormalizePath(Tcl_Interp *interp,
diff --git a/generic/tclThread.c b/generic/tclThread.c
index d6b5bcb..087d735 100644
--- a/generic/tclThread.c
+++ b/generic/tclThread.c
@@ -283,6 +283,43 @@ Tcl_MutexFinalize(
/*
*----------------------------------------------------------------------
*
+ * TclMutexUnlockAndFinalize --
+ *
+ * This procedure is invoked to unlock and then finalize a mutex.
+ * The mutex must have been locked by Tcl_MutexLock. It is also
+ * removed from the list of remembered objects. The mutex can no
+ * longer be used after calling this procedure.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Remove the mutex from the list.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclMutexUnlockAndFinalize(
+ Tcl_Mutex *mutexPtr)
+{
+ Tcl_Mutex mutex;
+ TclpMasterLock();
+ TclpMutexLock();
+#ifdef TCL_THREADS
+ mutex = *mutexPtr;
+ *mutexPtr = NULL; /* Force it to be created again. */
+ Tcl_MutexUnlock(&mutex);
+ TclpFinalizeMutex(&mutex);
+#endif
+ ForgetSyncObject(mutexPtr, &mutexRecord);
+ TclpMutexUnlock();
+ TclpMasterUnlock();
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TclRememberCondition
*
* Keep a list of condition variables used during finalization.
diff --git a/tests/thread.test b/tests/thread.test
index bfef91c..3c0a1e1 100644
--- a/tests/thread.test
+++ b/tests/thread.test
@@ -254,6 +254,32 @@ test thread-6.1 {freeing very large object trees in a thread} testthread {
set res
} {0}
+test thread-8.1 {threaded fork stress} -constraints {thread} -setup {
+ unset -nocomplain ::threadCount ::execCount ::threads ::thread
+ set ::threadCount 10
+ set ::execCount 10
+} -body {
+ set ::threads [list]
+ for {set i 0} {$i < $::threadCount} {incr i} {
+ lappend ::threads [thread::create -joinable [string map \
+ [list %execCount% $::execCount] {
+ proc execLs {} {
+ if {$::tcl_platform(platform) eq "windows"} then {
+ return [exec $::env(COMSPEC) /c DIR]
+ } else {
+ return [exec /bin/ls]
+ }
+ }
+ set j {%execCount%}; while {[incr j -1]} {execLs}
+ }]]
+ }
+ foreach ::thread $::threads {
+ thread::join $::thread
+ }
+} -cleanup {
+ unset -nocomplain ::threadCount ::execCount ::threads ::thread
+} -result {}
+
# cleanup
::tcltest::cleanupTests
return
diff --git a/unix/configure b/unix/configure
index 7a1ab59..1899aa3 100755
--- a/unix/configure
+++ b/unix/configure
@@ -857,6 +857,8 @@ Optional Features:
--enable-load allow dynamic loading and "load" command (default:
on)
--enable-symbols build with debugging symbols (default: off)
+ --enable-usleep use usleep if possible to sleep, otherwise use
+ Tcl_Sleep (default: on)
--enable-langinfo use nl_langinfo if possible to determine encoding at
startup, otherwise use old heuristic (default: on)
--enable-dll-unloading enable the 'unload' command (default: on)
@@ -16432,6 +16434,235 @@ _ACEOF
fi
#--------------------------------------------------------------------
+# Check for support of usleep function
+#--------------------------------------------------------------------
+
+
+ # Check whether --enable-usleep or --disable-usleep was given.
+if test "${enable_usleep+set}" = set; then
+ enableval="$enable_usleep"
+ usleep_ok=$enableval
+else
+ usleep_ok=yes
+fi;
+
+ HAVE_USLEEP=0
+ if test "$usleep_ok" = "yes"; then
+ if test "${ac_cv_header_unistd_h+set}" = set; then
+ echo "$as_me:$LINENO: checking for unistd.h" >&5
+echo $ECHO_N "checking for unistd.h... $ECHO_C" >&6
+if test "${ac_cv_header_unistd_h+set}" = set; then
+ echo $ECHO_N "(cached) $ECHO_C" >&6
+fi
+echo "$as_me:$LINENO: result: $ac_cv_header_unistd_h" >&5
+echo "${ECHO_T}$ac_cv_header_unistd_h" >&6
+else
+ # Is the header compilable?
+echo "$as_me:$LINENO: checking unistd.h usability" >&5
+echo $ECHO_N "checking unistd.h usability... $ECHO_C" >&6
+cat >conftest.$ac_ext <<_ACEOF
+/* confdefs.h. */
+_ACEOF
+cat confdefs.h >>conftest.$ac_ext
+cat >>conftest.$ac_ext <<_ACEOF
+/* end confdefs.h. */
+$ac_includes_default
+#include <unistd.h>
+_ACEOF
+rm -f conftest.$ac_objext
+if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
+ (eval $ac_compile) 2>conftest.er1
+ ac_status=$?
+ grep -v '^ *+' conftest.er1 >conftest.err
+ rm -f conftest.er1
+ cat conftest.err >&5
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); } &&
+ { ac_try='test -z "$ac_c_werror_flag"
+ || test ! -s conftest.err'
+ { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
+ (eval $ac_try) 2>&5
+ ac_status=$?
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); }; } &&
+ { ac_try='test -s conftest.$ac_objext'
+ { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
+ (eval $ac_try) 2>&5
+ ac_status=$?
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); }; }; then
+ ac_header_compiler=yes
+else
+ echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+ac_header_compiler=no
+fi
+rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+echo "$as_me:$LINENO: result: $ac_header_compiler" >&5
+echo "${ECHO_T}$ac_header_compiler" >&6
+
+# Is the header present?
+echo "$as_me:$LINENO: checking unistd.h presence" >&5
+echo $ECHO_N "checking unistd.h presence... $ECHO_C" >&6
+cat >conftest.$ac_ext <<_ACEOF
+/* confdefs.h. */
+_ACEOF
+cat confdefs.h >>conftest.$ac_ext
+cat >>conftest.$ac_ext <<_ACEOF
+/* end confdefs.h. */
+#include <unistd.h>
+_ACEOF
+if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5
+ (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1
+ ac_status=$?
+ grep -v '^ *+' conftest.er1 >conftest.err
+ rm -f conftest.er1
+ cat conftest.err >&5
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); } >/dev/null; then
+ if test -s conftest.err; then
+ ac_cpp_err=$ac_c_preproc_warn_flag
+ ac_cpp_err=$ac_cpp_err$ac_c_werror_flag
+ else
+ ac_cpp_err=
+ fi
+else
+ ac_cpp_err=yes
+fi
+if test -z "$ac_cpp_err"; then
+ ac_header_preproc=yes
+else
+ echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+ ac_header_preproc=no
+fi
+rm -f conftest.err conftest.$ac_ext
+echo "$as_me:$LINENO: result: $ac_header_preproc" >&5
+echo "${ECHO_T}$ac_header_preproc" >&6
+
+# So? What about this header?
+case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in
+ yes:no: )
+ { echo "$as_me:$LINENO: WARNING: unistd.h: accepted by the compiler, rejected by the preprocessor!" >&5
+echo "$as_me: WARNING: unistd.h: accepted by the compiler, rejected by the preprocessor!" >&2;}
+ { echo "$as_me:$LINENO: WARNING: unistd.h: proceeding with the compiler's result" >&5
+echo "$as_me: WARNING: unistd.h: proceeding with the compiler's result" >&2;}
+ ac_header_preproc=yes
+ ;;
+ no:yes:* )
+ { echo "$as_me:$LINENO: WARNING: unistd.h: present but cannot be compiled" >&5
+echo "$as_me: WARNING: unistd.h: present but cannot be compiled" >&2;}
+ { echo "$as_me:$LINENO: WARNING: unistd.h: check for missing prerequisite headers?" >&5
+echo "$as_me: WARNING: unistd.h: check for missing prerequisite headers?" >&2;}
+ { echo "$as_me:$LINENO: WARNING: unistd.h: see the Autoconf documentation" >&5
+echo "$as_me: WARNING: unistd.h: see the Autoconf documentation" >&2;}
+ { echo "$as_me:$LINENO: WARNING: unistd.h: section \"Present But Cannot Be Compiled\"" >&5
+echo "$as_me: WARNING: unistd.h: section \"Present But Cannot Be Compiled\"" >&2;}
+ { echo "$as_me:$LINENO: WARNING: unistd.h: proceeding with the preprocessor's result" >&5
+echo "$as_me: WARNING: unistd.h: proceeding with the preprocessor's result" >&2;}
+ { echo "$as_me:$LINENO: WARNING: unistd.h: in the future, the compiler will take precedence" >&5
+echo "$as_me: WARNING: unistd.h: in the future, the compiler will take precedence" >&2;}
+ (
+ cat <<\_ASBOX
+## ------------------------------ ##
+## Report this to the tcl lists. ##
+## ------------------------------ ##
+_ASBOX
+ ) |
+ sed "s/^/$as_me: WARNING: /" >&2
+ ;;
+esac
+echo "$as_me:$LINENO: checking for unistd.h" >&5
+echo $ECHO_N "checking for unistd.h... $ECHO_C" >&6
+if test "${ac_cv_header_unistd_h+set}" = set; then
+ echo $ECHO_N "(cached) $ECHO_C" >&6
+else
+ ac_cv_header_unistd_h=$ac_header_preproc
+fi
+echo "$as_me:$LINENO: result: $ac_cv_header_unistd_h" >&5
+echo "${ECHO_T}$ac_cv_header_unistd_h" >&6
+
+fi
+if test $ac_cv_header_unistd_h = yes; then
+ usleep_ok=yes
+else
+ usleep_ok=no
+fi
+
+
+ fi
+ echo "$as_me:$LINENO: checking whether to use usleep" >&5
+echo $ECHO_N "checking whether to use usleep... $ECHO_C" >&6
+ if test "$usleep_ok" = "yes"; then
+ if test "${tcl_cv_usleep_h+set}" = set; then
+ echo $ECHO_N "(cached) $ECHO_C" >&6
+else
+
+ cat >conftest.$ac_ext <<_ACEOF
+/* confdefs.h. */
+_ACEOF
+cat confdefs.h >>conftest.$ac_ext
+cat >>conftest.$ac_ext <<_ACEOF
+/* end confdefs.h. */
+#include <unistd.h>
+int
+main ()
+{
+usleep(0);
+ ;
+ return 0;
+}
+_ACEOF
+rm -f conftest.$ac_objext
+if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
+ (eval $ac_compile) 2>conftest.er1
+ ac_status=$?
+ grep -v '^ *+' conftest.er1 >conftest.err
+ rm -f conftest.er1
+ cat conftest.err >&5
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); } &&
+ { ac_try='test -z "$ac_c_werror_flag"
+ || test ! -s conftest.err'
+ { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
+ (eval $ac_try) 2>&5
+ ac_status=$?
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); }; } &&
+ { ac_try='test -s conftest.$ac_objext'
+ { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
+ (eval $ac_try) 2>&5
+ ac_status=$?
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); }; }; then
+ tcl_cv_usleep_h=yes
+else
+ echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+tcl_cv_usleep_h=no
+fi
+rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+fi
+
+ echo "$as_me:$LINENO: result: $tcl_cv_usleep_h" >&5
+echo "${ECHO_T}$tcl_cv_usleep_h" >&6
+ if test $tcl_cv_usleep_h = yes; then
+
+cat >>confdefs.h <<\_ACEOF
+#define HAVE_USLEEP 1
+_ACEOF
+
+ fi
+ else
+ echo "$as_me:$LINENO: result: $usleep_ok" >&5
+echo "${ECHO_T}$usleep_ok" >&6
+ fi
+
+
+#--------------------------------------------------------------------
# Check for support of nl_langinfo function
#--------------------------------------------------------------------
diff --git a/unix/configure.in b/unix/configure.in
index 6c7cc09..9c93024 100644
--- a/unix/configure.in
+++ b/unix/configure.in
@@ -479,6 +479,12 @@ if test $tcl_cv_putenv_copy = yes; then
fi
#--------------------------------------------------------------------
+# Check for support of usleep function
+#--------------------------------------------------------------------
+
+SC_ENABLE_USLEEP
+
+#--------------------------------------------------------------------
# Check for support of nl_langinfo function
#--------------------------------------------------------------------
diff --git a/unix/tcl.m4 b/unix/tcl.m4
index c4e4675..3db997a 100644
--- a/unix/tcl.m4
+++ b/unix/tcl.m4
@@ -808,6 +808,48 @@ AC_DEFUN([SC_ENABLE_SYMBOLS], [
])
#------------------------------------------------------------------------
+# SC_ENABLE_USLEEP --
+#
+# Allows use of usleep function.
+# This is only relevant for Unix.
+#
+# Arguments:
+# none
+#
+# Results:
+#
+# Adds the following arguments to configure:
+# --enable-usleep=yes|no (default is yes)
+#
+# Defines the following vars:
+# HAVE_USLEEP Triggers use of usleep if defined.
+#------------------------------------------------------------------------
+
+AC_DEFUN([SC_ENABLE_USLEEP], [
+ AC_ARG_ENABLE(usleep,
+ AC_HELP_STRING([--enable-usleep],
+ [use usleep if possible to sleep, otherwise use Tcl_Sleep (default: on)]),
+ [usleep_ok=$enableval], [usleep_ok=yes])
+
+ HAVE_USLEEP=0
+ if test "$usleep_ok" = "yes"; then
+ AC_CHECK_HEADER(unistd.h,[usleep_ok=yes],[usleep_ok=no])
+ fi
+ AC_MSG_CHECKING([whether to use usleep])
+ if test "$usleep_ok" = "yes"; then
+ AC_CACHE_VAL(tcl_cv_usleep_h, [
+ AC_TRY_COMPILE([#include <unistd.h>], [usleep(0);],
+ [tcl_cv_usleep_h=yes],[tcl_cv_usleep_h=no])])
+ AC_MSG_RESULT([$tcl_cv_usleep_h])
+ if test $tcl_cv_usleep_h = yes; then
+ AC_DEFINE(HAVE_USLEEP, 1, [Do we have usleep()?])
+ fi
+ else
+ AC_MSG_RESULT([$usleep_ok])
+ fi
+])
+
+#------------------------------------------------------------------------
# SC_ENABLE_LANGINFO --
#
# Allows use of modern nl_langinfo check for better l10n.
diff --git a/unix/tclUnixNotfy.c b/unix/tclUnixNotfy.c
index 8e59044..52f6b55 100644
--- a/unix/tclUnixNotfy.c
+++ b/unix/tclUnixNotfy.c
@@ -303,6 +303,7 @@ Tcl_InitNotifier(void)
* pipe to the original notifier thread
*/
if (notifierCount > 0 && processIDInitialized != getpid()) {
+ Tcl_ConditionFinalize(&notifierCV);
notifierCount = 0;
processIDInitialized = 0;
close(triggerPipe);
@@ -1270,7 +1271,7 @@ NotifierThreadProc(
Tcl_ConditionNotify(&notifierCV);
Tcl_MutexUnlock(&notifierMutex);
- TclpThreadExit (0);
+ TclpThreadExit(0);
}
#if defined(HAVE_PTHREAD_ATFORK) && !defined(__APPLE__) && !defined(__hpux)
@@ -1293,6 +1294,9 @@ NotifierThreadProc(
static void
AtForkPrepare(void)
{
+ Tcl_MutexLock(&notifierMutex);
+ TclpMasterLock();
+ TclpMutexLock();
}
/*
@@ -1314,6 +1318,9 @@ AtForkPrepare(void)
static void
AtForkParent(void)
{
+ TclpMutexUnlock();
+ TclpMasterUnlock();
+ Tcl_MutexUnlock(&notifierMutex);
}
/*
@@ -1335,15 +1342,16 @@ AtForkParent(void)
static void
AtForkChild(void)
{
- notifierMutex = NULL;
- notifierCV = NULL;
+ TclpMutexUnlock();
+ TclpMasterUnlock();
+ TclMutexUnlockAndFinalize(&notifierMutex);
Tcl_InitNotifier();
}
#endif /* HAVE_PTHREAD_ATFORK */
#endif /* TCL_THREADS */
-#endif /* HAVE_COREFOUNDATION */
+#endif /* !HAVE_COREFOUNDATION */
/*
* Local Variables:
diff --git a/unix/tclUnixThrd.c b/unix/tclUnixThrd.c
index d30791d..18b419f 100644
--- a/unix/tclUnixThrd.c
+++ b/unix/tclUnixThrd.c
@@ -21,6 +21,19 @@ typedef struct ThreadSpecificData {
static Tcl_ThreadDataKey dataKey;
/*
+ * This is the number of milliseconds to wait between internal retries in
+ * the Tcl_MutexLock function. This value must be greater than zero and
+ * should be a suitable value for the given platform.
+ *
+ * TODO: This may need to be dynamically determined, based on the relative
+ * performance of the running process.
+ */
+
+#ifndef TCL_MUTEX_LOCK_SLEEP_TIME
+# define TCL_MUTEX_LOCK_SLEEP_TIME (25)
+#endif
+
+/*
* masterLock is used to serialize creation of mutexes, condition variables,
* and thread local storage. This is the only place that can count on the
* ability to statically initialize the mutex.
@@ -44,6 +57,13 @@ static pthread_mutex_t allocLock = PTHREAD_MUTEX_INITIALIZER;
static pthread_mutex_t *allocLockPtr = &allocLock;
/*
+ * The mutexLock serializes Tcl_MutexLock. This is necessary to prevent
+ * races when finalizing a mutex that some other thread may want to lock.
+ */
+
+static pthread_mutex_t mutexLock = PTHREAD_MUTEX_INITIALIZER;
+
+/*
* These are for the critical sections inside this file.
*/
@@ -219,13 +239,13 @@ TclpThreadGetStackSize(void)
#if defined(HAVE_PTHREAD_ATTR_SETSTACKSIZE) && defined(TclpPthreadGetAttrs)
pthread_attr_t threadAttr; /* This will hold the thread attributes for
* the current thread. */
-#ifdef __GLIBC__
+#ifdef __GLIBC__
/*
* Fix for [Bug 1815573]
*
* DESCRIPTION:
* On linux TclpPthreadGetAttrs (which is pthread_attr_get_np) may return
- * bogus values on the initial thread.
+ * bogus values on the initial thread.
*
* ASSUMPTIONS:
* There seems to be no api to determine if we are on the initial
@@ -263,7 +283,7 @@ TclpThreadGetStackSize(void)
}
}
-
+
if (pthread_attr_getstacksize(&threadAttr, &stackSize) != 0) {
pthread_attr_destroy(&threadAttr);
return (size_t)-1;
@@ -274,7 +294,7 @@ TclpThreadGetStackSize(void)
/*
* On Darwin, the API below does not return the correct stack size for the
* main thread (which is not a real pthread), so fallback to getrlimit().
- */
+ */
if (!pthread_main_np())
#endif
stackSize = pthread_get_stacksize_np(pthread_self());
@@ -457,6 +477,58 @@ TclpMasterUnlock(void)
/*
*----------------------------------------------------------------------
*
+ * TclpMutexLock
+ *
+ * This procedure is used to grab a lock that serializes locking
+ * another mutex.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclpMutexLock(void)
+{
+#ifdef TCL_THREADS
+ pthread_mutex_lock(&mutexLock);
+#endif
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclpMutexUnlock
+ *
+ * This procedure is used to release a lock that serializes locking
+ * another mutex.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclpMutexUnlock(void)
+{
+#ifdef TCL_THREADS
+ pthread_mutex_unlock(&mutexLock);
+#endif
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
* Tcl_GetAllocMutex
*
* This procedure returns a pointer to a statically initialized mutex for
@@ -512,6 +584,9 @@ Tcl_MutexLock(
Tcl_Mutex *mutexPtr) /* Really (pthread_mutex_t **) */
{
pthread_mutex_t *pmutexPtr;
+
+retry:
+
if (*mutexPtr == NULL) {
MASTER_LOCK;
if (*mutexPtr == NULL) {
@@ -526,8 +601,32 @@ Tcl_MutexLock(
}
MASTER_UNLOCK;
}
- pmutexPtr = *((pthread_mutex_t **)mutexPtr);
- pthread_mutex_lock(pmutexPtr);
+ while (1) {
+ TclpMutexLock();
+ pmutexPtr = *((pthread_mutex_t **)mutexPtr);
+ if (pmutexPtr == NULL) {
+ TclpMutexUnlock();
+ goto retry;
+ }
+ if (pthread_mutex_trylock(pmutexPtr) == 0) {
+ TclpMutexUnlock();
+ return;
+ }
+ TclpMutexUnlock();
+ /*
+ * BUGBUG: All core and Thread package tests pass when usleep()
+ * is used; however, the Thread package tests hang at
+ * various places when Tcl_Sleep() is used, typically
+ * while running test "thread-17.8", "thread-17.9", or
+ * "thread-17.11a". Really, what we want here is just
+ * to yield to other threads for a while.
+ */
+#ifdef HAVE_USLEEP
+ usleep(TCL_MUTEX_LOCK_SLEEP_TIME * 1000);
+#else
+ Tcl_Sleep(TCL_MUTEX_LOCK_SLEEP_TIME);
+#endif
+ }
}
/*
diff --git a/win/tclWinThrd.c b/win/tclWinThrd.c
index 2413a78..2f2825f 100644
--- a/win/tclWinThrd.c
+++ b/win/tclWinThrd.c
@@ -23,6 +23,16 @@ _CRTIMP unsigned int __cdecl _controlfp (unsigned int unNew, unsigned int unMask
#endif
/*
+ * This is the number of milliseconds to wait between internal retries in
+ * the Tcl_MutexLock function. This value must be greater than or equal
+ * to zero and should be a suitable value for the given platform.
+ */
+
+#ifndef TCL_MUTEX_LOCK_SLEEP_TIME
+# define TCL_MUTEX_LOCK_SLEEP_TIME (0)
+#endif
+
+/*
* This is the master lock used to serialize access to other serialization
* data structures.
*/
@@ -56,6 +66,13 @@ static int allocOnce = 0;
#endif /* TCL_THREADS */
/*
+ * The mutexLock serializes Tcl_MutexLock. This is necessary to prevent
+ * races when finalizing a mutex that some other thread may want to lock.
+ */
+
+static CRITICAL_SECTION mutexLock;
+
+/*
* The joinLock serializes Create- and ExitThread. This is necessary to
* prevent a race where a new joinable thread exits before the creating thread
* had the time to create the necessary data structures in the emulation
@@ -368,6 +385,7 @@ TclpInitLock(void)
*/
init = 1;
+ InitializeCriticalSection(&mutexLock);
InitializeCriticalSection(&joinLock);
InitializeCriticalSection(&initLock);
InitializeCriticalSection(&masterLock);
@@ -463,6 +481,52 @@ TclpMasterUnlock(void)
/*
*----------------------------------------------------------------------
*
+ * TclpMutexLock
+ *
+ * This procedure is used to grab a lock that serializes locking
+ * another mutex.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclpMutexLock(void)
+{
+ EnterCriticalSection(&mutexLock);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclpMutexUnlock
+ *
+ * This procedure is used to release a lock that serializes locking
+ * another mutex.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclpMutexUnlock(void)
+{
+ LeaveCriticalSection(&mutexLock);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* Tcl_GetAllocMutex
*
* This procedure returns a pointer to a statically initialized mutex for
@@ -515,6 +579,7 @@ void
TclFinalizeLock(void)
{
MASTER_LOCK;
+ DeleteCriticalSection(&mutexLock);
DeleteCriticalSection(&joinLock);
/*
@@ -568,6 +633,8 @@ Tcl_MutexLock(
{
CRITICAL_SECTION *csPtr;
+retry:
+
if (*mutexPtr == NULL) {
MASTER_LOCK;
@@ -583,8 +650,20 @@ Tcl_MutexLock(
}
MASTER_UNLOCK;
}
- csPtr = *((CRITICAL_SECTION **)mutexPtr);
- EnterCriticalSection(csPtr);
+ while (1) {
+ TclpMutexLock();
+ csPtr = *((CRITICAL_SECTION **)mutexPtr);
+ if (csPtr == NULL) {
+ TclpMutexUnlock();
+ goto retry;
+ }
+ if (TryEnterCriticalSection(csPtr)) {
+ TclpMutexUnlock();
+ return;
+ }
+ TclpMutexUnlock();
+ Tcl_Sleep(TCL_MUTEX_LOCK_SLEEP_TIME);
+ }
}
/*