From: Daniel Barlow Date: Tue, 6 Aug 2002 11:46:32 +0000 (+0000) Subject: 0.7.6.12: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=9f10bc102adce15a820027777a03e49a7b7623da;p=sbcl.git 0.7.6.12: merge gc-cleanup-branch --- diff --git a/CREDITS b/CREDITS index 5937017..d7de58c 100644 --- a/CREDITS +++ b/CREDITS @@ -243,7 +243,7 @@ Also, Christopher Hoover and William Lott wrote compiler/generic/vm-macs.lisp to centralize information about machine-dependent macros and constants. Sean Hallgren is credited with most of the Alpha backend. Julian -Dolby created the CMU CL Alpha/linux port. Douglas Crosher added +Dolby created the CMU CL Alpha/Linux port. Douglas Crosher added complex-float support. The original PPC backend was the work of Gary Byers. Some bug fixes @@ -552,9 +552,7 @@ Espen S Johnsen: Arthur Lemmens: He found and fixed a number of SBCL bugs while partially porting - SBCL to bootstrap under . + SBCL to bootstrap under Lispworks for Windows Robert MacLachlan: He has continued to answer questions about, and contribute fixes to, diff --git a/doc/sbcl.1 b/doc/sbcl.1 index 0fcc298..aeb686c 100644 --- a/doc/sbcl.1 +++ b/doc/sbcl.1 @@ -169,7 +169,7 @@ SAVE-LISP does. (Why doesn't SBCL support more extensions? Why drop all those nice extensions from CMU CL when the code already exists? This is a -frequently asked question on the mailing list. In other cases, it's a +frequently asked question on the mailing list. In some cases, it's a design philosophy issue: arguably SBCL has done its job by supplying a stable FFI, and the right design decision is to move functionality derived from that, like socket support, into separate libraries, diff --git a/src/compiler/x86/cell.lisp b/src/compiler/x86/cell.lisp index f34e9ac..c3cfb86 100644 --- a/src/compiler/x86/cell.lisp +++ b/src/compiler/x86/cell.lisp @@ -116,13 +116,8 @@ (:generator 2 ;; The symbol-hash slot of NIL holds NIL because it is also the ;; cdr slot, so we have to strip off the two low bits to make sure - ;; it is a fixnum. - ;; - ;; FIXME: Is this still true? It seems to me from my reading of - ;; the DEFINE-PRIMITIVE-OBJECT in objdef.lisp that the symbol-hash - ;; is the second slot, and offset 0 = tags and stuff (and CAR slot in - ;; a CONS), offset 1 = value slot (and CDR slot in a CONS), and - ;; offset 2 = hash slot. + ;; it is a fixnum. The lowtag selection magic that is required to + ;; ensure this is explained in the comment in objdef.lisp (loadw res symbol symbol-hash-slot other-pointer-lowtag) (inst and res (lognot #b11)))) diff --git a/src/runtime/Config.alpha-linux b/src/runtime/Config.alpha-linux index 61f4739..7f59edb 100644 --- a/src/runtime/Config.alpha-linux +++ b/src/runtime/Config.alpha-linux @@ -21,4 +21,4 @@ OS_SRC = linux-os.c alpha-linux-os.c os-common.c LINKFLAGS+=-rdynamic # -static OS_LIBS= -ldl -GC_SRC= gc.c +GC_SRC= cheneygc.c diff --git a/src/runtime/Config.alpha-osf1 b/src/runtime/Config.alpha-osf1 index 02c8e14..675a566 100644 --- a/src/runtime/Config.alpha-osf1 +++ b/src/runtime/Config.alpha-osf1 @@ -27,4 +27,4 @@ ARCH_SRC = alpha-arch.c undefineds.c OS_SRC = osf1-os.c alpha-osf1-os.c os-common.c OS_LIBS= #-ldl -GC_SRC= gc.c +GC_SRC= cheneygc.c diff --git a/src/runtime/Config.ppc-linux b/src/runtime/Config.ppc-linux index f48e72b..d7a2393 100644 --- a/src/runtime/Config.ppc-linux +++ b/src/runtime/Config.ppc-linux @@ -19,4 +19,4 @@ OS_SRC = linux-os.c ppc-linux-os.c os-common.c LINKFLAGS+=-rdynamic OS_LIBS= -ldl -GC_SRC= gc.c +GC_SRC= cheneygc.c diff --git a/src/runtime/Config.sparc-linux b/src/runtime/Config.sparc-linux index ebcb8d6..a62e359 100644 --- a/src/runtime/Config.sparc-linux +++ b/src/runtime/Config.sparc-linux @@ -22,4 +22,4 @@ OS_SRC = linux-os.c sparc-linux-os.c os-common.c LINKFLAGS+=-rdynamic OS_LIBS= -ldl -GC_SRC= gc.c +GC_SRC= cheneygc.c diff --git a/src/runtime/Config.sparc-sunos b/src/runtime/Config.sparc-sunos index bbe9537..d72252e 100644 --- a/src/runtime/Config.sparc-sunos +++ b/src/runtime/Config.sparc-sunos @@ -24,4 +24,4 @@ OS_SRC = sunos-os.c sparc-sunos-os.c os-common.c LINKFLAGS+= OS_LIBS= -ldl -lsocket -lnsl -GC_SRC= gc.c +GC_SRC= cheneygc.c diff --git a/src/runtime/Config.x86-bsd b/src/runtime/Config.x86-bsd index b0f7d88..a7c026e 100644 --- a/src/runtime/Config.x86-bsd +++ b/src/runtime/Config.x86-bsd @@ -16,4 +16,3 @@ OS_SRC = bsd-os.c os-common.c undefineds.c OS_LIBS = -lm # -ldl GC_SRC = gencgc.c -CFLAGS += -DGENCGC diff --git a/src/runtime/Config.x86-linux b/src/runtime/Config.x86-linux index 0171ac5..b83f2b0 100644 --- a/src/runtime/Config.x86-linux +++ b/src/runtime/Config.x86-linux @@ -27,4 +27,4 @@ OS_LINK_FLAGS = -Wl,--export-dynamic OS_LIBS = -ldl GC_SRC = gencgc.c -CFLAGS += -DGENCGC + diff --git a/src/runtime/GNUmakefile b/src/runtime/GNUmakefile index bf32c7a..29fd1aa 100644 --- a/src/runtime/GNUmakefile +++ b/src/runtime/GNUmakefile @@ -36,7 +36,7 @@ include Config C_SRCS =alloc.c backtrace.c breakpoint.c coreparse.c \ - dynbind.c globals.c interr.c interrupt.c \ + dynbind.c gc-common.c globals.c interr.c interrupt.c \ monitor.c parse.c print.c purify.c \ regnames.c run-program.c runtime.c save.c search.c \ time.c util.c validate.c vars.c wrap.c diff --git a/src/runtime/alloc.c b/src/runtime/alloc.c index 0e0a438..00a24f1 100644 --- a/src/runtime/alloc.c +++ b/src/runtime/alloc.c @@ -30,7 +30,7 @@ #define ALIGNED_SIZE(n) (n+LOWTAG_MASK) & ~LOWTAG_MASK -#if defined GENCGC +#if defined LISP_FEATURE_GENCGC extern lispobj *alloc(int bytes); #else static lispobj * @@ -74,7 +74,7 @@ alloc_vector(int type, int length, int size) result->header = type; result->length = make_fixnum(length); - return ((lispobj)result)|OTHER_POINTER_LOWTAG; + return make_lispobj(result,OTHER_POINTER_LOWTAG); } lispobj @@ -85,7 +85,7 @@ alloc_cons(lispobj car, lispobj cdr) ptr->car = car; ptr->cdr = cdr; - return (lispobj)ptr | LIST_POINTER_LOWTAG; + return make_lispobj(ptr, LIST_POINTER_LOWTAG); } lispobj @@ -100,7 +100,7 @@ alloc_number(long n) ptr->digits[0] = n; - return (lispobj) ptr | OTHER_POINTER_LOWTAG; + return make_lispobj(ptr, OTHER_POINTER_LOWTAG); } } @@ -124,5 +124,5 @@ alloc_sap(void *ptr) sap=(struct sap *) alloc_unboxed((int)SAP_WIDETAG, sizeof(struct sap)/sizeof(lispobj) -1); sap->pointer = ptr; - return (lispobj) sap | OTHER_POINTER_LOWTAG; + return make_lispobj(sap,OTHER_POINTER_LOWTAG); } diff --git a/src/runtime/alpha-linux-os.c b/src/runtime/alpha-linux-os.c index 45c9ffb..80c8913 100644 --- a/src/runtime/alpha-linux-os.c +++ b/src/runtime/alpha-linux-os.c @@ -39,10 +39,6 @@ #include "validate.h" size_t os_vm_page_size; -#if defined GENCGC /* unlikely ... */ -#error SBCL Alpha does not work with the GENCGC -#include "gencgc.h" -#endif os_context_register_t * os_context_register_addr(os_context_t *context, int offset) diff --git a/src/runtime/alpha-osf1-os.c b/src/runtime/alpha-osf1-os.c index 8610500..14362c8 100644 --- a/src/runtime/alpha-osf1-os.c +++ b/src/runtime/alpha-osf1-os.c @@ -41,10 +41,6 @@ #include "validate.h" size_t os_vm_page_size; -#if defined GENCGC /* unlikely ... */ -#error SBCL Alpha does not work with the GENCGC -#include "gencgc.h" -#endif os_context_register_t * os_context_register_addr(os_context_t *context, int offset) diff --git a/src/runtime/bsd-os.c b/src/runtime/bsd-os.c index 54a1c00..707ea9a 100644 --- a/src/runtime/bsd-os.c +++ b/src/runtime/bsd-os.c @@ -37,9 +37,6 @@ #include "validate.h" vm_size_t os_vm_page_size; -#if defined GENCGC -#include "gencgc.h" -#endif /* The different BSD variants have diverged in exactly where they * store signal context information, but at least they tend to use the @@ -204,15 +201,7 @@ is_valid_lisp_addr(os_vm_address_t addr) * any OS-dependent special low-level handling for signals */ -#if !defined GENCGC - -void -os_install_interrupt_handlers(void) -{ - SHOW("os_install_interrupt_handlers()/bsd-os/!defined(GENCGC)"); -} - -#else +#if defined LISP_FEATURE_GENCGC /* * The GENCGC needs to be hooked into whatever signal is raised for @@ -246,4 +235,12 @@ os_install_interrupt_handlers(void) SHOW("leaving os_install_interrupt_handlers()"); } -#endif /* !defined GENCGC */ +#else +/* As of 2002.07.31, this configuration has never been tested */ +void +os_install_interrupt_handlers(void) +{ + SHOW("os_install_interrupt_handlers()/bsd-os/!defined(GENCGC)"); +} + +#endif /* defined GENCGC */ diff --git a/src/runtime/cheneygc-internal.h b/src/runtime/cheneygc-internal.h new file mode 100644 index 0000000..a5aa1d7 --- /dev/null +++ b/src/runtime/cheneygc-internal.h @@ -0,0 +1,50 @@ +extern lispobj *from_space; +extern lispobj *from_space_free_pointer; + +extern lispobj *new_space; +extern lispobj *new_space_free_pointer; + + +/* predicates */ +/* #if defined(DEBUG_SPACE_PREDICATES) */ +#if 0 +boolean +from_space_p(lispobj object) +{ + lispobj *ptr; + + /* this can be called for untagged pointers as well as for + descriptors, so this assertion's not applicable + gc_assert(is_lisp_pointer(object)); + */ + ptr = (lispobj *) native_pointer(object); + + return ((from_space <= ptr) && + (ptr < from_space_free_pointer)); +} + +boolean +new_space_p(lispobj object) +{ + lispobj *ptr; + + /* gc_assert(is_lisp_pointer(object)); */ + + ptr = (lispobj *) native_pointer(object); + + return ((new_space <= ptr) && + (ptr < new_space_free_pointer)); +} + +#else + +#define from_space_p(ptr) \ + ((from_space <= ((lispobj *) ((pointer_sized_uint_t) ptr))) && \ + (((lispobj *) ((pointer_sized_uint_t) ptr))< from_space_free_pointer)) + +#define new_space_p(ptr) \ + ((new_space <= ((lispobj *) ((pointer_sized_uint_t) ptr))) && \ + (((lispobj *) ((pointer_sized_uint_t) ptr)) < new_space_free_pointer)) + +#endif + diff --git a/src/runtime/cheneygc.c b/src/runtime/cheneygc.c new file mode 100644 index 0000000..894fc5c --- /dev/null +++ b/src/runtime/cheneygc.c @@ -0,0 +1,630 @@ +/* + * stop and copy GC based on Cheney's algorithm + */ + +/* + * This software is part of the SBCL system. See the README file for + * more information. + * + * This software is derived from the CMU CL system, which was + * written at Carnegie Mellon University and released into the + * public domain. The software is in the public domain and is + * provided with absolutely no warranty. See the COPYING and CREDITS + * files for more information. + */ + +#include +#include +#include +#include +#include "runtime.h" +#include "sbcl.h" +#include "os.h" +#include "gc.h" +#include "gc-internal.h" +#include "globals.h" +#include "interrupt.h" +#include "validate.h" +#include "lispregs.h" +#include "interr.h" + +/* So you need to debug? */ +#if 0 +#define PRINTNOISE +#define DEBUG_SPACE_PREDICATES +#define DEBUG_SCAVENGE_VERBOSE +#define DEBUG_COPY_VERBOSE +#define DEBUG_CODE_GC +#endif + +lispobj *from_space; +lispobj *from_space_free_pointer; + +lispobj *new_space; +lispobj *new_space_free_pointer; + +static void scavenge_newspace(void); +static void scavenge_interrupt_contexts(void); + + +/* collecting garbage */ + +#ifdef PRINTNOISE +static double +tv_diff(struct timeval *x, struct timeval *y) +{ + return (((double) x->tv_sec + (double) x->tv_usec * 1.0e-6) - + ((double) y->tv_sec + (double) y->tv_usec * 1.0e-6)); +} +#endif + +#define BYTES_ZERO_BEFORE_END (1<<12) + +/* FIXME do we need this? Doesn't it duplicate lisp code in + * scrub-control-stack? */ + +static void +zero_stack(void) +{ + u32 *ptr = (u32 *)current_control_stack_pointer; + search: + do { + if (*ptr) + goto fill; + ptr++; + } while (((unsigned long)ptr) & (BYTES_ZERO_BEFORE_END-1)); + return; + fill: + do { + *ptr++ = 0; + } while (((unsigned long)ptr) & (BYTES_ZERO_BEFORE_END-1)); + + goto search; +} + + +void * +gc_general_alloc(int bytes, int unboxed_p, int quick_p) { + lispobj *new=new_space_free_pointer; + new_space_free_pointer+=(bytes/4); + return new; +} + +lispobj copy_large_unboxed_object(lispobj object, int nwords) { + return copy_object(object,nwords); +} +lispobj copy_unboxed_object(lispobj object, int nwords) { + return copy_object(object,nwords); +} +lispobj copy_large_object(lispobj object, int nwords) { + return copy_object(object,nwords); +} + +/* Note: The generic GC interface we're implementing passes us a + * last_generation argument. That's meaningless for us, since we're + * not a generational GC. So we ignore it. */ +void +collect_garbage(unsigned ignore) +{ +#ifdef PRINTNOISE + struct timeval start_tv, stop_tv; + struct rusage start_rusage, stop_rusage; + double real_time, system_time, user_time; + double percent_retained, gc_rate; + unsigned long size_discarded; + unsigned long size_retained; +#endif + lispobj *current_static_space_free_pointer; + unsigned long static_space_size; + unsigned long control_stack_size, binding_stack_size; + sigset_t tmp, old; + +#ifdef PRINTNOISE + printf("[Collecting garbage ... \n"); + + getrusage(RUSAGE_SELF, &start_rusage); + gettimeofday(&start_tv, (struct timezone *) 0); +#endif + + sigemptyset(&tmp); + sigaddset_blockable(&tmp); + sigprocmask(SIG_BLOCK, &tmp, &old); + + current_static_space_free_pointer = + (lispobj *) ((unsigned long) + SymbolValue(STATIC_SPACE_FREE_POINTER)); + + + /* Set up from space and new space pointers. */ + + from_space = current_dynamic_space; + from_space_free_pointer = dynamic_space_free_pointer; + +#ifdef PRINTNOISE + fprintf(stderr,"from_space = %lx\n", + (unsigned long) current_dynamic_space); +#endif + if (current_dynamic_space == (lispobj *) DYNAMIC_0_SPACE_START) + new_space = (lispobj *)DYNAMIC_1_SPACE_START; + else if (current_dynamic_space == (lispobj *) DYNAMIC_1_SPACE_START) + new_space = (lispobj *) DYNAMIC_0_SPACE_START; + else { + lose("GC lossage. Current dynamic space is bogus!\n"); + } + new_space_free_pointer = new_space; + + /* Initialize the weak pointer list. */ + weak_pointers = (struct weak_pointer *) NULL; + + + /* Scavenge all of the roots. */ +#ifdef PRINTNOISE + printf("Scavenging interrupt contexts ...\n"); +#endif + scavenge_interrupt_contexts(); + +#ifdef PRINTNOISE + printf("Scavenging interrupt handlers (%d bytes) ...\n", + (int)sizeof(interrupt_handlers)); +#endif + scavenge((lispobj *) interrupt_handlers, + sizeof(interrupt_handlers) / sizeof(lispobj)); + + /* _size quantities are in units of sizeof(lispobj) - i.e. 4 */ + control_stack_size = + current_control_stack_pointer- + (lispobj *)CONTROL_STACK_START; +#ifdef PRINTNOISE + printf("Scavenging the control stack at %p (%ld words) ...\n", + ((lispobj *)CONTROL_STACK_START), + control_stack_size); +#endif + scavenge(((lispobj *)CONTROL_STACK_START), control_stack_size); + + + binding_stack_size = + current_binding_stack_pointer - + (lispobj *)BINDING_STACK_START; +#ifdef PRINTNOISE + printf("Scavenging the binding stack %x - %x (%d words) ...\n", + BINDING_STACK_START,current_binding_stack_pointer, + (int)(binding_stack_size)); +#endif + scavenge(((lispobj *)BINDING_STACK_START), binding_stack_size); + + static_space_size = + current_static_space_free_pointer - (lispobj *) STATIC_SPACE_START; +#ifdef PRINTNOISE + printf("Scavenging static space %x - %x (%d words) ...\n", + STATIC_SPACE_START,current_static_space_free_pointer, + (int)(static_space_size)); +#endif + scavenge(((lispobj *)STATIC_SPACE_START), static_space_size); + + /* Scavenge newspace. */ +#ifdef PRINTNOISE + printf("Scavenging new space (%d bytes) ...\n", + (int)((new_space_free_pointer - new_space) * sizeof(lispobj))); +#endif + scavenge_newspace(); + + +#if defined(DEBUG_PRINT_GARBAGE) + print_garbage(from_space, from_space_free_pointer); +#endif + + /* Scan the weak pointers. */ +#ifdef PRINTNOISE + printf("Scanning weak pointers ...\n"); +#endif + scan_weak_pointers(); + + + /* Flip spaces. */ +#ifdef PRINTNOISE + printf("Flipping spaces ...\n"); +#endif + + os_zero((os_vm_address_t) current_dynamic_space, + (os_vm_size_t) DYNAMIC_SPACE_SIZE); + + current_dynamic_space = new_space; + dynamic_space_free_pointer = new_space_free_pointer; + +#ifdef PRINTNOISE + size_discarded = (from_space_free_pointer - from_space) * sizeof(lispobj); + size_retained = (new_space_free_pointer - new_space) * sizeof(lispobj); +#endif + + /* Zero stack. */ +#ifdef PRINTNOISE + printf("Zeroing empty part of control stack ...\n"); +#endif + zero_stack(); + + sigprocmask(SIG_SETMASK, &old, 0); + + +#ifdef PRINTNOISE + gettimeofday(&stop_tv, (struct timezone *) 0); + getrusage(RUSAGE_SELF, &stop_rusage); + + printf("done.]\n"); + + percent_retained = (((float) size_retained) / + ((float) size_discarded)) * 100.0; + + printf("Total of %ld bytes out of %ld bytes retained (%3.2f%%).\n", + size_retained, size_discarded, percent_retained); + + real_time = tv_diff(&stop_tv, &start_tv); + user_time = tv_diff(&stop_rusage.ru_utime, &start_rusage.ru_utime); + system_time = tv_diff(&stop_rusage.ru_stime, &start_rusage.ru_stime); + +#if 0 + printf("Statistics:\n"); + printf("%10.2f sec of real time\n", real_time); + printf("%10.2f sec of user time,\n", user_time); + printf("%10.2f sec of system time.\n", system_time); +#else + printf("Statistics: %10.2fs real, %10.2fs user, %10.2fs system.\n", + real_time, user_time, system_time); +#endif + + gc_rate = ((float) size_retained / (float) (1<<20)) / real_time; + + printf("%10.2f M bytes/sec collected.\n", gc_rate); +#endif + /* os_flush_icache((os_vm_address_t) 0, sizeof(unsigned long)); */ + /* Maybe FIXME: it's possible that we could significantly reduce + * RSS by zeroing the from_space or madvise(MADV_DONTNEED) or + * similar os-dependent tricks here */ +} + + +/* scavenging */ + +static void +scavenge_newspace(void) +{ + lispobj *here, *next; + + here = new_space; + while (here < new_space_free_pointer) { + /* printf("here=%lx, new_space_free_pointer=%lx\n", + here,new_space_free_pointer); */ + next = new_space_free_pointer; + scavenge(here, next - here); + here = next; + } + /* printf("done with newspace\n"); */ +} + +/* scavenging interrupt contexts */ + +static int boxed_registers[] = BOXED_REGISTERS; + +static void +scavenge_interrupt_context(os_context_t *context) +{ + int i; +#ifdef reg_LIP + unsigned long lip; + unsigned long lip_offset; + int lip_register_pair; +#endif + unsigned long pc_code_offset; +#ifdef ARCH_HAS_LINK_REGISTER + unsigned long lr_code_offset; +#endif +#ifdef ARCH_HAS_NPC_REGISTER + unsigned long npc_code_offset; +#endif +#ifdef DEBUG_SCAVENGE_VERBOSE + fprintf(stderr, "Scavenging interrupt context at 0x%x\n",context); +#endif + /* Find the LIP's register pair and calculate its offset */ + /* before we scavenge the context. */ +#ifdef reg_LIP + lip = *os_context_register_addr(context, reg_LIP); + /* 0x7FFFFFFF or 0x7FFFFFFFFFFFFFFF ? */ + lip_offset = 0x7FFFFFFF; + lip_register_pair = -1; + for (i = 0; i < (sizeof(boxed_registers) / sizeof(int)); i++) { + unsigned long reg; + long offset; + int index; + + index = boxed_registers[i]; + reg = *os_context_register_addr(context, index); + /* would be using PTR if not for integer length issues */ + if ((reg & ~((1L<code must always be the + * last slot in the object + + * FIXME (2) it also appears in purify.c, and it has a different value + * for SPARC users in that bit + */ + +#define FUN_RAW_ADDR_OFFSET (6*sizeof(lispobj) - FUN_POINTER_LOWTAG) + +/* Note: on the sparc we don't have to do anything special for fdefns, */ +/* 'cause the raw-addr has a function lowtag. */ +#ifndef LISP_FEATURE_SPARC +static int +scav_fdefn(lispobj *where, lispobj object) +{ + struct fdefn *fdefn; + + fdefn = (struct fdefn *)where; + + if ((char *)(fdefn->fun + FUN_RAW_ADDR_OFFSET) + == (char *)((unsigned long)(fdefn->raw_addr))) { + scavenge(where + 1, sizeof(struct fdefn)/sizeof(lispobj) - 1); + fdefn->raw_addr = + (u32) ((char *) LOW_WORD(fdefn->fun)) + FUN_RAW_ADDR_OFFSET; + return sizeof(struct fdefn) / sizeof(lispobj); + } + else + return 1; +} +#endif + + + +/* vector-like objects */ + +/* #define NWORDS(x,y) (CEILING((x),(y)) / (y)) */ + +static int +scav_vector(lispobj *where, lispobj object) +{ + if (HeaderValue(object) == subtype_VectorValidHashing) { + *where = + (subtype_VectorMustRehash< + * as + * . + */ + +#include +#include +#include "runtime.h" +#include "sbcl.h" +#include "os.h" +#include "interr.h" +#include "globals.h" +#include "interrupt.h" +#include "validate.h" +#include "lispregs.h" +#include "arch.h" +#include "gc.h" +#include "gc-internal.h" + +#ifdef LISP_FEATURE_SPARC +#define LONG_FLOAT_SIZE 4 +#else +#ifdef LISP_FEATURE_X86 +#define LONG_FLOAT_SIZE 3 +#endif +#endif + +inline static boolean +forwarding_pointer_p(lispobj *pointer) { + lispobj first_word=*pointer; +#ifdef LISP_FEATURE_GENCGC + return (first_word == 0x01); +#else + return (is_lisp_pointer(first_word) + && new_space_p(first_word)); +#endif +} + +static inline lispobj * +forwarding_pointer_value(lispobj *pointer) { +#ifdef LISP_FEATURE_GENCGC + return (lispobj *) ((pointer_sized_uint_t) pointer[1]); +#else + return (lispobj *) ((pointer_sized_uint_t) pointer[0]); +#endif +} +static inline lispobj +set_forwarding_pointer(lispobj * pointer, lispobj newspace_copy) { +#ifdef LISP_FEATURE_GENCGC + pointer[0]=0x01; + pointer[1]=newspace_copy; +#else + pointer[0]=newspace_copy; +#endif + return newspace_copy; +} + +int (*scavtab[256])(lispobj *where, lispobj object); +lispobj (*transother[256])(lispobj object); +int (*sizetab[256])(lispobj *where); +struct weak_pointer *weak_pointers; + +/* + * copying objects + */ + +/* to copy a boxed object */ +lispobj +copy_object(lispobj object, int nwords) +{ + int tag; + lispobj *new; + lispobj *source, *dest; + + gc_assert(is_lisp_pointer(object)); + gc_assert(from_space_p(object)); + gc_assert((nwords & 0x01) == 0); + + /* Get tag of object. */ + tag = lowtag_of(object); + + /* Allocate space. */ + new = gc_general_alloc(nwords*4,ALLOC_BOXED,ALLOC_QUICK); + + dest = new; + source = (lispobj *) native_pointer(object); + + /* Copy the object. */ + while (nwords > 0) { + dest[0] = source[0]; + dest[1] = source[1]; + dest += 2; + source += 2; + nwords -= 2; + } + + return make_lispobj(new,tag); +} + +static int scav_lose(lispobj *where, lispobj object); /* forward decl */ + +/* FIXME: Most calls end up going to some trouble to compute an + * 'n_words' value for this function. The system might be a little + * simpler if this function used an 'end' parameter instead. */ + +void +scavenge(lispobj *start, long n_words) +{ + lispobj *end = start + n_words; + lispobj *object_ptr; + int n_words_scavenged; + + for (object_ptr = start; + object_ptr < end; + object_ptr += n_words_scavenged) { + + lispobj object = *object_ptr; +#ifdef LISP_FEATURE_GENCGC + gc_assert(!forwarding_pointer_p(object_ptr)); +#endif + if (is_lisp_pointer(object)) { + if (from_space_p(object)) { + /* It currently points to old space. Check for a + * forwarding pointer. */ + lispobj *ptr = native_pointer(object); + if (forwarding_pointer_p(ptr)) { + /* Yes, there's a forwarding pointer. */ + *object_ptr = LOW_WORD(forwarding_pointer_value(ptr)); + n_words_scavenged = 1; + } else { + /* Scavenge that pointer. */ + n_words_scavenged = + (scavtab[widetag_of(object)])(object_ptr, object); + } + } else { + /* It points somewhere other than oldspace. Leave it + * alone. */ + n_words_scavenged = 1; + } + } +#ifndef LISP_FEATURE_GENCGC + /* this workaround is probably not necessary for gencgc; at least, the + * behaviour it describes has never been reported */ + else if (n_words==1) { + /* there are some situations where an + other-immediate may end up in a descriptor + register. I'm not sure whether this is + supposed to happen, but if it does then we + don't want to (a) barf or (b) scavenge over the + data-block, because there isn't one. So, if + we're checking a single word and it's anything + other than a pointer, just hush it up */ + int type=widetag_of(object); + n_words_scavenged=1; + + if ((scavtab[type]==scav_lose) || + (((scavtab[type])(start,object))>1)) { + fprintf(stderr,"warning: attempted to scavenge non-descriptor value %x at %p. If you can\nreproduce this warning, send a bug report (see manual page for details)\n", + object,start); + } + } +#endif + else if ((object & 3) == 0) { + /* It's a fixnum: really easy.. */ + n_words_scavenged = 1; + } else { + /* It's some sort of header object or another. */ + n_words_scavenged = + (scavtab[widetag_of(object)])(object_ptr, object); + } + } + gc_assert(object_ptr == end); +} + +static lispobj trans_fun_header(lispobj object); /* forward decls */ +static lispobj trans_boxed(lispobj object); + +static int +scav_fun_pointer(lispobj *where, lispobj object) +{ + lispobj *first_pointer; + lispobj copy; + + gc_assert(is_lisp_pointer(object)); + + /* Object is a pointer into from_space - not a FP. */ + first_pointer = (lispobj *) native_pointer(object); + + /* must transport object -- object may point to either a function + * header, a closure function header, or to a closure header. */ + + switch (widetag_of(*first_pointer)) { + case SIMPLE_FUN_HEADER_WIDETAG: + case CLOSURE_FUN_HEADER_WIDETAG: + copy = trans_fun_header(object); + break; + default: + copy = trans_boxed(object); + break; + } + + if (copy != object) { + /* Set forwarding pointer */ + set_forwarding_pointer(first_pointer,copy); + } + + gc_assert(is_lisp_pointer(copy)); + gc_assert(!from_space_p(copy)); + + *where = copy; + + return 1; +} + + +static struct code * +trans_code(struct code *code) +{ + struct code *new_code; + lispobj first, l_code, l_new_code; + int nheader_words, ncode_words, nwords; + unsigned long displacement; + lispobj fheaderl, *prev_pointer; + + /* if object has already been transported, just return pointer */ + first = code->header; + if (forwarding_pointer_p((lispobj *)code)) { +#ifdef DEBUG_CODE_GC + printf("Was already transported\n"); +#endif + return (struct code *) forwarding_pointer_value + ((lispobj *)((pointer_sized_uint_t) code)); + } + + gc_assert(widetag_of(first) == CODE_HEADER_WIDETAG); + + /* prepare to transport the code vector */ + l_code = (lispobj) LOW_WORD(code) | OTHER_POINTER_LOWTAG; + + ncode_words = fixnum_value(code->code_size); + nheader_words = HeaderValue(code->header); + nwords = ncode_words + nheader_words; + nwords = CEILING(nwords, 2); + + l_new_code = copy_object(l_code, nwords); + new_code = (struct code *) native_pointer(l_new_code); + +#if defined(DEBUG_CODE_GC) + printf("Old code object at 0x%08x, new code object at 0x%08x.\n", + (unsigned long) code, (unsigned long) new_code); + printf("Code object is %d words long.\n", nwords); +#endif + +#ifdef LISP_FEATURE_GENCGC + if (new_code == code) + return new_code; +#endif + + displacement = l_new_code - l_code; + + set_forwarding_pointer((lispobj *)code, l_new_code); + + /* set forwarding pointers for all the function headers in the */ + /* code object. also fix all self pointers */ + + fheaderl = code->entry_points; + prev_pointer = &new_code->entry_points; + + while (fheaderl != NIL) { + struct simple_fun *fheaderp, *nfheaderp; + lispobj nfheaderl; + + fheaderp = (struct simple_fun *) native_pointer(fheaderl); + gc_assert(widetag_of(fheaderp->header) == SIMPLE_FUN_HEADER_WIDETAG); + + /* Calculate the new function pointer and the new */ + /* function header. */ + nfheaderl = fheaderl + displacement; + nfheaderp = (struct simple_fun *) native_pointer(nfheaderl); + +#ifdef DEBUG_CODE_GC + printf("fheaderp->header (at %x) <- %x\n", + &(fheaderp->header) , nfheaderl); +#endif + set_forwarding_pointer((lispobj *)fheaderp, nfheaderl); + + /* fix self pointer. */ + nfheaderp->self = +#ifdef LISP_FEATURE_GENCGC /* GENCGC? Maybe x86 is better conditional */ + FUN_RAW_ADDR_OFFSET + +#endif + nfheaderl; + + *prev_pointer = nfheaderl; + + fheaderl = fheaderp->next; + prev_pointer = &nfheaderp->next; + } + os_flush_icache((os_vm_address_t) (((int *)new_code) + nheader_words), + ncode_words * sizeof(int)); +#ifdef LISP_FEATURE_GENCGC + gencgc_apply_code_fixups(code, new_code); +#endif + return new_code; +} + +static int +scav_code_header(lispobj *where, lispobj object) +{ + struct code *code; + int n_header_words, n_code_words, n_words; + lispobj entry_point; /* tagged pointer to entry point */ + struct simple_fun *function_ptr; /* untagged pointer to entry point */ + + code = (struct code *) where; + n_code_words = fixnum_value(code->code_size); + n_header_words = HeaderValue(object); + n_words = n_code_words + n_header_words; + n_words = CEILING(n_words, 2); + + /* Scavenge the boxed section of the code data block. */ + scavenge(where + 1, n_header_words - 1); + + /* Scavenge the boxed section of each function object in the + * code data block. */ + for (entry_point = code->entry_points; + entry_point != NIL; + entry_point = function_ptr->next) { + + gc_assert(is_lisp_pointer(entry_point)); + + function_ptr = (struct simple_fun *) native_pointer(entry_point); + gc_assert(widetag_of(function_ptr->header)==SIMPLE_FUN_HEADER_WIDETAG); + + scavenge(&function_ptr->name, 1); + scavenge(&function_ptr->arglist, 1); + scavenge(&function_ptr->type, 1); + } + + return n_words; +} + +static lispobj +trans_code_header(lispobj object) +{ + struct code *ncode; + + ncode = trans_code((struct code *) native_pointer(object)); + return (lispobj) LOW_WORD(ncode) | OTHER_POINTER_LOWTAG; +} + + +static int +size_code_header(lispobj *where) +{ + struct code *code; + int nheader_words, ncode_words, nwords; + + code = (struct code *) where; + + ncode_words = fixnum_value(code->code_size); + nheader_words = HeaderValue(code->header); + nwords = ncode_words + nheader_words; + nwords = CEILING(nwords, 2); + + return nwords; +} + +static int +scav_return_pc_header(lispobj *where, lispobj object) +{ + lose("attempted to scavenge a return PC header where=0x%08x object=0x%08x", + (unsigned long) where, + (unsigned long) object); + return 0; /* bogus return value to satisfy static type checking */ +} + +static lispobj +trans_return_pc_header(lispobj object) +{ + struct simple_fun *return_pc; + unsigned long offset; + struct code *code, *ncode; + + return_pc = (struct simple_fun *) native_pointer(object); + offset = HeaderValue(return_pc->header) * 4 ; + + /* Transport the whole code object */ + code = (struct code *) ((unsigned long) return_pc - offset); + ncode = trans_code(code); + + return ((lispobj) LOW_WORD(ncode) + offset) | OTHER_POINTER_LOWTAG; +} + +/* On the 386, closures hold a pointer to the raw address instead of the + * function object, so we can use CALL [$FDEFN+const] to invoke + * the function without loading it into a register. Given that code + * objects don't move, we don't need to update anything, but we do + * have to figure out that the function is still live. */ + +#ifdef LISP_FEATURE_X86 +static int +scav_closure_header(lispobj *where, lispobj object) +{ + struct closure *closure; + lispobj fun; + + closure = (struct closure *)where; + fun = closure->fun - FUN_RAW_ADDR_OFFSET; + scavenge(&fun, 1); +#ifdef LISP_FEATURE_GENCGC + /* The function may have moved so update the raw address. But + * don't write unnecessarily. */ + if (closure->fun != fun + FUN_RAW_ADDR_OFFSET) + closure->fun = fun + FUN_RAW_ADDR_OFFSET; +#endif + return 2; +} +#endif + +static int +scav_fun_header(lispobj *where, lispobj object) +{ + lose("attempted to scavenge a function header where=0x%08x object=0x%08x", + (unsigned long) where, + (unsigned long) object); + return 0; /* bogus return value to satisfy static type checking */ +} + +static lispobj +trans_fun_header(lispobj object) +{ + struct simple_fun *fheader; + unsigned long offset; + struct code *code, *ncode; + + fheader = (struct simple_fun *) native_pointer(object); + offset = HeaderValue(fheader->header) * 4; + + /* Transport the whole code object */ + code = (struct code *) ((unsigned long) fheader - offset); + ncode = trans_code(code); + + return ((lispobj) LOW_WORD(ncode) + offset) | FUN_POINTER_LOWTAG; +} + + +/* + * instances + */ + +static int +scav_instance_pointer(lispobj *where, lispobj object) +{ + lispobj copy, *first_pointer; + + /* Object is a pointer into from space - not a FP. */ + copy = trans_boxed(object); + +#ifdef LISP_FEATURE_GENCGC + gc_assert(copy != object); +#endif + + first_pointer = (lispobj *) native_pointer(object); + set_forwarding_pointer(first_pointer,copy); + *where = copy; + + return 1; +} + + +/* + * lists and conses + */ + +static lispobj trans_list(lispobj object); + +static int +scav_list_pointer(lispobj *where, lispobj object) +{ + lispobj first, *first_pointer; + + gc_assert(is_lisp_pointer(object)); + + /* Object is a pointer into from space - not FP. */ + first_pointer = (lispobj *) native_pointer(object); + + first = trans_list(object); + gc_assert(first != object); + + /* Set forwarding pointer */ + set_forwarding_pointer(first_pointer, first); + + gc_assert(is_lisp_pointer(first)); + gc_assert(!from_space_p(first)); + + *where = first; + return 1; +} + + +static lispobj +trans_list(lispobj object) +{ + lispobj new_list_pointer; + struct cons *cons, *new_cons; + lispobj cdr; + + cons = (struct cons *) native_pointer(object); + + /* Copy 'object'. */ + new_cons = (struct cons *) + gc_general_alloc(sizeof(struct cons),ALLOC_BOXED,ALLOC_QUICK); + new_cons->car = cons->car; + new_cons->cdr = cons->cdr; /* updated later */ + new_list_pointer = make_lispobj(new_cons,lowtag_of(object)); + + /* Grab the cdr: set_forwarding_pointer will clobber it in GENCGC */ + cdr = cons->cdr; + + set_forwarding_pointer((lispobj *)cons, new_list_pointer); + + /* Try to linearize the list in the cdr direction to help reduce + * paging. */ + while (1) { + lispobj new_cdr; + struct cons *cdr_cons, *new_cdr_cons; + + if(lowtag_of(cdr) != LIST_POINTER_LOWTAG || + !from_space_p(cdr) || + forwarding_pointer_p((lispobj *)native_pointer(cdr))) + break; + + cdr_cons = (struct cons *) native_pointer(cdr); + + /* Copy 'cdr'. */ + new_cdr_cons = (struct cons*) + gc_general_alloc(sizeof(struct cons),ALLOC_BOXED,ALLOC_QUICK); + new_cdr_cons->car = cdr_cons->car; + new_cdr_cons->cdr = cdr_cons->cdr; + new_cdr = make_lispobj(new_cdr_cons, lowtag_of(cdr)); + + /* Grab the cdr before it is clobbered. */ + cdr = cdr_cons->cdr; + set_forwarding_pointer((lispobj *)cdr_cons, new_cdr); + + /* Update the cdr of the last cons copied into new space to + * keep the newspace scavenge from having to do it. */ + new_cons->cdr = new_cdr; + + new_cons = new_cdr_cons; + } + + return new_list_pointer; +} + + +/* + * scavenging and transporting other pointers + */ + +static int +scav_other_pointer(lispobj *where, lispobj object) +{ + lispobj first, *first_pointer; + + gc_assert(is_lisp_pointer(object)); + + /* Object is a pointer into from space - not FP. */ + first_pointer = (lispobj *) native_pointer(object); + first = (transother[widetag_of(*first_pointer)])(object); + + if (first != object) { + set_forwarding_pointer(first_pointer, first); +#ifdef LISP_FEATURE_GENCGC + *where = first; +#endif + } +#ifndef LISP_FEATURE_GENCGC + *where = first; +#endif + gc_assert(is_lisp_pointer(first)); + gc_assert(!from_space_p(first)); + + return 1; +} + +/* + * immediate, boxed, and unboxed objects + */ + +static int +size_pointer(lispobj *where) +{ + return 1; +} + +static int +scav_immediate(lispobj *where, lispobj object) +{ + return 1; +} + +static lispobj +trans_immediate(lispobj object) +{ + lose("trying to transport an immediate"); + return NIL; /* bogus return value to satisfy static type checking */ +} + +static int +size_immediate(lispobj *where) +{ + return 1; +} + + +static int +scav_boxed(lispobj *where, lispobj object) +{ + return 1; +} + +static lispobj +trans_boxed(lispobj object) +{ + lispobj header; + unsigned long length; + + gc_assert(is_lisp_pointer(object)); + + header = *((lispobj *) native_pointer(object)); + length = HeaderValue(header) + 1; + length = CEILING(length, 2); + + return copy_object(object, length); +} + + +static int +size_boxed(lispobj *where) +{ + lispobj header; + unsigned long length; + + header = *where; + length = HeaderValue(header) + 1; + length = CEILING(length, 2); + + return length; +} + +/* Note: on the sparc we don't have to do anything special for fdefns, */ +/* 'cause the raw-addr has a function lowtag. */ +#ifndef LISP_FEATURE_SPARC +static int +scav_fdefn(lispobj *where, lispobj object) +{ + struct fdefn *fdefn; + + fdefn = (struct fdefn *)where; + + /* FSHOW((stderr, "scav_fdefn, function = %p, raw_addr = %p\n", + fdefn->fun, fdefn->raw_addr)); */ + + if ((char *)(fdefn->fun + FUN_RAW_ADDR_OFFSET) + == (char *)((unsigned long)(fdefn->raw_addr))) { + scavenge(where + 1, sizeof(struct fdefn)/sizeof(lispobj) - 1); + + /* Don't write unnecessarily. */ + if (fdefn->raw_addr != (char *)(fdefn->fun + FUN_RAW_ADDR_OFFSET)) + fdefn->raw_addr = (char *)(fdefn->fun + FUN_RAW_ADDR_OFFSET); + /* gc.c has more casts here, which may be relevant or alternatively + may be compiler warning defeaters. try + fdefn->raw_addr = + (u32) ((char *) LOW_WORD(fdefn->fun)) + FUN_RAW_ADDR_OFFSET; + */ + return sizeof(struct fdefn) / sizeof(lispobj); + } else { + return 1; + } +} +#endif + +static int +scav_unboxed(lispobj *where, lispobj object) +{ + unsigned long length; + + length = HeaderValue(object) + 1; + length = CEILING(length, 2); + + return length; +} + +static lispobj +trans_unboxed(lispobj object) +{ + lispobj header; + unsigned long length; + + + gc_assert(is_lisp_pointer(object)); + + header = *((lispobj *) native_pointer(object)); + length = HeaderValue(header) + 1; + length = CEILING(length, 2); + + return copy_unboxed_object(object, length); +} + +static int +size_unboxed(lispobj *where) +{ + lispobj header; + unsigned long length; + + header = *where; + length = HeaderValue(header) + 1; + length = CEILING(length, 2); + + return length; +} + +static int +/* vector-like objects */ + +#define NWORDS(x,y) (CEILING((x),(y)) / (y)) + +scav_string(lispobj *where, lispobj object) +{ + struct vector *vector; + int length, nwords; + + /* NOTE: Strings contain one more byte of data than the length */ + /* slot indicates. */ + + vector = (struct vector *) where; + length = fixnum_value(vector->length) + 1; + nwords = CEILING(NWORDS(length, 4) + 2, 2); + + return nwords; +} +static lispobj +trans_string(lispobj object) +{ + struct vector *vector; + int length, nwords; + + gc_assert(is_lisp_pointer(object)); + + /* NOTE: A string contains one more byte of data (a terminating + * '\0' to help when interfacing with C functions) than indicated + * by the length slot. */ + + vector = (struct vector *) native_pointer(object); + length = fixnum_value(vector->length) + 1; + nwords = CEILING(NWORDS(length, 4) + 2, 2); + + return copy_large_unboxed_object(object, nwords); +} + +static int +size_string(lispobj *where) +{ + struct vector *vector; + int length, nwords; + + /* NOTE: A string contains one more byte of data (a terminating + * '\0' to help when interfacing with C functions) than indicated + * by the length slot. */ + + vector = (struct vector *) where; + length = fixnum_value(vector->length) + 1; + nwords = CEILING(NWORDS(length, 4) + 2, 2); + + return nwords; +} + +static lispobj +trans_vector(lispobj object) +{ + struct vector *vector; + int length, nwords; + + gc_assert(is_lisp_pointer(object)); + + vector = (struct vector *) native_pointer(object); + + length = fixnum_value(vector->length); + nwords = CEILING(length + 2, 2); + + return copy_large_object(object, nwords); +} + +static int +size_vector(lispobj *where) +{ + struct vector *vector; + int length, nwords; + + vector = (struct vector *) where; + length = fixnum_value(vector->length); + nwords = CEILING(length + 2, 2); + + return nwords; +} + +static int +scav_vector_bit(lispobj *where, lispobj object) +{ + struct vector *vector; + int length, nwords; + + vector = (struct vector *) where; + length = fixnum_value(vector->length); + nwords = CEILING(NWORDS(length, 32) + 2, 2); + + return nwords; +} + +static lispobj +trans_vector_bit(lispobj object) +{ + struct vector *vector; + int length, nwords; + + gc_assert(is_lisp_pointer(object)); + + vector = (struct vector *) native_pointer(object); + length = fixnum_value(vector->length); + nwords = CEILING(NWORDS(length, 32) + 2, 2); + + return copy_large_unboxed_object(object, nwords); +} + +static int +size_vector_bit(lispobj *where) +{ + struct vector *vector; + int length, nwords; + + vector = (struct vector *) where; + length = fixnum_value(vector->length); + nwords = CEILING(NWORDS(length, 32) + 2, 2); + + return nwords; +} + +static int +scav_vector_unsigned_byte_2(lispobj *where, lispobj object) +{ + struct vector *vector; + int length, nwords; + + vector = (struct vector *) where; + length = fixnum_value(vector->length); + nwords = CEILING(NWORDS(length, 16) + 2, 2); + + return nwords; +} + +static lispobj +trans_vector_unsigned_byte_2(lispobj object) +{ + struct vector *vector; + int length, nwords; + + gc_assert(is_lisp_pointer(object)); + + vector = (struct vector *) native_pointer(object); + length = fixnum_value(vector->length); + nwords = CEILING(NWORDS(length, 16) + 2, 2); + + return copy_large_unboxed_object(object, nwords); +} + +static int +size_vector_unsigned_byte_2(lispobj *where) +{ + struct vector *vector; + int length, nwords; + + vector = (struct vector *) where; + length = fixnum_value(vector->length); + nwords = CEILING(NWORDS(length, 16) + 2, 2); + + return nwords; +} + +static int +scav_vector_unsigned_byte_4(lispobj *where, lispobj object) +{ + struct vector *vector; + int length, nwords; + + vector = (struct vector *) where; + length = fixnum_value(vector->length); + nwords = CEILING(NWORDS(length, 8) + 2, 2); + + return nwords; +} + +static lispobj +trans_vector_unsigned_byte_4(lispobj object) +{ + struct vector *vector; + int length, nwords; + + gc_assert(is_lisp_pointer(object)); + + vector = (struct vector *) native_pointer(object); + length = fixnum_value(vector->length); + nwords = CEILING(NWORDS(length, 8) + 2, 2); + + return copy_large_unboxed_object(object, nwords); +} +static int +size_vector_unsigned_byte_4(lispobj *where) +{ + struct vector *vector; + int length, nwords; + + vector = (struct vector *) where; + length = fixnum_value(vector->length); + nwords = CEILING(NWORDS(length, 8) + 2, 2); + + return nwords; +} + + +static int +scav_vector_unsigned_byte_8(lispobj *where, lispobj object) +{ + struct vector *vector; + int length, nwords; + + vector = (struct vector *) where; + length = fixnum_value(vector->length); + nwords = CEILING(NWORDS(length, 4) + 2, 2); + + return nwords; +} + +/*********************/ + + + +static lispobj +trans_vector_unsigned_byte_8(lispobj object) +{ + struct vector *vector; + int length, nwords; + + gc_assert(is_lisp_pointer(object)); + + vector = (struct vector *) native_pointer(object); + length = fixnum_value(vector->length); + nwords = CEILING(NWORDS(length, 4) + 2, 2); + + return copy_large_unboxed_object(object, nwords); +} + +static int +size_vector_unsigned_byte_8(lispobj *where) +{ + struct vector *vector; + int length, nwords; + + vector = (struct vector *) where; + length = fixnum_value(vector->length); + nwords = CEILING(NWORDS(length, 4) + 2, 2); + + return nwords; +} + + +static int +scav_vector_unsigned_byte_16(lispobj *where, lispobj object) +{ + struct vector *vector; + int length, nwords; + + vector = (struct vector *) where; + length = fixnum_value(vector->length); + nwords = CEILING(NWORDS(length, 2) + 2, 2); + + return nwords; +} + +static lispobj +trans_vector_unsigned_byte_16(lispobj object) +{ + struct vector *vector; + int length, nwords; + + gc_assert(is_lisp_pointer(object)); + + vector = (struct vector *) native_pointer(object); + length = fixnum_value(vector->length); + nwords = CEILING(NWORDS(length, 2) + 2, 2); + + return copy_large_unboxed_object(object, nwords); +} + +static int +size_vector_unsigned_byte_16(lispobj *where) +{ + struct vector *vector; + int length, nwords; + + vector = (struct vector *) where; + length = fixnum_value(vector->length); + nwords = CEILING(NWORDS(length, 2) + 2, 2); + + return nwords; +} + +static int +scav_vector_unsigned_byte_32(lispobj *where, lispobj object) +{ + struct vector *vector; + int length, nwords; + + vector = (struct vector *) where; + length = fixnum_value(vector->length); + nwords = CEILING(length + 2, 2); + + return nwords; +} + +static lispobj +trans_vector_unsigned_byte_32(lispobj object) +{ + struct vector *vector; + int length, nwords; + + gc_assert(is_lisp_pointer(object)); + + vector = (struct vector *) native_pointer(object); + length = fixnum_value(vector->length); + nwords = CEILING(length + 2, 2); + + return copy_large_unboxed_object(object, nwords); +} + +static int +size_vector_unsigned_byte_32(lispobj *where) +{ + struct vector *vector; + int length, nwords; + + vector = (struct vector *) where; + length = fixnum_value(vector->length); + nwords = CEILING(length + 2, 2); + + return nwords; +} + +static int +scav_vector_single_float(lispobj *where, lispobj object) +{ + struct vector *vector; + int length, nwords; + + vector = (struct vector *) where; + length = fixnum_value(vector->length); + nwords = CEILING(length + 2, 2); + + return nwords; +} + +static lispobj +trans_vector_single_float(lispobj object) +{ + struct vector *vector; + int length, nwords; + + gc_assert(is_lisp_pointer(object)); + + vector = (struct vector *) native_pointer(object); + length = fixnum_value(vector->length); + nwords = CEILING(length + 2, 2); + + return copy_large_unboxed_object(object, nwords); +} + +static int +size_vector_single_float(lispobj *where) +{ + struct vector *vector; + int length, nwords; + + vector = (struct vector *) where; + length = fixnum_value(vector->length); + nwords = CEILING(length + 2, 2); + + return nwords; +} + +static int +scav_vector_double_float(lispobj *where, lispobj object) +{ + struct vector *vector; + int length, nwords; + + vector = (struct vector *) where; + length = fixnum_value(vector->length); + nwords = CEILING(length * 2 + 2, 2); + + return nwords; +} + +static lispobj +trans_vector_double_float(lispobj object) +{ + struct vector *vector; + int length, nwords; + + gc_assert(is_lisp_pointer(object)); + + vector = (struct vector *) native_pointer(object); + length = fixnum_value(vector->length); + nwords = CEILING(length * 2 + 2, 2); + + return copy_large_unboxed_object(object, nwords); +} + +static int +size_vector_double_float(lispobj *where) +{ + struct vector *vector; + int length, nwords; + + vector = (struct vector *) where; + length = fixnum_value(vector->length); + nwords = CEILING(length * 2 + 2, 2); + + return nwords; +} + +#ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG +static int +scav_vector_long_float(lispobj *where, lispobj object) +{ + struct vector *vector; + int length, nwords; + + vector = (struct vector *) where; + length = fixnum_value(vector->length); + nwords = CEILING(length * + LONG_FLOAT_SIZE + + 2, 2); + return nwords; +} + +static lispobj +trans_vector_long_float(lispobj object) +{ + struct vector *vector; + int length, nwords; + + gc_assert(is_lisp_pointer(object)); + + vector = (struct vector *) native_pointer(object); + length = fixnum_value(vector->length); + nwords = CEILING(length * LONG_FLOAT_SIZE + 2, 2); + + return copy_large_unboxed_object(object, nwords); +} + +static int +size_vector_long_float(lispobj *where) +{ + struct vector *vector; + int length, nwords; + + vector = (struct vector *) where; + length = fixnum_value(vector->length); + nwords = CEILING(length * LONG_FLOAT_SIZE + 2, 2); + + return nwords; +} +#endif + + +#ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG +static int +scav_vector_complex_single_float(lispobj *where, lispobj object) +{ + struct vector *vector; + int length, nwords; + + vector = (struct vector *) where; + length = fixnum_value(vector->length); + nwords = CEILING(length * 2 + 2, 2); + + return nwords; +} + +static lispobj +trans_vector_complex_single_float(lispobj object) +{ + struct vector *vector; + int length, nwords; + + gc_assert(is_lisp_pointer(object)); + + vector = (struct vector *) native_pointer(object); + length = fixnum_value(vector->length); + nwords = CEILING(length * 2 + 2, 2); + + return copy_large_unboxed_object(object, nwords); +} + +static int +size_vector_complex_single_float(lispobj *where) +{ + struct vector *vector; + int length, nwords; + + vector = (struct vector *) where; + length = fixnum_value(vector->length); + nwords = CEILING(length * 2 + 2, 2); + + return nwords; +} +#endif + +#ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG +static int +scav_vector_complex_double_float(lispobj *where, lispobj object) +{ + struct vector *vector; + int length, nwords; + + vector = (struct vector *) where; + length = fixnum_value(vector->length); + nwords = CEILING(length * 4 + 2, 2); + + return nwords; +} + +static lispobj +trans_vector_complex_double_float(lispobj object) +{ + struct vector *vector; + int length, nwords; + + gc_assert(is_lisp_pointer(object)); + + vector = (struct vector *) native_pointer(object); + length = fixnum_value(vector->length); + nwords = CEILING(length * 4 + 2, 2); + + return copy_large_unboxed_object(object, nwords); +} + +static int +size_vector_complex_double_float(lispobj *where) +{ + struct vector *vector; + int length, nwords; + + vector = (struct vector *) where; + length = fixnum_value(vector->length); + nwords = CEILING(length * 4 + 2, 2); + + return nwords; +} +#endif + + +#ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG +static int +scav_vector_complex_long_float(lispobj *where, lispobj object) +{ + struct vector *vector; + int length, nwords; + + vector = (struct vector *) where; + length = fixnum_value(vector->length); + nwords = CEILING(length * (2* LONG_FLOAT_SIZE) + 2, 2); + + return nwords; +} + +static lispobj +trans_vector_complex_long_float(lispobj object) +{ + struct vector *vector; + int length, nwords; + + gc_assert(is_lisp_pointer(object)); + + vector = (struct vector *) native_pointer(object); + length = fixnum_value(vector->length); + nwords = CEILING(length * (2*LONG_FLOAT_SIZE) + 2, 2); + + return copy_large_unboxed_object(object, nwords); +} + +static int +size_vector_complex_long_float(lispobj *where) +{ + struct vector *vector; + int length, nwords; + + vector = (struct vector *) where; + length = fixnum_value(vector->length); + nwords = CEILING(length * (2*LONG_FLOAT_SIZE) + 2, 2); + + return nwords; +} +#endif + +#define WEAK_POINTER_NWORDS \ + CEILING((sizeof(struct weak_pointer) / sizeof(lispobj)), 2) + +static lispobj +trans_weak_pointer(lispobj object) +{ + lispobj copy; +#ifndef LISP_FEATURE_GENCGC + struct weak_pointer *wp; +#endif + gc_assert(is_lisp_pointer(object)); + +#if defined(DEBUG_WEAK) + printf("Transporting weak pointer from 0x%08x\n", object); +#endif + + /* Need to remember where all the weak pointers are that have */ + /* been transported so they can be fixed up in a post-GC pass. */ + + copy = copy_object(object, WEAK_POINTER_NWORDS); +#ifndef LISP_FEATURE_GENCGC + wp = (struct weak_pointer *) native_pointer(copy); + + gc_assert(widetag_of(wp->header)==WEAK_POINTER_WIDETAG); + /* Push the weak pointer onto the list of weak pointers. */ + wp->next = LOW_WORD(weak_pointers); + weak_pointers = wp; +#endif + return copy; +} + +static int +size_weak_pointer(lispobj *where) +{ + return WEAK_POINTER_NWORDS; +} + + +void scan_weak_pointers(void) +{ + struct weak_pointer *wp; + for (wp = weak_pointers; wp != NULL; + wp=(struct weak_pointer *)native_pointer(wp->next)) { + lispobj value = wp->value; + lispobj *first_pointer; + gc_assert(widetag_of(wp->header)==WEAK_POINTER_WIDETAG); + if (!(is_lisp_pointer(value) && from_space_p(value))) + continue; + + /* Now, we need to check whether the object has been forwarded. If + * it has been, the weak pointer is still good and needs to be + * updated. Otherwise, the weak pointer needs to be nil'ed + * out. */ + + first_pointer = (lispobj *)native_pointer(value); + + if (forwarding_pointer_p(first_pointer)) { + wp->value= + (lispobj)LOW_WORD(forwarding_pointer_value(first_pointer)); + } else { + /* Break it. */ + wp->value = NIL; + wp->broken = T; + } + } +} + + + +/* + * initialization + */ + +static int +scav_lose(lispobj *where, lispobj object) +{ + lose("no scavenge function for object 0x%08x (widetag 0x%x)", + (unsigned long)object, + widetag_of(*(lispobj*)native_pointer(object))); + return 0; /* bogus return value to satisfy static type checking */ +} + +static lispobj +trans_lose(lispobj object) +{ + lose("no transport function for object 0x%08x (widetag 0x%x)", + (unsigned long)object, + widetag_of(*(lispobj*)native_pointer(object))); + return NIL; /* bogus return value to satisfy static type checking */ +} + +static int +size_lose(lispobj *where) +{ + lose("no size function for object at 0x%08x (widetag 0x%x)", + (unsigned long)where, + widetag_of(LOW_WORD(where))); + return 1; /* bogus return value to satisfy static type checking */ +} + + +/* + * initialization + */ + +void +gc_init_tables(void) +{ + int i; + + /* Set default value in all slots of scavenge table. FIXME + * replace this gnarly sizeof with something based on + * N_WIDETAG_BITS */ + for (i = 0; i < ((sizeof scavtab)/(sizeof scavtab[0])); i++) { + scavtab[i] = scav_lose; + } + + /* For each type which can be selected by the lowtag alone, set + * multiple entries in our widetag scavenge table (one for each + * possible value of the high bits). + */ + + for (i = 0; i < (1<<(N_WIDETAG_BITS-N_LOWTAG_BITS)); i++) { + scavtab[EVEN_FIXNUM_LOWTAG|(i< -#include -#include -#include -#include "runtime.h" -#include "sbcl.h" -#include "os.h" -#include "gc.h" -#include "globals.h" -#include "interrupt.h" -#include "validate.h" -#include "lispregs.h" -#include "interr.h" - -/* So you need to debug? */ -#if 0 -#define PRINTNOISE -#define DEBUG_SPACE_PREDICATES -#define DEBUG_SCAVENGE_VERBOSE -#define DEBUG_COPY_VERBOSE -#define DEBUG_CODE_GC -#endif - -static lispobj *from_space; -static lispobj *from_space_free_pointer; - -static lispobj *new_space; -static lispobj *new_space_free_pointer; - -static int (*scavtab[256])(lispobj *where, lispobj object); -static lispobj (*transother[256])(lispobj object); -static int (*sizetab[256])(lispobj *where); - -static struct weak_pointer *weak_pointers; - -static void scavenge(lispobj *start, u32 nwords); -static void scavenge_newspace(void); -static void scavenge_interrupt_contexts(void); -static void scan_weak_pointers(void); -static int scav_lose(lispobj *where, lispobj object); - -#define gc_abort() lose("GC invariant lost! File \"%s\", line %d\n", \ - __FILE__, __LINE__) - -#if 1 -#define gc_assert(ex) do { \ - if (!(ex)) gc_abort(); \ -} while (0) -#else -#define gc_assert(ex) -#endif - -#define CEILING(x,y) (((x) + ((y) - 1)) & (~((y) - 1))) - - -/* predicates */ - -#if defined(DEBUG_SPACE_PREDICATES) - -boolean -from_space_p(lispobj object) -{ - lispobj *ptr; - - /* this can be called for untagged pointers as well as for - descriptors, so this assertion's not applicable - gc_assert(is_lisp_pointer(object)); - */ - ptr = (lispobj *) native_pointer(object); - - return ((from_space <= ptr) && - (ptr < from_space_free_pointer)); -} - -boolean -new_space_p(lispobj object) -{ - lispobj *ptr; - - gc_assert(is_lisp_pointer(object)); - - ptr = (lispobj *) native_pointer(object); - - return ((new_space <= ptr) && - (ptr < new_space_free_pointer)); -} - -#else - -#define from_space_p(ptr) \ - ((from_space <= ((lispobj *) ptr)) && \ - (((lispobj *) ptr) < from_space_free_pointer)) - -#define new_space_p(ptr) \ - ((new_space <= ((lispobj *) ptr)) && \ - (((lispobj *) ptr) < new_space_free_pointer)) - -#endif - - -/* copying objects */ - -static lispobj -copy_object(lispobj object, int nwords) -{ - int tag; - lispobj *new; - lispobj *source, *dest; - - gc_assert(is_lisp_pointer(object)); - gc_assert(from_space_p(object)); - gc_assert((nwords & 0x01) == 0); - - /* get tag of object */ - tag = lowtag_of(object); - - /* allocate space */ - new = new_space_free_pointer; - new_space_free_pointer += nwords; - - dest = new; - source = (lispobj *) native_pointer(object); - -#ifdef DEBUG_COPY_VERBOSE - fprintf(stderr,"Copying %d words from %p to %p\n", nwords,source,new); -#endif - - /* copy the object */ - while (nwords > 0) { - dest[0] = source[0]; - dest[1] = source[1]; - dest += 2; - source += 2; - nwords -= 2; - } - /* return lisp pointer of new object */ - return (lispobj)(LOW_WORD(new) | tag); -} - - -/* collecting garbage */ - -#ifdef PRINTNOISE -static double -tv_diff(struct timeval *x, struct timeval *y) -{ - return (((double) x->tv_sec + (double) x->tv_usec * 1.0e-6) - - ((double) y->tv_sec + (double) y->tv_usec * 1.0e-6)); -} -#endif - -#define BYTES_ZERO_BEFORE_END (1<<12) - -#ifdef alpha -#define U32 u32 -#else -#define U32 unsigned long -#endif -static void -zero_stack(void) -{ - U32 *ptr = (U32 *)current_control_stack_pointer; - search: - do { - if (*ptr) - goto fill; - ptr++; - } while (((unsigned long)ptr) & (BYTES_ZERO_BEFORE_END-1)); - return; - fill: - do { - *ptr++ = 0; - } while (((unsigned long)ptr) & (BYTES_ZERO_BEFORE_END-1)); - - goto search; -} -#undef U32 - - -/* Note: The generic GC interface we're implementing passes us a - * last_generation argument. That's meaningless for us, since we're - * not a generational GC. So we ignore it. */ -void -collect_garbage(unsigned ignore) -{ -#ifdef PRINTNOISE - struct timeval start_tv, stop_tv; - struct rusage start_rusage, stop_rusage; - double real_time, system_time, user_time; - double percent_retained, gc_rate; - unsigned long size_discarded; - unsigned long size_retained; -#endif - lispobj *current_static_space_free_pointer; - unsigned long static_space_size; - unsigned long control_stack_size, binding_stack_size; - sigset_t tmp, old; - -#ifdef PRINTNOISE - printf("[Collecting garbage ... \n"); - - getrusage(RUSAGE_SELF, &start_rusage); - gettimeofday(&start_tv, (struct timezone *) 0); -#endif - - sigemptyset(&tmp); - sigaddset_blockable(&tmp); - sigprocmask(SIG_BLOCK, &tmp, &old); - - current_static_space_free_pointer = - (lispobj *) ((unsigned long) - SymbolValue(STATIC_SPACE_FREE_POINTER)); - - - /* Set up from space and new space pointers. */ - - from_space = current_dynamic_space; - from_space_free_pointer = dynamic_space_free_pointer; - -#ifdef PRINTNOISE - fprintf(stderr,"from_space = %lx\n", - (unsigned long) current_dynamic_space); -#endif - if (current_dynamic_space == (lispobj *) DYNAMIC_0_SPACE_START) - new_space = (lispobj *)DYNAMIC_1_SPACE_START; - else if (current_dynamic_space == (lispobj *) DYNAMIC_1_SPACE_START) - new_space = (lispobj *) DYNAMIC_0_SPACE_START; - else { - lose("GC lossage. Current dynamic space is bogus!\n"); - } - new_space_free_pointer = new_space; -#if 0 - /* at one time we had the bright idea of using mprotect() to - * hide the semispace that we're not using at the moment, so - * we'd see immediately if anyone had a pointer to it. - * Unfortunately, if we gc during a call to an assembler - * routine with a "raw" return style, at least on PPC we are - * expected to return into oldspace because we can't easily - * update the link register - it's not tagged, and we can't do - * it as an offset of reg_CODE because the calling routine - * might be nowhere near our code vector. We hope that we - * don't run very far in oldspace before it catapults us into - * newspace by either calling something else or returning - */ - - /* write-enable */ - os_protect(new_space,DYNAMIC_SPACE_SIZE,OS_VM_PROT_ALL); -#endif - - /* Initialize the weak pointer list. */ - weak_pointers = (struct weak_pointer *) NULL; - - - /* Scavenge all of the roots. */ -#ifdef PRINTNOISE - printf("Scavenging interrupt contexts ...\n"); -#endif - scavenge_interrupt_contexts(); - -#ifdef PRINTNOISE - printf("Scavenging interrupt handlers (%d bytes) ...\n", - (int)sizeof(interrupt_handlers)); -#endif - scavenge((lispobj *) interrupt_handlers, - sizeof(interrupt_handlers) / sizeof(lispobj)); - - /* _size quantities are in units of sizeof(lispobj) - i.e. 4 */ - control_stack_size = - current_control_stack_pointer- - (lispobj *)CONTROL_STACK_START; -#ifdef PRINTNOISE - printf("Scavenging the control stack at %p (%ld words) ...\n", - ((lispobj *)CONTROL_STACK_START), - control_stack_size); -#endif - scavenge(((lispobj *)CONTROL_STACK_START), control_stack_size); - - - binding_stack_size = - current_binding_stack_pointer - - (lispobj *)BINDING_STACK_START; -#ifdef PRINTNOISE - printf("Scavenging the binding stack %x - %x (%d words) ...\n", - BINDING_STACK_START,current_binding_stack_pointer, - (int)(binding_stack_size)); -#endif - scavenge(((lispobj *)BINDING_STACK_START), binding_stack_size); - - static_space_size = - current_static_space_free_pointer - (lispobj *) STATIC_SPACE_START; -#ifdef PRINTNOISE - printf("Scavenging static space %x - %x (%d words) ...\n", - STATIC_SPACE_START,current_static_space_free_pointer, - (int)(static_space_size)); -#endif - scavenge(((lispobj *)STATIC_SPACE_START), static_space_size); - - /* Scavenge newspace. */ -#ifdef PRINTNOISE - printf("Scavenging new space (%d bytes) ...\n", - (int)((new_space_free_pointer - new_space) * sizeof(lispobj))); -#endif - scavenge_newspace(); - - -#if defined(DEBUG_PRINT_GARBAGE) - print_garbage(from_space, from_space_free_pointer); -#endif - - /* Scan the weak pointers. */ -#ifdef PRINTNOISE - printf("Scanning weak pointers ...\n"); -#endif - scan_weak_pointers(); - - - /* Flip spaces. */ -#ifdef PRINTNOISE - printf("Flipping spaces ...\n"); -#endif - - os_zero((os_vm_address_t) current_dynamic_space, - (os_vm_size_t) DYNAMIC_SPACE_SIZE); - - current_dynamic_space = new_space; - dynamic_space_free_pointer = new_space_free_pointer; - -#ifdef PRINTNOISE - size_discarded = (from_space_free_pointer - from_space) * sizeof(lispobj); - size_retained = (new_space_free_pointer - new_space) * sizeof(lispobj); -#endif - - /* Zero stack. */ -#ifdef PRINTNOISE - printf("Zeroing empty part of control stack ...\n"); -#endif - zero_stack(); - - sigprocmask(SIG_SETMASK, &old, 0); - - -#ifdef PRINTNOISE - gettimeofday(&stop_tv, (struct timezone *) 0); - getrusage(RUSAGE_SELF, &stop_rusage); - - printf("done.]\n"); - - percent_retained = (((float) size_retained) / - ((float) size_discarded)) * 100.0; - - printf("Total of %ld bytes out of %ld bytes retained (%3.2f%%).\n", - size_retained, size_discarded, percent_retained); - - real_time = tv_diff(&stop_tv, &start_tv); - user_time = tv_diff(&stop_rusage.ru_utime, &start_rusage.ru_utime); - system_time = tv_diff(&stop_rusage.ru_stime, &start_rusage.ru_stime); - -#if 0 - printf("Statistics:\n"); - printf("%10.2f sec of real time\n", real_time); - printf("%10.2f sec of user time,\n", user_time); - printf("%10.2f sec of system time.\n", system_time); -#else - printf("Statistics: %10.2fs real, %10.2fs user, %10.2fs system.\n", - real_time, user_time, system_time); -#endif - - gc_rate = ((float) size_retained / (float) (1<<20)) / real_time; - - printf("%10.2f M bytes/sec collected.\n", gc_rate); -#endif - /* os_flush_icache((os_vm_address_t) 0, sizeof(unsigned long)); */ - -#if 0 - /* see comment above about mprotecting oldspace */ - - /* zero the from space now, to make it easier to find stale - pointers to it */ - - /* pray that both dynamic spaces are the same size ... */ - memset(from_space,(DYNAMIC_0_SPACE_END-DYNAMIC_0_SPACE_START-1),0); - os_protect(from_space,DYNAMIC_SPACE_SIZE,0); /* write-protect */ -#endif -} - - -/* scavenging */ - -static void -scavenge(lispobj *start, u32 nwords) -{ - while (nwords > 0) { - lispobj object; - int type, words_scavenged; - - object = *start; - type = widetag_of(object); - -#if defined(DEBUG_SCAVENGE_VERBOSE) - fprintf(stderr,"Scavenging object at 0x%08x, object = 0x%08x, type = %d\n", - (unsigned long) start, (unsigned long) object, type); -#endif - - if (is_lisp_pointer(object)) { - /* It be a pointer. */ - if (from_space_p(object)) { - /* It currently points to old space. Check for a */ - /* forwarding pointer. */ - lispobj first_word; - - first_word = *((lispobj *)native_pointer(object)); - if (is_lisp_pointer(first_word) && - new_space_p(first_word)) { - /* Yep, there be a forwarding pointer. */ - *start = first_word; - words_scavenged = 1; - } - else { - /* Scavenge that pointer. */ - words_scavenged = (scavtab[type])(start, object); - } - } - else { - /* It points somewhere other than oldspace. Leave */ - /* it alone. */ - words_scavenged = 1; - } - } - else if (nwords==1) { - /* there are some situations where an - other-immediate may end up in a descriptor - register. I'm not sure whether this is - supposed to happen, but if it does then we - don't want to (a) barf or (b) scavenge over the - data-block, because there isn't one. So, if - we're checking a single word and it's anything - other than a pointer, just hush it up */ - - words_scavenged=1; - if ((scavtab[type]==scav_lose) || - (((scavtab[type])(start,object))>1)) { - fprintf(stderr,"warning: attempted to scavenge non-descriptor value %x at %p. If you can\nreproduce this warning, send a test case to sbcl-devel@lists.sourceforge.net\n", - object,start); - } - } - else if ((object & 3) == 0) { - /* It's a fixnum. Real easy. */ - words_scavenged = 1; - } - else { - /* It's some random header object. */ - words_scavenged = (scavtab[type])(start, object); - - } - - start += words_scavenged; - nwords -= words_scavenged; - } - gc_assert(nwords == 0); -} - -static void -scavenge_newspace(void) -{ - lispobj *here, *next; - - here = new_space; - while (here < new_space_free_pointer) { - /* printf("here=%lx, new_space_free_pointer=%lx\n", - here,new_space_free_pointer); */ - next = new_space_free_pointer; - scavenge(here, next - here); - here = next; - } - /* printf("done with newspace\n"); */ -} - -/* scavenging interrupt contexts */ - -static int boxed_registers[] = BOXED_REGISTERS; - -static void -scavenge_interrupt_context(os_context_t *context) -{ - int i; -#ifdef reg_LIP - unsigned long lip; - unsigned long lip_offset; - int lip_register_pair; -#endif - unsigned long pc_code_offset; -#ifdef ARCH_HAS_LINK_REGISTER - unsigned long lr_code_offset; -#endif -#ifdef ARCH_HAS_NPC_REGISTER - unsigned long npc_code_offset; -#endif -#ifdef DEBUG_SCAVENGE_VERBOSE - fprintf(stderr, "Scavenging interrupt context at 0x%x\n",context); -#endif - /* Find the LIP's register pair and calculate its offset */ - /* before we scavenge the context. */ -#ifdef reg_LIP - lip = *os_context_register_addr(context, reg_LIP); - /* 0x7FFFFFFF or 0x7FFFFFFFFFFFFFFF ? */ - lip_offset = 0x7FFFFFFF; - lip_register_pair = -1; - for (i = 0; i < (sizeof(boxed_registers) / sizeof(int)); i++) { - unsigned long reg; - long offset; - int index; - - index = boxed_registers[i]; - reg = *os_context_register_addr(context, index); - /* would be using PTR if not for integer length issues */ - if ((reg & ~((1L<header; - if (is_lisp_pointer(first) && new_space_p(first)) { -#ifdef DEBUG_CODE_GC - printf("Was already transported\n"); -#endif - return (struct code *) native_pointer(first); - } - - gc_assert(widetag_of(first) == CODE_HEADER_WIDETAG); - - /* prepare to transport the code vector */ - l_code = (lispobj) LOW_WORD(code) | OTHER_POINTER_LOWTAG; - - ncode_words = fixnum_value(code->code_size); - nheader_words = HeaderValue(code->header); - nwords = ncode_words + nheader_words; - nwords = CEILING(nwords, 2); - - l_new_code = copy_object(l_code, nwords); - new_code = (struct code *) native_pointer(l_new_code); - - displacement = l_new_code - l_code; - -#if defined(DEBUG_CODE_GC) - printf("Old code object at 0x%08x, new code object at 0x%08x.\n", - (unsigned long) code, (unsigned long) new_code); - printf("Code object is %d words long.\n", nwords); -#endif - - /* set forwarding pointer */ - code->header = l_new_code; - - /* set forwarding pointers for all the function headers in the */ - /* code object. also fix all self pointers */ - - fheaderl = code->entry_points; - prev_pointer = &new_code->entry_points; - - while (fheaderl != NIL) { - struct simple_fun *fheaderp, *nfheaderp; - lispobj nfheaderl; - - fheaderp = (struct simple_fun *) native_pointer(fheaderl); - gc_assert(widetag_of(fheaderp->header) == SIMPLE_FUN_HEADER_WIDETAG); - - /* Calculate the new function pointer and the new */ - /* function header. */ - nfheaderl = fheaderl + displacement; - nfheaderp = (struct simple_fun *) native_pointer(nfheaderl); - - /* set forwarding pointer */ -#ifdef DEBUG_CODE_GC - printf("fheaderp->header (at %x) <- %x\n", - &(fheaderp->header) , nfheaderl); -#endif - fheaderp->header = nfheaderl; - - /* fix self pointer */ - nfheaderp->self = nfheaderl; - - *prev_pointer = nfheaderl; - - fheaderl = fheaderp->next; - prev_pointer = &nfheaderp->next; - } - -#ifndef MACH - os_flush_icache((os_vm_address_t) (((int *)new_code) + nheader_words), - ncode_words * sizeof(int)); -#endif - return new_code; -} - -static int -scav_code_header(lispobj *where, lispobj object) -{ - struct code *code; - int nheader_words, ncode_words, nwords; - lispobj fheaderl; - struct simple_fun *fheaderp; - - code = (struct code *) where; - ncode_words = fixnum_value(code->code_size); - nheader_words = HeaderValue(object); - nwords = ncode_words + nheader_words; - nwords = CEILING(nwords, 2); - -#if defined(DEBUG_CODE_GC) - printf("\nScavening code object at 0x%08x.\n", - (unsigned long) where); - printf("Code object is %d words long.\n", nwords); - printf("Scavenging boxed section of code data block (%d words).\n", - nheader_words - 1); -#endif - - /* Scavenge the boxed section of the code data block */ - scavenge(where + 1, nheader_words - 1); - - /* Scavenge the boxed section of each function object in the */ - /* code data block */ - fheaderl = code->entry_points; - while (fheaderl != NIL) { - fheaderp = (struct simple_fun *) native_pointer(fheaderl); - gc_assert(widetag_of(fheaderp->header) == SIMPLE_FUN_HEADER_WIDETAG); - -#if defined(DEBUG_CODE_GC) - printf("Scavenging boxed section of entry point located at 0x%08x.\n", - (unsigned long) native_pointer(fheaderl)); -#endif - scavenge(&fheaderp->name, 1); - scavenge(&fheaderp->arglist, 1); - scavenge(&fheaderp->type, 1); - - fheaderl = fheaderp->next; - } - - return nwords; -} - -static lispobj -trans_code_header(lispobj object) -{ - struct code *ncode; - - ncode = trans_code((struct code *) native_pointer(object)); - return (lispobj) LOW_WORD(ncode) | OTHER_POINTER_LOWTAG; -} - -static int -size_code_header(lispobj *where) -{ - struct code *code; - int nheader_words, ncode_words, nwords; - - code = (struct code *) where; - - ncode_words = fixnum_value(code->code_size); - nheader_words = HeaderValue(code->header); - nwords = ncode_words + nheader_words; - nwords = CEILING(nwords, 2); - - return nwords; -} - - -static int -scav_return_pc_header(lispobj *where, lispobj object) -{ - fprintf(stderr, "GC lossage. Should not be scavenging a "); - fprintf(stderr, "Return PC Header.\n"); - fprintf(stderr, "where = 0x%p, object = 0x%x", where, object); - lose(NULL); - return 0; -} - -static lispobj -trans_return_pc_header(lispobj object) -{ - struct simple_fun *return_pc; - unsigned long offset; - struct code *code, *ncode; - lispobj ret; - return_pc = (struct simple_fun *) native_pointer(object); - offset = HeaderValue(return_pc->header) * 4 ; - - /* Transport the whole code object */ - code = (struct code *) ((unsigned long) return_pc - offset); -#ifdef DEBUG_CODE_GC - printf("trans_return_pc_header object=%x, code=%lx\n",object,code); -#endif - ncode = trans_code(code); - if (object==0x304748d7) { - /* monitor_or_something(); */ - } - ret= ((lispobj) LOW_WORD(ncode) + offset) | OTHER_POINTER_LOWTAG; -#ifdef DEBUG_CODE_GC - printf("trans_return_pc_header returning %x\n",ret); -#endif - return ret; -} - -/* On the 386, closures hold a pointer to the raw address instead of - * the function object, so we can use CALL [$FDEFN+const] to invoke - * the function without loading it into a register. Given that code - * objects don't move, we don't need to update anything, but we do - * have to figure out that the function is still live. */ -#ifdef __i386__ -static -scav_closure_header(where, object) -lispobj *where, object; -{ - struct closure *closure; - lispobj fun; - - closure = (struct closure *)where; - fun = closure->fun - FUN_RAW_ADDR_OFFSET; - scavenge(&fun, 1); - - return 2; -} -#endif - -static int -scav_fun_header(lispobj *where, lispobj object) -{ - fprintf(stderr, "GC lossage. Should not be scavenging a "); - fprintf(stderr, "Function Header.\n"); - fprintf(stderr, "where = 0x%p, object = 0x%08x", - where, (unsigned int) object); - lose(NULL); - return 0; -} - -static lispobj -trans_fun_header(lispobj object) -{ - struct simple_fun *fheader; - unsigned long offset; - struct code *code, *ncode; - - fheader = (struct simple_fun *) native_pointer(object); - offset = HeaderValue(fheader->header) * 4; - - /* Transport the whole code object */ - code = (struct code *) ((unsigned long) fheader - offset); - ncode = trans_code(code); - - return ((lispobj) LOW_WORD(ncode) + offset) | FUN_POINTER_LOWTAG; -} - - - -/* instances */ - -static int -scav_instance_pointer(lispobj *where, lispobj object) -{ - lispobj *first_pointer; - - /* object is a pointer into from space. Not a FP */ - first_pointer = (lispobj *) native_pointer(object); - - *where = *first_pointer = trans_boxed(object); - return 1; -} - - -/* lists and conses */ - -static lispobj trans_list(lispobj object); - -static int -scav_list_pointer(lispobj *where, lispobj object) -{ - lispobj first, *first_pointer; - - gc_assert(is_lisp_pointer(object)); - - /* object is a pointer into from space. Not a FP. */ - first_pointer = (lispobj *) native_pointer(object); - - first = *first_pointer = trans_list(object); - - gc_assert(is_lisp_pointer(first)); - gc_assert(!from_space_p(first)); - - *where = first; - return 1; -} - -static lispobj -trans_list(lispobj object) -{ - lispobj new_list_pointer; - struct cons *cons, *new_cons; - - cons = (struct cons *) native_pointer(object); - - /* ### Don't use copy_object here. */ - new_list_pointer = copy_object(object, 2); - new_cons = (struct cons *) native_pointer(new_list_pointer); - - /* Set forwarding pointer. */ - cons->car = new_list_pointer; - - /* Try to linearize the list in the cdr direction to help reduce */ - /* paging. */ - - while (1) { - lispobj cdr, new_cdr, first; - struct cons *cdr_cons, *new_cdr_cons; - - cdr = cons->cdr; - - if (lowtag_of(cdr) != LIST_POINTER_LOWTAG || - !from_space_p(cdr) || - (is_lisp_pointer(first = *(lispobj *)native_pointer(cdr)) - && new_space_p(first))) - break; - - cdr_cons = (struct cons *) native_pointer(cdr); - - /* ### Don't use copy_object here */ - new_cdr = copy_object(cdr, 2); - new_cdr_cons = (struct cons *) native_pointer(new_cdr); - - /* Set forwarding pointer */ - cdr_cons->car = new_cdr; - - /* Update the cdr of the last cons copied into new */ - /* space to keep the newspace scavenge from having to */ - /* do it. */ - new_cons->cdr = new_cdr; - - cons = cdr_cons; - new_cons = new_cdr_cons; - } - - return new_list_pointer; -} - - -/* scavenging and transporting other pointers */ - -static int -scav_other_pointer(lispobj *where, lispobj object) -{ - lispobj first, *first_pointer; - - gc_assert(is_lisp_pointer(object)); - - /* Object is a pointer into from space - not a FP */ - first_pointer = (lispobj *) native_pointer(object); - first = *first_pointer = (transother[widetag_of(*first_pointer)])(object); - - gc_assert(is_lisp_pointer(first)); - gc_assert(!from_space_p(first)); - - *where = first; - return 1; -} - - -/* immediate, boxed, and unboxed objects */ - -static int -size_pointer(lispobj *where) -{ - return 1; -} - -static int -scav_immediate(lispobj *where, lispobj object) -{ - return 1; -} - -static lispobj -trans_immediate(lispobj object) -{ - fprintf(stderr, "GC lossage. Trying to transport an immediate!?\n"); - lose(NULL); - return NIL; -} - -static int -size_immediate(lispobj *where) -{ - return 1; -} - - -static int -scav_boxed(lispobj *where, lispobj object) -{ - return 1; -} - -static lispobj -trans_boxed(lispobj object) -{ - lispobj header; - unsigned long length; - - gc_assert(is_lisp_pointer(object)); - - header = *((lispobj *) native_pointer(object)); - length = HeaderValue(header) + 1; - length = CEILING(length, 2); - - return copy_object(object, length); -} - -static int -size_boxed(lispobj *where) -{ - lispobj header; - unsigned long length; - - header = *where; - length = HeaderValue(header) + 1; - length = CEILING(length, 2); - - return length; -} - -/* Note: on the sparc we don't have to do anything special for fdefns, */ -/* 'cause the raw-addr has a function lowtag. */ -#ifndef sparc -static int -scav_fdefn(lispobj *where, lispobj object) -{ - struct fdefn *fdefn; - - fdefn = (struct fdefn *)where; - - if ((char *)(fdefn->fun + FUN_RAW_ADDR_OFFSET) - == (char *)((unsigned long)(fdefn->raw_addr))) { - scavenge(where + 1, sizeof(struct fdefn)/sizeof(lispobj) - 1); - fdefn->raw_addr = - (u32) ((char *) LOW_WORD(fdefn->fun)) + FUN_RAW_ADDR_OFFSET; - return sizeof(struct fdefn) / sizeof(lispobj); - } - else - return 1; -} -#endif - -static int -scav_unboxed(lispobj *where, lispobj object) -{ - unsigned long length; - - length = HeaderValue(object) + 1; - length = CEILING(length, 2); - - return length; -} - -static lispobj -trans_unboxed(lispobj object) -{ - lispobj header; - unsigned long length; - - - gc_assert(is_lisp_pointer(object)); - - header = *((lispobj *) native_pointer(object)); - length = HeaderValue(header) + 1; - length = CEILING(length, 2); - - return copy_object(object, length); -} - -static int -size_unboxed(lispobj *where) -{ - lispobj header; - unsigned long length; - - header = *where; - length = HeaderValue(header) + 1; - length = CEILING(length, 2); - - return length; -} - - -/* vector-like objects */ - -#define NWORDS(x,y) (CEILING((x),(y)) / (y)) - -static int -scav_string(lispobj *where, lispobj object) -{ - struct vector *vector; - int length, nwords; - - /* NOTE: Strings contain one more byte of data than the length */ - /* slot indicates. */ - - vector = (struct vector *) where; - length = fixnum_value(vector->length) + 1; - nwords = CEILING(NWORDS(length, 4) + 2, 2); - - return nwords; -} - -static lispobj -trans_string(lispobj object) -{ - struct vector *vector; - int length, nwords; - - gc_assert(is_lisp_pointer(object)); - - /* NOTE: Strings contain one more byte of data than the length */ - /* slot indicates. */ - - vector = (struct vector *) native_pointer(object); - length = fixnum_value(vector->length) + 1; - nwords = CEILING(NWORDS(length, 4) + 2, 2); - - return copy_object(object, nwords); -} - -static int -size_string(lispobj *where) -{ - struct vector *vector; - int length, nwords; - - /* NOTE: Strings contain one more byte of data than the length */ - /* slot indicates. */ - - vector = (struct vector *) where; - length = fixnum_value(vector->length) + 1; - nwords = CEILING(NWORDS(length, 4) + 2, 2); - - return nwords; -} - -static int -scav_vector(lispobj *where, lispobj object) -{ - if (HeaderValue(object) == subtype_VectorValidHashing) { - *where = - (subtype_VectorMustRehash<length); - nwords = CEILING(length + 2, 2); - - return copy_object(object, nwords); -} - -static int -size_vector(lispobj *where) -{ - struct vector *vector; - int length, nwords; - - vector = (struct vector *) where; - length = fixnum_value(vector->length); - nwords = CEILING(length + 2, 2); - - return nwords; -} - - -static int -scav_vector_bit(lispobj *where, lispobj object) -{ - struct vector *vector; - int length, nwords; - - vector = (struct vector *) where; - length = fixnum_value(vector->length); - nwords = CEILING(NWORDS(length, 32) + 2, 2); - - return nwords; -} - -static lispobj -trans_vector_bit(lispobj object) -{ - struct vector *vector; - int length, nwords; - - gc_assert(is_lisp_pointer(object)); - - vector = (struct vector *) native_pointer(object); - length = fixnum_value(vector->length); - nwords = CEILING(NWORDS(length, 32) + 2, 2); - - return copy_object(object, nwords); -} - -static int -size_vector_bit(lispobj *where) -{ - struct vector *vector; - int length, nwords; - - vector = (struct vector *) where; - length = fixnum_value(vector->length); - nwords = CEILING(NWORDS(length, 32) + 2, 2); - - return nwords; -} - - -static int -scav_vector_unsigned_byte_2(lispobj *where, lispobj object) -{ - struct vector *vector; - int length, nwords; - - vector = (struct vector *) where; - length = fixnum_value(vector->length); - nwords = CEILING(NWORDS(length, 16) + 2, 2); - - return nwords; -} - -static lispobj -trans_vector_unsigned_byte_2(lispobj object) -{ - struct vector *vector; - int length, nwords; - - gc_assert(is_lisp_pointer(object)); - - vector = (struct vector *) native_pointer(object); - length = fixnum_value(vector->length); - nwords = CEILING(NWORDS(length, 16) + 2, 2); - - return copy_object(object, nwords); -} - -static int -size_vector_unsigned_byte_2(lispobj *where) -{ - struct vector *vector; - int length, nwords; - - vector = (struct vector *) where; - length = fixnum_value(vector->length); - nwords = CEILING(NWORDS(length, 16) + 2, 2); - - return nwords; -} - - -static int -scav_vector_unsigned_byte_4(lispobj *where, lispobj object) -{ - struct vector *vector; - int length, nwords; - - vector = (struct vector *) where; - length = fixnum_value(vector->length); - nwords = CEILING(NWORDS(length, 8) + 2, 2); - - return nwords; -} - -static lispobj -trans_vector_unsigned_byte_4(lispobj object) -{ - struct vector *vector; - int length, nwords; - - gc_assert(is_lisp_pointer(object)); - - vector = (struct vector *) native_pointer(object); - length = fixnum_value(vector->length); - nwords = CEILING(NWORDS(length, 8) + 2, 2); - - return copy_object(object, nwords); -} - -static int -size_vector_unsigned_byte_4(lispobj *where) -{ - struct vector *vector; - int length, nwords; - - vector = (struct vector *) where; - length = fixnum_value(vector->length); - nwords = CEILING(NWORDS(length, 8) + 2, 2); - - return nwords; -} - - -static int -scav_vector_unsigned_byte_8(lispobj *where, lispobj object) -{ - struct vector *vector; - int length, nwords; - - vector = (struct vector *) where; - length = fixnum_value(vector->length); - nwords = CEILING(NWORDS(length, 4) + 2, 2); - - return nwords; -} - -static lispobj -trans_vector_unsigned_byte_8(lispobj object) -{ - struct vector *vector; - int length, nwords; - - gc_assert(is_lisp_pointer(object)); - - vector = (struct vector *) native_pointer(object); - length = fixnum_value(vector->length); - nwords = CEILING(NWORDS(length, 4) + 2, 2); - - return copy_object(object, nwords); -} - -static int -size_vector_unsigned_byte_8(lispobj *where) -{ - struct vector *vector; - int length, nwords; - - vector = (struct vector *) where; - length = fixnum_value(vector->length); - nwords = CEILING(NWORDS(length, 4) + 2, 2); - - return nwords; -} - - -static int -scav_vector_unsigned_byte_16(lispobj *where, lispobj object) -{ - struct vector *vector; - int length, nwords; - - vector = (struct vector *) where; - length = fixnum_value(vector->length); - nwords = CEILING(NWORDS(length, 2) + 2, 2); - - return nwords; -} - -static lispobj -trans_vector_unsigned_byte_16(lispobj object) -{ - struct vector *vector; - int length, nwords; - - gc_assert(is_lisp_pointer(object)); - - vector = (struct vector *) native_pointer(object); - length = fixnum_value(vector->length); - nwords = CEILING(NWORDS(length, 2) + 2, 2); - - return copy_object(object, nwords); -} - -static int -size_vector_unsigned_byte_16(lispobj *where) -{ - struct vector *vector; - int length, nwords; - - vector = (struct vector *) where; - length = fixnum_value(vector->length); - nwords = CEILING(NWORDS(length, 2) + 2, 2); - - return nwords; -} - - -static int -scav_vector_unsigned_byte_32(lispobj *where, lispobj object) -{ - struct vector *vector; - int length, nwords; - - vector = (struct vector *) where; - length = fixnum_value(vector->length); - nwords = CEILING(length + 2, 2); - - return nwords; -} - -static lispobj -trans_vector_unsigned_byte_32(lispobj object) -{ - struct vector *vector; - int length, nwords; - - gc_assert(is_lisp_pointer(object)); - - vector = (struct vector *) native_pointer(object); - length = fixnum_value(vector->length); - nwords = CEILING(length + 2, 2); - - return copy_object(object, nwords); -} - -static int -size_vector_unsigned_byte_32(lispobj *where) -{ - struct vector *vector; - int length, nwords; - - vector = (struct vector *) where; - length = fixnum_value(vector->length); - nwords = CEILING(length + 2, 2); - - return nwords; -} - -static int -scav_vector_single_float(lispobj *where, lispobj object) -{ - struct vector *vector; - int length, nwords; - - vector = (struct vector *) where; - length = fixnum_value(vector->length); - nwords = CEILING(length + 2, 2); - - return nwords; -} - -static lispobj -trans_vector_single_float(lispobj object) -{ - struct vector *vector; - int length, nwords; - - gc_assert(is_lisp_pointer(object)); - - vector = (struct vector *) native_pointer(object); - length = fixnum_value(vector->length); - nwords = CEILING(length + 2, 2); - - return copy_object(object, nwords); -} - -static int -size_vector_single_float(lispobj *where) -{ - struct vector *vector; - int length, nwords; - - vector = (struct vector *) where; - length = fixnum_value(vector->length); - nwords = CEILING(length + 2, 2); - - return nwords; -} - - -static int -scav_vector_double_float(lispobj *where, lispobj object) -{ - struct vector *vector; - int length, nwords; - - vector = (struct vector *) where; - length = fixnum_value(vector->length); - nwords = CEILING(length * 2 + 2, 2); - - return nwords; -} - -static lispobj -trans_vector_double_float(lispobj object) -{ - struct vector *vector; - int length, nwords; - - gc_assert(is_lisp_pointer(object)); - - vector = (struct vector *) native_pointer(object); - length = fixnum_value(vector->length); - nwords = CEILING(length * 2 + 2, 2); - - return copy_object(object, nwords); -} - -static int -size_vector_double_float(lispobj *where) -{ - struct vector *vector; - int length, nwords; - - vector = (struct vector *) where; - length = fixnum_value(vector->length); - nwords = CEILING(length * 2 + 2, 2); - - return nwords; -} - - -#ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG -static int -scav_vector_long_float(lispobj *where, lispobj object) -{ - struct vector *vector; - int length, nwords; - - vector = (struct vector *) where; - length = fixnum_value(vector->length); -#ifdef sparc - nwords = CEILING(length * 4 + 2, 2); -#endif - - return nwords; -} - -static lispobj -trans_vector_long_float(lispobj object) -{ - struct vector *vector; - int length, nwords; - - gc_assert(is_lisp_pointer(object)); - - vector = (struct vector *) native_pointer(object); - length = fixnum_value(vector->length); -#ifdef sparc - nwords = CEILING(length * 4 + 2, 2); -#endif - - return copy_object(object, nwords); -} - -static int -size_vector_long_float(lispobj *where) -{ - struct vector *vector; - int length, nwords; - - vector = (struct vector *) where; - length = fixnum_value(vector->length); -#ifdef sparc - nwords = CEILING(length * 4 + 2, 2); -#endif - - return nwords; -} -#endif - - -#ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG -static int -scav_vector_complex_single_float(lispobj *where, lispobj object) -{ - struct vector *vector; - int length, nwords; - - vector = (struct vector *) where; - length = fixnum_value(vector->length); - nwords = CEILING(length * 2 + 2, 2); - - return nwords; -} - -static lispobj -trans_vector_complex_single_float(lispobj object) -{ - struct vector *vector; - int length, nwords; - - gc_assert(is_lisp_pointer(object)); - - vector = (struct vector *) native_pointer(object); - length = fixnum_value(vector->length); - nwords = CEILING(length * 2 + 2, 2); - - return copy_object(object, nwords); -} - -static int -size_vector_complex_single_float(lispobj *where) -{ - struct vector *vector; - int length, nwords; - - vector = (struct vector *) where; - length = fixnum_value(vector->length); - nwords = CEILING(length * 2 + 2, 2); - - return nwords; -} -#endif - -#ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG -static int -scav_vector_complex_double_float(lispobj *where, lispobj object) -{ - struct vector *vector; - int length, nwords; - - vector = (struct vector *) where; - length = fixnum_value(vector->length); - nwords = CEILING(length * 4 + 2, 2); - - return nwords; -} - -static lispobj -trans_vector_complex_double_float(lispobj object) -{ - struct vector *vector; - int length, nwords; - - gc_assert(is_lisp_pointer(object)); - - vector = (struct vector *) native_pointer(object); - length = fixnum_value(vector->length); - nwords = CEILING(length * 4 + 2, 2); - - return copy_object(object, nwords); -} - -static int -size_vector_complex_double_float(lispobj *where) -{ - struct vector *vector; - int length, nwords; - - vector = (struct vector *) where; - length = fixnum_value(vector->length); - nwords = CEILING(length * 4 + 2, 2); - - return nwords; -} -#endif - -#ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG -static int -scav_vector_complex_long_float(lispobj *where, lispobj object) -{ - struct vector *vector; - int length, nwords; - - vector = (struct vector *) where; - length = fixnum_value(vector->length); -#ifdef sparc - nwords = CEILING(length * 8 + 2, 2); -#endif - - return nwords; -} - -static lispobj -trans_vector_complex_long_float(lispobj object) -{ - struct vector *vector; - int length, nwords; - - gc_assert(is_lisp_pointer(object)); - - vector = (struct vector *) native_pointer(object); - length = fixnum_value(vector->length); -#ifdef sparc - nwords = CEILING(length * 8 + 2, 2); -#endif - - return copy_object(object, nwords); -} - -static int -size_vector_complex_long_float(lispobj *where) -{ - struct vector *vector; - int length, nwords; - - vector = (struct vector *) where; - length = fixnum_value(vector->length); -#ifdef sparc - nwords = CEILING(length * 8 + 2, 2); -#endif - - return nwords; -} -#endif - - -/* weak pointers */ - -#define WEAK_POINTER_NWORDS \ - CEILING((sizeof(struct weak_pointer) / sizeof(lispobj)), 2) - -static int -scav_weak_pointer(lispobj *where, lispobj object) -{ - /* Do not let GC scavenge the value slot of the weak pointer */ - /* (that is why it is a weak pointer). Note: we could use */ - /* the scav_unboxed method here. */ - - return WEAK_POINTER_NWORDS; -} - -static lispobj -trans_weak_pointer(lispobj object) -{ - lispobj copy; - struct weak_pointer *wp; - - gc_assert(is_lisp_pointer(object)); - -#if defined(DEBUG_WEAK) - printf("Transporting weak pointer from 0x%08x\n", object); -#endif - - /* Need to remember where all the weak pointers are that have */ - /* been transported so they can be fixed up in a post-GC pass. */ - - copy = copy_object(object, WEAK_POINTER_NWORDS); - wp = (struct weak_pointer *) native_pointer(copy); - - - /* Push the weak pointer onto the list of weak pointers. */ - wp->next = LOW_WORD(weak_pointers); - weak_pointers = wp; - - return copy; -} - -static int -size_weak_pointer(lispobj *where) -{ - return WEAK_POINTER_NWORDS; -} - -void scan_weak_pointers(void) -{ - struct weak_pointer *wp; - - for (wp = weak_pointers; wp != (struct weak_pointer *) NULL; - wp = (struct weak_pointer *)((unsigned long)wp->next)) { - lispobj value; - lispobj first, *first_pointer; - - value = wp->value; - -#if defined(DEBUG_WEAK) - printf("Weak pointer at 0x%p\n", wp); - printf("Value: 0x%08x\n", (unsigned int) value); -#endif - - if (!(is_lisp_pointer(value) && from_space_p(value))) - continue; - - /* Now, we need to check if the object has been */ - /* forwarded. If it has been, the weak pointer is */ - /* still good and needs to be updated. Otherwise, the */ - /* weak pointer needs to be nil'ed out. */ - - first_pointer = (lispobj *) native_pointer(value); - first = *first_pointer; - -#if defined(DEBUG_WEAK) - printf("First: 0x%08x\n", (unsigned long) first); -#endif - - if (is_lisp_pointer(first) && new_space_p(first)) - wp->value = first; - else { - wp->value = NIL; - wp->broken = T; - } - } -} - - - -/* initialization */ - -static int -scav_lose(lispobj *where, lispobj object) -{ - fprintf(stderr, "GC lossage. No scavenge function for object 0x%08x (at 0x%016lx)\n", - (unsigned int) object, (unsigned long)where); - lose(NULL); - return 0; -} - -static lispobj -trans_lose(lispobj object) -{ - fprintf(stderr, "GC lossage. No transport function for object 0x%08x\n", - (unsigned int)object); - lose(NULL); - return NIL; -} - -static int -size_lose(lispobj *where) -{ - fprintf(stderr, "Size lossage. No size function for object at 0x%p\n", - where); - fprintf(stderr, "First word of object: 0x%08x\n", - (u32) *where); - return 1; -} - -/* KLUDGE: SBCL already has two GC implementations, and if someday the - * precise generational GC is revived, it might have three. It would - * be nice to share the scavtab[] data set up here, and perhaps other - * things too, between all of them, rather than trying to maintain - * multiple copies. -- WHN 2001-05-09 */ -void -gc_init(void) -{ - int i; - - /* scavenge table */ - for (i = 0; i < 256; i++) - scavtab[i] = scav_lose; - /* scavtab[i] = scav_immediate; */ - - for (i = 0; i < 32; i++) { - scavtab[EVEN_FIXNUM_LOWTAG|(i<<3)] = scav_immediate; - scavtab[FUN_POINTER_LOWTAG|(i<<3)] = scav_fun_pointer; - /* skipping OTHER_IMMEDIATE_0_LOWTAG */ - scavtab[LIST_POINTER_LOWTAG|(i<<3)] = scav_list_pointer; - scavtab[ODD_FIXNUM_LOWTAG|(i<<3)] = scav_immediate; - scavtab[INSTANCE_POINTER_LOWTAG|(i<<3)] =scav_instance_pointer; - /* skipping OTHER_IMMEDIATE_1_LOWTAG */ - scavtab[OTHER_POINTER_LOWTAG|(i<<3)] = scav_other_pointer; - } - - scavtab[BIGNUM_WIDETAG] = scav_unboxed; - scavtab[RATIO_WIDETAG] = scav_boxed; - scavtab[SINGLE_FLOAT_WIDETAG] = scav_unboxed; - scavtab[DOUBLE_FLOAT_WIDETAG] = scav_unboxed; -#ifdef LONG_FLOAT_WIDETAG - scavtab[LONG_FLOAT_WIDETAG] = scav_unboxed; -#endif - scavtab[COMPLEX_WIDETAG] = scav_boxed; -#ifdef COMPLEX_SINGLE_FLOAT_WIDETAG - scavtab[COMPLEX_SINGLE_FLOAT_WIDETAG] = scav_unboxed; -#endif -#ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG - scavtab[COMPLEX_DOUBLE_FLOAT_WIDETAG] = scav_unboxed; -#endif -#ifdef COMPLEX_LONG_FLOAT_WIDETAG - scavtab[COMPLEX_LONG_FLOAT_WIDETAG] = scav_unboxed; -#endif - scavtab[SIMPLE_ARRAY_WIDETAG] = scav_boxed; - scavtab[SIMPLE_STRING_WIDETAG] = scav_string; - scavtab[SIMPLE_BIT_VECTOR_WIDETAG] = scav_vector_bit; - scavtab[SIMPLE_VECTOR_WIDETAG] = scav_vector; - scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG] = - scav_vector_unsigned_byte_2; - scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG] = - scav_vector_unsigned_byte_4; - scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG] = - scav_vector_unsigned_byte_8; - scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG] = - scav_vector_unsigned_byte_16; - scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG] = - scav_vector_unsigned_byte_32; -#ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG - scavtab[SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG] = - scav_vector_unsigned_byte_8; -#endif -#ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG - scavtab[SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG] = - scav_vector_unsigned_byte_16; -#endif -#ifdef SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG - scavtab[SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG] = - scav_vector_unsigned_byte_32; -#endif -#ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG - scavtab[SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG] = - scav_vector_unsigned_byte_32; -#endif - scavtab[SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG] = scav_vector_single_float; - scavtab[SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG] = scav_vector_double_float; -#ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG - scavtab[SIMPLE_ARRAY_LONG_FLOAT_WIDETAG] = scav_vector_long_float; -#endif -#ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG - scavtab[SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG] = - scav_vector_complex_single_float; -#endif -#ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG - scavtab[SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG] = - scav_vector_complex_double_float; -#endif -#ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG - scavtab[SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG] = - scav_vector_complex_long_float; -#endif - scavtab[COMPLEX_STRING_WIDETAG] = scav_boxed; - scavtab[COMPLEX_BIT_VECTOR_WIDETAG] = scav_boxed; - scavtab[COMPLEX_VECTOR_WIDETAG] = scav_boxed; - scavtab[COMPLEX_ARRAY_WIDETAG] = scav_boxed; - scavtab[CODE_HEADER_WIDETAG] = scav_code_header; - scavtab[SIMPLE_FUN_HEADER_WIDETAG] = scav_fun_header; - scavtab[CLOSURE_FUN_HEADER_WIDETAG] = scav_fun_header; - scavtab[RETURN_PC_HEADER_WIDETAG] = scav_return_pc_header; -#ifdef __i386__ - scavtab[CLOSURE_HEADER_WIDETAG] = scav_closure_header; - scavtab[FUNCALLABLE_INSTANCE_HEADER_WIDETAG] = scav_closure_header; -#else - scavtab[CLOSURE_HEADER_WIDETAG] = scav_boxed; - scavtab[FUNCALLABLE_INSTANCE_HEADER_WIDETAG] = scav_boxed; -#endif - scavtab[VALUE_CELL_HEADER_WIDETAG] = scav_boxed; - scavtab[SYMBOL_HEADER_WIDETAG] = scav_boxed; - scavtab[BASE_CHAR_WIDETAG] = scav_immediate; - scavtab[SAP_WIDETAG] = scav_unboxed; - scavtab[UNBOUND_MARKER_WIDETAG] = scav_immediate; - scavtab[WEAK_POINTER_WIDETAG] = scav_weak_pointer; - scavtab[INSTANCE_HEADER_WIDETAG] = scav_boxed; -#ifndef sparc - scavtab[FDEFN_WIDETAG] = scav_fdefn; -#else - scavtab[FDEFN_WIDETAG] = scav_boxed; -#endif - - /* Transport Other Table */ - for (i = 0; i < 256; i++) - transother[i] = trans_lose; - - transother[BIGNUM_WIDETAG] = trans_unboxed; - transother[RATIO_WIDETAG] = trans_boxed; - transother[SINGLE_FLOAT_WIDETAG] = trans_unboxed; - transother[DOUBLE_FLOAT_WIDETAG] = trans_unboxed; -#ifdef LONG_FLOAT_WIDETAG - transother[LONG_FLOAT_WIDETAG] = trans_unboxed; -#endif - transother[COMPLEX_WIDETAG] = trans_boxed; -#ifdef COMPLEX_SINGLE_FLOAT_WIDETAG - transother[COMPLEX_SINGLE_FLOAT_WIDETAG] = trans_unboxed; -#endif -#ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG - transother[COMPLEX_DOUBLE_FLOAT_WIDETAG] = trans_unboxed; -#endif -#ifdef COMPLEX_LONG_FLOAT_WIDETAG - transother[COMPLEX_LONG_FLOAT_WIDETAG] = trans_unboxed; -#endif - transother[SIMPLE_ARRAY_WIDETAG] = trans_boxed; - transother[SIMPLE_STRING_WIDETAG] = trans_string; - transother[SIMPLE_BIT_VECTOR_WIDETAG] = trans_vector_bit; - transother[SIMPLE_VECTOR_WIDETAG] = trans_vector; - transother[SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG] = - trans_vector_unsigned_byte_2; - transother[SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG] = - trans_vector_unsigned_byte_4; - transother[SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG] = - trans_vector_unsigned_byte_8; - transother[SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG] = - trans_vector_unsigned_byte_16; - transother[SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG] = - trans_vector_unsigned_byte_32; -#ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG - transother[SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG] = - trans_vector_unsigned_byte_8; -#endif -#ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG - transother[SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG] = - trans_vector_unsigned_byte_16; -#endif -#ifdef SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG - transother[SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG] = - trans_vector_unsigned_byte_32; -#endif -#ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG - transother[SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG] = - trans_vector_unsigned_byte_32; -#endif - transother[SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG] = - trans_vector_single_float; - transother[SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG] = - trans_vector_double_float; -#ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG - transother[SIMPLE_ARRAY_LONG_FLOAT_WIDETAG] = - trans_vector_long_float; -#endif -#ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG - transother[SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG] = - trans_vector_complex_single_float; -#endif -#ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG - transother[SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG] = - trans_vector_complex_double_float; -#endif -#ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG - transother[SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG] = - trans_vector_complex_long_float; -#endif - transother[COMPLEX_STRING_WIDETAG] = trans_boxed; - transother[COMPLEX_BIT_VECTOR_WIDETAG] = trans_boxed; - transother[COMPLEX_VECTOR_WIDETAG] = trans_boxed; - transother[COMPLEX_ARRAY_WIDETAG] = trans_boxed; - transother[CODE_HEADER_WIDETAG] = trans_code_header; - transother[SIMPLE_FUN_HEADER_WIDETAG] = trans_fun_header; - transother[CLOSURE_FUN_HEADER_WIDETAG] = trans_fun_header; - transother[RETURN_PC_HEADER_WIDETAG] = trans_return_pc_header; - transother[CLOSURE_HEADER_WIDETAG] = trans_boxed; - transother[FUNCALLABLE_INSTANCE_HEADER_WIDETAG] = trans_boxed; - transother[VALUE_CELL_HEADER_WIDETAG] = trans_boxed; - transother[SYMBOL_HEADER_WIDETAG] = trans_boxed; - transother[BASE_CHAR_WIDETAG] = trans_immediate; - transother[SAP_WIDETAG] = trans_unboxed; - transother[UNBOUND_MARKER_WIDETAG] = trans_immediate; - transother[WEAK_POINTER_WIDETAG] = trans_weak_pointer; - transother[INSTANCE_HEADER_WIDETAG] = trans_boxed; - transother[FDEFN_WIDETAG] = trans_boxed; - - /* Size table */ - - for (i = 0; i < 256; i++) - sizetab[i] = size_lose; - - for (i = 0; i < 32; i++) { - sizetab[EVEN_FIXNUM_LOWTAG|(i<<3)] = size_immediate; - sizetab[FUN_POINTER_LOWTAG|(i<<3)] = size_pointer; - /* skipping OTHER_IMMEDIATE_0_LOWTAG */ - sizetab[LIST_POINTER_LOWTAG|(i<<3)] = size_pointer; - sizetab[ODD_FIXNUM_LOWTAG|(i<<3)] = size_immediate; - sizetab[INSTANCE_POINTER_LOWTAG|(i<<3)] = size_pointer; - /* skipping OTHER_IMMEDIATE_1_LOWTAG */ - sizetab[OTHER_POINTER_LOWTAG|(i<<3)] = size_pointer; - } - - sizetab[BIGNUM_WIDETAG] = size_unboxed; - sizetab[RATIO_WIDETAG] = size_boxed; - sizetab[SINGLE_FLOAT_WIDETAG] = size_unboxed; - sizetab[DOUBLE_FLOAT_WIDETAG] = size_unboxed; -#ifdef LONG_FLOAT_WIDETAG - sizetab[LONG_FLOAT_WIDETAG] = size_unboxed; -#endif - sizetab[COMPLEX_WIDETAG] = size_boxed; -#ifdef COMPLEX_SINGLE_FLOAT_WIDETAG - sizetab[COMPLEX_SINGLE_FLOAT_WIDETAG] = size_unboxed; -#endif -#ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG - sizetab[COMPLEX_DOUBLE_FLOAT_WIDETAG] = size_unboxed; -#endif -#ifdef COMPLEX_LONG_FLOAT_WIDETAG - sizetab[COMPLEX_LONG_FLOAT_WIDETAG] = size_unboxed; -#endif - sizetab[SIMPLE_ARRAY_WIDETAG] = size_boxed; - sizetab[SIMPLE_STRING_WIDETAG] = size_string; - sizetab[SIMPLE_BIT_VECTOR_WIDETAG] = size_vector_bit; - sizetab[SIMPLE_VECTOR_WIDETAG] = size_vector; - sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG] = - size_vector_unsigned_byte_2; - sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG] = - size_vector_unsigned_byte_4; - sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG] = - size_vector_unsigned_byte_8; - sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG] = - size_vector_unsigned_byte_16; - sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG] = - size_vector_unsigned_byte_32; -#ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG - sizetab[SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG] = - size_vector_unsigned_byte_8; -#endif -#ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG - sizetab[SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG] = - size_vector_unsigned_byte_16; -#endif -#ifdef SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG - sizetab[SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG] = - size_vector_unsigned_byte_32; -#endif -#ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG - sizetab[SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG] = - size_vector_unsigned_byte_32; -#endif - sizetab[SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG] = size_vector_single_float; - sizetab[SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG] = size_vector_double_float; -#ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG - sizetab[SIMPLE_ARRAY_LONG_FLOAT_WIDETAG] = size_vector_long_float; -#endif -#ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG - sizetab[SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG] = - size_vector_complex_single_float; -#endif -#ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG - sizetab[SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG] = - size_vector_complex_double_float; -#endif -#ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG - sizetab[SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG] = - size_vector_complex_long_float; -#endif - sizetab[COMPLEX_STRING_WIDETAG] = size_boxed; - sizetab[COMPLEX_BIT_VECTOR_WIDETAG] = size_boxed; - sizetab[COMPLEX_VECTOR_WIDETAG] = size_boxed; - sizetab[COMPLEX_ARRAY_WIDETAG] = size_boxed; - sizetab[CODE_HEADER_WIDETAG] = size_code_header; -#if 0 - /* Shouldn't see these so just lose if it happens */ - sizetab[SIMPLE_FUN_HEADER_WIDETAG] = size_function_header; - sizetab[CLOSURE_FUN_HEADER_WIDETAG] = size_function_header; - sizetab[RETURN_PC_HEADER_WIDETAG] = size_return_pc_header; -#endif - sizetab[CLOSURE_HEADER_WIDETAG] = size_boxed; - sizetab[FUNCALLABLE_INSTANCE_HEADER_WIDETAG] = size_boxed; - sizetab[VALUE_CELL_HEADER_WIDETAG] = size_boxed; - sizetab[SYMBOL_HEADER_WIDETAG] = size_boxed; - sizetab[BASE_CHAR_WIDETAG] = size_immediate; - sizetab[SAP_WIDETAG] = size_unboxed; - sizetab[UNBOUND_MARKER_WIDETAG] = size_immediate; - sizetab[WEAK_POINTER_WIDETAG] = size_weak_pointer; - sizetab[INSTANCE_HEADER_WIDETAG] = size_boxed; - sizetab[FDEFN_WIDETAG] = size_boxed; -} - -/* noise to manipulate the gc trigger stuff */ - -void set_auto_gc_trigger(os_vm_size_t dynamic_usage) -{ - os_vm_address_t addr=(os_vm_address_t)current_dynamic_space - + dynamic_usage; - - long length = DYNAMIC_SPACE_SIZE - dynamic_usage; - - if (addr < (os_vm_address_t)dynamic_space_free_pointer) { - fprintf(stderr, - "set_auto_gc_trigger: tried to set gc trigger too low! (%d < %p)\n", - (unsigned int)dynamic_usage, - (os_vm_address_t)dynamic_space_free_pointer - - (os_vm_address_t)current_dynamic_space); - lose("lost"); - } - else if (length < 0) { - fprintf(stderr, - "set_auto_gc_trigger: tried to set gc trigger too high! (%p)\n", - dynamic_usage); - lose("lost"); - } - - addr=os_round_up_to_page(addr); - length=os_trunc_size_to_page(length); - -#if defined(SUNOS) || defined(SOLARIS) - os_invalidate(addr,length); -#else - os_protect(addr, length, 0); -#endif - - current_auto_gc_trigger = (lispobj *)addr; -} - -void clear_auto_gc_trigger(void) -{ - if (current_auto_gc_trigger!=NULL){ -#if defined(SUNOS) || defined(SOLARIS)/* don't want to force whole space into swapping mode... */ - os_vm_address_t addr=(os_vm_address_t)current_auto_gc_trigger; - os_vm_size_t length= - DYNAMIC_SPACE_SIZE + (os_vm_address_t)current_dynamic_space - addr; - - os_validate(addr,length); -#else - os_protect((os_vm_address_t)current_dynamic_space, - DYNAMIC_SPACE_SIZE, - OS_VM_PROT_ALL); -#endif - - current_auto_gc_trigger = NULL; - } -} diff --git a/src/runtime/gc.h b/src/runtime/gc.h index 7a2fec1..ff1276e 100644 --- a/src/runtime/gc.h +++ b/src/runtime/gc.h @@ -17,12 +17,7 @@ #define _GC_H_ extern void gc_init(void); - -/* Note: CMU CL had two different argument conventions for - * collect_garbage(..), depending on whether gencgc was in use. SBCL - * should have only one, which is automatic right now (20000814) since - * we only support gencgc, but should also be maintained if someone - * adds another GC, or ports one of the other CMU CL GCs like gengc. */ +extern void gc_initialize_pointers(void); extern void collect_garbage(unsigned last_gen); #include "os.h" diff --git a/src/runtime/gencgc-internal.h b/src/runtime/gencgc-internal.h new file mode 100644 index 0000000..6f75ae1 --- /dev/null +++ b/src/runtime/gencgc-internal.h @@ -0,0 +1,132 @@ +/* + * Generational Conservative Garbage Collector for SBCL x86 + * + * inline functions that gc-common.c needs sight of + */ + + +/* + * This software is part of the SBCL system. See the README file for + * more information. + * + * This software is derived from the CMU CL system, which was + * written at Carnegie Mellon University and released into the + * public domain. The software is in the public domain and is + * provided with absolutely no warranty. See the COPYING and CREDITS + * files for more information. + */ + +#ifndef _GENCGC_INTERNAL_H_ +#define _GENCGC_INTERNAL_H_ + +void gc_free_heap(void); +inline int find_page_index(void *); +inline void *page_address(int); +int gencgc_handle_wp_violation(void *); +lispobj *search_dynamic_space(lispobj *); + +struct page { + + unsigned + /* This is set when the page is write-protected. This should + * always reflect the actual write_protect status of a page. + * (If the page is written into, we catch the exception, make + * the page writable, and clear this flag.) */ + write_protected :1, + /* This flag is set when the above write_protected flag is + * cleared by the SIGBUS handler (or SIGSEGV handler, for some + * OSes). This is useful for re-scavenging pages that are + * written during a GC. */ + write_protected_cleared :1, + /* the region the page is allocated to: 0 for a free page; 1 + * for boxed objects; 2 for unboxed objects. If the page is + * free the following slots are invalid (well the bytes_used + * must be 0). */ + allocated :2, + /* If this page should not be moved during a GC then this flag + * is set. It's only valid during a GC for allocated pages. */ + dont_move :1, + /* If the page is part of a large object then this flag is + * set. No other objects should be allocated to these pages. + * This is only valid when the page is allocated. */ + large_object :1; + + /* the generation that this page belongs to. This should be valid + * for all pages that may have objects allocated, even current + * allocation region pages - this allows the space of an object to + * be easily determined. */ + int gen; + + /* the number of bytes of this page that are used. This may be less + * than the actual bytes used for pages within the current + * allocation regions. It should be 0 for all unallocated pages (not + * hard to achieve). */ + int bytes_used; + + /* It is important to know the offset to the first object in the + * page. Currently it's only important to know if an object starts + * at the beginning of the page in which case the offset would be 0. */ + int first_object_offset; +}; + +/* values for the page.allocated field */ + + +/* the number of pages needed for the dynamic space - rounding up */ +#define NUM_PAGES ((DYNAMIC_SPACE_SIZE+4095)/4096) +extern struct page page_table[NUM_PAGES]; + +/* Abstract out the data for an allocation region allowing a single + * routine to be used for allocation and closing. */ +struct alloc_region { + + /* These two are needed for quick allocation. */ + void *free_pointer; + void *end_addr; /* pointer to the byte after the last usable byte */ + + /* These are needed when closing the region. */ + int first_page; + int last_page; + void *start_addr; +}; + +extern struct alloc_region boxed_region; +extern struct alloc_region unboxed_region; +extern int from_space, new_space; +extern struct weak_pointer *weak_pointers; + +void gencgc_pickup_dynamic(void); + +void sniff_code_object(struct code *code, unsigned displacement); +void gencgc_apply_code_fixups(struct code *old_code, struct code *new_code); + +int update_x86_dynamic_space_free_pointer(void); +void gc_alloc_update_page_tables(int unboxed, + struct alloc_region *alloc_region); +/* + * predicates + */ +static inline int +space_matches_p(lispobj obj, int space) +{ + int page_index=(void*)obj - (void *)DYNAMIC_SPACE_START; + return ((page_index >= 0) + && ((page_index = ((unsigned int)page_index)/4096) < NUM_PAGES) + && (page_table[page_index].gen == space)); +} + +static inline boolean +from_space_p(lispobj obj) +{ + return space_matches_p(obj,from_space); +} + +static inline boolean +new_space_p(lispobj obj) +{ + return space_matches_p(obj,new_space); +} + + + +#endif diff --git a/src/runtime/gencgc.c b/src/runtime/gencgc.c index a90c60d..e33dcc0 100644 --- a/src/runtime/gencgc.c +++ b/src/runtime/gencgc.c @@ -36,11 +36,11 @@ #include "lispregs.h" #include "arch.h" #include "gc.h" -#include "gencgc.h" +#include "gc-internal.h" -/* a function defined externally in assembly language, called from - * this file */ +/* assembly language stub that executes trap_PendingInterrupt */ void do_pending_interrupt(void); + /* * GC parameters @@ -76,19 +76,7 @@ unsigned large_object_size = 4 * 4096; * debugging */ -#define gc_abort() lose("GC invariant lost, file \"%s\", line %d", \ - __FILE__, __LINE__) -/* FIXME: In CMU CL, this was "#if 0" with no explanation. Find out - * how much it costs to make it "#if 1". If it's not too expensive, - * keep it. */ -#if 1 -#define gc_assert(ex) do { \ - if (!(ex)) gc_abort(); \ -} while (0) -#else -#define gc_assert(ex) -#endif /* the verbosity level. All non-error messages are disabled at level 0; * and only a few rare messages are printed at level 1. */ @@ -135,8 +123,9 @@ static unsigned long auto_gc_trigger = 0; /* the source and destination generations. These are set before a GC starts * scavenging. */ -static int from_space; -static int new_space; +int from_space; +int new_space; + /* FIXME: It would be nice to use this symbolic constant instead of * bare 4096 almost everywhere. We could also use an assertion that @@ -152,6 +141,7 @@ struct page page_table[NUM_PAGES]; * is needed. */ static void *heap_base = NULL; + /* Calculate the start address for the given page number. */ inline void * page_address(int page_num) @@ -221,11 +211,15 @@ struct generation { * added, in which case a GC could be a waste of time */ double min_av_mem_age; }; +/* the number of actual generations. (The number of 'struct + * generation' objects is one more than this, because one object + * serves as scratch when GC'ing.) */ +#define NUM_GENERATIONS 6 /* an array of generation structures. There needs to be one more * generation structure than actual generations as the oldest * generation is temporarily raised then lowered. */ -static struct generation generations[NUM_GENERATIONS+1]; +struct generation generations[NUM_GENERATIONS+1]; /* the oldest generation that is will currently be GCed by default. * Valid values are: 0, 1, ... (NUM_GENERATIONS-1) @@ -896,7 +890,7 @@ gc_alloc_update_page_tables(int unboxed, struct alloc_region *alloc_region) static inline void *gc_quick_alloc(int nbytes); /* Allocate a possibly large object. */ -static void * +void * gc_alloc_large(int nbytes, int unboxed, struct alloc_region *alloc_region) { int first_page; @@ -1127,30 +1121,35 @@ gc_alloc_large(int nbytes, int unboxed, struct alloc_region *alloc_region) return((void *)(page_address(first_page)+orig_first_page_bytes_used)); } -/* Allocate bytes from the boxed_region. First checks whether there is - * room. If not then call gc_alloc_new_region() to find a new region - * with enough space. Return a pointer to the start of the region. */ -static void * -gc_alloc(int nbytes) +/* Allocate bytes. All the rest of the special-purpose allocation + * functions will eventually call this (instead of just duplicating + * parts of its code) */ + +void * +gc_general_alloc(int nbytes,int unboxed_p,int quick_p) { void *new_free_pointer; + struct alloc_region *my_region = + unboxed_p ? &unboxed_region : &boxed_region; /* FSHOW((stderr, "/gc_alloc %d\n", nbytes)); */ /* Check whether there is room in the current alloc region. */ - new_free_pointer = boxed_region.free_pointer + nbytes; + new_free_pointer = my_region->free_pointer + nbytes; - if (new_free_pointer <= boxed_region.end_addr) { + if (new_free_pointer <= my_region->end_addr) { /* If so then allocate from the current alloc region. */ - void *new_obj = boxed_region.free_pointer; - boxed_region.free_pointer = new_free_pointer; - - /* Check whether the alloc region is almost empty. */ - if ((boxed_region.end_addr - boxed_region.free_pointer) <= 32) { - /* If so finished with the current region. */ - gc_alloc_update_page_tables(0, &boxed_region); + void *new_obj = my_region->free_pointer; + my_region->free_pointer = new_free_pointer; + + /* Unless a `quick' alloc was requested, check whether the + alloc region is almost empty. */ + if (!quick_p && + (my_region->end_addr - my_region->free_pointer) <= 32) { + /* If so, finished with the current region. */ + gc_alloc_update_page_tables(unboxed_p, my_region); /* Set up a new region. */ - gc_alloc_new_region(32, 0, &boxed_region); + gc_alloc_new_region(32 /*bytes*/, unboxed_p, my_region); } return((void *)new_obj); } @@ -1160,34 +1159,34 @@ gc_alloc(int nbytes) /* If there some room left in the current region, enough to be worth * saving, then allocate a large object. */ /* FIXME: "32" should be a named parameter. */ - if ((boxed_region.end_addr-boxed_region.free_pointer) > 32) - return gc_alloc_large(nbytes, 0, &boxed_region); + if ((my_region->end_addr-my_region->free_pointer) > 32) + return gc_alloc_large(nbytes, unboxed_p, my_region); /* Else find a new region. */ /* Finished with the current region. */ - gc_alloc_update_page_tables(0, &boxed_region); + gc_alloc_update_page_tables(unboxed_p, my_region); /* Set up a new region. */ - gc_alloc_new_region(nbytes, 0, &boxed_region); + gc_alloc_new_region(nbytes, unboxed_p, my_region); /* Should now be enough room. */ /* Check whether there is room in the current region. */ - new_free_pointer = boxed_region.free_pointer + nbytes; + new_free_pointer = my_region->free_pointer + nbytes; - if (new_free_pointer <= boxed_region.end_addr) { + if (new_free_pointer <= my_region->end_addr) { /* If so then allocate from the current region. */ - void *new_obj = boxed_region.free_pointer; - boxed_region.free_pointer = new_free_pointer; + void *new_obj = my_region->free_pointer; + my_region->free_pointer = new_free_pointer; /* Check whether the current region is almost empty. */ - if ((boxed_region.end_addr - boxed_region.free_pointer) <= 32) { + if ((my_region->end_addr - my_region->free_pointer) <= 32) { /* If so find, finished with the current region. */ - gc_alloc_update_page_tables(0, &boxed_region); + gc_alloc_update_page_tables(unboxed_p, my_region); /* Set up a new region. */ - gc_alloc_new_region(32, 0, &boxed_region); + gc_alloc_new_region(32, unboxed_p, my_region); } return((void *)new_obj); @@ -1198,250 +1197,83 @@ gc_alloc(int nbytes) return((void *) NIL); /* dummy value: return something ... */ } + +static void * +gc_alloc(int nbytes,int unboxed_p) +{ + /* this is the only function that the external interface to + * allocation presently knows how to call: Lisp code will never + * allocate large objects, or to unboxed space, or `quick'ly. + * Any of that stuff will only ever happen inside of GC */ + return gc_general_alloc(nbytes,unboxed_p,0); +} + /* Allocate space from the boxed_region. If there is not enough free * space then call gc_alloc to do the job. A pointer to the start of - * the region is returned. */ + * the object is returned. */ static inline void * gc_quick_alloc(int nbytes) { - void *new_free_pointer; - - /* Check whether there is room in the current region. */ - new_free_pointer = boxed_region.free_pointer + nbytes; - - if (new_free_pointer <= boxed_region.end_addr) { - /* Allocate from the current region. */ - void *new_obj = boxed_region.free_pointer; - boxed_region.free_pointer = new_free_pointer; - return((void *)new_obj); - } else { - /* Let full gc_alloc() handle it. */ - return gc_alloc(nbytes); - } + return gc_general_alloc(nbytes,ALLOC_BOXED,ALLOC_QUICK); } -/* Allocate space for the boxed object. If it is a large object then - * do a large alloc else allocate from the current region. If there is - * not enough free space then call gc_alloc() to do the job. A pointer - * to the start of the region is returned. */ +/* Allocate space for the possibly large boxed object. If it is a + * large object then do a large alloc else use gc_quick_alloc. Note + * that gc_quick_alloc will eventually fall through to + * gc_general_alloc which may allocate the object in a large way + * anyway, but based on decisions about the free space in the current + * region, not the object size itself */ + static inline void * gc_quick_alloc_large(int nbytes) { - void *new_free_pointer; - if (nbytes >= large_object_size) - return gc_alloc_large(nbytes, 0, &boxed_region); - - /* Check whether there is room in the current region. */ - new_free_pointer = boxed_region.free_pointer + nbytes; - - if (new_free_pointer <= boxed_region.end_addr) { - /* If so then allocate from the current region. */ - void *new_obj = boxed_region.free_pointer; - boxed_region.free_pointer = new_free_pointer; - return((void *)new_obj); - } else { - /* Let full gc_alloc() handle it. */ - return gc_alloc(nbytes); - } + return gc_alloc_large(nbytes, ALLOC_BOXED, &boxed_region); + else + return gc_general_alloc(nbytes,ALLOC_BOXED,ALLOC_QUICK); } -static void * +static inline void * gc_alloc_unboxed(int nbytes) { - void *new_free_pointer; - - /* - FSHOW((stderr, "/gc_alloc_unboxed() %d\n", nbytes)); - */ - - /* Check whether there is room in the current region. */ - new_free_pointer = unboxed_region.free_pointer + nbytes; - - if (new_free_pointer <= unboxed_region.end_addr) { - /* If so then allocate from the current region. */ - void *new_obj = unboxed_region.free_pointer; - unboxed_region.free_pointer = new_free_pointer; - - /* Check whether the current region is almost empty. */ - if ((unboxed_region.end_addr - unboxed_region.free_pointer) <= 32) { - /* If so finished with the current region. */ - gc_alloc_update_page_tables(1, &unboxed_region); - - /* Set up a new region. */ - gc_alloc_new_region(32, 1, &unboxed_region); - } - - return((void *)new_obj); - } - - /* Else not enough free space in the current region. */ - - /* If there is a bit of room left in the current region then - allocate a large object. */ - if ((unboxed_region.end_addr-unboxed_region.free_pointer) > 32) - return gc_alloc_large(nbytes,1,&unboxed_region); - - /* Else find a new region. */ - - /* Finished with the current region. */ - gc_alloc_update_page_tables(1, &unboxed_region); - - /* Set up a new region. */ - gc_alloc_new_region(nbytes, 1, &unboxed_region); - - /* (There should now be enough room.) */ - - /* Check whether there is room in the current region. */ - new_free_pointer = unboxed_region.free_pointer + nbytes; - - if (new_free_pointer <= unboxed_region.end_addr) { - /* If so then allocate from the current region. */ - void *new_obj = unboxed_region.free_pointer; - unboxed_region.free_pointer = new_free_pointer; - - /* Check whether the current region is almost empty. */ - if ((unboxed_region.end_addr - unboxed_region.free_pointer) <= 32) { - /* If so find, finished with the current region. */ - gc_alloc_update_page_tables(1, &unboxed_region); - - /* Set up a new region. */ - gc_alloc_new_region(32, 1, &unboxed_region); - } - - return((void *)new_obj); - } - - /* shouldn't happen? */ - gc_assert(0); - return((void *) NIL); /* dummy value: return something ... */ + return gc_general_alloc(nbytes,ALLOC_UNBOXED,0); } static inline void * gc_quick_alloc_unboxed(int nbytes) { - void *new_free_pointer; - - /* Check whether there is room in the current region. */ - new_free_pointer = unboxed_region.free_pointer + nbytes; - - if (new_free_pointer <= unboxed_region.end_addr) { - /* If so then allocate from the current region. */ - void *new_obj = unboxed_region.free_pointer; - unboxed_region.free_pointer = new_free_pointer; - - return((void *)new_obj); - } else { - /* Let general gc_alloc_unboxed() handle it. */ - return gc_alloc_unboxed(nbytes); - } + return gc_general_alloc(nbytes,ALLOC_UNBOXED,ALLOC_QUICK); } /* Allocate space for the object. If it is a large object then do a * large alloc else allocate from the current region. If there is not * enough free space then call general gc_alloc_unboxed() to do the job. * - * A pointer to the start of the region is returned. */ + * A pointer to the start of the object is returned. */ static inline void * gc_quick_alloc_large_unboxed(int nbytes) { - void *new_free_pointer; - if (nbytes >= large_object_size) - return gc_alloc_large(nbytes,1,&unboxed_region); - - /* Check whether there is room in the current region. */ - new_free_pointer = unboxed_region.free_pointer + nbytes; - if (new_free_pointer <= unboxed_region.end_addr) { - /* Allocate from the current region. */ - void *new_obj = unboxed_region.free_pointer; - unboxed_region.free_pointer = new_free_pointer; - return((void *)new_obj); - } else { - /* Let full gc_alloc() handle it. */ - return gc_alloc_unboxed(nbytes); - } + return gc_alloc_large(nbytes,ALLOC_UNBOXED,&unboxed_region); + else + return gc_quick_alloc_unboxed(nbytes); } /* * scavenging/transporting routines derived from gc.c in CMU CL ca. 18b */ -static int (*scavtab[256])(lispobj *where, lispobj object); -static lispobj (*transother[256])(lispobj object); -static int (*sizetab[256])(lispobj *where); - -static struct weak_pointer *weak_pointers; - -#define CEILING(x,y) (((x) + ((y) - 1)) & (~((y) - 1))) - -/* - * predicates - */ - -static inline boolean -from_space_p(lispobj obj) -{ - int page_index=(void*)obj - heap_base; - return ((page_index >= 0) - && ((page_index = ((unsigned int)page_index)/4096) < NUM_PAGES) - && (page_table[page_index].gen == from_space)); -} - -static inline boolean -new_space_p(lispobj obj) -{ - int page_index = (void*)obj - heap_base; - return ((page_index >= 0) - && ((page_index = ((unsigned int)page_index)/4096) < NUM_PAGES) - && (page_table[page_index].gen == new_space)); -} - -/* - * copying objects - */ - -/* to copy a boxed object */ -static inline lispobj -copy_object(lispobj object, int nwords) -{ - int tag; - lispobj *new; - lispobj *source, *dest; - - gc_assert(is_lisp_pointer(object)); - gc_assert(from_space_p(object)); - gc_assert((nwords & 0x01) == 0); - - /* Get tag of object. */ - tag = lowtag_of(object); - - /* Allocate space. */ - new = gc_quick_alloc(nwords*4); - - dest = new; - source = (lispobj *) native_pointer(object); - - /* Copy the object. */ - while (nwords > 0) { - dest[0] = source[0]; - dest[1] = source[1]; - dest += 2; - source += 2; - nwords -= 2; - } - - /* Return Lisp pointer of new object. */ - return ((lispobj) new) | tag; -} +extern int (*scavtab[256])(lispobj *where, lispobj object); +extern lispobj (*transother[256])(lispobj object); +extern int (*sizetab[256])(lispobj *where); -/* to copy a large boxed object. If the object is in a large object +/* Copy a large boxed object. If the object is in a large object * region then it is simply promoted, else it is copied. If it's large * enough then it's copied to a large object region. * * Vectors may have shrunk. If the object is not copied the space * needs to be reclaimed, and the page_tables corrected. */ -static lispobj +lispobj copy_large_object(lispobj object, int nwords) { int tag; @@ -1453,9 +1285,6 @@ copy_large_object(lispobj object, int nwords) gc_assert(from_space_p(object)); gc_assert((nwords & 0x01) == 0); - if ((nwords > 1024*1024) && gencgc_verbose) { - FSHOW((stderr, "/copy_large_object: %d bytes\n", nwords*4)); - } /* Check whether it's a large object. */ first_page = find_page_index((void *)object); @@ -1523,7 +1352,7 @@ copy_large_object(lispobj object, int nwords) page_table[next_page].large_object && (page_table[next_page].first_object_offset == -(next_page - first_page)*4096)) { - /* Checks out OK, free the page. Don't need to both zeroing + /* Checks out OK, free the page. Don't need to bother zeroing * pages as this should have been done before shrinking the * object. These pages shouldn't be write-protected as they * should be zero filled. */ @@ -1536,9 +1365,6 @@ copy_large_object(lispobj object, int nwords) next_page++; } - if ((bytes_freed > 0) && gencgc_verbose) - FSHOW((stderr, "/copy_large_boxed bytes_freed=%d\n", bytes_freed)); - generations[from_space].bytes_allocated -= 4*nwords + bytes_freed; generations[new_space].bytes_allocated += 4*nwords; bytes_allocated -= bytes_freed; @@ -1572,7 +1398,7 @@ copy_large_object(lispobj object, int nwords) } /* to copy unboxed objects */ -static inline lispobj +lispobj copy_unboxed_object(lispobj object, int nwords) { int tag; @@ -1616,7 +1442,7 @@ copy_unboxed_object(lispobj object, int nwords) * * KLUDGE: There's a lot of cut-and-paste duplication between this * function and copy_large_object(..). -- WHN 20000619 */ -static lispobj +lispobj copy_large_unboxed_object(lispobj object, int nwords) { int tag; @@ -1734,108 +1560,18 @@ copy_large_unboxed_object(lispobj object, int nwords) return ((lispobj) new) | tag; } } - -/* - * scavenging - */ -/* FIXME: Most calls end up going to some trouble to compute an - * 'n_words' value for this function. The system might be a little - * simpler if this function used an 'end' parameter instead. */ -static void -scavenge(lispobj *start, long n_words) -{ - lispobj *end = start + n_words; - lispobj *object_ptr; - int n_words_scavenged; - - for (object_ptr = start; - object_ptr < end; - object_ptr += n_words_scavenged) { - - lispobj object = *object_ptr; - - gc_assert(object != 0x01); /* not a forwarding pointer */ - - if (is_lisp_pointer(object)) { - if (from_space_p(object)) { - /* It currently points to old space. Check for a - * forwarding pointer. */ - lispobj *ptr = (lispobj *)native_pointer(object); - lispobj first_word = *ptr; - if (first_word == 0x01) { - /* Yes, there's a forwarding pointer. */ - *object_ptr = ptr[1]; - n_words_scavenged = 1; - } else { - /* Scavenge that pointer. */ - n_words_scavenged = - (scavtab[widetag_of(object)])(object_ptr, object); - } - } else { - /* It points somewhere other than oldspace. Leave it - * alone. */ - n_words_scavenged = 1; - } - } else if ((object & 3) == 0) { - /* It's a fixnum: really easy.. */ - n_words_scavenged = 1; - } else { - /* It's some sort of header object or another. */ - n_words_scavenged = - (scavtab[widetag_of(object)])(object_ptr, object); - } - } - gc_assert(object_ptr == end); -} + + + /* * code and code-related objects */ - -/* FIXME: (1) Shouldn't this be defined in sbcl.h? */ -#define FUN_RAW_ADDR_OFFSET (6*sizeof(lispobj) - FUN_POINTER_LOWTAG) - +/* static lispobj trans_fun_header(lispobj object); static lispobj trans_boxed(lispobj object); - -static int -scav_fun_pointer(lispobj *where, lispobj object) -{ - lispobj *first_pointer; - lispobj copy; - - gc_assert(is_lisp_pointer(object)); - - /* Object is a pointer into from space - no a FP. */ - first_pointer = (lispobj *) native_pointer(object); - - /* must transport object -- object may point to either a function - * header, a closure function header, or to a closure header. */ - - switch (widetag_of(*first_pointer)) { - case SIMPLE_FUN_HEADER_WIDETAG: - case CLOSURE_FUN_HEADER_WIDETAG: - copy = trans_fun_header(object); - break; - default: - copy = trans_boxed(object); - break; - } - - if (copy != object) { - /* Set forwarding pointer */ - first_pointer[0] = 0x01; - first_pointer[1] = copy; - } - - gc_assert(is_lisp_pointer(copy)); - gc_assert(!from_space_p(copy)); - - *where = copy; - - return 1; -} +*/ /* Scan a x86 compiled code object, looking for possible fixups that * have been missed after a move. @@ -2016,8 +1752,8 @@ sniff_code_object(struct code *code, unsigned displacement) } } -static void -apply_code_fixups(struct code *old_code, struct code *new_code) +void +gencgc_apply_code_fixups(struct code *old_code, struct code *new_code) { int nheader_words, ncode_words, nwords; void *constants_start_addr, *constants_end_addr; @@ -2113,660 +1849,120 @@ apply_code_fixups(struct code *old_code, struct code *new_code) } } -static struct code * -trans_code(struct code *code) -{ - struct code *new_code; - lispobj l_code, l_new_code; - int nheader_words, ncode_words, nwords; - unsigned long displacement; - lispobj fheaderl, *prev_pointer; - - /* FSHOW((stderr, - "\n/transporting code object located at 0x%08x\n", - (unsigned long) code)); */ - - /* If object has already been transported, just return pointer. */ - if (*((lispobj *)code) == 0x01) - return (struct code*)(((lispobj *)code)[1]); - gc_assert(widetag_of(code->header) == CODE_HEADER_WIDETAG); - - /* Prepare to transport the code vector. */ - l_code = (lispobj) code | OTHER_POINTER_LOWTAG; +static lispobj +trans_boxed_large(lispobj object) +{ + lispobj header; + unsigned long length; - ncode_words = fixnum_value(code->code_size); - nheader_words = HeaderValue(code->header); - nwords = ncode_words + nheader_words; - nwords = CEILING(nwords, 2); + gc_assert(is_lisp_pointer(object)); - l_new_code = copy_large_object(l_code, nwords); - new_code = (struct code *) native_pointer(l_new_code); + header = *((lispobj *) native_pointer(object)); + length = HeaderValue(header) + 1; + length = CEILING(length, 2); - /* may not have been moved.. */ - if (new_code == code) - return new_code; + return copy_large_object(object, length); +} - displacement = l_new_code - l_code; - /* - FSHOW((stderr, - "/old code object at 0x%08x, new code object at 0x%08x\n", - (unsigned long) code, - (unsigned long) new_code)); - FSHOW((stderr, "/Code object is %d words long.\n", nwords)); - */ +static lispobj +trans_unboxed_large(lispobj object) +{ + lispobj header; + unsigned long length; - /* Set forwarding pointer. */ - ((lispobj *)code)[0] = 0x01; - ((lispobj *)code)[1] = l_new_code; - /* Set forwarding pointers for all the function headers in the - * code object. Also fix all self pointers. */ + gc_assert(is_lisp_pointer(object)); - fheaderl = code->entry_points; - prev_pointer = &new_code->entry_points; + header = *((lispobj *) native_pointer(object)); + length = HeaderValue(header) + 1; + length = CEILING(length, 2); - while (fheaderl != NIL) { - struct simple_fun *fheaderp, *nfheaderp; - lispobj nfheaderl; + return copy_large_unboxed_object(object, length); +} - fheaderp = (struct simple_fun *) native_pointer(fheaderl); - gc_assert(widetag_of(fheaderp->header) == SIMPLE_FUN_HEADER_WIDETAG); + +/* + * vector-like objects + */ - /* Calculate the new function pointer and the new - * function header. */ - nfheaderl = fheaderl + displacement; - nfheaderp = (struct simple_fun *) native_pointer(nfheaderl); - /* Set forwarding pointer. */ - ((lispobj *)fheaderp)[0] = 0x01; - ((lispobj *)fheaderp)[1] = nfheaderl; +/* FIXME: What does this mean? */ +int gencgc_hash = 1; - /* Fix self pointer. */ - nfheaderp->self = nfheaderl + FUN_RAW_ADDR_OFFSET; +static int +scav_vector(lispobj *where, lispobj object) +{ + unsigned int kv_length; + lispobj *kv_vector; + unsigned int length = 0; /* (0 = dummy to stop GCC warning) */ + lispobj *hash_table; + lispobj empty_symbol; + unsigned int *index_vector = NULL; /* (NULL = dummy to stop GCC warning) */ + unsigned int *next_vector = NULL; /* (NULL = dummy to stop GCC warning) */ + unsigned int *hash_vector = NULL; /* (NULL = dummy to stop GCC warning) */ + lispobj weak_p_obj; + unsigned next_vector_length = 0; - *prev_pointer = nfheaderl; + /* FIXME: A comment explaining this would be nice. It looks as + * though SB-VM:VECTOR-VALID-HASHING-SUBTYPE is set for EQ-based + * hash tables in the Lisp HASH-TABLE code, and nowhere else. */ + if (HeaderValue(object) != subtype_VectorValidHashing) + return 1; - fheaderl = fheaderp->next; - prev_pointer = &nfheaderp->next; + if (!gencgc_hash) { + /* This is set for backward compatibility. FIXME: Do we need + * this any more? */ + *where = + (subtype_VectorMustRehash<code_size); - n_header_words = HeaderValue(object); - n_words = n_code_words + n_header_words; - n_words = CEILING(n_words, 2); - - /* Scavenge the boxed section of the code data block. */ - scavenge(where + 1, n_header_words - 1); - - /* Scavenge the boxed section of each function object in the - * code data block. */ - for (entry_point = code->entry_points; - entry_point != NIL; - entry_point = function_ptr->next) { - - gc_assert(is_lisp_pointer(entry_point)); - - function_ptr = (struct simple_fun *) native_pointer(entry_point); - gc_assert(widetag_of(function_ptr->header)==SIMPLE_FUN_HEADER_WIDETAG); - - scavenge(&function_ptr->name, 1); - scavenge(&function_ptr->arglist, 1); - scavenge(&function_ptr->type, 1); + /* Scavenge element 0, which may be a hash-table structure. */ + scavenge(where+2, 1); + if (!is_lisp_pointer(where[2])) { + lose("no pointer at %x in hash table", where[2]); } - - return n_words; -} - -static lispobj -trans_code_header(lispobj object) -{ - struct code *ncode; - - ncode = trans_code((struct code *) native_pointer(object)); - return (lispobj) ncode | OTHER_POINTER_LOWTAG; -} - -static int -size_code_header(lispobj *where) -{ - struct code *code; - int nheader_words, ncode_words, nwords; - - code = (struct code *) where; - - ncode_words = fixnum_value(code->code_size); - nheader_words = HeaderValue(code->header); - nwords = ncode_words + nheader_words; - nwords = CEILING(nwords, 2); - - return nwords; -} - -static int -scav_return_pc_header(lispobj *where, lispobj object) -{ - lose("attempted to scavenge a return PC header where=0x%08x object=0x%08x", - (unsigned long) where, - (unsigned long) object); - return 0; /* bogus return value to satisfy static type checking */ -} - -static lispobj -trans_return_pc_header(lispobj object) -{ - struct simple_fun *return_pc; - unsigned long offset; - struct code *code, *ncode; - - SHOW("/trans_return_pc_header: Will this work?"); - - return_pc = (struct simple_fun *) native_pointer(object); - offset = HeaderValue(return_pc->header) * 4; - - /* Transport the whole code object. */ - code = (struct code *) ((unsigned long) return_pc - offset); - ncode = trans_code(code); - - return ((lispobj) ncode + offset) | OTHER_POINTER_LOWTAG; -} - -/* On the 386, closures hold a pointer to the raw address instead of the - * function object. */ -#ifdef __i386__ -static int -scav_closure_header(lispobj *where, lispobj object) -{ - struct closure *closure; - lispobj fun; - - closure = (struct closure *)where; - fun = closure->fun - FUN_RAW_ADDR_OFFSET; - scavenge(&fun, 1); - /* The function may have moved so update the raw address. But - * don't write unnecessarily. */ - if (closure->fun != fun + FUN_RAW_ADDR_OFFSET) - closure->fun = fun + FUN_RAW_ADDR_OFFSET; - - return 2; -} -#endif - -static int -scav_fun_header(lispobj *where, lispobj object) -{ - lose("attempted to scavenge a function header where=0x%08x object=0x%08x", - (unsigned long) where, - (unsigned long) object); - return 0; /* bogus return value to satisfy static type checking */ -} - -static lispobj -trans_fun_header(lispobj object) -{ - struct simple_fun *fheader; - unsigned long offset; - struct code *code, *ncode; - - fheader = (struct simple_fun *) native_pointer(object); - offset = HeaderValue(fheader->header) * 4; - - /* Transport the whole code object. */ - code = (struct code *) ((unsigned long) fheader - offset); - ncode = trans_code(code); - - return ((lispobj) ncode + offset) | FUN_POINTER_LOWTAG; -} - -/* - * instances - */ - -static int -scav_instance_pointer(lispobj *where, lispobj object) -{ - lispobj copy, *first_pointer; - - /* Object is a pointer into from space - not a FP. */ - copy = trans_boxed(object); - - gc_assert(copy != object); - - first_pointer = (lispobj *) native_pointer(object); - - /* Set forwarding pointer. */ - first_pointer[0] = 0x01; - first_pointer[1] = copy; - *where = copy; - - return 1; -} - -/* - * lists and conses - */ - -static lispobj trans_list(lispobj object); - -static int -scav_list_pointer(lispobj *where, lispobj object) -{ - lispobj first, *first_pointer; - - gc_assert(is_lisp_pointer(object)); - - /* Object is a pointer into from space - not FP. */ - - first = trans_list(object); - gc_assert(first != object); - - first_pointer = (lispobj *) native_pointer(object); - - /* Set forwarding pointer */ - first_pointer[0] = 0x01; - first_pointer[1] = first; - - gc_assert(is_lisp_pointer(first)); - gc_assert(!from_space_p(first)); - *where = first; - return 1; -} - -static lispobj -trans_list(lispobj object) -{ - lispobj new_list_pointer; - struct cons *cons, *new_cons; - lispobj cdr; - - gc_assert(from_space_p(object)); - - cons = (struct cons *) native_pointer(object); - - /* Copy 'object'. */ - new_cons = (struct cons *) gc_quick_alloc(sizeof(struct cons)); - new_cons->car = cons->car; - new_cons->cdr = cons->cdr; /* updated later */ - new_list_pointer = (lispobj)new_cons | lowtag_of(object); - - /* Grab the cdr before it is clobbered. */ - cdr = cons->cdr; - - /* Set forwarding pointer (clobbers start of list). */ - cons->car = 0x01; - cons->cdr = new_list_pointer; - - /* Try to linearize the list in the cdr direction to help reduce - * paging. */ - while (1) { - lispobj new_cdr; - struct cons *cdr_cons, *new_cdr_cons; - - if (lowtag_of(cdr) != LIST_POINTER_LOWTAG || !from_space_p(cdr) - || (*((lispobj *)native_pointer(cdr)) == 0x01)) - break; - - cdr_cons = (struct cons *) native_pointer(cdr); - - /* Copy 'cdr'. */ - new_cdr_cons = (struct cons*) gc_quick_alloc(sizeof(struct cons)); - new_cdr_cons->car = cdr_cons->car; - new_cdr_cons->cdr = cdr_cons->cdr; - new_cdr = (lispobj)new_cdr_cons | lowtag_of(cdr); - - /* Grab the cdr before it is clobbered. */ - cdr = cdr_cons->cdr; - - /* Set forwarding pointer. */ - cdr_cons->car = 0x01; - cdr_cons->cdr = new_cdr; - - /* Update the cdr of the last cons copied into new space to - * keep the newspace scavenge from having to do it. */ - new_cons->cdr = new_cdr; - - new_cons = new_cdr_cons; + hash_table = (lispobj *)native_pointer(where[2]); + /*FSHOW((stderr,"/hash_table = %x\n", hash_table));*/ + if (widetag_of(hash_table[0]) != INSTANCE_HEADER_WIDETAG) { + lose("hash table not instance (%x at %x)", hash_table[0], hash_table); } - return new_list_pointer; -} - - -/* - * scavenging and transporting other pointers - */ - -static int -scav_other_pointer(lispobj *where, lispobj object) -{ - lispobj first, *first_pointer; - - gc_assert(is_lisp_pointer(object)); - - /* Object is a pointer into from space - not FP. */ - first_pointer = (lispobj *) native_pointer(object); - - first = (transother[widetag_of(*first_pointer)])(object); - - if (first != object) { - /* Set forwarding pointer. */ - first_pointer[0] = 0x01; - first_pointer[1] = first; - *where = first; + /* Scavenge element 1, which should be some internal symbol that + * the hash table code reserves for marking empty slots. */ + scavenge(where+3, 1); + if (!is_lisp_pointer(where[3])) { + lose("not empty-hash-table-slot symbol pointer: %x", where[3]); } - - gc_assert(is_lisp_pointer(first)); - gc_assert(!from_space_p(first)); - - return 1; -} - -/* - * immediate, boxed, and unboxed objects - */ - -static int -size_pointer(lispobj *where) -{ - return 1; -} - -static int -scav_immediate(lispobj *where, lispobj object) -{ - return 1; -} - -static lispobj -trans_immediate(lispobj object) -{ - lose("trying to transport an immediate"); - return NIL; /* bogus return value to satisfy static type checking */ -} - -static int -size_immediate(lispobj *where) -{ - return 1; -} - - -static int -scav_boxed(lispobj *where, lispobj object) -{ - return 1; -} - -static lispobj -trans_boxed(lispobj object) -{ - lispobj header; - unsigned long length; - - gc_assert(is_lisp_pointer(object)); - - header = *((lispobj *) native_pointer(object)); - length = HeaderValue(header) + 1; - length = CEILING(length, 2); - - return copy_object(object, length); -} - -static lispobj -trans_boxed_large(lispobj object) -{ - lispobj header; - unsigned long length; - - gc_assert(is_lisp_pointer(object)); - - header = *((lispobj *) native_pointer(object)); - length = HeaderValue(header) + 1; - length = CEILING(length, 2); - - return copy_large_object(object, length); -} - -static int -size_boxed(lispobj *where) -{ - lispobj header; - unsigned long length; - - header = *where; - length = HeaderValue(header) + 1; - length = CEILING(length, 2); - - return length; -} - -static int -scav_fdefn(lispobj *where, lispobj object) -{ - struct fdefn *fdefn; - - fdefn = (struct fdefn *)where; - - /* FSHOW((stderr, "scav_fdefn, function = %p, raw_addr = %p\n", - fdefn->fun, fdefn->raw_addr)); */ - - if ((char *)(fdefn->fun + FUN_RAW_ADDR_OFFSET) == fdefn->raw_addr) { - scavenge(where + 1, sizeof(struct fdefn)/sizeof(lispobj) - 1); - - /* Don't write unnecessarily. */ - if (fdefn->raw_addr != (char *)(fdefn->fun + FUN_RAW_ADDR_OFFSET)) - fdefn->raw_addr = (char *)(fdefn->fun + FUN_RAW_ADDR_OFFSET); - - return sizeof(struct fdefn) / sizeof(lispobj); - } else { - return 1; + empty_symbol = where[3]; + /* fprintf(stderr,"* empty_symbol = %x\n", empty_symbol);*/ + if (widetag_of(*(lispobj *)native_pointer(empty_symbol)) != + SYMBOL_HEADER_WIDETAG) { + lose("not a symbol where empty-hash-table-slot symbol expected: %x", + *(lispobj *)native_pointer(empty_symbol)); } -} - -static int -scav_unboxed(lispobj *where, lispobj object) -{ - unsigned long length; - - length = HeaderValue(object) + 1; - length = CEILING(length, 2); - - return length; -} - -static lispobj -trans_unboxed(lispobj object) -{ - lispobj header; - unsigned long length; - - - gc_assert(is_lisp_pointer(object)); - - header = *((lispobj *) native_pointer(object)); - length = HeaderValue(header) + 1; - length = CEILING(length, 2); - return copy_unboxed_object(object, length); -} - -static lispobj -trans_unboxed_large(lispobj object) -{ - lispobj header; - unsigned long length; + /* Scavenge hash table, which will fix the positions of the other + * needed objects. */ + scavenge(hash_table, 16); + /* Cross-check the kv_vector. */ + if (where != (lispobj *)native_pointer(hash_table[9])) { + lose("hash_table table!=this table %x", hash_table[9]); + } - gc_assert(is_lisp_pointer(object)); + /* WEAK-P */ + weak_p_obj = hash_table[10]; - header = *((lispobj *) native_pointer(object)); - length = HeaderValue(header) + 1; - length = CEILING(length, 2); - - return copy_large_unboxed_object(object, length); -} - -static int -size_unboxed(lispobj *where) -{ - lispobj header; - unsigned long length; - - header = *where; - length = HeaderValue(header) + 1; - length = CEILING(length, 2); - - return length; -} - -/* - * vector-like objects - */ - -#define NWORDS(x,y) (CEILING((x),(y)) / (y)) - -static int -scav_string(lispobj *where, lispobj object) -{ - struct vector *vector; - int length, nwords; - - /* NOTE: Strings contain one more byte of data than the length */ - /* slot indicates. */ - - vector = (struct vector *) where; - length = fixnum_value(vector->length) + 1; - nwords = CEILING(NWORDS(length, 4) + 2, 2); - - return nwords; -} - -static lispobj -trans_string(lispobj object) -{ - struct vector *vector; - int length, nwords; - - gc_assert(is_lisp_pointer(object)); - - /* NOTE: A string contains one more byte of data (a terminating - * '\0' to help when interfacing with C functions) than indicated - * by the length slot. */ - - vector = (struct vector *) native_pointer(object); - length = fixnum_value(vector->length) + 1; - nwords = CEILING(NWORDS(length, 4) + 2, 2); - - return copy_large_unboxed_object(object, nwords); -} - -static int -size_string(lispobj *where) -{ - struct vector *vector; - int length, nwords; - - /* NOTE: A string contains one more byte of data (a terminating - * '\0' to help when interfacing with C functions) than indicated - * by the length slot. */ - - vector = (struct vector *) where; - length = fixnum_value(vector->length) + 1; - nwords = CEILING(NWORDS(length, 4) + 2, 2); - - return nwords; -} - -/* FIXME: What does this mean? */ -int gencgc_hash = 1; - -static int -scav_vector(lispobj *where, lispobj object) -{ - unsigned int kv_length; - lispobj *kv_vector; - unsigned int length = 0; /* (0 = dummy to stop GCC warning) */ - lispobj *hash_table; - lispobj empty_symbol; - unsigned int *index_vector = NULL; /* (NULL = dummy to stop GCC warning) */ - unsigned int *next_vector = NULL; /* (NULL = dummy to stop GCC warning) */ - unsigned int *hash_vector = NULL; /* (NULL = dummy to stop GCC warning) */ - lispobj weak_p_obj; - unsigned next_vector_length = 0; - - /* FIXME: A comment explaining this would be nice. It looks as - * though SB-VM:VECTOR-VALID-HASHING-SUBTYPE is set for EQ-based - * hash tables in the Lisp HASH-TABLE code, and nowhere else. */ - if (HeaderValue(object) != subtype_VectorValidHashing) - return 1; - - if (!gencgc_hash) { - /* This is set for backward compatibility. FIXME: Do we need - * this any more? */ - *where = - (subtype_VectorMustRehash<length); - nwords = CEILING(length + 2, 2); - - return copy_large_object(object, nwords); -} - -static int -size_vector(lispobj *where) -{ - struct vector *vector; - int length, nwords; - - vector = (struct vector *) where; - length = fixnum_value(vector->length); - nwords = CEILING(length + 2, 2); - - return nwords; -} - - -static int -scav_vector_bit(lispobj *where, lispobj object) -{ - struct vector *vector; - int length, nwords; - - vector = (struct vector *) where; - length = fixnum_value(vector->length); - nwords = CEILING(NWORDS(length, 32) + 2, 2); - - return nwords; -} - -static lispobj -trans_vector_bit(lispobj object) -{ - struct vector *vector; - int length, nwords; - - gc_assert(is_lisp_pointer(object)); - - vector = (struct vector *) native_pointer(object); - length = fixnum_value(vector->length); - nwords = CEILING(NWORDS(length, 32) + 2, 2); - - return copy_large_unboxed_object(object, nwords); -} - -static int -size_vector_bit(lispobj *where) -{ - struct vector *vector; - int length, nwords; - - vector = (struct vector *) where; - length = fixnum_value(vector->length); - nwords = CEILING(NWORDS(length, 32) + 2, 2); - - return nwords; -} - - -static int -scav_vector_unsigned_byte_2(lispobj *where, lispobj object) -{ - struct vector *vector; - int length, nwords; - - vector = (struct vector *) where; - length = fixnum_value(vector->length); - nwords = CEILING(NWORDS(length, 16) + 2, 2); - - return nwords; -} - -static lispobj -trans_vector_unsigned_byte_2(lispobj object) -{ - struct vector *vector; - int length, nwords; - - gc_assert(is_lisp_pointer(object)); - - vector = (struct vector *) native_pointer(object); - length = fixnum_value(vector->length); - nwords = CEILING(NWORDS(length, 16) + 2, 2); - - return copy_large_unboxed_object(object, nwords); -} - -static int -size_vector_unsigned_byte_2(lispobj *where) -{ - struct vector *vector; - int length, nwords; - - vector = (struct vector *) where; - length = fixnum_value(vector->length); - nwords = CEILING(NWORDS(length, 16) + 2, 2); - - return nwords; -} - - -static int -scav_vector_unsigned_byte_4(lispobj *where, lispobj object) -{ - struct vector *vector; - int length, nwords; - - vector = (struct vector *) where; - length = fixnum_value(vector->length); - nwords = CEILING(NWORDS(length, 8) + 2, 2); - - return nwords; -} - -static lispobj -trans_vector_unsigned_byte_4(lispobj object) -{ - struct vector *vector; - int length, nwords; - - gc_assert(is_lisp_pointer(object)); - - vector = (struct vector *) native_pointer(object); - length = fixnum_value(vector->length); - nwords = CEILING(NWORDS(length, 8) + 2, 2); - - return copy_large_unboxed_object(object, nwords); -} - -static int -size_vector_unsigned_byte_4(lispobj *where) -{ - struct vector *vector; - int length, nwords; - - vector = (struct vector *) where; - length = fixnum_value(vector->length); - nwords = CEILING(NWORDS(length, 8) + 2, 2); - - return nwords; -} - -static int -scav_vector_unsigned_byte_8(lispobj *where, lispobj object) -{ - struct vector *vector; - int length, nwords; - - vector = (struct vector *) where; - length = fixnum_value(vector->length); - nwords = CEILING(NWORDS(length, 4) + 2, 2); - - return nwords; -} - -static lispobj -trans_vector_unsigned_byte_8(lispobj object) -{ - struct vector *vector; - int length, nwords; - - gc_assert(is_lisp_pointer(object)); - - vector = (struct vector *) native_pointer(object); - length = fixnum_value(vector->length); - nwords = CEILING(NWORDS(length, 4) + 2, 2); - - return copy_large_unboxed_object(object, nwords); -} - -static int -size_vector_unsigned_byte_8(lispobj *where) -{ - struct vector *vector; - int length, nwords; - - vector = (struct vector *) where; - length = fixnum_value(vector->length); - nwords = CEILING(NWORDS(length, 4) + 2, 2); - - return nwords; -} - - -static int -scav_vector_unsigned_byte_16(lispobj *where, lispobj object) -{ - struct vector *vector; - int length, nwords; - - vector = (struct vector *) where; - length = fixnum_value(vector->length); - nwords = CEILING(NWORDS(length, 2) + 2, 2); - - return nwords; -} - -static lispobj -trans_vector_unsigned_byte_16(lispobj object) -{ - struct vector *vector; - int length, nwords; - - gc_assert(is_lisp_pointer(object)); - - vector = (struct vector *) native_pointer(object); - length = fixnum_value(vector->length); - nwords = CEILING(NWORDS(length, 2) + 2, 2); - - return copy_large_unboxed_object(object, nwords); -} - -static int -size_vector_unsigned_byte_16(lispobj *where) -{ - struct vector *vector; - int length, nwords; - - vector = (struct vector *) where; - length = fixnum_value(vector->length); - nwords = CEILING(NWORDS(length, 2) + 2, 2); - - return nwords; -} - -static int -scav_vector_unsigned_byte_32(lispobj *where, lispobj object) -{ - struct vector *vector; - int length, nwords; - - vector = (struct vector *) where; - length = fixnum_value(vector->length); - nwords = CEILING(length + 2, 2); - - return nwords; -} - -static lispobj -trans_vector_unsigned_byte_32(lispobj object) -{ - struct vector *vector; - int length, nwords; - - gc_assert(is_lisp_pointer(object)); - - vector = (struct vector *) native_pointer(object); - length = fixnum_value(vector->length); - nwords = CEILING(length + 2, 2); - - return copy_large_unboxed_object(object, nwords); -} - -static int -size_vector_unsigned_byte_32(lispobj *where) -{ - struct vector *vector; - int length, nwords; - - vector = (struct vector *) where; - length = fixnum_value(vector->length); - nwords = CEILING(length + 2, 2); - - return nwords; -} - -static int -scav_vector_single_float(lispobj *where, lispobj object) -{ - struct vector *vector; - int length, nwords; - - vector = (struct vector *) where; - length = fixnum_value(vector->length); - nwords = CEILING(length + 2, 2); - - return nwords; -} - -static lispobj -trans_vector_single_float(lispobj object) -{ - struct vector *vector; - int length, nwords; - - gc_assert(is_lisp_pointer(object)); - - vector = (struct vector *) native_pointer(object); - length = fixnum_value(vector->length); - nwords = CEILING(length + 2, 2); - - return copy_large_unboxed_object(object, nwords); -} - -static int -size_vector_single_float(lispobj *where) -{ - struct vector *vector; - int length, nwords; - - vector = (struct vector *) where; - length = fixnum_value(vector->length); - nwords = CEILING(length + 2, 2); - - return nwords; -} - -static int -scav_vector_double_float(lispobj *where, lispobj object) -{ - struct vector *vector; - int length, nwords; - - vector = (struct vector *) where; - length = fixnum_value(vector->length); - nwords = CEILING(length * 2 + 2, 2); - - return nwords; -} - -static lispobj -trans_vector_double_float(lispobj object) -{ - struct vector *vector; - int length, nwords; - - gc_assert(is_lisp_pointer(object)); - - vector = (struct vector *) native_pointer(object); - length = fixnum_value(vector->length); - nwords = CEILING(length * 2 + 2, 2); - - return copy_large_unboxed_object(object, nwords); -} - -static int -size_vector_double_float(lispobj *where) -{ - struct vector *vector; - int length, nwords; - - vector = (struct vector *) where; - length = fixnum_value(vector->length); - nwords = CEILING(length * 2 + 2, 2); - - return nwords; -} - -#ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG -static int -scav_vector_long_float(lispobj *where, lispobj object) -{ - struct vector *vector; - int length, nwords; - - vector = (struct vector *) where; - length = fixnum_value(vector->length); - nwords = CEILING(length * 3 + 2, 2); - - return nwords; -} - -static lispobj -trans_vector_long_float(lispobj object) -{ - struct vector *vector; - int length, nwords; - - gc_assert(is_lisp_pointer(object)); - - vector = (struct vector *) native_pointer(object); - length = fixnum_value(vector->length); - nwords = CEILING(length * 3 + 2, 2); - - return copy_large_unboxed_object(object, nwords); -} - -static int -size_vector_long_float(lispobj *where) -{ - struct vector *vector; - int length, nwords; - - vector = (struct vector *) where; - length = fixnum_value(vector->length); - nwords = CEILING(length * 3 + 2, 2); - - return nwords; -} -#endif - - -#ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG -static int -scav_vector_complex_single_float(lispobj *where, lispobj object) -{ - struct vector *vector; - int length, nwords; - - vector = (struct vector *) where; - length = fixnum_value(vector->length); - nwords = CEILING(length * 2 + 2, 2); - - return nwords; -} - -static lispobj -trans_vector_complex_single_float(lispobj object) -{ - struct vector *vector; - int length, nwords; - - gc_assert(is_lisp_pointer(object)); - - vector = (struct vector *) native_pointer(object); - length = fixnum_value(vector->length); - nwords = CEILING(length * 2 + 2, 2); - - return copy_large_unboxed_object(object, nwords); -} - -static int -size_vector_complex_single_float(lispobj *where) -{ - struct vector *vector; - int length, nwords; - - vector = (struct vector *) where; - length = fixnum_value(vector->length); - nwords = CEILING(length * 2 + 2, 2); - - return nwords; -} -#endif - -#ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG -static int -scav_vector_complex_double_float(lispobj *where, lispobj object) -{ - struct vector *vector; - int length, nwords; - - vector = (struct vector *) where; - length = fixnum_value(vector->length); - nwords = CEILING(length * 4 + 2, 2); - - return nwords; -} - -static lispobj -trans_vector_complex_double_float(lispobj object) -{ - struct vector *vector; - int length, nwords; - - gc_assert(is_lisp_pointer(object)); - - vector = (struct vector *) native_pointer(object); - length = fixnum_value(vector->length); - nwords = CEILING(length * 4 + 2, 2); + lose("invalid index_vector %x", index_vector_obj); + } + } - return copy_large_unboxed_object(object, nwords); -} + /* next vector */ + { + lispobj next_vector_obj = hash_table[14]; -static int -size_vector_complex_double_float(lispobj *where) -{ - struct vector *vector; - int length, nwords; + if (is_lisp_pointer(next_vector_obj) && + (widetag_of(*(lispobj *)native_pointer(next_vector_obj)) == + SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG)) { + next_vector = ((unsigned int *)native_pointer(next_vector_obj)) + 2; + /*FSHOW((stderr, "/next_vector = %x\n", next_vector));*/ + next_vector_length = fixnum_value(((unsigned int *)native_pointer(next_vector_obj))[1]); + /*FSHOW((stderr, "/next_vector_length = %d\n", next_vector_length));*/ + } else { + lose("invalid next_vector %x", next_vector_obj); + } + } - vector = (struct vector *) where; - length = fixnum_value(vector->length); - nwords = CEILING(length * 4 + 2, 2); + /* maybe hash vector */ + { + /* FIXME: This bare "15" offset should become a symbolic + * expression of some sort. And all the other bare offsets + * too. And the bare "16" in scavenge(hash_table, 16). And + * probably other stuff too. Ugh.. */ + lispobj hash_vector_obj = hash_table[15]; - return nwords; -} -#endif + if (is_lisp_pointer(hash_vector_obj) && + (widetag_of(*(lispobj *)native_pointer(hash_vector_obj)) + == SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG)) { + hash_vector = ((unsigned int *)native_pointer(hash_vector_obj)) + 2; + /*FSHOW((stderr, "/hash_vector = %x\n", hash_vector));*/ + gc_assert(fixnum_value(((unsigned int *)native_pointer(hash_vector_obj))[1]) + == next_vector_length); + } else { + hash_vector = NULL; + /*FSHOW((stderr, "/no hash_vector: %x\n", hash_vector_obj));*/ + } + } + /* These lengths could be different as the index_vector can be a + * different length from the others, a larger index_vector could help + * reduce collisions. */ + gc_assert(next_vector_length*2 == kv_length); -#ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG -static int -scav_vector_complex_long_float(lispobj *where, lispobj object) -{ - struct vector *vector; - int length, nwords; + /* now all set up.. */ - vector = (struct vector *) where; - length = fixnum_value(vector->length); - nwords = CEILING(length * 6 + 2, 2); + /* Work through the KV vector. */ + { + int i; + for (i = 1; i < next_vector_length; i++) { + lispobj old_key = kv_vector[2*i]; + unsigned int old_index = (old_key & 0x1fffffff)%length; - return nwords; -} + /* Scavenge the key and value. */ + scavenge(&kv_vector[2*i],2); -static lispobj -trans_vector_complex_long_float(lispobj object) -{ - struct vector *vector; - int length, nwords; + /* Check whether the key has moved and is EQ based. */ + { + lispobj new_key = kv_vector[2*i]; + unsigned int new_index = (new_key & 0x1fffffff)%length; - gc_assert(is_lisp_pointer(object)); + if ((old_index != new_index) && + ((!hash_vector) || (hash_vector[i] == 0x80000000)) && + ((new_key != empty_symbol) || + (kv_vector[2*i] != empty_symbol))) { - vector = (struct vector *) native_pointer(object); - length = fixnum_value(vector->length); - nwords = CEILING(length * 6 + 2, 2); + /*FSHOW((stderr, + "* EQ key %d moved from %x to %x; index %d to %d\n", + i, old_key, new_key, old_index, new_index));*/ - return copy_large_unboxed_object(object, nwords); -} + if (index_vector[old_index] != 0) { + /*FSHOW((stderr, "/P1 %d\n", index_vector[old_index]));*/ -static int -size_vector_complex_long_float(lispobj *where) -{ - struct vector *vector; - int length, nwords; + /* Unlink the key from the old_index chain. */ + if (index_vector[old_index] == i) { + /*FSHOW((stderr, "/P2a %d\n", next_vector[i]));*/ + index_vector[old_index] = next_vector[i]; + /* Link it into the needing rehash chain. */ + next_vector[i] = fixnum_value(hash_table[11]); + hash_table[11] = make_fixnum(i); + /*SHOW("P2");*/ + } else { + unsigned prior = index_vector[old_index]; + unsigned next = next_vector[prior]; - vector = (struct vector *) where; - length = fixnum_value(vector->length); - nwords = CEILING(length * 6 + 2, 2); + /*FSHOW((stderr, "/P3a %d %d\n", prior, next));*/ - return nwords; + while (next != 0) { + /*FSHOW((stderr, "/P3b %d %d\n", prior, next));*/ + if (next == i) { + /* Unlink it. */ + next_vector[prior] = next_vector[next]; + /* Link it into the needing rehash + * chain. */ + next_vector[next] = + fixnum_value(hash_table[11]); + hash_table[11] = make_fixnum(next); + /*SHOW("/P3");*/ + break; + } + prior = next; + next = next_vector[next]; + } + } + } + } + } + } + } + return (CEILING(kv_length + 2, 2)); } -#endif + /* @@ -3472,396 +2134,6 @@ scav_weak_pointer(lispobj *where, lispobj object) return WEAK_POINTER_NWORDS; } -static lispobj -trans_weak_pointer(lispobj object) -{ - lispobj copy; - /* struct weak_pointer *wp; */ - - gc_assert(is_lisp_pointer(object)); - -#if defined(DEBUG_WEAK) - FSHOW((stderr, "Transporting weak pointer from 0x%08x\n", object)); -#endif - - /* Need to remember where all the weak pointers are that have */ - /* been transported so they can be fixed up in a post-GC pass. */ - - copy = copy_object(object, WEAK_POINTER_NWORDS); - /* wp = (struct weak_pointer *) native_pointer(copy);*/ - - - /* Push the weak pointer onto the list of weak pointers. */ - /* wp->next = weak_pointers; - * weak_pointers = wp;*/ - - return copy; -} - -static int -size_weak_pointer(lispobj *where) -{ - return WEAK_POINTER_NWORDS; -} - -void scan_weak_pointers(void) -{ - struct weak_pointer *wp; - for (wp = weak_pointers; wp != NULL; wp = wp->next) { - lispobj value = wp->value; - lispobj *first_pointer; - - first_pointer = (lispobj *)native_pointer(value); - - if (is_lisp_pointer(value) && from_space_p(value)) { - /* Now, we need to check whether the object has been forwarded. If - * it has been, the weak pointer is still good and needs to be - * updated. Otherwise, the weak pointer needs to be nil'ed - * out. */ - if (first_pointer[0] == 0x01) { - wp->value = first_pointer[1]; - } else { - /* Break it. */ - wp->value = NIL; - wp->broken = T; - } - } - } -} - -/* - * initialization - */ - -static int -scav_lose(lispobj *where, lispobj object) -{ - lose("no scavenge function for object 0x%08x (widetag 0x%x)", - (unsigned long)object, - widetag_of(*(lispobj*)native_pointer(object))); - return 0; /* bogus return value to satisfy static type checking */ -} - -static lispobj -trans_lose(lispobj object) -{ - lose("no transport function for object 0x%08x (widetag 0x%x)", - (unsigned long)object, - widetag_of(*(lispobj*)native_pointer(object))); - return NIL; /* bogus return value to satisfy static type checking */ -} - -static int -size_lose(lispobj *where) -{ - lose("no size function for object at 0x%08x (widetag 0x%x)", - (unsigned long)where, - widetag_of(where)); - return 1; /* bogus return value to satisfy static type checking */ -} - -static void -gc_init_tables(void) -{ - int i; - - /* Set default value in all slots of scavenge table. */ - for (i = 0; i < 256; i++) { /* FIXME: bare constant length, ick! */ - scavtab[i] = scav_lose; - } - - /* For each type which can be selected by the lowtag alone, set - * multiple entries in our widetag scavenge table (one for each - * possible value of the high bits). - * - * FIXME: bare constant 32 and 3 here, ick! */ - for (i = 0; i < 32; i++) { - scavtab[EVEN_FIXNUM_LOWTAG|(i<<3)] = scav_immediate; - scavtab[FUN_POINTER_LOWTAG|(i<<3)] = scav_fun_pointer; - /* skipping OTHER_IMMEDIATE_0_LOWTAG */ - scavtab[LIST_POINTER_LOWTAG|(i<<3)] = scav_list_pointer; - scavtab[ODD_FIXNUM_LOWTAG|(i<<3)] = scav_immediate; - scavtab[INSTANCE_POINTER_LOWTAG|(i<<3)] = scav_instance_pointer; - /* skipping OTHER_IMMEDIATE_1_LOWTAG */ - scavtab[OTHER_POINTER_LOWTAG|(i<<3)] = scav_other_pointer; - } - - /* Other-pointer types (those selected by all eight bits of the - * tag) get one entry each in the scavenge table. */ - scavtab[BIGNUM_WIDETAG] = scav_unboxed; - scavtab[RATIO_WIDETAG] = scav_boxed; - scavtab[SINGLE_FLOAT_WIDETAG] = scav_unboxed; - scavtab[DOUBLE_FLOAT_WIDETAG] = scav_unboxed; -#ifdef LONG_FLOAT_WIDETAG - scavtab[LONG_FLOAT_WIDETAG] = scav_unboxed; -#endif - scavtab[COMPLEX_WIDETAG] = scav_boxed; -#ifdef COMPLEX_SINGLE_FLOAT_WIDETAG - scavtab[COMPLEX_SINGLE_FLOAT_WIDETAG] = scav_unboxed; -#endif -#ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG - scavtab[COMPLEX_DOUBLE_FLOAT_WIDETAG] = scav_unboxed; -#endif -#ifdef COMPLEX_LONG_FLOAT_WIDETAG - scavtab[COMPLEX_LONG_FLOAT_WIDETAG] = scav_unboxed; -#endif - scavtab[SIMPLE_ARRAY_WIDETAG] = scav_boxed; - scavtab[SIMPLE_STRING_WIDETAG] = scav_string; - scavtab[SIMPLE_BIT_VECTOR_WIDETAG] = scav_vector_bit; - scavtab[SIMPLE_VECTOR_WIDETAG] = scav_vector; - scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG] = - scav_vector_unsigned_byte_2; - scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG] = - scav_vector_unsigned_byte_4; - scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG] = - scav_vector_unsigned_byte_8; - scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG] = - scav_vector_unsigned_byte_16; - scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG] = - scav_vector_unsigned_byte_32; -#ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG - scavtab[SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG] = scav_vector_unsigned_byte_8; -#endif -#ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG - scavtab[SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG] = - scav_vector_unsigned_byte_16; -#endif -#ifdef SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG - scavtab[SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG] = - scav_vector_unsigned_byte_32; -#endif -#ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG - scavtab[SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG] = - scav_vector_unsigned_byte_32; -#endif - scavtab[SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG] = scav_vector_single_float; - scavtab[SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG] = scav_vector_double_float; -#ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG - scavtab[SIMPLE_ARRAY_LONG_FLOAT_WIDETAG] = scav_vector_long_float; -#endif -#ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG - scavtab[SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG] = - scav_vector_complex_single_float; -#endif -#ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG - scavtab[SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG] = - scav_vector_complex_double_float; -#endif -#ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG - scavtab[SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG] = - scav_vector_complex_long_float; -#endif - scavtab[COMPLEX_STRING_WIDETAG] = scav_boxed; - scavtab[COMPLEX_BIT_VECTOR_WIDETAG] = scav_boxed; - scavtab[COMPLEX_VECTOR_WIDETAG] = scav_boxed; - scavtab[COMPLEX_ARRAY_WIDETAG] = scav_boxed; - scavtab[CODE_HEADER_WIDETAG] = scav_code_header; - /*scavtab[SIMPLE_FUN_HEADER_WIDETAG] = scav_fun_header;*/ - /*scavtab[CLOSURE_FUN_HEADER_WIDETAG] = scav_fun_header;*/ - /*scavtab[RETURN_PC_HEADER_WIDETAG] = scav_return_pc_header;*/ -#ifdef __i386__ - scavtab[CLOSURE_HEADER_WIDETAG] = scav_closure_header; - scavtab[FUNCALLABLE_INSTANCE_HEADER_WIDETAG] = scav_closure_header; -#else - scavtab[CLOSURE_HEADER_WIDETAG] = scav_boxed; - scavtab[FUNCALLABLE_INSTANCE_HEADER_WIDETAG] = scav_boxed; -#endif - scavtab[VALUE_CELL_HEADER_WIDETAG] = scav_boxed; - scavtab[SYMBOL_HEADER_WIDETAG] = scav_boxed; - scavtab[BASE_CHAR_WIDETAG] = scav_immediate; - scavtab[SAP_WIDETAG] = scav_unboxed; - scavtab[UNBOUND_MARKER_WIDETAG] = scav_immediate; - scavtab[WEAK_POINTER_WIDETAG] = scav_weak_pointer; - scavtab[INSTANCE_HEADER_WIDETAG] = scav_boxed; - scavtab[FDEFN_WIDETAG] = scav_fdefn; - - /* transport other table, initialized same way as scavtab */ - for (i = 0; i < 256; i++) - transother[i] = trans_lose; - transother[BIGNUM_WIDETAG] = trans_unboxed; - transother[RATIO_WIDETAG] = trans_boxed; - transother[SINGLE_FLOAT_WIDETAG] = trans_unboxed; - transother[DOUBLE_FLOAT_WIDETAG] = trans_unboxed; -#ifdef LONG_FLOAT_WIDETAG - transother[LONG_FLOAT_WIDETAG] = trans_unboxed; -#endif - transother[COMPLEX_WIDETAG] = trans_boxed; -#ifdef COMPLEX_SINGLE_FLOAT_WIDETAG - transother[COMPLEX_SINGLE_FLOAT_WIDETAG] = trans_unboxed; -#endif -#ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG - transother[COMPLEX_DOUBLE_FLOAT_WIDETAG] = trans_unboxed; -#endif -#ifdef COMPLEX_LONG_FLOAT_WIDETAG - transother[COMPLEX_LONG_FLOAT_WIDETAG] = trans_unboxed; -#endif - transother[SIMPLE_ARRAY_WIDETAG] = trans_boxed_large; - transother[SIMPLE_STRING_WIDETAG] = trans_string; - transother[SIMPLE_BIT_VECTOR_WIDETAG] = trans_vector_bit; - transother[SIMPLE_VECTOR_WIDETAG] = trans_vector; - transother[SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG] = - trans_vector_unsigned_byte_2; - transother[SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG] = - trans_vector_unsigned_byte_4; - transother[SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG] = - trans_vector_unsigned_byte_8; - transother[SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG] = - trans_vector_unsigned_byte_16; - transother[SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG] = - trans_vector_unsigned_byte_32; -#ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG - transother[SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG] = - trans_vector_unsigned_byte_8; -#endif -#ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG - transother[SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG] = - trans_vector_unsigned_byte_16; -#endif -#ifdef SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG - transother[SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG] = - trans_vector_unsigned_byte_32; -#endif -#ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG - transother[SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG] = - trans_vector_unsigned_byte_32; -#endif - transother[SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG] = - trans_vector_single_float; - transother[SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG] = - trans_vector_double_float; -#ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG - transother[SIMPLE_ARRAY_LONG_FLOAT_WIDETAG] = - trans_vector_long_float; -#endif -#ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG - transother[SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG] = - trans_vector_complex_single_float; -#endif -#ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG - transother[SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG] = - trans_vector_complex_double_float; -#endif -#ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG - transother[SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG] = - trans_vector_complex_long_float; -#endif - transother[COMPLEX_STRING_WIDETAG] = trans_boxed; - transother[COMPLEX_BIT_VECTOR_WIDETAG] = trans_boxed; - transother[COMPLEX_VECTOR_WIDETAG] = trans_boxed; - transother[COMPLEX_ARRAY_WIDETAG] = trans_boxed; - transother[CODE_HEADER_WIDETAG] = trans_code_header; - transother[SIMPLE_FUN_HEADER_WIDETAG] = trans_fun_header; - transother[CLOSURE_FUN_HEADER_WIDETAG] = trans_fun_header; - transother[RETURN_PC_HEADER_WIDETAG] = trans_return_pc_header; - transother[CLOSURE_HEADER_WIDETAG] = trans_boxed; - transother[FUNCALLABLE_INSTANCE_HEADER_WIDETAG] = trans_boxed; - transother[VALUE_CELL_HEADER_WIDETAG] = trans_boxed; - transother[SYMBOL_HEADER_WIDETAG] = trans_boxed; - transother[BASE_CHAR_WIDETAG] = trans_immediate; - transother[SAP_WIDETAG] = trans_unboxed; - transother[UNBOUND_MARKER_WIDETAG] = trans_immediate; - transother[WEAK_POINTER_WIDETAG] = trans_weak_pointer; - transother[INSTANCE_HEADER_WIDETAG] = trans_boxed; - transother[FDEFN_WIDETAG] = trans_boxed; - - /* size table, initialized the same way as scavtab */ - for (i = 0; i < 256; i++) - sizetab[i] = size_lose; - for (i = 0; i < 32; i++) { - sizetab[EVEN_FIXNUM_LOWTAG|(i<<3)] = size_immediate; - sizetab[FUN_POINTER_LOWTAG|(i<<3)] = size_pointer; - /* skipping OTHER_IMMEDIATE_0_LOWTAG */ - sizetab[LIST_POINTER_LOWTAG|(i<<3)] = size_pointer; - sizetab[ODD_FIXNUM_LOWTAG|(i<<3)] = size_immediate; - sizetab[INSTANCE_POINTER_LOWTAG|(i<<3)] = size_pointer; - /* skipping OTHER_IMMEDIATE_1_LOWTAG */ - sizetab[OTHER_POINTER_LOWTAG|(i<<3)] = size_pointer; - } - sizetab[BIGNUM_WIDETAG] = size_unboxed; - sizetab[RATIO_WIDETAG] = size_boxed; - sizetab[SINGLE_FLOAT_WIDETAG] = size_unboxed; - sizetab[DOUBLE_FLOAT_WIDETAG] = size_unboxed; -#ifdef LONG_FLOAT_WIDETAG - sizetab[LONG_FLOAT_WIDETAG] = size_unboxed; -#endif - sizetab[COMPLEX_WIDETAG] = size_boxed; -#ifdef COMPLEX_SINGLE_FLOAT_WIDETAG - sizetab[COMPLEX_SINGLE_FLOAT_WIDETAG] = size_unboxed; -#endif -#ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG - sizetab[COMPLEX_DOUBLE_FLOAT_WIDETAG] = size_unboxed; -#endif -#ifdef COMPLEX_LONG_FLOAT_WIDETAG - sizetab[COMPLEX_LONG_FLOAT_WIDETAG] = size_unboxed; -#endif - sizetab[SIMPLE_ARRAY_WIDETAG] = size_boxed; - sizetab[SIMPLE_STRING_WIDETAG] = size_string; - sizetab[SIMPLE_BIT_VECTOR_WIDETAG] = size_vector_bit; - sizetab[SIMPLE_VECTOR_WIDETAG] = size_vector; - sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG] = - size_vector_unsigned_byte_2; - sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG] = - size_vector_unsigned_byte_4; - sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG] = - size_vector_unsigned_byte_8; - sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG] = - size_vector_unsigned_byte_16; - sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG] = - size_vector_unsigned_byte_32; -#ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG - sizetab[SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG] = size_vector_unsigned_byte_8; -#endif -#ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG - sizetab[SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG] = - size_vector_unsigned_byte_16; -#endif -#ifdef SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG - sizetab[SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG] = - size_vector_unsigned_byte_32; -#endif -#ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG - sizetab[SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG] = - size_vector_unsigned_byte_32; -#endif - sizetab[SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG] = size_vector_single_float; - sizetab[SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG] = size_vector_double_float; -#ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG - sizetab[SIMPLE_ARRAY_LONG_FLOAT_WIDETAG] = size_vector_long_float; -#endif -#ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG - sizetab[SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG] = - size_vector_complex_single_float; -#endif -#ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG - sizetab[SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG] = - size_vector_complex_double_float; -#endif -#ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG - sizetab[SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG] = - size_vector_complex_long_float; -#endif - sizetab[COMPLEX_STRING_WIDETAG] = size_boxed; - sizetab[COMPLEX_BIT_VECTOR_WIDETAG] = size_boxed; - sizetab[COMPLEX_VECTOR_WIDETAG] = size_boxed; - sizetab[COMPLEX_ARRAY_WIDETAG] = size_boxed; - sizetab[CODE_HEADER_WIDETAG] = size_code_header; -#if 0 - /* We shouldn't see these, so just lose if it happens. */ - sizetab[SIMPLE_FUN_HEADER_WIDETAG] = size_function_header; - sizetab[CLOSURE_FUN_HEADER_WIDETAG] = size_function_header; - sizetab[RETURN_PC_HEADER_WIDETAG] = size_return_pc_header; -#endif - sizetab[CLOSURE_HEADER_WIDETAG] = size_boxed; - sizetab[FUNCALLABLE_INSTANCE_HEADER_WIDETAG] = size_boxed; - sizetab[VALUE_CELL_HEADER_WIDETAG] = size_boxed; - sizetab[SYMBOL_HEADER_WIDETAG] = size_boxed; - sizetab[BASE_CHAR_WIDETAG] = size_immediate; - sizetab[SAP_WIDETAG] = size_unboxed; - sizetab[UNBOUND_MARKER_WIDETAG] = size_immediate; - sizetab[WEAK_POINTER_WIDETAG] = size_weak_pointer; - sizetab[INSTANCE_HEADER_WIDETAG] = size_boxed; - sizetab[FDEFN_WIDETAG] = size_boxed; -} /* Scan an area looking for an object which encloses the given pointer. * Return the object start on success or NULL on failure. */ @@ -5611,14 +3883,15 @@ update_x86_dynamic_space_free_pointer(void) return 0; /* dummy value: return something ... */ } -/* GC all generations below last_gen, raising their objects to the - * next generation until all generations below last_gen are empty. - * Then if last_gen is due for a GC then GC it. In the special case - * that last_gen==NUM_GENERATIONS, the last generation is always - * GC'ed. The valid range for last_gen is: 0,1,...,NUM_GENERATIONS. +/* GC all generations newer than last_gen, raising the objects in each + * to the next older generation - we finish when all generations below + * last_gen are empty. Then if last_gen is due for a GC, or if + * last_gen==NUM_GENERATIONS (the scratch generation? eh?) we GC that + * too. The valid range for last_gen is: 0,1,...,NUM_GENERATIONS. * - * The oldest generation to be GCed will always be - * gencgc_oldest_gen_to_gc, partly ignoring last_gen if necessary. */ + * We stop collecting at gencgc_oldest_gen_to_gc, even if this is less than + * last_gen (oh, and note that by default it is NUM_GENERATIONS-1) */ + void collect_garbage(unsigned last_gen) { @@ -5850,6 +4123,9 @@ gc_init(void) int i; gc_init_tables(); + scavtab[SIMPLE_VECTOR_WIDETAG] = scav_vector; + scavtab[WEAK_POINTER_WIDETAG] = scav_weak_pointer; + transother[SIMPLE_ARRAY_WIDETAG] = trans_boxed_large; heap_base = (void*)DYNAMIC_SPACE_START; @@ -5909,7 +4185,7 @@ gc_init(void) * The ALLOCATION_POINTER points to the end of the dynamic space. * * XX A scan is needed to identify the closest first objects for pages. */ -void +static void gencgc_pickup_dynamic(void) { int page = 0; @@ -5934,6 +4210,14 @@ gencgc_pickup_dynamic(void) current_region_free_pointer = boxed_region.free_pointer; current_region_end_addr = boxed_region.end_addr; } + +void +gc_initialize_pointers(void) +{ + gencgc_pickup_dynamic(); +} + + /* a counter for how deep we are in alloc(..) calls */ int alloc_entered = 0; @@ -6019,7 +4303,7 @@ alloc(int nbytes) /* Call gc_alloc(). */ boxed_region.free_pointer = current_region_free_pointer; { - void *new_obj = gc_alloc(nbytes); + void *new_obj = gc_alloc(nbytes,0); current_region_free_pointer = boxed_region.free_pointer; current_region_end_addr = boxed_region.end_addr; alloc_entered--; @@ -6078,7 +4362,7 @@ alloc(int nbytes) /* Else call gc_alloc(). */ boxed_region.free_pointer = current_region_free_pointer; - result = gc_alloc(nbytes); + result = gc_alloc(nbytes,0); current_region_free_pointer = boxed_region.free_pointer; current_region_end_addr = boxed_region.end_addr; @@ -6148,6 +4432,7 @@ void unhandled_sigmemoryfault(void); * Return true if this signal is a normal generational GC thing that * we were able to handle, or false if it was abnormal and control * should fall through to the general SIGSEGV/SIGBUS/whatever logic. */ + int gencgc_handle_wp_violation(void* fault_addr) { diff --git a/src/runtime/gencgc.h b/src/runtime/gencgc.h index 2852b1c..4ec36c0 100644 --- a/src/runtime/gencgc.h +++ b/src/runtime/gencgc.h @@ -32,7 +32,7 @@ struct page { write_protected :1, /* This flag is set when the above write_protected flag is * cleared by the SIGBUS handler (or SIGSEGV handler, for some - * OSes). This is useful for * re-scavenging pages that are + * OSes). This is useful for re-scavenging pages that are * written during a GC. */ write_protected_cleared :1, /* the region the page is allocated to: 0 for a free page; 1 @@ -70,6 +70,12 @@ struct page { #define FREE_PAGE 0 #define BOXED_PAGE 1 #define UNBOXED_PAGE 2 + +/* values for the *_alloc_* parameters */ +#define ALLOC_BOXED 0 +#define ALLOC_UNBOXED 1 +#define ALLOC_QUICK 1 + /* the number of pages needed for the dynamic space - rounding up */ #define NUM_PAGES ((DYNAMIC_SPACE_SIZE+4095)/4096) diff --git a/src/runtime/globals.c b/src/runtime/globals.c index e775166..96636d1 100644 --- a/src/runtime/globals.c +++ b/src/runtime/globals.c @@ -37,7 +37,7 @@ lispobj *current_binding_stack_pointer; lispobj *dynamic_space_free_pointer; #endif -#ifndef GENCGC /* since GENCGC has its own way to record trigger */ +#ifndef LISP_FEATURE_GENCGC /* GENCGC has its own way to record trigger */ lispobj *current_auto_gc_trigger; #endif @@ -51,7 +51,7 @@ void globals_init(void) /* Space, stack, and free pointer vars are initialized by * validate() and coreparse(). */ -#ifndef GENCGC /* since GENCGC has its own way to record trigger */ +#ifndef LISP_FEATURE_GENCGC /* no GC trigger yet */ current_auto_gc_trigger = NULL; #endif @@ -68,6 +68,6 @@ void globals_init(void) current_control_frame_pointer = (lispobj *)0; #ifndef BINDING_STACK_POINTER - current_binding_stack_pointer = BINDING_STACK_START; + current_binding_stack_pointer = native_pointer(BINDING_STACK_START); #endif } diff --git a/src/runtime/interrupt.c b/src/runtime/interrupt.c index 08771dc..f5e5979 100644 --- a/src/runtime/interrupt.c +++ b/src/runtime/interrupt.c @@ -502,7 +502,8 @@ interrupt_handle_now_handler(int signal, siginfo_t *info, void *void_context) * stuff to detect and handle hitting the GC trigger */ -#ifndef GENCGC /* since GENCGC has its own way to record trigger */ +#ifndef LISP_FEATURE_GENCGC +/* since GENCGC has its own way to record trigger */ static boolean gc_trigger_hit(int signal, siginfo_t *info, os_context_t *context) { @@ -522,8 +523,8 @@ boolean handle_control_stack_guard_triggered(os_context_t *context,void *addr) { /* note the os_context hackery here. When the signal handler returns, * it won't go back to what it was doing ... */ - if(addr>=CONTROL_STACK_GUARD_PAGE && - addr<(CONTROL_STACK_GUARD_PAGE+os_vm_page_size)) { + if(addr>=(void *)CONTROL_STACK_GUARD_PAGE && + addr<(void *)(CONTROL_STACK_GUARD_PAGE+os_vm_page_size)) { void *fun; void *code; @@ -531,7 +532,8 @@ boolean handle_control_stack_guard_triggered(os_context_t *context,void *addr) * temporarily so the error handler has some headroom */ protect_control_stack_guard_page(0); - fun = native_pointer(SymbolFunction(CONTROL_STACK_EXHAUSTED_ERROR)); + fun = (void *) + native_pointer((lispobj) SymbolFunction(CONTROL_STACK_EXHAUSTED_ERROR)); code = &(((struct simple_fun *) fun)->code); /* Build a stack frame showing `interrupted' so that the @@ -571,7 +573,7 @@ boolean handle_control_stack_guard_triggered(os_context_t *context,void *addr) else return 0; } -#ifndef __i386__ +#ifndef LISP_FEATURE_X86 /* This function gets called from the SIGSEGV (for e.g. Linux or * OpenBSD) or SIGBUS (for e.g. FreeBSD) handler. Here we check * whether the signal was due to treading on the mprotect()ed zone - @@ -582,11 +584,13 @@ interrupt_maybe_gc(int signal, siginfo_t *info, void *void_context) os_context_t *context=(os_context_t *) void_context; if (!foreign_function_call_active -#ifndef GENCGC /* since GENCGC has its own way to record trigger */ +#ifndef LISP_FEATURE_GENCGC + /* nb: GENCGC on non-x86? I really don't think so. This + * happens every time */ && gc_trigger_hit(signal, info, context) #endif ) { -#ifndef GENCGC /* since GENCGC has its own way to record trigger */ +#ifndef LISP_FEATURE_GENCGC clear_auto_gc_trigger(); #endif diff --git a/src/runtime/linux-os.c b/src/runtime/linux-os.c index 0bee001..371cbb6 100644 --- a/src/runtime/linux-os.c +++ b/src/runtime/linux-os.c @@ -44,9 +44,7 @@ #include "validate.h" size_t os_vm_page_size; -#if defined GENCGC -#include "gencgc.h" -#endif +#include "gc.h" #ifdef sparc @@ -243,7 +241,7 @@ is_valid_lisp_addr(os_vm_address_t addr) */ -#if defined GENCGC +#if defined LISP_FEATURE_GENCGC /* * The GENCGC needs to be hooked into whatever signal is raised for diff --git a/src/runtime/osf1-os.c b/src/runtime/osf1-os.c index 05fd248..57ee8c1 100644 --- a/src/runtime/osf1-os.c +++ b/src/runtime/osf1-os.c @@ -49,9 +49,6 @@ #include "validate.h" size_t os_vm_page_size; -#if defined GENCGC -#include "gencgc.h" -#endif void os_init(void) diff --git a/src/runtime/parse.c b/src/runtime/parse.c index bd5cc92..37c4c0a 100644 --- a/src/runtime/parse.c +++ b/src/runtime/parse.c @@ -246,7 +246,7 @@ static boolean lookup_symbol(char *name, lispobj *result) (lispobj *)SymbolValue(STATIC_SPACE_FREE_POINTER) - (lispobj *)STATIC_SPACE_START; if (search_for_symbol(name, &headerptr, &count)) { - *result = (lispobj)headerptr | OTHER_POINTER_LOWTAG; + *result = make_lispobj(headerptr,OTHER_POINTER_LOWTAG); return 1; } @@ -262,7 +262,7 @@ static boolean lookup_symbol(char *name, lispobj *result) (lispobj *)DYNAMIC_SPACE_START; #endif if (search_for_symbol(name, &headerptr, &count)) { - *result = (lispobj)headerptr | OTHER_POINTER_LOWTAG; + *result = make_lispobj(headerptr, OTHER_POINTER_LOWTAG); return 1; } diff --git a/src/runtime/ppc-linux-os.c b/src/runtime/ppc-linux-os.c index 14411f6..00378f7 100644 --- a/src/runtime/ppc-linux-os.c +++ b/src/runtime/ppc-linux-os.c @@ -38,11 +38,6 @@ #include "validate.h" size_t os_vm_page_size; -#if defined GENCGC /* unlikely ... */ -#error SBCL PPC does not work with the GENCGC -#include "gencgc.h" -#endif - os_context_register_t * os_context_register_addr(os_context_t *context, int offset) { diff --git a/src/runtime/print.c b/src/runtime/print.c index 2cc6f1b..cb51452 100644 --- a/src/runtime/print.c +++ b/src/runtime/print.c @@ -288,7 +288,7 @@ static void brief_list(lispobj obj) int space = 0; int length = 0; - if (!is_valid_lisp_addr((os_vm_address_t)obj)) + if (!is_valid_lisp_addr((os_vm_address_t)native_pointer(obj))) printf("(invalid Lisp-level address)"); else if (obj == NIL) printf("NIL"); @@ -320,7 +320,7 @@ static void brief_list(lispobj obj) static void print_list(lispobj obj) { - if (!is_valid_lisp_addr((os_vm_address_t)obj)) { + if (!is_valid_lisp_addr((os_vm_address_t)native_pointer(obj))) { printf("(invalid address)"); } else if (obj == NIL) { printf(" (NIL)"); diff --git a/src/runtime/purify.c b/src/runtime/purify.c index dc66cd2..45a0e6d 100644 --- a/src/runtime/purify.c +++ b/src/runtime/purify.c @@ -26,9 +26,8 @@ #include "interrupt.h" #include "purify.h" #include "interr.h" -#ifdef GENCGC -#include "gencgc.h" -#endif +#include "gc.h" +#include "gc-internal.h" #define PRINTNOISE @@ -76,7 +75,9 @@ static int later_count = 0; #define CEILING(x,y) (((x) + ((y) - 1)) & (~((y) - 1))) #define NWORDS(x,y) (CEILING((x),(y)) / (y)) -/* FIXME: (1) Shouldn't this be defined in sbcl.h? */ +/* FIXME: Shouldn't this be defined in sbcl.h? See also notes in + * cheneygc.c */ + #ifdef sparc #define FUN_RAW_ADDR_OFFSET 0 #else @@ -86,9 +87,7 @@ static int later_count = 0; static boolean forwarding_pointer_p(lispobj obj) { - lispobj *ptr; - - ptr = (lispobj *)obj; + lispobj *ptr = native_pointer(obj); return ((static_end <= ptr && ptr <= static_free) || (read_only_end <= ptr && ptr <= read_only_free)); @@ -112,7 +111,7 @@ dynamic_pointer_p(lispobj ptr) #ifdef __i386__ -#ifdef GENCGC +#ifdef LISP_FEATURE_GENCGC /* * enhanced x86/GENCGC stack scavenging by Douglas Crosher * @@ -463,7 +462,7 @@ ptrans_boxed(lispobj thing, lispobj header, boolean constant) bcopy(old, new, nwords * sizeof(lispobj)); /* Deposit forwarding pointer. */ - result = (lispobj)new | lowtag_of(thing); + result = make_lispobj(new, lowtag_of(thing)); *old = result; /* Scavenge it. */ @@ -507,7 +506,7 @@ ptrans_instance(lispobj thing, lispobj header, boolean constant) bcopy(old, new, nwords * sizeof(lispobj)); /* Deposit forwarding pointer. */ - result = (lispobj)new | lowtag_of(thing); + result = make_lispobj(new, lowtag_of(thing)); *old = result; /* Scavenge it. */ @@ -539,7 +538,7 @@ ptrans_fdefn(lispobj thing, lispobj header) bcopy(old, new, nwords * sizeof(lispobj)); /* Deposit forwarding pointer. */ - result = (lispobj)new | lowtag_of(thing); + result = make_lispobj(new, lowtag_of(thing)); *old = result; /* Scavenge the function. */ @@ -557,19 +556,19 @@ ptrans_unboxed(lispobj thing, lispobj header) { int nwords; lispobj result, *new, *old; - + nwords = 1 + HeaderValue(header); - + /* Allocate it */ old = (lispobj *)native_pointer(thing); new = read_only_free; read_only_free += CEILING(nwords, 2); - + /* Copy it. */ bcopy(old, new, nwords * sizeof(lispobj)); - + /* Deposit forwarding pointer. */ - result = (lispobj)new | lowtag_of(thing); + result = make_lispobj(new , lowtag_of(thing)); *old = result; return result; @@ -597,7 +596,7 @@ ptrans_vector(lispobj thing, int bits, int extra, bcopy(vector, new, nwords * sizeof(lispobj)); - result = (lispobj)new | lowtag_of(thing); + result = make_lispobj(new, lowtag_of(thing)); vector->header = result; if (boxed) @@ -635,7 +634,7 @@ apply_code_fixups_during_purify(struct code *old_code, struct code *new_code) if ((fixups==0) || (fixups==UNBOUND_MARKER_WIDETAG) || !is_lisp_pointer(fixups)) { -#ifdef GENCGC +#ifdef LISP_FEATURE_GENCGC /* Check for a possible errors. */ sniff_code_object(new_code,displacement); #endif @@ -683,7 +682,7 @@ apply_code_fixups_during_purify(struct code *old_code, struct code *new_code) /* No longer need the fixups. */ new_code->constants[0] = 0; -#ifdef GENCGC +#ifdef LISP_FEATURE_GENCGC /* Check for possible errors. */ sniff_code_object(new_code,displacement); #endif @@ -705,11 +704,11 @@ ptrans_code(lispobj thing) bcopy(code, new, nwords * sizeof(lispobj)); -#ifdef __i386__ +#ifdef LISP_FEATURE_X86 apply_code_fixups_during_purify(code,new); #endif - result = (lispobj)new | OTHER_POINTER_LOWTAG; + result = make_lispobj(new, OTHER_POINTER_LOWTAG); /* Stick in a forwarding pointer for the code object. */ *(lispobj *)code = result; @@ -783,12 +782,13 @@ ptrans_func(lispobj thing, lispobj header) function = (struct simple_fun *)native_pointer(thing); code = - (native_pointer(thing) - - (HeaderValue(function->header)*sizeof(lispobj))) | - OTHER_POINTER_LOWTAG; - + make_lispobj + ((native_pointer(thing) - + (HeaderValue(function->header))), OTHER_POINTER_LOWTAG); + /* This will cause the function's header to be replaced with a * forwarding pointer. */ + ptrans_code(code); /* So we can just return that. */ @@ -816,7 +816,7 @@ ptrans_func(lispobj thing, lispobj header) bcopy(old, new, nwords * sizeof(lispobj)); /* Deposit forwarding pointer. */ - result = (lispobj)new | lowtag_of(thing); + result = make_lispobj(new, lowtag_of(thing)); *old = result; /* Scavenge it. */ @@ -874,7 +874,7 @@ ptrans_list(lispobj thing, boolean constant) thing = new->cdr = old->cdr; /* Set up the forwarding pointer. */ - *(lispobj *)old = ((lispobj)new) | LIST_POINTER_LOWTAG; + *(lispobj *)old = make_lispobj(new, LIST_POINTER_LOWTAG); /* And count this cell. */ length++; @@ -885,7 +885,7 @@ ptrans_list(lispobj thing, boolean constant) /* Scavenge the list we just copied. */ pscav((lispobj *)orig, length * WORDS_PER_CONS, constant); - return ((lispobj)orig) | LIST_POINTER_LOWTAG; + return make_lispobj(orig, LIST_POINTER_LOWTAG); } static lispobj @@ -1324,7 +1324,7 @@ purify(lispobj static_roots, lispobj read_only_roots) fflush(stdout); #endif -#ifdef GENCGC +#ifdef LISP_FEATURE_GENCGC gc_assert((lispobj *)CONTROL_STACK_END > ((&read_only_roots)+1)); setup_i386_stack_scav(((&static_roots)-2), (lispobj *)CONTROL_STACK_END); #endif @@ -1349,7 +1349,7 @@ purify(lispobj static_roots, lispobj read_only_roots) current_control_stack_pointer - (lispobj *)CONTROL_STACK_START, 0); #else -#ifdef GENCGC +#ifdef LISP_FEATURE_GENCGC pscav_i386_stack(); #endif #endif @@ -1445,7 +1445,7 @@ purify(lispobj static_roots, lispobj read_only_roots) #if !defined(__i386__) dynamic_space_free_pointer = current_dynamic_space; #else -#if defined GENCGC +#if defined LISP_FEATURE_GENCGC gc_free_heap(); #else #error unsupported case /* in CMU CL, was "ibmrt using GC" */ diff --git a/src/runtime/runtime.c b/src/runtime/runtime.c index 039dac6..98a3d57 100644 --- a/src/runtime/runtime.c +++ b/src/runtime/runtime.c @@ -40,9 +40,6 @@ #include "interr.h" #include "monitor.h" #include "validate.h" -#if defined GENCGC -#include "gencgc.h" -#endif #include "core.h" #include "save.h" #include "lispregs.h" @@ -263,10 +260,7 @@ More information about SBCL is available at .\n\ SHOW("freeing core"); free(core); -#if defined GENCGC - gencgc_pickup_dynamic(); -#else -#endif + gc_initialize_pointers(); #ifdef BINDING_STACK_POINTER SetSymbolValue(BINDING_STACK_POINTER, BINDING_STACK_START); diff --git a/src/runtime/runtime.h b/src/runtime/runtime.h index 0e8f623..0ee1264 100644 --- a/src/runtime/runtime.h +++ b/src/runtime/runtime.h @@ -59,7 +59,8 @@ typedef unsigned int u32; typedef signed int s32; #define LOW_WORD(c) ((long)(c) & 0xFFFFFFFFL) - +/* this is an integral type the same length as a machine pointer */ +typedef unsigned long pointer_sized_uint_t ; typedef u32 lispobj; @@ -83,11 +84,15 @@ is_lisp_pointer(lispobj obj) /* Convert from a lispobj with type bits to a native (ordinary * C/assembly) pointer to the beginning of the object. */ -static inline lispobj +static inline lispobj * native_pointer(lispobj obj) { - return obj & ~LOWTAG_MASK; + return (lispobj *) ((pointer_sized_uint_t) (obj & ~LOWTAG_MASK)); } +/* inverse operation: create a suitably tagged lispobj from a native + * pointer or integer. Needs to be a macro due to the tedious C type + * system */ +#define make_lispobj(o,low_tag) ((lispobj)(LOW_WORD(o)|low_tag)) /* FIXME: There seems to be no reason that make_fixnum and fixnum_value * can't be implemented as (possibly inline) functions. */ @@ -109,7 +114,7 @@ typedef int boolean; /* This only works for static symbols. */ /* FIXME: should be called StaticSymbolFunction, right? */ #define SymbolFunction(sym) \ - (((struct fdefn *)(SymbolValue(sym)-OTHER_POINTER_LOWTAG))->fun) + (((struct fdefn *)(native_pointer(SymbolValue(sym))))->fun) /* KLUDGE: As far as I can tell there's no ANSI C way of saying * "this function never returns". This is the way that you do it diff --git a/src/runtime/save.c b/src/runtime/save.c index 1c50cca..8069141 100644 --- a/src/runtime/save.c +++ b/src/runtime/save.c @@ -23,10 +23,7 @@ #include "dynbind.h" #include "lispregs.h" #include "validate.h" - -#ifdef GENCGC -#include "gencgc.h" -#endif +#include "gc-internal.h" static long write_bytes(FILE *file, char *addr, long bytes) @@ -134,7 +131,7 @@ save(char *filename, lispobj init_function) (lispobj *)current_dynamic_space, dynamic_space_free_pointer); #else -#ifdef GENCGC +#ifdef LISP_FEATURE_GENCGC /* Flush the current_region, updating the tables. */ gc_alloc_update_page_tables(0,&boxed_region); gc_alloc_update_page_tables(1,&unboxed_region); diff --git a/src/runtime/sparc-linux-os.c b/src/runtime/sparc-linux-os.c index 9d4d683..fec7970 100644 --- a/src/runtime/sparc-linux-os.c +++ b/src/runtime/sparc-linux-os.c @@ -37,9 +37,6 @@ #include "validate.h" size_t os_vm_page_size; -#if defined GENCGC /* unlikely ... */ -#include "gencgc.h" -#endif os_context_register_t * os_context_register_addr(os_context_t *context, int offset) diff --git a/src/runtime/sparc-sunos-os.c b/src/runtime/sparc-sunos-os.c index 634e5e1..469c5a0 100644 --- a/src/runtime/sparc-sunos-os.c +++ b/src/runtime/sparc-sunos-os.c @@ -36,9 +36,6 @@ #include "validate.h" -#if defined GENCGC /* unlikely ... */ -#include "gencgc.h" -#endif os_context_register_t * os_context_register_addr(os_context_t *context, int offset) diff --git a/src/runtime/sunos-os.c b/src/runtime/sunos-os.c index 2a6bf34..a6ab92f 100644 --- a/src/runtime/sunos-os.c +++ b/src/runtime/sunos-os.c @@ -160,11 +160,6 @@ boolean is_valid_lisp_addr(os_vm_address_t addr) -#if defined GENCGC - -#error "GENCGC is not yet supported (presumably on x86 solaris?)" - -#else static void sigsegv_handler(int signal, siginfo_t *info, void* void_context) @@ -179,8 +174,6 @@ sigsegv_handler(int signal, siginfo_t *info, void* void_context) } } -#endif - void os_install_interrupt_handlers() { diff --git a/src/runtime/validate.c b/src/runtime/validate.c index 54b3a6b..be8ad27 100644 --- a/src/runtime/validate.c +++ b/src/runtime/validate.c @@ -66,7 +66,7 @@ validate(void) ensure_space( (lispobj *)READ_ONLY_SPACE_START, READ_ONLY_SPACE_SIZE); ensure_space( (lispobj *)STATIC_SPACE_START , STATIC_SPACE_SIZE); -#ifdef GENCGC +#ifdef LISP_FEATURE_GENCGC ensure_space( (lispobj *)DYNAMIC_SPACE_START , DYNAMIC_SPACE_SIZE); #else ensure_space( (lispobj *)DYNAMIC_0_SPACE_START , DYNAMIC_SPACE_SIZE); @@ -81,9 +81,6 @@ validate(void) #ifdef HOLES make_holes(); #endif -#ifndef GENCGC - current_dynamic_space = DYNAMIC_0_SPACE_START; -#endif #ifdef PRINTNOISE printf(" done.\n"); diff --git a/src/runtime/validate.h b/src/runtime/validate.h index 61a1d51..2a963a0 100644 --- a/src/runtime/validate.h +++ b/src/runtime/validate.h @@ -27,6 +27,7 @@ #if !defined(LANGUAGE_ASSEMBLY) extern void validate(void); +extern void protect_control_stack_guard_page(int protect_p); #endif /* note for anyone trying to port an architecture's support files diff --git a/src/runtime/x86-assem.S b/src/runtime/x86-assem.S index be58839..4fe372a 100644 --- a/src/runtime/x86-assem.S +++ b/src/runtime/x86-assem.S @@ -324,11 +324,13 @@ GNAME(do_pending_interrupt): ret .size GNAME(do_pending_interrupt),.-GNAME(do_pending_interrupt) -#ifdef GENCGC +#ifdef LISP_FEATURE_GENCGC /* This is a fast bzero using the FPU. The first argument is the start * address which needs to be aligned on an 8 byte boundary, the second * argument is the number of bytes, which must be a nonzero multiple * of 8 bytes. */ +/* FIXME whether this is still faster than using the OS's bzero or + * equivalent, we don't know */ .text .globl GNAME(i586_bzero) .type GNAME(i586_bzero),@function @@ -655,7 +657,7 @@ GNAME(alloc_16_to_edi): -#ifdef GENCGC +#ifdef LISP_FEATURE_GENCGC /* These routines are called from Lisp when an inline allocation * overflows. Every register except the result needs to be preserved. diff --git a/src/runtime/x86-linux-os.c b/src/runtime/x86-linux-os.c index e5c3895..30a44da 100644 --- a/src/runtime/x86-linux-os.c +++ b/src/runtime/x86-linux-os.c @@ -38,9 +38,6 @@ #include "validate.h" size_t os_vm_page_size; -#if defined GENCGC -#include "gencgc.h" -#endif /* KLUDGE: As of kernel 2.2.14 on Red Hat 6.2, there's code in the * file to define symbolic names for offsets into diff --git a/version.lisp-expr b/version.lisp-expr index 11bee21..d69dac7 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -18,4 +18,4 @@ ;;; for internal versions, especially for internal versions off the ;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.7.6.11" +"0.7.6.12"