Proof-of-concept of a nonmonotonic Tcl_Obj allocator, with zero perf impact and explicit ::tcl::unsupported::gc. Works with both threadAlloc and the older one. Disappointment: though it does free() the blocks, glibc is very reluctant to give back the pages to the OS :(

4 files changed, 338 insertions, 3 deletions

diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 2a334c4..dfdd7b0 100644
--- a/generic/tclBasic.c
+++ b/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,
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 1bb2103..f880e6c 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -1736,6 +1736,41 @@ enum PkgPreferOptions {
 
 /*
  *----------------------------------------------------------------
+ * 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 */
+    int free;                    /* temporary counter for gc       */
+} 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.
@@ -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[]);
diff --git a/generic/tclObj.c b/generic/tclObj.c
index 930e1fd..9180c97 100644
--- a/generic/tclObj.c
+++ b/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;
@@ -4491,6 +4499,229 @@ Tcl_RepresentationCmd(
 }
 
 /*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_GcCmd --
+ *
+ *	Implementation of the "tcl::unsupported::gc" command.
+ *
+ * Results:
+ *	{purged $nbobj chunks {$start $total $used $start $total $used ...}} 
+ *
+ * Side effects:
+ *	None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int ComparePointers(const void *a, const void *b)
+{
+    return (*(char **)a)-(*(char **)b);
+}
+
+#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;
+                }
+            }
+            fprintf(stderr,"# GC internal error: no chunk enclosing obj %p\n",obj);
+            return NULL;
+        }
+        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);
+}
+
+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();
+
+    fprintf(stderr, "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;
+    }
+
+    fprintf(stderr, "GC Phase 2: scan free lists, locating each obj's chunk and updating its free count\n");
+    for (obj = DerefIf(TclpGetLocalFreeObj()); obj; obj = (Tcl_Obj *)obj->internalRep.twoPtrValue.ptr1) {
+        info = GC_FindChunkInfo(obj, infotab, nch);
+        if (info) info->free++;
+    }
+    for (obj = DerefIf(TclpGetGlobalFreeObj()); obj; obj = (Tcl_Obj *)obj->internalRep.twoPtrValue.ptr1) {
+        info = GC_FindChunkInfo(obj, infotab, nch);
+        if (info) info->free++;
+    }
+
+    fprintf(stderr, "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) {
+            fprintf(stderr,"# GC internal error: chunk at %p counts %d frees but has room for %d only !\n",
+                    chunk,
+                    info->free,
+                    room);
+            break;
+        }
+        if (delta < 0) {
+            fprintf(stderr," . chunk %p : %d / %d\n",
+                    chunk,
+                    -delta,
+                    room);
+            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*/
+        fprintf(stderr," PURGE chunk %p : 0 / %d\n",
+                chunk,
+                room);
+    }
+
+    if (!npurge) {
+        fprintf(stderr," Sorry - nothing to purge :(\n");
+    } else {
+        {
+            Tcl_Obj **pobj;
+            int n,p;
+
+            fprintf(stderr, "GC Phase 4: remove the soon-to-be-purged objs from free lists\n");
+            
+            n = p = 0;
+            for (pobj = TclpGetLocalFreeObj(); (*pobj);) {
+                n++;
+                info = GC_FindChunkInfo(*pobj, infotab, nch);
+                if (info->free != -1) {
+                    pobj = (Tcl_Obj **)&(**pobj).internalRep.twoPtrValue.ptr1;
+                } else {
+                    *pobj = (Tcl_Obj *)(**pobj).internalRep.twoPtrValue.ptr1;
+                    p++;
+                }
+            }
+            TclpRecomputeLocalNumObj();
+            fprintf(stderr," (local: purge %d / %d\n",p,n);
+            n = p = 0;
+            for (pobj = TclpGetGlobalFreeObj(); (*pobj);) {
+                n++;
+                info = GC_FindChunkInfo(*pobj, infotab, nch);
+                if (info->free != -1) {
+                    pobj = (Tcl_Obj **)&(**pobj).internalRep.twoPtrValue.ptr1;
+                } else {
+                    *pobj = (Tcl_Obj *)(**pobj).internalRep.twoPtrValue.ptr1;
+                    p++;
+                }
+            }
+            TclpRecomputeGlobalNumObj();
+            fprintf(stderr," (global: purge %d / %d\n",p,n);
+
+        }
+        {
+            ObjChunkHeader **pchunk;
+            
+            fprintf(stderr, "GC Phase 5: free the located chunks, totalling %d objs\n", npurge);
+            for (pchunk = &tclObjChunkList; (chunk = *pchunk); ) {
+                if (chunk->end) {
+                    pchunk=&chunk->next;
+                } else {
+                    *pchunk = chunk->next;
+                    FREE_INTERNAL(chunk);
+                }
+            }
+        }
+    }
+    TclpUnlockAlloc();
+
+    return TCL_OK;
+}
+
+/*
  * Local Variables:
  * mode: c
  * c-basic-offset: 4
diff --git a/generic/tclThreadAlloc.c b/generic/tclThreadAlloc.c
index ddf888a..c9815d2 100644
--- a/generic/tclThreadAlloc.c
+++ b/generic/tclThreadAlloc.c
@@ -567,7 +567,7 @@ TclThreadAllocObj(void)
 	    Tcl_Obj *newObjsPtr;
 
 	    cachePtr->numObjects = numMove = NOBJALLOC;
-	    newObjsPtr = malloc(sizeof(Tcl_Obj) * numMove);
+	    newObjsPtr = (Tcl_Obj *)(((ObjChunkHeader *)malloc(sizeof(ObjChunkHeader) + sizeof(Tcl_Obj) * numMove)) + 1);
 	    if (newObjsPtr == NULL) {
 		Tcl_Panic("alloc: could not allocate %d new objects", numMove);
 	    }
@@ -576,6 +576,15 @@ 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);
+	    }
 	}
     }
 
@@ -1050,6 +1059,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) */
 /*
  *----------------------------------------------------------------------