summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordkf <donal.k.fellows@manchester.ac.uk>2004-06-18 13:42:39 (GMT)
committerdkf <donal.k.fellows@manchester.ac.uk>2004-06-18 13:42:39 (GMT)
commit24852b45e7e8cfca94b0fdc026236119e87b60d6 (patch)
treea8b0859a71c6cb5c1070861a256f491e5e419e58
parent9c324c95dca16f94b271dad6051d928e7275999c (diff)
downloadtcl-24852b45e7e8cfca94b0fdc026236119e87b60d6.zip
tcl-24852b45e7e8cfca94b0fdc026236119e87b60d6.tar.gz
tcl-24852b45e7e8cfca94b0fdc026236119e87b60d6.tar.bz2
Fix tclWinInit.c for KBK, adding comments as I go. :^)
-rw-r--r--ChangeLog5
-rw-r--r--generic/tclInt.h105
-rw-r--r--generic/tclObj.c79
-rw-r--r--win/tclWinInit.c39
4 files changed, 200 insertions, 28 deletions
diff --git a/ChangeLog b/ChangeLog
index b9f3879..70c8817 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,8 @@
+2004-06-18 Donal K. Fellows <donal.k.fellows@man.ac.uk>
+
+ * win/tclWinInit.c (SetDefaultLibraryDir): Fix logic, simplify and
+ add comments.
+
2004-06-17 Don Porter <dgp@users.sourceforge.net>
* generic/tclObj.c: Added missing space in panic message.
diff --git a/generic/tclInt.h b/generic/tclInt.h
index ebf5b57..8dbecfa 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -12,7 +12,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclInt.h,v 1.162 2004/05/30 12:18:25 dkf Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.163 2004/06/18 13:42:41 dkf Exp $
*/
#ifndef _TCLINT
@@ -2209,20 +2209,115 @@ EXTERN Tcl_Obj *TclPtrIncrWideVar _ANSI_ARGS_((Tcl_Interp *interp, Var *varPtr,
# define TclDecrRefCount(objPtr) \
if (--(objPtr)->refCount <= 0) { \
- TclFreeObjMacro(objPtr); \
- }
+ TclObjInitDeletionContext(contextPtr); \
+ if (TclObjDeletePending(contextPtr)) { \
+ TclPushObjToDelete(contextPtr,objPtr); \
+ } else { \
+ TclFreeObjMacro(contextPtr,objPtr); \
+ } \
+ }
-#define TclFreeObjMacro(objPtr) \
+/*
+ * Note that the contents of the while loop assume that the string rep
+ * has already been freed and we don't want to do anything fancy with
+ * adding to the queue inside ourselves. Must take care to unstack the
+ * object first since freeing the internal rep can add further objects
+ * to the stack. The code assumes that it is the first thing in a
+ * block; all current usages in the core satisfy this.
+ *
+ * Optimization opportunity: Allocate the context once in a large
+ * function (e.g. TclExecuteByteCode) and use it directly instead of
+ * looking it up each time.
+ */
+#define TclFreeObjMacro(contextPtr,objPtr) \
if (((objPtr)->typePtr != NULL) \
&& ((objPtr)->typePtr->freeIntRepProc != NULL)) { \
+ TclObjDeletionLock(contextPtr); \
(objPtr)->typePtr->freeIntRepProc(objPtr); \
+ TclObjDeletionUnlock(contextPtr); \
} \
if (((objPtr)->bytes != NULL) \
&& ((objPtr)->bytes != tclEmptyStringRep)) { \
ckfree((char *) (objPtr)->bytes); \
} \
TclFreeObjStorage(objPtr); \
- TclIncrObjsFreed()
+ TclIncrObjsFreed(); \
+ TclObjDeletionLock(contextPtr); \
+ while (TclObjOnStack(contextPtr)) { \
+ Tcl_Obj *objToFree; \
+ TclPopObjToDelete(contextPtr,objToFree); \
+ if ((objToFre->typePtr != NULL) \
+ && (objToFree->typePtr->freeIntRepProc != NULL)) { \
+ objToFree->typePtr->freeIntRepProc(objToFree); \
+ } \
+ TclFreeObjStorage(objToFree); \
+ TclIncrObjsFreed(); \
+ } \
+ TclObjDeletionUnlock(contextPtr)
+
+/*
+ * All context references are pointers to this structure; every thread
+ * will have its own reference.
+ */
+
+typedef struct PendingObjData {
+ int deletionCount; /* Count of the number of invokations of
+ * TclFreeObj() are on the stack (at least
+ * conceptually; many are actually expanded
+ * macros). */
+ Tcl_Obj *deletionStack; /* Stack of objects that have had TclFreeObj()
+ * invoked upon them but which can't be deleted
+ * yet because they are in a nested invokation
+ * of TclFreeObj(). By postponing this way, we
+ * limit the maximum overall C stack depth when
+ * deleting a complex object. The down-side is
+ * that we alter the overall behaviour by
+ * altering the order in which objects are
+ * deleted, and we change the order in which
+ * the string rep and the internal rep of an
+ * object are deleted. Note that code which
+ * assumes the previous behaviour in either of
+ * these respects is unsafe anyway; it was
+ * never documented as to exactly what would
+ * happen in these cases, and the overall
+ * contract of a user-level Tcl_DecrRefCount()
+ * is still preserved (assuming that a
+ * particular T_DRC would delete an object is
+ * not very safe). */
+} PendingObjData;
+
+/*
+ * These are separated out so that some semantic content is attached
+ * to them.
+ */
+#define TclObjDeletionLock(contextPtr) (contextPtr)->deletionCount++
+#define TclObjDeletionUnlock(contextPtr) (contextPtr)->deletionCount--
+#define TclObjDeletePending(contextPtr) (contextPtr)->deletionCount > 0
+#define TclObjOnStack(contextPtr) (contextPtr)->deletionStack != NULL
+#define TclPushObjToDelete(contextPtr,objPtr) \
+ /* Invalidate the string rep first so we can use the bytes value \
+ * for our pointer chain. */ \
+ if (((objPtr)->bytes != NULL) \
+ && ((objPtr)->bytes != tclEmptyStringRep)) { \
+ ckfree((char *) (objPtr)->bytes); \
+ } \
+ /* Now push onto the head of the stack. */ \
+ (objPtr)->bytes = (char *) ((contextPtr)->deletionStack); \
+ (contextPtr)->deletionStack = (objPtr)
+#define TclPopObjToDelete(contextPtr,objPtrVar) \
+ (objPtrVar) = (contextPtr)->deletionStack; \
+ (contextPtr)->deletionStack = (Tcl_Obj *) (objPtrVar)->bytes
+
+#ifndef TCL_THREADS
+extern PendingObjData tclPendingObjData;
+#define TclObjInitDeletionContext(contextPtr) \
+ PendingObjData *CONST contextPtr = &tclPendingObjData
+#else
+extern Tcl_ThreadDataKey tclPendingObjDataKey;
+#define TclObjInitDeletionContext(contextPtr) \
+ PendingObjData *CONST contextPtr = (PendingObjData *) \
+ Tcl_GetThreadData(&pendingObjDataKey, sizeof(PendingObjData))
+#endif
#if defined(PURIFY)
diff --git a/generic/tclObj.c b/generic/tclObj.c
index 750fb00..ba617cf 100644
--- a/generic/tclObj.c
+++ b/generic/tclObj.c
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclObj.c,v 1.60 2004/06/17 21:39:03 dgp Exp $
+ * RCS: @(#) $Id: tclObj.c,v 1.61 2004/06/18 13:42:41 dkf Exp $
*/
#include "tclInt.h"
@@ -62,6 +62,29 @@ static Tcl_ThreadDataKey dataKey;
#endif /* TCL_MEM_DEBUG && TCL_THREADS */
/*
+ * Nested Tcl_Obj deletion management support. Note that the code
+ * that implements all this is written as macros in tclInt.h
+ */
+
+#ifdef TCL_THREADS
+
+/*
+ * Lookup key for the thread-local data used in the implementation in
+ * tclInt.h.
+ */
+Tcl_ThreadDataKey tclPendingObjDataKey;
+
+#else
+
+/*
+ * Declaration of the singleton structure referenced in the
+ * implementation in tclInt.h.
+ */
+PendingObjData tclPendingObjData = { 0, NULL };
+
+#endif
+
+/*
* Prototypes for procedures defined later in this file:
*/
@@ -739,22 +762,51 @@ TclFreeObj(objPtr)
register Tcl_Obj *objPtr; /* The object to be freed. */
{
register Tcl_ObjType *typePtr = objPtr->typePtr;
+ /*
+ * This macro declares a variable, so must come here...
+ */
+ TclObjInitDeletionContext(context);
- if ((objPtr)->refCount < -1) {
+ if (objPtr->refCount < -1) {
Tcl_Panic("Reference count for %lx was negative", objPtr);
}
- if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) {
- typePtr->freeIntRepProc(objPtr);
- }
- Tcl_InvalidateStringRep(objPtr);
+ if (TclObjDeletePending(context)) {
+ TclPushObjToDelete(context, objPtr);
+ } else {
+ if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) {
+ TclObjDeletionLock(context);
+ typePtr->freeIntRepProc(objPtr);
+ TclObjDeletionUnlock(context);
+ }
+ Tcl_InvalidateStringRep(objPtr);
- Tcl_MutexLock(&tclObjMutex);
- ckfree((char *) objPtr);
- Tcl_MutexUnlock(&tclObjMutex);
+ Tcl_MutexLock(&tclObjMutex);
+ ckfree((char *) objPtr);
+ Tcl_MutexUnlock(&tclObjMutex);
+#ifdef TCL_COMPILE_STATS
+ tclObjsFreed++;
+#endif /* TCL_COMPILE_STATS */
+ TclObjDeletionLock(context);
+ while (TclObjOnStack(context)) {
+ Tcl_Obj *objToFree;
+
+ TclPopObjToDelete(context,objToFree);
+
+ if ((objToFre->typePtr != NULL)
+ && (objToFree->typePtr->freeIntRepProc != NULL)) {
+ objToFree->typePtr->freeIntRepProc(objToFree);
+ }
+
+ Tcl_MutexLock(&tclObjMutex);
+ ckfree((char *) objToFree);
+ Tcl_MutexUnlock(&tclObjMutex);
#ifdef TCL_COMPILE_STATS
- tclObjsFreed++;
+ tclObjsFreed++;
#endif /* TCL_COMPILE_STATS */
+ }
+ TclObjDeletionUnlock(context);
+ }
}
#else /* TCL_MEM_DEBUG */
@@ -762,7 +814,12 @@ void
TclFreeObj(objPtr)
register Tcl_Obj *objPtr; /* The object to be freed. */
{
- TclFreeObjMacro(objPtr);
+ TclObjInitDeletionContext(context);
+ if (TclObjDeletePending(context)) {
+ TclPushObjToDelete(context, objPtr);
+ } else {
+ TclFreeObjMacro(context, objPtr);
+ }
}
#endif
diff --git a/win/tclWinInit.c b/win/tclWinInit.c
index e9b1255..bae876e 100644
--- a/win/tclWinInit.c
+++ b/win/tclWinInit.c
@@ -7,7 +7,7 @@
* Copyright (c) 1998-1999 by Scriptics Corporation.
* All rights reserved.
*
- * RCS: @(#) $Id: tclWinInit.c,v 1.56 2004/06/17 22:13:00 dgp Exp $
+ * RCS: @(#) $Id: tclWinInit.c,v 1.57 2004/06/18 13:42:42 dkf Exp $
*/
#include "tclWinInt.h"
@@ -159,29 +159,44 @@ SetDefaultLibraryDir(directory)
Tcl_GetThreadData(&defaultLibraryDirKey, (int)sizeof(Tcl_Obj *));
Tcl_IncrRefCount(directory);
- if (NULL == *savedDirectoryPtr) {
- /* First call in this thread, set up the thread exit handler */
+ if (*savedDirectoryPtr == NULL) {
+ /*
+ * First call in this thread, set up the thread exit handler
+ */
Tcl_CreateThreadExitHandler(FreeThreadDefaultLibraryDir,
(ClientData) savedDirectoryPtr);
} else {
- /* Called SetDLD after a previous SetDLD or GetDLD in this thread ?! */
+ /*
+ * Called SetDLD after a previous SetDLD or GetDLD in this thread ?!
+ */
Tcl_DecrRefCount(*savedDirectoryPtr);
}
*savedDirectoryPtr = directory;
- /* No Mutex protection, as the only caller is already in TclpInitLock */
+ /*
+ * No Mutex protection, as the only caller is already in TclpInitLock
+ */
bytes = Tcl_GetStringFromObj(directory, &numBytes);
- if (NULL == defaultLibraryDir) {
- /* First call from any thread; set up exit handler */
- Tcl_CreateExitHandler(FreeDefaultLibraryDir, NULL);
- } else {
- if ((defaultLibraryDirLength != numBytes)
- || (0 != strcmp(defaultLibraryDir, bytes, numBytes))) {
- Tcl_Panic("Attempt to overwrite defaultLibraryDir");
+ if (defaultLibraryDir != NULL) {
+ /*
+ * This function has been called before. We only ever want to
+ * set up the default library directory once, but if it is set
+ * multiple times to the same value that's not harmful.
+ */
+ if (defaultLibraryDirLength != numBytes
+ || memcmp(defaultLibraryDir, bytes, numBytes) != 0) {
+ Tcl_Panic("Attempt to modify defaultLibraryDir");
}
return;
}
+
+ /*
+ * First call from any thread; set up exit handler
+ */
+
+ Tcl_CreateExitHandler(FreeDefaultLibraryDir, NULL);
+
defaultLibraryDirLength = numBytes;
defaultLibraryDir = ckalloc((unsigned int) numBytes + 1);
memcpy(defaultLibraryDir, bytes, (unsigned int) numBytes + 1);