/* "sys.c" opening and closing files, storage, and GC. * Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 2002, 2006 Free Software Foundation, Inc. * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as * published by the Free Software Foundation, either version 3 of the * License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, but * WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this program. If not, see * . */ #include #include "scm.h" #include "setjump.h" #ifdef POCKETCONSOLE # include #endif void igc P((const char *what, SCM basecont)); SCM *loc_open_file; /* for open-file callback */ SCM *loc_try_create_file; /* ttyname() etc. should be defined in . But unistd.h is missing on many systems. */ #ifndef STDC_HEADERS char *ttyname P((int fd)); char *tmpnam P((char *s)); # ifdef sun # ifndef __SVR4 int fputs P((char *s, FILE* stream)); int fputc P((char c, FILE* stream)); int fflush P((FILE* stream)); # endif # else sizet fwrite (); # endif int fgetc P((FILE* stream)); int fclose P((FILE* stream)); int pclose P((FILE* stream)); int unlink P((const char *pathname)); char *mktemp P((char *template)); #else # ifdef linux # include # endif # ifdef __NetBSD__ # include # endif # ifdef __OpenBSD__ # include # endif #endif static void gc_sweep P((int contin_bad)); char s_nogrow[] = "could not grow", s_heap[] = "heap", s_hplims[] = "hplims", s_try_create_file[] = "try-create-file"; 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_port_closedp[] = "port-closed?"; 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__ # include # include # define ttyname(x) "CON:" #else # ifndef MSDOS # ifndef ultrix # ifndef vms # ifdef _DCC # include # define setbuf(stream, buf) setvbuf(stream, buf, _IONBF, 0) # else # ifdef MWC # include # else # ifndef macintosh # ifndef ARM_ULIB # ifndef PLAN9 # include # endif # endif # endif # endif # endif # endif # endif # endif #endif /* __IBMC__ */ SCM i_setbuf0(port) /* should be called with DEFER_INTS active */ SCM port; { VERIFY_INTS("i_setbuf0", 0L); #ifndef NOSETBUF # ifndef MSDOS # ifdef FIONREAD # ifndef ultrix SYSCALL(setbuf(STREAM(port), 0L);); # endif # endif # endif #endif return UNSPECIFIED; } /* The CRDY bit is overloaded to indicate that additional processing is needed when reading or writing, such as updating line and column numbers. Returns 0 if cmodes is non-null and modes string is not valid. */ /* If nonnull, the CMODES argument receives a copy of all chars in MODES which are allowed by ANSI C. */ long mode_bits(modes, cmodes) char *modes, *cmodes; { int iout = 0; long bits = OPN; for (; *modes; modes++) switch (*modes) { case 'r': bits |= RDNG; goto outc; case 'w': case 'a': bits |= WRTNG; goto outc; case '+': bits |= (RDNG | WRTNG); goto outc; case 'b': bits |= BINARY; goto outc; case '0': bits |= BUF0; break; case '?': bits |= (TRACKED | CRDY); break; case 'x': bits |= EXCLUSIVE; break; outc: if (cmodes && (iout < 3)) cmodes[iout++] = *modes; break; } if (!cmodes) return bits; cmodes[iout] = 0; switch (cmodes[0]) { default: return 0; case 'r': case 'w': case 'a': return bits; } } SCM try_open_file(filename, modes) SCM filename, modes; { register SCM port; FILE *f; char cmodes[4]; long flags; ASRTER(NIMP(filename) && STRINGP(filename), filename, ARG1, s_open_file); ASRTER(NIMP(modes) && (STRINGP(modes) || SYMBOLP(modes)), modes, ARG2, s_open_file); flags = mode_bits(CHARS(modes), cmodes); ASRTER(flags, modes, ARG2, s_open_file); if ((EXCLUSIVE & flags) && NIMP(*loc_try_create_file)) { port = apply(*loc_try_create_file, filename, cons(modes, listofnull)); if (UNSPECIFIED != port) return port; } DEFER_INTS; SCM_OPENCALL((f = fopen(CHARS(filename), cmodes))); if (!f) { ALLOW_INTS; return BOOL_F; } port = scm_port_entry(f, tc16_fport, flags); if (BUF0 & flags) i_setbuf0(port); ALLOW_INTS; SCM_PORTDATA(port) = filename; return port; } /* Callback to Scheme */ SCM open_file(filename, modes) SCM filename, modes; { return apply(*loc_open_file, filename, cons(modes, listofnull)); } long tc16_clport; SCM close_port(port) SCM port; { sizet i; SCM ret = UNSPECIFIED; ASRTER(NIMP(port) && PORTP(port), port, ARG1, s_close_port); if (CLOSEDP(port)) return UNSPECIFIED; i = PTOBNUM(port); DEFER_INTS; if (ptobs[i].fclose) { int r; SYSCALL(r = (ptobs[i].fclose)(STREAM(port));); if (EOF == r) ret = BOOL_F; else ret = MAKINUM(r); } CAR(port) &= ~OPN; SCM_PORTFLAGS(port) &= ~OPN; /* Bash the old ptobnum with the closed port ptobnum. This allows catching some errors cheaply. */ SCM_SET_PTOBNUM(port, tc16_clport); ALLOW_INTS; return ret; } SCM input_portp(x) SCM x; { if (IMP(x)) return BOOL_F; return INPORTP(x) ? BOOL_T : BOOL_F; } SCM output_portp(x) SCM x; { if (IMP(x)) return BOOL_F; return OUTPORTP(x) ? BOOL_T : BOOL_F; } SCM port_closedp(port) SCM port; { ASRTER(NIMP(port) && PORTP(port), port, ARG1, s_port_closedp); if (CLOSEDP(port)) return BOOL_T; return BOOL_F; } SCM scm_port_type(port) SCM port; { int i; if (NIMP(port) && PORTP(port)) { i = PTOBNUM(port); if (ptobs[i].name) return CAR(sysintern(ptobs[i].name, UNDEFINED)); return BOOL_T; } return BOOL_F; } #if (__TURBOC__==1) # undef L_tmpnam /* Not supported in TURBOC V1.0 */ #endif #ifdef GO32 # undef L_tmpnam /* Would put files in %TMPDIR% = %DJDIR%/tmp */ #endif #ifdef MWC # undef L_tmpnam #endif #ifdef L_tmpnam SCM ltmpnam() { char name[L_tmpnam]; SYSCALL(tmpnam(name);); return makfrom0str(name); } #else /* TEMPTEMPLATE is used only if mktemp() is being used instead of tmpnam(). */ # ifdef AMIGA # define TEMPTEMPLATE "T:SchemeaaaXXXXXX"; # else # ifdef vms # define TEMPTEMPLATE "sys$scratch:aaaXXXXXX"; # else /* vms */ # ifdef __MSDOS__ # ifdef GO32 # define TEMPTEMPLATE "\\tmp\\TMPaaaXXXXXX"; # else # define TEMPTEMPLATE "TMPaaaXXXXXX"; # endif # else /* __MSDOS__ */ # define TEMPTEMPLATE "/tmp/aaaXXXXXX"; # endif /* __MSDOS__ */ # endif /* vms */ # endif /* AMIGA */ char template[] = TEMPTEMPLATE; # define TEMPLEN (sizeof template/sizeof(char) - 1) SCM ltmpnam() { SCM name; int temppos = TEMPLEN-9; name = makfromstr(template, (sizet)TEMPLEN); DEFER_INTS; inclp: template[temppos]++; if (!isalpha(template[temppos])) { template[temppos++] = 'a'; goto inclp; } # ifndef AMIGA # ifndef __MSDOS__ SYSCALL(temppos = !*mktemp(CHARS(name));); if (temppos) name = BOOL_F; # endif # endif ALLOW_INTS; return name; } #endif /* L_tmpnam */ #ifdef M_SYSV # define remove unlink #endif static char s_del_fil[] = "delete-file"; SCM del_fil(str) SCM str; { int ans; ASRTER(NIMP(str) && STRINGP(str), str, ARG1, s_del_fil); #ifdef STDC_HEADERS SYSCALL(ans = remove(CHARS(str));); #else SYSCALL(ans = unlink(CHARS(str));); #endif return ans ? BOOL_F : BOOL_T; } void prinport(exp, port, type) SCM exp; SCM port; char *type; { int filn = fileno(STREAM(exp)); lputs("#<", port); if (CLOSEDP(exp)) lputs("closed-", port); else { if (RDNG & CAR(exp)) lputs("input-", port); if (WRTNG & CAR(exp)) lputs("output-", port); } lputs(type, port); lputc(' ', port); #ifndef MSDOS # ifndef __EMX__ # ifndef _DCC # ifndef AMIGA # ifndef macintosh # ifndef PLAN9 if (OPENP(exp) && tc16_fport==TYP16(exp) && filn >= 0 && isatty(filn)) { char *ttyn = ttyname(filn); if (ttyn) lputs(ttyn, port); else goto punt; } else # endif # endif # endif # endif # endif #endif punt: { SCM s = PORTP(exp) ? SCM_PORTDATA(exp) : UNDEFINED; if (NIMP(s) && STRINGP(s)) scm_iprin1(s, port, 1); else if (OPFPORTP(exp)) scm_intprint((long)filn, 10, port); else scm_intprint(CDR(exp), -16, port); if (TRACKED & SCM_PORTFLAGS(exp)) { lputs(" L", port); scm_intprint(scm_port_table[SCM_PORTNUM(exp)].line, 10, port); lputs(" C", port); scm_intprint(scm_port_table[SCM_PORTNUM(exp)].col+0L, 10, port); } } lputc('>', port); } static int stputc(c, p) int c; SCM p; { sizet ind = INUM(CAR(p)); if (ind >= LENGTH(CDR(p))) resizuve(CDR(p), MAKINUM(ind + (ind>>1))); CHARS(CDR(p))[ind] = c; CAR(p) = MAKINUM(ind + 1); return c; } sizet stwrite(str, siz, num, p) sizet siz, num; char *str; SCM p; { sizet ind = INUM(CAR(p)); sizet len = siz * num; char *dst; if (ind + len >= LENGTH(CDR(p))) resizuve(CDR(p), MAKINUM(ind + len + ((ind + len)>>1))); dst = &(CHARS(CDR(p))[ind]); while (len--) dst[len] = str[len]; CAR(p) = MAKINUM(ind + siz*num); return num; } static int stputs(s, p) char *s; SCM p; { stwrite(s, 1, strlen(s), p); return 0; } static int stgetc(p) SCM p; { sizet ind = INUM(CAR(p)); if (ind >= LENGTH(CDR(p))) return EOF; CAR(p) = MAKINUM(ind + 1); return UCHARS(CDR(p))[ind]; } static int stclose(p) SCM p; { SETCDR(p, nullstr); return 0; } static int stungetc(c, p) int c; SCM p; { sizet ind; p = CDR(p); ind = INUM(CAR(p)); if (ind == 0) return EOF; CAR(p) = MAKINUM(--ind); ASRTER(UCHARS(CDR(p))[ind] == c, MAKICHR(c), "stungetc", ""); return c; } int noop0(stream) FILE *stream; { return 0; } SCM mkstrport(pos, str, modes, caller) SCM pos; SCM str; long modes; char *caller; { SCM z; ASRTER(INUMP(pos) && INUM(pos) >= 0, pos, ARG1, caller); ASRTER(NIMP(str) && (STRINGP(str) || SYMBOLP(str)), str, ARG1, caller); str = cons(pos, str); NEWCELL(z); DEFER_INTS; SETCHARS(z, str); CAR(z) = (modes | tc16_strport); /* port table entry 0 is scratch. */ /* z = scm_port_entry((FILE *)str, tc16_strport, modes); */ ALLOW_INTS; return z; } static char s_cwos[] = "call-with-output-string"; static char s_cwis[] = "call-with-input-string"; SCM cwos(proc) SCM proc; { SCM p = mkstrport(INUM0, make_string(MAKINUM(30), UNDEFINED), OPN | WRTNG, s_cwos); apply(proc, p, listofnull); return resizuve(CDR(CDR(p)), CAR(CDR(p))); } SCM cwis(str, proc) SCM str, proc; { SCM p = mkstrport(INUM0, str, OPN | RDNG, s_cwis); return apply(proc, p, listofnull); } #ifdef vms sizet pwrite(ptr, size, nitems, port) char *ptr; sizet size, nitems; FILE* port; { sizet len = size * nitems; sizet i = 0; for (;i < len;i++) putc(ptr[i], port); return len; } # define ffwrite pwrite #else # define ffwrite fwrite #endif static ptobfuns fptob = { s_port_type, mark0, fclose, 0, 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}; ptobfuns pipob = { 0, mark0, 0, /* replaced by pclose in init_posix() */ 0, 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}; static ptobfuns stptob = { s_string, markcdr, noop0, 0, 0, stputc, stputs, stwrite, noop0, stgetc, stclose, stungetc}; /* Soft ports */ /* fputc, fwrite, fputs, and fclose are called within a SYSCALL. So we need to set errno to 0 before returning. fflush may be called within a SYSCALL. So we need to set errno to 0 before returning. */ static int sfputc(c, p) int c; SCM p; { SCM arg = MAKICHR(c); scm_cvapply(VELTS(p)[0], 1L, &arg); errno = 0; return c; } sizet sfwrite(str, siz, num, p) sizet siz, num; char *str; SCM p; { SCM sstr; sstr = makfromstr(str, siz * num); scm_cvapply(VELTS(p)[1], 1L, &sstr); errno = 0; return num; } static int sfputs(s, p) char *s; SCM p; { sfwrite(s, 1, strlen(s), p); return 0; } int sfflush(stream) SCM stream; { SCM f = VELTS(stream)[2]; if (BOOL_F==f) return 0; f = apply(f, EOL, EOL); errno = 0; return BOOL_F==f ? EOF : 0; } static int sfgetc(p) SCM p; { SCM ans; ans = scm_cvapply(VELTS(p)[3], 0L, (SCM *)0); errno = 0; if (FALSEP(ans) || EOF_VAL==ans) return EOF; ASRTER(ICHRP(ans), ans, ARG1, "getc"); return ICHR(ans); } static int sfclose(p) SCM p; { SCM f = VELTS(p)[4]; if (BOOL_F==f) return 0; f = apply(f, EOL, EOL); errno = 0; return BOOL_F==f ? EOF : 0; } static char s_mksfpt[] = "make-soft-port"; SCM mksfpt(pv, modes) SCM pv, modes; { SCM z; long flags; static long arities[] = {1, 1, 0, 0, 0}; #ifndef RECKLESS int i; if (! (NIMP(pv) && VECTORP(pv) && 5==LENGTH(pv))) badarg: wta(pv, (char *)ARG1, s_mksfpt); for (i = 0; i < 5; i++) { ASRTGO(FALSEP(VELTS(pv)[i]) || scm_arity_check(VELTS(pv)[i], arities[i], (char *)0), badarg); } #endif ASRTER(NIMP(modes) && (STRINGP(modes) || SYMBOLP(modes)), modes, ARG2, s_mksfpt); flags = mode_bits(CHARS(modes), (char *)0); ASRTER(flags, modes, ARG2, s_mksfpt); DEFER_INTS; z = scm_port_entry((FILE *)pv, tc16_sfport, flags); ALLOW_INTS; return z; } static ptobfuns sfptob = { "soft", markcdr, noop0, 0, 0, sfputc, sfputs, sfwrite, sfflush, sfgetc, sfclose}; /* Closed ports, just return an error code and let the caller complain. */ static int clputc(c, p) int c; FILE *p; { return EOF; } static sizet clwrite(str, siz, num, p) sizet siz, num; char *str; FILE *p; { return 0; } static int clputs(s, p) char *s; FILE *p; { return EOF; } static int clgetc(p) FILE *p; { return EOF; } static ptobfuns clptob = { s_port_type, mark0, noop0, 0, 0, clputc, clputs, clwrite, clgetc, clgetc, 0}; /* 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_errp) && OPOUTPORTP(cur_errp)) lfflush(cur_errp); */ if (errbuf_end > 0) { if (errbuf_end > SYS_ERRP_SIZE) { scm_warn("output buffer", " overflowed", UNDEFINED); scm_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); /* if (NIMP(cur_errp) && OPOUTPORTP(cur_errp)) lfflush(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 ptobfuns sysptob = { 0, mark0, noop0, 0, 0, sysputc, sysputs, syswrite, noop0, noop0, noop0}; /* A `safeport' is used for writing objects as part of an error response. Since these objects may be very large or circular, the safeport will output only a fixed number of characters before exiting via longjmp. A setjmp must be done before each use of the safeport. */ static char s_msp[] = "mksafeport"; int tc16_safeport; SCM mksafeport(maxlen, port) int maxlen; SCM port; { SCM z; if (UNBNDP(port)) port = cur_errp; ASRTER(NIMP(port) && OPPORTP(port), port, ARG2, s_msp); z = must_malloc_cell(sizeof(safeport)+0L, tc16_safeport | OPN | WRTNG, s_msp); ((safeport *)STREAM(z))->ccnt = maxlen; ((safeport *)STREAM(z))->port = port; return z; } int reset_safeport(sfp, maxlen, port) int maxlen; SCM sfp, port; { if (NIMP(sfp) && tc16_safeport==TYP16(sfp)) { ((safeport *)STREAM(sfp))->ccnt = maxlen; if (NIMP(port)) ((safeport *)STREAM(sfp))->port = port; return !0; } return 0; } static sizet safewrite(str, siz, num, p) sizet siz, num; char *str; safeport *p; { int count = p->ccnt; sizet n = siz*num; if (n < count) { p->ccnt = count - n; lfwrite(str, siz, num, p->port); } else if (count) { num = count / siz; p->ccnt = 0; lfwrite(str, siz, num, p->port); lputs(" ...", p->port); longjmp(p->jmpbuf, !0); /* The usual C longjmp, not SCM's longjump */ } return num; } static int safeputs(s, p) char *s; safeport *p; { safewrite(s, 1, strlen(s), p); return 0; } static int safeputc(c, p) int c; safeport *p; { char cc = c; safewrite(&cc, 1, 1, p); return c; } static int safeflush(p) safeport *p; { if (p && NIMP(p->port) && OPOUTPORTP(p->port)) lfflush(p->port); return 0; } static SCM marksafep(ptr) SCM ptr; { return ((safeport *)STREAM(ptr))->port; } static int freesafep(ptr) FILE *ptr; { must_free((char *)ptr, sizeof(safeport)); return 0; } static ptobfuns safeptob = { 0, marksafep, freesafep, 0, 0, safeputc, safeputs, safewrite, safeflush, noop0, noop0}; static int freeprint(exp, port, writing) SCM exp; SCM port; int writing; { if (tc_broken_heart==CAR(exp)) { lputs("#", port); scm_iprin1(CDR(exp), port, writing); } else { if (NIMP(CDR(exp)) && tc7_smob==CAR(CDR(exp))) { lputs("#', port); return !0; } static smobfuns freecell = { mark0, free0, freeprint, 0}; static smobfuns flob = { mark0, /*flofree*/0, floprint, #ifdef FLOATS floequal #else 0 #endif }; static smobfuns bigob = { mark0, /*bigfree*/0, bigprint, #ifdef BIGDIG bigequal #else 0 #endif }; scm_gra finals_gra; static char s_final[] = "final"; /* statically allocated ports for diagnostic messages */ static cell tmp_errpbuf[3]; static SCM tmp_errp; extern sizet num_protects; /* sys_protects now in scl.c */ void init_types() { sizet j = num_protects; while(j) sys_protects[--j] = UNDEFINED; /* We need to set up tmp_errp before any errors may be thrown, the port_table index will be zero, usable by all ports that don't care about their table entries. */ tmp_errp = PTR2SCM(CELL_UP(&tmp_errpbuf[0])); CAR(tmp_errp) = tc16_fport | OPN | WRTNG; /* CAR(tmp_errp) = scm_port_entry(tc16_fport, OPN|WRTNG); */ SETSTREAM(tmp_errp, stderr); cur_errp = def_errp = sys_safep = tmp_errp; /* subrs_gra is trimmed to actual used by scm_init_extensions() */ scm_init_gra(&subrs_gra, sizeof(subr_info), 420 , 0, "subrs"); scm_init_gra(&ptobs_gra, sizeof(ptobfuns), 8, 255, "ptobs"); /* These newptob calls must be done in this order */ /* tc16_fport = */ newptob(&fptob); /* tc16_pipe = */ newptob(&pipob); /* tc16_strport = */ newptob(&stptob); /* tc16_sfport = */ newptob(&sfptob); tc16_clport = newptob(&clptob); tc16_sysport = newptob(&sysptob); tc16_safeport = newptob(&safeptob); scm_init_gra(&smobs_gra, sizeof(smobfuns), 16, 255, "smobs"); /* These newsmob calls must be done in this order */ newsmob(&freecell); newsmob(&flob); newsmob(&bigob); newsmob(&bigob); scm_init_gra(&finals_gra, sizeof(void (*)()), 4, 0, s_final); } #ifdef TEST_FINAL void test_final() { fputs("test_final ok\n", stderr); } #endif void add_final(final) void (* final)(); { scm_grow_gra(&finals_gra, (char *)&final); } static SCM gc_finalizers = EOL, gc_finalizers_pending = EOL; static char s_add_finalizer[] = "add-finalizer"; SCM scm_add_finalizer(value, finalizer) SCM value, finalizer; { SCM z; ASRTER(NIMP(value), value, ARG1, s_add_finalizer); #ifndef RECKLESS scm_arity_check(finalizer, 0L, s_add_finalizer); #endif z = acons(value, finalizer, EOL); DEFER_INTS; CDR(z) = gc_finalizers; gc_finalizers = z; ALLOW_INTS; return UNSPECIFIED; } 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; static SCM estk_pool = EOL; long scm_estk_size; static SCM make_stk_seg(size, contents) sizet size; SCM contents; { SCM seg = BOOL_F, *src, *dst; sizet i; VERIFY_INTS("make_stk_seg", 0L); while NIMP(estk_pool) { if (size==LENGTH(estk_pool)) { seg = estk_pool; estk_pool = SCM_ESTK_PARENT(seg); break; } estk_pool = SCM_ESTK_PARENT(estk_pool); } if (IMP(seg)) seg = must_malloc_cell((long)size*sizeof(SCM), MAKE_LENGTH(size, tc7_vector), s_estk); dst = VELTS(seg); if (NIMP(contents)) { src = VELTS(contents); for (i = size; i--;) dst[i] = src[i]; } else { for (i = size; i--;) dst[i] = UNSPECIFIED; SCM_ESTK_PARENT(seg) = BOOL_F; SCM_ESTK_PARENT_INDEX(seg) = INUM0; dst[SCM_ESTK_BASE - 1] = UNDEFINED; /* underflow sentinel */ } dst[size - 1] = UNDEFINED; /* overflow sentinel */ return seg; } /* size is a number of SCM elements, or zero for a default size. If nonzero, size must be SCM_ESTK_BASE + N * SCM_ESTK_FRLEN + 1 for some reasonable number of stackframes N */ void scm_estk_reset(size) sizet size; { VERIFY_INTS("scm_estk_reset", 0L); if (!size) size = SCM_ESTK_BASE + 20*SCM_ESTK_FRLEN + 1; scm_estk = make_stk_seg(size, UNDEFINED); scm_estk_ptr = &(VELTS(scm_estk)[SCM_ESTK_BASE]); scm_estk_size = size + 0L; } void scm_estk_grow() { /* 40 and 10 below are adjustable parameters: the number of frames in a stack segment, and the number of frames to overlap between stack segments. */ sizet size = 40 * SCM_ESTK_FRLEN + SCM_ESTK_BASE + 1; sizet overlap = 10*SCM_ESTK_FRLEN; SCM estk = make_stk_seg(size, UNDEFINED); SCM *newv, *oldv; sizet i, j; newv = VELTS(estk); oldv = VELTS(scm_estk); j = scm_estk_ptr - oldv + SCM_ESTK_FRLEN - overlap; SCM_ESTK_PARENT(estk) = scm_estk; SCM_ESTK_PARENT_WRITABLEP(estk) = BOOL_T; SCM_ESTK_PARENT_INDEX(estk) = MAKINUM(j - SCM_ESTK_FRLEN); for (i = SCM_ESTK_BASE; i < SCM_ESTK_BASE + overlap; i++, j++) { newv[i] = oldv[j]; oldv[j] = BOOL_F; } scm_estk = estk; scm_estk_ptr = &(newv[SCM_ESTK_BASE + overlap]); scm_estk_size += size + 0L; /* growth_mon(s_estk, scm_estk_size, "locations", !0); */ } void scm_estk_shrink() { SCM parent; sizet i; parent = SCM_ESTK_PARENT(scm_estk); i = INUM(SCM_ESTK_PARENT_INDEX(scm_estk)); if (IMP(parent)) wta(UNDEFINED, "underflow", s_estk); if (BOOL_F==SCM_ESTK_PARENT_WRITABLEP(scm_estk)) { parent = make_stk_seg((sizet)LENGTH(parent), parent); SCM_ESTK_PARENT_WRITABLEP(parent) = BOOL_F; } SCM_ESTK_PARENT(scm_estk) = estk_pool; estk_pool = scm_estk; scm_estk_size -= LENGTH(scm_estk); scm_estk = parent; scm_estk_ptr = &(VELTS(parent)[i]); /* growth_mon(s_estk, scm_estk_size, "locations", 0); */ } void scm_env_cons(x, y) SCM x, y; { register SCM z; register int i; DEFER_INTS_EGC; i = scm_ecache_index; if (1>i) { scm_egc(); i = scm_ecache_index; } z = PTR2SCM(&(scm_ecache[--i])); CAR(z) = x; CDR(z) = y; scm_env_tmp = z; scm_ecache_index = i; } void scm_env_cons2(w, x, y) SCM w, x, y; { SCM z1, z2; register int i; DEFER_INTS_EGC; i = scm_ecache_index; if (2>i) { scm_egc(); i = scm_ecache_index; } z1 = PTR2SCM(&(scm_ecache[--i])); CAR(z1) = x; CDR(z1) = y; z2 = PTR2SCM(&(scm_ecache[--i])); CAR(z2) = w; CDR(z2) = z1; scm_env_tmp = z2; scm_ecache_index = i; } void scm_env_cons3(v, w, x, y) SCM v, w, x, y; { SCM z1, z2; register int i; DEFER_INTS_EGC; i = scm_ecache_index; if (3>i) { scm_egc(); i = scm_ecache_index; } z1 = PTR2SCM(&(scm_ecache[--i])); CAR(z1) = x; CDR(z1) = y; z2 = PTR2SCM(&(scm_ecache[--i])); CAR(z2) = w; CDR(z2) = z1; z1 = PTR2SCM(&(scm_ecache[--i])); CAR(z1) = v; CDR(z1) = z2; scm_env_tmp = z1; scm_ecache_index = i; } void scm_env_v2lst(argc, argv) long argc; SCM *argv; { SCM z1, z2; register int i; DEFER_INTS_EGC; i = scm_ecache_index; if (argc>i) { scm_egc(); i = scm_ecache_index; } z1 = z2 = scm_env_tmp; /* set z1 just in case argc is zero */ while (argc--) { z1 = PTR2SCM(&(scm_ecache[--i])); CAR(z1) = argv[argc]; CDR(z1) = z2; z2 = z1; } scm_env_tmp = z1; scm_ecache_index = i; } /* scm_env = acons(names, scm_env_tmp, scm_env) */ void scm_extend_env() { SCM z; register int i; DEFER_INTS_EGC; i = scm_ecache_index; if (1>i) { scm_egc(); i = scm_ecache_index; } z = PTR2SCM(&(scm_ecache[--i])); CAR(z) = scm_env_tmp; CDR(z) = scm_env; scm_env = z; scm_ecache_index = i; } void old_scm_extend_env(names) SCM names; { SCM z1, z2; register int i; DEFER_INTS_EGC; i = scm_ecache_index; if (2>i) { scm_egc(); i = scm_ecache_index; } z1 = PTR2SCM(&(scm_ecache[--i])); CAR(z1) = names; CDR(z1) = scm_env_tmp; z2 = PTR2SCM(&(scm_ecache[--i])); CAR(z2) = z1; CDR(z2) = scm_env; scm_env = z2; scm_ecache_index = i; } char s_obunhash[] = "object-unhash", s_cache_gc[] = "cache_gc"; char s_recursive[] = "recursive"; #define s_gc (s_cache_gc+6) static iproc subr0s[] = { {"tmpnam", ltmpnam}, {"open-ports", scm_open_ports}, {0, 0}}; static iproc subr1s[] = { {s_input_portp, input_portp}, {s_output_portp, output_portp}, {s_port_closedp, port_closedp}, {s_close_port, close_port}, {"eof-object?", eof_objectp}, {"port-type", scm_port_type}, {s_cwos, cwos}, {"object-hash", obhash}, {s_obunhash, obunhash}, {s_del_fil, del_fil}, {0, 0}}; static iproc subr2s[] = { {s_try_open_file, try_open_file}, {s_cwis, cwis}, {s_mksfpt, mksfpt}, {s_add_finalizer, scm_add_finalizer}, {0, 0}}; SCM dynwind P((SCM thunk1, SCM thunk2, SCM thunk3)); 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(sysintern(s_try_open_file, UNDEFINED)))); loc_try_create_file = &CDR(sysintern(s_try_create_file, UNDEFINED)); #ifndef CHEAP_CONTINUATIONS add_feature("full-continuation"); #endif #ifdef TEST_FINAL add_final(test_final); #endif } void grew_lim(nm) long nm; { growth_mon(s_limit, nm, "bytes", !0); } int expmem = 0; sizet hplim_ind = 0; long heap_cells = 0; CELLPTR *hplims, heap_org; VOLATILE SCM freelist = EOL; long mltrigger, mtrigger = INIT_MALLOC_LIMIT; int gc_hook_pending = 0, gc_hook_active = 0; /* Ints should be deferred when calling igc_for_alloc. */ static char *igc_for_alloc(where, olen, size, what) char *where; long olen; sizet size; const char *what; { char *ptr; long nm; /* Check to see that heap is initialized */ ASRTER(heap_cells > 0, MAKINUM(size), NALLOC, what); /* printf("igc_for_alloc(%lx, %lu, %u, %s)\n", where, olen, size, what); fflush(stdout); */ igc(what, rootcont); 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);); ASRTER(ptr, MAKINUM(size), NALLOC, what); if (nm > mltrigger) { if (nm > mtrigger) mtrigger = nm + nm/2; else mtrigger += mtrigger/2; mltrigger = mtrigger - MIN_MALLOC_YIELD; } mallocated = nm; return ptr; } char *must_malloc(len, what) long len; const char *what; { char *ptr; sizet size = len; long nm = mallocated + size; VERIFY_INTS("must_malloc", what); #ifdef SHORT_SIZET ASRTER(len==size, MAKINUM(len), NALLOC, what); #endif if (nm <= mtrigger) SYSCALL(ptr = (char *)malloc(size);); else ptr = 0; if (!ptr) ptr = igc_for_alloc(0L, 0L, size, what); else mallocated = nm; /* printf("must_malloc(%lu, %s) => %lx\n", len, what, ptr); fflush(stdout); */ return ptr; } SCM must_malloc_cell(len, c, what) long len; SCM c; const char *what; { SCM z; char *ptr; sizet size = len; long nm = mallocated + size; VERIFY_INTS("must_malloc_cell", what); #ifdef SHORT_SIZET ASRTER(len==size, MAKINUM(len), NALLOC, what); #endif NEWCELL(z); if (nm <= mtrigger) SYSCALL(ptr = (char *)malloc(size);); else ptr = 0; if (!ptr) ptr = igc_for_alloc(0L, 0L, size, what); else mallocated = nm; /* printf("must_malloc_cell(%lu, %lx, %s) => %lx\n", len, c, what, ptr); fflush(stdout); */ SETCHARS(z, ptr); CAR(z) = c; return z; } char *must_realloc(where, olen, len, what) char *where; long olen, len; const char *what; { char *ptr; sizet size = len; long nm = mallocated + size - olen; VERIFY_INTS("must_realloc", what); #ifdef SHORT_SIZET ASRTER(len==size, MAKINUM(len), NALLOC, what); #endif ASRTER(!errjmp_bad, MAKINUM(len), NALLOC, what); /* printf("must_realloc(%lx, %lu, %lu, %s)\n", where, olen, len, what); fflush(stdout); printf("nm = %ld <= mtrigger = %ld: %d; size = %u\n", nm, mtrigger, (nm <= mtrigger), size); fflush(stdout); */ if (nm <= mtrigger) SYSCALL(ptr = (char *)realloc(where, size);); else ptr = 0; if (!ptr) ptr = igc_for_alloc(where, olen, size, what); else mallocated = nm; return ptr; } void must_realloc_cell(z, olen, len, what) SCM z; long olen, len; const char *what; { char *ptr, *where = CHARS(z); sizet size = len; long nm = mallocated + size - olen; VERIFY_INTS("must_realloc_cell", what); #ifdef SHORT_SIZET ASRTER(len==size, MAKINUM(len), NALLOC, what); #endif ASRTER(!errjmp_bad, MAKINUM(len), NALLOC, what); /* printf("must_realloc_cell(%lx, %lu, %lu, %s)\n", z, olen, len, what); fflush(stdout); */ if (nm <= mtrigger) SYSCALL(ptr = (char *)realloc(where, size);); else ptr = 0; if (!ptr) ptr = igc_for_alloc(where, olen, size, what); else mallocated = nm; SETCHARS(z, ptr); } void must_free(obj, len) char *obj; sizet len; { if (obj) { #ifdef CAREFUL_INTS while (len--) obj[len] = '#'; #endif /* printf("free(%lx)\n", obj); fflush(stdout); */ free(obj); mallocated = mallocated - len; } else wta(INUM0, "already free", ""); } SCM symhash; /* This used to be a sys_protect, but Radey Shouman added GC for unused, UNDEFINED symbols.*/ int symhash_dim = NUM_HASH_BUCKETS; /* sym2vcell looks up the symbol in the symhash table. */ SCM sym2vcell(sym) SCM sym; { SCM lsym, z; sizet hash = strhash(UCHARS(sym), (sizet)LENGTH(sym), (unsigned long)symhash_dim); for (lsym = VELTS(symhash)[hash];NIMP(lsym);lsym = CDR(lsym)) { z = CAR(lsym); if (CAR(z)==sym) return z; } wta(sym, "uninterned symbol? ", ""); } /* intern() and sysintern() return a pair; CAR is the symbol, CDR is the value. */ SCM intern(name, len) char *name; sizet len; { SCM lsym, z; register sizet i = len; register unsigned char *tmp = (unsigned char *)name; sizet hash = strhash(tmp, i, (unsigned long)symhash_dim); /* printf("intern %s len=%d\n",name,len); fflush(stdout); */ DEFER_INTS; for (lsym = VELTS(symhash)[hash];NIMP(lsym);lsym = CDR(lsym)) { z = CAR(lsym); z = CAR(z); tmp = UCHARS(z); if (LENGTH(z) != len) goto trynext; for (i = len;i--;) if (((unsigned char *)name)[i] != tmp[i]) goto trynext; ALLOW_INTS; return CAR(lsym); trynext: ; } /* lsym = makfromstr(name, len); */ lsym = must_malloc_cell(len+1L, MAKE_LENGTH(len, tc7_msymbol), s_string); i = len; CHARS(lsym)[len] = 0; while (i--) CHARS(lsym)[i] = name[i]; z = acons(lsym, UNDEFINED, UNDEFINED); CDR(z) = VELTS(symhash)[hash]; VELTS(symhash)[hash] = z; z = CAR(z); ALLOW_INTS; return z; } SCM sysintern(name, val) const char *name; SCM val; { SCM lsym, z; sizet len = strlen(name); register sizet i = len; register unsigned char *tmp = (unsigned char *)name; sizet hash = strhash(tmp, i, (unsigned long)symhash_dim); for (lsym = VELTS(symhash)[hash];NIMP(lsym);lsym = CDR(lsym)) { z = CAR(lsym); z = CAR(z); tmp = UCHARS(z); if (LENGTH(z) != len) goto trynext; for (i = len;i--;) if (((unsigned char *)name)[i] != tmp[i]) goto trynext; lsym = CAR(lsym); if (!UNBNDP(val)) CDR(lsym) = val; else if (UNBNDP(CDR(lsym)) && tc7_msymbol==TYP7(CAR(lsym))) scm_gc_protect(lsym); return lsym; trynext: ; } NEWCELL(lsym); SETLENGTH(lsym, len, tc7_ssymbol); SETCHARS(lsym, name); lsym = cons(lsym, val); z = cons(lsym, UNDEFINED); CDR(z) = VELTS(symhash)[hash]; VELTS(symhash)[hash] = z; return lsym; } SCM cons(x, y) SCM x, y; { register SCM z; NEWCELL(z); CAR(z) = x; CDR(z) = y; return z; } SCM cons2(w, x, y) SCM w, x, y; { register SCM z; NEWCELL(z); CAR(z) = x; CDR(z) = y; x = z; NEWCELL(z); CAR(z) = w; CDR(z) = x; return z; } SCM acons(w, x, y) SCM w, x, y; { register SCM z; NEWCELL(z); CAR(z) = w; CDR(z) = x; x = z; NEWCELL(z); CAR(z) = x; CDR(z) = y; return z; } SCM makstr(len) long len; { SCM s; #ifndef SHORT_SIZET ASRTER(!(len & ~LENGTH_MAX), MAKINUM(len), NALLOC, s_string); #endif DEFER_INTS; s = must_malloc_cell(len+1L, MAKE_LENGTH(len, tc7_string), s_string); CHARS(s)[len] = 0; ALLOW_INTS; return s; } char s_redefining[] = "redefining "; scm_gra subrs_gra; SCM scm_maksubr(name, type, fcn) const char *name; int type; SCM (*fcn)(); { subr_info info; int isubr; register SCM z; info.name = name; for (isubr = subrs_gra.len; 0 < isubr--;) { if (0==strcmp(((char **)subrs_gra.elts)[isubr], name)) { scm_warn(s_redefining, (char *)name, UNDEFINED); goto foundit; } } isubr = scm_grow_gra(&subrs_gra, (char *)&info); foundit: NEWCELL(z); if (!fcn && tc7_cxr==type) { const char *p = name; int code = 0; while (*++p != 'r') switch (*p) { default: wta(UNDEFINED, "bad cxr name", (char *)name); case 'a': code = (code<<2) + 1; continue; case 'd': code = (code<<2) + 2; continue; } type += (code << 8); } CAR(z) = (isubr<<16) + type; SUBRF(z) = fcn; return z; } SCM make_subr(name, type, fcn) const char *name; int type; SCM (*fcn)(); { return CDR(sysintern(name, scm_maksubr(name, type, fcn))); } #ifdef CCLO char s_comp_clo[] = "compiled-closure"; SCM makcclo(proc, len) SCM proc; long len; { SCM s; # ifndef SHORT_SIZET ASRTER(len < (((unsigned long)-1L)>>16), UNDEFINED, NALLOC, s_comp_clo); # endif DEFER_INTS; s = must_malloc_cell(len*sizeof(SCM), MAKE_NUMDIGS(len, tc16_cclo), s_comp_clo); while (--len) VELTS(s)[len] = UNSPECIFIED; CCLO_SUBR(s) = proc; ALLOW_INTS; return s; } #endif void stack_check() { STACKITEM *start = CONT(rootcont)->stkbse; STACKITEM stack; #ifdef STACK_GROWS_UP if (&stack - start > STACK_LIMIT/sizeof(STACKITEM)) #else if (start - &stack > STACK_LIMIT/sizeof(STACKITEM)) #endif /* def STACK_GROWS_UP */ { stack_report(); wta(UNDEFINED, (char *)SEGV_SIGNAL, "stack"); } } void stack_report() { STACKITEM stack; lputs(";; stack: 0x", cur_errp); scm_intprint((long)CONT(rootcont)->stkbse, -16, cur_errp); lputs(" - 0x", cur_errp); scm_intprint((long)&stack, -16, cur_errp); lputs("; ", cur_errp); scm_intprint(stack_size(CONT(rootcont)->stkbse)*sizeof(STACKITEM), 10, cur_errp); lputs(" bytes\n", cur_errp); } SCM dynwind(thunk1, thunk2, thunk3) SCM thunk1, thunk2, thunk3; { SCM ans; apply(thunk1, EOL, EOL); dynwinds = acons(thunk1, thunk3, dynwinds); ans = apply(thunk2, EOL, EOL); dynwinds = CDR(dynwinds); apply(thunk3, EOL, EOL); return ans; } void downd(to, delta) SCM to; long delta; { tail: if (dynwinds==to); else if (0 > delta) { downd(CDR(to), 1+delta); apply(CAR(CAR(to)), EOL, EOL); dynwinds = to; } else { SCM from = CDR(CAR(dynwinds)); dynwinds = CDR(dynwinds); apply(from, EOL, EOL); delta--; goto tail; /* downd(to, delta-1); */ } } void dowinds(to) SCM to; { downd(to, ilength(dynwinds) - ilength(to)); } /* Remember that setjump needs to be called after scm_make_cont */ SCM scm_make_cont() { SCM cont, estk, *from; CONTINUATION *ncont; sizet n; VERIFY_INTS("scm_make_cont", 0L); NEWCELL(cont); from = VELTS(scm_estk); n = scm_estk_ptr - from + SCM_ESTK_FRLEN; #ifdef CHEAP_CONTINUATIONS estk = scm_estk; #else from[1] = BOOL_F; /* Can't write to parent stack */ estk = must_malloc_cell((long)n*sizeof(SCM), MAKE_LENGTH(n, tc7_vector), s_cont); { SCM *to = VELTS(estk); while(n--) to[n] = from[n]; } #endif 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; ncont->other.stkframe[0] = scm_env; ncont->other.stkframe[1] = scm_env_tmp; ncont->other.estk = estk; #ifdef CHEAP_CONTINUATIONS ncont->other.estk_ptr = scm_estk_ptr; #else ncont->other.estk_ptr = (SCM *)0; #endif #ifndef RECKLESS ncont->other.stkframe[2] = scm_trace_env; ncont->other.stkframe[3] = scm_trace; #endif return cont; } static char s_sstale[] = "strangely stale"; void scm_dynthrow(tocont, arg1, arg2, rest) SCM tocont; SCM arg1, arg2, rest; { CONTINUATION *cont = CONT(tocont); if (cont->stkbse != CONT(rootcont)->stkbse) wta(tocont, &s_sstale[10], s_cont); dowinds(cont->other.dynenv); { DEFER_INTS; #ifdef CHEAP_CONTINUATIONS scm_estk = cont->other.estk; scm_estk_ptr = cont->other.estk_ptr; #else { SCM *to, *from = VELTS(cont->other.estk); sizet n = LENGTH(cont->other.estk); if (LENGTH(scm_estk) < n) scm_estk_reset(n); to = VELTS(scm_estk); scm_estk_ptr = &(to[n - SCM_ESTK_FRLEN]); while(n--) to[n] = from[n]; } #endif scm_env = cont->other.stkframe[0]; scm_env_tmp = cont->other.stkframe[1]; #ifndef RECKLESS scm_trace_env = cont->other.stkframe[2]; scm_trace = cont->other.stkframe[3]; #endif if (!UNBNDP(arg2) && IM_VALUES_TOKEN == scm_env_tmp) { scm_env_cons(arg2, rest); arg2 = UNDEFINED; } ALLOW_INTS; } if (!UNBNDP(arg2)) return; /* eval will signal wrong number of args */ throw_to_continuation(cont, arg1, CONT(rootcont)); wta(tocont, s_sstale, s_cont); } SCM obhash(obj) SCM obj; { #ifdef BIGDIG long n = SRS(obj, 1); if (!FIXABLE(n)) return long2big(n); #endif return (obj<<1)+2L; } SCM obunhash(obj) SCM obj; { #ifdef BIGDIG if (NIMP(obj) && BIGP(obj)) { sizet i = NUMDIGS(obj); BIGDIG *ds = BDIGITS(obj); if (TYP16(obj)==tc16_bigpos) { obj = 0; while (i--) obj = BIGUP(obj) + ds[i]; } else { obj = 0; while (i--) obj = BIGUP(obj) - ds[i]; } obj <<= 1; goto comm; } #endif ASRTER(INUMP(obj), obj, ARG1, s_obunhash); obj = SRS(obj, 1) & ~1L; comm: if (IMP(obj)) return obj; if (NCELLP(obj)) return BOOL_F; { /* This code is adapted from mark_locations() in "sys.c" and scm_cell_p() in "rope.c", which means that changes to these routines must be coordinated. */ register CELLPTR ptr = (CELLPTR)SCM2PTR(obj); register sizet i = 0, j = hplim_ind; do { if (PTR_GT(hplims[i++], ptr)) break; if (PTR_LE(hplims[--j], ptr)) break; if ((i != j) && PTR_LE(hplims[i++], ptr) && PTR_GT(hplims[--j], ptr)) continue; if (NFREEP(obj)) return obj; break; } while(i5) { sizet i = 5; unsigned long h = 264 % n; while (i--) h = ((h<<8) + ((unsigned)(downcase[str[h % len]]))) % n; return h; } else { sizet i = len; unsigned long h = 0; while (i) h = ((h<<8) + ((unsigned)(downcase[str[--i]]))) % n; return h; } } static void fixconfig(s1, s2, s) char *s1, *s2; int s; { fputs(s1, stderr); fputs(s2, stderr); fputs("\nin ", stderr); fputs(s ? "setjump" : "scmfig", stderr); fputs(".h and recompile scm\n", stderr); quit(MAKINUM(1L)); } void heap_report() { sizet i = 0; if (hplim_ind) lputs("; heap segments:", sys_errp); while(i < hplim_ind) { { long seg_cells = CELL_DN(hplims[i+1]) - CELL_UP(hplims[i]); lputs("\n; 0x", sys_errp); scm_intprint((long)hplims[i++], -16, sys_errp); lputs(" - 0x", sys_errp); scm_intprint((long)hplims[i++], -16, sys_errp); lputs("; ", sys_errp); scm_intprint(seg_cells, 10, sys_errp); lputs(" cells; ", sys_errp); scm_intprint(seg_cells / (1024 / sizeof(CELLPTR)), 10, sys_errp); lputs(".kiB", sys_errp); }} } sizet init_heap_seg(seg_org, size) CELLPTR seg_org; sizet size; { register CELLPTR ptr = seg_org; #ifdef POINTERS_MUNGED register SCM scmptr; #else # define scmptr ptr #endif CELLPTR seg_end = CELL_DN((char *)ptr + size); sizet i = hplim_ind, ni = 0; if (ptr==NULL) return 0; while((ni < hplim_ind) && PTR_LE(hplims[ni], seg_org)) ni++; while(i-- > ni) hplims[i+2] = hplims[i]; hplim_ind += 2; hplims[ni++] = ptr; /* same as seg_org here */ hplims[ni++] = seg_end; ptr = CELL_UP(ptr); ni = seg_end - ptr; /* printf("ni = %u; hplim_ind = %u\n", ni, hplim_ind); */ /* printf("ptr = %lx\n", ptr); */ for (i = ni;i--;ptr++) { #ifdef POINTERS_MUNGED scmptr = PTR2SCM(ptr); #endif CAR(scmptr) = (SCM)tc_free_cell; CDR(scmptr) = PTR2SCM(ptr+1); } /* CDR(scmptr) = freelist; */ CDR(PTR2SCM(--ptr)) = freelist; freelist = PTR2SCM(CELL_UP(seg_org)); heap_cells += ni; return size; #ifdef scmptr # undef scmptr #endif } static void alloc_some_heap() { CELLPTR ptr, *tmplims; 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); 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_cells)*sizeof(cell)); if ((sizet)(EXPHEAP(heap_cells)*sizeof(cell)) != len) len = 0; } else len = HEAP_SEG_SIZE; while (len >= MIN_HEAP_SEG_SIZE) { SYSCALL(ptr = (CELLPTR) malloc(len);); if (ptr) { init_heap_seg(ptr, len); return; } len /= 2; } wta(UNDEFINED, s_nogrow, s_heap); } /* Initialize a Growable arRAy, of initial size LEN, growing to at most MAXLEN elements of size ELTSIZE */ void scm_init_gra(gra, eltsize, len, maxlen, what) scm_gra *gra; sizet eltsize, len, maxlen; const char *what; { char *nelts; /* DEFER_INTS; */ /* Can't call must_malloc, because heap may not be initialized yet. */ /* SYSCALL(nelts = malloc(len*eltsize);); if (!nelts) wta(MAKINUM(len*eltsize), (char *)NALLOC, what); mallocated += len*eltsize; */ nelts = must_malloc((long)len*eltsize, what); gra->eltsize = eltsize; gra->len = 0; gra->elts = nelts; gra->alloclen = len; gra->maxlen = maxlen; gra->what = what; /* ALLOW_INTS; */ } /* Returns the index into the elt array */ int scm_grow_gra(gra, elt) scm_gra *gra; char *elt; { int i; char *tmp; if (gra->alloclen <= gra->len) { sizet inc = gra->len / 5 + 1; sizet nlen = gra->len + inc; if (gra->maxlen && nlen > gra->maxlen) /* growerr: */ wta(MAKINUM(nlen), (char *)NALLOC, gra->what); /* SYSCALL(tmp = realloc(gra->elts, nlen*gra->eltsize);); if (!tmp) goto growerr; mallocated += (nlen - gra->alloclen)*gra->eltsize; */ tmp = must_realloc(gra->elts, (long)gra->alloclen*gra->eltsize, (long)nlen*gra->eltsize, gra->what); gra->elts = tmp; gra->alloclen = nlen; } tmp = &gra->elts[gra->len*gra->eltsize]; gra->len += 1; for (i = 0; i < gra->eltsize; i++) tmp[i] = elt[i]; return gra->len - 1; } void scm_trim_gra(gra) scm_gra *gra; { char *tmp; long curlen = gra->len; if (0L==curlen) curlen = 1L; if (curlen==(long)gra->alloclen) return; tmp = must_realloc(gra->elts, (long)gra->alloclen * gra->eltsize, curlen * gra->eltsize, gra->what); gra->elts = tmp; gra->alloclen = curlen; } void scm_free_gra(gra) scm_gra *gra; { free(gra->elts); gra->elts = 0; mallocated -= gra->maxlen*gra->eltsize; } void gra_report1(gra) scm_gra *gra; { scm_intprint((long)gra->len, -10, cur_errp); lputs(" (of ", cur_errp); scm_intprint((long)gra->alloclen, -10, cur_errp); lputs(") ", cur_errp); lputs(gra->what, cur_errp); lputs("; ", cur_errp); } void gra_report() { lputs(";; gra: ", cur_errp); gra_report1(&ptobs_gra); gra_report1(&smobs_gra); gra_report1(&finals_gra); gra_report1(&subrs_gra); lputs("\n", cur_errp); } scm_gra smobs_gra; long newsmob(smob) smobfuns *smob; { return tc7_smob + 256*scm_grow_gra(&smobs_gra, (char *)smob); } scm_gra ptobs_gra; long newptob(ptob) ptobfuns *ptob; { return tc7_port + 256*scm_grow_gra(&ptobs_gra, (char *)ptob); } port_info *scm_port_table = 0; static sizet scm_port_table_len = 0; static char s_port_table[] = "port table"; SCM scm_port_entry(stream, ptype, flags) FILE *stream; long ptype, flags; { SCM z; sizet nlen; int i, j; VERIFY_INTS("scm_port_entry", 0L); flags = flags | (ptype & ~0xffffL); ASRTER(flags, INUM0, ARG1, "scm_port_entry"); for (i = 1; i < scm_port_table_len; i++) if (0L==scm_port_table[i].flags) goto ret; if (scm_port_table_len <= SCM_PORTNUM_MAX) { nlen = scm_port_table_len + (scm_port_table_len / 2); if (nlen >= SCM_PORTNUM_MAX) nlen = (sizet)SCM_PORTNUM_MAX + 1; scm_port_table = (port_info *) must_realloc((char *)scm_port_table, (long)scm_port_table_len * sizeof(port_info), (long)nlen * sizeof(port_info), s_port_table); scm_port_table_len = nlen; growth_mon(s_port_table, nlen + 0L, "entries", !0); for (j = i; j < scm_port_table_len; j++) { scm_port_table[j].flags = 0L; scm_port_table[j].data = UNDEFINED; scm_port_table[j].port = UNDEFINED; } } else { igc(s_port_table, rootcont); for (i = 0; i < scm_port_table_len; i++) if (0L==scm_port_table[i].flags) goto ret; wta(UNDEFINED, s_nogrow, s_port_table); } ret: NEWCELL(z); SETSTREAM(z, stream); CAR(z) = (((long)i)<<20) | (flags & 0x0f0000) | ptype; scm_port_table[i].unread = EOF; scm_port_table[i].flags = flags; scm_port_table[i].line = 1L; /* should both be one-based? */ scm_port_table[i].col = 1; scm_port_table[i].data = UNSPECIFIED; scm_port_table[i].port = z; return z; } SCM scm_open_ports() { SCM p, res = EOL; int k; for (k = scm_port_table_len - 1; k > 0; k--) { p = scm_port_table[k].port; if (NIMP(p) && OPPORTP(p)) res = cons(p, res); } return res; } SCM markcdr(ptr) SCM ptr; { return CDR(ptr); } sizet free0(ptr) CELLPTR ptr; { return 0; } SCM equal0(ptr1, ptr2) SCM ptr1, ptr2; { return (CDR(ptr1)==CDR(ptr2)) ? BOOL_T : BOOL_F; } static char remsg[] = "remove\n#define ", addmsg[] = "add\n#define ", rdmsg[] = "reduce"; void init_storage(stack_start_ptr, init_heap_size) STACKITEM *stack_start_ptr; long init_heap_size; { sizet j; /* Because not all protects may get initialized */ freelist = EOL; expmem = 0; estk_pool = EOL; scm_estk = BOOL_F; scm_port_table = 0; scm_port_table_len = 0; #ifdef SHORT_SIZET if (sizeof(sizet) >= sizeof(long)) fixconfig(remsg, "SHORT_SIZET", 0); #else if (sizeof(sizet) < sizeof(long)) fixconfig(addmsg, "SHORT_SIZET", 0); #endif #ifdef SHORT_INT if (sizeof(int) >= sizeof(long)) fixconfig(remsg, "SHORT_INT", 0); #else if (sizeof(int) < sizeof(long)) fixconfig(addmsg, "SHORT_INT", 0); #endif #ifdef CDR_DOUBLES if (sizeof(double) != sizeof(long)) fixconfig(remsg, "CDR_DOUBLES", 0); #else # ifdef SINGLES if (sizeof(float) != sizeof(long)) { if (sizeof(double) == sizeof(long)) fixconfig(addmsg, "CDR_DOUBLES", 0); else fixconfig(remsg, "SINGLES", 0); } # endif #endif #ifdef BIGDIG if (2*BITSPERDIG/CHAR_BIT > sizeof(long)) fixconfig(remsg, "BIGDIG", 0); # ifndef DIGSTOOBIG if (DIGSPERLONG*sizeof(BIGDIG) > sizeof(long)) fixconfig(addmsg, "DIGSTOOBIG", 0); # endif if (NUMDIGS_MAX > (((unsigned long)-1L)>>16)) fixconfig(rdmsg, "NUMDIGS_MAX", 0); #endif #ifdef STACK_GROWS_UP if (((STACKITEM *)&j - stack_start_ptr) < 0) fixconfig(remsg, "STACK_GROWS_UP", 1); #else if ((stack_start_ptr - (STACKITEM *)&j) < 0) fixconfig(addmsg, "STACK_GROWS_UP", 1); #endif j = HEAP_SEG_SIZE; if (HEAP_SEG_SIZE != j) fixconfig(rdmsg, "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; /* printf("j = %u; init_heap_size = %lu\n", j, init_heap_size); */ if ((init_heap_size != j) || !init_heap_seg((CELLPTR) malloc(j), j)) { j = HEAP_SEG_SIZE; /* printf("j = %u; HEAP_SEG_SIZE = %lu\n", j, HEAP_SEG_SIZE); */ if (!init_heap_seg((CELLPTR) malloc(j), j)) wta(MAKINUM(j), (char *)NALLOC, s_heap); } else expmem = 1; heap_org = CELL_UP(hplims[0]); /* hplims[0] can change. do not remove heap_org */ scm_port_table_len = 16; scm_port_table = (port_info *) must_malloc((long)scm_port_table_len * sizeof(port_info), s_port_table); for (j = 0; j < scm_port_table_len; j++) { scm_port_table[j].flags = 0L; scm_port_table[j].data = UNDEFINED; scm_port_table[j].port = UNDEFINED; } nullstr = must_malloc_cell(1L, MAKE_LENGTH(0, tc7_string), s_string); CHARS(nullstr)[0] = 0; nullvect = must_malloc_cell(1L, MAKE_LENGTH(0, tc7_vector), s_vector); { long i = symhash_dim; SCM *velts; symhash = must_malloc_cell(i * sizeof(SCM), MAKE_LENGTH(i, tc7_vector), s_vector); velts = VELTS(symhash); while(--i >= 0) (velts)[i] = EOL; } /* Now that symhash is setup, we can sysintern() */ sysintern("most-positive-fixnum", (SCM)MAKINUM(MOST_POSITIVE_FIXNUM)); sysintern("most-negative-fixnum", (SCM)MAKINUM(MOST_NEGATIVE_FIXNUM)); #ifdef BIGDIG sysintern("bignum-radix", MAKINUM(BIGRAD)); #endif def_inp = scm_port_entry(stdin, tc16_fport, OPN|RDNG); SCM_PORTDATA(def_inp) = CAR(sysintern("stdin", UNDEFINED)); def_outp = scm_port_entry(stdout, tc16_fport, OPN|WRTNG|TRACKED); SCM_PORTDATA(def_outp) = CAR(sysintern("stdout", UNDEFINED)); NEWCELL(def_errp); CAR(def_errp) = (tc16_fport|OPN|WRTNG); SETSTREAM(def_errp, stderr); 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); sys_safep = mksafeport(0, def_errp); 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; listofnull = cons(EOL, EOL); undefineds = cons(UNDEFINED, EOL); CDR(undefineds) = undefineds; /* 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 = BOOL_F; scm_estk_reset(0); } /* The way of garbage collecting which allows use of the cstack is due to */ /* Scheme In One Defun, but in C this time. * COPYRIGHT (c) 1989 BY * * PARADIGM ASSOCIATES INCORPORATED, CAMBRIDGE, MASSACHUSETTS. * * ALL RIGHTS RESERVED * Permission to use, copy, modify, distribute and sell this software and its documentation for any purpose and without fee is hereby granted, provided that the above copyright notice appear in all copies and that both that copyright notice and this permission notice appear in supporting documentation, and that the name of Paradigm Associates Inc not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. PARADIGM DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL PARADIGM BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. gjc@paradigm.com Paradigm Associates Inc Phone: 617-492-6079 29 Putnam Ave, Suite 6 Cambridge, MA 02138 */ char s_cells[] = "cells"; SCM gc_for_newcell() { SCM fl; int oints = ints_disabled; /* Temporary expedient */ if (!oints) ints_disabled = 1; igc(s_cells, rootcont); 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); } ++cells_allocated; fl = freelist; freelist = CDR(fl); ints_disabled = oints; return fl; } void gc_for_open_files() { igc("open files", rootcont); } void scm_fill_freelist() { while IMP(freelist) { igc(s_cells, rootcont); 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 "; 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 mark_subrs P((void)); static void sweep_symhash P((SCM v)); static void mark_finalizers P((SCM *live, SCM *dead)); static void mark_port_table P((SCM port)); static void sweep_port_table P((void)); static void egc_mark P((void)); static void egc_sweep P((void)); SCM gc(arg) SCM arg; { DEFER_INTS; if (UNBNDP(arg)) igc("call", rootcont); else scm_egc(); ALLOW_INTS; return UNSPECIFIED; } void scm_run_finalizers(exiting) int exiting; { SCM f; if (exiting) { /* run all finalizers, we're going home. */ DEFER_INTS; while NIMP(gc_finalizers) { f = CAR(gc_finalizers); CAR(f) = CDR(f); CDR(f) = gc_finalizers_pending; gc_finalizers_pending = f; gc_finalizers = CDR(gc_finalizers); } ALLOW_INTS; } while (!0) { DEFER_INTS; if (NIMP(gc_finalizers_pending)) { f = CAR(gc_finalizers_pending); gc_finalizers_pending = CDR(gc_finalizers_pending); } else f = BOOL_F; ALLOW_INTS; if (IMP(f)) break; apply(f, EOL, EOL); } } static SCM *loc_gc_hook = 0; void scm_gc_hook () { if (gc_hook_active) { scm_warn("gc-hook thrashing?\n", "", UNDEFINED); return; } gc_hook_active = !0; if (! loc_gc_hook) loc_gc_hook = &CDR(sysintern("gc-hook", UNDEFINED)); if (NIMP(*loc_gc_hook)) apply(*loc_gc_hook, EOL, EOL); scm_run_finalizers(0); gc_hook_active = 0; } void igc(what, basecont) const char *what; SCM basecont; { int j = num_protects; long oheap_cells = heap_cells; STACKITEM * stackbase = IMP(basecont) ? 0 : CONT(basecont)->stkbse; #ifdef DEBUG_GMALLOC int err = check_frag_blocks(); if (err) wta(MAKINUM(err), "malloc corrupted", what); #endif gc_start(what); if (errjmp_bad) wta(UNDEFINED, s_recursive, s_gc); errjmp_bad = s_gc; #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. */ mark_sym_values(symhash); #endif mark_subrs(); egc_mark(); if (stackbase) { #ifdef __ia64__ mark_regs_ia64(CONT(basecont)); #else jump_buf save_regs_gc_mark; FLUSH_REGISTER_WINDOWS; /* This assumes that all registers are saved into the jump_buf */ setjump(save_regs_gc_mark); mark_locations((STACKITEM *) save_regs_gc_mark, (sizet) (sizeof(STACKITEM) - 1 + sizeof save_regs_gc_mark) / sizeof(STACKITEM)); { /* stack_len is long rather than sizet in order to guarantee that &stack_len is long aligned */ # ifdef STACK_GROWS_UP # ifdef nosve long stack_len = (STACKITEM *)(&stack_len) - stackbase; # else long stack_len = stack_size(stackbase); # endif mark_locations(stackbase, (sizet)stack_len); # else # ifdef nosve long stack_len = stackbase - (STACKITEM *)(&stack_len); # else long stack_len = stack_size(stackbase); # endif mark_locations((stackbase - stack_len), (sizet)stack_len); # endif } #endif } while(j--) gc_mark(sys_protects[j]); mark_finalizers(&gc_finalizers, &gc_finalizers_pending); #ifndef NO_SYM_GC sweep_symhash(symhash); #endif gc_sweep(!stackbase); sweep_port_table(); egc_sweep(); estk_pool = EOL; errjmp_bad = (char *)0; gc_end(); 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); } gc_hook_pending = !0; deferred_proc = process_signals; } static char s_not_free[] = "not freed"; void free_storage() { DEFER_INTS; loc_gc_hook = (SCM *)0; gc_start("free"); errjmp_bad = "free_storage"; 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 */ gc_sweep(0); rootcont = BOOL_F; while (hplim_ind) { /* free heap segments */ hplim_ind -= 2; { CELLPTR ptr = CELL_UP(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_cells, s_cells, 0); fflush(stderr); }} 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"); */ /* 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"); */ hplims = 0; scm_free_gra(&finals_gra); scm_free_gra(&smobs_gra); scm_free_gra(&subrs_gra); gc_end(); ALLOW_INTS; /* A really bad idea, but printing does it anyway. */ exit_report(); lfflush(sys_errp); scm_free_gra(&ptobs_gra); 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 */ ) wta(ptr, "rogue pointer in ", s_heap); switch TYP7(ptr) { case tcs_cons_nimcar: if (GCMARKP(ptr)) break; SETGCMARK(ptr); if (IMP(CDR(ptr))) { /* IMP works even with a GC mark */ ptr = CAR(ptr); goto gc_mark_nimp; } gc_mark(CAR(ptr)); ptr = GCCDR(ptr); goto gc_mark_nimp; case tcs_cons_imcar: case tcs_cons_gloc: if (GCMARKP(ptr)) break; SETGCMARK(ptr); ptr = GCCDR(ptr); goto gc_mark_loop; case tcs_closures: if (GCMARKP(ptr)) break; SETGCMARK(ptr); if (IMP(GCENV(ptr))) { ptr = CODE(ptr); goto gc_mark_nimp; } gc_mark(CODE(ptr)); ptr = GCENV(ptr); goto gc_mark_nimp; case tc7_specfun: if (GC8MARKP(ptr)) break; SETGC8MARK(ptr); #ifdef 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); if (i==0) break; while(--i>0) if (NIMP(VELTS(ptr)[i])) gc_mark(VELTS(ptr)[i]); ptr = VELTS(ptr)[0]; goto gc_mark_loop; case tc7_contin: if (GC8MARKP(ptr)) break; SETGC8MARK(ptr); mark_locations((STACKITEM *)VELTS(ptr), (sizet)(LENGTH(ptr) + (sizeof(STACKITEM) - 1 + sizeof(CONTINUATION)) / sizeof(STACKITEM))); break; case tc7_string: case tc7_msymbol: if (GC8MARKP(ptr)) break; ASRTER(!(CHARS(ptr)[HUGE_LENGTH(ptr)]), MAKINUM(HUGE_LENGTH(ptr)), s_wrong_length, s_gc); case tc7_ssymbol: case tc7_Vbool: case tc7_VfixZ32: case tc7_VfixN32: case tc7_VfixZ16: case tc7_VfixN16: case tc7_VfixN8: case tc7_VfixZ8: case tc7_VfloR32: case tc7_VfloC32: case tc7_VfloR64: case tc7_VfloC64: SETGC8MARK(ptr); case tcs_subrs: break; case tc7_port: if (GC8MARKP(ptr)) break; SETGC8MARK(ptr); i = PTOBNUM(ptr); if (!(i < numptob)) goto def; mark_port_table(ptr); if (!ptobs[i].mark) break; ptr = (ptobs[i].mark)(ptr); goto gc_mark_loop; case tc7_smob: if (GC8MARKP(ptr)) break; SETGC8MARK(ptr); switch TYP16(ptr) { /* should be faster than going through smobs */ case tc_free_cell: /* printf("found free_cell %X ", ptr); fflush(stdout); */ ASRTER(tc_broken_heart!=CAR(ptr), ptr, "found ecache forward", s_gc); /* CDR(ptr) = UNDEFINED */; break; #ifdef BIGDIG case tcs_bignums: break; #endif #ifdef FLOATS case tc16_flo: break; #endif default: i = SMOBNUM(ptr); if (!(i < numsmob)) goto def; SETGC8MARK(ptr); if (!smobs[i].mark) break; ptr = (smobs[i].mark)(ptr); goto gc_mark_loop; } break; default: def: wta(ptr, s_bad_type, "gc_mark"); } } /* mark_locations() marks a location pointed to by x[0:n] only if `x[m]' is cell-aligned and points into a valid heap segment. This code is duplicated by obunhash() in "sys.c" and scm_cell_p() in "rope.c", which means that changes to these routines must be coordinated. */ void mark_locations(x, n) STACKITEM x[]; sizet n; { register long m = n; register int i, j; register CELLPTR ptr; while(0 <= --m) if (CELLP(*(SCM **)&x[m])) { ptr = (CELLPTR)SCM2PTR((SCM)(*(SCM **)&x[m])); i = 0; j = hplim_ind; do { if (PTR_GT(hplims[i++], ptr)) break; if (PTR_LE(hplims[--j], ptr)) break; if ((i != j) && PTR_LE(hplims[i++], ptr) && PTR_GT(hplims[--j], ptr)) continue; /* if (NFREEP(*(SCM **)&x[m])) */ gc_mark(*(SCM *)&x[m]); break; } while(ilength) scm_warn("uncollected ", "", scmptr); goto c8mrkcontinue; } minc = LENGTH(scmptr)*sizeof(STACKITEM) + sizeof(CONTINUATION); mallocated = mallocated - minc; free_continuation(CONT(scmptr)); break; /* goto freechars; */ case tc7_ssymbol: if (GC8MARKP(scmptr)) goto c8mrkcontinue; /* Do not free storage because tc7_ssymbol means scmptr's storage was not created by a call to malloc(). */ break; case tcs_subrs: continue; case tc7_port: if (GC8MARKP(scmptr)) goto c8mrkcontinue; if (OPENP(scmptr)) { int k = PTOBNUM(scmptr); if (!(k < numptob)) goto sweeperr; /* Yes, I really do mean ptobs[k].free */ /* rather than ptobs[k].close. .close */ /* is for explicit CLOSE-PORT by user */ (ptobs[k].free)(STREAM(scmptr)); gc_ports_collected++; SETSTREAM(scmptr, 0); CAR(scmptr) &= ~OPN; } break; case tc7_smob: switch GCTYP16(scmptr) { case tc_free_cell: if (GC8MARKP(scmptr)) goto c8mrkcontinue; break; #ifdef BIGDIG case tcs_bignums: if (GC8MARKP(scmptr)) goto c8mrkcontinue; minc = (NUMDIGS(scmptr)*sizeof(BIGDIG)); goto freechars; #endif /* def BIGDIG */ #ifdef FLOATS case tc16_flo: if (GC8MARKP(scmptr)) goto c8mrkcontinue; switch ((int)(CAR(scmptr)>>16)) { case (IMAG_PART | REAL_PART)>>16: minc = 2*sizeof(double); goto freechars; case REAL_PART>>16: case IMAG_PART>>16: minc = sizeof(double); goto freechars; case 0: break; default: goto sweeperr; } break; #endif /* def FLOATS */ default: if (GC8MARKP(scmptr)) goto c8mrkcontinue; { int k = SMOBNUM(scmptr); if (!(k < numsmob)) goto sweeperr; minc = (smobs[k].free)((CELLPTR)scmptr); } } break; default: sweeperr: wta(scmptr, s_bad_type, "gc_sweep"); } ++n; CAR(scmptr) = (SCM)tc_free_cell; CDR(scmptr) = nfreelist; nfreelist = scmptr; continue; c8mrkcontinue: CLRGC8MARK(scmptr); continue; cmrkcontinue: CLRGCMARK(scmptr); } #ifdef GC_FREE_SEGMENTS 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; i -= 2; /* need to scan segment just moved. */ nfreelist = freelist; } else #endif /* ifdef GC_FREE_SEGMENTS */ freelist = nfreelist; gc_cells_collected += n; n = 0; } lcells_allocated += (heap_cells - gc_cells_collected - cells_allocated); cells_allocated = (heap_cells - gc_cells_collected); gc_malloc_collected = (pre_m - mallocated); lmallocated = lmallocated - gc_malloc_collected; } #ifndef NO_SYM_GC /* mark_syms marks those symbols of hash table V which have non-UNDEFINED values. */ static void mark_syms(v) SCM v; { SCM x, al; int k = LENGTH(v); while (k--) for (al = VELTS(v)[k]; NIMP(al); al = GCCDR(al)) { /* If this bucket has already been marked, then something is wrong. */ ASRTER(!GCMARKP(al), al, s_bad_type, s_gc_sym); x = CAR(al); SETGCMARK(al); /* Do mark bucket list */ # ifdef CAREFUL_INTS ASRTER(NIMP(x) && NIMP(CAR(x)) && !GCMARKP(x), x, s_bad_type, s_gc_sym); ASRTER(!GC8MARKP(CAR(x)) && !(CHARS(CAR(x))[LENGTH(CAR(x))]), CAR(x), s_wrong_length, s_gc_sym); ASRTER(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)); used: /* SETGCMARK(x) */; /* Don't mark value cell. */ /* We used to mark the value cell, but value cells get returned by calls to intern(). This caused a rare GC leak which only showed up in large programs. */ } SETGC8MARK(v); /* Mark bucket vector. */ } /* mark_symhash marks the values of hash table V. */ static void mark_sym_values(v) SCM v; { SCM x, al; int k = LENGTH(v); /* SETGC8MARK(v); */ /* already set by mark_syms */ while (k--) for (al = VELTS(v)[k]; NIMP(al); al = GCCDR(al)) { x = GCCDR(CAR(al)); if (IMP(x)) continue; gc_mark(x); } } /* Splice any unused valueless symbols out of the hash buckets. */ static void sweep_symhash(v) SCM v; { SCM al, x, *lloc; int k = LENGTH(v); while (k--) { lloc = &(VELTS(v)[k]); while NIMP(al = (*lloc & ~1L)) { x = CAR(al); if (GC8MARKP(CAR(x))) { lloc = &(CDR(al)); SETGCMARK(x); } else { *lloc = CDR(al); CLRGCMARK(al); /* bucket pair to be collected by gc_sweep */ CLRGCMARK(x); /* value cell to be collected by gc_sweep */ gc_syms_collected++; } } VELTS(v)[k] &= ~1L; /* We may have deleted the first cell */ } } #endif /* This function should be called after all other marking is done. */ static void mark_finalizers(finalizers, pending) SCM *finalizers, *pending; { SCM lst, elt, v; SCM live = EOL, undead = *finalizers; int more_to_do = !0; gc_mark(*pending); while NIMP(*pending) pending = &CDR(*pending); while (more_to_do) { more_to_do = 0; lst = undead; undead = EOL; while (NIMP(lst)) { elt = CAR(lst); v = CAR(elt); switch (TYP3(v)) { default: if (GCMARKP(v)) goto marked; goto unmarked; case tc3_tc7_types: if (GC8MARKP(v)) { marked: gc_mark(CDR(elt)); more_to_do = !0; v = lst; lst = CDR(lst); CDR(v) = live; live = v; } else { unmarked: v = lst; lst = CDR(lst); CDR(v) = undead; undead = v; } break; } } } gc_mark(live); for (lst = undead; NIMP(lst); lst = CDR(lst)) CAR(lst) = CDR(CAR(lst)); gc_mark(undead); *finalizers = live; *pending = undead; } static void mark_subrs() { /* subr_info *table = subrs; */ /* int k = subrs_gra.len; */ /* while (k--) { } */ } static void mark_port_table(port) SCM port; { int i = SCM_PORTNUM(port); ASRTER(i>=0 && i 0; k--) { if (scm_port_table[k].flags & 1) scm_port_table[k].flags &= (~1L); else { scm_port_table[k].flags = 0L; scm_port_table[k].data = UNDEFINED; scm_port_table[k].port = UNDEFINED; } } } /* 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); } } /* Under some circumstances I don't fully understand, continuations may point to dead ecache cells. This prevents gc marked cells from causing errors during ecache gc. */ for (i = scm_ecache_index; i--;) { scm_ecache[i].car = UNSPECIFIED; scm_ecache[i].cdr = UNSPECIFIED; } } #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_locations(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])); } } } static void egc_copy_stack(stk, len) SCM stk; sizet len; { while (!0) { egc_copy_locations(VELTS(stk), len); len = INUM(SCM_ESTK_PARENT_INDEX(stk)) + SCM_ESTK_FRLEN; stk =SCM_ESTK_PARENT(stk); if (IMP(stk)) return; /* len = LENGTH(stk); */ } } 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 = CAR(x); if (NIMP(e) && ECACHEP(e)) egc_copy(&(CAR(x))); break; default: if (tc7_contin==TYP7(x)) { egc_copy_locations(CONT(x)->other.stkframe, 2); #ifndef CHEAP_CONTINUATIONS x = CONT(x)->other.estk; egc_copy_stack(x, LENGTH(x)); #endif 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; static int egc_need_gc() { SCM fl = freelist; int n; if (heap_cells - cells_allocated <= scm_ecache_len) return 1; /* Interrupting a NEWCELL could leave cells_allocated inconsistent with freelist, see handle_it() in repl.c */ for (n = 4; n; n--) { if (IMP(fl)) return 1; fl = CDR(fl); } return 0; } void scm_egc() { VERIFY_INTS("scm_egc", 0L); /* 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 (egc_need_gc()) { igc("ecache", rootcont); 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) wta(UNDEFINED, s_recursive, s_cache_gc); { SCM stkframe[2]; long lcells = cells_allocated; sizet nstk = (scm_estk_ptr - VELTS(scm_estk) + SCM_ESTK_FRLEN); ASRTER(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_locations(stkframe, sizeof(stkframe)/sizeof(SCM)); egc_copy_stack(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 = (char *)0; }