Fix bug [57945b574a6df0332efc4ac96b066f7c347b28f7|57945b574a]: lock in forking process under heavy multithreading. Thanks to Joe Mistachkin for the implementation of the fix, and Gustaf Neumann for the original report and testing the fix.

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);
+    }
 }
 
 /*