diff options
Diffstat (limited to 'tcl/generic/tclCkalloc.c')
| -rw-r--r-- | tcl/generic/tclCkalloc.c | 375 |
1 files changed, 293 insertions, 82 deletions
diff --git a/tcl/generic/tclCkalloc.c b/tcl/generic/tclCkalloc.c index fa089fccfea..1eb906d2af8 100644 --- a/tcl/generic/tclCkalloc.c +++ b/tcl/generic/tclCkalloc.c @@ -5,7 +5,8 @@ * 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. @@ -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 Tcl_Mutex *ckallocMutexPtr; +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 environment, + * such as during TclInitSubsystems. + * + *---------------------------------------------------------------------- + */ +void +TclInitDbCkalloc() +{ + if (!ckallocInit) { + ckallocInit = 1; + ckallocMutexPtr = Tcl_GetAllocMutex(); + } +} + +/* + *---------------------------------------------------------------------- + * * TclDumpMemoryInfo -- * Display the global memory management statistics. * @@ -123,34 +165,48 @@ void TclDumpMemoryInfo(outFile) FILE *outFile; { - fprintf(outFile,"total mallocs %10d\n", - total_mallocs); - fprintf(outFile,"total frees %10d\n", - total_frees); - fprintf(outFile,"current packets allocated %10d\n", - current_malloc_packets); - fprintf(outFile,"current bytes allocated %10d\n", - current_bytes_malloced); - fprintf(outFile,"maximum packets allocated %10d\n", - maximum_malloc_packets); - fprintf(outFile,"maximum bytes allocated %10d\n", - maximum_bytes_malloced); + fprintf(outFile,"total mallocs %10d\n", + total_mallocs); + fprintf(outFile,"total frees %10d\n", + total_frees); + fprintf(outFile,"current packets allocated %10d\n", + current_malloc_packets); + fprintf(outFile,"current bytes allocated %10d\n", + current_bytes_malloced); + fprintf(outFile,"maximum packets allocated %10d\n", + maximum_malloc_packets); + fprintf(outFile,"maximum bytes allocated %10d\n", + maximum_bytes_malloced); } + /* *---------------------------------------------------------------------- * * ValidateMemory -- - * Procedure to validate allocted memory guard zones. + * + * Validate memory guard zones for a particular chunk of allocated + * memory. + * + * Results: + * None. + * + * Side effects: + * Prints validation information about the allocated memory to stderr. * *---------------------------------------------------------------------- */ + static void ValidateMemory(memHeaderP, file, line, nukeGuards) - struct mem_header *memHeaderP; - char *file; - int line; - int nukeGuards; + struct mem_header *memHeaderP; /* Memory chunk to validate */ + char *file; /* File containing the call to + * Tcl_ValidateAllMemory */ + int line; /* Line number of call to + * Tcl_ValidateAllMemory */ + int nukeGuards; /* If non-zero, indicates that the + * memory guards are to be reset to 0 + * after they have been printed */ { unsigned char *hiPtr; int idx; @@ -164,7 +220,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 +241,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 */ } } @@ -211,45 +267,65 @@ ValidateMemory(memHeaderP, file, line, nukeGuards) *---------------------------------------------------------------------- * * Tcl_ValidateAllMemory -- - * Validates guard regions for all allocated memory. + * + * Validate memory guard regions for all allocated memory. + * + * Results: + * None. + * + * Side effects: + * Displays memory validation information to stderr. * *---------------------------------------------------------------------- */ void Tcl_ValidateAllMemory (file, line) - char *file; - int line; + char *file; /* File from which Tcl_ValidateAllMemory was called */ + int line; /* Line number of call to Tcl_ValidateAllMemory */ { struct mem_header *memScanP; - for (memScanP = allocHead; memScanP != NULL; memScanP = memScanP->flink) + if (!ckallocInit) { + TclInitDbCkalloc(); + } + Tcl_MutexLock(ckallocMutexPtr); + for (memScanP = allocHead; memScanP != NULL; memScanP = memScanP->flink) { ValidateMemory(memScanP, file, line, FALSE); - + } + Tcl_MutexUnlock(ckallocMutexPtr); } /* *---------------------------------------------------------------------- * * Tcl_DumpActiveMemory -- - * Displays all allocated memory to stderr. + * + * Displays all allocated memory to a file; if no filename is given, + * information will be written to stderr. * * Results: - * Return TCL_ERROR if an error accessing the file occures, `errno' - * will have the file error number left in it. + * Return TCL_ERROR if an error accessing the file occures, `errno' + * will have the file error number left in it. *---------------------------------------------------------------------- */ int Tcl_DumpActiveMemory (fileName) - char *fileName; + char *fileName; /* Name of the file to write info to */ { FILE *fileP; struct mem_header *memScanP; char *address; - fileP = fopen(fileName, "w"); - if (fileP == NULL) - return TCL_ERROR; + if (fileName == NULL) { + fileP = stderr; + } else { + fileP = fopen(fileName, "w"); + if (fileP == NULL) { + return TCL_ERROR; + } + } + Tcl_MutexLock(ckallocMutexPtr); for (memScanP = allocHead; memScanP != NULL; memScanP = memScanP->flink) { address = &memScanP->body [0]; fprintf(fileP, "%8lx - %8lx %7ld @ %s %d %s", @@ -259,7 +335,11 @@ Tcl_DumpActiveMemory (fileName) (memScanP->tagPtr == NULL) ? "" : memScanP->tagPtr->string); (void) fputc('\n', fileP); } - fclose (fileP); + Tcl_MutexUnlock(ckallocMutexPtr); + + if (fileP != stderr) { + fclose (fileP); + } return TCL_OK; } @@ -297,8 +377,7 @@ Tcl_DbCkalloc(size, file, line) if (result == NULL) { fflush(stdout); TclDumpMemoryInfo(stderr); - panic("unable to alloc %d bytes, %s line %d", size, file, - line); + panic("unable to alloc %d bytes, %s line %d", size, file, line); } /* @@ -313,6 +392,10 @@ 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) { + TclInitDbCkalloc(); + } + Tcl_MutexLock(ckallocMutexPtr); result->length = size; result->tagPtr = curTagPtr; if (curTagPtr != NULL) { @@ -322,6 +405,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 +441,8 @@ Tcl_DbCkalloc(size, file, line) if (current_bytes_malloced > maximum_bytes_malloced) maximum_bytes_malloced = current_bytes_malloced; + Tcl_MutexUnlock(ckallocMutexPtr); + return result->body; } @@ -381,10 +467,16 @@ Tcl_DbCkalloc(size, file, line) int Tcl_DbCkfree(ptr, file, line) - char * ptr; - char *file; - int line; + char *ptr; + char *file; + int line; { + struct mem_header *memp; + + if (ptr == NULL) { + return 0; + } + /* * The following cast is *very* tricky. Must convert the pointer * to an integer before doing arithmetic on it, because otherwise @@ -393,16 +485,18 @@ Tcl_DbCkfree(ptr, file, line) * even though BODY_OFFSET is in words on these machines). */ - struct mem_header *memp = (struct mem_header *) - (((unsigned long) ptr) - BODY_OFFSET); + memp = (struct mem_header *) (((unsigned long) ptr) - BODY_OFFSET); - if (alloc_tracing) + if (alloc_tracing) { fprintf(stderr, "ckfree %lx %ld %s %d\n", (long unsigned int) memp->body, memp->length, file, line); + } - if (validate_memory) + if (validate_memory) { Tcl_ValidateAllMemory(file, line); + } + Tcl_MutexLock(ckallocMutexPtr); ValidateMemory(memp, file, line, TRUE); if (init_malloced_bodies) { memset((VOID *) ptr, GUARD_VALUE, (size_t) memp->length); @@ -429,6 +523,8 @@ Tcl_DbCkfree(ptr, file, line) if (allocHead == memp) allocHead = memp->flink; TclpFree((char *) memp); + Tcl_MutexUnlock(ckallocMutexPtr); + return 0; } @@ -453,14 +549,18 @@ Tcl_DbCkrealloc(ptr, size, file, line) { char *new; unsigned int copySize; + struct mem_header *memp; + + if (ptr == NULL) { + return Tcl_DbCkalloc(size, file, line); + } /* * See comment from Tcl_DbCkfree before you change the following * line. */ - struct mem_header *memp = (struct mem_header *) - (((unsigned long) ptr) - BODY_OFFSET); + memp = (struct mem_header *) (((unsigned long) ptr) - BODY_OFFSET); copySize = size; if (copySize > (unsigned int) memp->length) { @@ -469,7 +569,7 @@ Tcl_DbCkrealloc(ptr, size, file, line) new = Tcl_DbCkalloc(size, file, line); memcpy((VOID *) new, (VOID *) ptr, (size_t) copySize); Tcl_DbCkfree(ptr, file, line); - return(new); + return new; } @@ -520,13 +620,14 @@ Tcl_Realloc(ptr, size) *---------------------------------------------------------------------- * * MemoryCmd -- - * Implements the TCL memory command: - * memory info - * memory display - * break_on_malloc count - * trace_on_at_malloc count - * trace on|off - * validate on|off + * Implements the Tcl "memory" command, which provides Tcl-level + * control of Tcl memory debugging information. + * memory info + * memory display + * memory break_on_malloc count + * memory trace_on_at_malloc count + * memory trace on|off + * memory validate on|off * * Results: * Standard TCL results. @@ -580,7 +681,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,20 +756,75 @@ 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. + * + * Create the "memory" and "checkmem" commands in the given + * interpreter. + * + * Results: + * None. + * + * Side effects: + * New commands are added to the interpreter. * *---------------------------------------------------------------------- */ + void Tcl_InitMemory(interp) - Tcl_Interp *interp; + Tcl_Interp *interp; /* Interpreter in which commands should be added */ { + TclInitDbCkalloc(); Tcl_CreateCommand (interp, "memory", MemoryCmd, (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "checkmem", CheckmemCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); } -#else + +#else /* TCL_MEM_DEBUG */ + +/* This is the !TCL_MEM_DEBUG case */ + +#undef Tcl_InitMemory +#undef Tcl_DumpActiveMemory +#undef Tcl_ValidateAllMemory /* @@ -678,14 +841,22 @@ char * Tcl_Alloc (size) unsigned int size; { - char *result; - - result = TclpAlloc(size); - /* CYGNUS LOCAL -- check that size is not zero */ - if (result == NULL && size ) - panic("unable to alloc %d bytes", size); - /* End CYGNUS LOCAL */ - return result; + char *result; + + result = TclpAlloc(size); + /* + * Most systems will not alloc(0), instead bumping it to one so + * that NULL isn't returned. Some systems (AIX, Tru64) will alloc(0) + * by returning NULL, so we have to check that the NULL we get is + * not in response to alloc(0). + * + * The ANSI spec actually says that systems either return NULL *or* + * a special pointer on failure, but we only check for NULL + */ + if ((result == NULL) && size) { + panic("unable to alloc %d bytes", size); + } + return result; } char * @@ -698,10 +869,9 @@ Tcl_DbCkalloc(size, file, line) result = (char *) TclpAlloc(size); - if (result == NULL) { + if ((result == NULL) && size) { fflush(stdout); - panic("unable to alloc %d bytes, %s line %d", size, file, - line); + panic("unable to alloc %d bytes, %s line %d", size, file, line); } return result; } @@ -725,8 +895,10 @@ Tcl_Realloc(ptr, size) char *result; result = TclpRealloc(ptr, size); - if (result == NULL) + + if ((result == NULL) && size) { panic("unable to realloc %d bytes", size); + } return result; } @@ -741,10 +913,9 @@ Tcl_DbCkrealloc(ptr, size, file, line) result = (char *) TclpRealloc(ptr, size); - if (result == NULL) { + if ((result == NULL) && size) { fflush(stdout); - panic("unable to realloc %d bytes, %s line %d", size, file, - line); + panic("unable to realloc %d bytes, %s line %d", size, file, line); } return result; } @@ -764,14 +935,14 @@ void Tcl_Free (ptr) char *ptr; { - TclpFree(ptr); + TclpFree(ptr); } int Tcl_DbCkfree(ptr, file, line) - char * ptr; - char *file; - int line; + char *ptr; + char *file; + int line; { TclpFree(ptr); return 0; @@ -793,13 +964,6 @@ Tcl_InitMemory(interp) { } -#undef Tcl_DumpActiveMemory -#undef Tcl_ValidateAllMemory - -extern int Tcl_DumpActiveMemory _ANSI_ARGS_((char *fileName)); -extern void Tcl_ValidateAllMemory _ANSI_ARGS_((char *file, - int line)); - int Tcl_DumpActiveMemory(fileName) char *fileName; @@ -814,4 +978,51 @@ Tcl_ValidateAllMemory(file, line) { } +void +TclDumpMemoryInfo(outFile) + FILE *outFile; +{ +} + +#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 + Tcl_MutexLock(ckallocMutexPtr); + if (tclMemDumpFileName != NULL) { + Tcl_DumpActiveMemory(tclMemDumpFileName); + } + if (curTagPtr != NULL) { + TclpFree((char *) curTagPtr); + } + allocHead = NULL; + Tcl_MutexUnlock(ckallocMutexPtr); #endif + +#if USE_TCLALLOC + TclFinalizeAllocSubsystem(); +#endif +} + |