tcl/generic/tclLiteral.c

   1 /*
   2  * tclLiteral.c --
   3  *
   4  *      Implementation of the global and ByteCode-local literal tables
   5  *      used to manage the Tcl objects created for literal values during
   6  *      compilation of Tcl scripts. This implementation borrows heavily
   7  *      from the more general hashtable implementation of Tcl hash tables
   8  *      that appears in tclHash.c.
   9  *
  10  * Copyright (c) 1997-1998 Sun Microsystems, Inc.
  11  *
  12  * See the file "license.terms" for information on usage and redistribution
  13  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  14  *
  15  * RCS: @(#) $Id$
  16  */
  17
  18 #include "tclInt.h"
  19 #include "tclCompile.h"
  20 #include "tclPort.h"
  21 /*
  22  * When there are this many entries per bucket, on average, rebuild
  23  * a literal's hash table to make it larger.
  24  */
  25
  26 #define REBUILD_MULTIPLIER      3
  27
  28 /*
  29  * Procedure prototypes for static procedures in this file:
  30  */
  31
  32 static int              AddLocalLiteralEntry _ANSI_ARGS_((
  33                             CompileEnv *envPtr, LiteralEntry *globalPtr,
  34                             int localHash));
  35 static void             ExpandLocalLiteralArray _ANSI_ARGS_((
  36                             CompileEnv *envPtr));
  37 static unsigned int     HashString _ANSI_ARGS_((CONST char *bytes,
  38                             int length));
  39 static void             RebuildLiteralTable _ANSI_ARGS_((
  40                             LiteralTable *tablePtr));
  41 \f
  42 /*
  43  *----------------------------------------------------------------------
  44  *
  45  * TclInitLiteralTable --
  46  *
  47  *      This procedure is called to initialize the fields of a literal table
  48  *      structure for either an interpreter or a compilation's CompileEnv
  49  *      structure.
  50  *
  51  * Results:
  52  *      None.
  53  *
  54  * Side effects:
  55  *      The literal table is made ready for use.
  56  *
  57  *----------------------------------------------------------------------
  58  */
  59
  60 void
  61 TclInitLiteralTable(tablePtr)
  62     register LiteralTable *tablePtr; /* Pointer to table structure, which
  63                                       * is supplied by the caller. */
  64 {
  65 #if (TCL_SMALL_HASH_TABLE != 4)
  66     panic("TclInitLiteralTable: TCL_SMALL_HASH_TABLE is %d, not 4\n",
  67             TCL_SMALL_HASH_TABLE);
  68 #endif
  69
  70     tablePtr->buckets = tablePtr->staticBuckets;
  71     tablePtr->staticBuckets[0] = tablePtr->staticBuckets[1] = 0;
  72     tablePtr->staticBuckets[2] = tablePtr->staticBuckets[3] = 0;
  73     tablePtr->numBuckets = TCL_SMALL_HASH_TABLE;
  74     tablePtr->numEntries = 0;
  75     tablePtr->rebuildSize = TCL_SMALL_HASH_TABLE*REBUILD_MULTIPLIER;
  76     tablePtr->mask = 3;
  77 }
  78 \f
  79 /*
  80  *----------------------------------------------------------------------
  81  *
  82  * TclDeleteLiteralTable --
  83  *
  84  *      This procedure frees up everything associated with a literal table
  85  *      except for the table's structure itself.
  86  *
  87  * Results:
  88  *      None.
  89  *
  90  * Side effects:
  91  *      Each literal in the table is released: i.e., its reference count
  92  *      in the global literal table is decremented and, if it becomes zero,
  93  *      the literal is freed. In addition, the table's bucket array is
  94  *      freed.
  95  *
  96  *----------------------------------------------------------------------
  97  */
  98
  99 void
 100 TclDeleteLiteralTable(interp, tablePtr)
 101     Tcl_Interp *interp;         /* Interpreter containing shared literals
 102                                  * referenced by the table to delete. */
 103     LiteralTable *tablePtr;     /* Points to the literal table to delete. */
 104 {
 105     LiteralEntry *entryPtr;
 106     int i, start;
 107
 108     /*
 109      * Release remaining literals in the table. Note that releasing a
 110      * literal might release other literals, modifying the table, so we
 111      * restart the search from the bucket chain we last found an entry.
 112      */
 113
 114 #ifdef TCL_COMPILE_DEBUG
 115     TclVerifyGlobalLiteralTable((Interp *) interp);
 116 #endif /*TCL_COMPILE_DEBUG*/
 117
 118     start = 0;
 119     while (tablePtr->numEntries > 0) {
 120         for (i = start;  i < tablePtr->numBuckets;  i++) {
 121             entryPtr = tablePtr->buckets[i];
 122             if (entryPtr != NULL) {
 123                 TclReleaseLiteral(interp, entryPtr->objPtr);
 124                 start = i;
 125                 break;
 126             }
 127         }
 128     }
 129
 130     /*
 131      * Free up the table's bucket array if it was dynamically allocated.
 132      */
 133
 134     if (tablePtr->buckets != tablePtr->staticBuckets) {
 135         ckfree((char *) tablePtr->buckets);
 136     }
 137 }
 138 \f
 139 /*
 140  *----------------------------------------------------------------------
 141  *
 142  * TclRegisterLiteral --
 143  *
 144  *      Find, or if necessary create, an object in a CompileEnv literal
 145  *      array that has a string representation matching the argument string.
 146  *
 147  * Results:
 148  *      The index in the CompileEnv's literal array that references a
 149  *      shared literal matching the string. The object is created if
 150  *      necessary.
 151  *
 152  * Side effects:
 153  *      To maximize sharing, we look up the string in the interpreter's
 154  *      global literal table. If not found, we create a new shared literal
 155  *      in the global table. We then add a reference to the shared
 156  *      literal in the CompileEnv's literal array.
 157  *
 158  *      If onHeap is 1, this procedure is given ownership of the string: if
 159  *      an object is created then its string representation is set directly
 160  *      from string, otherwise the string is freed. Typically, a caller sets
 161  *      onHeap 1 if "string" is an already heap-allocated buffer holding the
 162  *      result of backslash substitutions.
 163  *
 164  *----------------------------------------------------------------------
 165  */
 166
 167 int
 168 TclRegisterLiteral(envPtr, bytes, length, onHeap)
 169     CompileEnv *envPtr;         /* Points to the CompileEnv in whose object
 170                                  * array an object is found or created. */
 171     register char *bytes;       /* Points to string for which to find or
 172                                  * create an object in CompileEnv's object
 173                                  * array. */
 174     int length;                 /* Number of bytes in the string. If < 0,
 175                                  * the string consists of all bytes up to
 176                                  * the first null character. */
 177     int onHeap;                 /* If 1 then the caller already malloc'd
 178                                  * bytes and ownership is passed to this
 179                                  * procedure. */
 180 {
 181     Interp *iPtr = envPtr->iPtr;
 182     LiteralTable *globalTablePtr = &(iPtr->literalTable);
 183     LiteralTable *localTablePtr = &(envPtr->localLitTable);
 184     register LiteralEntry *globalPtr, *localPtr;
 185     register Tcl_Obj *objPtr;
 186     unsigned int hash;
 187     int localHash, globalHash, objIndex;
 188     long n;
 189     char buf[TCL_INTEGER_SPACE];
 190
 191     if (length < 0) {
 192         length = (bytes? strlen(bytes) : 0);
 193     }
 194     hash = HashString(bytes, length);
 195
 196     /*
 197      * Is the literal already in the CompileEnv's local literal array?
 198      * If so, just return its index.
 199      */
 200
 201     localHash = (hash & localTablePtr->mask);
 202     for (localPtr = localTablePtr->buckets[localHash];
 203           localPtr != NULL;  localPtr = localPtr->nextPtr) {
 204         objPtr = localPtr->objPtr;
 205         if ((objPtr->length == length) && ((length == 0)
 206                 || ((objPtr->bytes[0] == bytes[0])
 207                         && (memcmp(objPtr->bytes, bytes, (unsigned) length)
 208                                 == 0)))) {
 209             if (onHeap) {
 210                 ckfree(bytes);
 211             }
 212             objIndex = (localPtr - envPtr->literalArrayPtr);
 213 #ifdef TCL_COMPILE_DEBUG
 214             TclVerifyLocalLiteralTable(envPtr);
 215 #endif /*TCL_COMPILE_DEBUG*/
 216
 217             return objIndex;
 218         }
 219     }
 220
 221     /*
 222      * The literal is new to this CompileEnv. Is it in the interpreter's
 223      * global literal table?
 224      */
 225
 226     globalHash = (hash & globalTablePtr->mask);
 227     for (globalPtr = globalTablePtr->buckets[globalHash];
 228          globalPtr != NULL;  globalPtr = globalPtr->nextPtr) {
 229         objPtr = globalPtr->objPtr;
 230         if ((objPtr->length == length) && ((length == 0)
 231                 || ((objPtr->bytes[0] == bytes[0])
 232                         && (memcmp(objPtr->bytes, bytes, (unsigned) length)
 233                                 == 0)))) {
 234             /*
 235              * A global literal was found. Add an entry to the CompileEnv's
 236              * local literal array.
 237              */
 238
 239             if (onHeap) {
 240                 ckfree(bytes);
 241             }
 242             objIndex = AddLocalLiteralEntry(envPtr, globalPtr, localHash);
 243 #ifdef TCL_COMPILE_DEBUG
 244             if (globalPtr->refCount < 1) {
 245                 panic("TclRegisterLiteral: global literal \"%.*s\" had bad refCount %d",
 246                         (length>60? 60 : length), bytes,
 247                         globalPtr->refCount);
 248             }
 249             TclVerifyLocalLiteralTable(envPtr);
 250 #endif /*TCL_COMPILE_DEBUG*/
 251             return objIndex;
 252         }
 253     }
 254
 255     /*
 256      * The literal is new to the interpreter. Add it to the global literal
 257      * table then add an entry to the CompileEnv's local literal array.
 258      * Convert the object to an integer object if possible.
 259      */
 260
 261     TclNewObj(objPtr);
 262     Tcl_IncrRefCount(objPtr);
 263     if (onHeap) {
 264         objPtr->bytes = bytes;
 265         objPtr->length = length;
 266     } else {
 267         TclInitStringRep(objPtr, bytes, length);
 268     }
 269
 270     if (TclLooksLikeInt(bytes, length)) {
 271         /*
 272          * From here we use the objPtr, because it is NULL terminated
 273          */
 274         if (TclGetLong((Tcl_Interp *) NULL, objPtr->bytes, &n) == TCL_OK) {
 275             TclFormatInt(buf, n);
 276             if (strcmp(objPtr->bytes, buf) == 0) {
 277                 objPtr->internalRep.longValue = n;
 278                 objPtr->typePtr = &tclIntType;
 279             }
 280         }
 281     }
 282
 283 #ifdef TCL_COMPILE_DEBUG
 284     if (TclLookupLiteralEntry((Tcl_Interp *) iPtr, objPtr) != NULL) {
 285         panic("TclRegisterLiteral: literal \"%.*s\" found globally but shouldn't be",
 286                 (length>60? 60 : length), bytes);
 287     }
 288 #endif
 289
 290     globalPtr = (LiteralEntry *) ckalloc((unsigned) sizeof(LiteralEntry));
 291     globalPtr->objPtr = objPtr;
 292     globalPtr->refCount = 0;
 293     globalPtr->nextPtr = globalTablePtr->buckets[globalHash];
 294     globalTablePtr->buckets[globalHash] = globalPtr;
 295     globalTablePtr->numEntries++;
 296
 297     /*
 298      * If the global literal table has exceeded a decent size, rebuild it
 299      * with more buckets.
 300      */
 301
 302     if (globalTablePtr->numEntries >= globalTablePtr->rebuildSize) {
 303         RebuildLiteralTable(globalTablePtr);
 304     }
 305     objIndex = AddLocalLiteralEntry(envPtr, globalPtr, localHash);
 306
 307 #ifdef TCL_COMPILE_DEBUG
 308     TclVerifyGlobalLiteralTable(iPtr);
 309     TclVerifyLocalLiteralTable(envPtr);
 310     {
 311         LiteralEntry *entryPtr;
 312         int found, i;
 313         found = 0;
 314         for (i = 0;  i < globalTablePtr->numBuckets;  i++) {
 315             for (entryPtr = globalTablePtr->buckets[i];
 316                     entryPtr != NULL;  entryPtr = entryPtr->nextPtr) {
 317                 if ((entryPtr == globalPtr)
 318                         && (entryPtr->objPtr == objPtr)) {
 319                     found = 1;
 320                 }
 321             }
 322         }
 323         if (!found) {
 324             panic("TclRegisterLiteral: literal \"%.*s\" wasn't global",
 325                     (length>60? 60 : length), bytes);
 326         }
 327     }
 328 #endif /*TCL_COMPILE_DEBUG*/
 329 #ifdef TCL_COMPILE_STATS
 330     iPtr->stats.numLiteralsCreated++;
 331     iPtr->stats.totalLitStringBytes   += (double) (length + 1);
 332     iPtr->stats.currentLitStringBytes += (double) (length + 1);
 333     iPtr->stats.literalCount[TclLog2(length)]++;
 334 #endif /*TCL_COMPILE_STATS*/
 335     return objIndex;
 336 }
 337 \f
 338 /*
 339  *----------------------------------------------------------------------
 340  *
 341  * TclLookupLiteralEntry --
 342  *
 343  *      Finds the LiteralEntry that corresponds to a literal Tcl object
 344  *      holding a literal.
 345  *
 346  * Results:
 347  *      Returns the matching LiteralEntry if found, otherwise NULL.
 348  *
 349  * Side effects:
 350  *      None.
 351  *
 352  *----------------------------------------------------------------------
 353  */
 354
 355 LiteralEntry *
 356 TclLookupLiteralEntry(interp, objPtr)
 357     Tcl_Interp *interp;         /* Interpreter for which objPtr was created
 358                                  * to hold a literal. */
 359     register Tcl_Obj *objPtr;   /* Points to a Tcl object holding a
 360                                  * literal that was previously created by a
 361                                  * call to TclRegisterLiteral. */
 362 {
 363     Interp *iPtr = (Interp *) interp;
 364     LiteralTable *globalTablePtr = &(iPtr->literalTable);
 365     register LiteralEntry *entryPtr;
 366     char *bytes;
 367     int length, globalHash;
 368
 369     bytes = Tcl_GetStringFromObj(objPtr, &length);
 370     globalHash = (HashString(bytes, length) & globalTablePtr->mask);
 371     for (entryPtr = globalTablePtr->buckets[globalHash];
 372             entryPtr != NULL;  entryPtr = entryPtr->nextPtr) {
 373         if (entryPtr->objPtr == objPtr) {
 374             return entryPtr;
 375         }
 376     }
 377     return NULL;
 378 }
 379 \f
 380 /*
 381  *----------------------------------------------------------------------
 382  *
 383  * TclHideLiteral --
 384  *
 385  *      Remove a literal entry from the literal hash tables, leaving it in
 386  *      the literal array so existing references continue to function.
 387  *      This makes it possible to turn a shared literal into a private
 388  *      literal that cannot be shared.
 389  *
 390  * Results:
 391  *      None.
 392  *
 393  * Side effects:
 394  *      Removes the literal from the local hash table and decrements the
 395  *      global hash entry's reference count.
 396  *
 397  *----------------------------------------------------------------------
 398  */
 399
 400 void
 401 TclHideLiteral(interp, envPtr, index)
 402     Tcl_Interp *interp;          /* Interpreter for which objPtr was created
 403                                   * to hold a literal. */
 404     register CompileEnv *envPtr; /* Points to CompileEnv whose literal array
 405                                   * contains the entry being hidden. */
 406     int index;                   /* The index of the entry in the literal
 407                                   * array. */
 408 {
 409     LiteralEntry **nextPtrPtr, *entryPtr, *lPtr;
 410     LiteralTable *localTablePtr = &(envPtr->localLitTable);
 411     int localHash, length;
 412     char *bytes;
 413     Tcl_Obj *newObjPtr;
 414
 415     lPtr = &(envPtr->literalArrayPtr[index]);
 416
 417     /*
 418      * To avoid unwanted sharing we need to copy the object and remove it from
 419      * the local and global literal tables.  It still has a slot in the literal
 420      * array so it can be referred to by byte codes, but it will not be matched
 421      * by literal searches.
 422      */
 423
 424     newObjPtr = Tcl_DuplicateObj(lPtr->objPtr);
 425     Tcl_IncrRefCount(newObjPtr);
 426     TclReleaseLiteral(interp, lPtr->objPtr);
 427     lPtr->objPtr = newObjPtr;
 428
 429     bytes = Tcl_GetStringFromObj(newObjPtr, &length);
 430     localHash = (HashString(bytes, length) & localTablePtr->mask);
 431     nextPtrPtr = &localTablePtr->buckets[localHash];
 432
 433     for (entryPtr = *nextPtrPtr; entryPtr != NULL; entryPtr = *nextPtrPtr) {
 434         if (entryPtr == lPtr) {
 435             *nextPtrPtr = lPtr->nextPtr;
 436             lPtr->nextPtr = NULL;
 437             localTablePtr->numEntries--;
 438             break;
 439         }
 440         nextPtrPtr = &entryPtr->nextPtr;
 441     }
 442 }
 443 \f
 444 /*
 445  *----------------------------------------------------------------------
 446  *
 447  * TclAddLiteralObj --
 448  *
 449  *      Add a single literal object to the literal array.  This
 450  *      function does not add the literal to the local or global
 451  *      literal tables.  The caller is expected to add the entry
 452  *      to whatever tables are appropriate.
 453  *
 454  * Results:
 455  *      The index in the CompileEnv's literal array that references the
 456  *      literal.  Stores the pointer to the new literal entry in the
 457  *      location referenced by the localPtrPtr argument.
 458  *
 459  * Side effects:
 460  *      Expands the literal array if necessary.  Increments the refcount
 461  *      on the literal object.
 462  *
 463  *----------------------------------------------------------------------
 464  */
 465
 466 int
 467 TclAddLiteralObj(envPtr, objPtr, litPtrPtr)
 468     register CompileEnv *envPtr; /* Points to CompileEnv in whose literal
 469                                   * array the object is to be inserted. */
 470     Tcl_Obj *objPtr;             /* The object to insert into the array. */
 471     LiteralEntry **litPtrPtr;    /* The location where the pointer to the
 472                                   * new literal entry should be stored.
 473                                   * May be NULL. */
 474 {
 475     register LiteralEntry *lPtr;
 476     int objIndex;
 477
 478     if (envPtr->literalArrayNext >= envPtr->literalArrayEnd) {
 479         ExpandLocalLiteralArray(envPtr);
 480     }
 481     objIndex = envPtr->literalArrayNext;
 482     envPtr->literalArrayNext++;
 483
 484     lPtr = &(envPtr->literalArrayPtr[objIndex]);
 485     lPtr->objPtr = objPtr;
 486     Tcl_IncrRefCount(objPtr);
 487     lPtr->refCount = -1;        /* i.e., unused */
 488     lPtr->nextPtr = NULL;
 489
 490     if (litPtrPtr) {
 491         *litPtrPtr = lPtr;
 492     }
 493
 494     return objIndex;
 495 }
 496 \f
 497 /*
 498  *----------------------------------------------------------------------
 499  *
 500  * AddLocalLiteralEntry --
 501  *
 502  *      Insert a new literal into a CompileEnv's local literal array.
 503  *
 504  * Results:
 505  *      The index in the CompileEnv's literal array that references the
 506  *      literal.
 507  *
 508  * Side effects:
 509  *      Increments the ref count of the global LiteralEntry since the
 510  *      CompileEnv now refers to the literal. Expands the literal array
 511  *      if necessary. May rebuild the hash bucket array of the CompileEnv's
 512  *      literal array if it becomes too large.
 513  *
 514  *----------------------------------------------------------------------
 515  */
 516
 517 static int
 518 AddLocalLiteralEntry(envPtr, globalPtr, localHash)
 519     register CompileEnv *envPtr; /* Points to CompileEnv in whose literal
 520                                   * array the object is to be inserted. */
 521     LiteralEntry *globalPtr;     /* Points to the global LiteralEntry for
 522                                   * the literal to add to the CompileEnv. */
 523     int localHash;               /* Hash value for the literal's string. */
 524 {
 525     register LiteralTable *localTablePtr = &(envPtr->localLitTable);
 526     LiteralEntry *localPtr;
 527     int objIndex;
 528
 529     objIndex = TclAddLiteralObj(envPtr, globalPtr->objPtr, &localPtr);
 530
 531     /*
 532      * Add the literal to the local table.
 533      */
 534
 535     localPtr->nextPtr = localTablePtr->buckets[localHash];
 536     localTablePtr->buckets[localHash] = localPtr;
 537     localTablePtr->numEntries++;
 538
 539     globalPtr->refCount++;
 540
 541     /*
 542      * If the CompileEnv's local literal table has exceeded a decent size,
 543      * rebuild it with more buckets.
 544      */
 545
 546     if (localTablePtr->numEntries >= localTablePtr->rebuildSize) {
 547         RebuildLiteralTable(localTablePtr);
 548     }
 549
 550 #ifdef TCL_COMPILE_DEBUG
 551     TclVerifyLocalLiteralTable(envPtr);
 552     {
 553         char *bytes;
 554         int length, found, i;
 555         found = 0;
 556         for (i = 0;  i < localTablePtr->numBuckets;  i++) {
 557             for (localPtr = localTablePtr->buckets[i];
 558                     localPtr != NULL;  localPtr = localPtr->nextPtr) {
 559                 if (localPtr->objPtr == globalPtr->objPtr) {
 560                     found = 1;
 561                 }
 562             }
 563         }
 564         if (!found) {
 565             bytes = Tcl_GetStringFromObj(globalPtr->objPtr, &length);
 566             panic("AddLocalLiteralEntry: literal \"%.*s\" wasn't found locally",
 567                     (length>60? 60 : length), bytes);
 568         }
 569     }
 570 #endif /*TCL_COMPILE_DEBUG*/
 571     return objIndex;
 572 }
 573 \f
 574 /*
 575  *----------------------------------------------------------------------
 576  *
 577  * ExpandLocalLiteralArray --
 578  *
 579  *      Procedure that uses malloc to allocate more storage for a
 580  *      CompileEnv's local literal array.
 581  *
 582  * Results:
 583  *      None.
 584  *
 585  * Side effects:
 586  *      The literal array in *envPtr is reallocated to a new array of
 587  *      double the size, and if envPtr->mallocedLiteralArray is non-zero
 588  *      the old array is freed. Entries are copied from the old array
 589  *      to the new one. The local literal table is updated to refer to
 590  *      the new entries.
 591  *
 592  *----------------------------------------------------------------------
 593  */
 594
 595 static void
 596 ExpandLocalLiteralArray(envPtr)
 597     register CompileEnv *envPtr; /* Points to the CompileEnv whose object
 598                                   * array must be enlarged. */
 599 {
 600     /*
 601      * The current allocated local literal entries are stored between
 602      * elements 0 and (envPtr->literalArrayNext - 1) [inclusive].
 603      */
 604
 605     LiteralTable *localTablePtr = &(envPtr->localLitTable);
 606     int currElems = envPtr->literalArrayNext;
 607     size_t currBytes = (currElems * sizeof(LiteralEntry));
 608     register LiteralEntry *currArrayPtr = envPtr->literalArrayPtr;
 609     register LiteralEntry *newArrayPtr =
 610             (LiteralEntry *) ckalloc((unsigned) (2 * currBytes));
 611     int i;
 612
 613     /*
 614      * Copy from the old literal array to the new, then update the local
 615      * literal table's bucket array.
 616      */
 617
 618     memcpy((VOID *) newArrayPtr, (VOID *) currArrayPtr, currBytes);
 619     for (i = 0;  i < currElems;  i++) {
 620         if (currArrayPtr[i].nextPtr == NULL) {
 621             newArrayPtr[i].nextPtr = NULL;
 622         } else {
 623             newArrayPtr[i].nextPtr = newArrayPtr
 624                     + (currArrayPtr[i].nextPtr - currArrayPtr);
 625         }
 626     }
 627     for (i = 0;  i < localTablePtr->numBuckets;  i++) {
 628         if (localTablePtr->buckets[i] != NULL) {
 629             localTablePtr->buckets[i] = newArrayPtr
 630                     + (localTablePtr->buckets[i] - currArrayPtr);
 631         }
 632     }
 633
 634     /*
 635      * Free the old literal array if needed, and mark the new literal
 636      * array as malloced.
 637      */
 638
 639     if (envPtr->mallocedLiteralArray) {
 640         ckfree((char *) currArrayPtr);
 641     }
 642     envPtr->literalArrayPtr = newArrayPtr;
 643     envPtr->literalArrayEnd = (2 * currElems);
 644     envPtr->mallocedLiteralArray = 1;
 645 }
 646 \f
 647 /*
 648  *----------------------------------------------------------------------
 649  *
 650  * TclReleaseLiteral --
 651  *
 652  *      This procedure releases a reference to one of the shared Tcl objects
 653  *      that hold literals. It is called to release the literals referenced
 654  *      by a ByteCode that is being destroyed, and it is also called by
 655  *      TclDeleteLiteralTable.
 656  *
 657  * Results:
 658  *      None.
 659  *
 660  * Side effects:
 661  *      The reference count for the global LiteralTable entry that
 662  *      corresponds to the literal is decremented. If no other reference
 663  *      to a global literal object remains, it is freed.
 664  *
 665  *----------------------------------------------------------------------
 666  */
 667
 668 void
 669 TclReleaseLiteral(interp, objPtr)
 670     Tcl_Interp *interp;         /* Interpreter for which objPtr was created
 671                                  * to hold a literal. */
 672     register Tcl_Obj *objPtr;   /* Points to a literal object that was
 673                                  * previously created by a call to
 674                                  * TclRegisterLiteral. */
 675 {
 676     Interp *iPtr = (Interp *) interp;
 677     LiteralTable *globalTablePtr = &(iPtr->literalTable);
 678     register LiteralEntry *entryPtr, *prevPtr;
 679     ByteCode* codePtr;
 680     char *bytes;
 681     int length, index;
 682
 683     bytes = Tcl_GetStringFromObj(objPtr, &length);
 684     index = (HashString(bytes, length) & globalTablePtr->mask);
 685
 686     /*
 687      * Check to see if the object is in the global literal table and
 688      * remove this reference.  The object may not be in the table if
 689      * it is a hidden local literal.
 690      */
 691
 692     for (prevPtr = NULL, entryPtr = globalTablePtr->buckets[index];
 693             entryPtr != NULL;
 694             prevPtr = entryPtr, entryPtr = entryPtr->nextPtr) {
 695         if (entryPtr->objPtr == objPtr) {
 696             entryPtr->refCount--;
 697
 698             /*
 699              * If the literal is no longer being used by any ByteCode,
 700              * delete the entry then remove the reference corresponding
 701              * to the global literal table entry (decrement the ref count
 702              * of the object).
 703              */
 704
 705             if (entryPtr->refCount == 0) {
 706                 if (prevPtr == NULL) {
 707                     globalTablePtr->buckets[index] = entryPtr->nextPtr;
 708                 } else {
 709                     prevPtr->nextPtr = entryPtr->nextPtr;
 710                 }
 711                 ckfree((char *) entryPtr);
 712                 globalTablePtr->numEntries--;
 713
 714                 TclDecrRefCount(objPtr);
 715
 716                 /*
 717                  * Check if the LiteralEntry is only being kept alive by
 718                  * a circular reference from a ByteCode stored as its
 719                  * internal rep. In that case, set the ByteCode object array
 720                  * entry NULL to signal to TclCleanupByteCode to not try to
 721                  * release this about to be freed literal again.
 722                  */
 723
 724                 if (objPtr->typePtr == &tclByteCodeType) {
 725                     codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
 726                     if ((codePtr->numLitObjects == 1)
 727                             && (codePtr->objArrayPtr[0] == objPtr)) {
 728                         codePtr->objArrayPtr[0] = NULL;
 729                     }
 730                 }
 731
 732 #ifdef TCL_COMPILE_STATS
 733                 iPtr->stats.currentLitStringBytes -= (double) (length + 1);
 734 #endif /*TCL_COMPILE_STATS*/
 735             }
 736             break;
 737         }
 738     }
 739
 740     /*
 741      * Remove the reference corresponding to the local literal table
 742      * entry.
 743      */
 744
 745     Tcl_DecrRefCount(objPtr);
 746 }
 747 \f
 748 /*
 749  *----------------------------------------------------------------------
 750  *
 751  * HashString --
 752  *
 753  *      Compute a one-word summary of a text string, which can be
 754  *      used to generate a hash index.
 755  *
 756  * Results:
 757  *      The return value is a one-word summary of the information in
 758  *      string.
 759  *
 760  * Side effects:
 761  *      None.
 762  *
 763  *----------------------------------------------------------------------
 764  */
 765
 766 static unsigned int
 767 HashString(bytes, length)
 768     register CONST char *bytes; /* String for which to compute hash
 769                                  * value. */
 770     int length;                 /* Number of bytes in the string. */
 771 {
 772     register unsigned int result;
 773     register int i;
 774
 775     /*
 776      * I tried a zillion different hash functions and asked many other
 777      * people for advice.  Many people had their own favorite functions,
 778      * all different, but no-one had much idea why they were good ones.
 779      * I chose the one below (multiply by 9 and add new character)
 780      * because of the following reasons:
 781      *
 782      * 1. Multiplying by 10 is perfect for keys that are decimal strings,
 783      *    and multiplying by 9 is just about as good.
 784      * 2. Times-9 is (shift-left-3) plus (old).  This means that each
 785      *    character's bits hang around in the low-order bits of the
 786      *    hash value for ever, plus they spread fairly rapidly up to
 787      *    the high-order bits to fill out the hash value.  This seems
 788      *    works well both for decimal and non-decimal strings.
 789      */
 790
 791     result = 0;
 792     for (i = 0;  i < length;  i++) {
 793         result += (result<<3) + *bytes++;
 794     }
 795     return result;
 796 }
 797 \f
 798 /*
 799  *----------------------------------------------------------------------
 800  *
 801  * RebuildLiteralTable --
 802  *
 803  *      This procedure is invoked when the ratio of entries to hash buckets
 804  *      becomes too large in a local or global literal table. It allocates
 805  *      a larger bucket array and moves the entries into the new buckets.
 806  *
 807  * Results:
 808  *      None.
 809  *
 810  * Side effects:
 811  *      Memory gets reallocated and entries get rehashed into new buckets.
 812  *
 813  *----------------------------------------------------------------------
 814  */
 815
 816 static void
 817 RebuildLiteralTable(tablePtr)
 818     register LiteralTable *tablePtr; /* Local or global table to enlarge. */
 819 {
 820     LiteralEntry **oldBuckets;
 821     register LiteralEntry **oldChainPtr, **newChainPtr;
 822     register LiteralEntry *entryPtr;
 823     LiteralEntry **bucketPtr;
 824     char *bytes;
 825     int oldSize, count, index, length;
 826
 827     oldSize = tablePtr->numBuckets;
 828     oldBuckets = tablePtr->buckets;
 829
 830     /*
 831      * Allocate and initialize the new bucket array, and set up
 832      * hashing constants for new array size.
 833      */
 834
 835     tablePtr->numBuckets *= 4;
 836     tablePtr->buckets = (LiteralEntry **) ckalloc((unsigned)
 837             (tablePtr->numBuckets * sizeof(LiteralEntry *)));
 838     for (count = tablePtr->numBuckets, newChainPtr = tablePtr->buckets;
 839             count > 0;
 840             count--, newChainPtr++) {
 841         *newChainPtr = NULL;
 842     }
 843     tablePtr->rebuildSize *= 4;
 844     tablePtr->mask = (tablePtr->mask << 2) + 3;
 845
 846     /*
 847      * Rehash all of the existing entries into the new bucket array.
 848      */
 849
 850     for (oldChainPtr = oldBuckets;
 851             oldSize > 0;
 852             oldSize--, oldChainPtr++) {
 853         for (entryPtr = *oldChainPtr;  entryPtr != NULL;
 854                 entryPtr = *oldChainPtr) {
 855             bytes = Tcl_GetStringFromObj(entryPtr->objPtr, &length);
 856             index = (HashString(bytes, length) & tablePtr->mask);
 857
 858             *oldChainPtr = entryPtr->nextPtr;
 859             bucketPtr = &(tablePtr->buckets[index]);
 860             entryPtr->nextPtr = *bucketPtr;
 861             *bucketPtr = entryPtr;
 862         }
 863     }
 864
 865     /*
 866      * Free up the old bucket array, if it was dynamically allocated.
 867      */
 868
 869     if (oldBuckets != tablePtr->staticBuckets) {
 870         ckfree((char *) oldBuckets);
 871     }
 872 }
 873 \f
 874 #ifdef TCL_COMPILE_STATS
 875 /*
 876  *----------------------------------------------------------------------
 877  *
 878  * TclLiteralStats --
 879  *
 880  *      Return statistics describing the layout of the hash table
 881  *      in its hash buckets.
 882  *
 883  * Results:
 884  *      The return value is a malloc-ed string containing information
 885  *      about tablePtr.  It is the caller's responsibility to free
 886  *      this string.
 887  *
 888  * Side effects:
 889  *      None.
 890  *
 891  *----------------------------------------------------------------------
 892  */
 893
 894 char *
 895 TclLiteralStats(tablePtr)
 896     LiteralTable *tablePtr;     /* Table for which to produce stats. */
 897 {
 898 #define NUM_COUNTERS 10
 899     int count[NUM_COUNTERS], overflow, i, j;
 900     double average, tmp;
 901     register LiteralEntry *entryPtr;
 902     char *result, *p;
 903
 904     /*
 905      * Compute a histogram of bucket usage. For each bucket chain i,
 906      * j is the number of entries in the chain.
 907      */
 908
 909     for (i = 0;  i < NUM_COUNTERS;  i++) {
 910         count[i] = 0;
 911     }
 912     overflow = 0;
 913     average = 0.0;
 914     for (i = 0;  i < tablePtr->numBuckets;  i++) {
 915         j = 0;
 916         for (entryPtr = tablePtr->buckets[i];  entryPtr != NULL;
 917                 entryPtr = entryPtr->nextPtr) {
 918             j++;
 919         }
 920         if (j < NUM_COUNTERS) {
 921             count[j]++;
 922         } else {
 923             overflow++;
 924         }
 925         tmp = j;
 926         average += (tmp+1.0)*(tmp/tablePtr->numEntries)/2.0;
 927     }
 928
 929     /*
 930      * Print out the histogram and a few other pieces of information.
 931      */
 932
 933     result = (char *) ckalloc((unsigned) ((NUM_COUNTERS*60) + 300));
 934     sprintf(result, "%d entries in table, %d buckets\n",
 935             tablePtr->numEntries, tablePtr->numBuckets);
 936     p = result + strlen(result);
 937     for (i = 0; i < NUM_COUNTERS; i++) {
 938         sprintf(p, "number of buckets with %d entries: %d\n",
 939                 i, count[i]);
 940         p += strlen(p);
 941     }
 942     sprintf(p, "number of buckets with %d or more entries: %d\n",
 943             NUM_COUNTERS, overflow);
 944     p += strlen(p);
 945     sprintf(p, "average search distance for entry: %.1f", average);
 946     return result;
 947 }
 948 #endif /*TCL_COMPILE_STATS*/
 949 \f
 950 #ifdef TCL_COMPILE_DEBUG
 951 /*
 952  *----------------------------------------------------------------------
 953  *
 954  * TclVerifyLocalLiteralTable --
 955  *
 956  *      Check a CompileEnv's local literal table for consistency.
 957  *
 958  * Results:
 959  *      None.
 960  *
 961  * Side effects:
 962  *      Panics if problems are found.
 963  *
 964  *----------------------------------------------------------------------
 965  */
 966
 967 void
 968 TclVerifyLocalLiteralTable(envPtr)
 969     CompileEnv *envPtr;         /* Points to CompileEnv whose literal
 970                                  * table is to be validated. */
 971 {
 972     register LiteralTable *localTablePtr = &(envPtr->localLitTable);
 973     register LiteralEntry *localPtr;
 974     char *bytes;
 975     register int i;
 976     int length, count;
 977
 978     count = 0;
 979     for (i = 0;  i < localTablePtr->numBuckets;  i++) {
 980         for (localPtr = localTablePtr->buckets[i];
 981                 localPtr != NULL;  localPtr = localPtr->nextPtr) {
 982             count++;
 983             if (localPtr->refCount != -1) {
 984                 bytes = Tcl_GetStringFromObj(localPtr->objPtr, &length);
 985                 panic("TclVerifyLocalLiteralTable: local literal \"%.*s\" had bad refCount %d",
 986                         (length>60? 60 : length), bytes,
 987                         localPtr->refCount);
 988             }
 989             if (TclLookupLiteralEntry((Tcl_Interp *) envPtr->iPtr,
 990                     localPtr->objPtr) == NULL) {
 991                 bytes = Tcl_GetStringFromObj(localPtr->objPtr, &length);
 992                 panic("TclVerifyLocalLiteralTable: local literal \"%.*s\" is not global",
 993                          (length>60? 60 : length), bytes);
 994             }
 995             if (localPtr->objPtr->bytes == NULL) {
 996                 panic("TclVerifyLocalLiteralTable: literal has NULL string rep");
 997             }
 998         }
 999     }
1000     if (count != localTablePtr->numEntries) {
1001         panic("TclVerifyLocalLiteralTable: local literal table had %d entries, should be %d",
1002               count, localTablePtr->numEntries);
1003     }
1004 }
1005 \f
1006 /*
1007  *----------------------------------------------------------------------
1008  *
1009  * TclVerifyGlobalLiteralTable --
1010  *
1011  *      Check an interpreter's global literal table literal for consistency.
1012  *
1013  * Results:
1014  *      None.
1015  *
1016  * Side effects:
1017  *      Panics if problems are found.
1018  *
1019  *----------------------------------------------------------------------
1020  */
1021
1022 void
1023 TclVerifyGlobalLiteralTable(iPtr)
1024     Interp *iPtr;               /* Points to interpreter whose global
1025                                  * literal table is to be validated. */
1026 {
1027     register LiteralTable *globalTablePtr = &(iPtr->literalTable);
1028     register LiteralEntry *globalPtr;
1029     char *bytes;
1030     register int i;
1031     int length, count;
1032
1033     count = 0;
1034     for (i = 0;  i < globalTablePtr->numBuckets;  i++) {
1035         for (globalPtr = globalTablePtr->buckets[i];
1036                 globalPtr != NULL;  globalPtr = globalPtr->nextPtr) {
1037             count++;
1038             if (globalPtr->refCount < 1) {
1039                 bytes = Tcl_GetStringFromObj(globalPtr->objPtr, &length);
1040                 panic("TclVerifyGlobalLiteralTable: global literal \"%.*s\" had bad refCount %d",
1041                         (length>60? 60 : length), bytes,
1042                         globalPtr->refCount);
1043             }
1044             if (globalPtr->objPtr->bytes == NULL) {
1045                 panic("TclVerifyGlobalLiteralTable: literal has NULL string rep");
1046             }
1047         }
1048     }
1049     if (count != globalTablePtr->numEntries) {
1050         panic("TclVerifyGlobalLiteralTable: global literal table had %d entries, should be %d",
1051               count, globalTablePtr->numEntries);
1052     }
1053 }
1054 #endif /*TCL_COMPILE_DEBUG*/