![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to Talloc.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 3BSD / cmd / lisp|
Return to Talloc.c CVS log | Up to [CSRG BSD Unix] / 3BSD / cmd / lisp |
1.1 root 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 = nitems*4*spaces[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(16*NBPG); /* 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+pages*NBPG); /* 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:
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.