Zap outdated comment.

generic/tclBasic.c

@@ -843,6 +843,8 @@ Tcl_CreateInterp(void)
 	    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,

generic/tclInt.h

@@ -1734,6 +1734,41 @@ 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
@@ -3285,6 +3320,9 @@ MODULE_SCOPE int	Tcl_ForeachObjCmd(ClientData clientData,
 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[]);

generic/tclObj.c

@@ -51,6 +51,8 @@ Tcl_Mutex tclObjMutex;
 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
@@ -1237,8 +1239,9 @@ Tcl_DbNewObj(
 void
 TclAllocateFreeObjects(void)
 {
-    size_t bytesToAlloc = (OBJS_TO_ALLOC_EACH_TIME * sizeof(Tcl_Obj));
+    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;
 
@@ -1251,7 +1254,12 @@ TclAllocateFreeObjects(void)
      * Purify apparently can't figure that out, and fires a false alarm.
      */
 
-    basePtr = ckalloc(bytesToAlloc);
+    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;
@@ -4490,6 +4498,288 @@ Tcl_RepresentationCmd(
     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

generic/tclThreadAlloc.c

@@ -568,7 +568,7 @@ TclThreadAllocObj(void)
 	    Tcl_Obj *newObjsPtr;
 
 	    cachePtr->numObjects = numMove = NOBJALLOC;
-	    newObjsPtr = TclpSysAlloc(sizeof(Tcl_Obj) * numMove, 0);
+		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);
 	    }
@@ -577,6 +577,16 @@ TclThreadAllocObj(void)
 		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);
+	    }
 	}
     }
 
@@ -1051,6 +1061,61 @@ TclFinalizeThreadAllocThread(void)
     }
 }
 
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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) */
 /*
  *----------------------------------------------------------------------