Tcl package Thread source code

#--------------------------------------------------------------------


cat >>confdefs.h <<\_ACEOF
#define USE_TCL_STUBS 1
_ACEOF


#--------------------------------------------------------------------
# Enable compile-time support for TIP #143 and TIP #285.  When using
# a pre-Tcl 8.5 or 8.6 core, respectively, the actual functionality
# will not be available at runtime.
#--------------------------------------------------------------------


cat >>confdefs.h <<\_ACEOF
#define TCL_TIP143 1
_ACEOF


cat >>confdefs.h <<\_ACEOF
#define TCL_TIP285 1
_ACEOF


#--------------------------------------------------------------------
# This macro generates a line to use when building a library.  It
# depends on values set by the TEA_ENABLE_SHARED, TEA_ENABLE_SYMBOLS,
# and TEA_LOAD_TCLCONFIG macros above.
#--------------------------------------------------------------------

# Everyone should be linking against the Tcl stub library.  If you
# can't for some reason, remove this definition.  If you aren't using
# stubs, you also need to modify the SHLIB_LD_LIBS setting below to
# link against the non-stubbed Tcl library.  Add Tk too if necessary.
#--------------------------------------------------------------------

AC_DEFINE(USE_TCL_STUBS, 1, [Use Tcl stubs])

#--------------------------------------------------------------------
# Enable compile-time support for TIP #143 and TIP #285.  When using
# a pre-Tcl 8.5 or 8.6 core, respectively, the actual functionality
# will not be available at runtime.
#--------------------------------------------------------------------

AC_DEFINE(TCL_TIP143, 1, [Enable TIP #143 support])
AC_DEFINE(TCL_TIP285, 1, [Enable TIP #285 support])

#--------------------------------------------------------------------
# This macro generates a line to use when building a library.  It
# depends on values set by the TEA_ENABLE_SHARED, TEA_ENABLE_SYMBOLS,
# and TEA_LOAD_TCLCONFIG macros above.
#--------------------------------------------------------------------

 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 * ----------------------------------------------------------------------------
 */

#include "tclThreadInt.h"

/*
 * 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_MAJOR_VERSION > 8) || \
     ((TCL_MAJOR_VERSION == 8) && (TCL_MINOR_VERSION >= 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 (tclVersion>84)
#if defined(TCL_TIP143) && (TCL_MAJOR_VERSION == 8) && \
    (TCL_MINOR_VERSION < 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 (tclVersion>85)
#ifndef TCL_TIP285
# if (TCL_MAJOR_VERSION > 8) || \
     ((TCL_MAJOR_VERSION == 8) && (TCL_MINOR_VERSION >= 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_MAJOR_VERSION == 8) && \
    (TCL_MINOR_VERSION < 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.
 */

/*
 * Used to represent the empty result.
 */

static char *threadEmptyResult = (char *)"";

#if defined(TCL_TIP143) || defined(TCL_TIP285)
static int tclVersion = 0;
#endif

/*
 * 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.
 */

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 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 int
ThreadInit(interp)
    Tcl_Interp *interp; /* The current Tcl interpreter */
{
    if (Tcl_InitStubs(interp, "8.4", 0) == NULL) {
        return TCL_ERROR;
    }

#if defined(TCL_TIP143) || defined(TCL_TIP285)
    if (!tclVersion) {

    	/*
    	 * Get the current core version to decide whether to use
    	 * some lately introduced core features or to back-off.
    	 */

    	int major, minor;

    	Tcl_GetVersion(&major, &minor, NULL, NULL);
    	tclVersion = 10 * major + minor;
    }
#endif

    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);


    /*
     * Add shared variable commands
     */

    Sv_Init(interp);

            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.

        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.

            return tsdPtr;
        }
    }

    return NULL;
}

#ifdef TCL_TIP285
/*
 *----------------------------------------------------------------------
 *
 * ThreadCancel --
 *
 *    Cancels a script in another thread.
 *

    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 == (ThreadSpecificData*)NULL) {
        Tcl_MutexUnlock(&threadMutex);

    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.

         * 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 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 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,
     * call the registered error processing script now, if there
     * is one.
     */

    if (code != TCL_OK) {
        char buf[THREAD_HNDLMAXLEN];
        const char *errorInfo;

        errorInfo = Tcl_GetVar(tsdPtr->interp, "errorInfo", TCL_GLOBAL_ONLY);
        if (errorInfo == NULL) {
        	errorInfo = Tcl_GetStringResult(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);

crt = -MTd
!else
crt = -MT
!endif
!endif

cflags = $(cflags) -DMODULE_SCOPE=extern
cflags = $(cflags) -DTCL_TIP143 -DTCL_TIP285

!if !$(STATIC_BUILD)
cflags = $(cflags) -DUSE_TCL_STUBS
!if defined(TKSTUBLIB)
cflags = $(cflags) -DUSE_TK_STUBS
!endif
!endif