riscv
/
OpenFPGA
mirror of https://github.com/lnis-uofu/OpenFPGA.git
1
0
Fork 0
Code Issues Projects Releases Wiki Activity
OpenFPGA/libs/EXTERNAL/tcl8.6.12/pkgs/thread2.8.7/generic/threadCmd.c

3943 lines
106 KiB
C
Raw Normal View History

adding Tcl interface to vpr
2022-06-07 11:15:20 -05:00
/*
* threadCmd.c --
*
* This file implements the Tcl thread commands that allow script
* level access to threading. It will not load into a core that was
* not compiled for thread support.
*
* See http://www.tcl.tk/doc/howto/thread_model.html
*
* 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) 1999,2000 by Scriptics Corporation.
* Copyright (c) 2002 by Zoran Vasiljevic.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
* ----------------------------------------------------------------------------
*/
#include "tclThreadInt.h"
/*
* Provide package version in build contexts which do not provide
* -DPACKAGE_VERSION, like building a shell with the Thread object
* files built as part of that shell. Example: basekits.
*/
#ifndef PACKAGE_VERSION
#define PACKAGE_VERSION "2.8.7"
#endif
/*
* Check if this is Tcl 8.5 or higher. In that case, we will have the TIP
* #143 APIs (i.e. interpreter resource limiting) available.
*/
#ifndef TCL_TIP143
# if TCL_MINIMUM_VERSION(8,5)
# define TCL_TIP143
# endif
#endif
/*
* If TIP #143 support is enabled and we are compiling against a pre-Tcl 8.5
* core, hard-wire the necessary APIs using the "well-known" offsets into the
* stubs table.
*/
#define haveInterpLimit (threadTclVersion>=85)
#if defined(TCL_TIP143) && !TCL_MINIMUM_VERSION(8,5)
# if defined(USE_TCL_STUBS)
# define Tcl_LimitExceeded ((int (*)(Tcl_Interp *)) \
((&(tclStubsPtr->tcl_PkgProvideEx))[524]))
# else
# error "Supporting TIP #143 requires USE_TCL_STUBS before Tcl 8.5"
# endif
#endif
/*
* Check if this is Tcl 8.6 or higher. In that case, we will have the TIP
* #285 APIs (i.e. asynchronous script cancellation) available.
*/
#define haveInterpCancel (threadTclVersion>=86)
#ifndef TCL_TIP285
# if TCL_MINIMUM_VERSION(8,6)
# define TCL_TIP285
# endif
#endif
/*
* If TIP #285 support is enabled and we are compiling against a pre-Tcl 8.6
* core, hard-wire the necessary APIs using the "well-known" offsets into the
* stubs table.
*/
#if defined(TCL_TIP285) && !TCL_MINIMUM_VERSION(8,6)
# if defined(USE_TCL_STUBS)
# define TCL_CANCEL_UNWIND 0x100000
# define Tcl_CancelEval ((int (*)(Tcl_Interp *, Tcl_Obj *, ClientData, int)) \
((&(tclStubsPtr->tcl_PkgProvideEx))[580]))
# define Tcl_Canceled ((int (*)(Tcl_Interp *, int)) \
((&(tclStubsPtr->tcl_PkgProvideEx))[581]))
# else
# error "Supporting TIP #285 requires USE_TCL_STUBS before Tcl 8.6"
# endif
#endif
/*
* Access to the list of threads and to the thread send results
* (defined below) is guarded by this mutex.
*/
TCL_DECLARE_MUTEX(threadMutex)
/*
* 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 interpreter can send
* messages but only the main interpreter can receive them, unless you're
* not doing asynchronous script backfiring. In such cases the caller might
* signal the thread to which interpreter the result should be delivered.
*/
typedef struct ThreadSpecificData {
Tcl_ThreadId threadId; /* The real ID of this thread */
Tcl_Interp *interp; /* Main interp for this thread */
Tcl_Condition doOneEvent; /* Signalled just before running
an event from the event loop */
int flags; /* One of the ThreadFlags below */
size_t refCount; /* Used for thread reservation */
int eventsPending; /* # of unprocessed events */
int maxEventsCount; /* Maximum # of pending events */
struct ThreadEventResult *result;
struct ThreadSpecificData *nextPtr;
struct ThreadSpecificData *prevPtr;
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
#define THREAD_FLAGS_NONE 0 /* None */
#define THREAD_FLAGS_STOPPED 1 /* Thread is being stopped */
#define THREAD_FLAGS_INERROR 2 /* Thread is in error */
#define THREAD_FLAGS_UNWINDONERROR 4 /* Thread unwinds on script error */
#define THREAD_RESERVE 1 /* Reserves the thread */
#define THREAD_RELEASE 2 /* Releases the thread */
/*
* Length of storage for building the Tcl handle for the thread.
*/
#define THREAD_HNDLPREFIX "tid"
#define THREAD_HNDLMAXLEN 32
/*
* This list is used to list all threads that have interpreters.
*/
static struct ThreadSpecificData *threadList = NULL;
/*
* Used to represent the empty result.
*/
static char *threadEmptyResult = (char *)"";
int threadTclVersion = 0;
/*
* 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 {
char *script; /* Script to execute */
int flags; /* Initial value of the "flags"
* field in ThreadSpecificData */
Tcl_Condition condWait; /* Condition variable used to
* sync parent and child threads */
ClientData cd; /* Opaque ptr to pass to thread */
} ThreadCtrl;
/*
* Structure holding result of the command executed in target thread.
*/
typedef struct ThreadEventResult {
Tcl_Condition done; /* Set when the script completes */
int code; /* Return value of the function */
char *result; /* Result from the function */
char *errorInfo; /* Copy of errorInfo variable */
char *errorCode; /* Copy of errorCode variable */
Tcl_ThreadId srcThreadId; /* Id of sender, if it dies */
Tcl_ThreadId dstThreadId; /* Id of target, if it dies */
struct ThreadEvent *eventPtr; /* Back pointer */
struct ThreadEventResult *nextPtr; /* List for cleanup */
struct ThreadEventResult *prevPtr;
} ThreadEventResult;
/*
* This list links all active ThreadEventResult structures. This way
* an exiting thread can inform all threads waiting on jobs posted to
* his event queue that it is dying, so they might stop waiting.
*/
static ThreadEventResult *resultList;
/*
* This is the event used to send commands to other threads.
*/
typedef struct ThreadEvent {
Tcl_Event event; /* Must be first */
struct ThreadSendData *sendData; /* See below */
struct ThreadClbkData *clbkData; /* See below */
struct ThreadEventResult *resultPtr; /* To communicate the result back.
* NULL if we don't care about it */
} ThreadEvent;
typedef int (ThreadSendProc) (Tcl_Interp*, ClientData);
static ThreadSendProc ThreadSendEval; /* Does a regular Tcl_Eval */
static ThreadSendProc ThreadClbkSetVar; /* Sets the named variable */
/*
* These structures are used to communicate commands between source and target
* threads. The ThreadSendData is used for source->target command passing,
* while the ThreadClbkData is used for doing asynchronous callbacks.
*
* Important: structures below must have first two elements identical!
*/
typedef struct ThreadSendData {
ThreadSendProc *execProc; /* Func to exec in remote thread */
ClientData clientData; /* Ptr to pass to send function */
/* ---- */
Tcl_Interp *interp; /* Interp to run the command */
char script[1]; /* Script to be executed */
} ThreadSendData;
typedef struct ThreadClbkData {
ThreadSendProc *execProc; /* The callback function */
ClientData clientData; /* Ptr to pass to clbk function */
/* ---- */
Tcl_Interp *interp; /* Interp to run the command */
Tcl_ThreadId threadId; /* Thread where to post callback */
ThreadEventResult result; /* Returns result asynchronously */
char var[1]; /* Variable name to be set */
} ThreadClbkData;
/*
* Event used to transfer a channel between threads.
*/
typedef struct TransferEvent {
Tcl_Event event; /* Must be first */
Tcl_Channel chan; /* The channel to transfer */
struct TransferResult *resultPtr; /* To communicate the result */
} TransferEvent;
typedef struct TransferResult {
Tcl_Condition done; /* Set when transfer is done */
int resultCode; /* Set to TCL_OK or TCL_ERROR when
the transfer is done. Def = -1 */
char *resultMsg; /* Initialized to NULL. Set to a
allocated string by the target
thread in case of an error */
Tcl_ThreadId srcThreadId; /* Id of src thread, if it dies */
Tcl_ThreadId dstThreadId; /* Id of tgt thread, if it dies */
struct TransferEvent *eventPtr; /* Back pointer */
struct TransferResult *nextPtr; /* Next in the linked list */
struct TransferResult *prevPtr; /* Previous in the linked list */
} TransferResult;
static TransferResult *transferList;
/*
* This is for simple error handling when a thread script exits badly.
*/
static Tcl_ThreadId errorThreadId; /* Id of thread to post error message */
static char *errorProcString; /* Tcl script to run when reporting error */
/*
* Definition of flags for ThreadSend.
*/
#define THREAD_SEND_WAIT (1<<1)
#define THREAD_SEND_HEAD (1<<2)
#define THREAD_SEND_CLBK (1<<3)
#ifdef BUILD_thread
# undef TCL_STORAGE_CLASS
# define TCL_STORAGE_CLASS DLLEXPORT
#endif
/*
* Miscellaneous functions used within this file
*/
static Tcl_EventDeleteProc ThreadDeleteEvent;
static Tcl_ThreadCreateType
NewThread(ClientData clientData);
static ThreadSpecificData*
ThreadExistsInner(Tcl_ThreadId id);
static const char *
ThreadInit(Tcl_Interp *interp);
static int
ThreadCreate(Tcl_Interp *interp,
const char *script,
int stacksize,
int flags,
int preserve);
static int
ThreadSend(Tcl_Interp *interp,
Tcl_ThreadId id,
ThreadSendData *sendPtr,
ThreadClbkData *clbkPtr,
int flags);
static void
ThreadSetResult(Tcl_Interp *interp,
int code,
ThreadEventResult *resultPtr);
static int
ThreadGetOption(Tcl_Interp *interp,
Tcl_ThreadId id,
char *option,
Tcl_DString *ds);
static int
ThreadSetOption(Tcl_Interp *interp,
Tcl_ThreadId id,
char *option,
char *value);
static int
ThreadReserve(Tcl_Interp *interp,
Tcl_ThreadId id,
int operation,
int wait);
static int
ThreadEventProc(Tcl_Event *evPtr,
int mask);
static int
ThreadWait(Tcl_Interp *interp);
static int
ThreadExists(Tcl_ThreadId id);
static int
ThreadList(Tcl_Interp *interp,
Tcl_ThreadId **thrIdArray);
static void
ThreadErrorProc(Tcl_Interp *interp);
static void
ThreadFreeProc(ClientData clientData);
static void
ThreadIdleProc(ClientData clientData);
static void
ThreadExitProc(ClientData clientData);
static void
ThreadFreeError(ClientData clientData);
static void
ListRemove(ThreadSpecificData *tsdPtr);
static void
ListRemoveInner(ThreadSpecificData *tsdPtr);
static void
ListUpdate(ThreadSpecificData *tsdPtr);
static void
ListUpdateInner(ThreadSpecificData *tsdPtr);
static int
ThreadJoin(Tcl_Interp *interp,
Tcl_ThreadId id);
static int
ThreadTransfer(Tcl_Interp *interp,
Tcl_ThreadId id,
Tcl_Channel chan);
static int
ThreadDetach(Tcl_Interp *interp,
Tcl_Channel chan);
static int
ThreadAttach(Tcl_Interp *interp,
char *chanName);
static int
TransferEventProc(Tcl_Event *evPtr,
int mask);
static void
ThreadGetHandle(Tcl_ThreadId,
char *handlePtr);
static int
ThreadGetId(Tcl_Interp *interp,
Tcl_Obj *handleObj,
Tcl_ThreadId *thrIdPtr);
static void
ErrorNoSuchThread(Tcl_Interp *interp,
Tcl_ThreadId thrId);
static void
ThreadCutChannel(Tcl_Interp *interp,
Tcl_Channel channel);
#ifdef TCL_TIP285
static int
ThreadCancel(Tcl_Interp *interp,
Tcl_ThreadId thrId,
const char *result,
int flags);
#endif
/*
* Functions implementing Tcl commands
*/
static Tcl_ObjCmdProc ThreadCreateObjCmd;
static Tcl_ObjCmdProc ThreadReserveObjCmd;
static Tcl_ObjCmdProc ThreadReleaseObjCmd;
static Tcl_ObjCmdProc ThreadSendObjCmd;
static Tcl_ObjCmdProc ThreadBroadcastObjCmd;
static Tcl_ObjCmdProc ThreadUnwindObjCmd;
static Tcl_ObjCmdProc ThreadExitObjCmd;
static Tcl_ObjCmdProc ThreadIdObjCmd;
static Tcl_ObjCmdProc ThreadNamesObjCmd;
static Tcl_ObjCmdProc ThreadWaitObjCmd;
static Tcl_ObjCmdProc ThreadExistsObjCmd;
static Tcl_ObjCmdProc ThreadConfigureObjCmd;
static Tcl_ObjCmdProc ThreadErrorProcObjCmd;
static Tcl_ObjCmdProc ThreadJoinObjCmd;
static Tcl_ObjCmdProc ThreadTransferObjCmd;
static Tcl_ObjCmdProc ThreadDetachObjCmd;
static Tcl_ObjCmdProc ThreadAttachObjCmd;
#ifdef TCL_TIP285
static Tcl_ObjCmdProc ThreadCancelObjCmd;
#endif
static const char *
ThreadInit(
Tcl_Interp *interp /* The current Tcl interpreter */
) {
if (Tcl_InitStubs(interp, "8.4", 0) == NULL) {
return NULL;
}
if (!threadTclVersion) {
/*
* Check whether we are running threaded Tcl.
* Get the current core version to decide whether to use
* some lately introduced core features or to back-off.
*/
int major, minor;
Tcl_MutexLock(&threadMutex);
if (threadMutex == NULL){
/* If threadMutex==NULL here, it means that Tcl_MutexLock() is
* a dummy function, which is the case in unthreaded Tcl */
const char *msg = "Tcl core wasn't compiled for threading";
Tcl_SetObjResult(interp, Tcl_NewStringObj(msg, -1));
return NULL;
}
Tcl_GetVersion(&major, &minor, NULL, NULL);
threadTclVersion = 10 * major + minor;
Tcl_MutexUnlock(&threadMutex);
}
TCL_CMD(interp, THREAD_CMD_PREFIX"create", ThreadCreateObjCmd);
TCL_CMD(interp, THREAD_CMD_PREFIX"send", ThreadSendObjCmd);
TCL_CMD(interp, THREAD_CMD_PREFIX"broadcast", ThreadBroadcastObjCmd);
TCL_CMD(interp, THREAD_CMD_PREFIX"exit", ThreadExitObjCmd);
TCL_CMD(interp, THREAD_CMD_PREFIX"unwind", ThreadUnwindObjCmd);
TCL_CMD(interp, THREAD_CMD_PREFIX"id", ThreadIdObjCmd);
TCL_CMD(interp, THREAD_CMD_PREFIX"names", ThreadNamesObjCmd);
TCL_CMD(interp, THREAD_CMD_PREFIX"exists", ThreadExistsObjCmd);
TCL_CMD(interp, THREAD_CMD_PREFIX"wait", ThreadWaitObjCmd);
TCL_CMD(interp, THREAD_CMD_PREFIX"configure", ThreadConfigureObjCmd);
TCL_CMD(interp, THREAD_CMD_PREFIX"errorproc", ThreadErrorProcObjCmd);
TCL_CMD(interp, THREAD_CMD_PREFIX"preserve", ThreadReserveObjCmd);
TCL_CMD(interp, THREAD_CMD_PREFIX"release", ThreadReleaseObjCmd);
TCL_CMD(interp, THREAD_CMD_PREFIX"join", ThreadJoinObjCmd);
TCL_CMD(interp, THREAD_CMD_PREFIX"transfer", ThreadTransferObjCmd);
TCL_CMD(interp, THREAD_CMD_PREFIX"detach", ThreadDetachObjCmd);
TCL_CMD(interp, THREAD_CMD_PREFIX"attach", ThreadAttachObjCmd);
#ifdef TCL_TIP285
TCL_CMD(interp, THREAD_CMD_PREFIX"cancel", ThreadCancelObjCmd);
#endif
/*
* Add shared variable commands
*/
SvInit(interp);
/*
* Add commands to access thread
* synchronization primitives.
*/
SpInit(interp);
/*
* Add threadpool commands.
*/
TpoolInit(interp);
return PACKAGE_VERSION;
}
/*
*----------------------------------------------------------------------
*
* Thread_Init --
*
* Initialize the thread commands.
*
* Results:
* TCL_OK if the package was properly initialized.
*
* Side effects:
* Adds package commands to the current interp.
*
*----------------------------------------------------------------------
*/
DLLEXPORT int
Thread_Init(
Tcl_Interp *interp /* The current Tcl interpreter */
) {
const char *version = ThreadInit(interp);
if (version == NULL) {
return TCL_ERROR;
}
return Tcl_PkgProvideEx(interp, "Thread", version, NULL);
}
/*
*----------------------------------------------------------------------
*
* Init --
*
* Make sure internal list of threads references the current thread.
*
* Results:
* None
*
* Side effects:
* The list of threads is initialized to include the current thread.
*
*----------------------------------------------------------------------
*/
static void
Init(
Tcl_Interp *interp /* Current interpreter. */
) {
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (tsdPtr->interp == NULL) {
memset(tsdPtr, 0, sizeof(ThreadSpecificData));
tsdPtr->interp = interp;
ListUpdate(tsdPtr);
Tcl_CreateThreadExitHandler(ThreadExitProc,
threadEmptyResult);
}
}
/*
*----------------------------------------------------------------------
*
* ThreadCreateObjCmd --
*
* This procedure is invoked to process the "thread::create" Tcl
* command. See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
ThreadCreateObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[] /* Argument objects. */
) {
int argc, rsrv = 0;
const char *arg, *script;
int flags = TCL_THREAD_NOFLAGS;
(void)dummy;
Init(interp);
/*
* Syntax: thread::create ?-joinable? ?-preserved? ?script?
*/
script = THREAD_CMD_PREFIX"wait";
for (argc = 1; argc < objc; argc++) {
arg = Tcl_GetString(objv[argc]);
if (OPT_CMP(arg, "--")) {
argc++;
if ((argc + 1) == objc) {
script = Tcl_GetString(objv[argc]);
} else {
goto usage;
}
break;
} else if (OPT_CMP(arg, "-joinable")) {
flags |= TCL_THREAD_JOINABLE;
} else if (OPT_CMP(arg, "-preserved")) {
rsrv = 1;
} else if ((argc + 1) == objc) {
script = Tcl_GetString(objv[argc]);
} else {
goto usage;
}
}
return ThreadCreate(interp, script, TCL_THREAD_STACK_DEFAULT, flags, rsrv);
usage:
Tcl_WrongNumArgs(interp, 1, objv, "?-joinable? ?script?");
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* ThreadReserveObjCmd --
*
* This procedure is invoked to process the "thread::preserve" and
* "thread::release" Tcl commands, depending on the flag passed by
* the ClientData argument. See the user documentation for details
* on what those command do.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
ThreadReserveObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[] /* Argument objects. */
) {
Tcl_ThreadId thrId = NULL;
(void)dummy;
Init(interp);
if (objc > 2) {
Tcl_WrongNumArgs(interp, 1, objv, "?threadId?");
return TCL_ERROR;
}
if (objc == 2) {
if (ThreadGetId(interp, objv[1], &thrId) != TCL_OK) {
return TCL_ERROR;
}
}
return ThreadReserve(interp, thrId, THREAD_RESERVE, 0);
}
/*
*----------------------------------------------------------------------
*
* ThreadReleaseObjCmd --
*
* This procedure is invoked to process the "thread::release" Tcl
* command. See the user documentation for details on what this
* command does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
ThreadReleaseObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[] /* Argument objects. */
) {
int wait = 0;
Tcl_ThreadId thrId = NULL;
(void)dummy;
Init(interp);
if (objc > 3) {
Tcl_WrongNumArgs(interp, 1, objv, "?-wait? ?threadId?");
return TCL_ERROR;
}
if (objc > 1) {
if (OPT_CMP(Tcl_GetString(objv[1]), "-wait")) {
wait = 1;
if (objc > 2) {
if (ThreadGetId(interp, objv[2], &thrId) != TCL_OK) {
return TCL_ERROR;
}
}
} else if (ThreadGetId(interp, objv[1], &thrId) != TCL_OK) {
return TCL_ERROR;
}
}
return ThreadReserve(interp, thrId, THREAD_RELEASE, wait);
}
/*
*----------------------------------------------------------------------
*
* ThreadUnwindObjCmd --
*
* This procedure is invoked to process the "thread::unwind" Tcl
* command. See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
ThreadUnwindObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[] /* Argument objects. */
) {
(void)dummy;
Init(interp);
if (objc > 1) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
return TCL_ERROR;
}
return ThreadReserve(interp, 0, THREAD_RELEASE, 0);
}
/*
*----------------------------------------------------------------------
*
* ThreadExitObjCmd --
*
* This procedure is invoked to process the "thread::exit" Tcl
* command. This causes an unconditional close of the thread
* and is GUARANTEED to cause memory leaks. Use this with caution.
*
* Results:
* Doesn't actually return.
*
* Side effects:
* Lots. improper clean up of resources.
*
*----------------------------------------------------------------------
*/
static int
ThreadExitObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[] /* Argument objects. */
) {
int status = 666;
(void)dummy;
Init(interp);
if (objc > 2) {
Tcl_WrongNumArgs(interp, 1, objv, "?status?");
return TCL_ERROR;
}
if (objc == 2) {
if (Tcl_GetIntFromObj(interp, objv[1], &status) != TCL_OK) {
return TCL_ERROR;
}
}
ListRemove(NULL);
Tcl_ExitThread(status);
return TCL_OK; /* NOT REACHED */
}
/*
*----------------------------------------------------------------------
*
* ThreadIdObjCmd --
*
* This procedure is invoked to process the "thread::id" Tcl command.
* This returns the ID of the current thread.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
ThreadIdObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[] /* Argument objects. */
) {
char thrHandle[THREAD_HNDLMAXLEN];
(void)dummy;
Init(interp);
if (objc > 1) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
return TCL_ERROR;
}
ThreadGetHandle(Tcl_GetCurrentThread(), thrHandle);
Tcl_SetObjResult(interp, Tcl_NewStringObj(thrHandle, -1));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* ThreadNamesObjCmd --
*
* This procedure is invoked to process the "thread::names" Tcl
* command. This returns a list of all known thread IDs.
* These are only threads created via this module (e.g., not
* driver threads or the notifier).
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
ThreadNamesObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[] /* Argument objects. */
) {
int ii, length;
char *result, thrHandle[THREAD_HNDLMAXLEN];
Tcl_ThreadId *thrIdArray;
Tcl_DString threadNames;
(void)dummy;
Init(interp);
if (objc > 1) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
return TCL_ERROR;
}
length = ThreadList(interp, &thrIdArray);
if (length == 0) {
return TCL_OK;
}
Tcl_DStringInit(&threadNames);
for (ii = 0; ii < length; ii++) {
ThreadGetHandle(thrIdArray[ii], thrHandle);
Tcl_DStringAppendElement(&threadNames, thrHandle);
}
length = Tcl_DStringLength(&threadNames);
result = Tcl_DStringValue(&threadNames);
Tcl_SetObjResult(interp, Tcl_NewStringObj(result, length));
Tcl_DStringFree(&threadNames);
ckfree((char*)thrIdArray);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* ThreadSendObjCmd --
*
* This procedure is invoked to process the "thread::send" Tcl
* command. This sends a script to another thread for execution.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
ThreadSendObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[] /* Argument objects. */
) {
size_t size;
int ret, ii = 0, flags = 0;
Tcl_ThreadId thrId;
const char *script, *arg;
Tcl_Obj *var = NULL;
ThreadClbkData *clbkPtr = NULL;
ThreadSendData *sendPtr = NULL;
(void)dummy;
Init(interp);
/*
* Syntax: thread::send ?-async? ?-head? threadId script ?varName?
*/
if (objc < 3 || objc > 6) {
goto usage;
}
flags = THREAD_SEND_WAIT;
for (ii = 1; ii < objc; ii++) {
arg = Tcl_GetString(objv[ii]);
if (OPT_CMP(arg, "-async")) {
flags &= ~THREAD_SEND_WAIT;
} else if (OPT_CMP(arg, "-head")) {
flags |= THREAD_SEND_HEAD;
} else {
break;
}
}
if (ii >= objc) {
goto usage;
}
if (ThreadGetId(interp, objv[ii], &thrId) != TCL_OK) {
return TCL_ERROR;
}
if (++ii >= objc) {
goto usage;
}
script = Tcl_GetString(objv[ii]);
size = objv[ii]->length+1;
if (++ii < objc) {
var = objv[ii];
}
if (var && (flags & THREAD_SEND_WAIT) == 0) {
const char *varName = Tcl_GetString(var);
size_t vsize = var->length + 1;
if (thrId == Tcl_GetCurrentThread()) {
/*
* FIXME: Do something for callbacks to self
*/
Tcl_SetObjResult(interp, Tcl_NewStringObj("can't notify self", -1));
return TCL_ERROR;
}
/*
* Prepare record for the callback. This is asynchronously
* posted back to us when the target thread finishes processing.
* We should do a vwait on the "var" to get notified.
*/
clbkPtr = (ThreadClbkData*)ckalloc(sizeof(ThreadClbkData) + vsize);
clbkPtr->execProc = ThreadClbkSetVar;
clbkPtr->interp = interp;
clbkPtr->threadId = Tcl_GetCurrentThread();
memcpy(clbkPtr->var, varName, vsize);
clbkPtr->clientData = NULL;
}
/*
* Prepare job record for the target thread
*/
sendPtr = (ThreadSendData*)ckalloc(sizeof(ThreadSendData) + size);
sendPtr->interp = NULL; /* Signal to use thread main interp */
sendPtr->execProc = ThreadSendEval;
memcpy(sendPtr->script, script, size);
sendPtr->clientData = NULL;
ret = ThreadSend(interp, thrId, sendPtr, clbkPtr, flags);
if (var && (flags & THREAD_SEND_WAIT)) {
/*
* Leave job's result in passed variable
* and return the code, like "catch" does.
*/
Tcl_Obj *resultObj = Tcl_GetObjResult(interp);
if (!Tcl_ObjSetVar2(interp, var, NULL, resultObj, TCL_LEAVE_ERR_MSG)) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewIntObj(ret));
return TCL_OK;
}
return ret;
usage:
Tcl_WrongNumArgs(interp,1,objv,"?-async? ?-head? id script ?varName?");
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* ThreadBroadcastObjCmd --
*
* This procedure is invoked to process the "thread::broadcast" Tcl
* command. This asynchronously sends a script to all known threads.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Script is sent to all known threads except the caller thread.
*
*----------------------------------------------------------------------
*/
static int
ThreadBroadcastObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[] /* Argument objects. */
) {
int ii, nthreads;
size_t size;
const char *script;
Tcl_ThreadId *thrIdArray;
ThreadSendData *sendPtr, job;
(void)dummy;
Init(interp);
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "script");
return TCL_ERROR;
}
script = Tcl_GetString(objv[1]);
size = objv[1]->length + 1;
/*
* Get the list of known threads. Note that this one may
* actually change (thread may exit or otherwise cease to
* exist) while we circle in the loop below. We really do
* not care about that here since we don't return any
* script results to the caller.
*/
nthreads = ThreadList(interp, &thrIdArray);
if (nthreads == 0) {
return TCL_OK;
}
/*
* Prepare the structure with the job description
* to be sent asynchronously to each known thread.
*/
job.interp = NULL; /* Signal to use thread's main interp */
job.execProc = ThreadSendEval;
job.clientData = NULL;
/*
* Now, circle this list and send each thread the script.
* This is sent asynchronously, since we do not care what
* are they going to do with it. Also, the event is queued
* to the head of the event queue (as out-of-band message).
*/
for (ii = 0; ii < nthreads; ii++) {
if (thrIdArray[ii] == Tcl_GetCurrentThread()) {
continue; /* Do not broadcast self */
}
sendPtr = (ThreadSendData*)ckalloc(sizeof(ThreadSendData) + size);
*sendPtr = job;
memcpy(sendPtr->script, script, size);
sendPtr->clientData = NULL;
ThreadSend(interp, thrIdArray[ii], sendPtr, NULL, THREAD_SEND_HEAD);
}
ckfree((char*)thrIdArray);
Tcl_ResetResult(interp);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* ThreadWaitObjCmd --
*
* This procedure is invoked to process the "thread::wait" Tcl
* command. This enters the event loop.
*
* Results:
* Standard Tcl result.
*
* Side effects:
* Enters the event loop.
*
*----------------------------------------------------------------------
*/
static int
ThreadWaitObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[] /* Argument objects. */
) {
(void)dummy;
Init(interp);
if (objc > 1) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
return TCL_ERROR;
}
return ThreadWait(interp);
}
/*
*----------------------------------------------------------------------
*
* ThreadErrorProcObjCmd --
*
* This procedure is invoked to process the "thread::errorproc"
* command. This registers a procedure to handle thread errors.
* Empty string as the name of the procedure will reset the
* default behaviour, which is writing to standard error channel.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Registers an errorproc.
*
*----------------------------------------------------------------------
*/
static int
ThreadErrorProcObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[] /* Argument objects. */
) {
size_t len;
char *proc;
(void)dummy;
Init(interp);
if (objc > 2) {
Tcl_WrongNumArgs(interp, 1, objv, "?proc?");
return TCL_ERROR;
}
Tcl_MutexLock(&threadMutex);
if (objc == 1) {
if (errorProcString) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(errorProcString, -1));
}
} else {
if (errorProcString) {
ckfree(errorProcString);
}
proc = Tcl_GetString(objv[1]);
len = objv[1]->length;
if (len == 0) {
errorThreadId = NULL;
errorProcString = NULL;
} else {
errorThreadId = Tcl_GetCurrentThread();
errorProcString = (char *)ckalloc(1+strlen(proc));
strcpy(errorProcString, proc);
Tcl_DeleteThreadExitHandler(ThreadFreeError, NULL);
Tcl_CreateThreadExitHandler(ThreadFreeError, NULL);
}
}
Tcl_MutexUnlock(&threadMutex);
return TCL_OK;
}
static void
ThreadFreeError(
ClientData dummy
) {
(void)dummy;
Tcl_MutexLock(&threadMutex);
if (errorThreadId != Tcl_GetCurrentThread()) {
Tcl_MutexUnlock(&threadMutex);
return;
}
ckfree(errorProcString);
errorThreadId = NULL;
errorProcString = NULL;
Tcl_MutexUnlock(&threadMutex);
}
/*
*----------------------------------------------------------------------
*
* ThreadJoinObjCmd --
*
* This procedure is invoked to process the "thread::join" Tcl
* command. See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
ThreadJoinObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[] /* Argument objects. */
) {
Tcl_ThreadId thrId;
(void)dummy;
Init(interp);
/*
* Syntax of 'join': id
*/
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "id");
return TCL_ERROR;
}
if (ThreadGetId(interp, objv[1], &thrId) != TCL_OK) {
return TCL_ERROR;
}
return ThreadJoin(interp, thrId);
}
/*
*----------------------------------------------------------------------
*
* ThreadTransferObjCmd --
*
* This procedure is invoked to process the "thread::transfer" Tcl
* command. See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
ThreadTransferObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[] /* Argument objects. */
) {
Tcl_ThreadId thrId;
Tcl_Channel chan;
(void)dummy;
Init(interp);
/*
* Syntax of 'transfer': id channel
*/
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "id channel");
return TCL_ERROR;
}
if (ThreadGetId(interp, objv[1], &thrId) != TCL_OK) {
return TCL_ERROR;
}
chan = Tcl_GetChannel(interp, Tcl_GetString(objv[2]), NULL);
if (chan == NULL) {
return TCL_ERROR;
}
return ThreadTransfer(interp, thrId, Tcl_GetTopChannel(chan));
}
/*
*----------------------------------------------------------------------
*
* ThreadDetachObjCmd --
*
* This procedure is invoked to process the "thread::detach" Tcl
* command. See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
ThreadDetachObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[] /* Argument objects. */
) {
Tcl_Channel chan;
(void)dummy;
Init(interp);
/*
* Syntax: thread::detach channel
*/
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "channel");
return TCL_ERROR;
}
chan = Tcl_GetChannel(interp, Tcl_GetString(objv[1]), NULL);
if (chan == NULL) {
return TCL_ERROR;
}
return ThreadDetach(interp, Tcl_GetTopChannel(chan));
}
/*
*----------------------------------------------------------------------
*
* ThreadAttachObjCmd --
*
* This procedure is invoked to process the "thread::attach" Tcl
* command. See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
ThreadAttachObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[] /* Argument objects. */
) {
char *chanName;
(void)dummy;
Init(interp);
/*
* Syntax: thread::attach channel
*/
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "channel");
return TCL_ERROR;
}
chanName = Tcl_GetString(objv[1]);
if (Tcl_IsChannelExisting(chanName)) {
return TCL_OK;
}
return ThreadAttach(interp, chanName);
}
/*
*----------------------------------------------------------------------
*
* ThreadExistsObjCmd --
*
* This procedure is invoked to process the "thread::exists" Tcl
* command. See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
ThreadExistsObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[] /* Argument objects. */
) {
Tcl_ThreadId thrId;
(void)dummy;
Init(interp);
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "id");
return TCL_ERROR;
}
if (ThreadGetId(interp, objv[1], &thrId) != TCL_OK) {
return TCL_ERROR;
}
Tcl_SetIntObj(Tcl_GetObjResult(interp), ThreadExists(thrId)!=0);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* ThreadConfigureObjCmd --
*
* This procedure is invoked to process the Tcl "thread::configure"
* command. See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*----------------------------------------------------------------------
*/
static int
ThreadConfigureObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[] /* Argument objects. */
) {
char *option, *value;
Tcl_ThreadId thrId; /* Id of the thread to configure */
int i; /* Iterate over arg-value pairs. */
Tcl_DString ds; /* DString to hold result of
* calling GetThreadOption. */
(void)dummy;
if (objc < 2 || (objc % 2 == 1 && objc != 3)) {
Tcl_WrongNumArgs(interp, 1, objv, "threadlId ?optionName? "
"?value? ?optionName value?...");
return TCL_ERROR;
}
Init(interp);
if (ThreadGetId(interp, objv[1], &thrId) != TCL_OK) {
return TCL_ERROR;
}
if (objc == 2) {
Tcl_DStringInit(&ds);
if (ThreadGetOption(interp, thrId, NULL, &ds) != TCL_OK) {
Tcl_DStringFree(&ds);
return TCL_ERROR;
}
Tcl_DStringResult(interp, &ds);
return TCL_OK;
}
if (objc == 3) {
Tcl_DStringInit(&ds);
option = Tcl_GetString(objv[2]);
if (ThreadGetOption(interp, thrId, option, &ds) != TCL_OK) {
Tcl_DStringFree(&ds);
return TCL_ERROR;
}
Tcl_DStringResult(interp, &ds);
return TCL_OK;
}
for (i = 3; i < objc; i += 2) {
option = Tcl_GetString(objv[i-1]);
value = Tcl_GetString(objv[i]);
if (ThreadSetOption(interp, thrId, option, value) != TCL_OK) {
return TCL_ERROR;
}
}
return TCL_OK;
}
#ifdef TCL_TIP285
/*
*----------------------------------------------------------------------
*
* ThreadCancelObjCmd --
*
* This procedure is invoked to process the "thread::cancel" Tcl
* command. See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
ThreadCancelObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[] /* Argument objects. */
) {
Tcl_ThreadId thrId;
int ii, flags;
const char *result;
(void)dummy;
if ((objc < 2) || (objc > 4)) {
Tcl_WrongNumArgs(interp, 1, objv, "?-unwind? id ?result?");
return TCL_ERROR;
}
flags = 0;
ii = 1;
if ((objc == 3) || (objc == 4)) {
if (OPT_CMP(Tcl_GetString(objv[ii]), "-unwind")) {
flags |= TCL_CANCEL_UNWIND;
ii++;
}
}
if (ThreadGetId(interp, objv[ii], &thrId) != TCL_OK) {
return TCL_ERROR;
}
ii++;
if (ii < objc) {
result = Tcl_GetString(objv[ii]);
} else {
result = NULL;
}
return ThreadCancel(interp, thrId, result, flags);
}
#endif
/*
*----------------------------------------------------------------------
*
* ThreadSendEval --
*
* Evaluates Tcl script passed from source to target thread.
*
* Results:
* A standard Tcl result.
*
* Side effects:
*
*----------------------------------------------------------------------
*/
static int
ThreadSendEval(
Tcl_Interp *interp,
ClientData clientData
) {
ThreadSendData *sendPtr = (ThreadSendData*)clientData;
char *script = (char *)sendPtr->clientData;
if (!script) script = sendPtr->script;
return Tcl_EvalEx(interp, script, -1, TCL_EVAL_GLOBAL);
}
/*
*----------------------------------------------------------------------
*
* ThreadClbkSetVar --
*
* Sets the Tcl variable in the source thread, as the result
* of the asynchronous callback.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* New Tcl variable may be created
*
*----------------------------------------------------------------------
*/
static int
ThreadClbkSetVar(
Tcl_Interp *interp,
ClientData clientData
) {
ThreadClbkData *clbkPtr = (ThreadClbkData*)clientData;
const char *var = clbkPtr->var;
Tcl_Obj *valObj;
ThreadEventResult *resultPtr = &clbkPtr->result;
int rc = TCL_OK;
/*
* Get the result of the posted command.
* We will use it to fill-in the result variable.
*/
valObj = Tcl_NewStringObj(resultPtr->result, -1);
Tcl_IncrRefCount(valObj);
if (resultPtr->result != threadEmptyResult) {
ckfree(resultPtr->result);
}
/*
* Set the result variable
*/
if (Tcl_SetVar2Ex(interp, var, NULL, valObj,
TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG) == NULL) {
rc = TCL_ERROR;
goto cleanup;
}
/*
* In case of error, trigger the bgerror mechansim
*/
if (resultPtr->code == TCL_ERROR) {
if (resultPtr->errorCode) {
var = "errorCode";
Tcl_SetVar2Ex(interp, var, NULL, Tcl_NewStringObj(resultPtr->errorCode, -1), TCL_GLOBAL_ONLY);
ckfree((char*)resultPtr->errorCode);
}
if (resultPtr->errorInfo) {
var = "errorInfo";
Tcl_SetVar2Ex(interp, var, NULL, Tcl_NewStringObj(resultPtr->errorInfo, -1), TCL_GLOBAL_ONLY);
ckfree((char*)resultPtr->errorInfo);
}
Tcl_SetObjResult(interp, valObj);
Tcl_BackgroundException(interp, TCL_ERROR);
}
cleanup:
Tcl_DecrRefCount(valObj);
return rc;
}
/*
*----------------------------------------------------------------------
*
* 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.
*
*----------------------------------------------------------------------
*/
static int
ThreadCreate(
Tcl_Interp *interp, /* Current interpreter. */
const char *script, /* Script to evaluate */
int stacksize, /* Zero for default size */
int flags, /* Zero for no flags */
int preserve /* If true, reserve the thread */
) {
char thrHandle[THREAD_HNDLMAXLEN];
ThreadCtrl ctrl;
Tcl_ThreadId thrId;
ctrl.cd = Tcl_GetAssocData(interp, "thread:nsd", NULL);
ctrl.script = (char *)script;
ctrl.condWait = NULL;
ctrl.flags = 0;
Tcl_MutexLock(&threadMutex);
if (Tcl_CreateThread(&thrId, NewThread, &ctrl,
stacksize, flags) != TCL_OK) {
Tcl_MutexUnlock(&threadMutex);
Tcl_SetObjResult(interp, Tcl_NewStringObj("can't create a new thread", -1));
return TCL_ERROR;
}
/*
* Wait for the thread to start because it is using
* the ThreadCtrl argument which is on our stack.
*/
while (ctrl.script != NULL) {
Tcl_ConditionWait(&ctrl.condWait, &threadMutex, NULL);
}
if (preserve) {
ThreadSpecificData *tsdPtr = ThreadExistsInner(thrId);
if (tsdPtr == NULL) {
Tcl_MutexUnlock(&threadMutex);
Tcl_ConditionFinalize(&ctrl.condWait);
ErrorNoSuchThread(interp, thrId);
return TCL_ERROR;
}
tsdPtr->refCount++;
}
Tcl_MutexUnlock(&threadMutex);
Tcl_ConditionFinalize(&ctrl.condWait);
ThreadGetHandle(thrId, thrHandle);
Tcl_SetObjResult(interp, Tcl_NewStringObj(thrHandle, -1));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* NewThread --
*
* 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, plus some synchronization primitives. Those are
* used so the caller gets signalized when the new thread has
* done its initialization.
*
* Space to hold the ThreadControl structure itself is reserved on
* the stack of the calling function. The two condition variables
* in the ThreadControl structure are destroyed by the calling
* function as well. 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
NewThread(
ClientData clientData
) {
ThreadCtrl *ctrlPtr = (ThreadCtrl *)clientData;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
Tcl_Interp *interp;
int result = TCL_OK;
size_t scriptLen;
char *evalScript;
/*
* Initialize the interpreter. The bad thing here is that we
* assume that initialization of the Tcl interp will be
* error free, which it may not. In the future we must recover
* from this and exit gracefully (this is not that easy as
* it seems on the first glance...)
*/
#ifdef NS_AOLSERVER
NsThreadInterpData *md = (NsThreadInterpData *)ctrlPtr->cd;
Ns_ThreadSetName("-tclthread-");
interp = (Tcl_Interp*)Ns_TclAllocateInterp(md ? md->server : NULL);
#else
interp = Tcl_CreateInterp();
result = Tcl_Init(interp);
#endif
#if !defined(NS_AOLSERVER) || (defined(NS_MAJOR_VERSION) && NS_MAJOR_VERSION >= 4)
result = Thread_Init(interp);
#endif
tsdPtr->interp = interp;
Tcl_MutexLock(&threadMutex);
/*
* Update the list of threads.
*/
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
*/
scriptLen = strlen(ctrlPtr->script);
evalScript = strcpy((char*)ckalloc(scriptLen+1), ctrlPtr->script);
Tcl_CreateThreadExitHandler(ThreadExitProc,evalScript);
/*
* Notify the parent we are alive.
*/
ctrlPtr->script = NULL;
Tcl_ConditionNotify(&ctrlPtr->condWait);
Tcl_MutexUnlock(&threadMutex);
/*
* Run the script.
*/
Tcl_Preserve(tsdPtr->interp);
result = Tcl_EvalEx(tsdPtr->interp, evalScript,scriptLen,TCL_EVAL_GLOBAL);
if (result != TCL_OK) {
ThreadErrorProc(tsdPtr->interp);
}
/*
* Clean up. Note: add something like TlistRemove for the transfer list.
*/
if (tsdPtr->doOneEvent) {
Tcl_ConditionFinalize(&tsdPtr->doOneEvent);
}
ListRemove(tsdPtr);
/*
* It is up to all other extensions, including Tk, to be responsible
* for their own events when they receive their Tcl_CallWhenDeleted
* notice when we delete this interp.
*/
#ifdef NS_AOLSERVER
Ns_TclMarkForDelete(tsdPtr->interp);
Ns_TclDeAllocateInterp(tsdPtr->interp);
#else
Tcl_DeleteInterp(tsdPtr->interp);
#endif
Tcl_Release(tsdPtr->interp);
/*tsdPtr->interp = NULL;*/
/*
* Tcl_ExitThread calls Tcl_FinalizeThread() indirectly which calls
* ThreadExitHandlers and cleans the notifier as well as other sub-
* systems that save thread state data.
*/
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 */
) {
ThreadSendData *sendPtr;
const char *argv[3];
char buf[THREAD_HNDLMAXLEN];
const char *errorInfo;
errorInfo = Tcl_GetVar2(interp, "errorInfo", NULL, TCL_GLOBAL_ONLY);
if (errorInfo == NULL) {
errorInfo = "";
}
if (errorProcString == NULL) {
#ifdef NS_AOLSERVER
Ns_Log(Error, "%s\n%s", Tcl_GetString(Tcl_GetObjResult(interp)), errorInfo);
#else
Tcl_Channel errChannel = Tcl_GetStdChannel(TCL_STDERR);
if (errChannel == NULL) {
/* Fixes the [#634845] bug; credits to
* Wojciech Kocjan <wojciech@kocjan.org> */
return;
}
ThreadGetHandle(Tcl_GetCurrentThread(), buf);
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);
#endif
} else {
ThreadGetHandle(Tcl_GetCurrentThread(), buf);
argv[0] = errorProcString;
argv[1] = buf;
argv[2] = errorInfo;
sendPtr = (ThreadSendData*)ckalloc(sizeof(ThreadSendData));
sendPtr->execProc = ThreadSendEval;
sendPtr->clientData = Tcl_Merge(3, argv);
sendPtr->interp = NULL;
ThreadSend(interp, errorThreadId, sendPtr, NULL, 0);
}
}
/*
*----------------------------------------------------------------------
*
* ListUpdate --
*
* Add the thread local storage to the list. This grabs the
* mutex to protect the list.
*
* Results:
* None
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static void
ListUpdate(
ThreadSpecificData *tsdPtr
) {
if (tsdPtr == NULL) {
tsdPtr = TCL_TSD_INIT(&dataKey);
}
Tcl_MutexLock(&threadMutex);
ListUpdateInner(tsdPtr);
Tcl_MutexUnlock(&threadMutex);
}
/*
*----------------------------------------------------------------------
*
* ListUpdateInner --
*
* Add the thread local storage to the list. This assumes the caller
* has obtained the threadMutex.
*
* Results:
* None
*
* Side effects:
* Add the thread local storage to its list.
*
*----------------------------------------------------------------------
*/
static void
ListUpdateInner(
ThreadSpecificData *tsdPtr
) {
if (threadList) {
threadList->prevPtr = tsdPtr;
}
tsdPtr->nextPtr = threadList;
tsdPtr->prevPtr = NULL;
tsdPtr->threadId = Tcl_GetCurrentThread();
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);
ListRemoveInner(tsdPtr);
Tcl_MutexUnlock(&threadMutex);
}
/*
*----------------------------------------------------------------------
*
* ListRemoveInner --
*
* Remove the thread local storage from its list.
*
* Results:
* None
*
* Side effects:
* Remove the thread local storage from its list.
*
*----------------------------------------------------------------------
*/
static void
ListRemoveInner(
ThreadSpecificData *tsdPtr
) {
if (tsdPtr->prevPtr || tsdPtr->nextPtr) {
if (tsdPtr->prevPtr) {
tsdPtr->prevPtr->nextPtr = tsdPtr->nextPtr;
} else {
threadList = tsdPtr->nextPtr;
}
if (tsdPtr->nextPtr) {
tsdPtr->nextPtr->prevPtr = tsdPtr->prevPtr;
}
tsdPtr->nextPtr = NULL;
tsdPtr->prevPtr = NULL;
} else if (tsdPtr == threadList) {
threadList = NULL;
}
}
/*
*----------------------------------------------------------------------
*
* ThreadList --
*
* Return a list of threads running Tcl interpreters.
*
* Results:
* Number of threads.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
ThreadList(
Tcl_Interp *dummy,
Tcl_ThreadId **thrIdArray
) {
int ii, count = 0;
ThreadSpecificData *tsdPtr;
(void)dummy;
Tcl_MutexLock(&threadMutex);
/*
* First walk; find out how many threads are registered.
* We may avoid this and gain some speed by maintaining
* the counter of allocated structs in the threadList.
*/
for (tsdPtr = threadList; tsdPtr; tsdPtr = tsdPtr->nextPtr) {
count++;
}
if (count == 0) {
Tcl_MutexUnlock(&threadMutex);
return 0;
}
/*
* Allocate storage for passing thread id's to caller
*/
*thrIdArray = (Tcl_ThreadId*)ckalloc(count * sizeof(Tcl_ThreadId));
/*
* Second walk; fill-in the array with thread ID's
*/
for (tsdPtr = threadList, ii = 0; tsdPtr; tsdPtr = tsdPtr->nextPtr, ii++) {
(*thrIdArray)[ii] = tsdPtr->threadId;
}
Tcl_MutexUnlock(&threadMutex);
return count;
}
/*
*----------------------------------------------------------------------
*
* ThreadExists --
*
* Test whether a thread given by it's id is known to us.
*
* Results:
* Pointer to thread specific data structure or
* NULL if no thread with given ID found
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
ThreadExists(
Tcl_ThreadId thrId
) {
ThreadSpecificData *tsdPtr;
Tcl_MutexLock(&threadMutex);
tsdPtr = ThreadExistsInner(thrId);
Tcl_MutexUnlock(&threadMutex);
return tsdPtr != NULL;
}
/*
*----------------------------------------------------------------------
*
* ThreadExistsInner --
*
* Test whether a thread given by it's id is known to us. Assumes
* caller holds the thread mutex.
*
* Results:
* Pointer to thread specific data structure or
* NULL if no thread with given ID found
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static ThreadSpecificData *
ThreadExistsInner(
Tcl_ThreadId thrId /* Thread id to look for. */
) {
ThreadSpecificData *tsdPtr;
for (tsdPtr = threadList; tsdPtr; tsdPtr = tsdPtr->nextPtr) {
if (tsdPtr->threadId == thrId) {
return tsdPtr;
}
}
return NULL;
}
#ifdef TCL_TIP285
/*
*----------------------------------------------------------------------
*
* 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 thrId, /* Thread ID of other interpreter. */
const char *result, /* The error message or NULL for default. */
int flags /* Flags for Tcl_CancelEval. */
) {
int code;
Tcl_Obj *resultObj = NULL;
ThreadSpecificData *tsdPtr; /* ... of the target thread */
Tcl_MutexLock(&threadMutex);
tsdPtr = ThreadExistsInner(thrId);
if (tsdPtr == NULL) {
Tcl_MutexUnlock(&threadMutex);
ErrorNoSuchThread(interp, thrId);
return TCL_ERROR;
}
if (!haveInterpCancel) {
Tcl_MutexUnlock(&threadMutex);
Tcl_AppendResult(interp, "not supported with this Tcl version", NULL);
return TCL_ERROR;
}
if (result != NULL) {
resultObj = Tcl_NewStringObj(result, -1);
}
code = Tcl_CancelEval(tsdPtr->interp, resultObj, NULL, flags);
Tcl_MutexUnlock(&threadMutex);
return code;
}
#endif
/*
*----------------------------------------------------------------------
*
* ThreadJoin --
*
* Wait for the exit of a different thread.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* The status of the exiting thread is left in the interp result
* area, but only in the case of success.
*
*----------------------------------------------------------------------
*/
static int
ThreadJoin(
Tcl_Interp *interp, /* The current interpreter. */
Tcl_ThreadId thrId /* Thread ID of other interpreter. */
) {
int ret, state;
ret = Tcl_JoinThread(thrId, &state);
if (ret == TCL_OK) {
Tcl_SetIntObj(Tcl_GetObjResult (interp), state);
} else {
char thrHandle[THREAD_HNDLMAXLEN];
ThreadGetHandle(thrId, thrHandle);
Tcl_AppendResult(interp, "cannot join thread ", thrHandle, NULL);
}
return ret;
}
/*
*----------------------------------------------------------------------
*
* ThreadTransfer --
*
* Transfers the specified channel which must not be shared and has
* to be registered in the given interp from that location to the
* main interp of the specified thread.
*
* Thanks to Anreas Kupries for the initial implementation.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* The thread-global lists of all known channels of both threads
* involved (specified and current) are modified. The channel is
* moved, all event handling for the channel is killed.
*
*----------------------------------------------------------------------
*/
static int
ThreadTransfer(
Tcl_Interp *interp, /* The current interpreter. */
Tcl_ThreadId thrId, /* Thread Id of other interpreter. */
Tcl_Channel chan /* The channel to transfer */
) {
/* Steps to perform for the transfer:
*
* i. Sanity checks: chan has to registered in interp, must not be
* shared. This automatically excludes the special channels for
* stdin, stdout and stderr!
* ii. Clear event handling.
* iii. Bump reference counter up to prevent destruction during the
* following unregister, then unregister the channel from the
* interp. Remove it from the thread-global list of all channels
* too.
* iv. Wrap the channel into an event and send that to the other
* thread, then wait for the other thread to process our message.
* v. The event procedure called by the other thread is
* 'TransferEventProc'. It links the channel into the
* thread-global list of channels for that thread, registers it
* in the main interp of the other thread, removes the artificial
* reference, at last notifies this thread of the sucessful
* transfer. This allows this thread then to proceed.
*/
TransferEvent *evPtr;
TransferResult *resultPtr;
if (!Tcl_IsChannelRegistered(interp, chan)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("channel is not registered here", -1));
}
if (Tcl_IsChannelShared(chan)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("channel is shared", -1));
return TCL_ERROR;
}
/*
* Short circuit transfers to ourself. Nothing to do.
*/
if (thrId == Tcl_GetCurrentThread()) {
return TCL_OK;
}
Tcl_MutexLock(&threadMutex);
/*
* Verify the thread exists.
*/
if (ThreadExistsInner(thrId) == NULL) {
Tcl_MutexUnlock(&threadMutex);
ErrorNoSuchThread(interp, thrId);
return TCL_ERROR;
}
/*
* Cut the channel out of the interp/thread
*/
ThreadCutChannel(interp, chan);
/*
* Wrap it into an event.
*/
resultPtr = (TransferResult*)ckalloc(sizeof(TransferResult));
evPtr = (TransferEvent *)ckalloc(sizeof(TransferEvent));
evPtr->chan = chan;
evPtr->event.proc = TransferEventProc;
evPtr->resultPtr = resultPtr;
/*
* Initialize the result fields.
*/
resultPtr->done = (Tcl_Condition) NULL;
resultPtr->resultCode = -1;
resultPtr->resultMsg = (char *) NULL;
/*
* Maintain the cleanup list.
*/
resultPtr->srcThreadId = Tcl_GetCurrentThread();
resultPtr->dstThreadId = thrId;
resultPtr->eventPtr = evPtr;
SpliceIn(resultPtr, transferList);
/*
* Queue the event and poke the other thread's notifier.
*/
Tcl_ThreadQueueEvent(thrId, (Tcl_Event*)evPtr, TCL_QUEUE_TAIL);
Tcl_ThreadAlert(thrId);
/*
* (*) Block until the other thread has either processed the transfer
* or rejected it.
*/
while (resultPtr->resultCode < 0) {
Tcl_ConditionWait(&resultPtr->done, &threadMutex, NULL);
}
/*
* Unlink result from the result list.
*/
SpliceOut(resultPtr, transferList);
resultPtr->eventPtr = NULL;
resultPtr->nextPtr = NULL;
resultPtr->prevPtr = NULL;
Tcl_MutexUnlock(&threadMutex);
Tcl_ConditionFinalize(&resultPtr->done);
/*
* Process the result now.
*/
if (resultPtr->resultCode != TCL_OK) {
/*
* Transfer failed, restore old state of channel with respect
* to current thread and specified interp.
*/
Tcl_SpliceChannel(chan);
Tcl_RegisterChannel(interp, chan);
Tcl_UnregisterChannel((Tcl_Interp *) NULL, chan);
Tcl_AppendResult(interp, "transfer failed: ", NULL);
if (resultPtr->resultMsg) {
Tcl_AppendResult(interp, resultPtr->resultMsg, NULL);
ckfree(resultPtr->resultMsg);
} else {
Tcl_AppendResult(interp, "for reasons unknown", NULL);
}
ckfree((char *)resultPtr);
return TCL_ERROR;
}
if (resultPtr->resultMsg) {
ckfree(resultPtr->resultMsg);
}
ckfree((char *)resultPtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* ThreadDetach --
*
* Detaches the specified channel which must not be shared and has
* to be registered in the given interp. The detached channel is
* left in the transfer list until some other thread attaches it
+ by calling the "thread::attach" command.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* The thread-global lists of all known channels (transferList)
* is modified. All event handling for the channel is killed.
*
*----------------------------------------------------------------------
*/
static int
ThreadDetach(
Tcl_Interp *interp, /* The current interpreter. */
Tcl_Channel chan /* The channel to detach */
) {
TransferEvent *evPtr;
TransferResult *resultPtr;
if (!Tcl_IsChannelRegistered(interp, chan)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("channel is not registered here", -1));
}
if (Tcl_IsChannelShared(chan)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("channel is shared", -1));
return TCL_ERROR;
}
/*
* Cut the channel out of the interp/thread
*/
ThreadCutChannel(interp, chan);
/*
* Wrap it into the list of transfered channels. We generate no
* events associated with the detached channel, thus really not
* needing the transfer event structure allocated here. This
* is done purely to avoid having yet another wrapper.
*/
resultPtr = (TransferResult*)ckalloc(sizeof(TransferResult));
evPtr = (TransferEvent*)ckalloc(sizeof(TransferEvent));
evPtr->chan = chan;
evPtr->event.proc = NULL;
evPtr->resultPtr = resultPtr;
/*
* Initialize the result fields. This is not used.
*/
resultPtr->done = NULL;
resultPtr->resultCode = -1;
resultPtr->resultMsg = NULL;
/*
* Maintain the cleanup list. By setting the dst/srcThreadId
* to zero we signal the code in ThreadAttach that this is the
* detached channel. Therefore it should not be mistaken for
* some regular TransferChannel operation underway. Also, this
* will prevent the code in ThreadExitProc to splice out this
* record from the list when the threads are exiting.
* A side effect of this is that we may have entries in this
* list which may never be removed (i.e. nobody attaches the
* channel later on). This will result in both Tcl channel and
* memory leak.
*/
resultPtr->srcThreadId = NULL;
resultPtr->dstThreadId = NULL;
resultPtr->eventPtr = evPtr;
Tcl_MutexLock(&threadMutex);
SpliceIn(resultPtr, transferList);
Tcl_MutexUnlock(&threadMutex);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* ThreadAttach --
*
* Attaches the previously detached channel into the current
* interpreter.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* The thread-global lists of all known channels (transferList)
* is modified.
*
*----------------------------------------------------------------------
*/
static int
ThreadAttach(
Tcl_Interp *interp, /* The current interpreter. */
char *chanName /* The name of the channel to detach */
) {
int found = 0;
Tcl_Channel chan = NULL;
TransferResult *resPtr;
/*
* Locate the channel to attach by looking up its name in
* the list of transfered channels. Watch that we don't
* hit the regular channel transfer event.
*/
Tcl_MutexLock(&threadMutex);
for (resPtr = transferList; resPtr; resPtr = resPtr->nextPtr) {
chan = resPtr->eventPtr->chan;
if (!strcmp(Tcl_GetChannelName(chan),chanName)
&& !resPtr->dstThreadId) {
if (Tcl_IsChannelExisting(chanName)) {
Tcl_MutexUnlock(&threadMutex);
Tcl_AppendResult(interp, "channel already exists", NULL);
return TCL_ERROR;
}
SpliceOut(resPtr, transferList);
ckfree((char*)resPtr->eventPtr);
ckfree((char*)resPtr);
found = 1;
break;
}
}
Tcl_MutexUnlock(&threadMutex);
if (found == 0) {
Tcl_AppendResult(interp, "channel not detached", NULL);
return TCL_ERROR;
}
/*
* Splice channel into the current interpreter
*/
Tcl_SpliceChannel(chan);
Tcl_RegisterChannel(interp, chan);
Tcl_UnregisterChannel(NULL, chan);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* ThreadSend --
*
* Run the procedure in other thread.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
ThreadSend(
Tcl_Interp *interp, /* The current interpreter. */
Tcl_ThreadId thrId, /* Thread Id of other thread. */
ThreadSendData *send, /* Pointer to structure with work to do */
ThreadClbkData *clbk, /* Opt. callback structure (may be NULL) */
int flags /* Wait or queue to tail */
) {
ThreadSpecificData *tsdPtr = NULL; /* ... of the target thread */
int code;
ThreadEvent *eventPtr;
ThreadEventResult *resultPtr;
/*
* Verify the thread exists and is not in the error state.
* The thread is in the error state only if we've configured
* it to unwind on script evaluation error and last script
* evaluation resulted in error actually.
*/
Tcl_MutexLock(&threadMutex);
tsdPtr = ThreadExistsInner(thrId);
if (tsdPtr == NULL
|| (tsdPtr->flags & THREAD_FLAGS_INERROR)) {
int inerror = tsdPtr && (tsdPtr->flags & THREAD_FLAGS_INERROR);
Tcl_MutexUnlock(&threadMutex);
ThreadFreeProc(send);
if (clbk) {
ThreadFreeProc(clbk);
}
if (inerror) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("thread is in error", -1));
} else {
ErrorNoSuchThread(interp, thrId);
}
return TCL_ERROR;
}
/*
* Short circuit sends to ourself.
*/
if (thrId == Tcl_GetCurrentThread()) {
Tcl_MutexUnlock(&threadMutex);
if ((flags & THREAD_SEND_WAIT)) {
code = (*send->execProc)(interp, send);
ThreadFreeProc(send);
return code;
} else {
send->interp = interp;
Tcl_Preserve(send->interp);
Tcl_DoWhenIdle((Tcl_IdleProc*)ThreadIdleProc, send);
return TCL_OK;
}
}
/*
* Create the event for target thread event queue.
*/
eventPtr = (ThreadEvent*)ckalloc(sizeof(ThreadEvent));
eventPtr->sendData = send;
eventPtr->clbkData = clbk;
/*
* Target thread about to service
* another event
*/
if (tsdPtr->maxEventsCount) {
tsdPtr->eventsPending++;
}
/*
* Caller wants to be notified, so we must take care
* it's interpreter stays alive until we've finished.
*/
if (eventPtr->clbkData) {
Tcl_Preserve(eventPtr->clbkData->interp);
}
if ((flags & THREAD_SEND_WAIT) == 0) {
resultPtr = NULL;
eventPtr->resultPtr = NULL;
} else {
resultPtr = (ThreadEventResult*)ckalloc(sizeof(ThreadEventResult));
resultPtr->done = NULL;
resultPtr->result = NULL;
resultPtr->errorCode = NULL;
resultPtr->errorInfo = NULL;
resultPtr->dstThreadId = thrId;
resultPtr->srcThreadId = Tcl_GetCurrentThread();
resultPtr->eventPtr = eventPtr;
eventPtr->resultPtr = resultPtr;
SpliceIn(resultPtr, resultList);
}
/*
* Queue the event and poke the other thread's notifier.
*/
eventPtr->event.proc = ThreadEventProc;
if ((flags & THREAD_SEND_HEAD)) {
Tcl_ThreadQueueEvent(thrId, (Tcl_Event*)eventPtr, TCL_QUEUE_HEAD);
} else {
Tcl_ThreadQueueEvent(thrId, (Tcl_Event*)eventPtr, TCL_QUEUE_TAIL);
}
Tcl_ThreadAlert(thrId);
if ((flags & THREAD_SEND_WAIT) == 0) {
/*
* Might potentially spend some time here, until the
* worker thread cleans up its queue a little bit.
*/
if ((flags & THREAD_SEND_CLBK) == 0) {
while (tsdPtr->maxEventsCount &&
tsdPtr->eventsPending > tsdPtr->maxEventsCount) {
Tcl_ConditionWait(&tsdPtr->doOneEvent, &threadMutex, NULL);
}
}
Tcl_MutexUnlock(&threadMutex);
return TCL_OK;
}
/*
* Block on the result indefinitely.
*/
Tcl_ResetResult(interp);
while (resultPtr->result == NULL) {
Tcl_ConditionWait(&resultPtr->done, &threadMutex, NULL);
}
SpliceOut(resultPtr, resultList);
Tcl_MutexUnlock(&threadMutex);
/*
* Return result to caller
*/
if (resultPtr->code == TCL_ERROR) {
if (resultPtr->errorCode) {
Tcl_SetErrorCode(interp, resultPtr->errorCode, NULL);
ckfree(resultPtr->errorCode);
}
if (resultPtr->errorInfo) {
Tcl_AddErrorInfo(interp, resultPtr->errorInfo);
ckfree(resultPtr->errorInfo);
}
}
code = resultPtr->code;
Tcl_SetObjResult(interp, Tcl_NewStringObj(resultPtr->result, -1));
/*
* Cleanup
*/
Tcl_ConditionFinalize(&resultPtr->done);
if (resultPtr->result != threadEmptyResult) {
ckfree(resultPtr->result);
}
ckfree((char*)resultPtr);
return code;
}
/*
*----------------------------------------------------------------------
*
* ThreadWait --
*
* Waits for events and process them as they come, until signaled
* to stop.
*
* Results:
* Standard Tcl result.
*
* Side effects:
* Deletes any thread::send or thread::transfer events that are
* pending.
*
*----------------------------------------------------------------------
*/
static int
ThreadWait(Tcl_Interp *interp)
{
int code = TCL_OK;
int canrun = 1;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
/*
* Process events until signaled to stop.
*/
while (canrun) {
/*
* About to service another event.
* Wake-up eventual sleepers.
*/
if (tsdPtr->maxEventsCount) {
Tcl_MutexLock(&threadMutex);
tsdPtr->eventsPending--;
Tcl_ConditionNotify(&tsdPtr->doOneEvent);
Tcl_MutexUnlock(&threadMutex);
}
/*
* Attempt to process one event, blocking forever until an
* event is actually received. The event processed may cause
* a script in progress to be canceled or exceed its limit;
* therefore, check for these conditions if we are able to
* (i.e. we are running in a high enough version of Tcl).
*/
Tcl_DoOneEvent(TCL_ALL_EVENTS);
#ifdef TCL_TIP285
if (haveInterpCancel) {
/*
* 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 the
* Tcl_Canceled function to check if the command has been canceled.
*/
if (Tcl_Canceled(tsdPtr->interp,
TCL_LEAVE_ERR_MSG | TCL_CANCEL_UNWIND) == TCL_ERROR) {
code = TCL_ERROR;
break;
}
}
#endif
#ifdef TCL_TIP143
if (haveInterpLimit) {
if (Tcl_LimitExceeded(tsdPtr->interp)) {
code = TCL_ERROR;
break;
}
}
#endif
/*
* Test stop condition under mutex since
* some other thread may flip our flags.
*/
Tcl_MutexLock(&threadMutex);
canrun = (tsdPtr->flags & THREAD_FLAGS_STOPPED) == 0;
Tcl_MutexUnlock(&threadMutex);
}
#if defined(TCL_TIP143) || defined(TCL_TIP285)
/*
* If the event processing loop above was terminated due to a
* script in progress being canceled or exceeding its limits,
* transfer the error to the current interpreter.
*/
if (code != TCL_OK) {
char buf[THREAD_HNDLMAXLEN];
const char *errorInfo;
errorInfo = Tcl_GetVar2(tsdPtr->interp, "errorInfo", NULL, TCL_GLOBAL_ONLY);
if (errorInfo == NULL) {
errorInfo = Tcl_GetString(Tcl_GetObjResult(tsdPtr->interp));
}
ThreadGetHandle(Tcl_GetCurrentThread(), buf);
Tcl_AppendResult(interp, "Error from thread ", buf, "\n",
errorInfo, NULL);
}
#endif
/*
* Remove from the list of active threads, so nobody can post
* work to this thread, since it is just about to terminate.
*/
ListRemove(tsdPtr);
/*
* Now that the event processor for this thread is closing,
* delete all pending thread::send and thread::transfer events.
* These events are owned by us. We don't delete anyone else's
* events, but ours.
*/
Tcl_DeleteEvents((Tcl_EventDeleteProc*)ThreadDeleteEvent, NULL);
return code;
}
/*
*----------------------------------------------------------------------
*
* ThreadReserve --
*
* Results:
*
* Side effects:
*
*----------------------------------------------------------------------
*/
static int
ThreadReserve(
Tcl_Interp *interp, /* Current interpreter */
Tcl_ThreadId thrId, /* Target thread ID */
int operation, /* THREAD_RESERVE | THREAD_RELEASE */
int wait /* Wait for thread to exit */
) {
int users, dowait = 0;
ThreadEvent *evPtr;
ThreadSpecificData *tsdPtr;
Tcl_MutexLock(&threadMutex);
/*
* Check the given thread
*/
if (thrId == NULL) {
tsdPtr = TCL_TSD_INIT(&dataKey);
} else {
tsdPtr = ThreadExistsInner(thrId);
if (tsdPtr == NULL) {
Tcl_MutexUnlock(&threadMutex);
ErrorNoSuchThread(interp, thrId);
return TCL_ERROR;
}
}
switch (operation) {
case THREAD_RESERVE: ++tsdPtr->refCount; break;
case THREAD_RELEASE: --tsdPtr->refCount; dowait = wait; break;
}
users = tsdPtr->refCount;
if (users <= 0) {
/*
* We're last attached user, so tear down the *target* thread
*/
tsdPtr->flags |= THREAD_FLAGS_STOPPED;
if (thrId && thrId != Tcl_GetCurrentThread() /* Not current! */) {
ThreadEventResult *resultPtr = NULL;
/*
* Remove from the list of active threads, so nobody can post
* work to this thread, since it is just about to terminate.
*/
ListRemoveInner(tsdPtr);
/*
* Send an dummy event, just to wake-up target thread.
* It should immediately exit thereafter. We might get
* stuck here for long time if user really wants to
* be absolutely sure that the thread has exited.
*/
if (dowait) {
resultPtr = (ThreadEventResult*)
ckalloc(sizeof(ThreadEventResult));
resultPtr->done = NULL;
resultPtr->result = NULL;
resultPtr->code = TCL_OK;
resultPtr->errorCode = NULL;
resultPtr->errorInfo = NULL;
resultPtr->dstThreadId = thrId;
resultPtr->srcThreadId = Tcl_GetCurrentThread();
SpliceIn(resultPtr, resultList);
}
evPtr = (ThreadEvent*)ckalloc(sizeof(ThreadEvent));
evPtr->event.proc = ThreadEventProc;
evPtr->sendData = NULL;
evPtr->clbkData = NULL;
evPtr->resultPtr = resultPtr;
Tcl_ThreadQueueEvent(thrId, (Tcl_Event*)evPtr, TCL_QUEUE_TAIL);
Tcl_ThreadAlert(thrId);
if (dowait) {
while (resultPtr->result == NULL) {
Tcl_ConditionWait(&resultPtr->done, &threadMutex, NULL);
}
SpliceOut(resultPtr, resultList);
Tcl_ConditionFinalize(&resultPtr->done);
if (resultPtr->result != threadEmptyResult) {
ckfree(resultPtr->result); /* Will be ignored anyway */
}
ckfree((char*)resultPtr);
}
}
}
Tcl_MutexUnlock(&threadMutex);
Tcl_SetIntObj(Tcl_GetObjResult(interp), (users > 0) ? users : 0);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* 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);
Tcl_Interp *interp = NULL;
Tcl_ThreadId thrId = Tcl_GetCurrentThread();
ThreadEvent *eventPtr = (ThreadEvent*)evPtr;
ThreadSendData *sendPtr = eventPtr->sendData;
ThreadClbkData *clbkPtr = eventPtr->clbkData;
ThreadEventResult* resultPtr = eventPtr->resultPtr;
int code = TCL_ERROR; /* Pessimistic assumption */
(void)mask;
/*
* See whether user has any preferences about which interpreter
* to use for running this job. The job structure might identify
* one. If not, just use the thread's main interpreter which is
* stored in the thread specific data structure.
* Note that later on we might discover that we're running the
* async callback script. In this case, interpreter will be
* changed to one given in the callback.
*/
interp = (sendPtr && sendPtr->interp) ? sendPtr->interp : tsdPtr->interp;
if (interp != NULL) {
Tcl_Preserve(interp);
if (clbkPtr && clbkPtr->threadId == thrId) {
Tcl_Release(interp);
/* Watch: this thread evaluates its own callback. */
interp = clbkPtr->interp;
Tcl_Preserve(interp);
}
Tcl_ResetResult(interp);
if (sendPtr) {
Tcl_CreateThreadExitHandler(ThreadFreeProc, sendPtr);
if (clbkPtr) {
Tcl_CreateThreadExitHandler(ThreadFreeProc,
clbkPtr);
}
code = (*sendPtr->execProc)(interp, sendPtr);
Tcl_DeleteThreadExitHandler(ThreadFreeProc, sendPtr);
if (clbkPtr) {
Tcl_DeleteThreadExitHandler(ThreadFreeProc,
clbkPtr);
}
} else {
code = TCL_OK;
}
}
if (sendPtr) {
ThreadFreeProc(sendPtr);
eventPtr->sendData = NULL;
}
if (resultPtr) {
/*
* Report job result synchronously to waiting caller
*/
Tcl_MutexLock(&threadMutex);
ThreadSetResult(interp, code, resultPtr);
Tcl_ConditionNotify(&resultPtr->done);
Tcl_MutexUnlock(&threadMutex);
/*
* We still need to release the reference to the Tcl
* interpreter added by ThreadSend whenever the callback
* data is not NULL.
*/
if (clbkPtr) {
Tcl_Release(clbkPtr->interp);
}
} else if (clbkPtr && clbkPtr->threadId != thrId) {
ThreadSendData *tmpPtr = (ThreadSendData*)clbkPtr;
/*
* Route the callback back to it's originator.
* Do not wait for the result.
*/
if (code != TCL_OK) {
ThreadErrorProc(interp);
}
ThreadSetResult(interp, code, &clbkPtr->result);
ThreadSend(interp, clbkPtr->threadId, tmpPtr, NULL, THREAD_SEND_CLBK);
} else if (code != TCL_OK) {
/*
* Only pass errors onto the registered error handler
* when we don't have a result target for this event.
*/
ThreadErrorProc(interp);
/*
* We still need to release the reference to the Tcl
* interpreter added by ThreadSend whenever the callback
* data is not NULL.
*/
if (clbkPtr) {
Tcl_Release(clbkPtr->interp);
}
} else {
/*
* We still need to release the reference to the Tcl
* interpreter added by ThreadSend whenever the callback
* data is not NULL.
*/
if (clbkPtr) {
Tcl_Release(clbkPtr->interp);
}
}
if (interp != NULL) {
Tcl_Release(interp);
}
/*
* Mark unwind scenario for this thread if the script resulted
* in error condition and thread has been marked to unwind.
* This will cause thread to disappear from the list of active
* threads, clean-up its event queue and exit.
*/
if (code != TCL_OK) {
Tcl_MutexLock(&threadMutex);
if (tsdPtr->flags & THREAD_FLAGS_UNWINDONERROR) {
tsdPtr->flags |= THREAD_FLAGS_INERROR;
if (tsdPtr->refCount == 0) {
tsdPtr->flags |= THREAD_FLAGS_STOPPED;
}
}
Tcl_MutexUnlock(&threadMutex);
}
return 1;
}
/*
*----------------------------------------------------------------------
*
* ThreadSetResult --
*
* Results:
*
* Side effects:
*
*----------------------------------------------------------------------
*/
static void
ThreadSetResult(
Tcl_Interp *interp,
int code,
ThreadEventResult *resultPtr
) {
size_t size;
const char *errorCode, *errorInfo, *result;
if (interp == NULL) {
code = TCL_ERROR;
errorInfo = "";
errorCode = "THREAD";
result = "no target interp!";
size = strlen(result);
resultPtr->result = (size) ?
(char *)memcpy(ckalloc(1+size), result, 1+size) : threadEmptyResult;
} else {
result = Tcl_GetString(Tcl_GetObjResult(interp));
size = Tcl_GetObjResult(interp)->length;
resultPtr->result = (size) ?
(char *)memcpy(ckalloc(1+size), result, 1+size) : threadEmptyResult;
if (code == TCL_ERROR) {
errorCode = Tcl_GetVar2(interp, "errorCode", NULL, TCL_GLOBAL_ONLY);
errorInfo = Tcl_GetVar2(interp, "errorInfo", NULL, TCL_GLOBAL_ONLY);
} else {
errorCode = NULL;
errorInfo = NULL;
}
}
resultPtr->code = code;
if (errorCode != NULL) {
size = strlen(errorCode) + 1;
resultPtr->errorCode = (char *)memcpy(ckalloc(size), errorCode, size);
} else {
resultPtr->errorCode = NULL;
}
if (errorInfo != NULL) {
size = strlen(errorInfo) + 1;
resultPtr->errorInfo = (char *)memcpy(ckalloc(size), errorInfo, size);
} else {
resultPtr->errorInfo = NULL;
}
}
/*
*----------------------------------------------------------------------
*
* ThreadGetOption --
*
* Results:
*
* Side effects:
*
*----------------------------------------------------------------------
*/
static int
ThreadGetOption(
Tcl_Interp *interp,
Tcl_ThreadId thrId,
char *option,
Tcl_DString *dsPtr
) {
size_t len;
ThreadSpecificData *tsdPtr = NULL;
/*
* If the optionName is NULL it means that we want
* a list of all options and values.
*/
len = (option == NULL) ? 0 : strlen(option);
Tcl_MutexLock(&threadMutex);
tsdPtr = ThreadExistsInner(thrId);
if (tsdPtr == NULL) {
Tcl_MutexUnlock(&threadMutex);
ErrorNoSuchThread(interp, thrId);
return TCL_ERROR;
}
if (len == 0 || (len > 3 && option[1] == 'e' && option[2] == 'v'
&& !strncmp(option,"-eventmark", len))) {
char buf[16];
if (len == 0) {
Tcl_DStringAppendElement(dsPtr, "-eventmark");
}
sprintf(buf, "%d", tsdPtr->maxEventsCount);
Tcl_DStringAppendElement(dsPtr, buf);
if (len != 0) {
Tcl_MutexUnlock(&threadMutex);
return TCL_OK;
}
}
if (len == 0 || (len > 2 && option[1] == 'u'
&& !strncmp(option,"-unwindonerror", len))) {
int flag = tsdPtr->flags & THREAD_FLAGS_UNWINDONERROR;
if (len == 0) {
Tcl_DStringAppendElement(dsPtr, "-unwindonerror");
}
Tcl_DStringAppendElement(dsPtr, flag ? "1" : "0");
if (len != 0) {
Tcl_MutexUnlock(&threadMutex);
return TCL_OK;
}
}
if (len == 0 || (len > 3 && option[1] == 'e' && option[2] == 'r'
&& !strncmp(option,"-errorstate", len))) {
int flag = tsdPtr->flags & THREAD_FLAGS_INERROR;
if (len == 0) {
Tcl_DStringAppendElement(dsPtr, "-errorstate");
}
Tcl_DStringAppendElement(dsPtr, flag ? "1" : "0");
if (len != 0) {
Tcl_MutexUnlock(&threadMutex);
return TCL_OK;
}
}
if (len != 0) {
Tcl_AppendResult(interp, "bad option \"", option,
"\", should be one of -eventmark, "
"-unwindonerror or -errorstate", NULL);
Tcl_MutexUnlock(&threadMutex);
return TCL_ERROR;
}
Tcl_MutexUnlock(&threadMutex);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* ThreadSetOption --
*
* Results:
*
* Side effects:
*
*----------------------------------------------------------------------
*/
static int
ThreadSetOption(
Tcl_Interp *interp,
Tcl_ThreadId thrId,
char *option,
char *value
) {
size_t len = strlen(option);
ThreadSpecificData *tsdPtr = NULL;
Tcl_MutexLock(&threadMutex);
tsdPtr = ThreadExistsInner(thrId);
if (tsdPtr == NULL) {
Tcl_MutexUnlock(&threadMutex);
ErrorNoSuchThread(interp, thrId);
return TCL_ERROR;
}
if (len > 3 && option[1] == 'e' && option[2] == 'v'
&& !strncmp(option,"-eventmark", len)) {
if (sscanf(value, "%d", &tsdPtr->maxEventsCount) != 1) {
Tcl_AppendResult(interp, "expected integer but got \"",
value, "\"", NULL);
Tcl_MutexUnlock(&threadMutex);
return TCL_ERROR;
}
} else if (len > 2 && option[1] == 'u'
&& !strncmp(option,"-unwindonerror", len)) {
int flag = 0;
if (Tcl_GetBoolean(interp, value, &flag) != TCL_OK) {
Tcl_MutexUnlock(&threadMutex);
return TCL_ERROR;
}
if (flag) {
tsdPtr->flags |= THREAD_FLAGS_UNWINDONERROR;
} else {
tsdPtr->flags &= ~THREAD_FLAGS_UNWINDONERROR;
}
} else if (len > 3 && option[1] == 'e' && option[2] == 'r'
&& !strncmp(option,"-errorstate", len)) {
int flag = 0;
if (Tcl_GetBoolean(interp, value, &flag) != TCL_OK) {
Tcl_MutexUnlock(&threadMutex);
return TCL_ERROR;
}
if (flag) {
tsdPtr->flags |= THREAD_FLAGS_INERROR;
} else {
tsdPtr->flags &= ~THREAD_FLAGS_INERROR;
}
}
Tcl_MutexUnlock(&threadMutex);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* ThreadIdleProc --
*
* Results:
*
* Side effects.
*
*----------------------------------------------------------------------
*/
static void
ThreadIdleProc(
ClientData clientData
) {
int ret;
ThreadSendData *sendPtr = (ThreadSendData*)clientData;
ret = (*sendPtr->execProc)(sendPtr->interp, sendPtr);
if (ret != TCL_OK) {
ThreadErrorProc(sendPtr->interp);
}
Tcl_Release(sendPtr->interp);
ThreadFreeProc(clientData);
}
/*
*----------------------------------------------------------------------
*
* TransferEventProc --
*
* Handle a transfer event in the target thread.
*
* Results:
* Returns 1 to indicate that the event was processed.
*
* Side effects:
* Fills out the TransferResult struct.
*
*----------------------------------------------------------------------
*/
static int
TransferEventProc(
Tcl_Event *evPtr, /* Really ThreadEvent */
int mask
) {
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
TransferEvent *eventPtr = (TransferEvent *)evPtr;
TransferResult *resultPtr = eventPtr->resultPtr;
Tcl_Interp *interp = tsdPtr->interp;
int code;
const char* msg = NULL;
(void)mask;
if (interp == NULL) {
/*
* Reject transfer in case of a missing target.
*/
code = TCL_ERROR;
msg = "target interp missing";
} else {
/*
* Add channel to current thread and interp.
* See ThreadTransfer for more explanations.
*/
if (Tcl_IsChannelExisting(Tcl_GetChannelName(eventPtr->chan))) {
/*
* Reject transfer. Channel of same name already exists in target.
*/
code = TCL_ERROR;
msg = "channel already exists in target";
} else {
Tcl_SpliceChannel(eventPtr->chan);
Tcl_RegisterChannel(interp, eventPtr->chan);
Tcl_UnregisterChannel((Tcl_Interp *) NULL, eventPtr->chan);
code = TCL_OK; /* Return success. */
}
}
if (resultPtr) {
Tcl_MutexLock(&threadMutex);
resultPtr->resultCode = code;
if (msg != NULL) {
size_t size = strlen(msg)+1;
resultPtr->resultMsg = (char *)memcpy(ckalloc(size), msg, size);
}
Tcl_ConditionNotify(&resultPtr->done);
Tcl_MutexUnlock(&threadMutex);
}
return 1;
}
/*
*----------------------------------------------------------------------
*
* ThreadFreeProc --
*
* Called when we are exiting and memory needs to be freed.
*
* Results:
* None.
*
* Side effects:
* Clears up mem specified in ClientData
*
*----------------------------------------------------------------------
*/
static void
ThreadFreeProc(
ClientData clientData
) {
/*
* This will free send and/or callback structures
* since both are the same in the beginning.
*/
ThreadSendData *anyPtr = (ThreadSendData*)clientData;
if (anyPtr) {
if (anyPtr->clientData) {
ckfree((char *)anyPtr->clientData);
}
ckfree((char*)anyPtr);
}
}
/*
*----------------------------------------------------------------------
*
* 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.
*
*----------------------------------------------------------------------
*/
static int
ThreadDeleteEvent(
Tcl_Event *eventPtr, /* Really ThreadEvent */
ClientData dummy /* dummy */
) {
(void)dummy;
if (eventPtr->proc == ThreadEventProc) {
/*
* Regular script event. Just dispose memory
*/
ThreadEvent *evPtr = (ThreadEvent*)eventPtr;
if (evPtr->sendData) {
ThreadFreeProc(evPtr->sendData);
evPtr->sendData = NULL;
}
if (evPtr->clbkData) {
ThreadFreeProc(evPtr->clbkData);
evPtr->clbkData = NULL;
}
return 1;
}
if (eventPtr->proc == TransferEventProc) {
/*
* A channel is in flight toward the thread just exiting.
* Pass it back to the originator, if possible.
* Else kill it.
*/
TransferEvent* evPtr = (TransferEvent *) eventPtr;
if (evPtr->resultPtr == (TransferResult *) NULL) {
/* No thread to pass the channel back to. Kill it.
* This requires to splice it temporarily into our channel
* list and then forcing the ref.counter down to the real
* value of zero. This destroys the channel.
*/
Tcl_SpliceChannel(evPtr->chan);
Tcl_UnregisterChannel((Tcl_Interp *) NULL, evPtr->chan);
return 1;
}
/* Our caller (ThreadExitProc) will pass the channel back.
*/
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.
*
*----------------------------------------------------------------------
*/
static void
ThreadExitProc(
ClientData clientData
) {
char *threadEvalScript = (char*)clientData;
const char *diemsg = "target thread died";
ThreadEventResult *resultPtr, *nextPtr;
Tcl_ThreadId self = Tcl_GetCurrentThread();
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
TransferResult *tResultPtr, *tNextPtr;
if (threadEvalScript && threadEvalScript != threadEmptyResult) {
ckfree((char*)threadEvalScript);
}
Tcl_MutexLock(&threadMutex);
/*
* NaviServer/AOLserver and threadpool threads get started/stopped
* out of the control of this interface so this is
* the first chance to split them out of the thread list.
*/
ListRemoveInner(tsdPtr);
/*
* Delete events posted to our queue while we were running.
* For threads exiting from the thread::wait command, this
* has already been done in ThreadWait() function.
* For one-shot threads, having something here is a very
* strange condition. It *may* happen if somebody posts us
* an event while we were in the middle of processing some
* lengthly user script. It is unlikely to happen, though.
*/
Tcl_DeleteEvents((Tcl_EventDeleteProc*)ThreadDeleteEvent, NULL);
/*
* Walk the list of threads waiting for result from us
* and inform them that we're about to exit.
*/
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.
*/
SpliceOut(resultPtr, resultList);
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.
*/
resultPtr->result = strcpy((char *)ckalloc(1+strlen(diemsg)), diemsg);
resultPtr->code = TCL_ERROR;
resultPtr->errorCode = resultPtr->errorInfo = NULL;
Tcl_ConditionNotify(&resultPtr->done);
}
}
for (tResultPtr = transferList; tResultPtr; tResultPtr = tNextPtr) {
tNextPtr = tResultPtr->nextPtr;
if (tResultPtr->srcThreadId == self) {
/*
* We are going away. By freeing up the result we signal
* to the other thread we don't care about the result.
*
* This should not happen, as this thread should be in
* ThreadTransfer at location (*).
*/
SpliceOut(tResultPtr, transferList);
ckfree((char*)tResultPtr);
} else if (tResultPtr->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.
*/
tResultPtr->resultMsg = strcpy((char *)ckalloc(1+strlen(diemsg)),
diemsg);
tResultPtr->resultCode = TCL_ERROR;
Tcl_ConditionNotify(&tResultPtr->done);
}
}
Tcl_MutexUnlock(&threadMutex);
}
/*
*----------------------------------------------------------------------
*
* ThreadGetHandle --
*
* Construct the handle of the thread which is suitable
* to pass to Tcl.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static void
ThreadGetHandle(
Tcl_ThreadId thrId,
char *handlePtr
) {
sprintf(handlePtr, THREAD_HNDLPREFIX "%p", thrId);
}
/*
*----------------------------------------------------------------------
*
* ThreadGetId --
*
* Returns the ID of thread given it's Tcl handle.
*
* Results:
* Thread ID.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
ThreadGetId(
Tcl_Interp *interp,
Tcl_Obj *handleObj,
Tcl_ThreadId *thrIdPtr
) {
const char *thrHandle = Tcl_GetString(handleObj);
if (sscanf(thrHandle, THREAD_HNDLPREFIX "%p", thrIdPtr) == 1) {
return TCL_OK;
}
Tcl_AppendResult(interp, "invalid thread handle \"",
thrHandle, "\"", NULL);
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* ErrorNoSuchThread --
*
* Convenience function to set interpreter result when the thread
* given by it's ID cannot be found.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static void
ErrorNoSuchThread(
Tcl_Interp *interp,
Tcl_ThreadId thrId
) {
char thrHandle[THREAD_HNDLMAXLEN];
ThreadGetHandle(thrId, thrHandle);
Tcl_AppendResult(interp, "thread \"", thrHandle,
"\" does not exist", NULL);
}
/*
*----------------------------------------------------------------------
*
* ThreadCutChannel --
*
* Dissociate a Tcl channel from the current thread/interp.
*
* Results:
* None.
*
* Side effects:
* Events still pending in the thread event queue and ready to fire
* are not processed.
*
*----------------------------------------------------------------------
*/
static void
ThreadCutChannel(
Tcl_Interp *interp,
Tcl_Channel chan
) {
Tcl_DriverWatchProc *watchProc;
Tcl_ClearChannelHandlers(chan);
watchProc = Tcl_ChannelWatchProc(Tcl_GetChannelType(chan));
/*
* This effectively disables processing of pending
* events which are ready to fire for the given
* channel. If we do not do this, events will hit
* the detached channel which is potentially being
* owned by some other thread. This will wreck havoc
* on our memory and eventually badly hurt us...
*/
if (watchProc) {
(*watchProc)(Tcl_GetChannelInstanceData(chan), 0);
}
/*
* Artificially bump the channel reference count
* which protects us from channel being closed
* during the Tcl_UnregisterChannel().
*/
Tcl_RegisterChannel((Tcl_Interp *) NULL, chan);
Tcl_UnregisterChannel(interp, chan);
Tcl_CutChannel(chan);
}
/* EOF $RCSfile: threadCmd.c,v $ */
/* Emacs Setup Variables */
/* Local Variables: */
/* mode: C */
/* indent-tabs-mode: nil */
/* c-basic-offset: 4 */
/* End: */