![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to alloc.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSD / ucb / lisp / franz|
Return to alloc.c CVS log | Up to [CSRG BSD Unix] / 43BSD / ucb / lisp / franz |
1.1 root 1: #ifndef lint
2: static char *rcsid =
3: "$Header: alloc.c,v 1.12 85/03/24 10:59:57 sklower Exp $";
4: #endif
5:
6: /* -[Thu Feb 2 16:15:30 1984 by jkf]-
7: * alloc.c $Locker: $
8: * storage allocator and garbage collector
9: *
10: * (c) copyright 1982, Regents of the University of California
11: */
12:
13: # include "global.h"
14: # include "structs.h"
15:
16: #include <sys/types.h>
17: #include <sys/times.h>
18: #ifdef METER
19: #include <sys/vtimes.h>
20: #endif
21:
22: # define NUMWORDS TTSIZE * 128 /* max number of words in P0 space */
23: # define BITQUADS TTSIZE * 2 /* length of bit map in quad words */
24: # define BITLONGS TTSIZE * 4 /* length of bit map in long words */
25:
26: # ifdef vax
27: # define ftstbit asm(" ashl $-2,r11,r3");\
28: asm(" bbcs r3,_bitmapi,1f");\
29: asm(" ret"); \
30: asm("1:");
31:
32: /* setbit is a fast way of setting a bit, it is like ftstbit except it
33: * always continues on to the next instruction
34: */
35: # define setbit asm(" ashl $-2,r11,r0"); \
36: asm(" bbcs r0,_bitmapi,$0");
37: # endif
38:
39: # if m_68k
40: # define ftstbit {if(Itstbt()) return;}
41: # define setbit Itstbt()
42: # endif
43:
44: /* define ftstbit if( readbit(p) ) return; oksetbit; */
45: # define readbit(p) ((int)bbitmap[r=(int)p>>5] & (s=bitmsk[((int)p>>2)&7]))
46: # define lookbit(p) (bbitmap[(int)p>>5] & bitmsk[((int)p>>2) & 7])
47: /* # define setbit(p) {bbitmap[(int)p>>5] |= bitmsk[((int)p >> 2) & 7];} */
48: # define oksetbit {bbitmap[r] |= s;}
49:
50: # define readchk(p) ((int)bitfre[(int)p>>5] & bitmsk[((int)p>>2)&7])
51: # define setchk(p) {bitfre[(int)p>>5] |= bitmsk[((int)p >> 2) & 7];}
52: # define roundup(x,l) (((x - 1) | (l - 1)) + 1)
53:
54: # define MARKVAL(v) if(((int)v) >= (int)beginsweep) markdp(v);
55: # define ATOLX(p) ((((int)p)-OFFSET)>>7)
56:
57: /* the Vax hardware only allows 2^16-1 bytes to be accessed with one
58: * movc5 instruction. We use the movc5 instruction to clear the
59: * bitmaps.
60: */
61: # define MAXCLEAR ((1<<16)-1)
62:
63: /* METER denotes something added to help meter storage allocation. */
64:
65: extern int *beginsweep; /* first sweepable data */
66: extern char purepage[];
67: extern int fakettsize;
68: extern int gcstrings;
69: int debugin = FALSE; /* temp debug flag */
70:
71: extern lispval datalim; /* end of data space */
72: int bitmapi[BITLONGS]; /* the bit map--one bit per long */
73: double zeroq; /* a quad word of zeros */
74: char *bbitmap = (char *) bitmapi; /* byte version of bit map array */
75: double *qbitmap = (double *) bitmapi; /* integer version of bit map array */
76: #ifdef METER
77: extern int gcstat;
78: extern struct vtimes
79: premark,presweep,alldone; /* actually struct tbuffer's */
80:
81: extern int mrkdpcnt;
82: extern int conssame, consdiff,consnil; /* count of cells whose cdr point
83: * to the same page and different
84: * pages respectively
85: */
86: #endif
87: char bitmsk[8]={1,2,4,8,16,32,64,128}; /* used by bit-marking macros */
88: extern int *bind_lists ; /* lisp data for compiled code */
89:
90: char *xsbrk();
91: char *gethspace();
92:
93:
94: extern struct types atom_str, strng_str, int_str, dtpr_str, doub_str,
95: array_str, sdot_str, val_str, funct_str, hunk_str[], vect_str,
96: vecti_str, other_str;
97:
98: extern struct str_x str_current[];
99:
100: lispval hunk_items[7], hunk_pages[7], hunk_name[7];
101:
102: extern int initflag; /* starts off TRUE: initially gc not allowed */
103:
104:
105: /* this is a table of pointers to all struct types objects
106: * the index is the type number.
107: */
108: static struct types *spaces[NUMSPACES] =
109: {&strng_str, &atom_str, &int_str,
110: &dtpr_str, &doub_str, &funct_str,
111: (struct types *) 0, /* port objects not allocated in this way */
112: &array_str,
113: &other_str, /* other objects not allocated in this way */
114: &sdot_str,&val_str,
115: &hunk_str[0], &hunk_str[1], &hunk_str[2],
116: &hunk_str[3], &hunk_str[4], &hunk_str[5],
117: &hunk_str[6],
118: &vect_str, &vecti_str};
119:
120:
121: /* this is a table of pointers to collectable struct types objects
122: * the index is the type number.
123: */
124: struct types *gcableptr[] = {
125: #ifndef GCSTRINGS
126: (struct types *) 0, /* strings not collectable */
127: #else
128: &strng_str,
129: #endif
130: &atom_str,
131: &int_str, &dtpr_str, &doub_str,
132: (struct types *) 0, /* binary objects not collectable */
133: (struct types *) 0, /* port objects not collectable */
134: &array_str,
135: (struct types *) 0, /* gap in the type number sequence */
136: &sdot_str,&val_str,
137: &hunk_str[0], &hunk_str[1], &hunk_str[2],
138: &hunk_str[3], &hunk_str[4], &hunk_str[5],
139: &hunk_str[6],
140: &vect_str, &vecti_str};
141:
142:
143: /*
144: * get_more_space(type_struct,purep)
145: *
146: * Allocates and structures a new page, returning 0.
147: * If no space is available, returns positive number.
148: * If purep is TRUE, then pure space is allocated.
149: */
150: get_more_space(type_struct,purep)
151: struct types *type_struct;
152: {
153: int cntr;
154: char *start;
155: int *loop, *temp;
156: lispval p;
157: extern char holend[];
158:
159: if( (int) datalim >= TTSIZE*LBPG+OFFSET ) return(2);
160:
161: /*
162: * If the hole is defined, then we allocate binary objects
163: * and strings in the hole. However we don't put strings in
164: * the hole if strings are gc'ed.
165: */
166: #ifdef HOLE
167: if( purep
168: #ifndef GCSTRINGS
169: || type_struct==&strng_str
170: #endif
171: || type_struct==&funct_str)
172: start = gethspace(LBPG,type_struct->type);
173: else
174: #endif
175: start = xsbrk(1); /* get new page */
176:
177:
178: SETTYPE(start, type_struct->type,20); /* set type of page */
179:
180: purepage[ATOX(start)] = (char)purep; /* remember if page was pure*/
181:
182: /* bump the page counter for this space if not pure */
183:
184: if(!purep) ++((*(type_struct->pages))->i);
185:
186: type_struct->space_left = type_struct->space;
187: temp = loop = (int *) start;
188: for(cntr=1; cntr < type_struct->space; cntr++)
189: loop = (int *) (*loop = (int) (loop + type_struct->type_len));
190:
191: /* attach new cells to either the pure space free list or the
192: * standard free list
193: */
194: if(purep) {
195: *loop = (int) (type_struct->next_pure_free);
196: type_struct->next_pure_free = (char *) temp;
197: }
198: else {
199: *loop = (int) (type_struct->next_free);
200: type_struct->next_free = (char *) temp;
201: }
202:
203: /* if type atom, set pnames to CNIL */
204:
205: if( type_struct == &atom_str )
206: for(cntr=0, p=(lispval) temp; cntr<atom_str.space; ++cntr)
207: {
208: p->a.pname = (char *) CNIL;
209: p = (lispval) ((int *)p + atom_str.type_len);
210: }
211: return(0); /* space was available */
212: }
213:
214:
215: /*
216: * next_one(type_struct)
217: *
218: * Allocates one new item of each kind of space, except STRNG.
219: * If there is no space, calls gc, the garbage collector.
220: * If there is still no space, allocates a new page using
221: * get_more_space
222: */
223:
224: lispval
225: next_one(type_struct)
226: struct types *type_struct;
227: {
228:
229: register char *temp;
230:
231: while(type_struct->next_free == (char *) CNIL)
232: {
233: int g;
234:
235: if(
236: (initflag == FALSE) && /* dont gc during init */
237: #ifndef GCSTRINGS
238: (type_struct->type != STRNG) && /* can't collect strings */
239: #else
240: gcstrings && /* user (sstatus gcstrings) */
241: #endif
242: (type_struct->type != BCD) && /* nor function headers */
243: gcdis->a.clb == nil ) /* gc not disabled */
244: /* not to collect during load */
245:
246: {
247: gc(type_struct); /* collect */
248: }
249:
250: if( type_struct->next_free != (char *) CNIL ) break;
251:
252: if(! (g=get_more_space(type_struct,FALSE))) break;
253:
254: space_warn(g);
255: }
256: temp = type_struct->next_free;
257: type_struct->next_free = * (char **)(type_struct->next_free);
258: (*(type_struct->items))->i ++;
259: return((lispval) temp);
260: }
261: /*
262: * Warn about exhaustion of space,
263: * shared with next_pure_free().
264: */
265: space_warn(g)
266: {
267: if( g==1 ) {
268: plimit->i += NUMSPACES; /* allow a few more pages */
269: copval(plima,plimit); /* restore to reserved reg */
270:
271: error("PAGE LIMIT EXCEEDED--EMERGENCY PAGES ALLOCATED", TRUE);
272: } else error("SORRY, ABSOLUTE PAGE LIMIT HAS BEEN REACHED", TRUE);
273: }
274:
275:
276: /* allocate an element of a pure structure. Pure structures will
277: * be ignored by the garbage collector.
278: */
279: lispval
280: next_pure_one(type_struct)
281: struct types *type_struct;
282: {
283:
284: register char *temp;
285:
286: while(type_struct->next_pure_free == (char *) CNIL)
287: {
288: int g;
289: if(! (g=get_more_space(type_struct,TRUE))) break;
290: space_warn(g);
291: }
292:
293: temp = type_struct->next_pure_free;
294: type_struct->next_pure_free = * (char **)(type_struct->next_pure_free);
295: return((lispval) temp);
296: }
297:
298: lispval
299: newint()
300: {
301: return(next_one(&int_str));
302: }
303:
304: lispval
305: pnewint()
306: {
307: return(next_pure_one(&int_str));
308: }
309:
310: lispval
311: newdot()
312: {
313: lispval temp;
314:
315: temp = next_one(&dtpr_str);
316: temp->d.car = temp->d.cdr = nil;
317: return(temp);
318: }
319:
320: lispval
321: pnewdot()
322: {
323: lispval temp;
324:
325: temp = next_pure_one(&dtpr_str);
326: temp->d.car = temp->d.cdr = nil;
327: return(temp);
328: }
329:
330: lispval
331: newdoub()
332: {
333: return(next_one(&doub_str));
334: }
335:
336: lispval
337: pnewdb()
338: {
339: return(next_pure_one(&doub_str));
340: }
341:
342: lispval
343: newsdot()
344: {
345: register lispval temp;
346: temp = next_one(&sdot_str);
347: temp->d.car = temp->d.cdr = 0;
348: return(temp);
349: }
350:
351: lispval
352: pnewsdot()
353: {
354: register lispval temp;
355: temp = next_pure_one(&sdot_str);
356: temp->d.car = temp->d.cdr = 0;
357: return(temp);
358: }
359:
360: struct atom *
361: newatom(pure) {
362: struct atom *save; char *mypname;
363:
364: mypname = newstr(pure);
365: pnameprot = ((lispval) mypname);
366: save = (struct atom *) next_one(&atom_str) ;
367: save->plist = save->fnbnd = nil;
368: save->hshlnk = (struct atom *)CNIL;
369: save->clb = CNIL;
370: save->pname = mypname;
371: return (save);
372: }
373:
374: char *
375: newstr(purep) {
376: char *save, *strcpy();
377: int atmlen;
378: register struct str_x *p = str_current + purep;
379:
380: atmlen = strlen(strbuf)+1;
381: if(atmlen > p->space_left) {
382: if(atmlen >= STRBLEN) {
383: save = (char *)csegment(OTHER, atmlen, purep);
384: SETTYPE(save,STRNG,40);
385: purepage[ATOX(save)] = (char)purep;
386: strcpy(save,strbuf);
387: return(save);
388: }
389: p->next_free = (char *) (purep ?
390: next_pure_one(&strng_str) : next_one(&strng_str)) ;
391: p->space_left = LBPG;
392: }
393: strcpy((save = p->next_free), strbuf);
394: /*while(atmlen & 3) ++atmlen; /* even up length of string */
395: p->next_free += atmlen;
396: p->space_left -= atmlen;
397: return(save);
398: }
399:
400: static char * Iinewstr(s,purep) char *s;
401: {
402: int len = strlen(s);
403: while(len > (endstrb - strbuf - 1)) atomtoolong(strbuf);
404: strcpy(strbuf,s);
405: return(newstr(purep));
406: }
407:
408:
409: char *inewstr(s) char *s;
410: {
411: Iinewstr(s,0);
412: }
413:
414: char *pinewstr(s) char *s;
415: {
416: Iinewstr(s,1);
417: }
418:
419: lispval
420: newarray()
421: {
422: register lispval temp;
423:
424: temp = next_one(&array_str);
425: temp->ar.data = (char *)nil;
426: temp->ar.accfun = nil;
427: temp->ar.aux = nil;
428: temp->ar.length = SMALL(0);
429: temp->ar.delta = SMALL(0);
430: return(temp);
431: }
432:
433: lispval
434: newfunct()
435: {
436: register lispval temp;
437: lispval Badcall();
438: temp = next_one(&funct_str);
439: temp->bcd.start = Badcall;
440: temp->bcd.discipline = nil;
441: return(temp);
442: }
443:
444: lispval
445: newval()
446: {
447: register lispval temp;
448: temp = next_one(&val_str);
449: temp->l = nil;
450: return(temp);
451: }
452:
453: lispval
454: pnewval()
455: {
456: register lispval temp;
457: temp = next_pure_one(&val_str);
458: temp->l = nil;
459: return(temp);
460: }
461:
462: lispval
463: newhunk(hunknum)
464: int hunknum;
465: {
466: register lispval temp;
467:
468: temp = next_one(&hunk_str[hunknum]); /* Get a hunk */
469: return(temp);
470: }
471:
472: lispval
473: pnewhunk(hunknum)
474: int hunknum;
475: {
476: register lispval temp;
477:
478: temp = next_pure_one(&hunk_str[hunknum]); /* Get a hunk */
479: return(temp);
480: }
481:
482: lispval
483: inewval(arg) lispval arg;
484: {
485: lispval temp;
486: temp = next_one(&val_str);
487: temp->l = arg;
488: return(temp);
489: }
490:
491: /*
492: * Vector allocators.
493: * a vector looks like:
494: * longword: N = size in bytes
495: * longword: pointer to lisp object, this is the vector property field
496: * N consecutive bytes
497: *
498: */
499: lispval getvec();
500:
501: lispval
502: newvec(size)
503: {
504: return(getvec(size,&vect_str,FALSE));
505: }
506:
507: lispval
508: pnewvec(size)
509: {
510: return(getvec(size,&vect_str,TRUE));
511: }
512:
513: lispval
514: nveci(size)
515: {
516: return(getvec(size,&vecti_str,FALSE));
517: }
518:
519: lispval
520: pnveci(size)
521: {
522: return(getvec(size,&vecti_str,TRUE));
523: }
524:
525: /*
526: * getvec
527: * get a vector of size byte, from type structure typestr and
528: * get it from pure space if purep is TRUE.
529: * vectors are stored linked through their property field. Thus
530: * when the code here refers to v.vector[0], it is the prop field
531: * and vl.vectorl[-1] is the size field. In other code,
532: * v.vector[-1] is the prop field, and vl.vectorl[-2] is the size.
533: */
534: lispval
535: getvec(size,typestr,purep)
536: register struct types *typestr;
537: {
538: register lispval back, current;
539: int sizewant, bytes, thissize, pages, pindex, triedgc = FALSE;
540:
541: /* we have to round up to a multiple of 4 bytes to determine the
542: * size of vector we want. The rounding up assures that the
543: * property pointers are longword aligned
544: */
545: sizewant = VecTotSize(size);
546: if(debugin) fprintf(stderr,"want vect %db\n",size);
547: again:
548: if(purep)
549: back = (lispval) &(typestr->next_pure_free);
550: else
551: back = (lispval) &(typestr->next_free);
552: current = back->v.vector[0];
553: while(current != CNIL)
554: {
555: if(debugin)
556: fprintf(stderr,"next free size %db; ", current->vl.vectorl[-1]);
557: if ((thissize = VecTotSize(current->vl.vectorl[-1])) == sizewant)
558: {
559: if(debugin) fprintf(stderr,"exact match of size %d at 0x%x\n",
560: 4*thissize, ¤t->v.vector[1]);
561: back->v.vector[0]
562: = current->v.vector[0];/* change free pointer*/
563: current->v.vector[0] = nil; /* put nil in property */
564: /* to the user, vector begins one after property*/
565: return((lispval)¤t->v.vector[1]);
566: }
567: else if (thissize >= sizewant + 3)
568: {
569: /* the reason that there is a `+ 3' instead of `+ 2'
570: * is that we don't want to leave a zero sized vector which
571: * isn't guaranteed to be followed by another vector
572: */
573: if(debugin)
574: fprintf(stderr,"breaking a %d vector into a ",
575: current->vl.vectorl[-1]);
576:
577: current->v.vector[1+sizewant+1]
578: = current->v.vector[0]; /* free list pointer */
579: current->vl.vectorl[1+sizewant]
580: = VecTotToByte(thissize - sizewant - 2);/*size info */
581: back->v.vector[0] = (lispval) &(current->v.vector[1+sizewant+1]);
582: current->vl.vectorl[-1] = size;
583:
584: if(debugin)fprintf(stderr," %d one and a %d one\n",
585: current->vl.vectorl[-1],current->vl.vectorl[1+sizewant]);
586: current->v.vector[0] = nil; /* put nil in property */
587: /* vector begins one after the property */
588: if(debugin) fprintf(stderr," and returning vector at 0x%x\n",
589: ¤t->v.vector[1]);
590: return((lispval)(¤t->v.vector[1]));
591: }
592: back = current;
593: current = current->v.vector[0];
594: }
595: if(!triedgc
596: && !purep
597: && (gcdis->a.clb == nil)
598: && (initflag == FALSE))
599: {
600: gc(typestr);
601: triedgc = TRUE;
602: goto again;
603: }
604:
605: /* set bytes to size needed for this vector */
606: bytes = size + 2*sizeof(long);
607:
608: /* must make sure that if the vector we are allocating doesnt
609: completely fill a page, there is room for another vector to record
610: the size left over */
611: if((bytes & (LBPG - 1)) > (LBPG - 2*sizeof(long))) bytes += LBPG;
612: bytes = roundup(bytes,LBPG);
613:
614: current = csegment(typestr->type,bytes/sizeof(long),purep);
615: current->vl.vectorl[0] = bytes - 2*sizeof(long);
616:
617: if(purep) {
618: current->v.vector[1] = (lispval)(typestr->next_pure_free);
619: typestr->next_pure_free = (char *) &(current->v.vector[1]);
620: /* make them pure */
621: pages = bytes/LBPG;
622: for(pindex = ATOX(current); pages ; pages--)
623: {
624: purepage[pindex++] = TRUE;
625: }
626: } else {
627: current->v.vector[1] = (lispval)(typestr->next_free);
628: typestr->next_free = (char *) &(current->v.vector[1]);
629: if(debugin) fprintf(stderr,"grabbed %d vec pages\n",bytes/LBPG);
630: }
631: if(debugin)
632: fprintf(stderr,"creating a new vec, size %d\n",current->v.vector[0]);
633: goto again;
634: }
635:
636: /*
637: * Ipurep :: routine to check for pureness of a data item
638: *
639: */
640: lispval
641: Ipurep(element)
642: lispval element;
643: {
644: if(purepage[ATOX(element)]) return(tatom) ; else return(nil);
645: }
646:
647: /* routines to return space to the free list. These are used by the
648: * arithmetic routines which tend to create large intermediate results
649: * which are know to be garbage after the calculation is over.
650: *
651: * There are jsb callable versions of these routines in qfuncl.s
652: */
653:
654: /* pruneb - prune bignum. A bignum is an sdot followed by a list of
655: * dtprs. The dtpr list is linked by car instead of cdr so when we
656: * put it in the free list, we have to change the links.
657: */
658: pruneb(bignum)
659: lispval bignum;
660: {
661: register lispval temp = bignum;
662:
663: if(TYPE(temp) != SDOT)
664: errorh(Vermisc,"value to pruneb not a sdot",nil,FALSE,0);
665:
666: --(sdot_items->i);
667: temp->s.I = (int) sdot_str.next_free;
668: sdot_str.next_free = (char *) temp;
669:
670: /* bignums are not terminated by nil on the dual,
671: they are terminated by (lispval) 0 */
672:
673: while(temp = temp->s.CDR)
674: {
675: if(TYPE(temp) != DTPR)
676: errorh(Vermisc,"value to pruneb not a list",
677: nil,FALSE,0);
678: --(dtpr_items->i);
679: temp->s.I = (int) dtpr_str.next_free;
680: dtpr_str.next_free = (char *) temp;
681: }
682: }
683: lispval
684: Badcall()
685: { error("BAD FUNCTION DESCRIPTOR USED IN CALL",FALSE); }
686:
687:
688:
689: /*
690: * Ngc
691: * this is the lisp function gc
692: *
693: */
694:
695: lispval
696: Ngc()
697: {
698: return(gc((struct types *)CNIL));
699: }
700:
701: /*
702: * gc(type_struct)
703: *
704: * garbage collector: Collects garbage by mark and sweep algorithm.
705: * After this is done, calls the Nlambda, gcafter.
706: * gc may also be called from LISP, as an nlambda of no arguments.
707: * type_struct is the type of lisp data that ran out causing this
708: * garbage collection
709: */
710: int printall = 0;
711: lispval
712: gc(type_struct)
713: struct types *type_struct;
714: {
715: lispval save;
716: struct tms begin, finish;
717: extern int gctime;
718:
719: /* if this was called automatically when space ran out
720: * print out a message
721: */
722: if((Vgcprint->a.clb != nil)
723: && (type_struct != (struct types *) CNIL ))
724: {
725: FILE *port = okport(Vpoport->a.clb,poport);
726: fprintf(port,"gc:");
727: fflush(port);
728: }
729:
730: if(gctime) times(&begin);
731:
732: gc1(); /* mark&sweep */
733:
734: /* Now we call gcafter--special c ase if gc called from LISP */
735:
736: if( type_struct == (struct types *) CNIL )
737: gccall1->d.cdr = nil; /* make the call "(gcafter)" */
738: else
739: {
740: gccall1->d.cdr = gccall2;
741: gccall2->d.car = *(type_struct->type_name);
742: }
743: PUSHDOWN(gcdis,gcdis); /* flag to indicate in garbage collector */
744: save = eval(gccall1); /* call gcafter */
745: POP; /* turn off flag */
746:
747: if(gctime) {
748: times(&finish);
749: gctime += (finish.tms_utime - begin.tms_utime);
750: }
751: return(save); /* return result of gcafter */
752: }
753:
754:
755:
756: /* gc1() **************************************************************/
757: /* */
758: /* Mark-and-sweep phase */
759:
760: gc1()
761: {
762: int j, k;
763: register int *start,bvalue,type_len;
764: register struct types *s;
765: int *point,i,freecnt,itemstogo,bits,bindex,type,bytestoclear;
766: int usedcnt;
767: char *pindex;
768: struct argent *loop2;
769: struct nament *loop3;
770: struct atom *symb;
771: int markdp();
772: extern int hashtop;
773:
774: pagerand();
775: /* decide whether to check LISP structure or not */
776:
777:
778: #ifdef METER
779: vtimes(&premark,0);
780: mrkdpcnt = 0;
781: conssame = consdiff = consnil = 0;
782: #endif
783:
784: /* first set all bit maps to zero */
785:
786:
787: #ifdef SLOCLEAR
788: {
789: int enddat;
790: enddat = (int)(datalim-OFFSET) >> 8;
791: for(bvalue=0; bvalue < (int)enddat ; ++bvalue)
792: {
793: qbitmap[bvalue] = zeroq;
794: }
795: }
796: #endif
797:
798: /* try the movc5 to clear the bit maps */
799: /* the maximum number of bytes we can clear in one sweep is
800: * 2^16 (or 1<<16 in the C lingo)
801: */
802: bytestoclear = ((((int)datalim)-((int)beginsweep)) >> 9) * 16;
803: for(start = bitmapi + ATOLX(beginsweep);
804: bytestoclear > 0;)
805: {
806: if(bytestoclear > MAXCLEAR)
807: blzero((int)start,MAXCLEAR);
808: else
809: blzero((int)start,bytestoclear);
810: start = (int *) (MAXCLEAR + (int) start);
811: bytestoclear -= MAXCLEAR;
812: }
813:
814: /* mark all atoms in the oblist */
815: for( bvalue=0 ; bvalue <= hashtop-1 ; bvalue++ ) /* though oblist */
816: {
817: for( symb = hasht[bvalue] ; symb != (struct atom *) CNIL ;
818: symb = symb-> hshlnk) {
819: markdp((lispval)symb);
820: }
821: }
822:
823:
824: /* Mark all the atoms and ints associated with the hunk
825: data types */
826:
827: for(i=0; i<7; i++) {
828: markdp(hunk_items[i]);
829: markdp(hunk_name[i]);
830: markdp(hunk_pages[i]);
831: }
832: /* next run up the name stack */
833: for(loop2 = np - 1; loop2 >= orgnp; --loop2) MARKVAL(loop2->val);
834:
835: /* now the bindstack (vals only, atoms are marked elsewhere ) */
836: for(loop3 = bnp - 1; loop3 >= orgbnp; --loop3)MARKVAL(loop3->val);
837:
838:
839: /* next mark all compiler linked data */
840: /* if the Vpurcopylits switch is non nil (lisp variable $purcopylits)
841: * then when compiled code is read in, it tables will not be linked
842: * into this table and thus will not be marked here. That is ok
843: * though, since that data is assumed to be pure.
844: */
845: point = bind_lists;
846: while((start = point) != (int *)CNIL) {
847: while( *start != -1 )
848: {
849: markdp((lispval)*start);
850: start++;
851: }
852: point = (int *)*(point-1);
853: }
854:
855: /* next mark all system-significant lisp data */
856:
857:
858: for(i=0; i<SIGNIF; ++i) markdp((lispsys[i]));
859:
860: #ifdef METER
861: vtimes(&presweep,0);
862: #endif
863: /* all accessible data has now been marked. */
864: /* all collectable spaces must be swept, */
865: /* and freelists constructed. */
866:
867: /* first clear the structure elements for types
868: * we will sweep
869: */
870:
871: for(k=0 ; k <= VECTORI ; k++)
872: {
873: if( s=gcableptr[k]) {
874: if(k==STRNG && !gcstrings) { /* don't do anything*/ }
875: else
876: {
877: (*(s->items))->i = 0;
878: s->space_left = 0;
879: s->next_free = (char *) CNIL;
880: }
881: }
882: }
883: #if m_68k
884: fixbits(bitmapi+ATOLX(beginsweep),bitmapi+ATOLX(datalim));
885: #endif
886:
887:
888: /* sweep up in memory looking at gcable pages */
889:
890: for(start = beginsweep, bindex = ATOLX(start),
891: pindex = &purepage[ATOX(start)];
892: start < (int *)datalim;
893: start += 128, pindex++)
894: {
895: if(!(s=gcableptr[type = TYPE(start)]) || *pindex
896: #ifdef GCSTRINGS
897: || (type==STRNG && !gcstrings)
898: #endif
899: )
900: {
901: /* ignore this page but advance pointer */
902: bindex += 4; /* and 4 words of 32 bit bitmap words */
903: continue;
904: }
905:
906: freecnt = 0; /* number of free items found */
907: usedcnt = 0; /* number of used items found */
908:
909: point = start;
910: /* sweep dtprs as a special case, since
911: * 1) there will (usually) be more dtpr pages than any other type
912: * 2) most dtpr pages will be empty so we can really win by special
913: * caseing the sweeping of massive numbers of free cells
914: */
915: /* since sdot's have the same structure as dtprs, this code will
916: work for them too
917: */
918: if((type == DTPR) || (type == SDOT))
919: {
920: int *head,*lim;
921: head = (int *) s->next_free; /* first value on free list*/
922:
923: for(i=0; i < 4; i++) /* 4 bit map words per page */
924: {
925: bvalue = bitmapi[bindex++]; /* 32 bits = 16 dtprs */
926: if(bvalue == 0) /* if all are free */
927: {
928: *point = (int)head;
929: lim = point + 32; /* 16 dtprs = 32 ints */
930: for(point += 2; point < lim ; point += 2)
931: {
932: *point = (int)(point - 2);
933: }
934: head = point - 2;
935: freecnt += 16;
936: }
937: else for(j = 0; j < 16 ; j++)
938: {
939: if(!(bvalue & 1))
940: {
941: freecnt++;
942: *point = (int)head;
943: head = point;
944: }
945: #ifdef METER
946: /* check if the page address of this cell is the
947: * same as the address of its cdr
948: */
949: else if(FALSE && gcstat && (type == DTPR))
950: {
951: if(((int)point & ~511)
952: == ((int)(*point) & ~511)) conssame++;
953: else consdiff++;
954: usedcnt++;
955: }
956: #endif
957: else usedcnt++; /* keep track of used */
958:
959: point += 2;
960: bvalue = bvalue >> 2;
961: }
962: }
963: s->next_free = (char *) head;
964: }
965: else if((type == VECTOR) || (type == VECTORI))
966: {
967: int canjoin = FALSE;
968: int *tempp;
969:
970: /* check if first item on freelist ends exactly at
971: this page
972: */
973: if(((tempp = (int *)s->next_free) != (int *)CNIL)
974: && ((VecTotSize(((lispval)tempp)->vl.vectorl[-1])
975: + 1 + tempp)
976: == point))
977: canjoin = TRUE;
978:
979: /* arbitrary sized vector sweeper */
980: /*
981: * jump past first word since that is a size fixnum
982: * and second word since that is property word
983: */
984: if(debugin)
985: fprintf(stderr,"vector sweeping, start at 0x%x\n",
986: point);
987: bits = 30;
988: bvalue = bitmapi[bindex++] >> 2;
989: point += 2;
990: while (TRUE) {
991: type_len = point[VSizeOff];
992: if(debugin) {
993: fprintf(stderr,"point: 0x%x, type_len %d\n",
994: point, type_len);
995: fprintf(stderr,"bvalue: 0x%x, bits: %d, bindex: 0x%x\n",
996: bvalue, bits, bindex);
997: }
998: /* get size of vector */
999: if(!(bvalue & 1)) /* if free */
1000: {
1001: if(debugin) fprintf(stderr,"free\n");
1002: freecnt += type_len + 2*sizeof(long);
1003: if(canjoin)
1004: {
1005: /* join by adjusting size of first vector */
1006: ((lispval)(s->next_free))->vl.vectorl[-1]
1007: += type_len + 2*sizeof(long);
1008: if(debugin)
1009: fprintf(stderr,"joined size: %d\n",
1010: ((lispval)(s->next_free))->vl.vectorl[-1]);
1011: }
1012: else {
1013: /* vectors are linked at the property word */
1014: *(point - 1) = (int)(s->next_free);
1015: s->next_free = (char *) (point - 1);
1016: }
1017: canjoin = TRUE;
1018: }
1019: else {
1020: canjoin = FALSE;
1021: usedcnt += type_len + 2*sizeof(long);
1022: }
1023:
1024: point += VecTotSize(type_len);
1025: /* we stop sweeping only when we reach a page
1026: boundary since vectors can span pages
1027: */
1028: if(((int)point & 511) == 0)
1029: {
1030: /* reset the counters, we cannot predict how
1031: * many pages we have crossed over
1032: */
1033: bindex = ATOLX(point);
1034: /* these will be inced, so we must dec */
1035: pindex = &purepage[ATOX(point)] - 1;
1036: start = point - 128;
1037: if(debugin)
1038: fprintf(stderr,
1039: "out of vector sweep when point = 0x%x\n",
1040: point);
1041: break;
1042: }
1043: /* must advance to next point and next value in bitmap.
1044: * we add VecTotSize(type_len) + 2 to get us to the 0th
1045: * entry in the next vector (beyond the size fixnum)
1046: */
1047: point += 2; /* point to next 0th entry */
1048: if ( (bits -= (VecTotSize(type_len) + 2)) > 0)
1049: bvalue = bvalue >> (VecTotSize(type_len) + 2);
1050: else {
1051: bits = -bits; /* must advance to next word in map */
1052: bindex += bits / 32; /* this is tricky stuff... */
1053: bits = bits % 32;
1054: bvalue = bitmapi[bindex++] >> bits;
1055: bits = 32 - bits;
1056: }
1057: }
1058: }
1059: else {
1060: /* general sweeper, will work for all types */
1061: itemstogo = s->space; /* number of items per page */
1062: bits = 32; /* number of bits per word */
1063: type_len = s->type_len;
1064:
1065: /* printf(" s %d, itemstogo %d, len %d\n",s,itemstogo,type_len);*/
1066: bvalue = bitmapi[bindex++];
1067:
1068: while(TRUE)
1069: {
1070: if(!(bvalue & 1)) /* if data element is not marked */
1071: {
1072: freecnt++;
1073: *point = (int) (s->next_free) ;
1074: s->next_free = (char *) point;
1075: }
1076: else usedcnt++;
1077:
1078: if( --itemstogo <= 0 )
1079: { if(type_len >= 64)
1080: {
1081: bindex++;
1082: if(type_len >=128) bindex += 2;
1083: }
1084: break;
1085: }
1086:
1087: point += type_len;
1088: /* shift over mask by number of words in data type */
1089:
1090: if( (bits -= type_len) > 0)
1091: { bvalue = bvalue >> type_len;
1092: }
1093: else if( bits == 0 )
1094: { bvalue = bitmapi[bindex++];
1095: bits = 32;
1096: }
1097: else
1098: { bits = -bits;
1099: while( bits >= 32) { bindex++;
1100: bits -= 32;
1101: }
1102: bvalue = bitmapi[bindex++];
1103: bvalue = bvalue >> bits;
1104: bits = 32 - bits;;
1105: }
1106: }
1107: }
1108:
1109: s->space_left += freecnt;
1110: (*(s->items))->i += usedcnt;
1111: }
1112:
1113: #ifdef METER
1114: vtimes(&alldone,0);
1115: if(gcstat) gcdump();
1116: #endif
1117: pagenorm();
1118: }
1119:
1120: /*
1121: * alloc
1122: *
1123: * This routine tries to allocate one or more pages of the space named
1124: * by the first argument. Returns the number of pages actually allocated.
1125: *
1126: */
1127:
1128: lispval
1129: alloc(tname,npages)
1130: lispval tname; long npages;
1131: {
1132: long ii, jj;
1133: struct types *typeptr;
1134:
1135: ii = typenum(tname);
1136: typeptr = spaces[ii];
1137: if(npages <= 0) return(inewint(npages));
1138:
1139: if((ATOX(datalim)) + npages > TTSIZE)
1140: error("Space request would exceed maximum memory allocation",FALSE);
1141: if((ii == VECTOR) || (ii == VECTORI))
1142: {
1143: /* allocate in one big chunk */
1144: tname = csegment((int) ii,(int) npages*128,0);
1145: tname->vl.vectorl[0] = (npages*512 - 2*sizeof(long));
1146: tname->v.vector[1] = (lispval) typeptr->next_free;
1147: typeptr->next_free = (char *) &(tname->v.vector[1]);
1148: if(debugin) fprintf(stderr,"alloced %d vec pages\n",npages);
1149: return(inewint(npages));
1150: }
1151:
1152: for( jj=0; jj<npages; ++jj)
1153: if(get_more_space(spaces[ii],FALSE)) break;
1154: return(inewint(jj));
1155: }
1156:
1157: /*
1158: * csegment(typecode,nitems,useholeflag)
1159: * allocate nitems of type typecode. If useholeflag is true, then
1160: * allocate in the hole if there is room. This routine doesn't look
1161: * in the free lists, it always allocates space.
1162: */
1163: lispval
1164: csegment(typecode,nitems,useholeflag)
1165: {
1166: register int ii, jj;
1167: register char *charadd;
1168:
1169: ii = typecode;
1170:
1171: if(ii!=OTHER) nitems *= 4*spaces[ii]->type_len;
1172: nitems = roundup(nitems,512); /* round up to right length */
1173: #ifdef HOLE
1174: if(useholeflag)
1175: charadd = gethspace(nitems,ii);
1176: else
1177: #endif
1178: {
1179: charadd = sbrk(nitems);
1180: datalim = (lispval)(charadd+nitems);
1181: }
1182: if( (int) charadd <= 0 )
1183: error("NOT ENOUGH SPACE FOR ARRAY",FALSE);
1184: /*if(ii!=OTHER)*/ (*spaces[ii]->pages)->i += nitems/512;
1185: if(ATOX(datalim) > fakettsize) {
1186: datalim = (lispval) (OFFSET + (fakettsize << 9));
1187: if(fakettsize >= TTSIZE)
1188: {
1189: printf("There isn't room enough to continue, goodbye\n");
1190: franzexit(1);
1191: }
1192: fakettsize++;
1193: badmem(53);
1194: }
1195: for(jj=0; jj<nitems; jj=jj+512) {
1196: SETTYPE(charadd+jj, ii,30);
1197: }
1198: ii = (int) charadd;
1199: while(nitems > MAXCLEAR)
1200: {
1201: blzero(ii,MAXCLEAR);
1202: nitems -= MAXCLEAR;
1203: ii += MAXCLEAR;
1204: }
1205: blzero(ii,nitems);
1206: return((lispval)charadd);
1207: }
1208:
1209: int csizeof(tname) lispval tname;
1210: {
1211: return( spaces[typenum(tname)]->type_len * 4 );
1212: }
1213:
1214: int typenum(tname) lispval tname;
1215: {
1216: int ii;
1217:
1218: chek: for(ii=0; ii<NUMSPACES; ++ii)
1219: if(spaces[ii] && tname == *(spaces[ii]->type_name)) break;
1220: if(ii == NUMSPACES)
1221: {
1222: tname = error("BAD TYPE NAME",TRUE);
1223: goto chek;
1224: }
1225:
1226: return(ii);
1227:
1228: }
1229: char *
1230: gethspace(segsiz,type)
1231: {
1232: extern usehole; extern char holend[]; extern char *curhbeg;
1233: register char *value;
1234:
1235: if(usehole) {
1236: curhbeg = (char *) roundup(((int)curhbeg),LBPG);
1237: if((holend - curhbeg) < segsiz)
1238: {
1239: usehole = FALSE;
1240: curhbeg = holend;
1241: } else {
1242: value = curhbeg;
1243: curhbeg = curhbeg + segsiz;
1244: /*printf("start %d, finish %d, size %d\n",value, curhbeg,segsiz);*/
1245: return(value);
1246: }
1247: }
1248: value = (ysbrk(segsiz/LBPG,type));
1249: datalim = (lispval)(value + segsiz);
1250: return(value);
1251: }
1252: gcrebear()
1253: {
1254: #ifdef HOLE
1255: register int i; register struct types *p;
1256:
1257: /* this gets done upon rebirth */
1258: str_current[1].space_left = 0;
1259: #ifndef GCSTRINGS
1260: str_current[0].space_left = 0; /* both kinds of strings go in hole*/
1261: #endif
1262: funct_str.space_left = 0;
1263: funct_str.next_free = (char *) CNIL;
1264: /* clear pure space pointers */
1265: for(i = 0; i < NUMSPACES; i++)
1266: {
1267: if(p=spaces[i])
1268: p->next_pure_free = (char *) CNIL;
1269: }
1270: #endif
1271: }
1272:
1273: /** markit(p) ***********************************************************/
1274: /* just calls markdp */
1275:
1276: markit(p) lispval *p; { markdp(*p); }
1277:
1278: /*
1279: * markdp(p)
1280: *
1281: * markdp is the routine which marks each data item. If it is a
1282: * dotted pair, the car and cdr are marked also.
1283: * An iterative method is used to mark list structure, to avoid
1284: * excessive recursion.
1285: */
1286: markdp(p) register lispval p;
1287: {
1288: /* register int r, s; (goes with non-asm readbit, oksetbit) */
1289: /* register hsize, hcntr; */
1290: int hsize, hcntr;
1291:
1292: #ifdef METER
1293: mrkdpcnt++;
1294: #endif
1295: ptr_loop:
1296: if(((int)p) <= ((int)nil)) return; /* do not mark special data types or nil=0 */
1297:
1298:
1299: switch( TYPE(p) )
1300: {
1301: case ATOM:
1302: ftstbit;
1303: MARKVAL(p->a.clb);
1304: MARKVAL(p->a.plist);
1305: MARKVAL(p->a.fnbnd);
1306: #ifdef GCSTRINGS
1307: if(gcstrings) MARKVAL(((lispval)p->a.pname));
1308: return;
1309:
1310: case STRNG:
1311: p = (lispval) (((int) p) & ~ (LBPG-1));
1312: ftstbit;
1313: #endif
1314: return;
1315:
1316: case INT:
1317: case DOUB:
1318: ftstbit;
1319: return;
1320: case VALUE:
1321: ftstbit;
1322: p = p->l;
1323: goto ptr_loop;
1324: case DTPR:
1325: ftstbit;
1326: MARKVAL(p->d.car);
1327: #ifdef METER
1328: /* if we are metering , then check if the cdr is
1329: * nil, or if the cdr is on the same page, and if
1330: * it isn't one of those, then it is on a different
1331: * page
1332: */
1333: if(gcstat)
1334: {
1335: if(p->d.cdr == nil) consnil++;
1336: else if(((int)p & ~511)
1337: == (((int)(p->d.cdr)) & ~511))
1338: conssame++;
1339: else consdiff++;
1340: }
1341: #endif
1342: p = p->d.cdr;
1343: goto ptr_loop;
1344:
1345: case ARRAY:
1346: ftstbit; /* mark array itself */
1347:
1348: MARKVAL(p->ar.accfun); /* mark access function */
1349: MARKVAL(p->ar.aux); /* mark aux data */
1350: MARKVAL(p->ar.length); /* mark length */
1351: MARKVAL(p->ar.delta); /* mark delta */
1352: if(TYPE(p->ar.aux)==DTPR && p->ar.aux->d.car==Vnogbar)
1353: {
1354: /* a non garbage collected array must have its
1355: * array space marked but the value of the array
1356: * space is not marked
1357: */
1358: int l;
1359: int cnt,d;
1360: if(debugin && FALSE) {
1361: printf("mark array holders len %d, del %d, start 0x%x\n",
1362: p->ar.length->i,p->ar.delta->i,p->ar.data);
1363: fflush(stdout);
1364: }
1365: l = p->ar.length->i; /* number of elements */
1366: d = p->ar.delta->i; /* bytes per element */
1367: p = (lispval) p->ar.data;/* address of first one*/
1368: if(purepage[ATOX(p)]) return;
1369:
1370: for((cnt = 0); cnt<l ;
1371: p = (lispval)(((char *) p) + d), cnt++)
1372: {
1373: setbit;
1374: }
1375: } else {
1376: /* register int i, l; int d; */
1377: /* register char *dataptr = p->ar.data; */
1378: int i,l,d;
1379: char *dataptr = p->ar.data;
1380:
1381: for(i=0, l=p->ar.length->i, d=p->ar.delta->i; i<l; ++i)
1382: {
1383: markdp((lispval)dataptr);
1384: dataptr += d;
1385: }
1386: }
1387: return;
1388: case SDOT:
1389: do {
1390: ftstbit;
1391: p = p->s.CDR;
1392: } while (p!=0);
1393: return;
1394:
1395: case BCD:
1396: ftstbit;
1397: markdp(p->bcd.discipline);
1398: return;
1399:
1400: case HUNK2:
1401: case HUNK4:
1402: case HUNK8:
1403: case HUNK16:
1404: case HUNK32:
1405: case HUNK64:
1406: case HUNK128:
1407: {
1408: hsize = 2 << HUNKSIZE(p);
1409: ftstbit;
1410: for (hcntr = 0; hcntr < hsize; hcntr++)
1411: MARKVAL(p->h.hunk[hcntr]);
1412: return;
1413: }
1414:
1415: case VECTORI:
1416: ftstbit;
1417: MARKVAL(p->v.vector[-1]); /* mark property */
1418: return;
1419:
1420: case VECTOR:
1421: {
1422: register int vsize;
1423: ftstbit;
1424: vsize = VecSize(p->vl.vectorl[VSizeOff]);
1425: if(debugin)
1426: fprintf(stderr,"mark vect at %x size %d\n",
1427: p,vsize);
1428: while(--vsize >= -1)
1429: {
1430: MARKVAL(p->v.vector[vsize]);
1431: };
1432: return;
1433: }
1434: }
1435: return;
1436: }
1437:
1438:
1439: /* xsbrk allocates space in large chunks (currently 16 pages)
1440: * xsbrk(1) returns a pointer to a page
1441: * xsbrk(0) returns a pointer to the next page we will allocate (like sbrk(0))
1442: */
1443:
1444: char *
1445: xsbrk(n)
1446: {
1447: static char *xx; /* pointer to next available blank page */
1448: extern int xcycle; /* number of blank pages available */
1449: lispval u; /* used to compute limits of bit table */
1450:
1451: if( (xcycle--) <= 0 )
1452: {
1453: xcycle = 15;
1454: xx = sbrk(16*LBPG); /* get pages 16 at a time */
1455: if( (int)xx== -1 )
1456: lispend("For sbrk from lisp: no space... Goodbye!");
1457: }
1458: else xx += LBPG;
1459:
1460: if(n == 0)
1461: {
1462: xcycle++; /* don't allocate the page */
1463: xx -= LBPG;
1464: return(xx); /* just return its address */
1465: }
1466:
1467: if( (u = (lispval)(xx+LBPG)) > datalim ) datalim = u;
1468: return(xx);
1469: }
1470:
1471: char *ysbrk(pages,type) int pages, type;
1472: {
1473: char *xx; /* will point to block of storage */
1474: int i;
1475:
1476: xx = sbrk(pages*LBPG);
1477: if((int)xx == -1)
1478: error("OUT OF SPACE FOR ARRAY REQUEST",FALSE);
1479:
1480: datalim = (lispval)(xx+pages*LBPG); /* compute bit table limit */
1481:
1482: /* set type for pages */
1483:
1484: for(i = 0; i < pages; ++i) {
1485: SETTYPE((xx + i*LBPG),type,10);
1486: }
1487:
1488: return(xx); /* return pointer to block of storage */
1489: }
1490:
1491: /*
1492: * getatom
1493: * returns either an existing atom with the name specified in strbuf, or
1494: * if the atom does not already exist, regurgitates a new one and
1495: * returns it.
1496: */
1497: lispval
1498: getatom(purep)
1499: { register lispval aptr;
1500: register char *name, *endname;
1501: register int hash;
1502: lispval b;
1503: char c;
1504:
1505: name = strbuf;
1506: if (*name == (char)0377) return (eofa);
1507: hash = hashfcn(name);
1508: atmlen = strlen(name) + 1;
1509: aptr = (lispval) hasht[hash];
1510: while (aptr != CNIL)
1511: /* if (strcmp(name,aptr->a.pname)==0) */
1512: if (*name==*aptr->a.pname && strcmp(name,aptr->a.pname)==0)
1513: return (aptr);
1514: else
1515: aptr = (lispval) aptr->a.hshlnk;
1516: aptr = (lispval) newatom(purep); /*share pname of atoms on oblist*/
1517: aptr->a.hshlnk = hasht[hash];
1518: hasht[hash] = (struct atom *) aptr;
1519: endname = name + atmlen - 2;
1520: if ((atmlen != 4) && (*name == 'c') && (*endname == 'r'))
1521: {
1522: b = newdot();
1523: protect(b);
1524: b->d.car = lambda;
1525: b->d.cdr = newdot();
1526: b = b->d.cdr;
1527: b->d.car = newdot();
1528: (b->d.car)->d.car = xatom;
1529: while(TRUE)
1530: {
1531: b->d.cdr = newdot();
1532: b= b->d.cdr;
1533: if(++name == endname)
1534: {
1535: b->d.car= (lispval) xatom;
1536: aptr->a.fnbnd = (--np)->val;
1537: break;
1538: }
1539: b->d.car= newdot();
1540: b= b->d.car;
1541: if((c = *name) == 'a') b->d.car = cara;
1542: else if (c == 'd') b->d.car = cdra;
1543: else{ --np;
1544: break;
1545: }
1546: }
1547: }
1548:
1549: return(aptr);
1550: }
1551:
1552: /*
1553: * inewatom is like getatom, except that you provide it a string
1554: * to be used as the print name. It doesn't do the automagic
1555: * creation of things of the form c[ad]*r.
1556: */
1557: lispval
1558: inewatom(name)
1559: register char *name;
1560: { register struct atom *aptr;
1561: register int hash;
1562: extern struct types atom_str;
1563: char c;
1564:
1565: if (*name == (char)0377) return (eofa);
1566: hash = hashfcn(name);
1567: aptr = hasht[hash];
1568: while (aptr != (struct atom *)CNIL)
1569: if (strcmp(name,aptr->pname)==0)
1570: return ((lispval) aptr);
1571: else
1572: aptr = aptr->hshlnk;
1573: aptr = (struct atom *) next_one(&atom_str) ;
1574: aptr->plist = aptr->fnbnd = nil;
1575: aptr->clb = CNIL;
1576: aptr->pname = name;
1577: aptr->hshlnk = hasht[hash];
1578: hasht[hash] = aptr;
1579: return((lispval)aptr);
1580: }
1581:
1582:
1583: /* our hash function */
1584:
1585: hashfcn(symb)
1586: register char *symb;
1587: {
1588: register int i;
1589: /* for (i=0 ; *symb ; i += i + *symb++); return(i & (HASHTOP-1)); */
1590: for (i=0 ; *symb ; i += i*2 + *symb++);
1591: return(i&077777 % HASHTOP);
1592: }
1593:
1594: lispval
1595: LImemory()
1596: {
1597: int nextadr, pagesinuse;
1598:
1599: printf("Memory report. max pages = %d (0x%x) = %d Bytes\n",
1600: TTSIZE,TTSIZE,TTSIZE*LBPG);
1601: #ifdef HOLE
1602: printf("This lisp has a hole:\n");
1603: printf(" current hole start: %d (0x%x), end %d (0x%x)\n",
1604: curhbeg, curhbeg, holend, holend);
1605: printf(" hole free: %d bytes = %d pages\n\n",
1606: holend-curhbeg, (holend-curhbeg)/LBPG);
1607: #endif
1608: nextadr = (int) xsbrk(0); /* next space to be allocated */
1609: pagesinuse = nextadr/LBPG;
1610: printf("Next allocation at addr %d (0x%x) = page %d\n",
1611: nextadr, nextadr, pagesinuse);
1612: printf("Free data pages: %d\n", TTSIZE-pagesinuse);
1613: return(nil);
1614: }
1615:
1616: extern struct atom *hasht[HASHTOP];
1617: myhook(){}
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.