Check-in [09b2df2e2a]
Not logged in

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

Overview
Comment:add selected tcl upstream changes
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: 09b2df2e2a63e7e61bd7e349bad01725ab3fe871
User & Date: chw 2020-07-25 17:54:50
Context
2020-07-25
19:24
add selected tk upstream changes check-in: 0826c6af99 user: chw tags: trunk
17:54
add selected tcl upstream changes check-in: 09b2df2e2a user: chw tags: trunk
05:18
improve tcl-fuse Makefile.in check-in: bed12d9ce5 user: chw tags: trunk
Changes

Changes to jni/tcl/generic/tclInt.h.

1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
....
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
....
2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
....
3099
3100
3101
3102
3103
3104
3105
3106
3107
3108
3109
3110
3111
3112
3113
3114
....
3226
3227
3228
3229
3230
3231
3232
3233
3234
3235
3236
3237
3238
3239
3240
3241

    Namespace *globalNsPtr;	/* The interpreter's global namespace. */
    Tcl_HashTable *hiddenCmdTablePtr;
				/* Hash table used by tclBasic.c to keep track
				 * of hidden commands on a per-interp
				 * basis. */
    ClientData interpInfo;	/* Information used by tclInterp.c to keep
				 * track of master/slave interps on a
				 * per-interp basis. */
    union {
	void (*optimizer)(void *envPtr);
	Tcl_HashTable unused2;	/* No longer used (was mathFuncTable). The
				 * unused space in interp was repurposed for
				 * pluggable bytecode optimizers. The core
				 * contains one optimizer, which can be
................................................................................
    /*
     * The thread-specific data ekeko: cache pointers or values that
     *  (a) do not change during the thread's lifetime
     *  (b) require access to TSD to determine at runtime
     *  (c) are accessed very often (e.g., at each command call)
     *
     * Note that these are the same for all interps in the same thread. They
     * just have to be initialised for the thread's master interp, slaves
     * inherit the value.
     *
     * They are used by the macros defined below.
     */

    AllocCache *allocCache;
    void *pendingObjDataPtr;	/* Pointer to the Cache and PendingObjData
................................................................................

typedef void (TclInitProcessGlobalValueProc)(char **valuePtr, int *lengthPtr,
	Tcl_Encoding *encodingPtr);

/*
 * A ProcessGlobalValue struct exists for each internal value in Tcl that is
 * to be shared among several threads. Each thread sees a (Tcl_Obj) copy of
 * the value, and the master is kept as a counted string, with epoch and mutex
 * control. Each ProcessGlobalValue struct should be a static variable in some
 * file.
 */

typedef struct ProcessGlobalValue {
    int epoch;			/* Epoch counter to detect changes in the
				 * master value. */
    int numBytes;		/* Length of the master string. */
    char *value;		/* The master string value. */
    Tcl_Encoding encoding;	/* system encoding when master string was
				 * initialized. */
    TclInitProcessGlobalValueProc *proc;
    				/* A procedure to initialize the master string
				 * copy when a "get" request comes in before
				 * any "set" request has been received. */
    Tcl_Mutex mutex;		/* Enforce orderly access from multiple
				 * threads. */
    Tcl_ThreadDataKey key;	/* Key for per-thread data holding the
				 * (Tcl_Obj) copy for each thread. */
} ProcessGlobalValue;
................................................................................
MODULE_SCOPE int	TclpFindVariable(const char *name, int *lengthPtr);
MODULE_SCOPE void	TclpInitLibraryPath(char **valuePtr,
			    int *lengthPtr, Tcl_Encoding *encodingPtr);
MODULE_SCOPE void	TclpInitLock(void);
MODULE_SCOPE void	TclpInitPlatform(void);
MODULE_SCOPE void	TclpInitUnlock(void);
MODULE_SCOPE Tcl_Obj *	TclpObjListVolumes(void);
MODULE_SCOPE void	TclpMasterLock(void);
MODULE_SCOPE void	TclpMasterUnlock(void);
MODULE_SCOPE int	TclpMatchFiles(Tcl_Interp *interp, char *separators,
			    Tcl_DString *dirPtr, char *pattern, char *tail);
MODULE_SCOPE int	TclpObjNormalizePath(Tcl_Interp *interp,
			    Tcl_Obj *pathPtr, int nextCheckpoint);
MODULE_SCOPE void	TclpNativeJoinPath(Tcl_Obj *prefix, const char *joining);
MODULE_SCOPE Tcl_Obj *	TclpNativeSplitPath(Tcl_Obj *pathPtr, int *lenPtr);
MODULE_SCOPE Tcl_PathType TclpGetNativePathType(Tcl_Obj *pathPtr,
................................................................................
#   endif
#endif
MODULE_SCOPE Tcl_WideInt TclpGetMicroseconds(void);

MODULE_SCOPE int	TclZlibInit(Tcl_Interp *interp);
MODULE_SCOPE void *	TclpThreadCreateKey(void);
MODULE_SCOPE void	TclpThreadDeleteKey(void *keyPtr);
MODULE_SCOPE void	TclpThreadSetMasterTSD(void *tsdKeyPtr, void *ptr);
MODULE_SCOPE void *	TclpThreadGetMasterTSD(void *tsdKeyPtr);

MODULE_SCOPE void	TclErrorStackResetIf(Tcl_Interp *interp, const char *msg, int length);

#if TCL_UTF_MAX > 3
MODULE_SCOPE int	TclCollapseSurrogatePair(Tcl_Token *tokenPtr,
			    int *numReadPtr, char *buffer);
#endif







|







 







|







 







|
|
|




|
|
|
|


|







 







|
|







 







|
|







1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
....
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
....
2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
....
3099
3100
3101
3102
3103
3104
3105
3106
3107
3108
3109
3110
3111
3112
3113
3114
....
3226
3227
3228
3229
3230
3231
3232
3233
3234
3235
3236
3237
3238
3239
3240
3241

    Namespace *globalNsPtr;	/* The interpreter's global namespace. */
    Tcl_HashTable *hiddenCmdTablePtr;
				/* Hash table used by tclBasic.c to keep track
				 * of hidden commands on a per-interp
				 * basis. */
    ClientData interpInfo;	/* Information used by tclInterp.c to keep
				 * track of parent/child interps on a
				 * per-interp basis. */
    union {
	void (*optimizer)(void *envPtr);
	Tcl_HashTable unused2;	/* No longer used (was mathFuncTable). The
				 * unused space in interp was repurposed for
				 * pluggable bytecode optimizers. The core
				 * contains one optimizer, which can be
................................................................................
    /*
     * The thread-specific data ekeko: cache pointers or values that
     *  (a) do not change during the thread's lifetime
     *  (b) require access to TSD to determine at runtime
     *  (c) are accessed very often (e.g., at each command call)
     *
     * Note that these are the same for all interps in the same thread. They
     * just have to be initialised for the thread's parent interp, children
     * inherit the value.
     *
     * They are used by the macros defined below.
     */

    AllocCache *allocCache;
    void *pendingObjDataPtr;	/* Pointer to the Cache and PendingObjData
................................................................................

typedef void (TclInitProcessGlobalValueProc)(char **valuePtr, int *lengthPtr,
	Tcl_Encoding *encodingPtr);

/*
 * A ProcessGlobalValue struct exists for each internal value in Tcl that is
 * to be shared among several threads. Each thread sees a (Tcl_Obj) copy of
 * the value, and the gobal value is kept as a counted string, with epoch and
 * mutex control. Each ProcessGlobalValue struct should be a static variable in
 * some file.
 */

typedef struct ProcessGlobalValue {
    int epoch;			/* Epoch counter to detect changes in the
				 * global value. */
    int numBytes;		/* Length of the global string. */
    char *value;		/* The global string value. */
    Tcl_Encoding encoding;	/* system encoding when global string was
				 * initialized. */
    TclInitProcessGlobalValueProc *proc;
    				/* A procedure to initialize the global string
				 * copy when a "get" request comes in before
				 * any "set" request has been received. */
    Tcl_Mutex mutex;		/* Enforce orderly access from multiple
				 * threads. */
    Tcl_ThreadDataKey key;	/* Key for per-thread data holding the
				 * (Tcl_Obj) copy for each thread. */
} ProcessGlobalValue;
................................................................................
MODULE_SCOPE int	TclpFindVariable(const char *name, int *lengthPtr);
MODULE_SCOPE void	TclpInitLibraryPath(char **valuePtr,
			    int *lengthPtr, Tcl_Encoding *encodingPtr);
MODULE_SCOPE void	TclpInitLock(void);
MODULE_SCOPE void	TclpInitPlatform(void);
MODULE_SCOPE void	TclpInitUnlock(void);
MODULE_SCOPE Tcl_Obj *	TclpObjListVolumes(void);
MODULE_SCOPE void	TclpGlobalLock(void);
MODULE_SCOPE void	TclpGlobalUnlock(void);
MODULE_SCOPE int	TclpMatchFiles(Tcl_Interp *interp, char *separators,
			    Tcl_DString *dirPtr, char *pattern, char *tail);
MODULE_SCOPE int	TclpObjNormalizePath(Tcl_Interp *interp,
			    Tcl_Obj *pathPtr, int nextCheckpoint);
MODULE_SCOPE void	TclpNativeJoinPath(Tcl_Obj *prefix, const char *joining);
MODULE_SCOPE Tcl_Obj *	TclpNativeSplitPath(Tcl_Obj *pathPtr, int *lenPtr);
MODULE_SCOPE Tcl_PathType TclpGetNativePathType(Tcl_Obj *pathPtr,
................................................................................
#   endif
#endif
MODULE_SCOPE Tcl_WideInt TclpGetMicroseconds(void);

MODULE_SCOPE int	TclZlibInit(Tcl_Interp *interp);
MODULE_SCOPE void *	TclpThreadCreateKey(void);
MODULE_SCOPE void	TclpThreadDeleteKey(void *keyPtr);
MODULE_SCOPE void	TclpThreadSetGlobalTSD(void *tsdKeyPtr, void *ptr);
MODULE_SCOPE void *	TclpThreadGetGlobalTSD(void *tsdKeyPtr);

MODULE_SCOPE void	TclErrorStackResetIf(Tcl_Interp *interp, const char *msg, int length);

#if TCL_UTF_MAX > 3
MODULE_SCOPE int	TclCollapseSurrogatePair(Tcl_Token *tokenPtr,
			    int *numReadPtr, char *buffer);
#endif

Changes to jni/tcl/generic/tclThread.c.

137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
...
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
...
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
...
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
...
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
...
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
...
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
...
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
 *----------------------------------------------------------------------
 *
 * RememberSyncObject
 *
 *	Keep a list of (mutexes/condition variable/data key) used during
 *	finalization.
 *
 *	Assume master lock is held.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Add to the appropriate list.
 *
................................................................................
 
/*
 *----------------------------------------------------------------------
 *
 * ForgetSyncObject
 *
 *	Remove a single object from the list.
 *	Assume master lock is held.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Remove from the appropriate list.
 *
................................................................................
 
/*
 *----------------------------------------------------------------------
 *
 * TclRememberMutex
 *
 *	Keep a list of mutexes used during finalization.
 *	Assume master lock is held.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Add to the mutex list.
 *
................................................................................
void
Tcl_MutexFinalize(
    Tcl_Mutex *mutexPtr)
{
#ifdef TCL_THREADS
    TclpFinalizeMutex(mutexPtr);
#endif
    TclpMasterLock();
    ForgetSyncObject(mutexPtr, &mutexRecord);
    TclpMasterUnlock();
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclRememberCondition
 *
 *	Keep a list of condition variables used during finalization.
 *	Assume master lock is held.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Add to the condition variable list.
 *
................................................................................
void
Tcl_ConditionFinalize(
    Tcl_Condition *condPtr)
{
#ifdef TCL_THREADS
    TclpFinalizeCondition(condPtr);
#endif
    TclpMasterLock();
    ForgetSyncObject(condPtr, &condRecord);
    TclpMasterUnlock();
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclFinalizeThreadData --
 *
................................................................................
    int i;
    void *blockPtr;
    Tcl_ThreadDataKey *keyPtr;
#ifdef TCL_THREADS
    Tcl_Mutex *mutexPtr;
    Tcl_Condition *condPtr;

    TclpMasterLock();
#endif

    /*
     * If we're running unthreaded, the TSD blocks are simply stored inside
     * their thread data keys. Free them here.
     */

................................................................................
	keyRecord.list = NULL;
    }
    keyRecord.max = 0;
    keyRecord.num = 0;

#ifdef TCL_THREADS
    /*
     * Call thread storage master cleanup.
     */

    TclFinalizeThreadStorage();

    for (i=0 ; i<mutexRecord.num ; i++) {
	mutexPtr = (Tcl_Mutex *)mutexRecord.list[i];
	if (mutexPtr != NULL) {
................................................................................
    if (condRecord.list != NULL) {
	ckfree(condRecord.list);
	condRecord.list = NULL;
    }
    condRecord.max = 0;
    condRecord.num = 0;

    TclpMasterUnlock();
#endif /* TCL_THREADS */
}
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_ExitThread --







|







 







|







 







|







 







|

|








|







 







|

|







 







|







 







|







 







|







137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
...
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
...
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
...
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
...
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
...
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
...
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
...
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
 *----------------------------------------------------------------------
 *
 * RememberSyncObject
 *
 *	Keep a list of (mutexes/condition variable/data key) used during
 *	finalization.
 *
 *	Assume global lock is held.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Add to the appropriate list.
 *
................................................................................
 
/*
 *----------------------------------------------------------------------
 *
 * ForgetSyncObject
 *
 *	Remove a single object from the list.
 *	Assume global lock is held.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Remove from the appropriate list.
 *
................................................................................
 
/*
 *----------------------------------------------------------------------
 *
 * TclRememberMutex
 *
 *	Keep a list of mutexes used during finalization.
 *	Assume global lock is held.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Add to the mutex list.
 *
................................................................................
void
Tcl_MutexFinalize(
    Tcl_Mutex *mutexPtr)
{
#ifdef TCL_THREADS
    TclpFinalizeMutex(mutexPtr);
#endif
    TclpGlobalLock();
    ForgetSyncObject(mutexPtr, &mutexRecord);
    TclpGlobalUnlock();
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclRememberCondition
 *
 *	Keep a list of condition variables used during finalization.
 *	Assume global lock is held.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Add to the condition variable list.
 *
................................................................................
void
Tcl_ConditionFinalize(
    Tcl_Condition *condPtr)
{
#ifdef TCL_THREADS
    TclpFinalizeCondition(condPtr);
#endif
    TclpGlobalLock();
    ForgetSyncObject(condPtr, &condRecord);
    TclpGlobalUnlock();
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclFinalizeThreadData --
 *
................................................................................
    int i;
    void *blockPtr;
    Tcl_ThreadDataKey *keyPtr;
#ifdef TCL_THREADS
    Tcl_Mutex *mutexPtr;
    Tcl_Condition *condPtr;

    TclpGlobalLock();
#endif

    /*
     * If we're running unthreaded, the TSD blocks are simply stored inside
     * their thread data keys. Free them here.
     */

................................................................................
	keyRecord.list = NULL;
    }
    keyRecord.max = 0;
    keyRecord.num = 0;

#ifdef TCL_THREADS
    /*
     * Call thread storage global cleanup.
     */

    TclFinalizeThreadStorage();

    for (i=0 ; i<mutexRecord.num ; i++) {
	mutexPtr = (Tcl_Mutex *)mutexRecord.list[i];
	if (mutexPtr != NULL) {
................................................................................
    if (condRecord.list != NULL) {
	ckfree(condRecord.list);
	condRecord.list = NULL;
    }
    condRecord.max = 0;
    condRecord.num = 0;

    TclpGlobalUnlock();
#endif /* TCL_THREADS */
}
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_ExitThread --

Changes to jni/tcl/generic/tclThreadStorage.c.

23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
...
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
...
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
...
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
...
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
...
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
 * it for storing a table pointer. Each Tcl_ThreadDataKey has an offset into
 * the table of TSD values. We don't use more than 1 platform-specific TSD
 * slot, because there is a hard limit on the number of TSD slots. Valid key
 * offsets are greater than 0; 0 is for the initialized Tcl_ThreadDataKey.
 */

/*
 * The master collection of information about TSDs. This is shared across the
 * whole process, and includes the mutex used to protect it.
 */

static struct TSDMaster {
    void *key;			/* Key into the system TSD structure. The
				 * collection of Tcl TSD values for a
				 * particular thread will hang off the
				 * back-end of this. */
    sig_atomic_t counter;	/* The number of different Tcl TSDs used
				 * across *all* threads. This is a strictly
				 * increasing value. */
    Tcl_Mutex mutex;		/* Protection for the rest of this structure,
				 * which holds per-process data. */
} tsdMaster = { NULL, 0, NULL };

/*
 * The type of the data held per thread in a system TSD.
 */

typedef struct TSDTable {
    ClientData *tablePtr;	/* The table of Tcl TSDs. */
    sig_atomic_t allocated;	/* The size of the table in the current
				 * thread. */
} TSDTable;

/*
 * The actual type of Tcl_ThreadDataKey.
 */

typedef union TSDUnion {
    volatile sig_atomic_t offset;
				/* The type is really an offset into the
				 * thread-local table of TSDs, which is this
				 * field. */
    void *ptr;			/* For alignment purposes only. Not actually
				 * accessed through this. */
} TSDUnion;
................................................................................
 *----------------------------------------------------------------------
 */

void *
TclThreadStorageKeyGet(
    Tcl_ThreadDataKey *dataKeyPtr)
{
    TSDTable *tsdTablePtr = TclpThreadGetMasterTSD(tsdMaster.key);
    ClientData resultPtr = NULL;
    TSDUnion *keyPtr = (TSDUnion *) dataKeyPtr;
    sig_atomic_t offset = keyPtr->offset;

    if ((tsdTablePtr != NULL) && (offset > 0)
	    && (offset < tsdTablePtr->allocated)) {
	resultPtr = tsdTablePtr->tablePtr[offset];
................................................................................
 */

void
TclThreadStorageKeySet(
    Tcl_ThreadDataKey *dataKeyPtr,
    void *value)
{
    TSDTable *tsdTablePtr = TclpThreadGetMasterTSD(tsdMaster.key);
    TSDUnion *keyPtr = (TSDUnion *) dataKeyPtr;

    if (tsdTablePtr == NULL) {
	tsdTablePtr = TSDTableCreate();
	TclpThreadSetMasterTSD(tsdMaster.key, tsdTablePtr);
    }

    /*
     * Get the lock while we check if this TSD is new or not. Note that this
     * is the only place where Tcl_ThreadDataKey values are set. We use a
     * double-checked lock to try to avoid having to grab this lock a lot,
     * since it is on quite a few critical paths and will only get set once in
     * each location.
     */

    if (keyPtr->offset == 0) {
	Tcl_MutexLock(&tsdMaster.mutex);
	if (keyPtr->offset == 0) {
	    /*
	     * The Tcl_ThreadDataKey hasn't been used yet. Make a new one.
	     */

	    keyPtr->offset = ++tsdMaster.counter;
	}
	Tcl_MutexUnlock(&tsdMaster.mutex);
    }

    /*
     * Check if this is the first time this Tcl_ThreadDataKey has been used
     * with the current thread. Note that we don't need to hold a lock when
     * doing this, as we are *definitely* the only point accessing this
     * tsdTablePtr right now; it's thread-local.
................................................................................
 *
 *----------------------------------------------------------------------
 */

void
TclFinalizeThreadDataThread(void)
{
    TSDTable *tsdTablePtr = TclpThreadGetMasterTSD(tsdMaster.key);

    if (tsdTablePtr != NULL) {
	TSDTableDelete(tsdTablePtr);
	TclpThreadSetMasterTSD(tsdMaster.key, NULL);
    }
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclInitializeThreadStorage --
................................................................................
 *
 *----------------------------------------------------------------------
 */

void
TclInitThreadStorage(void)
{
    tsdMaster.key = TclpThreadCreateKey();
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclFinalizeThreadStorage --
 *
................................................................................
 *
 *----------------------------------------------------------------------
 */

void
TclFinalizeThreadStorage(void)
{
    TclpThreadDeleteKey(tsdMaster.key);
    tsdMaster.key = NULL;
}
 
#else /* !TCL_THREADS */
/*
 * Stub functions for non-threaded builds
 */








|



|









|





|









|







 







|







 







|




|











|





|

|







 







|



|







 







|







 







|
|







23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
...
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
...
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
...
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
...
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
...
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
 * it for storing a table pointer. Each Tcl_ThreadDataKey has an offset into
 * the table of TSD values. We don't use more than 1 platform-specific TSD
 * slot, because there is a hard limit on the number of TSD slots. Valid key
 * offsets are greater than 0; 0 is for the initialized Tcl_ThreadDataKey.
 */

/*
 * The global collection of information about TSDs. This is shared across the
 * whole process, and includes the mutex used to protect it.
 */

static struct {
    void *key;			/* Key into the system TSD structure. The
				 * collection of Tcl TSD values for a
				 * particular thread will hang off the
				 * back-end of this. */
    sig_atomic_t counter;	/* The number of different Tcl TSDs used
				 * across *all* threads. This is a strictly
				 * increasing value. */
    Tcl_Mutex mutex;		/* Protection for the rest of this structure,
				 * which holds per-process data. */
} tsdGlobal = { NULL, 0, NULL };

/*
 * The type of the data held per thread in a system TSD.
 */

typedef struct {
    ClientData *tablePtr;	/* The table of Tcl TSDs. */
    sig_atomic_t allocated;	/* The size of the table in the current
				 * thread. */
} TSDTable;

/*
 * The actual type of Tcl_ThreadDataKey.
 */

typedef union {
    volatile sig_atomic_t offset;
				/* The type is really an offset into the
				 * thread-local table of TSDs, which is this
				 * field. */
    void *ptr;			/* For alignment purposes only. Not actually
				 * accessed through this. */
} TSDUnion;
................................................................................
 *----------------------------------------------------------------------
 */

void *
TclThreadStorageKeyGet(
    Tcl_ThreadDataKey *dataKeyPtr)
{
    TSDTable *tsdTablePtr = TclpThreadGetGlobalTSD(tsdGlobal.key);
    ClientData resultPtr = NULL;
    TSDUnion *keyPtr = (TSDUnion *) dataKeyPtr;
    sig_atomic_t offset = keyPtr->offset;

    if ((tsdTablePtr != NULL) && (offset > 0)
	    && (offset < tsdTablePtr->allocated)) {
	resultPtr = tsdTablePtr->tablePtr[offset];
................................................................................
 */

void
TclThreadStorageKeySet(
    Tcl_ThreadDataKey *dataKeyPtr,
    void *value)
{
    TSDTable *tsdTablePtr = TclpThreadGetGlobalTSD(tsdGlobal.key);
    TSDUnion *keyPtr = (TSDUnion *) dataKeyPtr;

    if (tsdTablePtr == NULL) {
	tsdTablePtr = TSDTableCreate();
	TclpThreadSetGlobalTSD(tsdGlobal.key, tsdTablePtr);
    }

    /*
     * Get the lock while we check if this TSD is new or not. Note that this
     * is the only place where Tcl_ThreadDataKey values are set. We use a
     * double-checked lock to try to avoid having to grab this lock a lot,
     * since it is on quite a few critical paths and will only get set once in
     * each location.
     */

    if (keyPtr->offset == 0) {
	Tcl_MutexLock(&tsdGlobal.mutex);
	if (keyPtr->offset == 0) {
	    /*
	     * The Tcl_ThreadDataKey hasn't been used yet. Make a new one.
	     */

	    keyPtr->offset = ++tsdGlobal.counter;
	}
	Tcl_MutexUnlock(&tsdGlobal.mutex);
    }

    /*
     * Check if this is the first time this Tcl_ThreadDataKey has been used
     * with the current thread. Note that we don't need to hold a lock when
     * doing this, as we are *definitely* the only point accessing this
     * tsdTablePtr right now; it's thread-local.
................................................................................
 *
 *----------------------------------------------------------------------
 */

void
TclFinalizeThreadDataThread(void)
{
    TSDTable *tsdTablePtr = TclpThreadGetGlobalTSD(tsdGlobal.key);

    if (tsdTablePtr != NULL) {
	TSDTableDelete(tsdTablePtr);
	TclpThreadSetGlobalTSD(tsdGlobal.key, NULL);
    }
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclInitializeThreadStorage --
................................................................................
 *
 *----------------------------------------------------------------------
 */

void
TclInitThreadStorage(void)
{
    tsdGlobal.key = TclpThreadCreateKey();
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclFinalizeThreadStorage --
 *
................................................................................
 *
 *----------------------------------------------------------------------
 */

void
TclFinalizeThreadStorage(void)
{
    TclpThreadDeleteKey(tsdGlobal.key);
    tsdGlobal.key = NULL;
}
 
#else /* !TCL_THREADS */
/*
 * Stub functions for non-threaded builds
 */

Changes to jni/tcl/generic/tclUtil.c.

4408
4409
4410
4411
4412
4413
4414
4415
4416
4417
4418
4419
4420
4421
4422
4423
    int epoch = pgvPtr->epoch;

    if (pgvPtr->encoding) {
	Tcl_Encoding current = Tcl_GetEncoding(NULL, NULL);

	if (pgvPtr->encoding != current) {
	    /*
	     * The system encoding has changed since the master string value
	     * was saved. Convert the master value to be based on the new
	     * system encoding.
	     */

	    Tcl_DString native, newValue;

	    Tcl_MutexLock(&pgvPtr->mutex);
	    epoch = ++pgvPtr->epoch;







|
|







4408
4409
4410
4411
4412
4413
4414
4415
4416
4417
4418
4419
4420
4421
4422
4423
    int epoch = pgvPtr->epoch;

    if (pgvPtr->encoding) {
	Tcl_Encoding current = Tcl_GetEncoding(NULL, NULL);

	if (pgvPtr->encoding != current) {
	    /*
	     * The system encoding has changed since the global string value
	     * was saved. Convert the global value to be based on the new
	     * system encoding.
	     */

	    Tcl_DString native, newValue;

	    Tcl_MutexLock(&pgvPtr->mutex);
	    epoch = ++pgvPtr->epoch;

Changes to jni/tcl/library/tcltest/tcltest.tcl.

807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
....
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
    # errors go to stderr by default
    Option -errfile stderr {
	Send errors from test runs to the specified file.
    } AcceptOutFile errorFile
    trace add variable Option(-errfile) write \
	    [namespace code {errorChannel $Option(-errfile) ;#}]

    proc loadIntoSlaveInterpreter {slave args} {
	variable Version
	interp eval $slave [package ifneeded tcltest $Version]
	interp eval $slave "tcltest::configure {*}{$args}"
	interp alias $slave ::tcltest::ReportToMaster \
	    {} ::tcltest::ReportedFromSlave
    }
    proc ReportedFromSlave {total passed skipped failed because newfiles} {
	variable numTests
	variable skippedBecause
	variable createdNewFiles
	incr numTests(Total)   $total
	incr numTests(Passed)  $passed
	incr numTests(Skipped) $skipped
	incr numTests(Failed)  $failed
................................................................................
    variable originalTclPlatform
    variable coreModTime

    FillFilesExisted
    set testFileName [file tail [info script]]

    # Hook to handle reporting to a parent interpreter
    if {[llength [info commands [namespace current]::ReportToMaster]]} {
	ReportToMaster $numTests(Total) $numTests(Passed) $numTests(Skipped) \
	    $numTests(Failed) [array get skippedBecause] \
	    [array get createdNewFiles]
	set testSingleFile false
    }

    # Call the cleanup hook
    cleanupTestsHook







|

|
|
|
|

|







 







|
|







807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
....
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
    # errors go to stderr by default
    Option -errfile stderr {
	Send errors from test runs to the specified file.
    } AcceptOutFile errorFile
    trace add variable Option(-errfile) write \
	    [namespace code {errorChannel $Option(-errfile) ;#}]

    proc loadIntoChildInterpreter {child args} {
	variable Version
	interp eval $child [package ifneeded tcltest $Version]
	interp eval $child "tcltest::configure {*}{$args}"
	interp alias $child ::tcltest::ReportToParent \
	    {} ::tcltest::ReportedFromChild
    }
    proc ReportedFromChild {total passed skipped failed because newfiles} {
	variable numTests
	variable skippedBecause
	variable createdNewFiles
	incr numTests(Total)   $total
	incr numTests(Passed)  $passed
	incr numTests(Skipped) $skipped
	incr numTests(Failed)  $failed
................................................................................
    variable originalTclPlatform
    variable coreModTime

    FillFilesExisted
    set testFileName [file tail [info script]]

    # Hook to handle reporting to a parent interpreter
    if {[llength [info commands [namespace current]::ReportToParent]]} {
	ReportToParent $numTests(Total) $numTests(Passed) $numTests(Skipped) \
	    $numTests(Failed) [array get skippedBecause] \
	    [array get createdNewFiles]
	set testSingleFile false
    }

    # Call the cleanup hook
    cleanupTestsHook

Changes to jni/tcl/tests/chanio.test.

6367
6368
6369
6370
6371
6372
6373
6374
6375
6376
6377
6378
6379
6380
6381
....
6385
6386
6387
6388
6389
6390
6391
6392
6393
6394
6395
6396
6397
6398
6399
....
6404
6405
6406
6407
6408
6409
6410
6411
6412
6413
6414
6415
6416
6417
6418
....
6430
6431
6432
6433
6434
6435
6436
6437
6438
6439
6440
6441
6442
6443
6444
....
6453
6454
6455
6456
6457
6458
6459
6460
6461
6462
6463
6464
6465
6466
6467
....
6488
6489
6490
6491
6492
6493
6494
6495
6496
6497
6498
6499
6500
6501
6502
    lappend l [chan eof $f]
} -cleanup {
    chan close $f
} -result [list 7 a\rb\rc 7 {} 7 1]

test chan-io-50.1 {testing handler deletion} -setup {
    file delete $path(test1)
} -constraints {testchannelevent} -body {
    set f [open $path(test1) w]
    chan close $f
    set f [open $path(test1) r]
    testchannelevent $f add readable [namespace code {
	variable z called
	testchannelevent $f delete 0
    }]
................................................................................
} -cleanup {
    chan close $f
} -result called
test chan-io-50.2 {testing handler deletion with multiple handlers} -setup {
    file delete $path(test1)
    chan close [open $path(test1) w]
    set z ""
} -constraints {testchannelevent} -body {
    set f [open $path(test1) r]
    testchannelevent $f add readable [namespace code [list delhandler $f 1]]
    testchannelevent $f add readable [namespace code [list delhandler $f 0]]
    proc delhandler {f i} {
	variable z
	lappend z "called delhandler $f $i"
	testchannelevent $f delete 0
................................................................................
} -cleanup {
    chan close $f
} -result 1
test chan-io-50.3 {testing handler deletion with multiple handlers} -setup {
    file delete $path(test1)
    chan close [open $path(test1) w]
    set z ""
} -constraints {testchannelevent} -body {
    set f [open $path(test1) r]
    testchannelevent $f add readable [namespace code [list notcalled $f 1]]
    testchannelevent $f add readable [namespace code [list delhandler $f 0]]
    proc notcalled {f i} {
	variable z
	lappend z "notcalled was called!! $f $i"
    }
................................................................................
} -cleanup {
    chan close $f
} -result 1
test chan-io-50.4 {testing handler deletion vs reentrant calls} -setup {
    file delete $path(test1)
    set f [open $path(test1) w]
    chan close $f
} -constraints {testchannelevent} -body {
    set f [open $path(test1) r]
    testchannelevent $f add readable [namespace code {
	if {$u eq "recursive"} {
	    testchannelevent $f delete 0
	    lappend z "delrecursive deleting recursive"
	} else {
	    lappend z "delrecursive calling recursive"
................................................................................
} -cleanup {
    chan close $f
} -result {{delrecursive calling recursive} {delrecursive deleting recursive}}
test chan-io-50.5 {testing handler deletion vs reentrant calls} -setup {
    file delete $path(test1)
    set f [open $path(test1) w]
    chan close $f
} -constraints {testchannelevent} -body {
    set f [open $path(test1) r]
    testchannelevent $f add readable [namespace code [list notcalled $f]]
    testchannelevent $f add readable [namespace code [list del $f]]
    proc notcalled {f} {
	variable z
	lappend z "notcalled was called!! $f"
    }
................................................................................
    chan close $f
} -result [list {del calling recursive} {del deleted notcalled} \
	       {del deleted myself} {del after update}]
test chan-io-50.6 {testing handler deletion vs reentrant calls} -setup {
    file delete $path(test1)
    set f [open $path(test1) w]
    chan close $f
} -constraints {testchannelevent} -body {
    set f [open $path(test1) r]
    testchannelevent $f add readable [namespace code [list second $f]]
    testchannelevent $f add readable [namespace code [list first $f]]
    proc first {f} {
	variable u
	variable z
	if {$u eq "toplevel"} {







|







 







|







 







|







 







|







 







|







 







|







6367
6368
6369
6370
6371
6372
6373
6374
6375
6376
6377
6378
6379
6380
6381
....
6385
6386
6387
6388
6389
6390
6391
6392
6393
6394
6395
6396
6397
6398
6399
....
6404
6405
6406
6407
6408
6409
6410
6411
6412
6413
6414
6415
6416
6417
6418
....
6430
6431
6432
6433
6434
6435
6436
6437
6438
6439
6440
6441
6442
6443
6444
....
6453
6454
6455
6456
6457
6458
6459
6460
6461
6462
6463
6464
6465
6466
6467
....
6488
6489
6490
6491
6492
6493
6494
6495
6496
6497
6498
6499
6500
6501
6502
    lappend l [chan eof $f]
} -cleanup {
    chan close $f
} -result [list 7 a\rb\rc 7 {} 7 1]

test chan-io-50.1 {testing handler deletion} -setup {
    file delete $path(test1)
} -constraints {testchannelevent nonPortable} -body {
    set f [open $path(test1) w]
    chan close $f
    set f [open $path(test1) r]
    testchannelevent $f add readable [namespace code {
	variable z called
	testchannelevent $f delete 0
    }]
................................................................................
} -cleanup {
    chan close $f
} -result called
test chan-io-50.2 {testing handler deletion with multiple handlers} -setup {
    file delete $path(test1)
    chan close [open $path(test1) w]
    set z ""
} -constraints {testchannelevent nonPortable} -body {
    set f [open $path(test1) r]
    testchannelevent $f add readable [namespace code [list delhandler $f 1]]
    testchannelevent $f add readable [namespace code [list delhandler $f 0]]
    proc delhandler {f i} {
	variable z
	lappend z "called delhandler $f $i"
	testchannelevent $f delete 0
................................................................................
} -cleanup {
    chan close $f
} -result 1
test chan-io-50.3 {testing handler deletion with multiple handlers} -setup {
    file delete $path(test1)
    chan close [open $path(test1) w]
    set z ""
} -constraints {testchannelevent nonPortable} -body {
    set f [open $path(test1) r]
    testchannelevent $f add readable [namespace code [list notcalled $f 1]]
    testchannelevent $f add readable [namespace code [list delhandler $f 0]]
    proc notcalled {f i} {
	variable z
	lappend z "notcalled was called!! $f $i"
    }
................................................................................
} -cleanup {
    chan close $f
} -result 1
test chan-io-50.4 {testing handler deletion vs reentrant calls} -setup {
    file delete $path(test1)
    set f [open $path(test1) w]
    chan close $f
} -constraints {testchannelevent nonPortable} -body {
    set f [open $path(test1) r]
    testchannelevent $f add readable [namespace code {
	if {$u eq "recursive"} {
	    testchannelevent $f delete 0
	    lappend z "delrecursive deleting recursive"
	} else {
	    lappend z "delrecursive calling recursive"
................................................................................
} -cleanup {
    chan close $f
} -result {{delrecursive calling recursive} {delrecursive deleting recursive}}
test chan-io-50.5 {testing handler deletion vs reentrant calls} -setup {
    file delete $path(test1)
    set f [open $path(test1) w]
    chan close $f
} -constraints {testchannelevent nonPortable} -body {
    set f [open $path(test1) r]
    testchannelevent $f add readable [namespace code [list notcalled $f]]
    testchannelevent $f add readable [namespace code [list del $f]]
    proc notcalled {f} {
	variable z
	lappend z "notcalled was called!! $f"
    }
................................................................................
    chan close $f
} -result [list {del calling recursive} {del deleted notcalled} \
	       {del deleted myself} {del after update}]
test chan-io-50.6 {testing handler deletion vs reentrant calls} -setup {
    file delete $path(test1)
    set f [open $path(test1) w]
    chan close $f
} -constraints {testchannelevent nonPortable} -body {
    set f [open $path(test1) r]
    testchannelevent $f add readable [namespace code [list second $f]]
    testchannelevent $f add readable [namespace code [list first $f]]
    proc first {f} {
	variable u
	variable z
	if {$u eq "toplevel"} {

Changes to jni/tcl/tests/event.test.

23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
testConstraint testexithandler [llength [info commands testexithandler]]
testConstraint testfilewait [llength [info commands testfilewait]]
testConstraint exec [llength [info commands exec]]
 
test event-1.1 {Tcl_CreateFileHandler, reading} -setup {
    testfilehandler close
    set result ""
} -constraints {testfilehandler} -body {
    testfilehandler create 0 readable off
    testfilehandler clear 0
    testfilehandler oneevent
    lappend result [testfilehandler counts 0]
    testfilehandler fillpartial 0
    testfilehandler oneevent
    lappend result [testfilehandler counts 0]







|







23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
testConstraint testexithandler [llength [info commands testexithandler]]
testConstraint testfilewait [llength [info commands testfilewait]]
testConstraint exec [llength [info commands exec]]
 
test event-1.1 {Tcl_CreateFileHandler, reading} -setup {
    testfilehandler close
    set result ""
} -constraints {testfilehandler nonPortable} -body {
    testfilehandler create 0 readable off
    testfilehandler clear 0
    testfilehandler oneevent
    lappend result [testfilehandler counts 0]
    testfilehandler fillpartial 0
    testfilehandler oneevent
    lappend result [testfilehandler counts 0]

Changes to jni/tcl/tests/http11.test.

6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.

package require tcltest 2
namespace import -force ::tcltest::*

package require http 2.8

# start the server
variable httpd_output
proc create_httpd {} {
    proc httpd_read {chan} {
        variable httpd_output
        if {[gets $chan line] != -1} {







|







6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.

package require tcltest 2
namespace import -force ::tcltest::*

package require http 2.9

# start the server
variable httpd_output
proc create_httpd {} {
    proc httpd_read {chan} {
        variable httpd_output
        if {[gets $chan line] != -1} {

Changes to jni/tcl/tests/httpPipeline.test.

7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.

package require tcltest 2
namespace import -force ::tcltest::*

package require http 2.8

set sourcedir [file normalize [file dirname [info script]]]
source [file join $sourcedir httpTest.tcl]
source [file join $sourcedir httpTestScript.tcl]

# ------------------------------------------------------------------------------
# (1) Define the test scripts that will be used to generate logs for analysis -







|







7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.

package require tcltest 2
namespace import -force ::tcltest::*

package require http 2.9

set sourcedir [file normalize [file dirname [info script]]]
source [file join $sourcedir httpTest.tcl]
source [file join $sourcedir httpTestScript.tcl]

# ------------------------------------------------------------------------------
# (1) Define the test scripts that will be used to generate logs for analysis -

Changes to jni/tcl/tests/init.test.

15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
..
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
    namespace import -force ::tcltest::*
}

# Clear out any namespaces called test_ns_*
catch {namespace delete {*}[namespace children :: test_ns_*]}
 
test init-0.1 {no error on initialization phase (init.tcl)} -setup {
    interp create slave
} -body {
    slave eval {
	list [set v [info exists ::errorInfo]] \
		[if {$v} {set ::errorInfo}] \
	     [set v [info exists ::errorCode]] \
		[if {$v} {set ::errorCode}]
    }
} -cleanup {
    interp delete slave
} -result {0 {} 0 {}}

# Six cases - white box testing

test init-1.1 {auto_qualify - absolute cmd - namespace} {
    auto_qualify ::foo::bar ::blue
} ::foo::bar
................................................................................
test init-1.7 {auto_qualify - multiples colons 1} {
    auto_qualify :::foo::::bar ::blue
} ::foo::bar
test init-1.8 {auto_qualify - multiple colons 2} {
    auto_qualify :::foo ::bar
} foo
 
# We use a sub-interp and auto_reset and double the tests because there is 2
# places where auto_loading occur (before loading the indexes files and after)

set testInterp [interp create]
tcltest::loadIntoSlaveInterpreter $testInterp {*}$argv
interp eval $testInterp {
    namespace import -force ::tcltest::*
    customMatch pairwise {apply {{mode pair} {
	if {[llength $pair] != 2} {error "need a pair of values to check"}
	string $mode [lindex $pair 0] [lindex $pair 1]
    }}}








|

|






|







 







|



|







15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
..
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
    namespace import -force ::tcltest::*
}

# Clear out any namespaces called test_ns_*
catch {namespace delete {*}[namespace children :: test_ns_*]}
 
test init-0.1 {no error on initialization phase (init.tcl)} -setup {
    interp create child
} -body {
    child eval {
	list [set v [info exists ::errorInfo]] \
		[if {$v} {set ::errorInfo}] \
	     [set v [info exists ::errorCode]] \
		[if {$v} {set ::errorCode}]
    }
} -cleanup {
    interp delete child
} -result {0 {} 0 {}}

# Six cases - white box testing

test init-1.1 {auto_qualify - absolute cmd - namespace} {
    auto_qualify ::foo::bar ::blue
} ::foo::bar
................................................................................
test init-1.7 {auto_qualify - multiples colons 1} {
    auto_qualify :::foo::::bar ::blue
} ::foo::bar
test init-1.8 {auto_qualify - multiple colons 2} {
    auto_qualify :::foo ::bar
} foo
 
# We use a child interp and auto_reset and double the tests because there is 2
# places where auto_loading occur (before loading the indexes files and after)

set testInterp [interp create]
tcltest::loadIntoChildInterpreter $testInterp {*}$argv
interp eval $testInterp {
    namespace import -force ::tcltest::*
    customMatch pairwise {apply {{mode pair} {
	if {[llength $pair] != 2} {error "need a pair of values to check"}
	string $mode [lindex $pair 0] [lindex $pair 1]
    }}}

Changes to jni/tcl/tests/io.test.

6714
6715
6716
6717
6718
6719
6720
6721
6722
6723
6724
6725
6726
6727
6728
....
6730
6731
6732
6733
6734
6735
6736
6737
6738
6739
6740
6741
6742
6743
6744
....
6748
6749
6750
6751
6752
6753
6754
6755
6756
6757
6758
6759
6760
6761
6762
....
6774
6775
6776
6777
6778
6779
6780
6781
6782
6783
6784
6785
6786
6787
6788
....
6796
6797
6798
6799
6800
6801
6802
6803
6804
6805
6806
6807
6808
6809
6810
6811
6812
6813
....
6829
6830
6831
6832
6833
6834
6835
6836
6837
6838
6839
6840
6841
6842
6843
6844
6845
6846
6847
....
6871
6872
6873
6874
6875
6876
6877
6878
6879
6880
6881
6882
6883
6884
6885
6886
6887
6888
6889
    lappend l [gets $f]
    lappend l [tell $f]
    lappend l [eof $f]
    close $f
    set l
} [list 7 a\rb\rc 7 {} 7 1]

test io-50.1 {testing handler deletion} {testchannelevent} {
    file delete $path(test1)
    set f [open $path(test1) w]
    close $f
    set f [open $path(test1) r]
    testchannelevent $f add readable [namespace code [list delhandler $f]]
    proc delhandler {f} {
	variable z
................................................................................
	testchannelevent $f delete 0
    }
    set z not_called
    update
    close $f
    set z
} called
test io-50.2 {testing handler deletion with multiple handlers} {testchannelevent} {
    file delete $path(test1)
    set f [open $path(test1) w]
    close $f
    set f [open $path(test1) r]
    testchannelevent $f add readable [namespace code [list delhandler $f 1]]
    testchannelevent $f add readable [namespace code [list delhandler $f 0]]
    proc delhandler {f i} {
................................................................................
    }
    set z ""
    update
    close $f
    string compare [string tolower $z] \
	[list [list called delhandler $f 0] [list called delhandler $f 1]]
} 0
test io-50.3 {testing handler deletion with multiple handlers} {testchannelevent} {
    file delete $path(test1)
    set f [open $path(test1) w]
    close $f
    set f [open $path(test1) r]
    testchannelevent $f add readable [namespace code [list notcalled $f 1]]
    testchannelevent $f add readable [namespace code [list delhandler $f 0]]
    set z ""
................................................................................
    set z ""
    update
    close $f
    string compare [string tolower $z] \
	[list [list delhandler $f 0 called] \
	      [list delhandler $f 0 deleted myself]]
} 0
test io-50.4 {testing handler deletion vs reentrant calls} {testchannelevent} {
    file delete $path(test1)
    set f [open $path(test1) w]
    close $f
    set f [open $path(test1) r]
    testchannelevent $f add readable [namespace code [list delrecursive $f]]
    proc delrecursive {f} {
	variable z
................................................................................
	    update
	}
    }
    variable u toplevel
    variable z ""
    update
    close $f
    string compare [string tolower $z] \
	{{delrecursive calling recursive} {delrecursive deleting recursive}}
} 0
test io-50.5 {testing handler deletion vs reentrant calls} {testchannelevent} {
    file delete $path(test1)
    set f [open $path(test1) w]
    close $f
    set f [open $path(test1) r]
    testchannelevent $f add readable [namespace code [list notcalled $f]]
    testchannelevent $f add readable [namespace code [list del $f]]
    proc notcalled {f} {
................................................................................
	    lappend z "del after update"
	}
    }
    set z ""
    set u toplevel
    update
    close $f
    string compare [string tolower $z] \
	[list {del calling recursive} {del deleted notcalled} \
	      {del deleted myself} {del after update}]
} 0
test io-50.6 {testing handler deletion vs reentrant calls} {testchannelevent} {
    file delete $path(test1)
    set f [open $path(test1) w]
    close $f
    set f [open $path(test1) r]
    testchannelevent $f add readable [namespace code [list second $f]]
    testchannelevent $f add readable [namespace code [list first $f]]
    proc first {f} {
................................................................................
	    testchannelevent $f removeall
	}
    }
    set z ""
    set u toplevel
    update
    close $f
    string compare [string tolower $z] \
	[list {first called} {first called not toplevel} \
	      {second called, first time} {second called, second time} \
	      {first after update}]
} 0

test io-51.1 {Test old socket deletion on Macintosh} {socket} {
    set x 0
    set result ""
    proc accept {s a p} {
	variable x
	variable wait







|







 







|







 







|







 







|







 







|
|
<
|







 







|
|
|
<
|







 







|
|
|
|
<







6714
6715
6716
6717
6718
6719
6720
6721
6722
6723
6724
6725
6726
6727
6728
....
6730
6731
6732
6733
6734
6735
6736
6737
6738
6739
6740
6741
6742
6743
6744
....
6748
6749
6750
6751
6752
6753
6754
6755
6756
6757
6758
6759
6760
6761
6762
....
6774
6775
6776
6777
6778
6779
6780
6781
6782
6783
6784
6785
6786
6787
6788
....
6796
6797
6798
6799
6800
6801
6802
6803
6804

6805
6806
6807
6808
6809
6810
6811
6812
....
6828
6829
6830
6831
6832
6833
6834
6835
6836
6837

6838
6839
6840
6841
6842
6843
6844
6845
....
6869
6870
6871
6872
6873
6874
6875
6876
6877
6878
6879

6880
6881
6882
6883
6884
6885
6886
    lappend l [gets $f]
    lappend l [tell $f]
    lappend l [eof $f]
    close $f
    set l
} [list 7 a\rb\rc 7 {} 7 1]

test io-50.1 {testing handler deletion} {testchannelevent nonPortable} {
    file delete $path(test1)
    set f [open $path(test1) w]
    close $f
    set f [open $path(test1) r]
    testchannelevent $f add readable [namespace code [list delhandler $f]]
    proc delhandler {f} {
	variable z
................................................................................
	testchannelevent $f delete 0
    }
    set z not_called
    update
    close $f
    set z
} called
test io-50.2 {testing handler deletion with multiple handlers} {testchannelevent nonPortable} {
    file delete $path(test1)
    set f [open $path(test1) w]
    close $f
    set f [open $path(test1) r]
    testchannelevent $f add readable [namespace code [list delhandler $f 1]]
    testchannelevent $f add readable [namespace code [list delhandler $f 0]]
    proc delhandler {f i} {
................................................................................
    }
    set z ""
    update
    close $f
    string compare [string tolower $z] \
	[list [list called delhandler $f 0] [list called delhandler $f 1]]
} 0
test io-50.3 {testing handler deletion with multiple handlers} {testchannelevent nonPortable} {
    file delete $path(test1)
    set f [open $path(test1) w]
    close $f
    set f [open $path(test1) r]
    testchannelevent $f add readable [namespace code [list notcalled $f 1]]
    testchannelevent $f add readable [namespace code [list delhandler $f 0]]
    set z ""
................................................................................
    set z ""
    update
    close $f
    string compare [string tolower $z] \
	[list [list delhandler $f 0 called] \
	      [list delhandler $f 0 deleted myself]]
} 0
test io-50.4 {testing handler deletion vs reentrant calls} {testchannelevent nonPortable} {
    file delete $path(test1)
    set f [open $path(test1) w]
    close $f
    set f [open $path(test1) r]
    testchannelevent $f add readable [namespace code [list delrecursive $f]]
    proc delrecursive {f} {
	variable z
................................................................................
	    update
	}
    }
    variable u toplevel
    variable z ""
    update
    close $f
    set z
} {{delrecursive calling recursive} {delrecursive deleting recursive}}

test io-50.5 {testing handler deletion vs reentrant calls} {testchannelevent nonPortable} {
    file delete $path(test1)
    set f [open $path(test1) w]
    close $f
    set f [open $path(test1) r]
    testchannelevent $f add readable [namespace code [list notcalled $f]]
    testchannelevent $f add readable [namespace code [list del $f]]
    proc notcalled {f} {
................................................................................
	    lappend z "del after update"
	}
    }
    set z ""
    set u toplevel
    update
    close $f
    set z	
} [list {del calling recursive} {del deleted notcalled} \
	{del deleted myself} {del after update}]

test io-50.6 {testing handler deletion vs reentrant calls} {testchannelevent nonPortable} {
    file delete $path(test1)
    set f [open $path(test1) w]
    close $f
    set f [open $path(test1) r]
    testchannelevent $f add readable [namespace code [list second $f]]
    testchannelevent $f add readable [namespace code [list first $f]]
    proc first {f} {
................................................................................
	    testchannelevent $f removeall
	}
    }
    set z ""
    set u toplevel
    update
    close $f
    set z
} [list {first called} {first called not toplevel} \
	{second called, first time} {second called, second time} \
	{first after update}]


test io-51.1 {Test old socket deletion on Macintosh} {socket} {
    set x 0
    set result ""
    proc accept {s a p} {
	variable x
	variable wait

Changes to jni/tcl/tests/package.test.

13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
...
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
# this file, and for a DISCLAIMER OF ALL WARRANTIES.

if {"::tcltest" ni [namespace children]} {
    package require tcltest 2.3.3
    namespace import -force ::tcltest::*
}

# Do all this in a slave interp to avoid garbaging the package list
set i [interp create]
tcltest::loadIntoSlaveInterpreter $i {*}$argv
interp eval $i {
namespace import -force ::tcltest::*
package forget {*}[package names]
set oldPkgUnknown [package unknown]
package unknown {}
set oldPath $auto_path
set auto_path ""
................................................................................
test package-4.56 {Tcl_PackageCmd procedure, "vsatisfies" option} -body {
    package vsatisfies 2.1 x.y-3.2
} -returnCodes error -result {expected version number but got "x.y"}

# No tests for FindPackage; can't think up anything detectable errors.

test package-5.1 {TclFreePackageInfo procedure} {
    interp create slave
    slave eval {
	package ifneeded t 2.3 x
	package ifneeded t 2.4 y
	package ifneeded x 3.1 z
	package provide q 4.3
	package unknown "will this get freed?"
    }
    interp delete slave
} {}
test package-5.2 {TclFreePackageInfo procedure} -body {
    interp create foo
    foo eval {
	package ifneeded t 2.3 x
	package ifneeded t 2.4 y
	package ifneeded x 3.1 z







|

|







 







|
|






|







13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
...
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
# this file, and for a DISCLAIMER OF ALL WARRANTIES.

if {"::tcltest" ni [namespace children]} {
    package require tcltest 2.3.3
    namespace import -force ::tcltest::*
}

# Do all this in a child interp to avoid garbaging the package list
set i [interp create]
tcltest::loadIntoChildInterpreter $i {*}$argv
interp eval $i {
namespace import -force ::tcltest::*
package forget {*}[package names]
set oldPkgUnknown [package unknown]
package unknown {}
set oldPath $auto_path
set auto_path ""
................................................................................
test package-4.56 {Tcl_PackageCmd procedure, "vsatisfies" option} -body {
    package vsatisfies 2.1 x.y-3.2
} -returnCodes error -result {expected version number but got "x.y"}

# No tests for FindPackage; can't think up anything detectable errors.

test package-5.1 {TclFreePackageInfo procedure} {
    interp create child
    child eval {
	package ifneeded t 2.3 x
	package ifneeded t 2.4 y
	package ifneeded x 3.1 z
	package provide q 4.3
	package unknown "will this get freed?"
    }
    interp delete child
} {}
test package-5.2 {TclFreePackageInfo procedure} -body {
    interp create foo
    foo eval {
	package ifneeded t 2.3 x
	package ifneeded t 2.4 y
	package ifneeded x 3.1 z

Changes to jni/tcl/tests/socket.test.

900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928

test socket_$af-5.1 {byte order problems, socket numbers, htons} -body {
    if {![catch {socket -server dodo 0x1} msg]} {
	close $msg
        return {htons problem, should be disallowed, are you running as SU?}
    }
    return {couldn't open socket: not owner}
} -constraints [list socket supported_$af unix notRoot] -result {couldn't open socket: not owner}
test socket_$af-5.2 {byte order problems, socket numbers, htons} -body {
    if {![catch {socket -server dodo 0x10000} msg]} {
	close $msg
	return {port resolution problem, should be disallowed}
    }
    return {couldn't open socket: port number too high}
} -constraints [list socket supported_$af] -result {couldn't open socket: port number too high}
test socket_$af-5.3 {byte order problems, socket numbers, htons} -body {
    if {![catch {socket -server dodo 21} msg]} {
	close $msg
	return {htons problem, should be disallowed, are you running as SU?}
    }
    return {couldn't open socket: not owner}
} -constraints [list socket supported_$af unix notRoot] -result {couldn't open socket: not owner}

test socket_$af-6.1 {accept callback error} -constraints [list socket supported_$af stdio] -setup {
    proc myHandler {msg options} {
	variable x $msg
    }
    set handler [interp bgerror {}]
    interp bgerror {} [namespace which myHandler]







|













|







900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928

test socket_$af-5.1 {byte order problems, socket numbers, htons} -body {
    if {![catch {socket -server dodo 0x1} msg]} {
	close $msg
        return {htons problem, should be disallowed, are you running as SU?}
    }
    return {couldn't open socket: not owner}
} -constraints [list socket supported_$af unix notRoot notOSX] -result {couldn't open socket: not owner}
test socket_$af-5.2 {byte order problems, socket numbers, htons} -body {
    if {![catch {socket -server dodo 0x10000} msg]} {
	close $msg
	return {port resolution problem, should be disallowed}
    }
    return {couldn't open socket: port number too high}
} -constraints [list socket supported_$af] -result {couldn't open socket: port number too high}
test socket_$af-5.3 {byte order problems, socket numbers, htons} -body {
    if {![catch {socket -server dodo 21} msg]} {
	close $msg
	return {htons problem, should be disallowed, are you running as SU?}
    }
    return {couldn't open socket: not owner}
} -constraints [list socket supported_$af unix notRoot notOSX] -result {couldn't open socket: not owner}

test socket_$af-6.1 {accept callback error} -constraints [list socket supported_$af stdio] -setup {
    proc myHandler {msg options} {
	variable x $msg
    }
    set handler [interp bgerror {}]
    interp bgerror {} [namespace which myHandler]

Changes to jni/tcl/unix/tclUnixThrd.c.

18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
...
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
...
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
...
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
...
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
...
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
...
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
...
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
...
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
typedef struct ThreadSpecificData {
    char nabuf[16];
} ThreadSpecificData;

static Tcl_ThreadDataKey dataKey;

/*
 * masterLock is used to serialize creation of mutexes, condition variables,
 * and thread local storage. This is the only place that can count on the
 * ability to statically initialize the mutex.
 */

static pthread_mutex_t masterLock = PTHREAD_MUTEX_INITIALIZER;

/*
 * initLock is used to serialize initialization and finalization of Tcl. It
 * cannot use any dyamically allocated storage.
 */

static pthread_mutex_t initLock = PTHREAD_MUTEX_INITIALIZER;

/*
 * allocLock is used by Tcl's version of malloc for synchronization. For
 * obvious reasons, cannot use any dyamically allocated storage.
 */

static pthread_mutex_t allocLock = PTHREAD_MUTEX_INITIALIZER;
static pthread_mutex_t *allocLockPtr = &allocLock;

/*
 * These are for the critical sections inside this file.
 */

#define MASTER_LOCK	pthread_mutex_lock(&masterLock)
#define MASTER_UNLOCK	pthread_mutex_unlock(&masterLock)

#endif /* TCL_THREADS */
 
/*
 *----------------------------------------------------------------------
 *
 * TclpThreadCreate --
................................................................................
void
TclFinalizeLock(void)
{
#ifdef TCL_THREADS
    /*
     * You do not need to destroy mutexes that were created with the
     * PTHREAD_MUTEX_INITIALIZER macro. These mutexes do not need any
     * destruction: masterLock, allocLock, and initLock.
     */

    pthread_mutex_unlock(&initLock);
#endif
}
 
/*
................................................................................
    pthread_mutex_unlock(&initLock);
#endif
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclpMasterLock
 *
 *	This procedure is used to grab a lock that serializes creation and
 *	finalization of serialization objects. This interface is only needed
 *	in finalization; it is hidden during creation of the objects.
 *
 *	This lock must be different than the initLock because the initLock is
 *	held during creation of synchronization objects.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Acquire the master mutex.
 *
 *----------------------------------------------------------------------
 */

void
TclpMasterLock(void)
{
#ifdef TCL_THREADS
    pthread_mutex_lock(&masterLock);
#endif
}

 
/*
 *----------------------------------------------------------------------
 *
 * TclpMasterUnlock
 *
 *	This procedure is used to release a lock that serializes creation and
 *	finalization of synchronization objects.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Release the master mutex.
 *
 *----------------------------------------------------------------------
 */

void
TclpMasterUnlock(void)
{
#ifdef TCL_THREADS
    pthread_mutex_unlock(&masterLock);
#endif
}
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetAllocMutex
 *
 *	This procedure returns a pointer to a statically initialized mutex for
 *	use by the memory allocator. The alloctor must use this lock, because
 *	all other locks are allocated...
 *
 * Results:
 *	A pointer to a mutex that is suitable for passing to Tcl_MutexLock and
 *	Tcl_MutexUnlock.
 *
 * Side effects:
................................................................................
void
Tcl_MutexLock(
    Tcl_Mutex *mutexPtr)	/* Really (pthread_mutex_t **) */
{
    pthread_mutex_t *pmutexPtr;

    if (*mutexPtr == NULL) {
	MASTER_LOCK;
	if (*mutexPtr == NULL) {
	    /*
	     * Double inside master lock check to avoid a race condition.
	     */

	    pmutexPtr = ckalloc(sizeof(pthread_mutex_t));
	    pthread_mutex_init(pmutexPtr, NULL);
	    *mutexPtr = (Tcl_Mutex)pmutexPtr;
	    TclRememberMutex(mutexPtr);
	}
	MASTER_UNLOCK;
    }
    pmutexPtr = *((pthread_mutex_t **)mutexPtr);
    pthread_mutex_lock(pmutexPtr);
}
 
/*
 *----------------------------------------------------------------------
................................................................................
 *----------------------------------------------------------------------
 *
 * TclpFinalizeMutex --
 *
 *	This procedure is invoked to clean up one mutex. This is only safe to
 *	call at the end of time.
 *
 *	This assumes the Master Lock is held.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The mutex list is deallocated.
 *
................................................................................
    pthread_mutex_t *pmutexPtr;
    struct timespec ptime;
#if defined(HAVE_CLOCK_GETTIME) && defined(HAVE_PTHREAD_CONDATTR_SETCLOCK)
    int *monoFlagPtr;
#endif

    if (*condPtr == NULL) {
	MASTER_LOCK;

	/*
	 * Double check inside mutex to avoid race, then initialize condition
	 * variable if necessary.
	 */

	if (*condPtr == NULL) {
................................................................................
#else
	    pcondPtr = ckalloc(sizeof(pthread_cond_t));
	    pthread_cond_init(pcondPtr, NULL);
#endif
	    *condPtr = (Tcl_Condition) pcondPtr;
	    TclRememberCondition(condPtr);
	}
	MASTER_UNLOCK;
    }
    pmutexPtr = *((pthread_mutex_t **)mutexPtr);
    pcondPtr = *((pthread_cond_t **)condPtr);
    if (timePtr == NULL) {
	pthread_cond_wait(pcondPtr, pmutexPtr);
    } else {
#if defined(HAVE_CLOCK_GETTIME) && defined(HAVE_PTHREAD_CONDATTR_SETCLOCK)
................................................................................
 *----------------------------------------------------------------------
 *
 * TclpFinalizeCondition --
 *
 *	This procedure is invoked to clean up a condition variable. This is
 *	only safe to call at the end of time.
 *
 *	This assumes the Master Lock is held.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The condition variable is deallocated.
 *
................................................................................
	Tcl_Panic("unable to delete key!");
    }

    TclpSysFree(keyPtr);
}

void
TclpThreadSetMasterTSD(
    void *tsdKeyPtr,
    void *ptr)
{
    pthread_key_t *ptkeyPtr = tsdKeyPtr;

    if (pthread_setspecific(*ptkeyPtr, ptr)) {
	Tcl_Panic("unable to set master TSD value");
    }
}

void *
TclpThreadGetMasterTSD(
    void *tsdKeyPtr)
{
    pthread_key_t *ptkeyPtr = tsdKeyPtr;

    return pthread_getspecific(*ptkeyPtr);
}








|




|



|






|









|
|







 







|







 







|












|





|


|







|








|





|


|









|







 







|


|







|







 







|







 







|







 







|







 







|







 







|






|




|







18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
...
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
...
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
...
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
...
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
...
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
...
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
...
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
...
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
typedef struct ThreadSpecificData {
    char nabuf[16];
} ThreadSpecificData;

static Tcl_ThreadDataKey dataKey;

/*
 * globalLock is used to serialize creation of mutexes, condition variables,
 * and thread local storage. This is the only place that can count on the
 * ability to statically initialize the mutex.
 */

static pthread_mutex_t globalLock = PTHREAD_MUTEX_INITIALIZER;

/*
 * initLock is used to serialize initialization and finalization of Tcl. It
 * cannot use any dynamically allocated storage.
 */

static pthread_mutex_t initLock = PTHREAD_MUTEX_INITIALIZER;

/*
 * allocLock is used by Tcl's version of malloc for synchronization. For
 * obvious reasons, cannot use any dynamically allocated storage.
 */

static pthread_mutex_t allocLock = PTHREAD_MUTEX_INITIALIZER;
static pthread_mutex_t *allocLockPtr = &allocLock;

/*
 * These are for the critical sections inside this file.
 */

#define GLOBAL_LOCK	pthread_mutex_lock(&globalLock)
#define GLOBAL_UNLOCK	pthread_mutex_unlock(&globalLock)

#endif /* TCL_THREADS */
 
/*
 *----------------------------------------------------------------------
 *
 * TclpThreadCreate --
................................................................................
void
TclFinalizeLock(void)
{
#ifdef TCL_THREADS
    /*
     * You do not need to destroy mutexes that were created with the
     * PTHREAD_MUTEX_INITIALIZER macro. These mutexes do not need any
     * destruction: globalLock, allocLock, and initLock.
     */

    pthread_mutex_unlock(&initLock);
#endif
}
 
/*
................................................................................
    pthread_mutex_unlock(&initLock);
#endif
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclpGlobalLock
 *
 *	This procedure is used to grab a lock that serializes creation and
 *	finalization of serialization objects. This interface is only needed
 *	in finalization; it is hidden during creation of the objects.
 *
 *	This lock must be different than the initLock because the initLock is
 *	held during creation of synchronization objects.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Acquire the global mutex.
 *
 *----------------------------------------------------------------------
 */

void
TclpGlobalLock(void)
{
#ifdef TCL_THREADS
    pthread_mutex_lock(&globalLock);
#endif
}

 
/*
 *----------------------------------------------------------------------
 *
 * TclpGlobalUnlock
 *
 *	This procedure is used to release a lock that serializes creation and
 *	finalization of synchronization objects.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Release the global mutex.
 *
 *----------------------------------------------------------------------
 */

void
TclpGlobalUnlock(void)
{
#ifdef TCL_THREADS
    pthread_mutex_unlock(&globalLock);
#endif
}
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetAllocMutex
 *
 *	This procedure returns a pointer to a statically initialized mutex for
 *	use by the memory allocator. The allocator must use this lock, because
 *	all other locks are allocated...
 *
 * Results:
 *	A pointer to a mutex that is suitable for passing to Tcl_MutexLock and
 *	Tcl_MutexUnlock.
 *
 * Side effects:
................................................................................
void
Tcl_MutexLock(
    Tcl_Mutex *mutexPtr)	/* Really (pthread_mutex_t **) */
{
    pthread_mutex_t *pmutexPtr;

    if (*mutexPtr == NULL) {
	GLOBAL_LOCK;
	if (*mutexPtr == NULL) {
	    /*
	     * Double inside global lock check to avoid a race condition.
	     */

	    pmutexPtr = ckalloc(sizeof(pthread_mutex_t));
	    pthread_mutex_init(pmutexPtr, NULL);
	    *mutexPtr = (Tcl_Mutex)pmutexPtr;
	    TclRememberMutex(mutexPtr);
	}
	GLOBAL_UNLOCK;
    }
    pmutexPtr = *((pthread_mutex_t **)mutexPtr);
    pthread_mutex_lock(pmutexPtr);
}
 
/*
 *----------------------------------------------------------------------
................................................................................
 *----------------------------------------------------------------------
 *
 * TclpFinalizeMutex --
 *
 *	This procedure is invoked to clean up one mutex. This is only safe to
 *	call at the end of time.
 *
 *	This assumes the Global Lock is held.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The mutex list is deallocated.
 *
................................................................................
    pthread_mutex_t *pmutexPtr;
    struct timespec ptime;
#if defined(HAVE_CLOCK_GETTIME) && defined(HAVE_PTHREAD_CONDATTR_SETCLOCK)
    int *monoFlagPtr;
#endif

    if (*condPtr == NULL) {
	GLOBAL_LOCK;

	/*
	 * Double check inside mutex to avoid race, then initialize condition
	 * variable if necessary.
	 */

	if (*condPtr == NULL) {
................................................................................
#else
	    pcondPtr = ckalloc(sizeof(pthread_cond_t));
	    pthread_cond_init(pcondPtr, NULL);
#endif
	    *condPtr = (Tcl_Condition) pcondPtr;
	    TclRememberCondition(condPtr);
	}
	GLOBAL_UNLOCK;
    }
    pmutexPtr = *((pthread_mutex_t **)mutexPtr);
    pcondPtr = *((pthread_cond_t **)condPtr);
    if (timePtr == NULL) {
	pthread_cond_wait(pcondPtr, pmutexPtr);
    } else {
#if defined(HAVE_CLOCK_GETTIME) && defined(HAVE_PTHREAD_CONDATTR_SETCLOCK)
................................................................................
 *----------------------------------------------------------------------
 *
 * TclpFinalizeCondition --
 *
 *	This procedure is invoked to clean up a condition variable. This is
 *	only safe to call at the end of time.
 *
 *	This assumes the Global Lock is held.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The condition variable is deallocated.
 *
................................................................................
	Tcl_Panic("unable to delete key!");
    }

    TclpSysFree(keyPtr);
}

void
TclpThreadSetGlobalTSD(
    void *tsdKeyPtr,
    void *ptr)
{
    pthread_key_t *ptkeyPtr = tsdKeyPtr;

    if (pthread_setspecific(*ptkeyPtr, ptr)) {
	Tcl_Panic("unable to set global TSD value");
    }
}

void *
TclpThreadGetGlobalTSD(
    void *tsdKeyPtr)
{
    pthread_key_t *ptkeyPtr = tsdKeyPtr;

    return pthread_getspecific(*ptkeyPtr);
}

Changes to jni/tcl/win/tclWinThrd.c.

20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
...
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
...
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
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
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
...
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
...
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
...
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
...
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
....
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
#   define	_MCW_EM		0x0008001F	/* Error masks */
#   define	_MCW_RC		0x00000300	/* Rounding */
#   define	_MCW_PC		0x00030000	/* Precision */
_CRTIMP unsigned int __cdecl _controlfp (unsigned int unNew, unsigned int unMask);
#endif

/*
 * This is the master lock used to serialize access to other serialization
 * data structures.
 */

static CRITICAL_SECTION masterLock;
static int init = 0;
#define MASTER_LOCK TclpMasterLock()
#define MASTER_UNLOCK TclpMasterUnlock()


/*
 * This is the master lock used to serialize initialization and finalization
 * of Tcl as a whole.
 */

static CRITICAL_SECTION initLock;

/*
 * allocLock is used by Tcl's version of malloc for synchronization. For
 * obvious reasons, cannot use any dyamically allocated storage.
 */

#ifdef TCL_THREADS

static struct Tcl_Mutex_ {
    CRITICAL_SECTION crit;
} allocLock;
................................................................................
	 * interpreter has been created, it is safe to create more threads
	 * that create interpreters in parallel.
	 */

	init = 1;
	InitializeCriticalSection(&joinLock);
	InitializeCriticalSection(&initLock);
	InitializeCriticalSection(&masterLock);
    }
    EnterCriticalSection(&initLock);
}
 
/*
 *----------------------------------------------------------------------
 *
................................................................................
{
    LeaveCriticalSection(&initLock);
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclpMasterLock
 *
 *	This procedure is used to grab a lock that serializes creation of
 *	mutexes, condition variables, and thread local storage keys.
 *
 *	This lock must be different than the initLock because the initLock is
 *	held during creation of synchronization objects.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Acquire the master mutex.
 *
 *----------------------------------------------------------------------
 */

void
TclpMasterLock(void)
{
    if (!init) {
	/*
	 * There is a fundamental race here that is solved by creating the
	 * first Tcl interpreter in a single threaded environment. Once the
	 * interpreter has been created, it is safe to create more threads
	 * that create interpreters in parallel.
	 */

	init = 1;
	InitializeCriticalSection(&joinLock);
	InitializeCriticalSection(&initLock);
	InitializeCriticalSection(&masterLock);
    }
    EnterCriticalSection(&masterLock);
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclpMasterUnlock
 *
 *	This procedure is used to release a lock that serializes creation and
 *	deletion of synchronization objects.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Release the master mutex.
 *
 *----------------------------------------------------------------------
 */

void
TclpMasterUnlock(void)
{
    LeaveCriticalSection(&masterLock);
}
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetAllocMutex
 *
 *	This procedure returns a pointer to a statically initialized mutex for
 *	use by the memory allocator. The alloctor must use this lock, because
 *	all other locks are allocated...
 *
 * Results:
 *	A pointer to a mutex that is suitable for passing to Tcl_MutexLock and
 *	Tcl_MutexUnlock.
 *
 * Side effects:
................................................................................
 *
 *----------------------------------------------------------------------
 */

void
TclFinalizeLock(void)
{
    MASTER_LOCK;
    DeleteCriticalSection(&joinLock);

    /*
     * Destroy the critical section that we are holding!
     */

    DeleteCriticalSection(&masterLock);
    init = 0;

#ifdef TCL_THREADS
    if (allocOnce) {
	DeleteCriticalSection(&allocLock.crit);
	allocOnce = 0;
    }
................................................................................
void
Tcl_MutexLock(
    Tcl_Mutex *mutexPtr)	/* The lock */
{
    CRITICAL_SECTION *csPtr;

    if (*mutexPtr == NULL) {
	MASTER_LOCK;

	/*
	 * Double inside master lock check to avoid a race.
	 */

	if (*mutexPtr == NULL) {
	    csPtr = ckalloc(sizeof(CRITICAL_SECTION));
	    InitializeCriticalSection(csPtr);
	    *mutexPtr = (Tcl_Mutex)csPtr;
	    TclRememberMutex(mutexPtr);
	}
	MASTER_UNLOCK;
    }
    csPtr = *((CRITICAL_SECTION **)mutexPtr);
    EnterCriticalSection(csPtr);
}
 
/*
 *----------------------------------------------------------------------
................................................................................

    /*
     * Self initialize the two parts of the condition. The per-condition and
     * per-thread parts need to be handled independently.
     */

    if (tsdPtr->flags == WIN_THREAD_UNINIT) {
	MASTER_LOCK;

	/*
	 * Create the per-thread event and queue pointers.
	 */

	if (tsdPtr->flags == WIN_THREAD_UNINIT) {
	    tsdPtr->condEvent = CreateEventW(NULL, TRUE /* manual reset */,
		    FALSE /* non signaled */, NULL);
	    tsdPtr->nextPtr = NULL;
	    tsdPtr->prevPtr = NULL;
	    tsdPtr->flags = WIN_THREAD_RUNNING;
	    doExit = 1;
	}
	MASTER_UNLOCK;

	if (doExit) {
	    /*
	     * Create a per-thread exit handler to clean up the condEvent. We
	     * must be careful to do this outside the Master Lock because
	     * Tcl_CreateThreadExitHandler uses its own ThreadSpecificData,
	     * and initializing that may drop back into the Master Lock.
	     */

	    Tcl_CreateThreadExitHandler(FinalizeConditionEvent, tsdPtr);
	}
    }

    if (*condPtr == NULL) {
	MASTER_LOCK;

	/*
	 * Initialize the per-condition queue pointers and Mutex.
	 */

	if (*condPtr == NULL) {
	    winCondPtr = ckalloc(sizeof(WinCondition));
	    InitializeCriticalSection(&winCondPtr->condLock);
	    winCondPtr->firstPtr = NULL;
	    winCondPtr->lastPtr = NULL;
	    *condPtr = (Tcl_Condition) winCondPtr;
	    TclRememberCondition(condPtr);
	}
	MASTER_UNLOCK;
    }
    csPtr = *((CRITICAL_SECTION **)mutexPtr);
    winCondPtr = *((WinCondition **)condPtr);
    if (timePtr == NULL) {
	wtime = INFINITE;
    } else {
	wtime = timePtr->sec * 1000 + timePtr->usec / 1000;
................................................................................
 *----------------------------------------------------------------------
 *
 * TclpFinalizeCondition --
 *
 *	This procedure is invoked to clean up a condition variable. This is
 *	only safe to call at the end of time.
 *
 *	This assumes the Master Lock is held.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The condition variable is deallocated.
 *
................................................................................
	Tcl_Panic("unable to delete key");
    }

    TclpSysFree(keyPtr);
}

void
TclpThreadSetMasterTSD(
    void *tsdKeyPtr,
    void *ptr)
{
    DWORD *key = tsdKeyPtr;

    if (!TlsSetValue(*key, ptr)) {
	Tcl_Panic("unable to set master TSD value");
    }
}

void *
TclpThreadGetMasterTSD(
    void *tsdKeyPtr)
{
    DWORD *key = tsdKeyPtr;

    return TlsGetValue(*key);
}








|



|

|
|



|







|







 







|







 







|











|





|












|

|





|








|





|

|








|







 







|






|







 







|


|








|







 







|













|




|

|







|













|







 







|







 







|






|




|







20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
...
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
...
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
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
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
...
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
...
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
...
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
...
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
....
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
#   define	_MCW_EM		0x0008001F	/* Error masks */
#   define	_MCW_RC		0x00000300	/* Rounding */
#   define	_MCW_PC		0x00030000	/* Precision */
_CRTIMP unsigned int __cdecl _controlfp (unsigned int unNew, unsigned int unMask);
#endif

/*
 * This is the global lock used to serialize access to other serialization
 * data structures.
 */

static CRITICAL_SECTION globalLock;
static int init = 0;
#define GLOBAL_LOCK TclpGlobalLock()
#define GLOBAL_UNLOCK TclpGlobalUnlock()


/*
 * This is the global lock used to serialize initialization and finalization
 * of Tcl as a whole.
 */

static CRITICAL_SECTION initLock;

/*
 * allocLock is used by Tcl's version of malloc for synchronization. For
 * obvious reasons, cannot use any dynamically allocated storage.
 */

#ifdef TCL_THREADS

static struct Tcl_Mutex_ {
    CRITICAL_SECTION crit;
} allocLock;
................................................................................
	 * interpreter has been created, it is safe to create more threads
	 * that create interpreters in parallel.
	 */

	init = 1;
	InitializeCriticalSection(&joinLock);
	InitializeCriticalSection(&initLock);
	InitializeCriticalSection(&globalLock);
    }
    EnterCriticalSection(&initLock);
}
 
/*
 *----------------------------------------------------------------------
 *
................................................................................
{
    LeaveCriticalSection(&initLock);
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclpGlobalLock
 *
 *	This procedure is used to grab a lock that serializes creation of
 *	mutexes, condition variables, and thread local storage keys.
 *
 *	This lock must be different than the initLock because the initLock is
 *	held during creation of synchronization objects.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Acquire the global mutex.
 *
 *----------------------------------------------------------------------
 */

void
TclpGlobalLock(void)
{
    if (!init) {
	/*
	 * There is a fundamental race here that is solved by creating the
	 * first Tcl interpreter in a single threaded environment. Once the
	 * interpreter has been created, it is safe to create more threads
	 * that create interpreters in parallel.
	 */

	init = 1;
	InitializeCriticalSection(&joinLock);
	InitializeCriticalSection(&initLock);
	InitializeCriticalSection(&globalLock);
    }
    EnterCriticalSection(&globalLock);
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclpGlobalUnlock
 *
 *	This procedure is used to release a lock that serializes creation and
 *	deletion of synchronization objects.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Release the global mutex.
 *
 *----------------------------------------------------------------------
 */

void
TclpGlobalUnlock(void)
{
    LeaveCriticalSection(&globalLock);
}
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetAllocMutex
 *
 *	This procedure returns a pointer to a statically initialized mutex for
 *	use by the memory allocator. The allocator must use this lock, because
 *	all other locks are allocated...
 *
 * Results:
 *	A pointer to a mutex that is suitable for passing to Tcl_MutexLock and
 *	Tcl_MutexUnlock.
 *
 * Side effects:
................................................................................
 *
 *----------------------------------------------------------------------
 */

void
TclFinalizeLock(void)
{
    GLOBAL_LOCK;
    DeleteCriticalSection(&joinLock);

    /*
     * Destroy the critical section that we are holding!
     */

    DeleteCriticalSection(&globalLock);
    init = 0;

#ifdef TCL_THREADS
    if (allocOnce) {
	DeleteCriticalSection(&allocLock.crit);
	allocOnce = 0;
    }
................................................................................
void
Tcl_MutexLock(
    Tcl_Mutex *mutexPtr)	/* The lock */
{
    CRITICAL_SECTION *csPtr;

    if (*mutexPtr == NULL) {
	GLOBAL_LOCK;

	/*
	 * Double inside global lock check to avoid a race.
	 */

	if (*mutexPtr == NULL) {
	    csPtr = ckalloc(sizeof(CRITICAL_SECTION));
	    InitializeCriticalSection(csPtr);
	    *mutexPtr = (Tcl_Mutex)csPtr;
	    TclRememberMutex(mutexPtr);
	}
	GLOBAL_UNLOCK;
    }
    csPtr = *((CRITICAL_SECTION **)mutexPtr);
    EnterCriticalSection(csPtr);
}
 
/*
 *----------------------------------------------------------------------
................................................................................

    /*
     * Self initialize the two parts of the condition. The per-condition and
     * per-thread parts need to be handled independently.
     */

    if (tsdPtr->flags == WIN_THREAD_UNINIT) {
	GLOBAL_LOCK;

	/*
	 * Create the per-thread event and queue pointers.
	 */

	if (tsdPtr->flags == WIN_THREAD_UNINIT) {
	    tsdPtr->condEvent = CreateEventW(NULL, TRUE /* manual reset */,
		    FALSE /* non signaled */, NULL);
	    tsdPtr->nextPtr = NULL;
	    tsdPtr->prevPtr = NULL;
	    tsdPtr->flags = WIN_THREAD_RUNNING;
	    doExit = 1;
	}
	GLOBAL_UNLOCK;

	if (doExit) {
	    /*
	     * Create a per-thread exit handler to clean up the condEvent. We
	     * must be careful to do this outside the Global Lock because
	     * Tcl_CreateThreadExitHandler uses its own ThreadSpecificData,
	     * and initializing that may drop back into the Global Lock.
	     */

	    Tcl_CreateThreadExitHandler(FinalizeConditionEvent, tsdPtr);
	}
    }

    if (*condPtr == NULL) {
	GLOBAL_LOCK;

	/*
	 * Initialize the per-condition queue pointers and Mutex.
	 */

	if (*condPtr == NULL) {
	    winCondPtr = ckalloc(sizeof(WinCondition));
	    InitializeCriticalSection(&winCondPtr->condLock);
	    winCondPtr->firstPtr = NULL;
	    winCondPtr->lastPtr = NULL;
	    *condPtr = (Tcl_Condition) winCondPtr;
	    TclRememberCondition(condPtr);
	}
	GLOBAL_UNLOCK;
    }
    csPtr = *((CRITICAL_SECTION **)mutexPtr);
    winCondPtr = *((WinCondition **)condPtr);
    if (timePtr == NULL) {
	wtime = INFINITE;
    } else {
	wtime = timePtr->sec * 1000 + timePtr->usec / 1000;
................................................................................
 *----------------------------------------------------------------------
 *
 * TclpFinalizeCondition --
 *
 *	This procedure is invoked to clean up a condition variable. This is
 *	only safe to call at the end of time.
 *
 *	This assumes the Global Lock is held.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The condition variable is deallocated.
 *
................................................................................
	Tcl_Panic("unable to delete key");
    }

    TclpSysFree(keyPtr);
}

void
TclpThreadSetGlobalTSD(
    void *tsdKeyPtr,
    void *ptr)
{
    DWORD *key = tsdKeyPtr;

    if (!TlsSetValue(*key, ptr)) {
	Tcl_Panic("unable to set global TSD value");
    }
}

void *
TclpThreadGetGlobalTSD(
    void *tsdKeyPtr)
{
    DWORD *key = tsdKeyPtr;

    return TlsGetValue(*key);
}