Tcl package Thread source code

Check-in [f23bc2edae]
Login

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

Overview
Comment:Merge in thread::cancel support
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: f23bc2edae6bb42a4ca28a6b7e6b37b62047f04b
User & Date: dgp 2011-11-01 15:07:50
Context
2011-11-18
01:17
Update all remaining versions to 2.7b1. For [thread::cancel], avoid creating a new Tcl_Obj when the default script cancellation result is desired. Stop using -debug:full as it causes an error with the MSVC10 compiler. check-in: d893efb569 user: mistachkin tags: trunk
2011-11-01
15:07
Merge in thread::cancel support check-in: f23bc2edae user: dgp tags: trunk
15:07
Merge in bug fixes and finalization support check-in: 6067508840 user: dgp tags: trunk
2011-10-28
15:33
Test suite tolerate the existence of the [thread::cancel] command Closed-Leaf check-in: ed8e983fc8 user: dgp tags: tip285
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to doc/thread.man.

164
165
166
167
168
169
170
















171
172
173
174
175
176
177
invoked the [cmd thread::errorproc] command. The [arg procname]
is called like this:

[example {
    myerrorproc thread_id errorInfo
}]

















[call [cmd thread::unwind]]

Use of this command is deprecated in favour of more advanced thread
reservation system implemented with [cmd thread::preserve] and 
[cmd thread::release] commands. Support for [cmd thread::unwind] 
command will dissapear in some future major release of the extension.
[para]







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
invoked the [cmd thread::errorproc] command. The [arg procname]
is called like this:

[example {
    myerrorproc thread_id errorInfo
}]

[call [cmd thread::cancel] [opt -unwind] [arg id] [opt result]]

This command requires Tcl version 8.6 or higher.

[para]

Cancels the script being evaluated in the thread given by the [arg id]
parameter. Without the [option -unwind] switch the evaluation stack for
the interpreter is unwound until an enclosing catch command is found or
there are no further invocations of the interpreter left on the call
stack. With the [option -unwind] switch the evaluation stack for the
interpreter is unwound without regard to any intervening catch command
until there are no further invocations of the interpreter left on the
call stack. If [arg result] is present, it will be used as the error
message string; otherwise, a default error message string will be used.

[call [cmd thread::unwind]]

Use of this command is deprecated in favour of more advanced thread
reservation system implemented with [cmd thread::preserve] and 
[cmd thread::release] commands. Support for [cmd thread::unwind] 
command will dissapear in some future major release of the extension.
[para]

Changes to generic/threadCmd.c.

21
22
23
24
25
26
27










28
29
30
31
32
33
34

#include "tclThread.h"

#ifdef NS_AOLSERVER
# include "aolstub.cpp"
#endif











/* 
 * Access to the list of threads and to the thread send results
 * (defined below) is guarded by this mutex. 
 */

TCL_DECLARE_MUTEX(threadMutex)








>
>
>
>
>
>
>
>
>
>







21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44

#include "tclThread.h"

#ifdef NS_AOLSERVER
# include "aolstub.cpp"
#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.
 */

#if (TCL_MAJOR_VERSION > 8) || \
    ((TCL_MAJOR_VERSION == 8) && (TCL_MINOR_VERSION >= 6))
# define TCL_TIP285
#endif

/* 
 * Access to the list of threads and to the thread send results
 * (defined below) is guarded by this mutex. 
 */

TCL_DECLARE_MUTEX(threadMutex)

327
328
329
330
331
332
333








334
335
336
337
338
339
340
static void
ErrorNoSuchThread _ANSI_ARGS_((Tcl_Interp *interp,
                               Tcl_ThreadId thrId));
static void
ThreadCutChannel  _ANSI_ARGS_((Tcl_Interp *interp,
                               Tcl_Channel channel));









/*
 * Functions implementing Tcl commands
 */

static Tcl_ObjCmdProc ThreadCreateObjCmd;
static Tcl_ObjCmdProc ThreadReserveObjCmd;
static Tcl_ObjCmdProc ThreadReleaseObjCmd;







>
>
>
>
>
>
>
>







337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
static void
ErrorNoSuchThread _ANSI_ARGS_((Tcl_Interp *interp,
                               Tcl_ThreadId thrId));
static void
ThreadCutChannel  _ANSI_ARGS_((Tcl_Interp *interp,
                               Tcl_Channel channel));

#ifdef TCL_TIP285
static int 
ThreadCancel      _ANSI_ARGS_((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;
348
349
350
351
352
353
354




355
356
357
358
359
360
361
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;





static int
ThreadInit(interp)
    Tcl_Interp *interp; /* The current Tcl interpreter */
{
    Tcl_Obj *boolObjPtr;
    const char *msg;







>
>
>
>







366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
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 */
{
    Tcl_Obj *boolObjPtr;
    const char *msg;
392
393
394
395
396
397
398



















399
400
401
402
403
404
405
    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);
    







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
    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
    {
        /*
         * This package may have been compiled against Tcl 8.6 or higher;
         * however, what if it is being loaded by Tcl 8.5 or lower?  Perform
         * a version check now to stop using from trying to use the TIP #285
         * functionality if it is not present.
         */

        int major, minor;

        Tcl_GetVersion(&major, &minor, NULL, NULL);

        if (major > 8 || (major == 8 && minor >= 6)) {
            TCL_CMD(interp, THREAD_CMD_PREFIX"cancel",    ThreadCancelObjCmd);
        }
    }
#endif

    /*
     * Add shared variable commands
     */
    
    Sv_Init(interp);
    
1416
1417
1418
1419
1420
1421
1422


























































1423
1424
1425
1426
1427
1428
1429
            return TCL_ERROR;
        }
    }

    return TCL_OK;
}



























































