summaryrefslogtreecommitdiffstats
path: root/sys.c
diff options
context:
space:
mode:
Diffstat (limited to 'sys.c')
-rw-r--r--sys.c1095
1 files changed, 929 insertions, 166 deletions
diff --git a/sys.c b/sys.c
index 9767fe0..82ea647 100644
--- a/sys.c
+++ b/sys.c
@@ -46,6 +46,8 @@
#include "scm.h"
#include "setjump.h"
void igc P((char *what, STACKITEM *stackbase));
+void lfflush P((SCM port)); /* internal SCM call */
+SCM *loc_open_file; /* for open-file callback */
/* ttyname() etc. should be defined in <unistd.h>. But unistd.h is
missing on many systems. */
@@ -66,15 +68,21 @@ void igc P((char *what, STACKITEM *stackbase));
int pclose P((FILE* stream));
int unlink P((const char *pathname));
char *mktemp P((char *template));
+#else
+# ifdef linux
+# include <unistd.h>
+# endif
#endif
static void gc_sweep P((int contin_bad));
char s_nogrow[] = "could not grow", s_heap[] = "heap",
s_hplims[] = "hplims";
+static char s_segs[] = "segments", s_numheaps[] = "number of heaps";
static char s_input_portp[] = "input-port?",
s_output_portp[] = "output-port?";
-static char s_open_file[] = "open-file";
+static char s_try_open_file[] = "try-open-file";
+#define s_open_file (&s_try_open_file[4])
char s_close_port[] = "close-port";
#ifdef __IBMC__
@@ -92,7 +100,7 @@ char s_close_port[] = "close-port";
# ifdef MWC
# include <sys/io.h>
# else
-# ifndef THINK_C
+# ifndef macintosh
# ifndef ARM_ULIB
# include <sys/ioctl.h>
# endif
@@ -126,7 +134,7 @@ long mode_bits(modes)
| (strchr(modes, '0') ? BUF0 : 0);
}
-SCM open_file(filename, modes)
+SCM try_open_file(filename, modes)
SCM filename, modes;
{
register SCM port;
@@ -146,6 +154,15 @@ SCM open_file(filename, modes)
return port;
}
+ /* Callback to Scheme */
+SCM open_file(filename, modes)
+ SCM filename, modes;
+{
+ return apply(*loc_open_file,
+ filename,
+ cons(modes, listofnull));
+}
+
SCM close_port(port)
SCM port;
{
@@ -270,7 +287,7 @@ void prinport(exp, port, type)
# ifndef __EMX__
# ifndef _DCC
# ifndef AMIGA
-# ifndef THINK_C
+# ifndef macintosh
if (OPENP(exp) && tc16_fport==TYP16(exp) && isatty(fileno(STREAM(exp))))
lputs(ttyname(fileno(STREAM(exp))), port);
else
@@ -280,7 +297,7 @@ void prinport(exp, port, type)
# endif
#endif
if OPFPORTP(exp) intprint((long)fileno(STREAM(exp)), 10, port);
- else intprint(CDR(exp), 16, port);
+ else intprint(CDR(exp), -16, port);
lputc('>', port);
}
static int prinfport(exp, port, writing)
@@ -337,7 +354,7 @@ static int stgetc(p)
sizet ind = INUM(CAR(p));
if (ind >= LENGTH(CDR(p))) return EOF;
CAR(p) = MAKINUM(ind + 1);
- return CHARS(CDR(p))[ind];
+ return UCHARS(CDR(p))[ind];
}
int noop0(stream)
FILE *stream;
@@ -400,8 +417,13 @@ static ptobfuns fptob = {
prinfport,
0,
fputc,
+#ifdef __MWERKS__
+ (int (*)(char *, struct _FILE *))fputs,
+ (unsigned long (*)(char *, unsigned long, unsigned long, struct _FILE *))ffwrite,
+#else
fputs,
ffwrite,
+#endif
fflush,
fgetc,
fclose};
@@ -411,8 +433,13 @@ ptobfuns pipob = {
0, /* replaced by prinpipe in init_ioext() */
0,
fputc,
+#ifdef __MWERKS__
+ (int (*)(char *, struct _FILE *))fputs,
+ (unsigned long (*)(char *, unsigned long, unsigned long, struct _FILE *))ffwrite,
+#else
fputs,
ffwrite,
+#endif
fflush,
fgetc,
0}; /* replaced by pclose in init_ioext() */
@@ -513,10 +540,105 @@ static ptobfuns sfptob = {
sfgetc,
sfclose};
+/* The following ptob is for printing system messages in an interrupt-safe
+ way. Writing to sys_errp while interrupts are disabled will never enable
+ interrupts, do any actual i/o, or any allocation. Messages will be
+ written to cur_errp as soon as interrupts are enabled. There will only
+ ever be one of these. */
+int output_deferred = 0;
+static int tc16_sysport;
+#define SYS_ERRP_SIZE 480
+static char errbuf[SYS_ERRP_SIZE];
+static sizet errbuf_end = 0;
+static sizet syswrite(str, siz, num, p)
+ sizet siz, num;
+ char *str; FILE *p;
+{
+ sizet src, dst = errbuf_end;
+ sizet n = siz*num;
+ if (ints_disabled) {
+ deferred_proc = process_signals;
+ output_deferred = !0;
+ for (src = 0; src < n; src++, dst++)
+ errbuf[dst % SYS_ERRP_SIZE] = str[src];
+ errbuf_end = dst;
+ }
+ else {
+ if NIMP(cur_outp) lflush(cur_outp);
+ if (errbuf_end > 0) {
+ if (errbuf_end > SYS_ERRP_SIZE) {
+ warn("output buffer", " overflowed");
+ intprint((long)errbuf_end, 10, cur_errp);
+ lputs(" chars needed\n", cur_errp);
+ errbuf_end = errbuf_end % SYS_ERRP_SIZE;
+ lfwrite(&errbuf[errbuf_end], 1,
+ SYS_ERRP_SIZE - errbuf_end, cur_errp);
+ }
+ lfwrite(errbuf, sizeof(char), errbuf_end, cur_errp);
+ errbuf_end = 0;
+ }
+ num = lfwrite(str, siz, num, cur_errp);
+ lflush(cur_errp);
+ }
+ errno = 0;
+ return num;
+}
+static int sysputs(s, p)
+ char *s; FILE *p;
+{
+ syswrite(s, 1, strlen(s), p);
+ return 0;
+}
+static int sysputc(c, p)
+ int c; FILE *p;
+{
+ char cc = c;
+ syswrite(&cc, 1, 1, p);
+ return c;
+}
+static int sysflush(p)
+ FILE *p;
+{
+ syswrite(0, 0, 0, p);
+ return 0;
+}
+static ptobfuns sysptob = {
+ mark0,
+ noop0,
+ 0,
+ 0,
+ sysputc,
+ sysputs,
+ syswrite,
+ sysflush,
+ noop0,
+ noop0};
+
+static int freeprint(exp, port, writing)
+ SCM exp; SCM port; int writing;
+{
+ if (tc_broken_heart==CAR(exp)) {
+ lputs("#<GC-FORWARD->", port);
+ iprin1(CDR(exp), port, writing);
+ }
+ else {
+ if (NIMP(CDR(exp)) && tc7_smob==CAR(CDR(exp))) {
+ lputs("#<FREE-CELL ", port);
+ }
+ else {
+ lputs("#<NEW-CELL . ", port);
+ iprin1(CDR(exp), port, writing);
+ }
+ lputs(" @0x", port);
+ intprint((long)exp, -16, port);
+ }
+ lputc('>', port);
+ return !0;
+}
static smobfuns freecell = {
mark0,
free0,
- 0,
+ freeprint,
0};
static smobfuns flob = {
mark0,
@@ -541,6 +663,7 @@ void init_types()
/* tc16_pipe = */ newptob(&pipob);
/* tc16_strport = */ newptob(&stptob);
/* tc16_sfport = */ newptob(&sfptob);
+ tc16_sysport = newptob(&sysptob);
numsmob = 0;
smobs = (smobfuns *)malloc(7*sizeof(smobfuns));
/* These newsmob calls must be done in this order */
@@ -557,7 +680,7 @@ void add_final(final)
{
DEFER_INTS;
finals = (void (**)()) must_realloc((char *)finals,
- 1L*(num_finals)*sizeof(finals[0]),
+ (long)(num_finals)*sizeof(finals[0]),
(1L+num_finals)*sizeof(finals[0]),
s_final);
finals[num_finals++] = final;
@@ -565,9 +688,141 @@ void add_final(final)
return;
}
-char s_obunhash[] = "object-unhash", s_gc[] = "gc";
+static char s_estk[] = "environment stack";
+static cell ecache_v[ECACHE_SIZE];
+SCM scm_egc_roots[ECACHE_SIZE/20];
+CELLPTR scm_ecache;
+VOLATILE long scm_ecache_index, scm_ecache_len, scm_egc_root_index;
+SCM scm_estk = UNDEFINED, *scm_estk_ptr;
+void scm_estk_reset()
+{
+ SCM nstk = scm_estk, *v;
+ sizet i;
+ VERIFY_INTS("scm_estk_reset", 0);
+ /* We might be here because we blew the stack, or got tired of
+ watching it grow, so make sure the stack size is sane. */
+ if (IMP(nstk) || 50*SCM_ESTK_FRLEN < LENGTH(nstk)) {
+ i = 50L*SCM_ESTK_FRLEN + 1;
+ nstk = must_malloc_cell((long)i*sizeof(SCM), s_estk);
+ SETLENGTH(nstk, i, tc7_vector);
+ }
+ i = LENGTH(nstk);
+ v = VELTS(nstk);
+ while (i--) v[i] = UNSPECIFIED;
+ v[LENGTH(nstk)-1] = INUM0; /* overflow sentinel */
+ v[0] = INUM0; /* underflow sentinel */
+ /* The following are for a (future) segmented
+ stack implementation. */
+ v[1] = BOOL_T; /* writable? */
+ v[SCM_ESTK_FRLEN] = EOL; /* Must look like an environment */
+ v[SCM_ESTK_FRLEN + 1] = EOL; /* next stack segment */
+ scm_estk = nstk;
+ scm_estk_ptr = &(v[SCM_ESTK_BASE - SCM_ESTK_FRLEN]);
+}
+
+void scm_estk_grow(inc)
+ sizet inc;
+{
+ SCM estk = make_vector(MAKINUM(LENGTH(scm_estk) + inc*SCM_ESTK_FRLEN),
+ UNSPECIFIED);
+ sizet n, i;
+ DEFER_INTS;
+ n = scm_estk_ptr - VELTS(scm_estk);
+ ASSERT(n<=LENGTH(scm_estk), UNDEFINED, "estk corrupted", "scm_estk_grow");
+ for (i = n + 1; i--;)
+ VELTS(estk)[i] = VELTS(scm_estk)[i];
+ /* Sentinel for stack overflow. */
+ VELTS(estk)[LENGTH(estk)-1] = INUM0;
+ scm_estk = estk;
+ scm_estk_ptr = &(VELTS(estk)[n + SCM_ESTK_FRLEN]);
+ ALLOW_INTS;
+ growth_mon(s_estk, LENGTH(scm_estk), "locations", !0);
+}
+
+/* Will be useful when segmented stack is implemented. */
+void scm_estk_shrink()
+{
+#if 0
+ SCM next = VELTS(scm_estk)[SCM_ESTK_FRLEN];
+ int istrt;
+ if IMP(next) wta(UNDEFINED, "underflow", "stack");
+ istrt = INUM(CDR(next));
+ next = CAR(next);
+ if (BOOL_T != VELTS(next)[1]) {
+ SCM new_estk = make_vector(MAKINUM(LENGTH(scm_estk)), UNSPECIFIED);
+ int i = istrt;
+ while (--i) VELTS(new_estk)[i] = VELTS(next)[i];
+ VELTS(new_estk)[1] = BOOL_T;
+ VELTS(new_estk)[LENGTH(new_estk)-1] = INUM0;
+ next = new_estk;
+ }
+ scm_estk = next;
+ scm_estk_ptr = &(VELTS(scm_estk)[istrt]);
+#else
+ wta(UNDEFINED, "underflow", s_estk);
+#endif
+}
+
+void scm_env_cons(x, y)
+ SCM x, y;
+{
+ register SCM z;
+ DEFER_INTS_EGC;
+ if (1>scm_ecache_index) scm_egc();
+ z = PTR2SCM(&(scm_ecache[--scm_ecache_index]));
+ CAR(z) = x;
+ CDR(z) = y;
+ scm_env_tmp = z;
+}
+
+void scm_env_cons2(w, x, y)
+ SCM w, x, y;
+{
+ SCM z1, z2;
+ DEFER_INTS_EGC;
+ if (2>scm_ecache_index) scm_egc();
+ z1 = PTR2SCM(&(scm_ecache[--scm_ecache_index]));
+ CAR(z1) = x;
+ CDR(z1) = y;
+ z2 = PTR2SCM(&(scm_ecache[--scm_ecache_index]));
+ CAR(z2) = w;
+ CDR(z2) = z1;
+ scm_env_tmp = z2;
+}
+
+/* scm_env_tmp = cons(x, scm_env_tmp) */
+void scm_env_cons_tmp(x)
+ SCM x;
+{
+ register SCM z;
+ DEFER_INTS_EGC;
+ if (1>scm_ecache_index) scm_egc();
+ z = PTR2SCM(&(scm_ecache[--scm_ecache_index]));
+ CAR(z) = x;
+ CDR(z) = scm_env_tmp;
+ scm_env_tmp = z;
+}
+
+/* scm_env = acons(names, scm_env_tmp, scm_env) */
+void scm_extend_env(names)
+ SCM names;
+{
+ SCM z1, z2;
+ DEFER_INTS_EGC;
+ if (2>scm_ecache_index) scm_egc();
+ z1 = PTR2SCM(&(scm_ecache[--scm_ecache_index]));
+ CAR(z1) = names;
+ CDR(z1) = scm_env_tmp;
+ z2 = PTR2SCM(&(scm_ecache[--scm_ecache_index]));
+ CAR(z2) = z1;
+ CDR(z2) = scm_env;
+ scm_env = z2;
+}
+char s_obunhash[] = "object-unhash", s_cache_gc[] = "cache_gc";
+char s_recursive[] = "recursive";
+#define s_gc (s_cache_gc+6)
static iproc subr0s[] = {
- {s_gc, gc},
+ /* {s_gc, gc}, */
{"tmpnam", ltmpnam},
{0, 0}};
@@ -583,17 +838,22 @@ static iproc subr1s[] = {
{0, 0}};
static iproc subr2s[] = {
- {s_open_file, open_file},
+ {s_try_open_file, try_open_file},
{s_cwis, cwis},
{s_mksfpt, mksfpt},
{0, 0}};
SCM dynwind P((SCM thunk1, SCM thunk2, SCM thunk3));
-void init_io(){
+void init_io()
+{
make_subr("dynamic-wind", tc7_subr_3, dynwind);
+ make_subr(s_gc, tc7_subr_1o, gc);
init_iprocs(subr0s, tc7_subr_0);
init_iprocs(subr1s, tc7_subr_1);
init_iprocs(subr2s, tc7_subr_2);
+ loc_open_file =
+ &CDR(sysintern(s_open_file,
+ CDR(intern(s_try_open_file, sizeof(s_try_open_file)-1))));
#ifndef CHEAP_CONTINUATIONS
add_feature("full-continuation");
#endif
@@ -602,75 +862,245 @@ void init_io(){
void grew_lim(nm)
long nm;
{
- ALLOW_INTS;
- growth_mon(s_limit, nm, "bytes");
- DEFER_INTS;
+ growth_mon(s_limit, nm, "bytes", !0);
}
int expmem = 0;
sizet hplim_ind = 0;
-long heap_size = 0;
+long heap_cells = 0;
CELLPTR *hplims, heap_org;
-SCM freelist = EOL;
-long mtrigger;
+VOLATILE SCM freelist = EOL;
+long mtrigger, mltrigger;
+
+/* Ints should be deferred when calling igc_for_malloc. */
+static char *igc_for_alloc(where, olen, size, what)
+ char *where;
+ long olen;
+ sizet size;
+ char *what;
+{
+ char *ptr;
+ long nm;
+ igc(what, CONT(rootcont)->stkbse);
+ nm = mallocated + size - olen;
+ if (nm > mltrigger) {
+ if (nm > mtrigger) grew_lim(nm + nm/2);
+ else grew_lim(mtrigger + mtrigger/2);
+ }
+ if (where)
+ SYSCALL(ptr = (char *)realloc(where, size););
+ else
+ SYSCALL(ptr = (char *)malloc(size););
+ ASSERT(ptr, MAKINUM(size), NALLOC, what);
+ if (nm > mltrigger) {
+ if (nm > mtrigger) mtrigger = nm + nm/2;
+ else mtrigger += mtrigger/2;
+ mltrigger = mtrigger - MIN_MALLOC_YIELD;
+ }
+ return ptr;
+}
char *must_malloc(len, what)
long len;
char *what;
{
- char *ptr;
- sizet size = len;
- long nm = mallocated+size;
- if (len != size)
-malerr:
- wta(MAKINUM(len), (char *)NALLOC, what);
- if ((nm <= mtrigger)) {
- SYSCALL(ptr = (char *)malloc(size););
- if (NULL != ptr) {mallocated = nm; return ptr;}
- }
- igc(what, CONT(rootcont)->stkbse);
- nm = mallocated+size;
- if (nm > mtrigger) grew_lim(nm+nm/2); /* must do before malloc */
- SYSCALL(ptr = (char *)malloc(size););
- if (NULL != ptr) {
- mallocated = nm;
- if (nm > mtrigger) mtrigger = nm + nm/2;
- return ptr;}
- goto malerr;
+ char *ptr;
+ sizet size = len;
+ long nm = mallocated + size;
+ VERIFY_INTS("must_malloc", what);
+ ASSERT(len==size, MAKINUM(len), NALLOC, what);
+ if (nm <= mtrigger)
+ SYSCALL(ptr = (char *)malloc(size););
+ else
+ ptr = 0;
+ if (!ptr) ptr = igc_for_alloc(0, 0, size, what);
+ mallocated = nm;
+ return ptr;
+}
+SCM must_malloc_cell(len, what)
+ long len;
+ char *what;
+{
+ SCM z;
+ char *ptr;
+ sizet size = len;
+ long nm = mallocated + size;
+ VERIFY_INTS("must_malloc_cell", what);
+ ASSERT(len==size, MAKINUM(len), NALLOC, what);
+ NEWCELL(z);
+ if (nm <= mtrigger)
+ SYSCALL(ptr = (char *)malloc(size););
+ else
+ ptr = 0;
+ if (!ptr) ptr = igc_for_alloc(0, 0, size, what);
+ mallocated = nm;
+ SETCHARS(z, ptr);
+ return z;
}
char *must_realloc(where, olen, len, what)
char *where;
long olen, len;
char *what;
{
- char *ptr;
- sizet size = len;
- long nm = mallocated+size-olen;
- if (len != size)
-ralerr:
- wta(MAKINUM(len), (char *)NALLOC, what);
- if ((nm <= mtrigger)) {
- SYSCALL(ptr = (char *)realloc(where, size););
- if (NULL != ptr) {mallocated = nm; return ptr;}
- }
- igc(what, CONT(rootcont)->stkbse);
- nm = mallocated+size-olen;
- if (nm > mtrigger) grew_lim(nm+nm/2); /* must do before realloc */
- SYSCALL(ptr = (char *)realloc(where, size););
- if (NULL != ptr) {
- mallocated = nm;
- if (nm > mtrigger) mtrigger = nm + nm/2;
- return ptr;}
- goto ralerr;
-}
-void must_free(obj)
+ char *ptr;
+ sizet size = len;
+ long nm = mallocated + size - olen;
+ VERIFY_INTS("must_realloc", what);
+ ASSERT(len==size, MAKINUM(len), NALLOC, what);
+ if (nm <= mtrigger)
+ SYSCALL(ptr = (char *)realloc(where, size););
+ else
+ ptr = 0;
+ if (!ptr) ptr = igc_for_alloc(where, olen, size, what);
+ mallocated = nm;
+ return ptr;
+}
+void must_realloc_cell(z, olen, len, what)
+ SCM z;
+ long olen, len;
+ char *what;
+{
+ char *ptr, *where = CHARS(z);
+ sizet size = len;
+ long nm = mallocated + size - olen;
+ VERIFY_INTS("must_realloc_cell", what);
+ ASSERT(len==size, MAKINUM(len), NALLOC, what);
+ if (nm <= mtrigger)
+ SYSCALL(ptr = (char *)realloc(where, size););
+ else
+ ptr = 0;
+ if (!ptr) ptr = igc_for_alloc(where, olen, size, what);
+ mallocated = nm;
+ SETCHARS(z, ptr);
+}
+void must_free(obj, len)
char *obj;
+ sizet len;
{
- if (obj) free(obj);
+ if (obj) {
+#ifdef CAREFUL_INTS
+ while (len--) obj[len] = '#';
+#endif
+ free(obj);
+ }
else wta(INUM0, "already free", "");
}
+#ifdef NUM_HP
+# define NUM_HP_SIZE 240*sizeof(double)
+
+struct num_hp {
+ struct num_hp *next; /* Next heap in list */
+ sizet size; /* Size of one half-heap, in doubles */
+ sizet offset; /* 0 or size, depending on which half-heap is in use */
+ sizet ind; /* index of next available double */
+ double hp[1]; /* Make sure we are optimally aligned for doubles, more
+ follow */
+};
+typedef struct num_hp num_hp;
+static num_hp *num_hp_head = 0, *num_hp_cur = 0;
+long num_hp_total = 0;
+
+/* size is in bytes */
+static char s_num_hp[] = "flonum/bignum heap";
+static void num_hp_add(size)
+ sizet size;
+{
+ num_hp *new_hp;
+ sizet dsz = size / sizeof(double);
+ tail:
+ new_hp = (num_hp_cur ? num_hp_cur->next : 0);
+ if (new_hp) {
+ new_hp->ind = new_hp->size;
+ num_hp_cur = new_hp;
+ return;
+ }
+ new_hp = (num_hp *)must_malloc(sizeof(num_hp) + (2*dsz-1)*sizeof(double),
+ s_num_hp);
+ num_hp_total += sizeof(num_hp) + (2*dsz-1)*sizeof(double) ;
+ growth_mon(s_num_hp, num_hp_total, "doubles", !0);
+ new_hp->next = 0;
+ new_hp->size = dsz;
+ new_hp->offset = 0;
+ new_hp->ind = new_hp->size;
+ /* must_malloc might have called gc, moving num_hp_cur. */
+ if (num_hp_cur) {
+ num_hp *hp = num_hp_cur;
+ while (hp->next) hp = hp->next;
+ hp->next = new_hp;
+ }
+ else
+ num_hp_cur = new_hp;
+ if (num_hp_cur->ind >= NUM_HP_MAX_REQ/sizeof(double)) return;
+ goto tail;
+}
+
+static void num_hp_switch()
+{
+ num_hp *hp = num_hp_head;
+ while (hp) {
+ hp->offset = (hp->offset + hp->size) % (2*hp->size);
+ hp->ind = hp->size;
+ hp = hp->next;
+ }
+ num_hp_cur = num_hp_head;
+}
+
+/* len is in bytes */
+char *num_hp_alloc(len)
+ sizet len;
+{
+ num_hp *hp = num_hp_cur;
+ len = (len + sizeof(double) - 1)/sizeof(double);
+ if ((!hp) || (hp->ind < NUM_HP_MAX_REQ/sizeof(double))) {
+ num_hp_add(NUM_HP_SIZE);
+ hp = num_hp_cur;
+ }
+ hp->ind -= len;
+ return (char *)&(hp->hp[hp->ind + hp->offset]);
+}
+
+char *num_hp_realloc(where, olen, len, what)
+ char *where, *what;
+ long olen, len;
+{
+ char *ret;
+ sizet i;
+ if (len <= NUM_HP_MAX_REQ) {
+ num_hp *hp = num_hp_cur;
+ if (len <= olen) return where;
+ if (!hp || (hp->ind < NUM_HP_MAX_REQ/sizeof(double))) {
+ num_hp_add(NUM_HP_SIZE);
+ hp = num_hp_cur;
+ }
+ hp->ind -= (len + sizeof(double) - 1)/sizeof(double);
+ ret = (char *)&(hp->hp[hp->ind + hp->offset]);
+ for (i = len; i--;)
+ ret[i] = where[i];
+ if (olen > NUM_HP_MAX_REQ) must_free(where, (long)olen);
+ return ret;
+ }
+ if (olen > NUM_HP_MAX_REQ)
+ return must_realloc(where, olen, len, what);
+ ret = must_malloc((long)len, what);
+ for (i = len; i--;)
+ ret[i] = where[i];
+ return ret;
+}
+void num_hp_free(hp)
+ num_hp *hp;
+{
+ num_hp *next;
+ while (hp) {
+ next = hp->next;
+ num_hp_total -= 2*hp->size;
+ must_free((char *)hp, sizeof(num_hp) + hp->size*2 - sizeof(double));
+ hp = next;
+ }
+}
+#endif /* NUM_HP */
+
SCM symhash; /* This used to be a sys_protect, but
Radey Shouman <shouman@zianet.com>
- added GC for unuesd, UNDEFINED
+ added GC for unused, UNDEFINED
symbols.*/
int symhash_dim = NUM_HASH_BUCKETS;
/* sym2vcell looks up the symbol in the symhash table. */
@@ -718,7 +1148,7 @@ SCM intern(name, len)
return z;
}
SCM sysintern(name, val)
- char *name;
+ const char *name;
SCM val;
{
SCM lsym, z;
@@ -738,8 +1168,10 @@ SCM sysintern(name, val)
trynext: ;
}
NEWCELL(lsym);
+ DEFER_INTS;
SETLENGTH(lsym, (long)len, tc7_ssymbol);
SETCHARS(lsym, name);
+ ALLOW_INTS;
lsym = cons(lsym, val);
z = cons(lsym, UNDEFINED);
CDR(z) = VELTS(symhash)[hash];
@@ -786,17 +1218,16 @@ SCM makstr(len)
long len;
{
SCM s;
- NEWCELL(s);
DEFER_INTS;
- SETCHARS(s, must_malloc(len+1, s_string));
+ s = must_malloc_cell(len+1, s_string);
SETLENGTH(s, len, tc7_string);
- ALLOW_INTS;
CHARS(s)[len] = 0;
+ ALLOW_INTS;
return s;
}
SCM make_subr(name, type, fcn)
- char *name;
+ const char *name;
int type;
SCM (*fcn)();
{
@@ -806,8 +1237,8 @@ SCM make_subr(name, type, fcn)
if ((tmp>>8) != ((CELLPTR)(CAR(symcell))-heap_org))
tmp = 0;
NEWCELL(z);
- SUBRF(z) = fcn;
CAR(z) = tmp + type;
+ SUBRF(z) = fcn;
CDR(symcell) = z;
return z;
}
@@ -818,10 +1249,9 @@ SCM makcclo(proc, len)
long len;
{
SCM s;
- NEWCELL(s);
DEFER_INTS;
- SETCHARS(s, must_malloc(len*sizeof(SCM), "compiled-closure"));
- SETLENGTH(s, len, tc7_cclo);
+ s = must_malloc_cell(len*sizeof(SCM), "compiled-closure");
+ SETNUMDIGS(s, len, tc16_cclo);
while (--len) VELTS(s)[len] = UNSPECIFIED;
CCLO_SUBR(s) = proc;
ALLOW_INTS;
@@ -839,18 +1269,22 @@ void stack_check()
# else
if (start - &stack > STACK_LIMIT/sizeof(STACKITEM))
# endif /* def STACK_GROWS_UP */
- wta(UNDEFINED, (char *)SEGV_SIGNAL, "stack");
+ {
+ stack_report();
+ wta(UNDEFINED, (char *)SEGV_SIGNAL, "stack");
+ }
}
#endif
void stack_report()
{
STACKITEM stack;
- intprint(stack_size(CONT(rootcont)->stkbse)*sizeof(STACKITEM), 16, cur_errp);
- lputs(" of stack: 0x", cur_errp);
- intprint((long)CONT(rootcont)->stkbse, 16, cur_errp);
+ lputs(";; stack: 0x", cur_errp);
+ intprint((long)CONT(rootcont)->stkbse, -16, cur_errp);
lputs(" - 0x", cur_errp);
- intprint((long)&stack, 16, cur_errp);
- lputs("\n", cur_errp);
+ intprint((long)&stack, -16, cur_errp);
+ lputs("; ", cur_errp);
+ intprint(stack_size(CONT(rootcont)->stkbse)*sizeof(STACKITEM), 10, cur_errp);
+ lputs(" bytes\n", cur_errp);
}
SCM dynwind(thunk1, thunk2, thunk3)
@@ -887,20 +1321,26 @@ void dowinds(to, delta)
SCM scm_make_cont()
{
- SCM cont;
+ SCM cont, env, *from, *to;
CONTINUATION *ncont;
+ sizet n;
+ VERIFY_INTS("scm_make_cont", 0);
NEWCELL(cont);
- DEFER_INTS;
+ from = VELTS(scm_estk);
+ n = scm_estk_ptr - from + SCM_ESTK_FRLEN + 2;
+ env = must_malloc_cell((long)n*sizeof(SCM), s_cont);
+ SETLENGTH(env, (long)n, tc7_vector);
+ to = VELTS(env);
+ to[--n] = scm_env;
+ to[--n] = scm_env_tmp;
+ while(n--) to[n] = from[n];
ncont = make_continuation(CONT(rootcont));
if (!ncont) wta(MAKINUM(-1), (char *)NALLOC, s_cont);
ncont->other.parent = rootcont;
SETCONT(cont, ncont);
SETLENGTH(cont, ncont->length, tc7_contin);
ncont->other.dynenv = dynwinds;
-#ifdef CAUTIOUS
- CONT(cont)->other.stack_trace = stacktrace;
-#endif
- ALLOW_INTS;
+ ncont->other.env = env;
return cont;
}
static char s_sstale[] = "strangely stale";
@@ -912,9 +1352,20 @@ void scm_dynthrow(cont, val)
wta(cont->other.dynenv, &s_sstale[10], s_cont);
dowinds(cont->other.dynenv,
ilength(dynwinds)-ilength(cont->other.dynenv));
-#ifdef CAUTIOUS
- stacktrace = cont->other.stack_trace;
-#endif
+ {
+ SCM *from, *to;
+ sizet n = LENGTH(cont->other.env);
+ if (LENGTH(scm_estk) < n)
+ scm_estk_grow((n - (LENGTH(scm_estk))) / SCM_ESTK_FRLEN + 20);
+ DEFER_INTS;
+ from = VELTS(cont->other.env);
+ to = VELTS(scm_estk);
+ scm_env = from[--n];
+ scm_env_tmp = from[--n];
+ scm_estk_ptr = &(to[n]) - SCM_ESTK_FRLEN;
+ while(n--) to[n] = from[n];
+ ALLOW_INTS;
+ }
throw_to_continuation(cont, val, CONT(rootcont));
wta(cont->other.dynenv, s_sstale, s_cont);
}
@@ -1035,7 +1486,7 @@ sizet init_heap_seg(seg_org, size)
/* CDR(scmptr) = freelist; */
CDR(PTR2SCM(--ptr)) = freelist;
freelist = PTR2SCM(CELL_UP(seg_org));
- heap_size += ni;
+ heap_cells += ni;
return size;
#ifdef scmptr
# undef scmptr
@@ -1047,15 +1498,18 @@ static void alloc_some_heap()
sizet len = (2+hplim_ind)*sizeof(CELLPTR);
ASRTGO(len==(2+hplim_ind)*sizeof(CELLPTR), badhplims);
if (errjmp_bad) wta(UNDEFINED, "need larger initial", s_heap);
- SYSCALL(tmplims = (CELLPTR *)realloc((char *)hplims, len););
+ tmplims = (CELLPTR *)must_realloc((char *)hplims,
+ len-2L*sizeof(CELLPTR), (long)len,
+ s_heap);
+ /* SYSCALL(tmplims = (CELLPTR *)realloc((char *)hplims, len);); */
if (!tmplims)
badhplims:
wta(UNDEFINED, s_nogrow, s_hplims);
else hplims = tmplims;
/* hplim_ind gets incremented in init_heap_seg() */
if (expmem) {
- len = (sizet)(EXPHEAP(heap_size)*sizeof(cell));
- if ((sizet)(EXPHEAP(heap_size)*sizeof(cell)) != len) len = 0;
+ len = (sizet)(EXPHEAP(heap_cells)*sizeof(cell));
+ if ((sizet)(EXPHEAP(heap_cells)*sizeof(cell)) != len) len = 0;
}
else len = HEAP_SEG_SIZE;
while (len >= MIN_HEAP_SEG_SIZE) {
@@ -1141,8 +1595,9 @@ SCM equal0(ptr1, ptr2)
return (CDR(ptr1)==CDR(ptr2)) ? BOOL_T : BOOL_F;
}
-/* statically allocated port for diagnostic messages */
-cell tmp_errp = {(SCM)((0L<<8)|tc16_fport|OPN|WRTNG), 0};
+/* statically allocated ports for diagnostic messages */
+static cell tmp_errpbuf[3];
+static SCM tmp_errp;
static char remsg[] = "remove\n#define ", addmsg[] = "add\n#define ";
extern sizet num_protects; /* sys_protects now in scl.c */
@@ -1153,8 +1608,9 @@ void init_storage(stack_start_ptr, init_heap_size)
sizet j = num_protects;
/* Because not all protects may get initialized */
while(j) sys_protects[--j] = BOOL_F;
- tmp_errp.cdr = (SCM)stderr;
- cur_errp = PTR2SCM(&tmp_errp);
+ tmp_errp = PTR2SCM(CELL_UP(&tmp_errpbuf[0]));
+ CAR(tmp_errp) = (SCM)(tc16_fport|OPN|WRTNG);
+ CDR(tmp_errp) = (SCM)stderr;
freelist = EOL;
expmem = 0;
@@ -1197,6 +1653,7 @@ void init_storage(stack_start_ptr, init_heap_size)
fixconfig("reduce", "size of HEAP_SEG_SIZE", 0);
mtrigger = INIT_MALLOC_LIMIT;
+ mltrigger = mtrigger - MIN_MALLOC_YIELD;
hplims = (CELLPTR *) must_malloc(2L*sizeof(CELLPTR), s_hplims);
if (0L==init_heap_size) init_heap_size = INIT_HEAP_SIZE;
j = init_heap_size;
@@ -1221,16 +1678,15 @@ void init_storage(stack_start_ptr, init_heap_size)
cur_inp = def_inp;
cur_outp = def_outp;
cur_errp = def_errp;
+ NEWCELL(sys_errp);
+ CAR(sys_errp) = (tc16_sysport|OPN|WRTNG);
+ SETSTREAM(sys_errp, 0);
dynwinds = EOL;
NEWCELL(rootcont);
SETCONT(rootcont, make_root_continuation(stack_start_ptr));
CAR(rootcont) = tc7_contin;
CONT(rootcont)->other.dynenv = EOL;
CONT(rootcont)->other.parent = BOOL_F;
- stacktrace = EOL;
-#ifdef CAUTIOUS
- CONT(rootcont)->other.stack_trace = EOL;
-#endif
listofnull = cons(EOL, EOL);
undefineds = cons(UNDEFINED, EOL);
CDR(undefineds) = undefineds;
@@ -1246,6 +1702,20 @@ void init_storage(stack_start_ptr, init_heap_size)
sysintern("bignum-radix", MAKINUM(BIGRAD));
#endif
/* flo0 is now setup in scl.c */
+ /* Set up environment cache */
+ scm_ecache_len = sizeof(ecache_v)/sizeof(cell);
+ scm_ecache = CELL_UP(ecache_v);
+ scm_ecache_len = CELL_DN(ecache_v + scm_ecache_len - 1) - scm_ecache + 1;
+ scm_ecache_index = scm_ecache_len;
+ scm_egc_root_index = sizeof(scm_egc_roots)/sizeof(SCM);
+ scm_estk_reset();
+
+#ifdef NUM_HP
+ /* Allocate a very small initial num_hp in case
+ we need it only for flo0. */
+ num_hp_add(10*sizeof(double));
+ num_hp_head = num_hp_cur;
+#endif /* def NUM_HP */
}
/* The way of garbage collecting which allows use of the cstack is due to */
@@ -1281,33 +1751,50 @@ char s_cells[] = "cells";
SCM gc_for_newcell()
{
SCM fl;
- DEFER_INTS;
+ int oints = ints_disabled; /* Temporary expedient */
+ if (!oints) ints_disabled = 1;
igc(s_cells, CONT(rootcont)->stkbse);
- ALLOW_INTS;
if ((gc_cells_collected < MIN_GC_YIELD) || IMP(freelist)) {
- DEFER_INTS;
alloc_some_heap();
- ALLOW_INTS;
- growth_mon("number of heaps", (long)(hplim_ind/2), "segments");
- growth_mon(s_heap, heap_size, s_cells);
+ growth_mon(s_numheaps, (long)(hplim_ind/2), s_segs, !0);
+ growth_mon(s_heap, heap_cells, s_cells, !0);
}
++cells_allocated;
fl = freelist;
freelist = CDR(fl);
+ ints_disabled = oints;
return fl;
}
+void scm_fill_freelist()
+{
+ while IMP(freelist) {
+ igc(s_cells, CONT(rootcont)->stkbse);
+ if ((gc_cells_collected < MIN_GC_YIELD) || IMP(freelist)) {
+ alloc_some_heap();
+ growth_mon(s_numheaps, (long)(hplim_ind/2), s_segs, !0);
+ growth_mon(s_heap, heap_cells, s_cells, !0);
+ }
+ }
+}
+
static char s_bad_type[] = "unknown type in ";
jump_buf save_regs_gc_mark;
void mark_locations P((STACKITEM x[], sizet n));
static void mark_syms P((SCM v));
static void mark_sym_values P((SCM v));
static void sweep_symhash P((SCM v));
+static void egc_mark P((void));
+static void egc_sweep P((void));
-SCM gc()
+SCM gc(arg)
+ SCM arg;
{
DEFER_INTS;
- igc("call", CONT(rootcont)->stkbse);
+ if UNBNDP(arg)
+ igc("call", CONT(rootcont)->stkbse);
+ else
+ scm_egc();
ALLOW_INTS;
return UNSPECIFIED;
}
@@ -1316,21 +1803,25 @@ void igc(what, stackbase)
STACKITEM *stackbase;
{
int j = num_protects;
- long oheap_size = heap_size;
+ long oheap_cells = heap_cells;
gc_start(what);
if (++errjmp_bad > 1)
- wta(MAKINUM(errjmp_bad), "gc called from within ", s_gc);
+ wta(MAKINUM(errjmp_bad), s_recursive, s_gc);
+#ifdef NUM_HP
+ num_hp_switch(); /* Switch half-heaps for flonums/bignums */
+#endif
+#ifdef NO_SYM_GC
+ gc_mark(symhash);
+#else
/* By marking symhash first, we provide the best immunity from
accidental references. In order to accidentally protect a
symbol, a pointer will have to point directly at the symbol (as
opposed to the vector or bucket lists). */
mark_syms(symhash);
/* mark_sym_values() can be called anytime after mark_syms. */
-#ifdef NO_SYM_GC
- gc_mark(symhash);
-#else
mark_sym_values(symhash);
#endif
+ egc_mark();
if (stackbase) {
FLUSH_REGISTER_WINDOWS;
/* This assumes that all registers are saved into the jump_buf */
@@ -1360,14 +1851,24 @@ void igc(what, stackbase)
}
while(j--)
gc_mark(sys_protects[j]);
+#ifndef NO_SYM_GC
sweep_symhash(symhash);
+#endif
gc_sweep(!stackbase);
+ egc_sweep();
+#if 0 /* def NUM_HP */
+ if (num_hp_cur) {
+ num_hp *hp = num_hp_cur->next;
+ num_hp_cur->next = 0;
+ if (hp) num_hp_free(hp);
+ }
+#endif
--errjmp_bad;
gc_end();
- if (oheap_size != heap_size) {
- ALLOW_INTS;
- growth_mon(s_heap, heap_size, s_cells);
- DEFER_INTS;
+ if (oheap_cells != heap_cells) {
+ int grewp = heap_cells > oheap_cells;
+ growth_mon(s_numheaps, (long)(hplim_ind/2), s_segs, grewp);
+ growth_mon(s_heap, heap_cells, s_cells, grewp);
}
}
@@ -1377,7 +1878,8 @@ void free_storage()
DEFER_INTS;
gc_start("free");
++errjmp_bad;
- cur_inp = BOOL_F; cur_outp = BOOL_F; cur_errp = PTR2SCM(&tmp_errp);
+ cur_inp = BOOL_F; cur_outp = BOOL_F;
+ cur_errp = tmp_errp; sys_errp = tmp_errp;
gc_mark(def_inp); /* don't want to close stdin */
gc_mark(def_outp); /* don't want to close stdout */
gc_mark(def_errp); /* don't want to close stderr */
@@ -1387,44 +1889,65 @@ void free_storage()
hplim_ind -= 2;
{
CELLPTR ptr = CELL_UP(hplims[hplim_ind]);
- sizet seg_size = CELL_DN(hplims[hplim_ind+1]) - ptr;
- heap_size -= seg_size;
- must_free((char *)hplims[hplim_ind]);
+ sizet seg_cells = CELL_DN(hplims[hplim_ind+1]) - ptr;
+ heap_cells -= seg_cells;
+ free((char *)hplims[hplim_ind]);
hplims[hplim_ind] = 0;
- growth_mon(s_heap, heap_size, s_cells);
+ growth_mon(s_heap, heap_cells, s_cells, 0); fflush(stderr);
}}
- if (heap_size) wta(MAKINUM(heap_size), s_not_free, s_heap);
+ if (heap_cells) wta(MAKINUM(heap_cells), s_not_free, s_heap);
if (hplim_ind) wta((SCM)MAKINUM(hplim_ind), s_not_free, s_hplims);
/* Not all cells get freed (see gc_mark() calls above). */
/* if (cells_allocated) wta(MAKINUM(cells_allocated), s_not_free, "cells"); */
+#ifdef NUM_HP
+ num_hp_free(num_hp_head);
+#endif
/* either there is a small memory leak or I am counting wrong. */
+ must_free((char *)hplims, 0);
/* if (mallocated) wta(MAKINUM(mallocated), s_not_free, "malloc"); */
- must_free((char *)hplims);
hplims = 0;
- must_free((char *)smobs);
+ /* must_free((char *)smobs, numsmob * sizeof(smobfuns)); */
+ free((char *)smobs);
smobs = 0;
- gc_end();
+ gc_end();
ALLOW_INTS; /* A really bad idea, but printing does it anyway. */
exit_report();
- must_free((char *)ptobs);
+ lflush(sys_errp);
+ /* must_free((char *)ptobs, numptob * sizeof(ptobfuns)); */
+ free((char *)ptobs);
ptobs = 0;
lmallocated = mallocated = 0;
/* Can't do gc_end() here because it uses ptobs which have been freed */
+ fflush(stdout); /* in lieu of close */
+ fflush(stderr); /* in lieu of close */
+}
+
+#define HUGE_LENGTH(x) (LENGTH_MAX==LENGTH(x) ? *((long *)VELTS(x)) : LENGTH(x))
+
+/* This is used to force allocation of SCM temporaries on the stack,
+ it should be called with any SCM variables used for malloc headers
+ and entirely local to a C procedure. */
+void scm_protect_temp(ptr)
+ SCM *ptr;
+{
+ return;
}
+static char s_gc_sym[] = "mark_syms", s_wrong_length[] = "wrong length";
void gc_mark(p)
SCM p;
{
register long i;
register SCM ptr = p;
+ CHECK_STACK;
gc_mark_loop:
if IMP(ptr) return;
gc_mark_nimp:
if (NCELLP(ptr)
- /* #ifndef RECKLESS
- || PTR_GT(hplims[0], (CELLPTR)ptr)
- || PTR_GE((CELLPTR)ptr, hplims[hplim_ind-1])
-#endif */
+ /* #ifndef RECKLESS */
+ /* || PTR_GT(hplims[0], (CELLPTR)ptr) */
+ /* || PTR_GE((CELLPTR)ptr, hplims[hplim_ind-1]) */
+ /* #endif */
) wta(ptr, "rogue pointer in ", s_heap);
switch TYP7(ptr) {
case tcs_cons_nimcar:
@@ -1446,17 +1969,28 @@ void gc_mark(p)
case tcs_closures:
if GCMARKP(ptr) break;
SETGCMARK(ptr);
- if IMP(CDR(ptr)) {
+ if IMP(GCENV(ptr)) {
ptr = CODE(ptr);
goto gc_mark_nimp;
}
gc_mark(CODE(ptr));
- ptr = GCCDR(ptr);
+ ptr = GCENV(ptr);
goto gc_mark_nimp;
- case tc7_vector:
+ case tc7_specfun:
+ if GC8MARKP(ptr) break;
+ SETGC8MARK(ptr);
#ifdef CCLO
- case tc7_cclo:
+ if (tc16_cclo==GCTYP16(ptr)) {
+ i = CCLO_LENGTH(ptr);
+ if (i==0) break;
+ while(--i>0) if NIMP(VELTS(ptr)[i]) gc_mark(VELTS(ptr)[i]);
+ ptr = VELTS(ptr)[0];
+ }
+ else
#endif
+ ptr = CDR(ptr);
+ goto gc_mark_loop;
+ case tc7_vector:
if GC8MARKP(ptr) break;
SETGC8MARK(ptr);
i = LENGTH(ptr);
@@ -1472,15 +2006,18 @@ void gc_mark(p)
(sizeof(STACKITEM) - 1 + sizeof(CONTINUATION)) /
sizeof(STACKITEM)));
break;
+ case tc7_string:
+ case tc7_msymbol:
+ if GC8MARKP(ptr) break;
+ ASSERT(!(CHARS(ptr)[HUGE_LENGTH(ptr)]), MAKINUM(HUGE_LENGTH(ptr)),
+ s_wrong_length, s_gc);
+ case tc7_ssymbol:
case tc7_bvect:
case tc7_ivect:
case tc7_uvect:
case tc7_fvect:
case tc7_dvect:
case tc7_cvect:
- case tc7_string:
- case tc7_msymbol:
- case tc7_ssymbol:
SETGC8MARK(ptr);
case tcs_subrs:
break;
@@ -1495,12 +2032,46 @@ void gc_mark(p)
case tc_free_cell:
/* printf("found free_cell %X ", ptr); fflush(stdout); */
SETGC8MARK(ptr);
- CDR(ptr) = EOL;
+ ASSERT(tc_broken_heart!=CAR(ptr), ptr, "found ecache forward", s_gc);
+ /* CDR(ptr) = UNDEFINED */;
break;
+#ifdef BIGDIG
case tcs_bignums:
+#ifdef NUM_HP
+ if (NUMDIGS(ptr)*sizeof(BIGDIG) <= NUM_HP_MAX_REQ) {
+ sizet i = NUMDIGS(ptr);
+ BIGDIG *nw = (BIGDIG *)num_hp_alloc(i*sizeof(BIGDIG));
+ while (i--) nw[i] = BDIGITS(ptr)[i];
+ }
+#endif
+ SETGC8MARK(ptr);
+ break;
+#endif
+#ifdef FLOATS
case tc16_flo:
+# ifdef NUM_HP
+ {
+ double *nw;
+ switch ((int)(CAR(ptr)>>16)) {
+ default: goto def;
+ case (IMAG_PART | REAL_PART)>>16:
+ nw = (double *)num_hp_alloc(2*sizeof(double));
+ nw[0] = REAL(ptr);
+ nw[1] = IMAG(ptr);
+ CDR(ptr) = (SCM)nw;
+ break;
+ case REAL_PART>>16: case IMAG_PART>>16:
+ nw = (double *)num_hp_alloc(sizeof(double));
+ nw[0] = REAL(ptr);
+ CDR(ptr) = (SCM)nw;
+ break;
+ case 0: break;
+ }
+ }
+# endif /* def NUM_HP */
SETGC8MARK(ptr);
break;
+#endif
default:
i = SMOBNUM(ptr);
if (!(i < numsmob)) goto def;
@@ -1541,8 +2112,6 @@ void mark_locations(x, n)
}
}
-#define HUGE_LENGTH(x) (LENGTH_MAX==LENGTH(x) ? *((long *)VELTS(x)) : LENGTH(x))
-
static void gc_sweep(contin_bad)
int contin_bad;
{
@@ -1550,17 +2119,17 @@ static void gc_sweep(contin_bad)
#ifdef POINTERS_MUNGED
register SCM scmptr;
#else
-#define scmptr (SCM)ptr
+# define scmptr (SCM)ptr
#endif
register SCM nfreelist = EOL;
register long n = 0, m = 0;
- register sizet j;
+ register sizet j, minc;
sizet i = 0;
- sizet seg_size;
+ sizet seg_cells;
while (i<hplim_ind) {
ptr = CELL_UP(hplims[i++]);
- seg_size = CELL_DN(hplims[i++]) - ptr;
- for(j = seg_size;j--;++ptr) {
+ seg_cells = CELL_DN(hplims[i++]) - ptr;
+ for(j = seg_cells;j--;++ptr) {
#ifdef POINTERS_MUNGED
scmptr = PTR2SCM(ptr);
#endif
@@ -1571,44 +2140,51 @@ static void gc_sweep(contin_bad)
case tcs_closures:
if GCMARKP(scmptr) goto cmrkcontinue;
break;
- case tc7_vector:
+ case tc7_specfun:
+ if GC8MARKP(scmptr) goto c8mrkcontinue;
#ifdef CCLO
- case tc7_cclo:
+ if (tc16_cclo==GCTYP16(scmptr)) {
+ minc = (CCLO_LENGTH(scmptr)*sizeof(SCM));
+ goto freechars;
+ }
#endif
+ break;
+ case tc7_vector:
if GC8MARKP(scmptr) goto c8mrkcontinue;
- m += (LENGTH(scmptr)*sizeof(SCM));
+ minc = (LENGTH(scmptr)*sizeof(SCM));
freechars:
- must_free(CHARS(scmptr));
+ m += minc;
+ must_free(CHARS(scmptr), minc);
/* SETCHARS(scmptr, 0);*/
break;
case tc7_bvect:
if GC8MARKP(scmptr) goto c8mrkcontinue;
- m += sizeof(long)*((HUGE_LENGTH(scmptr)+LONG_BIT-1)/LONG_BIT);
+ minc = sizeof(long)*((HUGE_LENGTH(scmptr)+LONG_BIT-1)/LONG_BIT);
goto freechars;
case tc7_ivect:
case tc7_uvect:
if GC8MARKP(scmptr) goto c8mrkcontinue;
- m += HUGE_LENGTH(scmptr)*sizeof(long);
+ minc = HUGE_LENGTH(scmptr)*sizeof(long);
goto freechars;
case tc7_fvect:
if GC8MARKP(scmptr) goto c8mrkcontinue;
- m += HUGE_LENGTH(scmptr)*sizeof(float);
+ minc = HUGE_LENGTH(scmptr)*sizeof(float);
goto freechars;
case tc7_dvect:
if GC8MARKP(scmptr) goto c8mrkcontinue;
- m += HUGE_LENGTH(scmptr)*sizeof(double);
+ minc = HUGE_LENGTH(scmptr)*sizeof(double);
goto freechars;
case tc7_cvect:
if GC8MARKP(scmptr) goto c8mrkcontinue;
- m += HUGE_LENGTH(scmptr)*2*sizeof(double);
+ minc = HUGE_LENGTH(scmptr)*2*sizeof(double);
goto freechars;
case tc7_string:
if GC8MARKP(scmptr) goto c8mrkcontinue;
- m += HUGE_LENGTH(scmptr)+1;
+ minc = HUGE_LENGTH(scmptr)+1;
goto freechars;
case tc7_msymbol:
if GC8MARKP(scmptr) goto c8mrkcontinue;
- m += LENGTH(scmptr)+1;
+ minc = LENGTH(scmptr)+1;
goto freechars;
case tc7_contin:
if GC8MARKP(scmptr) {
@@ -1620,7 +2196,7 @@ static void gc_sweep(contin_bad)
}
goto c8mrkcontinue;
}
- m += LENGTH(scmptr)*sizeof(STACKITEM) + sizeof(CONTINUATION);
+ minc = LENGTH(scmptr)*sizeof(STACKITEM) + sizeof(CONTINUATION);
free_continuation(CONT(scmptr)); break; /* goto freechars; */
case tc7_ssymbol:
if GC8MARKP(scmptr) goto c8mrkcontinue;
@@ -1651,30 +2227,38 @@ static void gc_sweep(contin_bad)
#ifdef BIGDIG
case tcs_bignums:
if GC8MARKP(scmptr) goto c8mrkcontinue;
- m += (NUMDIGS(scmptr)*BITSPERDIG/CHAR_BIT);
+# ifdef NUM_HP
+ if (NUMDIGS(scmptr)*sizeof(BIGDIG) <= NUM_HP_MAX_REQ) break;
+# endif /* def NUM_HP */
+ minc = (NUMDIGS(scmptr)*BITSPERDIG/CHAR_BIT);
goto freechars;
#endif /* def BIGDIG */
+#ifdef FLOATS
case tc16_flo:
if GC8MARKP(scmptr) goto c8mrkcontinue;
+# ifndef NUM_HP
switch ((int)(CAR(scmptr)>>16)) {
case (IMAG_PART | REAL_PART)>>16:
- m += sizeof(double);
+ minc = 2*sizeof(double);
+ goto freechars;
case REAL_PART>>16:
case IMAG_PART>>16:
- m += sizeof(double);
+ minc = sizeof(double);
goto freechars;
case 0:
break;
default:
goto sweeperr;
}
+# endif /* ndef NUM_HP */
+#endif /* def FLOATS */
break;
default:
if GC8MARKP(scmptr) goto c8mrkcontinue;
{
int k = SMOBNUM(scmptr);
if (!(k < numsmob)) goto sweeperr;
- m += (smobs[k].free)((CELLPTR)scmptr);
+ minc = (smobs[k].free)((CELLPTR)scmptr);
}
}
break;
@@ -1692,9 +2276,12 @@ static void gc_sweep(contin_bad)
CLRGCMARK(scmptr);
}
#ifdef GC_FREE_SEGMENTS
- if (n==seg_size) {
- heap_size -= seg_size;
- must_free((char *)hplims[i-2]);
+ if (n==seg_cells) {
+ heap_cells -= seg_cells;
+ n = 0;
+ free((char *)hplims[i-2]);
+ /* must_free((char *)hplims[i-2],
+ sizeof(cell) * (hplims[i-1] - hplims[i-2])); */
hplims[i-2] = 0;
for(j = i;j < hplim_ind;j++) hplims[j-2] = hplims[j];
hplim_ind -= 2;
@@ -1707,16 +2294,16 @@ static void gc_sweep(contin_bad)
gc_cells_collected += n;
n = 0;
}
- lcells_allocated += (heap_size - gc_cells_collected - cells_allocated);
- cells_allocated = (heap_size - gc_cells_collected);
+ lcells_allocated += (heap_cells - gc_cells_collected - cells_allocated);
+ cells_allocated = (heap_cells - gc_cells_collected);
lmallocated -= m;
mallocated -= m;
gc_malloc_collected = m;
}
+#ifndef NO_SYM_GC
/* mark_syms marks those symbols of hash table V which have
non-UNDEFINED values. */
-static char s_gc_sym[] = "mark_syms";
static void mark_syms(v)
SCM v;
{
@@ -1728,7 +2315,14 @@ static void mark_syms(v)
ASSERT(!GCMARKP(al), al, s_bad_type, s_gc_sym);
x = CAR(al);
SETGCMARK(al); /* Do mark bucket list */
- ASSERT(!GCMARKP(x), x, s_bad_type, s_gc_sym);
+# ifdef CAREFUL_INTS
+ ASSERT(NIMP(x) && NIMP(CAR(x)) && !GCMARKP(x), x, s_bad_type, s_gc_sym);
+ ASSERT(!GC8MARKP(CAR(x)) && !(CHARS(CAR(x))[LENGTH(CAR(x))]),
+ CAR(x), s_wrong_length, s_gc_sym);
+ ASSERT(strhash(UCHARS(CAR(x)), (sizet)LENGTH(CAR(x)),
+ (unsigned long)symhash_dim)==k,
+ CAR(x), "bad hash", s_gc_sym);
+# endif
if (UNDEFINED==CDR(x) && tc7_msymbol==TYP7(CAR(x)))
goto used; /* Don't mark symbol. */
SETGC8MARK(CAR(x));
@@ -1747,7 +2341,7 @@ static void mark_sym_values(v)
{
SCM x, al;
int k = LENGTH(v);
- SETGC8MARK(v);
+ /* SETGC8MARK(v); */ /* already set by mark_syms */
while (k--)
for (al = VELTS(v)[k]; NIMP(al); al = GCCDR(al)) {
x = GCCDR(CAR(al));
@@ -1780,3 +2374,172 @@ static void sweep_symhash(v)
VELTS(v)[k] &= ~1L; /* We may have deleted the first cell */
}
}
+#endif
+
+/* Environment cache GC routines */
+/* This is called during a non-cache gc. We only mark those stack frames
+ that are in use. */
+static void egc_mark()
+{
+ SCM *v;
+ int i;
+ gc_mark(scm_env);
+ gc_mark(scm_env_tmp);
+ if IMP(scm_estk) return; /* Can happen when moving estk. */
+ if GC8MARKP(scm_estk) return;
+ v = VELTS(scm_estk);
+ SETGC8MARK(scm_estk);
+ i = scm_estk_ptr - v + SCM_ESTK_FRLEN;
+ while(--i >= 0)
+ if NIMP(v[i])
+ gc_mark(v[i]);
+}
+static void egc_sweep()
+{
+ SCM z;
+ int i;
+ for (i = scm_ecache_index; i < scm_ecache_len; i++) {
+ z = PTR2SCM(&(scm_ecache[i]));
+ if CONSP(z) {
+ CLRGCMARK(z);
+ }
+ else {
+ CLRGC8MARK(z);
+ }
+ }
+}
+
+#define ECACHEP(x) (PTR_LE((CELLPTR)(ecache_v), (CELLPTR)SCM2PTR(x)) && \
+ PTR_GT((CELLPTR)(ecache_v) + ECACHE_SIZE, (CELLPTR)SCM2PTR(x)))
+static void egc_copy(px)
+ SCM *px;
+{
+ SCM z, x = *px;
+ do {
+ if (tc_broken_heart==CAR(x)) {
+ *px = CDR(x);
+ return;
+ }
+ if IMP(freelist) wta(freelist, "empty freelist", "ecache gc");
+ z = freelist;
+ freelist = CDR(freelist);
+ ++cells_allocated;
+ CAR(z) = CAR(x);
+ CDR(z) = CDR(x);
+ CAR(x) = (SCM)tc_broken_heart;
+ CDR(x) = z;
+ *px = z;
+ x = CAR(z);
+ if (NIMP(x) && ECACHEP(x))
+ egc_copy(&(CAR(z)));
+ px = &(CDR(z));
+ x = *px;
+ } while (NIMP(x) && ECACHEP(x));
+}
+
+static void egc_copy_stack(ve, len)
+ SCM *ve;
+ sizet len;
+{
+ SCM x;
+ while (len--) {
+ x = ve[len];
+ if (NIMP(x) && ECACHEP(x))
+ if (tc_broken_heart==CAR(x))
+ ve[len] = CDR(x);
+ else
+ egc_copy(&(ve[len]));
+ }
+}
+
+extern long tc16_env, tc16_promise;
+static void egc_copy_roots()
+{
+ SCM *roots = &(scm_egc_roots[scm_egc_root_index]);
+ SCM e, x;
+ int len = sizeof(scm_egc_roots)/sizeof(SCM) - scm_egc_root_index ;
+ if (!(len>=0 && len <= sizeof(scm_egc_roots)/sizeof(SCM)))
+ wta(MAKINUM(scm_egc_root_index), "egc-root-index", "corrupted");
+ while (len--) {
+ x = roots[len];
+ if IMP(x) continue;
+ switch TYP3(x) {
+ clo:
+ case tc3_closure:
+ e = ENV(x);
+ if (NIMP(e) && ECACHEP(e)) {
+ egc_copy(&e);
+ CDR(x) = (6L & CDR(x)) | e;
+ }
+ break;
+ case tc3_cons_imcar:
+ case tc3_cons_nimcar: /* These are environment frames that have
+ been destructively altered by DEFINE or
+ LETREC. This is only a problem if a
+ non-cache cell was made to point into the
+ cache. */
+ if ECACHEP(x) break;
+ e = CDR(x);
+ if (NIMP(e) && ECACHEP(e))
+ egc_copy(&(CDR(x)));
+ break;
+ default:
+ if (tc7_contin==TYP7(x)) {
+ x = CONT(x)->other.env;
+ egc_copy_stack(VELTS(x), (sizet)LENGTH(x));
+ break;
+ }
+ if (tc16_env==CAR(x)) {
+ e = CDR(x);
+ if (NIMP(e) && ECACHEP(e))
+ egc_copy(&(CDR(x)));
+ break;
+ }
+ if (tc16_promise==CAR(x)) {
+ x = CDR(x);
+ goto clo;
+ }
+ }
+ }
+ scm_egc_root_index = sizeof(scm_egc_roots)/sizeof(SCM);
+}
+extern long scm_stk_moved, scm_clo_moved, scm_env_work;
+void scm_egc()
+{
+ VERIFY_INTS("scm_egc", 0);
+/* We need to make sure there are enough cells available to migrate
+ the entire environment cache, gc does not work properly during ecache gc */
+ while ((heap_cells - cells_allocated <= scm_ecache_len) || IMP(freelist)) {
+ igc("ecache", CONT(rootcont)->stkbse);
+ if ((gc_cells_collected < MIN_GC_YIELD) ||
+ (heap_cells - cells_allocated <= scm_ecache_len) || IMP(freelist)) {
+ alloc_some_heap();
+ growth_mon("number of heaps", (long)(hplim_ind/2), "segments", !0);
+ growth_mon(s_heap, heap_cells, s_cells, !0);
+ }
+ }
+ if (++errjmp_bad > 1)
+ wta(MAKINUM(errjmp_bad), s_recursive, s_cache_gc);
+ {
+ SCM stkframe[2];
+ long lcells = cells_allocated;
+ sizet nstk = (scm_estk_ptr - VELTS(scm_estk) + SCM_ESTK_FRLEN);
+ ASSERT(nstk<=LENGTH(scm_estk), UNDEFINED, "estk corrupted", s_cache_gc);
+ scm_egc_start();
+ stkframe[0] = scm_env;
+ stkframe[1] = scm_env_tmp;
+ egc_copy_roots();
+ scm_clo_moved += cells_allocated - lcells;
+ lcells = cells_allocated;
+ egc_copy_stack(stkframe, sizeof(stkframe)/sizeof(SCM));
+ egc_copy_stack(VELTS(scm_estk), nstk);
+ scm_env = stkframe[0];
+ scm_env_tmp = stkframe[1];
+ scm_stk_moved += cells_allocated - lcells;
+ scm_ecache_index = scm_ecache_len;
+ scm_env_work += scm_ecache_len;
+ scm_egc_end();
+ }
+ --errjmp_bad;
+}
+
generated by cgit v1.2.3 (git 2.39.1) at 2025-11-04 05:11:48 +0000