Tcl Source Code

     * Create unsupported commands for debugging bytecode and objects.
     */

    Tcl_CreateObjCommand(interp, "::tcl::unsupported::disassemble",
	    Tcl_DisassembleObjCmd, NULL, NULL);
    Tcl_CreateObjCommand(interp, "::tcl::unsupported::representation",
	    Tcl_RepresentationCmd, NULL, NULL);
    Tcl_CreateObjCommand(interp, "::tcl::unsupported::gc",
	    Tcl_GcCmd, NULL, NULL);

    /* Adding the bytecode assembler command */
    cmdPtr = (Command *) Tcl_NRCreateCommand(interp,
            "::tcl::unsupported::assemble", Tcl_AssembleObjCmd,
            TclNRAssembleObjCmd, NULL, NULL);
    cmdPtr->compileProc = &TclCompileAssembleCmd;

 * TIP #268.
 * Values for the selection mode, i.e the package require preferences.
 */

enum PkgPreferOptions {
    PKG_PREFER_LATEST, PKG_PREFER_STABLE
};

/*
 *----------------------------------------------------------------
 * These structures support gc
 *----------------------------------------------------------------
 */

/*
 * Header starting each chunk of Tcl_Obj, to chain them for use by gc
 */

typedef struct ObjChunkHeader {
    struct ObjChunkHeader *next; /* chaining          */
    Tcl_Obj *end;                /* address of last+1 */
} ObjChunkHeader;

MODULE_SCOPE ObjChunkHeader *tclObjChunkList; /* initialised in tclObj.c */

/*
 * Cell of temporary sorted array of chunk ranges and counters, for
 * dichotomic search in gc
 */

typedef struct ObjChunkInfo {
    Tcl_Obj *beg,*end;           /* [beg,end[ is the chunk's range */
    long free;                   /* temporary counter for gc ; long for word-aligt  */
} ObjChunkInfo;

MODULE_SCOPE void TclpLockAlloc(void);
MODULE_SCOPE void TclpUnlockAlloc(void);
MODULE_SCOPE Tcl_Obj **TclpGetGlobalFreeObj(void);
MODULE_SCOPE Tcl_Obj **TclpGetLocalFreeObj(void);
MODULE_SCOPE void TclpRecomputeGlobalNumObj(void);
MODULE_SCOPE void TclpRecomputeLocalNumObj(void);


/*
 *----------------------------------------------------------------
 * This structure shadows the first few fields of the memory cache for the
 * allocator defined in tclThreadAlloc.c; it has to be kept in sync with the
 * definition there.
 * Some macros require knowledge of some fields in the struct in order to

			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[]);
MODULE_SCOPE int	Tcl_ForeachObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[]);
MODULE_SCOPE int	Tcl_FormatObjCmd(ClientData dummy,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[]);
MODULE_SCOPE int	Tcl_GcCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[]);
MODULE_SCOPE int	Tcl_GetsObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[]);
MODULE_SCOPE int	Tcl_GlobalObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[]);

 * Pointer to a heap-allocated string of length zero that the Tcl core uses as
 * the value of an empty string representation for an object. This value is
 * shared by all new objects allocated by Tcl_NewObj.
 */

char tclEmptyString = '\0';
char *tclEmptyStringRep = &tclEmptyString;

ObjChunkHeader *tclObjChunkList = NULL;

#if defined(TCL_MEM_DEBUG) && defined(TCL_THREADS)
/*
 * Structure for tracking the source file and line number where a given
 * Tcl_Obj was allocated.  We also track the pointer to the Tcl_Obj itself,
 * for sanity checking purposes.
 */

 */

#define OBJS_TO_ALLOC_EACH_TIME 100

