diff options
Diffstat (limited to 'generic/tclObj.c')
| -rw-r--r-- | generic/tclObj.c | 105 |
1 files changed, 103 insertions, 2 deletions
diff --git a/generic/tclObj.c b/generic/tclObj.c index 4298f62..3bc6f12 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -26,8 +26,20 @@ static Tcl_HashTable typeTable; static int typeTableInitialized = 0; /* 0 means not yet initialized. */ TCL_DECLARE_MUTEX(tableMutex) -#if defined(TCL_THREADS) && defined(TCL_COMPILE_STATS) -static Tcl_Mutex tclObjMutex; +/* + * Head of the list of free Tcl_Obj structs we maintain. + */ + +Tcl_Obj *tclFreeObjList = NULL; + +/* + * The object allocator is single threaded. This mutex is referenced by the + * TclNewObj macro, however, so must be visible. + */ + +#ifdef TCL_THREADS +MODULE_SCOPE Tcl_Mutex tclObjMutex; +Tcl_Mutex tclObjMutex; #endif /* @@ -483,6 +495,15 @@ TclFinalizeObjects(void) typeTableInitialized = 0; } Tcl_MutexUnlock(&tableMutex); + + /* + * All we do here is reset the head pointer of the linked list of free + * Tcl_Obj's to NULL; the memory finalization will take care of releasing + * memory for us. + */ + Tcl_MutexLock(&tclObjMutex); + tclFreeObjList = NULL; + Tcl_MutexUnlock(&tclObjMutex); } /* @@ -1217,6 +1238,59 @@ Tcl_DbNewObj( /* *---------------------------------------------------------------------- * + * TclAllocateFreeObjects -- + * + * Function to allocate a number of free Tcl_Objs. This is done using a + * single ckalloc to reduce the overhead for Tcl_Obj allocation. + * + * Assumes mutex is held. + * + * Results: + * None. + * + * Side effects: + * tclFreeObjList, the head of the list of free Tcl_Objs, is set to the + * first of a number of free Tcl_Obj's linked together by their + * internalRep.otherValuePtrs. + * + *---------------------------------------------------------------------- + */ + +#define OBJS_TO_ALLOC_EACH_TIME 100 + +void +TclAllocateFreeObjects(void) +{ + size_t bytesToAlloc = (OBJS_TO_ALLOC_EACH_TIME * sizeof(Tcl_Obj)); + char *basePtr; + 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. + */ + + basePtr = ckalloc(bytesToAlloc); + + prevPtr = NULL; + objPtr = (Tcl_Obj *) basePtr; + for (i = 0; i < OBJS_TO_ALLOC_EACH_TIME; i++) { + objPtr->internalRep.otherValuePtr = prevPtr; + prevPtr = objPtr; + objPtr++; + } + tclFreeObjList = prevPtr; +} +#undef OBJS_TO_ALLOC_EACH_TIME + +/* + *---------------------------------------------------------------------- + * * TclFreeObj -- * * This function frees the memory associated with the argument object. @@ -1262,6 +1336,7 @@ TclFreeObj( */ TclInvalidateStringRep(objPtr); + objPtr->length = -1; if (ObjDeletePending(context)) { PushObjToDelete(context, objPtr); @@ -1329,6 +1404,7 @@ TclFreeObj( */ TclInvalidateStringRep(objPtr); + objPtr->length = -1; if (!objPtr->typePtr || !objPtr->typePtr->freeIntRepProc) { /* @@ -1411,6 +1487,31 @@ TclFreeObj( /* *---------------------------------------------------------------------- * + * TclObjBeingDeleted -- + * + * This function returns 1 when the Tcl_Obj is being deleted. It is + * provided for the rare cases where the reason for the loss of an + * internal rep might be relevant. [FR 1512138] + * + * Results: + * 1 if being deleted, 0 otherwise. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclObjBeingDeleted( + Tcl_Obj *objPtr) +{ + return (objPtr->length == -1); +} + +/* + *---------------------------------------------------------------------- + * * Tcl_DuplicateObj -- * * Create and return a new object that is a duplicate of the argument |