Further cleanup and enhancements.

doc/Thread.3

@@ -9,7 +9,7 @@
 .so man.macros
 .BS
 .SH NAME
-Tcl_ConditionNotify, Tcl_ConditionWait, Tcl_ConditionFinalize, Tcl_GetThreadData, Tcl_MutexLock, Tcl_MutexUnlock, Tcl_MutexFinalize, Tcl_CreateThread, Tcl_JoinThread \- Tcl thread support
+Tcl_ConditionNotify, Tcl_ConditionWait, Tcl_ConditionFinalize, Tcl_GetThreadData, Tcl_MutexLock, Tcl_MutexUnlock, Tcl_MutexFinalize, Tcl_MutexUnlockAndFinalize, Tcl_CreateThread, Tcl_JoinThread, Tcl_SetMutexWaitProc \- Tcl thread support
 .SH SYNOPSIS
 .nf
 \fB#include <tcl.h>\fR
@@ -35,11 +35,17 @@ void
 void
 \fBTcl_MutexFinalize\fR(\fImutexPtr\fR)
 .sp
+void
+\fBTcl_MutexUnlockAndFinalize\fR(\fImutexPtr\fR)
+.sp
 int
 \fBTcl_CreateThread\fR(\fIidPtr, proc, clientData, stackSize, flags\fR)
 .sp
 int
 \fBTcl_JoinThread\fR(\fIid, result\fR)
+.sp
+Tcl_MutexWaitProc *
+\fBTcl_SetMutexWaitProc\fR(\fIproc\fR)
 .SH ARGUMENTS
 .AS Tcl_CreateThreadProc proc out
 .AP Tcl_Condition *condPtr in
@@ -75,6 +81,16 @@ the new thread.
 .AP int *result out
 The referred storage is used to place the exit code of the thread
 waited upon into it.
+.AP Tcl_MutexWaitProc *proc in
+Procedure to invoke when waiting for a mutex to be unlocked by another
+thread, or (for \fBTcl_SetMutexWaitProc\fR) NULL to uninstall the current
+mutex wait procedure.  The special value \fBTCL_MUTEX_WAIT_NONE\fR can be
+used to indicate that the default mutex wait handling should be disabled
+and no wait procedure should be called.
+.AP int *retry in/out
+The number of times the current mutex lock operation has been retried.
+Initially, this value will be zero.  This value may be modified by the
+current mutex wait procedure.
 .BE
 .SH INTRODUCTION
 Beginning with the 8.1 release, the Tcl core is thread safe, which
@@ -139,11 +155,29 @@ A mutex is a lock that is used to serialize all threads through a piece
 of code by calling \fBTcl_MutexLock\fR and \fBTcl_MutexUnlock\fR.
 If one thread holds a mutex, any other thread calling \fBTcl_MutexLock\fR will
 block until \fBTcl_MutexUnlock\fR is called.
-A mutex can be destroyed after its use by calling \fBTcl_MutexFinalize\fR.
+If \fBTcl_MutexLock\fR is called when the mutex is locked by another thread,
+it will retry the locking operation; if \fBTcl_SetMutexWaitProc\fR is used,
+the configured mutex wait procedure will be called once per retry.
+The \fIProc\fR passed to Tcl_SetMutexWaitProc should match the type
+\fBTcl_MutexWaitProc\fR:
+.PP
+.CS
+typedef void \fBTcl_MutexWaitProc\fR(
+        Tcl_Mutex *\fImutexPtr\fR,
+        int *\fIretry\fR,
+        ClientData \fIclientData\fR);
+.CE
+.PP
+A mutex can be destroyed after its use by calling \fBTcl_MutexFinalize\fR or
+\fBTcl_MutexUnlockAndFinalize\fR.  The \fBTcl_MutexFinalize\fR function may
+only be used on unlocked mutexes; otherwise, its behavior is undefined.  The
+\fBTcl_MutexUnlockAndFinalize\fR function may only be used on locked mutexes;
+otherwise, its behavior is undefined.
 The result of locking a mutex twice from the same thread is undefined.
 On some platforms it will result in a deadlock.
-The \fBTcl_MutexLock\fR, \fBTcl_MutexUnlock\fR and \fBTcl_MutexFinalize\fR
-procedures are defined as empty macros if not compiling with threads enabled.
+The \fBTcl_MutexLock\fR, \fBTcl_MutexUnlock\fR, \fBTcl_MutexFinalize\fR, and
+\fBTcl_MutexUnlockAndFinalize\fR procedures are defined as empty macros if
+not compiling with threads enabled.
 For declaration of mutexes the \fBTCL_DECLARE_MUTEX\fR macro should be used.
 This macro assures correct mutex handling even when the core is compiled
 without threads enabled.
@@ -177,8 +211,8 @@ They are implemented as opaque pointers that should be NULL
 upon first use.
 The mutexes and condition variables are
 either cleaned up by process exit handlers (if living that long) or
-explicitly by calls to \fBTcl_MutexFinalize\fR or
-\fBTcl_ConditionFinalize\fR.
+explicitly by calls to \fBTcl_MutexFinalize\fR (or
+\fBTcl_MutexUnlockAndFinalize\fR) and \fBTcl_ConditionFinalize\fR.
 Thread local storage is reclaimed during \fBTcl_FinalizeThread\fR.
 .SH "SCRIPT-LEVEL ACCESS TO THREADS"
 .PP

generic/tcl.decls

