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: tclCkalloc.c,v 1.19 2003/01/19 07:21:18 hobbs Exp $ 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 32typedef 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 42static 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) 52struct 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 69static 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 89static int total_mallocs = 0; 90static int total_frees = 0; 91static int current_bytes_malloced = 0; 92static int maximum_bytes_malloced = 0; 93static int current_malloc_packets = 0; 94static int maximum_malloc_packets = 0; 95static int break_on_malloc = 0; 96static int trace_on_at_malloc = 0; 97static int alloc_tracing = FALSE; 98static 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 112char *tclMemDumpFileName = NULL; 113 114static char *onExitMemDumpFileName = NULL; 115static 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 */ 123static Tcl_Mutex *ckallocMutexPtr; 124static int ckallocInit = 0; 125 126/* 127 * Prototypes for procedures defined in this file: 128 */ 129 130static int CheckmemCmd _ANSI_ARGS_((ClientData clientData, 131 Tcl_Interp *interp, int argc, CONST char *argv[])); 132static int MemoryCmd _ANSI_ARGS_((ClientData clientData, 133 Tcl_Interp *interp, int argc, CONST char **argv)); 134static void ValidateMemory _ANSI_ARGS_(( 135 struct mem_header *memHeaderP, CONST char *file, 136 int line, int nukeGuards)); 137 138/* 139 *---------------------------------------------------------------------- 140 * 141 * TclInitDbCkalloc -- 142 * Initialize the locks used by the allocator. 143 * This is only appropriate to call in a single threaded environment, 144 * such as during TclInitSubsystems. 145 * 146 *---------------------------------------------------------------------- 147 */ 148void 149TclInitDbCkalloc() 150{ 151 if (!ckallocInit) { 152 ckallocInit = 1; 153 ckallocMutexPtr = Tcl_GetAllocMutex(); 154 } 155} 156 157/* 158 *---------------------------------------------------------------------- 159 * 160 * TclDumpMemoryInfo -- 161 * Display the global memory management statistics. 162 * 163 *---------------------------------------------------------------------- 164 */ 165void 166TclDumpMemoryInfo(outFile) 167 FILE *outFile; 168{ 169 fprintf(outFile,"total mallocs %10d\n", 170 total_mallocs); 171 fprintf(outFile,"total frees %10d\n", 172 total_frees); 173 fprintf(outFile,"current packets allocated %10d\n", 174 current_malloc_packets); 175 fprintf(outFile,"current bytes allocated %10d\n", 176 current_bytes_malloced); 177 fprintf(outFile,"maximum packets allocated %10d\n", 178 maximum_malloc_packets); 179 fprintf(outFile,"maximum bytes allocated %10d\n", 180 maximum_bytes_malloced); 181} 182 183 184/* 185 *---------------------------------------------------------------------- 186 * 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 201static void 202ValidateMemory(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 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 */ 282void 283Tcl_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 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 */ 312int 313Tcl_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 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 */ 365char * 366Tcl_DbCkalloc(size, file, line) 367 unsigned int size; 368 CONST char *file; 369 int line; 370{ 371 struct mem_header *result = NULL; 372 373 if (validate_memory) 374 Tcl_ValidateAllMemory (file, line); 375 376 377 /* Don't let size argument to TclpAlloc overflow */ 378 if (size <= UINT_MAX - HIGH_GUARD_SIZE - sizeof(struct mem_header)) { 379 result = (struct mem_header *) TclpAlloc((unsigned)size + 380 sizeof(struct mem_header) + HIGH_GUARD_SIZE); 381 } 382 if (result == NULL) { 383 fflush(stdout); 384 TclDumpMemoryInfo(stderr); 385 panic("unable to alloc %u bytes, %s line %d", size, file, line); 386 } 387 388 /* 389 * Fill in guard zones and size. Also initialize the contents of 390 * the block with bogus bytes to detect uses of initialized data. 391 * Link into allocated list. 392 */ 393 if (init_malloced_bodies) { 394 memset ((VOID *) result, GUARD_VALUE, 395 size + sizeof(struct mem_header) + HIGH_GUARD_SIZE); 396 } else { 397 memset ((char *) result->low_guard, GUARD_VALUE, LOW_GUARD_SIZE); 398 memset (result->body + size, GUARD_VALUE, HIGH_GUARD_SIZE); 399 } 400 if (!ckallocInit) { 401 TclInitDbCkalloc(); 402 } 403 Tcl_MutexLock(ckallocMutexPtr); 404 result->length = size; 405 result->tagPtr = curTagPtr; 406 if (curTagPtr != NULL) { 407 curTagPtr->refCount++; 408 } 409 result->file = file; 410 result->line = line; 411 result->flink = allocHead; 412 result->blink = NULL; 413 414 if (allocHead != NULL) 415 allocHead->blink = result; 416 allocHead = result; 417 418 total_mallocs++; 419 if (trace_on_at_malloc && (total_mallocs >= trace_on_at_malloc)) { 420 (void) fflush(stdout); 421 fprintf(stderr, "reached malloc trace enable point (%d)\n", 422 total_mallocs); 423 fflush(stderr); 424 alloc_tracing = TRUE; 425 trace_on_at_malloc = 0; 426 } 427 428 if (alloc_tracing) 429 fprintf(stderr,"ckalloc %lx %u %s %d\n", 430 (long unsigned int) result->body, size, file, line); 431 432 if (break_on_malloc && (total_mallocs >= break_on_malloc)) { 433 break_on_malloc = 0; 434 (void) fflush(stdout); 435 fprintf(stderr,"reached malloc break limit (%d)\n", 436 total_mallocs); 437 fprintf(stderr, "program will now enter C debugger\n"); 438 (void) fflush(stderr); 439 abort(); 440 } 441 442 current_malloc_packets++; 443 if (current_malloc_packets > maximum_malloc_packets) 444 maximum_malloc_packets = current_malloc_packets; 445 current_bytes_malloced += size; 446 if (current_bytes_malloced > maximum_bytes_malloced) 447 maximum_bytes_malloced = current_bytes_malloced; 448 449 Tcl_MutexUnlock(ckallocMutexPtr); 450 451 return result->body; 452} 453 454char * 455Tcl_AttemptDbCkalloc(size, file, line) 456 unsigned int size; 457 CONST char *file; 458 int line; 459{ 460 struct mem_header *result = NULL; 461 462 if (validate_memory) 463 Tcl_ValidateAllMemory (file, line); 464 465 /* Don't let size argument to TclpAlloc overflow */ 466 if (size <= UINT_MAX - HIGH_GUARD_SIZE - sizeof(struct mem_header)) { 467 result = (struct mem_header *) TclpAlloc((unsigned)size + 468 sizeof(struct mem_header) + HIGH_GUARD_SIZE); 469 } 470 if (result == NULL) { 471 fflush(stdout); 472 TclDumpMemoryInfo(stderr); 473 return NULL; 474 } 475 476 /* 477 * Fill in guard zones and size. Also initialize the contents of 478 * the block with bogus bytes to detect uses of initialized data. 479 * Link into allocated list. 480 */ 481 if (init_malloced_bodies) { 482 memset ((VOID *) result, GUARD_VALUE, 483 size + sizeof(struct mem_header) + HIGH_GUARD_SIZE); 484 } else { 485 memset ((char *) result->low_guard, GUARD_VALUE, LOW_GUARD_SIZE); 486 memset (result->body + size, GUARD_VALUE, HIGH_GUARD_SIZE); 487 } 488 if (!ckallocInit) { 489 TclInitDbCkalloc(); 490 } 491 Tcl_MutexLock(ckallocMutexPtr); 492 result->length = size; 493 result->tagPtr = curTagPtr; 494 if (curTagPtr != NULL) { 495 curTagPtr->refCount++; 496 } 497 result->file = file; 498 result->line = line; 499 result->flink = allocHead; 500 result->blink = NULL; 501 502 if (allocHead != NULL) 503 allocHead->blink = result; 504 allocHead = result; 505 506 total_mallocs++; 507 if (trace_on_at_malloc && (total_mallocs >= trace_on_at_malloc)) { 508 (void) fflush(stdout); 509 fprintf(stderr, "reached malloc trace enable point (%d)\n", 510 total_mallocs); 511 fflush(stderr); 512 alloc_tracing = TRUE; 513 trace_on_at_malloc = 0; 514 } 515 516 if (alloc_tracing) 517 fprintf(stderr,"ckalloc %lx %u %s %d\n", 518 (long unsigned int) result->body, size, file, line); 519 520 if (break_on_malloc && (total_mallocs >= break_on_malloc)) { 521 break_on_malloc = 0; 522 (void) fflush(stdout); 523 fprintf(stderr,"reached malloc break limit (%d)\n", 524 total_mallocs); 525 fprintf(stderr, "program will now enter C debugger\n"); 526 (void) fflush(stderr); 527 abort(); 528 } 529 530 current_malloc_packets++; 531 if (current_malloc_packets > maximum_malloc_packets) 532 maximum_malloc_packets = current_malloc_packets; 533 current_bytes_malloced += size; 534 if (current_bytes_malloced > maximum_bytes_malloced) 535 maximum_bytes_malloced = current_bytes_malloced; 536 537 Tcl_MutexUnlock(ckallocMutexPtr); 538 539 return result->body; 540} 541 542 543/* 544 *---------------------------------------------------------------------- 545 * 546 * Tcl_DbCkfree - debugging ckfree 547 * 548 * Verify that the low and high guards are intact, and if so 549 * then free the buffer else panic. 550 * 551 * The guards are erased after being checked to catch duplicate 552 * frees. 553 * 554 * The second and third arguments are file and line, these contain 555 * the filename and line number corresponding to the caller. 556 * These are sent by the ckfree macro; it uses the preprocessor 557 * autodefines __FILE__ and __LINE__. 558 * 559 *---------------------------------------------------------------------- 560 */ 561 562int 563Tcl_DbCkfree(ptr, file, line) 564 char *ptr; 565 CONST char *file; 566 int line; 567{ 568 struct mem_header *memp; 569 570 if (ptr == NULL) { 571 return 0; 572 } 573 574 /* 575 * The following cast is *very* tricky. Must convert the pointer 576 * to an integer before doing arithmetic on it, because otherwise 577 * the arithmetic will be done differently (and incorrectly) on 578 * word-addressed machines such as Crays (will subtract only bytes, 579 * even though BODY_OFFSET is in words on these machines). 580 */ 581 582 memp = (struct mem_header *) (((unsigned long) ptr) - BODY_OFFSET); 583 584 if (alloc_tracing) { 585 fprintf(stderr, "ckfree %lx %ld %s %d\n", 586 (long unsigned int) memp->body, memp->length, file, line); 587 } 588 589 if (validate_memory) { 590 Tcl_ValidateAllMemory(file, line); 591 } 592 593 Tcl_MutexLock(ckallocMutexPtr); 594 ValidateMemory(memp, file, line, TRUE); 595 if (init_malloced_bodies) { 596 memset((VOID *) ptr, GUARD_VALUE, (size_t) memp->length); 597 } 598 599 total_frees++; 600 current_malloc_packets--; 601 current_bytes_malloced -= memp->length; 602 603 if (memp->tagPtr != NULL) { 604 memp->tagPtr->refCount--; 605 if ((memp->tagPtr->refCount == 0) && (curTagPtr != memp->tagPtr)) { 606 TclpFree((char *) memp->tagPtr); 607 } 608 } 609 610 /* 611 * Delink from allocated list 612 */ 613 if (memp->flink != NULL) 614 memp->flink->blink = memp->blink; 615 if (memp->blink != NULL) 616 memp->blink->flink = memp->flink; 617 if (allocHead == memp) 618 allocHead = memp->flink; 619 TclpFree((char *) memp); 620 Tcl_MutexUnlock(ckallocMutexPtr); 621 622 return 0; 623} 624 625/* 626 *-------------------------------------------------------------------- 627 * 628 * Tcl_DbCkrealloc - debugging ckrealloc 629 * 630 * Reallocate a chunk of memory by allocating a new one of the 631 * right size, copying the old data to the new location, and then 632 * freeing the old memory space, using all the memory checking 633 * features of this package. 634 * 635 *-------------------------------------------------------------------- 636 */ 637char * 638Tcl_DbCkrealloc(ptr, size, file, line) 639 char *ptr; 640 unsigned int size; 641 CONST char *file; 642 int line; 643{ 644 char *new; 645 unsigned int copySize; 646 struct mem_header *memp; 647 648 if (ptr == NULL) { 649 return Tcl_DbCkalloc(size, file, line); 650 } 651 652 /* 653 * See comment from Tcl_DbCkfree before you change the following 654 * line. 655 */ 656 657 memp = (struct mem_header *) (((unsigned long) ptr) - BODY_OFFSET); 658 659 copySize = size; 660 if (copySize > (unsigned int) memp->length) { 661 copySize = memp->length; 662 } 663 new = Tcl_DbCkalloc(size, file, line); 664 memcpy((VOID *) new, (VOID *) ptr, (size_t) copySize); 665 Tcl_DbCkfree(ptr, file, line); 666 return new; 667} 668 669char * 670Tcl_AttemptDbCkrealloc(ptr, size, file, line) 671 char *ptr; 672 unsigned int size; 673 CONST char *file; 674 int line; 675{ 676 char *new; 677 unsigned int copySize; 678 struct mem_header *memp; 679 680 if (ptr == NULL) { 681 return Tcl_AttemptDbCkalloc(size, file, line); 682 } 683 684 /* 685 * See comment from Tcl_DbCkfree before you change the following 686 * line. 687 */ 688 689 memp = (struct mem_header *) (((unsigned long) ptr) - BODY_OFFSET); 690 691 copySize = size; 692 if (copySize > (unsigned int) memp->length) { 693 copySize = memp->length; 694 } 695 new = Tcl_AttemptDbCkalloc(size, file, line); 696 if (new == NULL) { 697 return NULL; 698 } 699 memcpy((VOID *) new, (VOID *) ptr, (size_t) copySize); 700 Tcl_DbCkfree(ptr, file, line); 701 return new; 702} 703 704 705/* 706 *---------------------------------------------------------------------- 707 * 708 * Tcl_Alloc, et al. -- 709 * 710 * These functions are defined in terms of the debugging versions 711 * when TCL_MEM_DEBUG is set. 712 * 713 * Results: 714 * Same as the debug versions. 715 * 716 * Side effects: 717 * Same as the debug versions. 718 * 719 *---------------------------------------------------------------------- 720 */ 721 722#undef Tcl_Alloc 723#undef Tcl_Free 724#undef Tcl_Realloc 725#undef Tcl_AttemptAlloc 726#undef Tcl_AttemptRealloc 727 728char * 729Tcl_Alloc(size) 730 unsigned int size; 731{ 732 return Tcl_DbCkalloc(size, "unknown", 0); 733} 734 735char * 736Tcl_AttemptAlloc(size) 737 unsigned int size; 738{ 739 return Tcl_AttemptDbCkalloc(size, "unknown", 0); 740} 741 742void 743Tcl_Free(ptr) 744 char *ptr; 745{ 746 Tcl_DbCkfree(ptr, "unknown", 0); 747} 748 749char * 750Tcl_Realloc(ptr, size) 751 char *ptr; 752 unsigned int size; 753{ 754 return Tcl_DbCkrealloc(ptr, size, "unknown", 0); 755} 756char * 757Tcl_AttemptRealloc(ptr, size) 758 char *ptr; 759 unsigned int size; 760{ 761 return Tcl_AttemptDbCkrealloc(ptr, size, "unknown", 0); 762} 763 764/* 765 *---------------------------------------------------------------------- 766 * 767 * MemoryCmd -- 768 * Implements the Tcl "memory" command, which provides Tcl-level 769 * control of Tcl memory debugging information. 770 * memory active $file 771 * memory break_on_malloc $count 772 * memory info 773 * memory init on|off 774 * memory onexit $file 775 * memory tag $string 776 * memory trace on|off 777 * memory trace_on_at_malloc $count 778 * memory validate on|off 779 * 780 * Results: 781 * Standard TCL results. 782 * 783 *---------------------------------------------------------------------- 784 */ 785 /* ARGSUSED */ 786static int 787MemoryCmd (clientData, interp, argc, argv) 788 ClientData clientData; 789 Tcl_Interp *interp; 790 int argc; 791 CONST char **argv; 792{ 793 CONST char *fileName; 794 Tcl_DString buffer; 795 int result; 796 797 if (argc < 2) { 798 Tcl_AppendResult(interp, "wrong # args: should be \"", 799 argv[0], " option [args..]\"", (char *) NULL); 800 return TCL_ERROR; 801 } 802 803 if ((strcmp(argv[1],"active") == 0) || (strcmp(argv[1],"display") == 0)) { 804 if (argc != 3) { 805 Tcl_AppendResult(interp, "wrong # args: should be \"", 806 argv[0], " ", argv[1], " file\"", (char *) NULL); 807 return TCL_ERROR; 808 } 809 fileName = Tcl_TranslateFileName(interp, argv[2], &buffer); 810 if (fileName == NULL) { 811 return TCL_ERROR; 812 } 813 result = Tcl_DumpActiveMemory (fileName); 814 Tcl_DStringFree(&buffer); 815 if (result != TCL_OK) { 816 Tcl_AppendResult(interp, "error accessing ", argv[2], 817 (char *) NULL); 818 return TCL_ERROR; 819 } 820 return TCL_OK; 821 } 822 if (strcmp(argv[1],"break_on_malloc") == 0) { 823 if (argc != 3) { 824 goto argError; 825 } 826 if (Tcl_GetInt(interp, argv[2], &break_on_malloc) != TCL_OK) { 827 return TCL_ERROR; 828 } 829 return TCL_OK; 830 } 831 if (strcmp(argv[1],"info") == 0) { 832 char buf[400]; 833 sprintf(buf, "%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10d\n", 834 "total mallocs", total_mallocs, "total frees", total_frees, 835 "current packets allocated", current_malloc_packets, 836 "current bytes allocated", current_bytes_malloced, 837 "maximum packets allocated", maximum_malloc_packets, 838 "maximum bytes allocated", maximum_bytes_malloced); 839 Tcl_SetResult(interp, buf, TCL_VOLATILE); 840 return TCL_OK; 841 } 842 if (strcmp(argv[1],"init") == 0) { 843 if (argc != 3) { 844 goto bad_suboption; 845 } 846 init_malloced_bodies = (strcmp(argv[2],"on") == 0); 847 return TCL_OK; 848 } 849 if (strcmp(argv[1],"onexit") == 0) { 850 if (argc != 3) { 851 Tcl_AppendResult(interp, "wrong # args: should be \"", 852 argv[0], " onexit file\"", (char *) NULL); 853 return TCL_ERROR; 854 } 855 fileName = Tcl_TranslateFileName(interp, argv[2], &buffer); 856 if (fileName == NULL) { 857 return TCL_ERROR; 858 } 859 onExitMemDumpFileName = dumpFile; 860 strcpy(onExitMemDumpFileName,fileName); 861 Tcl_DStringFree(&buffer); 862 return TCL_OK; 863 } 864 if (strcmp(argv[1],"tag") == 0) { 865 if (argc != 3) { 866 Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], 867 " tag string\"", (char *) NULL); 868 return TCL_ERROR; 869 } 870 if ((curTagPtr != NULL) && (curTagPtr->refCount == 0)) { 871 TclpFree((char *) curTagPtr); 872 } 873 curTagPtr = (MemTag *) TclpAlloc(TAG_SIZE(strlen(argv[2]))); 874 curTagPtr->refCount = 0; 875 strcpy(curTagPtr->string, argv[2]); 876 return TCL_OK; 877 } 878 if (strcmp(argv[1],"trace") == 0) { 879 if (argc != 3) { 880 goto bad_suboption; 881 } 882 alloc_tracing = (strcmp(argv[2],"on") == 0); 883 return TCL_OK; 884 } 885 886 if (strcmp(argv[1],"trace_on_at_malloc") == 0) { 887 if (argc != 3) { 888 goto argError; 889 } 890 if (Tcl_GetInt(interp, argv[2], &trace_on_at_malloc) != TCL_OK) { 891 return TCL_ERROR; 892 } 893 return TCL_OK; 894 } 895 if (strcmp(argv[1],"validate") == 0) { 896 if (argc != 3) { 897 goto bad_suboption; 898 } 899 validate_memory = (strcmp(argv[2],"on") == 0); 900 return TCL_OK; 901 } 902 903 Tcl_AppendResult(interp, "bad option \"", argv[1], 904 "\": should be active, break_on_malloc, info, init, onexit, ", 905 "tag, trace, trace_on_at_malloc, or validate", (char *) NULL); 906 return TCL_ERROR; 907 908argError: 909 Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], 910 " ", argv[1], " count\"", (char *) NULL); 911 return TCL_ERROR; 912 913bad_suboption: 914 Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], 915 " ", argv[1], " on|off\"", (char *) NULL); 916 return TCL_ERROR; 917} 918 919/* 920 *---------------------------------------------------------------------- 921 * 922 * CheckmemCmd -- 923 * 924 * This is the command procedure for the "checkmem" command, which 925 * causes the application to exit after printing information about 926 * memory usage to the file passed to this command as its first 927 * argument. 928 * 929 * Results: 930 * Returns a standard Tcl completion code. 931 * 932 * Side effects: 933 * None. 934 * 935 *---------------------------------------------------------------------- 936 */ 937 938static int 939CheckmemCmd(clientData, interp, argc, argv) 940 ClientData clientData; /* Not used. */ 941 Tcl_Interp *interp; /* Interpreter for evaluation. */ 942 int argc; /* Number of arguments. */ 943 CONST char *argv[]; /* String values of arguments. */ 944{ 945 if (argc != 2) { 946 Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], 947 " fileName\"", (char *) NULL); 948 return TCL_ERROR; 949 } 950 tclMemDumpFileName = dumpFile; 951 strcpy(tclMemDumpFileName, argv[1]); 952 return TCL_OK; 953} 954 955/* 956 *---------------------------------------------------------------------- 957 * 958 * Tcl_InitMemory -- 959 * 960 * Create the "memory" and "checkmem" commands in the given 961 * interpreter. 962 * 963 * Results: 964 * None. 965 * 966 * Side effects: 967 * New commands are added to the interpreter. 968 * 969 *---------------------------------------------------------------------- 970 */ 971 972void 973Tcl_InitMemory(interp) 974 Tcl_Interp *interp; /* Interpreter in which commands should be added */ 975{ 976 TclInitDbCkalloc(); 977 Tcl_CreateCommand (interp, "memory", MemoryCmd, (ClientData) NULL, 978 (Tcl_CmdDeleteProc *) NULL); 979 Tcl_CreateCommand(interp, "checkmem", CheckmemCmd, (ClientData) 0, 980 (Tcl_CmdDeleteProc *) NULL); 981} 982 983 984#else /* TCL_MEM_DEBUG */ 985 986/* This is the !TCL_MEM_DEBUG case */ 987 988#undef Tcl_InitMemory 989#undef Tcl_DumpActiveMemory 990#undef Tcl_ValidateAllMemory 991 992 993/* 994 *---------------------------------------------------------------------- 995 * 996 * Tcl_Alloc -- 997 * Interface to TclpAlloc when TCL_MEM_DEBUG is disabled. It does check 998 * that memory was actually allocated. 999 * 1000 *---------------------------------------------------------------------- 1001 */ 1002 1003char * 1004Tcl_Alloc (size) 1005 unsigned int size; 1006{ 1007 char *result; 1008 1009 result = TclpAlloc(size); 1010 /* 1011 * Most systems will not alloc(0), instead bumping it to one so 1012 * that NULL isn't returned. Some systems (AIX, Tru64) will alloc(0) 1013 * by returning NULL, so we have to check that the NULL we get is 1014 * not in response to alloc(0). 1015 * 1016 * The ANSI spec actually says that systems either return NULL *or* 1017 * a special pointer on failure, but we only check for NULL 1018 */ 1019 if ((result == NULL) && size) { 1020 panic("unable to alloc %u bytes", size); 1021 } 1022 return result; 1023} 1024 1025char * 1026Tcl_DbCkalloc(size, file, line) 1027 unsigned int size; 1028 CONST char *file; 1029 int line; 1030{ 1031 char *result; 1032 1033 result = (char *) TclpAlloc(size); 1034 1035 if ((result == NULL) && size) { 1036 fflush(stdout); 1037 panic("unable to alloc %u bytes, %s line %d", size, file, line); 1038 } 1039 return result; 1040} 1041 1042/* 1043 *---------------------------------------------------------------------- 1044 * 1045 * Tcl_AttemptAlloc -- 1046 * Interface to TclpAlloc when TCL_MEM_DEBUG is disabled. It does not 1047 * check that memory was actually allocated. 1048 * 1049 *---------------------------------------------------------------------- 1050 */ 1051 1052char * 1053Tcl_AttemptAlloc (size) 1054 unsigned int size; 1055{ 1056 char *result; 1057 1058 result = TclpAlloc(size); 1059 return result; 1060} 1061 1062char * 1063Tcl_AttemptDbCkalloc(size, file, line) 1064 unsigned int size; 1065 CONST char *file; 1066 int line; 1067{ 1068 char *result; 1069 1070 result = (char *) TclpAlloc(size); 1071 return result; 1072} 1073 1074 1075/* 1076 *---------------------------------------------------------------------- 1077 * 1078 * Tcl_Realloc -- 1079 * Interface to TclpRealloc when TCL_MEM_DEBUG is disabled. It does 1080 * check that memory was actually allocated. 1081 * 1082 *---------------------------------------------------------------------- 1083 */ 1084 1085char * 1086Tcl_Realloc(ptr, size) 1087 char *ptr; 1088 unsigned int size; 1089{ 1090 char *result; 1091 1092 result = TclpRealloc(ptr, size); 1093 1094 if ((result == NULL) && size) { 1095 panic("unable to realloc %u bytes", size); 1096 } 1097 return result; 1098} 1099 1100char * 1101Tcl_DbCkrealloc(ptr, size, file, line) 1102 char *ptr; 1103 unsigned int size; 1104 CONST char *file; 1105 int line; 1106{ 1107 char *result; 1108 1109 result = (char *) TclpRealloc(ptr, size); 1110 1111 if ((result == NULL) && size) { 1112 fflush(stdout); 1113 panic("unable to realloc %u bytes, %s line %d", size, file, line); 1114 } 1115 return result; 1116} 1117 1118/* 1119 *---------------------------------------------------------------------- 1120 * 1121 * Tcl_AttemptRealloc -- 1122 * Interface to TclpRealloc when TCL_MEM_DEBUG is disabled. It does 1123 * not check that memory was actually allocated. 1124 * 1125 *---------------------------------------------------------------------- 1126 */ 1127 1128char * 1129Tcl_AttemptRealloc(ptr, size) 1130 char *ptr; 1131 unsigned int size; 1132{ 1133 char *result; 1134 1135 result = TclpRealloc(ptr, size); 1136 return result; 1137} 1138 1139char * 1140Tcl_AttemptDbCkrealloc(ptr, size, file, line) 1141 char *ptr; 1142 unsigned int size; 1143 CONST char *file; 1144 int line; 1145{ 1146 char *result; 1147 1148 result = (char *) TclpRealloc(ptr, size); 1149 return result; 1150} 1151 1152/* 1153 *---------------------------------------------------------------------- 1154 * 1155 * Tcl_Free -- 1156 * Interface to TclpFree when TCL_MEM_DEBUG is disabled. Done here 1157 * rather in the macro to keep some modules from being compiled with 1158 * TCL_MEM_DEBUG enabled and some with it disabled. 1159 * 1160 *---------------------------------------------------------------------- 1161 */ 1162 1163void 1164Tcl_Free (ptr) 1165 char *ptr; 1166{ 1167 TclpFree(ptr); 1168} 1169 1170int 1171Tcl_DbCkfree(ptr, file, line) 1172 char *ptr; 1173 CONST char *file; 1174 int line; 1175{ 1176 TclpFree(ptr); 1177 return 0; 1178} 1179 1180/* 1181 *---------------------------------------------------------------------- 1182 * 1183 * Tcl_InitMemory -- 1184 * Dummy initialization for memory command, which is only available 1185 * if TCL_MEM_DEBUG is on. 1186 * 1187 *---------------------------------------------------------------------- 1188 */ 1189 /* ARGSUSED */ 1190void 1191Tcl_InitMemory(interp) 1192 Tcl_Interp *interp; 1193{ 1194} 1195 1196int 1197Tcl_DumpActiveMemory(fileName) 1198 CONST char *fileName; 1199{ 1200 return TCL_OK; 1201} 1202 1203void 1204Tcl_ValidateAllMemory(file, line) 1205 CONST char *file; 1206 int line; 1207{ 1208} 1209 1210void 1211TclDumpMemoryInfo(outFile) 1212 FILE *outFile; 1213{ 1214} 1215 1216#endif /* TCL_MEM_DEBUG */ 1217 1218/* 1219 *--------------------------------------------------------------------------- 1220 * 1221 * TclFinalizeMemorySubsystem -- 1222 * 1223 * This procedure is called to finalize all the structures that 1224 * are used by the memory allocator on a per-process basis. 1225 * 1226 * Results: 1227 * None. 1228 * 1229 * Side effects: 1230 * This subsystem is self-initializing, since memory can be 1231 * allocated before Tcl is formally initialized. After this call, 1232 * this subsystem has been reset to its initial state and is 1233 * usable again. 1234 * 1235 *--------------------------------------------------------------------------- 1236 */ 1237 1238void 1239TclFinalizeMemorySubsystem() 1240{ 1241#ifdef TCL_MEM_DEBUG 1242 if (tclMemDumpFileName != NULL) { 1243 Tcl_DumpActiveMemory(tclMemDumpFileName); 1244 } else if (onExitMemDumpFileName != NULL) { 1245 Tcl_DumpActiveMemory(onExitMemDumpFileName); 1246 } 1247 Tcl_MutexLock(ckallocMutexPtr); 1248 if (curTagPtr != NULL) { 1249 TclpFree((char *) curTagPtr); 1250 curTagPtr = NULL; 1251 } 1252 allocHead = NULL; 1253 Tcl_MutexUnlock(ckallocMutexPtr); 1254#endif 1255 1256#if USE_TCLALLOC 1257 TclFinalizeAllocSubsystem(); 1258#endif 1259} 1260