tcl/generic/tclCkalloc.c

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