diff --git a/lisp/purify.c b/lisp/purify.c index 1553e6551e972e08f270a4699de1cffdf43e89fc..563ac4c69a249fe827bb28fc1e2986dfdf531df8 100644 --- a/lisp/purify.c +++ b/lisp/purify.c @@ -1,11 +1,18 @@ -/* Purify. */ +/* Purify. -/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/purify.c,v 1.11 1997/11/01 22:58:04 dtc Exp $ */ + This code is based on public domain codes from CMUCL. It is placed + in the public domain and is provided as-is. -/* This file has been hacked a bunch by Werkowski as part of - * the x86 port. Stack direction changes as well as more conservative - * decisions about pointers. - */ + Stack direction changes, more conservative decisions about pointers + (carefully_pscave_stack), and static blue bag feature, by Paul + Werkowski, 1995, 1996. + + Bug fixes, x86 code movement support, and scavenger hook support, + by Douglas Crosher, 1996, 1997. + + $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/purify.c,v 1.12 1997/11/08 15:44:38 dtc Exp $ + + */ #include <stdio.h> #include <sys/types.h> #include <stdlib.h> @@ -18,6 +25,9 @@ #include "interrupt.h" #include "purify.h" #include "interr.h" +#ifdef GENCGC +#include "gencgc.h" +#endif #undef PRINTNOISE @@ -131,6 +141,12 @@ maybe_can_move_p(lispobj thing) #endif case type_SimpleArraySingleFloat: case type_SimpleArrayDoubleFloat: +#ifdef type_SimpleArrayComplexSingleFloat + case type_SimpleArrayComplexSingleFloat: +#endif +#ifdef type_SimpleArrayComplexDoubleFloat + case type_SimpleArrayComplexDoubleFloat: +#endif case type_CodeHeader: case type_FunctionHeader: case type_ClosureFunctionHeader: @@ -144,8 +160,11 @@ maybe_can_move_p(lispobj thing) case type_DylanFunctionHeader: case type_WeakPointer: case type_Fdefn: +#ifdef type_ScavengerHook + case type_ScavengerHook: return kind; break; +#endif default: return 0; }}} @@ -361,6 +380,91 @@ static lispobj ptrans_vector(lispobj thing, int bits, int extra, return result; } +#ifdef i386 +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) { + /* 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; i<length; i++) { + unsigned offset = fixups_vector->data[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; + } + } + + /* No longer need the fixups. */ + new_code->constants[0] = 0; + +#ifdef GENCGC + /* Check for possible errors. */ + sniff_code_object(new_code,displacement); +#endif +} +#endif static lispobj ptrans_code(lispobj thing) { @@ -371,19 +475,15 @@ static lispobj ptrans_code(lispobj thing) code = (struct code *)PTR(thing); nwords = HeaderValue(code->header) + fixnum_value(code->code_size); -#if defined(i386) - /* Moving machine code around does not work on the x86 port, but - byte compiled function code blocks can be moved. Perhaps for - all byte compiled code blocks the entry_points slot is nil. - Check and print a warning. */ - if ( (code->entry_points) != NIL ) - fprintf(stderr,"** ptrans_code(%x)\n",thing); -#endif new = (struct code *)read_only_free; read_only_free += CEILING(nwords, 2); bcopy(code, new, nwords * sizeof(lispobj)); - + +#ifdef i386 + apply_code_fixups_during_purify(code,new); +#endif + result = (lispobj)new | type_OtherPointer; /* Stick in a forwarding pointer for the code object. */ @@ -419,7 +519,16 @@ static lispobj ptrans_code(lispobj thing) func = ((struct function *)PTR(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; +#endif pscav(&((struct function *)PTR(func))->self, 2, TRUE); +#ifdef i386 + ((struct function *)PTR(func))->self += RAW_ADDR_OFFSET; +#endif pscav_later(&((struct function *)PTR(func))->name, 3); } @@ -441,10 +550,6 @@ static lispobj ptrans_func(lispobj thing, lispobj header) if (TypeOf(header) == type_FunctionHeader || TypeOf(header) == type_ClosureFunctionHeader) { -#if defined(i386) - /* Moving code around is not good on the x86 port; print a warning. */ - fprintf(stderr,"ptrans_function(%x, %x)\n",thing,header); -#endif /* 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. */ @@ -574,10 +679,13 @@ static lispobj ptrans_otherptr(lispobj thing, lispobj header, boolean constant) case type_ComplexVector: case type_ComplexArray: return ptrans_boxed(thing, header, constant); - + case type_ValueCellHeader: case type_WeakPointer: +#ifdef type_ScavengerHook + case type_ScavengerHook: return ptrans_boxed(thing, header, FALSE); +#endif case type_SymbolHeader: return ptrans_boxed(thing, header, FALSE); @@ -670,7 +778,6 @@ pscav_code(struct code*code) 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 @@ -698,13 +805,47 @@ pscav_code(struct code*code) func = ((struct function *)PTR(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; +#endif pscav(&((struct function *)PTR(func))->self, 2, TRUE); +#ifdef i386 + ((struct function *)PTR(func))->self += RAW_ADDR_OFFSET; +#endif pscav_later(&((struct function *)PTR(func))->name, 3); } return CEILING(nwords,2); } +#endif + +#ifdef type_ScavengerHook +static struct scavenger_hook *scavenger_hooks=NIL; + +static int pscav_scavenger_hook(struct scavenger_hook *scav_hook) +{ + lispobj *old_value = scav_hook->value; + + /* Scavenge the value */ + pscav((lispobj *)scav_hook+1, 1, FALSE); + + /* Did the value object move? */ + if (scav_hook->value != old_value) { + /* Check if this hook is already noted. */ + if (scav_hook->next == NULL) { + scav_hook->next = scavenger_hooks; + scavenger_hooks = (int)scav_hook | type_OtherPointer; + } + } + + /* Scavenge the function */ + pscav((lispobj *)scav_hook+2, 1, FALSE); + return 4; +} #endif static lispobj *pscav(lispobj *addr, int nwords, boolean constant) @@ -824,10 +965,20 @@ static lispobj *pscav(lispobj *addr, int nwords, boolean constant) break; case type_SimpleArrayDoubleFloat: +#ifdef type_SimpleArrayComplexSingleFloat + case type_SimpleArrayComplexSingleFloat: +#endif vector = (struct vector *)addr; count = fixnum_value(vector->length)*2+2; break; +#ifdef type_SimpleArrayComplexDoubleFloat + case type_SimpleArrayComplexDoubleFloat: + vector = (struct vector *)addr; + count = fixnum_value(vector->length)*4+2; + break; +#endif + case type_CodeHeader: #ifndef i386 gc_abort(); /* No code headers in static space */ @@ -853,14 +1004,15 @@ static lispobj *pscav(lispobj *addr, int nwords, boolean constant) case type_ByteCodeFunction: case type_ByteCodeClosure: case type_DylanFunctionHeader: - /* 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); - } - count = 2; + /* 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 @@ -877,6 +1029,12 @@ static lispobj *pscav(lispobj *addr, int nwords, boolean constant) count = pscav_fdefn((struct fdefn *)addr); break; +#ifdef type_ScavengerHook + case type_ScavengerHook: + count = pscav_scavenger_hook((struct scavenger_hook *)addr); + break; +#endif + default: count = 1; break; @@ -957,6 +1115,17 @@ int purify(lispobj static_roots, lispobj read_only_roots) pscav(binding_stack, (lispobj *)SymbolValue(BINDING_STACK_POINTER) - binding_stack, FALSE); #endif +#ifdef SCAVENGE_READ_ONLY_SPACE + 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) - read_only_space; + fprintf(stderr,"Scavenge read only space: %d bytes\n", + read_only_space_size * sizeof(lispobj)); + pscav(read_only_space, read_only_space_size, FALSE); + } +#endif + #ifdef PRINTNOISE printf(" static"); fflush(stdout); @@ -988,15 +1157,13 @@ int purify(lispobj static_roots, lispobj read_only_roots) } while (clean != static_free || later_blocks != NULL); + #ifdef PRINTNOISE printf(" cleanup"); fflush(stdout); #endif -/* well, something seems messed up in FreeBSD VM, hacking to resolve it. - * Nope -- problem was 'auto-gc-trigger' mprotecting pages in background. - */ -#if defined X86_CGC_ACTIVE_P +#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); @@ -1004,20 +1171,17 @@ int purify(lispobj static_roots, lispobj read_only_roots) os_zero((os_vm_address_t) current_dynamic_space, (os_vm_size_t) DYNAMIC_SPACE_SIZE); #endif - /* Zero stack. */ + + /* Zero stack. Note the stack is also zeroed by sub-gc calling + scrub-control-stack - this zeros the stack on the x86. */ #ifndef i386 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)))); -#else - /* os_zero won't work cause it things the junk is above the - * start address where here it is below. I don't see why we want - * to zero stuff anyhow. - */ #endif -#if defined STATIC_BLUE_BAG +#if defined(WANT_CGC) && defined(STATIC_BLUE_BAG) { lispobj bag = SymbolValue(STATIC_BLUE_BAG); struct cons*cons = (struct cons*)static_free; @@ -1038,23 +1202,40 @@ int purify(lispobj static_roots, lispobj read_only_roots) 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) - /* normal case for most ports */ current_dynamic_space_free_pointer = current_dynamic_space; #else -#if defined X86_CGC_ACTIVE_P +#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 - /* ibmrt or X86 using GC */ +#if defined GENCGC + gc_free_heap(); +#else + /* ibmrt using GC */ SetSymbolValue(ALLOCATION_POINTER, (lispobj)current_dynamic_space); #endif #endif +#endif +#ifdef type_ScavengerHook + /* Call the scavenger hook functions */ + { + struct scavenger_hook *sh; + for (sh=PTR((int)scavenger_hooks); sh!=PTR(NIL);) { + struct scavenger_hook *sh_next = PTR((int)sh->next); + funcall0(sh->function); + sh->next=NULL; + sh=sh_next; + } + scavenger_hooks = NIL; + } +#endif + #ifdef PRINTNOISE printf(" Done.]\n"); fflush(stdout);