summaryrefslogtreecommitdiff
path: root/src/runtime/ralc.r
diff options
context:
space:
mode:
Diffstat (limited to 'src/runtime/ralc.r')
-rw-r--r--src/runtime/ralc.r784
1 files changed, 784 insertions, 0 deletions
diff --git a/src/runtime/ralc.r b/src/runtime/ralc.r
new file mode 100644
index 0000000..9f55671
--- /dev/null
+++ b/src/runtime/ralc.r
@@ -0,0 +1,784 @@
+/*
+ * File: ralc.r
+ * Contents: allocation routines
+ */
+
+/*
+ * Prototypes.
+ */
+static struct region *findgap (struct region *curr, word nbytes);
+static struct region *newregion (word nbytes, word stdsize);
+
+extern word alcnum;
+
+#ifndef MultiThread
+word coexp_ser = 2; /* 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 */
+#endif /* MultiThread */
+
+
+/*
+ * AlcBlk - allocate a block.
+ */
+#begdef AlcBlk(var, struct_nm, t_code, nbytes)
+{
+#ifdef MultiThread
+ EVVal((word)nbytes, typech[t_code]);
+#endif /* MultiThread */
+
+ /*
+ * Ensure that there is enough room in the block region.
+ */
+ if (DiffPtrs(blkend,blkfree) < nbytes && !reserve(Blocks, nbytes))
+ return NULL;
+
+ /*
+ * If monitoring, show the allocation.
+ */
+#ifndef MultiThread
+ EVVal((word)nbytes, typech[t_code]);
+#endif
+
+ /*
+ * 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.
+ */
+ blktotal += nbytes;
+ var = (struct struct_nm *)blkfree;
+ blkfree += nbytes;
+ var->title = t_code;
+}
+#enddef
+
+/*
+ * AlcFixBlk - allocate a fixed length block.
+ */
+#define AlcFixBlk(var, struct_nm, t_code)\
+ AlcBlk(var, struct_nm, t_code, sizeof(struct struct_nm))
+
+/*
+ * AlcVarBlk - allocate a variable-length block.
+ */
+#begdef AlcVarBlk(var, struct_nm, t_code, n_desc)
+ {
+#ifdef EventMon
+ uword size;
+#else /* EventMon */
+ register uword size;
+#endif /* EventMon */
+
+ /*
+ * Variable size blocks are declared with one descriptor, thus
+ * we need add in only n_desc - 1 descriptors.
+ */
+ size = sizeof(struct struct_nm) + (n_desc - 1) * sizeof(struct descrip);
+ AlcBlk(var, struct_nm, t_code, size)
+ var->blksize = size;
+ }
+#enddef
+
+/*
+ * alcactiv - allocate a co-expression activation block.
+ */
+
+struct astkblk *alcactiv()
+ {
+ struct astkblk *abp;
+
+ abp = (struct astkblk *)malloc(sizeof(struct astkblk));
+
+ /*
+ * If malloc failed, attempt to free some co-expression blocks and retry.
+ */
+ if (abp == NULL) {
+ collect(Static);
+ abp = (struct astkblk *)malloc(sizeof(struct astkblk));
+ }
+
+ if (abp == NULL)
+ ReturnErrNum(305, NULL);
+ abp->nactivators = 0;
+ abp->astk_nxt = NULL;
+ return abp;
+ }
+
+#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;
+ AlcBlk(blk, b_bignum, T_Lrgint, size);
+ blk->blksize = size;
+ blk->msd = blk->sign = 0;
+ blk->lsd = n - 1;
+ return blk;
+ }
+#endif /* LargeInts */
+
+/*
+ * alccoexp - allocate a co-expression stack block.
+ */
+
+#if COMPILER
+struct b_coexpr *alccoexp()
+ {
+ struct b_coexpr *ep;
+ static int serial = 2; /* main co-expression is allocated elsewhere */
+ ep = (struct b_coexpr *)malloc(stksize);
+
+ /*
+ * 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.
+ */
+
+ if (ep == NULL || alcnum > AlcMax) {
+ collect(Static);
+ ep = (struct b_coexpr *)malloc(stksize);
+ }
+
+ if (ep == NULL)
+ ReturnErrNum(305, NULL);
+
+ alcnum++; /* increment allocation count since last g.c. */
+
+ ep->title = T_Coexpr;
+ ep->size = 0;
+ ep->id = serial++;
+ ep->nextstk = stklist;
+ ep->es_tend = NULL;
+ ep->file_name = "";
+ ep->line_num = 0;
+ ep->freshblk = nulldesc;
+ ep->es_actstk = NULL;
+ ep->cstate[0] = 0; /* zero the first two cstate words as a flag */
+ ep->cstate[1] = 0;
+ stklist = ep;
+ return ep;
+ }
+#else /* COMPILER */
+#ifdef MultiThread
+/*
+ * If this is a new program being loaded, an icodesize>0 gives the
+ * hdr.hsize and a stacksize to use; allocate
+ * sizeof(progstate) + icodesize + mstksize
+ * Otherwise (icodesize==0), allocate a normal stksize...
+ */
+struct b_coexpr *alccoexp(icodesize, stacksize)
+long icodesize, stacksize;
+#else /* MultiThread */
+struct b_coexpr *alccoexp()
+#endif /* MultiThread */
+
+ {
+ struct b_coexpr *ep;
+
+#ifdef MultiThread
+ if (icodesize > 0) {
+ ep = (struct b_coexpr *)
+ calloc(1, stacksize+
+ icodesize+
+ sizeof(struct progstate)+
+ sizeof(struct b_coexpr));
+ }
+ else
+#endif /* MultiThread */
+
+ ep = (struct b_coexpr *)malloc(stksize);
+
+ /*
+ * 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.
+ */
+
+ if (ep == NULL || alcnum > AlcMax) {
+
+ collect(Static);
+
+#ifdef MultiThread
+ if (icodesize>0) {
+ ep = (struct b_coexpr *)
+ malloc(mstksize+icodesize+sizeof(struct progstate));
+ }
+ else
+#endif /* MultiThread */
+
+ ep = (struct b_coexpr *)malloc(stksize);
+ }
+ if (ep == NULL)
+ ReturnErrNum(305, NULL);
+
+ alcnum++; /* increment allocation count since last g.c. */
+
+ ep->title = T_Coexpr;
+ ep->es_actstk = NULL;
+ ep->size = 0;
+#ifdef MultiThread
+ ep->es_pfp = NULL;
+ ep->es_gfp = NULL;
+ ep->es_argp = NULL;
+ ep->tvalloc = NULL;
+
+ if (icodesize > 0)
+ ep->id = 1;
+ else
+#endif /* MultiThread */
+ ep->id = coexp_ser++;
+ ep->nextstk = stklist;
+ ep->es_tend = NULL;
+ ep->cstate[0] = 0; /* zero the first two cstate words as a flag */
+ ep->cstate[1] = 0;
+
+#ifdef MultiThread
+ /*
+ * Initialize program state to self for &main; curpstate for others.
+ */
+ if(icodesize>0) ep->program = (struct progstate *)(ep+1);
+ else ep->program = curpstate;
+#endif /* MultiThread */
+
+ stklist = ep;
+ return ep;
+ }
+#endif /* COMPILER */
+
+/*
+ * alccset - allocate a cset in the block region.
+ */
+
+struct b_cset *alccset()
+ {
+ register struct b_cset *blk;
+ register int i;
+
+ AlcFixBlk(blk, 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;
+ {
+ tended struct descrip tname = *name;
+ register struct b_file *blk;
+
+ AlcFixBlk(blk, b_file, T_File)
+ blk->fd = fd;
+ blk->status = status;
+ blk->fname = tname;
+ return blk;
+ }
+
+/*
+ * alchash - allocate a hashed structure (set or table header) in the block
+ * region.
+ */
+union block *alchash(tcode)
+int tcode;
+ {
+ register int i;
+ register struct b_set *ps;
+ register struct b_table *pt;
+
+ if (tcode == T_Table) {
+ AlcFixBlk(pt, b_table, T_Table);
+ ps = (struct b_set *)pt;
+ ps->id = table_ser++;
+ }
+ else { /* tcode == T_Set */
+ AlcFixBlk(ps, b_set, T_Set);
+ ps->id = set_ser++;
+ }
+ ps->size = 0;
+ ps->mask = 0;
+ for (i = 0; i < HSegs; i++)
+ ps->hdir[i] = NULL;
+ return (union block *)ps;
+ }
+
+/*
+ * 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);
+ AlcBlk(blk, b_slots, T_Slots, size);
+ blk->blksize = size;
+ while (--nslots >= 0)
+ blk->hslots[nslots] = NULL;
+ return blk;
+ }
+
+/*
+ * alclist - allocate a list header block in the block region.
+ *
+ * Forces a g.c. if there's not enough room for the whole list.
+ */
+
+struct b_list *alclist(size)
+uword size;
+ {
+ register struct b_list *blk;
+
+ if (!reserve(Blocks, (word)(sizeof(struct b_list) + sizeof (struct b_lelem)
+ + (size - 1) * sizeof(struct descrip)))) return NULL;
+ AlcFixBlk(blk, b_list, T_List)
+ blk->size = size;
+ blk->id = list_ser++;
+ blk->listhead = NULL;
+ blk->listtail = NULL;
+ 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;
+
+ AlcVarBlk(blk, b_lelem, T_Lelem, nslots)
+ 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;
+ }
+
+/*
+ * alcreal - allocate a real value in the block region.
+ */
+
+struct b_real *alcreal(val)
+double val;
+ {
+ register struct b_real *blk;
+
+ AlcFixBlk(blk, b_real, T_Real)
+
+#ifdef Double
+/* access real values one word at a time */
+ { int *rp, *rq;
+ rp = (int *) &(blk->realval);
+ rq = (int *) &val;
+ *rp++ = *rq++;
+ *rp = *rq;
+ }
+#else /* Double */
+ blk->realval = val;
+#endif /* Double */
+
+ return blk;
+ }
+
+/*
+ * alcrecd - allocate record with nflds fields in the block region.
+ */
+
+struct b_record *alcrecd(nflds, recptr)
+int nflds;
+union block *recptr;
+ {
+ tended union block *trecptr = recptr;
+ register struct b_record *blk;
+
+ AlcVarBlk(blk, b_record, T_Record, nflds)
+ blk->recdesc = trecptr;
+ blk->id = (((struct b_proc *)recptr)->recid)++;
+ return blk;
+ }
+
+/*
+ * alcrefresh - allocate a co-expression refresh block.
+ */
+
+#if COMPILER
+struct b_refresh *alcrefresh(na, nl, nt, wrk_sz)
+int na;
+int nl;
+int nt;
+int wrk_sz;
+ {
+ struct b_refresh *blk;
+
+ AlcVarBlk(blk, b_refresh, T_Refresh, na + nl)
+ blk->nlocals = nl;
+ blk->nargs = na;
+ blk->ntemps = nt;
+ blk->wrk_size = wrk_sz;
+ return blk;
+ }
+#else /* COMPILER */
+struct b_refresh *alcrefresh(entryx, na, nl)
+word *entryx;
+int na, nl;
+ {
+ struct b_refresh *blk;
+
+ AlcVarBlk(blk, b_refresh, T_Refresh, na + nl);
+ blk->ep = entryx;
+ blk->numlocals = nl;
+ return blk;
+ }
+#endif /* COMPILER */
+
+/*
+ * alcselem - allocate a set element block.
+ */
+
+struct b_selem *alcselem(mbr,hn)
+uword hn;
+dptr mbr;
+
+ {
+ tended struct descrip tmbr = *mbr;
+ register struct b_selem *blk;
+
+ AlcFixBlk(blk, b_selem, T_Selem)
+ blk->clink = NULL;
+ blk->setmem = tmbr;
+ blk->hashnum = hn;
+ return blk;
+ }
+
+/*
+ * alcstr - allocate a string in the string space.
+ */
+
+char *alcstr(s, slen)
+register char *s;
+register word slen;
+ {
+ tended struct descrip ts;
+ register char *d;
+ char *ofree;
+
+#ifdef MultiThread
+ StrLen(ts) = slen;
+ StrLoc(ts) = s;
+#ifdef EventMon
+ if (!noMTevents)
+#endif /* EventMon */
+ EVVal(slen, E_String);
+ s = StrLoc(ts);
+#endif /* MultiThread */
+
+ /*
+ * Make sure there is enough room in the string space.
+ */
+ if (DiffPtrs(strend,strfree) < slen) {
+ StrLen(ts) = slen;
+ StrLoc(ts) = s;
+ if (!reserve(Strings, slen))
+ return NULL;
+ s = StrLoc(ts);
+ }
+
+ strtotal += 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;
+ }
+
+/*
+ * alcsubs - allocate a substring trapped variable in the block region.
+ */
+
+struct b_tvsubs *alcsubs(len, pos, var)
+word len, pos;
+dptr var;
+ {
+ tended struct descrip tvar = *var;
+ register struct b_tvsubs *blk;
+
+ AlcFixBlk(blk, b_tvsubs, T_Tvsubs)
+ blk->sslen = len;
+ blk->sspos = pos;
+ blk->ssvar = tvar;
+ return blk;
+ }
+
+/*
+ * alctelem - allocate a table element block in the block region.
+ */
+
+struct b_telem *alctelem()
+ {
+ register struct b_telem *blk;
+
+ AlcFixBlk(blk, b_telem, T_Telem)
+ blk->hashnum = 0;
+ blk->clink = NULL;
+ blk->tref = nulldesc;
+ 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;
+ {
+ tended struct descrip ttbl = *tbl;
+ tended struct descrip tref = *ref;
+ register struct b_tvtbl *blk;
+
+ AlcFixBlk(blk, b_tvtbl, T_Tvtbl)
+ blk->hashnum = hashnum;
+ blk->clink = BlkLoc(ttbl);
+ blk->tref = tref;
+ return blk;
+ }
+
+/*
+ * deallocate - return a block to the heap.
+ *
+ * The block must be the one that is at the very end of a block region.
+ */
+void deallocate (bp)
+union block *bp;
+{
+ word nbytes;
+ struct region *rp;
+
+ nbytes = BlkSize(bp);
+ for (rp = curblock; rp; rp = rp->next)
+ if ((char *)bp + nbytes == rp->free)
+ break;
+ if (!rp)
+ for (rp = curblock->prev; rp; rp = rp->prev)
+ if ((char *)bp + nbytes == rp->free)
+ break;
+ if (!rp)
+ syserr ("deallocation botch");
+ rp->free = (char *)bp;
+ blktotal -= nbytes;
+ EVVal(nbytes, E_BlkDeAlc);
+}
+
+/*
+ * reserve -- ensure space in either string or block region.
+ *
+ * 1. check for space in current region.
+ * 2. check for space in older regions.
+ * 3. check for space in newer regions.
+ * 4. set goal of 10% of size of newest region.
+ * 5. collect regions, newest to oldest, until goal met.
+ * 6. allocate new region at 200% the size of newest existing.
+ * 7. reset goal back to original request.
+ * 8. collect regions that were too small to bother with before.
+ * 9. search regions, newest to oldest.
+ * 10. give up and signal error.
+ */
+
+char *reserve(region, nbytes)
+int region;
+word nbytes;
+{
+ struct region **pcurr, *curr, *rp;
+ word want, newsize;
+ extern int qualfail;
+
+ if (region == Strings)
+ pcurr = &curstring;
+ else
+ pcurr = &curblock;
+ curr = *pcurr;
+
+ /*
+ * Check for space available now.
+ */
+ if (DiffPtrs(curr->end, curr->free) >= nbytes)
+ return curr->free; /* quick return: current region is OK */
+
+ if ((rp = findgap(curr, nbytes)) != 0) { /* check all regions on chain */
+ *pcurr = rp; /* switch regions */
+ return rp->free;
+ }
+
+ /*
+ * Set "curr" to point to newest region.
+ */
+ while (curr->next)
+ curr = curr->next;
+
+ /*
+ * Need to collect garbage. To reduce thrashing, set a minimum requirement
+ * of 10% of the size of the newest region, and collect regions until that
+ * amount of free space appears in one of them.
+ */
+ want = (curr->size / 100) * memcushion;
+ if (want < nbytes)
+ want = nbytes;
+
+ for (rp = curr; rp; rp = rp->prev)
+ if (rp->size >= want) { /* if large enough to possibly succeed */
+ *pcurr = rp;
+ collect(region);
+ if (DiffPtrs(rp->end,rp->free) >= want)
+ return rp->free;
+ }
+
+ /*
+ * That didn't work. Allocate a new region with a size based on the
+ * newest previous region.
+ */
+ newsize = (curr->size / 100) * memgrowth;
+ if (newsize < nbytes)
+ newsize = nbytes;
+ if (newsize < MinAbrSize)
+ newsize = MinAbrSize;
+
+ if ((rp = newregion(nbytes, newsize)) != 0) {
+ rp->prev = curr;
+ rp->next = NULL;
+ curr->next = rp;
+ rp->Gnext = curr;
+ rp->Gprev = curr->Gprev;
+ if (curr->Gprev) curr->Gprev->Gnext = rp;
+ curr->Gprev = rp;
+ *pcurr = rp;
+#ifdef EventMon
+ if (!noMTevents) {
+ if (region == Strings) {
+ EVVal(rp->size, E_TenureString);
+ }
+ else {
+ EVVal(rp->size, E_TenureBlock);
+ }
+ }
+#endif /* EventMon */
+ return rp->free;
+ }
+
+ /*
+ * Allocation failed. Try to continue, probably thrashing all the way.
+ * Collect the regions that weren't collected before and see if any
+ * region has enough to satisfy the original request.
+ */
+ for (rp = curr; rp; rp = rp->prev)
+ if (rp->size < want) { /* if not collected earlier */
+ *pcurr = rp;
+ collect(region);
+ if (DiffPtrs(rp->end,rp->free) >= want)
+ return rp->free;
+ }
+ if ((rp = findgap(curr, nbytes)) != 0) {
+ *pcurr = rp;
+ return rp->free;
+ }
+
+ /*
+ * All attempts failed.
+ */
+ if (region == Blocks)
+ ReturnErrNum(307, 0);
+ else if (qualfail)
+ ReturnErrNum(304, 0);
+ else
+ ReturnErrNum(306, 0);
+}
+
+/*
+ * findgap - search region chain for a region having at least nbytes available
+ */
+static struct region *findgap(curr, nbytes)
+struct region *curr;
+word nbytes;
+ {
+ struct region *rp;
+
+ for (rp = curr; rp; rp = rp->prev)
+ if (DiffPtrs(rp->end, rp->free) >= nbytes)
+ return rp;
+ for (rp = curr->next; rp; rp = rp->next)
+ if (DiffPtrs(rp->end, rp->free) >= nbytes)
+ return rp;
+ return NULL;
+ }
+
+/*
+ * newregion - try to malloc a new region and tenure the old one,
+ * backing off if the requested size fails.
+ */
+static struct region *newregion(nbytes,stdsize)
+word nbytes,stdsize;
+{
+ uword minSize = MinAbrSize;
+ struct region *rp;
+
+ if ((uword)nbytes > minSize)
+ minSize = (uword)nbytes;
+ rp = (struct region *)malloc(sizeof(struct region));
+ if (rp) {
+ rp->size = stdsize;
+ if (rp->size < nbytes)
+ rp->size = Max(nbytes+stdsize, nbytes);
+ do {
+ rp->free = rp->base = (char *)AllocReg(rp->size);
+ if (rp->free != NULL) {
+ rp->end = rp->base + rp->size;
+ return rp;
+ }
+ else {
+ }
+ rp->size = (rp->size + nbytes)/2 - 1;
+ }
+ while (rp->size >= minSize);
+ free((char *)rp);
+ }
+ return NULL;
+}
generated by cgit v1.2.3 (git 2.39.1) at 2024-06-07 17:38:59 +0000