![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to rmemmgt.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Research Unix] / researchv10dc / cmd / icon / src / iconx|
Return to rmemmgt.c CVS log | Up to [Research Unix] / researchv10dc / cmd / icon / src / iconx |
1.1 root 1: /*
2: * File: rmemmgt.c
3: * Contents: allocation routines, block description arrays, dump routines,
4: * garbage collaction, sweep, malloc/free
5: */
6:
7: #include "../h/rt.h"
8: #include "gc.h"
9:
10: #ifdef IconAlloc
11: /*
12: * If IconAlloc is defined the system allocation routines are not overloaded.
13: * The names are changed so that Icon's allocation routines are independently
14: * used. This works as long as no other system calls cause the break value
15: * to change.
16: */
17: #define malloc mem_alloc
18: #define free mem_free
19: #define realloc mem_realloc
20: #define calloc mem_calloc
21: #endif IconAlloc
22:
23: #ifdef RunStats
24: #ifndef VMS
25: #include <sys/types.h>
26: #include <sys/times.h>
27: #else VMS
28: #include <types.h>
29: #include <types.h>
30: struct tms {
31: time_t tms_utime; /* user time */
32: time_t tms_stime; /* system time */
33: time_t tms_cutime; /* user time, children */
34: time_t tms_cstime; /* system time, children */
35: };
36: #endif VMS
37: #endif RunStats
38:
39: /*
40: * Note: function calls beginning with "MM" are just empty macros
41: * unless MEMMON is defined.
42: */
43:
44: /*
45: * allocate - returns pointer to nbytes of free storage in block region.
46: */
47:
48: static union block *allocate(nbytes)
49: word nbytes;
50: {
51: register uword fspace, *sloc;
52:
53: Inc(al_n_total);
54: IncSum(al_bc_btotal,nbytes);
55: /*
56: * See if there is enough room in the block region.
57: */
58: fspace = maxblk - blkfree;
59: if (fspace < nbytes)
60: syserr("block allocation botch");
61:
62: /*
63: * If monitoring, show the allocation.
64: */
65: MMAlc(nbytes);
66:
67: /*
68: * Decrement the free space in the block region by the number of bytes allocated
69: * and return the address of the first byte of the allocated block.
70: */
71: sloc = (uword *) blkfree;
72: blkneed -= nbytes;
73: blkfree = blkfree + nbytes;
74: return (union block *) (sloc);
75: }
76:
77: /*
78: * alclint - allocate a long integer block in the block region.
79: */
80:
81: struct b_int *alclint(val)
82: long val;
83: {
84: register struct b_int *blk;
85: extern union block *allocate();
86:
87: MMType(T_Longint);
88: blk = (struct b_int *)allocate((word)sizeof(struct b_int));
89: blk->title = T_Longint;
90: blk->intval = val;
91: return blk;
92: }
93:
94: /*
95: * alcreal - allocate a real value in the block region.
96: */
97:
98: struct b_real *alcreal(val)
99: double val;
100: {
101: register struct b_real *blk;
102: extern union block *allocate();
103:
104: Inc(al_n_real);
105: MMType(T_Real);
106: blk = (struct b_real *) allocate((word)sizeof(struct b_real));
107: blk->title = T_Real;
108: #ifdef Double
109: /* access real values one word at a time */
110: { int *rp, *rq;
111: rp = (word *) &(blk->realval);
112: rq = (word *) &val;
113: *rp++ = *rq++;
114: *rp = *rq;
115: }
116: #else Double
117: blk->realval = val;
118: #endif Double
119: return blk;
120: }
121:
122: /*
123: * alccset - allocate a cset in the block region.
124: */
125:
126: /* >alccset */
127: struct b_cset *alccset(size)
128: int size;
129: {
130: register struct b_cset *blk;
131: register i;
132: extern union block *allocate();
133:
134: Inc(al_n_cset);
135: MMType(T_Cset);
136: blk = (struct b_cset *) allocate((word)sizeof(struct b_cset));
137: blk->title = T_Cset;
138: blk->size = size;
139: /*
140: * Zero the bit array.
141: */
142: for (i = 0; i < CsetSize; i++)
143: blk->bits[i] = 0;
144: return blk;
145: }
146: /* <alccset */
147:
148:
149: /*
150: * alcfile - allocate a file block in the block region.
151: */
152:
153: struct b_file *alcfile(fd, status, name)
154: FILE *fd;
155: int status;
156: struct descrip *name;
157: {
158: register struct b_file *blk;
159: extern union block *allocate();
160:
161: Inc(al_n_file);
162: MMType(T_File);
163: blk = (struct b_file *) allocate((word)sizeof(struct b_file));
164: blk->title = T_File;
165: blk->fd = fd;
166: blk->status = status;
167: blk->fname = *name;
168: return blk;
169: }
170:
171: /*
172: * alcrecd - allocate record with nflds fields in the block region.
173: */
174:
175: struct b_record *alcrecd(nflds, recptr)
176: int nflds;
177: struct descrip *recptr;
178: {
179: register struct b_record *blk;
180: register i, size;
181: extern union block *allocate();
182:
183: Inc(al_n_recd);
184: MMType(T_Record);
185: size = Vsizeof(struct b_record) + nflds*sizeof(struct descrip);
186: blk = (struct b_record *) allocate((word)size);
187: blk->title = T_Record;
188: blk->blksize = size;
189: blk->recdesc.dword = D_Proc;
190: BlkLoc(blk->recdesc) = (union block *)recptr;
191: /*
192: * Assign &null to each field in the record.
193: */
194: for (i = 0; i < nflds; i++)
195: blk->fields[i] = nulldesc;
196: return blk;
197: }
198:
199: /*
200: * alclist - allocate a list header block in the block region.
201: */
202:
203: struct b_list *alclist(size)
204: word size;
205: {
206: register struct b_list *blk;
207: extern union block *allocate();
208:
209: Inc(al_n_list);
210: MMType(T_List);
211: blk = (struct b_list *) allocate((word)sizeof(struct b_list));
212: blk->title = T_List;
213: blk->size = size;
214: blk->listhead = nulldesc;
215: return blk;
216: }
217:
218: /*
219: * alclstb - allocate a list element block in the block region.
220: */
221:
222: struct b_lelem *alclstb(nelem, first, nused)
223: word nelem, first, nused;
224: {
225: register struct b_lelem *blk;
226: register word i, size;
227: extern union block *allocate();
228:
229: Inc(al_n_lstb);
230: MMType(T_Lelem);
231: #ifdef MaxListSize
232: if (nelem >= MaxListSize)
233: runerr(205, NULL);
234: #endif MaxListSize
235: size = Vsizeof(struct b_lelem)+nelem*sizeof(struct descrip);
236: blk = (struct b_lelem *) allocate(size);
237: blk->title = T_Lelem;
238: blk->blksize = size;
239: blk->nelem = nelem;
240: blk->first = first;
241: blk->nused = nused;
242: blk->listprev = nulldesc;
243: blk->listnext = nulldesc;
244: /*
245: * Set all elements to &null.
246: */
247: for (i = 0; i < nelem; i++)
248: blk->lslots[i] = nulldesc;
249: return blk;
250: }
251:
252: /*
253: * alctable - allocate a table header block in the block region.
254: */
255:
256: struct b_table *alctable(def)
257: struct descrip *def;
258: {
259: register int i;
260: register struct b_table *blk;
261: extern union block *allocate();
262:
263: Inc(al_n_table);
264: MMType(T_Table);
265: blk = (struct b_table *) allocate((word)sizeof(struct b_table));
266: blk->title = T_Table;
267: blk->size = 0;
268: blk->defvalue = *def;
269: /*
270: * Zero out the buckets.
271: */
272: for (i = 0; i < TSlots; i++)
273: blk->buckets[i] = nulldesc;
274: return blk;
275: }
276:
277: /*
278: * alctelem - allocate a table element block in the block region.
279: */
280:
281: struct b_telem *alctelem()
282: {
283: register struct b_telem *blk;
284: extern union block *allocate();
285:
286: Inc(al_n_telem);
287: MMType(T_Telem);
288: blk = (struct b_telem *) allocate((word)sizeof(struct b_telem));
289: blk->title = T_Telem;
290: blk->hashnum = 0;
291: blk->clink = nulldesc;
292: blk->tref = nulldesc;
293: blk->tval = nulldesc;
294: return blk;
295: }
296:
297: /*
298: * alcset - allocate a set header block.
299: */
300:
301: struct b_set *alcset()
302: {
303: register int i;
304: register struct b_set *blk;
305: extern union block *allocate();
306:
307: MMType(T_Set);
308: blk = (struct b_set *) allocate((word)sizeof(struct b_set));
309: blk->title = T_Set;
310: blk->size = 0;
311: /*
312: * Zero out the buckets.
313: */
314: for (i = 0; i < SSlots; i++)
315: blk->sbucks[i] = nulldesc;
316: return blk;
317: }
318:
319: /*
320: * alcselem - allocate a set element block.
321: */
322:
323: struct b_selem *alcselem(mbr,hn)
324: word hn;
325: struct descrip *mbr;
326:
327: { register struct b_selem *blk;
328: extern union block *allocate();
329:
330: MMType(T_Selem);
331: blk = (struct b_selem *) allocate((word)sizeof(struct b_selem));
332: blk->title = T_Selem;
333: blk->clink = nulldesc;
334: blk->setmem = *mbr;
335: blk->hashnum = hn;
336: return blk;
337: }
338:
339: /*
340: * alcsubs - allocate a substring trapped variable in the block region.
341: */
342:
343: struct b_tvsubs *alcsubs(len, pos, var)
344: word len, pos;
345: struct descrip *var;
346: {
347: register struct b_tvsubs *blk;
348: extern union block *allocate();
349:
350: Inc(al_n_subs);
351: MMType(T_Tvsubs);
352: blk = (struct b_tvsubs *) allocate((word)sizeof(struct b_tvsubs));
353: blk->title = T_Tvsubs;
354: blk->sslen = len;
355: blk->sspos = pos;
356: blk->ssvar = *var;
357: return blk;
358: }
359:
360: /*
361: * alctvtbl - allocate a table element trapped variable block in the block region.
362: */
363:
364: struct b_tvtbl *alctvtbl(tbl, ref, hashnum)
365: register struct descrip *tbl, *ref;
366: word hashnum;
367: {
368: register struct b_tvtbl *blk;
369: extern union block *allocate();
370:
371: Inc(al_n_tvtbl);
372: MMType(T_Tvtbl);
373: blk = (struct b_tvtbl *) allocate((word)sizeof(struct b_tvtbl));
374: blk->title = T_Tvtbl;
375: blk->hashnum = hashnum;
376: blk->clink = *tbl;
377: blk->tref = *ref;
378: blk->tval = nulldesc;
379: return blk;
380: }
381:
382: /*
383: * alcstr - allocate a string in the string space.
384: */
385:
386: /* >alcstr */
387: char *alcstr(s, slen)
388: register char *s;
389: register word slen;
390: {
391: register char *d;
392: char *ofree;
393:
394: Inc(al_n_str);
395: IncSum(al_bc_stotal,slen);
396: MMStr(slen);
397: /*
398: * See if there is enough room in the string space.
399: */
400: if (strfree + slen > strend)
401: syserr("string allocation botch");
402: strneed -= slen;
403:
404: /*
405: * Copy the string into the string space, saving a pointer to its
406: * beginning. Note that s may be null, in which case the space
407: * is still to be allocated but nothing is to be copied into it.
408: */
409: ofree = d = strfree;
410: if (s != NULL) {
411: while (slen-- > 0)
412: *d++ = *s++;
413: }
414: else
415: d += slen;
416: strfree = d;
417: return ofree;
418: }
419: /* <alcstr */
420:
421: /*
422: * alcstk - allocate a co-expression stack block.
423: */
424:
425: struct b_coexpr *alcstk()
426: {
427: struct b_coexpr *ep;
428: char *malloc();
429:
430: Inc(al_n_estk);
431: ep = (struct b_coexpr *)malloc(stksize);
432: ep->title = T_Coexpr;
433: return ep;
434: }
435:
436: /*
437: * alceblk - allocate a co-expression block.
438: */
439:
440: struct b_refresh *alceblk(entryx, na, nl)
441: word *entryx;
442: int na, nl;
443: {
444: int size;
445: struct b_refresh *blk;
446: extern union block *allocate();
447:
448: Inc(al_n_eblk);
449: MMType(T_Refresh);
450: size = Vsizeof(struct b_refresh) + (na + nl) * sizeof(struct descrip);
451: blk = (struct b_refresh *) allocate((word)size);
452: blk->title = T_Refresh;
453: blk->blksize = size;
454: blk->ep = entryx;
455: blk->numlocals = nl;
456: return blk;
457: }
458:
459:
460: /*
461: * Allocated block size table (sizes given in bytes). A size of -1 is used
462: * for types that have no blocks; a size of 0 indicates that the
463: * second word of the block contains the size; a value greater than
464: * 0 is used for types with constant sized blocks.
465: */
466:
467: int bsizes[] = {
468: -1, /* 0, not used */
469: -1, /* 1, not used */
470: sizeof(struct b_int), /* T_Longint (2), long integer type */
471: sizeof(struct b_real), /* T_Real (3), real number */
472: sizeof(struct b_cset), /* T_Cset (4), cset */
473: sizeof(struct b_file), /* T_File (5), file block */
474: 0, /* T_Proc (6), procedure block */
475: sizeof(struct b_list), /* T_List (7), list header block */
476: sizeof(struct b_table), /* T_Table (8), table header block */
477: 0, /* T_Record (9), record block */
478: sizeof(struct b_telem), /* T_Telem (10), table element block */
479: 0, /* T_Lelem (11), list element block */
480: sizeof(struct b_tvsubs), /* T_Tvsubs (12), substring trapped variable */
481: -1, /* T_Tvkywd (13), keyword trapped variable */
482: sizeof(struct b_tvtbl), /* T_Tvtbl (14), table element trapped variable */
483: sizeof(struct b_set), /* T_Set (15), set header block */
484: sizeof(struct b_selem), /* T_Selem (16), set element block */
485: 0, /* T_Refresh (17), expression block */
486: -1, /* T_Coexpr (18), expression stack header */
487: };
488:
489: /*
490: * Table of offsets (in bytes) to first descriptor in blocks. -1 is for
491: * types not allocated, 0 for blocks with no descriptors.
492: */
493: int firstd[] = {
494: -1, /* 0, not used */
495: -1, /* 1, not used */
496: 0, /* T_Longint (2), long integer type */
497: 0, /* T_Real (3), real number */
498: 0, /* T_Cset (4), cset */
499: 3*WordSize, /* T_File (5), file block */
500: 8*WordSize, /* T_Proc (6), procedure block */
501: 2*WordSize, /* T_List (7), list header block */
502: 2*WordSize, /* T_Table (8), table header block */
503: 2*WordSize, /* T_Record (9), record block */
504: 2*WordSize, /* T_Telem (10), table element block */
505: 5*WordSize, /* T_Lelem (11), list element block */
506: 3*WordSize, /* T_Tvsubs (12), substring trapped variable */
507: -1, /* T_Tvkywd (13), keyword trapped variable */
508: 2*WordSize, /* T_Tvtbl (14), table element trapped variable */
509: 2*WordSize, /* T_Set (15), set header block */
510: 2*WordSize, /* T_Selem (16), set element block */
511: (4+Vwsizeof(struct pf_marker))*WordSize,
512: /* T_Refresh (17), expression block */
513: -1, /* T_Coexpr (18), expression stack header */
514: };
515:
516: /*
517: * Table of block names used by debugging functions.
518: */
519: char *blkname[] = {
520: "illegal", /* T_Null (0), not block */
521: "illegal", /* T_Integer (1), not block */
522: "long integer", /* T_Longint (2) */
523: "real number", /* T_Real (3) */
524: "cset", /* T_Cset (4) */
525: "file", /* T_File (5) */
526: "procedure", /* T_Proc (6) */
527: "list", /* T_List (7) */
528: "table", /* T_Table (8) */
529: "record", /* T_Record (9) */
530: "table element", /* T_Telem (10) */
531: "list element", /* T_Lelem (11) */
532: "substring trapped variable", /* T_Tvsubs (12) */
533: "keyword trapped variable", /* T_Tvkywd (13) */
534: "table element trapped variable", /* T_Tvtbl (14) */
535: "set", /* T_Set (15) */
536: "set elememt", /* T_Selem (16) */
537: "refresh", /* T_Refresh (17) */
538: "co-expression", /* T_Coexpr (18) */
539: };
540:
541:
542: /*
543: * descr - dump a descriptor. Used only for debugging.
544: */
545:
546: descr(dp)
547: struct descrip *dp;
548: {
549: int i;
550:
551: fprintf(stderr,"%08lx: ",(long)dp);
552: if (Qual(*dp))
553: fprintf(stderr,"%15s","qualifier");
554: else if (Var(*dp) && !Tvar(*dp))
555: fprintf(stderr,"%15s","variable");
556: else {
557: i = Type(*dp);
558: switch (i) {
559: case T_Null:
560: fprintf(stderr,"%15s","null");
561: break;
562: case T_Integer:
563: fprintf(stderr,"%15s","integer");
564: break;
565: default:
566: fprintf(stderr,"%15s",blkname[i]);
567: }
568: }
569: fprintf(stderr," %08lx %08lx\n",(long)dp->dword,(long)dp->vword.integr);
570: }
571:
572: /*
573: * blkdump - dump the allocated block region. Used only for debugging.
574: */
575:
576: blkdump()
577: {
578: register char *blk;
579: register word type, size, fdesc;
580: register struct descrip *ndesc;
581:
582: fprintf(stderr,"\nDump of allocated block region. base:%08lx free:%08lx max:%08lx\n",
583: (long)blkbase,(long)blkfree,(long)maxblk);
584: fprintf(stderr," loc type size contents\n");
585:
586: for (blk = blkbase; blk < blkfree; blk += BlkSize(blk)) {
587: type = BlkType(blk);
588: size = BlkSize(blk);
589: fprintf(stderr," %08lx %15s %4ld\n",(long)blk,blkname[type],(long)size);
590: if ((fdesc = firstd[type]) > 0)
591: for (ndesc = (struct descrip *) (blk + fdesc);
592: ndesc < (struct descrip *) (blk + size);ndesc++) {
593: fprintf(stderr," ");
594: descr(ndesc);
595: }
596: fprintf(stderr,"\n");
597: }
598: fprintf(stderr,"end of block region.\n");
599: }
600:
601:
602: /*
603: * blkreq - insure that at least bytes of space are left in the block region.
604: * The amount of space needed is transmitted to the collector via
605: * the global variable blkneed.
606: */
607:
608: blkreq(bytes)
609: uword bytes;
610: {
611: blkneed = bytes;
612: if (bytes > maxblk - blkfree) {
613: Inc(gc_n_blk);
614: collect();
615: }
616: }
617:
618: /*
619: * strreq - insure that at least n of space are left in the string
620: * space. The amount of space needed is transmitted to the collector
621: * via the global variable strneed.
622: */
623:
624: /* >strreq */
625: strreq(n)
626: uword n;
627: {
628: strneed = n; /* save in case of collection */
629: if (n > strend - strfree) {
630: Inc(gc_n_string);
631: collect();
632: }
633: }
634: /* <strreq */
635:
636: /*
637: * cofree - collect co-expression blocks. This is done after
638: * the marking phase of garbage collection and the stacks that are
639: * reachable have pointers to data blocks, rather than T_Coexpr,
640: * in their type field.
641: */
642:
643: /* >cofree */
644: cofree()
645: {
646: register struct b_coexpr **ep, *xep;
647:
648: /*
649: * Reset the type for &main.
650: */
651: BlkLoc(k_main)->coexpr.title = T_Coexpr;
652:
653: /*
654: * The co-expression blocks are linked together through their
655: * nextstk fields, with stklist pointing to the head of the list.
656: * The list is traversed and each stack that was not marked
657: * is freed.
658: */
659: ep = &stklist;
660: while (*ep != NULL) {
661: if (BlkType(*ep) == T_Coexpr) {
662: xep = *ep;
663: *ep = (*ep)->nextstk;
664: free((char *)xep);
665: }
666: else {
667: BlkType(*ep) = T_Coexpr;
668: ep = &(*ep)->nextstk;
669: }
670: }
671: }
672: /* <cofree */
673:
674: /*
675: * collect - do a garbage collection.
676: * the static region is needed.
677: */
678:
679: collect()
680: {
681: register word extra;
682: register char *newend;
683: register struct descrip *dp;
684: char *strptr;
685: struct b_coexpr *cp;
686: #ifndef MSDOS
687: extern char *brk();
688: #endif MSDOS
689: extern char *sbrk();
690: #ifdef RunStats
691: struct tms tmbuf;
692:
693: times(&tmbuf);
694: gc_t_start = tmbuf.tms_utime + tmbuf.tms_stime;
695: Inc(gc_n_total);
696: #endif RunStats
697: MMBGC();
698:
699: /*
700: * Sync the values (used by sweep) in the coexpr block for ¤t
701: * with the current values.
702: */
703: cp = (struct b_coexpr *)BlkLoc(current);
704: cp->es_pfp = pfp;
705: cp->es_gfp = gfp;
706: cp->es_efp = efp;
707: cp->es_sp = sp;
708:
709: /*
710: * Reset the string qualifier free list pointer.
711: */
712: qualfree = quallist;
713:
714: /*
715: * Mark the stacks for &main and the current co-expression.
716: */
717: markblock(&k_main);
718: markblock(¤t);
719: /*
720: * Mark &subject and the cached s2 and s3 strings for map.
721: */
722: postqual(&k_subject);
723: if (Qual(maps2)) /* caution: the cached arguments of */
724: postqual(&maps2); /* map may not be strings. */
725: else if (Pointer(maps2))
726: markblock(&maps2);
727: if (Qual(maps3))
728: postqual(&maps3);
729: else if (Pointer(maps3))
730: markblock(&maps3);
731: /*
732: * Mark the tended descriptors and the global and static variables.
733: */
734: for (dp = &tended[1]; dp <= &tended[ntended]; dp++)
735: /* >locate */
736: if (Qual(*dp))
737: postqual(dp);
738: else if (Pointer(*dp))
739: markblock(dp);
740: /* <locate */
741: for (dp = globals; dp < eglobals; dp++)
742: if (Qual(*dp))
743: postqual(dp);
744: else if (Pointer(*dp))
745: markblock(dp);
746: for (dp = statics; dp < estatics; dp++)
747: if (Qual(*dp))
748: postqual(dp);
749: else if (Pointer(*dp))
750: markblock(dp);
751:
752: /*
753: * Collect available co-expression stacks.
754: */
755: cofree();
756: if (statneed) {
757: /*
758: * The static region needs to be expanded. Make sure the end has not
759: * been changed by someone else.
760: */
761: if (currend != sbrk(0))
762: runerr(304, NULL);
763: extra = statneed;
764: newend = (char *) quallist + extra;
765: /*
766: * This next calculation determines if there is space for the requested
767: * static region expansion. The checks involving quallist and newend
768: * appear to only be required on machines where the above addition
769: * of extra might overflow.
770: */
771:
772: if (newend < (char *)quallist || newend > (char *)0x7fffffff ||
773: (newend > (char *)equallist && ((word) brk(newend) == (word)-1)))
774: runerr(303, NULL);
775: statend += statneed;
776: statneed = 0;
777: currend = sbrk(0);
778: }
779: else
780: /*
781: * Expansion of the static memory region is not required.
782: */
783: extra = 0;
784:
785: /*
786: * Collect the string space, indicating that it must be moved back
787: * extra bytes.
788: */
789: scollect(extra);
790: /*
791: * strptr is post-gc value for strings. Move back pointers for strend
792: * and quallist according to value of extra.
793: */
794: strptr = strbase + extra;
795: strend += extra;
796: quallist = (struct descrip **)((char *)quallist + extra);
797: if (quallist > equallist)
798: equallist = quallist;
799:
800: /*
801: * Calculate a value for extra space. The value is (the larger of
802: * (twice the string space needed) or (the number of words currently
803: * in the string space)) plus the unallocated string space.
804: */
805: extra = (Max(2*strneed, (strend-(char *)statend)/4) -
806: (strend - extra - strfree) + (GranSize-1)) & ~(GranSize-1);
807:
808: while (extra > 0) {
809: /*
810: * Try to get extra more bytes of storage. If it can't be gotten,
811: * decrease the value by GranSize and try again. If it's gotten,
812: * move back strend and quallist. First make sure that someone
813: * has not moved the end of the region.
814: */
815: if (currend != sbrk(0))
816: runerr(304, NULL);
817: newend = (char *)quallist + extra;
818: if (newend >= (char *)quallist &&
819: (newend <= (char *)equallist || ((int) brk(newend) != -1))) {
820: strend += extra;
821: quallist = (struct descrip **) newend;
822: currend = sbrk(0);
823: break;
824: }
825: extra -= GranSize;
826: }
827:
828: /*
829: * Adjust the pointers in the block region. Note that blkbase is the old base
830: * of the block region and strend will be the post-gc base of the block region.
831: */
832: adjust(blkbase,strend);
833: /*
834: * Compact the block region.
835: */
836: compact(blkbase);
837: /*
838: * Calculate a value for extra space. The value is (the larger of
839: * (twice the block region space needed) or (the number of words currently
840: * in the block region space)) plus the unallocated block space.
841: */
842: extra = (Max(2*blkneed, (maxblk-blkbase)/4) +
843: blkfree - maxblk + (GranSize-1)) & ~(GranSize-1);
844: while (extra > 0) {
845: /*
846: * Try to get extra more bytes of storage. If it can't be gotten,
847: * decrease the value by GranSize and try again. If it's gotten,
848: * move back quallist. First make sure the end has not been changed.
849: */
850: if (currend != sbrk(0))
851: runerr(304, NULL);
852: newend = (char *)quallist + extra;
853: if (newend >= (char *)quallist &&
854: (newend <= (char *)equallist || ((int) brk(newend) != -1))) {
855: quallist = (struct descrip **) newend;
856: currend = sbrk(0);
857: break;
858: }
859: extra -= GranSize;
860: }
861: if (quallist > equallist)
862: equallist = quallist;
863:
864: if (strend != blkbase) {
865: /*
866: * strend is not equal to blkbase and this indicates that the
867: * static region or string region was expanded and thus
868: * the block region must be moved. There is an assumption here that the
869: * block region always moves up in memory, i.e., the static and
870: * string regions never shrink. With this assumption in hand,
871: * the block region must be moved before the string space lest the string
872: * space overwrite block data. The assumption is valid, but beware
873: * if shrinking regions are ever implemented.
874: */
875: mvc((uword)(blkfree - blkbase), blkbase, strend);
876: blkfree += strend - blkbase;
877: blkbase = strend;
878: }
879: if (strptr != strbase) {
880: /*
881: * strptr is not equal to strbase and this indicates that the
882: * co-expression space was expanded and thus the string space
883: * must be moved up in memory.
884: */
885: mvc((uword)(strfree - strbase), strbase, strptr);
886: strfree += strptr - strbase;
887: strbase = strptr;
888: }
889:
890: /*
891: * Expand the block region.
892: */
893: maxblk = (char *)quallist;
894: #ifdef RunStats
895: times(&tmbuf);
896: gc_t_last =
897: 1000*(((tmbuf.tms_utime + tmbuf.tms_stime)-gc_t_start)/(double)Hz);
898: IncSum(gc_t_total,gc_t_last);
899: #endif RunStats
900: MMEGC();
901: return;
902: }
903: /*
904: * markblock- mark each accessible block in the block region and build back-list of
905: * descriptors pointing to that block. (Phase I of garbage collection.)
906: */
907:
908: /* >markblock */
909: markblock(dp)
910: struct descrip *dp;
911: {
912: register struct descrip *dp1;
913: register char *endblock, *block;
914: static word type, fdesc, off;
915:
916: /*
917: * Get the block to which dp points.
918: */
919:
920: block = (char *) BlkLoc(*dp);
921: if (block >= blkbase && block < blkfree) { /* check range */
922: if (Var(*dp) && !Tvar(*dp)) {
923:
924: /*
925: * The descriptor is a variable; point block to the head of the
926: * block containing the descriptor to which dp points.
927: */
928: off = Offset(*dp);
929: if (off == 0)
930: return;
931: else
932: block = (char *) ((word *) block - off);
933: }
934:
935: type = BlkType(block);
936: if ((uword)type <= MaxType) {
937:
938: /*
939: * The type is valid, which indicates that this block has not
940: * been marked. Point endblock to the byte past the end
941: * of the block.
942: */
943: endblock = block + BlkSize(block);
944: MMMark(block,type);
945: }
946:
947: /*
948: * Add dp to the back-chain for the block and point the
949: * block (via the type field) to dp.
950: */
951: BlkLoc(*dp) = (union block *) type;
952: BlkType(block) = (word)dp;
953: if (((unsigned)type <= MaxType) && ((fdesc = firstd[type]) > 0))
954:
955: /*
956: * The block has not been marked, and it does contain
957: * descriptors. Mark each descriptor.
958: */
959: for (dp1 = (struct descrip *) (block + fdesc);
960: (char *) dp1 < endblock; dp1++) {
961: if (Qual(*dp1))
962: postqual(dp1);
963: else if (Pointer(*dp1))
964: markblock(dp1);
965: }
966: }
967: else if (dp->dword == D_Coexpr &&
968: (unsigned)BlkType(block) <= MaxType) {
969:
970: /*
971: * dp points to a co-expression block that has not been
972: * marked. Point the block to dp. Sweep the interpreter
973: * stack in the block and mark the block for the
974: * activating co-expression and the refresh block.
975: */
976: BlkType(block) = (word)dp;
977: sweep((struct b_coexpr *)block);
978: markblock(&((struct b_coexpr *)block)->activator);
979: markblock(&((struct b_coexpr *)block)->freshblk);
980: }
981: }
982: /* <markblock */
983:
984: /*
985: * adjust - adjust pointers into the block region, beginning with block oblk and
986: * basing the "new" block region at nblk. (Phase II of garbage collection.)
987: */
988:
989: /* >adjust */
990: adjust(source,dest)
991: char *source, *dest;
992: {
993: register struct descrip *nxtptr, *tptr;
994:
995: /*
996: * Loop through to the end of allocated block region, moving source
997: * to each block in turn and using the size of a block to find the
998: * next block.
999: */
1000: while (source < blkfree) {
1001: if ((uword) (nxtptr = (struct descrip *)BlkType(source)) > MaxType) {
1002:
1003: /*
1004: * The type field of source is a back-pointer. Traverse the
1005: * chain of back pointers, changing each block location from
1006: * source to dest.
1007: */
1008: while ((uword)nxtptr > MaxType) {
1009: tptr = nxtptr;
1010: nxtptr = (struct descrip *)BlkLoc(*nxtptr);
1011: if (Var(*tptr) && !Tvar(*tptr))
1012: BlkLoc(*tptr) = (union block *)((word *)dest + Offset(*tptr));
1013: else
1014: BlkLoc(*tptr) = (union block *)dest;
1015: }
1016: BlkType(source) = (uword)nxtptr | F_Mark;
1017: dest += BlkSize(source);
1018: }
1019: source += BlkSize(source);
1020: }
1021: }
1022: /* <adjust */
1023:
1024: /*
1025: * compact - compact good blocks in the block region. (Phase III of garbage collection.)
1026: */
1027:
1028: /* >compact */
1029: compact(source)
1030: char *source;
1031: {
1032: register char *dest;
1033: register word size;
1034:
1035: /*
1036: * Start dest at source.
1037: */
1038: dest = source;
1039:
1040: /*
1041: * Loop through to end of allocated block space moving source to
1042: * each block in turn, using the size of a block to find the next
1043: * block. If a block has been marked, it is copied to the
1044: * location pointed to by dest and dest is pointed past the end
1045: * of the block, which is the location to place the next saved
1046: * block. Marks are removed from the saved blocks.
1047: */
1048: while (source < blkfree) {
1049: size = BlkSize(source);
1050: if (BlkType(source) & F_Mark) {
1051: BlkType(source) &= ~F_Mark;
1052: if (source != dest)
1053: mvc((uword)size,source,dest);
1054: dest += size;
1055: }
1056: source += size;
1057: }
1058:
1059: /*
1060: * dest is the location of the next free block. Now that compaction
1061: * is complete, point blkfree to that location.
1062: */
1063: blkfree = dest;
1064: }
1065: /* <compact */
1066:
1067: /*
1068: * postqual - mark a string qualifier. Strings outside the string space
1069: * are ignored.
1070: */
1071:
1072: /* >postqual */
1073: postqual(dp)
1074: struct descrip *dp;
1075: {
1076: #ifndef MSDOS
1077: extern char *brk();
1078: #endif MSDOS
1079: extern char *sbrk();
1080:
1081: if (StrLoc(*dp) >= strbase && StrLoc(*dp) < strend) {
1082: /*
1083: * The string is in the string space. Add it to the string qualifier
1084: * list. But before adding it, expand the string qualifier list
1085: * if necessary.
1086: */
1087: if (qualfree >= equallist) {
1088: equallist += Sqlinc;
1089: if (currend != sbrk(0)) /* make sure region has not changed */
1090: runerr(304, NULL);
1091: if ((int) brk(equallist) == -1) /* make sure region can be expanded */
1092: runerr(303, NULL);
1093: currend = sbrk(0);
1094: }
1095: *qualfree++ = dp;
1096: }
1097: }
1098: /* <postqual */
1099:
1100: /*
1101: * scollect - collect the string space. quallist is a list of pointers to
1102: * descriptors for all the reachable strings in the string space. For
1103: * ease of description, it is referred to as if it were composed of
1104: * descriptors rather than pointers to them.
1105: */
1106:
1107: /* >scollect */
1108: scollect(extra)
1109: word extra;
1110: {
1111: register char *source, *dest;
1112: register struct descrip **qptr;
1113: char *cend;
1114: extern int qlcmp();
1115:
1116: if (qualfree <= quallist) {
1117: /*
1118: * There are no accessible strings. Thus, there are none to
1119: * collect and the whole string space is free.
1120: */
1121: strfree = strbase;
1122: return;
1123: }
1124: /*
1125: * Sort the pointers on quallist in ascending order of string locations.
1126: */
1127: qsort(quallist, qualfree-quallist, sizeof(struct descrip *), qlcmp);
1128: /*
1129: * The string qualifiers are now ordered by starting location.
1130: */
1131: dest = strbase;
1132: source = cend = StrLoc(**quallist);
1133:
1134: /*
1135: * Loop through qualifiers for accessible strings.
1136: */
1137: for (qptr = quallist; qptr < qualfree; qptr++) {
1138: if (StrLoc(**qptr) > cend) {
1139:
1140: /*
1141: * qptr points to a qualifier for a string in the next clump;
1142: * the last clump is moved and source and cend are set for
1143: * the next clump.
1144: */
1145: MMSMark(source,cend - source);
1146: while (source < cend)
1147: *dest++ = *source++;
1148: source = cend = StrLoc(**qptr);
1149: }
1150: if (StrLoc(**qptr)+StrLen(**qptr) > cend)
1151: /*
1152: * qptr is a qualifier for a string in this clump; extend the clump.
1153: */
1154: cend = StrLoc(**qptr) + StrLen(**qptr);
1155: /*
1156: * Relocate the string qualifier.
1157: */
1158: StrLoc(**qptr) += dest - source + extra;
1159: }
1160:
1161: /*
1162: * Move the last clump.
1163: */
1164: MMSMark(source,cend - source);
1165: while (source < cend)
1166: *dest++ = *source++;
1167: strfree = dest;
1168: }
1169: /* <scollect */
1170:
1171: /*
1172: * qlcmp - compare the location fields of two string qualifiers for qsort.
1173: */
1174:
1175: /* >qlcmp */
1176: qlcmp(q1,q2)
1177: struct descrip **q1, **q2;
1178: {
1179: return (int)(StrLoc(**q1) - StrLoc(**q2));
1180: }
1181: /* <qlcmp */
1182:
1183: /*
1184: * mvc - move n bytes from src to dst.
1185: */
1186:
1187: mvc(n, s, d)
1188: uword n;
1189: register char *s, *d;
1190: {
1191: register int words;
1192: register int *srcw, *dstw;
1193: int bytes;
1194:
1195: words = n / sizeof(int);
1196: bytes = n % sizeof(int);
1197:
1198: srcw = (int *)s;
1199: dstw = (int *)d;
1200:
1201: if (d < s) {
1202: /*
1203: * The move is from higher memory to lower memory. (It so happens
1204: * that leftover bytes are not moved.)
1205: */
1206: while (--words >= 0)
1207: *(dstw)++ = *(srcw)++;
1208: while (--bytes >= 0)
1209: *d++ = *s++;
1210: }
1211: else if (d > s) {
1212: /*
1213: * The move is from lower memory to higher memory.
1214: */
1215: s += n;
1216: d += n;
1217: while (--bytes >= 0)
1218: *--d = *--s;
1219: srcw = (int *)s;
1220: dstw = (int *)d;
1221: while (--words >= 0)
1222: *--dstw = *--srcw;
1223: }
1224: }
1225:
1226: /*
1227: * sweep - sweep the stack, marking all descriptors there. Method
1228: * is to start at a known point, specifically, the frame that the
1229: * fp points to, and then trace back along the stack looking for
1230: * descriptors and local variables, marking them when they are found.
1231: * The sp starts at the first frame, and then is moved down through
1232: * the stack. Procedure, generator, and expression frames are
1233: * recognized when the sp is a certain distance from the fp, gfp,
1234: * and efp respectively.
1235: *
1236: * Sweeping problems can be manifested in a variety of ways due to
1237: * the "if it can't be identified it's a descriptor" methodology.
1238: */
1239: sweep(ce)
1240: struct b_coexpr *ce;
1241: {
1242: register word *s_sp;
1243: register struct pf_marker *fp;
1244: register struct gf_marker *s_gfp;
1245: register struct ef_marker *s_efp;
1246: word nargs, type, gsize;
1247:
1248: fp = ce->es_pfp;
1249: s_gfp = ce->es_gfp;
1250: if (s_gfp != 0) {
1251: type = s_gfp->gf_gentype;
1252: if (type == G_Psusp)
1253: gsize = Wsizeof(*s_gfp);
1254: else
1255: gsize = Wsizeof(struct gf_smallmarker);
1256: }
1257: s_efp = ce->es_efp;
1258: s_sp = ce->es_sp;
1259: nargs = 0; /* Nargs counter is 0 initially. */
1260:
1261: while ((fp != 0 || nargs)) { /* Keep going until current fp is
1262: 0 and no arguments are left. */
1263: if (s_sp == (word *)fp + Vwsizeof(*pfp) - 1) {/*The sp has reached the upper
1264: boundary of a procedure frame,
1265: process the frame. */
1266: s_efp = fp->pf_efp; /* Get saved efp out of frame */
1267: s_gfp = fp->pf_gfp; /* Get save gfp */
1268: if (s_gfp != 0) {
1269: type = s_gfp->gf_gentype;
1270: if (type == G_Psusp)
1271: gsize = Wsizeof(*s_gfp);
1272: else
1273: gsize = Wsizeof(struct gf_smallmarker);
1274: }
1275: s_sp = (word *)fp - 1; /* First argument descriptor is
1276: first word above proc frame */
1277: nargs = fp->pf_nargs;
1278: fp = fp->pf_pfp;
1279: }
1280: else if (s_sp == (word *)s_gfp + gsize - 1) {
1281: /* The sp has reached the lower end
1282: of a generator frame, process
1283: the frame.*/
1284: if (type == G_Psusp)
1285: fp = s_gfp->gf_pfp;
1286: s_sp = (word *)s_gfp - 1;
1287: s_efp = s_gfp->gf_efp;
1288: s_gfp = s_gfp->gf_gfp;
1289: if (s_gfp != 0) {
1290: type = s_gfp->gf_gentype;
1291: if (type == G_Psusp)
1292: gsize = Wsizeof(*s_gfp);
1293: else
1294: gsize = Wsizeof(struct gf_smallmarker);
1295: }
1296: nargs = 1;
1297: }
1298: else if (s_sp == (word *)s_efp + Wsizeof(*s_efp) - 1) {
1299: /* The sp has reached the upper
1300: end of an expression frame,
1301: process the frame. */
1302: s_gfp = s_efp->ef_gfp; /* Restore gfp, */
1303: if (s_gfp != 0) {
1304: type = s_gfp->gf_gentype;
1305: if (type == G_Psusp)
1306: gsize = Wsizeof(*s_gfp);
1307: else
1308: gsize = Wsizeof(struct gf_smallmarker);
1309: }
1310: s_efp = s_efp->ef_efp; /* and efp from frame. */
1311: s_sp -= Wsizeof(*s_efp); /* Move down past expression frame
1312: marker. */
1313: }
1314: else { /* Assume the sp is pointing at a
1315: descriptor. */
1316: if (Qual(*((struct descrip *)(&s_sp[-1]))))
1317: postqual(&s_sp[-1]);
1318: else if (Pointer(*((struct descrip *)(&s_sp[-1]))))
1319: markblock(&s_sp[-1]);
1320: s_sp -= 2; /* Move past descriptor. */
1321: if (nargs) /* Decrement argument count if in an*/
1322: nargs--; /* argument list. */
1323: }
1324: }
1325: }
1326:
1327: typedef int ALIGN; /* pick most stringent type for alignment */
1328:
1329: union bhead { /* header of free block */
1330: struct {
1331: union bhead *ptr; /* pointer to next free block */
1332: uword bsize; /* free block size */
1333: } s;
1334: ALIGN x; /* force block alignment */
1335: };
1336:
1337: typedef union bhead HEADER;
1338: #define NALLOC 1024 /* units to request at one time */
1339:
1340:
1341: static HEADER base; /* start with empty list */
1342: static HEADER *allocp = NULL; /* last allocated block */
1343:
1344: char *malloc(nbytes)
1345: unsigned nbytes;
1346: {
1347: HEADER *moremem();
1348: register HEADER *p, *q;
1349: register word nunits;
1350: int attempts;
1351:
1352: nunits = 1 + (nbytes + sizeof(HEADER) - 1) / sizeof(HEADER);
1353: if ((q = allocp) == NULL) { /* no free list yet */
1354: base.s.ptr = allocp = q = &base;
1355: base.s.bsize = 0;
1356: }
1357:
1358: for (attempts = 2; attempts--; q = allocp) {
1359: for (p = q->s.ptr;; q = p, p = p->s.ptr) {
1360: if (p->s.bsize >= nunits) { /* block is big enough */
1361: if (p->s.bsize == nunits) /* exactly right */
1362: q->s.ptr = p->s.ptr;
1363: else { /* allocate tail end */
1364: p->s.bsize -= nunits;
1365: p += p->s.bsize;
1366: p->s.bsize = nunits;
1367: }
1368: allocp = q;
1369: return (char *)(p + 1);
1370: }
1371: if (p == allocp) { /* wrap around */
1372: moremem(nunits); /* garbage collect and expand if needed */
1373: break;
1374: }
1375: }
1376: }
1377: syserr("cannot allocate requested storage");
1378: }
1379:
1380: /*
1381: * realloc() allocates a new block of memory of a different size
1382: * that contains the contents of the current block or as much as
1383: * will fit.
1384: */
1385:
1386: char *realloc(curmem,newsiz)
1387: register char *curmem; /* the current memory pointer */
1388: register int newsiz; /* the size of the new allocation */
1389: {
1390: register char *newmem, *p; /* the new memory pointer */
1391: register int cursiz; /* the size of the current allocation */
1392: register int n;
1393:
1394: HEADER *head; /* the pointer to the current header */
1395:
1396: if ((newmem = malloc(newsiz)) != NULL) {
1397: /* get the current allocation size */
1398: head = (HEADER *) (curmem-1);
1399: cursiz = head->s.bsize;
1400: p = newmem;
1401: n = (cursiz < newsiz ? cursiz : newsiz);
1402: while (--n >= 0)
1403: *newmem++ = *curmem++;
1404:
1405: /* free the current block */
1406: free(curmem);
1407: return(p);
1408: }
1409: syserr("malloc failed in realloc");
1410: }
1411:
1412: /*
1413: * calloc() allocates memory using malloc and zeroes it.
1414: */
1415:
1416: char *calloc(ecnt,esiz)
1417: register int ecnt, esiz;
1418: {
1419: register char *mem, *p; /* the memory pointer */
1420: register int amount; /* the amount of memory needed */
1421:
1422: amount = ecnt * esiz;
1423:
1424: if ((mem = malloc(amount)) != NULL) {
1425: p = mem;
1426: while (--amount >= 0)
1427: *mem++ = 0;
1428: return p;
1429: }
1430: syserr("malloc failure in calloc");
1431: }
1432:
1433: static HEADER *moremem(nunits)
1434: uword nunits;
1435: {
1436: register char *cp;
1437: register HEADER *up;
1438: register word rnu;
1439: word n;
1440:
1441: rnu = NALLOC * ((nunits + NALLOC - 1) / NALLOC);
1442: n = rnu * sizeof(HEADER);
1443: if (statfree + n > statend) {
1444: statneed = ((n / statincr) + 1) * statincr;
1445: collect();
1446: }
1447: if (statfree < statend) { /* that is, if there is any room left */
1448: up = (HEADER *) statfree;
1449: up->s.bsize = (statend - statfree) / sizeof(HEADER);
1450: statfree = statend;
1451: free((char *) (up + 1)); /* add block to free memory */
1452: }
1453: }
1454:
1455: free(ap) /* return block pointed to by ap to free list */
1456: char *ap;
1457: {
1458: register HEADER *p, *q;
1459:
1460: p = (HEADER *)ap - 1; /* point to header */
1461: if (p->s.bsize * sizeof(HEADER) >= statneed)
1462: statneed = 0;
1463: for (q = allocp; !(p > q && p < q->s.ptr); q = q->s.ptr)
1464: if (q >= q->s.ptr && (p > q || p < q->s.ptr))
1465: break; /* at one end or the other */
1466: if (p + p->s.bsize == q->s.ptr) { /* join to upper */
1467: p->s.bsize += q->s.ptr->s.bsize;
1468: if (p->s.bsize * sizeof(HEADER) >= statneed)
1469: statneed = 0;
1470: p->s.ptr = q->s.ptr->s.ptr;
1471: }
1472: else
1473: p->s.ptr = q->s.ptr;
1474: if (q + q->s.bsize == p) { /* join to lower */
1475: q->s.bsize += p->s.bsize;
1476: if (q->s.bsize * sizeof(HEADER) >= statneed)
1477: statneed = 0;
1478: q->s.ptr = p->s.ptr;
1479: }
1480: else
1481: q->s.ptr = p;
1482: allocp = q;
1483: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.