1219 lines
31 KiB
C
1219 lines
31 KiB
C
/*
|
||
* tclThreadTest.c --
|
||
*
|
||
* This file implements the testthread command. Eventually this should be
|
||
* tclThreadCmd.c
|
||
* Some of this code is based on work done by Richard Hipp on behalf of
|
||
* Conservation Through Innovation, Limited, with their permission.
|
||
*
|
||
* Copyright (c) 1998 by Sun Microsystems, Inc.
|
||
* Copyright (c) 2006-2008 by Joe Mistachkin. All rights reserved.
|
||
*
|
||
* See the file "license.terms" for information on usage and redistribution of
|
||
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||
*/
|
||
|
||
#ifndef USE_TCL_STUBS
|
||
# define USE_TCL_STUBS
|
||
#endif
|
||
#include "tclInt.h"
|
||
|
||
#ifdef TCL_THREADS
|
||
/*
|
||
* Each thread has an single instance of the following structure. There is one
|
||
* instance of this structure per thread even if that thread contains multiple
|
||
* interpreters. The interpreter identified by this structure is the main
|
||
* interpreter for the thread.
|
||
*
|
||
* The main interpreter is the one that will process any messages received by
|
||
* a thread. Any thread can send messages but only the main interpreter can
|
||
* receive them.
|
||
*/
|
||
|
||
typedef struct ThreadSpecificData {
|
||
Tcl_ThreadId threadId; /* Tcl ID for this thread */
|
||
Tcl_Interp *interp; /* Main interpreter for this thread */
|
||
int flags; /* See the TP_ defines below... */
|
||
struct ThreadSpecificData *nextPtr;
|
||
/* List for "thread names" */
|
||
struct ThreadSpecificData *prevPtr;
|
||
/* List for "thread names" */
|
||
} ThreadSpecificData;
|
||
static Tcl_ThreadDataKey dataKey;
|
||
|
||
/*
|
||
* This list is used to list all threads that have interpreters. This is
|
||
* protected by threadMutex.
|
||
*/
|
||
|
||
static ThreadSpecificData *threadList = NULL;
|
||
|
||
/*
|
||
* The following bit-values are legal for the "flags" field of the
|
||
* ThreadSpecificData structure.
|
||
*/
|
||
|
||
#define TP_Dying 0x001 /* This thread is being canceled */
|
||
|
||
/*
|
||
* An instance of the following structure contains all information that is
|
||
* passed into a new thread when the thread is created using either the
|
||
* "thread create" Tcl command or the ThreadCreate() C function.
|
||
*/
|
||
|
||
typedef struct ThreadCtrl {
|
||
const char *script; /* The Tcl command this thread should
|
||
* execute */
|
||
int flags; /* Initial value of the "flags" field in the
|
||
* ThreadSpecificData structure for the new
|
||
* thread. Might contain TP_Detached or
|
||
* TP_TclThread. */
|
||
Tcl_Condition condWait; /* This condition variable is used to
|
||
* synchronize the parent and child threads.
|
||
* The child won't run until it acquires
|
||
* threadMutex, and the parent function won't
|
||
* complete until signaled on this condition
|
||
* variable. */
|
||
} ThreadCtrl;
|
||
|
||
/*
|
||
* This is the event used to send scripts to other threads.
|
||
*/
|
||
|
||
typedef struct ThreadEvent {
|
||
Tcl_Event event; /* Must be first */
|
||
char *script; /* The script to execute. */
|
||
struct ThreadEventResult *resultPtr;
|
||
/* To communicate the result. This is NULL if
|
||
* we don't care about it. */
|
||
} ThreadEvent;
|
||
|
||
typedef struct ThreadEventResult {
|
||
Tcl_Condition done; /* Signaled when the script completes */
|
||
int code; /* Return value of Tcl_Eval */
|
||
char *result; /* Result from the script */
|
||
char *errorInfo; /* Copy of errorInfo variable */
|
||
char *errorCode; /* Copy of errorCode variable */
|
||
Tcl_ThreadId srcThreadId; /* Id of sending thread, in case it dies */
|
||
Tcl_ThreadId dstThreadId; /* Id of target thread, in case it dies */
|
||
struct ThreadEvent *eventPtr; /* Back pointer */
|
||
struct ThreadEventResult *nextPtr; /* List for cleanup */
|
||
struct ThreadEventResult *prevPtr;
|
||
|
||
} ThreadEventResult;
|
||
|
||
static ThreadEventResult *resultList;
|
||
|
||
/*
|
||
* This is for simple error handling when a thread script exits badly.
|
||
*/
|
||
|
||
static Tcl_ThreadId mainThreadId;
|
||
static Tcl_ThreadId errorThreadId;
|
||
static char *errorProcString;
|
||
|
||
/*
|
||
* Access to the list of threads and to the thread send results is guarded by
|
||
* this mutex.
|
||
*/
|
||
|
||
TCL_DECLARE_MUTEX(threadMutex)
|
||
|
||
static int ThreadObjCmd(ClientData clientData,
|
||
Tcl_Interp *interp, int objc,
|
||
Tcl_Obj *const objv[]);
|
||
static int ThreadCreate(Tcl_Interp *interp, const char *script,
|
||
int joinable);
|
||
static int ThreadList(Tcl_Interp *interp);
|
||
static int ThreadSend(Tcl_Interp *interp, Tcl_ThreadId id,
|
||
const char *script, int wait);
|
||
static int ThreadCancel(Tcl_Interp *interp, Tcl_ThreadId id,
|
||
const char *result, int flags);
|
||
|
||
static Tcl_ThreadCreateType NewTestThread(ClientData clientData);
|
||
static void ListRemove(ThreadSpecificData *tsdPtr);
|
||
static void ListUpdateInner(ThreadSpecificData *tsdPtr);
|
||
static int ThreadEventProc(Tcl_Event *evPtr, int mask);
|
||
static void ThreadErrorProc(Tcl_Interp *interp);
|
||
static void ThreadFreeProc(ClientData clientData);
|
||
static int ThreadDeleteEvent(Tcl_Event *eventPtr,
|
||
ClientData clientData);
|
||
static void ThreadExitProc(ClientData clientData);
|
||
extern int Tcltest_Init(Tcl_Interp *interp);
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* TclThread_Init --
|
||
*
|
||
* Initialize the test thread command.
|
||
*
|
||
* Results:
|
||
* TCL_OK if the package was properly initialized.
|
||
*
|
||
* Side effects:
|
||
* Add the "testthread" command to the interp.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
int
|
||
TclThread_Init(
|
||
Tcl_Interp *interp) /* The current Tcl interpreter */
|
||
{
|
||
/*
|
||
* If the main thread Id has not been set, do it now.
|
||
*/
|
||
|
||
Tcl_MutexLock(&threadMutex);
|
||
if (mainThreadId == 0) {
|
||
mainThreadId = Tcl_GetCurrentThread();
|
||
}
|
||
Tcl_MutexUnlock(&threadMutex);
|
||
|
||
Tcl_CreateObjCommand(interp, "testthread", ThreadObjCmd, NULL, NULL);
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* ThreadObjCmd --
|
||
*
|
||
* This procedure is invoked to process the "testthread" Tcl command. See
|
||
* the user documentation for details on what it does.
|
||
*
|
||
* thread cancel ?-unwind? id ?result?
|
||
* thread create ?-joinable? ?script?
|
||
* thread send ?-async? id script
|
||
* thread event
|
||
* thread exit
|
||
* thread id ?-main?
|
||
* thread names
|
||
* thread wait
|
||
* thread errorproc proc
|
||
* thread join id
|
||
*
|
||
* Results:
|
||
* A standard Tcl result.
|
||
*
|
||
* Side effects:
|
||
* See the user documentation.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
/* ARGSUSED */
|
||
static int
|
||
ThreadObjCmd(
|
||
ClientData dummy, /* Not used. */
|
||
Tcl_Interp *interp, /* Current interpreter. */
|
||
int objc, /* Number of arguments. */
|
||
Tcl_Obj *const objv[]) /* Argument objects. */
|
||
{
|
||
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
|
||
int option;
|
||
static const char *const threadOptions[] = {
|
||
"cancel", "create", "event", "exit", "id",
|
||
"join", "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
|
||
};
|
||
|
||
if (objc < 2) {
|
||
Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
|
||
return TCL_ERROR;
|
||
}
|
||
if (Tcl_GetIndexFromObj(interp, objv[1], threadOptions, "option", 0,
|
||
&option) != TCL_OK) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
* Make sure the initial thread is on the list before doing anything.
|
||
*/
|
||
|
||
if (tsdPtr->interp == NULL) {
|
||
Tcl_MutexLock(&threadMutex);
|
||
tsdPtr->interp = interp;
|
||
ListUpdateInner(tsdPtr);
|
||
Tcl_CreateThreadExitHandler(ThreadExitProc, NULL);
|
||
Tcl_MutexUnlock(&threadMutex);
|
||
}
|
||
|
||
switch ((enum options)option) {
|
||
case THREAD_CANCEL: {
|
||
Tcl_WideInt id;
|
||
const char *result;
|
||
int flags, arg;
|
||
|
||
if ((objc < 3) || (objc > 5)) {
|
||
Tcl_WrongNumArgs(interp, 2, objv, "?-unwind? id ?result?");
|
||
return TCL_ERROR;
|
||
}
|
||
flags = 0;
|
||
arg = 2;
|
||
if ((objc == 4) || (objc == 5)) {
|
||
if (strcmp("-unwind", Tcl_GetString(objv[arg])) == 0) {
|
||
flags = TCL_CANCEL_UNWIND;
|
||
arg++;
|
||
}
|
||
}
|
||
if (Tcl_GetWideIntFromObj(interp, objv[arg], &id) != TCL_OK) {
|
||
return TCL_ERROR;
|
||
}
|
||
arg++;
|
||
if (arg < objc) {
|
||
result = Tcl_GetString(objv[arg]);
|
||
} else {
|
||
result = NULL;
|
||
}
|
||
return ThreadCancel(interp, (Tcl_ThreadId) (size_t) id, result, flags);
|
||
}
|
||
case THREAD_CREATE: {
|
||
const char *script;
|
||
int joinable, len;
|
||
|
||
if (objc == 2) {
|
||
/*
|
||
* Neither joinable nor special script
|
||
*/
|
||
|
||
joinable = 0;
|
||
script = "testthread wait"; /* Just enter event loop */
|
||
} else if (objc == 3) {
|
||
/*
|
||
* Possibly -joinable, then no special script, no joinable, then
|
||
* its a script.
|
||
*/
|
||
|
||
script = Tcl_GetStringFromObj(objv[2], &len);
|
||
|
||
if ((len > 1) && (script[0] == '-') && (script[1] == 'j') &&
|
||
(0 == strncmp(script, "-joinable", len))) {
|
||
joinable = 1;
|
||
script = "testthread wait"; /* Just enter event loop */
|
||
} else {
|
||
/*
|
||
* Remember the script
|
||
*/
|
||
|
||
joinable = 0;
|
||
}
|
||
} else if (objc == 4) {
|
||
/*
|
||
* Definitely a script available, but is the flag -joinable?
|
||
*/
|
||
|
||
script = Tcl_GetStringFromObj(objv[2], &len);
|
||
joinable = ((len > 1) && (script[0] == '-') && (script[1] == 'j')
|
||
&& (0 == strncmp(script, "-joinable", len)));
|
||
script = Tcl_GetString(objv[3]);
|
||
} else {
|
||
Tcl_WrongNumArgs(interp, 2, objv, "?-joinable? ?script?");
|
||
return TCL_ERROR;
|
||
}
|
||
return ThreadCreate(interp, script, joinable);
|
||
}
|
||
case THREAD_EXIT:
|
||
if (objc > 2) {
|
||
Tcl_WrongNumArgs(interp, 2, objv, NULL);
|
||
return TCL_ERROR;
|
||
}
|
||
ListRemove(NULL);
|
||
Tcl_ExitThread(0);
|
||
return TCL_OK;
|
||
case THREAD_ID:
|
||
if (objc == 2 || objc == 3) {
|
||
Tcl_Obj *idObj;
|
||
|
||
/*
|
||
* Check if they want the main thread id or the current thread id.
|
||
*/
|
||
|
||
if (objc == 2) {
|
||
idObj = Tcl_NewWideIntObj((Tcl_WideInt)(size_t)Tcl_GetCurrentThread());
|
||
} else if (objc == 3
|
||
&& strcmp("-main", Tcl_GetString(objv[2])) == 0) {
|
||
Tcl_MutexLock(&threadMutex);
|
||
idObj = Tcl_NewWideIntObj((Tcl_WideInt)(size_t)mainThreadId);
|
||
Tcl_MutexUnlock(&threadMutex);
|
||
} else {
|
||
Tcl_WrongNumArgs(interp, 2, objv, NULL);
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
Tcl_SetObjResult(interp, idObj);
|
||
return TCL_OK;
|
||
} else {
|
||
Tcl_WrongNumArgs(interp, 2, objv, NULL);
|
||
return TCL_ERROR;
|
||
}
|
||
case THREAD_JOIN: {
|
||
Tcl_WideInt id;
|
||
int result, status;
|
||
|
||
if (objc != 3) {
|
||
Tcl_WrongNumArgs(interp, 2, objv, "id");
|
||
return TCL_ERROR;
|
||
}
|
||
if (Tcl_GetWideIntFromObj(interp, objv[2], &id) != TCL_OK) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
result = Tcl_JoinThread((Tcl_ThreadId)(size_t)id, &status);
|
||
if (result == TCL_OK) {
|
||
Tcl_SetIntObj(Tcl_GetObjResult(interp), status);
|
||
} else {
|
||
char buf[20];
|
||
|
||
sprintf(buf, "%" TCL_LL_MODIFIER "d", id);
|
||
Tcl_AppendResult(interp, "cannot join thread ", buf, NULL);
|
||
}
|
||
return result;
|
||
}
|
||
case THREAD_NAMES:
|
||
if (objc > 2) {
|
||
Tcl_WrongNumArgs(interp, 2, objv, NULL);
|
||
return TCL_ERROR;
|
||
}
|
||
return ThreadList(interp);
|
||
case THREAD_SEND: {
|
||
Tcl_WideInt id;
|
||
const char *script;
|
||
int wait, arg;
|
||
|
||
if ((objc != 4) && (objc != 5)) {
|
||
Tcl_WrongNumArgs(interp, 2, objv, "?-async? id script");
|
||
return TCL_ERROR;
|
||
}
|
||
if (objc == 5) {
|
||
if (strcmp("-async", Tcl_GetString(objv[2])) != 0) {
|
||
Tcl_WrongNumArgs(interp, 2, objv, "?-async? id script");
|
||
return TCL_ERROR;
|
||
}
|
||
wait = 0;
|
||
arg = 3;
|
||
} else {
|
||
wait = 1;
|
||
arg = 2;
|
||
}
|
||
if (Tcl_GetWideIntFromObj(interp, objv[arg], &id) != TCL_OK) {
|
||
return TCL_ERROR;
|
||
}
|
||
arg++;
|
||
script = Tcl_GetString(objv[arg]);
|
||
return ThreadSend(interp, (Tcl_ThreadId)(size_t)id, script, wait);
|
||
}
|
||
case THREAD_EVENT: {
|
||
if (objc > 2) {
|
||
Tcl_WrongNumArgs(interp, 2, objv, NULL);
|
||
return TCL_ERROR;
|
||
}
|
||
Tcl_SetObjResult(interp, Tcl_NewIntObj(
|
||
Tcl_DoOneEvent(TCL_ALL_EVENTS | TCL_DONT_WAIT)));
|
||
return TCL_OK;
|
||
}
|
||
case THREAD_ERRORPROC: {
|
||
/*
|
||
* Arrange for this proc to handle thread death errors.
|
||
*/
|
||
|
||
const char *proc;
|
||
|
||
if (objc != 3) {
|
||
Tcl_WrongNumArgs(interp, 2, objv, "proc");
|
||
return TCL_ERROR;
|
||
}
|
||
Tcl_MutexLock(&threadMutex);
|
||
errorThreadId = Tcl_GetCurrentThread();
|
||
if (errorProcString) {
|
||
ckfree(errorProcString);
|
||
}
|
||
proc = Tcl_GetString(objv[2]);
|
||
errorProcString = ckalloc(strlen(proc) + 1);
|
||
strcpy(errorProcString, proc);
|
||
Tcl_MutexUnlock(&threadMutex);
|
||
return TCL_OK;
|
||
}
|
||
case THREAD_WAIT:
|
||
if (objc > 2) {
|
||
Tcl_WrongNumArgs(interp, 2, objv, "");
|
||
return TCL_ERROR;
|
||
}
|
||
while (1) {
|
||
/*
|
||
* If the script has been unwound, bail out immediately. This does
|
||
* not follow the recommended guidelines for how extensions should
|
||
* handle the script cancellation functionality because this is
|
||
* not a "normal" extension. Most extensions do not have a command
|
||
* that simply enters an infinite Tcl event loop. Normal
|
||
* extensions should not specify the TCL_CANCEL_UNWIND when
|
||
* calling Tcl_Canceled to check if the command has been canceled.
|
||
*/
|
||
|
||
if (Tcl_Canceled(interp,
|
||
TCL_LEAVE_ERR_MSG | TCL_CANCEL_UNWIND) == TCL_ERROR) {
|
||
break;
|
||
}
|
||
(void) Tcl_DoOneEvent(TCL_ALL_EVENTS);
|
||
}
|
||
|
||
/*
|
||
* If we get to this point, we have been canceled by another thread,
|
||
* which is considered to be an "error".
|
||
*/
|
||
|
||
ThreadErrorProc(interp);
|
||
return TCL_OK;
|
||
}
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* ThreadCreate --
|
||
*
|
||
* This procedure is invoked to create a thread containing an interp to
|
||
* run a script. This returns after the thread has started executing.
|
||
*
|
||
* Results:
|
||
* A standard Tcl result, which is the thread ID.
|
||
*
|
||
* Side effects:
|
||
* Create a thread.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
/* ARGSUSED */
|
||
static int
|
||
ThreadCreate(
|
||
Tcl_Interp *interp, /* Current interpreter. */
|
||
const char *script, /* Script to execute */
|
||
int joinable) /* Flag, joinable thread or not */
|
||
{
|
||
ThreadCtrl ctrl;
|
||
Tcl_ThreadId id;
|
||
|
||
ctrl.script = script;
|
||
ctrl.condWait = NULL;
|
||
ctrl.flags = 0;
|
||
|
||
joinable = joinable ? TCL_THREAD_JOINABLE : TCL_THREAD_NOFLAGS;
|
||
|
||
Tcl_MutexLock(&threadMutex);
|
||
if (Tcl_CreateThread(&id, NewTestThread, (ClientData) &ctrl,
|
||
TCL_THREAD_STACK_DEFAULT, joinable) != TCL_OK) {
|
||
Tcl_MutexUnlock(&threadMutex);
|
||
Tcl_AppendResult(interp, "can't create a new thread", NULL);
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
* Wait for the thread to start because it is using something on our stack!
|
||
*/
|
||
|
||
Tcl_ConditionWait(&ctrl.condWait, &threadMutex, NULL);
|
||
Tcl_MutexUnlock(&threadMutex);
|
||
Tcl_ConditionFinalize(&ctrl.condWait);
|
||
Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt)(size_t)id));
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
*------------------------------------------------------------------------
|
||
*
|
||
* NewTestThread --
|
||
*
|
||
* This routine is the "main()" for a new thread whose task is to execute
|
||
* a single Tcl script. The argument to this function is a pointer to a
|
||
* structure that contains the text of the TCL script to be executed.
|
||
*
|
||
* Space to hold the script field of the ThreadControl structure passed
|
||
* in as the only argument was obtained from malloc() and must be freed
|
||
* by this function before it exits. Space to hold the ThreadControl
|
||
* structure itself is released by the calling function, and the two
|
||
* condition variables in the ThreadControl structure are destroyed by
|
||
* the calling function. The calling function will destroy the
|
||
* ThreadControl structure and the condition variable as soon as
|
||
* ctrlPtr->condWait is signaled, so this routine must make copies of any
|
||
* data it might need after that point.
|
||
*
|
||
* Results:
|
||
* None
|
||
*
|
||
* Side effects:
|
||
* A Tcl script is executed in a new thread.
|
||
*
|
||
*------------------------------------------------------------------------
|
||
*/
|
||
|
||
Tcl_ThreadCreateType
|
||
NewTestThread(
|
||
ClientData clientData)
|
||
{
|
||
ThreadCtrl *ctrlPtr = clientData;
|
||
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
|
||
int result;
|
||
char *threadEvalScript;
|
||
|
||
/*
|
||
* Initialize the interpreter. This should be more general.
|
||
*/
|
||
|
||
tsdPtr->interp = Tcl_CreateInterp();
|
||
result = Tcl_Init(tsdPtr->interp);
|
||
if (result != TCL_OK) {
|
||
ThreadErrorProc(tsdPtr->interp);
|
||
}
|
||
|
||
/*
|
||
* This is part of the test facility. Initialize _ALL_ test commands for
|
||
* use by the new thread.
|
||
*/
|
||
|
||
result = Tcltest_Init(tsdPtr->interp);
|
||
if (result != TCL_OK) {
|
||
ThreadErrorProc(tsdPtr->interp);
|
||
}
|
||
|
||
/*
|
||
* Update the list of threads.
|
||
*/
|
||
|
||
Tcl_MutexLock(&threadMutex);
|
||
ListUpdateInner(tsdPtr);
|
||
|
||
/*
|
||
* We need to keep a pointer to the alloc'ed mem of the script we are
|
||
* eval'ing, for the case that we exit during evaluation
|
||
*/
|
||
|
||
threadEvalScript = ckalloc(strlen(ctrlPtr->script) + 1);
|
||
strcpy(threadEvalScript, ctrlPtr->script);
|
||
|
||
Tcl_CreateThreadExitHandler(ThreadExitProc, threadEvalScript);
|
||
|
||
/*
|
||
* Notify the parent we are alive.
|
||
*/
|
||
|
||
Tcl_ConditionNotify(&ctrlPtr->condWait);
|
||
Tcl_MutexUnlock(&threadMutex);
|
||
|
||
/*
|
||
* Run the script.
|
||
*/
|
||
|
||
Tcl_Preserve(tsdPtr->interp);
|
||
result = Tcl_EvalEx(tsdPtr->interp, threadEvalScript, -1, 0);
|
||
if (result != TCL_OK) {
|
||
ThreadErrorProc(tsdPtr->interp);
|
||
}
|
||
|
||
/*
|
||
* Clean up.
|
||
*/
|
||
|
||
Tcl_DeleteInterp(tsdPtr->interp);
|
||
Tcl_Release(tsdPtr->interp);
|
||
ListRemove(tsdPtr);
|
||
Tcl_ExitThread(result);
|
||
|
||
TCL_THREAD_CREATE_RETURN;
|
||
}
|
||
|
||
/*
|
||
*------------------------------------------------------------------------
|
||
*
|
||
* ThreadErrorProc --
|
||
*
|
||
* Send a message to the thread willing to hear about errors.
|
||
*
|
||
* Results:
|
||
* None
|
||
*
|
||
* Side effects:
|
||
* Send an event.
|
||
*
|
||
*------------------------------------------------------------------------
|
||
*/
|
||
|
||
static void
|
||
ThreadErrorProc(
|
||
Tcl_Interp *interp) /* Interp that failed */
|
||
{
|
||
Tcl_Channel errChannel;
|
||
const char *errorInfo, *argv[3];
|
||
char *script;
|
||
char buf[TCL_DOUBLE_SPACE+1];
|
||
|
||
sprintf(buf, "%" TCL_LL_MODIFIER "d", (Tcl_WideInt)(size_t)Tcl_GetCurrentThread());
|
||
|
||
errorInfo = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY);
|
||
if (errorProcString == NULL) {
|
||
errChannel = Tcl_GetStdChannel(TCL_STDERR);
|
||
Tcl_WriteChars(errChannel, "Error from thread ", -1);
|
||
Tcl_WriteChars(errChannel, buf, -1);
|
||
Tcl_WriteChars(errChannel, "\n", 1);
|
||
Tcl_WriteChars(errChannel, errorInfo, -1);
|
||
Tcl_WriteChars(errChannel, "\n", 1);
|
||
} else {
|
||
argv[0] = errorProcString;
|
||
argv[1] = buf;
|
||
argv[2] = errorInfo;
|
||
script = Tcl_Merge(3, argv);
|
||
ThreadSend(interp, errorThreadId, script, 0);
|
||
ckfree(script);
|
||
}
|
||
}
|
||
|
||
|
||
/*
|
||
*------------------------------------------------------------------------
|
||
*
|
||
* ListUpdateInner --
|
||
*
|
||
* Add the thread local storage to the list. This assumes the caller has
|
||
* obtained the mutex.
|
||
*
|
||
* Results:
|
||
* None
|
||
*
|
||
* Side effects:
|
||
* Add the thread local storage to its list.
|
||
*
|
||
*------------------------------------------------------------------------
|
||
*/
|
||
|
||
static void
|
||
ListUpdateInner(
|
||
ThreadSpecificData *tsdPtr)
|
||
{
|
||
if (tsdPtr == NULL) {
|
||
tsdPtr = TCL_TSD_INIT(&dataKey);
|
||
}
|
||
tsdPtr->threadId = Tcl_GetCurrentThread();
|
||
tsdPtr->nextPtr = threadList;
|
||
if (threadList) {
|
||
threadList->prevPtr = tsdPtr;
|
||
}
|
||
tsdPtr->prevPtr = NULL;
|
||
threadList = tsdPtr;
|
||
}
|
||
|
||
/*
|
||
*------------------------------------------------------------------------
|
||
*
|
||
* ListRemove --
|
||
*
|
||
* Remove the thread local storage from its list. This grabs the mutex to
|
||
* protect the list.
|
||
*
|
||
* Results:
|
||
* None
|
||
*
|
||
* Side effects:
|
||
* Remove the thread local storage from its list.
|
||
*
|
||
*------------------------------------------------------------------------
|
||
*/
|
||
|
||
static void
|
||
ListRemove(
|
||
ThreadSpecificData *tsdPtr)
|
||
{
|
||
if (tsdPtr == NULL) {
|
||
tsdPtr = TCL_TSD_INIT(&dataKey);
|
||
}
|
||
Tcl_MutexLock(&threadMutex);
|
||
if (tsdPtr->prevPtr) {
|
||
tsdPtr->prevPtr->nextPtr = tsdPtr->nextPtr;
|
||
} else {
|
||
threadList = tsdPtr->nextPtr;
|
||
}
|
||
if (tsdPtr->nextPtr) {
|
||
tsdPtr->nextPtr->prevPtr = tsdPtr->prevPtr;
|
||
}
|
||
tsdPtr->nextPtr = tsdPtr->prevPtr = 0;
|
||
tsdPtr->interp = NULL;
|
||
Tcl_MutexUnlock(&threadMutex);
|
||
}
|
||
|
||
/*
|
||
*------------------------------------------------------------------------
|
||
*
|
||
* ThreadList --
|
||
*
|
||
* Return a list of threads running Tcl interpreters.
|
||
*
|
||
* Results:
|
||
* A standard Tcl result.
|
||
*
|
||
* Side effects:
|
||
* None.
|
||
*
|
||
*------------------------------------------------------------------------
|
||
*/
|
||
static int
|
||
ThreadList(
|
||
Tcl_Interp *interp)
|
||
{
|
||
ThreadSpecificData *tsdPtr;
|
||
Tcl_Obj *listPtr;
|
||
|
||
listPtr = Tcl_NewListObj(0, NULL);
|
||
Tcl_MutexLock(&threadMutex);
|
||
for (tsdPtr = threadList ; tsdPtr ; tsdPtr = tsdPtr->nextPtr) {
|
||
Tcl_ListObjAppendElement(interp, listPtr,
|
||
Tcl_NewWideIntObj((Tcl_WideInt)(size_t)tsdPtr->threadId));
|
||
}
|
||
Tcl_MutexUnlock(&threadMutex);
|
||
Tcl_SetObjResult(interp, listPtr);
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
*------------------------------------------------------------------------
|
||
*
|
||
* ThreadSend --
|
||
*
|
||
* Send a script to another thread.
|
||
*
|
||
* Results:
|
||
* A standard Tcl result.
|
||
*
|
||
* Side effects:
|
||
* None.
|
||
*
|
||
*------------------------------------------------------------------------
|
||
*/
|
||
|
||
static int
|
||
ThreadSend(
|
||
Tcl_Interp *interp, /* The current interpreter. */
|
||
Tcl_ThreadId id, /* Thread Id of other interpreter. */
|
||
const char *script, /* The script to evaluate. */
|
||
int wait) /* If 1, we block for the result. */
|
||
{
|
||
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
|
||
ThreadEvent *threadEventPtr;
|
||
ThreadEventResult *resultPtr;
|
||
int found, code;
|
||
Tcl_ThreadId threadId = (Tcl_ThreadId) id;
|
||
|
||
/*
|
||
* Verify the thread exists.
|
||
*/
|
||
|
||
Tcl_MutexLock(&threadMutex);
|
||
found = 0;
|
||
for (tsdPtr = threadList ; tsdPtr ; tsdPtr = tsdPtr->nextPtr) {
|
||
if (tsdPtr->threadId == threadId) {
|
||
found = 1;
|
||
break;
|
||
}
|
||
}
|
||
if (!found) {
|
||
Tcl_MutexUnlock(&threadMutex);
|
||
Tcl_AppendResult(interp, "invalid thread id", NULL);
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
* Short circut sends to ourself. Ought to do something with -async, like
|
||
* run in an idle handler.
|
||
*/
|
||
|
||
if (threadId == Tcl_GetCurrentThread()) {
|
||
Tcl_MutexUnlock(&threadMutex);
|
||
return Tcl_EvalEx(interp, script,-1,TCL_EVAL_GLOBAL);
|
||
}
|
||
|
||
/*
|
||
* Create the event for its event queue.
|
||
*/
|
||
|
||
threadEventPtr = ckalloc(sizeof(ThreadEvent));
|
||
threadEventPtr->script = ckalloc(strlen(script) + 1);
|
||
strcpy(threadEventPtr->script, script);
|
||
if (!wait) {
|
||
resultPtr = threadEventPtr->resultPtr = NULL;
|
||
} else {
|
||
resultPtr = ckalloc(sizeof(ThreadEventResult));
|
||
threadEventPtr->resultPtr = resultPtr;
|
||
|
||
/*
|
||
* Initialize the result fields.
|
||
*/
|
||
|
||
resultPtr->done = NULL;
|
||
resultPtr->code = 0;
|
||
resultPtr->result = NULL;
|
||
resultPtr->errorInfo = NULL;
|
||
resultPtr->errorCode = NULL;
|
||
|
||
/*
|
||
* Maintain the cleanup list.
|
||
*/
|
||
|
||
resultPtr->srcThreadId = Tcl_GetCurrentThread();
|
||
resultPtr->dstThreadId = threadId;
|
||
resultPtr->eventPtr = threadEventPtr;
|
||
resultPtr->nextPtr = resultList;
|
||
if (resultList) {
|
||
resultList->prevPtr = resultPtr;
|
||
}
|
||
resultPtr->prevPtr = NULL;
|
||
resultList = resultPtr;
|
||
}
|
||
|
||
/*
|
||
* Queue the event and poke the other thread's notifier.
|
||
*/
|
||
|
||
threadEventPtr->event.proc = ThreadEventProc;
|
||
Tcl_ThreadQueueEvent(threadId, (Tcl_Event *) threadEventPtr,
|
||
TCL_QUEUE_TAIL);
|
||
Tcl_ThreadAlert(threadId);
|
||
|
||
if (!wait) {
|
||
Tcl_MutexUnlock(&threadMutex);
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
* Block on the results and then get them.
|
||
*/
|
||
|
||
Tcl_ResetResult(interp);
|
||
while (resultPtr->result == NULL) {
|
||
Tcl_ConditionWait(&resultPtr->done, &threadMutex, NULL);
|
||
}
|
||
|
||
/*
|
||
* Unlink result from the result list.
|
||
*/
|
||
|
||
if (resultPtr->prevPtr) {
|
||
resultPtr->prevPtr->nextPtr = resultPtr->nextPtr;
|
||
} else {
|
||
resultList = resultPtr->nextPtr;
|
||
}
|
||
if (resultPtr->nextPtr) {
|
||
resultPtr->nextPtr->prevPtr = resultPtr->prevPtr;
|
||
}
|
||
resultPtr->eventPtr = NULL;
|
||
resultPtr->nextPtr = NULL;
|
||
resultPtr->prevPtr = NULL;
|
||
|
||
Tcl_MutexUnlock(&threadMutex);
|
||
|
||
if (resultPtr->code != TCL_OK) {
|
||
if (resultPtr->errorCode) {
|
||
Tcl_SetErrorCode(interp, resultPtr->errorCode, NULL);
|
||
ckfree(resultPtr->errorCode);
|
||
}
|
||
if (resultPtr->errorInfo) {
|
||
Tcl_AddErrorInfo(interp, resultPtr->errorInfo);
|
||
ckfree(resultPtr->errorInfo);
|
||
}
|
||
}
|
||
Tcl_AppendResult(interp, resultPtr->result, NULL);
|
||
Tcl_ConditionFinalize(&resultPtr->done);
|
||
code = resultPtr->code;
|
||
|
||
ckfree(resultPtr->result);
|
||
ckfree(resultPtr);
|
||
|
||
return code;
|
||
}
|
||
|
||
/*
|
||
*------------------------------------------------------------------------
|
||
*
|
||
* ThreadCancel --
|
||
*
|
||
* Cancels a script in another thread.
|
||
*
|
||
* Results:
|
||
* A standard Tcl result.
|
||
*
|
||
* Side effects:
|
||
* None.
|
||
*
|
||
*------------------------------------------------------------------------
|
||
*/
|
||
|
||
static int
|
||
ThreadCancel(
|
||
Tcl_Interp *interp, /* The current interpreter. */
|
||
Tcl_ThreadId id, /* Thread Id of other interpreter. */
|
||
const char *result, /* The result or NULL for default. */
|
||
int flags) /* Flags for Tcl_CancelEval. */
|
||
{
|
||
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
|
||
int found;
|
||
Tcl_ThreadId threadId = (Tcl_ThreadId) id;
|
||
|
||
/*
|
||
* Verify the thread exists.
|
||
*/
|
||
|
||
Tcl_MutexLock(&threadMutex);
|
||
found = 0;
|
||
for (tsdPtr = threadList ; tsdPtr ; tsdPtr = tsdPtr->nextPtr) {
|
||
if (tsdPtr->threadId == threadId) {
|
||
found = 1;
|
||
break;
|
||
}
|
||
}
|
||
if (!found) {
|
||
Tcl_MutexUnlock(&threadMutex);
|
||
Tcl_AppendResult(interp, "invalid thread id", NULL);
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
* Since Tcl_CancelEval can be safely called from any thread,
|
||
* we do it now.
|
||
*/
|
||
|
||
Tcl_MutexUnlock(&threadMutex);
|
||
Tcl_ResetResult(interp);
|
||
return Tcl_CancelEval(tsdPtr->interp,
|
||
(result != NULL) ? Tcl_NewStringObj(result, -1) : NULL, 0, flags);
|
||
}
|
||
|
||
/*
|
||
*------------------------------------------------------------------------
|
||
*
|
||
* ThreadEventProc --
|
||
*
|
||
* Handle the event in the target thread.
|
||
*
|
||
* Results:
|
||
* Returns 1 to indicate that the event was processed.
|
||
*
|
||
* Side effects:
|
||
* Fills out the ThreadEventResult struct.
|
||
*
|
||
*------------------------------------------------------------------------
|
||
*/
|
||
|
||
static int
|
||
ThreadEventProc(
|
||
Tcl_Event *evPtr, /* Really ThreadEvent */
|
||
int mask)
|
||
{
|
||
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
|
||
ThreadEvent *threadEventPtr = (ThreadEvent *) evPtr;
|
||
ThreadEventResult *resultPtr = threadEventPtr->resultPtr;
|
||
Tcl_Interp *interp = tsdPtr->interp;
|
||
int code;
|
||
const char *result, *errorCode, *errorInfo;
|
||
|
||
if (interp == NULL) {
|
||
code = TCL_ERROR;
|
||
result = "no target interp!";
|
||
errorCode = "THREAD";
|
||
errorInfo = "";
|
||
} else {
|
||
Tcl_Preserve(interp);
|
||
Tcl_ResetResult(interp);
|
||
Tcl_CreateThreadExitHandler(ThreadFreeProc, threadEventPtr->script);
|
||
code = Tcl_EvalEx(interp, threadEventPtr->script,-1,TCL_EVAL_GLOBAL);
|
||
Tcl_DeleteThreadExitHandler(ThreadFreeProc, threadEventPtr->script);
|
||
if (code != TCL_OK) {
|
||
errorCode = Tcl_GetVar(interp, "errorCode", TCL_GLOBAL_ONLY);
|
||
errorInfo = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY);
|
||
} else {
|
||
errorCode = errorInfo = NULL;
|
||
}
|
||
result = Tcl_GetStringResult(interp);
|
||
}
|
||
ckfree(threadEventPtr->script);
|
||
if (resultPtr) {
|
||
Tcl_MutexLock(&threadMutex);
|
||
resultPtr->code = code;
|
||
resultPtr->result = ckalloc(strlen(result) + 1);
|
||
strcpy(resultPtr->result, result);
|
||
if (errorCode != NULL) {
|
||
resultPtr->errorCode = ckalloc(strlen(errorCode) + 1);
|
||
strcpy(resultPtr->errorCode, errorCode);
|
||
}
|
||
if (errorInfo != NULL) {
|
||
resultPtr->errorInfo = ckalloc(strlen(errorInfo) + 1);
|
||
strcpy(resultPtr->errorInfo, errorInfo);
|
||
}
|
||
Tcl_ConditionNotify(&resultPtr->done);
|
||
Tcl_MutexUnlock(&threadMutex);
|
||
}
|
||
if (interp != NULL) {
|
||
Tcl_Release(interp);
|
||
}
|
||
return 1;
|
||
}
|
||
|
||
/*
|
||
*------------------------------------------------------------------------
|
||
*
|
||
* ThreadFreeProc --
|
||
*
|
||
* This is called from when we are exiting and memory needs
|
||
* to be freed.
|
||
*
|
||
* Results:
|
||
* None.
|
||
*
|
||
* Side effects:
|
||
* Clears up mem specified in ClientData
|
||
*
|
||
*------------------------------------------------------------------------
|
||
*/
|
||
|
||
/* ARGSUSED */
|
||
static void
|
||
ThreadFreeProc(
|
||
ClientData clientData)
|
||
{
|
||
if (clientData) {
|
||
ckfree(clientData);
|
||
}
|
||
}
|
||
|
||
/*
|
||
*------------------------------------------------------------------------
|
||
*
|
||
* ThreadDeleteEvent --
|
||
*
|
||
* This is called from the ThreadExitProc to delete memory related
|
||
* to events that we put on the queue.
|
||
*
|
||
* Results:
|
||
* 1 it was our event and we want it removed, 0 otherwise.
|
||
*
|
||
* Side effects:
|
||
* It cleans up our events in the event queue for this thread.
|
||
*
|
||
*------------------------------------------------------------------------
|
||
*/
|
||
|
||
/* ARGSUSED */
|
||
static int
|
||
ThreadDeleteEvent(
|
||
Tcl_Event *eventPtr, /* Really ThreadEvent */
|
||
ClientData clientData) /* dummy */
|
||
{
|
||
if (eventPtr->proc == ThreadEventProc) {
|
||
ckfree(((ThreadEvent *) eventPtr)->script);
|
||
return 1;
|
||
}
|
||
|
||
/*
|
||
* If it was NULL, we were in the middle of servicing the event and it
|
||
* should be removed
|
||
*/
|
||
|
||
return (eventPtr->proc == NULL);
|
||
}
|
||
|
||
/*
|
||
*------------------------------------------------------------------------
|
||
*
|
||
* ThreadExitProc --
|
||
*
|
||
* This is called when the thread exits.
|
||
*
|
||
* Results:
|
||
* None.
|
||
*
|
||
* Side effects:
|
||
* It unblocks anyone that is waiting on a send to this thread. It cleans
|
||
* up any events in the event queue for this thread.
|
||
*
|
||
*------------------------------------------------------------------------
|
||
*/
|
||
|
||
/* ARGSUSED */
|
||
static void
|
||
ThreadExitProc(
|
||
ClientData clientData)
|
||
{
|
||
char *threadEvalScript = clientData;
|
||
ThreadEventResult *resultPtr, *nextPtr;
|
||
Tcl_ThreadId self = Tcl_GetCurrentThread();
|
||
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
|
||
|
||
if (tsdPtr->interp != NULL) {
|
||
ListRemove(tsdPtr);
|
||
}
|
||
|
||
Tcl_MutexLock(&threadMutex);
|
||
|
||
if (self == errorThreadId) {
|
||
if (errorProcString) { /* Extra safety */
|
||
ckfree(errorProcString);
|
||
errorProcString = NULL;
|
||
}
|
||
errorThreadId = 0;
|
||
}
|
||
|
||
if (threadEvalScript) {
|
||
ckfree(threadEvalScript);
|
||
threadEvalScript = NULL;
|
||
}
|
||
Tcl_DeleteEvents((Tcl_EventDeleteProc *) ThreadDeleteEvent, NULL);
|
||
|
||
for (resultPtr = resultList ; resultPtr ; resultPtr = nextPtr) {
|
||
nextPtr = resultPtr->nextPtr;
|
||
if (resultPtr->srcThreadId == self) {
|
||
/*
|
||
* We are going away. By freeing up the result we signal to the
|
||
* other thread we don't care about the result.
|
||
*/
|
||
|
||
if (resultPtr->prevPtr) {
|
||
resultPtr->prevPtr->nextPtr = resultPtr->nextPtr;
|
||
} else {
|
||
resultList = resultPtr->nextPtr;
|
||
}
|
||
if (resultPtr->nextPtr) {
|
||
resultPtr->nextPtr->prevPtr = resultPtr->prevPtr;
|
||
}
|
||
resultPtr->nextPtr = resultPtr->prevPtr = 0;
|
||
resultPtr->eventPtr->resultPtr = NULL;
|
||
ckfree(resultPtr);
|
||
} else if (resultPtr->dstThreadId == self) {
|
||
/*
|
||
* Dang. The target is going away. Unblock the caller. The result
|
||
* string must be dynamically allocated because the main thread is
|
||
* going to call free on it.
|
||
*/
|
||
|
||
const char *msg = "target thread died";
|
||
|
||
resultPtr->result = ckalloc(strlen(msg) + 1);
|
||
strcpy(resultPtr->result, msg);
|
||
resultPtr->code = TCL_ERROR;
|
||
Tcl_ConditionNotify(&resultPtr->done);
|
||
}
|
||
}
|
||
Tcl_MutexUnlock(&threadMutex);
|
||
}
|
||
#endif /* TCL_THREADS */
|
||
|
||
/*
|
||
* Local Variables:
|
||
* mode: c
|
||
* c-basic-offset: 4
|
||
* fill-column: 78
|
||
* End:
|
||
*/
|