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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 66 - (hide annotations) (download)
Sun Oct 30 21:57:38 2016 UTC (7 years, 3 months ago) by dashley
File MIME type: text/plain
File size: 27625 byte(s)
Header and footer cleanup.
1 dashley 64 /* $Header$ */
2 dashley 25 /*
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 dashley 66 /* End of tclckalloc.c */

Properties

Name Value
svn:keywords Header

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25