/[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 66 - (hide annotations) (download)
Sun Oct 30 21:57:38 2016 UTC (7 years, 1 month ago) by dashley
File MIME type: text/plain
File size: 32695 byte(s)
Header and footer cleanup.
1 dashley 66 /* $Header$ */
2 dashley 25 /*
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 dashley 64 /* End of tclliteral.c */

Properties

Name Value
svn:keywords Header

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25