Tcl Source Code

Artifact Content
Login
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2019 Conference, Houston/TX, US, Nov 4-8
Send your abstracts to tclconference@googlegroups.com
or submit via the online form by Sep 9.

Artifact b5119e6e6b0213a3a399e1a73a4178e9c6d1eb8d:

Attachment "731356.patch" to ticket [731356ffff] added by dgp 2003-11-15 04:15:01.
Index: generic/tcl.h
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tcl.h,v
retrieving revision 1.167
diff -u -r1.167 tcl.h
--- generic/tcl.h	14 Nov 2003 20:44:44 -0000	1.167
+++ generic/tcl.h	14 Nov 2003 21:13:19 -0000
@@ -1169,8 +1169,13 @@
  *				hash table will attempt to rectify this by
  *				randomising the bits and then using the upper
  *				N bits as the index into the table.
+ * TCL_HASH_KEY_SYSTEM_HASH:
+ *				If this flag is set then all memory internally
+ *                              allocated for the hash table that is not for an
+ *                              entry will use the system heap.
  */
 #define TCL_HASH_KEY_RANDOMIZE_HASH 0x1
+#define TCL_HASH_KEY_SYSTEM_HASH    0x2
 
 /*
  * Structure definition for the methods associated with a hash table
Index: generic/tclCkalloc.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclCkalloc.c,v
retrieving revision 1.19
diff -u -r1.19 tclCkalloc.c
--- generic/tclCkalloc.c	19 Jan 2003 07:21:18 -0000	1.19
+++ generic/tclCkalloc.c	14 Nov 2003 21:13:19 -0000
@@ -1249,4 +1249,8 @@
 #if USE_TCLALLOC
     TclFinalizeAllocSubsystem(); 
 #endif
+
+#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC)
+    TclpFinalizeThreadAllocSubsystem();
+#endif
 }
Index: generic/tclHash.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclHash.c,v
retrieving revision 1.13
diff -u -r1.13 tclHash.c
--- generic/tclHash.c	24 Jun 2003 19:56:12 -0000	1.13
+++ generic/tclHash.c	14 Nov 2003 21:13:19 -0000
@@ -14,6 +14,7 @@
  */
 
 #include "tclInt.h"
+#include "tclPort.h"
 
 /*
  * Prevent macros from clashing with function definitions.
@@ -626,8 +627,12 @@
      */
 
     if (tablePtr->buckets != tablePtr->staticBuckets) {
+        if (typePtr->flags & TCL_HASH_KEY_SYSTEM_HASH) {
+	    TclpSysFree((char *) tablePtr->buckets);
+        } else {
 	ckfree((char *) tablePtr->buckets);
     }
+    }
 
     /*
      * Arrange for panics if the table is used again without
@@ -745,6 +750,26 @@
     double average, tmp;
     register Tcl_HashEntry *hPtr;
     char *result, *p;
+    Tcl_HashKeyType *typePtr;
+
+#if TCL_PRESERVE_BINARY_COMPATABILITY
+    if (tablePtr->keyType == TCL_STRING_KEYS) {
+	typePtr = &tclStringHashKeyType;
+    } else if (tablePtr->keyType == TCL_ONE_WORD_KEYS) {
+	typePtr = &tclOneWordHashKeyType;
+    } else if (tablePtr->keyType == TCL_CUSTOM_TYPE_KEYS
+	       || tablePtr->keyType == TCL_CUSTOM_PTR_KEYS) {
+	typePtr = tablePtr->typePtr;
+    } else {
+	typePtr = &tclArrayHashKeyType;
+    }
+#else
+    typePtr = tablePtr->typePtr;
+    if (typePtr == NULL) {
+	Tcl_Panic("called Tcl_HashStats on deleted table");
+	return NULL;
+    }
+#endif
 
     /*
      * Compute a histogram of bucket usage.
@@ -774,8 +799,11 @@
     /*
      * Print out the histogram and a few other pieces of information.
      */
-
+    if (typePtr->flags & TCL_HASH_KEY_SYSTEM_HASH) {
+        result = (char *) TclpSysAlloc((unsigned) ((NUM_COUNTERS*60) + 300), 0);
+    } else {
     result = (char *) ckalloc((unsigned) ((NUM_COUNTERS*60) + 300));
+    }
     sprintf(result, "%d entries in table, %d buckets\n",
 	    tablePtr->numEntries, tablePtr->numBuckets);
     p = result + strlen(result);
@@ -1122,6 +1150,21 @@
     Tcl_HashKeyType *typePtr;
     VOID *key;
 
+#if TCL_PRESERVE_BINARY_COMPATABILITY
+    if (tablePtr->keyType == TCL_STRING_KEYS) {
+	typePtr = &tclStringHashKeyType;
+    } else if (tablePtr->keyType == TCL_ONE_WORD_KEYS) {
+	typePtr = &tclOneWordHashKeyType;
+    } else if (tablePtr->keyType == TCL_CUSTOM_TYPE_KEYS
+	       || tablePtr->keyType == TCL_CUSTOM_PTR_KEYS) {
+	typePtr = tablePtr->typePtr;
+    } else {
+	typePtr = &tclArrayHashKeyType;
+    }
+#else
+    typePtr = tablePtr->typePtr;
+#endif
+
     oldSize = tablePtr->numBuckets;
     oldBuckets = tablePtr->buckets;
 
@@ -1131,8 +1174,13 @@
      */
 
     tablePtr->numBuckets *= 4;
