/[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 42 - (hide annotations) (download)
Fri Oct 14 01:50:00 2016 UTC (7 years, 1 month 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 dashley 25 /* $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