[unix-history] / usr / src / cmd / lisp / Talloc.c

# include "global.h"

# define NUMWORDS TTSIZE * 128  /*  max number of words in P0 space  */
# define BITQUADS TTSIZE * 2	/*  length of bit map in quad words  */

# define ftstbit	asm("	ashl	$-2,r11,r3");\
			asm("	bbcs	r3,_bitmapq,$1");\
			asm("	.byte	4");
/*  define ftstbit	if( readbit(p) ) return; oksetbit;  */
# define readbit(p)	((int)bitmap[r=(int)p>>5] & (s=bitmsk[((int)p>>2)&7]))
# define lookbit(p)	(bitmap[(int)p>>5] & bitmsk[((int)p>>2) & 7])
# define setbit(p)	{bitmap[(int)p>>5] |= bitmsk[((int)p >> 2) & 7];}
# define oksetbit	{bitmap[r] |= s;}

# define readchk(p)	((int)bitfre[(int)p>>5] & bitmsk[((int)p>>2)&7])
# define setchk(p)	{bitfre[(int)p>>5] |= bitmsk[((int)p >> 2) & 7];}

struct heads {
	struct heads *link;
	char *pntr;
}  header[TTSIZE];

FILE * chkport;				/* garbage collection dump file */
lispval datalim;			/*  end of data space */
double bitmapq[BITQUADS];		/*  the bit map--one bit per long  */
double zeroq;				/*  a quad word of zeros  */
char *bitmap = (char *) bitmapq;	/*  byte version of bit map array */
char bitmsk[8]={1,2,4,8,16,32,64,128};  /*  used by bit-marking macros  */
int  *bind_lists = (int *) CNIL;	/*  lisp data for compiled code */

char *xsbrk();


int atmlen;

struct types {
char	*next_free;
int	space_left,
	space,
	type,
	type_len;			/*  note type_len is in units of int */
lispval *items,
	*pages,
	*type_name;
struct heads
	*first;
} atom_str = {(char *)CNIL,0,ATOMSPP,ATOM,5,&atom_items,&atom_pages,&atom_name,(struct heads *)CNIL},
  strng_str    = {(char *)CNIL,0,STRSPP,STRNG,1,&str_items,&str_pages,&str_name,(struct heads *)CNIL},
  int_str  = {(char *)CNIL,0,INTSPP,INT,1,&int_items,&int_pages,&int_name,(struct heads *)CNIL},
  dtpr_str = {(char *)CNIL,0,DTPRSPP,DTPR,2,&dtpr_items,&dtpr_pages,&dtpr_name,(struct heads *)CNIL},
  doub_str     = {(char *)CNIL,0,DOUBSPP,DOUB,2,&doub_items,&doub_pages,&doub_name,(struct heads *)CNIL},
  array_str   = {(char *)CNIL,0,ARRAYSPP,ARRAY,5,&array_items,&array_pages,&array_name,(struct heads *)CNIL},
  sdot_str = {(char *)CNIL,0,SDOTSPP,SDOT,2,&sdot_items,&sdot_pages,&sdot_name,(struct heads *)CNIL},
  val_str  = {(char *)CNIL,0,VALSPP,VALUE,1,&val_items,&val_pages,&val_name,(struct heads *)CNIL},
  funct_str = {(char *)CNIL,0,BCDSPP,BCD,2,&funct_items,&funct_pages,&funct_name,(struct heads *)CNIL};

extern int initflag; /* starts off TRUE: initially gc not allowed */

int gcflag = FALSE;	/*  TRUE during garbage collection  */

int current = 0;	/* number of pages currently allocated */

#define NUMSPACES 9

static struct types *(spaces[NUMSPACES]) = 
	{&atom_str, &strng_str, &int_str,
	 &dtpr_str, &doub_str, &array_str,
	 &sdot_str, &val_str, &funct_str};


/** get_more_space(type_struct) *****************************************/
/*									*/
/*  Allocates and structures a new page, returning 0.			*/
/*  If no space is available, returns 1.				*/

get_more_space(type_struct)                                 
struct types *type_struct;
{
	int cntr;
	char *start;
	int *loop, *temp;
	lispval p, plim;
	struct heads *next;

	if(initflag == FALSE) 
		/*  mustn't look at plist of plima too soon  */
		{
		while( plim=copval(plima,(lispval)CNIL), TYPE(plim)!=INT )
			copval(plima,error("BAD PAGE LIMIT",TRUE));
		if( plim->i <= current ) return(1);	/*  Can't allocate  */
		}

	if( current >= TTSIZE ) return(2);

	start = xsbrk( NBPG );

	/* bump the page counter for this space */

	++((*(type_struct->pages))->i);

	SETTYPE(start, type_struct->type);  /*  set type of page  */

	type_struct->space_left = type_struct->space;
	next = &header[ current++ ];
	if ((type_struct->type)==STRNG)
		{
		type_struct->next_free = start;
		return(0);  /*  space was available  */
		}
	next->pntr = start;
	next->link = type_struct->first;
	type_struct->first = next;
	temp = loop = (int *) start;
	for(cntr=1; cntr < type_struct->space; cntr++)
		loop = (int *) (*loop = (int) (loop + type_struct->type_len));
	*loop = (int) (type_struct->next_free);
	type_struct->next_free = (char *) temp;

	/*  if type atom, set pnames to CNIL  */

	if( type_struct == &atom_str )
		for(cntr=0, p=(lispval) temp; cntr<atom_str.space; ++cntr)
			{
			p->pname = (char *) CNIL;
			p = (lispval) ((int *)p + atom_str.type_len);
			}
	return(0);  /*  space was available  */
}


