diff options
Diffstat (limited to 'generic/tclThreadTest.c')
| -rw-r--r-- | generic/tclThreadTest.c | 1211 |
1 files changed, 1211 insertions, 0 deletions
diff --git a/generic/tclThreadTest.c b/generic/tclThreadTest.c new file mode 100644 index 0000000..02ee038 --- /dev/null +++ b/generic/tclThreadTest.c @@ -0,0 +1,1211 @@ +/* + * 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: { + long 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_GetLongFromObj(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", (size_t) 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", (size_t) 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_NewLongObj((long)(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_Eval(tsdPtr->interp, threadEvalScript); + 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_GlobalEval(interp, script); + } + + /* + * 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_GlobalEval(interp, threadEventPtr->script); + 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 (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: + */ |