@@ -2326,6 +2326,16 @@ declare 630 {
 
 # ----- BASELINE -- FOR -- 8.6.0 ----- #
 
+# TIP #435 (part 1, atomic mutex unlock-and-finalize)
+declare 631 {
+    void Tcl_MutexUnlockAndFinalize(Tcl_Mutex *mutex)
+}
+
+# TIP #435 (part 2, custom mutex wait handler)
+declare 632 {
+    Tcl_MutexWaitProc *Tcl_SetMutexWaitProc(Tcl_MutexWaitProc *proc)
+}
+
 ##############################################################################
 
 # Define the platform specific public Tcl interface. These functions are only

generic/tcl.h

@@ -112,6 +112,10 @@ extern "C" {
 #define TCL_DECLARE_MUTEX(name)
 #endif
 
+#ifndef TCL_MUTEX_WAIT_NONE
+#define TCL_MUTEX_WAIT_NONE ((Tcl_MutexWaitProc *)(-1))
+#endif
+
 /*
  * Tcl's public routine Tcl_FSSeek() uses the values SEEK_SET, SEEK_CUR, and
  * SEEK_END, all #define'd by stdio.h .
@@ -742,6 +746,8 @@ typedef void (Tcl_EventCheckProc) (ClientData clientData, int flags);
 typedef int (Tcl_EventDeleteProc) (Tcl_Event *evPtr, ClientData clientData);
 typedef void (Tcl_EventSetupProc) (ClientData clientData, int flags);
 typedef void (Tcl_ExitProc) (ClientData clientData);
+typedef void (Tcl_MutexWaitProc) (Tcl_Mutex *mutexPtr, int *retry,
+	ClientData clientData);
 typedef void (Tcl_FileProc) (ClientData clientData, int mask);
 typedef void (Tcl_FileFreeProc) (ClientData clientData);
 typedef void (Tcl_FreeInternalRepProc) (struct Tcl_Obj *objPtr);
@@ -2605,6 +2611,10 @@ EXTERN void		Tcl_GetMemoryInfo(Tcl_DString *dsPtr);
 #define Tcl_MutexLock(mutexPtr)
 #undef  Tcl_MutexUnlock
 #define Tcl_MutexUnlock(mutexPtr)
+#undef  Tcl_MutexUnlockAndFinalize
+#define Tcl_MutexUnlockAndFinalize(mutexPtr)
+#undef  Tcl_SetMutexWaitProc
+#define Tcl_SetMutexWaitProc(mutexPtr, retry, clientData)
 #undef  Tcl_MutexFinalize
 #define Tcl_MutexFinalize(mutexPtr)
 #undef  Tcl_ConditionNotify

generic/tclDecls.h

@@ -1816,6 +1816,10 @@ EXTERN int		Tcl_FSUnloadFile(Tcl_Interp *interp,
 EXTERN void		Tcl_ZlibStreamSetCompressionDictionary(
 				Tcl_ZlibStream zhandle,
 				Tcl_Obj *compressionDictionaryObj);
+/* 631 */
+EXTERN void		Tcl_MutexUnlockAndFinalize(Tcl_Mutex *mutex);
+/* 632 */
+EXTERN Tcl_MutexWaitProc * Tcl_SetMutexWaitProc(Tcl_MutexWaitProc *proc);
 
 typedef struct {
     const struct TclPlatStubs *tclPlatStubs;
@@ -2482,6 +2486,8 @@ typedef struct TclStubs {
     void * (*tcl_FindSymbol) (Tcl_Interp *interp, Tcl_LoadHandle handle, const char *symbol); /* 628 */
     int (*tcl_FSUnloadFile) (Tcl_Interp *interp, Tcl_LoadHandle handlePtr); /* 629 */
     void (*tcl_ZlibStreamSetCompressionDictionary) (Tcl_ZlibStream zhandle, Tcl_Obj *compressionDictionaryObj); /* 630 */
+    void (*tcl_MutexUnlockAndFinalize) (Tcl_Mutex *mutex); /* 631 */
+    Tcl_MutexWaitProc * (*tcl_SetMutexWaitProc) (Tcl_MutexWaitProc *proc); /* 632 */
 } TclStubs;
 
 extern const TclStubs *tclStubsPtr;
@@ -3774,6 +3780,10 @@ extern const TclStubs *tclStubsPtr;
 	(tclStubsPtr->tcl_FSUnloadFile) /* 629 */
 #define Tcl_ZlibStreamSetCompressionDictionary \
 	(tclStubsPtr->tcl_ZlibStreamSetCompressionDictionary) /* 630 */
+#define Tcl_MutexUnlockAndFinalize \
+	(tclStubsPtr->tcl_MutexUnlockAndFinalize) /* 631 */
+#define Tcl_SetMutexWaitProc \
+	(tclStubsPtr->tcl_SetMutexWaitProc) /* 632 */
 
 #endif /* defined(USE_TCL_STUBS) */
 

generic/tclInt.h

@@ -2927,6 +2927,7 @@ MODULE_SCOPE void	TclFinalizePreserve(void);
 MODULE_SCOPE void	TclFinalizeSynchronization(void);
 MODULE_SCOPE void	TclFinalizeThreadAlloc(void);
 MODULE_SCOPE void	TclFinalizeThreadAllocThread(void);
+MODULE_SCOPE Tcl_MutexWaitProc *	TclGetMutexWaitProc(void);
 MODULE_SCOPE void	TclFinalizeThreadData(int quick);
 MODULE_SCOPE void	TclFinalizeThreadObjects(void);
 MODULE_SCOPE double	TclFloor(const mp_int *a);
@@ -3059,6 +3060,10 @@ 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	TclpMutexWait(Tcl_Mutex *mutexPtr, int *retry,
+			    ClientData clientData);
 MODULE_SCOPE int	TclpMatchFiles(Tcl_Interp *interp, char *separators,
 			    Tcl_DString *dirPtr, char *pattern, char *tail);
 MODULE_SCOPE int	TclpObjNormalizePath(Tcl_Interp *interp,

generic/tclStubInit.c

@@ -1412,6 +1412,8 @@ const TclStubs tclStubs = {
     Tcl_FindSymbol, /* 628 */
     Tcl_FSUnloadFile, /* 629 */
     Tcl_ZlibStreamSetCompressionDictionary, /* 630 */
+    Tcl_MutexUnlockAndFinalize, /* 631 */
+    Tcl_SetMutexWaitProc, /* 632 */
 };
 
 /* !END!: Do not edit above this line. */

generic/tclThread.c

@@ -28,6 +28,13 @@ typedef struct {
     void **list;	/* List of pointers */
 } SyncObjRecord;
 
+/*
+ * This holds the mutex wait procedure (TIP #435).  When non-NULL, it will
+ * be called from within Tcl_MutexLock once per retry when attempting to
+ * lock a given mutex.
+ */
+static Tcl_MutexWaitProc *appMutexWaitPtr = NULL;
+
 static SyncObjRecord keyRecord = {0, 0, NULL};
 static SyncObjRecord mutexRecord = {0, 0, NULL};
 static SyncObjRecord condRecord = {0, 0, NULL};
@@ -40,6 +47,13 @@ static void		ForgetSyncObject(void *objPtr, SyncObjRecord *recPtr);
 static void		RememberSyncObject(void *objPtr,
 			    SyncObjRecord *recPtr);
 
+/*
+ * This is a mutex wait procedure that does nothing.
+ */
+
+static void		MutexWaitNone(Tcl_Mutex *mutexPtr, int *retry,
+			    ClientData clientData);
+
 /*
  * Several functions are #defined to nothing in tcl.h if TCL_THREADS is not
  * specified. Here we undo that so the functions are defined in the stubs
@@ -50,6 +64,8 @@ static void		RememberSyncObject(void *objPtr,
 #undef Tcl_MutexLock
 #undef Tcl_MutexUnlock
 #undef Tcl_MutexFinalize
+#undef Tcl_MutexUnlockAndFinalize
+#undef Tcl_SetMutexWaitProc
 #undef Tcl_ConditionNotify
 #undef Tcl_ConditionWait
 #undef Tcl_ConditionFinalize
@@ -281,6 +297,88 @@ Tcl_MutexFinalize(
     TclpMasterUnlock();
 }
 
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_MutexUnlockAndFinalize --
+ *
+ *	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
+Tcl_MutexUnlockAndFinalize(
+    Tcl_Mutex *mutexPtr)
+{
+#ifdef TCL_THREADS
+    Tcl_Mutex mutex;
+#endif
+    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();
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_SetMutexWaitProc --
+ *
+ *	This function sets the application wide mutex wait handler that
+ *	will be called by Tcl_MutexLock once per retry to obtain a lock
+ *	on a given mutex.  If the mutex wait handler is NULL, the default
+ *	mutex wait handling is used, which may involve sleeping.
+ *
+ * Results:
+ *	The previously set application wide mutex wait handler.
+ *
+ * Side effects:
+ *	Sets the application wide mutex wait handler to the specified
+ *	value.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_MutexWaitProc *
+Tcl_SetMutexWaitProc(
+    Tcl_MutexWaitProc *proc)	/* New mutex wait handler for app or NULL */
+{
+    Tcl_MutexWaitProc *prevMutexWaitProc;
+
+    /*
+     * Swap the old mutex wait proc for the new one, saving the old one
+     * for our return value.
+     */
+
+    TclpMasterLock();
+    prevMutexWaitProc = appMutexWaitPtr;
+    if (proc != TCL_MUTEX_WAIT_NONE) {
+	appMutexWaitPtr = proc;
+    } else {
+	appMutexWaitPtr = MutexWaitNone;
+    }
+    TclpMasterUnlock();
+
+    return prevMutexWaitProc;
+}
+
 /*
  *----------------------------------------------------------------------
  *
@@ -334,6 +432,59 @@ Tcl_ConditionFinalize(
     TclpMasterUnlock();
 }
 
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclGetMutexWaitProc --
+ *
+ *	This function returns the application wide mutex wait handler.
+ *
+ * Results:
+ *	The application wide mutex wait handler, which may be NULL.
+ *
+ * Side effects:
+ *	None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_MutexWaitProc *TclGetMutexWaitProc(void)
+{
+    Tcl_MutexWaitProc *mutexWaitProc;
+
+    TclpMasterLock();
+    mutexWaitProc = appMutexWaitPtr;
+    TclpMasterUnlock();
+
+    return mutexWaitProc;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * MutexWaitNone --
+ *
+ *	This function is a Tcl_MutexWaitProc that never waits (i.e. it
+ *	is a noop).
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+MutexWaitNone(
+    Tcl_Mutex *mutexPtr,	/* Mutex passed to Tcl_MutexLock. */
+    int *retry,			/* The number of retries so far. */
+    ClientData clientData)	/* The extra data, if any. */
+{
+    /* Do nothing. */
+}
+
 /*
  *----------------------------------------------------------------------
  *

generic/tclThreadTest.c

@@ -190,6 +190,7 @@ TclThread_Init(
  *	thread event
  *	thread exit
  *	thread id ?-main?
+ *	thread mutexwait enable
  *	thread names
  *	thread wait
  *	thread errorproc proc
@@ -216,13 +217,13 @@ ThreadObjCmd(
     int option;
     static const char *const threadOptions[] = {
 	"cancel", "create", "event", "exit", "id",
-	"join", "names", "send", "wait", "errorproc",
-	NULL
+	"join", "mutexwait", "names", "send", "wait",
+	"errorproc", NULL
     };
     enum options {
 	THREAD_CANCEL, THREAD_CREATE, THREAD_EVENT, THREAD_EXIT,
-	THREAD_ID, THREAD_JOIN, THREAD_NAMES, THREAD_SEND,
-	THREAD_WAIT, THREAD_ERRORPROC
+	THREAD_ID, THREAD_JOIN, THREAD_MUTEXWAIT, THREAD_NAMES,
+	THREAD_SEND, THREAD_WAIT, THREAD_ERRORPROC
     };
 
     if (objc < 2) {
@@ -377,6 +378,20 @@ ThreadObjCmd(
 	}
 	return result;
     }
+    case THREAD_MUTEXWAIT: {
+	int boolValue;
+	Tcl_MutexWaitProc *proc;
+	if (objc != 3) {
+	    Tcl_WrongNumArgs(interp, 2, objv, "enable");
+	    return TCL_ERROR;
+	}
+	if (Tcl_GetBooleanFromObj(interp, objv[2], &boolValue) != TCL_OK) {
+	    return TCL_ERROR;
+	}
+	proc = Tcl_SetMutexWaitProc(boolValue ? NULL : TCL_MUTEX_WAIT_NONE);
+	Tcl_SetObjResult(interp, Tcl_NewIntObj((proc == NULL) ? 1 : 0));
+	return TCL_OK;
+    }
     case THREAD_NAMES:
 	if (objc > 2) {
 	    Tcl_WrongNumArgs(interp, 2, objv, NULL);

tests/thread.test

@@ -1438,6 +1438,21 @@ test thread-8.1 {threaded fork stress} -constraints {thread} -setup {
     unset -nocomplain ::threadCount ::execCount ::threads ::thread
 } -result {}
 
+test thread-9.1 {mutex wait procedure} -constraints {testthread} -setup {
+    unset -nocomplain res
+} -body {
+    catch {testthread mutexwait} res(1)
+    catch {testthread mutexwait 0 0} res(2)
+    catch {testthread mutexwait 0} res(3)
+    catch {testthread mutexwait 1} res(4)
+    catch {testthread mutexwait 0} res(5)
+    catch {testthread mutexwait 1} res(6)
+    list $res(1) $res(2) $res(3) $res(4) $res(5) $res(6)
+} -cleanup {
+    unset -nocomplain res
+} -result {{wrong # args: should be "testthread mutexwait enable"} {wrong #\
+args: should be "testthread mutexwait enable"} 1 0 1 0}
+
 # cleanup
 ::tcltest::cleanupTests
 return

unix/tclUnixNotfy.c

@@ -1,5 +1,3 @@
-#define AT_FORK_INIT_VALUE 0
-#define RESET_ATFORK_MUTEX 1
 /*
  * tclUnixNotify.c --
  *
@@ -99,11 +97,10 @@ typedef struct ThreadSpecificData {
 	 * by sending this event. */
     void *hwnd;			/* Messaging window. */
 #else /* !__CYGWIN__ */
-    pthread_cond_t waitCV;	/* Any other thread alerts a notifier that an
+    Tcl_Condition waitCV;	/* Any other thread alerts a notifier that an
 				 * event is ready to be processed by signaling
 				 * this condition variable. */
 #endif /* __CYGWIN__ */
-    int waitCVinitialized;	/* Variable to flag initialization of the structure */
     int eventReady;		/* True if an event is ready to be processed.
 				 * Used as condition flag together with waitCV
 				 * above. */
@@ -122,6 +119,15 @@ static Tcl_ThreadDataKey dataKey;
 
 static int notifierCount = 0;
 
+/*
+ * The following static stores the process ID of the initialized notifier
+ * thread. If it changes, we have passed a fork and we should start a new
+ * notifier thread.
+ *
+ * You must hold the notifierMutex lock before accessing this variable.
+ */
+static pid_t processIDInitialized = 0;
+
 /*
  * The following variable points to the head of a doubly-linked list of
  * ThreadSpecificData structures for all threads that are currently waiting on
@@ -152,15 +158,7 @@ static int triggerPipe = -1;
  * The notifierMutex locks access to all of the global notifier state.
  */
 
-pthread_mutex_t notifierInitMutex = PTHREAD_MUTEX_INITIALIZER;
-pthread_mutex_t notifierMutex     = PTHREAD_MUTEX_INITIALIZER;
-/*
- * The following static indicates if the notifier thread is running.
- *
- * You must hold the notifierInitMutex before accessing this variable.
- */
-
-static int notifierThreadRunning = 0;
+TCL_DECLARE_MUTEX(notifierMutex)
 
 /*
  * The notifier thread signals the notifierCV when it has finished
@@ -168,7 +166,7 @@ static int notifierThreadRunning = 0;
  * terminates.
  */
 
-static pthread_cond_t notifierCV = PTHREAD_COND_INITIALIZER;
+static Tcl_Condition notifierCV;
 
 /*
  * The pollState bits
@@ -196,15 +194,15 @@ static Tcl_ThreadId notifierThread;
 
 #ifdef TCL_THREADS
 static void	NotifierThreadProc(ClientData clientData);
-#if defined(HAVE_PTHREAD_ATFORK)
-static int	atForkInit = AT_FORK_INIT_VALUE;
+#if defined(HAVE_PTHREAD_ATFORK) && !defined(__APPLE__) && !defined(__hpux)
+static int	atForkInit = 0;
 static void	AtForkPrepare(void);
 static void	AtForkParent(void);
 static void	AtForkChild(void);
 #endif /* HAVE_PTHREAD_ATFORK */
 #endif /* TCL_THREADS */
 static int	FileHandlerEventProc(Tcl_Event *evPtr, int flags);
-
+
 /*
  * Import of Windows API when building threaded with Cygwin.
  */
@@ -253,58 +251,13 @@ extern unsigned char __stdcall	ResetEvent(void *);
 extern unsigned char __stdcall	TranslateMessage(const MSG *);
 
 /*
- * Threaded-cygwin specific constants and functions in this file:
+ * Threaded-cygwin specific functions in this file:
  */
 
-static const WCHAR NotfyClassName[] = L"TclNotifier";
 static DWORD __stdcall	NotifierProc(void *hwnd, unsigned int message,
 			    void *wParam, void *lParam);
 #endif /* TCL_THREADS && __CYGWIN__ */
 
-#if TCL_THREADS
-/*
- *----------------------------------------------------------------------
- *
- * StartNotifierThread --
- *
- *	Start a notfier thread and wait for the notifier pipe to be created.
- *
- * Results:
- *	None.
- *
- * Side effects:
- *	Running Thread.
- *
- *----------------------------------------------------------------------
- */
-static void
-StartNotifierThread(const char *proc)
-{
-    if (!notifierThreadRunning) {
-	pthread_mutex_lock(&notifierInitMutex);
-	if (!notifierThreadRunning) {
-	    if (TclpThreadCreate(&notifierThread, NotifierThreadProc, NULL,
-		    TCL_THREAD_STACK_DEFAULT, TCL_THREAD_JOINABLE) != TCL_OK) {
-		Tcl_Panic("%s: unable to start notifier thread", proc);
-	    }
-
-	    pthread_mutex_lock(&notifierMutex);
-	    /*
-	     * Wait for the notifier pipe to be created.
-	     */
-
-	    while (triggerPipe < 0) {
-		pthread_cond_wait(&notifierCV, &notifierMutex);
-	    }
-	    pthread_mutex_unlock(&notifierMutex);
-
-	    notifierThreadRunning = 1;
-	}
-	pthread_mutex_unlock(&notifierInitMutex);
-    }
-}
-#endif /* TCL_THREADS */
-
 /*
  *----------------------------------------------------------------------
  *
@@ -333,39 +286,13 @@ Tcl_InitNotifier(void)
 	tsdPtr->eventReady = 0;
 
 	/*
-	 * Initialize thread specific condition variable for this thread.
+	 * Start the Notifier thread if necessary.
 	 */
-	if (tsdPtr->waitCVinitialized == 0) {
-#ifdef __CYGWIN__
-	    WNDCLASS class;
 
-	    class.style = 0;
-	    class.cbClsExtra = 0;
-	    class.cbWndExtra = 0;
-	    class.hInstance = TclWinGetTclInstance();
-	    class.hbrBackground = NULL;
-	    class.lpszMenuName = NULL;
-	    class.lpszClassName = NotfyClassName;
-	    class.lpfnWndProc = NotifierProc;
-	    class.hIcon = NULL;
-	    class.hCursor = NULL;
-
-	    RegisterClassW(&class);
-	    tsdPtr->hwnd = CreateWindowExW(NULL, class.lpszClassName,
-		    class.lpszClassName, 0, 0, 0, 0, 0, NULL, NULL,
-		    TclWinGetTclInstance(), NULL);
-	    tsdPtr->event = CreateEventW(NULL, 1 /* manual */,
-		    0 /* !signaled */, NULL);
-#else
-	    pthread_cond_init(&tsdPtr->waitCV, NULL);
-#endif /* __CYGWIN__ */
-	    tsdPtr->waitCVinitialized = 1;
-	}
-
-	pthread_mutex_lock(&notifierInitMutex);
-#if defined(HAVE_PTHREAD_ATFORK)
+	Tcl_MutexLock(&notifierMutex);
+#if defined(HAVE_PTHREAD_ATFORK) && !defined(__APPLE__) && !defined(__hpux)
 	/*
-	 * Install pthread_atfork handlers to clean up the notifier in the
+	 * Install pthread_atfork handlers to reinitialize the notifier in the
 	 * child of a fork.
 	 */
 
@@ -378,11 +305,36 @@ Tcl_InitNotifier(void)
 	    atForkInit = 1;
 	}
 #endif /* HAVE_PTHREAD_ATFORK */
-
+	/*
+	 * Check if my process id changed, e.g. I was forked
+	 * In this case, restart the notifier thread and close the
+	 * pipe to the original notifier thread
+	 */
+	if (notifierCount > 0 && processIDInitialized != getpid()) {
+	    Tcl_ConditionFinalize(&notifierCV);
+	    notifierCount = 0;
+	    processIDInitialized = 0;
+	    close(triggerPipe);
+	    triggerPipe = -1;
+	}
+	if (notifierCount == 0) {
+	    if (TclpThreadCreate(&notifierThread, NotifierThreadProc, NULL,
+		    TCL_THREAD_STACK_DEFAULT, TCL_THREAD_JOINABLE) != TCL_OK) {
+		Tcl_Panic("Tcl_InitNotifier: unable to start notifier thread");
+	    }
+	    processIDInitialized = getpid();
+	}
 	notifierCount++;
 
-	pthread_mutex_unlock(&notifierInitMutex);
+	/*
+	 * Wait for the notifier pipe to be created.
+	 */
 
+	while (triggerPipe < 0) {
+	    Tcl_ConditionWait(&notifierCV, &notifierMutex, NULL);
+	}
+
+	Tcl_MutexUnlock(&notifierMutex);
 #endif /* TCL_THREADS */
 	return tsdPtr;
     }
@@ -417,7 +369,7 @@ Tcl_FinalizeNotifier(
 #ifdef TCL_THREADS
 	ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
 
-	pthread_mutex_lock(&notifierInitMutex);
+	Tcl_MutexLock(&notifierMutex);
 	notifierCount--;
 
 	/*
@@ -426,25 +378,37 @@ Tcl_FinalizeNotifier(
 	 */
 
 	if (notifierCount == 0) {
+	    int result;
 
-	    if (triggerPipe != -1) {
-		if (write(triggerPipe, "q", 1) != 1) {
-		    Tcl_Panic("Tcl_FinalizeNotifier: %s",
-			    "unable to write q to triggerPipe");
-		}
-		close(triggerPipe);
-		while(triggerPipe != -1) {
-		    pthread_cond_wait(&notifierCV, &notifierMutex);
-		}
-		if (notifierThreadRunning) {
-		    int result = pthread_join((pthread_t) notifierThread, NULL);
+	    if (triggerPipe < 0) {
+		Tcl_Panic("Tcl_FinalizeNotifier: %s",
+			"notifier pipe not initialized");
+	    }
 
-		    if (result) {
-			Tcl_Panic("Tcl_FinalizeNotifier: unable to join notifier "
-				"thread");
-		    }
-		    notifierThreadRunning = 0;
-		}
+	    /*
+	     * Send "q" message to the notifier thread so that it will
+	     * terminate. The notifier will return from its call to select()
+	     * and notice that a "q" message has arrived, it will then close
+	     * its side of the pipe and terminate its thread. Note the we can
+	     * not just close the pipe and check for EOF in the notifier thread
+	     * because if a background child process was created with exec,
+	     * select() would not register the EOF on the pipe until the child
+	     * processes had terminated. [Bug: 4139] [Bug: 1222872]
+	     */
+
+	    if (write(triggerPipe, "q", 1) != 1) {
+		Tcl_Panic("Tcl_FinalizeNotifier: %s",
+			"unable to write q to triggerPipe");
+	    }
+	    close(triggerPipe);
+	    while(triggerPipe >= 0) {
+		Tcl_ConditionWait(&notifierCV, &notifierMutex, NULL);
+	    }
+
+	    result = Tcl_JoinThread(notifierThread, NULL);
+	    if (result) {
+		Tcl_Panic("Tcl_FinalizeNotifier: %s",
+			"unable to join notifier thread");
 	    }
 	}
 
@@ -453,14 +417,12 @@ Tcl_FinalizeNotifier(
 	 */
 
 #ifdef __CYGWIN__
-	DestroyWindow(tsdPtr->hwnd);
 	CloseHandle(tsdPtr->event);
 #else /* __CYGWIN__ */
-	pthread_cond_destroy(&tsdPtr->waitCV);
+	Tcl_ConditionFinalize(&(tsdPtr->waitCV));
 #endif /* __CYGWIN__ */
-	tsdPtr->waitCVinitialized = 0;
 
-	pthread_mutex_unlock(&notifierInitMutex);
+	Tcl_MutexUnlock(&notifierMutex);
 #endif /* TCL_THREADS */
     }
 }
@@ -495,15 +457,14 @@ Tcl_AlertNotifier(
 #ifdef TCL_THREADS
 	ThreadSpecificData *tsdPtr = clientData;
 
-	pthread_mutex_lock(&notifierMutex);
+	Tcl_MutexLock(&notifierMutex);
 	tsdPtr->eventReady = 1;
-
 #   ifdef __CYGWIN__
 	PostMessageW(tsdPtr->hwnd, 1024, 0, 0);
 #   else
-	pthread_cond_broadcast(&tsdPtr->waitCV);
+	Tcl_ConditionNotify(&tsdPtr->waitCV);
 #   endif /* __CYGWIN__ */
-	pthread_mutex_unlock(&notifierMutex);
+	Tcl_MutexUnlock(&notifierMutex);
 #endif /* TCL_THREADS */
     }
 }
@@ -566,10 +527,8 @@ Tcl_ServiceModeHook(
     if (tclNotifierHooks.serviceModeHookProc) {
 	tclNotifierHooks.serviceModeHookProc(mode);
 	return;
-    } else if (mode == TCL_SERVICE_ALL) {
-#if TCL_THREADS
-	StartNotifierThread("Tcl_ServiceModeHook");
-#endif
+    } else {
+	/* Does nothing in this implementation. */
     }
 }
 
@@ -782,7 +741,6 @@ FileHandlerEventProc(
      */
 
     tsdPtr = TCL_TSD_INIT(&dataKey);
-
     for (filePtr = tsdPtr->firstFileHandlerPtr; filePtr != NULL;
 	    filePtr = filePtr->nextPtr) {
 	if (filePtr->fd != fileEvPtr->fd) {
@@ -920,13 +878,35 @@ Tcl_WaitForEvent(
 
 #ifdef TCL_THREADS
 	/*
-	 * Start notifier thread and place this thread on the list of
-	 * interested threads, signal the notifier thread, and wait for a
-	 * response or a timeout.
+	 * Place this thread on the list of interested threads, signal the
+	 * notifier thread, and wait for a response or a timeout.
 	 */
-	StartNotifierThread("Tcl_WaitForEvent");
 
-	pthread_mutex_lock(&notifierMutex);
+#ifdef __CYGWIN__
+	if (!tsdPtr->hwnd) {
+	    WNDCLASS class;
+
+	    class.style = 0;
+	    class.cbClsExtra = 0;
+	    class.cbWndExtra = 0;
+	    class.hInstance = TclWinGetTclInstance();
+	    class.hbrBackground = NULL;
+	    class.lpszMenuName = NULL;
+	    class.lpszClassName = L"TclNotifier";
+	    class.lpfnWndProc = NotifierProc;
+	    class.hIcon = NULL;
+	    class.hCursor = NULL;
+
+	    RegisterClassW(&class);
+	    tsdPtr->hwnd = CreateWindowExW(NULL, class.lpszClassName,
+		    class.lpszClassName, 0, 0, 0, 0, 0, NULL, NULL,
+		    TclWinGetTclInstance(), NULL);
+	    tsdPtr->event = CreateEventW(NULL, 1 /* manual */,
+		    0 /* !signaled */, NULL);
+	}
+#endif /* __CYGWIN */
+
+	Tcl_MutexLock(&notifierMutex);
 
 	if (timePtr != NULL && timePtr->sec == 0 && (timePtr->usec == 0
 #if defined(__APPLE__) && defined(__LP64__)
@@ -991,23 +971,12 @@ Tcl_WaitForEvent(
 		} else {
 		    timeout = 0xFFFFFFFF;
 		}
-		pthread_mutex_unlock(&notifierMutex);
+		Tcl_MutexUnlock(&notifierMutex);
 		MsgWaitForMultipleObjects(1, &tsdPtr->event, 0, timeout, 1279);
-		pthread_mutex_lock(&notifierMutex);
+		Tcl_MutexLock(&notifierMutex);
 	    }
 #else
-	    if (timePtr != NULL) {
-	       Tcl_Time now;
-	       struct timespec ptime;
-
-	       Tcl_GetTime(&now);
-	       ptime.tv_sec = timePtr->sec + now.sec + (timePtr->usec + now.usec) / 1000000;
-	       ptime.tv_nsec = 1000 * ((timePtr->usec + now.usec) % 1000000);
-
-	       pthread_cond_timedwait(&tsdPtr->waitCV, &notifierMutex, &ptime);
-	    } else {
-	       pthread_cond_wait(&tsdPtr->waitCV, &notifierMutex);
-	    }
+	    Tcl_ConditionWait(&tsdPtr->waitCV, &notifierMutex, timePtr);
 #endif /* __CYGWIN__ */
 	}
 	tsdPtr->eventReady = 0;
@@ -1110,7 +1079,7 @@ Tcl_WaitForEvent(
 	    filePtr->readyMask = mask;
 	}
 #ifdef TCL_THREADS
-	pthread_mutex_unlock(&notifierMutex);
+	Tcl_MutexUnlock(&notifierMutex);
 #endif /* TCL_THREADS */
 	return 0;
     }
@@ -1182,15 +1151,15 @@ NotifierThreadProc(
      * Install the write end of the pipe into the global variable.
      */
 
-    pthread_mutex_lock(&notifierMutex);
+    Tcl_MutexLock(&notifierMutex);
     triggerPipe = fds[1];
 
     /*
      * Signal any threads that are waiting.
      */
 
-    pthread_cond_broadcast(&notifierCV);
-    pthread_mutex_unlock(&notifierMutex);
+    Tcl_ConditionNotify(&notifierCV);
+    Tcl_MutexUnlock(&notifierMutex);
 
     /*
      * Look for file events and report them to interested threads.
@@ -1206,7 +1175,7 @@ NotifierThreadProc(
 	 * notifiers.
 	 */
 
-	pthread_mutex_lock(&notifierMutex);
+	Tcl_MutexLock(&notifierMutex);
 	timePtr = NULL;
 	for (tsdPtr = waitingListPtr; tsdPtr; tsdPtr = tsdPtr->nextPtr) {
 	    for (i = tsdPtr->numFdBits-1; i >= 0; --i) {
@@ -1233,7 +1202,7 @@ NotifierThreadProc(
 		timePtr = &poll;
 	    }
 	}
-	pthread_mutex_unlock(&notifierMutex);
+	Tcl_MutexUnlock(&notifierMutex);
 
 	/*
 	 * Set up the select mask to include the receive pipe.
@@ -1257,7 +1226,7 @@ NotifierThreadProc(
 	 * Alert any threads that are waiting on a ready file descriptor.
 	 */
 
-	pthread_mutex_lock(&notifierMutex);
+	Tcl_MutexLock(&notifierMutex);
 	for (tsdPtr = waitingListPtr; tsdPtr; tsdPtr = tsdPtr->nextPtr) {
 	    found = 0;
 
@@ -1303,12 +1272,12 @@ NotifierThreadProc(
 		}
 #ifdef __CYGWIN__
 		PostMessageW(tsdPtr->hwnd, 1024, 0, 0);
-#else /* __CYGWIN__ */
-		pthread_cond_broadcast(&tsdPtr->waitCV);
+#else
+		Tcl_ConditionNotify(&tsdPtr->waitCV);
 #endif /* __CYGWIN__ */
 	    }
 	}
-	pthread_mutex_unlock(&notifierMutex);
+	Tcl_MutexUnlock(&notifierMutex);
 
 	/*
 	 * Consume the next byte from the notifier pipe if the pipe was
@@ -1337,15 +1306,15 @@ NotifierThreadProc(
      */
 
     close(receivePipe);
-    pthread_mutex_lock(&notifierMutex);
+    Tcl_MutexLock(&notifierMutex);
     triggerPipe = -1;
-    pthread_cond_broadcast(&notifierCV);
-    pthread_mutex_unlock(&notifierMutex);
+    Tcl_ConditionNotify(&notifierCV);
+    Tcl_MutexUnlock(&notifierMutex);
 
     TclpThreadExit(0);
 }
 
-#if defined(HAVE_PTHREAD_ATFORK)
+#if defined(HAVE_PTHREAD_ATFORK) && !defined(__APPLE__) && !defined(__hpux)
 /*
  *----------------------------------------------------------------------
  *
@@ -1365,9 +1334,9 @@ NotifierThreadProc(
 static void
 AtForkPrepare(void)
 {
-#if RESET_ATFORK_MUTEX == 0
-    pthread_mutex_lock(&notifierInitMutex);
-#endif
+    Tcl_MutexLock(&notifierMutex);
+    TclpMasterLock();
+    TclpMutexLock();
 }
 
 /*
@@ -1389,9 +1358,9 @@ AtForkPrepare(void)
 static void
 AtForkParent(void)
 {
-#if RESET_ATFORK_MUTEX == 0
-    pthread_mutex_unlock(&notifierInitMutex);
-#endif
+    TclpMutexUnlock();
+    TclpMasterUnlock();
+    Tcl_MutexUnlock(&notifierMutex);
 }
 
 /*
@@ -1413,67 +1382,9 @@ AtForkParent(void)
 static void
 AtForkChild(void)
 {
-    if (notifierThreadRunning == 1) {
-	pthread_cond_destroy(&notifierCV);
-    }
-#if RESET_ATFORK_MUTEX == 0
-    pthread_mutex_unlock(&notifierInitMutex);
-#else
-    pthread_mutex_init(&notifierInitMutex, NULL);
-    pthread_mutex_init(&notifierMutex, NULL);
-#endif
-    pthread_cond_init(&notifierCV, NULL);
-
-    /*
-     * notifierThreadRunning == 1: thread is running, (there might be data in notifier lists)
-     * atForkInit == 0: InitNotifier was never called
-     * notifierCount != 0: unbalanced  InitNotifier() / FinalizeNotifier calls
-     * waitingListPtr != 0: there are threads currently waiting for events.
-     */
-
-    if (atForkInit == 1) {
-
-	notifierCount = 0;
-	if (notifierThreadRunning == 1) {
-	    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
-	    notifierThreadRunning = 0;
-
-	    close(triggerPipe);
-	    triggerPipe = -1;
-	    /*
-	     * The waitingListPtr might contain event info from multiple
-	     * threads, which are invalid here, so setting it to NULL is not
-	     * unreasonable.
-	     */
-	    waitingListPtr = NULL;
-
-	    /*
-	     * The tsdPtr from before the fork is copied as well.  But since
-	     * we are paranoic, we don't trust its condvar and reset it.
-	     */
-#ifdef __CYGWIN__
-	    DestroyWindow(tsdPtr->hwnd);
-	    tsdPtr->hwnd = CreateWindowExW(NULL, NotfyClassName,
-		    NotfyClassName, 0, 0, 0, 0, 0, NULL, NULL,
-		    TclWinGetTclInstance(), NULL);
-	    ResetEvent(tsdPtr->event);
-#else
-	    pthread_cond_destroy(&tsdPtr->waitCV);
-	    pthread_cond_init(&tsdPtr->waitCV, NULL);
-#endif
-	    /*
-	     * In case, we had multiple threads running before the fork,
-	     * make sure, we don't try to reach out to their thread local data.
-	     */
-	    tsdPtr->nextPtr = tsdPtr->prevPtr = NULL;
-
-	    /*
-	     * The list of registered event handlers at fork time is in
-	     * tsdPtr->firstFileHandlerPtr;
-	     */
-	}
-    }
-
+    TclpMutexUnlock();
+    TclpMasterUnlock();
+    Tcl_MutexUnlockAndFinalize(&notifierMutex);
     Tcl_InitNotifier();
 }
 #endif /* HAVE_PTHREAD_ATFORK */

unix/tclUnixThrd.c

@@ -21,6 +21,31 @@ typedef struct ThreadSpecificData {
 
 static Tcl_ThreadDataKey dataKey;
 
+/*
+ * This is the base 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.  It may be multiplied
+ * by an integer of zero or more, depending on how many times the delay has
+ * already been performed.
+ *
+ * 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	(10)
+#endif
+
+/*
+ * This is the number of retries before resetting the retry count to zero.
+ * It is multiplied with TCL_MUTEX_LOCK_SLEEP_TIME in order to obtain the
+ * number of milliseconds to sleep.
+ */
+
+#ifndef TCL_MUTEX_LOCK_RESET_LIMIT
+#  define TCL_MUTEX_LOCK_RESET_LIMIT	(10)
+#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
@@ -44,6 +69,13 @@ static pthread_mutex_t initLock = PTHREAD_MUTEX_INITIALIZER;
 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.
  */
@@ -360,6 +392,59 @@ TclpMasterUnlock(void)
     pthread_mutex_unlock(&masterLock);
 #endif
 }
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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
+}
+
 
 /*
  *----------------------------------------------------------------------
@@ -393,6 +478,49 @@ Tcl_GetAllocMutex(void)
 
 #ifdef TCL_THREADS
 
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclpMutexWait
+ *
+ *	This procedure is used to delay for a short interval while
+ *	waiting for a mutex to be unlocked by another thread.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	The value of the retry parameter is changed.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclpMutexWait(
+    Tcl_Mutex *mutexPtr,	/* Mutex passed to Tcl_MutexLock. */
+    int *retry,			/* The number of retries so far. */
+    ClientData clientData)	/* The extra data, if any. */
+{
+    int nRetry = (retry != NULL) ? *retry : 0;
+    if (nRetry > TCL_MUTEX_LOCK_RESET_LIMIT) {
+	nRetry = 0;
+    }
+    /*
+     * 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 * nRetry);
+#else
+    Tcl_Sleep(TCL_MUTEX_LOCK_SLEEP_TIME * nRetry);
+#endif
+    if (retry != NULL) *retry = nRetry;
+}
+
 /*
  *----------------------------------------------------------------------
  *
@@ -419,6 +547,10 @@ Tcl_MutexLock(
     Tcl_Mutex *mutexPtr)	/* Really (pthread_mutex_t **) */
 {
     pthread_mutex_t *pmutexPtr;
+    Tcl_MutexWaitProc *mutexWaitProc;
+    int nRetry = 0; /* NOTE: Hopefully, zero milliseconds means "yield". */
+
+retry:
 
     if (*mutexPtr == NULL) {
 	MASTER_LOCK;
@@ -434,8 +566,26 @@ 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();
+	mutexWaitProc = TclGetMutexWaitProc();
+	if (mutexWaitProc != NULL) {
+	    mutexWaitProc(mutexPtr, &nRetry, NULL);
+	} else {
+	    TclpMutexWait(mutexPtr, &nRetry, NULL);
+	}
+	nRetry++;
+    }
 }
 
 /*

win/tclWinThrd.c

@@ -23,6 +23,28 @@
 _CRTIMP unsigned int __cdecl _controlfp (unsigned int unNew, unsigned int unMask);
 #endif
 
+/*
+ * This is the base 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.  It may
+ * be multiplied by an integer of zero or more, depending on how many times
+ * the delay has already been performed.
+ */
+
+#ifndef TCL_MUTEX_LOCK_SLEEP_TIME
+#  define TCL_MUTEX_LOCK_SLEEP_TIME	(0)
+#endif
+
+/*
+ * This is the number of retries before resetting the retry count to zero.
+ * It is multiplied with TCL_MUTEX_LOCK_SLEEP_TIME in order to obtain the
+ * number of milliseconds to sleep.
+ */
+
+#ifndef TCL_MUTEX_LOCK_RESET_LIMIT
+#  define TCL_MUTEX_LOCK_RESET_LIMIT	(10)
+#endif
+
 /*
  * This is the master lock used to serialize access to other serialization
  * data structures.
@@ -56,6 +78,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
@@ -369,6 +398,7 @@ TclpInitLock(void)
 	 */
 
 	init = 1;
+	InitializeCriticalSection(&mutexLock);
 	InitializeCriticalSection(&joinLock);
 	InitializeCriticalSection(&initLock);
 	InitializeCriticalSection(&masterLock);
@@ -461,6 +491,52 @@ TclpMasterUnlock(void)
     LeaveCriticalSection(&masterLock);
 }
 
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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);
+}
+
 /*
  *----------------------------------------------------------------------
  *
@@ -516,6 +592,7 @@ void
 TclFinalizeLock(void)
 {
     MASTER_LOCK;
+    DeleteCriticalSection(&mutexLock);
     DeleteCriticalSection(&joinLock);
 
     /*
@@ -546,6 +623,37 @@ TclFinalizeLock(void)
 /* locally used prototype */
 static void		FinalizeConditionEvent(ClientData data);
 
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclpMutexWait
+ *
+ *	This procedure is used to delay for a short interval while
+ *	waiting for a mutex to be unlocked by another thread.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	The value of the retry parameter is changed.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclpMutexWait(
+    Tcl_Mutex *mutexPtr,	/* Mutex passed to Tcl_MutexLock. */
+    int *retry,			/* The number of retries so far. */
+    ClientData clientData)	/* The extra data, if any. */
+{
+    int nRetry = (retry != NULL) ? *retry : 0;
+    if (nRetry > TCL_MUTEX_LOCK_RESET_LIMIT) {
+	nRetry = 0;
+    }
+    Tcl_Sleep(TCL_MUTEX_LOCK_SLEEP_TIME * nRetry);
+    if (retry != NULL) *retry = nRetry;
+}
+
 /*
  *----------------------------------------------------------------------
  *
@@ -568,6 +676,10 @@ Tcl_MutexLock(
     Tcl_Mutex *mutexPtr)	/* The lock */
 {
     CRITICAL_SECTION *csPtr;
+    Tcl_MutexWaitProc *mutexWaitProc;
+    int nRetry = 0; /* NOTE: Hopefully, zero milliseconds means "yield". */
+
+retry:
 
     if (*mutexPtr == NULL) {
 	MASTER_LOCK;
@@ -584,8 +696,26 @@ 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();
+	mutexWaitProc = TclGetMutexWaitProc();
+	if (mutexWaitProc != NULL) {
+	    mutexWaitProc(mutexPtr, &nRetry, NULL);
+	} else {
+	    TclpMutexWait(mutexPtr, &nRetry, NULL);
+	}
+	nRetry++;
+    }
 }
 
 /*