+++ /dev/null
-/*
- * 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.
- *
- * 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.
- */
-
-#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.
- */
-
-#define REBUILD_MULTIPLIER 3
-
-/*
- * Function prototypes for static functions in this file:
- */
-
-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);
-\f
-/*
- *----------------------------------------------------------------------
- *
- * TclInitLiteralTable --
- *
- * 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:
- * The literal table is made ready for use.
- *
- *----------------------------------------------------------------------
- */
-
-void
-TclInitLiteralTable(
- register LiteralTable *tablePtr)
- /* Pointer to table structure, which is
- * supplied by the caller. */
-{
-#if (TCL_SMALL_HASH_TABLE != 4)
- Tcl_Panic("%s: TCL_SMALL_HASH_TABLE is %d, not 4", "TclInitLiteralTable",
- 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->mask = 3;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * TclDeleteLiteralTable --
- *
- * 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.
- *
- *----------------------------------------------------------------------
- */
-
-void
-TclDeleteLiteralTable(
- Tcl_Interp *interp, /* Interpreter containing shared literals
- * referenced by the table to delete. */
- LiteralTable *tablePtr) /* Points to the literal table to delete. */
-{
- 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.
- */
-
-#ifdef TCL_COMPILE_DEBUG
- TclVerifyGlobalLiteralTable((Interp *) interp);
-#endif /*TCL_COMPILE_DEBUG*/
-
- /*
- * 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(entryPtr);
- entryPtr = nextPtr;
- }
- }
-
- /*
- * Free up the table's bucket array if it was dynamically allocated.
- */
-
- if (tablePtr->buckets != tablePtr->staticBuckets) {
- ckfree(tablePtr->buckets);
- }
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * TclCreateLiteral --
- *
- * 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 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:
- * 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.
- *
- *----------------------------------------------------------------------
- */
-
-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)
-{
- 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) {
- 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 literal was found: return it
- */
-
- if (newPtr) {
- *newPtr = 0;
- }
- if (globalPtrPtr) {
- *globalPtrPtr = globalPtr;
- }
- 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.
- */
-
- TclNewObj(objPtr);
- Tcl_IncrRefCount(objPtr);
- if (flags & LITERAL_ON_HEAP) {
- objPtr->bytes = bytes;
- objPtr->length = length;
- } else {
- TclInitStringRep(objPtr, bytes, length);
- }
-
-#ifdef TCL_COMPILE_DEBUG
- 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 = ckalloc(sizeof(LiteralEntry));
- globalPtr->objPtr = objPtr;
- 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 (globalTablePtr->numEntries >= globalTablePtr->rebuildSize) {
- RebuildLiteralTable(globalTablePtr);
- }
-
-#ifdef TCL_COMPILE_DEBUG
- TclVerifyGlobalLiteralTable(iPtr);
- {
- 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)) {
- found = 1;
- }
- }
- }
- if (!found) {
- Tcl_Panic("%s: literal \"%.*s\" wasn't global",
- "TclRegisterLiteral", (length>60? 60 : length), bytes);
- }
- }
-#endif /*TCL_COMPILE_DEBUG*/
-
-#ifdef TCL_COMPILE_STATS
- iPtr->stats.numLiteralsCreated++;
- 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-#ifdef TCL_COMPILE_DEBUG
-/*
- *----------------------------------------------------------------------
- *
- * LookupLiteralEntry --
- *
- * Finds the LiteralEntry that corresponds to a literal Tcl object
- * holding a literal.
- *
- * Results:
- * Returns the matching LiteralEntry if found, otherwise NULL.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-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
- * that was previously created by a call to
- * TclRegisterLiteral. */
-{
- Interp *iPtr = (Interp *) interp;
- LiteralTable *globalTablePtr = &iPtr->literalTable;
- register LiteralEntry *entryPtr;
- const char *bytes;
- int length, globalHash;
-
- 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;
- }
- }
- return NULL;
-}
-\f
-#endif
-/*
- *----------------------------------------------------------------------
- *
- * 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.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Removes the literal from the local hash table and decrements the
- * global hash entry's reference count.
- *
- *----------------------------------------------------------------------
- */
-
-void
-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;
- int localHash, length;
- const char *bytes;
- Tcl_Obj *newObjPtr;
-
- 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.
- */
-
- newObjPtr = Tcl_DuplicateObj(lPtr->objPtr);
- Tcl_IncrRefCount(newObjPtr);
- TclReleaseLiteral(interp, lPtr->objPtr);
- lPtr->objPtr = newObjPtr;
-
- bytes = TclGetStringFromObj(newObjPtr, &length);
- localHash = (HashString(bytes, length) & localTablePtr->mask);
- nextPtrPtr = &localTablePtr->buckets[localHash];
-
- for (entryPtr=*nextPtrPtr ; entryPtr!=NULL ; entryPtr=*nextPtrPtr) {
- if (entryPtr == lPtr) {
- *nextPtrPtr = lPtr->nextPtr;
- lPtr->nextPtr = NULL;
- localTablePtr->numEntries--;
- break;
- }
- nextPtrPtr = &entryPtr->nextPtr;
- }
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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.
- *
- * 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.
- *
- * Side effects:
- * Expands the literal array if necessary. Increments the refcount on the
- * literal object.
- *
- *----------------------------------------------------------------------
- */
-
-int
-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;
-
- if (envPtr->literalArrayNext >= envPtr->literalArrayEnd) {
- ExpandLocalLiteralArray(envPtr);
- }
- objIndex = envPtr->literalArrayNext;
- envPtr->literalArrayNext++;
-
- lPtr = &envPtr->literalArrayPtr[objIndex];
- lPtr->objPtr = objPtr;
- Tcl_IncrRefCount(objPtr);
- lPtr->refCount = -1; /* i.e., unused */
- lPtr->nextPtr = NULL;
-
- if (litPtrPtr) {
- *litPtrPtr = lPtr;
- }
-
- return objIndex;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * AddLocalLiteralEntry --
- *
- * Insert a new literal into a CompileEnv's local literal array.
- *
- * Results:
- * The index in the CompileEnv's literal array that references the
- * literal.
- *
- * Side effects:
- * 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(
- 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, objPtr, &localPtr);
-
- /*
- * Add the literal to the local table.
- */
-
- localPtr->nextPtr = localTablePtr->buckets[localHash];
- localTablePtr->buckets[localHash] = localPtr;
- localTablePtr->numEntries++;
-
- /*
- * If the CompileEnv's local literal table has exceeded a decent size,
- * rebuild it with more buckets.
- */
-
- if (localTablePtr->numEntries >= localTablePtr->rebuildSize) {
- RebuildLiteralTable(localTablePtr);
- }
-
-#ifdef TCL_COMPILE_DEBUG
- TclVerifyLocalLiteralTable(envPtr);
- {
- 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 == objPtr) {
- found = 1;
- }
- }
- }
-
- if (!found) {
- bytes = Tcl_GetStringFromObj(objPtr, &length);
- Tcl_Panic("%s: literal \"%.*s\" wasn't found locally",
- "AddLocalLiteralEntry", (length>60? 60 : length), bytes);
- }
- }
-#endif /*TCL_COMPILE_DEBUG*/
-
- return objIndex;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * ExpandLocalLiteralArray --
- *
- * 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.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-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].
- */
-
- LiteralTable *localTablePtr = &envPtr->localLitTable;
- int currElems = envPtr->literalArrayNext;
- size_t currBytes = (currElems * sizeof(LiteralEntry));
- LiteralEntry *currArrayPtr = envPtr->literalArrayPtr;
- LiteralEntry *newArrayPtr;
- int i;
-
- 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.
- */
-
- newArrayPtr = ckalloc(2 * currBytes);
- memcpy(newArrayPtr, currArrayPtr, currBytes);
- envPtr->mallocedLiteralArray = 1;
- }
-
- /*
- * Update the local literal table's bucket array.
- */
-
- 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);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * TclReleaseLiteral --
- *
- * 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.
- *
- *----------------------------------------------------------------------
- */
-
-void
-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;
- register LiteralEntry *entryPtr, *prevPtr;
- const char *bytes;
- int length, index;
-
- if (iPtr == NULL) {
- goto done;
- }
-
- globalTablePtr = &iPtr->literalTable;
- 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.
- */
-
- 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 (entryPtr->refCount == 0) {
- if (prevPtr == NULL) {
- globalTablePtr->buckets[index] = entryPtr->nextPtr;
- } else {
- prevPtr->nextPtr = entryPtr->nextPtr;
- }
- ckfree(entryPtr);
- globalTablePtr->numEntries--;
-
- TclDecrRefCount(objPtr);
-
-#ifdef TCL_COMPILE_STATS
- iPtr->stats.currentLitStringBytes -= (double) (length + 1);
-#endif /*TCL_COMPILE_STATS*/
- }
- break;
- }
- }
-
- /*
- * Remove the reference corresponding to the local literal table entry.
- */
-
- done:
- Tcl_DecrRefCount(objPtr);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * HashString --
- *
- * 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.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-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 = 0;
-
- /*
- * 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.
- *
- * 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]
- */
-
- if (length > 0) {
- result = UCHAR(*string);
- while (--length) {
- result += (result << 3) + UCHAR(*++string);
- }
- }
- return result;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * RebuildLiteralTable --
- *
- * 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.
- *
- * Side effects:
- * Memory gets reallocated and entries get rehashed into new buckets.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-RebuildLiteralTable(
- register LiteralTable *tablePtr)
- /* Local or global table to enlarge. */
-{
- LiteralEntry **oldBuckets;
- register LiteralEntry **oldChainPtr, **newChainPtr;
- register LiteralEntry *entryPtr;
- LiteralEntry **bucketPtr;
- const char *bytes;
- int oldSize, count, index, length;
-
- oldSize = tablePtr->numBuckets;
- oldBuckets = tablePtr->buckets;
-
- /*
- * Allocate and initialize the new bucket array, and set up hashing
- * constants for new array size.
- */
-
- tablePtr->numBuckets *= 4;
- tablePtr->buckets = ckalloc(tablePtr->numBuckets * sizeof(LiteralEntry*));
- for (count=tablePtr->numBuckets, newChainPtr=tablePtr->buckets;
- count>0 ; count--, newChainPtr++) {
- *newChainPtr = NULL;
- }
- tablePtr->rebuildSize *= 4;
- tablePtr->mask = (tablePtr->mask << 2) + 3;
-
- /*
- * 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 = TclGetStringFromObj(entryPtr->objPtr, &length);
- index = (HashString(bytes, length) & tablePtr->mask);
-
- *oldChainPtr = entryPtr->nextPtr;
- bucketPtr = &tablePtr->buckets[index];
- entryPtr->nextPtr = *bucketPtr;
- *bucketPtr = entryPtr;
- }
- }
-
- /*
- * Free up the old bucket array, if it was dynamically allocated.
- */
-
- if (oldBuckets != tablePtr->staticBuckets) {
- ckfree(oldBuckets);
- }
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
- }
-}
-\f
-#ifdef TCL_COMPILE_STATS
-/*
- *----------------------------------------------------------------------
- *
- * TclLiteralStats --
- *
- * 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.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-char *
-TclLiteralStats(
- LiteralTable *tablePtr) /* Table for which to produce stats. */
-{
-#define NUM_COUNTERS 10
- int count[NUM_COUNTERS], overflow, i, j;
- double average, tmp;
- register LiteralEntry *entryPtr;
- char *result, *p;
-
- /*
- * 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++) {
- count[i] = 0;
- }
- overflow = 0;
- average = 0.0;
- for (i=0 ; i<tablePtr->numBuckets ; i++) {
- j = 0;
- for (entryPtr=tablePtr->buckets[i] ; entryPtr!=NULL;
- entryPtr=entryPtr->nextPtr) {
- j++;
- }
- if (j < NUM_COUNTERS) {
- count[j]++;
- } else {
- overflow++;
- }
- tmp = j;
- average += (tmp+1.0)*(tmp/tablePtr->numEntries)/2.0;
- }
-
- /*
- * Print out the histogram and a few other pieces of information.
- */
-
- 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++) {
- sprintf(p, "number of buckets with %d entries: %d\n",
- i, count[i]);
- p += strlen(p);
- }
- sprintf(p, "number of buckets with %d or more entries: %d\n",
- NUM_COUNTERS, overflow);
- p += strlen(p);
- sprintf(p, "average search distance for entry: %.1f", average);
- return result;
-}
-#endif /*TCL_COMPILE_STATS*/
-\f
-#ifdef TCL_COMPILE_DEBUG
-/*
- *----------------------------------------------------------------------
- *
- * TclVerifyLocalLiteralTable --
- *
- * Check a CompileEnv's local literal table for consistency.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Tcl_Panic if problems are found.
- *
- *----------------------------------------------------------------------
- */
-
-void
-TclVerifyLocalLiteralTable(
- CompileEnv *envPtr) /* Points to CompileEnv whose literal table is
- * to be validated. */
-{
- 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) {
- count++;
- if (localPtr->refCount != -1) {
- bytes = Tcl_GetStringFromObj(localPtr->objPtr, &length);
- Tcl_Panic("%s: local literal \"%.*s\" had bad refCount %d",
- "TclVerifyLocalLiteralTable",
- (length>60? 60 : length), bytes, localPtr->refCount);
- }
- if (LookupLiteralEntry((Tcl_Interp *) envPtr->iPtr,
- localPtr->objPtr) == NULL) {
- bytes = Tcl_GetStringFromObj(localPtr->objPtr, &length);
- Tcl_Panic("%s: local literal \"%.*s\" is not global",
- "TclVerifyLocalLiteralTable",
- (length>60? 60 : length), bytes);
- }
- if (localPtr->objPtr->bytes == NULL) {
- Tcl_Panic("%s: literal has NULL string rep",
- "TclVerifyLocalLiteralTable");
- }
- }
- }
- if (count != localTablePtr->numEntries) {
- Tcl_Panic("%s: local literal table had %d entries, should be %d",
- "TclVerifyLocalLiteralTable", count,
- localTablePtr->numEntries);
- }
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * TclVerifyGlobalLiteralTable --
- *
- * Check an interpreter's global literal table literal for consistency.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Tcl_Panic if problems are found.
- *
- *----------------------------------------------------------------------
- */
-
-void
-TclVerifyGlobalLiteralTable(
- Interp *iPtr) /* Points to interpreter whose global literal
- * table is to be validated. */
-{
- 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) {
- count++;
- if (globalPtr->refCount < 1) {
- bytes = Tcl_GetStringFromObj(globalPtr->objPtr, &length);
- 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("%s: literal has NULL string rep",
- "TclVerifyGlobalLiteralTable");
- }
- }
- }
- if (count != globalTablePtr->numEntries) {
- Tcl_Panic("%s: global literal table had %d entries, should be %d",
- "TclVerifyGlobalLiteralTable", count,
- globalTablePtr->numEntries);
- }
-}
-#endif /*TCL_COMPILE_DEBUG*/
-\f
-/*
- * Local Variables:
- * mode: c
- * c-basic-offset: 4
- * fill-column: 78
- * End:
- */
OSDN Git Service
