Tcl package Thread source code

Check-in [f2f87df486]
Login
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2019 Conference, Houston/TX, US, Nov 4-8
Send your abstracts to [email protected]
or submit via the online form by Sep 9.

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:Merge 2.8
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA3-256: f2f87df486e8c1f6ec3b14388355928f78ca3850bd6d1f9de1f0bc404bc96473
User & Date: jan.nijtmans 2019-03-08 20:23:56
Context
2019-03-19
15:03
Merge 2.8 check-in: ba84bb8eed user: jan.nijtmans tags: trunk
2019-03-08
20:24
Merge trunk check-in: 69ea097204 user: jan.nijtmans tags: novem
20:23
Merge 2.8 check-in: f2f87df486 user: jan.nijtmans tags: trunk
20:23
Fix harmless gcc/MSVC compiler warnings. Somewhat more size_t usage. check-in: 2f57e12886 user: jan.nijtmans tags: thread-2-8-branch
2019-02-09
21:22
Merge thread-2-8-branch check-in: 53b1fa86b0 user: jan.nijtmans tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to generic/tclThreadInt.h.

15
16
17
18
19
20
21











22
23
24
25
26
27
28
#ifndef _TCL_THREAD_INT_H_
#define _TCL_THREAD_INT_H_

#include "tclThread.h"
#include <stdlib.h> /* For strtoul */
#include <string.h> /* For memset and friends */












/*
 * Used to tag functions that are only to be visible within the module being
 * built and not outside it (where this is supported by the linker).
 */

#ifndef MODULE_SCOPE
#   ifdef __cplusplus






>
>
>
>
>
>
>
>
>
>
>







15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
#ifndef _TCL_THREAD_INT_H_
#define _TCL_THREAD_INT_H_

#include "tclThread.h"
#include <stdlib.h> /* For strtoul */
#include <string.h> /* For memset and friends */

/*
 * MSVC 8.0 started to mark many standard C library functions depreciated
 * including the *printf family and others. Tell it to shut up.
 * (_MSC_VER is 1200 for VC6, 1300 or 1310 for vc7.net, 1400 for 8.0)
 */
#if defined(_MSC_VER) && (_MSC_VER >= 1400)
#   pragma warning(disable:4244)
#   pragma warning(disable:4267)
#   pragma warning(disable:4996)
#endif

/*
 * Used to tag functions that are only to be visible within the module being
 * built and not outside it (where this is supported by the linker).
 */

#ifndef MODULE_SCOPE
#   ifdef __cplusplus

Changes to generic/tclXkeylist.c.

281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
...
548
549
550
551
552
553
554
555
556
557
558

559
560
561
562
563
564
565
566
...
942
943
944
945
946
947
948
949

950
951
952
953
954
955
956
static void
DeleteKeyedListEntry(keylIntObj_t *keylIntPtr,
                                  int           entryIdx);

static int
FindKeyedListEntry(keylIntObj_t *keylIntPtr,
                                const char   *key,
                                int          *keyLenPtr,
                                const char   **nextSubKeyPtr);

static int
ObjToKeyedListEntry(Tcl_Interp  *interp,
                                 Tcl_Obj     *objPtr,
                                 keylEntry_t *entryPtr);

................................................................................
 *   Index of the entry or -1 if not found.
 *-----------------------------------------------------------------------------
 */
