/* 

 * tclAlloc.c --

 *

 *	This is a very fast storage allocator.  It allocates blocks of a

 *	small number of different sizes, and keeps free lists of each size.

 *	Blocks that don't exactly fit are passed up to the next larger size.

 *	Blocks over a certain size are directly allocated from the system.

 *

 * Copyright (c) 1983 Regents of the University of California.

 * Copyright (c) 1996-1997 Sun Microsystems, Inc.

 * Copyright (c) 1998-1999 by Scriptics Corporation.

 *

 * Portions contributed by Chris Kingsley, Jack Jansen and Ray Johnson.

 *

 * See the file "license.terms" for information on usage and redistribution

 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.

 *

 * RCS: @(#) $Id: tclAlloc.c,v 1.16.2.1 2004/10/28 21:12:37 andreas_kupries Exp $

 */

/*

 * Windows and Unix use an alternative allocator when building with threads

 * that has significantly reduced lock contention.

 */

#if !defined(TCL_THREADS) || !defined(USE_THREAD_ALLOC) || defined(TCL_MEM_DEBUG)

#include "tclInt.h"

#include "tclPort.h"

#if USE_TCLALLOC

#ifdef TCL_DEBUG

#   define DEBUG

/* #define MSTATS */

#   define RCHECK

#endif

/*

 * We should really make use of AC_CHECK_TYPE(caddr_t)

 * here, but it can wait until Tcl uses config.h properly.

 */

#if defined(MAC_TCL) || defined(_MSC_VER) || defined(__MINGW32__) || defined(__BORLANDC__)

typedef unsigned long caddr_t;

#endif

/*

 * The overhead on a block is at least 8 bytes.  When free, this space

 * contains a pointer to the next free block, and the bottom two bits must

 * be zero.  When in use, the first byte is set to MAGIC, and the second

 * byte is the size index.  The remaining bytes are for alignment.

 * If range checking is enabled then a second word holds the size of the

 * requested block, less 1, rounded up to a multiple of sizeof(RMAGIC).

 * The order of elements is critical: ov_magic must overlay the low order

 * bits of ov_next, and ov_magic can not be a valid ov_next bit pattern.

 */

union overhead {

    union overhead *ov_next;	/* when free */

    unsigned char ov_padding[8]; /* Ensure the structure is 8-byte aligned. */

    struct {

	unsigned char	ovu_magic0;	/* magic number */

	unsigned char	ovu_index;	/* bucket # */

	unsigned char	ovu_unused;	/* unused */

	unsigned char	ovu_magic1;	/* other magic number */

#ifdef RCHECK

	unsigned short	ovu_rmagic;	/* range magic number */

	unsigned long	ovu_size;	/* actual block size */

	unsigned short  ovu_unused2;    /* padding to 8-byte align */

#endif

    } ovu;

#define ov_magic0	ovu.ovu_magic0

#define ov_magic1	ovu.ovu_magic1

#define ov_index	ovu.ovu_index

#define ov_rmagic	ovu.ovu_rmagic

#define ov_size		ovu.ovu_size

};

#define MAGIC		0xef		/* magic # on accounting info */

#define RMAGIC		0x5555		/* magic # on range info */

#ifdef RCHECK

#define	RSLOP		sizeof (unsigned short)

#else

#define	RSLOP		0

#endif

#define OVERHEAD (sizeof(union overhead) + RSLOP)

/*

 * nextf[i] is the pointer to the next free block of size 2^(i+3).  The

 * smallest allocatable block is 8 bytes.  The overhead information

 * precedes the data area returned to the user.

 */

#define NBUCKETS	13

#define MAXMALLOC	(1<<(NBUCKETS+2))

static	union overhead *nextf[NBUCKETS];

/* 

 * The following structure is used to keep track of all system memory 

 * currently owned by Tcl.  When finalizing, all this memory will

 * be returned to the system.

 */

struct block {

    struct block *nextPtr;	/* Linked list. */

    struct block *prevPtr;	/* Linked list for big blocks, ensures 8-byte 

				 * alignment for suballocated blocks. */

};

