/* * File: rmemmgt.c * Contents: allocation routines, block description arrays, dump routines, * garbage collection, sweep */ #include "..\h\config.h" #include "..\h\rt.h" #include "rproto.h" #if MACINTOSH #if MPW #include #include #endif /* MPW */ #endif /* MACINTOSH */ #ifdef IconAlloc /* * If IconAlloc is defined the system allocation routines are not overloaded. * The names are changed so that Icon's allocation routines are independently * used. This works as long as no other system calls cause the break value * to change. */ #define malloc mem_alloc #define free mem_free #define realloc mem_realloc #define calloc mem_calloc #endif /* IconAlloc */ #ifdef CRAY #include #endif /* CRAY */ /* * Prototype. */ hidden union block *alcblk Params((uword nbytes,int tcode)); word coexp_ser = 1; /* serial numbers for co-expressions; &main is 1 */ word list_ser = 1; /* serial numbers for lists */ word set_ser = 1; /* serial numbers for sets */ word table_ser = 1; /* serial numbers for tables */ word coll_stat = 0; /* collections in static region */ word coll_str = 0; /* collections in string region */ word coll_blk = 0; /* collections in block region */ word coll_tot = 0; /* total collections */ #ifdef EvalTrace extern FILE *trfile; extern word colmno; extern word lineno; #endif /* EvalTrace */ #ifdef FixedRegions word alcnum = 0; /* co-expressions allocated since g.c. */ #endif /* FixedRegions */ dptr *quallist; /* string qualifier list */ dptr *qualfree; /* qualifier list free pointer */ dptr *equallist; /* end of qualifier list */ int qualfail; /* flag: quailifier list overflow */ /* * Note: function calls beginning with "MM" are just empty macros * unless MemMon is defined. */ /* * Allocated block size table (sizes given in bytes). A size of -1 is used * for types that have no blocks; a size of 0 indicates that the * second word of the block contains the size; a value greater than * 0 is used for types with constant sized blocks. */ int bsizes[] = { -1, /* T_Null (0), not block */ -1, /* T_Integer (1), not block */ #ifdef LargeInts 0, /* T_Bignum (2), bignum */ #else -1, /* (2), not used */ #endif /* LargeInts */ sizeof(struct b_real), /* T_Real (3), real number */ sizeof(struct b_cset), /* T_Cset (4), cset */ sizeof(struct b_file), /* T_File (5), file block */ 0, /* T_Proc (6), procedure block */ sizeof(struct b_list), /* T_List (7), list header block */ sizeof(struct b_table), /* T_Table (8), table header block */ 0, /* T_Record (9), record block */ sizeof(struct b_telem), /* T_Telem (10), table element block */ 0, /* T_Lelem (11), list element block */ sizeof(struct b_tvsubs), /* T_Tvsubs (12), substring trapped variable */ -1, /* T_Tvkywd (13), keyword trapped variable */ sizeof(struct b_tvtbl), /* T_Tvtbl (14), table element trapped variable */ sizeof(struct b_set), /* T_Set (15), set header block */ sizeof(struct b_selem), /* T_Selem (16), set element block */ 0, /* T_Refresh (17), refresh block */ -1, /* T_Coexpr (18), co-expression block */ 0, /* T_External (19), external block */ 0, /* T_Slots (20), set/table hash block */ }; /* * Table of offsets (in bytes) to first descriptor in blocks. -1 is for * types not allocated, 0 for blocks with no descriptors. */ int firstd[] = { -1, /* T_Null (0), not block */ -1, /* T_Integer (1), not block */ #ifdef LargeInts 0, /* T_Bignum (2), bignum */ #else -1, /* (2), not used */ #endif /* LargeInts */ 0, /* T_Real (3), real number */ 0, /* T_Cset (4), cset */ 3*WordSize, /* T_File (5), file block */ 7*WordSize, /* T_Proc (6), procedure block */ 0, /* T_List (7), list header block */ (4+HSegs)*WordSize, /* T_Table (8), table header block */ 4*WordSize, /* T_Record (9), record block */ 3*WordSize, /* T_Telem (10), table element block */ 7*WordSize, /* T_Lelem (11), list element block */ 3*WordSize, /* T_Tvsubs (12), substring trapped variable */ -1, /* T_Tvkywd (13), keyword trapped variable */ 3*WordSize, /* T_Tvtbl (14), table element trapped variable */ 0, /* T_Set (15), set header block */ 3*WordSize, /* T_Selem (16), set element block */ (4+Wsizeof(struct pf_marker))*WordSize, /* T_Refresh (17), refresh block */ -1, /* T_Coexpr (18), co-expression block */ 0, /* T_External (19), external block */ 0, /* T_Slots (20), set/table hash block */ }; /* * Table of offsets (in bytes) to first pointer in blocks. -1 is for * types not allocated, 0 for blocks with no pointers. */ int firstp[] = { -1, /* T_Null (0), not block */ -1, /* T_Integer (1), not block */ #ifdef LargeInts 0, /* T_Bignum (2), bignum */ #else -1, /* (2), not used */ #endif /* LargeInts */ 0, /* T_Real (3), real number */ 0, /* T_Cset (4), cset */ 0, /* T_File (5), file block */ 0, /* T_Proc (6), procedure block */ 3*WordSize, /* T_List (7), list header block */ 4*WordSize, /* T_Table (8), table header block */ 3*WordSize, /* T_Record (9), record block */ 1*WordSize, /* T_Telem (10), table element block */ 2*WordSize, /* T_Lelem (11), list element block */ 0, /* T_Tvsubs (12), substring trapped variable */ -1, /* T_Tvkywd (13), keyword trapped variable */ 1*WordSize, /* T_Tvtbl (14), table element trapped variable */ 4*WordSize, /* T_Set (15), set header block */ 1*WordSize, /* T_Selem (16), set element block */ 0, /* T_Refresh (17), refresh block */ -1, /* T_Coexpr (18), co-expression block */ 0, /* T_External (19), external block */ 2*WordSize, /* T_Slots (20), set/table hash block */ }; /* * Table of number of pointers in blocks. -1 is for types not allocated and * types without pointers, 0 for pointers through the end of the block. */ int ptrno[] = { -1, /* T_Null (0), not block */ -1, /* T_Integer (1), not block */ -1, /* T_Bignum (2), large integer, or not used */ -1, /* T_Real (3), real number */ -1, /* T_Cset (4), cset */ -1, /* T_File (5), file block */ -1, /* T_Proc (6), procedure block */ 2, /* T_List (7), list header block */ HSegs, /* T_Table (8), table header block */ 1, /* T_Record (9), record block */ 1, /* T_Telem (10), table element block */ 2, /* T_Lelem (11), list element block */ -1, /* T_Tvsubs (12), substring trapped variable */ -1, /* T_Tvkywd (13), keyword trapped variable */ 1, /* T_Tvtbl (14), table element trapped variable */ HSegs, /* T_Set (15), set header block */ 1, /* T_Selem (16), set element block */ -1, /* T_Refresh (17), refresh block */ -1, /* T_Coexpr (18), co-expression block */ -1, /* T_External (19), external block */ 0, /* T_Slots (20), set/table hash block */ }; /* * Table of block names used by debugging functions. */ char *blkname[] = { "illegal object", /* T_Null (0), not block */ "illegal object", /* T_Integer (1), not block */ #ifdef LargeInts "large integer", /* T_Bignum (2), bignum */ #else "illegal object", /* not used */ #endif /* LargeInts */ "real number", /* T_Real (3) */ "cset", /* T_Cset (4) */ "file", /* T_File (5) */ "procedure", /* T_Proc (6) */ "list", /* T_List (7) */ "table", /* T_Table (8) */ "record", /* T_Record (9) */ "table element", /* T_Telem (10) */ "list element", /* T_Lelem (11) */ "substring trapped variable", /* T_Tvsubs (12) */ "keyword trapped variable", /* T_Tvkywd (13) */ "table element trapped variable", /* T_Tvtbl (14) */ "set", /* T_Set (15) */ "set elememt", /* T_Selem (16) */ "refresh block", /* T_Refresh (17) */ "co-expression", /* T_Coexpr (18) */ "external block", /* T_External (19) */ "hash block", /* T_Slots (20) */ }; /* * Sizes of hash chain segments. * Table size must equal or exceed HSegs. */ uword segsize[] = { ((uword)HSlots), /* segment 0 */ ((uword)HSlots), /* segment 1 */ ((uword)HSlots) << 1, /* segment 2 */ ((uword)HSlots) << 2, /* segment 3 */ ((uword)HSlots) << 3, /* segment 4 */ ((uword)HSlots) << 4, /* segment 5 */ ((uword)HSlots) << 5, /* segment 6 */ ((uword)HSlots) << 6, /* segment 7 */ ((uword)HSlots) << 7, /* segment 8 */ ((uword)HSlots) << 8, /* segment 9 */ ((uword)HSlots) << 9, /* segment 10 */ ((uword)HSlots) << 10, /* segment 11 */ }; #ifdef FixedRegions #include "rmemfix.c" #else /* FixedRegions */ #include "rmemexp.c" #endif /* FixedRegions */ /* * alcblk - returns pointer to nbytes of free storage in block region. */ static union block *alcblk(nbytes,tcode) uword nbytes; int tcode; { register uword fspace, *sloc; /* * See if there is enough room in the block region. */ fspace = DiffPtrs(blkend,blkfree); if (fspace < nbytes) syserr("block allocation botch"); /* * If monitoring, show the allocation. */ MMAlc((word)nbytes,tcode); #ifdef EvalTrace if (trfile) { fprintf(trfile,"a\t%ld\t%ld\t%d\t%ld\n",colmno,lineno,tcode,nbytes); } #endif /* EvalTrace */ /* * Decrement the free space in the block region by the number of bytes * allocated and return the address of the first byte of the allocated * block. */ sloc = (uword *)blkfree; blkneed -= nbytes; blkfree += nbytes; BlkType(sloc) = tcode; return (union block *)(sloc); } /* * alcreal - allocate a real value in the block region. */ struct b_real *alcreal(val) double val; { register struct b_real *blk; blk = (struct b_real *)alcblk((uword)sizeof(struct b_real), T_Real); #ifdef Double /* access real values one word at a time */ { int *rp, *rq; rp = (word *) &(blk->realval); rq = (word *) &val; *rp++ = *rq++; *rp = *rq; } #else /* Double */ blk->realval = val; #endif /* Double */ return blk; } #ifdef LargeInts /* * alcbignum - allocate an n-digit bignum in the block region */ struct b_bignum *alcbignum(n) word n; { register struct b_bignum *blk; register uword size; size = sizeof(struct b_bignum) + ((n - 1) * sizeof(DIGIT)); /* ensure whole number of words allocated */ size = (size + WordSize - 1) & -WordSize; blk = (struct b_bignum *)alcblk(size, T_Bignum); blk->blksize = size; blk->msd = blk->sign = 0; blk->lsd = n - 1; return blk; } #endif /* LargeInts */ /* * alccset - allocate a cset in the block region. */ struct b_cset *alccset() { register struct b_cset *blk; register int i; blk = (struct b_cset *)alcblk((uword)sizeof(struct b_cset), T_Cset); blk->size = -1; /* flag size as not yet computed */ /* * Zero the bit array. */ for (i = 0; i < CsetSize; i++) blk->bits[i] = 0; return blk; } /* * alcfile - allocate a file block in the block region. */ struct b_file *alcfile(fd, status, name) FILE *fd; int status; dptr name; { register struct b_file *blk; blk = (struct b_file *)alcblk((uword)sizeof(struct b_file), T_File); blk->fd = fd; blk->status = status; blk->fname = *name; return blk; } /* * alcrecd - allocate record with nflds fields in the block region. */ struct b_record *alcrecd(nflds, recptr) int nflds; union block **recptr; { register struct b_record *blk; register int size; size = Vsizeof(struct b_record) + nflds*sizeof(struct descrip); blk = (struct b_record *)alcblk((uword)size, T_Record); blk->blksize = size; blk->recdesc = (union block *)recptr; return blk; } /* * alcextrnl - allocate an external block. */ struct b_external *alcextrnl(n) int n; { register struct b_external *blk; blk = (struct b_external *)alcblk((uword)(n * sizeof(word)), T_External); blk->blksize = (n + 3) * sizeof(word); blk->descoff = 0; /* probably ought to clear the rest of the block */ return blk; } /* * alclist - allocate a list header block in the block region. */ struct b_list *alclist(size) uword size; { static word list_ser = 1; register struct b_list *blk; blk = (struct b_list *)alcblk((uword)sizeof(struct b_list), T_List); blk->size = size; blk->listhead = NULL; blk->listtail = NULL; blk->id = list_ser++; return blk; } /* * alclstb - allocate a list element block in the block region. */ struct b_lelem *alclstb(nslots, first, nused) uword nslots, first, nused; { register struct b_lelem *blk; register word i, size; size = Vsizeof(struct b_lelem) + nslots * sizeof(struct descrip); blk = (struct b_lelem *)alcblk((uword)size, T_Lelem); blk->blksize = size; blk->nslots = nslots; blk->first = first; blk->nused = nused; blk->listprev = NULL; blk->listnext = NULL; /* * Set all elements to &null. */ for (i = 0; i < nslots; i++) blk->lslots[i] = nulldesc; return blk; } /* * alchash - allocate a hashed structure (set or table header) in the block * region. */ union block *alchash(tcode) int tcode; { static word table_ser = 1; static word set_ser = 1; register int i; register union block *blk; word serial; uword blksize; if (tcode == T_Table) { serial = table_ser++; blksize = sizeof(struct b_table); } else { /* tcode == T_Set */ serial = set_ser++; blksize = sizeof(struct b_set); } blk = alcblk(blksize, tcode); blk->set.size = 0; blk->set.id = serial; blk->set.mask = 0; for (i = 0; i < HSegs; i++) blk->set.hdir[i] = NULL; return blk; } /* * alcsegment - allocate a slot block in the block region. */ struct b_slots *alcsegment(nslots) word nslots; { uword size; register struct b_slots *blk; size = sizeof(struct b_slots) + WordSize * (nslots - HSlots); blk = (struct b_slots *)alcblk(size, T_Slots); blk->blksize = size; while (--nslots >= 0) blk->hslots[nslots] = NULL; return blk; } /* * alctelem - allocate a table element block in the block region. */ struct b_telem *alctelem() { register struct b_telem *blk; blk = (struct b_telem *)alcblk((uword)sizeof(struct b_telem), T_Telem); blk->hashnum = 0; blk->clink = NULL; blk->tref = nulldesc; blk->tval = nulldesc; return blk; } /* * alcselem - allocate a set element block. */ struct b_selem *alcselem(mbr,hn) dptr mbr; uword hn; { register struct b_selem *blk; blk = (struct b_selem *)alcblk((uword)sizeof(struct b_selem), T_Selem); blk->clink = NULL; blk->setmem = *mbr; blk->hashnum = hn; return blk; } /* * alcsubs - allocate a substring trapped variable in the block region. */ struct b_tvsubs *alcsubs(len, pos, var) word len, pos; dptr var; { register struct b_tvsubs *blk; blk = (struct b_tvsubs *)alcblk((uword)sizeof(struct b_tvsubs), T_Tvsubs); blk->sslen = len; blk->sspos = pos; blk->ssvar = *var; return blk; } /* * alctvtbl - allocate a table element trapped variable block in the block * region. */ struct b_tvtbl *alctvtbl(tbl, ref, hashnum) register dptr tbl, ref; uword hashnum; { register struct b_tvtbl *blk; blk = (struct b_tvtbl *)alcblk((uword)sizeof(struct b_tvtbl), T_Tvtbl); blk->hashnum = hashnum; blk->clink = BlkLoc(*tbl); blk->tref = *ref; blk->tval = nulldesc; return blk; } /* * alcstr - allocate a string in the string space. */ char *alcstr(s, slen) register char *s; register word slen; { register char *d; register uword fspace; char *ofree; MMStr(slen); #ifdef EvalTrace if (trfile) { fprintf(trfile,"a\t%ld\t%ld\t%ld\n",colmno,lineno,slen); } #endif /* EvalTrace */ /* * See if there is enough room in the string space. */ fspace = DiffPtrs(strend,strfree); if (fspace < slen) syserr("string allocation botch"); strneed -= slen; /* * Copy the string into the string space, saving a pointer to its * beginning. Note that s may be null, in which case the space * is still to be allocated but nothing is to be copied into it. */ ofree = d = strfree; if (s) { while (slen-- > 0) *d++ = *s++; } else d += slen; strfree = d; return ofree; } /* * alccoexp - allocate a co-expression stack block. */ struct b_coexpr *alccoexp() { struct b_coexpr *ep; static word coexp_ser = 2; /* &main is 1 */ #ifdef ATTM32 ep = (struct b_coexpr *)coexp_salloc(); /* 3B2/15/4000 stack */ #else /* ATTM32 */ ep = (struct b_coexpr *)malloc((msize)stksize); #endif /* ATTM32 */ /* * If malloc failed or if there have been too many co-expression allocations * since a collection, attempt to free some co-expression blocks and retry. */ #ifdef FixedRegions if (ep == NULL || alcnum > AlcMax) { #else /* FixedRegions */ if (ep == NULL) { #endif /* Fixed Regions */ collect(Static); #ifdef ATTM32 /* not needed, but here to play it safe */ ep = (struct b_coexpr *)coexp_salloc(); /* 3B2/15/4000 stack */ #else /* ATTM32 */ ep = (struct b_coexpr *)malloc((msize)stksize); #endif /* ATTM32 */ } if (ep == NULL) { k_errornumber = -305; k_errortext = ""; k_errorvalue = nulldesc; return NULL; } #ifdef FixedRegions alcnum++; /* increment allocation count since last g.c. */ #endif /* FixedRegions */ ep->title = T_Coexpr; ep->es_actstk = NULL; ep->size = 0; ep->id = coexp_ser++; ep->nextstk = stklist; stklist = ep; MMStat((char *)ep, stksize, 'X'); return ep; } /* * alcactiv - allocate a co-expression activation block. */ struct astkblk *alcactiv() { struct astkblk *abp; abp = (struct astkblk *)malloc((msize)sizeof(struct astkblk)); #ifdef FixedRegions /* * If malloc failed, attempt to free some co-expression blocks and retry. */ if (abp == NULL) { collect(Static); abp = (struct astkblk *)malloc((msize)sizeof(struct astkblk)); } #endif /* FixedRegions */ if (abp == NULL) { k_errornumber = -305; k_errortext = ""; k_errorvalue = nulldesc; return NULL; } abp->nactivators = 0; abp->astk_nxt = NULL; return abp; } /* * alcrefresh - allocate a co-expression refresh block. */ struct b_refresh *alcrefresh(entryx, na, nl) word *entryx; int na, nl; { int size; struct b_refresh *blk; size = Vsizeof(struct b_refresh) + (na + nl) * sizeof(struct descrip); blk = (struct b_refresh *)alcblk((uword)size, T_Refresh); blk->blksize = size; blk->ep = entryx; blk->numlocals = nl; return blk; } /* * blkreq - insure that at least bytes of space are left in the block region. * The amount of space needed is transmitted to the collector via * the global variable blkneed. */ int blkreq(bytes) uword bytes; { blkneed = bytes; if (bytes > (uword)DiffPtrs(blkend,blkfree)) { coll_blk++; collect(Blocks); if (bytes > (uword)DiffPtrs(blkend,blkfree)) RetError(-307, nulldesc); } return Success; } /* * strreq - insure that at least n of space are left in the string * space. The amount of space needed is transmitted to the collector * via the global variable strneed. */ int strreq(n) uword n; { strneed = n; /* save in case of collection */ if (n > (uword)DiffPtrs(strend,strfree)) { coll_str++; collect(Strings); if (n > (uword)DiffPtrs(strend,strfree)) { #ifdef FixedRegions if (qualfail) RetError(-304, nulldesc); #endif /* FixedRegions */ RetError(-306, nulldesc); } } return Success; } /* * cofree - collect co-expression blocks. This is done after * the marking phase of garbage collection and the stacks that are * reachable have pointers to data blocks, rather than T_Coexpr, * in their type field. */ novalue cofree() { register struct b_coexpr **ep, *xep; extern word mstksize; /* main stack size */ register struct astkblk *abp, *xabp; /* * Reset the type for &main. */ BlkLoc(k_main)->coexpr.title = T_Coexpr; /* * The co-expression blocks are linked together through their * nextstk fields, with stklist pointing to the head of the list. * The list is traversed and each stack that was not marked * is freed. */ ep = &stklist; while (*ep != NULL) { if (BlkType(*ep) == T_Coexpr) { xep = *ep; *ep = (*ep)->nextstk; /* * Free the astkblks. There should always be one and it seems that * it's not possible to have more than one, but nonetheless, the * code provides for more than one. */ for (abp = xep->es_actstk; abp; ) { xabp = abp; abp = abp->astk_nxt; free((pointer)xabp); } #ifdef CoProcesses coswitch(BlkLoc(k_current)->coexpr.cstate, xep->cstate, -1); /* terminate coproc for coexpression first */ #endif /* CoProcesses */ free((pointer)xep); } else { BlkType(*ep) = T_Coexpr; MMStat((char *)(*ep), stksize, 'X'); ep = &(*ep)->nextstk; } } MMStat((char *)stack, mstksize, 'X'); /* Also record main stack */ } /* * collect - do a garbage collection. */ novalue collect(region) int region; { register dptr dp; struct b_coexpr *cp; MMBGC(region); #ifdef EvalTrace if (trfile) { fprintf(trfile,"c\t%ld\t%ld\t%d\n",colmno,lineno,region); } #endif /* EvalTrace */ coll_tot++; #ifdef FixedRegions alcnum = 0; #endif /* FixedRegions */ /* * Garbage collection cannot be done until initialization is complete. */ if (sp == NULL) return; #if MACINTOSH #if MPW SetCursor(*GetCursor(watchCursor)); /* Set watch cursor */ #endif /* MPW */ #endif /* MACINTOSH */ /* * Sync the values (used by sweep) in the coexpr block for ¤t * with the current values. */ cp = (struct b_coexpr *)BlkLoc(k_current); cp->es_pfp = pfp; cp->es_gfp = gfp; cp->es_efp = efp; cp->es_sp = sp; /* * Reset qualifier list. */ #ifndef FixedRegions quallist = (dptr *)blkfree; #endif /* FixedRegions */ qualfree = quallist; qualfail = 0; /* * Mark the stacks for &main and the current co-expression. */ markblock(&k_main); markblock(&k_current); /* * Mark &subject and the cached s2 and s3 strings for map. */ postqual(&k_subject); if (Qual(maps2)) /* caution: the cached arguments of */ postqual(&maps2); /* map may not be strings. */ else if (Pointer(maps2)) markblock(&maps2); if (Qual(maps3)) postqual(&maps3); else if (Pointer(maps3)) markblock(&maps3); /* * Mark the tended descriptors and the global and static variables. */ for (dp = &tended[1]; dp <= &tended[ntended]; dp++) if (Qual(*dp)) postqual(dp); else if (Pointer(*dp)) markblock(dp); for (dp = globals; dp < eglobals; dp++) if (Qual(*dp)) postqual(dp); else if (Pointer(*dp)) markblock(dp); for (dp = statics; dp < estatics; dp++) if (Qual(*dp)) postqual(dp); else if (Pointer(*dp)) markblock(dp); reclaim(region); MMEGC(); #ifndef FixedRegions if (qualfail && (region == Strings || statneed) && DiffPtrs((char *)quallist,blkfree) > Sqlinc) /* * The string region could not be collected, but it looks like it * needs to be. Collecting the block region gave more room for * the qualifier list, so try again. */ collect(region); #endif /* FixedRegions */ } /* * markblock - mark each accessible block in the block region and build * back-list of descriptors pointing to that block. (Phase I of garbage * collection.) */ novalue markblock(dp) dptr dp; { register dptr dp1; register char *block, *endblock; word type, fdesc; int numptr; register union block **ptr, **lastptr; /* * Get the block to which dp points. */ block = (char *)BlkLoc(*dp); if (InRange(blkbase,block,blkfree)) { if (Var(*dp) && !Tvar(*dp)) { /* * The descriptor is a variable; block now points to the head of the * block containing the descriptor. */ if (Offset(*dp) == 0) return; } type = BlkType(block); if ((uword)type <= MaxType) { /* * The type is valid, which indicates that this block has not * been marked. Point endblock to the byte past the end * of the block. */ endblock = block + BlkSize(block); MMMark(block,(int)type); } /* * Add dp to the back chain for the block and point the * block (via the type field) to dp.vword. */ BlkLoc(*dp) = (union block *)type; BlkType(block) = (uword)&BlkLoc(*dp); if ((unsigned int)type <= MaxType) { /* * The block was not marked; process pointers and descriptors * within the block. */ if ((fdesc = firstp[type]) > 0) { /* * The block contains pointers; mark each pointer. */ ptr = (union block **)(block + fdesc); numptr = ptrno[type]; if (numptr > 0) lastptr = ptr + numptr; else lastptr = (union block **)endblock; for (; ptr < lastptr; ptr++) if (*ptr != NULL) markptr(ptr); } if ((fdesc = firstd[type]) > 0) /* * The block contains descriptors; mark each descriptor. */ for (dp1 = (dptr)(block + fdesc); (char *)dp1 < endblock; dp1++) { if (Qual(*dp1)) postqual(dp1); else if (Pointer(*dp1)) markblock(dp1); } } } else if (dp->dword == D_Coexpr && (unsigned int)BlkType(block) <= MaxType) { struct b_coexpr *cp; struct astkblk *abp; int i; struct descrip adesc; /* * dp points to a co-expression block that has not been * marked. Point the block to dp. Sweep the interpreter * stack in the block. Then mark the block for the * activating co-expression and the refresh block. */ BlkType(block) = (uword)dp; sweep((struct b_coexpr *)block); #ifdef Coexpr /* * Mark the activators of this co-expression. The activators are * stored as a list of addresses, but markblock requires the address * of a descriptor. To accommodate markblock, the dummy descriptor * adesc is filled in with each activator address in turn and then * marked. Since co-expressions and the descriptors that reference * them don't participate in the back-chaining scheme, it's ok to * reuse the descriptor in this manner. */ cp = (struct b_coexpr *)block; adesc.dword = D_Coexpr; for (abp = cp->es_actstk; abp != NULL; abp = abp->astk_nxt) { for (i = 1; i <= abp->nactivators; i++) { BlkLoc(adesc) = (union block *)abp->arec[i-1].activator; markblock(&adesc); } } markblock(&((struct b_coexpr *)block)->freshblk); #endif /* Coexpr */ } } /* * markptr - just like mark block except the object pointing at the block * is just a block pointer, not a descriptor. */ novalue markptr(ptr) union block **ptr; { register dptr dp; register char *block, *endblock; word type, fdesc; int numptr; register union block **ptr1, **lastptr; /* * Get the block to which ptr points. */ block = (char *)*ptr; if (InRange(blkbase,block,blkfree)) { type = BlkType(block); if ((uword)type <= MaxType) { /* * The type is valid, which indicates that this block has not * been marked. Point endblock to the byte past the end * of the block. */ endblock = block + BlkSize(block); MMMark(block,(int)type); } /* * Add ptr to the back chain for the block and point the * block (via the type field) to ptr. */ *ptr = (union block *)type; BlkType(block) = (uword)ptr; if ((unsigned int)type <= MaxType) { /* * The block was not marked; process pointers and descriptors * within the block. */ if ((fdesc = firstp[type]) > 0) { /* * The block contains pointers; mark each pointer. */ ptr1 = (union block **)(block + fdesc); numptr = ptrno[type]; if (numptr > 0) lastptr = ptr1 + numptr; else lastptr = (union block **)endblock; for (; ptr1 < lastptr; ptr1++) if (*ptr1 != NULL) markptr(ptr1); } if ((fdesc = firstd[type]) > 0) /* * The block contains descriptors; mark each descriptor. */ for (dp = (dptr)(block + fdesc); (char *)dp < endblock; dp++) { if (Qual(*dp)) postqual(dp); else if (Pointer(*dp)) markblock(dp); } } } } /* * adjust - adjust pointers into the block region, beginning with block oblk * and basing the "new" block region at nblk. (Phase II of garbage * collection.) */ novalue adjust(source,dest) char *source, *dest; { register union block **nxtptr, **tptr; /* * Loop through to the end of allocated block region, moving source * to each block in turn and using the size of a block to find the * next block. */ while (source < blkfree) { if ((uword)(nxtptr = (union block **)BlkType(source)) > MaxType) { /* * The type field of source is a back pointer. Traverse the * chain of back pointers, changing each block location from * source to dest. */ while ((uword)nxtptr > MaxType) { tptr = nxtptr; nxtptr = (union block **) *nxtptr; *tptr = (union block *)dest; } BlkType(source) = (uword)nxtptr | F_Mark; dest += BlkSize(source); } source += BlkSize(source); } } /* * compact - compact good blocks in the block region. (Phase III of garbage * collection.) */ novalue compact(source) char *source; { register char *dest; register word size; /* * Start dest at source. */ dest = source; /* * Loop through to end of allocated block space, moving source * to each block in turn, using the size of a block to find the next * block. If a block has been marked, it is copied to the * location pointed to by dest and dest is pointed past the end * of the block, which is the location to place the next saved * block. Marks are removed from the saved blocks. */ while (source < blkfree) { size = BlkSize(source); if (BlkType(source) & F_Mark) { BlkType(source) &= ~F_Mark; if (source != dest) mvc((uword)size,source,dest); dest += size; } source += size; } /* * dest is the location of the next free block. Now that compaction * is complete, point blkfree to that location. */ blkfree = dest; } /* * postqual - mark a string qualifier. Strings outside the string space * are ignored. */ novalue postqual(dp) dptr dp; { char *newend; #ifdef CRAY if (strbase <= StrLoc(*dp) && StrLoc(*dp) < strend) { #else /* CRAY */ if (InRange(strbase,StrLoc(*dp),strend)) { #endif /* CRAY */ /* * The string is in the string space. Add it to the string qualifier * list, but before adding it, expand the string qualifier list if * necessary. */ if (qualfree >= equallist) { #ifdef FixedRegions qualfail = 1; return; #else /* FixedRegions */ newend = (char *)equallist + Sqlinc; /* * Make sure region has not changed and that it can be expanded. */ if (currend != sbrk((word)0) || (int)brk((char *)newend) == -1) { qualfail = 1; return; } equallist = (dptr *)newend; currend = sbrk((word)0); #ifdef QuallistExp fprintf(stderr,"size of quallist = %ld\n", (long)DiffPtrs((char *)equallist,(char *)quallist)); fflush(stderr); #endif /* QuallistExp */ #endif /* FixedRegions */ } *qualfree++ = dp; } } /* * scollect - collect the string space. quallist is a list of pointers to * descriptors for all the reachable strings in the string space. For * ease of description, it is referred to as if it were composed of * descriptors rather than pointers to them. */ novalue scollect(extra) word extra; { register char *source, *dest; register dptr *qptr; char *cend; if (qualfree <= quallist) { /* * There are no accessible strings. Thus, there are none to * collect and the whole string space is free. */ strfree = strbase; return; } /* * Sort the pointers on quallist in ascending order of string * locations. */ qsort((char *)quallist, (int)(DiffPtrs((char *)qualfree,(char *)quallist)) / sizeof(dptr *), sizeof(dptr), qlcmp); /* * The string qualifiers are now ordered by starting location. */ dest = strbase; source = cend = StrLoc(**quallist); /* * Loop through qualifiers for accessible strings. */ for (qptr = quallist; qptr < qualfree; qptr++) { if (StrLoc(**qptr) > cend) { /* * qptr points to a qualifier for a string in the next clump. * The last clump is moved, and source and cend are set for * the next clump. */ MMSMark(source,DiffPtrs(cend,source)); while (source < cend) *dest++ = *source++; source = cend = StrLoc(**qptr); } if ((StrLoc(**qptr) + StrLen(**qptr)) > cend) /* * qptr is a qualifier for a string in this clump; extend * the clump. */ cend = StrLoc(**qptr) + StrLen(**qptr); /* * Relocate the string qualifier. */ StrLoc(**qptr) = StrLoc(**qptr) + DiffPtrs(dest,source) + (uword)extra; } /* * Move the last clump. */ MMSMark(source,DiffPtrs(cend,source)); while (source < cend) *dest++ = *source++; strfree = dest; } /* * qlcmp - compare the location fields of two string qualifiers for qsort. */ int qlcmp(q1,q2) dptr *q1, *q2; { #if IntBits == 16 long l; l = (long)(DiffPtrs(StrLoc(**q1),StrLoc(**q2))); if (l < 0) return -1; else if (l > 0) return 1; else return 0; #else /* IntBits = 16 */ return (int)(DiffPtrs(StrLoc(**q1),StrLoc(**q2))); #endif /* IntBits == 16 */ } /* * mvc - move n bytes from src to dest * * The algorithm is to copy the data (using memcopy) in the largest * chunks possible, which is the size of area of the source data not in * the destination area (ie non-overlapped area). (Chunks are expected to * be fairly large.) */ novalue mvc(n, src, dest) uword n; register char *src, *dest; { register char *srcend, *destend; /* end of data areas */ word copy_size; /* of size copy_size */ word left_over; /* size of last chunk < copy_size */ if (n == 0) return; srcend = src + n; /* point at byte after src data */ destend = dest + n; /* point at byte after dest area */ if ((destend <= src) || (srcend <= dest)) /* not overlapping */ memcopy(dest,src,n); else { /* overlapping data areas */ if (dest < src) { /* * The move is from higher memory to lower memory. */ copy_size = DiffPtrs(src,dest); /* now loop round copying copy_size chunks of data */ do { memcopy(dest,src,copy_size); dest = src; src = src + copy_size; } while (DiffPtrs(srcend,src) > copy_size); left_over = DiffPtrs(srcend,src); /* copy final fragment of data - if there is one */ if (left_over > 0) memcopy(dest,src,left_over); } else if (dest > src) { /* * The move is from lower memory to higher memory. */ copy_size = DiffPtrs(destend,srcend); /* now loop round copying copy_size chunks of data */ do { destend = srcend; srcend = srcend - copy_size; memcopy(destend,srcend,copy_size); } while (DiffPtrs(srcend,src) > copy_size); left_over = DiffPtrs(srcend,src); /* copy intial fragment of data - if there is one */ if (left_over > 0) memcopy(dest,src,left_over); } } /* end of overlapping data area code */ /* * Note that src == dest implies no action */ } /* * sweep - sweep the stack, marking all descriptors there. Method * is to start at a known point, specifically, the frame that the * fp points to, and then trace back along the stack looking for * descriptors and local variables, marking them when they are found. * The sp starts at the first frame, and then is moved down through * the stack. Procedure, generator, and expression frames are * recognized when the sp is a certain distance from the fp, gfp, * and efp respectively. * * Sweeping problems can be manifested in a variety of ways due to * the "if it can't be identified it's a descriptor" methodology. */ novalue sweep(ce) struct b_coexpr *ce; { register word *s_sp; register struct pf_marker *fp; register struct gf_marker *s_gfp; register struct ef_marker *s_efp; word nargs, type, gsize; fp = ce->es_pfp; s_gfp = ce->es_gfp; if (s_gfp != 0) { type = s_gfp->gf_gentype; if (type == G_Psusp) gsize = Wsizeof(*s_gfp); else gsize = Wsizeof(struct gf_smallmarker); } s_efp = ce->es_efp; s_sp = ce->es_sp; nargs = 0; /* Nargs counter is 0 initially. */ while ((fp != 0 || nargs)) { /* Keep going until current fp is 0 and no arguments are left. */ if (s_sp == (word *)fp + Vwsizeof(*pfp) - 1) { /* sp has reached the upper boundary of a procedure frame, process the frame. */ s_efp = fp->pf_efp; /* Get saved efp out of frame */ s_gfp = fp->pf_gfp; /* Get save gfp */ if (s_gfp != 0) { type = s_gfp->gf_gentype; if (type == G_Psusp) gsize = Wsizeof(*s_gfp); else gsize = Wsizeof(struct gf_smallmarker); } s_sp = (word *)fp - 1; /* First argument descriptor is first word above proc frame */ nargs = fp->pf_nargs; fp = fp->pf_pfp; } else if (s_gfp != NULL && s_sp == (word *)s_gfp + gsize - 1) { /* The sp has reached the lower end of a generator frame, process the frame.*/ if (type == G_Psusp) fp = s_gfp->gf_pfp; s_sp = (word *)s_gfp - 1; s_efp = s_gfp->gf_efp; s_gfp = s_gfp->gf_gfp; if (s_gfp != 0) { type = s_gfp->gf_gentype; if (type == G_Psusp) gsize = Wsizeof(*s_gfp); else gsize = Wsizeof(struct gf_smallmarker); } nargs = 1; } else if (s_sp == (word *)s_efp + Wsizeof(*s_efp) - 1) { /* The sp has reached the upper end of an expression frame, process the frame. */ s_gfp = s_efp->ef_gfp; /* Restore gfp, */ if (s_gfp != 0) { type = s_gfp->gf_gentype; if (type == G_Psusp) gsize = Wsizeof(*s_gfp); else gsize = Wsizeof(struct gf_smallmarker); } s_efp = s_efp->ef_efp; /* and efp from frame. */ s_sp -= Wsizeof(*s_efp); /* Move past expression frame marker. */ } else { /* Assume the sp is pointing at a descriptor. */ if (Qual(*((dptr)(&s_sp[-1])))) postqual((dptr)&s_sp[-1]); else if (Pointer(*((dptr)(&s_sp[-1])))) markblock((dptr)&s_sp[-1]); s_sp -= 2; /* Move past descriptor. */ if (nargs) /* Decrement argument count if in an*/ nargs--; /* argument list. */ } } } #ifdef DeBugIconx /* * descr - dump a descriptor. Used only for debugging. */ novalue descr(dp) dptr dp; { int i; fprintf(stderr,"%08lx: ",(long)dp); if (Qual(*dp)) fprintf(stderr,"%15s","qualifier"); else if (Var(*dp) && !Tvar(*dp)) fprintf(stderr,"%15s","variable"); else { i = Type(*dp); switch (i) { case T_Null: fprintf(stderr,"%15s","null"); break; case T_Integer: fprintf(stderr,"%15s","integer"); break; default: fprintf(stderr,"%15s",blkname[i]); } } fprintf(stderr," %08lx %08lx\n",(long)dp->dword,(long)IntVal(*dp)); } /* * blkdump - dump the allocated block region. Used only for debugging. */ novalue blkdump() { register char *blk; register word type, size, fdesc; register dptr ndesc; fprintf(stderr, "\nDump of allocated block region. base:%08lx free:%08lx max:%08lx\n", (long)blkbase,(long)blkfree,(long)blkend); fprintf(stderr," loc type size contents\n"); for (blk = blkbase; blk < blkfree; blk += BlkSize(blk)) { type = BlkType(blk); size = BlkSize(blk); fprintf(stderr," %08lx %15s %4ld\n",(long)blk,blkname[type], (long)size); if ((fdesc = firstd[type]) > 0) for (ndesc = (dptr)(blk + fdesc); ndesc < (dptr)(blk + size); ndesc++) { fprintf(stderr," "); descr(ndesc); } fprintf(stderr,"\n"); } fprintf(stderr,"end of block region.\n"); } #endif /* DeBugIconx */