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

Diff of /projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclckalloc.c

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

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

Legend:
Removed from v.70  
changed lines
  Added in v.71

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25