void
TclAllocateFreeObjects(void)
{
    size_t bytesToAlloc = (sizeof(ObjChunkHeader) + OBJS_TO_ALLOC_EACH_TIME * sizeof(Tcl_Obj));
    char *basePtr;
    ObjChunkHeader *header;
    register Tcl_Obj *prevPtr, *objPtr;
    register int i;

    /*
     * This has been noted by Purify to be a potential leak. The problem is
     * that Tcl, when not TCL_MEM_DEBUG compiled, keeps around all allocated
     * Tcl_Obj's, pointed to by tclFreeObjList, when freed instead of actually
     * freeing the memory. TclFinalizeObjects() does not ckfree() this memory,
     * but leaves it to Tcl's memory subsystem finalization to release it.
     * Purify apparently can't figure that out, and fires a false alarm.
     */

    header = (ObjChunkHeader *) ckalloc(bytesToAlloc);
    header->next = tclObjChunkList;
    header->end = (Tcl_Obj *)(((char *)header) + bytesToAlloc);
    tclObjChunkList = header;

    basePtr = (char *) (header + 1);

    prevPtr = NULL;
    objPtr = (Tcl_Obj *) basePtr;
    for (i = 0; i < OBJS_TO_ALLOC_EACH_TIME; i++) {
	objPtr->internalRep.twoPtrValue.ptr1 = prevPtr;
	prevPtr = objPtr;
	objPtr++;

                16, "...");
	Tcl_AppendToObj(descObj, "\"", -1);
    } else {
	Tcl_AppendToObj(descObj, ", no string representation", -1);
    }

    Tcl_SetObjResult(interp, descObj);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GcCmd --
 *
 *	Implementation of the "tcl::unsupported::gc" command.
 *
 * Results:
 *	{purged $nbobj chunks {$start $total $used $start $total $used ...}} 
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static void
BailOut(void)
{
    exit(127);
}

static void
GcLog(
    const char *fmt, ...)
{
    va_list ap;

    va_start(ap, fmt);
    vfprintf(stderr, fmt, ap);
    va_end(ap);
}

static int
ComparePointers(
    const void *a,
    const void *b)
{
    char *aa = *(char **)a;
    char *bb = *(char **)b;

    /*
     * BEWARE: ptr difference (aa-bb) is *not* a proper order
     * (an extra bit is needed for that)
     * Hence we resort to explicit pointer comparison
     * Which stores this bit in the Carry flag.
     */

    return (aa<bb)?-1:((aa>bb)?1:0);
}

#define GC_BISECT_MIN_RECURS 4

static ObjChunkInfo *
GC_FindChunkInfo(
    Tcl_Obj *obj,
    ObjChunkInfo *itab,
    int len)
{
    while (1) {
        int mid;

        if (len <= GC_BISECT_MIN_RECURS) {
            int i;

            for(i = 0; i < len; i++, itab++) {
                if ((obj>=itab->beg)&&(obj<itab->end)) {
                    return itab;
                }
            }
            /* no Panic : avoid dumping core with a huge heap */
            GcLog("### GC internal error: no chunk enclosing obj %p\n",obj);
            BailOut();
        }
        mid = len / 2;
        if (obj >= itab[mid].beg) {
            itab += mid;
            len -= mid;
        } else {
            len = mid;
        }
    }
}

#ifndef USE_THREAD_ALLOC
void
TclpLockAlloc(void)
{
    Tcl_MutexLock(&tclObjMutex);
}

void
TclpUnlockAlloc(void)
{
    Tcl_MutexUnlock(&tclObjMutex);
}

Tcl_Obj **
TclpGetGlobalFreeObj(void)
{
    return &tclFreeObjList;
}

Tcl_Obj **
TclpGetLocalFreeObj(void)
{
    return NULL;
}

void
TclpRecomputeGlobalNumObj(void)
{
}

void
TclpRecomputeLocalNumObj(void)
{
}

# define FREE_INTERNAL ckfree
#else
# define FREE_INTERNAL free
#endif

static Tcl_Obj *
DerefIf(
    Tcl_Obj **src)
{
    return (src ? (*src) : NULL);
}

#define NEXT_OBJ(objPtr) \
    ((objPtr)->internalRep.twoPtrValue.ptr1)