+    if (typePtr->flags & TCL_HASH_KEY_SYSTEM_HASH) {
+        tablePtr->buckets = (Tcl_HashEntry **) TclpSysAlloc((unsigned)
+    	        (tablePtr->numBuckets * sizeof(Tcl_HashEntry *)), 0);
+    } else {
     tablePtr->buckets = (Tcl_HashEntry **) ckalloc((unsigned)
 	    (tablePtr->numBuckets * sizeof(Tcl_HashEntry *)));
+    }
     for (count = tablePtr->numBuckets, newChainPtr = tablePtr->buckets;
 	    count > 0; count--, newChainPtr++) {
 	*newChainPtr = NULL;
@@ -1141,21 +1189,6 @@
     tablePtr->downShift -= 2;
     tablePtr->mask = (tablePtr->mask << 2) + 3;
 
-#if TCL_PRESERVE_BINARY_COMPATABILITY
-    if (tablePtr->keyType == TCL_STRING_KEYS) {
-	typePtr = &tclStringHashKeyType;
-    } else if (tablePtr->keyType == TCL_ONE_WORD_KEYS) {
-	typePtr = &tclOneWordHashKeyType;
-    } else if (tablePtr->keyType == TCL_CUSTOM_TYPE_KEYS
-	       || tablePtr->keyType == TCL_CUSTOM_PTR_KEYS) {
-	typePtr = tablePtr->typePtr;
-    } else {
-	typePtr = &tclArrayHashKeyType;
-    }
-#else
-    typePtr = tablePtr->typePtr;
-#endif
-
     /*
      * Rehash all of the existing entries into the new bucket array.
      */
@@ -1200,6 +1233,10 @@
      */
 
     if (oldBuckets != tablePtr->staticBuckets) {
+        if (typePtr->flags & TCL_HASH_KEY_SYSTEM_HASH) {
+	    TclpSysFree((char *) oldBuckets);
+        } else {
 	ckfree((char *) oldBuckets);
+        }
     }
 }
Index: generic/tclInt.h
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclInt.h,v
retrieving revision 1.138
diff -u -r1.138 tclInt.h
--- generic/tclInt.h	3 Nov 2003 12:49:31 -0000	1.138
+++ generic/tclInt.h	14 Nov 2003 21:13:20 -0000
@@ -1722,6 +1722,8 @@
 EXTERN void		TclpFinalizeCondition _ANSI_ARGS_((
 			    Tcl_Condition *condPtr));
 EXTERN void		TclpFinalizeMutex _ANSI_ARGS_((Tcl_Mutex *mutexPtr));