/** next_one(type_struct) ************************************************/
/*									*/
/*  Allocates one new item of each kind of space, except STRNG.		*/
/*  If there is no space, calls gc, the garbage collector.		*/
/*  If there is still no space, allocates a new page using		*/
/*  get_more_space(type_struct)						*/

lispval
next_one(type_struct)
struct types *type_struct;
{

	register char *temp;
	snpand(1);

	while(type_struct->next_free == (char *) CNIL)
		{
		int g;

		if((type_struct->type != ATOM) &&   /* can't collect atoms */
		   (type_struct->type != STRNG) &&  /* can't collect strings */
		   (gcthresh->i <= current) &&       /* threshhold for gc */
		   ISNIL(copval(gcdis,CNIL)) &&	  /* gc not disabled */
		   (NOTNIL(copval(gcload,CNIL)) || (loading->clb != tatom)) &&
					/* not to collect during load */
		   (initflag == FALSE) &&	/* dont gc during init */
		   (gcflag == FALSE))		  /* don't recurse gc */

			{
			/* fputs("Collecting",poport);
			dmpport(poport);*/
			gc(type_struct);  /*  collect  */
			}

		if( type_struct->next_free != (char *) CNIL ) break;

		if(! (g=get_more_space(type_struct))) break;

		if( g==1 )
			{
			plimit->i = current+NUMSPACES;
				/*  allow a few more pages  */
			copval(plima,plimit);	/*  restore to reserved reg  */

			error("PAGE LIMIT EXCEEDED--EMERGENCY PAGES ALLOCATED",
				TRUE);
			}
		else error("SORRY, ABSOLUTE PAGE LIMIT HAS BEEN REACHED",
				TRUE);
		}

	temp = type_struct->next_free;
	type_struct->next_free = * (char **)(type_struct->next_free);
	return((lispval) temp);
}

lispval
newint()
{
	++(int_items->i);
	return(next_one(&int_str));
}

lispval
newdot()
{
	lispval temp;

	++(dtpr_items->i);
	temp = next_one(&dtpr_str);
	temp->car = temp->cdr = nil;
	return(temp);
}

lispval
newdoub()
{
	++(doub_items->i);
	return(next_one(&doub_str));
}

lispval
newsdot()
{
	register lispval temp;
	++(dtpr_items->i);
	temp = next_one(&sdot_str);
	temp->car = temp->cdr = 0;
	return(temp);
}

struct atom *newatom() {
	struct atom *save;

	++(atom_items->i);
	save = (struct atom *) next_one(&atom_str) ;	
	save->plist = save->fnbnd = nil;
	save->hshlnk = (struct atom *)CNIL;
	save->clb = CNIL;
	save->pname = newstr();
	return (save);
}

char *newstr() {
	char *save;
	int atmlen2;

	++(str_items->i);
	atmlen = strlen(strbuf)+1;
	if(atmlen > strng_str.space_left)
		while(get_more_space(&strng_str))
			error("YOU HAVE RUN OUT OF SPACE",TRUE);
	strcpy((save = strng_str.next_free), strbuf);
	atmlen2 = atmlen;
	while(atmlen2 % 4) ++atmlen2;	/*  even up length of string  */
	strng_str.next_free += atmlen2;
	strng_str.space_left -= atmlen2;
	return(save);
}

char *inewstr(s) char *s;
{
	strbuf[STRBLEN-1] = '\0';
	strcpyn(strbuf,s,STRBLEN-1);
	return(newstr());
}

lispval
newarray()
	{
	register lispval temp;
	++(array_items->i);
	temp = next_one(&array_str);
	temp->data = (char *)nil;
	temp->accfun = nil;
	temp->aux = nil;
	temp->length = SMALL(0);
	temp->delta = SMALL(0);
	return(temp);
	}

lispval
badcall()
	{ error("BAD FUNCTION DESCRIPTOR USED IN CALL",FALSE); }

lispval
newfunct()
	{
	register lispval temp;
	++(funct_items->i);
	temp = next_one(&funct_str);
	temp->entry = badcall;
	temp->discipline = nil;
	return(temp);
	}

lispval
newval()
	{
	register lispval temp;
	++(val_items->i);
	temp = next_one(&val_str);
	temp->l = nil;
	return(temp);
	}

lispval
inewval(arg) lispval arg;
	{
	lispval temp;
	++(val_items->i);
	temp = next_one(&val_str);
	temp->l = arg;
	return(temp);
	}

/** Ngc *****************************************************************/
/*									*/
/*  LISP interface to gc.						*/

lispval Ngc()
	{
	lispval temp;

	if( ISNIL(lbot->val) ) return(gc(CNIL));

	if( TYPE(lbot->val) != DTPR ) error("BAD CALL TO GC",FALSE);

	chkport = poport;

	if( NOTNIL(lbot->val->car) )
		{
		temp = eval(lbot->val->car);
		if( TYPE(temp) == PORT ) chkport = (FILE *)*temp;
		}

	gc1(TRUE);

	return(nil);
	}

/** gc(type_struct) *****************************************************/
/*									*/
/*  garbage collector:  Collects garbage by mark and sweep algorithm.	*/
/*  After this is done, calls the Nlambda, gcafter.			*/
/*  gc may also be called from LISP, as a lambda of no arguments.	*/

