Planet
navi homePPSaboutscreenshotsdownloaddevelopmentforum

source: downloads/tcl8.5.2/generic/tclLiteral.c @ 63

Last change on this file since 63 was 25, checked in by landauf, 17 years ago

added tcl to libs

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