/* Copyright 1989-93 GROUPE BULL -- See license conditions in file COPYRIGHT */
/******************************************************\
* 						       *
* reference.c:					       *
* reference count management and other storage issues  *
* 						       *
\******************************************************/

#include        "EXTERN.h"
#include 	"klone.h"
#ifdef DEBUG2
#include "kl_atom.h"
KlO *KlCurrentZrt;
#include "kl_string.h"
#include "kl_stream.h"
#endif
#ifdef STATS
#include "kl_string.h"
#include "kl_stream.h"
#endif

void KlChildDeathProcess();

/*
 * The memory management of KLONE is implemented via a differed reference
 * count. That, each time an object's reference count attains 0, it is put in
 * the KlZrt, which is polled at regular intervals
 */

/*************************************\
*                                     *
* Zero_reference table module (KlZrt) *
*                                     *
\*************************************/

/*
 * The KlZrt (Zero Reference Table) global structure  is used to mark ALL wobs
 * that have at any moment be of KlRef 0, that is either being created or via
 * KlDecRef.  Then you can call KlZrtGc at strategic moments, (ie in
 * no enclosing KLONE function) to free all the zero-referenced objects in the
 * KlZrt.
 * To perform a GC you should use the macros KlGCMark / KlGC to only perform
 * GC on the current generation of scoped objects. 
 */

#ifdef STATS
KlO
zrtstats()
{
    KlPrintf("Zero-reference-table has %d", KlZrtLast - KlZrt);
    KlPrintf("/%d slots\n", KlZrtSizeLimit);
    return NIL;
}

#endif					/* STATS */

KlZrtInit()
{
    KlZrtSizeLimit = 63;			/* pow(2,n)/4 -1 */
    KlZrt = (KlO *) Malloc(KlZrtSizeLimit * sizeof(KlO));
    KlZrtLast = KlZrt;
    KlZrtLimit = KlZrt + KlZrtSizeLimit;
    KlZrtFrom = 0;
}

/* disposes really of objects stacked in KlZrt. 
 * Be warned that a KlSelFree might trigger KlZrtPut during the KlZrtGc !
 *
 * KlZrtPut may trigger reallocation of Zrt, so KlZrtFrom and KlZrtLast 
 * are globals so they can be updated transparently
 */

#ifdef DEBUG2
#define GCDEBUG
#endif

#ifdef GCDEBUG
#include "kl_func.h"
#undef KlSend_free(o)

void
KlSend_free(obj)
    KlO obj;
{
    KlO *p = KlStack + KlStackPtr;

    /* check we dont free an object in the stack */
    while (p > KlStack) {
	if (*p-- == obj) {
	    stop_if_in_dbx("Freeing an object in the stack!");
	    return;
	}
    }
#ifdef TRACEALL
    {
	static int KlFreeCount;
	fprintf(stderr, "KlFreeCount = %d, obj = 0x%lx\n", KlFreeCount, obj);
	KlFreeCount++;
    }
#endif
    KlSend(KlSelFree, obj, (obj));	/* DO NOT REDEFINE AS KlSend_free!!! */
}
#endif /* GCDEBUG */

KlZrtGc(from)
    Int from;
{
    if (KlZrtFrom) {
	/* we are already GCing. We cannot thus use KlZrtFrom which is global,
	 * but we must take care of possible reallocs of the Zrt, moving it
	 */
	while (KlZrtLast > KlZrt + from) {
	    if ((*(--KlZrtLast))->reference_count) {
		/* somebody claimed it, ok, graduate to normal object */
		(*KlZrtLast)->reference_count |= 1;
	    } else {
		/* last call! Nobody? Ok, smithe it */
#ifdef KlHOOK_NUMBER
		KlFreeHooks(*KlZrtLast);
#endif
		KlSend_free(*KlZrtLast);
	    }
	}
    } else {				/* toplevel GC */
	KlZrtFrom = KlZrt + from;
	while (KlZrtLast > KlZrtFrom) {
	    if ((*(--KlZrtLast))->reference_count) {
		/* somebody claimed it, ok, graduate to normal object */
		(*KlZrtLast)->reference_count |= 1;
	    } else {
		/* last call! Nobody? Ok, smithe it */
#ifdef KlHOOK_NUMBER
		KlFreeHooks(*KlZrtLast);
#endif
		KlSend_free(*KlZrtLast);
	    }
	}
	KlZrtFrom = 0;			/* to indicate we are done */
    }

    if (KlChildDeathReported)
	KlChildDeathProcess();
}

/*
 * Never call KlZrtPut if obj was already in it (should not happen)
 */

