1250 lines
35 KiB
C
1250 lines
35 KiB
C
/*
|
||
* 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);
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* 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(
|
||
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;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* 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);
|
||
}
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* 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) {
|
||
/*
|
||
* Literals should always have UTF-8 representations... but this
|
||
* is not guaranteed so we need to be careful anyway.
|
||
*
|
||
* https://stackoverflow.com/q/54337750/301832
|
||
*/
|
||
|
||
int objLength;
|
||
char *objBytes = TclGetStringFromObj(objPtr, &objLength);
|
||
|
||
if ((objLength == length) && ((length == 0)
|
||
|| ((objBytes[0] == bytes[0])
|
||
&& (memcmp(objBytes, bytes, 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);
|
||
if ((flags & LITERAL_ON_HEAP)) {
|
||
objPtr->bytes = bytes;
|
||
objPtr->length = length;
|
||
} else {
|
||
TclInitStringRep(objPtr, bytes, length);
|
||
}
|
||
|
||
if ((flags & LITERAL_UNSHARED)) {
|
||
/*
|
||
* Make clear, that no global value is returned
|
||
*/
|
||
if (globalPtrPtr != NULL) {
|
||
*globalPtrPtr = NULL;
|
||
}
|
||
return objPtr;
|
||
}
|
||
|
||
#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 = (LiteralEntry *)ckalloc(sizeof(LiteralEntry));
|
||
globalPtr->objPtr = objPtr;
|
||
Tcl_IncrRefCount(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;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* 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. */
|
||
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, 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.
|
||
*/
|
||
|
||
globalPtr = NULL;
|
||
objPtr = TclCreateLiteral(iPtr, bytes, length, hash, &new, nsPtr, flags,
|
||
&globalPtr);
|
||
objIndex = AddLocalLiteralEntry(envPtr, objPtr, localHash);
|
||
|
||
#ifdef TCL_COMPILE_DEBUG
|
||
if (globalPtr != NULL && 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
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* 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. */
|
||
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;
|
||
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;
|
||
}
|
||
|
||
#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. */
|
||
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;
|
||
}
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* 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(
|
||
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. */
|
||
{
|
||
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;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* 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(
|
||
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. */
|
||
{
|
||
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;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* 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(
|
||
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;
|
||
unsigned int newSize = (currBytes <= UINT_MAX / 2) ? 2*currBytes : UINT_MAX;
|
||
|
||
if (currBytes == newSize) {
|
||
Tcl_Panic("max size of Tcl literal array (%d literals) exceeded",
|
||
currElems);
|
||
}
|
||
|
||
if (envPtr->mallocedLiteralArray) {
|
||
newArrayPtr = (LiteralEntry *)ckrealloc(currArrayPtr, newSize);
|
||
} else {
|
||
/*
|
||
* envPtr->literalArrayPtr isn't a ckalloc'd pointer, so we must
|
||
* code a ckrealloc equivalent for ourselves.
|
||
*/
|
||
|
||
newArrayPtr = (LiteralEntry *)ckalloc(newSize);
|
||
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 = newSize / sizeof(LiteralEntry);
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* 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. */
|
||
Tcl_Obj *objPtr) /* Points to a literal object that was
|
||
* previously created by a call to
|
||
* TclRegisterLiteral. */
|
||
{
|
||
Interp *iPtr = (Interp *) interp;
|
||
LiteralTable *globalTablePtr;
|
||
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);
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* 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(
|
||
const char *string, /* String for which to compute hash value. */
|
||
int length) /* Number of bytes in the string. */
|
||
{
|
||
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;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* 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(
|
||
LiteralTable *tablePtr)
|
||
/* Local or global table to enlarge. */
|
||
{
|
||
LiteralEntry **oldBuckets;
|
||
LiteralEntry **oldChainPtr, **newChainPtr;
|
||
LiteralEntry *entryPtr;
|
||
LiteralEntry **bucketPtr;
|
||
const char *bytes;
|
||
unsigned int oldSize;
|
||
int 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.
|
||
*/
|
||
|
||
if (oldSize > UINT_MAX/(4 * sizeof(LiteralEntry *))) {
|
||
/*
|
||
* Memory allocator limitations will not let us create the
|
||
* next larger table size. Best option is to limp along
|
||
* with what we have.
|
||
*/
|
||
|
||
return;
|
||
}
|
||
|
||
tablePtr->numBuckets *= 4;
|
||
tablePtr->buckets = (LiteralEntry **)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);
|
||
}
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* 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);
|
||
}
|
||
}
|
||
|
||
#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;
|
||
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 = (char *)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*/
|
||
|
||
#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. */
|
||
{
|
||
LiteralTable *localTablePtr = &envPtr->localLitTable;
|
||
LiteralEntry *localPtr;
|
||
char *bytes;
|
||
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 (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);
|
||
}
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* 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. */
|
||
{
|
||
LiteralTable *globalTablePtr = &iPtr->literalTable;
|
||
LiteralEntry *globalPtr;
|
||
char *bytes;
|
||
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*/
|
||
|
||
/*
|
||
* Local Variables:
|
||
* mode: c
|
||
* c-basic-offset: 4
|
||
* fill-column: 78
|
||
* End:
|
||
*/
|