Tcl package Thread source code

Index: generic/threadSvCmd.c
==================================================================
--- generic/threadSvCmd.c
+++ generic/threadSvCmd.c
@@ -57,10 +57,13 @@
 
 /*
  * Global variables used within this file.
  */
 
+static size_t     nofThreads;      /* Number of initialized threads */
+static Tcl_Mutex  nofThreadsMutex; /* Protects the nofThreads variable */
+
 static Bucket*    buckets;      /* Array of buckets. */
 static Tcl_Mutex  bucketsMutex; /* Protects the array of buckets */
 
 static SvCmdInfo* svCmdInfo;    /* Linked list of registered commands */
 static RegType*   regType;      /* Linked list of registered obj types */
@@ -2128,10 +2131,24 @@
     Bucket *bucketPtr;
     SvCmdInfo *cmdPtr;
     const Tcl_UniChar no[3] = {'n', 'o', 0} ;
     Tcl_Obj *obj;
 
+    /*
+     * Create exit handler for this thread
+     */
+#ifdef SV_FINALIZE
+    Tcl_CreateThreadExitHandler(SvFinalize, NULL);
+#endif
+
+    /*
+     * Increment number of threads
+     */
+    Tcl_MutexLock(&nofThreadsMutex);
+    ++nofThreads;
+    Tcl_MutexUnlock(&nofThreadsMutex);
+
     /*
      * Add keyed-list datatype
      */
 
     TclX_KeyedListInit(interp);
@@ -2187,11 +2204,10 @@
 
     if (buckets == NULL) {
         Tcl_MutexLock(&bucketsMutex);
         if (buckets == NULL) {
             buckets = (Bucket *)ckalloc(sizeof(Bucket) * NUMBUCKETS);
-            Tcl_CreateExitHandler(SvFinalize, NULL);
 
             for (i = 0; i < NUMBUCKETS; ++i) {
                 bucketPtr = &buckets[i];
                 memset(bucketPtr, 0, sizeof(Bucket));
                 Tcl_InitHashTable(&bucketPtr->arrays, TCL_STRING_KEYS);
@@ -2256,10 +2272,22 @@
     SvCmdInfo *cmdPtr;
     RegType *regPtr;
 
     Tcl_HashEntry *hashPtr;
     Tcl_HashSearch search;
+
+    /*
+     * Decrement number of threads. Proceed only if I was the last one. The
+     * mutex is unlocked at the end of this function, so new threads that might
+     * want to register in the meanwhile will find a clean environment when
+     * they eventually succeed acquiring nofThreadsMutex.
+     */
+    Tcl_MutexLock(&nofThreadsMutex);
+    if (nofThreads > 1)
+    {
+        goto done;
+    }
 
     /*
      * Reclaim memory for shared arrays
      */
 
@@ -2317,10 +2345,14 @@
         }
         regType = NULL;
     }
 
     Tcl_MutexUnlock(&svMutex);
+
+done:
+    --nofThreads;
+    Tcl_MutexUnlock(&nofThreadsMutex);
 }
 #endif /* SV_FINALIZE */
 
 /* EOF $RCSfile: threadSvCmd.c,v $ */