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