static struct block *blockList;		/* Tracks the suballocated blocks. */

static struct block bigBlocks = {	/* Big blocks aren't suballocated. */

    &bigBlocks, &bigBlocks

};

/*

 * The allocator is protected by a special mutex that must be

 * explicitly initialized.  Futhermore, because Tcl_Alloc may be

 * used before anything else in Tcl, we make this module self-initializing

 * after all with the allocInit variable.

 */

#ifdef TCL_THREADS

static Tcl_Mutex *allocMutexPtr;

#endif

static int allocInit = 0;

#ifdef MSTATS

/*

 * nmalloc[i] is the difference between the number of mallocs and frees

 * for a given block size.

 */

static	unsigned int nmalloc[NBUCKETS+1];

#include <stdio.h>

#endif

#if defined(DEBUG) || defined(RCHECK)

#define	ASSERT(p)   if (!(p)) panic(# p)

#define RANGE_ASSERT(p) if (!(p)) panic(# p)

#else

#define	ASSERT(p)

#define RANGE_ASSERT(p)

#endif

/*

 * Prototypes for functions used only in this file.

 */

static void 		MoreCore _ANSI_ARGS_((int bucket));

/*

 *-------------------------------------------------------------------------

 *

 * TclInitAlloc --

 *

 *	Initialize the memory system.

 *

 * Results:

 *	None.

 *

 * Side effects:

 *	Initialize the mutex used to serialize allocations.

 *

 *-------------------------------------------------------------------------

 */

void

TclInitAlloc()

{

    if (!allocInit) {

	allocInit = 1;

#ifdef TCL_THREADS

	allocMutexPtr = Tcl_GetAllocMutex();

#endif

    }

}

/*

 *-------------------------------------------------------------------------

 *

 * TclFinalizeAllocSubsystem --

 *

 *	Release all resources being used by this subsystem, including 

 *	aggressively freeing all memory allocated by TclpAlloc() that 

 *	has not yet been released with TclpFree().

 *	

 *	After this function is called, all memory allocated with 

 *	TclpAlloc() should be considered unusable.

 *

 * Results:

 *	None.

 *

 * Side effects:

 *	This subsystem is self-initializing, since memory can be 

 *	allocated before Tcl is formally initialized.  After this call,

 *	this subsystem has been reset to its initial state and is 

 *	usable again.

 *

 *-------------------------------------------------------------------------

 */

void

TclFinalizeAllocSubsystem()

{

    int i;

    struct block *blockPtr, *nextPtr;

    Tcl_MutexLock(allocMutexPtr);

    for (blockPtr = blockList; blockPtr != NULL; blockPtr = nextPtr) {

	nextPtr = blockPtr->nextPtr;

	TclpSysFree(blockPtr);

    }

    blockList = NULL;

    for (blockPtr = bigBlocks.nextPtr; blockPtr != &bigBlocks; ) {

	nextPtr = blockPtr->nextPtr;

	TclpSysFree(blockPtr);

	blockPtr = nextPtr;

    }

    bigBlocks.nextPtr = &bigBlocks;

    bigBlocks.prevPtr = &bigBlocks;

    for (i = 0; i < NBUCKETS; i++) {

	nextf[i] = NULL;

#ifdef MSTATS

	nmalloc[i] = 0;

#endif

    }

#ifdef MSTATS

    nmalloc[i] = 0;

#endif

    Tcl_MutexUnlock(allocMutexPtr);

}

/*

 *----------------------------------------------------------------------

 *

 * TclpAlloc --

 *

 *	Allocate more memory.

 *

 * Results:

 *	None.

 *

 * Side effects:

 *	None.

 *

 *----------------------------------------------------------------------

 */

char *

TclpAlloc(nbytes)

    unsigned int nbytes;	/* Number of bytes to allocate. */

