tclLiteral.c

Go to the documentation of this file.
00001 /*
00002  * tclLiteral.c --
00003  *
00004  *      Implementation of the global and ByteCode-local literal tables used to
00005  *      manage the Tcl objects created for literal values during compilation
00006  *      of Tcl scripts. This implementation borrows heavily from the more
00007  *      general hashtable implementation of Tcl hash tables that appears in
00008  *      tclHash.c.
00009  *
00010  * Copyright (c) 1997-1998 Sun Microsystems, Inc.
00011  * Copyright (c) 2004 by Kevin B. Kenny.  All rights reserved.
00012  *
00013  * See the file "license.terms" for information on usage and redistribution of
00014  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
00015  *
00016  * RCS: @(#) $Id: tclLiteral.c,v 1.33 2007/12/13 15:23:19 dgp Exp $
00017  */
00018 
00019 #include "tclInt.h"
00020 #include "tclCompile.h"
00021 
00022 /*
00023  * When there are this many entries per bucket, on average, rebuild a
00024  * literal's hash table to make it larger.
00025  */
00026 
00027 #define REBUILD_MULTIPLIER      3
00028 
00029 /*
00030  * Function prototypes for static functions in this file:
00031  */
00032 
00033 static int              AddLocalLiteralEntry(CompileEnv *envPtr,
00034                             Tcl_Obj *objPtr, int localHash);
00035 static void             ExpandLocalLiteralArray(CompileEnv *envPtr);
00036 static unsigned int     HashString(const char *bytes, int length);
00037 static void             RebuildLiteralTable(LiteralTable *tablePtr);
00038 
00039 /*
00040  *----------------------------------------------------------------------
00041  *
00042  * TclInitLiteralTable --
00043  *
00044  *      This function is called to initialize the fields of a literal table
00045  *      structure for either an interpreter or a compilation's CompileEnv
00046  *      structure.
00047  *
00048  * Results:
00049  *      None.
00050  *
00051  * Side effects:
00052  *      The literal table is made ready for use.
00053  *
00054  *----------------------------------------------------------------------
00055  */
00056 
00057 void
00058 TclInitLiteralTable(
00059     register LiteralTable *tablePtr)
00060                                 /* Pointer to table structure, which is
00061                                  * supplied by the caller. */
00062 {
00063 #if (TCL_SMALL_HASH_TABLE != 4)
00064     Tcl_Panic("TclInitLiteralTable: TCL_SMALL_HASH_TABLE is %d, not 4",
00065             TCL_SMALL_HASH_TABLE);
00066 #endif
00067 
00068     tablePtr->buckets = tablePtr->staticBuckets;
00069     tablePtr->staticBuckets[0] = tablePtr->staticBuckets[1] = 0;
00070     tablePtr->staticBuckets[2] = tablePtr->staticBuckets[3] = 0;
00071     tablePtr->numBuckets = TCL_SMALL_HASH_TABLE;
00072     tablePtr->numEntries = 0;
00073     tablePtr->rebuildSize = TCL_SMALL_HASH_TABLE * REBUILD_MULTIPLIER;
00074     tablePtr->mask = 3;
00075 }
00076 
00077 /*
00078  *----------------------------------------------------------------------
00079  *
00080  * TclCleanupLiteralTable --
00081  *
00082  *      This function frees the internal representation of every literal in a
00083  *      literal table. It is called prior to deleting an interp, so that
00084  *      variable refs will be cleaned up properly.
00085  *
00086  * Results:
00087  *      None.
00088  *
00089  * Side effects:
00090  *      Each literal in the table has its internal representation freed.
00091  *
00092  *----------------------------------------------------------------------
00093  */
00094 
00095 void
00096 TclCleanupLiteralTable(
00097     Tcl_Interp *interp,         /* Interpreter containing literals to purge */
00098     LiteralTable *tablePtr)     /* Points to the literal table being
00099                                  * cleaned. */
00100 {
00101     int i;
00102     LiteralEntry* entryPtr;     /* Pointer to the current entry in the hash
00103                                  * table of literals. */
00104     LiteralEntry* nextPtr;      /* Pointer to the next entry in the bucket. */
00105     Tcl_Obj* objPtr;            /* Pointer to a literal object whose internal
00106                                  * rep is being freed. */
00107     const Tcl_ObjType* typePtr; /* Pointer to the object's type. */
00108     int didOne;                 /* Flag for whether we've removed a literal in
00109                                  * the current bucket. */
00110 
00111 #ifdef TCL_COMPILE_DEBUG
00112     TclVerifyGlobalLiteralTable((Interp *) interp);
00113 #endif /* TCL_COMPILE_DEBUG */
00114 
00115     for (i=0 ; i<tablePtr->numBuckets ; i++) {
00116         /*
00117          * It is tempting simply to walk each hash bucket once and delete the
00118          * internal representations of each literal in turn. It's also wrong.
00119          * The problem is that freeing a literal's internal representation can
00120          * delete other literals to which it refers, making nextPtr invalid.
00121          * So each time we free an internal rep, we start its bucket over
00122          * again.
00123          */
00124 
00125         do {
00126             didOne = 0;
00127             entryPtr = tablePtr->buckets[i];
00128             while (entryPtr != NULL) {
00129                 objPtr = entryPtr->objPtr;
00130                 nextPtr = entryPtr->nextPtr;
00131                 typePtr = objPtr->typePtr;
00132                 if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) {
00133                     if (objPtr->bytes == NULL) {
00134                         Tcl_Panic( "literal without a string rep" );
00135                     }
00136                     objPtr->typePtr = NULL;
00137                     typePtr->freeIntRepProc(objPtr);
00138                     didOne = 1;
00139                 } else {
00140                     entryPtr = nextPtr;
00141                 }
00142             }
00143         } while (didOne);
00144     }
00145 }
00146 
00147 /*
00148  *----------------------------------------------------------------------
00149  *
00150  * TclDeleteLiteralTable --
00151  *
00152  *      This function frees up everything associated with a literal table
00153  *      except for the table's structure itself. It is called when the
00154  *      interpreter is deleted.
00155  *
00156  * Results:
00157  *      None.
00158  *
00159  * Side effects:
00160  *      Each literal in the table is released: i.e., its reference count in
00161  *      the global literal table is decremented and, if it becomes zero, the
00162  *      literal is freed. In addition, the table's bucket array is freed.
00163  *
00164  *----------------------------------------------------------------------
00165  */
00166 
00167 void
00168 TclDeleteLiteralTable(
00169     Tcl_Interp *interp,         /* Interpreter containing shared literals
00170                                  * referenced by the table to delete. */
00171     LiteralTable *tablePtr)     /* Points to the literal table to delete. */
00172 {
00173     LiteralEntry *entryPtr, *nextPtr;
00174     Tcl_Obj *objPtr;
00175     int i;
00176 
00177     /*
00178      * Release remaining literals in the table. Note that releasing a literal
00179      * might release other literals, modifying the table, so we restart the
00180      * search from the bucket chain we last found an entry.
00181      */
00182 
00183 #ifdef TCL_COMPILE_DEBUG
00184     TclVerifyGlobalLiteralTable((Interp *) interp);
00185 #endif /*TCL_COMPILE_DEBUG*/
00186 
00187     /*
00188      * We used to call TclReleaseLiteral for each literal in the table, which
00189      * is rather inefficient as it causes one lookup-by-hash for each
00190      * reference to the literal. We now rely at interp-deletion on each
00191      * bytecode object to release its references to the literal Tcl_Obj
00192      * without requiring that it updates the global table itself, and deal
00193      * here only with the table.
00194      */
00195 
00196     for (i=0 ; i<tablePtr->numBuckets ; i++) {
00197         entryPtr = tablePtr->buckets[i];
00198         while (entryPtr != NULL) {
00199             objPtr = entryPtr->objPtr;
00200             TclDecrRefCount(objPtr);
00201             nextPtr = entryPtr->nextPtr;
00202             ckfree((char *) entryPtr);
00203             entryPtr = nextPtr;
00204         }
00205     }
00206 
00207     /*
00208      * Free up the table's bucket array if it was dynamically allocated.
00209      */
00210 
00211     if (tablePtr->buckets != tablePtr->staticBuckets) {
00212         ckfree((char *) tablePtr->buckets);
00213     }
00214 }
00215 
00216 /*
00217  *----------------------------------------------------------------------
00218  *
00219  * TclCreateLiteral --
00220  *
00221  *      Find, or if necessary create, an object in the interpreter's literal
00222  *      table that has a string representation matching the argument
00223  *      string. If nsPtr!=NULL then only literals stored for the namespace are
00224  *      considered. 
00225  *
00226  * Results:
00227  *      The literal object. If it was created in this call *newPtr is set to
00228  *      1, else 0. NULL is returned if newPtr==NULL and no literal is found.
00229  *
00230  * Side effects:
00231  *      Increments the ref count of the global LiteralEntry since the caller
00232  *      now holds a reference. 
00233  *      If LITERAL_ON_HEAP is set in flags, this function is given ownership
00234  *      of the string: if an object is created then its string representation
00235  *      is set directly from string, otherwise the string is freed. Typically,
00236  *      a caller sets LITERAL_ON_HEAP if "string" is an already heap-allocated
00237  *      buffer holding the result of backslash substitutions.
00238  *
00239  *----------------------------------------------------------------------
00240  */
00241 
00242 Tcl_Obj *
00243 TclCreateLiteral(
00244     Interp *iPtr,
00245     char *bytes,
00246     int length,
00247     unsigned int hash,       /* The string's hash. If -1, it will be computed here */
00248     int *newPtr,
00249     Namespace *nsPtr,
00250     int flags,
00251     LiteralEntry **globalPtrPtr)
00252 {
00253     LiteralTable *globalTablePtr = &(iPtr->literalTable);
00254     LiteralEntry *globalPtr;
00255     int globalHash;
00256     Tcl_Obj *objPtr;
00257     
00258     /*
00259      * Is it in the interpreter's global literal table?
00260      */
00261 
00262     if (hash == (unsigned int) -1) {
00263         hash = HashString(bytes, length);
00264     }
00265     globalHash = (hash & globalTablePtr->mask);
00266     for (globalPtr=globalTablePtr->buckets[globalHash] ; globalPtr!=NULL;
00267             globalPtr = globalPtr->nextPtr) {
00268         objPtr = globalPtr->objPtr;
00269         if ((globalPtr->nsPtr == nsPtr)
00270                 && (objPtr->length == length) && ((length == 0)
00271                 || ((objPtr->bytes[0] == bytes[0])
00272                 && (memcmp(objPtr->bytes, bytes, (unsigned) length) == 0)))) {
00273             /*
00274              * A literal was found: return it
00275              */
00276 
00277             if (newPtr) {
00278                 *newPtr = 0;
00279             }
00280             if (globalPtrPtr) {
00281                 *globalPtrPtr = globalPtr;
00282             }
00283             if (flags & LITERAL_ON_HEAP) {
00284                 ckfree(bytes);
00285             }
00286             globalPtr->refCount++;
00287             return objPtr;
00288         }
00289     }
00290     if (!newPtr) {
00291         if (flags & LITERAL_ON_HEAP) {
00292             ckfree(bytes);
00293         }
00294         return NULL;
00295     }
00296 
00297     /*
00298      * The literal is new to the interpreter. Add it to the global literal
00299      * table.
00300      */
00301 
00302     TclNewObj(objPtr);
00303     Tcl_IncrRefCount(objPtr);
00304     if (flags & LITERAL_ON_HEAP) {
00305         objPtr->bytes = bytes;
00306         objPtr->length = length;
00307     } else {
00308         TclInitStringRep(objPtr, bytes, length);
00309     }
00310 
00311 #ifdef TCL_COMPILE_DEBUG
00312     if (TclLookupLiteralEntry((Tcl_Interp *) iPtr, objPtr) != NULL) {
00313         Tcl_Panic("TclRegisterLiteral: literal \"%.*s\" found globally but shouldn't be",
00314                 (length>60? 60 : length), bytes);
00315     }
00316 #endif
00317 
00318     globalPtr = (LiteralEntry *) ckalloc((unsigned) sizeof(LiteralEntry));
00319     globalPtr->objPtr = objPtr;
00320     globalPtr->refCount = 1;
00321     globalPtr->nsPtr = nsPtr;
00322     globalPtr->nextPtr = globalTablePtr->buckets[globalHash];
00323     globalTablePtr->buckets[globalHash] = globalPtr;
00324     globalTablePtr->numEntries++;
00325 
00326     /*
00327      * If the global literal table has exceeded a decent size, rebuild it with
00328      * more buckets.
00329      */
00330 
00331     if (globalTablePtr->numEntries >= globalTablePtr->rebuildSize) {
00332         RebuildLiteralTable(globalTablePtr);
00333     }
00334 
00335 #ifdef TCL_COMPILE_DEBUG
00336     TclVerifyGlobalLiteralTable(iPtr);
00337     {
00338         LiteralEntry *entryPtr;
00339         int found, i;
00340 
00341         found = 0;
00342         for (i=0 ; i<globalTablePtr->numBuckets ; i++) {
00343             for (entryPtr=globalTablePtr->buckets[i]; entryPtr!=NULL ;
00344                     entryPtr=entryPtr->nextPtr) {
00345                 if ((entryPtr == globalPtr) && (entryPtr->objPtr == objPtr)) {
00346                     found = 1;
00347                 }
00348             }
00349         }
00350         if (!found) {
00351             Tcl_Panic("TclRegisterLiteral: literal \"%.*s\" wasn't global",
00352                     (length>60? 60 : length), bytes);
00353         }
00354     }
00355 #endif /*TCL_COMPILE_DEBUG*/
00356 
00357 #ifdef TCL_COMPILE_STATS
00358     iPtr->stats.numLiteralsCreated++;
00359     iPtr->stats.totalLitStringBytes += (double) (length + 1);
00360     iPtr->stats.currentLitStringBytes += (double) (length + 1);
00361     iPtr->stats.literalCount[TclLog2(length)]++;
00362 #endif /*TCL_COMPILE_STATS*/
00363 
00364     if (globalPtrPtr) {
00365         *globalPtrPtr = globalPtr;
00366     }
00367     *newPtr = 1;
00368     return objPtr;
00369 }
00370 
00371 /*
00372  *----------------------------------------------------------------------
00373  *
00374  * TclRegisterLiteral --
00375  *
00376  *      Find, or if necessary create, an object in a CompileEnv literal array
00377  *      that has a string representation matching the argument string.
00378  *
00379  * Results:
00380  *      The index in the CompileEnv's literal array that references a shared
00381  *      literal matching the string. The object is created if necessary.
00382  *
00383  * Side effects:
00384  *      To maximize sharing, we look up the string in the interpreter's global
00385  *      literal table. If not found, we create a new shared literal in the
00386  *      global table. We then add a reference to the shared literal in the
00387  *      CompileEnv's literal array.
00388  *
00389  *      If LITERAL_ON_HEAP is set in flags, this function is given ownership
00390  *      of the string: if an object is created then its string representation
00391  *      is set directly from string, otherwise the string is freed. Typically,
00392  *      a caller sets LITERAL_ON_HEAP if "string" is an already heap-allocated
00393  *      buffer holding the result of backslash substitutions.
00394  *
00395  *----------------------------------------------------------------------
00396  */
00397 
00398 int
00399 TclRegisterLiteral(
00400     CompileEnv *envPtr,         /* Points to the CompileEnv in whose object
00401                                  * array an object is found or created. */
00402     register char *bytes,       /* Points to string for which to find or
00403                                  * create an object in CompileEnv's object
00404                                  * array. */
00405     int length,                 /* Number of bytes in the string. If < 0, the
00406                                  * string consists of all bytes up to the
00407                                  * first null character. */
00408     int flags)                  /* If LITERAL_ON_HEAP then the caller already
00409                                  * malloc'd bytes and ownership is passed to
00410                                  * this function. If LITERAL_NS_SCOPE then
00411                                  * the literal shouldnot be shared accross
00412                                  * namespaces. */
00413 {
00414     Interp *iPtr = envPtr->iPtr;
00415     LiteralTable *localTablePtr = &(envPtr->localLitTable);
00416     LiteralEntry *globalPtr, *localPtr;
00417     Tcl_Obj *objPtr;
00418     unsigned int hash;
00419     int localHash, objIndex, new;
00420     Namespace *nsPtr;
00421 
00422     if (length < 0) {
00423         length = (bytes ? strlen(bytes) : 0);
00424     }
00425     hash = HashString(bytes, length);
00426 
00427     /*
00428      * Is the literal already in the CompileEnv's local literal array? If so,
00429      * just return its index.
00430      */
00431 
00432     localHash = (hash & localTablePtr->mask);
00433     for (localPtr=localTablePtr->buckets[localHash] ; localPtr!=NULL;
00434             localPtr = localPtr->nextPtr) {
00435         objPtr = localPtr->objPtr;
00436         if ((objPtr->length == length) && ((length == 0)
00437                 || ((objPtr->bytes[0] == bytes[0])
00438                 && (memcmp(objPtr->bytes, bytes, (unsigned) length) == 0)))) {
00439             if (flags & LITERAL_ON_HEAP) {
00440                 ckfree(bytes);
00441             }
00442             objIndex = (localPtr - envPtr->literalArrayPtr);
00443 #ifdef TCL_COMPILE_DEBUG
00444             TclVerifyLocalLiteralTable(envPtr);
00445 #endif /*TCL_COMPILE_DEBUG*/
00446 
00447             return objIndex;
00448         }
00449     }
00450 
00451     /*
00452      * The literal is new to this CompileEnv. Should it be shared accross
00453      * namespaces? If it is a fully qualified name, the namespace
00454      * specification is not needed to avoid sharing.
00455      */
00456 
00457     if ((flags & LITERAL_NS_SCOPE) && iPtr->varFramePtr
00458             && ((length <2) || (bytes[0] != ':') || (bytes[1] != ':'))) {
00459         nsPtr = iPtr->varFramePtr->nsPtr;
00460     } else {
00461         nsPtr = NULL;
00462     }
00463 
00464     /*
00465      * Is it in the interpreter's global literal table? If not, create it.
00466      */
00467 
00468     objPtr = TclCreateLiteral(iPtr, bytes, length, hash, &new, nsPtr,
00469             flags, &globalPtr);
00470     objIndex = AddLocalLiteralEntry(envPtr, objPtr, localHash);
00471 
00472 #ifdef TCL_COMPILE_DEBUG
00473     if (globalPtr->refCount < 1) {
00474         Tcl_Panic("TclRegisterLiteral: global literal \"%.*s\" had bad refCount %d",
00475                 (length>60? 60 : length), bytes, globalPtr->refCount);
00476     }
00477     TclVerifyLocalLiteralTable(envPtr);
00478 #endif /*TCL_COMPILE_DEBUG*/
00479     return objIndex;
00480 }
00481 
00482 /*
00483  *----------------------------------------------------------------------
00484  *
00485  * TclLookupLiteralEntry --
00486  *
00487  *      Finds the LiteralEntry that corresponds to a literal Tcl object
00488  *      holding a literal.
00489  *
00490  * Results:
00491  *      Returns the matching LiteralEntry if found, otherwise NULL.
00492  *
00493  * Side effects:
00494  *      None.
00495  *
00496  *----------------------------------------------------------------------
00497  */
00498 
00499 LiteralEntry *
00500 TclLookupLiteralEntry(
00501     Tcl_Interp *interp,         /* Interpreter for which objPtr was created to
00502                                  * hold a literal. */
00503     register Tcl_Obj *objPtr)   /* Points to a Tcl object holding a literal
00504                                  * that was previously created by a call to
00505                                  * TclRegisterLiteral. */
00506 {
00507     Interp *iPtr = (Interp *) interp;
00508     LiteralTable *globalTablePtr = &(iPtr->literalTable);
00509     register LiteralEntry *entryPtr;
00510     char *bytes;
00511     int length, globalHash;
00512 
00513     bytes = TclGetStringFromObj(objPtr, &length);
00514     globalHash = (HashString(bytes, length) & globalTablePtr->mask);
00515     for (entryPtr=globalTablePtr->buckets[globalHash] ; entryPtr!=NULL;
00516             entryPtr=entryPtr->nextPtr) {
00517         if (entryPtr->objPtr == objPtr) {
00518             return entryPtr;
00519         }
00520     }
00521     return NULL;
00522 }
00523 
00524 /*
00525  *----------------------------------------------------------------------
00526  *
00527  * TclHideLiteral --
00528  *
00529  *      Remove a literal entry from the literal hash tables, leaving it in the
00530  *      literal array so existing references continue to function. This makes
00531  *      it possible to turn a shared literal into a private literal that
00532  *      cannot be shared.
00533  *
00534  * Results:
00535  *      None.
00536  *
00537  * Side effects:
00538  *      Removes the literal from the local hash table and decrements the
00539  *      global hash entry's reference count.
00540  *
00541  *----------------------------------------------------------------------
00542  */
00543 
00544 void
00545 TclHideLiteral(
00546     Tcl_Interp *interp,         /* Interpreter for which objPtr was created to
00547                                  * hold a literal. */
00548     register CompileEnv *envPtr,/* Points to CompileEnv whose literal array
00549                                  * contains the entry being hidden. */
00550     int index)                  /* The index of the entry in the literal
00551                                  * array. */
00552 {
00553     LiteralEntry **nextPtrPtr, *entryPtr, *lPtr;
00554     LiteralTable *localTablePtr = &(envPtr->localLitTable);
00555     int localHash, length;
00556     char *bytes;
00557     Tcl_Obj *newObjPtr;
00558 
00559     lPtr = &(envPtr->literalArrayPtr[index]);
00560 
00561     /*
00562      * To avoid unwanted sharing we need to copy the object and remove it from
00563      * the local and global literal tables. It still has a slot in the literal
00564      * array so it can be referred to by byte codes, but it will not be
00565      * matched by literal searches.
00566      */
00567 
00568     newObjPtr = Tcl_DuplicateObj(lPtr->objPtr);
00569     Tcl_IncrRefCount(newObjPtr);
00570     TclReleaseLiteral(interp, lPtr->objPtr);
00571     lPtr->objPtr = newObjPtr;
00572 
00573     bytes = TclGetStringFromObj(newObjPtr, &length);
00574     localHash = (HashString(bytes, length) & localTablePtr->mask);
00575     nextPtrPtr = &localTablePtr->buckets[localHash];
00576 
00577     for (entryPtr=*nextPtrPtr ; entryPtr!=NULL ; entryPtr=*nextPtrPtr) {
00578         if (entryPtr == lPtr) {
00579             *nextPtrPtr = lPtr->nextPtr;
00580             lPtr->nextPtr = NULL;
00581             localTablePtr->numEntries--;
00582             break;
00583         }
00584         nextPtrPtr = &entryPtr->nextPtr;
00585     }
00586 }
00587 
00588 /*
00589  *----------------------------------------------------------------------
00590  *
00591  * TclAddLiteralObj --
00592  *
00593  *      Add a single literal object to the literal array. This function does
00594  *      not add the literal to the local or global literal tables. The caller
00595  *      is expected to add the entry to whatever tables are appropriate.
00596  *
00597  * Results:
00598  *      The index in the CompileEnv's literal array that references the
00599  *      literal. Stores the pointer to the new literal entry in the location
00600  *      referenced by the localPtrPtr argument.
00601  *
00602  * Side effects:
00603  *      Expands the literal array if necessary. Increments the refcount on the
00604  *      literal object.
00605  *
00606  *----------------------------------------------------------------------
00607  */
00608 
00609 int
00610 TclAddLiteralObj(
00611     register CompileEnv *envPtr,/* Points to CompileEnv in whose literal array
00612                                  * the object is to be inserted. */
00613     Tcl_Obj *objPtr,            /* The object to insert into the array. */
00614     LiteralEntry **litPtrPtr)   /* The location where the pointer to the new
00615                                  * literal entry should be stored. May be
00616                                  * NULL. */
00617 {
00618     register LiteralEntry *lPtr;
00619     int objIndex;
00620 
00621     if (envPtr->literalArrayNext >= envPtr->literalArrayEnd) {
00622         ExpandLocalLiteralArray(envPtr);
00623     }
00624     objIndex = envPtr->literalArrayNext;
00625     envPtr->literalArrayNext++;
00626 
00627     lPtr = &(envPtr->literalArrayPtr[objIndex]);
00628     lPtr->objPtr = objPtr;
00629     Tcl_IncrRefCount(objPtr);
00630     lPtr->refCount = -1;        /* i.e., unused */
00631     lPtr->nextPtr = NULL;
00632 
00633     if (litPtrPtr) {
00634         *litPtrPtr = lPtr;
00635     }
00636 
00637     return objIndex;
00638 }
00639 
00640 /*
00641  *----------------------------------------------------------------------
00642  *
00643  * AddLocalLiteralEntry --
00644  *
00645  *      Insert a new literal into a CompileEnv's local literal array.
00646  *
00647  * Results:
00648  *      The index in the CompileEnv's literal array that references the
00649  *      literal.
00650  *
00651  * Side effects:
00652  *      Expands the literal array if necessary. May rebuild the hash bucket
00653  *      array of the CompileEnv's literal array if it becomes too large.
00654  *
00655  *----------------------------------------------------------------------
00656  */
00657 
00658 static int
00659 AddLocalLiteralEntry(
00660     register CompileEnv *envPtr,/* Points to CompileEnv in whose literal array
00661                                  * the object is to be inserted. */
00662     Tcl_Obj *objPtr,            /* The literal to add to the CompileEnv. */
00663     int localHash)              /* Hash value for the literal's string. */
00664 {
00665     register LiteralTable *localTablePtr = &(envPtr->localLitTable);
00666     LiteralEntry *localPtr;
00667     int objIndex;
00668 
00669     objIndex = TclAddLiteralObj(envPtr, objPtr, &localPtr);
00670 
00671     /*
00672      * Add the literal to the local table.
00673      */
00674 
00675     localPtr->nextPtr = localTablePtr->buckets[localHash];
00676     localTablePtr->buckets[localHash] = localPtr;
00677     localTablePtr->numEntries++;
00678 
00679     /*
00680      * If the CompileEnv's local literal table has exceeded a decent size,
00681      * rebuild it with more buckets.
00682      */
00683 
00684     if (localTablePtr->numEntries >= localTablePtr->rebuildSize) {
00685         RebuildLiteralTable(localTablePtr);
00686     }
00687 
00688 #ifdef TCL_COMPILE_DEBUG
00689     TclVerifyLocalLiteralTable(envPtr);
00690     {
00691         char *bytes;
00692         int length, found, i;
00693 
00694         found = 0;
00695         for (i=0 ; i<localTablePtr->numBuckets ; i++) {
00696             for (localPtr=localTablePtr->buckets[i] ; localPtr!=NULL ;
00697                     localPtr=localPtr->nextPtr) {
00698                 if (localPtr->objPtr == objPtr) {
00699                     found = 1;
00700                 }
00701             }
00702         }
00703 
00704         if (!found) {
00705             bytes = Tcl_GetStringFromObj(objPtr, &length);
00706             Tcl_Panic("AddLocalLiteralEntry: literal \"%.*s\" wasn't found locally",
00707                     (length>60? 60 : length), bytes);
00708         }
00709     }
00710 #endif /*TCL_COMPILE_DEBUG*/
00711 
00712     return objIndex;
00713 }
00714 
00715 /*
00716  *----------------------------------------------------------------------
00717  *
00718  * ExpandLocalLiteralArray --
00719  *
00720  *      Function that uses malloc to allocate more storage for a CompileEnv's
00721  *      local literal array.
00722  *
00723  * Results:
00724  *      None.
00725  *
00726  * Side effects:
00727  *      The literal array in *envPtr is reallocated to a new array of double
00728  *      the size, and if envPtr->mallocedLiteralArray is non-zero the old
00729  *      array is freed. Entries are copied from the old array to the new one.
00730  *      The local literal table is updated to refer to the new entries.
00731  *
00732  *----------------------------------------------------------------------
00733  */
00734 
00735 static void
00736 ExpandLocalLiteralArray(
00737     register CompileEnv *envPtr)/* Points to the CompileEnv whose object array
00738                                  * must be enlarged. */
00739 {
00740     /*
00741      * The current allocated local literal entries are stored between elements
00742      * 0 and (envPtr->literalArrayNext - 1) [inclusive].
00743      */
00744 
00745     LiteralTable *localTablePtr = &(envPtr->localLitTable);
00746     int currElems = envPtr->literalArrayNext;
00747     size_t currBytes = (currElems * sizeof(LiteralEntry));
00748     LiteralEntry *currArrayPtr = envPtr->literalArrayPtr;
00749     LiteralEntry *newArrayPtr;
00750     int i;
00751 
00752     if (envPtr->mallocedLiteralArray) {
00753         newArrayPtr = (LiteralEntry *) ckrealloc(
00754                 (char *)currArrayPtr, 2 * currBytes);
00755     } else {
00756         /*
00757          * envPtr->literalArrayPtr isn't a ckalloc'd pointer, so we must
00758          * code a ckrealloc equivalent for ourselves
00759          */
00760         newArrayPtr = (LiteralEntry *) ckalloc(2 * currBytes);
00761         memcpy(newArrayPtr, currArrayPtr, currBytes);
00762         envPtr->mallocedLiteralArray = 1;
00763     }
00764 
00765     /*
00766      * Update the local literal table's bucket array.
00767      */
00768 
00769     if (currArrayPtr != newArrayPtr) {
00770         for (i=0 ; i<currElems ; i++) {
00771             if (newArrayPtr[i].nextPtr != NULL) {
00772                 newArrayPtr[i].nextPtr = newArrayPtr 
00773                         + (newArrayPtr[i].nextPtr - currArrayPtr);
00774             }
00775         }
00776         for (i=0 ; i<localTablePtr->numBuckets ; i++) {
00777             if (localTablePtr->buckets[i] != NULL) {
00778                 localTablePtr->buckets[i] = newArrayPtr
00779                         + (localTablePtr->buckets[i] - currArrayPtr);
00780             }
00781         }
00782     }
00783 
00784     envPtr->literalArrayPtr = newArrayPtr;
00785     envPtr->literalArrayEnd = (2 * currElems);
00786 }
00787 
00788 /*
00789  *----------------------------------------------------------------------
00790  *
00791  * TclReleaseLiteral --
00792  *
00793  *      This function releases a reference to one of the shared Tcl objects
00794  *      that hold literals. It is called to release the literals referenced by
00795  *      a ByteCode that is being destroyed, and it is also called by
00796  *      TclDeleteLiteralTable.
00797  *
00798  * Results:
00799  *      None.
00800  *
00801  * Side effects:
00802  *      The reference count for the global LiteralTable entry that corresponds
00803  *      to the literal is decremented. If no other reference to a global
00804  *      literal object remains, it is freed.
00805  *
00806  *----------------------------------------------------------------------
00807  */
00808 
00809 void
00810 TclReleaseLiteral(
00811     Tcl_Interp *interp,         /* Interpreter for which objPtr was created to
00812                                  * hold a literal. */
00813     register Tcl_Obj *objPtr)   /* Points to a literal object that was
00814                                  * previously created by a call to
00815                                  * TclRegisterLiteral. */
00816 {
00817     Interp *iPtr = (Interp *) interp;
00818     LiteralTable *globalTablePtr = &(iPtr->literalTable);
00819     register LiteralEntry *entryPtr, *prevPtr;
00820     char *bytes;
00821     int length, index;
00822 
00823     bytes = TclGetStringFromObj(objPtr, &length);
00824     index = (HashString(bytes, length) & globalTablePtr->mask);
00825 
00826     /*
00827      * Check to see if the object is in the global literal table and remove
00828      * this reference. The object may not be in the table if it is a hidden
00829      * local literal.
00830      */
00831 
00832     for (prevPtr=NULL, entryPtr=globalTablePtr->buckets[index];
00833             entryPtr!=NULL ; prevPtr=entryPtr, entryPtr=entryPtr->nextPtr) {
00834         if (entryPtr->objPtr == objPtr) {
00835             entryPtr->refCount--;
00836 
00837             /*
00838              * If the literal is no longer being used by any ByteCode, delete
00839              * the entry then remove the reference corresponding to the global
00840              * literal table entry (decrement the ref count of the object).
00841              */
00842 
00843             if (entryPtr->refCount == 0) {
00844                 if (prevPtr == NULL) {
00845                     globalTablePtr->buckets[index] = entryPtr->nextPtr;
00846                 } else {
00847                     prevPtr->nextPtr = entryPtr->nextPtr;
00848                 }
00849                 ckfree((char *) entryPtr);
00850                 globalTablePtr->numEntries--;
00851 
00852                 TclDecrRefCount(objPtr);
00853 
00854 #ifdef TCL_COMPILE_STATS
00855                 iPtr->stats.currentLitStringBytes -= (double) (length + 1);
00856 #endif /*TCL_COMPILE_STATS*/
00857             }
00858             break;
00859         }
00860     }
00861 
00862     /*
00863      * Remove the reference corresponding to the local literal table entry.
00864      */
00865 
00866     Tcl_DecrRefCount(objPtr);
00867 }
00868 
00869 /*
00870  *----------------------------------------------------------------------
00871  *
00872  * HashString --
00873  *
00874  *      Compute a one-word summary of a text string, which can be used to
00875  *      generate a hash index.
00876  *
00877  * Results:
00878  *      The return value is a one-word summary of the information in string.
00879  *
00880  * Side effects:
00881  *      None.
00882  *
00883  *----------------------------------------------------------------------
00884  */
00885 
00886 static unsigned int
00887 HashString(
00888     register const char *bytes, /* String for which to compute hash value. */
00889     int length)                 /* Number of bytes in the string. */
00890 {
00891     register unsigned int result;
00892     register int i;
00893 
00894     /*
00895      * I tried a zillion different hash functions and asked many other people
00896      * for advice. Many people had their own favorite functions, all
00897      * different, but no-one had much idea why they were good ones. I chose
00898      * the one below (multiply by 9 and add new character) because of the
00899      * following reasons:
00900      *
00901      * 1. Multiplying by 10 is perfect for keys that are decimal strings, and
00902      *    multiplying by 9 is just about as good.
00903      * 2. Times-9 is (shift-left-3) plus (old). This means that each
00904      *    character's bits hang around in the low-order bits of the hash value
00905      *    for ever, plus they spread fairly rapidly up to the high-order bits
00906      *    to fill out the hash value. This seems works well both for decimal
00907      *    and non-decimal strings.
00908      */
00909 
00910     result = 0;
00911     for (i=0 ; i<length ; i++) {
00912         result += (result<<3) + bytes[i];
00913     }
00914     return result;
00915 }
00916 
00917 /*
00918  *----------------------------------------------------------------------
00919  *
00920  * RebuildLiteralTable --
00921  *
00922  *      This function is invoked when the ratio of entries to hash buckets
00923  *      becomes too large in a local or global literal table. It allocates a
00924  *      larger bucket array and moves the entries into the new buckets.
00925  *
00926  * Results:
00927  *      None.
00928  *
00929  * Side effects:
00930  *      Memory gets reallocated and entries get rehashed into new buckets.
00931  *
00932  *----------------------------------------------------------------------
00933  */
00934 
00935 static void
00936 RebuildLiteralTable(
00937     register LiteralTable *tablePtr)
00938                                 /* Local or global table to enlarge. */
00939 {
00940     LiteralEntry **oldBuckets;
00941     register LiteralEntry **oldChainPtr, **newChainPtr;
00942     register LiteralEntry *entryPtr;
00943     LiteralEntry **bucketPtr;
00944     char *bytes;
00945     int oldSize, count, index, length;
00946 
00947     oldSize = tablePtr->numBuckets;
00948     oldBuckets = tablePtr->buckets;
00949 
00950     /*
00951      * Allocate and initialize the new bucket array, and set up hashing
00952      * constants for new array size.
00953      */
00954 
00955     tablePtr->numBuckets *= 4;
00956     tablePtr->buckets = (LiteralEntry **) ckalloc((unsigned)
00957             (tablePtr->numBuckets * sizeof(LiteralEntry *)));
00958     for (count=tablePtr->numBuckets, newChainPtr=tablePtr->buckets;
00959             count>0 ; count--, newChainPtr++) {
00960         *newChainPtr = NULL;
00961     }
00962     tablePtr->rebuildSize *= 4;
00963     tablePtr->mask = (tablePtr->mask << 2) + 3;
00964 
00965     /*
00966      * Rehash all of the existing entries into the new bucket array.
00967      */
00968 
00969     for (oldChainPtr=oldBuckets ; oldSize>0 ; oldSize--,oldChainPtr++) {
00970         for (entryPtr=*oldChainPtr ; entryPtr!=NULL ; entryPtr=*oldChainPtr) {
00971             bytes = TclGetStringFromObj(entryPtr->objPtr, &length);
00972             index = (HashString(bytes, length) & tablePtr->mask);
00973 
00974             *oldChainPtr = entryPtr->nextPtr;
00975             bucketPtr = &(tablePtr->buckets[index]);
00976             entryPtr->nextPtr = *bucketPtr;
00977             *bucketPtr = entryPtr;
00978         }
00979     }
00980 
00981     /*
00982      * Free up the old bucket array, if it was dynamically allocated.
00983      */
00984 
00985     if (oldBuckets != tablePtr->staticBuckets) {
00986         ckfree((char *) oldBuckets);
00987     }
00988 }
00989 
00990 #ifdef TCL_COMPILE_STATS
00991 /*
00992  *----------------------------------------------------------------------
00993  *
00994  * TclLiteralStats --
00995  *
00996  *      Return statistics describing the layout of the hash table in its hash
00997  *      buckets.
00998  *
00999  * Results:
01000  *      The return value is a malloc-ed string containing information about
01001  *      tablePtr. It is the caller's responsibility to free this string.
01002  *
01003  * Side effects:
01004  *      None.
01005  *
01006  *----------------------------------------------------------------------
01007  */
01008 
01009 char *
01010 TclLiteralStats(
01011     LiteralTable *tablePtr)     /* Table for which to produce stats. */
01012 {
01013 #define NUM_COUNTERS 10
01014     int count[NUM_COUNTERS], overflow, i, j;
01015     double average, tmp;
01016     register LiteralEntry *entryPtr;
01017     char *result, *p;
01018 
01019     /*
01020      * Compute a histogram of bucket usage. For each bucket chain i, j is the
01021      * number of entries in the chain.
01022      */
01023 
01024     for (i=0 ; i<NUM_COUNTERS ; i++) {
01025         count[i] = 0;
01026     }
01027     overflow = 0;
01028     average = 0.0;
01029     for (i=0 ; i<tablePtr->numBuckets ; i++) {
01030         j = 0;
01031         for (entryPtr=tablePtr->buckets[i] ; entryPtr!=NULL;
01032                 entryPtr=entryPtr->nextPtr) {
01033             j++;
01034         }
01035         if (j < NUM_COUNTERS) {
01036             count[j]++;
01037         } else {
01038             overflow++;
01039         }
01040         tmp = j;
01041         average += (tmp+1.0)*(tmp/tablePtr->numEntries)/2.0;
01042     }
01043 
01044     /*
01045      * Print out the histogram and a few other pieces of information.
01046      */
01047 
01048     result = (char *) ckalloc((unsigned) ((NUM_COUNTERS*60) + 300));
01049     sprintf(result, "%d entries in table, %d buckets\n",
01050             tablePtr->numEntries, tablePtr->numBuckets);
01051     p = result + strlen(result);
01052     for (i=0 ; i<NUM_COUNTERS ; i++) {
01053         sprintf(p, "number of buckets with %d entries: %d\n",
01054                 i, count[i]);
01055         p += strlen(p);
01056     }
01057     sprintf(p, "number of buckets with %d or more entries: %d\n",
01058             NUM_COUNTERS, overflow);
01059     p += strlen(p);
01060     sprintf(p, "average search distance for entry: %.1f", average);
01061     return result;
01062 }
01063 #endif /*TCL_COMPILE_STATS*/
01064 
01065 #ifdef TCL_COMPILE_DEBUG
01066 /*
01067  *----------------------------------------------------------------------
01068  *
01069  * TclVerifyLocalLiteralTable --
01070  *
01071  *      Check a CompileEnv's local literal table for consistency.
01072  *
01073  * Results:
01074  *      None.
01075  *
01076  * Side effects:
01077  *      Tcl_Panic if problems are found.
01078  *
01079  *----------------------------------------------------------------------
01080  */
01081 
01082 void
01083 TclVerifyLocalLiteralTable(
01084     CompileEnv *envPtr)         /* Points to CompileEnv whose literal table is
01085                                  * to be validated. */
01086 {
01087     register LiteralTable *localTablePtr = &(envPtr->localLitTable);
01088     register LiteralEntry *localPtr;
01089     char *bytes;
01090     register int i;
01091     int length, count;
01092 
01093     count = 0;
01094     for (i=0 ; i<localTablePtr->numBuckets ; i++) {
01095         for (localPtr=localTablePtr->buckets[i] ; localPtr!=NULL;
01096                 localPtr=localPtr->nextPtr) {
01097             count++;
01098             if (localPtr->refCount != -1) {
01099                 bytes = Tcl_GetStringFromObj(localPtr->objPtr, &length);
01100                 Tcl_Panic("TclVerifyLocalLiteralTable: local literal \"%.*s\" had bad refCount %d",
01101                         (length>60? 60 : length), bytes, localPtr->refCount);
01102             }
01103             if (TclLookupLiteralEntry((Tcl_Interp *) envPtr->iPtr,
01104                     localPtr->objPtr) == NULL) {
01105                 bytes = Tcl_GetStringFromObj(localPtr->objPtr, &length);
01106                 Tcl_Panic("TclVerifyLocalLiteralTable: local literal \"%.*s\" is not global",
01107                         (length>60? 60 : length), bytes);
01108             }
01109             if (localPtr->objPtr->bytes == NULL) {
01110                 Tcl_Panic("TclVerifyLocalLiteralTable: literal has NULL string rep");
01111             }
01112         }
01113     }
01114     if (count != localTablePtr->numEntries) {
01115         Tcl_Panic("TclVerifyLocalLiteralTable: local literal table had %d entries, should be %d",
01116                 count, localTablePtr->numEntries);
01117     }
01118 }
01119 
01120 /*
01121  *----------------------------------------------------------------------
01122  *
01123  * TclVerifyGlobalLiteralTable --
01124  *
01125  *      Check an interpreter's global literal table literal for consistency.
01126  *
01127  * Results:
01128  *      None.
01129  *
01130  * Side effects:
01131  *      Tcl_Panic if problems are found.
01132  *
01133  *----------------------------------------------------------------------
01134  */
01135 
01136 void
01137 TclVerifyGlobalLiteralTable(
01138     Interp *iPtr)               /* Points to interpreter whose global literal
01139                                  * table is to be validated. */
01140 {
01141     register LiteralTable *globalTablePtr = &(iPtr->literalTable);
01142     register LiteralEntry *globalPtr;
01143     char *bytes;
01144     register int i;
01145     int length, count;
01146 
01147     count = 0;
01148     for (i=0 ; i<globalTablePtr->numBuckets ; i++) {
01149         for (globalPtr=globalTablePtr->buckets[i] ; globalPtr!=NULL;
01150                 globalPtr=globalPtr->nextPtr) {
01151             count++;
01152             if (globalPtr->refCount < 1) {
01153                 bytes = Tcl_GetStringFromObj(globalPtr->objPtr, &length);
01154                 Tcl_Panic("TclVerifyGlobalLiteralTable: global literal \"%.*s\" had bad refCount %d",
01155                         (length>60? 60 : length), bytes, globalPtr->refCount);
01156             }
01157             if (globalPtr->objPtr->bytes == NULL) {
01158                 Tcl_Panic("TclVerifyGlobalLiteralTable: literal has NULL string rep");
01159             }
01160         }
01161     }
01162     if (count != globalTablePtr->numEntries) {
01163         Tcl_Panic("TclVerifyGlobalLiteralTable: global literal table had %d entries, should be %d",
01164                 count, globalTablePtr->numEntries);
01165     }
01166 }
01167 #endif /*TCL_COMPILE_DEBUG*/
01168 
01169 /*
01170  * Local Variables:
01171  * mode: c
01172  * c-basic-offset: 4
01173  * fill-column: 78
01174  * End:
01175  */



Generated on Wed Mar 12 12:18:19 2008 by  doxygen 1.5.1