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