Tcl package Thread source code

Check-in [e187578bb3]
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:simplify some things, and make it work against Tcl 8.4/8.5 again
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | compileTipCheck
Files: files | file ages | folders
SHA1: e187578bb3c51dddc661cea3a803ed145721053d
User & Date: jan.nijtmans 2012-11-13 23:15:49
Context
2012-11-13
23:23
merge compileTipCheck to trunk check-in: 3d2f5a0b19 user: jan.nijtmans tags: trunk
23:15
simplify some things, and make it work against Tcl 8.4/8.5 again Closed-Leaf check-in: e187578bb3 user: jan.nijtmans tags: compileTipCheck
22:45
Restore [9cbfc3b299] bugfix. check-in: 8f5ee5bc0e user: jan.nijtmans tags: compileTipCheck
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to configure.

11345
11346
11347
11348
11349
11350
11351

















11352
11353
11354
11355
11356
11357
11358
#--------------------------------------------------------------------


cat >>confdefs.h <<\_ACEOF
#define USE_TCL_STUBS 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.
#--------------------------------------------------------------------







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







11345
11346
11347
11348
11349
11350
11351
11352
11353
11354
11355
11356
11357
11358
11359
11360
11361
11362
11363
11364
11365
11366
11367
11368
11369
11370
11371
11372
11373
11374
11375
#--------------------------------------------------------------------


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.
#--------------------------------------------------------------------

Changes to generic/threadCmd.c.

35
36
37
38
39
40
41

42
43
44
45
46
47
48
..
50
51
52
53
54
55
56

57
58
59
60
61
62
63
...
137
138
139
140
141
142
143
144
145
146
147
148

149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
...
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459





460
461
462
463
464
465
466
...
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
....
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
....
2831
2832
2833
2834
2835
2836
2837
2838
2839
2840
2841
2842
2843
2844
2845
2846
2847
2848
2849
2850
2851
2852
2853
2854
2855
2856
2857
2858
2859
2860
2861
/*
 * 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.
 */


#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

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


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

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

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

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

/*
 * This will be set to non-zero if TIP #143 functionality is available.
 */

#ifdef TCL_TIP143

static int threadHaveInterpLimit = 0;
#endif

/*
 * This will be set to non-zero if TIP #285 functionality is available.
 */

#ifdef TCL_TIP285
static int threadHaveInterpCancel = 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 Tcl_ObjCmdProc ThreadCancelObjCmd;
#endif

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

    if (Tcl_InitStubs(interp, "8.4", 0) == NULL) {
        return TCL_ERROR;
    }

    boolObjPtr = Tcl_GetVar2Ex(interp, "::tcl_platform", "threaded", 0);

    if (boolObjPtr == NULL
	|| Tcl_GetBooleanFromObj(interp, boolObjPtr, &boolVar) != TCL_OK
	|| boolVar == 0) {
        msg = "Tcl core wasn't compiled for threading.";
        Tcl_SetObjResult(interp, Tcl_NewStringObj(msg, -1));
        return TCL_ERROR;
    }






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

#if defined(TCL_TIP143) || defined(TCL_TIP285)
    {
        /*
         * This package may have been compiled against Tcl 8.5 or higher;
         * however, what if it is being loaded by Tcl 8.4 or lower?  Perform
         * a version check now to stop using from trying to use the TIP #143
         * or TIP #285 functionality if they are not present.
         */

        int major, minor;

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

        Tcl_MutexLock(&threadMutex);
        if (major > 8 || (major == 8 && minor >= 5)) {
            threadHaveInterpLimit = 1;
        }
        if (major > 8 || (major == 8 && minor >= 6)) {
            threadHaveInterpCancel = 1;
        }
        Tcl_MutexUnlock(&threadMutex);

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

    /*
     * Add shared variable commands
     */

    Sv_Init(interp);

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

    if (!threadHaveInterpCancel) {
        Tcl_MutexUnlock(&threadMutex);
        Tcl_AppendResult(interp, "not supported with this Tcl version", NULL);
        return TCL_ERROR;
    }

    if (result != NULL) {
        resultObj = Tcl_NewStringObj(result, -1);
................................................................................
 *----------------------------------------------------------------------
 */
static int
ThreadWait(Tcl_Interp *interp)
{
    int code = TCL_OK;
    int canrun = 1;
    int haveInterpLimit;
    int haveInterpCancel;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

#if defined(TCL_TIP143) || defined(TCL_TIP285)
    Tcl_MutexLock(&threadMutex);
#endif
#ifdef TCL_TIP143
    haveInterpLimit = threadHaveInterpLimit;
#endif
#ifdef TCL_TIP285
    haveInterpCancel = threadHaveInterpCancel;
#endif
#if defined(TCL_TIP143) || defined(TCL_TIP285)
    Tcl_MutexUnlock(&threadMutex);
#endif

    /*
     * Process events until signaled to stop.
     */

    while (canrun) {

        /*






>







 







>







 







<
<
<
<
<
>
|
<
<
<
<
<
<
<
<







 







<
<
<
<




|
|
|
|
|
|
|
|
|
>
>
>
>
>







 







<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<







 







|







 







<
<


<
<
<
<
<
<
<
<
<
<
<
<
<







35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
..
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
...
139
140
141
142
143
144
145





146
147








148
149
150
151
152
153
154
...
426
427
428
429
430
431
432




433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
...
463
464
465
466
467
468
469




























470
471
472
473
474
475
476
....
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
....
2794
2795
2796
2797
2798
2799
2800


2801
2802













2803
2804
2805
2806
2807
2808
2809
/*
 * 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

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

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

/*
 * 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 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"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);

    /*
................................................................................
    tsdPtr = ThreadExistsInner(thrId);
    if (tsdPtr == (ThreadSpecificData*)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);
................................................................................
 *----------------------------------------------------------------------
 */
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) {

        /*