tclckalloc.c

tcl是工具命令语言

        fflush(stderr);
        alloc_tracing = TRUE;
        trace_on_at_malloc = 0;
    }

    if (alloc_tracing)
        fprintf(stderr,"ckalloc %lx %u %s %d\n",
		(long unsigned int) result->body, size, file, line);

    if (break_on_malloc && (total_mallocs >= break_on_malloc)) {
        break_on_malloc = 0;
        (void) fflush(stdout);
        fprintf(stderr,"reached malloc break limit (%d)\n", 
                total_mallocs);
        fprintf(stderr, "program will now enter C debugger\n");
        (void) fflush(stderr);
	abort();
    }

    current_malloc_packets++;
    if (current_malloc_packets > maximum_malloc_packets)
        maximum_malloc_packets = current_malloc_packets;
    current_bytes_malloced += size;
    if (current_bytes_malloced > maximum_bytes_malloced)
        maximum_bytes_malloced = current_bytes_malloced;

    Tcl_MutexUnlock(ckallocMutexPtr);

    return result->body;
}

char *
Tcl_AttemptDbCkalloc(size, file, line)
    unsigned int size;
    CONST char  *file;
    int          line;
{
    struct mem_header *result;

    if (validate_memory)
        Tcl_ValidateAllMemory (file, line);

    result = (struct mem_header *) TclpAlloc((unsigned)size + 
                              sizeof(struct mem_header) + HIGH_GUARD_SIZE);
    if (result == NULL) {
        fflush(stdout);
        TclDumpMemoryInfo(stderr);
	return NULL;
    }

    /*
     * Fill in guard zones and size.  Also initialize the contents of
     * the block with bogus bytes to detect uses of initialized data.
     * Link into allocated list.
     */
    if (init_malloced_bodies) {
        memset ((VOID *) result, GUARD_VALUE,
		size + sizeof(struct mem_header) + HIGH_GUARD_SIZE);
    } else {
	memset ((char *) result->low_guard, GUARD_VALUE, LOW_GUARD_SIZE);
	memset (result->body + size, GUARD_VALUE, HIGH_GUARD_SIZE);
    }
    if (!ckallocInit) {
	TclInitDbCkalloc();
    }
    Tcl_MutexLock(ckallocMutexPtr);
    result->length = size;
    result->tagPtr = curTagPtr;
    if (curTagPtr != NULL) {
	curTagPtr->refCount++;
    }
    result->file = file;
    result->line = line;
    result->flink = allocHead;
    result->blink = NULL;

    if (allocHead != NULL)
        allocHead->blink = result;
    allocHead = result;

    total_mallocs++;
    if (trace_on_at_malloc && (total_mallocs >= trace_on_at_malloc)) {
        (void) fflush(stdout);
        fprintf(stderr, "reached malloc trace enable point (%d)\n",
                total_mallocs);
        fflush(stderr);
        alloc_tracing = TRUE;
        trace_on_at_malloc = 0;
    }

    if (alloc_tracing)
        fprintf(stderr,"ckalloc %lx %u %s %d\n",
		(long unsigned int) result->body, size, file, line);

    if (break_on_malloc && (total_mallocs >= break_on_malloc)) {
        break_on_malloc = 0;
        (void) fflush(stdout);
        fprintf(stderr,"reached malloc break limit (%d)\n", 
                total_mallocs);
        fprintf(stderr, "program will now enter C debugger\n");
        (void) fflush(stderr);
	abort();
    }

    current_malloc_packets++;
    if (current_malloc_packets > maximum_malloc_packets)
        maximum_malloc_packets = current_malloc_packets;
    current_bytes_malloced += size;
    if (current_bytes_malloced > maximum_bytes_malloced)
        maximum_bytes_malloced = current_bytes_malloced;

    Tcl_MutexUnlock(ckallocMutexPtr);

    return result->body;
}