lispval
gc(type_struct)
	struct types *type_struct;
	{
	lispval save;
	struct {
		long mytime;
		long allelse[3];
	} begin, finish;
	extern int GCtime;

	save = copval(gcport,CNIL);
	if(GCtime)
		times(&begin);

	while( (TYPE(save) != PORT) && NOTNIL(save))
		save = error("NEED PORT FOR GC",TRUE);

	chkport = ISNIL(save) ? poport : (FILE *)*save;
	
	gc1(NOTNIL(copval(gccheck,CNIL)) || (chkport!=poport)); /* mark&sweep */

	/* Now we call gcafter--special case if gc called from LISP */

	if( type_struct == (struct types *) CNIL )
		gccall1->cdr = nil;  /* make the call "(gcafter)" */
	else
		{
		gccall1->cdr = gccall2;
		gccall2->car = *(type_struct->type_name);
		}
	gcflag = TRUE;		/*  flag to indicate in garbage collector  */
	save = eval(gccall1);	/*  call gcafter  */
	gcflag = FALSE;		/*  turn off flag  */

	if(GCtime) {
		times(&finish);
		GCtime += (finish.mytime - begin.mytime);
	}
	return(save);	/*  return result of gcafter  */
	}

	
/*  gc1()  **************************************************************/
/*									*/
/*  Mark-and-sweep phase						*/

gc1(chkflag) int chkflag;
	{
	int i, j, typep;
	register int *start, *point;
	struct types *s;
	struct heads *loop;
	struct argent *loop2;
	int markdp();

	
	/*  decide whether to check LISP structure or not  */


	/*  first set all bit maps to zero  */

	for(i=0; i<((int)datalim >> 8); ++i) bitmapq[i] = zeroq;


	/* then mark all atoms' plists, clbs, and function bindings */

	for(loop=atom_str.first; loop!=(struct heads *)CNIL; loop=loop->link)
		for(start=(int *)(loop->pntr), i=1;
			i <= atom_str.space;
			start = start + atom_str.type_len, ++i)
			{

			/* unused atoms are marked with pname == CNIL */
			/* this is done by get_more_space, as well as */
			/* by gc (in the future)		      */

			if(((lispval)start)->pname == (char *)CNIL) continue;
#define MARKSUB(p)	if(nil!=((lispval)start)->p)markdp(((lispval)start)->p);
			MARKSUB(clb);
			MARKSUB(fnbnd);
			MARKSUB(plist);
			}

	/* next run up the name stack */

	for(loop2 = np - 1; loop2 >=  orgnp; --loop2) markdp((loop2->val));	
	/* from TBL 29july79  */
	/* next mark all compiler linked data */
	point = bind_lists;
	while((start = point) != (int *)CNIL) {
		while( *start != -1 )
			markdp(*start++);
		point = (int *)*(point-1);
	}
	/* end from TBL */

	/* next mark all system-significant lisp data */

	for(i=0; i<SIGNIF; ++i) markdp((lispsys[i]));

	/* all accessible data has now been marked. */
	/* all collectable spaces must be swept,    */
	/* and freelists constructed.		    */

	for(i=0; i<NUMSPACES; ++i)
		{
		/* STRINGS do not participate. */
		/* ATOMS dont either (currently) */

		s = spaces[i];
		typep = s->type;
		if((typep==STRNG) || (typep==ATOM)) continue;

		s->space_left = 0;  /* we will count free cells */
		(*(s->items))->i = 0;    /* and compute cells used    */

		/* for each space, traverse list of pages. */

		s->next_free = (char *) CNIL;	/*  reinitialize free list  */

		for(loop = s->first; loop != (struct heads *) CNIL; loop=loop->link)
			{
			/* add another page's worth to use count */

			(*(s->items))->i  += s->space;

			/* for each page, make a list of unmarked data */

			for(j=0, point=(int *)(loop->pntr);
				j<s->space; ++j, point += s->type_len)
				if( ! lookbit(point) )
					{
						/* add to free list */
						/* update pointer to free list*/
						/* update count of free list */

					*point = (int)(s->next_free);
					s->next_free = (char *) point;
					++(s->space_left);
					}
			}
		(*(s->items))->i -= s->space_left;	/* compute cells used */
		}
}

/** alloc() *************************************************************/
/*									*/
/*  This routine tries to allocate one more page of the space named	*/
/*  by the argument.  If no more space is available returns 1, else 0.	*/

lispval
alloc(tname,npages)
	lispval tname; int npages;
	{
	int ii, jj;

	ii = typenum(tname);

	for( jj=0; jj<npages; ++jj)
		if(get_more_space(spaces[ii])) break;
	return(inewint(jj));
	}

lispval
csegment(tname,nitems)
lispval tname; int nitems;
	{
	int ii, jj;
	char *charadd;

	ii = typenum(tname);

	nitems = nitems*4*spaces[ii]->type_len;	/*  find c-length of space  */
	while( nitems%512 ) ++nitems;		/*  round up to right length  */
	current += nitems/512;
	charadd = sbrk(nitems);
	if( (int) charadd == 0 )
		error("NOT ENOUGH SPACE FOR ARRAY",FALSE);
	(datalim = (lispval)(charadd+nitems));
	if((((int)datalim) >> 9) > TTSIZE) {
		datalim = (lispval) (TTSIZE << 9);
		badmem(53);
	}
	for(jj=0; jj<nitems; jj=jj+512) {
		SETTYPE(charadd+jj, spaces[ii]->type);
	}
	return((lispval)charadd);
	}

int csizeof(tname) lispval tname;
	{
	return( spaces[typenum(tname)]->type_len * 4 );
	}

int typenum(tname) lispval tname;
	{
	int ii;

chek:	for(ii=0; ii<NUMSPACES; ++ii)
		if(tname == *(spaces[ii]->type_name)) break;
	if(ii == NUMSPACES)
		{
		tname = error("BAD TYPE NAME",TRUE);
		goto chek;
		}

	return(ii);
	}

