New scheme for keeping the per-process tcl_precision value in sync without

the need for mutex locks on every read.  Uses adapted ProcessGlobalValue
machinery backported from Tcl 8.5 where it's been working without reported
problems.  Thanks to Phil Brooks for reporting on tests which highlight the
thread performance problems raised by the old scheme, and to Clif Flynt for
further testing pointing the finger at tcl_precision locks as the main culprit.

1 files changed, 296 insertions, 23 deletions

diff --git a/generic/tclUtil.c b/generic/tclUtil.c
index b327b99..7d455af 100644
--- a/generic/tclUtil.c
+++ b/generic/tclUtil.c
@@ -47,27 +47,59 @@ char *tclNativeExecutableName = NULL;
 #define BRACES_UNMATCHED	4
 
 /*
+ * Data structures for process-global values.
+ */
+
+typedef void (InitPGVProc) _ANSI_ARGS_ ((char **valuePtr, int *lengthPtr));
+
+/*
+ * 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. */
+    InitPGVProc *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. */
+} PGV;
+
+/*
  * The following values determine the precision used when converting
  * floating-point values to strings.  This information is linked to all
  * of the tcl_precision variables in all interpreters via the procedure
  * TclPrecTraceProc.
  */
 
-static char precisionString[10] = "12";
-				/* The string value of all the tcl_precision
-				 * variables. */
-static char precisionFormat[10] = "%.12g";
-				/* The format string actually used in calls
-				 * to sprintf. */
-TCL_DECLARE_MUTEX(precisionMutex)
+static InitPGVProc InitPrecision;
+static PGV precision = {
+    0, 0, NULL, InitPrecision, NULL, NULL
+};
 
 /*
  * Prototypes for procedures defined later in this file.
  */
 
+static void ClearHash _ANSI_ARGS_((Tcl_HashTable *tablePtr));
+static void FreePGV _ANSI_ARGS_((ClientData clientData));
+static void FreeThreadHash _ANSI_ARGS_((ClientData clientData));
+static Tcl_HashTable * GetThreadHash _ANSI_ARGS_((
+		Tcl_ThreadDataKey *keyPtr));
 static void UpdateStringOfEndOffset _ANSI_ARGS_((Tcl_Obj* objPtr));
 static int SetEndOffsetFromAny _ANSI_ARGS_((Tcl_Interp* interp,
 					    Tcl_Obj* objPtr));
