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

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

Parent Directory Parent Directory | Revision Log Revision Log


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

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25