/** markit(p) ***********************************************************/
/*  just calls markdp							*/

markit(p) lispval *p; { markdp(*p); }

/** markdp(p) ***********************************************************/
/*									*/
/*  markdp is the routine which marks each data item.  If it is a	*/
/*  dotted pair, the car and cdr are marked also.			*/
/*  An iterative method is used to mark list structure, to avoid	*/
/*  excessive recursion.						*/


markdp(p) register lispval p;
	{
/*	register int r, s;	(goes with non-asm readbit, oksetbit)	*/

ptr_loop:
	if((int)p <= 0) return;	/*  do not mark special data types or nil=0  */

	switch( TYPE(p) )
		{
		case INT:
		case DOUB:
/*			setbit(p);*/
			ftstbit;
			return;
		case VALUE:
			ftstbit;
			p = p->l;
			goto ptr_loop;
		case DTPR:
			ftstbit;
			markdp(p->car);
			p = p->cdr;
			goto ptr_loop;

		case ARRAY:
			ftstbit;	/* mark array itself */

			markdp(p->accfun);	/* mark access function */
			markdp(p->aux);		/* mark aux data */
			markdp(p->length);	/* mark length */
			markdp(p->delta);	/* mark delta */

			{
			register int i, l; int d;
			register char *dataptr = p->data;

			for(i=0, l=p->length->i, d=p->delta->i; i<l; ++i)
				{
				markdp(dataptr);
				dataptr += d;
				}
			return;
			}
		case SDOT:
			do {
				ftstbit;
				p = p->CDR;
			} while (p!=0);
			return;

		case BCD:
			ftstbit;
			markdp(p->discipline);
			return;
		}
	return;
	}


char *
xsbrk()
	{
	static char *xx;	/*  pointer to next available blank page  */
	static int cycle = 0;	/*  number of blank pages available  */
	lispval u;			/*  used to compute limits of bit table  */

	if( (cycle--) <= 0 )
		{
		cycle = 15;
		xx = sbrk(16*NBPG);	/*  get pages 16 at a time  */
		if( (int)xx== -1 )
			lispend("For sbrk from lisp: no space... Goodbye!");
		goto done;
		}
	xx += NBPG;
done:	if( (u = (lispval)(xx+NBPG))  > datalim ) datalim = u;
	return(xx);
	}

char *ysbrk(pages,type) int pages, type;
	{
	char *xx;	/*  will point to block of storage  */
	int i;

	xx = sbrk(pages*NBPG);
	if((int)xx == -1)
		error("OUT OF SPACE FOR ARRAY REQUEST",FALSE);

	datalim = (lispval)(xx+pages*NBPG);	/*  compute bit table limit  */

	/*  set type for pages  */

	for(i = 0; i < pages; ++i) {
		SETTYPE((xx + i*NBPG),type);
	}

	return(xx);	/*  return pointer to block of storage  */
	}

/* getatom **************************************************************/
/* returns either an existing atom with the name specified in strbuf, or*/
/* if the atom does not already exist, regurgitates a new one and       */
/* returns it.                                                          */
lispval
getatom()
{   register lispval aptr;
    register char *name, *endname;
    lispval	b;
    char	c;
    register int hash;
    snpand(4);

	name = strbuf;
	if (*name == (char)0377) return (eofa);
	hash = 0;
	for(name=strbuf; *name;) {
		hash ^= *name++;
	}
	hash &= 0177;	/*  make sure no high-order bits have crept in  */
	atmlen = name - strbuf + 1;
	aptr = (lispval) hasht[hash];
	while (aptr != CNIL)
	    if (strcmp(strbuf,aptr->pname)==0)
		return (aptr);
	    else
		aptr = (lispval) aptr->hshlnk;
	aptr = (lispval) newatom();
	aptr->hshlnk = hasht[hash];
	hasht[hash] = (struct atom *) aptr;
	endname = name - 1;
	name = strbuf;
	if ((atmlen != 4) && (*name == 'c') && (*endname == 'r'))
		{
		b = newdot();
		protect(b);
		b->car = lambda;
		b->cdr = newdot();
		b = b->cdr;
		b->car = newdot();
		(b->car)->car = xatom;
		while(TRUE)
			{
			b->cdr = newdot();
			b= b->cdr;
			if(++name == endname)
				{
				b->car= (lispval) xatom;
				aptr->fnbnd = unprot();
				break;
				}
			b->car= newdot();
			b= b->car;
			if((c = *name) == 'a') b->car = cara;
			else if (c == 'd') b->car = cdra;
			else{ unprot();
			   break;
			 }
			}
		}

	return(aptr);
	}