static int
FindKeyedListEntry (keylIntPtr, key, keyLenPtr, nextSubKeyPtr)
    keylIntObj_t *keylIntPtr;
    const char   *key;
    int          *keyLenPtr;
    const char   **nextSubKeyPtr;
{
    char *keySeparPtr;

    int keyLen, findIdx;

    keySeparPtr = strchr (key, '.');
    if (keySeparPtr != NULL) {
        keyLen = keySeparPtr - key;
    } else {
        keyLen = strlen (key);
    }
................................................................................
    Tcl_Interp *interp;
    Tcl_Obj    *keylPtr;
    const char *key;
    Tcl_Obj    *valuePtr;
{
    keylIntObj_t *keylIntPtr;
    const char *nextSubKey;
    int findIdx, keyLen, status;

    Tcl_Obj *newKeylPtr;

    if (keylPtr->typePtr != &keyedListType) {
        if (SetKeyedListFromAny(interp, keylPtr) != TCL_OK) {
            return TCL_ERROR;
        }
    }






|







 







|



>
|







 







|
>







281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
...
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
...
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
static void
DeleteKeyedListEntry(keylIntObj_t *keylIntPtr,
                                  int           entryIdx);

static int
FindKeyedListEntry(keylIntObj_t *keylIntPtr,
                                const char   *key,
                                size_t       *keyLenPtr,
                                const char   **nextSubKeyPtr);

static int
ObjToKeyedListEntry(Tcl_Interp  *interp,
                                 Tcl_Obj     *objPtr,
                                 keylEntry_t *entryPtr);

................................................................................
 *   Index of the entry or -1 if not found.
 *-----------------------------------------------------------------------------
 */
static int
FindKeyedListEntry (keylIntPtr, key, keyLenPtr, nextSubKeyPtr)
    keylIntObj_t *keylIntPtr;
    const char   *key;
    size_t       *keyLenPtr;
    const char   **nextSubKeyPtr;
{
    char *keySeparPtr;
    size_t keyLen;
    int findIdx;

    keySeparPtr = strchr (key, '.');
    if (keySeparPtr != NULL) {
        keyLen = keySeparPtr - key;
    } else {
        keyLen = strlen (key);
    }
................................................................................
    Tcl_Interp *interp;
    Tcl_Obj    *keylPtr;
    const char *key;
    Tcl_Obj    *valuePtr;
{
    keylIntObj_t *keylIntPtr;
    const char *nextSubKey;
    int findIdx, status;
    size_t keyLen;
    Tcl_Obj *newKeylPtr;

    if (keylPtr->typePtr != &keyedListType) {
        if (SetKeyedListFromAny(interp, keylPtr) != TCL_OK) {
            return TCL_ERROR;
        }
    }

Changes to generic/threadCmd.c.

108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
....
1839
1840
1841
1842
1843
1844
1845
1846

1847
1848
1849
1850
1851
1852
1853
....
3349
3350
3351
3352
3353
3354
3355
3356
3357
3358
3359
3360
3361
3362
3363
....
3441
3442
3443
3444
3445
3446
3447
3448
3449
3450
3451
3452
3453
3454
3455
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 */
    int 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;

................................................................................
Tcl_ThreadCreateType
NewThread(clientData)
    ClientData clientData;
{
    ThreadCtrl *ctrlPtr = (ThreadCtrl *)clientData;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    Tcl_Interp *interp;
    int result = TCL_OK, 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
................................................................................
static int
ThreadGetOption(interp, thrId, option, dsPtr)
    Tcl_Interp *interp;
    Tcl_ThreadId thrId;
    char *option;
    Tcl_DString *dsPtr;
{
    int len;
    ThreadSpecificData *tsdPtr = NULL;

    /*
     * If the optionName is NULL it means that we want
     * a list of all options and values.
     */

................................................................................
static int
ThreadSetOption(interp, thrId, option, value)
    Tcl_Interp *interp;
    Tcl_ThreadId thrId;
    char *option;
    char *value;
{
    int len = strlen(option);
    ThreadSpecificData *tsdPtr = NULL;

    Tcl_MutexLock(&threadMutex);

    tsdPtr = ThreadExistsInner(thrId);

    if (tsdPtr == (ThreadSpecificData*)NULL) {






|







 







|
>







 







|







 







|







108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
....
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
....
3350
3351
3352
3353
3354
3355
3356
3357
3358
3359
3360
3361
3362
3363
3364
....
3442
3443
3444
3445
3446
3447
3448
3449
3450
3451
3452
3453
3454
3455
3456
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;

................................................................................
Tcl_ThreadCreateType
NewThread(clientData)
    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
................................................................................
static int
ThreadGetOption(interp, thrId, option, dsPtr)
    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.
     */

................................................................................
static int
ThreadSetOption(interp, thrId, option, value)
    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 == (ThreadSpecificData*)NULL) {

Changes to generic/threadPoolCmd.c.

33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
..
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
...
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
...
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
...
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
...
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
....
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
....
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
    int suspend;                    /* Set to 1 to suspend pool processing */
    char *initScript;               /* Script to initialize worker thread */
    char *exitScript;               /* Script to cleanup the worker */
    int minWorkers;                 /* Minimum number or worker threads */
    int maxWorkers;                 /* Maximum number of worker threads */
    int numWorkers;                 /* Current number of worker threads */
    int idleWorkers;                /* Number of idle workers */
    int refCount;                   /* Reference counter for reserve/release */
    Tcl_Mutex mutex;                /* Pool mutex */
    Tcl_Condition cond;             /* Pool condition variable */
    Tcl_HashTable jobsDone;         /* Stores processed job results */
    struct TpoolResult *workTail;   /* Tail of the list with jobs pending*/
    struct TpoolResult *workHead;   /* Head of the list with jobs pending*/
    struct TpoolWaiter *waitTail;   /* Tail of the thread waiters list */
    struct TpoolWaiter *waitHead;   /* Head of the thread waiters list */
................................................................................
 * Structure for passing evaluation results
 */

typedef struct TpoolResult {
    int detached;                   /* Result is to be ignored */
    Tcl_WideInt jobId;              /* The job id of the current job */
    char *script;                   /* Script to evaluate in worker thread */
    int scriptLen;                  /* Length of the script */
    int retcode;                    /* Tcl return code of the current job */
    char *result;                   /* Tcl result of the current job */
    char *errorCode;                /* On error: content of the errorCode */
    char *errorInfo;                /* On error: content of the errorInfo */
    Tcl_ThreadId threadId;          /* Originating thread id */
    ThreadPool *tpoolPtr;           /* Current thread pool */
    struct TpoolResult *nextPtr;
................................................................................
static TpoolWaiter*
PopWaiter(ThreadPool *tpoolPtr);

static void
SignalWaiter(ThreadPool *tpoolPtr);

static int
TpoolEval(Tcl_Interp *interp, char *script, int scriptLen,
                            TpoolResult *rPtr);
static void
SetResult(Tcl_Interp *interp, TpoolResult *rPtr);

static ThreadPool*
GetTpool(const char *tpoolName);

................................................................................

static void
AppExitHandler(ClientData clientData);

static int
TpoolReserve(ThreadPool *tpoolPtr);

static int
TpoolRelease(ThreadPool *tpoolPtr);

static void
TpoolSuspend(ThreadPool *tpoolPtr);

static void
TpoolResume(ThreadPool *tpoolPtr);
................................................................................
static int
TpoolReleaseObjCmd(dummy, interp, objc, objv)
    ClientData  dummy;          /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    int         objc;           /* Number of arguments. */
    Tcl_Obj    *const objv[];   /* Argument objects. */
{
    int ret;
    char *tpoolName;
    ThreadPool *tpoolPtr;

    /*
     * Syntax: tpool::release tpoolId
     */

................................................................................
        Tcl_AppendResult(interp, "can not find threadpool \"", tpoolName,
                         "\"", NULL);
        return TCL_ERROR;
    }

    ret = TpoolRelease(tpoolPtr);
    Tcl_MutexUnlock(&listMutex);
    Tcl_SetObjResult(interp, Tcl_NewIntObj(ret));

    return TCL_OK;
}
 
/*
 *----------------------------------------------------------------------
 *
................................................................................
 *
 *----------------------------------------------------------------------
 */
static int
TpoolEval(interp, script, scriptLen, rPtr)
    Tcl_Interp *interp;
    char *script;
    int scriptLen;
    TpoolResult *rPtr;
{
    int ret;
    size_t reslen;
    const char *result;
    const char *errorCode, *errorInfo;

................................................................................
 *  None.
 *
 * Side effects:
 *  May tear-down the threadpool if refcount drops to 0 or below.
 *
 *----------------------------------------------------------------------
 */
static int
TpoolRelease(tpoolPtr)
    ThreadPool *tpoolPtr;
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    TpoolResult *rPtr;
    Tcl_HashEntry *hPtr;
    Tcl_HashSearch search;

    if (--tpoolPtr->refCount > 0) {
        return tpoolPtr->refCount;
    }

    /*
     * Pool is going away; remove from the list of pools,
     */







|







 







|







 







|







 







|







 







|







 







|







 







|







 







|








|







33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
..
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
...
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
...
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
...
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
...
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
....
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
....
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
    int suspend;                    /* Set to 1 to suspend pool processing */
    char *initScript;               /* Script to initialize worker thread */
    char *exitScript;               /* Script to cleanup the worker */
    int minWorkers;                 /* Minimum number or worker threads */
    int maxWorkers;                 /* Maximum number of worker threads */
    int numWorkers;                 /* Current number of worker threads */
    int idleWorkers;                /* Number of idle workers */
    size_t refCount;                /* Reference counter for reserve/release */
    Tcl_Mutex mutex;                /* Pool mutex */
    Tcl_Condition cond;             /* Pool condition variable */
    Tcl_HashTable jobsDone;         /* Stores processed job results */
    struct TpoolResult *workTail;   /* Tail of the list with jobs pending*/
    struct TpoolResult *workHead;   /* Head of the list with jobs pending*/
    struct TpoolWaiter *waitTail;   /* Tail of the thread waiters list */
    struct TpoolWaiter *waitHead;   /* Head of the thread waiters list */
................................................................................
 * Structure for passing evaluation results
 */

typedef struct TpoolResult {
    int detached;                   /* Result is to be ignored */
    Tcl_WideInt jobId;              /* The job id of the current job */
    char *script;                   /* Script to evaluate in worker thread */
    size_t scriptLen;               /* Length of the script */
    int retcode;                    /* Tcl return code of the current job */
    char *result;                   /* Tcl result of the current job */
    char *errorCode;                /* On error: content of the errorCode */
    char *errorInfo;                /* On error: content of the errorInfo */
    Tcl_ThreadId threadId;          /* Originating thread id */
    ThreadPool *tpoolPtr;           /* Current thread pool */
    struct TpoolResult *nextPtr;
................................................................................
static TpoolWaiter*
PopWaiter(ThreadPool *tpoolPtr);

static void
SignalWaiter(ThreadPool *tpoolPtr);

static int
TpoolEval(Tcl_Interp *interp, char *script, size_t scriptLen,
                            TpoolResult *rPtr);
static void
SetResult(Tcl_Interp *interp, TpoolResult *rPtr);

static ThreadPool*
GetTpool(const char *tpoolName);

................................................................................

static void
AppExitHandler(ClientData clientData);

static int
TpoolReserve(ThreadPool *tpoolPtr);

static size_t
TpoolRelease(ThreadPool *tpoolPtr);

static void
TpoolSuspend(ThreadPool *tpoolPtr);

static void
TpoolResume(ThreadPool *tpoolPtr);
................................................................................
static int
TpoolReleaseObjCmd(dummy, interp, objc, objv)
    ClientData  dummy;          /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    int         objc;           /* Number of arguments. */
    Tcl_Obj    *const objv[];   /* Argument objects. */
{
    size_t ret;
    char *tpoolName;
    ThreadPool *tpoolPtr;

    /*
     * Syntax: tpool::release tpoolId
     */

................................................................................
        Tcl_AppendResult(interp, "can not find threadpool \"", tpoolName,
                         "\"", NULL);
        return TCL_ERROR;
    }

    ret = TpoolRelease(tpoolPtr);
    Tcl_MutexUnlock(&listMutex);
    Tcl_SetObjResult(interp, Tcl_NewWideIntObj(ret));

    return TCL_OK;
}
 
/*
 *----------------------------------------------------------------------
 *
................................................................................
 *
 *----------------------------------------------------------------------
 */
static int
TpoolEval(interp, script, scriptLen, rPtr)
    Tcl_Interp *interp;
    char *script;
    size_t scriptLen;
    TpoolResult *rPtr;
{
    int ret;
    size_t reslen;
    const char *result;
    const char *errorCode, *errorInfo;

................................................................................
 *  None.
 *
 * Side effects:
 *  May tear-down the threadpool if refcount drops to 0 or below.
 *
 *----------------------------------------------------------------------
 */
static size_t
TpoolRelease(tpoolPtr)
    ThreadPool *tpoolPtr;
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    TpoolResult *rPtr;
    Tcl_HashEntry *hPtr;
    Tcl_HashSearch search;

    if (tpoolPtr->refCount-- > 1) {
        return tpoolPtr->refCount;
    }

    /*
     * Pool is going away; remove from the list of pools,
     */

Changes to generic/threadSvCmd.c.

151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
void
Sv_RegisterCommand(
                   const char *cmdName,                /* Name of command to register */
                   Tcl_ObjCmdProc *objProc,            /* Object-based command procedure */
                   Tcl_CmdDeleteProc *delProc,         /* Command delete procedure */
                   int aolSpecial)
{
    int len = strlen(cmdName) + strlen(TSV_CMD_PREFIX) + 1;
    int len2 = strlen(cmdName) + strlen(TSV_CMD2_PREFIX) + 1;
    SvCmdInfo *newCmd = (SvCmdInfo*)ckalloc(sizeof(SvCmdInfo) + len + len2);

    /*
     * Setup new command structure
     */

    newCmd->cmdName = (char*)((char*)newCmd + sizeof(SvCmdInfo));






|
|







151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
void
Sv_RegisterCommand(
                   const char *cmdName,                /* Name of command to register */
                   Tcl_ObjCmdProc *objProc,            /* Object-based command procedure */
                   Tcl_CmdDeleteProc *delProc,         /* Command delete procedure */
                   int aolSpecial)
{
    size_t len = strlen(cmdName) + strlen(TSV_CMD_PREFIX) + 1;
    size_t len2 = strlen(cmdName) + strlen(TSV_CMD2_PREFIX) + 1;
    SvCmdInfo *newCmd = (SvCmdInfo*)ckalloc(sizeof(SvCmdInfo) + len + len2);

    /*
     * Setup new command structure
     */

    newCmd->cmdName = (char*)((char*)newCmd + sizeof(SvCmdInfo));