From db04688faa20f3576257c0fe41752ec435beab9a Mon Sep 17 00:00:00 2001 From: Bryan Newbold Date: Mon, 20 Feb 2017 00:05:25 -0800 Subject: Import Upstream version 5c3 --- sys.c | 1095 +++++++++++++++++++++++++++++++++++++++++++++++++++++++---------- 1 file changed, 929 insertions(+), 166 deletions(-) (limited to 'sys.c') 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 . 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 +# 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 # else -# ifndef THINK_C +# ifndef macintosh # ifndef ARM_ULIB # include # 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("#", port); + iprin1(CDR(exp), port, writing); + } + else { + if (NIMP(CDR(exp)) && tc7_smob==CAR(CDR(exp))) { + lputs("#', 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 - 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>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; +} + -- cgit v1.2.3