Commit	Line	Data
b2e344ca JF	1	# include "global.h"
	2
	3	# define NUMWORDS TTSIZE * 128 /* max number of words in P0 space */
	4	# define BITQUADS TTSIZE * 2 /* length of bit map in quad words */
	5
	6	# define ftstbit asm(" ashl $-2,r11,r3");\
	7	asm(" bbcs r3,_bitmapq,$1");\
	8	asm(" .byte 4");
	9	/* define ftstbit if( readbit(p) ) return; oksetbit; */
	10	# define readbit(p) ((int)bitmap[r=(int)p>>5] & (s=bitmsk[((int)p>>2)&7]))
	11	# define lookbit(p) (bitmap[(int)p>>5] & bitmsk[((int)p>>2) & 7])
	12	# define setbit(p) {bitmap[(int)p>>5] \|= bitmsk[((int)p >> 2) & 7];}
	13	# define oksetbit {bitmap[r] \|= s;}
	14
	15	# define readchk(p) ((int)bitfre[(int)p>>5] & bitmsk[((int)p>>2)&7])
	16	# define setchk(p) {bitfre[(int)p>>5] \|= bitmsk[((int)p >> 2) & 7];}
	17
	18	struct heads {
	19	struct heads *link;
	20	char *pntr;
	21	} header[TTSIZE];
	22
	23	FILE * chkport; /* garbage collection dump file */
	24	lispval datalim; /* end of data space */
	25	double bitmapq[BITQUADS]; /* the bit map--one bit per long */
	26	double zeroq; /* a quad word of zeros */
	27	char bitmap = (char ) bitmapq; /* byte version of bit map array */
	28	char bitmsk[8]={1,2,4,8,16,32,64,128}; /* used by bit-marking macros */
	29	int bind_lists = (int ) CNIL; /* lisp data for compiled code */
	30
	31	char *xsbrk();
	32
	33
	34	int atmlen;
	35
	36	struct types {
	37	char *next_free;
	38	int space_left,
	39	space,
	40	type,
	41	type_len; /* note type_len is in units of int */
	42	lispval *items,
	43	*pages,
	44	*type_name;
	45	struct heads
	46	*first;
	47	} atom_str = {(char )CNIL,0,ATOMSPP,ATOM,5,&atom_items,&atom_pages,&atom_name,(struct heads )CNIL},
	48	strng_str = {(char )CNIL,0,STRSPP,STRNG,1,&str_items,&str_pages,&str_name,(struct heads )CNIL},
	49	int_str = {(char )CNIL,0,INTSPP,INT,1,&int_items,&int_pages,&int_name,(struct heads )CNIL},
	50	dtpr_str = {(char )CNIL,0,DTPRSPP,DTPR,2,&dtpr_items,&dtpr_pages,&dtpr_name,(struct heads )CNIL},
	51	doub_str = {(char )CNIL,0,DOUBSPP,DOUB,2,&doub_items,&doub_pages,&doub_name,(struct heads )CNIL},
	52	array_str = {(char )CNIL,0,ARRAYSPP,ARRAY,5,&array_items,&array_pages,&array_name,(struct heads )CNIL},
	53	sdot_str = {(char )CNIL,0,SDOTSPP,SDOT,2,&sdot_items,&sdot_pages,&sdot_name,(struct heads )CNIL},
	54	val_str = {(char )CNIL,0,VALSPP,VALUE,1,&val_items,&val_pages,&val_name,(struct heads )CNIL},
	55	funct_str = {(char )CNIL,0,BCDSPP,BCD,2,&funct_items,&funct_pages,&funct_name,(struct heads )CNIL};
	56
	57	extern int initflag; /* starts off TRUE: initially gc not allowed */
	58
	59	int gcflag = FALSE; /* TRUE during garbage collection */
	60
	61	int current = 0; /* number of pages currently allocated */
	62
	63	#define NUMSPACES 9
	64