KlZrtPut(obj)
    KlO obj;
{
#ifdef DEBUG2
    KlMustNotBeInZrt(obj);
#endif /* DEBUG2 */
    if (KlZrtLast >= KlZrtLimit) {
	KlO *oldZrt = KlZrt;
#ifdef MLEAK
	extern int MLEAK_on;
	int old_mlo = MLEAK_on;
	MLEAK_on = 0;
#endif MLEAK
	KlZrtSizeLimit = (KlZrtSizeLimit + 1) * 2 - 1;
	KlZrt = (KlO *) Realloc(KlZrt, KlZrtSizeLimit * sizeof(KlO));
	KlZrtLast = KlZrt + (KlZrtLast - oldZrt);
	if (KlZrtFrom)
	    KlZrtFrom = KlZrt + (KlZrtFrom - oldZrt);
	KlZrtLimit = KlZrt + KlZrtSizeLimit;
#ifdef MLEAK
	MLEAK_on = old_mlo;
#endif /* MLEAK */
    }
    (*(KlZrtLast++) = obj)->reference_count = 0;
}

#ifdef DEBUG2
/* checks that the element is not in fact already in the KlZrt...
 */

KlMustNotBeInZrt(obj)
    KlO obj;
{
    KlO *zrt_ptr = KlZrt;
    KlO *zrtlast = KlZrtLast;

    while (zrt_ptr < zrtlast) {
	if (*zrt_ptr == obj) {
	    KlPrintf("at KlZrt[%d]", zrtlast - KlZrt);
	    KlPrintf(" and KlZrt[%d], type: ", zrt_ptr - KlZrt);
	    if (KlObjectIsValid(obj)) {
		KlPrint(KlTypeName(obj->type));
		KlPuts(", obj: ");
		KlPrint(obj);
	    } else {
		KlPrintf(" NON-KLO at 0x%x", obj);
		stop_if_in_dbx("NON-KLO in ZRT!!!");
		obj = NIL;		/* for not crashing KlError print */
	    }
	    KlNewline();
	    KlPrintf("object 0x%x was already in KlZrt!\n", obj);
	    stop_if_in_dbx("Already in ZRT!");
	}
	zrt_ptr++;
    }
}

#endif					/* DEBUG2	     */

/***********************\
* 		        *
* reference management  *
* 		        *
\***********************/

/* KlIncRef is a macro (KlRef(x)++) */

#ifdef DEBUGREF				/* macro otherwise */
KlIncRef(obj)
    KlO obj;				/* obj may be KlUndef */
{
    KlRef(obj) += 2;
}

KlIncRefOrNull(obj)
    KlO obj;				/* obj may be KlUndef */
{
    if (obj)
	KlRef(obj) += 2;
}

KlDecRef(obj)
    KlO obj;				/* obj may be KlUndef */
{
    if (obj) {
	KlDecRefNonNull(obj);
    }
}

KlDecRefNonNull(obj)
    KlO obj;				/* obj must be non-nil */
{
    if (((obj->reference_count) -= 2) == 1)
	KlZrtPut(obj);
    else if (obj->reference_count < 0) {
	printf("INTERNAL ERROR: negative reference_count: %d, obj 0x%x\n",
	       obj->reference_count, obj);
	stop_if_in_dbx("negative reference_count!");
	/* if we are not in dbx, try to fix things and continue */
	if (KlIsActuallyInZrt(obj)) {
	    obj->reference_count = 0;
	} else {
	    KlZrtPut(obj);
	}
    }
}

int
KlIsActuallyInZrt(obj)
    KlO obj;
{
    KlO *zrt_ptr = KlZrt;
    KlO *zrtlast = KlZrtLast;

    while (zrt_ptr < zrtlast) {
	if (*zrt_ptr == obj) {
	    return 1;
	}
	zrt_ptr++;
    }
    return 0;
}


#endif					/* DEBUGREF */

/*
 * KlDecRefList:
 * decrease reference count of all the elements of the list.
 * but doesn't free the list.
 */

KlDecRefList(count, list)
    int count;
    KlO *list;
{
    KlO *last = list + count;

    while (list < last) {
	KlDecRef(*list);
	list++;
    }
}

/*
 * duplicate an array of objects, increasing the reference count,
 * and mallocing
 */

KlDuplicateNObjects(source, dest, n)
    KlO *source;			/* source is the array */
    KlO **dest;				/* while dest is a POINTER to the
					 * array */
    int n;				/* how many to copy */
{
    KlO *p = source, *q, *last = source + n;

    q = *dest = (KlO *) Malloc(sizeof(KlO) * n);
    while (p < last)
	KlIncRef(*q++ = *p++);
}

/*
 * duplicate an array of objects, increasing the reference count,
 * without mallocing (dest already points to an malloced aera)
 */

KlCopyNObjects(source, dest, n)
    KlO *source;			/* source is the array */
    KlO *dest;				/* dest is  the array */
    int n;				/* how many to copy */
{
    KlO *p = source, *q = dest, *last = source + n;

    while (p < last)
	KlIncRef(*q++ = *p++);
}

/* KlSetField
 * sets a Klone object to a memeory location, managing the reference counts
 */

void
KlSetField(ptr, value)
    KlO *ptr;
    KlO value;
{
    KlDecRef(*ptr);
    KlIncRef(*ptr = value);
}