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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 29 - (hide annotations) (download)
Sat Oct 8 07:08:47 2016 UTC (7 years, 1 month 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 dashley 25 /* $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