summaryrefslogtreecommitdiffstats
path: root/generic/tclCkalloc.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclCkalloc.c')
-rw-r--r--generic/tclCkalloc.c193
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
+}