#include <stdio.h>
#include <sys/types.h>
#include <stdlib.h>
+#include <strings.h>
#include "runtime.h"
#include "os.h"
#include "interrupt.h"
#include "purify.h"
#include "interr.h"
-#ifdef GENCGC
-#include "gencgc.h"
-#endif
+#include "gc.h"
+#include "gc-internal.h"
+#include "genesis/primitive-objects.h"
+#include "genesis/static-symbols.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));
dynamic_pointer_p(lispobj ptr)
{
#ifndef __i386__
- /* KLUDGE: This has an implicit dependence on the ordering of
- * address spaces, and is therefore basically wrong. I'd fix it,
- * but I don't have a non-386 port to test it on. Porters are
- * encouraged to fix it. -- WHN 2000-10-17 */
- return (ptr >= (lispobj)DYNAMIC_SPACE_START);
+ return (ptr >= (lispobj)current_dynamic_space
+ &&
+ ptr < (lispobj)dynamic_space_free_pointer);
#else
/* Be more conservative, and remember, this is a maybe. */
return (ptr >= (lispobj)DYNAMIC_SPACE_START
\f
#ifdef __i386__
-#ifdef GENCGC
+#ifdef LISP_FEATURE_GENCGC
/*
* enhanced x86/GENCGC stack scavenging by Douglas Crosher
*
return 0;
}
/* Is it plausible cons? */
- if((is_lisp_pointer(start_addr[0])
+ if ((is_lisp_pointer(start_addr[0])
|| ((start_addr[0] & 3) == 0) /* fixnum */
|| (widetag_of(start_addr[0]) == BASE_CHAR_WIDETAG)
|| (widetag_of(start_addr[0]) == UNBOUND_MARKER_WIDETAG))
}
return 0;
}
- /* Is it plausible? Not a cons. X should check the headers. */
- if(is_lisp_pointer(start_addr[0]) || ((start_addr[0] & 3) == 0)) {
+ /* Is it plausible? Not a cons. XXX should check the headers. */
+ if (is_lisp_pointer(start_addr[0]) || ((start_addr[0] & 3) == 0)) {
if (pointer_filter_verbose) {
fprintf(stderr,"*Wo2: %x %x %x\n", (unsigned int) pointer,
(unsigned int) start_addr, *start_addr);
* return addresses. This will also pick up pointers to
* functions in code objects. */
if (widetag_of(*start_addr) == CODE_HEADER_WIDETAG) {
+ /* FIXME asserting here is a really dumb thing to do.
+ * If we've overflowed some arbitrary static limit, we
+ * should just refuse to purify, instead of killing
+ * the whole lisp session
+ */
gc_assert(num_valid_stack_ra_locations <
MAX_STACK_RETURN_ADDRESSES);
valid_stack_ra_locations[num_valid_stack_ra_locations] = sp;
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;
/* Arrange to scavenge the debug info later. */
pscav_later(&new->debug_info, 1);
- if(new->trace_table_offset & 0x3)
+ if (new->trace_table_offset & 0x3)
#if 0
pscav(&new->trace_table_offset, 1, 0);
#else
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
int count, i;
struct later *laters, *next;
+
#ifdef PRINTNOISE
printf("[doing purification:");
fflush(stdout);
#endif
-
+#ifdef LISP_FEATURE_GENCGC
+ gc_alloc_update_all_page_tables();
+#endif
if (fixnum_value(SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX)) != 0) {
/* FIXME: 1. What does this mean? 2. It shouldn't be reporting
* its error simply by a. printing a string b. to stdout instead
fflush(stdout);
#endif
-#ifdef GENCGC
+#if (defined(LISP_FEATURE_GENCGC) && defined(LISP_FEATURE_X86))
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" */