/[dtapublic]/projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclliteral.c
ViewVC logotype

Contents of /projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclliteral.c

Parent Directory Parent Directory | Revision Log Revision Log


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

Properties

Name Value
svn:keywords Header

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25