int
Tcl_GcCmd(
    ClientData clientData,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    int nch, i, npurge;
    ObjChunkHeader *chunk, **tmp;
    ObjChunkInfo *info, *infotab;
    Tcl_Obj *obj;

    if (objc != 1) {
	Tcl_WrongNumArgs(interp, 1, objv, "");
	return TCL_ERROR;
    }

    TclpLockAlloc();

    GcLog("GC Phase 1: prepare sorted list of chunk info\n");
    nch = 0;
    for (chunk = tclObjChunkList; chunk; chunk = chunk->next) {
        nch++;
    }
    infotab = (ObjChunkInfo *) malloc(nch * sizeof(ObjChunkInfo));
    tmp = (ObjChunkHeader **) infotab; /* pointers are smaller, so they fit */
    for (chunk = tclObjChunkList; chunk; chunk = chunk->next) {
        *(tmp++) = chunk;
    }

    qsort(infotab, nch, sizeof(ObjChunkHeader *), ComparePointers);

    /* in-place cacheing of chunk headers into chunk infos */
    for(i = nch - 1; i >= 0; i--) {
        chunk = ((ObjChunkHeader **) infotab)[i];
        info = infotab + i;
        info->beg = (Tcl_Obj *)(chunk + 1);
        info->end = chunk->end;
        info->free = 0;
    }

    GcLog("GC Phase 2: scan free lists, locating each obj's chunk and "
            "updating its free count\n");
    for (obj = DerefIf(TclpGetLocalFreeObj()); obj != NULL;
            obj = (Tcl_Obj *) NEXT_OBJ(obj)) {
        info = GC_FindChunkInfo(obj, infotab, nch);
        if (info) {
            info->free++;
        }
    }
    for (obj = DerefIf(TclpGetGlobalFreeObj()); obj != NULL;
            obj = (Tcl_Obj *) NEXT_OBJ(obj)) {
        info = GC_FindChunkInfo(obj, infotab, nch);
        if (info) {
            info->free++;
        }
    }

    GcLog("GC Phase 3: locate chunks entirely made of free objs and mark them "
            "with chunk->end=NULL and info->free=-1\n");
    npurge = 0;
    for (i = 0, info = infotab; i < nch; i++, info++) {
        int room, delta;

        room = info->end - info->beg;
        delta = info->free - room;
        chunk = ((ObjChunkHeader *)info->beg) - 1;
        if (delta > 0) {
            GcLog("# GC internal error: chunk at %p counts %ld frees but has "
                    "room for %d only !\n", chunk, info->free, room);
            BailOut();
        }
        if (delta < 0) {
#if 0
            GcLog(" . chunk %p : %d / %d\n", chunk, -delta, room);
#endif
            continue;
        }
        /* here we have a purgeable chunk */
        npurge += room;
        chunk->end = NULL ; /* mark it for final sweep of chunks */
        info->free = -1 ; /* mark it for final sweep of objs*/
#if 0
        GcLog(" PURGE chunk %p : 0 / %d\n", chunk, room);
#endif
    }

    if (!npurge) {
        GcLog(" Sorry - nothing to purge :(\n");
    } else {
        GcLog("GC Phase 4: remove the soon-to-be-purged objs from free "
                "lists\n");
            
        {
            Tcl_Obj **pobj;
            int n, p;

            n = p = 0;
            for (pobj = TclpGetLocalFreeObj(); *pobj != NULL ;) {
                n++;
                info = GC_FindChunkInfo(*pobj, infotab, nch);
                if (info->free != -1) {
                    pobj = (Tcl_Obj **) & NEXT_OBJ(*pobj);
                } else {
                    *pobj = (Tcl_Obj *) NEXT_OBJ(*pobj);
                    p++;
                }
            }
            TclpRecomputeLocalNumObj();
            GcLog(" (local: purge %d / %d\n", p, n);
            n = p = 0;
            for (pobj = TclpGetGlobalFreeObj(); *pobj != NULL ;) {
                n++;
                info = GC_FindChunkInfo(*pobj, infotab, nch);
                if (info->free != -1) {
                    pobj = (Tcl_Obj **) & NEXT_OBJ(*pobj);
                } else {
                    *pobj = (Tcl_Obj *) NEXT_OBJ(*pobj);
                    p++;
                }
            }
            TclpRecomputeGlobalNumObj();
            GcLog(" (global: purge %d / %d\n", p, n);

        }

        GcLog("GC Phase 5: free the located chunks, totalling %d objs\n",
                npurge);

        {
            ObjChunkHeader **pchunk;
            
            for (pchunk = &tclObjChunkList; (chunk = *pchunk) != NULL; ) {
                if (chunk->end) {
                    pchunk = &chunk->next;
                } else {
                    *pchunk = chunk->next;
                    FREE_INTERNAL(chunk);
                }
            }
        }
        free(infotab);
    }
    TclpUnlockAlloc();

    return TCL_OK;
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * tab-width: 8
 * indent-tabs-mode: nil
 * End:
 */

	    MoveObjs(sharedPtr, cachePtr, numMove);
	}
	Tcl_MutexUnlock(objLockPtr);
	if (cachePtr->numObjects == 0) {
	    Tcl_Obj *newObjsPtr;

	    cachePtr->numObjects = numMove = NOBJALLOC;
		newObjsPtr = (Tcl_Obj *)(((ObjChunkHeader *)TclpSysAlloc(sizeof(ObjChunkHeader) + sizeof(Tcl_Obj) * numMove, 0)) + 1);
	    if (newObjsPtr == NULL) {
		Tcl_Panic("alloc: could not allocate %d new objects", numMove);
	    }
	    while (--numMove >= 0) {
		objPtr = &newObjsPtr[numMove];
		objPtr->internalRep.twoPtrValue.ptr1 = cachePtr->firstObjPtr;
		cachePtr->firstObjPtr = objPtr;
	    }
	    {
		ObjChunkHeader *chunk = ((ObjChunkHeader *)newObjsPtr) - 1;

		chunk->end = newObjsPtr + NOBJALLOC;

		Tcl_MutexLock(objLockPtr);
		chunk->next = tclObjChunkList;
		tclObjChunkList = chunk;
		Tcl_MutexUnlock(objLockPtr);
	    }
	}
    }

    /*
     * Pop the first object.
     */

