/* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997 Free Software Foundation, Inc. * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2, 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 General Public License for more details. * * You should have received a copy of the GNU General Public License * along with this software; see the file COPYING. If not, write to * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. * * As a special exception, the Free Software Foundation gives permission * for additional uses of the text contained in its release of GUILE. * * The exception is that, if you link the GUILE library with other files * to produce an executable, this does not by itself cause the * resulting executable to be covered by the GNU General Public License. * Your use of that executable is in no way restricted on account of * linking the GUILE library code into it. * * This exception does not however invalidate any other reasons why * the executable file might be covered by the GNU General Public License. * * This exception applies only to the code released by the * Free Software Foundation under the name GUILE. If you copy * code from other Free Software Foundation releases into a copy of * GUILE, as the General Public License permits, the exception does * not apply to the code that you add in this way. To avoid misleading * anyone as to the status of such modified files, you must delete * this exception notice from them. * * If you write modifications of your own for GUILE, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ /* "sys.c" opening and closing files, storage, and GC. */ #include #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. */ #ifndef STDC_HEADERS char *ttyname P((int fd)); char *tmpnam P((char *s)); sizet fwrite (); # ifdef sun # ifndef __svr4__ int fputs P((char *s, FILE* stream)); int fputc P((char c, FILE* stream)); int fflush P((FILE* stream)); # endif # 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 #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_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 # include # endif # endif # endif # endif # endif # endif # endif #endif /* __IBMC__ */ SCM i_setbuf0(port) /* should be called with DEFER_INTS active */ SCM port; { #ifndef NOSETBUF # ifndef MSDOS # ifdef FIONREAD # ifndef ultrix SYSCALL(setbuf(STREAM(port), 0);); # endif # endif # endif #endif return UNSPECIFIED; } long mode_bits(modes) char *modes; { return OPN | (strchr(modes, 'r') || strchr(modes, '+') ? RDNG : 0) | (strchr(modes, 'w') || strchr(modes, 'a') || strchr(modes, '+') ? WRTNG : 0) | (strchr(modes, '0') ? BUF0 : 0); } SCM try_open_file(filename, modes) SCM filename, modes; { register SCM port; FILE *f; ASSERT(NIMP(filename) && STRINGP(filename), filename, ARG1, s_open_file); ASSERT(NIMP(modes) && STRINGP(modes), modes, ARG2, s_open_file); NEWCELL(port); DEFER_INTS; SYSCALL(f = fopen(CHARS(filename), CHARS(modes));); if (!f) port = BOOL_F; else { SETSTREAM(port, f); if (BUF0 & (CAR(port) = tc16_fport | mode_bits(CHARS(modes)))) i_setbuf0(port); } ALLOW_INTS; 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; { sizet i; ASSERT(NIMP(port) && PORTP(port), port, ARG1, s_close_port); if CLOSEDP(port) return UNSPECIFIED; i = PTOBNUM(port); DEFER_INTS; if (ptobs[i].fclose) { SYSCALL((ptobs[i].fclose)(STREAM(port));); } CAR(port) &= ~OPN; ALLOW_INTS; return UNSPECIFIED; } 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; } #if (__TURBOC__==1) # undef L_tmpnam /* Not supported in TURBOC V1.0 */ #endif #ifdef GO32 # undef L_tmpnam #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; ASSERT(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; { 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 if (OPENP(exp) && tc16_fport==TYP16(exp) && isatty(fileno(STREAM(exp)))) lputs(ttyname(fileno(STREAM(exp))), port); else # endif # endif # endif # endif #endif if OPFPORTP(exp) intprint((long)fileno(STREAM(exp)), 10, port); else intprint(CDR(exp), -16, port); lputc('>', port); } static int prinfport(exp, port, writing) SCM exp; SCM port; int writing; { prinport(exp, port, s_port_type); return !0; } static int prinstpt(exp, port, writing) SCM exp; SCM port; int writing; { prinport(exp, port, s_string); return !0; } static int prinsfpt(exp, port, writing) SCM exp; SCM port; int writing; { prinport(exp, port, "soft"); return !0; } 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]; } int noop0(stream) FILE *stream; { return 0; } SCM mkstrport(pos, str, modes, caller) SCM pos; SCM str; long modes; char *caller; { SCM z; ASSERT(INUMP(pos) && INUM(pos) >= 0, pos, ARG1, caller); ASSERT(NIMP(str) && (STRINGP(str) || SYMBOLP(str)), str, ARG1, caller); str = cons(pos, str); NEWCELL(z); DEFER_INTS; SETCHARS(z, str); CAR(z) = 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 = { mark0, fclose, 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}; ptobfuns pipob = { mark0, 0, /* replaced by pclose in init_ioext() */ 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() */ static ptobfuns stptob = { markcdr, noop0, prinstpt, 0, stputc, stputs, stwrite, noop0, stgetc, 0}; /* 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; { apply(VELTS(p)[0], MAKICHR(c), listofnull); errno = 0; return c; } sizet sfwrite(str, siz, num, p) sizet siz, num; char *str; SCM p; { SCM sstr; sstr = makfromstr(str, siz * num); apply(VELTS(p)[1], sstr, listofnull); 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 = apply(VELTS(p)[3], EOL, EOL); errno = 0; if (FALSEP(ans) || EOF_VAL==ans) return EOF; ASSERT(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; ASSERT(NIMP(pv) && VECTORP(pv) && 5==LENGTH(pv), pv, ARG1, s_mksfpt); ASSERT(NIMP(modes) && STRINGP(modes), modes, ARG2, s_mksfpt); NEWCELL(z); DEFER_INTS; CAR(z) = tc16_sfport | mode_bits(CHARS(modes)); SETSTREAM(z, pv); ALLOW_INTS; return z; } static ptobfuns sfptob = { markcdr, noop0, prinsfpt, 0, sfputc, sfputs, sfwrite, sfflush, 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, freeprint, 0}; static smobfuns flob = { mark0, /*flofree*/0, floprint, floequal}; static smobfuns bigob = { mark0, /*bigfree*/0, bigprint, bigequal}; void (**finals)() = 0; sizet num_finals = 0; static char s_final[] = "final"; void init_types() { numptob = 0; ptobs = (ptobfuns *)malloc(4*sizeof(ptobfuns)); /* 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_sysport = newptob(&sysptob); numsmob = 0; smobs = (smobfuns *)malloc(7*sizeof(smobfuns)); /* These newsmob calls must be done in this order */ newsmob(&freecell); newsmob(&flob); newsmob(&bigob); newsmob(&bigob); finals = (void(**)())malloc(2 * sizeof(finals[0])); num_finals = 0; } void add_final(final) void (* final)(); { DEFER_INTS; finals = (void (**)()) must_realloc((char *)finals, (long)(num_finals)*sizeof(finals[0]), (1L+num_finals)*sizeof(finals[0]), s_final); finals[num_finals++] = final; ALLOW_INTS; return; } 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}, */ {"tmpnam", ltmpnam}, {0, 0}}; static iproc subr1s[] = { {s_input_portp, input_portp}, {s_output_portp, output_portp}, {s_close_port, close_port}, {"eof-object?", eof_objectp}, {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}, {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(intern(s_try_open_file, sizeof(s_try_open_file)-1)))); #ifndef CHEAP_CONTINUATIONS add_feature("full-continuation"); #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 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; 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; 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) { #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 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); 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; return CAR(lsym); trynext: ; } lsym = makfromstr(name, len); DEFER_INTS; SETLENGTH(lsym, (long)len, tc7_msymbol); ALLOW_INTS; z = acons(lsym, UNDEFINED, UNDEFINED); DEFER_INTS; /* Operations on symhash must be atomic. */ 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); CDR(lsym) = val; return lsym; 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]; 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; DEFER_INTS; s = must_malloc_cell(len+1, s_string); SETLENGTH(s, len, tc7_string); CHARS(s)[len] = 0; ALLOW_INTS; return s; } SCM make_subr(name, type, fcn) const char *name; int type; SCM (*fcn)(); { SCM symcell = sysintern(name, UNDEFINED); long tmp = ((((CELLPTR)(CAR(symcell)))-heap_org)<<8); register SCM z; if ((tmp>>8) != ((CELLPTR)(CAR(symcell))-heap_org)) tmp = 0; NEWCELL(z); CAR(z) = tmp + type; SUBRF(z) = fcn; CDR(symcell) = z; return z; } #ifdef CCLO SCM makcclo(proc, len) SCM proc; long len; { SCM s; DEFER_INTS; 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; return s; } #endif #ifdef STACK_LIMIT 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"); } } #endif void stack_report() { STACKITEM stack; lputs(";; stack: 0x", cur_errp); intprint((long)CONT(rootcont)->stkbse, -16, cur_errp); lputs(" - 0x", 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) 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 dowinds(to, delta) SCM to; long delta; { tail: if (dynwinds==to); else if (0 > delta) { dowinds(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; /* dowinds(to, delta-1); */ } } /* Remember that setjump needs to be called after scm_make_cont */ SCM scm_make_cont() { SCM cont, env, *from, *to; CONTINUATION *ncont; sizet n; VERIFY_INTS("scm_make_cont", 0); NEWCELL(cont); 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; ncont->other.env = env; return cont; } static char s_sstale[] = "strangely stale"; void scm_dynthrow(cont, val) CONTINUATION *cont; SCM val; { if (cont->stkbse != CONT(rootcont)->stkbse) wta(cont->other.dynenv, &s_sstale[10], s_cont); dowinds(cont->other.dynenv, ilength(dynwinds)-ilength(cont->other.dynenv)); { 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); } 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 ASSERT(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)); } 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; 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); } smobfuns *smobs; sizet numsmob; long newsmob(smob) smobfuns *smob; { char *tmp; if (255 <= numsmob) goto smoberr; DEFER_INTS; SYSCALL(tmp = (char *)realloc((char *)smobs, (1+numsmob)*sizeof(smobfuns));); if (tmp) { smobs = (smobfuns *)tmp; smobs[numsmob].mark = smob->mark; smobs[numsmob].free = smob->free; smobs[numsmob].print = smob->print; smobs[numsmob].equalp = smob->equalp; numsmob++; } ALLOW_INTS; if (!tmp) smoberr: wta(MAKINUM((long)numsmob), (char *)NALLOC, "newsmob"); return tc7_smob + (numsmob-1)*256; } ptobfuns *ptobs; sizet numptob; long newptob(ptob) ptobfuns *ptob; { char *tmp; if (255 <= numptob) goto ptoberr; DEFER_INTS; SYSCALL(tmp = (char *)realloc((char *)ptobs, (1+numptob)*sizeof(ptobfuns));); if (tmp) { ptobs = (ptobfuns *)tmp; ptobs[numptob].mark = ptob->mark; ptobs[numptob].free = ptob->free; ptobs[numptob].print = ptob->print; ptobs[numptob].equalp = ptob->equalp; ptobs[numptob].fputc = ptob->fputc; ptobs[numptob].fputs = ptob->fputs; ptobs[numptob].fwrite = ptob->fwrite; ptobs[numptob].fflush = ptob->fflush; ptobs[numptob].fgetc = ptob->fgetc; ptobs[numptob].fclose = ptob->fclose; numptob++; } ALLOW_INTS; if (!tmp) ptoberr: wta(MAKINUM((long)numptob), (char *)NALLOC, "newptob"); return tc7_port + (numptob-1)*256; } SCM markcdr(ptr) SCM ptr; { if GC8MARKP(ptr) return BOOL_F; SETGC8MARK(ptr); return CDR(ptr); } SCM mark0(ptr) SCM ptr; { SETGC8MARK(ptr); return BOOL_F; } sizet free0(ptr) CELLPTR ptr; { return 0; } SCM equal0(ptr1, ptr2) SCM ptr1, ptr2; { return (CDR(ptr1)==CDR(ptr2)) ? BOOL_T : BOOL_F; } /* 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 */ void init_storage(stack_start_ptr, init_heap_size) STACKITEM *stack_start_ptr; long init_heap_size; { sizet j = num_protects; /* Because not all protects may get initialized */ while(j) sys_protects[--j] = BOOL_F; 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; #ifdef SHORT_INT if (sizeof(int) >= sizeof(long)) fixconfig(remsg, "SHORT_INT", 1); #else if (sizeof(int) < sizeof(long)) fixconfig(addmsg, "SHORT_INT", 1); #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 #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("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; if ((init_heap_size != j) || !init_heap_seg((CELLPTR) malloc(j), j)) { 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 */ NEWCELL(def_inp); CAR(def_inp) = (tc16_fport|OPN|RDNG); SETSTREAM(def_inp, stdin); NEWCELL(def_outp); CAR(def_outp) = (tc16_fport|OPN|WRTNG); SETSTREAM(def_outp, stdout); 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); 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; nullstr = makstr(0L); nullvect = make_vector(INUM0, UNDEFINED); /* NEWCELL(nullvect); CAR(nullvect) = tc7_vector; SETCHARS(nullvect, NULL); */ symhash = make_vector((SCM)MAKINUM(symhash_dim), EOL); 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 /* 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 */ /* 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, 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); } ++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(arg) SCM arg; { DEFER_INTS; if UNBNDP(arg) igc("call", CONT(rootcont)->stkbse); else scm_egc(); ALLOW_INTS; return UNSPECIFIED; } void igc(what, stackbase) char *what; STACKITEM *stackbase; { int j = num_protects; long oheap_cells = heap_cells; gc_start(what); if (++errjmp_bad > 1) 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. */ mark_sym_values(symhash); #endif egc_mark(); if (stackbase) { 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 } } 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_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); } } static char s_not_free[] = "not freed"; void free_storage() { DEFER_INTS; gc_start("free"); ++errjmp_bad; 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"); */ #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"); */ hplims = 0; /* must_free((char *)smobs, numsmob * sizeof(smobfuns)); */ free((char *)smobs); smobs = 0; gc_end(); ALLOW_INTS; /* A really bad idea, but printing does it anyway. */ exit_report(); 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 */ ) 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; 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: SETGC8MARK(ptr); case tcs_subrs: break; case tc7_port: i = PTOBNUM(ptr); if (!(i < numptob)) goto def; ptr = (ptobs[i].mark)(ptr); goto gc_mark_loop; case tc7_smob: if GC8MARKP(ptr) break; switch TYP16(ptr) { /* should be faster than going through smobs */ case tc_free_cell: /* printf("found free_cell %X ", ptr); fflush(stdout); */ SETGC8MARK(ptr); 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; 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 **)&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) { warn("uncollected ", (char *)0); iprin1(scmptr, cur_errp, 1); lputc('\n', cur_errp); lfflush(cur_errp); } goto c8mrkcontinue; } minc = LENGTH(scmptr)*sizeof(STACKITEM) + sizeof(CONTINUATION); 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 ftobs[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; # ifdef NUM_HP if (NUMDIGS(scmptr)*sizeof(BIGDIG) <= NUM_HP_MAX_REQ) break; # endif /* def NUM_HP */ minc = (NUMDIGS(scmptr)*BITSPERDIG/CHAR_BIT); goto freechars; #endif /* def BIGDIG */ #ifdef FLOATS case tc16_flo: if GC8MARKP(scmptr) goto c8mrkcontinue; # ifndef NUM_HP switch ((int)(CAR(scmptr)>>16)) { case (IMAG_PART | REAL_PART)>>16: 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; } # endif /* ndef NUM_HP */ #endif /* def FLOATS */ break; 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); 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 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. */ ASSERT(!GCMARKP(al), al, s_bad_type, s_gc_sym); x = CAR(al); SETGCMARK(al); /* Do mark bucket list */ # 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)); 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 /* 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; }