+EXTERN void             TclpFinalizeThreadStorage _ANSI_ARGS_((void));
+EXTERN void             TclpFinalizeThreadAllocSubsystem _ANSI_ARGS_((void));
 EXTERN void		TclpFinalizeThreadData _ANSI_ARGS_((
 			    Tcl_ThreadDataKey *keyPtr));
 EXTERN void		TclpFinalizeThreadDataKey _ANSI_ARGS_((
@@ -1744,6 +1746,9 @@
 EXTERN Tcl_Obj*		TclpObjListVolumes _ANSI_ARGS_((void));
 EXTERN void		TclpMasterLock _ANSI_ARGS_((void));
 EXTERN void		TclpMasterUnlock _ANSI_ARGS_((void));
+EXTERN void             TclpThreadStorageLockInit _ANSI_ARGS_((void));
+EXTERN void             TclpThreadStorageLock _ANSI_ARGS_((void));
+EXTERN void             TclpThreadStorageUnlock _ANSI_ARGS_((void));
 EXTERN int		TclpMatchFiles _ANSI_ARGS_((Tcl_Interp *interp,
 			    char *separators, Tcl_DString *dirPtr,
 			    char *pattern, char *tail));
@@ -1791,6 +1796,11 @@
 EXTERN void		TclpReleaseFile _ANSI_ARGS_((TclFile file));
 EXTERN void		TclpSetVariables _ANSI_ARGS_((Tcl_Interp *interp));
 EXTERN void		TclpUnloadFile _ANSI_ARGS_((Tcl_LoadHandle loadHandle));
+EXTERN Tcl_HashTable *  TclpThreadStorageInit _ANSI_ARGS_((Tcl_ThreadId id));
+EXTERN Tcl_HashTable *  TclpThreadStorageGetHashTable _ANSI_ARGS_((
+                            Tcl_ThreadId id));
+EXTERN void             TclpThreadStoragePrint _ANSI_ARGS_((FILE *outFile,
+                            int flags));
 EXTERN VOID *		TclpThreadDataKeyGet _ANSI_ARGS_((
 			    Tcl_ThreadDataKey *keyPtr));
 EXTERN void		TclpThreadDataKeyInit _ANSI_ARGS_((
Index: generic/tclThread.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclThread.c,v
retrieving revision 1.6
diff -u -r1.6 tclThread.c
--- generic/tclThread.c	10 Dec 2002 00:34:15 -0000	1.6
+++ generic/tclThread.c	14 Nov 2003 21:13:20 -0000
@@ -484,6 +484,9 @@
     condRecord.max = 0;
     condRecord.num = 0;
 
+    /* call platform specific thread storage master cleanup */
+    TclpFinalizeThreadStorage();
+
     TclpMasterUnlock();
 #else
     if (keyRecord.list != NULL) {
Index: win/tclWin32Dll.c
===================================================================
RCS file: /cvsroot/tcl/tcl/win/tclWin32Dll.c,v
retrieving revision 1.28
diff -u -r1.28 tclWin32Dll.c
--- win/tclWin32Dll.c	13 Oct 2003 16:48:07 -0000	1.28
+++ win/tclWin32Dll.c	14 Nov 2003 21:13:21 -0000
@@ -244,8 +244,12 @@
     switch (reason) {
     case DLL_PROCESS_ATTACH:
 	TclWinInit(hInst);
+        TclpThreadStorageLockInit(); /*
+                                      * Eliminate potential race condition by
+                                      * doing this here in case multiple threads
+                                      * need to allocate memory straight away.
+                                      */
 	return TRUE;
-
     case DLL_PROCESS_DETACH:
 	if (hInst == hInstance) {
 	    Tcl_Finalize();
Index: win/tclWinThrd.c
===================================================================
RCS file: /cvsroot/tcl/tcl/win/tclWinThrd.c,v
retrieving revision 1.26
diff -u -r1.26 tclWinThrd.c
--- win/tclWinThrd.c	13 May 2003 10:16:17 -0000	1.26
+++ win/tclWinThrd.c	14 Nov 2003 21:13:21 -0000
@@ -14,6 +14,12 @@
 
 #include "tclWinInt.h"
 
+/* TODO: put these in the "standard" location(s). */
+#define TCL_NO_TLS
+#define TCL_THREAD_ALLOC_NO_TLS
+/* WARNING: produces a lot of output. */
+/* #define TCL_THREAD_STORAGE_DEBUG */
+
 #include <fcntl.h>
 #include <io.h>
 #include <sys/stat.h>
@@ -110,6 +116,96 @@
     struct ThreadSpecificData *lastPtr;
 } WinCondition;
 
+/*
+ * This is the thread storage cache array and it's accompanying mutex.
+ * The elements are pairs of thread Id and an associated hash table
+ * pointer; the hash table being pointed to contains the thread storage
+ * for it's associated thread. The purpose of this cache is to minimize
+ *
+ */
+static CRITICAL_SECTION threadStorageLock;
+#define STORAGE_LOCK  TclpThreadStorageLock()
+#define STORAGE_UNLOCK  TclpThreadStorageUnlock()
+
+/*
+ * This is the struct used for a thread storage cache slot. It
+ * contains the owning thread Id and the associated hash table
+ * pointer.
+ */
+typedef struct WinThreadStorage {
+  Tcl_ThreadId id; /* the owning thread id */
+  Tcl_HashTable *hashTablePtr; /* the hash table for the thread */
+} WinThreadStorage;
+
+/*
+ * These are the prototypes for the custom hash table allocation
+ * functions used by the thread storage subsystem.
+ */
+static Tcl_HashEntry *	AllocThreadStorageEntry _ANSI_ARGS_((
+			    Tcl_HashTable *tablePtr, VOID *keyPtr));
+static void		FreeThreadStorageEntry _ANSI_ARGS_((
+			    Tcl_HashEntry *hPtr));
+
+/*
+ * This is the hash key type for thread storage. We MUST use
+ * this because these hash tables are used by the threaded memory
+ * allocator.
+ */
+Tcl_HashKeyType tclThreadStorageHashKeyType = {
+    TCL_HASH_KEY_TYPE_VERSION,          /* version */
+    TCL_HASH_KEY_SYSTEM_HASH,           /* flags */
+    NULL,                               /* hashKeyProc */
+    NULL,                               /* compareKeysProc */
+    AllocThreadStorageEntry,            /* allocEntryProc */
+    FreeThreadStorageEntry              /* freeEntryProc */
+};
+
+/*
+ * This is an invalid thread value.
+ */
+#define STORAGE_INVALID_THREAD  0
+
+/*
+ * This is the value for an invalid thread storage key.
+ */
+#define STORAGE_INVALID_KEY     0
+
+/*
+ * This is the first valid key for use by external callers.
+ */
+#define STORAGE_FIRST_KEY       1
+
+/*
+ * This define may need to be fine tuned for maximum performance.
+ */
+#define STORAGE_CACHE_SLOTS     100
+
+/*
+ * This is the master thread storage hash table. It is keyed on
+ * thread Id and contains values that are hash tables for each thread.
+ * The thread specific hash tables contain the actual thread storage.
+ */
+static Tcl_HashTable *threadStorageHashTablePtr = NULL;
+
+/*
+ * This is the next thread data key value to use. We increment this
+ * everytime we "allocate" one. It is initially set to 1 in
+ * TclpThreadStorageInit.
+ */
+static DWORD nextThreadStorageKey = STORAGE_INVALID_KEY;
+
+/*
+ * Have we initialized the thread storage critical section yet?
+ */
+static int initThreadStorage = 0;
+
+/*
+ * This is the master thread storage cache. Per kennykb's idea, this
+ * prevents unnecessary lookups for threads that use a lot of thread
+ * storage.
+ */
+volatile WinThreadStorage threadStorageCache[STORAGE_CACHE_SLOTS];
+
 
 /*
  *----------------------------------------------------------------------
@@ -373,6 +469,88 @@
 /*
  *----------------------------------------------------------------------
  *
+ * TclpThreadStorageLockInit
+ *
+ *      This procedure is used to initialize the lock that serializes
+ *      creation of thread storage.
+ *
+ * Results:
+ *      None.
+ *
+ * Side effects:
+ *      None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclpThreadStorageLockInit()
+{
+    if (!initThreadStorage) {
+        /*
+         * 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.
+         */
+        initThreadStorage = 1;
+        InitializeCriticalSection(&threadStorageLock);
+    }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclpThreadStorageLock
+ *
+ *      This procedure is used to grab a lock that serializes creation
+ *      of thread storage.
+ *
+ *      This lock must be different than the initLock because the
+ *      initLock is held during creation of syncronization objects.
+ *
+ * Results:
+ *      None.
+ *
+ * Side effects:
+ *      Acquire the thread storage mutex.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclpThreadStorageLock()
+{
+    TclpThreadStorageLockInit();
+    EnterCriticalSection(&threadStorageLock);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclpThreadStorageUnlock
+ *
+ *      This procedure is used to release a lock that serializes creation
+ *      of thread storage.
+ *
+ * Results:
+ *      None.
+ *
+ * Side effects:
+ *      Release the thread storage mutex.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclpThreadStorageUnlock()
+{
+    LeaveCriticalSection(&threadStorageLock);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
  * Tcl_GetAllocMutex
  *
  *	This procedure returns a pointer to a statically initialized
@@ -511,6 +689,304 @@
 /*
  *----------------------------------------------------------------------
  *
+ * AllocThreadStorageEntry --
+ *
+ *	Allocate space for a Tcl_HashEntry using TclpSysAlloc (not ckalloc).
+ *      We do this because the threaded memory allocator uses the thread
+ *      storage hash tables.
+ *
+ * Results:
+ *	The return value is a pointer to the created entry.
+ *
+ * Side effects:
+ *	None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static Tcl_HashEntry *
+AllocThreadStorageEntry(tablePtr, keyPtr)
+    Tcl_HashTable *tablePtr;	/* Hash table. */
+    VOID *keyPtr;		/* Key to store in the hash table entry. */
+{
+    Tcl_HashEntry *hPtr;
+
+    hPtr = (Tcl_HashEntry *)TclpSysAlloc(sizeof(Tcl_HashEntry), 0);
+    hPtr->key.oneWordValue = (char *)keyPtr;
+
+    return hPtr;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * FreeThreadStorageEntry --
+ *
+ *	Frees space for a Tcl_HashEntry using TclpSysFree (not ckfree).
+ *      We do this because the threaded memory allocator uses the thread
+ *      storage hash tables.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+FreeThreadStorageEntry(hPtr)
+    Tcl_HashEntry *hPtr;	/* Hash entry to free. */
+{
+    TclpSysFree((char *)hPtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ *  TclpThreadStoragePrint --
+ *
+ *      This procedure prints out the contents of the master thread
+ *      storage hash table, the thread storage cache, and the next key
+ *      value to the specified file.
+ *
+ * Results:
+ *      None.
+ *
+ * Side effects:
+ *      None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclpThreadStoragePrint(outFile, flags)
+    FILE *outFile;              /* The file to print the information to. */
+    int flags;                  /* Reserved for future use. */
+{
+    Tcl_HashEntry *hPtr;
+    Tcl_HashSearch search;
+#if 0
+    /* Please see comment regarding Tcl_HashStats below. */
+    CONST char *stats;
+#endif
+    int header;
+    int index;
+
+    STORAGE_LOCK;
+    if (threadStorageHashTablePtr != NULL) {
+        hPtr = Tcl_FirstHashEntry(threadStorageHashTablePtr, &search);
+
+        if (hPtr != NULL) {
+            fprintf(outFile, "master thread storage hash table:\n");
+            for (; hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
+                fprintf(outFile, "master entry ptr 0x%08lx, thread %ld, thread table ptr 0x%08lx\n",
+                    hPtr, Tcl_GetHashKey(threadStorageHashTablePtr, hPtr), Tcl_GetHashValue(hPtr));
+            }
+        } else {
+            fprintf(outFile, "master thread storage hash table has no entries\n");
+        }
+    } else {
+        fprintf(outFile, "master thread storage hash table not initialized\n");
+    }
+
+    header = 0; /* we have not output the header yet. */
+    for (index = 0; index < STORAGE_CACHE_SLOTS; index++) {
+        if (threadStorageCache[index].id != STORAGE_INVALID_THREAD) {
+            if (!header) {
+                fprintf(outFile, "thread storage cache (%d total slots):\n", STORAGE_CACHE_SLOTS);
+                header = 1;
+            }
+
+            fprintf(outFile, "slot %d, thread %d, thread table ptr 0x%08lx\n",
+                index, threadStorageCache[index].id,
+                threadStorageCache[index].hashTablePtr);
+#if 0
+            /*
+             * Currently disabled due to Tcl_HashStats use of ckalloc and ckfree.
+             */
+            if (threadStorageCache[index].hashTablePtr != NULL) {
+                stats = Tcl_HashStats(threadStorageCache[index].hashTablePtr);
+                if (stats != NULL) {
+                    fprintf(outFile, "%s\n", stats);
+                    ckfree((void *)stats);
+                } else {
+                    fprintf(outFile, "could not get table statistics for slot %d\n", index);
+                }
+            }
+#endif
+        } else {
+            /* fprintf(outFile, "cache slot %d not used\n", index); */
+        }
+    }
+
+    if (!header) {
+        fprintf(outFile, "thread storage cache is empty (%d total slots)\n", STORAGE_CACHE_SLOTS);
+        header = 1;
+    }
+
+    /* Show the next data key value. */
+    fprintf(outFile, "next data key value is: %ld\n", nextThreadStorageKey);
+    STORAGE_UNLOCK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclpThreadStorageGetHashTable --
+ *
+ *      This procedure returns a hash table pointer to be used for thread
+ *      storage for the specified thread.
+ *
+ * Results:
+ *      A hash table pointer for the specified thread, or NULL
+ *      if the hash table has not been created yet.
+ *
+ * Side effects:
+ *      May change an entry in the master thread storage cache to point
+ *      to the specified thread and it's associated hash table.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_HashTable *
+TclpThreadStorageGetHashTable(id)
+    Tcl_ThreadId id;    /* Id of the thread to get the hash table for */
+{
+    int index = (DWORD)id % STORAGE_CACHE_SLOTS;
+    Tcl_HashEntry *hPtr;
+
+    /*
+     * It's important that we pick up the hash table pointer BEFORE
+     * comparing thread Id in case another thread is in the critical
+     * region changing things out from under you.
+     */
+    Tcl_HashTable *hashTablePtr = threadStorageCache[index].hashTablePtr;
+
+    if (threadStorageCache[index].id != id) {
+        STORAGE_LOCK;
+        if (threadStorageHashTablePtr != NULL) {
+            /* it's not in the cache, so we look it up... */
+            hPtr = Tcl_FindHashEntry(threadStorageHashTablePtr, (char *)id);
+
+            if (hPtr != NULL) {
+                /* we found it, extract the hash table pointer. */
+                hashTablePtr = Tcl_GetHashValue(hPtr);
+            } else {
+                /* the thread specific hash table is not found. */
+                hashTablePtr = NULL;
+            }
+        } else {
+            /* we cannot look it up, the master hash table has not been initialized. */
+            hashTablePtr = NULL;
+        }
+
+        /* for threads that have not created their hash table yet, we need to skip
+           putting that thread in the cache. */
+        if (hashTablePtr != NULL) {
+            /* now, we put it in the cache since it is highly likely it will
+               be needed again shortly. */
+            threadStorageCache[index].id = id;
+            threadStorageCache[index].hashTablePtr = hashTablePtr;
+        }
+        STORAGE_UNLOCK;
+    }
+
+    return hashTablePtr;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclpThreadStorageInit --
+ *
+ *      This procedure initializes a thread specific hash table for the
+ *      current thread. It may also initialize the master hash table which
+ *      stores all the thread specific hash tables.
+ *
+ * Results:
+ *      A hash table pointer for the specified thread, or NULL if we are
+ *      be called to initialize the master hash table only.
+ *
+ * Side effects:
+ *      The thread specific hash table may be initialized and added to the
+ *      master hash table.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_HashTable *
+TclpThreadStorageInit(id)
+    Tcl_ThreadId id;    /* Id of the thread to get the hash table for */
+{
+    Tcl_HashTable *hashTablePtr; /* hash table for current thread */
+    Tcl_HashEntry *hPtr; /* hash entry for current thread in master table */
+    int new;
+
+#ifdef TCL_THREAD_STORAGE_DEBUG
+    TclpThreadStoragePrint(stderr, 0);
+#endif
+
+    STORAGE_LOCK;
+    if (threadStorageHashTablePtr == NULL) {
+        /* looks like we haven't created the outer hash table yet
+           we can just do that now. */
+        threadStorageHashTablePtr = (Tcl_HashTable *)TclpSysAlloc(sizeof(Tcl_HashTable), 0);
+
+        if (threadStorageHashTablePtr != NULL) {
+            /* initialize the hash table */
+            Tcl_InitCustomHashTable(threadStorageHashTablePtr, TCL_CUSTOM_TYPE_KEYS, &tclThreadStorageHashKeyType);
+        } else {
+            panic("could not allocate master thread storage hash table");
+        }
+
+        /* we MUST also initialize the cache, since it is checked by
+           TclpThreadStorageGetHashTable in the call below. */
+        memset((WinThreadStorage *)&threadStorageCache, 0, sizeof(WinThreadStorage) * STORAGE_CACHE_SLOTS);
+
+        /* now, we set the first value to be used for a thread data key. */
+        nextThreadStorageKey = STORAGE_FIRST_KEY;
+    }
+    STORAGE_UNLOCK;
+
+    /*
+     * A thread Id of zero indicates that the caller does not want to
+     * lookup or initialize the hash table pointer for the thread.
+     */
+    if (id != STORAGE_INVALID_THREAD) {
+        hashTablePtr = TclpThreadStorageGetHashTable(id);
+
+        if (hashTablePtr == NULL) {
+            hashTablePtr = (Tcl_HashTable *)TclpSysAlloc(sizeof(Tcl_HashTable), 0);
+
+            if (hashTablePtr != NULL) {
+                Tcl_InitCustomHashTable(hashTablePtr, TCL_CUSTOM_TYPE_KEYS, &tclThreadStorageHashKeyType);
+
+                /* add new thread storage hash table to the master hash table */
+                STORAGE_LOCK;
+                hPtr = Tcl_CreateHashEntry(threadStorageHashTablePtr, (char *)id, &new);
+
+                if (hPtr != NULL) {
+                    Tcl_SetHashValue(hPtr, hashTablePtr);
+                } else {
+                    panic("Tcl_CreateHashEntry failed from TclpThreadStorageInit!");
+                }
+                STORAGE_UNLOCK;
+            } else {
+                panic("could not allocate thread specific hash table");
+            }
+        }
+    } else {
+        hashTablePtr = NULL;
+    }
+
+    return hashTablePtr;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
  * TclpThreadDataKeyInit --
  *
  *	This procedure initializes a thread specific data block key.
@@ -540,18 +1016,67 @@
 {
     DWORD *indexPtr;
     DWORD newKey;
-
     MASTER_LOCK;
     if (*keyPtr == NULL) {
 	indexPtr = (DWORD *)ckalloc(sizeof(DWORD));
+        if (indexPtr != NULL) {
+#ifndef TCL_NO_TLS
 	newKey = TlsAlloc();
         if (newKey != TLS_OUT_OF_INDEXES) {
             *indexPtr = newKey;
+                *keyPtr = (Tcl_ThreadDataKey)indexPtr;
+                TclRememberDataKey(keyPtr);
         } else {
+                /*
+                 * This panic is probably the most likely one in this
+                 * entire file to actually be hit. The primary reason for
+                 * this is that there are hard coded limits on the number
+                 * of TLS indexes/slots on ALL versions of Win32, as
+                 * follows:
+                 *
+                 *  95/NT4: 64
+                 *   98/Me: 80
+                 * 2000/XP: 1088
+                 *    2003: 1088
+                 *
+                 * All of these limits are per process, for the lifetime
+                 * of the process, which could be a big problem for long
+                 * running processes that load and unload a lot of DLLs
+                 * that use TLS.
+                 */
             panic("TlsAlloc failed from TclpThreadDataKeyInit!"); /* this should be a fatal error */
         }
+#else
+            /*
+             * We must call this now to make sure
+             * that nextThreadStorageKey has a well defined
+             * value.
+             */
+            TclpThreadStorageInit(STORAGE_INVALID_THREAD);
+            STORAGE_LOCK;
+            /*
+             * These data key values are sequentially
+             * assigned and we must use the storage
+             * lock to prevent serious problems here.
+             * We could use the Win32 interlocked
+             * increment here IF it had consistent
+             * behavior on different variations of
+             * Win32. Also note that the caller should
+             * NOT make any assumptions about the
+             * provided values. In particular, we may
+             * need to reserve some values in the
+             * future.
+             */
+            newKey = nextThreadStorageKey++;
+            STORAGE_UNLOCK;
+
+            *indexPtr = newKey;
 	*keyPtr = (Tcl_ThreadDataKey)indexPtr;
 	TclRememberDataKey(keyPtr);
+#endif
+        } else {
+            panic("ckalloc failed from TclpThreadDataKeyInit!"); /* this should also be a fatal error */
+        }
     }
     MASTER_UNLOCK;
 }
@@ -580,15 +1105,41 @@
 {
     DWORD *indexPtr = *(DWORD **)keyPtr;
     LPVOID result;
+#ifndef TCL_NO_TLS
     if (indexPtr == NULL) {
-	return NULL;
+        result = NULL;
     } else {
         result = TlsGetValue(*indexPtr);
         if ((result == NULL) && (GetLastError() != NO_ERROR)) {
             panic("TlsGetValue failed from TclpThreadDataKeyGet!");
         }
+    }
 	return result;
+#else
+    Tcl_ThreadId id = Tcl_GetCurrentThread();
+    Tcl_HashTable *hashTablePtr;
+    Tcl_HashEntry *hPtr;
+
+    if (indexPtr == NULL) {
+        result = NULL;
+    } else {
+        hashTablePtr = TclpThreadStorageInit(id);
+
+        if (hashTablePtr != NULL) {
+            hPtr = Tcl_FindHashEntry(hashTablePtr, (char *)*indexPtr);
+
+            if (hPtr != NULL) {
+                result = (LPVOID)Tcl_GetHashValue(hPtr);
+            } else {
+                result = NULL;
     }
+        } else {
+            panic("TclpThreadStorageInit failed from TclpThreadDataKeyGet!");
+            result = NULL;
+        }
+    }
+    return result;
+#endif /* TCL_NO_TLS */
 }
 
 /*
@@ -615,11 +1166,97 @@
     VOID *data;			/* Thread local storage */
 {
     DWORD *indexPtr = *(DWORD **)keyPtr;
+#ifndef TCL_NO_TLS
     BOOL success;
     success = TlsSetValue(*indexPtr, (void *)data);
     if (!success) {
         panic("TlsSetValue failed from TclpThreadDataKeySet!");
     }
+#else
+    Tcl_ThreadId id = Tcl_GetCurrentThread();
+    Tcl_HashTable *hashTablePtr;
+    Tcl_HashEntry *hPtr;
+    int new;
+
+    hashTablePtr = TclpThreadStorageInit(id);
+
+    if (hashTablePtr != NULL) {
+        hPtr = Tcl_FindHashEntry(hashTablePtr, (char *)*indexPtr);
+
+        /* does the item need to be created? */
+        if (hPtr == NULL) {
+            hPtr = Tcl_CreateHashEntry(hashTablePtr, (char *)*indexPtr, &new);
+        }
+
+        if (hPtr != NULL) {
+            Tcl_SetHashValue(hPtr, data);
+        } else {
+            panic("could not set hash entry value from TclpThreadDataKeySet");
+        }
+    } else {
+        panic("TclpThreadStorageInit failed from TclpThreadDataKeySet!");
+    }
+#endif /* TCL_NO_TLS */
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclpFinalizeThreadStorage --
+ *
+ *      This procedure cleans up the master thread storage hash table,
+ *      all thread specific hash tables, and the thread storage cache.
+ *
+ * Results:
+ *      None.
+ *
+ * Side effects:
+ *      The master thread storage hash table and thread storage cache are
+ *      reset to their initial (empty) state.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclpFinalizeThreadStorage()
+{
+    Tcl_HashTable *hashTablePtr; /* hash table for current thread */
+    Tcl_HashSearch search; /* we need to hit every thread with this search */
+    Tcl_HashEntry *hPtr; /* hash entry for current thread in master table */
+
+    STORAGE_LOCK;
+    if (threadStorageHashTablePtr != NULL) {
+        /* we are going to delete the hash table for every thread now. */
+        for (hPtr = Tcl_FirstHashEntry(threadStorageHashTablePtr, &search);
+                hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
+
+            /* get the hash table corresponding to the thread in question. */
+            hashTablePtr = Tcl_GetHashValue(hPtr);
+
+            if (hashTablePtr != NULL) {
+                /* delete thread specific hash table and free the struct. */
+                Tcl_DeleteHashTable(hashTablePtr);
+                TclpSysFree((char *)hashTablePtr);
+            }
+
+            /* delete thread specific entry from master hash table. */
+            Tcl_SetHashValue(hPtr, NULL);
+        }
+
+        Tcl_DeleteHashTable(threadStorageHashTablePtr);
+        TclpSysFree((char *)threadStorageHashTablePtr);
+
+        /* reset this so that next time around we know it's not valid. */
+        threadStorageHashTablePtr = NULL;
+
+        /* clear out the thread storage cache as well */
+        memset((WinThreadStorage *)&threadStorageCache, 0, sizeof(WinThreadStorage) * STORAGE_CACHE_SLOTS);
+
+        /* reset this to zero, it will be set to 1 if the thread storage
+           subsystem gets reinitialized */
+        nextThreadStorageKey = STORAGE_INVALID_KEY;
+    }
+    STORAGE_UNLOCK;
 }
 
 /*
@@ -645,11 +1282,19 @@
 {
     VOID *result;
     DWORD *indexPtr;
+#ifndef TCL_NO_TLS
     BOOL success;
+#else
+    Tcl_ThreadId id = Tcl_GetCurrentThread();
+    Tcl_HashTable *hashTablePtr; /* hash table for current thread */
+    Tcl_HashEntry *hPtr; /* hash entry for data key in current thread */
+#endif
 
 #ifdef USE_THREAD_ALLOC
     TclWinFreeAllocCache();
 #endif
+
+#ifndef TCL_NO_TLS
     if (*keyPtr != NULL) {
 	indexPtr = *(DWORD **)keyPtr;
 	result = (VOID *)TlsGetValue(*indexPtr);
@@ -665,6 +1310,29 @@
             }
 	}
     }
+#else
+    if (*keyPtr != NULL) {
+        indexPtr = *(DWORD **)keyPtr;
+
+        hashTablePtr = TclpThreadStorageInit(id);
+
+        if (hashTablePtr != NULL) {
+            hPtr = Tcl_FindHashEntry(hashTablePtr, (char *)*indexPtr);
+
+            if (hPtr != NULL) {
+                result = Tcl_GetHashValue(hPtr);
+
+                if (result != NULL) {
+                    ckfree((char *)result);
+                }
+
+                Tcl_SetHashValue(hPtr, NULL);
+            }
+        } else {
+            panic("TclpThreadStorageInit failed from TclpFinalizeThreadData!");
+        }
+    }
+#endif /* TCL_NO_TLS */
 }
 
 /*
@@ -692,16 +1360,53 @@
     Tcl_ThreadDataKey *keyPtr;
 {
     DWORD *indexPtr;
+#ifndef TCL_NO_TLS
     BOOL success;
     if (*keyPtr != NULL) {
 	indexPtr = *(DWORD **)keyPtr;
 	success = TlsFree(*indexPtr);
-        if (!success) {
+        if (success) {
+            ckfree((char *)indexPtr);
+            *keyPtr = NULL;
+        } else {
             panic("TlsFree failed from TclpFinalizeThreadDataKey!");
         }
+    }
+#else
+    Tcl_HashTable *hashTablePtr; /* hash table for current thread */
+    Tcl_HashSearch search; /* we need to hit every thread with this search */
+    Tcl_HashEntry *hPtr; /* hash entry for current thread in master table */
+    Tcl_HashEntry *hDataPtr; /* hash entry for data key in current thread */
+
+    if (*keyPtr != NULL) {
+        indexPtr = *(DWORD **)keyPtr;
+
+        STORAGE_LOCK;
+        if (threadStorageHashTablePtr != NULL) {
+            /* we are going to delete the specified data key entry from every thread. */
+            for (hPtr = Tcl_FirstHashEntry(threadStorageHashTablePtr, &search);
+                    hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
+
+                /* get the hash table corresponding to the thread in question. */
+                hashTablePtr = Tcl_GetHashValue(hPtr);
+
+                if (hashTablePtr != NULL) {
+                    /* now find the entry for the specified data key. */
+                    hDataPtr = Tcl_FindHashEntry(hashTablePtr, (char *)*indexPtr);
+
+                    if (hDataPtr != NULL) {
+                        /* delete the data key for this thread. */
+                        Tcl_DeleteHashEntry(hDataPtr);
+                    }
+                }
+            }
+        }
+        STORAGE_UNLOCK;
+
 	ckfree((char *)indexPtr);
 	*keyPtr = NULL;
     }
+#endif
 }
 
 /*
@@ -1005,7 +1710,16 @@
  * Additions by AOL for specialized thread memory allocator.
  */
 #ifdef USE_THREAD_ALLOC
-static DWORD key;
+static int initThreadAlloc = 0;
+
+#ifndef TCL_NO_TLS
+#define THREAD_ALLOC_BAD_KEY    TLS_OUT_OF_INDEXES
+#else
+#define THREAD_ALLOC_BAD_KEY    STORAGE_INVALID_KEY
+#endif
+
+/* set to an invalid value for a thread [local] storage index */
+static DWORD key = THREAD_ALLOC_BAD_KEY;
 
 Tcl_Mutex *
 TclpNewAllocMutex(void)
@@ -1027,57 +1741,174 @@
 void *
 TclpGetAllocCache(void)
 {
-    static int once = 0;
     VOID *result;
-
-    if (!once) {
+#ifndef TCL_THREAD_ALLOC_NO_TLS
+    if (!initThreadAlloc) {
 	/*
 	 * We need to make sure that TclWinFreeAllocCache is called
 	 * on each thread that calls this, but only on threads that
 	 * call this.
 	 */
     	key = TlsAlloc();
-	once = 1;
-	if (key == TLS_OUT_OF_INDEXES) {
+        if (key != TLS_OUT_OF_INDEXES) {
+            initThreadAlloc = 1;
+        } else {
 	    panic("could not allocate thread local storage");
 	}
     }
 
+    if (key != TLS_OUT_OF_INDEXES) {
     result = TlsGetValue(key);
     if ((result == NULL) && (GetLastError() != NO_ERROR)) {
         panic("TlsGetValue failed from TclpGetAllocCache!");
     }
+    } else {
+        result = NULL;
+    }
+#else
+    Tcl_ThreadId id = Tcl_GetCurrentThread();
+    Tcl_HashTable *hashTablePtr;
+    Tcl_HashEntry *hPtr;
+    int new;
+
+    hashTablePtr = TclpThreadStorageInit(id);
+
+    if (!initThreadAlloc) {
+        STORAGE_LOCK;
+        /*
+         * This must be after call to TclpThreadStorageInit,
+         * otherwise nextThreadStorageKey may not have been initialized.
+         */
+        key = nextThreadStorageKey++;
+        STORAGE_UNLOCK;
+        initThreadAlloc = 1;
+    }
+
+    if (hashTablePtr != NULL) {
+        hPtr = Tcl_FindHashEntry(hashTablePtr, (char *)key);
+
+        if (hPtr != NULL) {
+            /* return the value for this thread */
+            result = Tcl_GetHashValue(hPtr);
+        } else {
+            result = NULL;
+
+            /* now create the thread storage index for this thread */
+            hPtr = Tcl_CreateHashEntry(hashTablePtr, (char *)key, &new);
+
+            if (hPtr != NULL) {
+                /* initially, set to NULL */
+                Tcl_SetHashValue(hPtr, NULL);
+            } else {
+                panic("Tcl_CreateHashEntry failed from TclpGetAllocCache!");
+            }
+        }
+    } else {
+        panic("TclpThreadStorageInit failed from TclpGetAllocCache!");
+        result = NULL;
+    }
+#endif
     return result;
 }
 
 void
 TclpSetAllocCache(void *ptr)
 {
+#ifndef TCL_THREAD_ALLOC_NO_TLS
     BOOL success;
     success = TlsSetValue(key, ptr);
     if (!success) {
         panic("TlsSetValue failed from TclpSetAllocCache!");
     }
+#else
+    Tcl_ThreadId id = Tcl_GetCurrentThread();
+    Tcl_HashTable *hashTablePtr;
+    Tcl_HashEntry *hPtr;
+
+    hashTablePtr = TclpThreadStorageInit(id);
+
+    if (hashTablePtr != NULL) {
+        hPtr = Tcl_FindHashEntry(hashTablePtr, (char *)key);
+
+        if (hPtr != NULL) {
+            Tcl_SetHashValue(hPtr, ptr);
+        } else {
+            /*
+             * This may indicate an error by the caller, they should have
+             * called TclpGetAllocCache prior to calling this function.
+             */
+            panic("could not find thread alloc hash entry from TclpSetAllocCache");
+        }
+    } else {
+        panic("TclpThreadStorageInit failed from TclpSetAllocCache!");
+    }
+#endif
 }
 
 void
 TclWinFreeAllocCache(void)
 {
     void *ptr;
+#ifndef TCL_THREAD_ALLOC_NO_TLS
     BOOL success;
-
     ptr = TlsGetValue(key);
     if (ptr != NULL) {
 	success = TlsSetValue(key, NULL);
-        if (!success) {
+        if (success) {
+            TclFreeAllocCache(ptr);
+        } else {
             panic("TlsSetValue failed from TclWinFreeAllocCache!");
         }
-	TclFreeAllocCache(ptr);
     } else {
       if (GetLastError() != NO_ERROR) {
           panic("TlsGetValue failed from TclWinFreeAllocCache!");
       }
     }
+#else
+    Tcl_ThreadId id = Tcl_GetCurrentThread();
+    Tcl_HashTable *hashTablePtr;
+    Tcl_HashEntry *hPtr;
+
+    hashTablePtr = TclpThreadStorageInit(id);
+
+    if (hashTablePtr != NULL) {
+        hPtr = Tcl_FindHashEntry(hashTablePtr, (char *)key);
+
+        if (hPtr != NULL) {
+            ptr = Tcl_GetHashValue(hPtr);
+
+            if (ptr != NULL) {
+                TclFreeAllocCache(ptr);
+            }
+
+            Tcl_DeleteHashEntry(hPtr);
+        }
+    } else {
+        panic("TclpThreadStorageInit failed from TclWinFreeAllocCache!");
+    }
+#endif
+}
+
+void
+TclpFinalizeThreadAllocSubsystem(void)
+{
+#ifndef TCL_THREAD_ALLOC_NO_TLS
+    BOOL success;
+    if (initThreadAlloc) {
+        success = TlsFree(key);
+        if (success) {
+            /* reset the variable for next time. */
+            key = TLS_OUT_OF_INDEXES;
+            initThreadAlloc = 0;
+        } else {
+            panic("TlsFree failed from TclpFinalizeThreadAllocSubsystem!");
+        }
+    }
+#else
+    /* reset for next time around... */
+    key = STORAGE_INVALID_KEY;
+    initThreadAlloc = 0;
+#endif
 }
 
 #endif /* USE_THREAD_ALLOC */