Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
  • 8 commits
  • 41 files changed
  • 0 commit comments
  • 1 contributor
Commits on Jul 31, 2002
Daniel Barlow telent 0.7.6.gc-cleanup-branch.1:
	Note that this is all on a branch.  It is not expected to be stable
	or even necessarily to build on all ports

	First iteration towards Once And Only Once in garbage collection,

	(1) collects together most of the scavenging/translating/sizing
	routines into the new gc-common.c file

	(2) delete lots of the duplicated code in gencgc gc_*_alloc()
	routines

	The old Cheney stop & copy gc (henceforth known as CHENEYGC)
	probably does not build in this checkin.  GENCGC builds and
	works at least superficially (passes tests etc)
4398111
Daniel Barlow telent new 436a172
Daniel Barlow telent 0.7.6.gc-cleanup-branch.2
	compilation fixes for cheneygc:

	... some objects lost their `inline' and/or `static'
	 qualifiers, so we can see tham from both gc-common.o and gc.o

	... some variable names fixed up

	... gc_general_alloc becomes the supported
         allocation-during-gc interface, so the flags for
         boxed/unboxed, fast/slow are now needed in gc-internal.h to
         be shared by both collectors.  (All we do in cheneygc is
         ignore them, but that's not the point)

	... copy_foo_object defns created as wrappers for copy_object.
         these will go away again later in favour of ignorable flags
         to copy_object
7431345
Daniel Barlow telent 0.7.6.gc-cleanup-branch.3:
	rename gc.c to cheneygc.c
	twiddle Config.* to cope
	no changes were made to actual file contents: this is just a rename
1f73254
Daniel Barlow telent 0.7.6.gc-cleanup-branch.4
	Mostly-mechanical preprocessor symbol cleanup
	GENCGC->LISP_FEATURE_GENCGC
cdb44eb
Commits on Aug 02, 2002
Daniel Barlow telent 0.7.6.gc-cleanup-branch.5:
	Oodles of gcc warning cleanups for machines with different-sized
	lispobj and void * (e.g. alpha)
	cheneygc runs again
e959592
Daniel Barlow telent 0.7.6.gc-cleanup-branch.6
	Found some missing #ifdef GENCGC -> LISP_FEATURE_GENCGC replacements:
	purify now works again in gencgc
1a823f1
Commits on Aug 03, 2002
Daniel Barlow telent 0.7.6.gc-cleanup-branch.7
	Remove mailing list address from "please report this as a bug"
	message in gc-common.c.  Minor edit to manual page
78042f2
Showing with 1,715 additions and 3,107 deletions.
  1. +1 −1  doc/sbcl.1
  2. +1 −1  src/runtime/Config.alpha-linux
  3. +1 −1  src/runtime/Config.alpha-osf1
  4. +1 −1  src/runtime/Config.ppc-linux
  5. +1 −1  src/runtime/Config.sparc-linux
  6. +1 −1  src/runtime/Config.sparc-sunos
  7. +0 −1  src/runtime/Config.x86-bsd
  8. +1 −1  src/runtime/Config.x86-linux
  9. +1 −1  src/runtime/GNUmakefile
  10. +5 −5 src/runtime/alloc.c
  11. +0 −4 src/runtime/alpha-linux-os.c
  12. +0 −4 src/runtime/alpha-osf1-os.c
  13. +10 −13 src/runtime/bsd-os.c
  14. +50 −0 src/runtime/cheneygc-internal.h
  15. +653 −0 src/runtime/cheneygc.c
  16. +2 −2 src/runtime/coreparse.c
  17. +417 −956 src/runtime/{gc.c → gc-common.c}
  18. +66 −0 src/runtime/gc-internal.h
  19. +1 −6 src/runtime/gc.h
  20. +132 −0 src/runtime/gencgc-internal.h
  21. +296 −2,011 src/runtime/gencgc.c
  22. +7 −1 src/runtime/gencgc.h
  23. +3 −3 src/runtime/globals.c
  24. +11 −7 src/runtime/interrupt.c
  25. +2 −4 src/runtime/linux-os.c
  26. +0 −3  src/runtime/osf1-os.c
  27. +2 −2 src/runtime/parse.c
  28. +0 −5 src/runtime/ppc-linux-os.c
  29. +2 −2 src/runtime/print.c
  30. +29 −31 src/runtime/purify.c
  31. +1 −7 src/runtime/runtime.c
  32. +9 −4 src/runtime/runtime.h
  33. +2 −5 src/runtime/save.c
  34. +0 −3  src/runtime/sparc-linux-os.c
  35. +0 −3  src/runtime/sparc-sunos-os.c
  36. +0 −7 src/runtime/sunos-os.c
  37. +1 −4 src/runtime/validate.c
  38. +1 −0  src/runtime/validate.h
  39. +4 −2 src/runtime/x86-assem.S
  40. +0 −3  src/runtime/x86-linux-os.c
  41. +1 −1  version.lisp-expr
2  doc/sbcl.1
View
@@ -169,7 +169,7 @@ SAVE-LISP does.
(Why doesn't SBCL support more extensions? Why drop all those nice
extensions from CMU CL when the code already exists? This is a
-frequently asked question on the mailing list. In other cases, it's a
+frequently asked question on the mailing list. In some cases, it's a
design philosophy issue: arguably SBCL has done its job by supplying a
stable FFI, and the right design decision is to move functionality
derived from that, like socket support, into separate libraries,
2  src/runtime/Config.alpha-linux
View
@@ -21,4 +21,4 @@ OS_SRC = linux-os.c alpha-linux-os.c os-common.c
LINKFLAGS+=-rdynamic # -static
OS_LIBS= -ldl
-GC_SRC= gc.c
+GC_SRC= cheneygc.c
2  src/runtime/Config.alpha-osf1
View
@@ -27,4 +27,4 @@ ARCH_SRC = alpha-arch.c undefineds.c
OS_SRC = osf1-os.c alpha-osf1-os.c os-common.c
OS_LIBS= #-ldl
-GC_SRC= gc.c
+GC_SRC= cheneygc.c
2  src/runtime/Config.ppc-linux
View
@@ -19,4 +19,4 @@ OS_SRC = linux-os.c ppc-linux-os.c os-common.c
LINKFLAGS+=-rdynamic
OS_LIBS= -ldl
-GC_SRC= gc.c
+GC_SRC= cheneygc.c
2  src/runtime/Config.sparc-linux
View
@@ -22,4 +22,4 @@ OS_SRC = linux-os.c sparc-linux-os.c os-common.c
LINKFLAGS+=-rdynamic
OS_LIBS= -ldl
-GC_SRC= gc.c
+GC_SRC= cheneygc.c
2  src/runtime/Config.sparc-sunos
View
@@ -24,4 +24,4 @@ OS_SRC = sunos-os.c sparc-sunos-os.c os-common.c
LINKFLAGS+=
OS_LIBS= -ldl -lsocket -lnsl
-GC_SRC= gc.c
+GC_SRC= cheneygc.c
1  src/runtime/Config.x86-bsd
View
@@ -16,4 +16,3 @@ OS_SRC = bsd-os.c os-common.c undefineds.c
OS_LIBS = -lm # -ldl
GC_SRC = gencgc.c
-CFLAGS += -DGENCGC
2  src/runtime/Config.x86-linux
View
@@ -27,4 +27,4 @@ OS_LINK_FLAGS = -Wl,--export-dynamic
OS_LIBS = -ldl
GC_SRC = gencgc.c
-CFLAGS += -DGENCGC
+
2  src/runtime/GNUmakefile
View
@@ -36,7 +36,7 @@ include Config
C_SRCS =alloc.c backtrace.c breakpoint.c coreparse.c \
- dynbind.c globals.c interr.c interrupt.c \
+ dynbind.c gc-common.c globals.c interr.c interrupt.c \
monitor.c parse.c print.c purify.c \
regnames.c run-program.c runtime.c save.c search.c \
time.c util.c validate.c vars.c wrap.c
10 src/runtime/alloc.c
View
@@ -30,7 +30,7 @@
#define ALIGNED_SIZE(n) (n+LOWTAG_MASK) & ~LOWTAG_MASK
-#if defined GENCGC
+#if defined LISP_FEATURE_GENCGC
extern lispobj *alloc(int bytes);
#else
static lispobj *
@@ -74,7 +74,7 @@ alloc_vector(int type, int length, int size)
result->header = type;
result->length = make_fixnum(length);
- return ((lispobj)result)|OTHER_POINTER_LOWTAG;
+ return make_lispobj(result,OTHER_POINTER_LOWTAG);
}
lispobj
@@ -85,7 +85,7 @@ alloc_cons(lispobj car, lispobj cdr)
ptr->car = car;
ptr->cdr = cdr;
- return (lispobj)ptr | LIST_POINTER_LOWTAG;
+ return make_lispobj(ptr, LIST_POINTER_LOWTAG);
}
lispobj
@@ -100,7 +100,7 @@ alloc_number(long n)
ptr->digits[0] = n;
- return (lispobj) ptr | OTHER_POINTER_LOWTAG;
+ return make_lispobj(ptr, OTHER_POINTER_LOWTAG);
}
}
@@ -124,5 +124,5 @@ alloc_sap(void *ptr)
sap=(struct sap *)
alloc_unboxed((int)SAP_WIDETAG, sizeof(struct sap)/sizeof(lispobj) -1);
sap->pointer = ptr;
- return (lispobj) sap | OTHER_POINTER_LOWTAG;
+ return make_lispobj(sap,OTHER_POINTER_LOWTAG);
}
4 src/runtime/alpha-linux-os.c
View
@@ -39,10 +39,6 @@
#include "validate.h"
size_t os_vm_page_size;
-#if defined GENCGC /* unlikely ... */
-#error SBCL Alpha does not work with the GENCGC
-#include "gencgc.h"
-#endif
os_context_register_t *
os_context_register_addr(os_context_t *context, int offset)
4 src/runtime/alpha-osf1-os.c
View
@@ -41,10 +41,6 @@
#include "validate.h"
size_t os_vm_page_size;
-#if defined GENCGC /* unlikely ... */
-#error SBCL Alpha does not work with the GENCGC
-#include "gencgc.h"
-#endif
os_context_register_t *
os_context_register_addr(os_context_t *context, int offset)
23 src/runtime/bsd-os.c
View
@@ -37,9 +37,6 @@
#include "validate.h"
vm_size_t os_vm_page_size;
-#if defined GENCGC
-#include "gencgc.h"
-#endif
/* The different BSD variants have diverged in exactly where they
* store signal context information, but at least they tend to use the
@@ -204,15 +201,7 @@ is_valid_lisp_addr(os_vm_address_t addr)
* any OS-dependent special low-level handling for signals
*/
-#if !defined GENCGC
-
-void
-os_install_interrupt_handlers(void)
-{
- SHOW("os_install_interrupt_handlers()/bsd-os/!defined(GENCGC)");
-}
-
-#else
+#if defined LISP_FEATURE_GENCGC
/*
* The GENCGC needs to be hooked into whatever signal is raised for
@@ -246,4 +235,12 @@ os_install_interrupt_handlers(void)
SHOW("leaving os_install_interrupt_handlers()");
}
-#endif /* !defined GENCGC */
+#else
+/* As of 2002.07.31, this configuration has never been tested */
+void
+os_install_interrupt_handlers(void)
+{
+ SHOW("os_install_interrupt_handlers()/bsd-os/!defined(GENCGC)");
+}
+
+#endif /* defined GENCGC */
50 src/runtime/cheneygc-internal.h
View
@@ -0,0 +1,50 @@
+extern lispobj *from_space;
+extern lispobj *from_space_free_pointer;
+
+extern lispobj *new_space;
+extern lispobj *new_space_free_pointer;
+
+
+/* predicates */
+/* #if defined(DEBUG_SPACE_PREDICATES) */
+#if 0
+boolean
+from_space_p(lispobj object)
+{
+ lispobj *ptr;
+
+ /* this can be called for untagged pointers as well as for
+ descriptors, so this assertion's not applicable
+ gc_assert(is_lisp_pointer(object));
+ */
+ ptr = (lispobj *) native_pointer(object);
+
+ return ((from_space <= ptr) &&
+ (ptr < from_space_free_pointer));
+}
+
+boolean
+new_space_p(lispobj object)
+{
+ lispobj *ptr;
+
+ /* gc_assert(is_lisp_pointer(object)); */
+
+ ptr = (lispobj *) native_pointer(object);
+
+ return ((new_space <= ptr) &&
+ (ptr < new_space_free_pointer));
+}
+
+#else
+
+#define from_space_p(ptr) \
+ ((from_space <= ((lispobj *) ((pointer_sized_uint_t) ptr))) && \
+ (((lispobj *) ((pointer_sized_uint_t) ptr))< from_space_free_pointer))
+
+#define new_space_p(ptr) \
+ ((new_space <= ((lispobj *) ((pointer_sized_uint_t) ptr))) && \
+ (((lispobj *) ((pointer_sized_uint_t) ptr)) < new_space_free_pointer))
+
+#endif
+
653 src/runtime/cheneygc.c
View
@@ -0,0 +1,653 @@
+/*
+ * 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);
+
+
+/* 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
+
+
+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;
+#if 0
+ /* at one time we had the bright idea of using mprotect() to
+ * hide the semispace that we're not using at the moment, so
+ * we'd see immediately if anyone had a pointer to it.
+ * Unfortunately, if we gc during a call to an assembler
+ * routine with a "raw" return style, at least on PPC we are
+ * expected to return into oldspace because we can't easily
+ * update the link register - it's not tagged, and we can't do
+ * it as an offset of reg_CODE because the calling routine
+ * might be nowhere near our code vector. We hope that we
+ * don't run very far in oldspace before it catapults us into
+ * newspace by either calling something else or returning
+ */
+
+ /* write-enable */
+ os_protect(new_space,DYNAMIC_SPACE_SIZE,OS_VM_PROT_ALL);
+#endif
+
+ /* Initialize the weak pointer list. */
+ weak_pointers = (struct weak_pointer *) NULL;
+
+
+ /* Scavenge all of the roots. */
+#ifdef PRINTNOISE
+ printf("Scavenging interrupt contexts ...\n");
+#endif
+ scavenge_interrupt_contexts();
+
+#ifdef PRINTNOISE
+ printf("Scavenging interrupt handlers (%d bytes) ...\n",
+ (int)sizeof(interrupt_handlers));
+#endif
+ scavenge((lispobj *) interrupt_handlers,
+ sizeof(interrupt_handlers) / sizeof(lispobj));
+
+ /* _size quantities are in units of sizeof(lispobj) - i.e. 4 */
+ control_stack_size =
+ current_control_stack_pointer-
+ (lispobj *)CONTROL_STACK_START;
+#ifdef PRINTNOISE
+ printf("Scavenging the control stack at %p (%ld words) ...\n",
+ ((lispobj *)CONTROL_STACK_START),
+ control_stack_size);
+#endif
+ scavenge(((lispobj *)CONTROL_STACK_START), control_stack_size);
+
+
+ binding_stack_size =
+ current_binding_stack_pointer -
+ (lispobj *)BINDING_STACK_START;
+#ifdef PRINTNOISE
+ printf("Scavenging the binding stack %x - %x (%d words) ...\n",
+ BINDING_STACK_START,current_binding_stack_pointer,
+ (int)(binding_stack_size));
+#endif
+ scavenge(((lispobj *)BINDING_STACK_START), binding_stack_size);
+
+ static_space_size =
+ current_static_space_free_pointer - (lispobj *) STATIC_SPACE_START;
+#ifdef PRINTNOISE
+ printf("Scavenging static space %x - %x (%d words) ...\n",
+ STATIC_SPACE_START,current_static_space_free_pointer,
+ (int)(static_space_size));
+#endif
+ scavenge(((lispobj *)STATIC_SPACE_START), static_space_size);
+
+ /* Scavenge newspace. */
+#ifdef PRINTNOISE
+ printf("Scavenging new space (%d bytes) ...\n",
+ (int)((new_space_free_pointer - new_space) * sizeof(lispobj)));
+#endif
+ scavenge_newspace();
+
+
+#if defined(DEBUG_PRINT_GARBAGE)
+ print_garbage(from_space, from_space_free_pointer);
+#endif
+
+ /* Scan the weak pointers. */
+#ifdef PRINTNOISE
+ printf("Scanning weak pointers ...\n");
+#endif
+ scan_weak_pointers();
+
+
+ /* Flip spaces. */
+#ifdef PRINTNOISE
+ printf("Flipping spaces ...\n");
+#endif
+
+ os_zero((os_vm_address_t) current_dynamic_space,
+ (os_vm_size_t) DYNAMIC_SPACE_SIZE);
+
+ current_dynamic_space = new_space;
+ dynamic_space_free_pointer = new_space_free_pointer;
+
+#ifdef PRINTNOISE
+ size_discarded = (from_space_free_pointer - from_space) * sizeof(lispobj);
+ size_retained = (new_space_free_pointer - new_space) * sizeof(lispobj);
+#endif
+
+ /* Zero stack. */
+#ifdef PRINTNOISE
+ printf("Zeroing empty part of control stack ...\n");
+#endif
+ zero_stack();
+
+ sigprocmask(SIG_SETMASK, &old, 0);
+
+
+#ifdef PRINTNOISE
+ gettimeofday(&stop_tv, (struct timezone *) 0);
+ getrusage(RUSAGE_SELF, &stop_rusage);
+
+ printf("done.]\n");
+
+ percent_retained = (((float) size_retained) /
+ ((float) size_discarded)) * 100.0;
+
+ printf("Total of %ld bytes out of %ld bytes retained (%3.2f%%).\n",
+ size_retained, size_discarded, percent_retained);
+
+ real_time = tv_diff(&stop_tv, &start_tv);
+ user_time = tv_diff(&stop_rusage.ru_utime, &start_rusage.ru_utime);
+ system_time = tv_diff(&stop_rusage.ru_stime, &start_rusage.ru_stime);
+
+#if 0
+ printf("Statistics:\n");
+ printf("%10.2f sec of real time\n", real_time);
+ printf("%10.2f sec of user time,\n", user_time);
+ printf("%10.2f sec of system time.\n", system_time);
+#else
+ printf("Statistics: %10.2fs real, %10.2fs user, %10.2fs system.\n",
+ real_time, user_time, system_time);
+#endif
+
+ gc_rate = ((float) size_retained / (float) (1<<20)) / real_time;
+
+ printf("%10.2f M bytes/sec collected.\n", gc_rate);
+#endif
+ /* os_flush_icache((os_vm_address_t) 0, sizeof(unsigned long)); */
+
+#if 0
+ /* see comment above about mprotecting oldspace */
+
+ /* zero the from space now, to make it easier to find stale
+ pointers to it */
+
+ /* pray that both dynamic spaces are the same size ... */
+ memset(from_space,(DYNAMIC_0_SPACE_END-DYNAMIC_0_SPACE_START-1),0);
+ os_protect(from_space,DYNAMIC_SPACE_SIZE,0); /* write-protect */
+#endif
+}
+
+
+/* scavenging */
+
+static void
+scavenge_newspace(void)
+{
+ lispobj *here, *next;
+
+ here = new_space;
+ while (here < new_space_free_pointer) {
+ /* printf("here=%lx, new_space_free_pointer=%lx\n",
+ here,new_space_free_pointer); */
+ next = new_space_free_pointer;
+ scavenge(here, next - here);
+ here = next;
+ }
+ /* printf("done with newspace\n"); */
+}
+
+/* scavenging interrupt contexts */
+
+static int boxed_registers[] = BOXED_REGISTERS;
+
+static void
+scavenge_interrupt_context(os_context_t *context)
+{
+ int i;
+#ifdef reg_LIP
+ unsigned long lip;
+ unsigned long lip_offset;
+ int lip_register_pair;
+#endif
+ unsigned long pc_code_offset;
+#ifdef ARCH_HAS_LINK_REGISTER
+ unsigned long lr_code_offset;
+#endif
+#ifdef ARCH_HAS_NPC_REGISTER
+ unsigned long npc_code_offset;
+#endif
+#ifdef DEBUG_SCAVENGE_VERBOSE
+ fprintf(stderr, "Scavenging interrupt context at 0x%x\n",context);
+#endif
+ /* Find the LIP's register pair and calculate its offset */
+ /* before we scavenge the context. */
+#ifdef reg_LIP
+ lip = *os_context_register_addr(context, reg_LIP);
+ /* 0x7FFFFFFF or 0x7FFFFFFFFFFFFFFF ? */
+ lip_offset = 0x7FFFFFFF;
+ lip_register_pair = -1;
+ for (i = 0; i < (sizeof(boxed_registers) / sizeof(int)); i++) {
+ unsigned long reg;
+ long offset;
+ int index;
+
+ index = boxed_registers[i];
+ reg = *os_context_register_addr(context, index);
+ /* would be using PTR if not for integer length issues */
+ if ((reg & ~((1L<<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);
+ }
+}
+
+
+/* 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);
+}
+
+
+/* code and code-related objects */
+
+/* FIXME: Shouldn't this be defined in sbcl.h? */
+
+
+/* static lispobj trans_fun_header(lispobj object); */
+/* static lispobj trans_boxed(lispobj object); */
+#define FUN_RAW_ADDR_OFFSET (6*sizeof(lispobj) - FUN_POINTER_LOWTAG)
+
+/* Note: on the sparc we don't have to do anything special for fdefns, */
+/* 'cause the raw-addr has a function lowtag. */
+#ifndef LISP_FEATURE_SPARC
+static int
+scav_fdefn(lispobj *where, lispobj object)
+{
+ struct fdefn *fdefn;
+
+ fdefn = (struct fdefn *)where;
+
+ if ((char *)(fdefn->fun + FUN_RAW_ADDR_OFFSET)
+ == (char *)((unsigned long)(fdefn->raw_addr))) {
+ scavenge(where + 1, sizeof(struct fdefn)/sizeof(lispobj) - 1);
+ fdefn->raw_addr =
+ (u32) ((char *) LOW_WORD(fdefn->fun)) + FUN_RAW_ADDR_OFFSET;
+ return sizeof(struct fdefn) / sizeof(lispobj);
+ }
+ else
+ return 1;
+}
+#endif
+
+
+
+/* vector-like objects */
+
+/* #define NWORDS(x,y) (CEILING((x),(y)) / (y)) */
+
+static int
+scav_vector(lispobj *where, lispobj object)
+{
+ if (HeaderValue(object) == subtype_VectorValidHashing) {
+ *where =
+ (subtype_VectorMustRehash<<N_WIDETAG_BITS) | SIMPLE_VECTOR_WIDETAG;
+ }
+
+ return 1;
+}
+
+
+/* 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;
+}
+
+
+/* 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;
+}
+
+
+
+
+/* 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;
+ }
+}
4 src/runtime/coreparse.c
View
@@ -68,7 +68,7 @@ process_directory(int fd, u32 *ptr, int count)
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);
@@ -87,7 +87,7 @@ process_directory(int fd, u32 *ptr, int count)
/* 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;
1,373 src/runtime/gc.c → src/runtime/gc-common.c
View
@@ -1,5 +1,6 @@
/*
- * stop and copy GC based on Cheney's algorithm
+ * Garbage Collection common functions for scavenging, moving and sizing
+ * objects. These are for use with both GC (stop & copy GC) and GENCGC
*/
/*
@@ -13,109 +14,95 @@
* 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 <sys/time.h>
-#include <sys/resource.h>
#include <signal.h>
#include "runtime.h"
#include "sbcl.h"
#include "os.h"
-#include "gc.h"
+#include "interr.h"
#include "globals.h"
#include "interrupt.h"
#include "validate.h"
#include "lispregs.h"
-#include "interr.h"
+#include "arch.h"
+#include "gc.h"
+#include "gc-internal.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
+#ifdef LISP_FEATURE_SPARC
+#define LONG_FLOAT_SIZE 4
+#else
+#ifdef LISP_FEATURE_X86
+#define LONG_FLOAT_SIZE 3
+#endif
#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)
+inline static boolean
+forwarding_pointer_p(lispobj *pointer) {
+ lispobj first_word=*pointer;
+#ifdef LISP_FEATURE_GENCGC
+ return (first_word == 0x01);
#else
-#define gc_assert(ex)
+ return (is_lisp_pointer(first_word)
+ && new_space_p(first_word));
#endif
+}
-#define CEILING(x,y) (((x) + ((y) - 1)) & (~((y) - 1)))
-
-
-/* predicates */
-
-#if defined(DEBUG_SPACE_PREDICATES)
-
-boolean
-from_space_p(lispobj object)
-{
- lispobj *ptr;
-
- /* this can be called for untagged pointers as well as for
- descriptors, so this assertion's not applicable
- gc_assert(is_lisp_pointer(object));
- */
- ptr = (lispobj *) native_pointer(object);
-
- return ((from_space <= ptr) &&
- (ptr < from_space_free_pointer));
-}
-
-boolean
-new_space_p(lispobj object)
-{
- lispobj *ptr;
-
- gc_assert(is_lisp_pointer(object));
-
- ptr = (lispobj *) native_pointer(object);
-
- return ((new_space <= ptr) &&
- (ptr < new_space_free_pointer));
-}
-
+static inline lispobj *
+forwarding_pointer_value(lispobj *pointer) {
+#ifdef LISP_FEATURE_GENCGC
+ return (lispobj *) ((pointer_sized_uint_t) pointer[1]);
#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))
-
+ 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;
+}
-
-/* copying objects */
+int (*scavtab[256])(lispobj *where, lispobj object);
+lispobj (*transother[256])(lispobj object);
+int (*sizetab[256])(lispobj *where);
+struct weak_pointer *weak_pointers;
-static lispobj
+/*
+ * copying objects
+ */
+
+/* to copy a boxed object */
+lispobj
copy_object(lispobj object, int nwords)
{
int tag;
@@ -126,21 +113,16 @@ copy_object(lispobj object, int nwords)
gc_assert(from_space_p(object));
gc_assert((nwords & 0x01) == 0);
- /* get tag of object */
+ /* Get tag of object. */
tag = lowtag_of(object);
- /* allocate space */
- new = new_space_free_pointer;
- new_space_free_pointer += nwords;
+ /* Allocate space. */
+ new = gc_general_alloc(nwords*4,ALLOC_BOXED,ALLOC_QUICK);
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 */
+ /* Copy the object. */
while (nwords > 0) {
dest[0] = source[0];
dest[1] = source[1];
@@ -148,300 +130,55 @@ copy_object(lispobj object, int nwords)
source += 2;
nwords -= 2;
}
- /* return lisp pointer of new object */
- return (lispobj)(LOW_WORD(new) | tag);
-}
-
-
-/* collecting garbage */
-#ifdef PRINTNOISE
-static double
-tv_diff(struct timeval *x, struct timeval *y)
-{
- return (((double) x->tv_sec + (double) x->tv_usec * 1.0e-6) -
- ((double) y->tv_sec + (double) y->tv_usec * 1.0e-6));
+ return make_lispobj(new,tag);
}
-#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
+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. */
-/* Note: The generic GC interface we're implementing passes us a
- * last_generation argument. That's meaningless for us, since we're
- * not a generational GC. So we ignore it. */
void
-collect_garbage(unsigned ignore)
-{
-#ifdef PRINTNOISE
- struct timeval start_tv, stop_tv;
- struct rusage start_rusage, stop_rusage;
- double real_time, system_time, user_time;
- double percent_retained, gc_rate;
- unsigned long size_discarded;
- unsigned long size_retained;
-#endif
- lispobj *current_static_space_free_pointer;
- unsigned long static_space_size;
- unsigned long control_stack_size, binding_stack_size;
- sigset_t tmp, old;
-
-#ifdef PRINTNOISE
- printf("[Collecting garbage ... \n");
-
- getrusage(RUSAGE_SELF, &start_rusage);
- gettimeofday(&start_tv, (struct timezone *) 0);
-#endif
-
- sigemptyset(&tmp);
- sigaddset_blockable(&tmp);
- sigprocmask(SIG_BLOCK, &tmp, &old);
-
- current_static_space_free_pointer =
- (lispobj *) ((unsigned long)
- SymbolValue(STATIC_SPACE_FREE_POINTER));
-
-
- /* Set up from space and new space pointers. */
-
- from_space = current_dynamic_space;
- from_space_free_pointer = dynamic_space_free_pointer;
-
-#ifdef PRINTNOISE
- fprintf(stderr,"from_space = %lx\n",
- (unsigned long) current_dynamic_space);
-#endif
- if (current_dynamic_space == (lispobj *) DYNAMIC_0_SPACE_START)
- new_space = (lispobj *)DYNAMIC_1_SPACE_START;
- else if (current_dynamic_space == (lispobj *) DYNAMIC_1_SPACE_START)
- new_space = (lispobj *) DYNAMIC_0_SPACE_START;
- else {
- lose("GC lossage. Current dynamic space is bogus!\n");
- }
- new_space_free_pointer = new_space;
-#if 0
- /* at one time we had the bright idea of using mprotect() to
- * hide the semispace that we're not using at the moment, so
- * we'd see immediately if anyone had a pointer to it.
- * Unfortunately, if we gc during a call to an assembler
- * routine with a "raw" return style, at least on PPC we are
- * expected to return into oldspace because we can't easily
- * update the link register - it's not tagged, and we can't do
- * it as an offset of reg_CODE because the calling routine
- * might be nowhere near our code vector. We hope that we
- * don't run very far in oldspace before it catapults us into
- * newspace by either calling something else or returning
- */
-
- /* write-enable */
- os_protect(new_space,DYNAMIC_SPACE_SIZE,OS_VM_PROT_ALL);
-#endif
-
- /* Initialize the weak pointer list. */
- weak_pointers = (struct weak_pointer *) NULL;
-
-
- /* Scavenge all of the roots. */
-#ifdef PRINTNOISE
- printf("Scavenging interrupt contexts ...\n");
-#endif
- scavenge_interrupt_contexts();
-
-#ifdef PRINTNOISE
- printf("Scavenging interrupt handlers (%d bytes) ...\n",
- (int)sizeof(interrupt_handlers));
-#endif
- scavenge((lispobj *) interrupt_handlers,
- sizeof(interrupt_handlers) / sizeof(lispobj));
-
- /* _size quantities are in units of sizeof(lispobj) - i.e. 4 */
- control_stack_size =
- current_control_stack_pointer-
- (lispobj *)CONTROL_STACK_START;
-#ifdef PRINTNOISE
- printf("Scavenging the control stack at %p (%ld words) ...\n",
- ((lispobj *)CONTROL_STACK_START),
- control_stack_size);
-#endif
- scavenge(((lispobj *)CONTROL_STACK_START), control_stack_size);
-
-
- binding_stack_size =
- current_binding_stack_pointer -
- (lispobj *)BINDING_STACK_START;
-#ifdef PRINTNOISE
- printf("Scavenging the binding stack %x - %x (%d words) ...\n",
- BINDING_STACK_START,current_binding_stack_pointer,
- (int)(binding_stack_size));
-#endif
- scavenge(((lispobj *)BINDING_STACK_START), binding_stack_size);
-
- static_space_size =
- current_static_space_free_pointer - (lispobj *) STATIC_SPACE_START;
-#ifdef PRINTNOISE
- printf("Scavenging static space %x - %x (%d words) ...\n",
- STATIC_SPACE_START,current_static_space_free_pointer,
- (int)(static_space_size));
-#endif
- scavenge(((lispobj *)STATIC_SPACE_START), static_space_size);
-
- /* Scavenge newspace. */
-#ifdef PRINTNOISE
- printf("Scavenging new space (%d bytes) ...\n",
- (int)((new_space_free_pointer - new_space) * sizeof(lispobj)));
-#endif
- scavenge_newspace();
-
-
-#if defined(DEBUG_PRINT_GARBAGE)
- print_garbage(from_space, from_space_free_pointer);
-#endif
-
- /* Scan the weak pointers. */
-#ifdef PRINTNOISE
- printf("Scanning weak pointers ...\n");
-#endif
- scan_weak_pointers();
-
-
- /* Flip spaces. */
-#ifdef PRINTNOISE
- printf("Flipping spaces ...\n");
-#endif
-
- os_zero((os_vm_address_t) current_dynamic_space,
- (os_vm_size_t) DYNAMIC_SPACE_SIZE);
-
- current_dynamic_space = new_space;
- dynamic_space_free_pointer = new_space_free_pointer;
-
-#ifdef PRINTNOISE
- size_discarded = (from_space_free_pointer - from_space) * sizeof(lispobj);
- size_retained = (new_space_free_pointer - new_space) * sizeof(lispobj);
-#endif
-
- /* Zero stack. */
-#ifdef PRINTNOISE
- printf("Zeroing empty part of control stack ...\n");
-#endif
- zero_stack();
-
- sigprocmask(SIG_SETMASK, &old, 0);
-
-
-#ifdef PRINTNOISE
- gettimeofday(&stop_tv, (struct timezone *) 0);
- getrusage(RUSAGE_SELF, &stop_rusage);
-
- printf("done.]\n");
-
- percent_retained = (((float) size_retained) /
- ((float) size_discarded)) * 100.0;
-
- printf("Total of %ld bytes out of %ld bytes retained (%3.2f%%).\n",
- size_retained, size_discarded, percent_retained);
-
- real_time = tv_diff(&stop_tv, &start_tv);
- user_time = tv_diff(&stop_rusage.ru_utime, &start_rusage.ru_utime);
- system_time = tv_diff(&stop_rusage.ru_stime, &start_rusage.ru_stime);
-
-#if 0
- printf("Statistics:\n");
- printf("%10.2f sec of real time\n", real_time);
- printf("%10.2f sec of user time,\n", user_time);
- printf("%10.2f sec of system time.\n", system_time);
-#else
- printf("Statistics: %10.2fs real, %10.2fs user, %10.2fs system.\n",
- real_time, user_time, system_time);
-#endif
-
- gc_rate = ((float) size_retained / (float) (1<<20)) / real_time;
-
- printf("%10.2f M bytes/sec collected.\n", gc_rate);
-#endif
- /* os_flush_icache((os_vm_address_t) 0, sizeof(unsigned long)); */
-
-#if 0
- /* see comment above about mprotecting oldspace */
-
- /* zero the from space now, to make it easier to find stale
- pointers to it */
-
- /* pray that both dynamic spaces are the same size ... */
- memset(from_space,(DYNAMIC_0_SPACE_END-DYNAMIC_0_SPACE_START-1),0);
- os_protect(from_space,DYNAMIC_SPACE_SIZE,0); /* write-protect */
-#endif
-}
-
-
-/* scavenging */
-
-static void
-scavenge(lispobj *start, u32 nwords)
+scavenge(lispobj *start, long n_words)
{
- while (nwords > 0) {
- lispobj object;
- int type, words_scavenged;
-
- object = *start;
- type = widetag_of(object);
+ lispobj *end = start + n_words;
+ lispobj *object_ptr;
+ int n_words_scavenged;
+
+ for (object_ptr = start;
+ object_ptr < end;
+ object_ptr += n_words_scavenged) {
-#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);
+ lispobj object = *object_ptr;
+#ifdef LISP_FEATURE_GENCGC
+ gc_assert(!forwarding_pointer_p(object_ptr));
#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 {
+ /* 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. */
- words_scavenged = (scavtab[type])(start, object);
+ n_words_scavenged =
+ (scavtab[widetag_of(object)])(object_ptr, object);
}
- }
- else {
- /* It points somewhere other than oldspace. Leave */
- /* it alone. */
- words_scavenged = 1;
+ } else {
+ /* It points somewhere other than oldspace. Leave it
+ * alone. */
+ n_words_scavenged = 1;
}
}
- else if (nwords==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
@@ -450,256 +187,46 @@ scavenge(lispobj *start, u32 nwords)
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;
+ 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 test case to sbcl-devel@lists.sourceforge.net\n",
+ 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);
}
}
- else if ((object & 3) == 0) {
- /* It's a fixnum. Real easy. */
- words_scavenged = 1;
- }
- else {
- /* It's some random header object. */
- words_scavenged = (scavtab[type])(start, object);
-
- }
-
- start += words_scavenged;
- nwords -= words_scavenged;
- }
- gc_assert(nwords == 0);
-}
-
-static void
-scavenge_newspace(void)
-{
- lispobj *here, *next;
-
- here = new_space;
- while (here < new_space_free_pointer) {
- /* printf("here=%lx, new_space_free_pointer=%lx\n",
- here,new_space_free_pointer); */
- next = new_space_free_pointer;
- scavenge(here, next - here);
- here = next;
- }
- /* printf("done with newspace\n"); */
-}
-
-/* scavenging interrupt contexts */
-
-static int boxed_registers[] = BOXED_REGISTERS;
-
-static void
-scavenge_interrupt_context(os_context_t *context)
-{
- int i;
-#ifdef reg_LIP
- unsigned long lip;
- unsigned long lip_offset;
- int lip_register_pair;
-#endif
- unsigned long pc_code_offset;
-#ifdef ARCH_HAS_LINK_REGISTER
- unsigned long lr_code_offset;
-#endif
-#ifdef ARCH_HAS_NPC_REGISTER
- unsigned long npc_code_offset;
-#endif
-#ifdef DEBUG_SCAVENGE_VERBOSE
- fprintf(stderr, "Scavenging interrupt context at 0x%x\n",context);
-#endif
- /* Find the LIP's register pair and calculate its offset */
- /* before we scavenge the context. */
-#ifdef reg_LIP
- lip = *os_context_register_addr(context, reg_LIP);
- /* 0x7FFFFFFF or 0x7FFFFFFFFFFFFFFF ? */
- lip_offset = 0x7FFFFFFF;
- lip_register_pair = -1;
- for (i = 0; i < (sizeof(boxed_registers) / sizeof(int)); i++) {
- unsigned long reg;
- long offset;
- int index;
-
- index = boxed_registers[i];
- reg = *os_context_register_addr(context, index);
- /* would be using PTR if not for integer length issues */
- if ((reg & ~((1L<<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);
- }
-}
-
-
-/* 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 if ((object & 3) == 0) {
+ /* It's a fixnum: really easy.. */
+ n_words_scavenged = 1;
} 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);
+ /* It's some sort of header object or another. */
+ n_words_scavenged =
+ (scavtab[widetag_of(object)])(object_ptr, object);
}
- start += nwords;
}
- printf("%d total words not copied.\n", total_words_not_copied);
+ gc_assert(object_ptr == end);
}
-
-/* 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_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 *first_pointer;
lispobj copy;
- lispobj first;
- int type;
gc_assert(is_lisp_pointer(object));
-
- /* object is a pointer into from space. Not a FP */
+
+ /* 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) {
+
+ /* 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);
@@ -708,16 +235,21 @@ scav_fun_pointer(lispobj *where, lispobj object)
copy = trans_boxed(object);
break;
}
-
- first = *first_pointer = copy;
- gc_assert(is_lisp_pointer(first));
- gc_assert(!from_space_p(first));
+ 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;
- *where = first;
return 1;
}
+
static struct code *
trans_code(struct code *code)
{
@@ -727,18 +259,14 @@ trans_code(struct code *code)
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)) {
+ if (forwarding_pointer_p((lispobj *)code)) {
#ifdef DEBUG_CODE_GC
printf("Was already transported\n");
#endif
- return (struct code *) native_pointer(first);
+ return (struct code *) forwarding_pointer_value
+ ((lispobj *)((pointer_sized_uint_t) code));
}
gc_assert(widetag_of(first) == CODE_HEADER_WIDETAG);
@@ -754,16 +282,20 @@ trans_code(struct code *code)
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;
+#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 */
@@ -783,25 +315,28 @@ trans_code(struct code *code)
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;
+ set_forwarding_pointer((lispobj *)fheaderp, nfheaderl);
- /* fix self pointer */
- nfheaderp->self = 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;
}
-
-#ifndef MACH
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;
}
@@ -810,46 +345,36 @@ static int
scav_code_header(lispobj *where, lispobj object)
{
struct code *code;
- int nheader_words, ncode_words, nwords;
- lispobj fheaderl;
- struct simple_fun *fheaderp;
+ 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;
- ncode_words = fixnum_value(code->code_size);
- nheader_words = HeaderValue(object);
- nwords = ncode_words + nheader_words;
- nwords = CEILING(nwords, 2);
+ 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);
-#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, n_header_words - 1);
- /* 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. */
+ for (entry_point = code->entry_points;
+ entry_point != NIL;
+ entry_point = function_ptr->next) {
- /* 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;
+ 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 nwords;
+ return n_words;
}
static lispobj
@@ -861,6 +386,7 @@ trans_code_header(lispobj object)
return (lispobj) LOW_WORD(ncode) | OTHER_POINTER_LOWTAG;
}
+
static int
size_code_header(lispobj *where)
{
@@ -877,15 +403,13 @@ size_code_header(lispobj *where)
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;
+ 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
@@ -894,35 +418,26 @@ 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;
+
+ 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
+/* 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;
+
+#ifdef LISP_FEATURE_X86
+static int
+scav_closure_header(lispobj *where, lispobj object)
{
struct closure *closure;
lispobj fun;
@@ -930,7 +445,12 @@ lispobj *where, object;
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
@@ -938,12 +458,10 @@ lispobj *where, object;
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;
+ 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
@@ -963,24 +481,34 @@ trans_fun_header(lispobj object)
return ((lispobj) LOW_WORD(ncode) + offset) | FUN_POINTER_LOWTAG;
}
-
-/* instances */
+/*
+ * instances
+ */
static int
scav_instance_pointer(lispobj *where, lispobj object)
{
- lispobj *first_pointer;
-
- /* object is a pointer into from space. Not a FP */
+ 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);
-
- *where = *first_pointer = trans_boxed(object);
+ set_forwarding_pointer(first_pointer,copy);
+ *where = copy;
+
return 1;
}
-/* lists and conses */
+/*
+ * lists and conses
+ */
static lispobj trans_list(lispobj object);
@@ -991,63 +519,72 @@ scav_list_pointer(lispobj *where, lispobj object)
gc_assert(is_lisp_pointer(object));
- /* object is a pointer into from space. Not a FP. */
+ /* Object is a pointer into from space - not FP. */
first_pointer = (lispobj *) native_pointer(object);
-
- first = *first_pointer = trans_list(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);
- /* ### Don't use copy_object here. */
- new_list_pointer = copy_object(object, 2);
- new_cons = (struct cons *) native_pointer(new_list_pointer);
+ /* 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));
- /* Set forwarding pointer. */
- cons->car = new_list_pointer;
-
- /* Try to linearize the list in the cdr direction to help reduce */
- /* paging. */
+ /* 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 cdr, new_cdr, first;
+ lispobj new_cdr;
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)))
+
+ 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);
- /* ### Don't use copy_object here */
- new_cdr = copy_object(cdr, 2);
- new_cdr_cons = (struct cons *) native_pointer(new_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));
- /* Set forwarding pointer */
- cdr_cons->car = new_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. */
+ /* 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;
}
@@ -1055,7 +592,9 @@ trans_list(lispobj object)
}
-/* scavenging and transporting other pointers */
+/*
+ * scavenging and transporting other pointers
+ */
static int
scav_other_pointer(lispobj *where, lispobj object)
@@ -1064,19 +603,28 @@ scav_other_pointer(lispobj *where, lispobj object)
gc_assert(is_lisp_pointer(object));
- /* Object is a pointer into from space - not a FP */
+ /* Object is a pointer into from space - not FP. */
first_pointer = (lispobj *) native_pointer(object);
- first = *first_pointer = (transother[widetag_of(*first_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));
- *where = first;
return 1;
}
-
-/* immediate, boxed, and unboxed objects */
+/*
+ * immediate, boxed, and unboxed objects
+ */
static int
size_pointer(lispobj *where)
@@ -1093,9 +641,8 @@ scav_immediate(lispobj *where, lispobj object)
static lispobj
trans_immediate(lispobj object)
{
- fprintf(stderr, "GC lossage. Trying to transport an immediate!?\n");
- lose(NULL);
- return NIL;
+ lose("trying to transport an immediate");
+ return NIL; /* bogus return value to satisfy static type checking */
}
static int
@@ -1126,6 +673,7 @@ trans_boxed(lispobj object)
return copy_object(object, length);
}
+
static int
size_boxed(lispobj *where)
{
@@ -1141,23 +689,33 @@ size_boxed(lispobj *where)
/* Note: on the sparc we don't have to do anything special for fdefns, */
/* 'cause the raw-addr has a function lowtag. */
-#ifndef sparc
+#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);
+ 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);
+ */
+ return sizeof(struct fdefn) / sizeof(lispobj);
+ } else {
+ return 1;
}
- else
- return 1;
}
#endif
@@ -1185,7 +743,7 @@ trans_unboxed(lispobj object)
length = HeaderValue(header) + 1;
length = CEILING(length, 2);
- return copy_object(object, length);
+ return copy_unboxed_object(object, length);
}
static int
@@ -1201,12 +759,11 @@ size_unboxed(lispobj *where)
return length;
}
-
+static int
/* vector-like objects */
#define NWORDS(x,y) (CEILING((x),(y)) / (y))
-static int
scav_string(lispobj *where, lispobj object)
{
struct vector *vector;
@@ -1221,7 +778,6 @@ scav_string(lispobj *where, lispobj object)
return nwords;
}
-
static lispobj
trans_string(lispobj object)
{
@@ -1230,14 +786,15 @@ trans_string(lispobj object)
gc_assert(is_lisp_pointer(object));
- /* NOTE: Strings contain one more byte of data than the length */
- /* slot indicates. */
+ /* 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_object(object, nwords);
+ return copy_large_unboxed_object(object, nwords);
}
static int
@@ -1246,8 +803,9 @@ size_string(lispobj *where)
struct vector *vector;
int length, nwords;
- /* NOTE: Strings contain one more byte of data than the length */
- /* slot indicates. */
+ /* 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;
@@ -1256,18 +814,6 @@ size_string(lispobj *where)
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)
{
@@ -1281,7 +827,7 @@ trans_vector(lispobj object)
length = fixnum_value(vector->length);
nwords = CEILING(length + 2, 2);
- return copy_object(object, nwords);
+ return copy_large_object(object, nwords);
}
static int
@@ -1297,7 +843,6 @@ size_vector(lispobj *where)
return nwords;
}
-
static int
scav_vector_bit(lispobj *where, lispobj object)
{
@@ -1323,7 +868,7 @@ trans_vector_bit(lispobj object)
length = fixnum_value(vector->length);
nwords = CEILING(NWORDS(length, 32) + 2, 2);
- return copy_object(object, nwords);
+ return copy_large_unboxed_object(object, nwords);
}
static int
@@ -1339,7 +884,6 @@ size_vector_bit(lispobj *where)
return nwords;
}
-
static int
scav_vector_unsigned_byte_2(lispobj *where, lispobj object)
{
@@ -1365,7 +909,7 @@ trans_vector_unsigned_byte_2(lispobj object)
length = fixnum_value(vector->length);
nwords = CEILING(NWORDS(length, 16) + 2, 2);
- return copy_object(object, nwords);
+ return copy_large_unboxed_object(object, nwords);
}
static int
@@ -1381,7 +925,6 @@ size_vector_unsigned_byte_2(lispobj *where)
return nwords;
}
-
static int
scav_vector_unsigned_byte_4(lispobj *where, lispobj object)
{
@@ -1407,9 +950,8 @@ trans_vector_unsigned_byte_4(lispobj object)
length = fixnum_value(vector->length);
nwords = CEILING(NWORDS(length, 8) + 2, 2);
- return copy_object(object, nwords);
+ return copy_large_unboxed_object(object, nwords);
}
-
static int
size_vector_unsigned_byte_4(lispobj *where)
{
@@ -1437,6 +979,10 @@ scav_vector_unsigned_byte_8(lispobj *where, lispobj object)
return nwords;
}
+/*********************/
+