diff options
Diffstat (limited to 'generic/tclThreadTest.c')
| -rw-r--r-- | generic/tclThreadTest.c | 852 |
1 files changed, 334 insertions, 518 deletions
diff --git a/generic/tclThreadTest.c b/generic/tclThreadTest.c index 22b5995..d298e5b 100644 --- a/generic/tclThreadTest.c +++ b/generic/tclThreadTest.c @@ -1,79 +1,70 @@ -/* +/* * tclThreadTest.c -- * - * This file implements the testthread command. Eventually this should be - * tclThreadCmd.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. + * 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. + * 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" */ + 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. + * This list is used to list all threads that have interpreters. + * This is protected by threadMutex. */ -static ThreadSpecificData *threadList = NULL; +static struct ThreadSpecificData *threadList; /* * The following bit-values are legal for the "flags" field of the * ThreadSpecificData structure. */ - -#define TP_Dying 0x001 /* This thread is being canceled */ +#define TP_Dying 0x001 /* This thread is being cancelled */ /* * 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. + * "thread create" Tcl command or the TclCreateThread() 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. */ + 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; /* @@ -84,8 +75,8 @@ 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. */ + /* To communicate the result. This is + * NULL if we don't care about it. */ } ThreadEvent; typedef struct ThreadEventResult { @@ -108,38 +99,41 @@ 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. +/* + * 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); +#undef TCL_STORAGE_CLASS +#define TCL_STORAGE_CLASS DLLEXPORT + +EXTERN int TclThread_Init _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN int Tcl_ThreadObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int TclCreateThread _ANSI_ARGS_((Tcl_Interp *interp, + char *script, int joinable)); +EXTERN int TclThreadList _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN int TclThreadSend _ANSI_ARGS_((Tcl_Interp *interp, Tcl_ThreadId id, + char *script, int wait)); + +#undef TCL_STORAGE_CLASS +#define TCL_STORAGE_CLASS DLLIMPORT + +Tcl_ThreadCreateType NewTestThread _ANSI_ARGS_((ClientData clientData)); +static void ListRemove _ANSI_ARGS_((ThreadSpecificData *tsdPtr)); +static void ListUpdateInner _ANSI_ARGS_((ThreadSpecificData *tsdPtr)); +static int ThreadEventProc _ANSI_ARGS_((Tcl_Event *evPtr, int mask)); +static void ThreadErrorProc _ANSI_ARGS_((Tcl_Interp *interp)); +static void ThreadFreeProc _ANSI_ARGS_((ClientData clientData)); +static int ThreadDeleteEvent _ANSI_ARGS_((Tcl_Event *eventPtr, + ClientData clientData)); +static void ThreadExitProc _ANSI_ARGS_((ClientData clientData)); + /* *---------------------------------------------------------------------- @@ -149,7 +143,7 @@ extern int Tcltest_Init(Tcl_Interp *interp); * Initialize the test thread command. * * Results: - * TCL_OK if the package was properly initialized. + * TCL_OK if the package was properly initialized. * * Side effects: * Add the "testthread" command to the interp. @@ -158,20 +152,15 @@ extern int Tcltest_Init(Tcl_Interp *interp); */ int -TclThread_Init( - Tcl_Interp *interp) /* The current Tcl interpreter */ +TclThread_Init(interp) + 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_CreateObjCommand(interp,"testthread", Tcl_ThreadObjCmd, + (ClientData)NULL ,NULL); + if (Tcl_PkgProvide(interp, "Thread", "1.0" ) != TCL_OK) { + return TCL_ERROR; } - Tcl_MutexUnlock(&threadMutex); - - Tcl_CreateObjCommand(interp, "testthread", ThreadObjCmd, NULL, NULL); return TCL_OK; } @@ -179,17 +168,15 @@ TclThread_Init( /* *---------------------------------------------------------------------- * - * ThreadObjCmd -- + * Tcl_ThreadObjCmd -- * - * This procedure is invoked to process the "testthread" Tcl command. See - * the user documentation for details on what it does. + * 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 send id ?-async? script * thread exit - * thread id ?-main? + * thread info id * thread names * thread wait * thread errorproc proc @@ -205,36 +192,31 @@ TclThread_Init( */ /* ARGSUSED */ -static int -ThreadObjCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ +int +Tcl_ThreadObjCmd(dummy, interp, objc, objv) + 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 - }; + static CONST char *threadOptions[] = {"create", "exit", "id", "join", "names", + "send", "wait", "errorproc", + (char *) NULL}; + enum options {THREAD_CREATE, THREAD_EXIT, THREAD_ID, THREAD_JOIN, + THREAD_NAMES, THREAD_SEND, THREAD_WAIT, THREAD_ERRORPROC}; if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?"); + Tcl_WrongNumArgs(interp, 1, objv, "option ?args?"); return TCL_ERROR; } - if (Tcl_GetIndexFromObj(interp, objv[1], threadOptions, "option", 0, - &option) != TCL_OK) { + 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. */ @@ -247,241 +229,166 @@ ThreadObjCmd( } 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; + case THREAD_CREATE: { + char *script; + int joinable, len; - if (objc == 2) { - /* - * Neither joinable nor special script - */ + 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. - */ + joinable = 0; + script = "testthread wait"; /* Just enter the event loop */ - script = Tcl_GetStringFromObj(objv[2], &len); + } else if (objc == 3) { + /* Possibly -joinable, then no special script, + * no joinable, then its a script. + */ - 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 + script = Tcl_GetString(objv[2]); + len = strlen (script); + + if ((len > 1) && + (script [0] == '-') && (script [1] == 'j') && + (0 == strncmp (script, "-joinable", (size_t) len))) { + joinable = 1; + script = "testthread wait"; /* Just enter the event loop + */ + } else { + /* Remember the script */ + joinable = 0; + } + } else if (objc == 4) { + /* Definitely a script available, but is the flag + * -joinable ? */ - joinable = 0; - } - } else if (objc == 4) { - /* - * Definitely a script available, but is the flag -joinable? - */ + script = Tcl_GetString(objv[2]); + len = strlen (script); - 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; + 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 TclCreateThread(interp, script, joinable); } - return ThreadCreate(interp, script, joinable); - } - case THREAD_EXIT: - if (objc > 2) { - Tcl_WrongNumArgs(interp, 2, objv, NULL); - return TCL_ERROR; + case THREAD_EXIT: { + if (objc > 2) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); + return TCL_ERROR; + } + ListRemove(NULL); + Tcl_ExitThread(0); + return TCL_OK; } - 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. - */ - + case THREAD_ID: if (objc == 2) { - idObj = Tcl_NewLongObj((long)(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); + Tcl_Obj *idObj = Tcl_NewLongObj((long)Tcl_GetCurrentThread()); + Tcl_SetObjResult(interp, idObj); + return TCL_OK; } else { Tcl_WrongNumArgs(interp, 2, objv, NULL); return TCL_ERROR; } + case THREAD_JOIN: { + long id; + int result, status; - Tcl_SetObjResult(interp, idObj); - return TCL_OK; - } else { - Tcl_WrongNumArgs(interp, 2, objv, NULL); - return TCL_ERROR; - } - case THREAD_JOIN: { - long id; - int result, status; - - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "id"); - return TCL_ERROR; - } - if (Tcl_GetLongFromObj(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]; + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "join id"); + return TCL_ERROR; + } + if (Tcl_GetLongFromObj(interp, objv[2], &id) != TCL_OK) { + return TCL_ERROR; + } - TclFormatInt(buf, 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: { - long id; - const char *script; - int wait, arg; - - if ((objc != 4) && (objc != 5)) { - Tcl_WrongNumArgs(interp, 2, objv, "?-async? id script"); - return TCL_ERROR; + result = Tcl_JoinThread ((Tcl_ThreadId) id, &status); + if (result == TCL_OK) { + Tcl_SetIntObj (Tcl_GetObjResult (interp), status); + } else { + char buf [20]; + sprintf (buf, "%ld", id); + Tcl_AppendResult (interp, "cannot join thread ", buf, NULL); + } + return result; } - if (objc == 5) { - if (strcmp("-async", Tcl_GetString(objv[2])) != 0) { - Tcl_WrongNumArgs(interp, 2, objv, "?-async? id script"); + case THREAD_NAMES: { + if (objc > 2) { + Tcl_WrongNumArgs(interp, 2, objv, NULL); return TCL_ERROR; } - wait = 0; - arg = 3; - } else { - wait = 1; - arg = 2; + return TclThreadList(interp); } - if (Tcl_GetLongFromObj(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; + case THREAD_SEND: { + long id; + char *script; + int wait, arg; - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "proc"); - return TCL_ERROR; - } - Tcl_MutexLock(&threadMutex); - errorThreadId = Tcl_GetCurrentThread(); - if (errorProcString) { - ckfree(errorProcString); + if ((objc != 4) && (objc != 5)) { + Tcl_WrongNumArgs(interp, 1, objv, "send ?-async? id script"); + return TCL_ERROR; + } + if (objc == 5) { + if (strcmp("-async", Tcl_GetString(objv[2])) != 0) { + Tcl_WrongNumArgs(interp, 1, objv, "send ?-async? id script"); + return TCL_ERROR; + } + wait = 0; + arg = 3; + } else { + wait = 1; + arg = 2; + } + if (Tcl_GetLongFromObj(interp, objv[arg], &id) != TCL_OK) { + return TCL_ERROR; + } + arg++; + script = Tcl_GetString(objv[arg]); + return TclThreadSend(interp, (Tcl_ThreadId) id, script, wait); } - 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; + case THREAD_WAIT: { + while (1) { + (void) Tcl_DoOneEvent(TCL_ALL_EVENTS); + } } - while (1) { + case THREAD_ERRORPROC: { /* - * 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. + * Arrange for this proc to handle thread death errors. */ - if (Tcl_Canceled(interp, - TCL_LEAVE_ERR_MSG | TCL_CANCEL_UNWIND) == TCL_ERROR) { - break; + char *proc; + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "errorproc proc"); + return TCL_ERROR; } - (void) Tcl_DoOneEvent(TCL_ALL_EVENTS); + 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; } - - /* - * 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 -- + * TclCreateThread -- * * This procedure is invoked to create a thread containing an interp to - * run a script. This returns after the thread has started executing. + * run a script. This returns after the thread has started executing. * * Results: * A standard Tcl result, which is the thread ID. @@ -493,11 +400,11 @@ ThreadObjCmd( */ /* ARGSUSED */ -static int -ThreadCreate( - Tcl_Interp *interp, /* Current interpreter. */ - const char *script, /* Script to execute */ - int joinable) /* Flag, joinable thread or not */ +int +TclCreateThread(interp, script, joinable) + Tcl_Interp *interp; /* Current interpreter. */ + char *script; /* Script to execute */ + int joinable; /* Flag, joinable thread or not */ { ThreadCtrl ctrl; Tcl_ThreadId id; @@ -510,10 +417,10 @@ ThreadCreate( Tcl_MutexLock(&threadMutex); if (Tcl_CreateThread(&id, NewTestThread, (ClientData) &ctrl, - TCL_THREAD_STACK_DEFAULT, joinable) != TCL_OK) { + TCL_THREAD_STACK_DEFAULT, joinable) != TCL_OK) { Tcl_MutexUnlock(&threadMutex); - Tcl_AppendResult(interp, "can't create a new thread", NULL); - ckfree(ctrl.script); + Tcl_AppendResult(interp,"can't create a new thread",NULL); + ckfree((void*)ctrl.script); return TCL_ERROR; } @@ -524,7 +431,7 @@ ThreadCreate( Tcl_ConditionWait(&ctrl.condWait, &threadMutex, NULL); Tcl_MutexUnlock(&threadMutex); Tcl_ConditionFinalize(&ctrl.condWait); - Tcl_SetObjResult(interp, Tcl_NewLongObj((long)(size_t)id)); + Tcl_SetObjResult(interp, Tcl_NewLongObj((long)id)); return TCL_OK; } @@ -533,57 +440,45 @@ ThreadCreate( * * 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. + * 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 + * none * * Side effects: - * A Tcl script is executed in a new thread. + * A TCL script is executed in a new thread. * *------------------------------------------------------------------------ */ - Tcl_ThreadCreateType -NewTestThread( - ClientData clientData) +NewTestThread(clientData) + ClientData clientData; { - ThreadCtrl *ctrlPtr = clientData; + ThreadCtrl *ctrlPtr = (ThreadCtrl*)clientData; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); int result; char *threadEvalScript; /* - * Initialize the interpreter. This should be more general. + * 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); - } + result = TclThread_Init(tsdPtr->interp); /* * Update the list of threads. @@ -591,16 +486,14 @@ NewTestThread( 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 + * 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); + threadEvalScript = (char *) ckalloc(strlen(ctrlPtr->script)+1); strcpy(threadEvalScript, ctrlPtr->script); - Tcl_CreateThreadExitHandler(ThreadExitProc, threadEvalScript); + Tcl_CreateThreadExitHandler(ThreadExitProc, (ClientData) threadEvalScript); /* * Notify the parent we are alive. @@ -613,7 +506,7 @@ NewTestThread( * Run the script. */ - Tcl_Preserve(tsdPtr->interp); + Tcl_Preserve((ClientData) tsdPtr->interp); result = Tcl_Eval(tsdPtr->interp, threadEvalScript); if (result != TCL_OK) { ThreadErrorProc(tsdPtr->interp); @@ -623,9 +516,9 @@ NewTestThread( * Clean up. */ - Tcl_DeleteInterp(tsdPtr->interp); - Tcl_Release(tsdPtr->interp); ListRemove(tsdPtr); + Tcl_Release((ClientData) tsdPtr->interp); + Tcl_DeleteInterp(tsdPtr->interp); Tcl_ExitThread(result); TCL_THREAD_CREATE_RETURN; @@ -636,27 +529,25 @@ NewTestThread( * * ThreadErrorProc -- * - * Send a message to the thread willing to hear about errors. + * Send a message to the thread willing to hear about errors. * * Results: - * None + * none * * Side effects: - * Send an event. + * Send an event. * *------------------------------------------------------------------------ */ - static void -ThreadErrorProc( - Tcl_Interp *interp) /* Interp that failed */ +ThreadErrorProc(interp) + Tcl_Interp *interp; /* Interp that failed */ { Tcl_Channel errChannel; - const char *errorInfo, *argv[3]; + CONST char *errorInfo, *argv[3]; char *script; char buf[TCL_DOUBLE_SPACE+1]; - - TclFormatInt(buf, (size_t) Tcl_GetCurrentThread()); + sprintf(buf, "%ld", (long) Tcl_GetCurrentThread()); errorInfo = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY); if (errorProcString == NULL) { @@ -671,7 +562,7 @@ ThreadErrorProc( argv[1] = buf; argv[2] = errorInfo; script = Tcl_Merge(3, argv); - ThreadSend(interp, errorThreadId, script, 0); + TclThreadSend(interp, errorThreadId, script, 0); ckfree(script); } } @@ -682,21 +573,20 @@ ThreadErrorProc( * * ListUpdateInner -- * - * Add the thread local storage to the list. This assumes the caller has - * obtained the mutex. + * Add the thread local storage to the list. This assumes + * the caller has obtained the mutex. * * Results: - * None + * none * * Side effects: - * Add the thread local storage to its list. + * Add the thread local storage to its list. * *------------------------------------------------------------------------ */ - static void -ListUpdateInner( - ThreadSpecificData *tsdPtr) +ListUpdateInner(tsdPtr) + ThreadSpecificData *tsdPtr; { if (tsdPtr == NULL) { tsdPtr = TCL_TSD_INIT(&dataKey); @@ -715,21 +605,20 @@ ListUpdateInner( * * ListRemove -- * - * Remove the thread local storage from its list. This grabs the mutex to - * protect the list. + * Remove the thread local storage from its list. This grabs the + * mutex to protect the list. * * Results: - * None + * none * * Side effects: - * Remove the thread local storage from its list. + * Remove the thread local storage from its list. * *------------------------------------------------------------------------ */ - static void -ListRemove( - ThreadSpecificData *tsdPtr) +ListRemove(tsdPtr) + ThreadSpecificData *tsdPtr; { if (tsdPtr == NULL) { tsdPtr = TCL_TSD_INIT(&dataKey); @@ -744,14 +633,14 @@ ListRemove( tsdPtr->nextPtr->prevPtr = tsdPtr->prevPtr; } tsdPtr->nextPtr = tsdPtr->prevPtr = 0; - tsdPtr->interp = NULL; Tcl_MutexUnlock(&threadMutex); } + /* *------------------------------------------------------------------------ * - * ThreadList -- + * TclThreadList -- * * Return a list of threads running Tcl interpreters. * @@ -763,9 +652,9 @@ ListRemove( * *------------------------------------------------------------------------ */ -static int -ThreadList( - Tcl_Interp *interp) +int +TclThreadList(interp) + Tcl_Interp *interp; { ThreadSpecificData *tsdPtr; Tcl_Obj *listPtr; @@ -774,17 +663,18 @@ ThreadList( Tcl_MutexLock(&threadMutex); for (tsdPtr = threadList ; tsdPtr ; tsdPtr = tsdPtr->nextPtr) { Tcl_ListObjAppendElement(interp, listPtr, - Tcl_NewLongObj((long)(size_t)tsdPtr->threadId)); + Tcl_NewLongObj((long)tsdPtr->threadId)); } Tcl_MutexUnlock(&threadMutex); Tcl_SetObjResult(interp, listPtr); return TCL_OK; } + /* *------------------------------------------------------------------------ * - * ThreadSend -- + * TclThreadSend -- * * Send a script to another thread. * @@ -796,13 +686,12 @@ ThreadList( * *------------------------------------------------------------------------ */ - -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. */ +int +TclThreadSend(interp, id, script, wait) + Tcl_Interp *interp; /* The current interpreter. */ + Tcl_ThreadId id; /* Thread Id of other interpreter. */ + char *script; /* The script to evaluate. */ + int wait; /* If 1, we block for the result. */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); ThreadEvent *threadEventPtr; @@ -810,7 +699,7 @@ ThreadSend( int found, code; Tcl_ThreadId threadId = (Tcl_ThreadId) id; - /* + /* * Verify the thread exists. */ @@ -829,26 +718,26 @@ ThreadSend( } /* - * Short circut sends to ourself. Ought to do something with -async, like - * run in an idle handler. + * Short circut sends to ourself. Ought to do something with -async, + * like run in an idle handler. */ if (threadId == Tcl_GetCurrentThread()) { - Tcl_MutexUnlock(&threadMutex); + Tcl_MutexUnlock(&threadMutex); return Tcl_GlobalEval(interp, script); } - /* + /* * Create the event for its event queue. */ - threadEventPtr = ckalloc(sizeof(ThreadEvent)); + threadEventPtr = (ThreadEvent *) ckalloc(sizeof(ThreadEvent)); threadEventPtr->script = ckalloc(strlen(script) + 1); strcpy(threadEventPtr->script, script); if (!wait) { resultPtr = threadEventPtr->resultPtr = NULL; } else { - resultPtr = ckalloc(sizeof(ThreadEventResult)); + resultPtr = (ThreadEventResult *) ckalloc(sizeof(ThreadEventResult)); threadEventPtr->resultPtr = resultPtr; /* @@ -861,7 +750,7 @@ ThreadSend( resultPtr->errorInfo = NULL; resultPtr->errorCode = NULL; - /* + /* * Maintain the cleanup list. */ @@ -881,7 +770,7 @@ ThreadSend( */ threadEventPtr->event.proc = ThreadEventProc; - Tcl_ThreadQueueEvent(threadId, (Tcl_Event *) threadEventPtr, + Tcl_ThreadQueueEvent(threadId, (Tcl_Event *)threadEventPtr, TCL_QUEUE_TAIL); Tcl_ThreadAlert(threadId); @@ -890,13 +779,13 @@ ThreadSend( return TCL_OK; } - /* + /* * Block on the results and then get them. */ Tcl_ResetResult(interp); while (resultPtr->result == NULL) { - Tcl_ConditionWait(&resultPtr->done, &threadMutex, NULL); + Tcl_ConditionWait(&resultPtr->done, &threadMutex, NULL); } /* @@ -931,66 +820,11 @@ ThreadSend( Tcl_ConditionFinalize(&resultPtr->done); code = resultPtr->code; - ckfree(resultPtr); + ckfree((char *) 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); -} /* *------------------------------------------------------------------------ @@ -1007,18 +841,17 @@ ThreadCancel( * *------------------------------------------------------------------------ */ - static int -ThreadEventProc( - Tcl_Event *evPtr, /* Really ThreadEvent */ - int mask) +ThreadEventProc(evPtr, mask) + Tcl_Event *evPtr; /* Really ThreadEvent */ + int mask; { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - ThreadEvent *threadEventPtr = (ThreadEvent *) evPtr; + ThreadEvent *threadEventPtr = (ThreadEvent *)evPtr; ThreadEventResult *resultPtr = threadEventPtr->resultPtr; Tcl_Interp *interp = tsdPtr->interp; int code; - const char *result, *errorCode, *errorInfo; + CONST char *result, *errorCode, *errorInfo; if (interp == NULL) { code = TCL_ERROR; @@ -1026,11 +859,13 @@ ThreadEventProc( errorCode = "THREAD"; errorInfo = ""; } else { - Tcl_Preserve(interp); + Tcl_Preserve((ClientData) interp); Tcl_ResetResult(interp); - Tcl_CreateThreadExitHandler(ThreadFreeProc, threadEventPtr->script); + Tcl_CreateThreadExitHandler(ThreadFreeProc, + (ClientData) threadEventPtr->script); code = Tcl_GlobalEval(interp, threadEventPtr->script); - Tcl_DeleteThreadExitHandler(ThreadFreeProc, threadEventPtr->script); + Tcl_DeleteThreadExitHandler(ThreadFreeProc, + (ClientData) threadEventPtr->script); if (code != TCL_OK) { errorCode = Tcl_GetVar(interp, "errorCode", TCL_GLOBAL_ONLY); errorInfo = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY); @@ -1057,7 +892,7 @@ ThreadEventProc( Tcl_MutexUnlock(&threadMutex); } if (interp != NULL) { - Tcl_Release(interp); + Tcl_Release((ClientData) interp); } return 1; } @@ -1078,14 +913,13 @@ ThreadEventProc( * *------------------------------------------------------------------------ */ - /* ARGSUSED */ static void -ThreadFreeProc( - ClientData clientData) +ThreadFreeProc(clientData) + ClientData clientData; { if (clientData) { - ckfree(clientData); + ckfree((char *) clientData); } } @@ -1105,23 +939,20 @@ ThreadFreeProc( * *------------------------------------------------------------------------ */ - /* ARGSUSED */ static int -ThreadDeleteEvent( - Tcl_Event *eventPtr, /* Really ThreadEvent */ - ClientData clientData) /* dummy */ +ThreadDeleteEvent(eventPtr, clientData) + Tcl_Event *eventPtr; /* Really ThreadEvent */ + ClientData clientData; /* dummy */ { if (eventPtr->proc == ThreadEventProc) { - ckfree(((ThreadEvent *) eventPtr)->script); + ckfree((char *) ((ThreadEvent *) eventPtr)->script); return 1; } - /* - * If it was NULL, we were in the middle of servicing the event and it - * should be removed + * If it was NULL, we were in the middle of servicing the event + * and it should be removed */ - return (eventPtr->proc == NULL); } @@ -1130,48 +961,41 @@ ThreadDeleteEvent( * * ThreadExitProc -- * - * This is called when the thread exits. + * 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. + * 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) +ThreadExitProc(clientData) + ClientData clientData; { - char *threadEvalScript = clientData; + char *threadEvalScript = (char *) 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); + ckfree((char *) threadEvalScript); threadEvalScript = NULL; } - Tcl_DeleteEvents((Tcl_EventDeleteProc *) ThreadDeleteEvent, 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. + * 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 { @@ -1182,17 +1006,16 @@ ThreadExitProc( } resultPtr->nextPtr = resultPtr->prevPtr = 0; resultPtr->eventPtr->resultPtr = NULL; - ckfree(resultPtr); + ckfree((char *)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. + * 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); + char *msg = "target thread died"; + resultPtr->result = ckalloc(strlen(msg)+1); strcpy(resultPtr->result, msg); resultPtr->code = TCL_ERROR; Tcl_ConditionNotify(&resultPtr->done); @@ -1200,12 +1023,5 @@ ThreadExitProc( } Tcl_MutexUnlock(&threadMutex); } + #endif /* TCL_THREADS */ - -/* - * Local Variables: - * mode: c - * c-basic-offset: 4 - * fill-column: 78 - * End: - */ |