From: John Foderaro Date: Fri, 28 Dec 1979 03:11:09 +0000 (-0800) Subject: BSD 3 development X-Git-Tag: BSD-3~261 X-Git-Url: https://git.subgeniuskitty.com/unix-history/.git/commitdiff_plain/b2e344cab991d347a6586ccb4fd4712ad6f9267d BSD 3 development Work on file usr/src/cmd/lisp/Talloc.c Synthesized-from: 3bsd --- diff --git a/usr/src/cmd/lisp/Talloc.c b/usr/src/cmd/lisp/Talloc.c new file mode 100644 index 0000000000..5f61bf4439 --- /dev/null +++ b/usr/src/cmd/lisp/Talloc.c @@ -0,0 +1,727 @@ +# 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; cntrpname = (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; itype; + 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); + jspace; ++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; jjtype_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; jjtype); + } + 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; iitype_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; iCDR; + } 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); + } +