diff options
Diffstat (limited to 'generic/tclLiteral.c')
| -rw-r--r-- | generic/tclLiteral.c | 855 |
1 files changed, 453 insertions, 402 deletions
diff --git a/generic/tclLiteral.c b/generic/tclLiteral.c index 0c88303..2c91b82 100644 --- a/generic/tclLiteral.c +++ b/generic/tclLiteral.c @@ -1,76 +1,74 @@ -/* +/* * tclLiteral.c -- * - * Implementation of the global and ByteCode-local literal tables - * used to manage the Tcl objects created for literal values during - * compilation of Tcl scripts. This implementation borrows heavily - * from the more general hashtable implementation of Tcl hash tables - * that appears in tclHash.c. + * Implementation of the global and ByteCode-local literal tables used to + * manage the Tcl objects created for literal values during compilation + * of Tcl scripts. This implementation borrows heavily from the more + * general hashtable implementation of Tcl hash tables that appears in + * tclHash.c. * * Copyright (c) 1997-1998 Sun Microsystems, Inc. + * Copyright (c) 2004 by Kevin B. Kenny. All rights reserved. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #include "tclCompile.h" -#include "tclPort.h" + /* - * When there are this many entries per bucket, on average, rebuild - * a literal's hash table to make it larger. + * When there are this many entries per bucket, on average, rebuild a + * literal's hash table to make it larger. */ #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 int HashString(const char *bytes, int length); +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. * * Results: * None. * - * Side effects: + * Side effects: * The literal table is made ready for use. * *---------------------------------------------------------------------- */ void -TclInitLiteralTable(tablePtr) - register LiteralTable *tablePtr; /* Pointer to table structure, which - * is supplied by the caller. */ +TclInitLiteralTable( + register LiteralTable *tablePtr) + /* Pointer to table structure, which is + * supplied by the caller. */ { -#if (TCL_SMALL_HASH_TABLE != 4) - panic("TclInitLiteralTable: TCL_SMALL_HASH_TABLE is %d, not 4\n", +#if (TCL_SMALL_HASH_TABLE != 4) + Tcl_Panic("TclInitLiteralTable: TCL_SMALL_HASH_TABLE is %d, not 4", TCL_SMALL_HASH_TABLE); #endif - + tablePtr->buckets = tablePtr->staticBuckets; tablePtr->staticBuckets[0] = tablePtr->staticBuckets[1] = 0; 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; } @@ -79,49 +77,58 @@ TclInitLiteralTable(tablePtr) * * TclDeleteLiteralTable -- * - * This procedure frees up everything associated with a literal table - * except for the table's structure itself. + * 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. * * Results: * None. * * Side effects: - * Each literal in the table is released: i.e., its reference count - * in the global literal table is decremented and, if it becomes zero, - * the literal is freed. In addition, the table's bucket array is - * freed. + * Each literal in the table is released: i.e., its reference count in + * the global literal table is decremented and, if it becomes zero, the + * literal is freed. In addition, the table's bucket array is freed. * *---------------------------------------------------------------------- */ 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; - int i, start; + LiteralEntry *entryPtr, *nextPtr; + Tcl_Obj *objPtr; + int i; /* - * Release remaining literals in the table. Note that releasing a - * literal might release other literals, modifying the table, so we - * restart the search from the bucket chain we last found an entry. + * Release remaining literals in the table. Note that releasing a literal + * might release other literals, modifying the table, so we restart the + * search from the bucket chain we last found an entry. */ #ifdef TCL_COMPILE_DEBUG TclVerifyGlobalLiteralTable((Interp *) interp); #endif /*TCL_COMPILE_DEBUG*/ - start = 0; - while (tablePtr->numEntries > 0) { - for (i = start; i < tablePtr->numBuckets; i++) { - entryPtr = tablePtr->buckets[i]; - if (entryPtr != NULL) { - TclReleaseLiteral(interp, entryPtr->objPtr); - start = i; - break; - } + /* + * 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 + * 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++) { + entryPtr = tablePtr->buckets[i]; + while (entryPtr != NULL) { + objPtr = entryPtr->objPtr; + TclDecrRefCount(objPtr); + nextPtr = entryPtr->nextPtr; + ckfree((char *) entryPtr); + entryPtr = nextPtr; } } @@ -137,199 +144,266 @@ TclDeleteLiteralTable(interp, tablePtr) /* *---------------------------------------------------------------------- * - * 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 onHeap is 1, 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 - * onHeap 1 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, onHeap) - 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 onHeap; /* If 1 then the caller already malloc'd - * bytes and ownership is passed to this - * procedure. */ +Tcl_Obj * +TclCreateLiteral( + Interp *iPtr, + char *bytes, + int length, + unsigned int 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; - long n; - char buf[TCL_INTEGER_SPACE]; - - if (length < 0) { - length = (bytes? strlen(bytes) : 0); - } - hash = HashString(bytes, length); - + LiteralEntry *globalPtr; + int globalHash; + Tcl_Obj *objPtr; + /* - * Is the literal already in the CompileEnv's local literal array? - * If so, just return its index. + * Is it in the interpreter's global literal table? */ - 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 (onHeap) { - ckfree(bytes); - } - objIndex = (localPtr - envPtr->literalArrayPtr); -#ifdef TCL_COMPILE_DEBUG - TclVerifyLocalLiteralTable(envPtr); -#endif /*TCL_COMPILE_DEBUG*/ - - return objIndex; - } + if (hash == (unsigned int) -1) { + hash = HashString(bytes, length); } - - /* - * The literal is new to this CompileEnv. Is it in the interpreter's - * global literal table? - */ - 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 ((objPtr->length == length) && ((length == 0) + if ((globalPtr->nsPtr == nsPtr) + && (objPtr->length == length) && ((length == 0) || ((objPtr->bytes[0] == bytes[0]) - && (memcmp(objPtr->bytes, bytes, (unsigned) length) - == 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 (onHeap) { - ckfree(bytes); + + if (newPtr) { + *newPtr = 0; } - objIndex = AddLocalLiteralEntry(envPtr, globalPtr, localHash); -#ifdef TCL_COMPILE_DEBUG - if (globalPtr->refCount < 1) { - panic("TclRegisterLiteral: global literal \"%.*s\" had bad refCount %d", - (length>60? 60 : length), bytes, - globalPtr->refCount); + if (globalPtrPtr) { + *globalPtrPtr = globalPtr; } - TclVerifyLocalLiteralTable(envPtr); -#endif /*TCL_COMPILE_DEBUG*/ - return objIndex; + if (flags & LITERAL_ON_HEAP) { + ckfree(bytes); + } + 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); Tcl_IncrRefCount(objPtr); - if (onHeap) { + if (flags & LITERAL_ON_HEAP) { objPtr->bytes = bytes; objPtr->length = length; } else { TclInitStringRep(objPtr, bytes, length); } - if (TclLooksLikeInt(bytes, length)) { - /* - * From here we use the objPtr, because it is NULL terminated - */ - 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; - } - } - } - #ifdef TCL_COMPILE_DEBUG if (TclLookupLiteralEntry((Tcl_Interp *) iPtr, objPtr) != NULL) { - panic("TclRegisterLiteral: literal \"%.*s\" found globally but shouldn't be", - (length>60? 60 : length), bytes); + Tcl_Panic("TclRegisterLiteral: literal \"%.*s\" found globally but shouldn't be", + (length>60? 60 : length), bytes); } #endif globalPtr = (LiteralEntry *) ckalloc((unsigned) sizeof(LiteralEntry)); globalPtr->objPtr = objPtr; - globalPtr->refCount = 0; + globalPtr->refCount = 1; + globalPtr->nsPtr = nsPtr; globalPtr->nextPtr = globalTablePtr->buckets[globalHash]; globalTablePtr->buckets[globalHash] = globalPtr; globalTablePtr->numEntries++; /* - * If the global literal table has exceeded a decent size, rebuild it - * with more buckets. + * If the global literal table has exceeded a decent size, rebuild it with + * more buckets. */ 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; + found = 0; - for (i = 0; i < globalTablePtr->numBuckets; i++) { - for (entryPtr = globalTablePtr->buckets[i]; - entryPtr != NULL; entryPtr = entryPtr->nextPtr) { - if ((entryPtr == globalPtr) - && (entryPtr->objPtr == objPtr)) { + for (i=0 ; i<globalTablePtr->numBuckets ; i++) { + for (entryPtr=globalTablePtr->buckets[i]; entryPtr!=NULL ; + entryPtr=entryPtr->nextPtr) { + if ((entryPtr == globalPtr) && (entryPtr->objPtr == objPtr)) { found = 1; } } } if (!found) { - panic("TclRegisterLiteral: literal \"%.*s\" wasn't global", - (length>60? 60 : length), bytes); + Tcl_Panic("TclRegisterLiteral: literal \"%.*s\" wasn't global", + (length>60? 60 : length), bytes); } } #endif /*TCL_COMPILE_DEBUG*/ -#ifdef TCL_COMPILE_STATS + +#ifdef TCL_COMPILE_STATS iPtr->stats.numLiteralsCreated++; - iPtr->stats.totalLitStringBytes += (double) (length + 1); + iPtr->stats.totalLitStringBytes += (double) (length + 1); iPtr->stats.currentLitStringBytes += (double) (length + 1); iPtr->stats.literalCount[TclLog2(length)]++; #endif /*TCL_COMPILE_STATS*/ + + if (globalPtrPtr) { + *globalPtrPtr = globalPtr; + } + *newPtr = 1; + return 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( + 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 function. If LITERAL_NS_SCOPE then + * the literal shouldnot be shared accross + * namespaces. */ +{ + Interp *iPtr = envPtr->iPtr; + LiteralTable *localTablePtr = &(envPtr->localLitTable); + LiteralEntry *globalPtr, *localPtr; + Tcl_Obj *objPtr; + unsigned int 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. 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; + } + + /* + * 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("TclRegisterLiteral: global literal \"%.*s\" had bad refCount %d", + (length>60? 60 : length), bytes, globalPtr->refCount); + } + TclVerifyLocalLiteralTable(envPtr); +#endif /*TCL_COMPILE_DEBUG*/ return objIndex; } @@ -339,24 +413,24 @@ TclRegisterLiteral(envPtr, bytes, length, onHeap) * TclLookupLiteralEntry -- * * Finds the LiteralEntry that corresponds to a literal Tcl object - * holding a literal. + * holding a literal. * * Results: - * Returns the matching LiteralEntry if found, otherwise NULL. + * Returns the matching LiteralEntry if found, otherwise NULL. * * Side effects: - * None. + * None. * *---------------------------------------------------------------------- */ LiteralEntry * -TclLookupLiteralEntry(interp, objPtr) - 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 that was previously created by a - * call to TclRegisterLiteral. */ +TclLookupLiteralEntry( + 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 + * that was previously created by a call to + * TclRegisterLiteral. */ { Interp *iPtr = (Interp *) interp; LiteralTable *globalTablePtr = &(iPtr->literalTable); @@ -364,13 +438,13 @@ TclLookupLiteralEntry(interp, objPtr) 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) { - if (entryPtr->objPtr == objPtr) { - return entryPtr; - } + for (entryPtr=globalTablePtr->buckets[globalHash] ; entryPtr!=NULL; + entryPtr=entryPtr->nextPtr) { + if (entryPtr->objPtr == objPtr) { + return entryPtr; + } } return NULL; } @@ -380,10 +454,10 @@ TclLookupLiteralEntry(interp, objPtr) * * TclHideLiteral -- * - * Remove a literal entry from the literal hash tables, leaving it in - * the literal array so existing references continue to function. - * This makes it possible to turn a shared literal into a private - * literal that cannot be shared. + * Remove a literal entry from the literal hash tables, leaving it in the + * literal array so existing references continue to function. This makes + * it possible to turn a shared literal into a private literal that + * cannot be shared. * * Results: * None. @@ -396,13 +470,13 @@ TclLookupLiteralEntry(interp, objPtr) */ void -TclHideLiteral(interp, envPtr, index) - Tcl_Interp *interp; /* Interpreter for which objPtr was created - * to hold a literal. */ - register CompileEnv *envPtr; /* Points to CompileEnv whose literal array - * contains the entry being hidden. */ - int index; /* The index of the entry in the literal - * array. */ +TclHideLiteral( + Tcl_Interp *interp, /* Interpreter for which objPtr was created to + * hold a literal. */ + register CompileEnv *envPtr,/* Points to CompileEnv whose literal array + * contains the entry being hidden. */ + int index) /* The index of the entry in the literal + * array. */ { LiteralEntry **nextPtrPtr, *entryPtr, *lPtr; LiteralTable *localTablePtr = &(envPtr->localLitTable); @@ -414,9 +488,9 @@ TclHideLiteral(interp, envPtr, 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); @@ -424,11 +498,11 @@ 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]; - for (entryPtr = *nextPtrPtr; entryPtr != NULL; entryPtr = *nextPtrPtr) { + for (entryPtr=*nextPtrPtr ; entryPtr!=NULL ; entryPtr=*nextPtrPtr) { if (entryPtr == lPtr) { *nextPtrPtr = lPtr->nextPtr; lPtr->nextPtr = NULL; @@ -444,31 +518,30 @@ TclHideLiteral(interp, envPtr, index) * * TclAddLiteralObj -- * - * Add a single literal object to the literal array. This - * function does not add the literal to the local or global - * literal tables. The caller is expected to add the entry - * to whatever tables are appropriate. + * Add a single literal object to the literal array. This function does + * not add the literal to the local or global literal tables. The caller + * is expected to add the entry to whatever tables are appropriate. * * Results: * The index in the CompileEnv's literal array that references the - * literal. Stores the pointer to the new literal entry in the - * location referenced by the localPtrPtr argument. + * literal. Stores the pointer to the new literal entry in the location + * referenced by the localPtrPtr argument. * * Side effects: - * Expands the literal array if necessary. Increments the refcount - * on the literal object. + * Expands the literal array if necessary. Increments the refcount on the + * literal object. * *---------------------------------------------------------------------- */ int -TclAddLiteralObj(envPtr, objPtr, litPtrPtr) - 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 literal entry should be stored. - * May be NULL. */ +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 + * literal entry should be stored. May be + * NULL. */ { register LiteralEntry *lPtr; int objIndex; @@ -504,27 +577,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 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. */ +AddLocalLiteralEntry( + register CompileEnv *envPtr,/* Points to CompileEnv in whose literal array + * the object is to be inserted. */ + Tcl_Obj *objPtr, /* The literal to add to the CompileEnv. */ + int localHash) /* Hash value for the literal's string. */ { 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. @@ -534,8 +604,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. @@ -550,22 +618,25 @@ AddLocalLiteralEntry(envPtr, globalPtr, localHash) { char *bytes; int length, found, i; + found = 0; - for (i = 0; i < localTablePtr->numBuckets; i++) { - for (localPtr = localTablePtr->buckets[i]; - localPtr != NULL; localPtr = localPtr->nextPtr) { - if (localPtr->objPtr == globalPtr->objPtr) { + for (i=0 ; i<localTablePtr->numBuckets ; i++) { + for (localPtr=localTablePtr->buckets[i] ; localPtr!=NULL ; + localPtr=localPtr->nextPtr) { + if (localPtr->objPtr == objPtr) { found = 1; } } } + if (!found) { - bytes = Tcl_GetStringFromObj(globalPtr->objPtr, &length); - panic("AddLocalLiteralEntry: literal \"%.*s\" wasn't found locally", - (length>60? 60 : length), bytes); + bytes = Tcl_GetStringFromObj(objPtr, &length); + Tcl_Panic("AddLocalLiteralEntry: literal \"%.*s\" wasn't found locally", + (length>60? 60 : length), bytes); } } #endif /*TCL_COMPILE_DEBUG*/ + return objIndex; } @@ -574,72 +645,72 @@ AddLocalLiteralEntry(envPtr, globalPtr, localHash) * * ExpandLocalLiteralArray -- * - * Procedure that uses malloc to allocate more storage for a - * CompileEnv's local literal array. + * Function that uses malloc to allocate more storage for a CompileEnv's + * local literal array. * * Results: * None. * * Side effects: - * The literal array in *envPtr is reallocated to a new array of - * double the size, and if envPtr->mallocedLiteralArray is non-zero - * the old array is freed. Entries are copied from the old array - * to the new one. The local literal table is updated to refer to - * the new entries. + * The literal array in *envPtr is reallocated to a new array of double + * the size, and if envPtr->mallocedLiteralArray is non-zero the old + * array is freed. Entries are copied from the old array to the new one. + * The local literal table is updated to refer to the new entries. * *---------------------------------------------------------------------- */ static void -ExpandLocalLiteralArray(envPtr) - register CompileEnv *envPtr; /* Points to the CompileEnv whose object - * array must be enlarged. */ +ExpandLocalLiteralArray( + register CompileEnv *envPtr)/* Points to the CompileEnv whose object array + * must be enlarged. */ { /* - * The current allocated local literal entries are stored between - * elements 0 and (envPtr->literalArrayNext - 1) [inclusive]. + * The current allocated local literal entries are stored between elements + * 0 and (envPtr->literalArrayNext - 1) [inclusive]. */ 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; - + + if (envPtr->mallocedLiteralArray) { + newArrayPtr = (LiteralEntry *) ckrealloc( + (char *)currArrayPtr, 2 * currBytes); + } else { + /* + * envPtr->literalArrayPtr isn't a ckalloc'd pointer, so we must + * code a ckrealloc equivalent for ourselves + */ + newArrayPtr = (LiteralEntry *) ckalloc(2 * currBytes); + memcpy(newArrayPtr, currArrayPtr, currBytes); + envPtr->mallocedLiteralArray = 1; + } + /* - * Copy from the old literal array to the new, then update the local - * literal table's bucket array. + * Update the local literal table's bucket array. */ - 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); + 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); + for (i=0 ; i<localTablePtr->numBuckets ; i++) { + if (localTablePtr->buckets[i] != NULL) { + localTablePtr->buckets[i] = newArrayPtr + + (localTablePtr->buckets[i] - currArrayPtr); + } } } - /* - * Free the old literal array if needed, and mark the new literal - * array as malloced. - */ - - if (envPtr->mallocedLiteralArray) { - ckfree((char *) currArrayPtr); - } envPtr->literalArrayPtr = newArrayPtr; envPtr->literalArrayEnd = (2 * currElems); - envPtr->mallocedLiteralArray = 1; } /* @@ -647,59 +718,56 @@ ExpandLocalLiteralArray(envPtr) * * TclReleaseLiteral -- * - * This procedure 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 + * 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. * * Results: * None. * * Side effects: - * The reference count for the global LiteralTable entry that - * corresponds to the literal is decremented. If no other reference - * to a global literal object remains, it is freed. + * The reference count for the global LiteralTable entry that corresponds + * to the literal is decremented. If no other reference to a global + * literal object remains, it is freed. * *---------------------------------------------------------------------- */ void -TclReleaseLiteral(interp, objPtr) - Tcl_Interp *interp; /* Interpreter for which objPtr was created - * to hold a literal. */ - register Tcl_Obj *objPtr; /* Points to a literal object that was +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 * previously created by a call to * TclRegisterLiteral. */ { Interp *iPtr = (Interp *) interp; LiteralTable *globalTablePtr = &(iPtr->literalTable); register LiteralEntry *entryPtr, *prevPtr; - ByteCode* codePtr; char *bytes; int length, index; - bytes = Tcl_GetStringFromObj(objPtr, &length); + bytes = TclGetStringFromObj(objPtr, &length); index = (HashString(bytes, length) & globalTablePtr->mask); /* - * Check to see if the object is in the global literal table and - * remove this reference. The object may not be in the table if - * it is a hidden local literal. + * Check to see if the object is in the global literal table and remove + * this reference. The object may not be in the table if it is a hidden + * 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--; /* - * If the literal is no longer being used by any ByteCode, - * delete the entry then remove the reference corresponding - * to the global literal table entry (decrement the ref count - * of the object). + * If the literal is no longer being used by any ByteCode, delete + * the entry then remove the reference corresponding to the global + * literal table entry (decrement the ref count of the object). */ - + if (entryPtr->refCount == 0) { if (prevPtr == NULL) { globalTablePtr->buckets[index] = entryPtr->nextPtr; @@ -711,22 +779,6 @@ TclReleaseLiteral(interp, objPtr) TclDecrRefCount(objPtr); - /* - * Check if the LiteralEntry is only being kept alive by - * a circular reference from a ByteCode stored as its - * internal rep. In that case, set the ByteCode object array - * entry NULL to signal to TclCleanupByteCode to not try to - * release this about to be freed literal again. - */ - - if (objPtr->typePtr == &tclByteCodeType) { - codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; - if ((codePtr->numLitObjects == 1) - && (codePtr->objArrayPtr[0] == objPtr)) { - codePtr->objArrayPtr[0] = NULL; - } - } - #ifdef TCL_COMPILE_STATS iPtr->stats.currentLitStringBytes -= (double) (length + 1); #endif /*TCL_COMPILE_STATS*/ @@ -734,10 +786,9 @@ TclReleaseLiteral(interp, objPtr) break; } } - + /* - * Remove the reference corresponding to the local literal table - * entry. + * Remove the reference corresponding to the local literal table entry. */ Tcl_DecrRefCount(objPtr); @@ -748,12 +799,11 @@ TclReleaseLiteral(interp, objPtr) * * HashString -- * - * Compute a one-word summary of a text string, which can be - * used to generate a hash index. + * Compute a one-word summary of a text string, which can be used to + * generate a hash index. * * Results: - * The return value is a one-word summary of the information in - * string. + * The return value is a one-word summary of the information in string. * * Side effects: * None. @@ -762,33 +812,32 @@ 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. */ +HashString( + register const char *bytes, /* String for which to compute hash value. */ + int length) /* Number of bytes in the string. */ { register unsigned int result; register int i; /* - * I tried a zillion different hash functions and asked many other - * people for advice. Many people had their own favorite functions, - * all different, but no-one had much idea why they were good ones. - * I chose the one below (multiply by 9 and add new character) - * because of the following reasons: + * I tried a zillion different hash functions and asked many other people + * for advice. Many people had their own favorite functions, all + * different, but no-one had much idea why they were good ones. I chose + * the one below (multiply by 9 and add new character) because of the + * 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. + * 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. */ result = 0; - for (i = 0; i < length; i++) { - result += (result<<3) + *bytes++; + for (i=0 ; i<length ; i++) { + result += (result<<3) + bytes[i]; } return result; } @@ -798,9 +847,9 @@ HashString(bytes, length) * * RebuildLiteralTable -- * - * This procedure 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. + * 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. * * Results: * None. @@ -812,8 +861,9 @@ HashString(bytes, length) */ static void -RebuildLiteralTable(tablePtr) - register LiteralTable *tablePtr; /* Local or global table to enlarge. */ +RebuildLiteralTable( + register LiteralTable *tablePtr) + /* Local or global table to enlarge. */ { LiteralEntry **oldBuckets; register LiteralEntry **oldChainPtr, **newChainPtr; @@ -826,16 +876,15 @@ RebuildLiteralTable(tablePtr) oldBuckets = tablePtr->buckets; /* - * Allocate and initialize the new bucket array, and set up - * hashing constants for new array size. + * Allocate and initialize the new bucket array, and set up hashing + * constants for new array size. */ tablePtr->numBuckets *= 4; tablePtr->buckets = (LiteralEntry **) ckalloc((unsigned) (tablePtr->numBuckets * sizeof(LiteralEntry *))); - for (count = tablePtr->numBuckets, newChainPtr = tablePtr->buckets; - count > 0; - count--, newChainPtr++) { + for (count=tablePtr->numBuckets, newChainPtr=tablePtr->buckets; + count>0 ; count--, newChainPtr++) { *newChainPtr = NULL; } tablePtr->rebuildSize *= 4; @@ -845,14 +894,11 @@ RebuildLiteralTable(tablePtr) * Rehash all of the existing entries into the new bucket array. */ - for (oldChainPtr = oldBuckets; - oldSize > 0; - oldSize--, oldChainPtr++) { - for (entryPtr = *oldChainPtr; entryPtr != NULL; - entryPtr = *oldChainPtr) { - bytes = Tcl_GetStringFromObj(entryPtr->objPtr, &length); + for (oldChainPtr=oldBuckets ; oldSize>0 ; oldSize--,oldChainPtr++) { + for (entryPtr=*oldChainPtr ; entryPtr!=NULL ; entryPtr=*oldChainPtr) { + bytes = TclGetStringFromObj(entryPtr->objPtr, &length); index = (HashString(bytes, length) & tablePtr->mask); - + *oldChainPtr = entryPtr->nextPtr; bucketPtr = &(tablePtr->buckets[index]); entryPtr->nextPtr = *bucketPtr; @@ -875,13 +921,12 @@ RebuildLiteralTable(tablePtr) * * TclLiteralStats -- * - * Return statistics describing the layout of the hash table - * in its hash buckets. + * Return statistics describing the layout of the hash table in its hash + * buckets. * * Results: - * The return value is a malloc-ed string containing information - * about tablePtr. It is the caller's responsibility to free - * this string. + * The return value is a malloc-ed string containing information about + * tablePtr. It is the caller's responsibility to free this string. * * Side effects: * None. @@ -890,8 +935,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; @@ -900,19 +945,19 @@ TclLiteralStats(tablePtr) char *result, *p; /* - * Compute a histogram of bucket usage. For each bucket chain i, - * j is the number of entries in the chain. + * Compute a histogram of bucket usage. For each bucket chain i, j is the + * 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) { @@ -932,7 +977,7 @@ TclLiteralStats(tablePtr) 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); @@ -957,15 +1002,15 @@ TclLiteralStats(tablePtr) * None. * * Side effects: - * Panics if problems are found. + * Tcl_Panic if problems are found. * *---------------------------------------------------------------------- */ void -TclVerifyLocalLiteralTable(envPtr) - CompileEnv *envPtr; /* Points to CompileEnv whose literal - * table is to be validated. */ +TclVerifyLocalLiteralTable( + CompileEnv *envPtr) /* Points to CompileEnv whose literal table is + * to be validated. */ { register LiteralTable *localTablePtr = &(envPtr->localLitTable); register LiteralEntry *localPtr; @@ -974,30 +1019,29 @@ TclVerifyLocalLiteralTable(envPtr) 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); - panic("TclVerifyLocalLiteralTable: local literal \"%.*s\" had bad refCount %d", - (length>60? 60 : length), bytes, - localPtr->refCount); + Tcl_Panic("TclVerifyLocalLiteralTable: local literal \"%.*s\" had bad refCount %d", + (length>60? 60 : length), bytes, localPtr->refCount); } if (TclLookupLiteralEntry((Tcl_Interp *) envPtr->iPtr, localPtr->objPtr) == NULL) { bytes = Tcl_GetStringFromObj(localPtr->objPtr, &length); - panic("TclVerifyLocalLiteralTable: local literal \"%.*s\" is not global", - (length>60? 60 : length), bytes); + Tcl_Panic("TclVerifyLocalLiteralTable: local literal \"%.*s\" is not global", + (length>60? 60 : length), bytes); } if (localPtr->objPtr->bytes == NULL) { - panic("TclVerifyLocalLiteralTable: literal has NULL string rep"); + Tcl_Panic("TclVerifyLocalLiteralTable: literal has NULL string rep"); } } } if (count != localTablePtr->numEntries) { - panic("TclVerifyLocalLiteralTable: local literal table had %d entries, should be %d", - count, localTablePtr->numEntries); + Tcl_Panic("TclVerifyLocalLiteralTable: local literal table had %d entries, should be %d", + count, localTablePtr->numEntries); } } @@ -1012,15 +1056,15 @@ TclVerifyLocalLiteralTable(envPtr) * None. * * Side effects: - * Panics if problems are found. + * Tcl_Panic if problems are found. * *---------------------------------------------------------------------- */ void -TclVerifyGlobalLiteralTable(iPtr) - Interp *iPtr; /* Points to interpreter whose global - * literal table is to be validated. */ +TclVerifyGlobalLiteralTable( + Interp *iPtr) /* Points to interpreter whose global literal + * table is to be validated. */ { register LiteralTable *globalTablePtr = &(iPtr->literalTable); register LiteralEntry *globalPtr; @@ -1029,24 +1073,31 @@ TclVerifyGlobalLiteralTable(iPtr) 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); - panic("TclVerifyGlobalLiteralTable: global literal \"%.*s\" had bad refCount %d", - (length>60? 60 : length), bytes, - globalPtr->refCount); + Tcl_Panic("TclVerifyGlobalLiteralTable: global literal \"%.*s\" had bad refCount %d", + (length>60? 60 : length), bytes, globalPtr->refCount); } if (globalPtr->objPtr->bytes == NULL) { - panic("TclVerifyGlobalLiteralTable: literal has NULL string rep"); + Tcl_Panic("TclVerifyGlobalLiteralTable: literal has NULL string rep"); } } } if (count != globalTablePtr->numEntries) { - panic("TclVerifyGlobalLiteralTable: global literal table had %d entries, should be %d", - count, globalTablePtr->numEntries); + Tcl_Panic("TclVerifyGlobalLiteralTable: global literal table had %d entries, should be %d", + count, globalTablePtr->numEntries); } } #endif /*TCL_COMPILE_DEBUG*/ + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ |