/[dtapublic]/projs/emts/trunk/src/c_tcl_base_7_5_w_mods/tclckalloc.c
ViewVC logotype

Diff of /projs/emts/trunk/src/c_tcl_base_7_5_w_mods/tclckalloc.c

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 44 by dashley, Fri Oct 14 02:09:58 2016 UTC revision 71 by dashley, Sat Nov 5 11:07:06 2016 UTC
# Line 1  Line 1 
 /* $Header: /cvsroot/esrg/sfesrg/esrgpcpj/shared/tcl_base/tclckalloc.c,v 1.1.1.1 2001/06/13 04:34:03 dtashley Exp $ */  
   
 /*  
  * tclCkalloc.c --  
  *  
  *    Interface to malloc and free that provides support for debugging problems  
  *    involving overwritten, double freeing memory and loss of memory.  
  *  
  * Copyright (c) 1991-1994 The Regents of the University of California.  
  * 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.1.1.1 2001/06/13 04:34:03 dtashley Exp $  
  */  
   
 #include "tclInt.h"  
 #include "tclPort.h"  
   
 #define FALSE   0  
 #define TRUE    1  
   
 #ifdef TCL_MEM_DEBUG  
   
 /*  
  * One of the following structures is allocated each time the  
  * "memory tag" command is invoked, to hold the current tag.  
  */  
   
 typedef struct MemTag {  
     int refCount;               /* Number of mem_headers referencing  
                                  * this tag. */  
     char string[4];             /* Actual size of string will be as  
                                  * large as needed for actual tag.  This  
                                  * must be the last field in the structure. */  
 } MemTag;  
   
 #define TAG_SIZE(bytesInString) ((unsigned) sizeof(MemTag) + bytesInString - 3)  
   
 static MemTag *curTagPtr = NULL;/* Tag to use in all future mem_headers  
                                  * (set by "memory tag" command). */  
   
 /*  
  * One of the following structures is allocated just before each  
  * dynamically allocated chunk of memory, both to record information  
  * about the chunk and to help detect chunk under-runs.  
  */  
   
 #define LOW_GUARD_SIZE (8 + (32 - (sizeof(long) + sizeof(int)))%8)  
 struct mem_header {  
     struct mem_header *flink;  
     struct mem_header *blink;  
     MemTag *tagPtr;             /* Tag from "memory tag" command;  may be  
                                  * NULL. */  
     char *file;  
     long length;  
     int line;  
     unsigned char low_guard[LOW_GUARD_SIZE];  
                                 /* Aligns body on 8-byte boundary, plus  
                                  * provides at least 8 additional guard bytes  
                                  * to detect underruns. */  
     char body[1];               /* First byte of client's space.  Actual  
                                  * size of this field will be larger than  
                                  * one. */  
 };  
   
 static struct mem_header *allocHead = NULL;  /* List of allocated structures */  
   
 #define GUARD_VALUE  0141  
   
 /*  
  * The following macro determines the amount of guard space *above* each  
  * chunk of memory.  
  */  
   
 #define HIGH_GUARD_SIZE 8  
   
 /*  
  * The following macro computes the offset of the "body" field within  
  * mem_header.  It is used to get back to the header pointer from the  
  * body pointer that's used by clients.  
  */  
   
 #define BODY_OFFSET \  
         ((unsigned long) (&((struct mem_header *) 0)->body))  
   
 static int total_mallocs = 0;  
 static int total_frees = 0;  
 static int current_bytes_malloced = 0;  
 static int maximum_bytes_malloced = 0;  
 static int current_malloc_packets = 0;  
 static int maximum_malloc_packets = 0;  
 static int break_on_malloc = 0;  
 static int trace_on_at_malloc = 0;  
 static int  alloc_tracing = FALSE;  
 static int  init_malloced_bodies = TRUE;  
 #ifdef MEM_VALIDATE  
     static int  validate_memory = TRUE;  
 #else  
     static int  validate_memory = FALSE;  
 #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_((  
                             struct mem_header *memHeaderP, char *file,  
                             int line, int nukeGuards));  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * 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.  
  *  
  *----------------------------------------------------------------------  
  */  
 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);  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * ValidateMemory --  
  *     Procedure to validate allocted memory guard zones.  
  *  
  *----------------------------------------------------------------------  
  */  
 static void  
 ValidateMemory(memHeaderP, file, line, nukeGuards)  
     struct mem_header *memHeaderP;  
     char              *file;  
     int                line;  
     int                nukeGuards;  
 {  
     unsigned char *hiPtr;  
     int   idx;  
     int   guard_failed = FALSE;  
     int byte;  
       
     for (idx = 0; idx < LOW_GUARD_SIZE; idx++) {  
         byte = *(memHeaderP->low_guard + idx);  
         if (byte != GUARD_VALUE) {  
             guard_failed = TRUE;  
             fflush(stdout);  
             byte &= 0xff;  
             fprintf(stderr, "low guard byte %d is 0x%x  \t%c\n", idx, byte,  
                     (isprint(UCHAR(byte)) ? byte : ' ')); /* INTL: bytes */  
         }  
     }  
     if (guard_failed) {  
         TclDumpMemoryInfo (stderr);  
         fprintf(stderr, "low guard failed at %lx, %s %d\n",  
                  (long unsigned int) memHeaderP->body, file, line);  
         fflush(stderr);  /* In case name pointer is bad. */  
         fprintf(stderr, "%ld bytes allocated at (%s %d)\n", memHeaderP->length,  
                 memHeaderP->file, memHeaderP->line);  
         panic ("Memory validation failure");  
     }  
   
     hiPtr = (unsigned char *)memHeaderP->body + memHeaderP->length;  
     for (idx = 0; idx < HIGH_GUARD_SIZE; idx++) {  
         byte = *(hiPtr + idx);  
         if (byte != GUARD_VALUE) {  
             guard_failed = TRUE;  
             fflush (stdout);  
             byte &= 0xff;  
             fprintf(stderr, "hi guard byte %d is 0x%x  \t%c\n", idx, byte,  
                     (isprint(UCHAR(byte)) ? byte : ' ')); /* INTL: bytes */  
         }  
     }  
   
     if (guard_failed) {  
         TclDumpMemoryInfo (stderr);  
         fprintf(stderr, "high guard failed at %lx, %s %d\n",  
                  (long unsigned int) memHeaderP->body, file, line);  
         fflush(stderr);  /* In case name pointer is bad. */  
         fprintf(stderr, "%ld bytes allocated at (%s %d)\n",  
                 memHeaderP->length, memHeaderP->file,  
                 memHeaderP->line);  
         panic("Memory validation failure");  
     }  
   
     if (nukeGuards) {  
         memset ((char *) memHeaderP->low_guard, 0, LOW_GUARD_SIZE);  
         memset ((char *) hiPtr, 0, HIGH_GUARD_SIZE);  
     }  
   
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * Tcl_ValidateAllMemory --  
  *     Validates guard regions for all allocated memory.  
  *  
  *----------------------------------------------------------------------  
  */  
 void  
 Tcl_ValidateAllMemory (file, line)  
     char  *file;  
     int    line;  
 {  
     struct mem_header *memScanP;  
   
     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.  
  *  
  * Results:  
  *     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;  
 {  
     FILE              *fileP;  
     struct mem_header *memScanP;  
     char              *address;  
   
     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",  
                 (long unsigned int) address,  
                  (long unsigned int) address + memScanP->length - 1,  
                  memScanP->length, memScanP->file, memScanP->line,  
                  (memScanP->tagPtr == NULL) ? "" : memScanP->tagPtr->string);  
         (void) fputc('\n', fileP);  
     }  
     Tcl_MutexUnlock(ckallocMutexPtr);  
   
     if (fileP != stderr) {  
         fclose (fileP);  
     }  
     return TCL_OK;  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * Tcl_DbCkalloc - debugging ckalloc  
  *  
  *        Allocate the requested amount of space plus some extra for  
  *        guard bands at both ends of the request, plus a size, panicing  
  *        if there isn't enough space, then write in the guard bands  
  *        and return the address of the space in the middle that the  
  *        user asked for.  
  *  
  *        The second and third arguments are file and line, these contain  
  *        the filename and line number corresponding to the caller.  
  *        These are sent by the ckalloc macro; it uses the preprocessor  
  *        autodefines __FILE__ and __LINE__.  
  *  
  *----------------------------------------------------------------------  
  */  
 char *  
 Tcl_DbCkalloc(size, file, line)  
     unsigned int size;  
     char        *file;  
     int          line;  
 {  
     struct mem_header *result;  
   
     if (validate_memory)  
         Tcl_ValidateAllMemory (file, line);  
   
     result = (struct mem_header *) TclpAlloc((unsigned)size +  
                               sizeof(struct mem_header) + HIGH_GUARD_SIZE);  
     if (result == NULL) {  
         fflush(stdout);  
         TclDumpMemoryInfo(stderr);  
         panic("unable to alloc %d bytes, %s line %d", size, file, line);  
     }  
   
     /*  
      * Fill in guard zones and size.  Also initialize the contents of  
      * the block with bogus bytes to detect uses of initialized data.  
      * Link into allocated list.  
      */  
     if (init_malloced_bodies) {  
         memset ((VOID *) result, GUARD_VALUE,  
                 size + sizeof(struct mem_header) + HIGH_GUARD_SIZE);  
     } else {  
         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) {  
         curTagPtr->refCount++;  
     }  
     result->file = file;  
     result->line = line;  
     result->flink = allocHead;  
     result->blink = NULL;  
   
     if (allocHead != NULL)  
         allocHead->blink = result;  
     allocHead = result;  
   
     total_mallocs++;  
     if (trace_on_at_malloc && (total_mallocs >= trace_on_at_malloc)) {  
         (void) fflush(stdout);  
         fprintf(stderr, "reached malloc trace enable point (%d)\n",  
                 total_mallocs);  
         fflush(stderr);  
         alloc_tracing = TRUE;  
         trace_on_at_malloc = 0;  
     }  
   
     if (alloc_tracing)  
         fprintf(stderr,"ckalloc %lx %d %s %d\n",  
                 (long unsigned int) result->body, size, file, line);  
   
     if (break_on_malloc && (total_mallocs >= break_on_malloc)) {  
         break_on_malloc = 0;  
         (void) fflush(stdout);  
         fprintf(stderr,"reached malloc break limit (%d)\n",  
                 total_mallocs);  
         fprintf(stderr, "program will now enter C debugger\n");  
         (void) fflush(stderr);  
         abort();  
     }  
   
     current_malloc_packets++;  
     if (current_malloc_packets > maximum_malloc_packets)  
         maximum_malloc_packets = current_malloc_packets;  
     current_bytes_malloced += size;  
     if (current_bytes_malloced > maximum_bytes_malloced)  
         maximum_bytes_malloced = current_bytes_malloced;  
   
     Tcl_MutexUnlock(ckallocMutexPtr);  
   
     return result->body;  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * Tcl_DbCkfree - debugging ckfree  
  *  
  *        Verify that the low and high guards are intact, and if so  
  *        then free the buffer else panic.  
  *  
  *        The guards are erased after being checked to catch duplicate  
  *        frees.  
  *  
  *        The second and third arguments are file and line, these contain  
  *        the filename and line number corresponding to the caller.  
  *        These are sent by the ckfree macro; it uses the preprocessor  
  *        autodefines __FILE__ and __LINE__.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 int  
 Tcl_DbCkfree(ptr, file, 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  
      * the arithmetic will be done differently (and incorrectly) on  
      * word-addressed machines such as Crays (will subtract only bytes,  
      * even though BODY_OFFSET is in words on these machines).  
      */  
   
     memp = (struct mem_header *) (((unsigned long) ptr) - BODY_OFFSET);  
   
     if (alloc_tracing) {  
         fprintf(stderr, "ckfree %lx %ld %s %d\n",  
                 (long unsigned int) memp->body, memp->length, file, line);  
     }  
   
     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);  
     }  
   
     total_frees++;  
     current_malloc_packets--;  
     current_bytes_malloced -= memp->length;  
   
     if (memp->tagPtr != NULL) {  
         memp->tagPtr->refCount--;  
         if ((memp->tagPtr->refCount == 0) && (curTagPtr != memp->tagPtr)) {  
             TclpFree((char *) memp->tagPtr);  
         }  
     }  
   
     /*  
      * Delink from allocated list  
      */  
     if (memp->flink != NULL)  
         memp->flink->blink = memp->blink;  
     if (memp->blink != NULL)  
         memp->blink->flink = memp->flink;  
     if (allocHead == memp)  
         allocHead = memp->flink;  
     TclpFree((char *) memp);  
     Tcl_MutexUnlock(ckallocMutexPtr);  
   
     return 0;  
 }  
   
 /*  
  *--------------------------------------------------------------------  
  *  
  * Tcl_DbCkrealloc - debugging ckrealloc  
  *  
  *      Reallocate a chunk of memory by allocating a new one of the  
  *      right size, copying the old data to the new location, and then  
  *      freeing the old memory space, using all the memory checking  
  *      features of this package.  
  *  
  *--------------------------------------------------------------------  
  */  
 char *  
 Tcl_DbCkrealloc(ptr, size, file, line)  
     char *ptr;  
     unsigned int size;  
     char *file;  
     int 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.  
      */  
   
     memp = (struct mem_header *) (((unsigned long) ptr) - BODY_OFFSET);  
   
     copySize = size;  
     if (copySize > (unsigned int) memp->length) {  
         copySize = memp->length;  
     }  
     new = Tcl_DbCkalloc(size, file, line);  
     memcpy((VOID *) new, (VOID *) ptr, (size_t) copySize);  
     Tcl_DbCkfree(ptr, file, line);  
     return new;  
 }  
   
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * Tcl_Alloc, et al. --  
  *  
  *      These functions are defined in terms of the debugging versions  
  *      when TCL_MEM_DEBUG is set.  
  *  
  * Results:  
  *      Same as the debug versions.  
  *  
  * Side effects:  
  *      Same as the debug versions.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 #undef Tcl_Alloc  
 #undef Tcl_Free  
 #undef Tcl_Realloc  
   
 char *  
 Tcl_Alloc(size)  
     unsigned int size;  
 {  
     return Tcl_DbCkalloc(size, "unknown", 0);  
 }  
   
 void  
 Tcl_Free(ptr)  
     char *ptr;  
 {  
     Tcl_DbCkfree(ptr, "unknown", 0);  
 }  
   
 char *  
 Tcl_Realloc(ptr, size)  
     char *ptr;  
     unsigned int size;  
 {  
     return Tcl_DbCkrealloc(ptr, size, "unknown", 0);  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * 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  
  *  
  * Results:  
  *     Standard TCL results.  
  *  
  *----------------------------------------------------------------------  
  */  
         /* ARGSUSED */  
 static int  
 MemoryCmd (clientData, interp, argc, argv)  
     ClientData  clientData;  
     Tcl_Interp *interp;  
     int         argc;  
     char      **argv;  
 {  
     char *fileName;  
     Tcl_DString buffer;  
     int result;  
   
     if (argc < 2) {  
         Tcl_AppendResult(interp, "wrong # args: should be \"",  
                 argv[0], " option [args..]\"", (char *) NULL);  
         return TCL_ERROR;  
     }  
   
     if (strcmp(argv[1],"active") == 0) {  
         if (argc != 3) {  
             Tcl_AppendResult(interp, "wrong # args: should be \"",  
                     argv[0], " active file\"", (char *) NULL);  
             return TCL_ERROR;  
         }  
         fileName = Tcl_TranslateFileName(interp, argv[2], &buffer);  
         if (fileName == NULL) {  
             return TCL_ERROR;  
         }  
         result = Tcl_DumpActiveMemory (fileName);  
         Tcl_DStringFree(&buffer);  
         if (result != TCL_OK) {  
             Tcl_AppendResult(interp, "error accessing ", argv[2],  
                     (char *) NULL);  
             return TCL_ERROR;  
         }  
         return TCL_OK;  
     }  
     if (strcmp(argv[1],"break_on_malloc") == 0) {  
         if (argc != 3) {  
             goto argError;  
         }  
         if (Tcl_GetInt(interp, argv[2], &break_on_malloc) != TCL_OK) {  
             return TCL_ERROR;  
         }  
         return TCL_OK;  
     }  
     if (strcmp(argv[1],"info") == 0) {  
         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) {  
         if (argc != 3) {  
             goto bad_suboption;  
         }  
         init_malloced_bodies = (strcmp(argv[2],"on") == 0);  
         return TCL_OK;  
     }  
     if (strcmp(argv[1],"tag") == 0) {  
         if (argc != 3) {  
             Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],  
                     " tag string\"", (char *) NULL);  
             return TCL_ERROR;  
         }  
         if ((curTagPtr != NULL) && (curTagPtr->refCount == 0)) {  
             TclpFree((char *) curTagPtr);  
         }  
         curTagPtr = (MemTag *) TclpAlloc(TAG_SIZE(strlen(argv[2])));  
         curTagPtr->refCount = 0;  
         strcpy(curTagPtr->string, argv[2]);  
         return TCL_OK;  
     }  
     if (strcmp(argv[1],"trace") == 0) {  
         if (argc != 3) {  
             goto bad_suboption;  
         }  
         alloc_tracing = (strcmp(argv[2],"on") == 0);  
         return TCL_OK;  
     }  
   
     if (strcmp(argv[1],"trace_on_at_malloc") == 0) {  
         if (argc != 3) {  
             goto argError;  
         }  
         if (Tcl_GetInt(interp, argv[2], &trace_on_at_malloc) != TCL_OK) {  
             return TCL_ERROR;  
         }  
         return TCL_OK;  
     }  
     if (strcmp(argv[1],"validate") == 0) {  
         if (argc != 3) {  
             goto bad_suboption;  
         }  
         validate_memory = (strcmp(argv[2],"on") == 0);  
         return TCL_OK;  
     }  
   
     Tcl_AppendResult(interp, "bad option \"", argv[1],  
             "\": should be active, break_on_malloc, info, init, ",  
             "tag, trace, trace_on_at_malloc, or validate", (char *) NULL);  
     return TCL_ERROR;  
   
 argError:  
     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],  
             " ", argv[1], " count\"", (char *) NULL);  
     return TCL_ERROR;  
   
 bad_suboption:  
     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],  
             " ", argv[1], " on|off\"", (char *) NULL);  
     return TCL_ERROR;  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * 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.  
  *  
  *----------------------------------------------------------------------  
  */  
 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 */  
   
 /* This is the !TCL_MEM_DEBUG case */  
   
 #undef Tcl_InitMemory  
 #undef Tcl_DumpActiveMemory  
 #undef Tcl_ValidateAllMemory  
   
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * Tcl_Alloc --  
  *     Interface to TclpAlloc when TCL_MEM_DEBUG is disabled.  It does check  
  *     that memory was actually allocated.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 char *  
 Tcl_Alloc (size)  
     unsigned int size;  
 {  
     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 *  
 Tcl_DbCkalloc(size, file, line)  
     unsigned int size;  
     char        *file;  
     int          line;  
 {  
     char *result;  
   
     result = (char *) TclpAlloc(size);  
   
     if ((result == NULL) && size) {  
         fflush(stdout);  
         panic("unable to alloc %d bytes, %s line %d", size, file, line);  
     }  
     return result;  
 }  
   
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * Tcl_Realloc --  
  *     Interface to TclpRealloc when TCL_MEM_DEBUG is disabled.  It does  
  *     check that memory was actually allocated.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 char *  
 Tcl_Realloc(ptr, size)  
     char *ptr;  
     unsigned int size;  
 {  
     char *result;  
   
     result = TclpRealloc(ptr, size);  
   
     if ((result == NULL) && size) {  
         panic("unable to realloc %d bytes", size);  
     }  
     return result;  
 }  
   
 char *  
 Tcl_DbCkrealloc(ptr, size, file, line)  
     char *ptr;  
     unsigned int size;  
     char *file;  
     int line;  
 {  
     char *result;  
   
     result = (char *) TclpRealloc(ptr, size);  
   
     if ((result == NULL) && size) {  
         fflush(stdout);  
         panic("unable to realloc %d bytes, %s line %d", size, file, line);  
     }  
     return result;  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * Tcl_Free --  
  *     Interface to TclpFree when TCL_MEM_DEBUG is disabled.  Done here  
  *     rather in the macro to keep some modules from being compiled with  
  *     TCL_MEM_DEBUG enabled and some with it disabled.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 void  
 Tcl_Free (ptr)  
     char *ptr;  
 {  
     TclpFree(ptr);  
 }  
   
 int  
 Tcl_DbCkfree(ptr, file, line)  
     char *ptr;  
     char *file;  
     int   line;  
 {  
     TclpFree(ptr);  
     return 0;  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * Tcl_InitMemory --  
  *     Dummy initialization for memory command, which is only available  
  *     if TCL_MEM_DEBUG is on.  
  *  
  *----------------------------------------------------------------------  
  */  
         /* ARGSUSED */  
 void  
 Tcl_InitMemory(interp)  
     Tcl_Interp *interp;  
 {  
 }  
   
 int  
 Tcl_DumpActiveMemory(fileName)  
     char *fileName;  
 {  
     return TCL_OK;  
 }  
   
 void  
 Tcl_ValidateAllMemory(file, line)  
     char  *file;  
     int    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  
 }  
   
   
 /* $History: tclckalloc.c $  
  *  
  * *****************  Version 1  *****************  
  * User: Dtashley     Date: 1/02/01    Time: 1:33a  
  * Created in $/IjuScripter, IjuConsole/Source/Tcl Base  
  * Initial check-in.  
  */  
   
 /* End of TCLCKALLOC.C */  
1    /* $Header$ */
2    /*
3     * tclCkalloc.c --
4     *
5     *    Interface to malloc and free that provides support for debugging problems
6     *    involving overwritten, double freeing memory and loss of memory.
7     *
8     * Copyright (c) 1991-1994 The Regents of the University of California.
9     * Copyright (c) 1994-1997 Sun Microsystems, Inc.
10     * Copyright (c) 1998-1999 by Scriptics Corporation.
11     *
12     * See the file "license.terms" for information on usage and redistribution
13     * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
14     *
15     * This code contributed by Karl Lehenbauer and Mark Diekhans
16     *
17     * RCS: @(#) $Id: tclckalloc.c,v 1.1.1.1 2001/06/13 04:34:03 dtashley Exp $
18     */
19    
20    #include "tclInt.h"
21    #include "tclPort.h"
22    
23    #define FALSE   0
24    #define TRUE    1
25    
26    #ifdef TCL_MEM_DEBUG
27    
28    /*
29     * One of the following structures is allocated each time the
30     * "memory tag" command is invoked, to hold the current tag.
31     */
32    
33    typedef struct MemTag {
34        int refCount;               /* Number of mem_headers referencing
35                                     * this tag. */
36        char string[4];             /* Actual size of string will be as
37                                     * large as needed for actual tag.  This
38                                     * must be the last field in the structure. */
39    } MemTag;
40    
41    #define TAG_SIZE(bytesInString) ((unsigned) sizeof(MemTag) + bytesInString - 3)
42    
43    static MemTag *curTagPtr = NULL;/* Tag to use in all future mem_headers
44                                     * (set by "memory tag" command). */
45    
46    /*
47     * One of the following structures is allocated just before each
48     * dynamically allocated chunk of memory, both to record information
49     * about the chunk and to help detect chunk under-runs.
50     */
51    
52    #define LOW_GUARD_SIZE (8 + (32 - (sizeof(long) + sizeof(int)))%8)
53    struct mem_header {
54        struct mem_header *flink;
55        struct mem_header *blink;
56        MemTag *tagPtr;             /* Tag from "memory tag" command;  may be
57                                     * NULL. */
58        char *file;
59        long length;
60        int line;
61        unsigned char low_guard[LOW_GUARD_SIZE];
62                                    /* Aligns body on 8-byte boundary, plus
63                                     * provides at least 8 additional guard bytes
64                                     * to detect underruns. */
65        char body[1];               /* First byte of client's space.  Actual
66                                     * size of this field will be larger than
67                                     * one. */
68    };
69    
70    static struct mem_header *allocHead = NULL;  /* List of allocated structures */
71    
72    #define GUARD_VALUE  0141
73    
74    /*
75     * The following macro determines the amount of guard space *above* each
76     * chunk of memory.
77     */
78    
79    #define HIGH_GUARD_SIZE 8
80    
81    /*
82     * The following macro computes the offset of the "body" field within
83     * mem_header.  It is used to get back to the header pointer from the
84     * body pointer that's used by clients.
85     */
86    
87    #define BODY_OFFSET \
88            ((unsigned long) (&((struct mem_header *) 0)->body))
89    
90    static int total_mallocs = 0;
91    static int total_frees = 0;
92    static int current_bytes_malloced = 0;
93    static int maximum_bytes_malloced = 0;
94    static int current_malloc_packets = 0;
95    static int maximum_malloc_packets = 0;
96    static int break_on_malloc = 0;
97    static int trace_on_at_malloc = 0;
98    static int  alloc_tracing = FALSE;
99    static int  init_malloced_bodies = TRUE;
100    #ifdef MEM_VALIDATE
101        static int  validate_memory = TRUE;
102    #else
103        static int  validate_memory = FALSE;
104    #endif
105    
106    /*
107     * The following variable indicates to TclFinalizeMemorySubsystem()
108     * that it should dump out the state of memory before exiting.  If the
109     * value is non-NULL, it gives the name of the file in which to
110     * dump memory usage information.
111     */
112    
113    char *tclMemDumpFileName = NULL;
114    
115    static char dumpFile[100];      /* Records where to dump memory allocation
116                                     * information. */
117    
118    /*
119     * Mutex to serialize allocations.  This is a low-level mutex that must
120     * be explicitly initialized.  This is necessary because the self
121     * initializing mutexes use ckalloc...
122     */
123    static Tcl_Mutex *ckallocMutexPtr;
124    static int ckallocInit = 0;
125    
126    /*
127     * Prototypes for procedures defined in this file:
128     */
129    
130    static int              CheckmemCmd _ANSI_ARGS_((ClientData clientData,
131                                Tcl_Interp *interp, int argc, char *argv[]));
132    static int              MemoryCmd _ANSI_ARGS_((ClientData clientData,
133                                Tcl_Interp *interp, int argc, char **argv));
134    static void             ValidateMemory _ANSI_ARGS_((
135                                struct mem_header *memHeaderP, char *file,
136                                int line, int nukeGuards));
137    
138    /*
139     *----------------------------------------------------------------------
140     *
141     * TclInitDbCkalloc --
142     *      Initialize the locks used by the allocator.
143     *      This is only appropriate to call in a single threaded environment,
144     *      such as during TclInitSubsystems.
145     *
146     *----------------------------------------------------------------------
147     */
148    void
149    TclInitDbCkalloc()
150    {
151        if (!ckallocInit) {
152            ckallocInit = 1;
153            ckallocMutexPtr = Tcl_GetAllocMutex();
154        }
155    }
156    
157    /*
158     *----------------------------------------------------------------------
159     *
160     * TclDumpMemoryInfo --
161     *     Display the global memory management statistics.
162     *
163     *----------------------------------------------------------------------
164     */
165    void
166    TclDumpMemoryInfo(outFile)
167        FILE *outFile;
168    {
169        fprintf(outFile,"total mallocs             %10d\n",
170                total_mallocs);
171        fprintf(outFile,"total frees               %10d\n",
172                total_frees);
173        fprintf(outFile,"current packets allocated %10d\n",
174                current_malloc_packets);
175        fprintf(outFile,"current bytes allocated   %10d\n",
176                current_bytes_malloced);
177        fprintf(outFile,"maximum packets allocated %10d\n",
178                maximum_malloc_packets);
179        fprintf(outFile,"maximum bytes allocated   %10d\n",
180                maximum_bytes_malloced);
181    }
182    
183    /*
184     *----------------------------------------------------------------------
185     *
186     * ValidateMemory --
187     *     Procedure to validate allocted memory guard zones.
188     *
189     *----------------------------------------------------------------------
190     */
191    static void
192    ValidateMemory(memHeaderP, file, line, nukeGuards)
193        struct mem_header *memHeaderP;
194        char              *file;
195        int                line;
196        int                nukeGuards;
197    {
198        unsigned char *hiPtr;
199        int   idx;
200        int   guard_failed = FALSE;
201        int byte;
202        
203        for (idx = 0; idx < LOW_GUARD_SIZE; idx++) {
204            byte = *(memHeaderP->low_guard + idx);
205            if (byte != GUARD_VALUE) {
206                guard_failed = TRUE;
207                fflush(stdout);
208                byte &= 0xff;
209                fprintf(stderr, "low guard byte %d is 0x%x  \t%c\n", idx, byte,
210                        (isprint(UCHAR(byte)) ? byte : ' ')); /* INTL: bytes */
211            }
212        }
213        if (guard_failed) {
214            TclDumpMemoryInfo (stderr);
215            fprintf(stderr, "low guard failed at %lx, %s %d\n",
216                     (long unsigned int) memHeaderP->body, file, line);
217            fflush(stderr);  /* In case name pointer is bad. */
218            fprintf(stderr, "%ld bytes allocated at (%s %d)\n", memHeaderP->length,
219                    memHeaderP->file, memHeaderP->line);
220            panic ("Memory validation failure");
221        }
222    
223        hiPtr = (unsigned char *)memHeaderP->body + memHeaderP->length;
224        for (idx = 0; idx < HIGH_GUARD_SIZE; idx++) {
225            byte = *(hiPtr + idx);
226            if (byte != GUARD_VALUE) {
227                guard_failed = TRUE;
228                fflush (stdout);
229                byte &= 0xff;
230                fprintf(stderr, "hi guard byte %d is 0x%x  \t%c\n", idx, byte,
231                        (isprint(UCHAR(byte)) ? byte : ' ')); /* INTL: bytes */
232            }
233        }
234    
235        if (guard_failed) {
236            TclDumpMemoryInfo (stderr);
237            fprintf(stderr, "high guard failed at %lx, %s %d\n",
238                     (long unsigned int) memHeaderP->body, file, line);
239            fflush(stderr);  /* In case name pointer is bad. */
240            fprintf(stderr, "%ld bytes allocated at (%s %d)\n",
241                    memHeaderP->length, memHeaderP->file,
242                    memHeaderP->line);
243            panic("Memory validation failure");
244        }
245    
246        if (nukeGuards) {
247            memset ((char *) memHeaderP->low_guard, 0, LOW_GUARD_SIZE);
248            memset ((char *) hiPtr, 0, HIGH_GUARD_SIZE);
249        }
250    
251    }
252    
253    /*
254     *----------------------------------------------------------------------
255     *
256     * Tcl_ValidateAllMemory --
257     *     Validates guard regions for all allocated memory.
258     *
259     *----------------------------------------------------------------------
260     */
261    void
262    Tcl_ValidateAllMemory (file, line)
263        char  *file;
264        int    line;
265    {
266        struct mem_header *memScanP;
267    
268        if (!ckallocInit) {
269            TclInitDbCkalloc();
270        }
271        Tcl_MutexLock(ckallocMutexPtr);
272        for (memScanP = allocHead; memScanP != NULL; memScanP = memScanP->flink) {
273            ValidateMemory(memScanP, file, line, FALSE);
274        }
275        Tcl_MutexUnlock(ckallocMutexPtr);
276    }
277    
278    /*
279     *----------------------------------------------------------------------
280     *
281     * Tcl_DumpActiveMemory --
282     *     Displays all allocated memory to stderr.
283     *
284     * Results:
285     *     Return TCL_ERROR if an error accessing the file occures, `errno'
286     *     will have the file error number left in it.
287     *----------------------------------------------------------------------
288     */
289    int
290    Tcl_DumpActiveMemory (fileName)
291        char *fileName;
292    {
293        FILE              *fileP;
294        struct mem_header *memScanP;
295        char              *address;
296    
297        if (fileName == NULL) {
298            fileP = stderr;
299        } else {
300            fileP = fopen(fileName, "w");
301            if (fileP == NULL) {
302                return TCL_ERROR;
303            }
304        }
305    
306        Tcl_MutexLock(ckallocMutexPtr);
307        for (memScanP = allocHead; memScanP != NULL; memScanP = memScanP->flink) {
308            address = &memScanP->body [0];
309            fprintf(fileP, "%8lx - %8lx  %7ld @ %s %d %s",
310                    (long unsigned int) address,
311                     (long unsigned int) address + memScanP->length - 1,
312                     memScanP->length, memScanP->file, memScanP->line,
313                     (memScanP->tagPtr == NULL) ? "" : memScanP->tagPtr->string);
314            (void) fputc('\n', fileP);
315        }
316        Tcl_MutexUnlock(ckallocMutexPtr);
317    
318        if (fileP != stderr) {
319            fclose (fileP);
320        }
321        return TCL_OK;
322    }
323    
324    /*
325     *----------------------------------------------------------------------
326     *
327     * Tcl_DbCkalloc - debugging ckalloc
328     *
329     *        Allocate the requested amount of space plus some extra for
330     *        guard bands at both ends of the request, plus a size, panicing
331     *        if there isn't enough space, then write in the guard bands
332     *        and return the address of the space in the middle that the
333     *        user asked for.
334     *
335     *        The second and third arguments are file and line, these contain
336     *        the filename and line number corresponding to the caller.
337     *        These are sent by the ckalloc macro; it uses the preprocessor
338     *        autodefines __FILE__ and __LINE__.
339     *
340     *----------------------------------------------------------------------
341     */
342    char *
343    Tcl_DbCkalloc(size, file, line)
344        unsigned int size;
345        char        *file;
346        int          line;
347    {
348        struct mem_header *result;
349    
350        if (validate_memory)
351            Tcl_ValidateAllMemory (file, line);
352    
353        result = (struct mem_header *) TclpAlloc((unsigned)size +
354                                  sizeof(struct mem_header) + HIGH_GUARD_SIZE);
355        if (result == NULL) {
356            fflush(stdout);
357            TclDumpMemoryInfo(stderr);
358            panic("unable to alloc %d bytes, %s line %d", size, file, line);
359        }
360    
361        /*
362         * Fill in guard zones and size.  Also initialize the contents of
363         * the block with bogus bytes to detect uses of initialized data.
364         * Link into allocated list.
365         */
366        if (init_malloced_bodies) {
367            memset ((VOID *) result, GUARD_VALUE,
368                    size + sizeof(struct mem_header) + HIGH_GUARD_SIZE);
369        } else {
370            memset ((char *) result->low_guard, GUARD_VALUE, LOW_GUARD_SIZE);
371            memset (result->body + size, GUARD_VALUE, HIGH_GUARD_SIZE);
372        }
373        if (!ckallocInit) {
374            TclInitDbCkalloc();
375        }
376        Tcl_MutexLock(ckallocMutexPtr);
377        result->length = size;
378        result->tagPtr = curTagPtr;
379        if (curTagPtr != NULL) {
380            curTagPtr->refCount++;
381        }
382        result->file = file;
383        result->line = line;
384        result->flink = allocHead;
385        result->blink = NULL;
386    
387        if (allocHead != NULL)
388            allocHead->blink = result;
389        allocHead = result;
390    
391        total_mallocs++;
392        if (trace_on_at_malloc && (total_mallocs >= trace_on_at_malloc)) {
393            (void) fflush(stdout);
394            fprintf(stderr, "reached malloc trace enable point (%d)\n",
395                    total_mallocs);
396            fflush(stderr);
397            alloc_tracing = TRUE;
398            trace_on_at_malloc = 0;
399        }
400    
401        if (alloc_tracing)
402            fprintf(stderr,"ckalloc %lx %d %s %d\n",
403                    (long unsigned int) result->body, size, file, line);
404    
405        if (break_on_malloc && (total_mallocs >= break_on_malloc)) {
406            break_on_malloc = 0;
407            (void) fflush(stdout);
408            fprintf(stderr,"reached malloc break limit (%d)\n",
409                    total_mallocs);
410            fprintf(stderr, "program will now enter C debugger\n");
411            (void) fflush(stderr);
412            abort();
413        }
414    
415        current_malloc_packets++;
416        if (current_malloc_packets > maximum_malloc_packets)
417            maximum_malloc_packets = current_malloc_packets;
418        current_bytes_malloced += size;
419        if (current_bytes_malloced > maximum_bytes_malloced)
420            maximum_bytes_malloced = current_bytes_malloced;
421    
422        Tcl_MutexUnlock(ckallocMutexPtr);
423    
424        return result->body;
425    }
426    
427    /*
428     *----------------------------------------------------------------------
429     *
430     * Tcl_DbCkfree - debugging ckfree
431     *
432     *        Verify that the low and high guards are intact, and if so
433     *        then free the buffer else panic.
434     *
435     *        The guards are erased after being checked to catch duplicate
436     *        frees.
437     *
438     *        The second and third arguments are file and line, these contain
439     *        the filename and line number corresponding to the caller.
440     *        These are sent by the ckfree macro; it uses the preprocessor
441     *        autodefines __FILE__ and __LINE__.
442     *
443     *----------------------------------------------------------------------
444     */
445    
446    int
447    Tcl_DbCkfree(ptr, file, line)
448        char *ptr;
449        char *file;
450        int   line;
451    {
452        struct mem_header *memp;
453    
454        if (ptr == NULL) {
455            return 0;
456        }
457    
458        /*
459         * The following cast is *very* tricky.  Must convert the pointer
460         * to an integer before doing arithmetic on it, because otherwise
461         * the arithmetic will be done differently (and incorrectly) on
462         * word-addressed machines such as Crays (will subtract only bytes,
463         * even though BODY_OFFSET is in words on these machines).
464         */
465    
466        memp = (struct mem_header *) (((unsigned long) ptr) - BODY_OFFSET);
467    
468        if (alloc_tracing) {
469            fprintf(stderr, "ckfree %lx %ld %s %d\n",
470                    (long unsigned int) memp->body, memp->length, file, line);
471        }
472    
473        if (validate_memory) {
474            Tcl_ValidateAllMemory(file, line);
475        }
476    
477        Tcl_MutexLock(ckallocMutexPtr);
478        ValidateMemory(memp, file, line, TRUE);
479        if (init_malloced_bodies) {
480            memset((VOID *) ptr, GUARD_VALUE, (size_t) memp->length);
481        }
482    
483        total_frees++;
484        current_malloc_packets--;
485        current_bytes_malloced -= memp->length;
486    
487        if (memp->tagPtr != NULL) {
488            memp->tagPtr->refCount--;
489            if ((memp->tagPtr->refCount == 0) && (curTagPtr != memp->tagPtr)) {
490                TclpFree((char *) memp->tagPtr);
491            }
492        }
493    
494        /*
495         * Delink from allocated list
496         */
497        if (memp->flink != NULL)
498            memp->flink->blink = memp->blink;
499        if (memp->blink != NULL)
500            memp->blink->flink = memp->flink;
501        if (allocHead == memp)
502            allocHead = memp->flink;
503        TclpFree((char *) memp);
504        Tcl_MutexUnlock(ckallocMutexPtr);
505    
506        return 0;
507    }
508    
509    /*
510     *--------------------------------------------------------------------
511     *
512     * Tcl_DbCkrealloc - debugging ckrealloc
513     *
514     *      Reallocate a chunk of memory by allocating a new one of the
515     *      right size, copying the old data to the new location, and then
516     *      freeing the old memory space, using all the memory checking
517     *      features of this package.
518     *
519     *--------------------------------------------------------------------
520     */
521    char *
522    Tcl_DbCkrealloc(ptr, size, file, line)
523        char *ptr;
524        unsigned int size;
525        char *file;
526        int line;
527    {
528        char *new;
529        unsigned int copySize;
530        struct mem_header *memp;
531    
532        if (ptr == NULL) {
533            return Tcl_DbCkalloc(size, file, line);
534        }
535    
536        /*
537         * See comment from Tcl_DbCkfree before you change the following
538         * line.
539         */
540    
541        memp = (struct mem_header *) (((unsigned long) ptr) - BODY_OFFSET);
542    
543        copySize = size;
544        if (copySize > (unsigned int) memp->length) {
545            copySize = memp->length;
546        }
547        new = Tcl_DbCkalloc(size, file, line);
548        memcpy((VOID *) new, (VOID *) ptr, (size_t) copySize);
549        Tcl_DbCkfree(ptr, file, line);
550        return new;
551    }
552    
553    
554    /*
555     *----------------------------------------------------------------------
556     *
557     * Tcl_Alloc, et al. --
558     *
559     *      These functions are defined in terms of the debugging versions
560     *      when TCL_MEM_DEBUG is set.
561     *
562     * Results:
563     *      Same as the debug versions.
564     *
565     * Side effects:
566     *      Same as the debug versions.
567     *
568     *----------------------------------------------------------------------
569     */
570    
571    #undef Tcl_Alloc
572    #undef Tcl_Free
573    #undef Tcl_Realloc
574    
575    char *
576    Tcl_Alloc(size)
577        unsigned int size;
578    {
579        return Tcl_DbCkalloc(size, "unknown", 0);
580    }
581    
582    void
583    Tcl_Free(ptr)
584        char *ptr;
585    {
586        Tcl_DbCkfree(ptr, "unknown", 0);
587    }
588    
589    char *
590    Tcl_Realloc(ptr, size)
591        char *ptr;
592        unsigned int size;
593    {
594        return Tcl_DbCkrealloc(ptr, size, "unknown", 0);
595    }
596    
597    /*
598     *----------------------------------------------------------------------
599     *
600     * MemoryCmd --
601     *     Implements the TCL memory command:
602     *       memory info
603     *       memory display
604     *       break_on_malloc count
605     *       trace_on_at_malloc count
606     *       trace on|off
607     *       validate on|off
608     *
609     * Results:
610     *     Standard TCL results.
611     *
612     *----------------------------------------------------------------------
613     */
614            /* ARGSUSED */
615    static int
616    MemoryCmd (clientData, interp, argc, argv)
617        ClientData  clientData;
618        Tcl_Interp *interp;
619        int         argc;
620        char      **argv;
621    {
622        char *fileName;
623        Tcl_DString buffer;
624        int result;
625    
626        if (argc < 2) {
627            Tcl_AppendResult(interp, "wrong # args: should be \"",
628                    argv[0], " option [args..]\"", (char *) NULL);
629            return TCL_ERROR;
630        }
631    
632        if (strcmp(argv[1],"active") == 0) {
633            if (argc != 3) {
634                Tcl_AppendResult(interp, "wrong # args: should be \"",
635                        argv[0], " active file\"", (char *) NULL);
636                return TCL_ERROR;
637            }
638            fileName = Tcl_TranslateFileName(interp, argv[2], &buffer);
639            if (fileName == NULL) {
640                return TCL_ERROR;
641            }
642            result = Tcl_DumpActiveMemory (fileName);
643            Tcl_DStringFree(&buffer);
644            if (result != TCL_OK) {
645                Tcl_AppendResult(interp, "error accessing ", argv[2],
646                        (char *) NULL);
647                return TCL_ERROR;
648            }
649            return TCL_OK;
650        }
651        if (strcmp(argv[1],"break_on_malloc") == 0) {
652            if (argc != 3) {
653                goto argError;
654            }
655            if (Tcl_GetInt(interp, argv[2], &break_on_malloc) != TCL_OK) {
656                return TCL_ERROR;
657            }
658            return TCL_OK;
659        }
660        if (strcmp(argv[1],"info") == 0) {
661            char buffer[400];
662            sprintf(buffer, "%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10d\n",
663                "total mallocs", total_mallocs, "total frees", total_frees,
664                "current packets allocated", current_malloc_packets,
665                "current bytes allocated", current_bytes_malloced,
666                "maximum packets allocated", maximum_malloc_packets,
667                "maximum bytes allocated", maximum_bytes_malloced);
668            Tcl_SetResult(interp, buffer, TCL_VOLATILE);
669            return TCL_OK;
670        }
671        if (strcmp(argv[1],"init") == 0) {
672            if (argc != 3) {
673                goto bad_suboption;
674            }
675            init_malloced_bodies = (strcmp(argv[2],"on") == 0);
676            return TCL_OK;
677        }
678        if (strcmp(argv[1],"tag") == 0) {
679            if (argc != 3) {
680                Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
681                        " tag string\"", (char *) NULL);
682                return TCL_ERROR;
683            }
684            if ((curTagPtr != NULL) && (curTagPtr->refCount == 0)) {
685                TclpFree((char *) curTagPtr);
686            }
687            curTagPtr = (MemTag *) TclpAlloc(TAG_SIZE(strlen(argv[2])));
688            curTagPtr->refCount = 0;
689            strcpy(curTagPtr->string, argv[2]);
690            return TCL_OK;
691        }
692        if (strcmp(argv[1],"trace") == 0) {
693            if (argc != 3) {
694                goto bad_suboption;
695            }
696            alloc_tracing = (strcmp(argv[2],"on") == 0);
697            return TCL_OK;
698        }
699    
700        if (strcmp(argv[1],"trace_on_at_malloc") == 0) {
701            if (argc != 3) {
702                goto argError;
703            }
704            if (Tcl_GetInt(interp, argv[2], &trace_on_at_malloc) != TCL_OK) {
705                return TCL_ERROR;
706            }
707            return TCL_OK;
708        }
709        if (strcmp(argv[1],"validate") == 0) {
710            if (argc != 3) {
711                goto bad_suboption;
712            }
713            validate_memory = (strcmp(argv[2],"on") == 0);
714            return TCL_OK;
715        }
716    
717        Tcl_AppendResult(interp, "bad option \"", argv[1],
718                "\": should be active, break_on_malloc, info, init, ",
719                "tag, trace, trace_on_at_malloc, or validate", (char *) NULL);
720        return TCL_ERROR;
721    
722    argError:
723        Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
724                " ", argv[1], " count\"", (char *) NULL);
725        return TCL_ERROR;
726    
727    bad_suboption:
728        Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
729                " ", argv[1], " on|off\"", (char *) NULL);
730        return TCL_ERROR;
731    }
732    
733    /*
734     *----------------------------------------------------------------------
735     *
736     * CheckmemCmd --
737     *
738     *      This is the command procedure for the "checkmem" command, which
739     *      causes the application to exit after printing information about
740     *      memory usage to the file passed to this command as its first
741     *      argument.
742     *
743     * Results:
744     *      Returns a standard Tcl completion code.
745     *
746     * Side effects:
747     *      None.
748     *
749     *----------------------------------------------------------------------
750     */
751    
752    static int
753    CheckmemCmd(clientData, interp, argc, argv)
754        ClientData clientData;              /* Not used. */
755        Tcl_Interp *interp;                 /* Interpreter for evaluation. */
756        int argc;                           /* Number of arguments. */
757        char *argv[];                       /* String values of arguments. */
758    {
759        if (argc != 2) {
760            Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
761                    " fileName\"", (char *) NULL);
762            return TCL_ERROR;
763        }
764        tclMemDumpFileName = dumpFile;
765        strcpy(tclMemDumpFileName, argv[1]);
766        return TCL_OK;
767    }
768    
769    /*
770     *----------------------------------------------------------------------
771     *
772     * Tcl_InitMemory --
773     *     Initialize the memory command.
774     *
775     *----------------------------------------------------------------------
776     */
777    void
778    Tcl_InitMemory(interp)
779        Tcl_Interp *interp;
780    {
781        TclInitDbCkalloc();
782        Tcl_CreateCommand (interp, "memory", MemoryCmd, (ClientData) NULL,
783                (Tcl_CmdDeleteProc *) NULL);
784        Tcl_CreateCommand(interp, "checkmem", CheckmemCmd, (ClientData) 0,
785                (Tcl_CmdDeleteProc *) NULL);
786    }
787    
788    
789    #else   /* TCL_MEM_DEBUG */
790    
791    /* This is the !TCL_MEM_DEBUG case */
792    
793    #undef Tcl_InitMemory
794    #undef Tcl_DumpActiveMemory
795    #undef Tcl_ValidateAllMemory
796    
797    
798    /*
799     *----------------------------------------------------------------------
800     *
801     * Tcl_Alloc --
802     *     Interface to TclpAlloc when TCL_MEM_DEBUG is disabled.  It does check
803     *     that memory was actually allocated.
804     *
805     *----------------------------------------------------------------------
806     */
807    
808    char *
809    Tcl_Alloc (size)
810        unsigned int size;
811    {
812        char *result;
813    
814        result = TclpAlloc(size);
815        /*
816         * Most systems will not alloc(0), instead bumping it to one so
817         * that NULL isn't returned.  Some systems (AIX, Tru64) will alloc(0)
818         * by returning NULL, so we have to check that the NULL we get is
819         * not in response to alloc(0).
820         *
821         * The ANSI spec actually says that systems either return NULL *or*
822         * a special pointer on failure, but we only check for NULL
823         */
824        if ((result == NULL) && size) {
825            panic("unable to alloc %d bytes", size);
826        }
827        return result;
828    }
829    
830    char *
831    Tcl_DbCkalloc(size, file, line)
832        unsigned int size;
833        char        *file;
834        int          line;
835    {
836        char *result;
837    
838        result = (char *) TclpAlloc(size);
839    
840        if ((result == NULL) && size) {
841            fflush(stdout);
842            panic("unable to alloc %d bytes, %s line %d", size, file, line);
843        }
844        return result;
845    }
846    
847    
848    /*
849     *----------------------------------------------------------------------
850     *
851     * Tcl_Realloc --
852     *     Interface to TclpRealloc when TCL_MEM_DEBUG is disabled.  It does
853     *     check that memory was actually allocated.
854     *
855     *----------------------------------------------------------------------
856     */
857    
858    char *
859    Tcl_Realloc(ptr, size)
860        char *ptr;
861        unsigned int size;
862    {
863        char *result;
864    
865        result = TclpRealloc(ptr, size);
866    
867        if ((result == NULL) && size) {
868            panic("unable to realloc %d bytes", size);
869        }
870        return result;
871    }
872    
873    char *
874    Tcl_DbCkrealloc(ptr, size, file, line)
875        char *ptr;
876        unsigned int size;
877        char *file;
878        int line;
879    {
880        char *result;
881    
882        result = (char *) TclpRealloc(ptr, size);
883    
884        if ((result == NULL) && size) {
885            fflush(stdout);
886            panic("unable to realloc %d bytes, %s line %d", size, file, line);
887        }
888        return result;
889    }
890    
891    /*
892     *----------------------------------------------------------------------
893     *
894     * Tcl_Free --
895     *     Interface to TclpFree when TCL_MEM_DEBUG is disabled.  Done here
896     *     rather in the macro to keep some modules from being compiled with
897     *     TCL_MEM_DEBUG enabled and some with it disabled.
898     *
899     *----------------------------------------------------------------------
900     */
901    
902    void
903    Tcl_Free (ptr)
904        char *ptr;
905    {
906        TclpFree(ptr);
907    }
908    
909    int
910    Tcl_DbCkfree(ptr, file, line)
911        char *ptr;
912        char *file;
913        int   line;
914    {
915        TclpFree(ptr);
916        return 0;
917    }
918    
919    /*
920     *----------------------------------------------------------------------
921     *
922     * Tcl_InitMemory --
923     *     Dummy initialization for memory command, which is only available
924     *     if TCL_MEM_DEBUG is on.
925     *
926     *----------------------------------------------------------------------
927     */
928            /* ARGSUSED */
929    void
930    Tcl_InitMemory(interp)
931        Tcl_Interp *interp;
932    {
933    }
934    
935    int
936    Tcl_DumpActiveMemory(fileName)
937        char *fileName;
938    {
939        return TCL_OK;
940    }
941    
942    void
943    Tcl_ValidateAllMemory(file, line)
944        char  *file;
945        int    line;
946    {
947    }
948    
949    void
950    TclDumpMemoryInfo(outFile)
951        FILE *outFile;
952    {
953    }
954    
955    #endif  /* TCL_MEM_DEBUG */
956    
957    /*
958     *---------------------------------------------------------------------------
959     *
960     * TclFinalizeMemorySubsystem --
961     *
962     *      This procedure is called to finalize all the structures that
963     *      are used by the memory allocator on a per-process basis.
964     *
965     * Results:
966     *      None.
967     *
968     * Side effects:
969     *      This subsystem is self-initializing, since memory can be
970     *      allocated before Tcl is formally initialized.  After this call,
971     *      this subsystem has been reset to its initial state and is
972     *      usable again.
973     *
974     *---------------------------------------------------------------------------
975     */
976    
977    void
978    TclFinalizeMemorySubsystem()
979    {
980    #ifdef TCL_MEM_DEBUG
981        Tcl_MutexLock(ckallocMutexPtr);
982        if (tclMemDumpFileName != NULL) {
983            Tcl_DumpActiveMemory(tclMemDumpFileName);
984        }
985        if (curTagPtr != NULL) {
986            TclpFree((char *) curTagPtr);
987        }
988        allocHead = NULL;
989        Tcl_MutexUnlock(ckallocMutexPtr);
990    #endif
991    
992    #if USE_TCLALLOC
993        TclFinalizeAllocSubsystem();
994    #endif
995    }
996    
997    /* End of tclckalloc.c */
Legend:
Removed from v.44  
changed lines
  Added in v.71
dashley@gmail.com
 ViewVC Help
Powered by ViewVC 1.1.25