/*
 *----------------------------------------------------------------------
 *
 * Tcl_DbCkfree - debugging ckfree
 *
 *        Verify that the low and high guards are intact, and if so
 *        then free the buffer else panic.
 *
 *        The guards are erased after being checked to catch duplicate
 *        frees.
 *
 *        The second and third arguments are file and line, these contain
 *        the filename and line number corresponding to the caller.
 *        These are sent by the ckfree macro; it uses the preprocessor
 *        autodefines __FILE__ and __LINE__.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_DbCkfree(ptr, file, line)
    char       *ptr;
    CONST char *file;
    int         line;
{
    struct mem_header *memp;

    if (ptr == NULL) {
	return 0;
    }

    /*
     * The following cast is *very* tricky.  Must convert the pointer
     * to an integer before doing arithmetic on it, because otherwise
     * the arithmetic will be done differently (and incorrectly) on
     * word-addressed machines such as Crays (will subtract only bytes,
     * even though BODY_OFFSET is in words on these machines).
     */

    memp = (struct mem_header *) (((unsigned long) ptr) - BODY_OFFSET);

    if (alloc_tracing) {
        fprintf(stderr, "ckfree %lx %ld %s %d\n",
		(long unsigned int) memp->body, memp->length, file, line);
    }

    if (validate_memory) {
        Tcl_ValidateAllMemory(file, line);
    }

    Tcl_MutexLock(ckallocMutexPtr);
    ValidateMemory(memp, file, line, TRUE);
    if (init_malloced_bodies) {
	memset((VOID *) ptr, GUARD_VALUE, (size_t) memp->length);
    }

    total_frees++;
    current_malloc_packets--;
    current_bytes_malloced -= memp->length;

    if (memp->tagPtr != NULL) {
	memp->tagPtr->refCount--;
	if ((memp->tagPtr->refCount == 0) && (curTagPtr != memp->tagPtr)) {
	    TclpFree((char *) memp->tagPtr);
	}
    }

    /*
     * Delink from allocated list
     */
    if (memp->flink != NULL)
        memp->flink->blink = memp->blink;
    if (memp->blink != NULL)
        memp->blink->flink = memp->flink;
    if (allocHead == memp)
        allocHead = memp->flink;
    TclpFree((char *) memp);
    Tcl_MutexUnlock(ckallocMutexPtr);

    return 0;
}

/*
 *--------------------------------------------------------------------
 *
 * Tcl_DbCkrealloc - debugging ckrealloc
 *
 *	Reallocate a chunk of memory by allocating a new one of the
 *	right size, copying the old data to the new location, and then
 *	freeing the old memory space, using all the memory checking
 *	features of this package.
 *
 *--------------------------------------------------------------------
 */
char *
Tcl_DbCkrealloc(ptr, size, file, line)
    char        *ptr;
    unsigned int size;
    CONST char  *file;
    int          line;
{
    char *new;
    unsigned int copySize;
    struct mem_header *memp;

    if (ptr == NULL) {
	return Tcl_DbCkalloc(size, file, line);
    }

    /*
     * See comment from Tcl_DbCkfree before you change the following
     * line.
     */

    memp = (struct mem_header *) (((unsigned long) ptr) - BODY_OFFSET);

    copySize = size;
    if (copySize > (unsigned int) memp->length) {
	copySize = memp->length;
    }
    new = Tcl_DbCkalloc(size, file, line);
    memcpy((VOID *) new, (VOID *) ptr, (size_t) copySize);
    Tcl_DbCkfree(ptr, file, line);
    return new;
}

char *
Tcl_AttemptDbCkrealloc(ptr, size, file, line)
    char        *ptr;
    unsigned int size;
    CONST char  *file;
    int          line;
{
    char *new;
    unsigned int copySize;
    struct mem_header *memp;

    if (ptr == NULL) {
	return Tcl_AttemptDbCkalloc(size, file, line);
    }

    /*
     * See comment from Tcl_DbCkfree before you change the following
     * line.
     */

    memp = (struct mem_header *) (((unsigned long) ptr) - BODY_OFFSET);

    copySize = size;
    if (copySize > (unsigned int) memp->length) {
	copySize = memp->length;
    }
    new = Tcl_AttemptDbCkalloc(size, file, line);
    if (new == NULL) {
	return NULL;
    }
    memcpy((VOID *) new, (VOID *) ptr, (size_t) copySize);
    Tcl_DbCkfree(ptr, file, line);
    return new;
}


