#ifndef lint static char *rcsid = "$Header: alloc.c,v 1.12 85/03/24 10:59:57 sklower Exp $"; #endif /* -[Thu Feb 2 16:15:30 1984 by jkf]- * alloc.c $Locker: $ * storage allocator and garbage collector * * (c) copyright 1982, Regents of the University of California */ # include "global.h" # include "structs.h" #include #include #ifdef METER #include #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 /* define ftstbit if( readbit(p) ) return; oksetbit; */ # define readbit(p) ((int)bbitmap[r=(int)p>>5] & (s=bitmsk[((int)p>>2)&7])) # define lookbit(p) (bbitmap[(int)p>>5] & bitmsk[((int)p>>2) & 7]) /* # define setbit(p) {bbitmap[(int)p>>5] |= bitmsk[((int)p >> 2) & 7];} */ # define oksetbit {bbitmap[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];} # 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 char bitmsk[8]={1,2,4,8,16,32,64,128}; /* used by bit-marking macros */ 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; cntra.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; iitems))->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; jjtype_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 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; iitype_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; { /* register int r, s; (goes with non-asm readbit, oksetbit) */ /* 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 && FALSE) { 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); cntar.data; */ int i,l,d; char *dataptr = p->ar.data; for(i=0, l=p->ar.length->i, d=p->ar.delta->i; is.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(){}