65	static struct types *(spaces[NUMSPACES]) =
66	{&atom_str, &strng_str, &int_str,
67	&dtpr_str, &doub_str, &array_str,
68	&sdot_str, &val_str, &funct_str};
69
70
71	/ get_more_space(type_struct) ***************************************/
72	/* */
73	/* Allocates and structures a new page, returning 0. */
74	/* If no space is available, returns 1. */
75
76	get_more_space(type_struct)
77	struct types *type_struct;
78	{
79	int cntr;
80	char *start;
81	int loop, temp;
82	lispval p, plim;
83	struct heads *next;
84
85	if(initflag == FALSE)
86	/* mustn't look at plist of plima too soon */
87	{
88	while( plim=copval(plima,(lispval)CNIL), TYPE(plim)!=INT )
89	copval(plima,error("BAD PAGE LIMIT",TRUE));
90	if( plim->i <= current ) return(1); /* Can't allocate */
91	}
92
93	if( current >= TTSIZE ) return(2);
94
95	start = xsbrk( NBPG );
96
97	/* bump the page counter for this space */
98
99	++((*(type_struct->pages))->i);
100
101	SETTYPE(start, type_struct->type); /* set type of page */
102
103	type_struct->space_left = type_struct->space;
104	next = &header[ current++ ];
105	if ((type_struct->type)==STRNG)
106	{
107	type_struct->next_free = start;
108	return(0); /* space was available */
109	}
110	next->pntr = start;
111	next->link = type_struct->first;
112	type_struct->first = next;
113	temp = loop = (int *) start;
114	for(cntr=1; cntr < type_struct->space; cntr++)
115	loop = (int ) (loop = (int) (loop + type_struct->type_len));
116	*loop = (int) (type_struct->next_free);
117	type_struct->next_free = (char *) temp;
118
119	/* if type atom, set pnames to CNIL */
120
121	if( type_struct == &atom_str )
122	for(cntr=0, p=(lispval) temp; cntr<atom_str.space; ++cntr)
123	{
124	p->pname = (char *) CNIL;
125	p = (lispval) ((int *)p + atom_str.type_len);
126	}
127	return(0); /* space was available */
128	}
129
130
131	/ next_one(type_struct) **********************************************/
132	/* */
133	/* Allocates one new item of each kind of space, except STRNG. */
134	/* If there is no space, calls gc, the garbage collector. */
135	/* If there is still no space, allocates a new page using */
136	/* get_more_space(type_struct) */
137
138	lispval
139	next_one(type_struct)
140	struct types *type_struct;
141	{
142
143	register char *temp;
144	snpand(1);
145
146	while(type_struct->next_free == (char *) CNIL)
147	{
148	int g;
149
150	if((type_struct->type != ATOM) && /* can't collect atoms */
151	(type_struct->type != STRNG) && /* can't collect strings */
152	(gcthresh->i <= current) && /* threshhold for gc */
153	ISNIL(copval(gcdis,CNIL)) && /* gc not disabled */
154	(NOTNIL(copval(gcload,CNIL)) \|\| (loading->clb != tatom)) &&
155	/* not to collect during load */
156	(initflag == FALSE) && /* dont gc during init */
157	(gcflag == FALSE)) /* don't recurse gc */
158
159	{
160	/* fputs("Collecting",poport);
161	dmpport(poport);*/
162	gc(type_struct); /* collect */
163	}
164
165	if( type_struct->next_free != (char *) CNIL ) break;
166
167	if(! (g=get_more_space(type_struct))) break;
168
169	if( g==1 )
170	{
171	plimit->i = current+NUMSPACES;
172	/* allow a few more pages */
173	copval(plima,plimit); /* restore to reserved reg */
174
175	error("PAGE LIMIT EXCEEDED--EMERGENCY PAGES ALLOCATED",
176	TRUE);
177	}
178	else error("SORRY, ABSOLUTE PAGE LIMIT HAS BEEN REACHED",
179	TRUE);
180	}
181
182	temp = type_struct->next_free;
183	type_struct->next_free = * (char **)(type_struct->next_free);
184	return((lispval) temp);
185	}
186
187	lispval
188	newint()
189	{
190	++(int_items->i);
191	return(next_one(&int_str));
192	}
193
194	lispval
195	newdot()
196	{
197	lispval temp;
198
199	++(dtpr_items->i);
200	temp = next_one(&dtpr_str);
201	temp->car = temp->cdr = nil;
202	return(temp);
203	}
204
205	lispval
206	newdoub()
207	{
208	++(doub_items->i);
209	return(next_one(&doub_str));
210	}
211
212	lispval
213	newsdot()
214	{
215	register lispval temp;
216	++(dtpr_items->i);
217	temp = next_one(&sdot_str);
218	temp->car = temp->cdr = 0;
219	return(temp);
220	}
221
222	struct atom *newatom() {
223	struct atom *save;
224
225	++(atom_items->i);
226	save = (struct atom *) next_one(&atom_str) ;
227	save->plist = save->fnbnd = nil;
228	save->hshlnk = (struct atom *)CNIL;
229	save->clb = CNIL;
230	save->pname = newstr();
231	return (save);
232	}
233
234	char *newstr() {
235	char *save;
236	int atmlen2;
237
238	++(str_items->i);
239	atmlen = strlen(strbuf)+1;
240	if(atmlen > strng_str.space_left)
241	while(get_more_space(&strng_str))
242	error("YOU HAVE RUN OUT OF SPACE",TRUE);
243	strcpy((save = strng_str.next_free), strbuf);
244	atmlen2 = atmlen;
245	while(atmlen2 % 4) ++atmlen2; /* even up length of string */
246	strng_str.next_free += atmlen2;
247	strng_str.space_left -= atmlen2;
248	return(save);
249	}
250
251	char inewstr(s) char s;
252	{
253	strbuf[STRBLEN-1] = '\0';
254	strcpyn(strbuf,s,STRBLEN-1);
255	return(newstr());
256	}
257
258	lispval
259	newarray()
260	{
261	register lispval temp;
262	++(array_items->i);
263	temp = next_one(&array_str);
264	temp->data = (char *)nil;
265	temp->accfun = nil;
266	temp->aux = nil;
267	temp->length = SMALL(0);
268	temp->delta = SMALL(0);
269	return(temp);
270	}
271
272	lispval
273	badcall()
274	{ error("BAD FUNCTION DESCRIPTOR USED IN CALL",FALSE); }
275
276	lispval
277	newfunct()
278	{
279	register lispval temp;
280	++(funct_items->i);
281	temp = next_one(&funct_str);
282	temp->entry = badcall;
283	temp->discipline = nil;
284	return(temp);
285	}
286
287	lispval
288	newval()
289	{
290	register lispval temp;
291	++(val_items->i);
292	temp = next_one(&val_str);
293	temp->l = nil;
294	return(temp);
295	}
296
297	lispval
298	inewval(arg) lispval arg;
299	{
300	lispval temp;
301	++(val_items->i);
302	temp = next_one(&val_str);
303	temp->l = arg;
304	return(temp);
305	}
306
307	/ Ngc ***************************************************************/
308	/* */
309	/* LISP interface to gc. */
310
311	lispval Ngc()
312	{
313	lispval temp;
314
315	if( ISNIL(lbot->val) ) return(gc(CNIL));
316
317	if( TYPE(lbot->val) != DTPR ) error("BAD CALL TO GC",FALSE);
318
319	chkport = poport;
320
321	if( NOTNIL(lbot->val->car) )
322	{
323	temp = eval(lbot->val->car);
324	if( TYPE(temp) == PORT ) chkport = (FILE )temp;
325	}
326
327	gc1(TRUE);
328
329	return(nil);
330	}
331
332	/ gc(type_struct) ***************************************************/
333	/* */
334	/* garbage collector: Collects garbage by mark and sweep algorithm. */
335	/* After this is done, calls the Nlambda, gcafter. */
336	/* gc may also be called from LISP, as a lambda of no arguments. */
337
338	lispval
339	gc(type_struct)
340	struct types *type_struct;
341	{
342	lispval save;
343	struct {
344	long mytime;
345	long allelse[3];
346	} begin, finish;
347	extern int GCtime;
348
349	save = copval(gcport,CNIL);
350	if(GCtime)
351	times(&begin);
352
353	while( (TYPE(save) != PORT) && NOTNIL(save))
354	save = error("NEED PORT FOR GC",TRUE);
355
356	chkport = ISNIL(save) ? poport : (FILE )save;
357
358	gc1(NOTNIL(copval(gccheck,CNIL)) \|\| (chkport!=poport)); /* mark&sweep */
359
360	/* Now we call gcafter--special case if gc called from LISP */
361
362	if( type_struct == (struct types *) CNIL )
363	gccall1->cdr = nil; /* make the call "(gcafter)" */
364	else
365	{
366	gccall1->cdr = gccall2;
367	gccall2->car = *(type_struct->type_name);
368	}
369	gcflag = TRUE; /* flag to indicate in garbage collector */
370	save = eval(gccall1); /* call gcafter */
371	gcflag = FALSE; /* turn off flag */
372
373	if(GCtime) {
374	times(&finish);
375	GCtime += (finish.mytime - begin.mytime);
376	}
377	return(save); /* return result of gcafter */
378	}
379
380
381
382	/* gc1() **************************************************************/
383	/* */
384	/* Mark-and-sweep phase */
385
386	gc1(chkflag) int chkflag;
387	{
388	int i, j, typep;
389	register int start, point;
390	struct types *s;
391	struct heads *loop;
392	struct argent *loop2;
393	int markdp();
394
395
396	/* decide whether to check LISP structure or not */
397
398
399
400
401	/* first set all bit maps to zero */
402
403	for(i=0; i<((int)datalim >> 8); ++i) bitmapq[i] = zeroq;
404
405
406	/* then mark all atoms' plists, clbs, and function bindings */
407
408	for(loop=atom_str.first; loop!=(struct heads *)CNIL; loop=loop->link)
409	for(start=(int *)(loop->pntr), i=1;
410	i <= atom_str.space;
411	start = start + atom_str.type_len, ++i)
412	{
413
414	/* unused atoms are marked with pname == CNIL */
415	/* this is done by get_more_space, as well as */
416	/* by gc (in the future) */
417
418	if(((lispval)start)->pname == (char *)CNIL) continue;
419	#define MARKSUB(p) if(nil!=((lispval)start)->p)markdp(((lispval)start)->p);
420	MARKSUB(clb);
421	MARKSUB(fnbnd);
422	MARKSUB(plist);
423	}
424
425	/* next run up the name stack */
426
427	for(loop2 = np - 1; loop2 >= orgnp; --loop2) markdp((loop2->val));
428	/* from TBL 29july79 */
429	/* next mark all compiler linked data */
430	point = bind_lists;
431	while((start = point) != (int *)CNIL) {
432	while( *start != -1 )
433	markdp(*start++);
434	point = (int )(point-1);
435	}
436	/* end from TBL */
437
438	/* next mark all system-significant lisp data */
439
440	for(i=0; i<SIGNIF; ++i) markdp((lispsys[i]));
441
442	/* all accessible data has now been marked. */
443	/* all collectable spaces must be swept, */
444	/* and freelists constructed. */
445
446	for(i=0; i<NUMSPACES; ++i)
447	{
448	/* STRINGS do not participate. */
449	/* ATOMS dont either (currently) */
450
451	s = spaces[i];
452	typep = s->type;
453	if((typep==STRNG) \|\| (typep==ATOM)) continue;
454
455	s->space_left = 0; /* we will count free cells */
456	((s->items))->i = 0; / and compute cells used */
457
458	/* for each space, traverse list of pages. */
459
460	s->next_free = (char ) CNIL; / reinitialize free list */
461
462	for(loop = s->first; loop != (struct heads *) CNIL; loop=loop->link)
463	{
464	/* add another page's worth to use count */
465
466	(*(s->items))->i += s->space;
467
468	/* for each page, make a list of unmarked data */
469
470	for(j=0, point=(int *)(loop->pntr);
471	j<s->space; ++j, point += s->type_len)
472	if( ! lookbit(point) )
473	{
474	/* add to free list */
475	/* update pointer to free list*/
476	/* update count of free list */
477
478	*point = (int)(s->next_free);
479	s->next_free = (char *) point;
480	++(s->space_left);
481	}
482	}
483	((s->items))->i -= s->space_left; / compute cells used */
484	}
485	}
486
487	/ alloc() ***********************************************************/
488	/* */
489	/* This routine tries to allocate one more page of the space named */
490	/* by the argument. If no more space is available returns 1, else 0. */
491
492	lispval
493	alloc(tname,npages)
494	lispval tname; int npages;
495	{
496	int ii, jj;
497
498	ii = typenum(tname);
499
500	for( jj=0; jj<npages; ++jj)
501	if(get_more_space(spaces[ii])) break;
502	return(inewint(jj));
503	}
504
505	lispval
506	csegment(tname,nitems)
507	lispval tname; int nitems;
508	{
509	int ii, jj;
510	char *charadd;
511
512	ii = typenum(tname);
513
514	nitems = nitems4spaces[ii]->type_len; /* find c-length of space */
515	while( nitems%512 ) ++nitems; /* round up to right length */
516	current += nitems/512;
517	charadd = sbrk(nitems);
518	if( (int) charadd == 0 )
519	error("NOT ENOUGH SPACE FOR ARRAY",FALSE);
520	(datalim = (lispval)(charadd+nitems));
521	if((((int)datalim) >> 9) > TTSIZE) {
522	datalim = (lispval) (TTSIZE << 9);
523	badmem(53);
524	}
525	for(jj=0; jj<nitems; jj=jj+512) {
526	SETTYPE(charadd+jj, spaces[ii]->type);
527	}
528	return((lispval)charadd);
529	}
530
531	int csizeof(tname) lispval tname;
532	{
533	return( spaces[typenum(tname)]->type_len * 4 );
534	}
535
536	int typenum(tname) lispval tname;
537	{
538	int ii;
539
540	chek: for(ii=0; ii<NUMSPACES; ++ii)
541	if(tname == *(spaces[ii]->type_name)) break;
542	if(ii == NUMSPACES)
543	{
544	tname = error("BAD TYPE NAME",TRUE);
545	goto chek;
546	}
547
548	return(ii);
549	}
550
551	/ markit(p) *********************************************************/
552	/* just calls markdp */
553
554	markit(p) lispval p; { markdp(p); }
555
556	/ markdp(p) *********************************************************/
557	/* */
558	/* markdp is the routine which marks each data item. If it is a */
559	/* dotted pair, the car and cdr are marked also. */
560	/* An iterative method is used to mark list structure, to avoid */
561	/* excessive recursion. */
562
563
564	markdp(p) register lispval p;
565	{
566	/* register int r, s; (goes with non-asm readbit, oksetbit) */
567
568	ptr_loop:
569	if((int)p <= 0) return; /* do not mark special data types or nil=0 */
570
571	switch( TYPE(p) )
572	{
573	case INT:
574	case DOUB:
575	/* setbit(p);*/
576	ftstbit;
577	return;
578	case VALUE:
579	ftstbit;
580	p = p->l;
581	goto ptr_loop;
582	case DTPR:
583	ftstbit;
584	markdp(p->car);
585	p = p->cdr;
586	goto ptr_loop;
587
588	case ARRAY:
589	ftstbit; /* mark array itself */
590
591	markdp(p->accfun); /* mark access function */
592	markdp(p->aux); /* mark aux data */
593	markdp(p->length); /* mark length */
594	markdp(p->delta); /* mark delta */
595
596	{
597	register int i, l; int d;
598	register char *dataptr = p->data;
599
600	for(i=0, l=p->length->i, d=p->delta->i; i<l; ++i)
601	{
602	markdp(dataptr);
603	dataptr += d;
604	}
605	return;
606	}
607	case SDOT:
608	do {
609	ftstbit;
610	p = p->CDR;
611	} while (p!=0);
612	return;
613
614	case BCD:
615	ftstbit;
616	markdp(p->discipline);
617	return;
618	}
619	return;
620	}
621
622
623
624	char *
625	xsbrk()
626	{
627	static char xx; / pointer to next available blank page */
628	static int cycle = 0; /* number of blank pages available */
629	lispval u; /* used to compute limits of bit table */
630
631	if( (cycle--) <= 0 )
632	{
633	cycle = 15;
634	xx = sbrk(16NBPG); / get pages 16 at a time */
635	if( (int)xx== -1 )
636	lispend("For sbrk from lisp: no space... Goodbye!");
637	goto done;
638	}
639	xx += NBPG;
640	done: if( (u = (lispval)(xx+NBPG)) > datalim ) datalim = u;
641	return(xx);
642	}
643
644	char *ysbrk(pages,type) int pages, type;
645	{
646	char xx; / will point to block of storage */
647	int i;
648
649	xx = sbrk(pages*NBPG);
650	if((int)xx == -1)
651	error("OUT OF SPACE FOR ARRAY REQUEST",FALSE);
652
653	datalim = (lispval)(xx+pagesNBPG); / compute bit table limit */
654
655	/* set type for pages */
656
657	for(i = 0; i < pages; ++i) {
658	SETTYPE((xx + i*NBPG),type);
659	}
660
661	return(xx); /* return pointer to block of storage */
662	}
663
664	/* getatom **************************************************************/
665	/* returns either an existing atom with the name specified in strbuf, or*/
666	/* if the atom does not already exist, regurgitates a new one and */
667	/* returns it. */
668	lispval
669	getatom()
670	{ register lispval aptr;
671	register char name, endname;
672	lispval b;
673	char c;
674	register int hash;
675	snpand(4);
676
677	name = strbuf;
678	if (*name == (char)0377) return (eofa);
679	hash = 0;
680	for(name=strbuf; *name;) {
681	hash ^= *name++;
682	}
683	hash &= 0177; /* make sure no high-order bits have crept in */
684	atmlen = name - strbuf + 1;
685	aptr = (lispval) hasht[hash];
686	while (aptr != CNIL)
687	if (strcmp(strbuf,aptr->pname)==0)
688	return (aptr);
689	else
690	aptr = (lispval) aptr->hshlnk;
691	aptr = (lispval) newatom();
692	aptr->hshlnk = hasht[hash];
693	hasht[hash] = (struct atom *) aptr;
694	endname = name - 1;
695	name = strbuf;
696	if ((atmlen != 4) && (name == 'c') && (endname == 'r'))
697	{
698	b = newdot();
699	protect(b);
700	b->car = lambda;
701	b->cdr = newdot();
702	b = b->cdr;
703	b->car = newdot();
704	(b->car)->car = xatom;
705	while(TRUE)
706	{
707	b->cdr = newdot();
708	b= b->cdr;
709	if(++name == endname)
710	{
711	b->car= (lispval) xatom;
712	aptr->fnbnd = unprot();
713	break;
714	}
715	b->car= newdot();
716	b= b->car;
717	if((c = *name) == 'a') b->car = cara;
718	else if (c == 'd') b->car = cdra;
719	else{ unprot();
720	break;
721	}
722	}
723	}
724
725	return(aptr);
726	}
727