diff options
Diffstat (limited to 'generic/tclLiteral.c')
| -rw-r--r-- | generic/tclLiteral.c | 799 |
1 files changed, 439 insertions, 360 deletions
diff --git a/generic/tclLiteral.c b/generic/tclLiteral.c index c4bf5ee..2b0cc7e 100644 --- a/generic/tclLiteral.c +++ b/generic/tclLiteral.c @@ -12,12 +12,11 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclLiteral.c,v 1.25 2005/07/19 00:09:07 dkf Exp $ */ #include "tclInt.h" #include "tclCompile.h" + /* * When there are this many entries per bucket, on average, rebuild a * literal's hash table to make it larger. @@ -26,25 +25,25 @@ #define REBUILD_MULTIPLIER 3 /* - * Procedure prototypes for static procedures in this file: + * Function prototypes for static functions in this file: */ -static int AddLocalLiteralEntry _ANSI_ARGS_(( - CompileEnv *envPtr, LiteralEntry *globalPtr, - int localHash)); -static void ExpandLocalLiteralArray _ANSI_ARGS_(( - CompileEnv *envPtr)); -static unsigned int HashString _ANSI_ARGS_((CONST char *bytes, - int length)); -static void RebuildLiteralTable _ANSI_ARGS_(( - LiteralTable *tablePtr)); +static int AddLocalLiteralEntry(CompileEnv *envPtr, + Tcl_Obj *objPtr, int localHash); +static void ExpandLocalLiteralArray(CompileEnv *envPtr); +static unsigned HashString(const char *string, int length); +#ifdef TCL_COMPILE_DEBUG +static LiteralEntry * LookupLiteralEntry(Tcl_Interp *interp, + Tcl_Obj *objPtr); +#endif +static void RebuildLiteralTable(LiteralTable *tablePtr); /* *---------------------------------------------------------------------- * * TclInitLiteralTable -- * - * This procedure is called to initialize the fields of a literal table + * This function is called to initialize the fields of a literal table * structure for either an interpreter or a compilation's CompileEnv * structure. * @@ -58,13 +57,13 @@ static void RebuildLiteralTable _ANSI_ARGS_(( */ void -TclInitLiteralTable(tablePtr) - register LiteralTable *tablePtr; +TclInitLiteralTable( + register LiteralTable *tablePtr) /* Pointer to table structure, which is * supplied by the caller. */ { #if (TCL_SMALL_HASH_TABLE != 4) - Tcl_Panic("TclInitLiteralTable: TCL_SMALL_HASH_TABLE is %d, not 4\n", + Tcl_Panic("%s: TCL_SMALL_HASH_TABLE is %d, not 4", "TclInitLiteralTable", TCL_SMALL_HASH_TABLE); #endif @@ -73,87 +72,16 @@ TclInitLiteralTable(tablePtr) tablePtr->staticBuckets[2] = tablePtr->staticBuckets[3] = 0; tablePtr->numBuckets = TCL_SMALL_HASH_TABLE; tablePtr->numEntries = 0; - tablePtr->rebuildSize = TCL_SMALL_HASH_TABLE*REBUILD_MULTIPLIER; + tablePtr->rebuildSize = TCL_SMALL_HASH_TABLE * REBUILD_MULTIPLIER; tablePtr->mask = 3; } /* *---------------------------------------------------------------------- * - * TclCleanupLiteralTable -- - * - * This procedure frees the internal representation of every literal in a - * literal table. It is called prior to deleting an interp, so that - * variable refs will be cleaned up properly. - * - * Results: - * None. - * - * Side effects: - * Each literal in the table has its internal representation freed. - * - *---------------------------------------------------------------------- - */ - -void -TclCleanupLiteralTable( interp, tablePtr ) - Tcl_Interp* interp; /* Interpreter containing literals to - * purge. */ - LiteralTable* tablePtr; /* Points to the literal table being - * cleaned. */ -{ - int i; - LiteralEntry* entryPtr; /* Pointer to the current entry in the hash - * table of literals. */ - LiteralEntry* nextPtr; /* Pointer to the next entry in the bucket. */ - Tcl_Obj* objPtr; /* Pointer to a literal object whose internal - * rep is being freed. */ - Tcl_ObjType* typePtr; /* Pointer to the object's type. */ - int didOne; /* Flag for whether we've removed a literal in - * the current bucket. */ - -#ifdef TCL_COMPILE_DEBUG - TclVerifyGlobalLiteralTable( (Interp*) interp ); -#endif /* TCL_COMPILE_DEBUG */ - - for (i=0 ; i<tablePtr->numBuckets ; i++) { - /* - * It is tempting simply to walk each hash bucket once and delete the - * internal representations of each literal in turn. It's also wrong. - * The problem is that freeing a literal's internal representation can - * delete other literals to which it refers, making nextPtr invalid. - * So each time we free an internal rep, we start its bucket over - * again. - */ - - do { - didOne = 0; - entryPtr = tablePtr->buckets[i]; - while (entryPtr != NULL) { - objPtr = entryPtr->objPtr; - nextPtr = entryPtr->nextPtr; - typePtr = objPtr->typePtr; - if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) { - if (objPtr->bytes == NULL) { - Tcl_Panic( "literal without a string rep" ); - } - objPtr->typePtr = NULL; - typePtr->freeIntRepProc(objPtr); - didOne = 1; - } else { - entryPtr = nextPtr; - } - } - } while (didOne); - } -} - -/* - *---------------------------------------------------------------------- - * * TclDeleteLiteralTable -- * - * This procedure frees up everything associated with a literal table + * This function frees up everything associated with a literal table * except for the table's structure itself. It is called when the * interpreter is deleted. * @@ -169,10 +97,10 @@ TclCleanupLiteralTable( interp, tablePtr ) */ void -TclDeleteLiteralTable(interp, tablePtr) - Tcl_Interp *interp; /* Interpreter containing shared literals +TclDeleteLiteralTable( + Tcl_Interp *interp, /* Interpreter containing shared literals * referenced by the table to delete. */ - LiteralTable *tablePtr; /* Points to the literal table to delete. */ + LiteralTable *tablePtr) /* Points to the literal table to delete. */ { LiteralEntry *entryPtr, *nextPtr; Tcl_Obj *objPtr; @@ -191,19 +119,19 @@ TclDeleteLiteralTable(interp, tablePtr) /* * We used to call TclReleaseLiteral for each literal in the table, which * is rather inefficient as it causes one lookup-by-hash for each - * reference to the literal. We now rely at interp-deletion on each + * reference to the literal. We now rely at interp-deletion on each * bytecode object to release its references to the literal Tcl_Obj * without requiring that it updates the global table itself, and deal * here only with the table. */ - for (i = 0; i < tablePtr->numBuckets; i++) { + for (i=0 ; i<tablePtr->numBuckets ; i++) { entryPtr = tablePtr->buckets[i]; while (entryPtr != NULL) { objPtr = entryPtr->objPtr; TclDecrRefCount(objPtr); nextPtr = entryPtr->nextPtr; - ckfree((char *) entryPtr); + ckfree(entryPtr); entryPtr = nextPtr; } } @@ -213,140 +141,96 @@ TclDeleteLiteralTable(interp, tablePtr) */ if (tablePtr->buckets != tablePtr->staticBuckets) { - ckfree((char *) tablePtr->buckets); + ckfree(tablePtr->buckets); } } /* *---------------------------------------------------------------------- * - * TclRegisterLiteral -- + * TclCreateLiteral -- * - * Find, or if necessary create, an object in a CompileEnv literal array - * that has a string representation matching the argument string. + * Find, or if necessary create, an object in the interpreter's literal + * table that has a string representation matching the argument + * string. If nsPtr!=NULL then only literals stored for the namespace are + * considered. * * Results: - * The index in the CompileEnv's literal array that references a shared - * literal matching the string. The object is created if necessary. + * The literal object. If it was created in this call *newPtr is set to + * 1, else 0. NULL is returned if newPtr==NULL and no literal is found. * * Side effects: - * To maximize sharing, we look up the string in the interpreter's global - * literal table. If not found, we create a new shared literal in the - * global table. We then add a reference to the shared literal in the - * CompileEnv's literal array. - * - * If LITERAL_ON_HEAP is set in flags, this procedure is given ownership - * of the string: if an object is created then its string representation - * is set directly from string, otherwise the string is freed. Typically, - * a caller sets LITERAL_ON_HEAP if "string" is an already heap-allocated - * buffer holding the result of backslash substitutions. + * Increments the ref count of the global LiteralEntry since the caller + * now holds a reference. If LITERAL_ON_HEAP is set in flags, this + * function is given ownership of the string: if an object is created + * then its string representation is set directly from string, otherwise + * the string is freed. Typically, a caller sets LITERAL_ON_HEAP if + * "string" is an already heap-allocated buffer holding the result of + * backslash substitutions. * *---------------------------------------------------------------------- */ -int -TclRegisterLiteral(envPtr, bytes, length, flags) - CompileEnv *envPtr; /* Points to the CompileEnv in whose object - * array an object is found or created. */ - register char *bytes; /* Points to string for which to find or - * create an object in CompileEnv's object - * array. */ - int length; /* Number of bytes in the string. If < 0, the - * string consists of all bytes up to the - * first null character. */ - int flags; /* If LITERAL_ON_HEAP then the caller already - * malloc'd bytes and ownership is passed to - * this procedure. If LITERAL_NS_SCOPE then - * the literal shouldnot be shared accross - * namespaces. */ +Tcl_Obj * +TclCreateLiteral( + Interp *iPtr, + char *bytes, /* The start of the string. Note that this is + * not a NUL-terminated string. */ + int length, /* Number of bytes in the string. */ + unsigned hash, /* The string's hash. If -1, it will be + * computed here. */ + int *newPtr, + Namespace *nsPtr, + int flags, + LiteralEntry **globalPtrPtr) { - Interp *iPtr = envPtr->iPtr; - LiteralTable *globalTablePtr = &(iPtr->literalTable); - LiteralTable *localTablePtr = &(envPtr->localLitTable); - register LiteralEntry *globalPtr, *localPtr; - register Tcl_Obj *objPtr; - unsigned int hash; - int localHash, globalHash, objIndex; - Namespace *nsPtr; - - if (length < 0) { - length = (bytes ? strlen(bytes) : 0); - } - hash = HashString(bytes, length); - - /* - * Is the literal already in the CompileEnv's local literal array? If so, - * just return its index. - */ - - localHash = (hash & localTablePtr->mask); - for (localPtr = localTablePtr->buckets[localHash]; - localPtr != NULL; localPtr = localPtr->nextPtr) { - objPtr = localPtr->objPtr; - if ((objPtr->length == length) && ((length == 0) - || ((objPtr->bytes[0] == bytes[0]) - && (memcmp(objPtr->bytes, bytes, (unsigned) length) == 0)))) { - if (flags & LITERAL_ON_HEAP) { - ckfree(bytes); - } - objIndex = (localPtr - envPtr->literalArrayPtr); -#ifdef TCL_COMPILE_DEBUG - TclVerifyLocalLiteralTable(envPtr); -#endif /*TCL_COMPILE_DEBUG*/ - - return objIndex; - } - } - - /* - * The literal is new to this CompileEnv. Should it be shared accross - * namespaces? If it is a fully qualified name, the namespace - * specification is not needed to avoid sharing. - */ - - if ((flags & LITERAL_NS_SCOPE) && iPtr->varFramePtr - && ((length <2) || (bytes[0] != ':') || (bytes[1] != ':'))) { - nsPtr = iPtr->varFramePtr->nsPtr; - } else { - nsPtr = NULL; - } + LiteralTable *globalTablePtr = &iPtr->literalTable; + LiteralEntry *globalPtr; + int globalHash; + Tcl_Obj *objPtr; /* * Is it in the interpreter's global literal table? */ + if (hash == (unsigned) -1) { + hash = HashString(bytes, length); + } globalHash = (hash & globalTablePtr->mask); - for (globalPtr = globalTablePtr->buckets[globalHash]; - globalPtr != NULL; globalPtr = globalPtr->nextPtr) { + for (globalPtr=globalTablePtr->buckets[globalHash] ; globalPtr!=NULL; + globalPtr = globalPtr->nextPtr) { objPtr = globalPtr->objPtr; if ((globalPtr->nsPtr == nsPtr) && (objPtr->length == length) && ((length == 0) || ((objPtr->bytes[0] == bytes[0]) && (memcmp(objPtr->bytes, bytes, (unsigned) length) == 0)))) { /* - * A global literal was found. Add an entry to the CompileEnv's - * local literal array. + * A literal was found: return it */ + if (newPtr) { + *newPtr = 0; + } + if (globalPtrPtr) { + *globalPtrPtr = globalPtr; + } if (flags & LITERAL_ON_HEAP) { ckfree(bytes); } - objIndex = AddLocalLiteralEntry(envPtr, globalPtr, localHash); -#ifdef TCL_COMPILE_DEBUG - if (globalPtr->refCount < 1) { - Tcl_Panic("TclRegisterLiteral: global literal \"%.*s\" had bad refCount %d", - (length>60? 60 : length), bytes, globalPtr->refCount); - } - TclVerifyLocalLiteralTable(envPtr); -#endif /*TCL_COMPILE_DEBUG*/ - return objIndex; + globalPtr->refCount++; + return objPtr; } } + if (!newPtr) { + if (flags & LITERAL_ON_HEAP) { + ckfree(bytes); + } + return NULL; + } /* * The literal is new to the interpreter. Add it to the global literal - * table then add an entry to the CompileEnv's local literal array. - * Convert the object to an integer object if possible. + * table. */ TclNewObj(objPtr); @@ -358,35 +242,16 @@ TclRegisterLiteral(envPtr, bytes, length, flags) TclInitStringRep(objPtr, bytes, length); } -#if 0 - if (TclLooksLikeInt(bytes, length)) { - /* - * From here we use the objPtr, because it is NULL terminated - */ - - long n; - char buf[TCL_INTEGER_SPACE]; - - if (TclGetLong((Tcl_Interp *) NULL, objPtr->bytes, &n) == TCL_OK) { - TclFormatInt(buf, n); - if (strcmp(objPtr->bytes, buf) == 0) { - objPtr->internalRep.longValue = n; - objPtr->typePtr = &tclIntType; - } - } - } -#endif - #ifdef TCL_COMPILE_DEBUG - if (TclLookupLiteralEntry((Tcl_Interp *) iPtr, objPtr) != NULL) { - Tcl_Panic("TclRegisterLiteral: literal \"%.*s\" found globally but shouldn't be", - (length>60? 60 : length), bytes); + if (LookupLiteralEntry((Tcl_Interp *) iPtr, objPtr) != NULL) { + Tcl_Panic("%s: literal \"%.*s\" found globally but shouldn't be", + "TclRegisterLiteral", (length>60? 60 : length), bytes); } #endif - globalPtr = (LiteralEntry *) ckalloc((unsigned) sizeof(LiteralEntry)); + globalPtr = ckalloc(sizeof(LiteralEntry)); globalPtr->objPtr = objPtr; - globalPtr->refCount = 0; + globalPtr->refCount = 1; globalPtr->nsPtr = nsPtr; globalPtr->nextPtr = globalTablePtr->buckets[globalHash]; globalTablePtr->buckets[globalHash] = globalPtr; @@ -400,11 +265,9 @@ TclRegisterLiteral(envPtr, bytes, length, flags) if (globalTablePtr->numEntries >= globalTablePtr->rebuildSize) { RebuildLiteralTable(globalTablePtr); } - objIndex = AddLocalLiteralEntry(envPtr, globalPtr, localHash); #ifdef TCL_COMPILE_DEBUG TclVerifyGlobalLiteralTable(iPtr); - TclVerifyLocalLiteralTable(envPtr); { LiteralEntry *entryPtr; int found, i; @@ -419,8 +282,8 @@ TclRegisterLiteral(envPtr, bytes, length, flags) } } if (!found) { - Tcl_Panic("TclRegisterLiteral: literal \"%.*s\" wasn't global", - (length>60? 60 : length), bytes); + Tcl_Panic("%s: literal \"%.*s\" wasn't global", + "TclRegisterLiteral", (length>60? 60 : length), bytes); } } #endif /*TCL_COMPILE_DEBUG*/ @@ -432,13 +295,162 @@ TclRegisterLiteral(envPtr, bytes, length, flags) iPtr->stats.literalCount[TclLog2(length)]++; #endif /*TCL_COMPILE_STATS*/ + if (globalPtrPtr) { + *globalPtrPtr = globalPtr; + } + *newPtr = 1; + return objPtr; +} + +/* + *---------------------------------------------------------------------- + * + * TclFetchLiteral -- + * + * Fetch from a CompileEnv the literal value identified by an index + * value, as returned by a prior call to TclRegisterLiteral(). + * + * Results: + * The literal value, or NULL if the index is out of range. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +TclFetchLiteral( + CompileEnv *envPtr, /* Points to the CompileEnv from which to + * fetch the registered literal value. */ + unsigned int index) /* Index of the desired literal, as returned + * by prior call to TclRegisterLiteral() */ +{ + if (index >= (unsigned int) envPtr->literalArrayNext) { + return NULL; + } + return envPtr->literalArrayPtr[index].objPtr; +} + +/* + *---------------------------------------------------------------------- + * + * TclRegisterLiteral -- + * + * Find, or if necessary create, an object in a CompileEnv literal array + * that has a string representation matching the argument string. + * + * Results: + * The index in the CompileEnv's literal array that references a shared + * literal matching the string. The object is created if necessary. + * + * Side effects: + * To maximize sharing, we look up the string in the interpreter's global + * literal table. If not found, we create a new shared literal in the + * global table. We then add a reference to the shared literal in the + * CompileEnv's literal array. + * + * If LITERAL_ON_HEAP is set in flags, this function is given ownership + * of the string: if an object is created then its string representation + * is set directly from string, otherwise the string is freed. Typically, + * a caller sets LITERAL_ON_HEAP if "string" is an already heap-allocated + * buffer holding the result of backslash substitutions. + * + *---------------------------------------------------------------------- + */ + +int +TclRegisterLiteral( + void *ePtr, /* Points to the CompileEnv in whose object + * array an object is found or created. */ + register char *bytes, /* Points to string for which to find or + * create an object in CompileEnv's object + * array. */ + int length, /* Number of bytes in the string. If < 0, the + * string consists of all bytes up to the + * first null character. */ + int flags) /* If LITERAL_ON_HEAP then the caller already + * malloc'd bytes and ownership is passed to + * this function. If LITERAL_CMD_NAME then + * the literal should not be shared accross + * namespaces. */ +{ + CompileEnv *envPtr = ePtr; + Interp *iPtr = envPtr->iPtr; + LiteralTable *localTablePtr = &envPtr->localLitTable; + LiteralEntry *globalPtr, *localPtr; + Tcl_Obj *objPtr; + unsigned hash; + int localHash, objIndex, new; + Namespace *nsPtr; + + if (length < 0) { + length = (bytes ? strlen(bytes) : 0); + } + hash = HashString(bytes, length); + + /* + * Is the literal already in the CompileEnv's local literal array? If so, + * just return its index. + */ + + localHash = (hash & localTablePtr->mask); + for (localPtr=localTablePtr->buckets[localHash] ; localPtr!=NULL; + localPtr = localPtr->nextPtr) { + objPtr = localPtr->objPtr; + if ((objPtr->length == length) && ((length == 0) + || ((objPtr->bytes[0] == bytes[0]) + && (memcmp(objPtr->bytes, bytes, (unsigned) length) == 0)))) { + if (flags & LITERAL_ON_HEAP) { + ckfree(bytes); + } + objIndex = (localPtr - envPtr->literalArrayPtr); +#ifdef TCL_COMPILE_DEBUG + TclVerifyLocalLiteralTable(envPtr); +#endif /*TCL_COMPILE_DEBUG*/ + + return objIndex; + } + } + + /* + * The literal is new to this CompileEnv. If it is a command name, avoid + * sharing it accross namespaces, and try not to share it with non-cmd + * literals. Note that FQ command names can be shared, so that we register + * the namespace as the interp's global NS. + */ + + if (flags & LITERAL_CMD_NAME) { + if ((length >= 2) && (bytes[0] == ':') && (bytes[1] == ':')) { + nsPtr = iPtr->globalNsPtr; + } else { + nsPtr = iPtr->varFramePtr->nsPtr; + } + } else { + nsPtr = NULL; + } + + /* + * Is it in the interpreter's global literal table? If not, create it. + */ + + objPtr = TclCreateLiteral(iPtr, bytes, length, hash, &new, nsPtr, flags, + &globalPtr); + objIndex = AddLocalLiteralEntry(envPtr, objPtr, localHash); + +#ifdef TCL_COMPILE_DEBUG + if (globalPtr->refCount < 1) { + Tcl_Panic("%s: global literal \"%.*s\" had bad refCount %d", + "TclRegisterLiteral", (length>60? 60 : length), bytes, + globalPtr->refCount); + } + TclVerifyLocalLiteralTable(envPtr); +#endif /*TCL_COMPILE_DEBUG*/ return objIndex; } +#ifdef TCL_COMPILE_DEBUG /* *---------------------------------------------------------------------- * - * TclLookupLiteralEntry -- + * LookupLiteralEntry -- * * Finds the LiteralEntry that corresponds to a literal Tcl object * holding a literal. @@ -452,24 +464,24 @@ TclRegisterLiteral(envPtr, bytes, length, flags) *---------------------------------------------------------------------- */ -LiteralEntry * -TclLookupLiteralEntry(interp, objPtr) - Tcl_Interp *interp; /* Interpreter for which objPtr was created to +static LiteralEntry * +LookupLiteralEntry( + Tcl_Interp *interp, /* Interpreter for which objPtr was created to * hold a literal. */ - register Tcl_Obj *objPtr; /* Points to a Tcl object holding a literal + register Tcl_Obj *objPtr) /* Points to a Tcl object holding a literal * that was previously created by a call to * TclRegisterLiteral. */ { Interp *iPtr = (Interp *) interp; - LiteralTable *globalTablePtr = &(iPtr->literalTable); + LiteralTable *globalTablePtr = &iPtr->literalTable; register LiteralEntry *entryPtr; - char *bytes; + const char *bytes; int length, globalHash; - bytes = Tcl_GetStringFromObj(objPtr, &length); + bytes = TclGetStringFromObj(objPtr, &length); globalHash = (HashString(bytes, length) & globalTablePtr->mask); - for (entryPtr = globalTablePtr->buckets[globalHash]; - entryPtr != NULL; entryPtr = entryPtr->nextPtr) { + for (entryPtr=globalTablePtr->buckets[globalHash] ; entryPtr!=NULL; + entryPtr=entryPtr->nextPtr) { if (entryPtr->objPtr == objPtr) { return entryPtr; } @@ -477,6 +489,7 @@ TclLookupLiteralEntry(interp, objPtr) return NULL; } +#endif /* *---------------------------------------------------------------------- * @@ -498,27 +511,27 @@ TclLookupLiteralEntry(interp, objPtr) */ void -TclHideLiteral(interp, envPtr, index) - Tcl_Interp *interp; /* Interpreter for which objPtr was created to +TclHideLiteral( + Tcl_Interp *interp, /* Interpreter for which objPtr was created to * hold a literal. */ - register CompileEnv *envPtr;/* Points to CompileEnv whose literal array + register CompileEnv *envPtr,/* Points to CompileEnv whose literal array * contains the entry being hidden. */ - int index; /* The index of the entry in the literal + int index) /* The index of the entry in the literal * array. */ { LiteralEntry **nextPtrPtr, *entryPtr, *lPtr; - LiteralTable *localTablePtr = &(envPtr->localLitTable); + LiteralTable *localTablePtr = &envPtr->localLitTable; int localHash, length; - char *bytes; + const char *bytes; Tcl_Obj *newObjPtr; - lPtr = &(envPtr->literalArrayPtr[index]); + lPtr = &envPtr->literalArrayPtr[index]; /* * To avoid unwanted sharing we need to copy the object and remove it from - * the local and global literal tables. It still has a slot in the - * literal array so it can be referred to by byte codes, but it will not - * be matched by literal searches. + * the local and global literal tables. It still has a slot in the literal + * array so it can be referred to by byte codes, but it will not be + * matched by literal searches. */ newObjPtr = Tcl_DuplicateObj(lPtr->objPtr); @@ -526,7 +539,7 @@ TclHideLiteral(interp, envPtr, index) TclReleaseLiteral(interp, lPtr->objPtr); lPtr->objPtr = newObjPtr; - bytes = Tcl_GetStringFromObj(newObjPtr, &length); + bytes = TclGetStringFromObj(newObjPtr, &length); localHash = (HashString(bytes, length) & localTablePtr->mask); nextPtrPtr = &localTablePtr->buckets[localHash]; @@ -563,11 +576,11 @@ TclHideLiteral(interp, envPtr, index) */ int -TclAddLiteralObj(envPtr, objPtr, litPtrPtr) - register CompileEnv *envPtr;/* Points to CompileEnv in whose literal array +TclAddLiteralObj( + register CompileEnv *envPtr,/* Points to CompileEnv in whose literal array * the object is to be inserted. */ - Tcl_Obj *objPtr; /* The object to insert into the array. */ - LiteralEntry **litPtrPtr; /* The location where the pointer to the new + Tcl_Obj *objPtr, /* The object to insert into the array. */ + LiteralEntry **litPtrPtr) /* The location where the pointer to the new * literal entry should be stored. May be * NULL. */ { @@ -580,7 +593,7 @@ TclAddLiteralObj(envPtr, objPtr, litPtrPtr) objIndex = envPtr->literalArrayNext; envPtr->literalArrayNext++; - lPtr = &(envPtr->literalArrayPtr[objIndex]); + lPtr = &envPtr->literalArrayPtr[objIndex]; lPtr->objPtr = objPtr; Tcl_IncrRefCount(objPtr); lPtr->refCount = -1; /* i.e., unused */ @@ -605,27 +618,24 @@ TclAddLiteralObj(envPtr, objPtr, litPtrPtr) * literal. * * Side effects: - * Increments the ref count of the global LiteralEntry since the - * CompileEnv now refers to the literal. Expands the literal array if - * necessary. May rebuild the hash bucket array of the CompileEnv's - * literal array if it becomes too large. + * Expands the literal array if necessary. May rebuild the hash bucket + * array of the CompileEnv's literal array if it becomes too large. * *---------------------------------------------------------------------- */ static int -AddLocalLiteralEntry(envPtr, globalPtr, localHash) - register CompileEnv *envPtr;/* Points to CompileEnv in whose literal array +AddLocalLiteralEntry( + register CompileEnv *envPtr,/* Points to CompileEnv in whose literal array * the object is to be inserted. */ - LiteralEntry *globalPtr; /* Points to the global LiteralEntry for the - * literal to add to the CompileEnv. */ - int localHash; /* Hash value for the literal's string. */ + Tcl_Obj *objPtr, /* The literal to add to the CompileEnv. */ + int localHash) /* Hash value for the literal's string. */ { - register LiteralTable *localTablePtr = &(envPtr->localLitTable); + register LiteralTable *localTablePtr = &envPtr->localLitTable; LiteralEntry *localPtr; int objIndex; - objIndex = TclAddLiteralObj(envPtr, globalPtr->objPtr, &localPtr); + objIndex = TclAddLiteralObj(envPtr, objPtr, &localPtr); /* * Add the literal to the local table. @@ -635,8 +645,6 @@ AddLocalLiteralEntry(envPtr, globalPtr, localHash) localTablePtr->buckets[localHash] = localPtr; localTablePtr->numEntries++; - globalPtr->refCount++; - /* * If the CompileEnv's local literal table has exceeded a decent size, * rebuild it with more buckets. @@ -656,16 +664,16 @@ AddLocalLiteralEntry(envPtr, globalPtr, localHash) for (i=0 ; i<localTablePtr->numBuckets ; i++) { for (localPtr=localTablePtr->buckets[i] ; localPtr!=NULL ; localPtr=localPtr->nextPtr) { - if (localPtr->objPtr == globalPtr->objPtr) { + if (localPtr->objPtr == objPtr) { found = 1; } } } if (!found) { - bytes = Tcl_GetStringFromObj(globalPtr->objPtr, &length); - Tcl_Panic("AddLocalLiteralEntry: literal \"%.*s\" wasn't found locally", - (length>60? 60 : length), bytes); + bytes = Tcl_GetStringFromObj(objPtr, &length); + Tcl_Panic("%s: literal \"%.*s\" wasn't found locally", + "AddLocalLiteralEntry", (length>60? 60 : length), bytes); } } #endif /*TCL_COMPILE_DEBUG*/ @@ -678,7 +686,7 @@ AddLocalLiteralEntry(envPtr, globalPtr, localHash) * * ExpandLocalLiteralArray -- * - * Procedure that uses malloc to allocate more storage for a CompileEnv's + * Function that uses malloc to allocate more storage for a CompileEnv's * local literal array. * * Results: @@ -694,8 +702,8 @@ AddLocalLiteralEntry(envPtr, globalPtr, localHash) */ static void -ExpandLocalLiteralArray(envPtr) - register CompileEnv *envPtr;/* Points to the CompileEnv whose object array +ExpandLocalLiteralArray( + register CompileEnv *envPtr)/* Points to the CompileEnv whose object array * must be enlarged. */ { /* @@ -703,46 +711,47 @@ ExpandLocalLiteralArray(envPtr) * 0 and (envPtr->literalArrayNext - 1) [inclusive]. */ - LiteralTable *localTablePtr = &(envPtr->localLitTable); + LiteralTable *localTablePtr = &envPtr->localLitTable; int currElems = envPtr->literalArrayNext; size_t currBytes = (currElems * sizeof(LiteralEntry)); - register LiteralEntry *currArrayPtr = envPtr->literalArrayPtr; - register LiteralEntry *newArrayPtr = - (LiteralEntry *) ckalloc((unsigned) (2 * currBytes)); + LiteralEntry *currArrayPtr = envPtr->literalArrayPtr; + LiteralEntry *newArrayPtr; int i; - /* - * Copy from the old literal array to the new, then update the local - * literal table's bucket array. - */ + if (envPtr->mallocedLiteralArray) { + newArrayPtr = ckrealloc(currArrayPtr, 2 * currBytes); + } else { + /* + * envPtr->literalArrayPtr isn't a ckalloc'd pointer, so we must + * code a ckrealloc equivalent for ourselves. + */ - memcpy((VOID *) newArrayPtr, (VOID *) currArrayPtr, currBytes); - for (i=0 ; i<currElems ; i++) { - if (currArrayPtr[i].nextPtr == NULL) { - newArrayPtr[i].nextPtr = NULL; - } else { - newArrayPtr[i].nextPtr = - newArrayPtr + (currArrayPtr[i].nextPtr - currArrayPtr); - } - } - for (i=0 ; i<localTablePtr->numBuckets ; i++) { - if (localTablePtr->buckets[i] != NULL) { - localTablePtr->buckets[i] = - newArrayPtr + (localTablePtr->buckets[i] - currArrayPtr); - } + newArrayPtr = ckalloc(2 * currBytes); + memcpy(newArrayPtr, currArrayPtr, currBytes); + envPtr->mallocedLiteralArray = 1; } /* - * Free the old literal array if needed, and mark the new literal array as - * malloced. + * Update the local literal table's bucket array. */ - if (envPtr->mallocedLiteralArray) { - ckfree((char *) currArrayPtr); + if (currArrayPtr != newArrayPtr) { + for (i=0 ; i<currElems ; i++) { + if (newArrayPtr[i].nextPtr != NULL) { + newArrayPtr[i].nextPtr = newArrayPtr + + (newArrayPtr[i].nextPtr - currArrayPtr); + } + } + for (i=0 ; i<localTablePtr->numBuckets ; i++) { + if (localTablePtr->buckets[i] != NULL) { + localTablePtr->buckets[i] = newArrayPtr + + (localTablePtr->buckets[i] - currArrayPtr); + } + } } + envPtr->literalArrayPtr = newArrayPtr; envPtr->literalArrayEnd = (2 * currElems); - envPtr->mallocedLiteralArray = 1; } /* @@ -750,7 +759,7 @@ ExpandLocalLiteralArray(envPtr) * * TclReleaseLiteral -- * - * This procedure releases a reference to one of the shared Tcl objects + * This function releases a reference to one of the shared Tcl objects * that hold literals. It is called to release the literals referenced by * a ByteCode that is being destroyed, and it is also called by * TclDeleteLiteralTable. @@ -767,20 +776,25 @@ ExpandLocalLiteralArray(envPtr) */ void -TclReleaseLiteral(interp, objPtr) - Tcl_Interp *interp; /* Interpreter for which objPtr was created to +TclReleaseLiteral( + Tcl_Interp *interp, /* Interpreter for which objPtr was created to * hold a literal. */ - register Tcl_Obj *objPtr; /* Points to a literal object that was + register Tcl_Obj *objPtr) /* Points to a literal object that was * previously created by a call to * TclRegisterLiteral. */ { Interp *iPtr = (Interp *) interp; - LiteralTable *globalTablePtr = &(iPtr->literalTable); + LiteralTable *globalTablePtr; register LiteralEntry *entryPtr, *prevPtr; - char *bytes; + const char *bytes; int length, index; - bytes = Tcl_GetStringFromObj(objPtr, &length); + if (iPtr == NULL) { + goto done; + } + + globalTablePtr = &iPtr->literalTable; + bytes = TclGetStringFromObj(objPtr, &length); index = (HashString(bytes, length) & globalTablePtr->mask); /* @@ -789,9 +803,8 @@ TclReleaseLiteral(interp, objPtr) * local literal. */ - for (prevPtr = NULL, entryPtr = globalTablePtr->buckets[index]; - entryPtr != NULL; - prevPtr = entryPtr, entryPtr = entryPtr->nextPtr) { + for (prevPtr=NULL, entryPtr=globalTablePtr->buckets[index]; + entryPtr!=NULL ; prevPtr=entryPtr, entryPtr=entryPtr->nextPtr) { if (entryPtr->objPtr == objPtr) { entryPtr->refCount--; @@ -807,7 +820,7 @@ TclReleaseLiteral(interp, objPtr) } else { prevPtr->nextPtr = entryPtr->nextPtr; } - ckfree((char *) entryPtr); + ckfree(entryPtr); globalTablePtr->numEntries--; TclDecrRefCount(objPtr); @@ -824,6 +837,7 @@ TclReleaseLiteral(interp, objPtr) * Remove the reference corresponding to the local literal table entry. */ + done: Tcl_DecrRefCount(objPtr); } @@ -844,13 +858,12 @@ TclReleaseLiteral(interp, objPtr) *---------------------------------------------------------------------- */ -static unsigned int -HashString(bytes, length) - register CONST char *bytes; /* String for which to compute hash value. */ - int length; /* Number of bytes in the string. */ +static unsigned +HashString( + register const char *string, /* String for which to compute hash value. */ + int length) /* Number of bytes in the string. */ { - register unsigned int result; - register int i; + register unsigned int result = 0; /* * I tried a zillion different hash functions and asked many other people @@ -860,17 +873,33 @@ HashString(bytes, length) * following reasons: * * 1. Multiplying by 10 is perfect for keys that are decimal strings, and - * multiplying by 9 is just about as good. - * 2. Times-9 is (shift-left-3) plus (old). This means that each - * character's bits hang around in the low-order bits of the hash value - * for ever, plus they spread fairly rapidly up to the high-order bits - * to fill out the hash value. This seems works well both for decimal - * and non-decimal strings. + * multiplying by 9 is just about as good. + * 2. Times-9 is (shift-left-3) plus (old). This means that each + * character's bits hang around in the low-order bits of the hash value + * for ever, plus they spread fairly rapidly up to the high-order bits + * to fill out the hash value. This seems works well both for decimal + * and non-decimal strings. + * + * Note that this function is very weak against malicious strings; it's + * very easy to generate multiple keys that have the same hashcode. On the + * other hand, that hardly ever actually occurs and this function *is* + * very cheap, even by comparison with industry-standard hashes like FNV. + * If real strength of hash is required though, use a custom hash based on + * Bob Jenkins's lookup3(), but be aware that it's significantly slower. + * Tcl scripts tend to not have a big issue in this area, and literals + * mostly aren't looked up by name anyway. + * + * See also HashStringKey in tclHash.c. + * See also TclObjHashKey in tclObj.c. + * + * See [tcl-Feature Request #2958832] */ - result = 0; - for (i=0 ; i<length ; i++) { - result += (result<<3) + bytes[i]; + if (length > 0) { + result = UCHAR(*string); + while (--length) { + result += (result << 3) + UCHAR(*++string); + } } return result; } @@ -880,7 +909,7 @@ HashString(bytes, length) * * RebuildLiteralTable -- * - * This procedure is invoked when the ratio of entries to hash buckets + * This function is invoked when the ratio of entries to hash buckets * becomes too large in a local or global literal table. It allocates a * larger bucket array and moves the entries into the new buckets. * @@ -894,15 +923,15 @@ HashString(bytes, length) */ static void -RebuildLiteralTable(tablePtr) - register LiteralTable *tablePtr; +RebuildLiteralTable( + register LiteralTable *tablePtr) /* Local or global table to enlarge. */ { LiteralEntry **oldBuckets; register LiteralEntry **oldChainPtr, **newChainPtr; register LiteralEntry *entryPtr; LiteralEntry **bucketPtr; - char *bytes; + const char *bytes; int oldSize, count, index, length; oldSize = tablePtr->numBuckets; @@ -914,11 +943,9 @@ RebuildLiteralTable(tablePtr) */ tablePtr->numBuckets *= 4; - tablePtr->buckets = (LiteralEntry **) ckalloc((unsigned) - (tablePtr->numBuckets * sizeof(LiteralEntry *))); - for (count = tablePtr->numBuckets, newChainPtr = tablePtr->buckets; - count > 0; - count--, newChainPtr++) { + tablePtr->buckets = ckalloc(tablePtr->numBuckets * sizeof(LiteralEntry*)); + for (count=tablePtr->numBuckets, newChainPtr=tablePtr->buckets; + count>0 ; count--, newChainPtr++) { *newChainPtr = NULL; } tablePtr->rebuildSize *= 4; @@ -930,11 +957,11 @@ RebuildLiteralTable(tablePtr) for (oldChainPtr=oldBuckets ; oldSize>0 ; oldSize--,oldChainPtr++) { for (entryPtr=*oldChainPtr ; entryPtr!=NULL ; entryPtr=*oldChainPtr) { - bytes = Tcl_GetStringFromObj(entryPtr->objPtr, &length); + bytes = TclGetStringFromObj(entryPtr->objPtr, &length); index = (HashString(bytes, length) & tablePtr->mask); *oldChainPtr = entryPtr->nextPtr; - bucketPtr = &(tablePtr->buckets[index]); + bucketPtr = &tablePtr->buckets[index]; entryPtr->nextPtr = *bucketPtr; *bucketPtr = entryPtr; } @@ -945,7 +972,52 @@ RebuildLiteralTable(tablePtr) */ if (oldBuckets != tablePtr->staticBuckets) { - ckfree((char *) oldBuckets); + ckfree(oldBuckets); + } +} + +/* + *---------------------------------------------------------------------- + * + * TclInvalidateCmdLiteral -- + * + * Invalidate a command literal entry, if present in the literal hash + * tables, by resetting its internal representation. This invalidation + * leaves it in the literal tables and in existing literal arrays. As a + * result, existing references continue to work but we force a fresh + * command look-up upon the next use (see, in particular, + * TclSetCmdNameObj()). + * + * Results: + * None. + * + * Side effects: + * Resets the internal representation of the CmdName Tcl_Obj + * using TclFreeIntRep(). + * + *---------------------------------------------------------------------- + */ + +void +TclInvalidateCmdLiteral( + Tcl_Interp *interp, /* Interpreter for which to invalidate a + * command literal. */ + const char *name, /* Points to the start of the cmd literal + * name. */ + Namespace *nsPtr) /* The namespace for which to lookup and + * invalidate a cmd literal. */ +{ + Interp *iPtr = (Interp *) interp; + Tcl_Obj *literalObjPtr = TclCreateLiteral(iPtr, (char *) name, + strlen(name), -1, NULL, nsPtr, 0, NULL); + + if (literalObjPtr != NULL) { + if (literalObjPtr->typePtr == &tclCmdNameType) { + TclFreeIntRep(literalObjPtr); + } + /* Balance the refcount effects of TclCreateLiteral() above */ + Tcl_IncrRefCount(literalObjPtr); + TclReleaseLiteral(interp, literalObjPtr); } } @@ -969,8 +1041,8 @@ RebuildLiteralTable(tablePtr) */ char * -TclLiteralStats(tablePtr) - LiteralTable *tablePtr; /* Table for which to produce stats. */ +TclLiteralStats( + LiteralTable *tablePtr) /* Table for which to produce stats. */ { #define NUM_COUNTERS 10 int count[NUM_COUNTERS], overflow, i, j; @@ -983,15 +1055,15 @@ TclLiteralStats(tablePtr) * number of entries in the chain. */ - for (i = 0; i < NUM_COUNTERS; i++) { + for (i=0 ; i<NUM_COUNTERS ; i++) { count[i] = 0; } overflow = 0; average = 0.0; - for (i = 0; i < tablePtr->numBuckets; i++) { + for (i=0 ; i<tablePtr->numBuckets ; i++) { j = 0; - for (entryPtr = tablePtr->buckets[i]; entryPtr != NULL; - entryPtr = entryPtr->nextPtr) { + for (entryPtr=tablePtr->buckets[i] ; entryPtr!=NULL; + entryPtr=entryPtr->nextPtr) { j++; } if (j < NUM_COUNTERS) { @@ -1007,11 +1079,11 @@ TclLiteralStats(tablePtr) * Print out the histogram and a few other pieces of information. */ - result = (char *) ckalloc((unsigned) ((NUM_COUNTERS*60) + 300)); + result = ckalloc(NUM_COUNTERS*60 + 300); sprintf(result, "%d entries in table, %d buckets\n", tablePtr->numEntries, tablePtr->numBuckets); p = result + strlen(result); - for (i = 0; i < NUM_COUNTERS; i++) { + for (i=0 ; i<NUM_COUNTERS ; i++) { sprintf(p, "number of buckets with %d entries: %d\n", i, count[i]); p += strlen(p); @@ -1042,40 +1114,44 @@ TclLiteralStats(tablePtr) */ void -TclVerifyLocalLiteralTable(envPtr) - CompileEnv *envPtr; /* Points to CompileEnv whose literal table is +TclVerifyLocalLiteralTable( + CompileEnv *envPtr) /* Points to CompileEnv whose literal table is * to be validated. */ { - register LiteralTable *localTablePtr = &(envPtr->localLitTable); + register LiteralTable *localTablePtr = &envPtr->localLitTable; register LiteralEntry *localPtr; char *bytes; register int i; int length, count; count = 0; - for (i = 0; i < localTablePtr->numBuckets; i++) { - for (localPtr = localTablePtr->buckets[i]; - localPtr != NULL; localPtr = localPtr->nextPtr) { + for (i=0 ; i<localTablePtr->numBuckets ; i++) { + for (localPtr=localTablePtr->buckets[i] ; localPtr!=NULL; + localPtr=localPtr->nextPtr) { count++; if (localPtr->refCount != -1) { bytes = Tcl_GetStringFromObj(localPtr->objPtr, &length); - Tcl_Panic("TclVerifyLocalLiteralTable: local literal \"%.*s\" had bad refCount %d", + Tcl_Panic("%s: local literal \"%.*s\" had bad refCount %d", + "TclVerifyLocalLiteralTable", (length>60? 60 : length), bytes, localPtr->refCount); } - if (TclLookupLiteralEntry((Tcl_Interp *) envPtr->iPtr, + if (LookupLiteralEntry((Tcl_Interp *) envPtr->iPtr, localPtr->objPtr) == NULL) { bytes = Tcl_GetStringFromObj(localPtr->objPtr, &length); - Tcl_Panic("TclVerifyLocalLiteralTable: local literal \"%.*s\" is not global", + Tcl_Panic("%s: local literal \"%.*s\" is not global", + "TclVerifyLocalLiteralTable", (length>60? 60 : length), bytes); } if (localPtr->objPtr->bytes == NULL) { - Tcl_Panic("TclVerifyLocalLiteralTable: literal has NULL string rep"); + Tcl_Panic("%s: literal has NULL string rep", + "TclVerifyLocalLiteralTable"); } } } if (count != localTablePtr->numEntries) { - Tcl_Panic("TclVerifyLocalLiteralTable: local literal table had %d entries, should be %d", - count, localTablePtr->numEntries); + Tcl_Panic("%s: local literal table had %d entries, should be %d", + "TclVerifyLocalLiteralTable", count, + localTablePtr->numEntries); } } @@ -1096,34 +1172,37 @@ TclVerifyLocalLiteralTable(envPtr) */ void -TclVerifyGlobalLiteralTable(iPtr) - Interp *iPtr; /* Points to interpreter whose global literal +TclVerifyGlobalLiteralTable( + Interp *iPtr) /* Points to interpreter whose global literal * table is to be validated. */ { - register LiteralTable *globalTablePtr = &(iPtr->literalTable); + register LiteralTable *globalTablePtr = &iPtr->literalTable; register LiteralEntry *globalPtr; char *bytes; register int i; int length, count; count = 0; - for (i = 0; i < globalTablePtr->numBuckets; i++) { - for (globalPtr = globalTablePtr->buckets[i]; - globalPtr != NULL; globalPtr = globalPtr->nextPtr) { + for (i=0 ; i<globalTablePtr->numBuckets ; i++) { + for (globalPtr=globalTablePtr->buckets[i] ; globalPtr!=NULL; + globalPtr=globalPtr->nextPtr) { count++; if (globalPtr->refCount < 1) { bytes = Tcl_GetStringFromObj(globalPtr->objPtr, &length); - Tcl_Panic("TclVerifyGlobalLiteralTable: global literal \"%.*s\" had bad refCount %d", + Tcl_Panic("%s: global literal \"%.*s\" had bad refCount %d", + "TclVerifyGlobalLiteralTable", (length>60? 60 : length), bytes, globalPtr->refCount); } if (globalPtr->objPtr->bytes == NULL) { - Tcl_Panic("TclVerifyGlobalLiteralTable: literal has NULL string rep"); + Tcl_Panic("%s: literal has NULL string rep", + "TclVerifyGlobalLiteralTable"); } } } if (count != globalTablePtr->numEntries) { - Tcl_Panic("TclVerifyGlobalLiteralTable: global literal table had %d entries, should be %d", - count, globalTablePtr->numEntries); + Tcl_Panic("%s: global literal table had %d entries, should be %d", + "TclVerifyGlobalLiteralTable", count, + globalTablePtr->numEntries); } } #endif /*TCL_COMPILE_DEBUG*/ |