Fix tclWinInit.c for KBK, adding comments as I go. :^)

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);