TclFinalizeThreadAllocThread(void)
{
    Cache *cachePtr = TclpGetAllocCache();
    if (cachePtr != NULL) {
	TclpFreeAllocCache(cachePtr);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclpLockAlloc, TclpUnlockAlloc, TclpGetGlobalFreeObj, TclpGetLocalFreeObj --
 *     These functions allow outside callers to reach safely into our internal
 *     state for inspection or gc.
 *----------------------------------------------------------------------
 */

void
TclpLockAlloc(void)
{
    Tcl_MutexLock(objLockPtr);
}

void
TclpUnlockAlloc(void)
{
    Tcl_MutexUnlock(objLockPtr);
}

Tcl_Obj **
TclpGetGlobalFreeObj(void)
{
    return &sharedPtr->firstObjPtr;
}

Tcl_Obj **
TclpGetLocalFreeObj(void)
{
    Cache *cachePtr;

    GETCACHE(cachePtr);
    return &cachePtr->firstObjPtr;
}

void TclpRecomputeGlobalNumObj(void)
{
    int n;
    Tcl_Obj *obj;

    for(n=0,obj=sharedPtr->firstObjPtr;obj;obj=(Tcl_Obj *)obj->internalRep.twoPtrValue.ptr1,n++);
    sharedPtr->numObjects = n;
}
void TclpRecomputeLocalNumObj(void)
{
    int n;
    Tcl_Obj *obj;
    Cache *cachePtr;

    GETCACHE(cachePtr);
    for(n=0,obj=cachePtr->firstObjPtr;obj;obj=(Tcl_Obj *)obj->internalRep.twoPtrValue.ptr1,n++);
    cachePtr->numObjects = n;
}

#else /* !(TCL_THREADS && USE_THREAD_ALLOC) */
/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetMemoryInfo --
 *