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 */ + 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 @@ -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,292 @@ } 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 (aabb)?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)&&(objend)) { + 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: Index: generic/tclThreadAlloc.c ================================================================== --- generic/tclThreadAlloc.c +++ generic/tclThreadAlloc.c @@ -566,19 +566,29 @@ Tcl_MutexUnlock(objLockPtr); if (cachePtr->numObjects == 0) { 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); } 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. @@ -1048,10 +1058,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) */ /* *---------------------------------------------------------------------- *