/*
 *----------------------------------------------------------------------
 *
 * Tcl_Alloc, et al. --
 *
 *	These functions are defined in terms of the debugging versions
 *	when TCL_MEM_DEBUG is set.
 *
 * Results:
 *	Same as the debug versions.
 *
 * Side effects:
 *	Same as the debug versions.
 *
 *----------------------------------------------------------------------
 */

#undef Tcl_Alloc
#undef Tcl_Free
#undef Tcl_Realloc
#undef Tcl_AttemptAlloc
#undef Tcl_AttemptRealloc

char *
Tcl_Alloc(size)
    unsigned int size;
{
    return Tcl_DbCkalloc(size, "unknown", 0);
}

char *
Tcl_AttemptAlloc(size)
    unsigned int size;
{
    return Tcl_AttemptDbCkalloc(size, "unknown", 0);
}

void
Tcl_Free(ptr)
    char *ptr;
{
    Tcl_DbCkfree(ptr, "unknown", 0);
}

char *
Tcl_Realloc(ptr, size)
    char *ptr;
    unsigned int size;
{
    return Tcl_DbCkrealloc(ptr, size, "unknown", 0);
}
char *
Tcl_AttemptRealloc(ptr, size)
    char *ptr;
    unsigned int size;
{
    return Tcl_AttemptDbCkrealloc(ptr, size, "unknown", 0);
}

/*
 *----------------------------------------------------------------------
 *
 * MemoryCmd --
 *	Implements the Tcl "memory" command, which provides Tcl-level
 *	control of Tcl memory debugging information.
 *		memory active $file
 *		memory break_on_malloc $count
 *		memory info
 *		memory init on|off
 *		memory onexit $file
 *		memory tag $string
 *		memory trace on|off
 *		memory trace_on_at_malloc $count
 *		memory validate on|off
 *
 * Results:
 *     Standard TCL results.
 *
 *----------------------------------------------------------------------
 */
	/* ARGSUSED */
static int
MemoryCmd (clientData, interp, argc, argv)
    ClientData  clientData;
    Tcl_Interp *interp;
    int         argc;
    CONST char  **argv;
{
    CONST char *fileName;
    Tcl_DString buffer;
    int result;

    if (argc < 2) {
	Tcl_AppendResult(interp, "wrong # args: should be \"",
		argv[0], " option [args..]\"", (char *) NULL);
	return TCL_ERROR;
    }

    if ((strcmp(argv[1],"active") == 0) || (strcmp(argv[1],"display") == 0)) {
        if (argc != 3) {
	    Tcl_AppendResult(interp, "wrong # args: should be \"",
		    argv[0], " ", argv[1], " file\"", (char *) NULL);
	    return TCL_ERROR;
	}
	fileName = Tcl_TranslateFileName(interp, argv[2], &buffer);
	if (fileName == NULL) {
	    return TCL_ERROR;
	}
	result = Tcl_DumpActiveMemory (fileName);
	Tcl_DStringFree(&buffer);
	if (result != TCL_OK) {
	    Tcl_AppendResult(interp, "error accessing ", argv[2], 
		    (char *) NULL);
	    return TCL_ERROR;
	}
	return TCL_OK;
    }
    if (strcmp(argv[1],"break_on_malloc") == 0) {
        if (argc != 3) {
            goto argError;
	}
        if (Tcl_GetInt(interp, argv[2], &break_on_malloc) != TCL_OK) {
	    return TCL_ERROR;
	}
        return TCL_OK;
    }
    if (strcmp(argv[1],"info") == 0) {
	char buf[400];
	sprintf(buf, "%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10d\n",
	    "total mallocs", total_mallocs, "total frees", total_frees,
	    "current packets allocated", current_malloc_packets,
	    "current bytes allocated", current_bytes_malloced,
	    "maximum packets allocated", maximum_malloc_packets,
	    "maximum bytes allocated", maximum_bytes_malloced);
	Tcl_SetResult(interp, buf, TCL_VOLATILE);
        return TCL_OK;
    }
    if (strcmp(argv[1],"init") == 0) {
        if (argc != 3) {