X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fruntime%2Fpurify.c;h=e93e170fbc11c72ae99f6f7bb07cee10a38ec81b;hb=3d9d3088982414ca5617caf62bd37b4fecac29b6;hp=ba5d88e0977d1e34e6e8a7d365b881495cdc86cd;hpb=6e662062162ad5a6f09d6d3a5ec1249520e813a5;p=sbcl.git diff --git a/src/runtime/purify.c b/src/runtime/purify.c index ba5d88e..e93e170 100644 --- a/src/runtime/purify.c +++ b/src/runtime/purify.c @@ -16,6 +16,7 @@ #include #include #include +#include #include "runtime.h" #include "os.h" @@ -25,9 +26,10 @@ #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 @@ -75,7 +77,9 @@ static int later_count = 0; #define CEILING(x,y) (((x) + ((y) - 1)) & (~((y) - 1))) #define NWORDS(x,y) (CEILING((x),(y)) / (y)) -/* FIXME: (1) Shouldn't this be defined in sbcl.h? */ +/* FIXME: Shouldn't this be defined in sbcl.h? See also notes in + * cheneygc.c */ + #ifdef sparc #define FUN_RAW_ADDR_OFFSET 0 #else @@ -85,9 +89,7 @@ static int later_count = 0; static boolean forwarding_pointer_p(lispobj obj) { - lispobj *ptr; - - ptr = (lispobj *)obj; + lispobj *ptr = native_pointer(obj); return ((static_end <= ptr && ptr <= static_free) || (read_only_end <= ptr && ptr <= read_only_free)); @@ -97,11 +99,9 @@ static boolean 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 @@ -113,7 +113,7 @@ dynamic_pointer_p(lispobj ptr) #ifdef __i386__ -#ifdef GENCGC +#ifdef LISP_FEATURE_GENCGC /* * enhanced x86/GENCGC stack scavenging by Douglas Crosher * @@ -181,7 +181,7 @@ valid_dynamic_space_pointer(lispobj *pointer, lispobj *start_addr) 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)) @@ -221,8 +221,8 @@ valid_dynamic_space_pointer(lispobj *pointer, lispobj *start_addr) } 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); @@ -364,6 +364,11 @@ setup_i386_stack_scav(lispobj *lowaddr, lispobj *base) * 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; @@ -464,7 +469,7 @@ ptrans_boxed(lispobj thing, lispobj header, boolean constant) bcopy(old, new, nwords * sizeof(lispobj)); /* Deposit forwarding pointer. */ - result = (lispobj)new | lowtag_of(thing); + result = make_lispobj(new, lowtag_of(thing)); *old = result; /* Scavenge it. */ @@ -508,7 +513,7 @@ ptrans_instance(lispobj thing, lispobj header, boolean constant) bcopy(old, new, nwords * sizeof(lispobj)); /* Deposit forwarding pointer. */ - result = (lispobj)new | lowtag_of(thing); + result = make_lispobj(new, lowtag_of(thing)); *old = result; /* Scavenge it. */ @@ -540,7 +545,7 @@ ptrans_fdefn(lispobj thing, lispobj header) bcopy(old, new, nwords * sizeof(lispobj)); /* Deposit forwarding pointer. */ - result = (lispobj)new | lowtag_of(thing); + result = make_lispobj(new, lowtag_of(thing)); *old = result; /* Scavenge the function. */ @@ -558,19 +563,19 @@ ptrans_unboxed(lispobj thing, lispobj header) { int nwords; lispobj result, *new, *old; - + nwords = 1 + HeaderValue(header); - + /* Allocate it */ old = (lispobj *)native_pointer(thing); new = read_only_free; read_only_free += CEILING(nwords, 2); - + /* Copy it. */ bcopy(old, new, nwords * sizeof(lispobj)); - + /* Deposit forwarding pointer. */ - result = (lispobj)new | lowtag_of(thing); + result = make_lispobj(new , lowtag_of(thing)); *old = result; return result; @@ -598,7 +603,7 @@ ptrans_vector(lispobj thing, int bits, int extra, bcopy(vector, new, nwords * sizeof(lispobj)); - result = (lispobj)new | lowtag_of(thing); + result = make_lispobj(new, lowtag_of(thing)); vector->header = result; if (boxed) @@ -636,7 +641,7 @@ apply_code_fixups_during_purify(struct code *old_code, struct code *new_code) if ((fixups==0) || (fixups==UNBOUND_MARKER_WIDETAG) || !is_lisp_pointer(fixups)) { -#ifdef GENCGC +#ifdef LISP_FEATURE_GENCGC /* Check for a possible errors. */ sniff_code_object(new_code,displacement); #endif @@ -684,7 +689,7 @@ apply_code_fixups_during_purify(struct code *old_code, struct code *new_code) /* No longer need the fixups. */ new_code->constants[0] = 0; -#ifdef GENCGC +#ifdef LISP_FEATURE_GENCGC /* Check for possible errors. */ sniff_code_object(new_code,displacement); #endif @@ -706,11 +711,11 @@ ptrans_code(lispobj thing) bcopy(code, new, nwords * sizeof(lispobj)); -#ifdef __i386__ +#ifdef LISP_FEATURE_X86 apply_code_fixups_during_purify(code,new); #endif - result = (lispobj)new | OTHER_POINTER_LOWTAG; + result = make_lispobj(new, OTHER_POINTER_LOWTAG); /* Stick in a forwarding pointer for the code object. */ *(lispobj *)code = result; @@ -728,7 +733,7 @@ ptrans_code(lispobj thing) /* 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 @@ -784,12 +789,13 @@ ptrans_func(lispobj thing, lispobj header) function = (struct simple_fun *)native_pointer(thing); code = - (native_pointer(thing) - - (HeaderValue(function->header)*sizeof(lispobj))) | - OTHER_POINTER_LOWTAG; - + make_lispobj + ((native_pointer(thing) - + (HeaderValue(function->header))), OTHER_POINTER_LOWTAG); + /* This will cause the function's header to be replaced with a * forwarding pointer. */ + ptrans_code(code); /* So we can just return that. */ @@ -817,7 +823,7 @@ ptrans_func(lispobj thing, lispobj header) bcopy(old, new, nwords * sizeof(lispobj)); /* Deposit forwarding pointer. */ - result = (lispobj)new | lowtag_of(thing); + result = make_lispobj(new, lowtag_of(thing)); *old = result; /* Scavenge it. */ @@ -875,7 +881,7 @@ ptrans_list(lispobj thing, boolean constant) thing = new->cdr = old->cdr; /* Set up the forwarding pointer. */ - *(lispobj *)old = ((lispobj)new) | LIST_POINTER_LOWTAG; + *(lispobj *)old = make_lispobj(new, LIST_POINTER_LOWTAG); /* And count this cell. */ length++; @@ -886,7 +892,7 @@ ptrans_list(lispobj thing, boolean constant) /* Scavenge the list we just copied. */ pscav((lispobj *)orig, length * WORDS_PER_CONS, constant); - return ((lispobj)orig) | LIST_POINTER_LOWTAG; + return make_lispobj(orig, LIST_POINTER_LOWTAG); } static lispobj @@ -1296,11 +1302,14 @@ purify(lispobj static_roots, lispobj read_only_roots) 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 @@ -1325,7 +1334,7 @@ purify(lispobj static_roots, lispobj read_only_roots) 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 @@ -1350,7 +1359,7 @@ purify(lispobj static_roots, lispobj read_only_roots) current_control_stack_pointer - (lispobj *)CONTROL_STACK_START, 0); #else -#ifdef GENCGC +#ifdef LISP_FEATURE_GENCGC pscav_i386_stack(); #endif #endif @@ -1446,7 +1455,7 @@ purify(lispobj static_roots, lispobj read_only_roots) #if !defined(__i386__) dynamic_space_free_pointer = current_dynamic_space; #else -#if defined GENCGC +#if defined LISP_FEATURE_GENCGC gc_free_heap(); #else #error unsupported case /* in CMU CL, was "ibmrt using GC" */