4.4BSD/usr/src/old/lisp/franz/alloc.c
#ifndef lint
static char *rcsid =
"$Header: alloc.c,v 1.13 87/12/11 17:27:45 sklower Exp $";
#endif
/*
* alloc.c $Locker: $
* storage allocator and garbage collector
*
* (c) copyright 1982, Regents of the University of California
*/
# include "global.h"
# include "structs.h"
#include <sys/types.h>
#include <sys/times.h>
#ifdef METER
#include <sys/vtimes.h>
#endif
# define NUMWORDS TTSIZE * 128 /* max number of words in P0 space */
# define BITQUADS TTSIZE * 2 /* length of bit map in quad words */
# define BITLONGS TTSIZE * 4 /* length of bit map in long words */
# ifdef vax
# define ftstbit asm(" ashl $-2,r11,r3");\
asm(" bbcs r3,_bitmapi,1f");\
asm(" ret"); \
asm("1:");
/* setbit is a fast way of setting a bit, it is like ftstbit except it
* always continues on to the next instruction
*/
# define setbit asm(" ashl $-2,r11,r0"); \
asm(" bbcs r0,_bitmapi,$0");
# endif
# if m_68k
# define ftstbit {if(Itstbt()) return;}
# define setbit Itstbt()
# endif
# ifdef tahoe
# define ftstbit if( readbit(p) ) return; oksetbit;
# define setbit {bitmapi[(int)p>>7] |= bitmsk[((int)p >> 2)&31];}
# define readbit(p) ((int)bitmapi[r=(int)p>>7] & (s=bitmsk[((int)p>>2)&31]))
# define oksetbit {bitmapi[r] |= s;}
# endif
/* Unused bit macros
# define lookbit(p) (bbitmap[(int)p>>5] & bitmsk[((int)p>>2) & 7])
# 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];}
*/
# define roundup(x,l) (((x - 1) | (l - 1)) + 1)
# define MARKVAL(v) if(((int)v) >= (int)beginsweep) markdp(v);
# define ATOLX(p) ((((int)p)-OFFSET)>>7)
/* the Vax hardware only allows 2^16-1 bytes to be accessed with one
* movc5 instruction. We use the movc5 instruction to clear the
* bitmaps.
*/
# define MAXCLEAR ((1<<16)-1)
/* METER denotes something added to help meter storage allocation. */
extern int *beginsweep; /* first sweepable data */
extern char purepage[];
extern int fakettsize;
extern int gcstrings;
int debugin = FALSE; /* temp debug flag */
extern lispval datalim; /* end of data space */
int bitmapi[BITLONGS]; /* the bit map--one bit per long */
double zeroq; /* a quad word of zeros */
char *bbitmap = (char *) bitmapi; /* byte version of bit map array */
double *qbitmap = (double *) bitmapi; /* integer version of bit map array */
#ifdef METER
extern int gcstat;
extern struct vtimes
premark,presweep,alldone; /* actually struct tbuffer's */
extern int mrkdpcnt;
extern int conssame, consdiff,consnil; /* count of cells whose cdr point
* to the same page and different
* pages respectively
*/
#endif
int bitmsk[32]={1,2,4,8,16,32,64,128, /* used by bit-marking macros */
0x100, 0x200, 0x400, 0x800,
0x1000, 0x2000, 0x4000, 0x8000,
0x10000, 0x20000, 0x40000, 0x80000,
0x100000, 0x200000, 0x400000, 0x800000,
0x1000000, 0x2000000, 0x4000000, 0x8000000,
0x10000000, 0x20000000, 0x40000000, 0x80000000};
extern int *bind_lists; /* lisp data for compiled code */
char *xsbrk();
char *gethspace();
extern struct types atom_str, strng_str, int_str, dtpr_str, doub_str,
array_str, sdot_str, val_str, funct_str, hunk_str[], vect_str,
vecti_str, other_str;
extern struct str_x str_current[];
lispval hunk_items[7], hunk_pages[7], hunk_name[7];
extern int initflag; /* starts off TRUE: initially gc not allowed */
/* this is a table of pointers to all struct types objects
* the index is the type number.
*/
static struct types *spaces[NUMSPACES] =
{&strng_str, &atom_str, &int_str,
&dtpr_str, &doub_str, &funct_str,
(struct types *) 0, /* port objects not allocated in this way */
&array_str,
&other_str, /* other objects not allocated in this way */
&sdot_str,&val_str,
&hunk_str[0], &hunk_str[1], &hunk_str[2],
&hunk_str[3], &hunk_str[4], &hunk_str[5],
&hunk_str[6],
&vect_str, &vecti_str};
/* this is a table of pointers to collectable struct types objects
* the index is the type number.
*/
struct types *gcableptr[] = {
#ifndef GCSTRINGS
(struct types *) 0, /* strings not collectable */
#else
&strng_str,
#endif
&atom_str,
&int_str, &dtpr_str, &doub_str,
(struct types *) 0, /* binary objects not collectable */
(struct types *) 0, /* port objects not collectable */
&array_str,
(struct types *) 0, /* gap in the type number sequence */
&sdot_str,&val_str,
&hunk_str[0], &hunk_str[1], &hunk_str[2],
&hunk_str[3], &hunk_str[4], &hunk_str[5],
&hunk_str[6],
&vect_str, &vecti_str};
/*
* get_more_space(type_struct,purep)
*
* Allocates and structures a new page, returning 0.
* If no space is available, returns positive number.
* If purep is TRUE, then pure space is allocated.
*/
get_more_space(type_struct,purep)
struct types *type_struct;
{
int cntr;
char *start;
int *loop, *temp;
lispval p;
extern char holend[];
if( (int) datalim >= TTSIZE*LBPG+OFFSET ) return(2);
/*
* If the hole is defined, then we allocate binary objects
* and strings in the hole. However we don't put strings in
* the hole if strings are gc'ed.
*/
#ifdef HOLE
if( purep
#ifndef GCSTRINGS
|| type_struct==&strng_str
#endif
|| type_struct==&funct_str)
start = gethspace(LBPG,type_struct->type);
else
#endif
start = xsbrk(1); /* get new page */
SETTYPE(start, type_struct->type,20); /* set type of page */
purepage[ATOX(start)] = (char)purep; /* remember if page was pure*/
/* bump the page counter for this space if not pure */
if(!purep) ++((*(type_struct->pages))->i);
type_struct->space_left = type_struct->space;
temp = loop = (int *) start;
for(cntr=1; cntr < type_struct->space; cntr++)
loop = (int *) (*loop = (int) (loop + type_struct->type_len));
/* attach new cells to either the pure space free list or the
* standard free list
*/
if(purep) {
*loop = (int) (type_struct->next_pure_free);
type_struct->next_pure_free = (char *) temp;
}
else {
*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->a.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
*/
lispval
next_one(type_struct)
struct types *type_struct;
{
register char *temp;
while(type_struct->next_free == (char *) CNIL)
{
int g;
if(
(initflag == FALSE) && /* dont gc during init */
#ifndef GCSTRINGS
(type_struct->type != STRNG) && /* can't collect strings */
#else
gcstrings && /* user (sstatus gcstrings) */
#endif
(type_struct->type != BCD) && /* nor function headers */
gcdis->a.clb == nil ) /* gc not disabled */
/* not to collect during load */
{
gc(type_struct); /* collect */
}
if( type_struct->next_free != (char *) CNIL ) break;
if(! (g=get_more_space(type_struct,FALSE))) break;
space_warn(g);
}
temp = type_struct->next_free;
type_struct->next_free = * (char **)(type_struct->next_free);
(*(type_struct->items))->i ++;
return((lispval) temp);
}
/*
* Warn about exhaustion of space,
* shared with next_pure_free().
*/
space_warn(g)
{
if( g==1 ) {
plimit->i += 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);
}
/* allocate an element of a pure structure. Pure structures will
* be ignored by the garbage collector.
*/
lispval
next_pure_one(type_struct)
struct types *type_struct;
{
register char *temp;
while(type_struct->next_pure_free == (char *) CNIL)
{
int g;
if(! (g=get_more_space(type_struct,TRUE))) break;
space_warn(g);
}
temp = type_struct->next_pure_free;
type_struct->next_pure_free = * (char **)(type_struct->next_pure_free);
return((lispval) temp);
}
lispval
newint()
{
return(next_one(&int_str));
}
lispval
pnewint()
{
return(next_pure_one(&int_str));
}
lispval
newdot()
{
lispval temp;
temp = next_one(&dtpr_str);
temp->d.car = temp->d.cdr = nil;
return(temp);
}
lispval
pnewdot()
{
lispval temp;
temp = next_pure_one(&dtpr_str);
temp->d.car = temp->d.cdr = nil;
return(temp);
}
lispval
newdoub()
{
return(next_one(&doub_str));
}
lispval
pnewdb()
{
return(next_pure_one(&doub_str));
}
lispval
newsdot()
{
register lispval temp;
temp = next_one(&sdot_str);
temp->d.car = temp->d.cdr = 0;
return(temp);
}
lispval
pnewsdot()
{
register lispval temp;
temp = next_pure_one(&sdot_str);
temp->d.car = temp->d.cdr = 0;
return(temp);
}
struct atom *
newatom(pure) {
struct atom *save; char *mypname;
mypname = newstr(pure);
pnameprot = ((lispval) mypname);
save = (struct atom *) next_one(&atom_str) ;
save->plist = save->fnbnd = nil;
save->hshlnk = (struct atom *)CNIL;
save->clb = CNIL;
save->pname = mypname;
return (save);
}
char *
newstr(purep) {
char *save, *strcpy();
int atmlen;
register struct str_x *p = str_current + purep;
atmlen = strlen(strbuf)+1;
if(atmlen > p->space_left) {
if(atmlen >= STRBLEN) {
save = (char *)csegment(OTHER, atmlen, purep);
SETTYPE(save,STRNG,40);
purepage[ATOX(save)] = (char)purep;
strcpy(save,strbuf);
return(save);
}
p->next_free = (char *) (purep ?
next_pure_one(&strng_str) : next_one(&strng_str)) ;
p->space_left = LBPG;
}
strcpy((save = p->next_free), strbuf);
/*while(atmlen & 3) ++atmlen; /* even up length of string */
p->next_free += atmlen;
p->space_left -= atmlen;
return(save);
}
static char * Iinewstr(s,purep) char *s;
{
int len = strlen(s);
while(len > (endstrb - strbuf - 1)) atomtoolong(strbuf);
strcpy(strbuf,s);
return(newstr(purep));
}
char *inewstr(s) char *s;
{
Iinewstr(s,0);
}
char *pinewstr(s) char *s;
{
Iinewstr(s,1);
}
lispval
newarray()
{
register lispval temp;
temp = next_one(&array_str);
temp->ar.data = (char *)nil;
temp->ar.accfun = nil;
temp->ar.aux = nil;
temp->ar.length = SMALL(0);
temp->ar.delta = SMALL(0);
return(temp);
}
lispval
newfunct()
{
register lispval temp;
lispval Badcall();
temp = next_one(&funct_str);
temp->bcd.start = Badcall;
temp->bcd.discipline = nil;
return(temp);
}
lispval
newval()
{
register lispval temp;
temp = next_one(&val_str);
temp->l = nil;
return(temp);
}
lispval
pnewval()
{
register lispval temp;
temp = next_pure_one(&val_str);
temp->l = nil;
return(temp);
}
lispval
newhunk(hunknum)
int hunknum;
{
register lispval temp;
temp = next_one(&hunk_str[hunknum]); /* Get a hunk */
return(temp);
}
lispval
pnewhunk(hunknum)
int hunknum;
{
register lispval temp;
temp = next_pure_one(&hunk_str[hunknum]); /* Get a hunk */
return(temp);
}
lispval
inewval(arg) lispval arg;
{
lispval temp;
temp = next_one(&val_str);
temp->l = arg;
return(temp);
}
/*
* Vector allocators.
* a vector looks like:
* longword: N = size in bytes
* longword: pointer to lisp object, this is the vector property field
* N consecutive bytes
*
*/
lispval getvec();
lispval
newvec(size)
{
return(getvec(size,&vect_str,FALSE));
}
lispval
pnewvec(size)
{
return(getvec(size,&vect_str,TRUE));
}
lispval
nveci(size)
{
return(getvec(size,&vecti_str,FALSE));
}
lispval
pnveci(size)
{
return(getvec(size,&vecti_str,TRUE));
}
/*
* getvec
* get a vector of size byte, from type structure typestr and
* get it from pure space if purep is TRUE.
* vectors are stored linked through their property field. Thus
* when the code here refers to v.vector[0], it is the prop field
* and vl.vectorl[-1] is the size field. In other code,
* v.vector[-1] is the prop field, and vl.vectorl[-2] is the size.
*/
lispval
getvec(size,typestr,purep)
register struct types *typestr;
{
register lispval back, current;
int sizewant, bytes, thissize, pages, pindex, triedgc = FALSE;
/* we have to round up to a multiple of 4 bytes to determine the
* size of vector we want. The rounding up assures that the
* property pointers are longword aligned
*/
sizewant = VecTotSize(size);
if(debugin) fprintf(stderr,"want vect %db\n",size);
again:
if(purep)
back = (lispval) &(typestr->next_pure_free);
else
back = (lispval) &(typestr->next_free);
current = back->v.vector[0];
while(current != CNIL)
{
if(debugin)
fprintf(stderr,"next free size %db; ", current->vl.vectorl[-1]);
if ((thissize = VecTotSize(current->vl.vectorl[-1])) == sizewant)
{
if(debugin) fprintf(stderr,"exact match of size %d at 0x%x\n",
4*thissize, ¤t->v.vector[1]);
back->v.vector[0]
= current->v.vector[0];/* change free pointer*/
current->v.vector[0] = nil; /* put nil in property */
/* to the user, vector begins one after property*/
return((lispval)¤t->v.vector[1]);
}
else if (thissize >= sizewant + 3)
{
/* the reason that there is a `+ 3' instead of `+ 2'
* is that we don't want to leave a zero sized vector which
* isn't guaranteed to be followed by another vector
*/
if(debugin)
fprintf(stderr,"breaking a %d vector into a ",
current->vl.vectorl[-1]);
current->v.vector[1+sizewant+1]
= current->v.vector[0]; /* free list pointer */
current->vl.vectorl[1+sizewant]
= VecTotToByte(thissize - sizewant - 2);/*size info */
back->v.vector[0] = (lispval) &(current->v.vector[1+sizewant+1]);
current->vl.vectorl[-1] = size;
if(debugin)fprintf(stderr," %d one and a %d one\n",
current->vl.vectorl[-1],current->vl.vectorl[1+sizewant]);
current->v.vector[0] = nil; /* put nil in property */
/* vector begins one after the property */
if(debugin) fprintf(stderr," and returning vector at 0x%x\n",
¤t->v.vector[1]);
return((lispval)(¤t->v.vector[1]));
}
back = current;
current = current->v.vector[0];
}
if(!triedgc
&& !purep
&& (gcdis->a.clb == nil)
&& (initflag == FALSE))
{
gc(typestr);
triedgc = TRUE;
goto again;
}
/* set bytes to size needed for this vector */
bytes = size + 2*sizeof(long);
/* must make sure that if the vector we are allocating doesnt
completely fill a page, there is room for another vector to record
the size left over */
if((bytes & (LBPG - 1)) > (LBPG - 2*sizeof(long))) bytes += LBPG;
bytes = roundup(bytes,LBPG);
current = csegment(typestr->type,bytes/sizeof(long),purep);
current->vl.vectorl[0] = bytes - 2*sizeof(long);
if(purep) {
current->v.vector[1] = (lispval)(typestr->next_pure_free);
typestr->next_pure_free = (char *) &(current->v.vector[1]);
/* make them pure */
pages = bytes/LBPG;
for(pindex = ATOX(current); pages ; pages--)
{
purepage[pindex++] = TRUE;
}
} else {
current->v.vector[1] = (lispval)(typestr->next_free);
typestr->next_free = (char *) &(current->v.vector[1]);
if(debugin) fprintf(stderr,"grabbed %d vec pages\n",bytes/LBPG);
}
if(debugin)
fprintf(stderr,"creating a new vec, size %d\n",current->v.vector[0]);
goto again;
}
/*
* Ipurep :: routine to check for pureness of a data item
*
*/
lispval
Ipurep(element)
lispval element;
{
if(purepage[ATOX(element)]) return(tatom) ; else return(nil);
}
/* routines to return space to the free list. These are used by the
* arithmetic routines which tend to create large intermediate results
* which are know to be garbage after the calculation is over.
*
* There are jsb callable versions of these routines in qfuncl.s
*/
/* pruneb - prune bignum. A bignum is an sdot followed by a list of
* dtprs. The dtpr list is linked by car instead of cdr so when we
* put it in the free list, we have to change the links.
*/
pruneb(bignum)
lispval bignum;
{
register lispval temp = bignum;
if(TYPE(temp) != SDOT)
errorh(Vermisc,"value to pruneb not a sdot",nil,FALSE,0);
--(sdot_items->i);
temp->s.I = (int) sdot_str.next_free;
sdot_str.next_free = (char *) temp;
/* bignums are not terminated by nil on the dual,
they are terminated by (lispval) 0 */
while(temp = temp->s.CDR)
{
if(TYPE(temp) != DTPR)
errorh(Vermisc,"value to pruneb not a list",
nil,FALSE,0);
--(dtpr_items->i);
temp->s.I = (int) dtpr_str.next_free;
dtpr_str.next_free = (char *) temp;
}
}
lispval
Badcall()
{ error("BAD FUNCTION DESCRIPTOR USED IN CALL",FALSE); }
/*
* Ngc
* this is the lisp function gc
*
*/
lispval
Ngc()
{
return(gc((struct types *)CNIL));
}
/*
* 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 an nlambda of no arguments.
* type_struct is the type of lisp data that ran out causing this
* garbage collection
*/
int printall = 0;
lispval
gc(type_struct)
struct types *type_struct;
{
lispval save;
struct tms begin, finish;
extern int gctime;
/* if this was called automatically when space ran out
* print out a message
*/
if((Vgcprint->a.clb != nil)
&& (type_struct != (struct types *) CNIL ))
{
FILE *port = okport(Vpoport->a.clb,poport);
fprintf(port,"gc:");
fflush(port);
}
if(gctime) times(&begin);
gc1(); /* mark&sweep */
/* Now we call gcafter--special c ase if gc called from LISP */
if( type_struct == (struct types *) CNIL )
gccall1->d.cdr = nil; /* make the call "(gcafter)" */
else
{
gccall1->d.cdr = gccall2;
gccall2->d.car = *(type_struct->type_name);
}
PUSHDOWN(gcdis,gcdis); /* flag to indicate in garbage collector */
save = eval(gccall1); /* call gcafter */
POP; /* turn off flag */
if(gctime) {
times(&finish);
gctime += (finish.tms_utime - begin.tms_utime);
}
return(save); /* return result of gcafter */
}
/* gc1() **************************************************************/
/* */
/* Mark-and-sweep phase */
gc1()
{
int j, k;
register int *start,bvalue,type_len;
register struct types *s;
int *point,i,freecnt,itemstogo,bits,bindex,type,bytestoclear;
int usedcnt;
char *pindex;
struct argent *loop2;
struct nament *loop3;
struct atom *symb;
int markdp();
extern int hashtop;
pagerand();
/* decide whether to check LISP structure or not */
#ifdef METER
vtimes(&premark,0);
mrkdpcnt = 0;
conssame = consdiff = consnil = 0;
#endif
/* first set all bit maps to zero */
#ifdef SLOCLEAR
{
int enddat;
enddat = (int)(datalim-OFFSET) >> 8;
for(bvalue=0; bvalue < (int)enddat ; ++bvalue)
{
qbitmap[bvalue] = zeroq;
}
}
#endif
/* try the movc5 to clear the bit maps */
/* the maximum number of bytes we can clear in one sweep is
* 2^16 (or 1<<16 in the C lingo)
*/
bytestoclear = ((((int)datalim)-((int)beginsweep)) >> 9) * 16;
for(start = bitmapi + ATOLX(beginsweep);
bytestoclear > 0;)
{
if(bytestoclear > MAXCLEAR)
blzero((int)start,MAXCLEAR);
else
blzero((int)start,bytestoclear);
start = (int *) (MAXCLEAR + (int) start);
bytestoclear -= MAXCLEAR;
}
/* mark all atoms in the oblist */
for( bvalue=0 ; bvalue <= hashtop-1 ; bvalue++ ) /* though oblist */
{
for( symb = hasht[bvalue] ; symb != (struct atom *) CNIL ;
symb = symb-> hshlnk) {
markdp((lispval)symb);
}
}
/* Mark all the atoms and ints associated with the hunk
data types */
for(i=0; i<7; i++) {
markdp(hunk_items[i]);
markdp(hunk_name[i]);
markdp(hunk_pages[i]);
}
/* next run up the name stack */
for(loop2 = np - 1; loop2 >= orgnp; --loop2) MARKVAL(loop2->val);
/* now the bindstack (vals only, atoms are marked elsewhere ) */
for(loop3 = bnp - 1; loop3 >= orgbnp; --loop3)MARKVAL(loop3->val);
/* next mark all compiler linked data */
/* if the Vpurcopylits switch is non nil (lisp variable $purcopylits)
* then when compiled code is read in, it tables will not be linked
* into this table and thus will not be marked here. That is ok
* though, since that data is assumed to be pure.
*/
point = bind_lists;
while((start = point) != (int *)CNIL) {
while( *start != -1 )
{
markdp((lispval)*start);
start++;
}
point = (int *)*(point-1);
}
/* next mark all system-significant lisp data */
for(i=0; i<SIGNIF; ++i) markdp((lispsys[i]));
#ifdef METER
vtimes(&presweep,0);
#endif
/* all accessible data has now been marked. */
/* all collectable spaces must be swept, */
/* and freelists constructed. */
/* first clear the structure elements for types
* we will sweep
*/
for(k=0 ; k <= VECTORI ; k++)
{
if( s=gcableptr[k]) {
if(k==STRNG && !gcstrings) { /* don't do anything*/ }
else
{
(*(s->items))->i = 0;
s->space_left = 0;
s->next_free = (char *) CNIL;
}
}
}
#if m_68k
fixbits(bitmapi+ATOLX(beginsweep),bitmapi+ATOLX(datalim));
#endif
/* sweep up in memory looking at gcable pages */
for(start = beginsweep, bindex = ATOLX(start),
pindex = &purepage[ATOX(start)];
start < (int *)datalim;
start += 128, pindex++)
{
if(!(s=gcableptr[type = TYPE(start)]) || *pindex
#ifdef GCSTRINGS
|| (type==STRNG && !gcstrings)
#endif
)
{
/* ignore this page but advance pointer */
bindex += 4; /* and 4 words of 32 bit bitmap words */
continue;
}
freecnt = 0; /* number of free items found */
usedcnt = 0; /* number of used items found */
point = start;
/* sweep dtprs as a special case, since
* 1) there will (usually) be more dtpr pages than any other type
* 2) most dtpr pages will be empty so we can really win by special
* caseing the sweeping of massive numbers of free cells
*/
/* since sdot's have the same structure as dtprs, this code will
work for them too
*/
if((type == DTPR) || (type == SDOT))
{
int *head,*lim;
head = (int *) s->next_free; /* first value on free list*/
for(i=0; i < 4; i++) /* 4 bit map words per page */
{
bvalue = bitmapi[bindex++]; /* 32 bits = 16 dtprs */
if(bvalue == 0) /* if all are free */
{
*point = (int)head;
lim = point + 32; /* 16 dtprs = 32 ints */
for(point += 2; point < lim ; point += 2)
{
*point = (int)(point - 2);
}
head = point - 2;
freecnt += 16;
}
else for(j = 0; j < 16 ; j++)
{
if(!(bvalue & 1))
{
freecnt++;
*point = (int)head;
head = point;
}
#ifdef METER
/* check if the page address of this cell is the
* same as the address of its cdr
*/
else if(FALSE && gcstat && (type == DTPR))
{
if(((int)point & ~511)
== ((int)(*point) & ~511)) conssame++;
else consdiff++;
usedcnt++;
}
#endif
else usedcnt++; /* keep track of used */
point += 2;
bvalue = bvalue >> 2;
}
}
s->next_free = (char *) head;
}
else if((type == VECTOR) || (type == VECTORI))
{
int canjoin = FALSE;
int *tempp;
/* check if first item on freelist ends exactly at
this page
*/
if(((tempp = (int *)s->next_free) != (int *)CNIL)
&& ((VecTotSize(((lispval)tempp)->vl.vectorl[-1])
+ 1 + tempp)
== point))
canjoin = TRUE;
/* arbitrary sized vector sweeper */
/*
* jump past first word since that is a size fixnum
* and second word since that is property word
*/
if(debugin)
fprintf(stderr,"vector sweeping, start at 0x%x\n",
point);
bits = 30;
bvalue = bitmapi[bindex++] >> 2;
point += 2;
while (TRUE) {
type_len = point[VSizeOff];
if(debugin) {
fprintf(stderr,"point: 0x%x, type_len %d\n",
point, type_len);
fprintf(stderr,"bvalue: 0x%x, bits: %d, bindex: 0x%x\n",
bvalue, bits, bindex);
}
/* get size of vector */
if(!(bvalue & 1)) /* if free */
{
if(debugin) fprintf(stderr,"free\n");
freecnt += type_len + 2*sizeof(long);
if(canjoin)
{
/* join by adjusting size of first vector */
((lispval)(s->next_free))->vl.vectorl[-1]
+= type_len + 2*sizeof(long);
if(debugin)
fprintf(stderr,"joined size: %d\n",
((lispval)(s->next_free))->vl.vectorl[-1]);
}
else {
/* vectors are linked at the property word */
*(point - 1) = (int)(s->next_free);
s->next_free = (char *) (point - 1);
}
canjoin = TRUE;
}
else {
canjoin = FALSE;
usedcnt += type_len + 2*sizeof(long);
}
point += VecTotSize(type_len);
/* we stop sweeping only when we reach a page
boundary since vectors can span pages
*/
if(((int)point & 511) == 0)
{
/* reset the counters, we cannot predict how
* many pages we have crossed over
*/
bindex = ATOLX(point);
/* these will be inced, so we must dec */
pindex = &purepage[ATOX(point)] - 1;
start = point - 128;
if(debugin)
fprintf(stderr,
"out of vector sweep when point = 0x%x\n",
point);
break;
}
/* must advance to next point and next value in bitmap.
* we add VecTotSize(type_len) + 2 to get us to the 0th
* entry in the next vector (beyond the size fixnum)
*/
point += 2; /* point to next 0th entry */
if ( (bits -= (VecTotSize(type_len) + 2)) > 0)
bvalue = bvalue >> (VecTotSize(type_len) + 2);
else {
bits = -bits; /* must advance to next word in map */
bindex += bits / 32; /* this is tricky stuff... */
bits = bits % 32;
bvalue = bitmapi[bindex++] >> bits;
bits = 32 - bits;
}
}
}
else {
/* general sweeper, will work for all types */
itemstogo = s->space; /* number of items per page */
bits = 32; /* number of bits per word */
type_len = s->type_len;
/* printf(" s %d, itemstogo %d, len %d\n",s,itemstogo,type_len);*/
bvalue = bitmapi[bindex++];
while(TRUE)
{
if(!(bvalue & 1)) /* if data element is not marked */
{
freecnt++;
*point = (int) (s->next_free) ;
s->next_free = (char *) point;
}
else usedcnt++;
if( --itemstogo <= 0 )
{ if(type_len >= 64)
{
bindex++;
if(type_len >=128) bindex += 2;
}
break;
}
point += type_len;
/* shift over mask by number of words in data type */
if( (bits -= type_len) > 0)
{ bvalue = bvalue >> type_len;
}
else if( bits == 0 )
{ bvalue = bitmapi[bindex++];
bits = 32;
}
else
{ bits = -bits;
while( bits >= 32) { bindex++;
bits -= 32;
}
bvalue = bitmapi[bindex++];
bvalue = bvalue >> bits;
bits = 32 - bits;;
}
}
}
s->space_left += freecnt;
(*(s->items))->i += usedcnt;
}
#ifdef METER
vtimes(&alldone,0);
if(gcstat) gcdump();
#endif
pagenorm();
}
/*
* alloc
*
* This routine tries to allocate one or more pages of the space named
* by the first argument. Returns the number of pages actually allocated.
*
*/
lispval
alloc(tname,npages)
lispval tname; long npages;
{
long ii, jj;
struct types *typeptr;
ii = typenum(tname);
typeptr = spaces[ii];
if(npages <= 0) return(inewint(npages));
if((ATOX(datalim)) + npages > TTSIZE)
error("Space request would exceed maximum memory allocation",FALSE);
if((ii == VECTOR) || (ii == VECTORI))
{
/* allocate in one big chunk */
tname = csegment((int) ii,(int) npages*128,0);
tname->vl.vectorl[0] = (npages*512 - 2*sizeof(long));
tname->v.vector[1] = (lispval) typeptr->next_free;
typeptr->next_free = (char *) &(tname->v.vector[1]);
if(debugin) fprintf(stderr,"alloced %d vec pages\n",npages);
return(inewint(npages));
}
for( jj=0; jj<npages; ++jj)
if(get_more_space(spaces[ii],FALSE)) break;
return(inewint(jj));
}
/*
* csegment(typecode,nitems,useholeflag)
* allocate nitems of type typecode. If useholeflag is true, then
* allocate in the hole if there is room. This routine doesn't look
* in the free lists, it always allocates space.
*/
lispval
csegment(typecode,nitems,useholeflag)
{
register int ii, jj;
register char *charadd;
ii = typecode;
if(ii!=OTHER) nitems *= 4*spaces[ii]->type_len;
nitems = roundup(nitems,512); /* round up to right length */
#ifdef HOLE
if(useholeflag)
charadd = gethspace(nitems,ii);
else
#endif
{
charadd = sbrk(nitems);
datalim = (lispval)(charadd+nitems);
}
if( (int) charadd <= 0 )
error("NOT ENOUGH SPACE FOR ARRAY",FALSE);
/*if(ii!=OTHER)*/ (*spaces[ii]->pages)->i += nitems/512;
if(ATOX(datalim) > fakettsize) {
datalim = (lispval) (OFFSET + (fakettsize << 9));
if(fakettsize >= TTSIZE)
{
printf("There isn't room enough to continue, goodbye\n");
franzexit(1);
}
fakettsize++;
badmem(53);
}
for(jj=0; jj<nitems; jj=jj+512) {
SETTYPE(charadd+jj, ii,30);
}
ii = (int) charadd;
while(nitems > MAXCLEAR)
{
blzero(ii,MAXCLEAR);
nitems -= MAXCLEAR;
ii += MAXCLEAR;
}
blzero(ii,nitems);
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(spaces[ii] && tname == *(spaces[ii]->type_name)) break;
if(ii == NUMSPACES)
{
tname = error("BAD TYPE NAME",TRUE);
goto chek;
}
return(ii);
}
char *
gethspace(segsiz,type)
{
extern usehole; extern char holend[]; extern char *curhbeg;
register char *value;
if(usehole) {
curhbeg = (char *) roundup(((int)curhbeg),LBPG);
if((holend - curhbeg) < segsiz)
{
usehole = FALSE;
curhbeg = holend;
} else {
value = curhbeg;
curhbeg = curhbeg + segsiz;
/*printf("start %d, finish %d, size %d\n",value, curhbeg,segsiz);*/
return(value);
}
}
value = (ysbrk(segsiz/LBPG,type));
datalim = (lispval)(value + segsiz);
return(value);
}
gcrebear()
{
#ifdef HOLE
register int i; register struct types *p;
/* this gets done upon rebirth */
str_current[1].space_left = 0;
#ifndef GCSTRINGS
str_current[0].space_left = 0; /* both kinds of strings go in hole*/
#endif
funct_str.space_left = 0;
funct_str.next_free = (char *) CNIL;
/* clear pure space pointers */
for(i = 0; i < NUMSPACES; i++)
{
if(p=spaces[i])
p->next_pure_free = (char *) CNIL;
}
#endif
}
/** 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;
{
#ifdef tahoe
register int r, s; /* (goes with non-asm readbit, oksetbit) */
#endif
/* register hsize, hcntr; */
int hsize, hcntr;
#ifdef METER
mrkdpcnt++;
#endif
ptr_loop:
if(((int)p) <= ((int)nil)) return; /* do not mark special data types or nil=0 */
switch( TYPE(p) )
{
case ATOM:
ftstbit;
MARKVAL(p->a.clb);
MARKVAL(p->a.plist);
MARKVAL(p->a.fnbnd);
#ifdef GCSTRINGS
if(gcstrings) MARKVAL(((lispval)p->a.pname));
return;
case STRNG:
p = (lispval) (((int) p) & ~ (LBPG-1));
ftstbit;
#endif
return;
case INT:
case DOUB:
ftstbit;
return;
case VALUE:
ftstbit;
p = p->l;
goto ptr_loop;
case DTPR:
ftstbit;
MARKVAL(p->d.car);
#ifdef METER
/* if we are metering , then check if the cdr is
* nil, or if the cdr is on the same page, and if
* it isn't one of those, then it is on a different
* page
*/
if(gcstat)
{
if(p->d.cdr == nil) consnil++;
else if(((int)p & ~511)
== (((int)(p->d.cdr)) & ~511))
conssame++;
else consdiff++;
}
#endif
p = p->d.cdr;
goto ptr_loop;
case ARRAY:
ftstbit; /* mark array itself */
MARKVAL(p->ar.accfun); /* mark access function */
MARKVAL(p->ar.aux); /* mark aux data */
MARKVAL(p->ar.length); /* mark length */
MARKVAL(p->ar.delta); /* mark delta */
if(TYPE(p->ar.aux)==DTPR && p->ar.aux->d.car==Vnogbar)
{
/* a non garbage collected array must have its
* array space marked but the value of the array
* space is not marked
*/
int l;
int cnt,d;
if(debugin) {
printf("mark array holders len %d, del %d, start 0x%x\n",
p->ar.length->i,p->ar.delta->i,p->ar.data);
fflush(stdout);
}
l = p->ar.length->i; /* number of elements */
d = p->ar.delta->i; /* bytes per element */
p = (lispval) p->ar.data;/* address of first one*/
if(purepage[ATOX(p)]) return;
for((cnt = 0); cnt<l ;
p = (lispval)(((char *) p) + d), cnt++)
{
setbit;
}
} else {
/* register int i, l; int d; */
/* register char *dataptr = p->ar.data; */
int i,l,d;
char *dataptr = p->ar.data;
for(i=0, l=p->ar.length->i, d=p->ar.delta->i; i<l; ++i)
{
markdp((lispval)dataptr);
dataptr += d;
}
}
return;
case SDOT:
do {
ftstbit;
p = p->s.CDR;
} while (p!=0);
return;
case BCD:
ftstbit;
markdp(p->bcd.discipline);
return;
case HUNK2:
case HUNK4:
case HUNK8:
case HUNK16:
case HUNK32:
case HUNK64:
case HUNK128:
{
hsize = 2 << HUNKSIZE(p);
ftstbit;
for (hcntr = 0; hcntr < hsize; hcntr++)
MARKVAL(p->h.hunk[hcntr]);
return;
}
case VECTORI:
ftstbit;
MARKVAL(p->v.vector[-1]); /* mark property */
return;
case VECTOR:
{
register int vsize;
ftstbit;
vsize = VecSize(p->vl.vectorl[VSizeOff]);
if(debugin)
fprintf(stderr,"mark vect at %x size %d\n",
p,vsize);
while(--vsize >= -1)
{
MARKVAL(p->v.vector[vsize]);
};
return;
}
}
return;
}
/* xsbrk allocates space in large chunks (currently 16 pages)
* xsbrk(1) returns a pointer to a page
* xsbrk(0) returns a pointer to the next page we will allocate (like sbrk(0))
*/
char *
xsbrk(n)
{
static char *xx; /* pointer to next available blank page */
extern int xcycle; /* number of blank pages available */
lispval u; /* used to compute limits of bit table */
if( (xcycle--) <= 0 )
{
xcycle = 15;
xx = sbrk(16*LBPG); /* get pages 16 at a time */
if( (int)xx== -1 )
lispend("For sbrk from lisp: no space... Goodbye!");
}
else xx += LBPG;
if(n == 0)
{
xcycle++; /* don't allocate the page */
xx -= LBPG;
return(xx); /* just return its address */
}
if( (u = (lispval)(xx+LBPG)) > 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*LBPG);
if((int)xx == -1)
error("OUT OF SPACE FOR ARRAY REQUEST",FALSE);
datalim = (lispval)(xx+pages*LBPG); /* compute bit table limit */
/* set type for pages */
for(i = 0; i < pages; ++i) {
SETTYPE((xx + i*LBPG),type,10);
}
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(purep)
{ register lispval aptr;
register char *name, *endname;
register int hash;
lispval b;
char c;
name = strbuf;
if (*name == (char)0377) return (eofa);
hash = hashfcn(name);
atmlen = strlen(name) + 1;
aptr = (lispval) hasht[hash];
while (aptr != CNIL)
/* if (strcmp(name,aptr->a.pname)==0) */
if (*name==*aptr->a.pname && strcmp(name,aptr->a.pname)==0)
return (aptr);
else
aptr = (lispval) aptr->a.hshlnk;
aptr = (lispval) newatom(purep); /*share pname of atoms on oblist*/
aptr->a.hshlnk = hasht[hash];
hasht[hash] = (struct atom *) aptr;
endname = name + atmlen - 2;
if ((atmlen != 4) && (*name == 'c') && (*endname == 'r'))
{
b = newdot();
protect(b);
b->d.car = lambda;
b->d.cdr = newdot();
b = b->d.cdr;
b->d.car = newdot();
(b->d.car)->d.car = xatom;
while(TRUE)
{
b->d.cdr = newdot();
b= b->d.cdr;
if(++name == endname)
{
b->d.car= (lispval) xatom;
aptr->a.fnbnd = (--np)->val;
break;
}
b->d.car= newdot();
b= b->d.car;
if((c = *name) == 'a') b->d.car = cara;
else if (c == 'd') b->d.car = cdra;
else{ --np;
break;
}
}
}
return(aptr);
}
/*
* inewatom is like getatom, except that you provide it a string
* to be used as the print name. It doesn't do the automagic
* creation of things of the form c[ad]*r.
*/
lispval
inewatom(name)
register char *name;
{ register struct atom *aptr;
register int hash;
extern struct types atom_str;
char c;
if (*name == (char)0377) return (eofa);
hash = hashfcn(name);
aptr = hasht[hash];
while (aptr != (struct atom *)CNIL)
if (strcmp(name,aptr->pname)==0)
return ((lispval) aptr);
else
aptr = aptr->hshlnk;
aptr = (struct atom *) next_one(&atom_str) ;
aptr->plist = aptr->fnbnd = nil;
aptr->clb = CNIL;
aptr->pname = name;
aptr->hshlnk = hasht[hash];
hasht[hash] = aptr;
return((lispval)aptr);
}
/* our hash function */
hashfcn(symb)
register char *symb;
{
register int i;
/* for (i=0 ; *symb ; i += i + *symb++); return(i & (HASHTOP-1)); */
for (i=0 ; *symb ; i += i*2 + *symb++);
return(i&077777 % HASHTOP);
}
lispval
LImemory()
{
int nextadr, pagesinuse;
printf("Memory report. max pages = %d (0x%x) = %d Bytes\n",
TTSIZE,TTSIZE,TTSIZE*LBPG);
#ifdef HOLE
printf("This lisp has a hole:\n");
printf(" current hole start: %d (0x%x), end %d (0x%x)\n",
curhbeg, curhbeg, holend, holend);
printf(" hole free: %d bytes = %d pages\n\n",
holend-curhbeg, (holend-curhbeg)/LBPG);
#endif
nextadr = (int) xsbrk(0); /* next space to be allocated */
pagesinuse = nextadr/LBPG;
printf("Next allocation at addr %d (0x%x) = page %d\n",
nextadr, nextadr, pagesinuse);
printf("Free data pages: %d\n", TTSIZE-pagesinuse);
return(nil);
}
extern struct atom *hasht[HASHTOP];
myhook(){}