/*
 *----------------------------------------------------------------------
 *
 * ThreadSendEval --
 *
 *  Evaluates Tcl script passed from source to target thread.
 *







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
            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(dummy, interp, objc, objv)
    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;

    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.
 *
2031
2032
2033
2034
2035
2036
2037











































2038
2039
2040
2041
2042
2043
2044
        if (tsdPtr->threadId == thrId) {
            return tsdPtr;
        }
    }

    return NULL;
}












































/*
 *----------------------------------------------------------------------
 *
 * ThreadJoin --
 *
 *  Wait for the exit of a different thread.







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
        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(interp, thrId, result, flags)
    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. */
{
    ThreadSpecificData *tsdPtr = NULL; /* ... of the target thread */

    Tcl_MutexLock(&threadMutex);

    tsdPtr = ThreadExistsInner(thrId);

    if (tsdPtr == (ThreadSpecificData*)NULL) {
        Tcl_MutexUnlock(&threadMutex);
        ErrorNoSuchThread(interp, thrId);
        return TCL_ERROR;
    }

    Tcl_MutexUnlock(&threadMutex);

    return Tcl_CancelEval(tsdPtr->interp, Tcl_NewStringObj(result, -1), 0,
            flags);
}
#endif

/*
 *----------------------------------------------------------------------
 *
 * ThreadJoin --
 *
 *  Wait for the exit of a different thread.

Changes to tests/thread.test.

37
38
39
40
41
42
43
44


45
46
47
48
49
50
51
}

test thread-2.0 {no global thread command} {
    info commands thread
} {}

test thread-2.84 {thread subcommands} {
    lsort [info commands thread::*]


} {::thread::attach ::thread::broadcast ::thread::cond ::thread::configure ::thread::create ::thread::detach ::thread::errorproc ::thread::eval ::thread::exists ::thread::exit ::thread::id ::thread::join ::thread::mutex ::thread::names ::thread::preserve ::thread::release ::thread::rwmutex ::thread::send ::thread::transfer ::thread::unwind ::thread::wait}

test thread-3.0 {thread::names initial thread list} {
    list [ThreadReap] [llength [thread::names]]
} {1 1}

test thread-4.0 {thread::create: create server thread} {







|
>
>







37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
}

test thread-2.0 {no global thread command} {
    info commands thread
} {}

test thread-2.84 {thread subcommands} {
    set cmds [info commands thread::*]
    set idx [lsearch -exact $cmds ::thread::cancel]
    lsort [lreplace $cmds $idx $idx]
} {::thread::attach ::thread::broadcast ::thread::cond ::thread::configure ::thread::create ::thread::detach ::thread::errorproc ::thread::eval ::thread::exists ::thread::exit ::thread::id ::thread::join ::thread::mutex ::thread::names ::thread::preserve ::thread::release ::thread::rwmutex ::thread::send ::thread::transfer ::thread::unwind ::thread::wait}

test thread-3.0 {thread::names initial thread list} {
    list [ThreadReap] [llength [thread::names]]
} {1 1}

test thread-4.0 {thread::create: create server thread} {

Changes to win/vc/makefile.vc.

184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
PRJHEADERS = 

#-------------------------------------------------------------------------
# Target names and paths ( shouldn't need changing )
#-------------------------------------------------------------------------

BINROOT		= .
ROOT            = ..

PRJIMPLIB	= $(OUT_DIR)\$(PROJECT)$(VERSION)$(SUFX).lib
PRJLIBNAME	= $(PROJECT)$(VERSION)$(SUFX).$(EXT)
PRJLIB		= $(OUT_DIR)\$(PRJLIBNAME)

PRJSTUBLIBNAME	= $(STUBPREFIX)$(VERSION).lib
PRJSTUBLIB	= $(OUT_DIR)\$(PRJSTUBLIBNAME)







|







184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
PRJHEADERS = 

#-------------------------------------------------------------------------
# Target names and paths ( shouldn't need changing )
#-------------------------------------------------------------------------

BINROOT		= .
ROOT            = ..\..

PRJIMPLIB	= $(OUT_DIR)\$(PROJECT)$(VERSION)$(SUFX).lib
PRJLIBNAME	= $(PROJECT)$(VERSION)$(SUFX).$(EXT)
PRJLIB		= $(OUT_DIR)\$(PRJLIBNAME)

PRJSTUBLIBNAME	= $(STUBPREFIX)$(VERSION).lib
PRJSTUBLIB	= $(OUT_DIR)\$(PRJSTUBLIBNAME)