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: tclLiteral.c,v 1.11 2001/10/11 22:28:01 msofer Exp $ 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 32static int AddLocalLiteralEntry _ANSI_ARGS_(( 33 CompileEnv *envPtr, LiteralEntry *globalPtr, 34 int localHash)); 35static void ExpandLocalLiteralArray _ANSI_ARGS_(( 36 CompileEnv *envPtr)); 37static unsigned int HashString _ANSI_ARGS_((CONST char *bytes, 38 int length)); 39static void RebuildLiteralTable _ANSI_ARGS_(( 40 LiteralTable *tablePtr)); 41 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 60void 61TclInitLiteralTable(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 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 99void 100TclDeleteLiteralTable(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 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 167int 168TclRegisterLiteral(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 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 355LiteralEntry * 356TclLookupLiteralEntry(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 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 400void 401TclHideLiteral(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 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 466int 467TclAddLiteralObj(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 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 517static int 518AddLocalLiteralEntry(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 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 595static void 596ExpandLocalLiteralArray(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 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 668void 669TclReleaseLiteral(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 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 766static unsigned int 767HashString(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 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 816static void 817RebuildLiteralTable(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 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 894char * 895TclLiteralStats(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 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 967void 968TclVerifyLocalLiteralTable(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 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 1022void 1023TclVerifyGlobalLiteralTable(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*/ 1055