+static void SetPGV _ANSI_ARGS_((PGV *pgvPtr, Tcl_Obj *newValue));
+static Tcl_Obj * GetPGV _ANSI_ARGS_((PGV *pgvPtr));
 
 /*
  * The following is the Tcl object type definition for an object
@@ -1874,6 +1906,32 @@ Tcl_DStringEndSublist(dsPtr)
 /*
  *----------------------------------------------------------------------
  *
+ * InitPrecision --
+ *
+ *	Set the default value for tcl_precision to 12.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+InitPrecision(valuePtr, lengthPtr)
+    char **valuePtr;
+    int *lengthPtr;
+{
+    *lengthPtr = 2;
+    *valuePtr = ckalloc(3);
+    memcpy(*valuePtr, "12", 3);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
  * Tcl_PrintDouble --
  *
  *	Given a floating-point value, this procedure converts it to
@@ -1902,11 +1960,12 @@ Tcl_PrintDouble(interp, value, dst)
 					 * characters. */
 {
     char *p, c;
+    char format[10];
     Tcl_UniChar ch;
+    Tcl_Obj *precisionObj = GetPGV(&precision);
 
-    Tcl_MutexLock(&precisionMutex);
-    sprintf(dst, precisionFormat, value);
-    Tcl_MutexUnlock(&precisionMutex);
+    sprintf(format, "%%.%sg", Tcl_GetString(precisionObj));
+    sprintf(dst, format, value);
 
     /*
      * If the ASCII result looks like an integer, add ".0" so that it
@@ -1984,12 +2043,9 @@ TclPrecTraceProc(clientData, interp, name1, name2, flags)
      * out of date.
      */
 
-    Tcl_MutexLock(&precisionMutex);
-
     if (flags & TCL_TRACE_READS) {
-	Tcl_SetVar2(interp, name1, name2, precisionString,
+	Tcl_SetVar2Ex(interp, name1, name2, GetPGV(&precision),
 		flags & TCL_GLOBAL_ONLY);
-	Tcl_MutexUnlock(&precisionMutex);
 	return (char *) NULL;
     }
 
@@ -2001,9 +2057,8 @@ TclPrecTraceProc(clientData, interp, name1, name2, flags)
      */
 
     if (Tcl_IsSafe(interp)) {
-	Tcl_SetVar2(interp, name1, name2, precisionString,
+	Tcl_SetVar2Ex(interp, name1, name2, GetPGV(&precision),
 		flags & TCL_GLOBAL_ONLY);
-	Tcl_MutexUnlock(&precisionMutex);
 	return "can't modify precision from a safe interpreter";
     }
     value = Tcl_GetVar2(interp, name1, name2, flags & TCL_GLOBAL_ONLY);
@@ -2011,16 +2066,13 @@ TclPrecTraceProc(clientData, interp, name1, name2, flags)
 	value = "";
     }
     prec = strtoul(value, &end, 10);
-    if ((prec <= 0) || (prec > TCL_MAX_PREC) || (prec > 100) ||
-	    (end == value) || (*end != 0)) {
-	Tcl_SetVar2(interp, name1, name2, precisionString,
+    if ((prec <= 0) || (prec > TCL_MAX_PREC)
+	    || (end == value) || (*end != 0)) {
+	Tcl_SetVar2Ex(interp, name1, name2, GetPGV(&precision),
 		flags & TCL_GLOBAL_ONLY);
-	Tcl_MutexUnlock(&precisionMutex);
 	return "improper value for precision";
     }
-    TclFormatInt(precisionString, prec);
-    sprintf(precisionFormat, "%%.%dg", prec);
-    Tcl_MutexUnlock(&precisionMutex);
+    SetPGV(&precision, Tcl_NewIntObj(prec));
     return (char *) NULL;
 }
 
@@ -2522,6 +2574,227 @@ TclCheckBadOctal(interp, value)
 /*
  *----------------------------------------------------------------------
  *
+ * ClearHash --
+ *
+ *	Remove all the entries in the hash table *tablePtr.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+ClearHash(tablePtr)
+    Tcl_HashTable *tablePtr;
+{
+    Tcl_HashSearch search;
+    Tcl_HashEntry *hPtr;
+
+    for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL;
+	    hPtr = Tcl_NextHashEntry(&search)) {
+	Tcl_Obj *objPtr = (Tcl_Obj *) Tcl_GetHashValue(hPtr);
+	Tcl_DecrRefCount(objPtr);
+	Tcl_DeleteHashEntry(hPtr);
+    }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * GetThreadHash --
+ *
+ *	Get a thread-specific (Tcl_HashTable *) associated with a thread data
+ *	key.
+ *
+ * Results:
+ *	The Tcl_HashTable * corresponding to *keyPtr.
+ *
+ * Side effects:
+ *	The first call on a keyPtr in each thread creates a new Tcl_HashTable,
+ *	and registers a thread exit handler to dispose of it.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static Tcl_HashTable *
+GetThreadHash(keyPtr)
+    Tcl_ThreadDataKey *keyPtr;
+{
+    Tcl_HashTable **tablePtrPtr = (Tcl_HashTable **)
+	    Tcl_GetThreadData(keyPtr, (int) sizeof(Tcl_HashTable *));
+
+    if (NULL == *tablePtrPtr) {
+	*tablePtrPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
+	Tcl_CreateThreadExitHandler(FreeThreadHash, (ClientData)*tablePtrPtr);
+	Tcl_InitHashTable(*tablePtrPtr, TCL_ONE_WORD_KEYS);
+    }
+    return *tablePtrPtr;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * FreeThreadHash --
+ *
+ *	Thread exit handler used by GetThreadHash to dispose of a thread hash
+ *	table.
+ *
+ * Side effects:
+ *	Frees a Tcl_HashTable.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+FreeThreadHash(clientData)
+    ClientData clientData;
+{
+    Tcl_HashTable *tablePtr = (Tcl_HashTable *) clientData;
+
+    ClearHash(tablePtr);
+    Tcl_DeleteHashTable(tablePtr);
+    ckfree((char *) tablePtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * FreePGV --
+ *
+ *	Exit handler used by (Set|Get)PGV to cleanup a PGV at exit.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+FreePGV(clientData)
+    ClientData clientData;
+{
+    PGV *pgvPtr = (PGV *) clientData;
+
+    pgvPtr->epoch++;
+    pgvPtr->numBytes = 0;
+    ckfree(pgvPtr->value);
+    pgvPtr->value = NULL;
+    Tcl_MutexFinalize(&pgvPtr->mutex);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * SetPGV --
+ *
+ *	Utility routine to set a global value shared by all threads in the
+ *	process while keeping a thread-local copy as well.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+SetPGV(pgvPtr, newValue)
+    PGV *pgvPtr;
+    Tcl_Obj *newValue;
+{
+    CONST char *bytes;
+    Tcl_HashTable *cacheMap;
+    Tcl_HashEntry *hPtr;
+    int dummy;
+
+    Tcl_MutexLock(&pgvPtr->mutex);
+
+    /*
+     * Fill the global string value.
+     */
+
+    pgvPtr->epoch++;
+    if (NULL != pgvPtr->value) {
+	ckfree(pgvPtr->value);
+    } else {
+	Tcl_CreateExitHandler(FreePGV, (ClientData) pgvPtr);
+    }
+    bytes = Tcl_GetStringFromObj(newValue, &pgvPtr->numBytes);
+    pgvPtr->value = ckalloc((unsigned) pgvPtr->numBytes + 1);
+    memcpy(pgvPtr->value, bytes, (unsigned) pgvPtr->numBytes + 1);
+
+    /*
+     * Fill the local thread copy directly with the Tcl_Obj value to avoid
+     * loss of the intrep. Increment newValue refCount early to handle case
+     * where we set a PGV to itself.
+     */
+
+    Tcl_IncrRefCount(newValue);
+    cacheMap = GetThreadHash(&pgvPtr->key);
+    ClearHash(cacheMap);
+    hPtr = Tcl_CreateHashEntry(cacheMap, (char *) pgvPtr->epoch, &dummy);
+    Tcl_SetHashValue(hPtr, (ClientData) newValue);
+    Tcl_MutexUnlock(&pgvPtr->mutex);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * GetPGV --
+ *
+ *	Retrieve a global value shared among all threads of the process,
+ *	preferring a thread-local copy as long as it remains valid.
+ *
+ * Results:
+ *	Returns a (Tcl_Obj *) that holds a copy of the global value.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static Tcl_Obj *
+GetPGV(pgvPtr)
+    PGV *pgvPtr;
+{
+    Tcl_Obj *value = NULL;
+    Tcl_HashTable *cacheMap;
+    Tcl_HashEntry *hPtr;
+    int epoch = pgvPtr->epoch;
+
+    cacheMap = GetThreadHash(&pgvPtr->key);
+    hPtr = Tcl_FindHashEntry(cacheMap, (char *) epoch);
+    if (NULL == hPtr) {
+	int dummy;
+
+	/*
+	 * No cache for the current epoch - must be a new one.
+	 *
+	 * First, clear the cacheMap, as anything in it must refer to some
+	 * expired epoch.
+	 */
+
+	ClearHash(cacheMap);
+
+	/*
+	 * If no thread has set the shared value, call the initializer.
+	 */
+
+	Tcl_MutexLock(&pgvPtr->mutex);
+	if ((NULL == pgvPtr->value) && (pgvPtr->proc)) {
+	    pgvPtr->epoch++;
+	    (*(pgvPtr->proc))(&pgvPtr->value, &pgvPtr->numBytes);
+	    if (pgvPtr->value == NULL) {
+		Tcl_Panic("PGV Initializer did not initialize");
+	    }
+	    Tcl_CreateExitHandler(FreePGV, (ClientData) pgvPtr);
+	}
+
+	/*
+	 * Store a copy of the shared value in our epoch-indexed cache.
+	 */
+
+	value = Tcl_NewStringObj(pgvPtr->value, pgvPtr->numBytes);
+	hPtr = Tcl_CreateHashEntry(cacheMap, (char *) pgvPtr->epoch, &dummy);
+	Tcl_MutexUnlock(&pgvPtr->mutex);
+	Tcl_SetHashValue(hPtr, (ClientData) value);
+	Tcl_IncrRefCount(value);
+    }
+    return (Tcl_Obj *) Tcl_GetHashValue(hPtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
  * Tcl_GetNameOfExecutable --
  *
  *	This procedure simply returns a pointer to the internal full