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

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

Parent Directory Parent Directory | Revision Log Revision Log


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

Properties

Name Value
svn:keywords Header

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25