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