X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fruntime%2Fpurify.c;h=aadf78b577adbb4377d331021aac0c4f99e34d15;hb=cb83aa22932bf4b9bc74ac6f0fcd91db1702ad33;hp=d194d35ae0545927d4790cac7e395d49c6e059ae;hpb=a530bbe337109d898d5b4a001fc8f1afa3b5dc39;p=sbcl.git diff --git a/src/runtime/purify.c b/src/runtime/purify.c index d194d35..aadf78b 100644 --- a/src/runtime/purify.c +++ b/src/runtime/purify.c @@ -13,42 +13,33 @@ * files for more information. */ -/* - * $Header$ - */ - #include #include #include +#include +#include +#include "sbcl.h" #include "runtime.h" #include "os.h" -#include "sbcl.h" #include "globals.h" #include "validate.h" #include "interrupt.h" #include "purify.h" #include "interr.h" -#ifdef GENCGC -#include "gencgc.h" -#endif +#include "fixnump.h" +#include "gc.h" +#include "gc-internal.h" +#include "thread.h" +#include "genesis/primitive-objects.h" +#include "genesis/static-symbols.h" +#include "genesis/layout.h" -#undef PRINTNOISE +#define PRINTNOISE -#if defined(ibmrt) || defined(__i386__) -static lispobj *current_dynamic_space_free_pointer; -#endif - -#define gc_abort() \ - lose("GC invariant lost, file \"%s\", line %d", __FILE__, __LINE__) +extern unsigned long bytes_consed_between_gcs; -#if 1 -#define gc_assert(ex) do { \ - if (!(ex)) gc_abort(); \ -} while (0) -#else -#define gc_assert(ex) -#endif +static lispobj *dynamic_space_purify_pointer; /* These hold the original end of the read_only and static spaces so @@ -58,35 +49,32 @@ static lispobj *read_only_end, *static_end; static lispobj *read_only_free, *static_free; -static lispobj *pscav(lispobj *addr, int nwords, boolean constant); +static lispobj *pscav(lispobj *addr, long nwords, boolean constant); #define LATERBLOCKSIZE 1020 #define LATERMAXCOUNT 10 -static struct later { +static struct +later { struct later *next; union { lispobj *ptr; - int count; + long count; } u[LATERBLOCKSIZE]; } *later_blocks = NULL; -static int later_count = 0; - -#define CEILING(x,y) (((x) + ((y) - 1)) & (~((y) - 1))) -#define NWORDS(x,y) (CEILING((x),(y)) / (y)) +static long later_count = 0; -#ifdef sparc -#define RAW_ADDR_OFFSET 0 -#else -#define RAW_ADDR_OFFSET (6*sizeof(lispobj) - type_FunctionPointer) +#if N_WORD_BITS == 32 + #define SIMPLE_ARRAY_WORD_WIDETAG SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG +#elif N_WORD_BITS == 64 + #define SIMPLE_ARRAY_WORD_WIDETAG SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG #endif + 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)); @@ -95,123 +83,46 @@ forwarding_pointer_p(lispobj obj) static boolean dynamic_pointer_p(lispobj ptr) { -#ifndef __i386__ - return (ptr >= (lispobj)dynamic_0_space); +#ifndef LISP_FEATURE_GENCGC + return (ptr >= (lispobj)current_dynamic_space + && + ptr < (lispobj)dynamic_space_purify_pointer); #else /* Be more conservative, and remember, this is a maybe. */ - return (ptr >= (lispobj)current_dynamic_space - && - ptr < (lispobj)current_dynamic_space_free_pointer); + return (ptr >= (lispobj)DYNAMIC_SPACE_START + && + ptr < (lispobj)dynamic_space_purify_pointer); #endif } - -#ifdef __i386__ - -#ifdef WANT_CGC -/* original x86/CGC stack scavenging code by Paul Werkowski */ - -static int -maybe_can_move_p(lispobj thing) -{ - lispobj *thingp,header; - if (dynamic_pointer_p(thing)) { /* in dynamic space */ - thingp = (lispobj*)PTR(thing); - header = *thingp; - if(Pointerp(header) && forwarding_pointer_p(header)) - return -1; /* must change it */ - if(LowtagOf(thing) == type_ListPointer) - return type_ListPointer; /* can we check this somehow */ - else if (thing & 3) { /* not fixnum */ - int kind = TypeOf(header); - /* printf(" %x %x",header,kind); */ - switch (kind) { /* something with a header */ - case type_Bignum: - case type_SingleFloat: - case type_DoubleFloat: -#ifdef type_LongFloat - case type_LongFloat: -#endif - case type_Sap: - case type_SimpleVector: - case type_SimpleString: - case type_SimpleBitVector: - case type_SimpleArrayUnsignedByte2: - case type_SimpleArrayUnsignedByte4: - case type_SimpleArrayUnsignedByte8: - case type_SimpleArrayUnsignedByte16: - case type_SimpleArrayUnsignedByte32: -#ifdef type_SimpleArraySignedByte8 - case type_SimpleArraySignedByte8: -#endif -#ifdef type_SimpleArraySignedByte16 - case type_SimpleArraySignedByte16: -#endif -#ifdef type_SimpleArraySignedByte30 - case type_SimpleArraySignedByte30: -#endif -#ifdef type_SimpleArraySignedByte32 - case type_SimpleArraySignedByte32: -#endif - case type_SimpleArraySingleFloat: - case type_SimpleArrayDoubleFloat: -#ifdef type_SimpleArrayLongFloat - case type_SimpleArrayLongFloat: -#endif -#ifdef type_SimpleArrayComplexSingleFloat - case type_SimpleArrayComplexSingleFloat: -#endif -#ifdef type_SimpleArrayComplexDoubleFloat - case type_SimpleArrayComplexDoubleFloat: -#endif -#ifdef type_SimpleArrayComplexLongFloat - case type_SimpleArrayComplexLongFloat: -#endif - case type_CodeHeader: - case type_FunctionHeader: - case type_ClosureFunctionHeader: - case type_ReturnPcHeader: - case type_ClosureHeader: - case type_FuncallableInstanceHeader: - case type_InstanceHeader: - case type_ValueCellHeader: - case type_ByteCodeFunction: - case type_ByteCodeClosure: - case type_WeakPointer: - case type_Fdefn: - return kind; - break; - default: - return 0; - }}} - return 0; -} - -static int pverbose=0; -#define PVERBOSE pverbose -static void -carefully_pscav_stack(lispobj*lowaddr, lispobj*base) +static inline lispobj * +newspace_alloc(long nwords, int constantp) { - lispobj*sp = lowaddr; - while (sp < base) - { int k; - lispobj thing = *sp; - if((unsigned)thing & 0x3) /* may be pointer */ - { - /* need to check for valid float/double? */ - k = maybe_can_move_p(thing); - if(PVERBOSE)printf("%8x %8x %d\n",sp, thing, k); - if(k) - pscav(sp, 1, 0); - } - sp++; + lispobj *ret; + nwords=CEILING(nwords,2); + if(constantp) { + if(read_only_free + nwords >= (lispobj *)READ_ONLY_SPACE_END) { + lose("Ran out of read-only space while purifying!\n"); + } + ret=read_only_free; + read_only_free+=nwords; + } else { + if(static_free + nwords >= (lispobj *)STATIC_SPACE_END) { + lose("Ran out of static space while purifying!\n"); + } + ret=static_free; + static_free+=nwords; } + return ret; } -#endif -#ifdef GENCGC + + +#if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64) + +#ifdef LISP_FEATURE_GENCGC /* - * Enhanced x86/GENCGC stack scavenging by Douglas Crosher. + * enhanced x86/GENCGC stack scavenging by Douglas Crosher * * Scavenging the stack on the i386 is problematic due to conservative * roots and raw return addresses. Here it is handled in two passes: @@ -222,273 +133,339 @@ carefully_pscav_stack(lispobj*lowaddr, lispobj*base) static unsigned pointer_filter_verbose = 0; +/* FIXME: This is substantially the same code as + * possibly_valid_dynamic_space_pointer in gencgc.c. The only + * relevant difference seems to be that the gencgc code also checks + * for raw pointers into Code objects, whereas in purify these are + * checked separately in setup_i386_stack_scav - they go onto + * valid_stack_ra_locations instead of just valid_stack_locations */ + static int valid_dynamic_space_pointer(lispobj *pointer, lispobj *start_addr) { - /* If it's not a return address then it needs to be a valid Lisp - * pointer. */ - if (!Pointerp((lispobj)pointer)) - return 0; + /* If it's not a return address then it needs to be a valid Lisp + * pointer. */ + if (!is_lisp_pointer((lispobj)pointer)) + return 0; - /* Check that the object pointed to is consistent with the pointer - * low tag. */ - switch (LowtagOf((lispobj)pointer)) { - case type_FunctionPointer: - /* Start_addr should be the enclosing code object, or a closure - * header. */ - switch (TypeOf(*start_addr)) { - case type_CodeHeader: - /* This case is probably caught above. */ - break; - case type_ClosureHeader: - case type_FuncallableInstanceHeader: - case type_ByteCodeFunction: - case type_ByteCodeClosure: - if ((int)pointer != ((int)start_addr+type_FunctionPointer)) { - if (pointer_filter_verbose) { - fprintf(stderr,"*Wf2: %x %x %x\n", pointer, start_addr, *start_addr); - } - return 0; - } - break; - default: - if (pointer_filter_verbose) { - fprintf(stderr,"*Wf3: %x %x %x\n", pointer, start_addr, *start_addr); - } - return 0; - } - break; - case type_ListPointer: - if ((int)pointer != ((int)start_addr+type_ListPointer)) { - if (pointer_filter_verbose) - fprintf(stderr,"*Wl1: %x %x %x\n", pointer, start_addr, *start_addr); - return 0; - } - /* Is it plausible cons? */ - if((Pointerp(start_addr[0]) - || ((start_addr[0] & 3) == 0) /* fixnum */ - || (TypeOf(start_addr[0]) == type_BaseChar) - || (TypeOf(start_addr[0]) == type_UnboundMarker)) - && (Pointerp(start_addr[1]) - || ((start_addr[1] & 3) == 0) /* fixnum */ - || (TypeOf(start_addr[1]) == type_BaseChar) - || (TypeOf(start_addr[1]) == type_UnboundMarker))) { - break; - } else { - if (pointer_filter_verbose) { - fprintf(stderr,"*Wl2: %x %x %x\n", pointer, start_addr, *start_addr); - } - return 0; - } - case type_InstancePointer: - if ((int)pointer != ((int)start_addr+type_InstancePointer)) { - if (pointer_filter_verbose) { - fprintf(stderr,"*Wi1: %x %x %x\n", pointer, start_addr, *start_addr); - } - return 0; - } - if (TypeOf(start_addr[0]) != type_InstanceHeader) { - if (pointer_filter_verbose) { - fprintf(stderr,"*Wi2: %x %x %x\n", pointer, start_addr, *start_addr); - } - return 0; - } - break; - case type_OtherPointer: - if ((int)pointer != ((int)start_addr+type_OtherPointer)) { - if (pointer_filter_verbose) { - fprintf(stderr,"*Wo1: %x %x %x\n", pointer, start_addr, *start_addr); - } - return 0; - } - /* Is it plausible? Not a cons. X should check the headers. */ - if(Pointerp(start_addr[0]) || ((start_addr[0] & 3) == 0)) { - if (pointer_filter_verbose) { - fprintf(stderr,"*Wo2: %x %x %x\n", pointer, start_addr, *start_addr); - } - return 0; - } - switch (TypeOf(start_addr[0])) { - case type_UnboundMarker: - case type_BaseChar: - if (pointer_filter_verbose) { - fprintf(stderr,"*Wo3: %x %x %x\n", pointer, start_addr, *start_addr); - } - return 0; - - /* only pointed to by function pointers? */ - case type_ClosureHeader: - case type_FuncallableInstanceHeader: - case type_ByteCodeFunction: - case type_ByteCodeClosure: - if (pointer_filter_verbose) { - fprintf(stderr,"*Wo4: %x %x %x\n", pointer, start_addr, *start_addr); - } - return 0; - - case type_InstanceHeader: - if (pointer_filter_verbose) { - fprintf(stderr,"*Wo5: %x %x %x\n", pointer, start_addr, *start_addr); - } - return 0; - - /* the valid other immediate pointer objects */ - case type_SimpleVector: - case type_Ratio: - case type_Complex: -#ifdef type_ComplexSingleFloat - case type_ComplexSingleFloat: -#endif -#ifdef type_ComplexDoubleFloat - case type_ComplexDoubleFloat: -#endif -#ifdef type_ComplexLongFloat - case type_ComplexLongFloat: -#endif - case type_SimpleArray: - case type_ComplexString: - case type_ComplexBitVector: - case type_ComplexVector: - case type_ComplexArray: - case type_ValueCellHeader: - case type_SymbolHeader: - case type_Fdefn: - case type_CodeHeader: - case type_Bignum: - case type_SingleFloat: - case type_DoubleFloat: -#ifdef type_LongFloat - case type_LongFloat: -#endif - case type_SimpleString: - case type_SimpleBitVector: - case type_SimpleArrayUnsignedByte2: - case type_SimpleArrayUnsignedByte4: - case type_SimpleArrayUnsignedByte8: - case type_SimpleArrayUnsignedByte16: - case type_SimpleArrayUnsignedByte32: -#ifdef type_SimpleArraySignedByte8 - case type_SimpleArraySignedByte8: -#endif -#ifdef type_SimpleArraySignedByte16 - case type_SimpleArraySignedByte16: -#endif -#ifdef type_SimpleArraySignedByte30 - case type_SimpleArraySignedByte30: -#endif -#ifdef type_SimpleArraySignedByte32 - case type_SimpleArraySignedByte32: -#endif - case type_SimpleArraySingleFloat: - case type_SimpleArrayDoubleFloat: -#ifdef type_SimpleArrayLongFloat - case type_SimpleArrayLongFloat: -#endif -#ifdef type_SimpleArrayComplexSingleFloat - case type_SimpleArrayComplexSingleFloat: -#endif -#ifdef type_SimpleArrayComplexDoubleFloat - case type_SimpleArrayComplexDoubleFloat: -#endif -#ifdef type_SimpleArrayComplexLongFloat - case type_SimpleArrayComplexLongFloat: -#endif - case type_Sap: - case type_WeakPointer: - break; + /* Check that the object pointed to is consistent with the pointer + * low tag. */ + switch (lowtag_of((lispobj)pointer)) { + case FUN_POINTER_LOWTAG: + /* Start_addr should be the enclosing code object, or a closure + * header. */ + switch (widetag_of(*start_addr)) { + case CODE_HEADER_WIDETAG: + /* This case is probably caught above. */ + break; + case CLOSURE_HEADER_WIDETAG: + case FUNCALLABLE_INSTANCE_HEADER_WIDETAG: + if ((long)pointer != ((long)start_addr+FUN_POINTER_LOWTAG)) { + if (pointer_filter_verbose) { + fprintf(stderr,"*Wf2: %p %p %p\n", + pointer, start_addr, (void *)*start_addr); + } + return 0; + } + break; + default: + if (pointer_filter_verbose) { + fprintf(stderr,"*Wf3: %p %p %p\n", + pointer, start_addr, (void *)*start_addr); + } + return 0; + } + break; + case LIST_POINTER_LOWTAG: + if ((long)pointer != ((long)start_addr+LIST_POINTER_LOWTAG)) { + if (pointer_filter_verbose) + fprintf(stderr,"*Wl1: %p %p %p\n", + pointer, start_addr, (void *)*start_addr); + return 0; + } + /* Is it plausible cons? */ + if ((is_lisp_pointer(start_addr[0]) + || ((start_addr[0] & FIXNUM_TAG_MASK) == 0) /* fixnum */ + || (widetag_of(start_addr[0]) == CHARACTER_WIDETAG) +#if N_WORD_BITS == 64 + || (widetag_of(start_addr[0]) == SINGLE_FLOAT_WIDETAG) +#endif + || (widetag_of(start_addr[0]) == UNBOUND_MARKER_WIDETAG)) + && (is_lisp_pointer(start_addr[1]) + || ((start_addr[1] & FIXNUM_TAG_MASK) == 0) /* fixnum */ + || (widetag_of(start_addr[1]) == CHARACTER_WIDETAG) +#if N_WORD_BITS == 64 + || (widetag_of(start_addr[1]) == SINGLE_FLOAT_WIDETAG) +#endif + || (widetag_of(start_addr[1]) == UNBOUND_MARKER_WIDETAG))) { + break; + } else { + if (pointer_filter_verbose) { + fprintf(stderr,"*Wl2: %p %p %p\n", + pointer, start_addr, (void *)*start_addr); + } + return 0; + } + case INSTANCE_POINTER_LOWTAG: + if ((long)pointer != ((long)start_addr+INSTANCE_POINTER_LOWTAG)) { + if (pointer_filter_verbose) { + fprintf(stderr,"*Wi1: %p %p %p\n", + pointer, start_addr, (void *)*start_addr); + } + return 0; + } + if (widetag_of(start_addr[0]) != INSTANCE_HEADER_WIDETAG) { + if (pointer_filter_verbose) { + fprintf(stderr,"*Wi2: %p %p %p\n", + pointer, start_addr, (void *)*start_addr); + } + return 0; + } + break; + case OTHER_POINTER_LOWTAG: + if ((long)pointer != ((long)start_addr+OTHER_POINTER_LOWTAG)) { + if (pointer_filter_verbose) { + fprintf(stderr,"*Wo1: %p %p %p\n", + pointer, start_addr, (void *)*start_addr); + } + return 0; + } + /* Is it plausible? Not a cons. XXX should check the headers. */ + if (is_lisp_pointer(start_addr[0]) || ((start_addr[0] & FIXNUM_TAG_MASK) == 0)) { + if (pointer_filter_verbose) { + fprintf(stderr,"*Wo2: %p %p %p\n", + pointer, start_addr, (void *)*start_addr); + } + return 0; + } + switch (widetag_of(start_addr[0])) { + case UNBOUND_MARKER_WIDETAG: + case CHARACTER_WIDETAG: +#if N_WORD_BITS == 64 + case SINGLE_FLOAT_WIDETAG: +#endif + if (pointer_filter_verbose) { + fprintf(stderr,"*Wo3: %p %p %p\n", + pointer, start_addr, (void *)*start_addr); + } + return 0; + + /* only pointed to by function pointers? */ + case CLOSURE_HEADER_WIDETAG: + case FUNCALLABLE_INSTANCE_HEADER_WIDETAG: + if (pointer_filter_verbose) { + fprintf(stderr,"*Wo4: %p %p %p\n", + pointer, start_addr, (void *)*start_addr); + } + return 0; + case INSTANCE_HEADER_WIDETAG: + if (pointer_filter_verbose) { + fprintf(stderr,"*Wo5: %p %p %p\n", + pointer, start_addr, (void *)*start_addr); + } + return 0; + + /* the valid other immediate pointer objects */ + case SIMPLE_VECTOR_WIDETAG: + case RATIO_WIDETAG: + case COMPLEX_WIDETAG: +#ifdef COMPLEX_SINGLE_FLOAT_WIDETAG + case COMPLEX_SINGLE_FLOAT_WIDETAG: +#endif +#ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG + case COMPLEX_DOUBLE_FLOAT_WIDETAG: +#endif +#ifdef COMPLEX_LONG_FLOAT_WIDETAG + case COMPLEX_LONG_FLOAT_WIDETAG: +#endif + case SIMPLE_ARRAY_WIDETAG: + case COMPLEX_BASE_STRING_WIDETAG: +#ifdef COMPLEX_CHARACTER_STRING_WIDETAG + case COMPLEX_CHARACTER_STRING_WIDETAG: +#endif + case COMPLEX_VECTOR_NIL_WIDETAG: + case COMPLEX_BIT_VECTOR_WIDETAG: + case COMPLEX_VECTOR_WIDETAG: + case COMPLEX_ARRAY_WIDETAG: + case VALUE_CELL_HEADER_WIDETAG: + case SYMBOL_HEADER_WIDETAG: + case FDEFN_WIDETAG: + case CODE_HEADER_WIDETAG: + case BIGNUM_WIDETAG: +#if N_WORD_BITS != 64 + case SINGLE_FLOAT_WIDETAG: +#endif + case DOUBLE_FLOAT_WIDETAG: +#ifdef LONG_FLOAT_WIDETAG + case LONG_FLOAT_WIDETAG: +#endif + case SIMPLE_ARRAY_NIL_WIDETAG: + case SIMPLE_BASE_STRING_WIDETAG: +#ifdef SIMPLE_CHARACTER_STRING_WIDETAG + case SIMPLE_CHARACTER_STRING_WIDETAG: +#endif + case SIMPLE_BIT_VECTOR_WIDETAG: + case SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG: + case SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG: + case SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG: + case SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG: + case SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG: + case SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG: +#ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG + case SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG: +#endif + case SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG: + case SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG: +#ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_60_WIDETAG + case SIMPLE_ARRAY_UNSIGNED_BYTE_60_WIDETAG: +#endif +#ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG + case SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG: +#endif +#ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG + case SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG: +#endif +#ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG + case SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG: +#endif +#ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG + case SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG: +#endif +#ifdef SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG + case SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG: +#endif +#ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG + case SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG: +#endif +#ifdef SIMPLE_ARRAY_SIGNED_BYTE_61_WIDETAG + case SIMPLE_ARRAY_SIGNED_BYTE_61_WIDETAG: +#endif +#ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG + case SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG: +#endif + case SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG: + case SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG: +#ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG + case SIMPLE_ARRAY_LONG_FLOAT_WIDETAG: +#endif +#ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG + case SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG: +#endif +#ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG + case SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG: +#endif +#ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG + case SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG: +#endif + case SAP_WIDETAG: + case WEAK_POINTER_WIDETAG: +#ifdef LUTEX_WIDETAG + case LUTEX_WIDETAG: +#endif + break; + + default: + if (pointer_filter_verbose) { + fprintf(stderr,"*Wo6: %p %p %p\n", + pointer, start_addr, (void *)*start_addr); + } + return 0; + } + break; default: - if (pointer_filter_verbose) { - fprintf(stderr,"*Wo6: %x %x %x\n", pointer, start_addr, *start_addr); - } - return 0; - } - break; - default: - if (pointer_filter_verbose) { - fprintf(stderr,"*W?: %x %x %x\n", pointer, start_addr, *start_addr); + if (pointer_filter_verbose) { + fprintf(stderr,"*W?: %p %p %p\n", + pointer, start_addr, (void *)*start_addr); + } + return 0; } - return 0; - } - /* looks good */ - return 1; + /* looks good */ + return 1; } #define MAX_STACK_POINTERS 256 lispobj *valid_stack_locations[MAX_STACK_POINTERS]; -unsigned int num_valid_stack_locations; +unsigned long num_valid_stack_locations; #define MAX_STACK_RETURN_ADDRESSES 128 lispobj *valid_stack_ra_locations[MAX_STACK_RETURN_ADDRESSES]; lispobj *valid_stack_ra_code_objects[MAX_STACK_RETURN_ADDRESSES]; -unsigned int num_valid_stack_ra_locations; +unsigned long num_valid_stack_ra_locations; /* Identify valid stack slots. */ static void setup_i386_stack_scav(lispobj *lowaddr, lispobj *base) { - lispobj *sp = lowaddr; - num_valid_stack_locations = 0; - num_valid_stack_ra_locations = 0; - for (sp = lowaddr; sp < base; sp++) { - lispobj thing = *sp; - /* Find the object start address */ - lispobj *start_addr = search_dynamic_space((void *)thing); - if (start_addr) { - /* We need to allow raw pointers into Code objects for return - * addresses. This will also pick up pointers to functions in code - * objects. */ - if (TypeOf(*start_addr) == type_CodeHeader) { - gc_assert(num_valid_stack_ra_locations < MAX_STACK_RETURN_ADDRESSES); - valid_stack_ra_locations[num_valid_stack_ra_locations] = sp; - valid_stack_ra_code_objects[num_valid_stack_ra_locations++] = - (lispobj *)((int)start_addr + type_OtherPointer); - } else { - if (valid_dynamic_space_pointer((void *)thing, start_addr)) { - gc_assert(num_valid_stack_locations < MAX_STACK_POINTERS); - valid_stack_locations[num_valid_stack_locations++] = sp; - } - } + lispobj *sp = lowaddr; + num_valid_stack_locations = 0; + num_valid_stack_ra_locations = 0; + for (sp = lowaddr; sp < base; sp++) { + lispobj thing = *sp; + /* Find the object start address */ + lispobj *start_addr = search_dynamic_space((void *)thing); + if (start_addr) { + /* We need to allow raw pointers into Code objects for + * 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; + valid_stack_ra_code_objects[num_valid_stack_ra_locations++] = + (lispobj *)((long)start_addr + OTHER_POINTER_LOWTAG); + } else { + if (valid_dynamic_space_pointer((void *)thing, start_addr)) { + gc_assert(num_valid_stack_locations < MAX_STACK_POINTERS); + valid_stack_locations[num_valid_stack_locations++] = sp; + } + } + } + } + if (pointer_filter_verbose) { + fprintf(stderr, "number of valid stack pointers = %ld\n", + num_valid_stack_locations); + fprintf(stderr, "number of stack return addresses = %ld\n", + num_valid_stack_ra_locations); } - } - if (pointer_filter_verbose) { - fprintf(stderr, "number of valid stack pointers = %d\n", - num_valid_stack_locations); - fprintf(stderr, "number of stack return addresses = %d\n", - num_valid_stack_ra_locations); - } } static void pscav_i386_stack(void) { - int i; - - for (i = 0; i < num_valid_stack_locations; i++) - pscav(valid_stack_locations[i], 1, 0); - - for (i = 0; i < num_valid_stack_ra_locations; i++) { - lispobj code_obj = (lispobj)valid_stack_ra_code_objects[i]; - pscav(&code_obj, 1, 0); - if (pointer_filter_verbose) { - fprintf(stderr,"*C moved RA %x to %x; for code object %x to %x\n", - *valid_stack_ra_locations[i], - (int)(*valid_stack_ra_locations[i]) - - ((int)valid_stack_ra_code_objects[i] - (int)code_obj), - valid_stack_ra_code_objects[i], code_obj); + long i; + + for (i = 0; i < num_valid_stack_locations; i++) + pscav(valid_stack_locations[i], 1, 0); + + for (i = 0; i < num_valid_stack_ra_locations; i++) { + lispobj code_obj = (lispobj)valid_stack_ra_code_objects[i]; + pscav(&code_obj, 1, 0); + if (pointer_filter_verbose) { + fprintf(stderr,"*C moved RA %p to %p; for code object %p to %p\n", + (void *)*valid_stack_ra_locations[i], + (void *)(*valid_stack_ra_locations[i]) - + ((void *)valid_stack_ra_code_objects[i] - + (void *)code_obj), + valid_stack_ra_code_objects[i], (void *)code_obj); + } + *valid_stack_ra_locations[i] = + ((long)(*valid_stack_ra_locations[i]) + - ((long)valid_stack_ra_code_objects[i] - (long)code_obj)); } - *valid_stack_ra_locations[i] = - ((int)(*valid_stack_ra_locations[i]) - - ((int)valid_stack_ra_code_objects[i] - (int)code_obj)); - } } #endif #endif static void -pscav_later(lispobj *where, int count) +pscav_later(lispobj *where, long count) { struct later *new; @@ -516,29 +493,23 @@ pscav_later(lispobj *where, int count) } } -static lispobj ptrans_boxed(lispobj thing, lispobj header, boolean constant) +static lispobj +ptrans_boxed(lispobj thing, lispobj header, boolean constant) { - int nwords; + long nwords; lispobj result, *new, *old; - nwords = 1 + HeaderValue(header); + nwords = CEILING(1 + HeaderValue(header), 2); /* Allocate it */ - old = (lispobj *)PTR(thing); - if (constant) { - new = read_only_free; - read_only_free += CEILING(nwords, 2); - } - else { - new = static_free; - static_free += CEILING(nwords, 2); - } + old = (lispobj *)native_pointer(thing); + new = newspace_alloc(nwords,constant); /* Copy it. */ bcopy(old, new, nwords * sizeof(lispobj)); /* Deposit forwarding pointer. */ - result = (lispobj)new | LowtagOf(thing); + result = make_lispobj(new, lowtag_of(thing)); *old = result; /* Scavenge it. */ @@ -548,125 +519,128 @@ static lispobj ptrans_boxed(lispobj thing, lispobj header, boolean constant) } /* We need to look at the layout to see whether it is a pure structure - * class, and only then can we transport as constant. If it is pure, we can - * ALWAYS transport as a constant. */ -static lispobj ptrans_instance(lispobj thing, lispobj header, boolean constant) + * class, and only then can we transport as constant. If it is pure, + * we can ALWAYS transport as a constant. */ +static lispobj +ptrans_instance(lispobj thing, lispobj header, boolean /* ignored */ constant) { - lispobj layout = ((struct instance *)PTR(thing))->slots[0]; - lispobj pure = ((struct instance *)PTR(layout))->slots[15]; + struct layout *layout = + (struct layout *) native_pointer(((struct instance *)native_pointer(thing))->slots[0]); + lispobj pure = layout->pure; switch (pure) { case T: - return (ptrans_boxed(thing, header, 1)); + return (ptrans_boxed(thing, header, 1)); case NIL: - return (ptrans_boxed(thing, header, 0)); + return (ptrans_boxed(thing, header, 0)); case 0: - { - /* Substructure: special case for the compact-info-envs, where - * the instance may have a point to the dynamic space placed - * into it (e.g. the cache-name slot), but the lists and arrays - * at the time of a purify can be moved to the RO space. */ - int nwords; - lispobj result, *new, *old; + { + /* Substructure: special case for the COMPACT-INFO-ENVs, + * where the instance may have a point to the dynamic + * space placed into it (e.g. the cache-name slot), but + * the lists and arrays at the time of a purify can be + * moved to the RO space. */ + long nwords; + lispobj result, *new, *old; - nwords = 1 + HeaderValue(header); + nwords = CEILING(1 + HeaderValue(header), 2); - /* Allocate it */ - old = (lispobj *)PTR(thing); - new = static_free; - static_free += CEILING(nwords, 2); + /* Allocate it */ + old = (lispobj *)native_pointer(thing); + new = newspace_alloc(nwords, 0); /* inconstant */ - /* Copy it. */ - bcopy(old, new, nwords * sizeof(lispobj)); + /* Copy it. */ + bcopy(old, new, nwords * sizeof(lispobj)); - /* Deposit forwarding pointer. */ - result = (lispobj)new | LowtagOf(thing); - *old = result; + /* Deposit forwarding pointer. */ + result = make_lispobj(new, lowtag_of(thing)); + *old = result; - /* Scavenge it. */ - pscav(new, nwords, 1); + /* Scavenge it. */ + pscav(new, nwords, 1); - return result; - } + return result; + } default: - gc_abort(); + gc_abort(); + return NIL; /* dummy value: return something ... */ } } -static lispobj ptrans_fdefn(lispobj thing, lispobj header) +static lispobj +ptrans_fdefn(lispobj thing, lispobj header) { - int nwords; + long nwords; lispobj result, *new, *old, oldfn; struct fdefn *fdefn; - nwords = 1 + HeaderValue(header); + nwords = CEILING(1 + HeaderValue(header), 2); /* Allocate it */ - old = (lispobj *)PTR(thing); - new = static_free; - static_free += CEILING(nwords, 2); + old = (lispobj *)native_pointer(thing); + new = newspace_alloc(nwords, 0); /* inconstant */ /* Copy it. */ bcopy(old, new, nwords * sizeof(lispobj)); /* Deposit forwarding pointer. */ - result = (lispobj)new | LowtagOf(thing); + result = make_lispobj(new, lowtag_of(thing)); *old = result; /* Scavenge the function. */ fdefn = (struct fdefn *)new; - oldfn = fdefn->function; - pscav(&fdefn->function, 1, 0); - if ((char *)oldfn + RAW_ADDR_OFFSET == fdefn->raw_addr) - fdefn->raw_addr = (char *)fdefn->function + RAW_ADDR_OFFSET; + oldfn = fdefn->fun; + pscav(&fdefn->fun, 1, 0); + if ((char *)oldfn + FUN_RAW_ADDR_OFFSET == fdefn->raw_addr) + fdefn->raw_addr = (char *)fdefn->fun + FUN_RAW_ADDR_OFFSET; return result; } -static lispobj ptrans_unboxed(lispobj thing, lispobj header) +static lispobj +ptrans_unboxed(lispobj thing, lispobj header) { - int nwords; + long nwords; lispobj result, *new, *old; - nwords = 1 + HeaderValue(header); + nwords = CEILING(1 + HeaderValue(header), 2); /* Allocate it */ - old = (lispobj *)PTR(thing); - new = read_only_free; - read_only_free += CEILING(nwords, 2); + old = (lispobj *)native_pointer(thing); + new = newspace_alloc(nwords,1); /* always constant */ - /* Copy it. */ + /* copy it. */ bcopy(old, new, nwords * sizeof(lispobj)); /* Deposit forwarding pointer. */ - result = (lispobj)new | LowtagOf(thing); + result = make_lispobj(new , lowtag_of(thing)); *old = result; return result; } -static lispobj ptrans_vector(lispobj thing, int bits, int extra, - boolean boxed, boolean constant) +static lispobj +ptrans_vector(lispobj thing, long bits, long extra, + boolean boxed, boolean constant) { struct vector *vector; - int nwords; + long nwords; lispobj result, *new; + long length; - vector = (struct vector *)PTR(thing); - nwords = 2 + (CEILING((fixnum_value(vector->length)+extra)*bits,32)>>5); - - if (boxed && !constant) { - new = static_free; - static_free += CEILING(nwords, 2); - } - else { - new = read_only_free; - read_only_free += CEILING(nwords, 2); + vector = (struct vector *)native_pointer(thing); + length = fixnum_value(vector->length)+extra; + // Argh, handle simple-vector-nil separately. + if (bits == 0) { + nwords = 2; + } else { + nwords = CEILING(NWORDS(length, bits) + 2, 2); } + new=newspace_alloc(nwords, (constant || !boxed)); bcopy(vector, new, nwords * sizeof(lispobj)); - result = (lispobj)new | LowtagOf(thing); + result = make_lispobj(new, lowtag_of(thing)); vector->header = result; if (boxed) @@ -675,111 +649,109 @@ static lispobj ptrans_vector(lispobj thing, int bits, int extra, return result; } -#ifdef __i386__ +#if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64) static void apply_code_fixups_during_purify(struct code *old_code, struct code *new_code) { - int nheader_words, ncode_words, nwords; - void *constants_start_addr, *constants_end_addr; - void *code_start_addr, *code_end_addr; - lispobj p; - lispobj fixups = NIL; - unsigned displacement = (unsigned)new_code - (unsigned)old_code; - struct vector *fixups_vector; - - /* Byte compiled code has no fixups. The trace table offset will be - * a fixnum if it's x86 compiled code - check. */ - if (new_code->trace_table_offset & 0x3) - return; - - /* Else it's x86 machine code. */ - ncode_words = fixnum_value(new_code->code_size); - nheader_words = HeaderValue(*(lispobj *)new_code); - nwords = ncode_words + nheader_words; - - constants_start_addr = (void *)new_code + 5*4; - constants_end_addr = (void *)new_code + nheader_words*4; - code_start_addr = (void *)new_code + nheader_words*4; - code_end_addr = (void *)new_code + nwords*4; - - /* The first constant should be a pointer to the fixups for this - * code objects. Check. */ - fixups = new_code->constants[0]; - - /* It will be 0 or the unbound-marker if there are no fixups, and - * will be an other-pointer to a vector if it is valid. */ - if ((fixups==0) || (fixups==type_UnboundMarker) || !Pointerp(fixups)) { -#ifdef GENCGC - /* Check for a possible errors. */ - sniff_code_object(new_code,displacement); -#endif - return; - } - - fixups_vector = (struct vector *)PTR(fixups); - - /* Could be pointing to a forwarding pointer. */ - if (Pointerp(fixups) && (dynamic_pointer_p(fixups)) - && forwarding_pointer_p(*(lispobj *)fixups_vector)) { - /* If so then follow it. */ - fixups_vector = (struct vector *)PTR(*(lispobj *)fixups_vector); - } - - if (TypeOf(fixups_vector->header) == type_SimpleArrayUnsignedByte32) { - /* We got the fixups for the code block. Now work through the vector, - * and apply a fixup at each address. */ - int length = fixnum_value(fixups_vector->length); - int i; - for (i=0; idata[i]; - /* Now check the current value of offset. */ - unsigned old_value = *(unsigned *)((unsigned)code_start_addr + offset); - - /* If it's within the old_code object then it must be an - * absolute fixup (relative ones are not saved) */ - if ((old_value>=(unsigned)old_code) - && (old_value<((unsigned)old_code + nwords*4))) - /* So add the dispacement. */ - *(unsigned *)((unsigned)code_start_addr + offset) = old_value - + displacement; - else - /* It is outside the old code object so it must be a relative - * fixup (absolute fixups are not saved). So subtract the - * displacement. */ - *(unsigned *)((unsigned)code_start_addr + offset) = old_value - - displacement; + long nheader_words, ncode_words, nwords; + void *constants_start_addr, *constants_end_addr; + void *code_start_addr, *code_end_addr; + lispobj fixups = NIL; + unsigned displacement = (unsigned)new_code - (unsigned)old_code; + struct vector *fixups_vector; + + ncode_words = fixnum_value(new_code->code_size); + nheader_words = HeaderValue(*(lispobj *)new_code); + nwords = ncode_words + nheader_words; + + constants_start_addr = (void *)new_code + 5 * N_WORD_BYTES; + constants_end_addr = (void *)new_code + nheader_words*N_WORD_BYTES; + code_start_addr = (void *)new_code + nheader_words*N_WORD_BYTES; + code_end_addr = (void *)new_code + nwords*N_WORD_BYTES; + + /* The first constant should be a pointer to the fixups for this + * code objects. Check. */ + fixups = new_code->constants[0]; + + /* It will be 0 or the unbound-marker if there are no fixups, and + * will be an other-pointer to a vector if it is valid. */ + if ((fixups==0) || + (fixups==UNBOUND_MARKER_WIDETAG) || + !is_lisp_pointer(fixups)) { +#ifdef LISP_FEATURE_GENCGC + /* Check for a possible errors. */ + sniff_code_object(new_code,displacement); +#endif + return; } - } - /* No longer need the fixups. */ - new_code->constants[0] = 0; + fixups_vector = (struct vector *)native_pointer(fixups); + + /* Could be pointing to a forwarding pointer. */ + if (is_lisp_pointer(fixups) && (dynamic_pointer_p(fixups)) + && forwarding_pointer_p(*(lispobj *)fixups_vector)) { + /* If so then follow it. */ + fixups_vector = + (struct vector *)native_pointer(*(lispobj *)fixups_vector); + } -#ifdef GENCGC - /* Check for possible errors. */ - sniff_code_object(new_code,displacement); + if (widetag_of(fixups_vector->header) == SIMPLE_ARRAY_WORD_WIDETAG) { + /* We got the fixups for the code block. Now work through the + * vector, and apply a fixup at each address. */ + long length = fixnum_value(fixups_vector->length); + long i; + for (i=0; idata[i]; + /* Now check the current value of offset. */ + unsigned old_value = + *(unsigned *)((unsigned)code_start_addr + offset); + + /* If it's within the old_code object then it must be an + * absolute fixup (relative ones are not saved) */ + if ((old_value>=(unsigned)old_code) + && (old_value<((unsigned)old_code + nwords * N_WORD_BYTES))) + /* So add the dispacement. */ + *(unsigned *)((unsigned)code_start_addr + offset) = old_value + + displacement; + else + /* It is outside the old code object so it must be a relative + * fixup (absolute fixups are not saved). So subtract the + * displacement. */ + *(unsigned *)((unsigned)code_start_addr + offset) = old_value + - displacement; + } + } + + /* No longer need the fixups. */ + new_code->constants[0] = 0; + +#ifdef LISP_FEATURE_GENCGC + /* Check for possible errors. */ + sniff_code_object(new_code,displacement); #endif } #endif -static lispobj ptrans_code(lispobj thing) +static lispobj +ptrans_code(lispobj thing) { struct code *code, *new; - int nwords; + long nwords; lispobj func, result; - code = (struct code *)PTR(thing); - nwords = HeaderValue(code->header) + fixnum_value(code->code_size); + code = (struct code *)native_pointer(thing); + nwords = CEILING(HeaderValue(code->header) + fixnum_value(code->code_size), + 2); - new = (struct code *)read_only_free; - read_only_free += CEILING(nwords, 2); + new = (struct code *)newspace_alloc(nwords,1); /* constant */ bcopy(code, new, nwords * sizeof(lispobj)); -#ifdef __i386__ +#if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64) apply_code_fixups_during_purify(code,new); #endif - result = (lispobj)new | type_OtherPointer; + result = make_lispobj(new, OTHER_POINTER_LOWTAG); /* Stick in a forwarding pointer for the code object. */ *(lispobj *)code = result; @@ -787,21 +759,26 @@ static lispobj ptrans_code(lispobj thing) /* Put in forwarding pointers for all the functions. */ for (func = code->entry_points; func != NIL; - func = ((struct function *)PTR(func))->next) { + func = ((struct simple_fun *)native_pointer(func))->next) { - gc_assert(LowtagOf(func) == type_FunctionPointer); + gc_assert(lowtag_of(func) == FUN_POINTER_LOWTAG); - *(lispobj *)PTR(func) = result + (func - thing); + *(lispobj *)native_pointer(func) = result + (func - thing); } /* Arrange to scavenge the debug info later. */ pscav_later(&new->debug_info, 1); - if(new->trace_table_offset & 0x3) + /* FIXME: why would this be a fixnum? */ + /* "why" is a hard word, but apparently for compiled functions the + trace_table_offset contains the length of the instructions, as + a fixnum. See CODE-INST-AREA-LENGTH in + src/compiler/target-disassem.lisp. -- CSR, 2004-01-08 */ + if (!(fixnump(new->trace_table_offset))) #if 0 - pscav(&new->trace_table_offset, 1, 0); + pscav(&new->trace_table_offset, 1, 0); #else - new->trace_table_offset = NIL; /* limit lifetime */ + new->trace_table_offset = NIL; /* limit lifetime */ #endif /* Scavenge the constants. */ @@ -811,30 +788,32 @@ static lispobj ptrans_code(lispobj thing) pscav(&new->entry_points, 1, 1); for (func = new->entry_points; func != NIL; - func = ((struct function *)PTR(func))->next) { - gc_assert(LowtagOf(func) == type_FunctionPointer); + func = ((struct simple_fun *)native_pointer(func))->next) { + gc_assert(lowtag_of(func) == FUN_POINTER_LOWTAG); gc_assert(!dynamic_pointer_p(func)); -#ifdef __i386__ - /* Temporarly convert the self pointer to a real function - pointer. */ - ((struct function *)PTR(func))->self -= RAW_ADDR_OFFSET; +#if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64) + /* Temporarily convert the self pointer to a real function pointer. */ + ((struct simple_fun *)native_pointer(func))->self + -= FUN_RAW_ADDR_OFFSET; #endif - pscav(&((struct function *)PTR(func))->self, 2, 1); -#ifdef __i386__ - ((struct function *)PTR(func))->self += RAW_ADDR_OFFSET; + pscav(&((struct simple_fun *)native_pointer(func))->self, 2, 1); +#if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64) + ((struct simple_fun *)native_pointer(func))->self + += FUN_RAW_ADDR_OFFSET; #endif - pscav_later(&((struct function *)PTR(func))->name, 3); + pscav_later(&((struct simple_fun *)native_pointer(func))->name, 3); } return result; } -static lispobj ptrans_func(lispobj thing, lispobj header) +static lispobj +ptrans_func(lispobj thing, lispobj header) { - int nwords; + long nwords; lispobj code, *new, *old, result; - struct function *function; + struct simple_fun *function; /* Thing can either be a function header, a closure function * header, a closure, or a funcallable-instance. If it's a closure @@ -842,47 +821,42 @@ static lispobj ptrans_func(lispobj thing, lispobj header) * Otherwise we have to do something strange, 'cause it is buried * inside a code object. */ - if (TypeOf(header) == type_FunctionHeader || - TypeOf(header) == type_ClosureFunctionHeader) { + if (widetag_of(header) == SIMPLE_FUN_HEADER_WIDETAG) { - /* We can only end up here if the code object has not been + /* We can only end up here if the code object has not been * scavenged, because if it had been scavenged, forwarding pointers * would have been left behind for all the entry points. */ - function = (struct function *)PTR(thing); - code = (PTR(thing)-(HeaderValue(function->header)*sizeof(lispobj))) | - type_OtherPointer; + function = (struct simple_fun *)native_pointer(thing); + code = + make_lispobj + ((native_pointer(thing) - + (HeaderValue(function->header))), OTHER_POINTER_LOWTAG); - /* This will cause the function's header to be replaced with a + /* This will cause the function's header to be replaced with a * forwarding pointer. */ + ptrans_code(code); /* So we can just return that. */ return function->header; } else { - /* It's some kind of closure-like thing. */ - nwords = 1 + HeaderValue(header); - old = (lispobj *)PTR(thing); - - /* Allocate the new one. */ - if (TypeOf(header) == type_FuncallableInstanceHeader) { - /* FINs *must* not go in read_only space. */ - new = static_free; - static_free += CEILING(nwords, 2); - } - else { - /* Closures can always go in read-only space, 'cause they - * never change. */ - - new = read_only_free; - read_only_free += CEILING(nwords, 2); - } + /* It's some kind of closure-like thing. */ + nwords = CEILING(1 + HeaderValue(header), 2); + old = (lispobj *)native_pointer(thing); + + /* Allocate the new one. FINs *must* not go in read_only + * space. Closures can; they never change */ + + new = newspace_alloc + (nwords,(widetag_of(header)!=FUNCALLABLE_INSTANCE_HEADER_WIDETAG)); + /* Copy it. */ bcopy(old, new, nwords * sizeof(lispobj)); /* Deposit forwarding pointer. */ - result = (lispobj)new | LowtagOf(thing); + result = make_lispobj(new, lowtag_of(thing)); *old = result; /* Scavenge it. */ @@ -892,7 +866,8 @@ static lispobj ptrans_func(lispobj thing, lispobj header) } } -static lispobj ptrans_returnpc(lispobj thing, lispobj header) +static lispobj +ptrans_returnpc(lispobj thing, lispobj header) { lispobj code, new; @@ -900,7 +875,7 @@ static lispobj ptrans_returnpc(lispobj thing, lispobj header) code = thing - HeaderValue(header)*sizeof(lispobj); /* Make sure it's been transported. */ - new = *(lispobj *)PTR(code); + new = *(lispobj *)native_pointer(code); if (!forwarding_pointer_p(new)) new = ptrans_code(code); @@ -910,205 +885,229 @@ static lispobj ptrans_returnpc(lispobj thing, lispobj header) #define WORDS_PER_CONS CEILING(sizeof(struct cons) / sizeof(lispobj), 2) -static lispobj ptrans_list(lispobj thing, boolean constant) +static lispobj +ptrans_list(lispobj thing, boolean constant) { struct cons *old, *new, *orig; - int length; + long length; - if (constant) - orig = (struct cons *)read_only_free; - else - orig = (struct cons *)static_free; + orig = (struct cons *) newspace_alloc(0,constant); length = 0; do { /* Allocate a new cons cell. */ - old = (struct cons *)PTR(thing); - if (constant) { - new = (struct cons *)read_only_free; - read_only_free += WORDS_PER_CONS; - } - else { - new = (struct cons *)static_free; - static_free += WORDS_PER_CONS; - } + old = (struct cons *)native_pointer(thing); + new = (struct cons *) newspace_alloc(WORDS_PER_CONS,constant); /* Copy the cons cell and keep a pointer to the cdr. */ new->car = old->car; thing = new->cdr = old->cdr; /* Set up the forwarding pointer. */ - *(lispobj *)old = ((lispobj)new) | type_ListPointer; + *(lispobj *)old = make_lispobj(new, LIST_POINTER_LOWTAG); /* And count this cell. */ length++; - } while (LowtagOf(thing) == type_ListPointer && + } while (lowtag_of(thing) == LIST_POINTER_LOWTAG && dynamic_pointer_p(thing) && - !(forwarding_pointer_p(*(lispobj *)PTR(thing)))); + !(forwarding_pointer_p(*(lispobj *)native_pointer(thing)))); /* Scavenge the list we just copied. */ pscav((lispobj *)orig, length * WORDS_PER_CONS, constant); - return ((lispobj)orig) | type_ListPointer; + return make_lispobj(orig, LIST_POINTER_LOWTAG); } -static lispobj ptrans_otherptr(lispobj thing, lispobj header, boolean constant) +static lispobj +ptrans_otherptr(lispobj thing, lispobj header, boolean constant) { - switch (TypeOf(header)) { - case type_Bignum: - case type_SingleFloat: - case type_DoubleFloat: -#ifdef type_LongFloat - case type_LongFloat: -#endif -#ifdef type_ComplexSingleFloat - case type_ComplexSingleFloat: -#endif -#ifdef type_ComplexDoubleFloat - case type_ComplexDoubleFloat: -#endif -#ifdef type_ComplexLongFloat - case type_ComplexLongFloat: -#endif - case type_Sap: - return ptrans_unboxed(thing, header); - - case type_Ratio: - case type_Complex: - case type_SimpleArray: - case type_ComplexString: - case type_ComplexVector: - case type_ComplexArray: + switch (widetag_of(header)) { + /* FIXME: this needs a reindent */ + case BIGNUM_WIDETAG: + case SINGLE_FLOAT_WIDETAG: + case DOUBLE_FLOAT_WIDETAG: +#ifdef LONG_FLOAT_WIDETAG + case LONG_FLOAT_WIDETAG: +#endif +#ifdef COMPLEX_SINGLE_FLOAT_WIDETAG + case COMPLEX_SINGLE_FLOAT_WIDETAG: +#endif +#ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG + case COMPLEX_DOUBLE_FLOAT_WIDETAG: +#endif +#ifdef COMPLEX_LONG_FLOAT_WIDETAG + case COMPLEX_LONG_FLOAT_WIDETAG: +#endif + case SAP_WIDETAG: + return ptrans_unboxed(thing, header); +#ifdef LUTEX_WIDETAG + case LUTEX_WIDETAG: + gencgc_unregister_lutex(native_pointer(thing)); + return ptrans_unboxed(thing, header); +#endif + + case RATIO_WIDETAG: + case COMPLEX_WIDETAG: + case SIMPLE_ARRAY_WIDETAG: + case COMPLEX_BASE_STRING_WIDETAG: +#ifdef COMPLEX_CHARACTER_STRING_WIDETAG + case COMPLEX_CHARACTER_STRING_WIDETAG: +#endif + case COMPLEX_BIT_VECTOR_WIDETAG: + case COMPLEX_VECTOR_NIL_WIDETAG: + case COMPLEX_VECTOR_WIDETAG: + case COMPLEX_ARRAY_WIDETAG: return ptrans_boxed(thing, header, constant); - - case type_ValueCellHeader: - case type_WeakPointer: + + case VALUE_CELL_HEADER_WIDETAG: + case WEAK_POINTER_WIDETAG: return ptrans_boxed(thing, header, 0); - case type_SymbolHeader: + case SYMBOL_HEADER_WIDETAG: return ptrans_boxed(thing, header, 0); - case type_SimpleString: + case SIMPLE_ARRAY_NIL_WIDETAG: + return ptrans_vector(thing, 0, 0, 0, constant); + + case SIMPLE_BASE_STRING_WIDETAG: return ptrans_vector(thing, 8, 1, 0, constant); - case type_SimpleBitVector: +#ifdef SIMPLE_CHARACTER_STRING_WIDETAG + case SIMPLE_CHARACTER_STRING_WIDETAG: + return ptrans_vector(thing, 32, 1, 0, constant); +#endif + + case SIMPLE_BIT_VECTOR_WIDETAG: return ptrans_vector(thing, 1, 0, 0, constant); - case type_SimpleVector: - return ptrans_vector(thing, 32, 0, 1, constant); + case SIMPLE_VECTOR_WIDETAG: + return ptrans_vector(thing, N_WORD_BITS, 0, 1, constant); - case type_SimpleArrayUnsignedByte2: + case SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG: return ptrans_vector(thing, 2, 0, 0, constant); - case type_SimpleArrayUnsignedByte4: + case SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG: return ptrans_vector(thing, 4, 0, 0, constant); - case type_SimpleArrayUnsignedByte8: -#ifdef type_SimpleArraySignedByte8 - case type_SimpleArraySignedByte8: + case SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG: +#ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG + case SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG: + case SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG: #endif return ptrans_vector(thing, 8, 0, 0, constant); - case type_SimpleArrayUnsignedByte16: -#ifdef type_SimpleArraySignedByte16 - case type_SimpleArraySignedByte16: + case SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG: +#ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG + case SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG: + case SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG: #endif return ptrans_vector(thing, 16, 0, 0, constant); - case type_SimpleArrayUnsignedByte32: -#ifdef type_SimpleArraySignedByte30 - case type_SimpleArraySignedByte30: + case SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG: +#ifdef SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG + case SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG: + case SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG: #endif -#ifdef type_SimpleArraySignedByte32 - case type_SimpleArraySignedByte32: +#ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG + case SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG: + case SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG: #endif return ptrans_vector(thing, 32, 0, 0, constant); - case type_SimpleArraySingleFloat: +#if N_WORD_BITS == 64 +#ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_60_WIDETAG + case SIMPLE_ARRAY_UNSIGNED_BYTE_60_WIDETAG: +#endif +#ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG + case SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG: +#endif +#ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG + case SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG: +#endif +#ifdef SIMPLE_ARRAY_SIGNED_BYTE_61_WIDETAG + case SIMPLE_ARRAY_SIGNED_BYTE_61_WIDETAG: +#endif +#ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG + case SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG: +#endif + return ptrans_vector(thing, 64, 0, 0, constant); +#endif + + case SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG: return ptrans_vector(thing, 32, 0, 0, constant); - case type_SimpleArrayDoubleFloat: + case SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG: return ptrans_vector(thing, 64, 0, 0, constant); -#ifdef type_SimpleArrayLongFloat - case type_SimpleArrayLongFloat: -#ifdef __i386__ +#ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG + case SIMPLE_ARRAY_LONG_FLOAT_WIDETAG: +#ifdef LISP_FEATURE_X86 return ptrans_vector(thing, 96, 0, 0, constant); #endif -#ifdef sparc +#ifdef LISP_FEATURE_SPARC return ptrans_vector(thing, 128, 0, 0, constant); #endif #endif -#ifdef type_SimpleArrayComplexSingleFloat - case type_SimpleArrayComplexSingleFloat: +#ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG + case SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG: return ptrans_vector(thing, 64, 0, 0, constant); #endif -#ifdef type_SimpleArrayComplexDoubleFloat - case type_SimpleArrayComplexDoubleFloat: +#ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG + case SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG: return ptrans_vector(thing, 128, 0, 0, constant); #endif -#ifdef type_SimpleArrayComplexLongFloat - case type_SimpleArrayComplexLongFloat: -#ifdef __i386__ +#ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG + case SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG: +#ifdef LISP_FEATURE_X86 return ptrans_vector(thing, 192, 0, 0, constant); #endif -#ifdef sparc +#ifdef LISP_FEATURE_SPARC return ptrans_vector(thing, 256, 0, 0, constant); #endif #endif - case type_CodeHeader: + case CODE_HEADER_WIDETAG: return ptrans_code(thing); - case type_ReturnPcHeader: + case RETURN_PC_HEADER_WIDETAG: return ptrans_returnpc(thing, header); - case type_Fdefn: - return ptrans_fdefn(thing, header); + case FDEFN_WIDETAG: + return ptrans_fdefn(thing, header); default: + fprintf(stderr, "Invalid widetag: %d\n", widetag_of(header)); /* Should only come across other pointers to the above stuff. */ gc_abort(); - return NIL; + return NIL; } } -static int pscav_fdefn(struct fdefn *fdefn) +static long +pscav_fdefn(struct fdefn *fdefn) { boolean fix_func; - fix_func = ((char *)(fdefn->function+RAW_ADDR_OFFSET) == fdefn->raw_addr); + fix_func = ((char *)(fdefn->fun+FUN_RAW_ADDR_OFFSET) == fdefn->raw_addr); pscav(&fdefn->name, 1, 1); - pscav(&fdefn->function, 1, 0); + pscav(&fdefn->fun, 1, 0); if (fix_func) - fdefn->raw_addr = (char *)(fdefn->function + RAW_ADDR_OFFSET); + fdefn->raw_addr = (char *)(fdefn->fun + FUN_RAW_ADDR_OFFSET); return sizeof(struct fdefn) / sizeof(lispobj); } -#ifdef __i386__ +#if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64) /* now putting code objects in static space */ -static int +static long pscav_code(struct code*code) { - int nwords; + long nwords; lispobj func; - nwords = HeaderValue(code->header) + fixnum_value(code->code_size); - - /* pw--The trace_table_offset slot can contain a list pointer. This - * occurs when the code object is a top level form that initializes - * a byte-compiled function. The fact that PURIFY was ignoring this - * slot may be a bug unrelated to the x86 port, except that TLF's - * normally become unreachable after the loader calls them and - * won't be seen by PURIFY at all!! */ - if(code->trace_table_offset & 0x3) -#if 0 - pscav(&code->trace_table_offset, 1, 0); -#else - code->trace_table_offset = NIL; /* limit lifetime */ -#endif + nwords = CEILING(HeaderValue(code->header) + fixnum_value(code->code_size), + 2); /* Arrange to scavenge the debug info later. */ pscav_later(&code->debug_info, 1); @@ -1120,59 +1119,62 @@ pscav_code(struct code*code) pscav(&code->entry_points, 1, 1); for (func = code->entry_points; func != NIL; - func = ((struct function *)PTR(func))->next) { - gc_assert(LowtagOf(func) == type_FunctionPointer); + func = ((struct simple_fun *)native_pointer(func))->next) { + gc_assert(lowtag_of(func) == FUN_POINTER_LOWTAG); gc_assert(!dynamic_pointer_p(func)); -#ifdef __i386__ - /* Temporarly convert the self pointer to a real function - * pointer. */ - ((struct function *)PTR(func))->self -= RAW_ADDR_OFFSET; +#if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64) + /* Temporarily convert the self pointer to a real function + * pointer. */ + ((struct simple_fun *)native_pointer(func))->self + -= FUN_RAW_ADDR_OFFSET; #endif - pscav(&((struct function *)PTR(func))->self, 2, 1); -#ifdef __i386__ - ((struct function *)PTR(func))->self += RAW_ADDR_OFFSET; + pscav(&((struct simple_fun *)native_pointer(func))->self, 2, 1); +#if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64) + ((struct simple_fun *)native_pointer(func))->self + += FUN_RAW_ADDR_OFFSET; #endif - pscav_later(&((struct function *)PTR(func))->name, 3); + pscav_later(&((struct simple_fun *)native_pointer(func))->name, 3); } return CEILING(nwords,2); } #endif -static lispobj *pscav(lispobj *addr, int nwords, boolean constant) +static lispobj * +pscav(lispobj *addr, long nwords, boolean constant) { lispobj thing, *thingp, header; - int count; + long count = 0; /* (0 = dummy init value to stop GCC warning) */ struct vector *vector; while (nwords > 0) { thing = *addr; - if (Pointerp(thing)) { + if (is_lisp_pointer(thing)) { /* It's a pointer. Is it something we might have to move? */ if (dynamic_pointer_p(thing)) { /* Maybe. Have we already moved it? */ - thingp = (lispobj *)PTR(thing); + thingp = (lispobj *)native_pointer(thing); header = *thingp; - if (Pointerp(header) && forwarding_pointer_p(header)) + if (is_lisp_pointer(header) && forwarding_pointer_p(header)) /* Yep, so just copy the forwarding pointer. */ thing = header; else { /* Nope, copy the object. */ - switch (LowtagOf(thing)) { - case type_FunctionPointer: + switch (lowtag_of(thing)) { + case FUN_POINTER_LOWTAG: thing = ptrans_func(thing, header); break; - case type_ListPointer: + case LIST_POINTER_LOWTAG: thing = ptrans_list(thing, constant); break; - case type_InstancePointer: + case INSTANCE_POINTER_LOWTAG: thing = ptrans_instance(thing, header, constant); break; - case type_OtherPointer: + case OTHER_POINTER_LOWTAG: thing = ptrans_otherptr(thing, header, constant); break; @@ -1185,164 +1187,211 @@ static lispobj *pscav(lispobj *addr, int nwords, boolean constant) } count = 1; } - else if (thing & 3) { +#if N_WORD_BITS == 64 + else if (widetag_of(thing) == SINGLE_FLOAT_WIDETAG) { + count = 1; + } +#endif + else if (thing & FIXNUM_TAG_MASK) { /* It's an other immediate. Maybe the header for an unboxed */ /* object. */ - switch (TypeOf(thing)) { - case type_Bignum: - case type_SingleFloat: - case type_DoubleFloat: -#ifdef type_LongFloat - case type_LongFloat: -#endif - case type_Sap: + switch (widetag_of(thing)) { + case BIGNUM_WIDETAG: + case SINGLE_FLOAT_WIDETAG: + case DOUBLE_FLOAT_WIDETAG: +#ifdef LONG_FLOAT_WIDETAG + case LONG_FLOAT_WIDETAG: +#endif + case SAP_WIDETAG: /* It's an unboxed simple object. */ - count = HeaderValue(thing)+1; + count = CEILING(HeaderValue(thing)+1, 2); break; - case type_SimpleVector: - if (HeaderValue(thing) == subtype_VectorValidHashing) - *addr = (subtype_VectorMustRehash<length)+1,4)+2,2); + count = CEILING(NWORDS(fixnum_value(vector->length)+1,8)+2,2); break; - case type_SimpleBitVector: +#ifdef SIMPLE_CHARACTER_STRING_WIDETAG + case SIMPLE_CHARACTER_STRING_WIDETAG: vector = (struct vector *)addr; - count = CEILING(NWORDS(fixnum_value(vector->length),32)+2,2); + count = CEILING(NWORDS(fixnum_value(vector->length)+1,32)+2,2); break; +#endif - case type_SimpleArrayUnsignedByte2: + case SIMPLE_BIT_VECTOR_WIDETAG: vector = (struct vector *)addr; - count = CEILING(NWORDS(fixnum_value(vector->length),16)+2,2); + count = CEILING(NWORDS(fixnum_value(vector->length),1)+2,2); + break; + + case SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG: + vector = (struct vector *)addr; + count = CEILING(NWORDS(fixnum_value(vector->length),2)+2,2); break; - case type_SimpleArrayUnsignedByte4: + case SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG: + vector = (struct vector *)addr; + count = CEILING(NWORDS(fixnum_value(vector->length),4)+2,2); + break; + + case SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG: +#ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG + case SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG: + case SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG: +#endif vector = (struct vector *)addr; count = CEILING(NWORDS(fixnum_value(vector->length),8)+2,2); break; - case type_SimpleArrayUnsignedByte8: -#ifdef type_SimpleArraySignedByte8 - case type_SimpleArraySignedByte8: + case SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG: +#ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG + case SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG: + case SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG: #endif vector = (struct vector *)addr; - count = CEILING(NWORDS(fixnum_value(vector->length),4)+2,2); + count = CEILING(NWORDS(fixnum_value(vector->length),16)+2,2); break; - case type_SimpleArrayUnsignedByte16: -#ifdef type_SimpleArraySignedByte16 - case type_SimpleArraySignedByte16: + case SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG: +#ifdef SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG + case SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG: + case SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG: +#endif +#ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG + case SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG: + case SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG: #endif vector = (struct vector *)addr; - count = CEILING(NWORDS(fixnum_value(vector->length),2)+2,2); + count = CEILING(NWORDS(fixnum_value(vector->length),32)+2,2); break; - case type_SimpleArrayUnsignedByte32: -#ifdef type_SimpleArraySignedByte30 - case type_SimpleArraySignedByte30: +#if N_WORD_BITS == 64 + case SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG: +#ifdef SIMPLE_ARRAY_SIGNED_BYTE_61_WIDETAG + case SIMPLE_ARRAY_SIGNED_BYTE_61_WIDETAG: + case SIMPLE_ARRAY_UNSIGNED_BYTE_60_WIDETAG: #endif -#ifdef type_SimpleArraySignedByte32 - case type_SimpleArraySignedByte32: +#ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG + case SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG: + case SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG: #endif vector = (struct vector *)addr; - count = CEILING(fixnum_value(vector->length)+2,2); + count = CEILING(NWORDS(fixnum_value(vector->length),64)+2,2); break; +#endif - case type_SimpleArraySingleFloat: + case SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG: vector = (struct vector *)addr; - count = CEILING(fixnum_value(vector->length)+2,2); + count = CEILING(NWORDS(fixnum_value(vector->length), 32) + 2, + 2); break; - case type_SimpleArrayDoubleFloat: -#ifdef type_SimpleArrayComplexSingleFloat - case type_SimpleArrayComplexSingleFloat: + case SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG: +#ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG + case SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG: #endif vector = (struct vector *)addr; - count = fixnum_value(vector->length)*2+2; + count = CEILING(NWORDS(fixnum_value(vector->length), 64) + 2, + 2); break; -#ifdef type_SimpleArrayLongFloat - case type_SimpleArrayLongFloat: +#ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG + case SIMPLE_ARRAY_LONG_FLOAT_WIDETAG: vector = (struct vector *)addr; -#ifdef __i386__ +#ifdef LISP_FEATURE_X86 count = fixnum_value(vector->length)*3+2; #endif -#ifdef sparc +#ifdef LISP_FEATURE_SPARC count = fixnum_value(vector->length)*4+2; #endif break; #endif -#ifdef type_SimpleArrayComplexDoubleFloat - case type_SimpleArrayComplexDoubleFloat: +#ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG + case SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG: vector = (struct vector *)addr; - count = fixnum_value(vector->length)*4+2; + count = CEILING(NWORDS(fixnum_value(vector->length), 128) + 2, + 2); break; #endif -#ifdef type_SimpleArrayComplexLongFloat - case type_SimpleArrayComplexLongFloat: +#ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG + case SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG: vector = (struct vector *)addr; -#ifdef __i386__ +#ifdef LISP_FEATURE_X86 count = fixnum_value(vector->length)*6+2; #endif -#ifdef sparc +#ifdef LISP_FEATURE_SPARC count = fixnum_value(vector->length)*8+2; #endif break; #endif - case type_CodeHeader: -#ifndef __i386__ + case CODE_HEADER_WIDETAG: +#if !defined(LISP_FEATURE_X86) && !defined(LISP_FEATURE_X86_64) gc_abort(); /* no code headers in static space */ #else - count = pscav_code((struct code*)addr); + count = pscav_code((struct code*)addr); #endif break; - case type_FunctionHeader: - case type_ClosureFunctionHeader: - case type_ReturnPcHeader: + case SIMPLE_FUN_HEADER_WIDETAG: + case RETURN_PC_HEADER_WIDETAG: /* We should never hit any of these, 'cause they occur * buried in the middle of code objects. */ gc_abort(); - break; - -#ifdef __i386__ - case type_ClosureHeader: - case type_FuncallableInstanceHeader: - case type_ByteCodeFunction: - case type_ByteCodeClosure: - /* The function self pointer needs special care on the - * x86 because it is the real entry point. */ - { - lispobj fun = ((struct closure *)addr)->function - - RAW_ADDR_OFFSET; - pscav(&fun, 1, constant); - ((struct closure *)addr)->function = fun + RAW_ADDR_OFFSET; - } - count = 2; - break; -#endif - - case type_WeakPointer: + break; + +#if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64) + case CLOSURE_HEADER_WIDETAG: + /* The function self pointer needs special care on the + * x86 because it is the real entry point. */ + { + lispobj fun = ((struct closure *)addr)->fun + - FUN_RAW_ADDR_OFFSET; + pscav(&fun, 1, constant); + ((struct closure *)addr)->fun = fun + FUN_RAW_ADDR_OFFSET; + } + count = 2; + break; +#endif + + case WEAK_POINTER_WIDETAG: /* Weak pointers get preserved during purify, 'cause I - * don't feel like figuring out how to break them. */ + * don't feel like figuring out how to break them. */ pscav(addr+1, 2, constant); count = 4; break; - case type_Fdefn: - /* We have to handle fdefn objects specially, so we - * can fix up the raw function address. */ - count = pscav_fdefn((struct fdefn *)addr); - break; + case FDEFN_WIDETAG: + /* We have to handle fdefn objects specially, so we + * can fix up the raw function address. */ + count = pscav_fdefn((struct fdefn *)addr); + break; + + case INSTANCE_HEADER_WIDETAG: + { + struct instance *instance = (struct instance *) addr; + struct layout *layout + = (struct layout *) native_pointer(instance->slots[0]); + long nuntagged = fixnum_value(layout->n_untagged_slots); + long nslots = HeaderValue(*addr); + pscav(addr + 1, nslots - nuntagged, constant); + count = CEILING(1 + nslots, 2); + } + break; default: count = 1; @@ -1361,44 +1410,66 @@ static lispobj *pscav(lispobj *addr, int nwords, boolean constant) return addr; } -int purify(lispobj static_roots, lispobj read_only_roots) +int +purify(lispobj static_roots, lispobj read_only_roots) { lispobj *clean; - int count, i; + long count, i; struct later *laters, *next; + struct thread *thread; + + if(all_threads->next) { + /* FIXME: there should be _some_ sensible error reporting + * convention. See following comment too */ + fprintf(stderr,"Can't purify when more than one thread exists\n"); + fflush(stderr); + return 0; + } #ifdef PRINTNOISE printf("[doing purification:"); fflush(stdout); #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 - * of stderr. */ +#ifdef LISP_FEATURE_GENCGC + gc_alloc_update_all_page_tables(); +#endif + for_each_thread(thread) + if (fixnum_value(SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX,thread)) != 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 + * of stderr. */ printf(" Ack! Can't purify interrupt contexts. "); fflush(stdout); return 0; } -#if defined(ibmrt) || defined(__i386__) - current_dynamic_space_free_pointer = - (lispobj*)SymbolValue(ALLOCATION_POINTER); +#if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64) + dynamic_space_purify_pointer = + (lispobj*)SymbolValue(ALLOCATION_POINTER,0); +#else +#if defined(LISP_FEATURE_GENCGC) + dynamic_space_purify_pointer = get_alloc_pointer(); +#else + dynamic_space_purify_pointer = dynamic_space_free_pointer; +#endif #endif read_only_end = read_only_free = - (lispobj *)SymbolValue(READ_ONLY_SPACE_FREE_POINTER); + (lispobj *)SymbolValue(READ_ONLY_SPACE_FREE_POINTER,0); static_end = static_free = - (lispobj *)SymbolValue(STATIC_SPACE_FREE_POINTER); + (lispobj *)SymbolValue(STATIC_SPACE_FREE_POINTER,0); #ifdef PRINTNOISE printf(" roots"); fflush(stdout); #endif -#ifdef GENCGC - gc_assert(control_stack_end > ((&read_only_roots)+1)); - setup_i386_stack_scav(((&static_roots)-2), control_stack_end); +#if defined(LISP_FEATURE_GENCGC) && (defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)) + /* note this expects only one thread to be active. We'd have to + * stop all the others in the same way as GC does if we wanted + * PURIFY to work when >1 thread exists */ + setup_i386_stack_scav(((&static_roots)-2), + ((void *)all_threads->control_stack_end)); #endif pscav(&static_roots, 1, 0); @@ -1416,37 +1487,60 @@ int purify(lispobj static_roots, lispobj read_only_roots) printf(" stack"); fflush(stdout); #endif -#ifndef __i386__ - pscav(control_stack, current_control_stack_pointer - control_stack, 0); +#if !defined(LISP_FEATURE_X86) && !defined(LISP_FEATURE_X86_64) + pscav((lispobj *)all_threads->control_stack_start, + current_control_stack_pointer - + all_threads->control_stack_start, + 0); #else -#ifdef GENCGC +#ifdef LISP_FEATURE_GENCGC pscav_i386_stack(); #endif -#ifdef WANT_CGC - gc_assert(control_stack_end > ((&read_only_roots)+1)); - carefully_pscav_stack(((&read_only_roots)+1), control_stack_end); -#endif #endif #ifdef PRINTNOISE printf(" bindings"); fflush(stdout); #endif -#if !defined(ibmrt) && !defined(__i386__) - pscav(binding_stack, current_binding_stack_pointer - binding_stack, 0); +#if !(defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)) + pscav( (lispobj *)all_threads->binding_stack_start, + (lispobj *)current_binding_stack_pointer - + all_threads->binding_stack_start, + 0); #else - pscav(binding_stack, (lispobj *)SymbolValue(BINDING_STACK_POINTER) - binding_stack, 0); + for_each_thread(thread) { + pscav( (lispobj *)thread->binding_stack_start, + (lispobj *)SymbolValue(BINDING_STACK_POINTER,thread) - + (lispobj *)thread->binding_stack_start, + 0); +#ifdef LISP_FEATURE_SB_THREAD + pscav( (lispobj *) (thread+1), + fixnum_value(SymbolValue(FREE_TLS_INDEX,0)) - + (sizeof (struct thread))/(sizeof (lispobj)), + 0); +#endif + } + + #endif -#ifdef SCAVENGE_READ_ONLY_SPACE - if (SymbolValue(SCAVENGE_READ_ONLY_SPACE) != type_UnboundMarker - && SymbolValue(SCAVENGE_READ_ONLY_SPACE) != NIL) { + /* The original CMU CL code had scavenge-read-only-space code + * controlled by the Lisp-level variable + * *SCAVENGE-READ-ONLY-SPACE*. It was disabled by default, and it + * wasn't documented under what circumstances it was useful or + * safe to turn it on, so it's been turned off in SBCL. If you + * want/need this functionality, and can test and document it, + * please submit a patch. */ +#if 0 + if (SymbolValue(SCAVENGE_READ_ONLY_SPACE) != UNBOUND_MARKER_WIDETAG + && SymbolValue(SCAVENGE_READ_ONLY_SPACE) != NIL) { unsigned read_only_space_size = - (lispobj *)SymbolValue(READ_ONLY_SPACE_FREE_POINTER) - read_only_space; + (lispobj *)SymbolValue(READ_ONLY_SPACE_FREE_POINTER) - + (lispobj *)READ_ONLY_SPACE_START; fprintf(stderr, - "scavenging read only space: %d bytes\n", - read_only_space_size * sizeof(lispobj)); - pscav(read_only_space, read_only_space_size, 0); + "scavenging read only space: %d bytes\n", + read_only_space_size * sizeof(lispobj)); + pscav( (lispobj *)READ_ONLY_SPACE_START, read_only_space_size, 0); } #endif @@ -1454,7 +1548,7 @@ int purify(lispobj static_roots, lispobj read_only_roots) printf(" static"); fflush(stdout); #endif - clean = static_space; + clean = (lispobj *)STATIC_SPACE_START; do { while (clean != static_free) clean = pscav(clean, static_free - clean, 0); @@ -1471,7 +1565,7 @@ int purify(lispobj static_roots, lispobj read_only_roots) i++; } else { pscav(laters->u[i].ptr, 1, 1); - } + } } next = laters->next; free(laters); @@ -1485,69 +1579,37 @@ int purify(lispobj static_roots, lispobj read_only_roots) fflush(stdout); #endif -#if defined(WANT_CGC) && defined(X86_CGC_ACTIVE_P) - if(SymbolValue(X86_CGC_ACTIVE_P) != T) - os_zero((os_vm_address_t) current_dynamic_space, - (os_vm_size_t) DYNAMIC_SPACE_SIZE); -#else os_zero((os_vm_address_t) current_dynamic_space, - (os_vm_size_t) DYNAMIC_SPACE_SIZE); -#endif + (os_vm_size_t) dynamic_space_size); /* Zero the stack. Note that the stack is also zeroed by SUB-GC * calling SCRUB-CONTROL-STACK - this zeros the stack on the x86. */ -#ifndef __i386__ +#if !defined(LISP_FEATURE_X86) && !defined(LISP_FEATURE_X86_64) os_zero((os_vm_address_t) current_control_stack_pointer, - (os_vm_size_t) (CONTROL_STACK_SIZE - - ((current_control_stack_pointer - control_stack) * - sizeof(lispobj)))); -#endif - -#if defined(WANT_CGC) && defined(STATIC_BLUE_BAG) - { - lispobj bag = SymbolValue(STATIC_BLUE_BAG); - struct cons*cons = (struct cons*)static_free; - struct cons*pair = cons + 1; - static_free += 2*WORDS_PER_CONS; - if(bag == type_UnboundMarker) - bag = NIL; - cons->cdr = bag; - cons->car = (lispobj)pair | type_ListPointer; - pair->car = (lispobj)static_end; - pair->cdr = (lispobj)static_free; - bag = (lispobj)cons | type_ListPointer; - SetSymbolValue(STATIC_BLUE_BAG, bag); - } + (os_vm_size_t) + ((all_threads->control_stack_end - + current_control_stack_pointer) * sizeof(lispobj))); #endif /* It helps to update the heap free pointers so that free_heap can * verify after it's done. */ - SetSymbolValue(READ_ONLY_SPACE_FREE_POINTER, (lispobj)read_only_free); - SetSymbolValue(STATIC_SPACE_FREE_POINTER, (lispobj)static_free); + SetSymbolValue(READ_ONLY_SPACE_FREE_POINTER, (lispobj)read_only_free,0); + SetSymbolValue(STATIC_SPACE_FREE_POINTER, (lispobj)static_free,0); -#if !defined(ibmrt) && !defined(__i386__) - current_dynamic_space_free_pointer = current_dynamic_space; -#else -#if defined(WANT_CGC) && defined(X86_CGC_ACTIVE_P) - /* X86 using CGC */ - if(SymbolValue(X86_CGC_ACTIVE_P) != T) - SetSymbolValue(ALLOCATION_POINTER, (lispobj)current_dynamic_space); - else - cgc_free_heap(); -#else -#if defined GENCGC +#if defined LISP_FEATURE_GENCGC gc_free_heap(); #else - /* ibmrt using GC */ - SetSymbolValue(ALLOCATION_POINTER, (lispobj)current_dynamic_space); -#endif -#endif + dynamic_space_free_pointer = current_dynamic_space; + set_auto_gc_trigger(bytes_consed_between_gcs); #endif + /* Blast away instruction cache */ + os_flush_icache((os_vm_address_t)READ_ONLY_SPACE_START, READ_ONLY_SPACE_SIZE); + os_flush_icache((os_vm_address_t)STATIC_SPACE_START, STATIC_SPACE_SIZE); + #ifdef PRINTNOISE printf(" done]\n"); fflush(stdout); #endif - return 0; }