merged tcl 8.1 branch back into the main trunk

1 files changed, 175 insertions, 18 deletions

diff --git a/generic/tclCkalloc.c b/generic/tclCkalloc.c
index 61d4623..f19d597 100644
--- a/generic/tclCkalloc.c
+++ b/generic/tclCkalloc.c
@@ -5,14 +5,15 @@
  *    involving overwritten, double freeing memory and loss of memory.
  *
  * Copyright (c) 1991-1994 The Regents of the University of California.
- * Copyright (c) 1994-1996 Sun Microsystems, Inc.
+ * Copyright (c) 1994-1997 Sun Microsystems, Inc.
+ * Copyright (c) 1998-1999 by Scriptics Corporation.
  *
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
  * This code contributed by Karl Lehenbauer and Mark Diekhans
  *
- * RCS: @(#) $Id: tclCkalloc.c,v 1.3 1999/03/10 05:52:47 stanton Exp $
+ * RCS: @(#) $Id: tclCkalloc.c,v 1.4 1999/04/16 00:46:42 stanton Exp $
  */
 
 #include "tclInt.h"
@@ -102,9 +103,31 @@ static int  init_malloced_bodies = TRUE;
 #endif
 
 /*
+ * The following variable indicates to TclFinalizeMemorySubsystem() 
+ * that it should dump out the state of memory before exiting.  If the
+ * value is non-NULL, it gives the name of the file in which to
+ * dump memory usage information.
+ */
+
+char *tclMemDumpFileName = NULL;
+
+static char dumpFile[100];	/* Records where to dump memory allocation
+				 * information. */
+
+/*
+ * Mutex to serialize allocations.  This is a low-level mutex that must
+ * be explicitly initialized.  This is necessary because the self
+ * initializing mutexes use ckalloc...
+ */
+static TclpMutex ckallocMutex;
+static int ckallocInit = 0;
+
+/*
  * Prototypes for procedures defined in this file:
  */
 
+static int		CheckmemCmd _ANSI_ARGS_((ClientData clientData,
+			    Tcl_Interp *interp, int argc, char *argv[]));
 static int		MemoryCmd _ANSI_ARGS_((ClientData clientData,
 			    Tcl_Interp *interp, int argc, char **argv));
 static void		ValidateMemory _ANSI_ARGS_((
@@ -114,6 +137,25 @@ static void		ValidateMemory _ANSI_ARGS_((
 /*
  *----------------------------------------------------------------------
  *
+ * TclInitDbCkalloc --
+ *     Initialize the locks used by the allocator.
+ *	This is only appropriate to call in a single threaded environtment,
+ *	such as during TclInitSubsystems.
+ *
+ *----------------------------------------------------------------------
+ */
+void
+TclInitDbCkalloc() 
+{
+    if (!ckallocInit) {
+	ckallocInit = 1;
+	TclpMutexInit(&ckallocMutex);
+    }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
  * TclDumpMemoryInfo --
  *     Display the global memory management statistics.
  *
@@ -164,7 +206,7 @@ ValidateMemory(memHeaderP, file, line, nukeGuards)
             fflush(stdout);
 	    byte &= 0xff;
             fprintf(stderr, "low guard byte %d is 0x%x  \t%c\n", idx, byte,
-		    (isprint(UCHAR(byte)) ? byte : ' '));
+		    (isprint(UCHAR(byte)) ? byte : ' ')); /* INTL: bytes */
         }
     }
     if (guard_failed) {
@@ -185,7 +227,7 @@ ValidateMemory(memHeaderP, file, line, nukeGuards)
             fflush (stdout);
 	    byte &= 0xff;
             fprintf(stderr, "hi guard byte %d is 0x%x  \t%c\n", idx, byte,
-		    (isprint(UCHAR(byte)) ? byte : ' '));
+		    (isprint(UCHAR(byte)) ? byte : ' ')); /* INTL: bytes */
         }
     }
 
@@ -222,9 +264,15 @@ Tcl_ValidateAllMemory (file, line)
 {
     struct mem_header *memScanP;
 
-    for (memScanP = allocHead; memScanP != NULL; memScanP = memScanP->flink)
+    if (!ckallocInit) {
+	ckallocInit = 1;
+	TclpMutexInit(&ckallocMutex);
+    }
+    TclpMutexLock(&ckallocMutex);
+    for (memScanP = allocHead; memScanP != NULL; memScanP = memScanP->flink) {
         ValidateMemory(memScanP, file, line, FALSE);
-
+    }
+    TclpMutexUnlock(&ckallocMutex);
 }
 
 /*
@@ -246,10 +294,16 @@ Tcl_DumpActiveMemory (fileName)
     struct mem_header *memScanP;
     char              *address;
 
-    fileP = fopen(fileName, "w");
-    if (fileP == NULL)
-        return TCL_ERROR;
+    if (fileName == NULL) {
+	fileP = stdout;
+    } else {
+	fileP = fopen(fileName, "w");
+	if (fileP == NULL) {
+	    return TCL_ERROR;
+	}
+    }
 
+    TclpMutexLock(&ckallocMutex);
     for (memScanP = allocHead; memScanP != NULL; memScanP = memScanP->flink) {
         address = &memScanP->body [0];
         fprintf(fileP, "%8lx - %8lx  %7ld @ %s %d %s",
@@ -259,7 +313,11 @@ Tcl_DumpActiveMemory (fileName)
 		 (memScanP->tagPtr == NULL) ? "" : memScanP->tagPtr->string);
 	(void) fputc('\n', fileP);
     }
-    fclose (fileP);
+    TclpMutexUnlock(&ckallocMutex);
+
+    if (fileP != stderr) {
+	fclose (fileP);
+    }
     return TCL_OK;
 }
 
@@ -313,6 +371,11 @@ Tcl_DbCkalloc(size, file, line)
 	memset ((char *) result->low_guard, GUARD_VALUE, LOW_GUARD_SIZE);
 	memset (result->body + size, GUARD_VALUE, HIGH_GUARD_SIZE);
     }
+    if (!ckallocInit) {
+	ckallocInit = 1;
+	TclpMutexInit(&ckallocMutex);
+    }
+    TclpMutexLock(&ckallocMutex);
     result->length = size;
     result->tagPtr = curTagPtr;
     if (curTagPtr != NULL) {
@@ -322,6 +385,7 @@ Tcl_DbCkalloc(size, file, line)
     result->line = line;
     result->flink = allocHead;
     result->blink = NULL;
+
     if (allocHead != NULL)
         allocHead->blink = result;
     allocHead = result;
@@ -357,6 +421,8 @@ Tcl_DbCkalloc(size, file, line)
     if (current_bytes_malloced > maximum_bytes_malloced)
         maximum_bytes_malloced = current_bytes_malloced;
 
+    TclpMutexUnlock(&ckallocMutex);
+
     return result->body;
 }
 
@@ -403,6 +469,7 @@ Tcl_DbCkfree(ptr, file, line)
     if (validate_memory)
         Tcl_ValidateAllMemory(file, line);
 
+    TclpMutexLock(&ckallocMutex);
     ValidateMemory(memp, file, line, TRUE);
     if (init_malloced_bodies) {
 	memset((VOID *) ptr, GUARD_VALUE, (size_t) memp->length);
@@ -429,6 +496,8 @@ Tcl_DbCkfree(ptr, file, line)
     if (allocHead == memp)
         allocHead = memp->flink;
     TclpFree((char *) memp);
+    TclpMutexUnlock(&ckallocMutex);
+
     return 0;
 }
 
@@ -580,7 +649,14 @@ MemoryCmd (clientData, interp, argc, argv)
         return TCL_OK;
     }
     if (strcmp(argv[1],"info") == 0) {
-        TclDumpMemoryInfo(stdout);
+	char buffer[400];
+	sprintf(buffer, "%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10d\n",
+	    "total mallocs", total_mallocs, "total frees", total_frees,
+	    "current packets allocated", current_malloc_packets,
+	    "current bytes allocated", current_bytes_malloced,
+	    "maximum packets allocated", maximum_malloc_packets,
+	    "maximum bytes allocated", maximum_bytes_malloced);
+	Tcl_SetResult(interp, buffer, TCL_VOLATILE);
         return TCL_OK;
     }
     if (strcmp(argv[1],"init") == 0) {
@@ -648,6 +724,42 @@ bad_suboption:
 /*
  *----------------------------------------------------------------------
  *
+ * CheckmemCmd --
+ *
+ *	This is the command procedure for the "checkmem" command, which
+ *	causes the application to exit after printing information about
+ *	memory usage to the file passed to this command as its first
+ *	argument.
+ *
+ * Results:
+ *	Returns a standard Tcl completion code.
+ *
+ * Side effects:
+ *	None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+CheckmemCmd(clientData, interp, argc, argv)
+    ClientData clientData;		/* Not used. */
+    Tcl_Interp *interp;			/* Interpreter for evaluation. */
+    int argc;				/* Number of arguments. */
+    char *argv[];			/* String values of arguments. */
+{
+    if (argc != 2) {
+	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
+		" fileName\"", (char *) NULL);
+	return TCL_ERROR;
+    }
+    tclMemDumpFileName = dumpFile;
+    strcpy(tclMemDumpFileName, argv[1]);
+    return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
  * Tcl_InitMemory --
  *     Initialize the memory command.
  *
@@ -657,11 +769,19 @@ void
 Tcl_InitMemory(interp)
     Tcl_Interp *interp;
 {
+    TclInitDbCkalloc();
     Tcl_CreateCommand (interp, "memory", MemoryCmd, (ClientData) NULL, 
 	    (Tcl_CmdDeleteProc *) NULL);
+    Tcl_CreateCommand(interp, "checkmem", CheckmemCmd, (ClientData) 0,
+	    (Tcl_CmdDeleteProc *) NULL);
 }
 
-#else /* TCL_MEM_DEBUG */
+
+#else	/* TCL_MEM_DEBUG */
+
+#undef Tcl_InitMemory
+#undef Tcl_DumpActiveMemory
+#undef Tcl_ValidateAllMemory
 
 
 /*
@@ -778,8 +898,8 @@ Tcl_DbCkfree(ptr, file, line)
 /*
  *----------------------------------------------------------------------
  *
- * Tcl_InitMemory, et al. --
- *     Dummy implementations of memory routines, which is only available 
+ * Tcl_InitMemory --
+ *     Dummy initialization for memory command, which is only available 
  *     if TCL_MEM_DEBUG is on.
  *
  *----------------------------------------------------------------------
@@ -791,9 +911,6 @@ Tcl_InitMemory(interp)
 {
 }
 
-#undef Tcl_DumpActiveMemory
-#undef Tcl_ValidateAllMemory
-
 int
 Tcl_DumpActiveMemory(fileName)
     char *fileName;
@@ -814,4 +931,44 @@ TclDumpMemoryInfo(outFile)
 {
 }
 
-#endif /* TCL_MEM_DEBUG */
+#endif	/* TCL_MEM_DEBUG */
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * TclFinalizeMemorySubsystem --
+ *
+ *	This procedure is called to finalize all the structures that 
+ *	are used by the memory allocator on a per-process basis.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	This subsystem is self-initializing, since memory can be 
+ *	allocated before Tcl is formally initialized.  After this call,
+ *	this subsystem has been reset to its initial state and is 
+ *	usable again.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+void
+TclFinalizeMemorySubsystem()
+{
+#ifdef TCL_MEM_DEBUG
+    TclpMutexLock(&ckallocMutex);
+    if (tclMemDumpFileName != NULL) {
+	Tcl_DumpActiveMemory(tclMemDumpFileName);
+    }
+    if (curTagPtr != NULL) {
+	TclpFree((char *) curTagPtr);
+    }
+    allocHead = NULL;
+    TclpMutexUnlock(&ckallocMutex);
+#endif
+
+#if USE_TCLALLOC
+    TclFinalizeAllocSubsystem(); 
+#endif
+}