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
Arthur Lemmens:
He found and fixed a number of SBCL bugs while partially porting
- SBCL to bootstrap under <some other Common Lisp system -- LispWorks
- for Windows? -- which could probably be found in the sbcl-devel
- archives>.
+ SBCL to bootstrap under Lispworks for Windows
Robert MacLachlan:
He has continued to answer questions about, and contribute fixes to,
(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,
(: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))))
\f
LINKFLAGS+=-rdynamic # -static
OS_LIBS= -ldl
-GC_SRC= gc.c
+GC_SRC= cheneygc.c
OS_SRC = osf1-os.c alpha-osf1-os.c os-common.c
OS_LIBS= #-ldl
-GC_SRC= gc.c
+GC_SRC= cheneygc.c
LINKFLAGS+=-rdynamic
OS_LIBS= -ldl
-GC_SRC= gc.c
+GC_SRC= cheneygc.c
LINKFLAGS+=-rdynamic
OS_LIBS= -ldl
-GC_SRC= gc.c
+GC_SRC= cheneygc.c
LINKFLAGS+=
OS_LIBS= -ldl -lsocket -lnsl
-GC_SRC= gc.c
+GC_SRC= cheneygc.c
OS_LIBS = -lm # -ldl
GC_SRC = gencgc.c
-CFLAGS += -DGENCGC
OS_LIBS = -ldl
GC_SRC = gencgc.c
-CFLAGS += -DGENCGC
+
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
#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 *
result->header = type;
result->length = make_fixnum(length);
- return ((lispobj)result)|OTHER_POINTER_LOWTAG;
+ return make_lispobj(result,OTHER_POINTER_LOWTAG);
}
lispobj
ptr->car = car;
ptr->cdr = cdr;
- return (lispobj)ptr | LIST_POINTER_LOWTAG;
+ return make_lispobj(ptr, LIST_POINTER_LOWTAG);
}
lispobj
ptr->digits[0] = n;
- return (lispobj) ptr | OTHER_POINTER_LOWTAG;
+ return make_lispobj(ptr, OTHER_POINTER_LOWTAG);
}
}
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);
}
#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)
#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)
#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
* 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
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 */
--- /dev/null
+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
+
--- /dev/null
+/*
+ * 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 <stdio.h>
+#include <sys/time.h>
+#include <sys/resource.h>
+#include <signal.h>
+#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);
+
+\f
+/* 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 */
+}
+
+\f
+/* 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"); */
+}
+\f
+/* 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<<N_LOWTAG_BITS)-1)) <= lip) {
+ offset = lip - reg;
+ if (offset < lip_offset) {
+ lip_offset = offset;
+ lip_register_pair = index;
+ }
+ }
+ }
+#endif /* reg_LIP */
+
+ /* Compute the PC's offset from the start of the CODE */
+ /* register. */
+ pc_code_offset =
+ *os_context_pc_addr(context) -
+ *os_context_register_addr(context, reg_CODE);
+#ifdef ARCH_HAS_NPC_REGISTER
+ npc_code_offset =
+ *os_context_npc_addr(context) -
+ *os_context_register_addr(context, reg_CODE);
+#endif
+#ifdef ARCH_HAS_LINK_REGISTER
+ lr_code_offset =
+ *os_context_lr_addr(context) -
+ *os_context_register_addr(context, reg_CODE);
+#endif
+
+ /* Scavenge all boxed registers in the context. */
+ for (i = 0; i < (sizeof(boxed_registers) / sizeof(int)); i++) {
+ int index;
+ lispobj foo;
+
+ index = boxed_registers[i];
+ foo = *os_context_register_addr(context,index);
+ scavenge((lispobj *) &foo, 1);
+ *os_context_register_addr(context,index) = foo;
+
+ /* this is unlikely to work as intended on bigendian
+ * 64 bit platforms */
+
+ scavenge((lispobj *)
+ os_context_register_addr(context, index), 1);
+ }
+
+#ifdef reg_LIP
+ /* Fix the LIP */
+ *os_context_register_addr(context, reg_LIP) =
+ *os_context_register_addr(context, lip_register_pair) + lip_offset;
+#endif /* reg_LIP */
+
+ /* Fix the PC if it was in from space */
+ if (from_space_p(*os_context_pc_addr(context)))
+ *os_context_pc_addr(context) =
+ *os_context_register_addr(context, reg_CODE) + pc_code_offset;
+#ifdef ARCH_HAS_LINK_REGISTER
+ /* Fix the LR ditto; important if we're being called from
+ * an assembly routine that expects to return using blr, otherwise
+ * harmless */
+ if (from_space_p(*os_context_lr_addr(context)))
+ *os_context_lr_addr(context) =
+ *os_context_register_addr(context, reg_CODE) + lr_code_offset;
+#endif
+
+#ifdef ARCH_HAS_NPC_REGISTER
+ if (from_space_p(*os_context_npc_addr(context)))
+ *os_context_npc_addr(context) =
+ *os_context_register_addr(context, reg_CODE) + npc_code_offset;
+#endif
+}
+
+void scavenge_interrupt_contexts(void)
+{
+ int i, index;
+ os_context_t *context;
+
+ index = fixnum_value(SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX));
+
+#ifdef DEBUG_SCAVENGE_VERBOSE
+ fprintf(stderr, "%d interrupt contexts to scan\n",index);
+#endif
+ for (i = 0; i < index; i++) {
+ context = lisp_interrupt_contexts[i];
+ scavenge_interrupt_context(context);
+ }
+}
+
+\f
+/* debugging code */
+
+void
+print_garbage(lispobj *from_space, lispobj *from_space_free_pointer)
+{
+ lispobj *start;
+ int total_words_not_copied;
+
+ printf("Scanning from space ...\n");
+
+ total_words_not_copied = 0;
+ start = from_space;
+ while (start < from_space_free_pointer) {
+ lispobj object;
+ int forwardp, type, nwords;
+ lispobj header;
+
+ object = *start;
+ forwardp = is_lisp_pointer(object) && new_space_p(object);
+
+ if (forwardp) {
+ int tag;
+ lispobj *pointer;
+
+ tag = lowtag_of(object);
+
+ switch (tag) {
+ case LIST_POINTER_LOWTAG:
+ nwords = 2;
+ break;
+ case INSTANCE_POINTER_LOWTAG:
+ printf("Don't know about instances yet!\n");
+ nwords = 1;
+ break;
+ case FUN_POINTER_LOWTAG:
+ nwords = 1;
+ break;
+ case OTHER_POINTER_LOWTAG:
+ pointer = (lispobj *) native_pointer(object);
+ header = *pointer;
+ type = widetag_of(header);
+ nwords = (sizetab[type])(pointer);
+ break;
+ default: nwords=1; /* shut yer whinging, gcc */
+ }
+ } else {
+ type = widetag_of(object);
+ nwords = (sizetab[type])(start);
+ total_words_not_copied += nwords;
+ printf("%4d words not copied at 0x%16lx; ",
+ nwords, (unsigned long) start);
+ printf("Header word is 0x%08x\n",
+ (unsigned int) object);
+ }
+ start += nwords;
+ }
+ printf("%d total words not copied.\n", total_words_not_copied);
+}
+
+\f
+/* code and code-related objects */
+
+/* FIXME (1) this could probably be defined using something like
+ * sizeof(lispobj)*floor(sizeof(struct simple_fun)/sizeof(lispobj))
+ * - FUN_POINTER_LOWTAG
+ * as I'm reasonably sure that simple_fun->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
+
+
+\f
+/* 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<<N_WIDETAG_BITS) | SIMPLE_VECTOR_WIDETAG;
+ }
+
+ return 1;
+}
+
+\f
+/* 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;
+}
+
+\f
+/* initialization. if gc_init can be moved to after core load, we could
+ * combine these two functions */
+
+void
+gc_init(void)
+{
+ gc_init_tables();
+ scavtab[SIMPLE_VECTOR_WIDETAG] = scav_vector;
+ scavtab[WEAK_POINTER_WIDETAG] = scav_weak_pointer;
+}
+
+void
+gc_initialize_pointers(void)
+{
+ current_dynamic_space = DYNAMIC_0_SPACE_START;
+}
+
+
+
+\f
+/* 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;
+ }
+}
switch (id) {
case DYNAMIC_CORE_SPACE_ID:
-#ifdef GENCGC
+#ifdef LISP_FEATURE_GENCGC
if (addr != (os_vm_address_t)DYNAMIC_SPACE_START) {
fprintf(stderr, "in core: 0x%lx; in runtime: 0x%lx \n",
(long)addr, (long)DYNAMIC_SPACE_START);
/* FIXME: Should the conditional here be reg_ALLOC instead of
* defined(__i386__)
* ? */
-#if defined(__i386__)
+#if defined(LISP_FEATURE_X86)
SetSymbolValue(ALLOCATION_POINTER, (lispobj)free_pointer);
#else
dynamic_space_free_pointer = free_pointer;
--- /dev/null
+/*
+ * Garbage Collection common functions for scavenging, moving and sizing
+ * objects. These are for use with both GC (stop & copy GC) and GENCGC
+ */
+
+/*
+ * 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.
+ */
+
+/*
+ * GENerational Conservative Garbage Collector for SBCL x86
+ */
+
+/*
+ * 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.
+ */
+
+/*
+ * For a review of garbage collection techniques (e.g. generational
+ * GC) and terminology (e.g. "scavenging") see Paul R. Wilson,
+ * "Uniprocessor Garbage Collection Techniques". As of 20000618, this
+ * had been accepted for _ACM Computing Surveys_ and was available
+ * as a PostScript preprint through
+ * <http://www.cs.utexas.edu/users/oops/papers.html>
+ * as
+ * <ftp://ftp.cs.utexas.edu/pub/garbage/bigsurv.ps>.
+ */
+
+#include <stdio.h>
+#include <signal.h>
+#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;
+}
+
+\f
+/*
+ * 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;
+}
+
+\f
+/*
+ * 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;
+}
+
+\f
+/*
+ * 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;
+}
+\f
+/*
+ * 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\f
+/* 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;
+ }
+ }
+}
+
+
+\f
+/*
+ * 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 */
+}
+
+\f
+/*
+ * 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<<N_LOWTAG_BITS)] = scav_immediate;
+ scavtab[FUN_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = scav_fun_pointer;
+ /* skipping OTHER_IMMEDIATE_0_LOWTAG */
+ scavtab[LIST_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = scav_list_pointer;
+ scavtab[ODD_FIXNUM_LOWTAG|(i<<N_LOWTAG_BITS)] = scav_immediate;
+ scavtab[INSTANCE_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = scav_instance_pointer;
+ /* skipping OTHER_IMMEDIATE_1_LOWTAG */
+ scavtab[OTHER_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = 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_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;
+#ifndef LISP_FEATURE_GENCGC /* FIXME ..._X86 ? */
+ 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;
+#endif
+#ifdef LISP_FEATURE_X86
+ 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[INSTANCE_HEADER_WIDETAG] = scav_boxed;
+#ifdef LISP_FEATURE_SPARC
+ scavtab[FDEFN_WIDETAG] = scav_boxed;
+#else
+ scavtab[FDEFN_WIDETAG] = scav_fdefn;
+#endif
+
+ /* transport other table, initialized same way as scavtab */
+ for (i = 0; i < ((sizeof transother)/(sizeof transother[0])); 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; /* but not GENCGC */
+ 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 < ((sizeof sizetab)/(sizeof sizetab[0])); i++)
+ sizetab[i] = size_lose;
+ for (i = 0; i < (1<<(N_WIDETAG_BITS-N_LOWTAG_BITS)); 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;
+}
--- /dev/null
+/*
+ * garbage collection - shared definitions for modules "inside" the GC system
+ */
+
+/*
+ * 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 _GC_INTERNAL_H_
+#define _GC_INTERNAL_H_
+
+#if 1
+#define gc_assert(ex) do { \
+ if (!(ex)) gc_abort(); \
+} while (0)
+#else
+#define gc_assert(ex)
+#endif
+#define gc_abort() lose("GC invariant lost, file \"%s\", line %d", \
+ __FILE__, __LINE__)
+
+#define CEILING(x,y) (((x) + ((y) - 1)) & (~((y) - 1)))
+#define NWORDS(x,y) (CEILING((x),(y)) / (y))
+
+/* FIXME: Shouldn't this be defined in sbcl.h? */
+#define FUN_RAW_ADDR_OFFSET (6*sizeof(lispobj) - FUN_POINTER_LOWTAG)
+
+/* values for the *_alloc_* parameters */
+#define FREE_PAGE 0
+#define BOXED_PAGE 1
+#define UNBOXED_PAGE 2
+
+#define ALLOC_BOXED 0
+#define ALLOC_UNBOXED 1
+#define ALLOC_QUICK 1
+
+void *gc_general_alloc(int nbytes,int unboxed_p,int quick_p);
+
+extern int (*scavtab[256])(lispobj *where, lispobj object);
+extern lispobj (*transother[256])(lispobj object);
+extern int (*sizetab[256])(lispobj *where);
+
+extern struct weak_pointer *weak_pointers; /* in gc-common.c */
+
+extern void scavenge(lispobj *start, long n_words);
+extern void scan_weak_pointers(void);
+
+lispobj copy_large_unboxed_object(lispobj object, int nwords);
+lispobj copy_unboxed_object(lispobj object, int nwords);
+lispobj copy_large_object(lispobj object, int nwords);
+lispobj copy_object(lispobj object, int nwords);
+
+#ifdef LISP_FEATURE_GENCGC
+#include "gencgc-internal.h"
+#else
+#include "cheneygc-internal.h"
+#endif
+
+#endif /* _GC_INTERNAL_H_ */
+++ /dev/null
-/*
- * 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 <stdio.h>
-#include <sys/time.h>
-#include <sys/resource.h>
-#include <signal.h>
-#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)))
-
-\f
-/* 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
-
-\f
-/* 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);
-}
-
-\f
-/* 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
-}
-
-\f
-/* 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"); */
-}
-\f
-/* 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<<N_LOWTAG_BITS)-1)) <= lip) {
- offset = lip - reg;
- if (offset < lip_offset) {
- lip_offset = offset;
- lip_register_pair = index;
- }
- }
- }
-#endif /* reg_LIP */
-
- /* Compute the PC's offset from the start of the CODE */
- /* register. */
- pc_code_offset =
- *os_context_pc_addr(context) -
- *os_context_register_addr(context, reg_CODE);
-#ifdef ARCH_HAS_NPC_REGISTER
- npc_code_offset =
- *os_context_npc_addr(context) -
- *os_context_register_addr(context, reg_CODE);
-#endif
-#ifdef ARCH_HAS_LINK_REGISTER
- lr_code_offset =
- *os_context_lr_addr(context) -
- *os_context_register_addr(context, reg_CODE);
-#endif
-
- /* Scavenge all boxed registers in the context. */
- for (i = 0; i < (sizeof(boxed_registers) / sizeof(int)); i++) {
- int index;
- lispobj foo;
-
- index = boxed_registers[i];
- foo = *os_context_register_addr(context,index);
- scavenge((lispobj *) &foo, 1);
- *os_context_register_addr(context,index) = foo;
-
- /* this is unlikely to work as intended on bigendian
- * 64 bit platforms */
-
- scavenge((lispobj *)
- os_context_register_addr(context, index), 1);
- }
-
-#ifdef reg_LIP
- /* Fix the LIP */
- *os_context_register_addr(context, reg_LIP) =
- *os_context_register_addr(context, lip_register_pair) + lip_offset;
-#endif /* reg_LIP */
-
- /* Fix the PC if it was in from space */
- if (from_space_p(*os_context_pc_addr(context)))
- *os_context_pc_addr(context) =
- *os_context_register_addr(context, reg_CODE) + pc_code_offset;
-#ifdef ARCH_HAS_LINK_REGISTER
- /* Fix the LR ditto; important if we're being called from
- * an assembly routine that expects to return using blr, otherwise
- * harmless */
- if (from_space_p(*os_context_lr_addr(context)))
- *os_context_lr_addr(context) =
- *os_context_register_addr(context, reg_CODE) + lr_code_offset;
-#endif
-
-#ifdef ARCH_HAS_NPC_REGISTER
- if (from_space_p(*os_context_npc_addr(context)))
- *os_context_npc_addr(context) =
- *os_context_register_addr(context, reg_CODE) + npc_code_offset;
-#endif
-}
-
-void scavenge_interrupt_contexts(void)
-{
- int i, index;
- os_context_t *context;
-
- index = fixnum_value(SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX));
-
-#ifdef DEBUG_SCAVENGE_VERBOSE
- fprintf(stderr, "%d interrupt contexts to scan\n",index);
-#endif
- for (i = 0; i < index; i++) {
- context = lisp_interrupt_contexts[i];
- scavenge_interrupt_context(context);
- }
-}
-
-\f
-/* debugging code */
-
-void
-print_garbage(lispobj *from_space, lispobj *from_space_free_pointer)
-{
- lispobj *start;
- int total_words_not_copied;
-
- printf("Scanning from space ...\n");
-
- total_words_not_copied = 0;
- start = from_space;
- while (start < from_space_free_pointer) {
- lispobj object;
- int forwardp, type, nwords;
- lispobj header;
-
- object = *start;
- forwardp = is_lisp_pointer(object) && new_space_p(object);
-
- if (forwardp) {
- int tag;
- lispobj *pointer;
-
- tag = lowtag_of(object);
-
- switch (tag) {
- case LIST_POINTER_LOWTAG:
- nwords = 2;
- break;
- case INSTANCE_POINTER_LOWTAG:
- printf("Don't know about instances yet!\n");
- nwords = 1;
- break;
- case FUN_POINTER_LOWTAG:
- nwords = 1;
- break;
- case OTHER_POINTER_LOWTAG:
- pointer = (lispobj *) native_pointer(object);
- header = *pointer;
- type = widetag_of(header);
- nwords = (sizetab[type])(pointer);
- }
- } else {
- type = widetag_of(object);
- nwords = (sizetab[type])(start);
- total_words_not_copied += nwords;
- printf("%4d words not copied at 0x%16lx; ",
- nwords, (unsigned long) start);
- printf("Header word is 0x%08x\n",
- (unsigned int) object);
- }
- start += nwords;
- }
- printf("%d total words not copied.\n", total_words_not_copied);
-}
-
-\f
-/* code and code-related objects */
-
-/* FIXME: 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;
- lispobj first;
- int type;
-
- 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;
-
- /* must transport object -- object may point */
- /* to either a function header, a closure */
- /* function header, or to a closure header. */
-
- type = widetag_of(first);
- switch (type) {
- case SIMPLE_FUN_HEADER_WIDETAG:
- case CLOSURE_FUN_HEADER_WIDETAG:
- copy = trans_fun_header(object);
- break;
- default:
- copy = trans_boxed(object);
- break;
- }
-
- first = *first_pointer = copy;
-
- gc_assert(is_lisp_pointer(first));
- gc_assert(!from_space_p(first));
-
- *where = first;
- 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 defined(DEBUG_CODE_GC)
- printf("\nTransporting code object located at 0x%08x.\n",
- (unsigned long) code);
-#endif
-
- /* if object has already been transported, just return pointer */
- first = code->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;
-}
-
-
-\f
-/* 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;
-}
-
-\f
-/* 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;
-}
-
-\f
-/* 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;
-}
-
-\f
-/* 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;
-}
-
-\f
-/* 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<<N_WIDETAG_BITS) | SIMPLE_VECTOR_WIDETAG;
- }
-
- return 1;
-}
-
-
-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_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
-
-\f
-/* 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;
- }
- }
-}
-
-
-\f
-/* 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;
-}
-\f
-/* 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;
- }
-}
#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"
--- /dev/null
+/*
+ * 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 *);
+\f
+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 */
+
+\f
+/* 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];
+\f
+/* 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;
+\f
+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
#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);
+
\f
/*
* GC parameters
* 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. */
/* 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
* is needed. */
static void *heap_base = NULL;
+
/* Calculate the start address for the given page number. */
inline void *
page_address(int page_num)
* 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)
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;
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);
}
/* 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);
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);
}
\f
/*
* 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)))
-\f
-/*
- * 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));
-}
-\f
-/*
- * 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;
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);
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. */
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;
}
/* to copy unboxed objects */
-static inline lispobj
+lispobj
copy_unboxed_object(lispobj object, int nwords)
{
int tag;
*
* 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;
return ((lispobj) new) | tag;
}
}
-\f
-/*
- * 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);
-}
+
+
\f
+
/*
* 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.
}
}
-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;
}
}
-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);
+\f
+/*
+ * 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<<N_WIDETAG_BITS) | SIMPLE_VECTOR_WIDETAG;
+ return 1;
}
- apply_code_fixups(code, new_code);
-
- return new_code;
-}
+ kv_length = fixnum_value(where[1]);
+ kv_vector = where + 2; /* Skip the header and length. */
+ /*FSHOW((stderr,"/kv_length = %d\n", kv_length));*/
-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);
+ /* 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;
-}
-\f
-/*
- * 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;
-}
-\f
-/*
- * 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;
-}
-
-\f
-/*
- * 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;
-}
-\f
-/*
- * 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;
-}
-\f
-/*
- * 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<<N_WIDETAG_BITS) | SIMPLE_VECTOR_WIDETAG;
- return 1;
- }
-
- kv_length = fixnum_value(where[1]);
- kv_vector = where + 2; /* Skip the header and length. */
- /*FSHOW((stderr,"/kv_length = %d\n", kv_length));*/
-
- /* 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]);
- }
- 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);
- }
-
- /* 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]);
- }
- 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));
- }
-
- /* 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]);
- }
-
- /* WEAK-P */
- weak_p_obj = hash_table[10];
-
- /* index vector */
- {
- lispobj index_vector_obj = hash_table[13];
+ /* index vector */
+ {
+ lispobj index_vector_obj = hash_table[13];
if (is_lisp_pointer(index_vector_obj) &&
(widetag_of(*(lispobj *)native_pointer(index_vector_obj)) ==
length = fixnum_value(((unsigned int *)native_pointer(index_vector_obj))[1]);
/*FSHOW((stderr, "/length = %d\n", length));*/
} else {
- lose("invalid index_vector %x", index_vector_obj);
- }
- }
-
- /* next vector */
- {
- lispobj next_vector_obj = hash_table[14];
-
- 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);
- }
- }
-
- /* 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];
-
- 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);
-
- /* now all set up.. */
-
- /* 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;
-
- /* Scavenge the key and value. */
- scavenge(&kv_vector[2*i],2);
-
- /* 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;
-
- if ((old_index != new_index) &&
- ((!hash_vector) || (hash_vector[i] == 0x80000000)) &&
- ((new_key != empty_symbol) ||
- (kv_vector[2*i] != empty_symbol))) {
-
- /*FSHOW((stderr,
- "* EQ key %d moved from %x to %x; index %d to %d\n",
- i, old_key, new_key, old_index, new_index));*/
-
- if (index_vector[old_index] != 0) {
- /*FSHOW((stderr, "/P1 %d\n", index_vector[old_index]));*/
-
- /* 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];
-
- /*FSHOW((stderr, "/P3a %d %d\n", prior, next));*/
-
- 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));
-}
-
-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 * 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
+
\f
/*
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;
- }
- }
- }
-}
-\f
-/*
- * 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;
-}
\f
/* Scan an area looking for an object which encloses the given pointer.
* Return the object start on success or NULL on failure. */
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)
{
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;
* 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;
current_region_free_pointer = boxed_region.free_pointer;
current_region_end_addr = boxed_region.end_addr;
}
+
+void
+gc_initialize_pointers(void)
+{
+ gencgc_pickup_dynamic();
+}
+
+
\f
/* a counter for how deep we are in alloc(..) calls */
int alloc_entered = 0;
/* 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--;
/* 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;
* 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)
{
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
#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
+
\f
/* the number of pages needed for the dynamic space - rounding up */
#define NUM_PAGES ((DYNAMIC_SPACE_SIZE+4095)/4096)
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
/* 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
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
}
* 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)
{
{
/* 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;
* 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
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 -
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
#include "validate.h"
size_t os_vm_page_size;
-#if defined GENCGC
-#include "gencgc.h"
-#endif
+#include "gc.h"
\f
#ifdef sparc
*/
-#if defined GENCGC
+#if defined LISP_FEATURE_GENCGC
/*
* The GENCGC needs to be hooked into whatever signal is raised for
#include "validate.h"
size_t os_vm_page_size;
-#if defined GENCGC
-#include "gencgc.h"
-#endif
\f
void os_init(void)
(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;
}
(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;
}
#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)
{
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");
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)");
#include "interrupt.h"
#include "purify.h"
#include "interr.h"
-#ifdef GENCGC
-#include "gencgc.h"
-#endif
+#include "gc.h"
+#include "gc-internal.h"
#define PRINTNOISE
#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
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));
\f
#ifdef __i386__
-#ifdef GENCGC
+#ifdef LISP_FEATURE_GENCGC
/*
* enhanced x86/GENCGC stack scavenging by Douglas Crosher
*
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. */
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. */
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. */
{
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;
bcopy(vector, new, nwords * sizeof(lispobj));
- result = (lispobj)new | lowtag_of(thing);
+ result = make_lispobj(new, lowtag_of(thing));
vector->header = result;
if (boxed)
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
/* 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
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;
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. */
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. */
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++;
/* 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
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
current_control_stack_pointer - (lispobj *)CONTROL_STACK_START,
0);
#else
-#ifdef GENCGC
+#ifdef LISP_FEATURE_GENCGC
pscav_i386_stack();
#endif
#endif
#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" */
#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"
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);
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;
/* 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. */
/* 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
#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)
(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);
#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)
#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)
\f
-#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)
}
}
-#endif
-
void
os_install_interrupt_handlers()
{
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);
#ifdef HOLES
make_holes();
#endif
-#ifndef GENCGC
- current_dynamic_space = DYNAMIC_0_SPACE_START;
-#endif
#ifdef PRINTNOISE
printf(" done.\n");
#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
ret
.size GNAME(do_pending_interrupt),.-GNAME(do_pending_interrupt)
\f
-#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
\f
-#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.
#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
* <sys/ucontext.h> file to define symbolic names for offsets into
;;; 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"
projects / sbcl.git / commitdiff