diff options
author | William Joye <wjoye@cfa.harvard.edu> | 2017-09-22 18:51:12 (GMT) |
---|---|---|
committer | William Joye <wjoye@cfa.harvard.edu> | 2017-09-22 18:51:12 (GMT) |
commit | 3fa8e6dc88e8041b6cb88d1b1e9c05676d3346b7 (patch) | |
tree | 69afbb41089c8358615879f7cd3c4cf7997f4c7e /tcl8.6/generic/tclThreadTest.c | |
parent | a0e17db23c0fd7c771c0afce8cce350c98f90b02 (diff) | |
download | blt-3fa8e6dc88e8041b6cb88d1b1e9c05676d3346b7.zip blt-3fa8e6dc88e8041b6cb88d1b1e9c05676d3346b7.tar.gz blt-3fa8e6dc88e8041b6cb88d1b1e9c05676d3346b7.tar.bz2 |
update to tcl/tk 8.6.7
Diffstat (limited to 'tcl8.6/generic/tclThreadTest.c')
-rw-r--r-- | tcl8.6/generic/tclThreadTest.c | 1211 |
1 files changed, 0 insertions, 1211 deletions
diff --git a/tcl8.6/generic/tclThreadTest.c b/tcl8.6/generic/tclThreadTest.c deleted file mode 100644 index 9c66313..0000000 --- a/tcl8.6/generic/tclThreadTest.c +++ /dev/null @@ -1,1211 +0,0 @@ -/* - * 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_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 (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: - */ |