Attachment "newatfork.diff" to
ticket [923072ffff]
added by
davidw
2004-06-17 03:59:59.
Index: generic/tclThread.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclThread.c,v
retrieving revision 1.7
diff -u -r1.7 tclThread.c
--- generic/tclThread.c 23 Apr 2004 07:21:36 -0000 1.7
+++ generic/tclThread.c 17 May 2004 20:58:28 -0000
@@ -494,7 +494,128 @@
keyRecord.num = 0;
#endif
}
+#if 1 && defined(TCL_THREADS)
+/*
+ *-----------------------------------------------------------------------------
+ *
+ * TclpAtforkLock --
+ *
+ * pthread_atfork callback called just before fork() in the
+ * parent process. Locks mutexes which are subsequently unlocked
+ * in both the parent and child.
+ *
+ * Results:
+ * None.
+ *
+ * Side Effects:
+ * Locks mutexes.
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+void
+TclpAtforkLock(void)
+{
+ Tcl_Mutex *mutexPtr;
+ int i;
+
+ /* locks must be held in locking order (if any) */
+ TclpMasterLock();
+ TclpInitLock();
+ for (i=0 ; i<mutexRecord.num ; i++) {
+ mutexPtr = (Tcl_Mutex *)mutexRecord.list[i];
+ if (mutexPtr != NULL) {
+ Tcl_MutexLock(mutexPtr);
+ }
+ }
+ Tcl_MutexLock(Tcl_GetAllocMutex());
+}
+
+/*
+ *-----------------------------------------------------------------------------
+ *
+ * TclpAtForkParent --
+ *
+ * This is the pthread_atfork callback in the parent process,
+ * after the fork.
+ *
+ * Results:
+ * None.
+ *
+ * Side Effects:
+ * Calls TclpAtforkUnlock to unlock mutexes and initialize the
+ * notifier system.
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+void TclpAtForkParent(void)
+{
+ TclpAtforkUnlock();
+ /* FIXME Hooks can go here. */
+}
+
+/*
+ *-----------------------------------------------------------------------------
+ *
+ * TclpAtForkChild --
+ *
+ * This is the pthread_atfork callback in the child process,
+ * after the fork.
+ *
+ * Results:
+ * None.
+ *
+ * Side Effects:
+ * Calls TclpAtforkUnlock to unlock mutexes and initialize the
+ * notifier system.
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+void TclpAtForkChild(void)
+{
+ TclpAtforkUnlock();
+ /* FIXME Hooks can go here. */
+}
+
+/*
+ *-----------------------------------------------------------------------------
+ *
+ * TclpAtforkUnlock --
+ *
+ * Unlocks mutexes locked in TclpAtforkLock, and starts the
+ * notifier subsystem with TclInitNotifier.
+ *
+ * Results:
+ * None.
+ *
+ * Side Effects:
+ * TclInitNotifier creates a notifier thread.
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+void
+TclpAtforkUnlock(void)
+{
+ Tcl_Mutex *mutexPtr;
+ int i;
+
+ /* locks must be released in same order as in atfork_lock() */
+ TclpMasterUnlock();
+ TclpInitUnlock();
+ for (i=0; i<mutexRecord.num ; i++) {
+ mutexPtr = (Tcl_Mutex *)mutexRecord.list[i];
+ if (mutexPtr != NULL) {
+ Tcl_MutexUnlock(mutexPtr);
+ }
+ }
+ Tcl_MutexUnlock(Tcl_GetAllocMutex());
+ TclInitNotifier();
+}
+#endif
/*
*----------------------------------------------------------------------
Index: tests/thread.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/thread.test,v
retrieving revision 1.10
diff -u -r1.10 thread.test
--- tests/thread.test 2 May 2000 22:02:36 -0000 1.10
+++ tests/thread.test 17 May 2004 20:58:31 -0000
@@ -19,10 +19,12 @@
# Some tests require the testthread command
-set ::tcltest::testConstraints(testthread) \
- [expr {[info commands testthread] != {}}]
+#set ::tcltest::testConstraints(testthread) \
+# [expr {[info commands testthread] != {}}]
-if {$::tcltest::testConstraints(testthread)} {
+tcltest::constraints::cset testthread [expr {[info commands testthread] != {}}]
+
+if {[::tcltest::constraints::cset testthread]} {
testthread errorproc ThreadError
Index: unix/tcl.m4
===================================================================
RCS file: /cvsroot/tcl/tcl/unix/tcl.m4,v
retrieving revision 1.114
diff -u -r1.114 tcl.m4
--- unix/tcl.m4 18 Mar 2004 19:01:43 -0000 1.114
+++ unix/tcl.m4 17 May 2004 20:58:48 -0000
@@ -469,6 +469,7 @@
ac_saved_libs=$LIBS
LIBS="$LIBS $THREADS_LIBS"
AC_CHECK_FUNCS(pthread_attr_setstacksize)
+ AC_CHECK_FUNCS(pthread_atfork)
LIBS=$ac_saved_libs
AC_CHECK_FUNCS(readdir_r)
else
Index: unix/tclAppInit.c
===================================================================
RCS file: /cvsroot/tcl/tcl/unix/tclAppInit.c,v
retrieving revision 1.11
diff -u -r1.11 tclAppInit.c
--- unix/tclAppInit.c 31 May 2002 22:20:22 -0000 1.11
+++ unix/tclAppInit.c 17 May 2004 20:58:48 -0000
@@ -15,6 +15,7 @@
*/
#include "tcl.h"
+#include "tclPort.h"
#ifdef TCL_TEST
Index: unix/tclUnixInit.c
===================================================================
RCS file: /cvsroot/tcl/tcl/unix/tclUnixInit.c,v
retrieving revision 1.41
diff -u -r1.41 tclUnixInit.c
--- unix/tclUnixInit.c 7 Apr 2004 22:04:30 -0000 1.41
+++ unix/tclUnixInit.c 17 May 2004 20:58:49 -0000
@@ -937,6 +937,15 @@
return result;
}
+#if defined(TCL_THREADS) && defined(HAVE_PTHREAD_ATFORK)
+static pthread_once_t once = PTHREAD_ONCE_INIT;
+
+static void
+InitAtfork(void)
+{
+ pthread_atfork(TclpAtforkLock, TclpAtForkParent, TclpAtForkChild);
+}
+#endif
/*
*----------------------------------------------------------------------
*
@@ -967,12 +976,17 @@
return (TCL_ERROR);
};
}
-
+
+#if defined(TCL_THREADS) && defined(HAVE_PTHREAD_ATFORK)
+ pthread_once(&once, InitAtfork);
+#endif
+
pathPtr = TclGetLibraryPath();
if (pathPtr == NULL) {
pathPtr = Tcl_NewObj();
}
Tcl_SetVar2Ex(interp, "tcl_libPath", NULL, pathPtr, TCL_GLOBAL_ONLY);
+
return Tcl_Eval(interp, initScript);
}
Index: unix/tclUnixPort.h
===================================================================
RCS file: /cvsroot/tcl/tcl/unix/tclUnixPort.h,v
retrieving revision 1.35
diff -u -r1.35 tclUnixPort.h
--- unix/tclUnixPort.h 6 Apr 2004 22:25:57 -0000 1.35
+++ unix/tclUnixPort.h 17 May 2004 20:58:50 -0000
@@ -574,6 +574,10 @@
*/
#define NO_REALPATH
#endif
+EXTERN void TclpAtforkLock(void);
+EXTERN void TclpAtforkUnlock(void);
+EXTERN void TclpAtForkChild(void);
+EXTERN void TclpAtForkParent(void);
#else
typedef int TclpMutex;
#define TclpMutexInit(a)
Index: unix/tclUnixTest.c
===================================================================
RCS file: /cvsroot/tcl/tcl/unix/tclUnixTest.c,v
retrieving revision 1.16
diff -u -r1.16 tclUnixTest.c
--- unix/tclUnixTest.c 6 Apr 2004 22:25:57 -0000 1.16
+++ unix/tclUnixTest.c 17 May 2004 20:58:50 -0000
@@ -81,6 +81,10 @@
Tcl_Interp *interp, int argc, CONST char **argv));
static int TestgotsigCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, CONST char **argv));
+static int TestforkCmd _ANSI_ARGS_((ClientData dummy,
+ Tcl_Interp *interp, int argc, CONST char **argv));
+static int TestwaitpidCmd _ANSI_ARGS_((ClientData dummy,
+ Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
static void AlarmHandler _ANSI_ARGS_(());
/*
@@ -120,6 +124,10 @@
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testgotsig", TestgotsigCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
+ Tcl_CreateCommand(interp, "testfork", TestforkCmd,
+ (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
+ Tcl_CreateObjCommand(interp, "testwaitpid", TestwaitpidCmd,
+ (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
return TCL_OK;
}
@@ -702,3 +710,80 @@
gotsig = "0";
return TCL_OK;
}
+
+/*
+ *----------------------------------------------------------------------
+ * TestforkCmd --
+ *
+ * Implementation of fork().
+ *
+ * Results:
+ * In the parent process, the child process' pid, in the child, 0.
+ *
+ * Side Effects:
+ * Creates a new process.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TestforkCmd(clientData, interp, argc, argv)
+ ClientData clientData; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int argc; /* Number of arguments. */
+ CONST char **argv; /* Argument strings. */
+{
+ pid_t pid;
+
+ pid = fork();
+ if (pid < 0) {
+ Tcl_AppendResult(interp, "fork failed: ",
+ Tcl_PosixError(interp),
+ (char *)NULL);
+ return TCL_ERROR;
+ }
+ Tcl_SetIntObj (Tcl_GetObjResult (interp), (int)pid);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ * TestwaitpidCmd --
+ *
+ * Implementation of waitpid().
+ *
+ * Results:
+ * Returns the PID of the process we waited on.
+ *
+ * Side Effects:
+ * Waits untill the process in question exits.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TestwaitpidCmd(clientData, interp, objc, objv)
+ ClientData clientData; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument strings. */
+{
+ pid_t pid = 0;
+ pid_t returnPid = 0;
+ int status = 0;
+
+ if (Tcl_GetIntFromObj(interp, objv[1], &pid) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ returnPid = waitpid(pid, &status, 0);
+ if (returnPid < 0) {
+ Tcl_AppendResult(interp, "wait failed: ",
+ Tcl_PosixError(interp),
+ (char *)NULL);
+ return TCL_ERROR;
+ }
+ Tcl_SetObjResult(interp, Tcl_NewIntObj(returnPid));
+
+ return TCL_OK;
+}
Index: unix/tclUnixThrd.c
===================================================================
RCS file: /cvsroot/tcl/tcl/unix/tclUnixThrd.c,v
retrieving revision 1.28
diff -u -r1.28 tclUnixThrd.c
--- unix/tclUnixThrd.c 23 Apr 2004 07:21:37 -0000 1.28
+++ unix/tclUnixThrd.c 17 May 2004 20:58:51 -0000
@@ -928,6 +928,35 @@
#ifdef TCL_THREADS
/*
+ * Additional functions to handle broken pthread behavior on fork().
+ * From the pthread_atfork man page:
+ * To understand the purpose of pthread_atfork, recall that
+ * fork(2) duplicates the whole memory space, including
+ * mutexes in their current locking state, but only the call
+ * ing thread: other threads are not running in the child
+ * process. The mutexes are not usable after the fork and
+ * must be initialized with pthread_mutex_init in the child
+ * process. This is a limitation of the current implementa
+ * tion and might or might not be present in future versions.
+ */
+#if 0
+/* this is called in parent before the fork() */
+void
+TclpAtforkLock(void)
+{
+ /* locks must be held in locking order (if any) */
+ Tcl_MutexLock((Tcl_Mutex *)&allocLockPtr);
+}
+
+/* this is called in both parent and child after the fork() */
+void
+TclpAtforkUnlock(void)
+{
+ /* locks must be released in same order as in atfork_lock() */
+ Tcl_MutexUnlock((Tcl_Mutex *)&allocLockPtr);
+}
+#endif
+/*
* Additions by AOL for specialized thread memory allocator.
*/
#ifdef USE_THREAD_ALLOC
