X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fruntime%2Fpurify.c;h=c7060857b4ccababb49be8e4328f49137c7e4184;hb=81cfdf526490d642c73602ebac9bcacb8af644e1;hp=8a9591f99d268bc61ab4f09dc672a31562ce45b1;hpb=d7f6139a91d7d9b0667a597584ae306d958bb2f4;p=sbcl.git diff --git a/src/runtime/purify.c b/src/runtime/purify.c index 8a9591f..c706085 100644 --- a/src/runtime/purify.c +++ b/src/runtime/purify.c @@ -31,7 +31,7 @@ #define PRINTNOISE -#if defined(ibmrt) || defined(__i386__) +#if defined(__i386__) /* again, what's so special about the x86 that this is differently * visible there than on other platforms? -dan 20010125 */ @@ -62,7 +62,8 @@ static lispobj *pscav(lispobj *addr, int nwords, boolean constant); #define LATERBLOCKSIZE 1020 #define LATERMAXCOUNT 10 -static struct later { +static struct +later { struct later *next; union { lispobj *ptr; @@ -111,110 +112,9 @@ dynamic_pointer_p(lispobj ptr) #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) -{ - 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++; - } -} -#endif - #ifdef 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: @@ -225,210 +125,221 @@ carefully_pscav_stack(lispobj*lowaddr, lispobj*base) static unsigned pointer_filter_verbose = 0; +/* FIXME: This is substantially the same code as in gencgc.c. (There + * are some differences, at least (1) the gencgc.c code needs to worry + * about return addresses on the stack pinning code objects, (2) the + * gencgc.c code needs to worry about the GC maybe happening in an + * interrupt service routine when the main thread of control was + * interrupted just as it had allocated memory and before it + * initialized it, while PURIFY needn't worry about that, and (3) the + * gencgc.c code has mutated more under maintenance since the fork + * from CMU CL than the code here has.) The two versions should be + * made to explicitly share common code, instead of just two different + * cut-and-pasted versions. */ 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", (unsigned int) pointer, - (unsigned int) start_addr, *start_addr); + /* 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", (unsigned int) pointer, + (unsigned int) start_addr, *start_addr); + } + return 0; + } + break; + default: + if (pointer_filter_verbose) { + fprintf(stderr,"*Wf3: %x %x %x\n", (unsigned int) pointer, + (unsigned int) start_addr, *start_addr); + } + return 0; } - return 0; - } - break; - default: - if (pointer_filter_verbose) { - fprintf(stderr,"*Wf3: %x %x %x\n", (unsigned int) pointer, - (unsigned int) 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", (unsigned int) pointer, - (unsigned int) start_addr, *start_addr); - return 0; - } - /* Is it a 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", (unsigned int) pointer, - (unsigned int) 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", (unsigned int) pointer, - (unsigned int) start_addr, *start_addr); - } - return 0; - } - if (TypeOf(start_addr[0]) != type_InstanceHeader) { - if (pointer_filter_verbose) { - fprintf(stderr,"*Wi2: %x %x %x\n", (unsigned int) pointer, - (unsigned int) 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", (unsigned int) pointer, - (unsigned int) 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", (unsigned int) pointer, - (unsigned int) 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", (unsigned int) pointer, - (unsigned int) 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", (unsigned int) pointer, - (unsigned int) start_addr, *start_addr); - } - return 0; - - case type_InstanceHeader: - if (pointer_filter_verbose) { - fprintf(stderr,"*Wo5: %x %x %x\n", (unsigned int) pointer, - (unsigned int) start_addr, *start_addr); - } - return 0; - - /* the valid other immediate pointer objects */ - case type_SimpleVector: - case type_Ratio: - case type_Complex: + break; + case type_ListPointer: + if ((int)pointer != ((int)start_addr+type_ListPointer)) { + if (pointer_filter_verbose) + fprintf(stderr,"*Wl1: %x %x %x\n", (unsigned int) pointer, + (unsigned int) start_addr, *start_addr); + return 0; + } + /* Is it plausible cons? */ + if((is_lisp_pointer(start_addr[0]) + || ((start_addr[0] & 3) == 0) /* fixnum */ + || (TypeOf(start_addr[0]) == type_BaseChar) + || (TypeOf(start_addr[0]) == type_UnboundMarker)) + && (is_lisp_pointer(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", (unsigned int) pointer, + (unsigned int) 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", (unsigned int) pointer, + (unsigned int) start_addr, *start_addr); + } + return 0; + } + if (TypeOf(start_addr[0]) != type_InstanceHeader) { + if (pointer_filter_verbose) { + fprintf(stderr,"*Wi2: %x %x %x\n", (unsigned int) pointer, + (unsigned int) 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", (unsigned int) pointer, + (unsigned int) start_addr, *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)) { + if (pointer_filter_verbose) { + fprintf(stderr,"*Wo2: %x %x %x\n", (unsigned int) pointer, + (unsigned int) 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", (unsigned int) pointer, + (unsigned int) 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", (unsigned int) pointer, + (unsigned int) start_addr, *start_addr); + } + return 0; + + case type_InstanceHeader: + if (pointer_filter_verbose) { + fprintf(stderr,"*Wo5: %x %x %x\n", (unsigned int) pointer, + (unsigned int) 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: + case type_ComplexSingleFloat: #endif #ifdef type_ComplexDoubleFloat - case 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: + 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: + 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: + case type_SimpleArraySignedByte8: #endif #ifdef type_SimpleArraySignedByte16 - case type_SimpleArraySignedByte16: + case type_SimpleArraySignedByte16: #endif #ifdef type_SimpleArraySignedByte30 - case type_SimpleArraySignedByte30: + case type_SimpleArraySignedByte30: #endif #ifdef type_SimpleArraySignedByte32 - case type_SimpleArraySignedByte32: + case type_SimpleArraySignedByte32: #endif - case type_SimpleArraySingleFloat: - case type_SimpleArrayDoubleFloat: + case type_SimpleArraySingleFloat: + case type_SimpleArrayDoubleFloat: #ifdef type_SimpleArrayLongFloat - case type_SimpleArrayLongFloat: + case type_SimpleArrayLongFloat: #endif #ifdef type_SimpleArrayComplexSingleFloat - case type_SimpleArrayComplexSingleFloat: + case type_SimpleArrayComplexSingleFloat: #endif #ifdef type_SimpleArrayComplexDoubleFloat - case type_SimpleArrayComplexDoubleFloat: + case type_SimpleArrayComplexDoubleFloat: #endif #ifdef type_SimpleArrayComplexLongFloat - case type_SimpleArrayComplexLongFloat: + case type_SimpleArrayComplexLongFloat: #endif - case type_Sap: - case type_WeakPointer: - break; + case type_Sap: + case type_WeakPointer: + break; + default: + if (pointer_filter_verbose) { + fprintf(stderr,"*Wo6: %x %x %x\n", (unsigned int) pointer, + (unsigned int) start_addr, *start_addr); + } + return 0; + } + break; default: - if (pointer_filter_verbose) { - fprintf(stderr,"*Wo6: %x %x %x\n", (unsigned int) pointer, - (unsigned int) start_addr, *start_addr); - } - return 0; - } - break; - default: - if (pointer_filter_verbose) { - fprintf(stderr,"*W?: %x %x %x\n", (unsigned int) pointer, - (unsigned int) start_addr, *start_addr); + if (pointer_filter_verbose) { + fprintf(stderr,"*W?: %x %x %x\n", (unsigned int) pointer, + (unsigned int) start_addr, *start_addr); + } + return 0; } - return 0; - } - /* looks good */ - return 1; + /* looks good */ + return 1; } #define MAX_STACK_POINTERS 256 @@ -542,7 +453,7 @@ ptrans_boxed(lispobj thing, lispobj header, boolean constant) nwords = 1 + HeaderValue(header); /* Allocate it */ - old = (lispobj *)PTR(thing); + old = (lispobj *)native_pointer(thing); if (constant) { new = read_only_free; read_only_free += CEILING(nwords, 2); @@ -571,8 +482,8 @@ ptrans_boxed(lispobj thing, lispobj header, boolean constant) static lispobj ptrans_instance(lispobj thing, lispobj header, boolean constant) { - lispobj layout = ((struct instance *)PTR(thing))->slots[0]; - lispobj pure = ((struct instance *)PTR(layout))->slots[15]; + lispobj layout = ((struct instance *)native_pointer(thing))->slots[0]; + lispobj pure = ((struct instance *)native_pointer(layout))->slots[15]; switch (pure) { case T: @@ -581,17 +492,18 @@ ptrans_instance(lispobj thing, lispobj header, boolean constant) 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. */ + /* 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; nwords = 1 + HeaderValue(header); /* Allocate it */ - old = (lispobj *)PTR(thing); + old = (lispobj *)native_pointer(thing); new = static_free; static_free += CEILING(nwords, 2); @@ -623,7 +535,7 @@ ptrans_fdefn(lispobj thing, lispobj header) nwords = 1 + HeaderValue(header); /* Allocate it */ - old = (lispobj *)PTR(thing); + old = (lispobj *)native_pointer(thing); new = static_free; static_free += CEILING(nwords, 2); @@ -653,7 +565,7 @@ ptrans_unboxed(lispobj thing, lispobj header) nwords = 1 + HeaderValue(header); /* Allocate it */ - old = (lispobj *)PTR(thing); + old = (lispobj *)native_pointer(thing); new = read_only_free; read_only_free += CEILING(nwords, 2); @@ -675,7 +587,7 @@ ptrans_vector(lispobj thing, int bits, int extra, int nwords; lispobj result, *new; - vector = (struct vector *)PTR(thing); + vector = (struct vector *)native_pointer(thing); nwords = 2 + (CEILING((fixnum_value(vector->length)+extra)*bits,32)>>5); if (boxed && !constant) { @@ -730,7 +642,9 @@ apply_code_fixups_during_purify(struct code *old_code, struct code *new_code) /* 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)) { + if ((fixups==0) || + (fixups==type_UnboundMarker) || + !is_lisp_pointer(fixups)) { #ifdef GENCGC /* Check for a possible errors. */ sniff_code_object(new_code,displacement); @@ -738,13 +652,13 @@ apply_code_fixups_during_purify(struct code *old_code, struct code *new_code) return; } - fixups_vector = (struct vector *)PTR(fixups); + fixups_vector = (struct vector *)native_pointer(fixups); /* Could be pointing to a forwarding pointer. */ - if (Pointerp(fixups) && (dynamic_pointer_p(fixups)) + if (is_lisp_pointer(fixups) && (dynamic_pointer_p(fixups)) && forwarding_pointer_p(*(lispobj *)fixups_vector)) { /* If so then follow it. */ - fixups_vector = (struct vector *)PTR(*(lispobj *)fixups_vector); + fixups_vector = (struct vector *)native_pointer(*(lispobj *)fixups_vector); } if (TypeOf(fixups_vector->header) == type_SimpleArrayUnsignedByte32) { @@ -790,7 +704,7 @@ ptrans_code(lispobj thing) int nwords; lispobj func, result; - code = (struct code *)PTR(thing); + code = (struct code *)native_pointer(thing); nwords = HeaderValue(code->header) + fixnum_value(code->code_size); new = (struct code *)read_only_free; @@ -810,11 +724,11 @@ 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 function *)native_pointer(func))->next) { gc_assert(LowtagOf(func) == type_FunctionPointer); - *(lispobj *)PTR(func) = result + (func - thing); + *(lispobj *)native_pointer(func) = result + (func - thing); } /* Arrange to scavenge the debug info later. */ @@ -834,20 +748,20 @@ ptrans_code(lispobj thing) pscav(&new->entry_points, 1, 1); for (func = new->entry_points; func != NIL; - func = ((struct function *)PTR(func))->next) { + func = ((struct function *)native_pointer(func))->next) { gc_assert(LowtagOf(func) == type_FunctionPointer); 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; + ((struct function *)native_pointer(func))->self -= RAW_ADDR_OFFSET; #endif - pscav(&((struct function *)PTR(func))->self, 2, 1); + pscav(&((struct function *)native_pointer(func))->self, 2, 1); #ifdef __i386__ - ((struct function *)PTR(func))->self += RAW_ADDR_OFFSET; + ((struct function *)native_pointer(func))->self += RAW_ADDR_OFFSET; #endif - pscav_later(&((struct function *)PTR(func))->name, 3); + pscav_later(&((struct function *)native_pointer(func))->name, 3); } return result; @@ -873,8 +787,10 @@ ptrans_func(lispobj thing, lispobj header) * 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))) | + function = (struct function *)native_pointer(thing); + code = + (native_pointer(thing) - + (HeaderValue(function->header)*sizeof(lispobj))) | type_OtherPointer; /* This will cause the function's header to be replaced with a @@ -887,7 +803,7 @@ ptrans_func(lispobj thing, lispobj header) else { /* It's some kind of closure-like thing. */ nwords = 1 + HeaderValue(header); - old = (lispobj *)PTR(thing); + old = (lispobj *)native_pointer(thing); /* Allocate the new one. */ if (TypeOf(header) == type_FuncallableInstanceHeader) { @@ -925,7 +841,7 @@ 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); @@ -949,7 +865,7 @@ ptrans_list(lispobj thing, boolean constant) do { /* Allocate a new cons cell. */ - old = (struct cons *)PTR(thing); + old = (struct cons *)native_pointer(thing); if (constant) { new = (struct cons *)read_only_free; read_only_free += WORDS_PER_CONS; @@ -970,7 +886,7 @@ ptrans_list(lispobj thing, boolean constant) length++; } while (LowtagOf(thing) == type_ListPointer && 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); @@ -1148,20 +1064,20 @@ pscav_code(struct code*code) pscav(&code->entry_points, 1, 1); for (func = code->entry_points; func != NIL; - func = ((struct function *)PTR(func))->next) { + func = ((struct function *)native_pointer(func))->next) { gc_assert(LowtagOf(func) == type_FunctionPointer); 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; + ((struct function *)native_pointer(func))->self -= RAW_ADDR_OFFSET; #endif - pscav(&((struct function *)PTR(func))->self, 2, 1); + pscav(&((struct function *)native_pointer(func))->self, 2, 1); #ifdef __i386__ - ((struct function *)PTR(func))->self += RAW_ADDR_OFFSET; + ((struct function *)native_pointer(func))->self += RAW_ADDR_OFFSET; #endif - pscav_later(&((struct function *)PTR(func))->name, 3); + pscav_later(&((struct function *)native_pointer(func))->name, 3); } return CEILING(nwords,2); @@ -1177,13 +1093,13 @@ pscav(lispobj *addr, int nwords, boolean constant) 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 { @@ -1411,7 +1327,7 @@ purify(lispobj static_roots, lispobj read_only_roots) return 0; } -#if defined(ibmrt) || defined(__i386__) +#if defined(__i386__) dynamic_space_free_pointer = (lispobj*)SymbolValue(ALLOCATION_POINTER); #endif @@ -1454,21 +1370,15 @@ purify(lispobj static_roots, lispobj read_only_roots) #ifdef GENCGC pscav_i386_stack(); #endif -#ifdef WANT_CGC - gc_assert((lispobj *)control_stack_end > ((&read_only_roots)+1)); - carefully_pscav_stack(((&read_only_roots)+1), - (lispobj *)CONTROL_STACK_END); -#endif #endif #ifdef PRINTNOISE printf(" bindings"); fflush(stdout); #endif -#if !defined(ibmrt) && !defined(__i386__) - pscav((lispobj *)BINDING_STACK_START, - (lispobj *)current_binding_stack_pointer - - (lispobj *)BINDING_STACK_START, +#if !defined(__i386__) + pscav( (lispobj *)BINDING_STACK_START, + (lispobj *)current_binding_stack_pointer - (lispobj *)BINDING_STACK_START, 0); #else pscav( (lispobj *)BINDING_STACK_START, @@ -1477,16 +1387,23 @@ purify(lispobj static_roots, lispobj read_only_roots) 0); #endif -#ifdef SCAVENGE_READ_ONLY_SPACE + /* 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) != type_UnboundMarker && SymbolValue(SCAVENGE_READ_ONLY_SPACE) != NIL) { - unsigned read_only_space_size = - (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( (lispobj *)READ_ONLY_SPACE_START, read_only_space_size, 0); + unsigned read_only_space_size = + (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( (lispobj *)READ_ONLY_SPACE_START, read_only_space_size, 0); } #endif @@ -1525,15 +1442,8 @@ 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) DYNAMIC_SPACE_START, - (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 /* Zero the stack. Note that the stack is also zeroed by SUB-GC * calling SCRUB-CONTROL-STACK - this zeros the stack on the x86. */ @@ -1545,44 +1455,18 @@ purify(lispobj static_roots, lispobj read_only_roots) 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); - } -#endif - - /* It helps to update the heap free pointers so that free_heap() - * can verify after it's done. */ + /* 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); -#if !defined(ibmrt) && !defined(__i386__) +#if !defined(__i386__) 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)DYNAMIC_SPACE_START); - else - cgc_free_heap(); -#else -#if defined(GENCGC) +#if defined GENCGC gc_free_heap(); #else - /* ibmrt using GC */ - SetSymbolValue(ALLOCATION_POINTER, (lispobj)DYNAMIC_SPACE_START); -#endif +#error unsupported case /* in CMU CL, was "ibmrt using GC" */ #endif #endif