{

    register union overhead *op;

    register long bucket;

    register unsigned amt;

    struct block *bigBlockPtr;

    if (!allocInit) {

	/*

	 * We have to make the "self initializing" because Tcl_Alloc

	 * may be used before any other part of Tcl.  E.g., see

	 * main() for tclsh!

	 */

	TclInitAlloc();

    }

    Tcl_MutexLock(allocMutexPtr);

    /*

     * First the simple case: we simple allocate big blocks directly

     */

    if (nbytes + OVERHEAD >= MAXMALLOC) {

	bigBlockPtr = (struct block *) TclpSysAlloc((unsigned) 

		(sizeof(struct block) + OVERHEAD + nbytes), 0);

	if (bigBlockPtr == NULL) {

	    Tcl_MutexUnlock(allocMutexPtr);

	    return NULL;

	}

	bigBlockPtr->nextPtr = bigBlocks.nextPtr;

	bigBlocks.nextPtr = bigBlockPtr;

	bigBlockPtr->prevPtr = &bigBlocks;

	bigBlockPtr->nextPtr->prevPtr = bigBlockPtr;

	op = (union overhead *) (bigBlockPtr + 1);

	op->ov_magic0 = op->ov_magic1 = MAGIC;

	op->ov_index = 0xff;

#ifdef MSTATS

	nmalloc[NBUCKETS]++;

#endif

#ifdef RCHECK

	/*

	 * Record allocated size of block and

	 * bound space with magic numbers.

	 */

	op->ov_size = (nbytes + RSLOP - 1) & ~(RSLOP - 1);

	op->ov_rmagic = RMAGIC;

	*(unsigned short *)((caddr_t)(op + 1) + op->ov_size) = RMAGIC;

#endif

	Tcl_MutexUnlock(allocMutexPtr);

	return (void *)(op+1);

    }

    /*

     * Convert amount of memory requested into closest block size

     * stored in hash buckets which satisfies request.

     * Account for space used per block for accounting.

     */

#ifndef RCHECK

    amt = 8;	/* size of first bucket */

    bucket = 0;

#else

    amt = 16;	/* size of first bucket */

    bucket = 1;

#endif

    while (nbytes + OVERHEAD > amt) {

	amt <<= 1;

	if (amt == 0) {

	    Tcl_MutexUnlock(allocMutexPtr);

	    return (NULL);

	}

	bucket++;

    }

    ASSERT( bucket < NBUCKETS );

    /*

     * If nothing in hash bucket right now,

     * request more memory from the system.

     */

    if ((op = nextf[bucket]) == NULL) {

	MoreCore(bucket);

	if ((op = nextf[bucket]) == NULL) {

	    Tcl_MutexUnlock(allocMutexPtr);

	    return (NULL);

	}

    }

    /*

     * Remove from linked list

     */

    nextf[bucket] = op->ov_next;

    op->ov_magic0 = op->ov_magic1 = MAGIC;

    op->ov_index = (unsigned char) bucket;

#ifdef MSTATS

    nmalloc[bucket]++;

#endif

#ifdef RCHECK

    /*

     * Record allocated size of block and

     * bound space with magic numbers.

     */

    op->ov_size = (nbytes + RSLOP - 1) & ~(RSLOP - 1);

    op->ov_rmagic = RMAGIC;

    *(unsigned short *)((caddr_t)(op + 1) + op->ov_size) = RMAGIC;

#endif

    Tcl_MutexUnlock(allocMutexPtr);

    return ((char *)(op + 1));

}

/*

 *----------------------------------------------------------------------

 *

 * MoreCore --

 *

 *	Allocate more memory to the indicated bucket.

 *

 *	Assumes Mutex is already held.

 *

 * Results:

 *	None.

 *

 * Side effects:

 *	Attempts to get more memory from the system.

 *

 *----------------------------------------------------------------------

 */

static void

MoreCore(bucket)

    int bucket;		/* What bucket to allocat to. */

