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

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25