#include <malloc.h>
#include "lisp.h"

/* storage module for SIMULISP */

#define PAGEINCR 16		/* number of pages to snarf at a time */
#define NBYTES 4192		/* no. of bytes to allocate for byte pool */

objptr fr_ptr[NTYPES];		/* linked free lists for each type */
char o_size[NTYPES] =		/* # of objects that make up each type */
  { 0, 0, FLOSIZE, SYMSIZE, CONSSIZE, 0, 0, 0, 0 };

struct Cons nil_proto;		/* actual abode of nil */
object nil;

page *fr_pgs;			/* linked list of free pages */

char *by_pool;			/* pointer to current byte pool */
int by_index;

/* gc'able pages are remembered in a table which is itself a linked
 * list of pages -- the first entry in each page points to the next
 * page in the list, if any.
 */
page *gc_pages;			/* ptr to current page in gc page list */
int gc_index;			/* index to last used entry in current page */

/* init storage data bases */
i_storage()
  {	register int i;
	register cons *n = &nil_proto;
	register value sunn;	/* for sun unix cc bug */

	for (i=0; i<NTYPES; i++) fr_ptr[i] = NULL;
	fr_pgs = NULL;
	gc_pages = NULL;
	gc_index = 0;
	by_pool = NULL;
	by_index = 0;

	/* set up cons cell for nil; both car and cdr of nil are nil */
	SETVALUE(nil,(sunn = (value)n));
	SETTYPE(nil,CONS);
	n->car = nil;
	n->cdr = nil;
}

/* allocate a page -- gctype<>0 if page should be swept during garbage
 * collection.
 */
page *al_page(gctype)
  int gctype;
  {	register page *nextpage = fr_pgs;
	register int sunnextpage;	/* sun unix cc bug */

	register page *temp;
	object p = NULL;
	register int i;
	int amount = PAGEINCR*OBJPAGESIZE*sizeof(object);

	/* if no more pages, allocate another batch from the system */
	if (nextpage == NULL) {
	  fr_pgs = (page *)malloc(amount);
	  if (fr_pgs == NULL)
	    { lprintf(stderr,"Out of room\n"); exit(-1); }
	  for (i=0, temp=NULL, nextpage = fr_pgs; i<PAGEINCR-1; i++) {
	    (*nextpage)[0] = (object)temp;
	    temp = nextpage++;
	  }
	  fr_pgs = temp;
	} else fr_pgs = (page *)((*nextpage)[0]);

	/* if we should sweep page during a gc, add it to our list */
	if (gctype) {
	  if (gc_index==OBJPAGESIZE || gc_pages==NULL) {
	    temp = al_page(0);
	    (*temp)[0] = (object)gc_pages;
	    gc_pages = temp;
	    gc_index = 1;
	  }
	  SETVALUE(p,(sunnextpage = (int)nextpage));
	  SETTYPE(p,gctype);
	  (*gc_pages)[gc_index++] = p;
	}

	return(nextpage);
}

/* return page to free list */
fr_page(rpage)
  register page *rpage;
  {	(*rpage)[0] = (object)fr_pgs;
	fr_pgs = rpage;
}

char *tname[] = {
  "FREE", "FIXNUM", "FLONUM", "SYMBOL", "CONS", "SUBR", "STRING", "NODE", "TRANS" };

/* allocate an object of the specified type and return it */
object al_obj(type)
  int type;
  {	register objptr obj,temp;
	register int suntemp;	/* sun unix cc bug */
	register int size,i,num;
	register char *p;
	object ans = NULL;

	SETTYPE(ans,type);

	/* complain if type doesn't require allocation */
	size = o_size[type];
	if (size == 0) {
	  lprintf(stderr,"Bad type in alloc_obj (%d)\n",type);
	  return(NULL);
	}

	/* try to allocate obj from free list */
	if (obj = fr_ptr[type])
	  {fr_ptr[type] = (objptr)ADDR(*obj); goto done; }

	/* if empty, try a garbage collection */
	gc();

	/* try to allocate obj from free list once again*/
	if (obj = fr_ptr[type])
	  { fr_ptr[type] = (objptr)ADDR(*obj); goto done; }

	/* looks like we need some more storage */
	obj = (objptr)al_page(type);
	num = OBJPAGESIZE/size - 1;
	for (i = 0, temp = NULL; i < num; i++)
	  { SETVALUE(*obj,(suntemp = (int)temp)); temp = obj; obj += size; }
	fr_ptr[type] = temp;

done:	SETVALUE(ans,(suntemp = (int)obj));
	p = (char *)obj;
	size *= sizeof(object);
	while (size--) *p++ = 0;
	return(ans);
}

/* allocate n bytes */
char *al_bytes(n)
  register int n;
  {	int amount = NBYTES;
	register char *p;

	n = (n+1) & ~1;
	if (n > NBYTES) amount = n;
	if (n>NBYTES-by_index || by_pool==NULL) {
	  if ((by_pool = malloc(amount)) == NULL)
	    { lprintf(stderr,"Out of room\n"); exit(-1); }
	  by_index = 0;
	}
	p = &by_pool[by_index];
	by_index += n;
	return(p);
}

/* recursively mark an object's components */
m_obj(obj)
  object obj;
  {	register objptr val = (objptr)ADDR(obj);

	switch (TYPE(obj)) {
	  default:	return;

	  case CONS:	if (MARKED(*val)) return;
			SETGCBIT(*val);
			m_obj(((cons *)val)->car);
			m_obj(((cons *)val)->cdr);
			return;

	  case FLONUM:	SETGCBIT(*val);
			return;

	  case SYMBOL:	if (MARKED(*val)) return;
			SETGCBIT(*val);
			m_obj(((symbol *)val)->sym_value);
			m_obj(((symbol *)val)->sym_function);
			m_obj(((symbol *)val)->sym_plist);
			m_obj(((symbol *)val)->sym_pname);
			m_obj(((symbol *)val)->sym_hlink);
			return;
	}
}

/* sweep a page of the specified type */
sweep_page(ptr,type)
  register objptr ptr;
  int type;
  {	register int size = o_size[type];
	register int num = OBJPAGESIZE/size;
	register int i;
	register int sunptr;	/* sun unix cc bug */

	while (num-- > 0) {
	  if (!MARKED(*ptr)) {
	    SETVALUE(*ptr, (sunptr = (int)fr_ptr[type]));
	    fr_ptr[type] = ptr;
	    ptr += size;
	  } else if (type == FLONUM) {
	    CLEARGCBIT(*ptr);
	    ptr += size;
	  } else for (i=size; i-- > 0;) CLEARGCBIT(*ptr++);
	}
}

/* garbage collector */
gc()
  {	register page *current;
	register int index;
	register cons *n = &nil_proto;
	object temp;

	/* first mark all reachable objects */
	m_stack();
	m_obarray();

	/* we'll be reconstructing free lists from scratch */
	for (index=0; index<NTYPES; index++) fr_ptr[index] = NULL;

	/* now sweep through all gc'able pages collecting garbage */
	current = gc_pages;
	index = gc_index;
	while (current != NULL) {
	  while (--index) {
	    temp = (*current)[index];
	    sweep_page(ADDR(temp),TYPE(temp));
	  }
	  current = (page *)((*current)[0]);
	  index = OBJPAGESIZE;
	}

	/* turn off gc bit in nil prototype */
	CLEARGCBIT(n->car);
	CLEARGCBIT(n->cdr);
}