os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/generic/tclLiteral.c
1.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
1.2 +++ b/os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/generic/tclLiteral.c Fri Jun 15 03:10:57 2012 +0200
1.3 @@ -0,0 +1,1054 @@
1.4 +/*
1.5 + * tclLiteral.c --
1.6 + *
1.7 + * Implementation of the global and ByteCode-local literal tables
1.8 + * used to manage the Tcl objects created for literal values during
1.9 + * compilation of Tcl scripts. This implementation borrows heavily
1.10 + * from the more general hashtable implementation of Tcl hash tables
1.11 + * that appears in tclHash.c.
1.12 + *
1.13 + * Copyright (c) 1997-1998 Sun Microsystems, Inc.
1.14 + *
1.15 + * See the file "license.terms" for information on usage and redistribution
1.16 + * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
1.17 + *
1.18 + * RCS: @(#) $Id: tclLiteral.c,v 1.11 2001/10/11 22:28:01 msofer Exp $
1.19 + */
1.20 +
1.21 +#include "tclInt.h"
1.22 +#include "tclCompile.h"
1.23 +#include "tclPort.h"
1.24 +/*
1.25 + * When there are this many entries per bucket, on average, rebuild
1.26 + * a literal's hash table to make it larger.
1.27 + */
1.28 +
1.29 +#define REBUILD_MULTIPLIER 3
1.30 +
1.31 +/*
1.32 + * Procedure prototypes for static procedures in this file:
1.33 + */
1.34 +
1.35 +static int AddLocalLiteralEntry _ANSI_ARGS_((
1.36 + CompileEnv *envPtr, LiteralEntry *globalPtr,
1.37 + int localHash));
1.38 +static void ExpandLocalLiteralArray _ANSI_ARGS_((
1.39 + CompileEnv *envPtr));
1.40 +static unsigned int HashString _ANSI_ARGS_((CONST char *bytes,
1.41 + int length));
1.42 +static void RebuildLiteralTable _ANSI_ARGS_((
1.43 + LiteralTable *tablePtr));
1.44 +
1.45 +/*
1.46 + *----------------------------------------------------------------------
1.47 + *
1.48 + * TclInitLiteralTable --
1.49 + *
1.50 + * This procedure is called to initialize the fields of a literal table
1.51 + * structure for either an interpreter or a compilation's CompileEnv
1.52 + * structure.
1.53 + *
1.54 + * Results:
1.55 + * None.
1.56 + *
1.57 + * Side effects:
1.58 + * The literal table is made ready for use.
1.59 + *
1.60 + *----------------------------------------------------------------------
1.61 + */
1.62 +
1.63 +void
1.64 +TclInitLiteralTable(tablePtr)
1.65 + register LiteralTable *tablePtr; /* Pointer to table structure, which
1.66 + * is supplied by the caller. */
1.67 +{
1.68 +#if (TCL_SMALL_HASH_TABLE != 4)
1.69 + panic("TclInitLiteralTable: TCL_SMALL_HASH_TABLE is %d, not 4\n",
1.70 + TCL_SMALL_HASH_TABLE);
1.71 +#endif
1.72 +
1.73 + tablePtr->buckets = tablePtr->staticBuckets;
1.74 + tablePtr->staticBuckets[0] = tablePtr->staticBuckets[1] = 0;
1.75 + tablePtr->staticBuckets[2] = tablePtr->staticBuckets[3] = 0;
1.76 + tablePtr->numBuckets = TCL_SMALL_HASH_TABLE;
1.77 + tablePtr->numEntries = 0;
1.78 + tablePtr->rebuildSize = TCL_SMALL_HASH_TABLE*REBUILD_MULTIPLIER;
1.79 + tablePtr->mask = 3;
1.80 +}
1.81 +
1.82 +/*
1.83 + *----------------------------------------------------------------------
1.84 + *
1.85 + * TclDeleteLiteralTable --
1.86 + *
1.87 + * This procedure frees up everything associated with a literal table
1.88 + * except for the table's structure itself.
1.89 + *
1.90 + * Results:
1.91 + * None.
1.92 + *
1.93 + * Side effects:
1.94 + * Each literal in the table is released: i.e., its reference count
1.95 + * in the global literal table is decremented and, if it becomes zero,
1.96 + * the literal is freed. In addition, the table's bucket array is
1.97 + * freed.
1.98 + *
1.99 + *----------------------------------------------------------------------
1.100 + */
1.101 +
1.102 +void
1.103 +TclDeleteLiteralTable(interp, tablePtr)
1.104 + Tcl_Interp *interp; /* Interpreter containing shared literals
1.105 + * referenced by the table to delete. */
1.106 + LiteralTable *tablePtr; /* Points to the literal table to delete. */
1.107 +{
1.108 + LiteralEntry *entryPtr;
1.109 + int i, start;
1.110 +
1.111 + /*
1.112 + * Release remaining literals in the table. Note that releasing a
1.113 + * literal might release other literals, modifying the table, so we
1.114 + * restart the search from the bucket chain we last found an entry.
1.115 + */
1.116 +
1.117 +#ifdef TCL_COMPILE_DEBUG
1.118 + TclVerifyGlobalLiteralTable((Interp *) interp);
1.119 +#endif /*TCL_COMPILE_DEBUG*/
1.120 +
1.121 + start = 0;
1.122 + while (tablePtr->numEntries > 0) {
1.123 + for (i = start; i < tablePtr->numBuckets; i++) {
1.124 + entryPtr = tablePtr->buckets[i];
1.125 + if (entryPtr != NULL) {
1.126 + TclReleaseLiteral(interp, entryPtr->objPtr);
1.127 + start = i;
1.128 + break;
1.129 + }
1.130 + }
1.131 + }
1.132 +
1.133 + /*
1.134 + * Free up the table's bucket array if it was dynamically allocated.
1.135 + */
1.136 +
1.137 + if (tablePtr->buckets != tablePtr->staticBuckets) {
1.138 + ckfree((char *) tablePtr->buckets);
1.139 + }
1.140 +}
1.141 +
1.142 +/*
1.143 + *----------------------------------------------------------------------
1.144 + *
1.145 + * TclRegisterLiteral --
1.146 + *
1.147 + * Find, or if necessary create, an object in a CompileEnv literal
1.148 + * array that has a string representation matching the argument string.
1.149 + *
1.150 + * Results:
1.151 + * The index in the CompileEnv's literal array that references a
1.152 + * shared literal matching the string. The object is created if
1.153 + * necessary.
1.154 + *
1.155 + * Side effects:
1.156 + * To maximize sharing, we look up the string in the interpreter's
1.157 + * global literal table. If not found, we create a new shared literal
1.158 + * in the global table. We then add a reference to the shared
1.159 + * literal in the CompileEnv's literal array.
1.160 + *
1.161 + * If onHeap is 1, this procedure is given ownership of the string: if
1.162 + * an object is created then its string representation is set directly
1.163 + * from string, otherwise the string is freed. Typically, a caller sets
1.164 + * onHeap 1 if "string" is an already heap-allocated buffer holding the
1.165 + * result of backslash substitutions.
1.166 + *
1.167 + *----------------------------------------------------------------------
1.168 + */
1.169 +
1.170 +int
1.171 +TclRegisterLiteral(envPtr, bytes, length, onHeap)
1.172 + CompileEnv *envPtr; /* Points to the CompileEnv in whose object
1.173 + * array an object is found or created. */
1.174 + register char *bytes; /* Points to string for which to find or
1.175 + * create an object in CompileEnv's object
1.176 + * array. */
1.177 + int length; /* Number of bytes in the string. If < 0,
1.178 + * the string consists of all bytes up to
1.179 + * the first null character. */
1.180 + int onHeap; /* If 1 then the caller already malloc'd
1.181 + * bytes and ownership is passed to this
1.182 + * procedure. */
1.183 +{
1.184 + Interp *iPtr = envPtr->iPtr;
1.185 + LiteralTable *globalTablePtr = &(iPtr->literalTable);
1.186 + LiteralTable *localTablePtr = &(envPtr->localLitTable);
1.187 + register LiteralEntry *globalPtr, *localPtr;
1.188 + register Tcl_Obj *objPtr;
1.189 + unsigned int hash;
1.190 + int localHash, globalHash, objIndex;
1.191 + long n;
1.192 + char buf[TCL_INTEGER_SPACE];
1.193 +
1.194 + if (length < 0) {
1.195 + length = (bytes? strlen(bytes) : 0);
1.196 + }
1.197 + hash = HashString(bytes, length);
1.198 +
1.199 + /*
1.200 + * Is the literal already in the CompileEnv's local literal array?
1.201 + * If so, just return its index.
1.202 + */
1.203 +
1.204 + localHash = (hash & localTablePtr->mask);
1.205 + for (localPtr = localTablePtr->buckets[localHash];
1.206 + localPtr != NULL; localPtr = localPtr->nextPtr) {
1.207 + objPtr = localPtr->objPtr;
1.208 + if ((objPtr->length == length) && ((length == 0)
1.209 + || ((objPtr->bytes[0] == bytes[0])
1.210 + && (memcmp(objPtr->bytes, bytes, (unsigned) length)
1.211 + == 0)))) {
1.212 + if (onHeap) {
1.213 + ckfree(bytes);
1.214 + }
1.215 + objIndex = (localPtr - envPtr->literalArrayPtr);
1.216 +#ifdef TCL_COMPILE_DEBUG
1.217 + TclVerifyLocalLiteralTable(envPtr);
1.218 +#endif /*TCL_COMPILE_DEBUG*/
1.219 +
1.220 + return objIndex;
1.221 + }
1.222 + }
1.223 +
1.224 + /*
1.225 + * The literal is new to this CompileEnv. Is it in the interpreter's
1.226 + * global literal table?
1.227 + */
1.228 +
1.229 + globalHash = (hash & globalTablePtr->mask);
1.230 + for (globalPtr = globalTablePtr->buckets[globalHash];
1.231 + globalPtr != NULL; globalPtr = globalPtr->nextPtr) {
1.232 + objPtr = globalPtr->objPtr;
1.233 + if ((objPtr->length == length) && ((length == 0)
1.234 + || ((objPtr->bytes[0] == bytes[0])
1.235 + && (memcmp(objPtr->bytes, bytes, (unsigned) length)
1.236 + == 0)))) {
1.237 + /*
1.238 + * A global literal was found. Add an entry to the CompileEnv's
1.239 + * local literal array.
1.240 + */
1.241 +
1.242 + if (onHeap) {
1.243 + ckfree(bytes);
1.244 + }
1.245 + objIndex = AddLocalLiteralEntry(envPtr, globalPtr, localHash);
1.246 +#ifdef TCL_COMPILE_DEBUG
1.247 + if (globalPtr->refCount < 1) {
1.248 + panic("TclRegisterLiteral: global literal \"%.*s\" had bad refCount %d",
1.249 + (length>60? 60 : length), bytes,
1.250 + globalPtr->refCount);
1.251 + }
1.252 + TclVerifyLocalLiteralTable(envPtr);
1.253 +#endif /*TCL_COMPILE_DEBUG*/
1.254 + return objIndex;
1.255 + }
1.256 + }
1.257 +
1.258 + /*
1.259 + * The literal is new to the interpreter. Add it to the global literal
1.260 + * table then add an entry to the CompileEnv's local literal array.
1.261 + * Convert the object to an integer object if possible.
1.262 + */
1.263 +
1.264 + TclNewObj(objPtr);
1.265 + Tcl_IncrRefCount(objPtr);
1.266 + if (onHeap) {
1.267 + objPtr->bytes = bytes;
1.268 + objPtr->length = length;
1.269 + } else {
1.270 + TclInitStringRep(objPtr, bytes, length);
1.271 + }
1.272 +
1.273 + if (TclLooksLikeInt(bytes, length)) {
1.274 + /*
1.275 + * From here we use the objPtr, because it is NULL terminated
1.276 + */
1.277 + if (TclGetLong((Tcl_Interp *) NULL, objPtr->bytes, &n) == TCL_OK) {
1.278 + TclFormatInt(buf, n);
1.279 + if (strcmp(objPtr->bytes, buf) == 0) {
1.280 + objPtr->internalRep.longValue = n;
1.281 + objPtr->typePtr = &tclIntType;
1.282 + }
1.283 + }
1.284 + }
1.285 +
1.286 +#ifdef TCL_COMPILE_DEBUG
1.287 + if (TclLookupLiteralEntry((Tcl_Interp *) iPtr, objPtr) != NULL) {
1.288 + panic("TclRegisterLiteral: literal \"%.*s\" found globally but shouldn't be",
1.289 + (length>60? 60 : length), bytes);
1.290 + }
1.291 +#endif
1.292 +
1.293 + globalPtr = (LiteralEntry *) ckalloc((unsigned) sizeof(LiteralEntry));
1.294 + globalPtr->objPtr = objPtr;
1.295 + globalPtr->refCount = 0;
1.296 + globalPtr->nextPtr = globalTablePtr->buckets[globalHash];
1.297 + globalTablePtr->buckets[globalHash] = globalPtr;
1.298 + globalTablePtr->numEntries++;
1.299 +
1.300 + /*
1.301 + * If the global literal table has exceeded a decent size, rebuild it
1.302 + * with more buckets.
1.303 + */
1.304 +
1.305 + if (globalTablePtr->numEntries >= globalTablePtr->rebuildSize) {
1.306 + RebuildLiteralTable(globalTablePtr);
1.307 + }
1.308 + objIndex = AddLocalLiteralEntry(envPtr, globalPtr, localHash);
1.309 +
1.310 +#ifdef TCL_COMPILE_DEBUG
1.311 + TclVerifyGlobalLiteralTable(iPtr);
1.312 + TclVerifyLocalLiteralTable(envPtr);
1.313 + {
1.314 + LiteralEntry *entryPtr;
1.315 + int found, i;
1.316 + found = 0;
1.317 + for (i = 0; i < globalTablePtr->numBuckets; i++) {
1.318 + for (entryPtr = globalTablePtr->buckets[i];
1.319 + entryPtr != NULL; entryPtr = entryPtr->nextPtr) {
1.320 + if ((entryPtr == globalPtr)
1.321 + && (entryPtr->objPtr == objPtr)) {
1.322 + found = 1;
1.323 + }
1.324 + }
1.325 + }
1.326 + if (!found) {
1.327 + panic("TclRegisterLiteral: literal \"%.*s\" wasn't global",
1.328 + (length>60? 60 : length), bytes);
1.329 + }
1.330 + }
1.331 +#endif /*TCL_COMPILE_DEBUG*/
1.332 +#ifdef TCL_COMPILE_STATS
1.333 + iPtr->stats.numLiteralsCreated++;
1.334 + iPtr->stats.totalLitStringBytes += (double) (length + 1);
1.335 + iPtr->stats.currentLitStringBytes += (double) (length + 1);
1.336 + iPtr->stats.literalCount[TclLog2(length)]++;
1.337 +#endif /*TCL_COMPILE_STATS*/
1.338 + return objIndex;
1.339 +}
1.340 +
1.341 +/*
1.342 + *----------------------------------------------------------------------
1.343 + *
1.344 + * TclLookupLiteralEntry --
1.345 + *
1.346 + * Finds the LiteralEntry that corresponds to a literal Tcl object
1.347 + * holding a literal.
1.348 + *
1.349 + * Results:
1.350 + * Returns the matching LiteralEntry if found, otherwise NULL.
1.351 + *
1.352 + * Side effects:
1.353 + * None.
1.354 + *
1.355 + *----------------------------------------------------------------------
1.356 + */
1.357 +
1.358 +LiteralEntry *
1.359 +TclLookupLiteralEntry(interp, objPtr)
1.360 + Tcl_Interp *interp; /* Interpreter for which objPtr was created
1.361 + * to hold a literal. */
1.362 + register Tcl_Obj *objPtr; /* Points to a Tcl object holding a
1.363 + * literal that was previously created by a
1.364 + * call to TclRegisterLiteral. */
1.365 +{
1.366 + Interp *iPtr = (Interp *) interp;
1.367 + LiteralTable *globalTablePtr = &(iPtr->literalTable);
1.368 + register LiteralEntry *entryPtr;
1.369 + char *bytes;
1.370 + int length, globalHash;
1.371 +
1.372 + bytes = Tcl_GetStringFromObj(objPtr, &length);
1.373 + globalHash = (HashString(bytes, length) & globalTablePtr->mask);
1.374 + for (entryPtr = globalTablePtr->buckets[globalHash];
1.375 + entryPtr != NULL; entryPtr = entryPtr->nextPtr) {
1.376 + if (entryPtr->objPtr == objPtr) {
1.377 + return entryPtr;
1.378 + }
1.379 + }
1.380 + return NULL;
1.381 +}
1.382 +
1.383 +/*
1.384 + *----------------------------------------------------------------------
1.385 + *
1.386 + * TclHideLiteral --
1.387 + *
1.388 + * Remove a literal entry from the literal hash tables, leaving it in
1.389 + * the literal array so existing references continue to function.
1.390 + * This makes it possible to turn a shared literal into a private
1.391 + * literal that cannot be shared.
1.392 + *
1.393 + * Results:
1.394 + * None.
1.395 + *
1.396 + * Side effects:
1.397 + * Removes the literal from the local hash table and decrements the
1.398 + * global hash entry's reference count.
1.399 + *
1.400 + *----------------------------------------------------------------------
1.401 + */
1.402 +
1.403 +void
1.404 +TclHideLiteral(interp, envPtr, index)
1.405 + Tcl_Interp *interp; /* Interpreter for which objPtr was created
1.406 + * to hold a literal. */
1.407 + register CompileEnv *envPtr; /* Points to CompileEnv whose literal array
1.408 + * contains the entry being hidden. */
1.409 + int index; /* The index of the entry in the literal
1.410 + * array. */
1.411 +{
1.412 + LiteralEntry **nextPtrPtr, *entryPtr, *lPtr;
1.413 + LiteralTable *localTablePtr = &(envPtr->localLitTable);
1.414 + int localHash, length;
1.415 + char *bytes;
1.416 + Tcl_Obj *newObjPtr;
1.417 +
1.418 + lPtr = &(envPtr->literalArrayPtr[index]);
1.419 +
1.420 + /*
1.421 + * To avoid unwanted sharing we need to copy the object and remove it from
1.422 + * the local and global literal tables. It still has a slot in the literal
1.423 + * array so it can be referred to by byte codes, but it will not be matched
1.424 + * by literal searches.
1.425 + */
1.426 +
1.427 + newObjPtr = Tcl_DuplicateObj(lPtr->objPtr);
1.428 + Tcl_IncrRefCount(newObjPtr);
1.429 + TclReleaseLiteral(interp, lPtr->objPtr);
1.430 + lPtr->objPtr = newObjPtr;
1.431 +
1.432 + bytes = Tcl_GetStringFromObj(newObjPtr, &length);
1.433 + localHash = (HashString(bytes, length) & localTablePtr->mask);
1.434 + nextPtrPtr = &localTablePtr->buckets[localHash];
1.435 +
1.436 + for (entryPtr = *nextPtrPtr; entryPtr != NULL; entryPtr = *nextPtrPtr) {
1.437 + if (entryPtr == lPtr) {
1.438 + *nextPtrPtr = lPtr->nextPtr;
1.439 + lPtr->nextPtr = NULL;
1.440 + localTablePtr->numEntries--;
1.441 + break;
1.442 + }
1.443 + nextPtrPtr = &entryPtr->nextPtr;
1.444 + }
1.445 +}
1.446 +
1.447 +/*
1.448 + *----------------------------------------------------------------------
1.449 + *
1.450 + * TclAddLiteralObj --
1.451 + *
1.452 + * Add a single literal object to the literal array. This
1.453 + * function does not add the literal to the local or global
1.454 + * literal tables. The caller is expected to add the entry
1.455 + * to whatever tables are appropriate.
1.456 + *
1.457 + * Results:
1.458 + * The index in the CompileEnv's literal array that references the
1.459 + * literal. Stores the pointer to the new literal entry in the
1.460 + * location referenced by the localPtrPtr argument.
1.461 + *
1.462 + * Side effects:
1.463 + * Expands the literal array if necessary. Increments the refcount
1.464 + * on the literal object.
1.465 + *
1.466 + *----------------------------------------------------------------------
1.467 + */
1.468 +
1.469 +int
1.470 +TclAddLiteralObj(envPtr, objPtr, litPtrPtr)
1.471 + register CompileEnv *envPtr; /* Points to CompileEnv in whose literal
1.472 + * array the object is to be inserted. */
1.473 + Tcl_Obj *objPtr; /* The object to insert into the array. */
1.474 + LiteralEntry **litPtrPtr; /* The location where the pointer to the
1.475 + * new literal entry should be stored.
1.476 + * May be NULL. */
1.477 +{
1.478 + register LiteralEntry *lPtr;
1.479 + int objIndex;
1.480 +
1.481 + if (envPtr->literalArrayNext >= envPtr->literalArrayEnd) {
1.482 + ExpandLocalLiteralArray(envPtr);
1.483 + }
1.484 + objIndex = envPtr->literalArrayNext;
1.485 + envPtr->literalArrayNext++;
1.486 +
1.487 + lPtr = &(envPtr->literalArrayPtr[objIndex]);
1.488 + lPtr->objPtr = objPtr;
1.489 + Tcl_IncrRefCount(objPtr);
1.490 + lPtr->refCount = -1; /* i.e., unused */
1.491 + lPtr->nextPtr = NULL;
1.492 +
1.493 + if (litPtrPtr) {
1.494 + *litPtrPtr = lPtr;
1.495 + }
1.496 +
1.497 + return objIndex;
1.498 +}
1.499 +
1.500 +/*
1.501 + *----------------------------------------------------------------------
1.502 + *
1.503 + * AddLocalLiteralEntry --
1.504 + *
1.505 + * Insert a new literal into a CompileEnv's local literal array.
1.506 + *
1.507 + * Results:
1.508 + * The index in the CompileEnv's literal array that references the
1.509 + * literal.
1.510 + *
1.511 + * Side effects:
1.512 + * Increments the ref count of the global LiteralEntry since the
1.513 + * CompileEnv now refers to the literal. Expands the literal array
1.514 + * if necessary. May rebuild the hash bucket array of the CompileEnv's
1.515 + * literal array if it becomes too large.
1.516 + *
1.517 + *----------------------------------------------------------------------
1.518 + */
1.519 +
1.520 +static int
1.521 +AddLocalLiteralEntry(envPtr, globalPtr, localHash)
1.522 + register CompileEnv *envPtr; /* Points to CompileEnv in whose literal
1.523 + * array the object is to be inserted. */
1.524 + LiteralEntry *globalPtr; /* Points to the global LiteralEntry for
1.525 + * the literal to add to the CompileEnv. */
1.526 + int localHash; /* Hash value for the literal's string. */
1.527 +{
1.528 + register LiteralTable *localTablePtr = &(envPtr->localLitTable);
1.529 + LiteralEntry *localPtr;
1.530 + int objIndex;
1.531 +
1.532 + objIndex = TclAddLiteralObj(envPtr, globalPtr->objPtr, &localPtr);
1.533 +
1.534 + /*
1.535 + * Add the literal to the local table.
1.536 + */
1.537 +
1.538 + localPtr->nextPtr = localTablePtr->buckets[localHash];
1.539 + localTablePtr->buckets[localHash] = localPtr;
1.540 + localTablePtr->numEntries++;
1.541 +
1.542 + globalPtr->refCount++;
1.543 +
1.544 + /*
1.545 + * If the CompileEnv's local literal table has exceeded a decent size,
1.546 + * rebuild it with more buckets.
1.547 + */
1.548 +
1.549 + if (localTablePtr->numEntries >= localTablePtr->rebuildSize) {
1.550 + RebuildLiteralTable(localTablePtr);
1.551 + }
1.552 +
1.553 +#ifdef TCL_COMPILE_DEBUG
1.554 + TclVerifyLocalLiteralTable(envPtr);
1.555 + {
1.556 + char *bytes;
1.557 + int length, found, i;
1.558 + found = 0;
1.559 + for (i = 0; i < localTablePtr->numBuckets; i++) {
1.560 + for (localPtr = localTablePtr->buckets[i];
1.561 + localPtr != NULL; localPtr = localPtr->nextPtr) {
1.562 + if (localPtr->objPtr == globalPtr->objPtr) {
1.563 + found = 1;
1.564 + }
1.565 + }
1.566 + }
1.567 + if (!found) {
1.568 + bytes = Tcl_GetStringFromObj(globalPtr->objPtr, &length);
1.569 + panic("AddLocalLiteralEntry: literal \"%.*s\" wasn't found locally",
1.570 + (length>60? 60 : length), bytes);
1.571 + }
1.572 + }
1.573 +#endif /*TCL_COMPILE_DEBUG*/
1.574 + return objIndex;
1.575 +}
1.576 +
1.577 +/*
1.578 + *----------------------------------------------------------------------
1.579 + *
1.580 + * ExpandLocalLiteralArray --
1.581 + *
1.582 + * Procedure that uses malloc to allocate more storage for a
1.583 + * CompileEnv's local literal array.
1.584 + *
1.585 + * Results:
1.586 + * None.
1.587 + *
1.588 + * Side effects:
1.589 + * The literal array in *envPtr is reallocated to a new array of
1.590 + * double the size, and if envPtr->mallocedLiteralArray is non-zero
1.591 + * the old array is freed. Entries are copied from the old array
1.592 + * to the new one. The local literal table is updated to refer to
1.593 + * the new entries.
1.594 + *
1.595 + *----------------------------------------------------------------------
1.596 + */
1.597 +
1.598 +static void
1.599 +ExpandLocalLiteralArray(envPtr)
1.600 + register CompileEnv *envPtr; /* Points to the CompileEnv whose object
1.601 + * array must be enlarged. */
1.602 +{
1.603 + /*
1.604 + * The current allocated local literal entries are stored between
1.605 + * elements 0 and (envPtr->literalArrayNext - 1) [inclusive].
1.606 + */
1.607 +
1.608 + LiteralTable *localTablePtr = &(envPtr->localLitTable);
1.609 + int currElems = envPtr->literalArrayNext;
1.610 + size_t currBytes = (currElems * sizeof(LiteralEntry));
1.611 + register LiteralEntry *currArrayPtr = envPtr->literalArrayPtr;
1.612 + register LiteralEntry *newArrayPtr =
1.613 + (LiteralEntry *) ckalloc((unsigned) (2 * currBytes));
1.614 + int i;
1.615 +
1.616 + /*
1.617 + * Copy from the old literal array to the new, then update the local
1.618 + * literal table's bucket array.
1.619 + */
1.620 +
1.621 + memcpy((VOID *) newArrayPtr, (VOID *) currArrayPtr, currBytes);
1.622 + for (i = 0; i < currElems; i++) {
1.623 + if (currArrayPtr[i].nextPtr == NULL) {
1.624 + newArrayPtr[i].nextPtr = NULL;
1.625 + } else {
1.626 + newArrayPtr[i].nextPtr = newArrayPtr
1.627 + + (currArrayPtr[i].nextPtr - currArrayPtr);
1.628 + }
1.629 + }
1.630 + for (i = 0; i < localTablePtr->numBuckets; i++) {
1.631 + if (localTablePtr->buckets[i] != NULL) {
1.632 + localTablePtr->buckets[i] = newArrayPtr
1.633 + + (localTablePtr->buckets[i] - currArrayPtr);
1.634 + }
1.635 + }
1.636 +
1.637 + /*
1.638 + * Free the old literal array if needed, and mark the new literal
1.639 + * array as malloced.
1.640 + */
1.641 +
1.642 + if (envPtr->mallocedLiteralArray) {
1.643 + ckfree((char *) currArrayPtr);
1.644 + }
1.645 + envPtr->literalArrayPtr = newArrayPtr;
1.646 + envPtr->literalArrayEnd = (2 * currElems);
1.647 + envPtr->mallocedLiteralArray = 1;
1.648 +}
1.649 +
1.650 +/*
1.651 + *----------------------------------------------------------------------
1.652 + *
1.653 + * TclReleaseLiteral --
1.654 + *
1.655 + * This procedure releases a reference to one of the shared Tcl objects
1.656 + * that hold literals. It is called to release the literals referenced
1.657 + * by a ByteCode that is being destroyed, and it is also called by
1.658 + * TclDeleteLiteralTable.
1.659 + *
1.660 + * Results:
1.661 + * None.
1.662 + *
1.663 + * Side effects:
1.664 + * The reference count for the global LiteralTable entry that
1.665 + * corresponds to the literal is decremented. If no other reference
1.666 + * to a global literal object remains, it is freed.
1.667 + *
1.668 + *----------------------------------------------------------------------
1.669 + */
1.670 +
1.671 +void
1.672 +TclReleaseLiteral(interp, objPtr)
1.673 + Tcl_Interp *interp; /* Interpreter for which objPtr was created
1.674 + * to hold a literal. */
1.675 + register Tcl_Obj *objPtr; /* Points to a literal object that was
1.676 + * previously created by a call to
1.677 + * TclRegisterLiteral. */
1.678 +{
1.679 + Interp *iPtr = (Interp *) interp;
1.680 + LiteralTable *globalTablePtr = &(iPtr->literalTable);
1.681 + register LiteralEntry *entryPtr, *prevPtr;
1.682 + ByteCode* codePtr;
1.683 + char *bytes;
1.684 + int length, index;
1.685 +
1.686 + bytes = Tcl_GetStringFromObj(objPtr, &length);
1.687 + index = (HashString(bytes, length) & globalTablePtr->mask);
1.688 +
1.689 + /*
1.690 + * Check to see if the object is in the global literal table and
1.691 + * remove this reference. The object may not be in the table if
1.692 + * it is a hidden local literal.
1.693 + */
1.694 +
1.695 + for (prevPtr = NULL, entryPtr = globalTablePtr->buckets[index];
1.696 + entryPtr != NULL;
1.697 + prevPtr = entryPtr, entryPtr = entryPtr->nextPtr) {
1.698 + if (entryPtr->objPtr == objPtr) {
1.699 + entryPtr->refCount--;
1.700 +
1.701 + /*
1.702 + * If the literal is no longer being used by any ByteCode,
1.703 + * delete the entry then remove the reference corresponding
1.704 + * to the global literal table entry (decrement the ref count
1.705 + * of the object).
1.706 + */
1.707 +
1.708 + if (entryPtr->refCount == 0) {
1.709 + if (prevPtr == NULL) {
1.710 + globalTablePtr->buckets[index] = entryPtr->nextPtr;
1.711 + } else {
1.712 + prevPtr->nextPtr = entryPtr->nextPtr;
1.713 + }
1.714 + ckfree((char *) entryPtr);
1.715 + globalTablePtr->numEntries--;
1.716 +
1.717 + TclDecrRefCount(objPtr);
1.718 +
1.719 + /*
1.720 + * Check if the LiteralEntry is only being kept alive by
1.721 + * a circular reference from a ByteCode stored as its
1.722 + * internal rep. In that case, set the ByteCode object array
1.723 + * entry NULL to signal to TclCleanupByteCode to not try to
1.724 + * release this about to be freed literal again.
1.725 + */
1.726 +
1.727 + if (objPtr->typePtr == &tclByteCodeType) {
1.728 + codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
1.729 + if ((codePtr->numLitObjects == 1)
1.730 + && (codePtr->objArrayPtr[0] == objPtr)) {
1.731 + codePtr->objArrayPtr[0] = NULL;
1.732 + }
1.733 + }
1.734 +
1.735 +#ifdef TCL_COMPILE_STATS
1.736 + iPtr->stats.currentLitStringBytes -= (double) (length + 1);
1.737 +#endif /*TCL_COMPILE_STATS*/
1.738 + }
1.739 + break;
1.740 + }
1.741 + }
1.742 +
1.743 + /*
1.744 + * Remove the reference corresponding to the local literal table
1.745 + * entry.
1.746 + */
1.747 +
1.748 + Tcl_DecrRefCount(objPtr);
1.749 +}
1.750 +
1.751 +/*
1.752 + *----------------------------------------------------------------------
1.753 + *
1.754 + * HashString --
1.755 + *
1.756 + * Compute a one-word summary of a text string, which can be
1.757 + * used to generate a hash index.
1.758 + *
1.759 + * Results:
1.760 + * The return value is a one-word summary of the information in
1.761 + * string.
1.762 + *
1.763 + * Side effects:
1.764 + * None.
1.765 + *
1.766 + *----------------------------------------------------------------------
1.767 + */
1.768 +
1.769 +static unsigned int
1.770 +HashString(bytes, length)
1.771 + register CONST char *bytes; /* String for which to compute hash
1.772 + * value. */
1.773 + int length; /* Number of bytes in the string. */
1.774 +{
1.775 + register unsigned int result;
1.776 + register int i;
1.777 +
1.778 + /*
1.779 + * I tried a zillion different hash functions and asked many other
1.780 + * people for advice. Many people had their own favorite functions,
1.781 + * all different, but no-one had much idea why they were good ones.
1.782 + * I chose the one below (multiply by 9 and add new character)
1.783 + * because of the following reasons:
1.784 + *
1.785 + * 1. Multiplying by 10 is perfect for keys that are decimal strings,
1.786 + * and multiplying by 9 is just about as good.
1.787 + * 2. Times-9 is (shift-left-3) plus (old). This means that each
1.788 + * character's bits hang around in the low-order bits of the
1.789 + * hash value for ever, plus they spread fairly rapidly up to
1.790 + * the high-order bits to fill out the hash value. This seems
1.791 + * works well both for decimal and non-decimal strings.
1.792 + */
1.793 +
1.794 + result = 0;
1.795 + for (i = 0; i < length; i++) {
1.796 + result += (result<<3) + *bytes++;
1.797 + }
1.798 + return result;
1.799 +}
1.800 +
1.801 +/*
1.802 + *----------------------------------------------------------------------
1.803 + *
1.804 + * RebuildLiteralTable --
1.805 + *
1.806 + * This procedure is invoked when the ratio of entries to hash buckets
1.807 + * becomes too large in a local or global literal table. It allocates
1.808 + * a larger bucket array and moves the entries into the new buckets.
1.809 + *
1.810 + * Results:
1.811 + * None.
1.812 + *
1.813 + * Side effects:
1.814 + * Memory gets reallocated and entries get rehashed into new buckets.
1.815 + *
1.816 + *----------------------------------------------------------------------
1.817 + */
1.818 +
1.819 +static void
1.820 +RebuildLiteralTable(tablePtr)
1.821 + register LiteralTable *tablePtr; /* Local or global table to enlarge. */
1.822 +{
1.823 + LiteralEntry **oldBuckets;
1.824 + register LiteralEntry **oldChainPtr, **newChainPtr;
1.825 + register LiteralEntry *entryPtr;
1.826 + LiteralEntry **bucketPtr;
1.827 + char *bytes;
1.828 + int oldSize, count, index, length;
1.829 +
1.830 + oldSize = tablePtr->numBuckets;
1.831 + oldBuckets = tablePtr->buckets;
1.832 +
1.833 + /*
1.834 + * Allocate and initialize the new bucket array, and set up
1.835 + * hashing constants for new array size.
1.836 + */
1.837 +
1.838 + tablePtr->numBuckets *= 4;
1.839 + tablePtr->buckets = (LiteralEntry **) ckalloc((unsigned)
1.840 + (tablePtr->numBuckets * sizeof(LiteralEntry *)));
1.841 + for (count = tablePtr->numBuckets, newChainPtr = tablePtr->buckets;
1.842 + count > 0;
1.843 + count--, newChainPtr++) {
1.844 + *newChainPtr = NULL;
1.845 + }
1.846 + tablePtr->rebuildSize *= 4;
1.847 + tablePtr->mask = (tablePtr->mask << 2) + 3;
1.848 +
1.849 + /*
1.850 + * Rehash all of the existing entries into the new bucket array.
1.851 + */
1.852 +
1.853 + for (oldChainPtr = oldBuckets;
1.854 + oldSize > 0;
1.855 + oldSize--, oldChainPtr++) {
1.856 + for (entryPtr = *oldChainPtr; entryPtr != NULL;
1.857 + entryPtr = *oldChainPtr) {
1.858 + bytes = Tcl_GetStringFromObj(entryPtr->objPtr, &length);
1.859 + index = (HashString(bytes, length) & tablePtr->mask);
1.860 +
1.861 + *oldChainPtr = entryPtr->nextPtr;
1.862 + bucketPtr = &(tablePtr->buckets[index]);
1.863 + entryPtr->nextPtr = *bucketPtr;
1.864 + *bucketPtr = entryPtr;
1.865 + }
1.866 + }
1.867 +
1.868 + /*
1.869 + * Free up the old bucket array, if it was dynamically allocated.
1.870 + */
1.871 +
1.872 + if (oldBuckets != tablePtr->staticBuckets) {
1.873 + ckfree((char *) oldBuckets);
1.874 + }
1.875 +}
1.876 +
1.877 +#ifdef TCL_COMPILE_STATS
1.878 +/*
1.879 + *----------------------------------------------------------------------
1.880 + *
1.881 + * TclLiteralStats --
1.882 + *
1.883 + * Return statistics describing the layout of the hash table
1.884 + * in its hash buckets.
1.885 + *
1.886 + * Results:
1.887 + * The return value is a malloc-ed string containing information
1.888 + * about tablePtr. It is the caller's responsibility to free
1.889 + * this string.
1.890 + *
1.891 + * Side effects:
1.892 + * None.
1.893 + *
1.894 + *----------------------------------------------------------------------
1.895 + */
1.896 +
1.897 +char *
1.898 +TclLiteralStats(tablePtr)
1.899 + LiteralTable *tablePtr; /* Table for which to produce stats. */
1.900 +{
1.901 +#define NUM_COUNTERS 10
1.902 + int count[NUM_COUNTERS], overflow, i, j;
1.903 + double average, tmp;
1.904 + register LiteralEntry *entryPtr;
1.905 + char *result, *p;
1.906 +
1.907 + /*
1.908 + * Compute a histogram of bucket usage. For each bucket chain i,
1.909 + * j is the number of entries in the chain.
1.910 + */
1.911 +
1.912 + for (i = 0; i < NUM_COUNTERS; i++) {
1.913 + count[i] = 0;
1.914 + }
1.915 + overflow = 0;
1.916 + average = 0.0;
1.917 + for (i = 0; i < tablePtr->numBuckets; i++) {
1.918 + j = 0;
1.919 + for (entryPtr = tablePtr->buckets[i]; entryPtr != NULL;
1.920 + entryPtr = entryPtr->nextPtr) {
1.921 + j++;
1.922 + }
1.923 + if (j < NUM_COUNTERS) {
1.924 + count[j]++;
1.925 + } else {
1.926 + overflow++;
1.927 + }
1.928 + tmp = j;
1.929 + average += (tmp+1.0)*(tmp/tablePtr->numEntries)/2.0;
1.930 + }
1.931 +
1.932 + /*
1.933 + * Print out the histogram and a few other pieces of information.
1.934 + */
1.935 +
1.936 + result = (char *) ckalloc((unsigned) ((NUM_COUNTERS*60) + 300));
1.937 + sprintf(result, "%d entries in table, %d buckets\n",
1.938 + tablePtr->numEntries, tablePtr->numBuckets);
1.939 + p = result + strlen(result);
1.940 + for (i = 0; i < NUM_COUNTERS; i++) {
1.941 + sprintf(p, "number of buckets with %d entries: %d\n",
1.942 + i, count[i]);
1.943 + p += strlen(p);
1.944 + }
1.945 + sprintf(p, "number of buckets with %d or more entries: %d\n",
1.946 + NUM_COUNTERS, overflow);
1.947 + p += strlen(p);
1.948 + sprintf(p, "average search distance for entry: %.1f", average);
1.949 + return result;
1.950 +}
1.951 +#endif /*TCL_COMPILE_STATS*/
1.952 +
1.953 +#ifdef TCL_COMPILE_DEBUG
1.954 +/*
1.955 + *----------------------------------------------------------------------
1.956 + *
1.957 + * TclVerifyLocalLiteralTable --
1.958 + *
1.959 + * Check a CompileEnv's local literal table for consistency.
1.960 + *
1.961 + * Results:
1.962 + * None.
1.963 + *
1.964 + * Side effects:
1.965 + * Panics if problems are found.
1.966 + *
1.967 + *----------------------------------------------------------------------
1.968 + */
1.969 +
1.970 +void
1.971 +TclVerifyLocalLiteralTable(envPtr)
1.972 + CompileEnv *envPtr; /* Points to CompileEnv whose literal
1.973 + * table is to be validated. */
1.974 +{
1.975 + register LiteralTable *localTablePtr = &(envPtr->localLitTable);
1.976 + register LiteralEntry *localPtr;
1.977 + char *bytes;
1.978 + register int i;
1.979 + int length, count;
1.980 +
1.981 + count = 0;
1.982 + for (i = 0; i < localTablePtr->numBuckets; i++) {
1.983 + for (localPtr = localTablePtr->buckets[i];
1.984 + localPtr != NULL; localPtr = localPtr->nextPtr) {
1.985 + count++;
1.986 + if (localPtr->refCount != -1) {
1.987 + bytes = Tcl_GetStringFromObj(localPtr->objPtr, &length);
1.988 + panic("TclVerifyLocalLiteralTable: local literal \"%.*s\" had bad refCount %d",
1.989 + (length>60? 60 : length), bytes,
1.990 + localPtr->refCount);
1.991 + }
1.992 + if (TclLookupLiteralEntry((Tcl_Interp *) envPtr->iPtr,
1.993 + localPtr->objPtr) == NULL) {
1.994 + bytes = Tcl_GetStringFromObj(localPtr->objPtr, &length);
1.995 + panic("TclVerifyLocalLiteralTable: local literal \"%.*s\" is not global",
1.996 + (length>60? 60 : length), bytes);
1.997 + }
1.998 + if (localPtr->objPtr->bytes == NULL) {
1.999 + panic("TclVerifyLocalLiteralTable: literal has NULL string rep");
1.1000 + }
1.1001 + }
1.1002 + }
1.1003 + if (count != localTablePtr->numEntries) {
1.1004 + panic("TclVerifyLocalLiteralTable: local literal table had %d entries, should be %d",
1.1005 + count, localTablePtr->numEntries);
1.1006 + }
1.1007 +}
1.1008 +
1.1009 +/*
1.1010 + *----------------------------------------------------------------------
1.1011 + *
1.1012 + * TclVerifyGlobalLiteralTable --
1.1013 + *
1.1014 + * Check an interpreter's global literal table literal for consistency.
1.1015 + *
1.1016 + * Results:
1.1017 + * None.
1.1018 + *
1.1019 + * Side effects:
1.1020 + * Panics if problems are found.
1.1021 + *
1.1022 + *----------------------------------------------------------------------
1.1023 + */
1.1024 +
1.1025 +void
1.1026 +TclVerifyGlobalLiteralTable(iPtr)
1.1027 + Interp *iPtr; /* Points to interpreter whose global
1.1028 + * literal table is to be validated. */
1.1029 +{
1.1030 + register LiteralTable *globalTablePtr = &(iPtr->literalTable);
1.1031 + register LiteralEntry *globalPtr;
1.1032 + char *bytes;
1.1033 + register int i;
1.1034 + int length, count;
1.1035 +
1.1036 + count = 0;
1.1037 + for (i = 0; i < globalTablePtr->numBuckets; i++) {
1.1038 + for (globalPtr = globalTablePtr->buckets[i];
1.1039 + globalPtr != NULL; globalPtr = globalPtr->nextPtr) {
1.1040 + count++;
1.1041 + if (globalPtr->refCount < 1) {
1.1042 + bytes = Tcl_GetStringFromObj(globalPtr->objPtr, &length);
1.1043 + panic("TclVerifyGlobalLiteralTable: global literal \"%.*s\" had bad refCount %d",
1.1044 + (length>60? 60 : length), bytes,
1.1045 + globalPtr->refCount);
1.1046 + }
1.1047 + if (globalPtr->objPtr->bytes == NULL) {
1.1048 + panic("TclVerifyGlobalLiteralTable: literal has NULL string rep");
1.1049 + }
1.1050 + }
1.1051 + }
1.1052 + if (count != globalTablePtr->numEntries) {
1.1053 + panic("TclVerifyGlobalLiteralTable: global literal table had %d entries, should be %d",
1.1054 + count, globalTablePtr->numEntries);
1.1055 + }
1.1056 +}
1.1057 +#endif /*TCL_COMPILE_DEBUG*/