Tcl Source Code

2013-03-04  Don Porter  <[email protected]>

	* generic/tclUtil.c:	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.

2013-02-27  Jan Nijtmans  <[email protected]>

	* generic/regcomp.c:	[Bug 3606139]: missing error check allows
	* tests/regexp.test:    regexp to crash Tcl. Thanks to Tom Lane
	for providing the test-case and the patch.

2013-02-22  Don Porter  <[email protected]>

 * BRACES_UNMATCHED -		1 means that braces aren't properly matched
 *				in the argument.
 */

#define USE_BRACES		2
#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 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
 * that represents a list index in the form, "end-offset".  It is
 * used as a performance optimization in TclGetIntForIndex.  The
 * internal rep is an integer, so no memory management is required
 * for it.

{
    Tcl_DStringAppend(dsPtr, "}", -1);
}

/*
 *----------------------------------------------------------------------
 *
 * 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
 *	an ASCII string using.
 *
 * Results:
 *	The ASCII equivalent of "value" is written at "dst".  It is

					 * printing.  It's ignored now. */
    double value;			/* Value to print as string. */
    char *dst;				/* Where to store converted value;
					 * must have at least TCL_DOUBLE_SPACE
					 * characters. */
{
    char *p, c;
    char format[10];
    Tcl_UniChar ch;
    Tcl_Obj *precisionObj = GetPGV(&precision);


    sprintf(format, "%%.%sg", Tcl_GetString(precisionObj));
    sprintf(dst, format, value);


    /*
     * If the ASCII result looks like an integer, add ".0" so that it
     * doesn't look like an integer anymore.  This prevents floating-point
     * values from being converted to integers unintentionally.
     * Check for ASCII specifically to speed up the function.
     */

    /*
     * When the variable is read, reset its value from our shared
     * value.  This is needed in case the variable was modified in
     * some other interpreter so that this interpreter's value is
     * out of date.
     */



    if (flags & TCL_TRACE_READS) {
	Tcl_SetVar2Ex(interp, name1, name2, GetPGV(&precision),
		flags & TCL_GLOBAL_ONLY);

	return (char *) NULL;
    }

    /*
     * The variable is being written.  Check the new value and disallow
     * it if it isn't reasonable or if this is a safe interpreter (we
     * don't want safe interpreters messing up the precision of other
     * interpreters).
     */

    if (Tcl_IsSafe(interp)) {
	Tcl_SetVar2Ex(interp, name1, name2, GetPGV(&precision),
		flags & TCL_GLOBAL_ONLY);

	return "can't modify precision from a safe interpreter";
    }
    value = Tcl_GetVar2(interp, name1, name2, flags & TCL_GLOBAL_ONLY);
    if (value == NULL) {
	value = "";
    }
    prec = strtoul(value, &end, 10);
    if ((prec <= 0) || (prec > TCL_MAX_PREC)
	    || (end == value) || (*end != 0)) {
	Tcl_SetVar2Ex(interp, name1, name2, GetPGV(&precision),
		flags & TCL_GLOBAL_ONLY);

	return "improper value for precision";
    }


    SetPGV(&precision, Tcl_NewIntObj(prec));
    return (char *) NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * TclNeedSpace --

			(char *) NULL);
	    }
	    return 1;
	}
    }
    return 0;
}

/*
 *----------------------------------------------------------------------
 *
 * 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