Index: generic/tclBasic.c ================================================================== --- generic/tclBasic.c +++ generic/tclBasic.c @@ -841,10 +841,12 @@ 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); Index: generic/tclInt.h ================================================================== --- generic/tclInt.h +++ generic/tclInt.h @@ -1731,10 +1731,45 @@ */ 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 */ + 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 @@ -3282,10 +3317,13 @@ 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, Index: generic/tclObj.c ================================================================== --- generic/tclObj.c +++ generic/tclObj.c @@ -48,10 +48,12 @@ * 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, @@ -1235,12 +1237,13 @@ #define OBJS_TO_ALLOC_EACH_TIME 100 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; /* * This has been noted by Purify to be a potential leak. The problem is @@ -1249,11 +1252,16 @@ * 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. */ - 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; for (i = 0; i < OBJS_TO_ALLOC_EACH_TIME; i++) { objPtr->internalRep.twoPtrValue.ptr1 = prevPtr; @@ -4485,10 +4493,233 @@ } 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 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)&&(objend)) { + 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: Index: generic/tclThreadAlloc.c ================================================================== --- generic/tclThreadAlloc.c +++ generic/tclThreadAlloc.c @@ -565,19 +565,28 @@ Tcl_MutexUnlock(objLockPtr); if (cachePtr->numObjects == 0) { 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); } 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. @@ -1047,10 +1056,65 @@ 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) */ /* *---------------------------------------------------------------------- *