{

    register union overhead *op;

    register long sz;		/* size of desired block */

    long amt;			/* amount to allocate */

    int nblks;			/* how many blocks we get */

    struct block *blockPtr;

    /*

     * sbrk_size <= 0 only for big, FLUFFY, requests (about

     * 2^30 bytes on a VAX, I think) or for a negative arg.

     */

    sz = 1 << (bucket + 3);

    ASSERT(sz > 0);

    amt = MAXMALLOC;

    nblks = amt / sz;

    ASSERT(nblks*sz == amt);

    blockPtr = (struct block *) TclpSysAlloc((unsigned) 

	    (sizeof(struct block) + amt), 1);

    /* no more room! */

    if (blockPtr == NULL) {

	return;

    }

    blockPtr->nextPtr = blockList;

    blockList = blockPtr;

    op = (union overhead *) (blockPtr + 1);

    /*

     * Add new memory allocated to that on

     * free list for this hash bucket.

     */

    nextf[bucket] = op;

    while (--nblks > 0) {

	op->ov_next = (union overhead *)((caddr_t)op + sz);

	op = (union overhead *)((caddr_t)op + sz);

    }

    op->ov_next = (union overhead *)NULL;

}

/*

 *----------------------------------------------------------------------

 *

 * TclpFree --

 *

 *	Free memory.

 *

 * Results:

 *	None.

 *

 * Side effects:

 *	None.

 *

 *----------------------------------------------------------------------

 */

void

TclpFree(cp)

    char *cp;		/* Pointer to memory to free. */

{   

    register long size;

    register union overhead *op;

    struct block *bigBlockPtr;

    if (cp == NULL) {

	return;

    }

    Tcl_MutexLock(allocMutexPtr);

    op = (union overhead *)((caddr_t)cp - sizeof (union overhead));

    ASSERT(op->ov_magic0 == MAGIC);		/* make sure it was in use */

    ASSERT(op->ov_magic1 == MAGIC);

    if (op->ov_magic0 != MAGIC || op->ov_magic1 != MAGIC) {

	Tcl_MutexUnlock(allocMutexPtr);

	return;

    }

    RANGE_ASSERT(op->ov_rmagic == RMAGIC);

    RANGE_ASSERT(*(unsigned short *)((caddr_t)(op + 1) + op->ov_size) == RMAGIC);

    size = op->ov_index;

    if ( size == 0xff ) {

#ifdef MSTATS

	nmalloc[NBUCKETS]--;

#endif

	bigBlockPtr = (struct block *) op - 1;

	bigBlockPtr->prevPtr->nextPtr = bigBlockPtr->nextPtr;

	bigBlockPtr->nextPtr->prevPtr = bigBlockPtr->prevPtr;

	TclpSysFree(bigBlockPtr);

	Tcl_MutexUnlock(allocMutexPtr);

	return;

    }

    ASSERT(size < NBUCKETS);

    op->ov_next = nextf[size];	/* also clobbers ov_magic */

    nextf[size] = op;

#ifdef MSTATS

    nmalloc[size]--;

#endif

    Tcl_MutexUnlock(allocMutexPtr);

}

/*

 *----------------------------------------------------------------------

 *

 * TclpRealloc --

 *

 *	Reallocate memory.

 *

 * Results:

 *	None.

 *

 * Side effects:

 *	None.

 *

 *----------------------------------------------------------------------

 */

char *

TclpRealloc(cp, nbytes)

    char *cp;			/* Pointer to alloced block. */

    unsigned int nbytes;	/* New size of memory. */

{   

    int i;

    union overhead *op;

    struct block *bigBlockPtr;

    int expensive;

    unsigned long maxsize;

    if (cp == NULL) {

	return (TclpAlloc(nbytes));

    }

    Tcl_MutexLock(allocMutexPtr);

    op = (union overhead *)((caddr_t)cp - sizeof (union overhead));

    ASSERT(op->ov_magic0 == MAGIC);		/* make sure it was in use */

    ASSERT(op->ov_magic1 == MAGIC);

    if (op->ov_magic0 != MAGIC || op->ov_magic1 != MAGIC) {

	Tcl_MutexUnlock(allocMutexPtr);

	return NULL;

    }

    RANGE_ASSERT(op->ov_rmagic == RMAGIC);