os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/generic/tclCkalloc.c
1.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
1.2 +++ b/os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/generic/tclCkalloc.c Fri Jun 15 03:10:57 2012 +0200
1.3 @@ -0,0 +1,1258 @@
1.4 +/*
1.5 + * tclCkalloc.c --
1.6 + *
1.7 + * Interface to malloc and free that provides support for debugging problems
1.8 + * involving overwritten, double freeing memory and loss of memory.
1.9 + *
1.10 + * Copyright (c) 1991-1994 The Regents of the University of California.
1.11 + * Copyright (c) 1994-1997 Sun Microsystems, Inc.
1.12 + * Copyright (c) 1998-1999 by Scriptics Corporation.
1.13 + * Portions Copyright (c) 2007-2008 Nokia Corporation and/or its subsidiaries. All rights reserved.
1.14 + *
1.15 + * See the file "license.terms" for information on usage and redistribution
1.16 + * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
1.17 + *
1.18 + * This code contributed by Karl Lehenbauer and Mark Diekhans
1.19 + *
1.20 + * RCS: @(#) $Id: tclCkalloc.c,v 1.19 2003/01/19 07:21:18 hobbs Exp $
1.21 + */
1.22 +
1.23 +#include "tclInt.h"
1.24 +#include "tclPort.h"
1.25 +
1.26 +#define FALSE 0
1.27 +#define TRUE 1
1.28 +
1.29 +#ifdef TCL_MEM_DEBUG
1.30 +
1.31 +/*
1.32 + * One of the following structures is allocated each time the
1.33 + * "memory tag" command is invoked, to hold the current tag.
1.34 + */
1.35 +
1.36 +typedef struct MemTag {
1.37 + int refCount; /* Number of mem_headers referencing
1.38 + * this tag. */
1.39 + char string[4]; /* Actual size of string will be as
1.40 + * large as needed for actual tag. This
1.41 + * must be the last field in the structure. */
1.42 +} MemTag;
1.43 +
1.44 +#define TAG_SIZE(bytesInString) ((unsigned) sizeof(MemTag) + bytesInString - 3)
1.45 +
1.46 +static MemTag *curTagPtr = NULL;/* Tag to use in all future mem_headers
1.47 + * (set by "memory tag" command). */
1.48 +
1.49 +/*
1.50 + * One of the following structures is allocated just before each
1.51 + * dynamically allocated chunk of memory, both to record information
1.52 + * about the chunk and to help detect chunk under-runs.
1.53 + */
1.54 +
1.55 +#define LOW_GUARD_SIZE (8 + (32 - (sizeof(long) + sizeof(int)))%8)
1.56 +struct mem_header {
1.57 + struct mem_header *flink;
1.58 + struct mem_header *blink;
1.59 + MemTag *tagPtr; /* Tag from "memory tag" command; may be
1.60 + * NULL. */
1.61 + CONST char *file;
1.62 + long length;
1.63 + int line;
1.64 + unsigned char low_guard[LOW_GUARD_SIZE];
1.65 + /* Aligns body on 8-byte boundary, plus
1.66 + * provides at least 8 additional guard bytes
1.67 + * to detect underruns. */
1.68 + char body[1]; /* First byte of client's space. Actual
1.69 + * size of this field will be larger than
1.70 + * one. */
1.71 +};
1.72 +
1.73 +#if !defined(__SYMBIAN32__) || !defined(__WINSCW__)
1.74 +static struct mem_header *allocHead = NULL; /* List of allocated structures */
1.75 +#else
1.76 +typedef struct mem_header (*memHeaderPtr);
1.77 +#define allocHead (*(memHeaderPtr*)get_allocHead())
1.78 +#endif
1.79 +
1.80 +#define GUARD_VALUE 0141
1.81 +
1.82 +/*
1.83 + * The following macro determines the amount of guard space *above* each
1.84 + * chunk of memory.
1.85 + */
1.86 +
1.87 +#define HIGH_GUARD_SIZE 8
1.88 +
1.89 +/*
1.90 + * The following macro computes the offset of the "body" field within
1.91 + * mem_header. It is used to get back to the header pointer from the
1.92 + * body pointer that's used by clients.
1.93 + */
1.94 +
1.95 +#define BODY_OFFSET \
1.96 + ((unsigned long) (&((struct mem_header *) 0)->body))
1.97 +
1.98 +static int total_mallocs = 0;
1.99 +static int total_frees = 0;
1.100 +static int current_bytes_malloced = 0;
1.101 +static int maximum_bytes_malloced = 0;
1.102 +static int current_malloc_packets = 0;
1.103 +static int maximum_malloc_packets = 0;
1.104 +static int break_on_malloc = 0;
1.105 +static int trace_on_at_malloc = 0;
1.106 +static int alloc_tracing = FALSE;
1.107 +static int init_malloced_bodies = TRUE;
1.108 +#ifdef MEM_VALIDATE
1.109 + static int validate_memory = TRUE;
1.110 +#else
1.111 + static int validate_memory = FALSE;
1.112 +#endif
1.113 +
1.114 +/*
1.115 + * The following variable indicates to TclFinalizeMemorySubsystem()
1.116 + * that it should dump out the state of memory before exiting. If the
1.117 + * value is non-NULL, it gives the name of the file in which to
1.118 + * dump memory usage information.
1.119 + */
1.120 +
1.121 +char *tclMemDumpFileName = NULL;
1.122 +
1.123 +static char *onExitMemDumpFileName = NULL;
1.124 +static char dumpFile[100]; /* Records where to dump memory allocation
1.125 + * information. */
1.126 +
1.127 +/*
1.128 + * Mutex to serialize allocations. This is a low-level mutex that must
1.129 + * be explicitly initialized. This is necessary because the self
1.130 + * initializing mutexes use ckalloc...
1.131 + */
1.132 +static Tcl_Mutex *ckallocMutexPtr;
1.133 +static int ckallocInit = 0;
1.134 +
1.135 +/*
1.136 + * Prototypes for procedures defined in this file:
1.137 + */
1.138 +
1.139 +static int CheckmemCmd _ANSI_ARGS_((ClientData clientData,
1.140 + Tcl_Interp *interp, int argc, CONST char *argv[]));
1.141 +static int MemoryCmd _ANSI_ARGS_((ClientData clientData,
1.142 + Tcl_Interp *interp, int argc, CONST char **argv));
1.143 +static void ValidateMemory _ANSI_ARGS_((
1.144 + struct mem_header *memHeaderP, CONST char *file,
1.145 + int line, int nukeGuards));
1.146 +
1.147 +/*
1.148 + *----------------------------------------------------------------------
1.149 + *
1.150 + * TclInitDbCkalloc --
1.151 + * Initialize the locks used by the allocator.
1.152 + * This is only appropriate to call in a single threaded environment,
1.153 + * such as during TclInitSubsystems.
1.154 + *
1.155 + *----------------------------------------------------------------------
1.156 + */
1.157 +void
1.158 +TclInitDbCkalloc()
1.159 +{
1.160 + if (!ckallocInit) {
1.161 + ckallocInit = 1;
1.162 + ckallocMutexPtr = Tcl_GetAllocMutex();
1.163 + }
1.164 +}
1.165 +
1.166 +/*
1.167 + *----------------------------------------------------------------------
1.168 + *
1.169 + * TclDumpMemoryInfo --
1.170 + * Display the global memory management statistics.
1.171 + *
1.172 + *----------------------------------------------------------------------
1.173 + */
1.174 +void
1.175 +TclDumpMemoryInfo(outFile)
1.176 + FILE *outFile;
1.177 +{
1.178 + fprintf(outFile,"total mallocs %10d\n",
1.179 + total_mallocs);
1.180 + fprintf(outFile,"total frees %10d\n",
1.181 + total_frees);
1.182 + fprintf(outFile,"current packets allocated %10d\n",
1.183 + current_malloc_packets);
1.184 + fprintf(outFile,"current bytes allocated %10d\n",
1.185 + current_bytes_malloced);
1.186 + fprintf(outFile,"maximum packets allocated %10d\n",
1.187 + maximum_malloc_packets);
1.188 + fprintf(outFile,"maximum bytes allocated %10d\n",
1.189 + maximum_bytes_malloced);
1.190 +}
1.191 +
1.192 +
1.193 +/*
1.194 + *----------------------------------------------------------------------
1.195 + *
1.196 + * ValidateMemory --
1.197 + *
1.198 + * Validate memory guard zones for a particular chunk of allocated
1.199 + * memory.
1.200 + *
1.201 + * Results:
1.202 + * None.
1.203 + *
1.204 + * Side effects:
1.205 + * Prints validation information about the allocated memory to stderr.
1.206 + *
1.207 + *----------------------------------------------------------------------
1.208 + */
1.209 +
1.210 +static void
1.211 +ValidateMemory(memHeaderP, file, line, nukeGuards)
1.212 + struct mem_header *memHeaderP; /* Memory chunk to validate */
1.213 + CONST char *file; /* File containing the call to
1.214 + * Tcl_ValidateAllMemory */
1.215 + int line; /* Line number of call to
1.216 + * Tcl_ValidateAllMemory */
1.217 + int nukeGuards; /* If non-zero, indicates that the
1.218 + * memory guards are to be reset to 0
1.219 + * after they have been printed */
1.220 +{
1.221 + unsigned char *hiPtr;
1.222 + int idx;
1.223 + int guard_failed = FALSE;
1.224 + int byte;
1.225 +
1.226 + for (idx = 0; idx < LOW_GUARD_SIZE; idx++) {
1.227 + byte = *(memHeaderP->low_guard + idx);
1.228 + if (byte != GUARD_VALUE) {
1.229 + guard_failed = TRUE;
1.230 + fflush(stdout);
1.231 + byte &= 0xff;
1.232 + fprintf(stderr, "low guard byte %d is 0x%x \t%c\n", idx, byte,
1.233 + (isprint(UCHAR(byte)) ? byte : ' ')); /* INTL: bytes */
1.234 + }
1.235 + }
1.236 + if (guard_failed) {
1.237 + TclDumpMemoryInfo (stderr);
1.238 + fprintf(stderr, "low guard failed at %lx, %s %d\n",
1.239 + (long unsigned int) memHeaderP->body, file, line);
1.240 + fflush(stderr); /* In case name pointer is bad. */
1.241 + fprintf(stderr, "%ld bytes allocated at (%s %d)\n", memHeaderP->length,
1.242 + memHeaderP->file, memHeaderP->line);
1.243 + panic ("Memory validation failure");
1.244 + }
1.245 +
1.246 + hiPtr = (unsigned char *)memHeaderP->body + memHeaderP->length;
1.247 + for (idx = 0; idx < HIGH_GUARD_SIZE; idx++) {
1.248 + byte = *(hiPtr + idx);
1.249 + if (byte != GUARD_VALUE) {
1.250 + guard_failed = TRUE;
1.251 + fflush (stdout);
1.252 + byte &= 0xff;
1.253 + fprintf(stderr, "hi guard byte %d is 0x%x \t%c\n", idx, byte,
1.254 + (isprint(UCHAR(byte)) ? byte : ' ')); /* INTL: bytes */
1.255 + }
1.256 + }
1.257 +
1.258 + if (guard_failed) {
1.259 + TclDumpMemoryInfo (stderr);
1.260 + fprintf(stderr, "high guard failed at %lx, %s %d\n",
1.261 + (long unsigned int) memHeaderP->body, file, line);
1.262 + fflush(stderr); /* In case name pointer is bad. */
1.263 + fprintf(stderr, "%ld bytes allocated at (%s %d)\n",
1.264 + memHeaderP->length, memHeaderP->file,
1.265 + memHeaderP->line);
1.266 + panic("Memory validation failure");
1.267 + }
1.268 +
1.269 + if (nukeGuards) {
1.270 + memset ((char *) memHeaderP->low_guard, 0, LOW_GUARD_SIZE);
1.271 + memset ((char *) hiPtr, 0, HIGH_GUARD_SIZE);
1.272 + }
1.273 +
1.274 +}
1.275 +
1.276 +/*
1.277 + *----------------------------------------------------------------------
1.278 + *
1.279 + * Tcl_ValidateAllMemory --
1.280 + *
1.281 + * Validate memory guard regions for all allocated memory.
1.282 + *
1.283 + * Results:
1.284 + * None.
1.285 + *
1.286 + * Side effects:
1.287 + * Displays memory validation information to stderr.
1.288 + *
1.289 + *----------------------------------------------------------------------
1.290 + */
1.291 +EXPORT_C void
1.292 +Tcl_ValidateAllMemory (file, line)
1.293 + CONST char *file; /* File from which Tcl_ValidateAllMemory was called */
1.294 + int line; /* Line number of call to Tcl_ValidateAllMemory */
1.295 +{
1.296 + struct mem_header *memScanP;
1.297 +
1.298 + if (!ckallocInit) {
1.299 + TclInitDbCkalloc();
1.300 + }
1.301 + Tcl_MutexLock(ckallocMutexPtr);
1.302 + for (memScanP = allocHead; memScanP != NULL; memScanP = memScanP->flink) {
1.303 + ValidateMemory(memScanP, file, line, FALSE);
1.304 + }
1.305 + Tcl_MutexUnlock(ckallocMutexPtr);
1.306 +}
1.307 +
1.308 +/*
1.309 + *----------------------------------------------------------------------
1.310 + *
1.311 + * Tcl_DumpActiveMemory --
1.312 + *
1.313 + * Displays all allocated memory to a file; if no filename is given,
1.314 + * information will be written to stderr.
1.315 + *
1.316 + * Results:
1.317 + * Return TCL_ERROR if an error accessing the file occurs, `errno'
1.318 + * will have the file error number left in it.
1.319 + *----------------------------------------------------------------------
1.320 + */
1.321 +EXPORT_C int
1.322 +Tcl_DumpActiveMemory (fileName)
1.323 + CONST char *fileName; /* Name of the file to write info to */
1.324 +{
1.325 + FILE *fileP;
1.326 + struct mem_header *memScanP;
1.327 + char *address;
1.328 +
1.329 + if (fileName == NULL) {
1.330 + fileP = stderr;
1.331 + } else {
1.332 + fileP = fopen(fileName, "w");
1.333 + if (fileP == NULL) {
1.334 + return TCL_ERROR;
1.335 + }
1.336 + }
1.337 +
1.338 + Tcl_MutexLock(ckallocMutexPtr);
1.339 + for (memScanP = allocHead; memScanP != NULL; memScanP = memScanP->flink) {
1.340 + address = &memScanP->body [0];
1.341 + fprintf(fileP, "%8lx - %8lx %7ld @ %s %d %s",
1.342 + (long unsigned int) address,
1.343 + (long unsigned int) address + memScanP->length - 1,
1.344 + memScanP->length, memScanP->file, memScanP->line,
1.345 + (memScanP->tagPtr == NULL) ? "" : memScanP->tagPtr->string);
1.346 + (void) fputc('\n', fileP);
1.347 + }
1.348 + Tcl_MutexUnlock(ckallocMutexPtr);
1.349 +
1.350 + if (fileP != stderr) {
1.351 + fclose (fileP);
1.352 + }
1.353 + return TCL_OK;
1.354 +}
1.355 +
1.356 +/*
1.357 + *----------------------------------------------------------------------
1.358 + *
1.359 + * Tcl_DbCkalloc - debugging ckalloc
1.360 + *
1.361 + * Allocate the requested amount of space plus some extra for
1.362 + * guard bands at both ends of the request, plus a size, panicing
1.363 + * if there isn't enough space, then write in the guard bands
1.364 + * and return the address of the space in the middle that the
1.365 + * user asked for.
1.366 + *
1.367 + * The second and third arguments are file and line, these contain
1.368 + * the filename and line number corresponding to the caller.
1.369 + * These are sent by the ckalloc macro; it uses the preprocessor
1.370 + * autodefines __FILE__ and __LINE__.
1.371 + *
1.372 + *----------------------------------------------------------------------
1.373 + */
1.374 +EXPORT_C char *
1.375 +Tcl_DbCkalloc(size, file, line)
1.376 + unsigned int size;
1.377 + CONST char *file;
1.378 + int line;
1.379 +{
1.380 + struct mem_header *result;
1.381 +
1.382 + if (validate_memory)
1.383 + Tcl_ValidateAllMemory (file, line);
1.384 +
1.385 + result = (struct mem_header *) TclpAlloc((unsigned)size +
1.386 + sizeof(struct mem_header) + HIGH_GUARD_SIZE);
1.387 + if (result == NULL) {
1.388 + fflush(stdout);
1.389 + TclDumpMemoryInfo(stderr);
1.390 + panic("unable to alloc %u bytes, %s line %d", size, file, line);
1.391 + }
1.392 +
1.393 + /*
1.394 + * Fill in guard zones and size. Also initialize the contents of
1.395 + * the block with bogus bytes to detect uses of initialized data.
1.396 + * Link into allocated list.
1.397 + */
1.398 + if (init_malloced_bodies) {
1.399 + memset ((VOID *) result, GUARD_VALUE,
1.400 + size + sizeof(struct mem_header) + HIGH_GUARD_SIZE);
1.401 + } else {
1.402 + memset ((char *) result->low_guard, GUARD_VALUE, LOW_GUARD_SIZE);
1.403 + memset (result->body + size, GUARD_VALUE, HIGH_GUARD_SIZE);
1.404 + }
1.405 + if (!ckallocInit) {
1.406 + TclInitDbCkalloc();
1.407 + }
1.408 + Tcl_MutexLock(ckallocMutexPtr);
1.409 + result->length = size;
1.410 + result->tagPtr = curTagPtr;
1.411 + if (curTagPtr != NULL) {
1.412 + curTagPtr->refCount++;
1.413 + }
1.414 + result->file = file;
1.415 + result->line = line;
1.416 + result->flink = allocHead;
1.417 + result->blink = NULL;
1.418 +
1.419 + if (allocHead != NULL)
1.420 + allocHead->blink = result;
1.421 + allocHead = result;
1.422 +
1.423 + total_mallocs++;
1.424 + if (trace_on_at_malloc && (total_mallocs >= trace_on_at_malloc)) {
1.425 + (void) fflush(stdout);
1.426 + fprintf(stderr, "reached malloc trace enable point (%d)\n",
1.427 + total_mallocs);
1.428 + fflush(stderr);
1.429 + alloc_tracing = TRUE;
1.430 + trace_on_at_malloc = 0;
1.431 + }
1.432 +
1.433 + if (alloc_tracing)
1.434 + fprintf(stderr,"ckalloc %lx %u %s %d\n",
1.435 + (long unsigned int) result->body, size, file, line);
1.436 +
1.437 + if (break_on_malloc && (total_mallocs >= break_on_malloc)) {
1.438 + break_on_malloc = 0;
1.439 + (void) fflush(stdout);
1.440 + fprintf(stderr,"reached malloc break limit (%d)\n",
1.441 + total_mallocs);
1.442 + fprintf(stderr, "program will now enter C debugger\n");
1.443 + (void) fflush(stderr);
1.444 + abort();
1.445 + }
1.446 +
1.447 + current_malloc_packets++;
1.448 + if (current_malloc_packets > maximum_malloc_packets)
1.449 + maximum_malloc_packets = current_malloc_packets;
1.450 + current_bytes_malloced += size;
1.451 + if (current_bytes_malloced > maximum_bytes_malloced)
1.452 + maximum_bytes_malloced = current_bytes_malloced;
1.453 +
1.454 + Tcl_MutexUnlock(ckallocMutexPtr);
1.455 +
1.456 + return result->body;
1.457 +}
1.458 +
1.459 +char *
1.460 +Tcl_AttemptDbCkalloc(size, file, line)
1.461 + unsigned int size;
1.462 + CONST char *file;
1.463 + int line;
1.464 +{
1.465 + struct mem_header *result;
1.466 +
1.467 + if (validate_memory)
1.468 + Tcl_ValidateAllMemory (file, line);
1.469 +
1.470 + result = (struct mem_header *) TclpAlloc((unsigned)size +
1.471 + sizeof(struct mem_header) + HIGH_GUARD_SIZE);
1.472 + if (result == NULL) {
1.473 + fflush(stdout);
1.474 + TclDumpMemoryInfo(stderr);
1.475 + return NULL;
1.476 + }
1.477 +
1.478 + /*
1.479 + * Fill in guard zones and size. Also initialize the contents of
1.480 + * the block with bogus bytes to detect uses of initialized data.
1.481 + * Link into allocated list.
1.482 + */
1.483 + if (init_malloced_bodies) {
1.484 + memset ((VOID *) result, GUARD_VALUE,
1.485 + size + sizeof(struct mem_header) + HIGH_GUARD_SIZE);
1.486 + } else {
1.487 + memset ((char *) result->low_guard, GUARD_VALUE, LOW_GUARD_SIZE);
1.488 + memset (result->body + size, GUARD_VALUE, HIGH_GUARD_SIZE);
1.489 + }
1.490 + if (!ckallocInit) {
1.491 + TclInitDbCkalloc();
1.492 + }
1.493 + Tcl_MutexLock(ckallocMutexPtr);
1.494 + result->length = size;
1.495 + result->tagPtr = curTagPtr;
1.496 + if (curTagPtr != NULL) {
1.497 + curTagPtr->refCount++;
1.498 + }
1.499 + result->file = file;
1.500 + result->line = line;
1.501 + result->flink = allocHead;
1.502 + result->blink = NULL;
1.503 +
1.504 + if (allocHead != NULL)
1.505 + allocHead->blink = result;
1.506 + allocHead = result;
1.507 +
1.508 + total_mallocs++;
1.509 + if (trace_on_at_malloc && (total_mallocs >= trace_on_at_malloc)) {
1.510 + (void) fflush(stdout);
1.511 + fprintf(stderr, "reached malloc trace enable point (%d)\n",
1.512 + total_mallocs);
1.513 + fflush(stderr);
1.514 + alloc_tracing = TRUE;
1.515 + trace_on_at_malloc = 0;
1.516 + }
1.517 +
1.518 + if (alloc_tracing)
1.519 + fprintf(stderr,"ckalloc %lx %u %s %d\n",
1.520 + (long unsigned int) result->body, size, file, line);
1.521 +
1.522 + if (break_on_malloc && (total_mallocs >= break_on_malloc)) {
1.523 + break_on_malloc = 0;
1.524 + (void) fflush(stdout);
1.525 + fprintf(stderr,"reached malloc break limit (%d)\n",
1.526 + total_mallocs);
1.527 + fprintf(stderr, "program will now enter C debugger\n");
1.528 + (void) fflush(stderr);
1.529 + abort();
1.530 + }
1.531 +
1.532 + current_malloc_packets++;
1.533 + if (current_malloc_packets > maximum_malloc_packets)
1.534 + maximum_malloc_packets = current_malloc_packets;
1.535 + current_bytes_malloced += size;
1.536 + if (current_bytes_malloced > maximum_bytes_malloced)
1.537 + maximum_bytes_malloced = current_bytes_malloced;
1.538 +
1.539 + Tcl_MutexUnlock(ckallocMutexPtr);
1.540 +
1.541 + return result->body;
1.542 +}
1.543 +
1.544 +
1.545 +/*
1.546 + *----------------------------------------------------------------------
1.547 + *
1.548 + * Tcl_DbCkfree - debugging ckfree
1.549 + *
1.550 + * Verify that the low and high guards are intact, and if so
1.551 + * then free the buffer else panic.
1.552 + *
1.553 + * The guards are erased after being checked to catch duplicate
1.554 + * frees.
1.555 + *
1.556 + * The second and third arguments are file and line, these contain
1.557 + * the filename and line number corresponding to the caller.
1.558 + * These are sent by the ckfree macro; it uses the preprocessor
1.559 + * autodefines __FILE__ and __LINE__.
1.560 + *
1.561 + *----------------------------------------------------------------------
1.562 + */
1.563 +
1.564 +EXPORT_C int
1.565 +Tcl_DbCkfree(ptr, file, line)
1.566 + char *ptr;
1.567 + CONST char *file;
1.568 + int line;
1.569 +{
1.570 + struct mem_header *memp;
1.571 +
1.572 + if (ptr == NULL) {
1.573 + return 0;
1.574 + }
1.575 +
1.576 + /*
1.577 + * The following cast is *very* tricky. Must convert the pointer
1.578 + * to an integer before doing arithmetic on it, because otherwise
1.579 + * the arithmetic will be done differently (and incorrectly) on
1.580 + * word-addressed machines such as Crays (will subtract only bytes,
1.581 + * even though BODY_OFFSET is in words on these machines).
1.582 + */
1.583 +
1.584 + memp = (struct mem_header *) (((unsigned long) ptr) - BODY_OFFSET);
1.585 +
1.586 + if (alloc_tracing) {
1.587 + fprintf(stderr, "ckfree %lx %ld %s %d\n",
1.588 + (long unsigned int) memp->body, memp->length, file, line);
1.589 + }
1.590 +
1.591 + if (validate_memory) {
1.592 + Tcl_ValidateAllMemory(file, line);
1.593 + }
1.594 +
1.595 + Tcl_MutexLock(ckallocMutexPtr);
1.596 + ValidateMemory(memp, file, line, TRUE);
1.597 + if (init_malloced_bodies) {
1.598 + memset((VOID *) ptr, GUARD_VALUE, (size_t) memp->length);
1.599 + }
1.600 +
1.601 + total_frees++;
1.602 + current_malloc_packets--;
1.603 + current_bytes_malloced -= memp->length;
1.604 +
1.605 + if (memp->tagPtr != NULL) {
1.606 + memp->tagPtr->refCount--;
1.607 + if ((memp->tagPtr->refCount == 0) && (curTagPtr != memp->tagPtr)) {
1.608 + TclpFree((char *) memp->tagPtr);
1.609 + }
1.610 + }
1.611 +
1.612 + /*
1.613 + * Delink from allocated list
1.614 + */
1.615 + if (memp->flink != NULL)
1.616 + memp->flink->blink = memp->blink;
1.617 + if (memp->blink != NULL)
1.618 + memp->blink->flink = memp->flink;
1.619 + if (allocHead == memp)
1.620 + allocHead = memp->flink;
1.621 + TclpFree((char *) memp);
1.622 + Tcl_MutexUnlock(ckallocMutexPtr);
1.623 +
1.624 + return 0;
1.625 +}
1.626 +
1.627 +/*
1.628 + *--------------------------------------------------------------------
1.629 + *
1.630 + * Tcl_DbCkrealloc - debugging ckrealloc
1.631 + *
1.632 + * Reallocate a chunk of memory by allocating a new one of the
1.633 + * right size, copying the old data to the new location, and then
1.634 + * freeing the old memory space, using all the memory checking
1.635 + * features of this package.
1.636 + *
1.637 + *--------------------------------------------------------------------
1.638 + */
1.639 +EXPORT_C char *
1.640 +Tcl_DbCkrealloc(ptr, size, file, line)
1.641 + char *ptr;
1.642 + unsigned int size;
1.643 + CONST char *file;
1.644 + int line;
1.645 +{
1.646 + char *new;
1.647 + unsigned int copySize;
1.648 + struct mem_header *memp;
1.649 +
1.650 + if (ptr == NULL) {
1.651 + return Tcl_DbCkalloc(size, file, line);
1.652 + }
1.653 +
1.654 + /*
1.655 + * See comment from Tcl_DbCkfree before you change the following
1.656 + * line.
1.657 + */
1.658 +
1.659 + memp = (struct mem_header *) (((unsigned long) ptr) - BODY_OFFSET);
1.660 +
1.661 + copySize = size;
1.662 + if (copySize > (unsigned int) memp->length) {
1.663 + copySize = memp->length;
1.664 + }
1.665 + new = Tcl_DbCkalloc(size, file, line);
1.666 + memcpy((VOID *) new, (VOID *) ptr, (size_t) copySize);
1.667 + Tcl_DbCkfree(ptr, file, line);
1.668 + return new;
1.669 +}
1.670 +
1.671 +char *
1.672 +Tcl_AttemptDbCkrealloc(ptr, size, file, line)
1.673 + char *ptr;
1.674 + unsigned int size;
1.675 + CONST char *file;
1.676 + int line;
1.677 +{
1.678 + char *new;
1.679 + unsigned int copySize;
1.680 + struct mem_header *memp;
1.681 +
1.682 + if (ptr == NULL) {
1.683 + return Tcl_AttemptDbCkalloc(size, file, line);
1.684 + }
1.685 +
1.686 + /*
1.687 + * See comment from Tcl_DbCkfree before you change the following
1.688 + * line.
1.689 + */
1.690 +
1.691 + memp = (struct mem_header *) (((unsigned long) ptr) - BODY_OFFSET);
1.692 +
1.693 + copySize = size;
1.694 + if (copySize > (unsigned int) memp->length) {
1.695 + copySize = memp->length;
1.696 + }
1.697 + new = Tcl_AttemptDbCkalloc(size, file, line);
1.698 + if (new == NULL) {
1.699 + return NULL;
1.700 + }
1.701 + memcpy((VOID *) new, (VOID *) ptr, (size_t) copySize);
1.702 + Tcl_DbCkfree(ptr, file, line);
1.703 + return new;
1.704 +}
1.705 +
1.706 +
1.707 +/*
1.708 + *----------------------------------------------------------------------
1.709 + *
1.710 + * Tcl_Alloc, et al. --
1.711 + *
1.712 + * These functions are defined in terms of the debugging versions
1.713 + * when TCL_MEM_DEBUG is set.
1.714 + *
1.715 + * Results:
1.716 + * Same as the debug versions.
1.717 + *
1.718 + * Side effects:
1.719 + * Same as the debug versions.
1.720 + *
1.721 + *----------------------------------------------------------------------
1.722 + */
1.723 +
1.724 +#undef Tcl_Alloc
1.725 +#undef Tcl_Free
1.726 +#undef Tcl_Realloc
1.727 +#undef Tcl_AttemptAlloc
1.728 +#undef Tcl_AttemptRealloc
1.729 +
1.730 +EXPORT_C char *
1.731 +Tcl_Alloc(size)
1.732 + unsigned int size;
1.733 +{
1.734 + return Tcl_DbCkalloc(size, "unknown", 0);
1.735 +}
1.736 +
1.737 +char *
1.738 +Tcl_AttemptAlloc(size)
1.739 + unsigned int size;
1.740 +{
1.741 + return Tcl_AttemptDbCkalloc(size, "unknown", 0);
1.742 +}
1.743 +
1.744 +EXPORT_C void
1.745 +Tcl_Free(ptr)
1.746 + char *ptr;
1.747 +{
1.748 + Tcl_DbCkfree(ptr, "unknown", 0);
1.749 +}
1.750 +
1.751 +EXPORT_C char *
1.752 +Tcl_Realloc(ptr, size)
1.753 + char *ptr;
1.754 + unsigned int size;
1.755 +{
1.756 + return Tcl_DbCkrealloc(ptr, size, "unknown", 0);
1.757 +}
1.758 +char *
1.759 +Tcl_AttemptRealloc(ptr, size)
1.760 + char *ptr;
1.761 + unsigned int size;
1.762 +{
1.763 + return Tcl_AttemptDbCkrealloc(ptr, size, "unknown", 0);
1.764 +}
1.765 +
1.766 +/*
1.767 + *----------------------------------------------------------------------
1.768 + *
1.769 + * MemoryCmd --
1.770 + * Implements the Tcl "memory" command, which provides Tcl-level
1.771 + * control of Tcl memory debugging information.
1.772 + * memory active $file
1.773 + * memory break_on_malloc $count
1.774 + * memory info
1.775 + * memory init on|off
1.776 + * memory onexit $file
1.777 + * memory tag $string
1.778 + * memory trace on|off
1.779 + * memory trace_on_at_malloc $count
1.780 + * memory validate on|off
1.781 + *
1.782 + * Results:
1.783 + * Standard TCL results.
1.784 + *
1.785 + *----------------------------------------------------------------------
1.786 + */
1.787 + /* ARGSUSED */
1.788 +static int
1.789 +MemoryCmd (clientData, interp, argc, argv)
1.790 + ClientData clientData;
1.791 + Tcl_Interp *interp;
1.792 + int argc;
1.793 + CONST char **argv;
1.794 +{
1.795 + CONST char *fileName;
1.796 + Tcl_DString buffer;
1.797 + int result;
1.798 +
1.799 + if (argc < 2) {
1.800 + Tcl_AppendResult(interp, "wrong # args: should be \"",
1.801 + argv[0], " option [args..]\"", (char *) NULL);
1.802 + return TCL_ERROR;
1.803 + }
1.804 +
1.805 + if ((strcmp(argv[1],"active") == 0) || (strcmp(argv[1],"display") == 0)) {
1.806 + if (argc != 3) {
1.807 + Tcl_AppendResult(interp, "wrong # args: should be \"",
1.808 + argv[0], " ", argv[1], " file\"", (char *) NULL);
1.809 + return TCL_ERROR;
1.810 + }
1.811 + fileName = Tcl_TranslateFileName(interp, argv[2], &buffer);
1.812 + if (fileName == NULL) {
1.813 + return TCL_ERROR;
1.814 + }
1.815 + result = Tcl_DumpActiveMemory (fileName);
1.816 + Tcl_DStringFree(&buffer);
1.817 + if (result != TCL_OK) {
1.818 + Tcl_AppendResult(interp, "error accessing ", argv[2],
1.819 + (char *) NULL);
1.820 + return TCL_ERROR;
1.821 + }
1.822 + return TCL_OK;
1.823 + }
1.824 + if (strcmp(argv[1],"break_on_malloc") == 0) {
1.825 + if (argc != 3) {
1.826 + goto argError;
1.827 + }
1.828 + if (Tcl_GetInt(interp, argv[2], &break_on_malloc) != TCL_OK) {
1.829 + return TCL_ERROR;
1.830 + }
1.831 + return TCL_OK;
1.832 + }
1.833 + if (strcmp(argv[1],"info") == 0) {
1.834 + char buf[400];
1.835 + sprintf(buf, "%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10d\n",
1.836 + "total mallocs", total_mallocs, "total frees", total_frees,
1.837 + "current packets allocated", current_malloc_packets,
1.838 + "current bytes allocated", current_bytes_malloced,
1.839 + "maximum packets allocated", maximum_malloc_packets,
1.840 + "maximum bytes allocated", maximum_bytes_malloced);
1.841 + Tcl_SetResult(interp, buf, TCL_VOLATILE);
1.842 + return TCL_OK;
1.843 + }
1.844 + if (strcmp(argv[1],"init") == 0) {
1.845 + if (argc != 3) {
1.846 + goto bad_suboption;
1.847 + }
1.848 + init_malloced_bodies = (strcmp(argv[2],"on") == 0);
1.849 + return TCL_OK;
1.850 + }
1.851 + if (strcmp(argv[1],"onexit") == 0) {
1.852 + if (argc != 3) {
1.853 + Tcl_AppendResult(interp, "wrong # args: should be \"",
1.854 + argv[0], " onexit file\"", (char *) NULL);
1.855 + return TCL_ERROR;
1.856 + }
1.857 + fileName = Tcl_TranslateFileName(interp, argv[2], &buffer);
1.858 + if (fileName == NULL) {
1.859 + return TCL_ERROR;
1.860 + }
1.861 + onExitMemDumpFileName = dumpFile;
1.862 + strcpy(onExitMemDumpFileName,fileName);
1.863 + Tcl_DStringFree(&buffer);
1.864 + return TCL_OK;
1.865 + }
1.866 + if (strcmp(argv[1],"tag") == 0) {
1.867 + if (argc != 3) {
1.868 + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
1.869 + " tag string\"", (char *) NULL);
1.870 + return TCL_ERROR;
1.871 + }
1.872 + if ((curTagPtr != NULL) && (curTagPtr->refCount == 0)) {
1.873 + TclpFree((char *) curTagPtr);
1.874 + }
1.875 + curTagPtr = (MemTag *) TclpAlloc(TAG_SIZE(strlen(argv[2])));
1.876 + curTagPtr->refCount = 0;
1.877 + strcpy(curTagPtr->string, argv[2]);
1.878 + return TCL_OK;
1.879 + }
1.880 + if (strcmp(argv[1],"trace") == 0) {
1.881 + if (argc != 3) {
1.882 + goto bad_suboption;
1.883 + }
1.884 + alloc_tracing = (strcmp(argv[2],"on") == 0);
1.885 + return TCL_OK;
1.886 + }
1.887 +
1.888 + if (strcmp(argv[1],"trace_on_at_malloc") == 0) {
1.889 + if (argc != 3) {
1.890 + goto argError;
1.891 + }
1.892 + if (Tcl_GetInt(interp, argv[2], &trace_on_at_malloc) != TCL_OK) {
1.893 + return TCL_ERROR;
1.894 + }
1.895 + return TCL_OK;
1.896 + }
1.897 + if (strcmp(argv[1],"validate") == 0) {
1.898 + if (argc != 3) {
1.899 + goto bad_suboption;
1.900 + }
1.901 + validate_memory = (strcmp(argv[2],"on") == 0);
1.902 + return TCL_OK;
1.903 + }
1.904 +
1.905 + Tcl_AppendResult(interp, "bad option \"", argv[1],
1.906 + "\": should be active, break_on_malloc, info, init, onexit, ",
1.907 + "tag, trace, trace_on_at_malloc, or validate", (char *) NULL);
1.908 + return TCL_ERROR;
1.909 +
1.910 +argError:
1.911 + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
1.912 + " ", argv[1], " count\"", (char *) NULL);
1.913 + return TCL_ERROR;
1.914 +
1.915 +bad_suboption:
1.916 + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
1.917 + " ", argv[1], " on|off\"", (char *) NULL);
1.918 + return TCL_ERROR;
1.919 +}
1.920 +
1.921 +/*
1.922 + *----------------------------------------------------------------------
1.923 + *
1.924 + * CheckmemCmd --
1.925 + *
1.926 + * This is the command procedure for the "checkmem" command, which
1.927 + * causes the application to exit after printing information about
1.928 + * memory usage to the file passed to this command as its first
1.929 + * argument.
1.930 + *
1.931 + * Results:
1.932 + * Returns a standard Tcl completion code.
1.933 + *
1.934 + * Side effects:
1.935 + * None.
1.936 + *
1.937 + *----------------------------------------------------------------------
1.938 + */
1.939 +
1.940 +static int
1.941 +CheckmemCmd(clientData, interp, argc, argv)
1.942 + ClientData clientData; /* Not used. */
1.943 + Tcl_Interp *interp; /* Interpreter for evaluation. */
1.944 + int argc; /* Number of arguments. */
1.945 + CONST char *argv[]; /* String values of arguments. */
1.946 +{
1.947 + if (argc != 2) {
1.948 + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
1.949 + " fileName\"", (char *) NULL);
1.950 + return TCL_ERROR;
1.951 + }
1.952 + tclMemDumpFileName = dumpFile;
1.953 + strcpy(tclMemDumpFileName, argv[1]);
1.954 + return TCL_OK;
1.955 +}
1.956 +
1.957 +/*
1.958 + *----------------------------------------------------------------------
1.959 + *
1.960 + * Tcl_InitMemory --
1.961 + *
1.962 + * Create the "memory" and "checkmem" commands in the given
1.963 + * interpreter.
1.964 + *
1.965 + * Results:
1.966 + * None.
1.967 + *
1.968 + * Side effects:
1.969 + * New commands are added to the interpreter.
1.970 + *
1.971 + *----------------------------------------------------------------------
1.972 + */
1.973 +
1.974 +EXPORT_C void
1.975 +Tcl_InitMemory(interp)
1.976 + Tcl_Interp *interp; /* Interpreter in which commands should be added */
1.977 +{
1.978 + TclInitDbCkalloc();
1.979 + Tcl_CreateCommand (interp, "memory", MemoryCmd, (ClientData) NULL,
1.980 + (Tcl_CmdDeleteProc *) NULL);
1.981 + Tcl_CreateCommand(interp, "checkmem", CheckmemCmd, (ClientData) 0,
1.982 + (Tcl_CmdDeleteProc *) NULL);
1.983 +}
1.984 +
1.985 +
1.986 +#else /* TCL_MEM_DEBUG */
1.987 +
1.988 +/* This is the !TCL_MEM_DEBUG case */
1.989 +
1.990 +#undef Tcl_InitMemory
1.991 +#undef Tcl_DumpActiveMemory
1.992 +#undef Tcl_ValidateAllMemory
1.993 +
1.994 +
1.995 +/*
1.996 + *----------------------------------------------------------------------
1.997 + *
1.998 + * Tcl_Alloc --
1.999 + * Interface to TclpAlloc when TCL_MEM_DEBUG is disabled. It does check
1.1000 + * that memory was actually allocated.
1.1001 + *
1.1002 + *----------------------------------------------------------------------
1.1003 + */
1.1004 +
1.1005 +EXPORT_C char *
1.1006 +Tcl_Alloc (size)
1.1007 + unsigned int size;
1.1008 +{
1.1009 + char *result;
1.1010 +
1.1011 + result = TclpAlloc(size);
1.1012 + /*
1.1013 + * Most systems will not alloc(0), instead bumping it to one so
1.1014 + * that NULL isn't returned. Some systems (AIX, Tru64) will alloc(0)
1.1015 + * by returning NULL, so we have to check that the NULL we get is
1.1016 + * not in response to alloc(0).
1.1017 + *
1.1018 + * The ANSI spec actually says that systems either return NULL *or*
1.1019 + * a special pointer on failure, but we only check for NULL
1.1020 + */
1.1021 + if ((result == NULL) && size) {
1.1022 + panic("unable to alloc %u bytes", size);
1.1023 + }
1.1024 + return result;
1.1025 +}
1.1026 +
1.1027 +EXPORT_C char *
1.1028 +Tcl_DbCkalloc(size, file, line)
1.1029 + unsigned int size;
1.1030 + CONST char *file;
1.1031 + int line;
1.1032 +{
1.1033 + char *result;
1.1034 +
1.1035 + result = (char *) TclpAlloc(size);
1.1036 +
1.1037 + if ((result == NULL) && size) {
1.1038 + fflush(stdout);
1.1039 + panic("unable to alloc %u bytes, %s line %d", size, file, line);
1.1040 + }
1.1041 + return result;
1.1042 +}
1.1043 +
1.1044 +/*
1.1045 + *----------------------------------------------------------------------
1.1046 + *
1.1047 + * Tcl_AttemptAlloc --
1.1048 + * Interface to TclpAlloc when TCL_MEM_DEBUG is disabled. It does not
1.1049 + * check that memory was actually allocated.
1.1050 + *
1.1051 + *----------------------------------------------------------------------
1.1052 + */
1.1053 +
1.1054 +EXPORT_C char *
1.1055 +Tcl_AttemptAlloc (size)
1.1056 + unsigned int size;
1.1057 +{
1.1058 + char *result;
1.1059 +
1.1060 + result = TclpAlloc(size);
1.1061 + return result;
1.1062 +}
1.1063 +
1.1064 +EXPORT_C char *
1.1065 +Tcl_AttemptDbCkalloc(size, file, line)
1.1066 + unsigned int size;
1.1067 + CONST char *file;
1.1068 + int line;
1.1069 +{
1.1070 + char *result;
1.1071 +
1.1072 + result = (char *) TclpAlloc(size);
1.1073 + return result;
1.1074 +}
1.1075 +
1.1076 +
1.1077 +/*
1.1078 + *----------------------------------------------------------------------
1.1079 + *
1.1080 + * Tcl_Realloc --
1.1081 + * Interface to TclpRealloc when TCL_MEM_DEBUG is disabled. It does
1.1082 + * check that memory was actually allocated.
1.1083 + *
1.1084 + *----------------------------------------------------------------------
1.1085 + */
1.1086 +
1.1087 +EXPORT_C char *
1.1088 +Tcl_Realloc(ptr, size)
1.1089 + char *ptr;
1.1090 + unsigned int size;
1.1091 +{
1.1092 + char *result;
1.1093 +
1.1094 + result = TclpRealloc(ptr, size);
1.1095 +
1.1096 + if ((result == NULL) && size) {
1.1097 + panic("unable to realloc %u bytes", size);
1.1098 + }
1.1099 + return result;
1.1100 +}
1.1101 +
1.1102 +EXPORT_C char *
1.1103 +Tcl_DbCkrealloc(ptr, size, file, line)
1.1104 + char *ptr;
1.1105 + unsigned int size;
1.1106 + CONST char *file;
1.1107 + int line;
1.1108 +{
1.1109 + char *result;
1.1110 +
1.1111 + result = (char *) TclpRealloc(ptr, size);
1.1112 +
1.1113 + if ((result == NULL) && size) {
1.1114 + fflush(stdout);
1.1115 + panic("unable to realloc %u bytes, %s line %d", size, file, line);
1.1116 + }
1.1117 + return result;
1.1118 +}
1.1119 +
1.1120 +/*
1.1121 + *----------------------------------------------------------------------
1.1122 + *
1.1123 + * Tcl_AttemptRealloc --
1.1124 + * Interface to TclpRealloc when TCL_MEM_DEBUG is disabled. It does
1.1125 + * not check that memory was actually allocated.
1.1126 + *
1.1127 + *----------------------------------------------------------------------
1.1128 + */
1.1129 +
1.1130 +EXPORT_C char *
1.1131 +Tcl_AttemptRealloc(ptr, size)
1.1132 + char *ptr;
1.1133 + unsigned int size;
1.1134 +{
1.1135 + char *result;
1.1136 +
1.1137 + result = TclpRealloc(ptr, size);
1.1138 + return result;
1.1139 +}
1.1140 +
1.1141 +EXPORT_C char *
1.1142 +Tcl_AttemptDbCkrealloc(ptr, size, file, line)
1.1143 + char *ptr;
1.1144 + unsigned int size;
1.1145 + CONST char *file;
1.1146 + int line;
1.1147 +{
1.1148 + char *result;
1.1149 +
1.1150 + result = (char *) TclpRealloc(ptr, size);
1.1151 + return result;
1.1152 +}
1.1153 +
1.1154 +/*
1.1155 + *----------------------------------------------------------------------
1.1156 + *
1.1157 + * Tcl_Free --
1.1158 + * Interface to TclpFree when TCL_MEM_DEBUG is disabled. Done here
1.1159 + * rather in the macro to keep some modules from being compiled with
1.1160 + * TCL_MEM_DEBUG enabled and some with it disabled.
1.1161 + *
1.1162 + *----------------------------------------------------------------------
1.1163 + */
1.1164 +
1.1165 +EXPORT_C void
1.1166 +Tcl_Free (ptr)
1.1167 + char *ptr;
1.1168 +{
1.1169 + TclpFree(ptr);
1.1170 +}
1.1171 +
1.1172 +EXPORT_C int
1.1173 +Tcl_DbCkfree(ptr, file, line)
1.1174 + char *ptr;
1.1175 + CONST char *file;
1.1176 + int line;
1.1177 +{
1.1178 + TclpFree(ptr);
1.1179 + return 0;
1.1180 +}
1.1181 +
1.1182 +/*
1.1183 + *----------------------------------------------------------------------
1.1184 + *
1.1185 + * Tcl_InitMemory --
1.1186 + * Dummy initialization for memory command, which is only available
1.1187 + * if TCL_MEM_DEBUG is on.
1.1188 + *
1.1189 + *----------------------------------------------------------------------
1.1190 + */
1.1191 + /* ARGSUSED */
1.1192 +EXPORT_C void
1.1193 +Tcl_InitMemory(interp)
1.1194 + Tcl_Interp *interp;
1.1195 +{
1.1196 +}
1.1197 +
1.1198 +EXPORT_C int
1.1199 +Tcl_DumpActiveMemory(fileName)
1.1200 + CONST char *fileName;
1.1201 +{
1.1202 + return TCL_OK;
1.1203 +}
1.1204 +
1.1205 +EXPORT_C void
1.1206 +Tcl_ValidateAllMemory(file, line)
1.1207 + CONST char *file;
1.1208 + int line;
1.1209 +{
1.1210 +}
1.1211 +
1.1212 +EXPORT_C void
1.1213 +TclDumpMemoryInfo(outFile)
1.1214 + FILE *outFile;
1.1215 +{
1.1216 +}
1.1217 +
1.1218 +#endif /* TCL_MEM_DEBUG */
1.1219 +
1.1220 +/*
1.1221 + *---------------------------------------------------------------------------
1.1222 + *
1.1223 + * TclFinalizeMemorySubsystem --
1.1224 + *
1.1225 + * This procedure is called to finalize all the structures that
1.1226 + * are used by the memory allocator on a per-process basis.
1.1227 + *
1.1228 + * Results:
1.1229 + * None.
1.1230 + *
1.1231 + * Side effects:
1.1232 + * This subsystem is self-initializing, since memory can be
1.1233 + * allocated before Tcl is formally initialized. After this call,
1.1234 + * this subsystem has been reset to its initial state and is
1.1235 + * usable again.
1.1236 + *
1.1237 + *---------------------------------------------------------------------------
1.1238 + */
1.1239 +
1.1240 +void
1.1241 +TclFinalizeMemorySubsystem()
1.1242 +{
1.1243 +#ifdef TCL_MEM_DEBUG
1.1244 + if (tclMemDumpFileName != NULL) {
1.1245 + Tcl_DumpActiveMemory(tclMemDumpFileName);
1.1246 + } else if (onExitMemDumpFileName != NULL) {
1.1247 + Tcl_DumpActiveMemory(onExitMemDumpFileName);
1.1248 + }
1.1249 + Tcl_MutexLock(ckallocMutexPtr);
1.1250 + if (curTagPtr != NULL) {
1.1251 + TclpFree((char *) curTagPtr);
1.1252 + curTagPtr = NULL;
1.1253 + }
1.1254 + allocHead = NULL;
1.1255 + Tcl_MutexUnlock(ckallocMutexPtr);
1.1256 +#endif
1.1257 +
1.1258 +#if USE_TCLALLOC
1.1259 + TclFinalizeAllocSubsystem();
1.1260 +#endif
1.1261 +}