Index: /trunk/source/lisp-kernel/ppc-exceptions.c =================================================================== --- /trunk/source/lisp-kernel/ppc-exceptions.c (revision 8492) +++ /trunk/source/lisp-kernel/ppc-exceptions.c (revision 8493) @@ -442,4 +442,5 @@ /* nrs_GC_EVENT_STATUS_BITS.vcell |= gc_integrity_check_bit; */ gc_from_xp(xp, 0L); + release_readonly_area(); } if (selector & GC_TRAP_FUNCTION_PURIFY) { @@ -905,4 +906,11 @@ handler = protection_handlers[area->why]; return handler(xp, area, addr); + } else { + if ((addr >= readonly_area->low) && + (addr < readonly_area->active)) { + UnProtectMemory((LogicalAddress)(truncate_to_power_of_2(addr,log2_page_size)), + page_size); + return 0; + } } } Index: /trunk/source/lisp-kernel/ppc-gc.c =================================================================== --- /trunk/source/lisp-kernel/ppc-gc.c (revision 8492) +++ /trunk/source/lisp-kernel/ppc-gc.c (revision 8493) @@ -1729,157 +1729,134 @@ /* - This assumes that it's getting called with a simple-{base,general}-string - or code vector as an argument and that there's room for the object in the + This assumes that it's getting called with an ivector + argument and that there's room for the object in the destination area. */ +LispObj +purify_displaced_object(LispObj obj, area *dest, natural disp) +{ + BytePtr + free = dest->active, + *old = (BytePtr *) ptr_from_lispobj(untag(obj)); + LispObj + header = header_of(obj), + new; + natural + start = (natural)old, + physbytes; + + physbytes = ((natural)(skip_over_ivector(start,header))) - start; + dest->active += physbytes; + + new = ptr_to_lispobj(free)+disp; + + memcpy(free, (BytePtr)old, physbytes); + /* Leave a trail of breadcrumbs. Or maybe just one breadcrumb. */ + /* Actually, it's best to always leave a trail, for two reasons. + a) We may be walking the same heap that we're leaving forwaring + pointers in, so we don't want garbage that we leave behind to + look like a header. + b) We'd like to be able to forward code-vector locatives, and + it's easiest to do so if we leave a {forward_marker, dnode_locative} + pair at every doubleword in the old vector. + */ + while(physbytes) { + *old++ = (BytePtr) forward_marker; + *old++ = (BytePtr) free; + free += dnode_size; + physbytes -= dnode_size; + } + return new; +} + +LispObj +purify_object(LispObj obj, area *dest) +{ + return purify_displaced_object(obj, dest, fulltag_of(obj)); +} + + + +void +copy_ivector_reference(LispObj *ref, BytePtr low, BytePtr high, area *dest) +{ + LispObj obj = *ref, header; + natural tag = fulltag_of(obj), header_tag, header_subtag; + + if ((tag == fulltag_misc) && + (((BytePtr)ptr_from_lispobj(obj)) > low) && + (((BytePtr)ptr_from_lispobj(obj)) < high)) { + header = deref(obj, 0); + if (header == forward_marker) { /* already copied */ + *ref = (untag(deref(obj,1)) + tag); + } else { + header_tag = fulltag_of(header); + if (immheader_tag_p(header_tag)) { + *ref = purify_object(obj, dest); + } + } + } +} + +void +purify_locref(LispObj *locaddr, BytePtr low, BytePtr high, area *to) +{ +#ifdef PPC LispObj - purify_displaced_object(LispObj obj, area *dest, natural disp) - { - BytePtr - free = dest->active, - *old = (BytePtr *) ptr_from_lispobj(untag(obj)); - LispObj - header = header_of(obj), - new; - natural - subtag = header_subtag(header), - element_count = header_element_count(header), - physbytes; - - switch(subtag) { - case subtag_simple_base_string: - physbytes = node_size + (element_count << 2); - break; - - case subtag_code_vector: - physbytes = node_size + (element_count << 2); - break; - - default: - Bug(NULL, "Can't purify object at 0x%08x", obj); - return obj; - } - physbytes = (physbytes+(dnode_size-1))&~(dnode_size-1); - dest->active += physbytes; - - new = ptr_to_lispobj(free)+disp; - - memcpy(free, (BytePtr)old, physbytes); - /* Leave a trail of breadcrumbs. Or maybe just one breadcrumb. */ - /* Actually, it's best to always leave a trail, for two reasons. - a) We may be walking the same heap that we're leaving forwaring - pointers in, so we don't want garbage that we leave behind to - look like a header. - b) We'd like to be able to forward code-vector locatives, and - it's easiest to do so if we leave a {forward_marker, dnode_locative} - pair at every doubleword in the old vector. - */ - while(physbytes) { - *old++ = (BytePtr) forward_marker; - *old++ = (BytePtr) free; - free += dnode_size; - physbytes -= dnode_size; - } - return new; - } - - LispObj - purify_object(LispObj obj, area *dest) - { - return purify_displaced_object(obj, dest, fulltag_of(obj)); - } - - -#define FORWARD_ONLY 0 -#define COPY_CODE (1<<0) -#define COPY_STRINGS (1<<1) - - void - copy_ivector_reference(LispObj *ref, BytePtr low, BytePtr high, area *dest, int what_to_copy) - { - LispObj obj = *ref, header; - natural tag = fulltag_of(obj), header_tag, header_subtag; - - if ((tag == fulltag_misc) && - (((BytePtr)ptr_from_lispobj(obj)) > low) && - (((BytePtr)ptr_from_lispobj(obj)) < high)) { - header = deref(obj, 0); - if (header == forward_marker) { /* already copied */ - *ref = (untag(deref(obj,1)) + tag); + loc = *locaddr, + *headerP; + opcode + *p, + insn; + natural + tag = fulltag_of(loc); + + if (((BytePtr)ptr_from_lispobj(loc) > low) && + ((BytePtr)ptr_from_lispobj(loc) < high)) { + + headerP = (LispObj *)ptr_from_lispobj(untag(loc)); + switch (tag) { + case fulltag_even_fixnum: + case fulltag_odd_fixnum: +#ifdef PPC64 + case fulltag_cons: + case fulltag_misc: +#endif + if (*headerP == forward_marker) { + *locaddr = (headerP[1]+tag); } else { - header_tag = fulltag_of(header); - if (immheader_tag_p(header_tag)) { - header_subtag = header_subtag(header); - if (((header_subtag == subtag_code_vector) && (what_to_copy & COPY_CODE)) || - ((what_to_copy & COPY_STRINGS) && - ((header_subtag == subtag_simple_base_string)))) { - *ref = purify_object(obj, dest); - } - } - } - } - } - - void - purify_locref(LispObj *locaddr, BytePtr low, BytePtr high, area *to, int what) - { -#ifdef PPC - LispObj - loc = *locaddr, - *headerP; - opcode - *p, - insn; - natural - tag = fulltag_of(loc); - - if (((BytePtr)ptr_from_lispobj(loc) > low) && - - ((BytePtr)ptr_from_lispobj(loc) < high)) { - - headerP = (LispObj *)ptr_from_lispobj(untag(loc)); - switch (tag) { - case fulltag_even_fixnum: - case fulltag_odd_fixnum: + /* Grovel backwards until the header's found; copy + the code vector to to space, then treat it as if it + hasn't already been copied. */ + p = (opcode *)headerP; + do { + p -= 2; + tag += 8; + insn = *p; #ifdef PPC64 - case fulltag_cons: - case fulltag_misc: -#endif - if (*headerP == forward_marker) { - *locaddr = (headerP[1]+tag); - } else { - /* Grovel backwards until the header's found; copy - the code vector to to space, then treat it as if it - hasn't already been copied. */ - p = (opcode *)headerP; - do { - p -= 2; - tag += 8; - insn = *p; -#ifdef PPC64 - } while (insn != PPC64_CODE_VECTOR_PREFIX); - headerP = ((LispObj*)p)-1; - *locaddr = purify_displaced_object(((LispObj)headerP), to, tag); + } while (insn != PPC64_CODE_VECTOR_PREFIX); + headerP = ((LispObj*)p)-1; + *locaddr = purify_displaced_object(((LispObj)headerP), to, tag); #else - } while ((insn & code_header_mask) != subtag_code_vector); - *locaddr = purify_displaced_object(ptr_to_lispobj(p), to, tag); -#endif - } - break; + } while ((insn & code_header_mask) != subtag_code_vector); + *locaddr = purify_displaced_object(ptr_to_lispobj(p), to, tag); +#endif + } + break; #ifndef PPC64 - case fulltag_misc: - copy_ivector_reference(locaddr, low, high, to, what); - break; -#endif - } - } -#endif -} - -void -purify_range(LispObj *start, LispObj *end, BytePtr low, BytePtr high, area *to, int what) + case fulltag_misc: + copy_ivector_reference(locaddr, low, high, to); + break; +#endif + } +} +#endif +} + +void +purify_range(LispObj *start, LispObj *end, BytePtr low, BytePtr high, area *to) { LispObj header; @@ -1896,8 +1873,8 @@ } else { if (!nodeheader_tag_p(tag)) { - copy_ivector_reference(start, low, high, to, what); + copy_ivector_reference(start, low, high, to); } start++; - copy_ivector_reference(start, low, high, to, what); + copy_ivector_reference(start, low, high, to); start++; } @@ -1908,5 +1885,5 @@ /* Purify references from tstack areas */ void -purify_tstack_area(area *a, BytePtr low, BytePtr high, area *to, int what) +purify_tstack_area(area *a, BytePtr low, BytePtr high, area *to) { LispObj @@ -1923,5 +1900,5 @@ end = ((next >= start) && (next < limit)) ? next : limit; if (current[1] == 0) { - purify_range(current+2, end, low, high, to, what); + purify_range(current+2, end, low, high, to); } } @@ -1930,5 +1907,5 @@ /* Purify a vstack area */ void -purify_vstack_area(area *a, BytePtr low, BytePtr high, area *to, int what) +purify_vstack_area(area *a, BytePtr low, BytePtr high, area *to) { LispObj @@ -1937,13 +1914,13 @@ if (((natural)p) & sizeof(natural)) { - copy_ivector_reference(p, low, high, to, what); + copy_ivector_reference(p, low, high, to); p++; } - purify_range(p, q, low, high, to, what); -} - -#ifdef PPC -void -purify_cstack_area(area *a, BytePtr low, BytePtr high, area *to, int what) + purify_range(p, q, low, high, to); +} + + +void +purify_cstack_area(area *a, BytePtr low, BytePtr high, area *to) { BytePtr @@ -1958,5 +1935,5 @@ (((((lisp_frame *)current)->savefn) == 0) || (fulltag_of(((lisp_frame *)current)->savefn) == fulltag_misc))) { - purify_locref(&((lisp_frame *) current)->savelr, low, high, to, what); + purify_locref(&((lisp_frame *) current)->savelr, low, high, to); } else { /* Clear low bits of "next", just in case */ @@ -1965,12 +1942,10 @@ } } -#endif - -void -purify_xp(ExceptionInformation *xp, BytePtr low, BytePtr high, area *to, int what) + +void +purify_xp(ExceptionInformation *xp, BytePtr low, BytePtr high, area *to) { unsigned long *regs = (unsigned long *) xpGPRvector(xp); -#ifdef PPC int r; @@ -1980,27 +1955,25 @@ for (r = fn; r < 32; r++) { - copy_ivector_reference((LispObj*) (&(regs[r])), low, high, to, what); + copy_ivector_reference((LispObj*) (&(regs[r])), low, high, to); }; - purify_locref((LispObj*) (&(regs[loc_pc])), low, high, to, what); - - purify_locref((LispObj*) (&(xpPC(xp))), low, high, to, what); - purify_locref((LispObj*) (&(xpLR(xp))), low, high, to, what); - purify_locref((LispObj*) (&(xpCTR(xp))), low, high, to, what); -#endif - -} - -void -purify_tcr_tlb(TCR *tcr, BytePtr low, BytePtr high, area *to, int what) + purify_locref((LispObj*) (&(regs[loc_pc])), low, high, to); + + purify_locref((LispObj*) (&(xpPC(xp))), low, high, to); + purify_locref((LispObj*) (&(xpLR(xp))), low, high, to); + purify_locref((LispObj*) (&(xpCTR(xp))), low, high, to); +} + +void +purify_tcr_tlb(TCR *tcr, BytePtr low, BytePtr high, area *to) { natural n = tcr->tlb_limit; LispObj *start = tcr->tlb_pointer, *end = (LispObj *) ((BytePtr)start+n); - purify_range(start, end, low, high, to, what); -} - -void -purify_tcr_xframes(TCR *tcr, BytePtr low, BytePtr high, area *to, int what) + purify_range(start, end, low, high, to); +} + +void +purify_tcr_xframes(TCR *tcr, BytePtr low, BytePtr high, area *to) { xframe_list *xframes; @@ -2009,15 +1982,27 @@ xp = tcr->gc_context; if (xp) { - purify_xp(xp, low, high, to, what); + purify_xp(xp, low, high, to); } for (xframes = tcr->xframe; xframes; xframes = xframes->prev) { - purify_xp(xframes->curr, low, high, to, what); - } -} - - -void -purify_areas(BytePtr low, BytePtr high, area *target, int what) + purify_xp(xframes->curr, low, high, to); + } +} + +void +purify_gcable_ptrs(BytePtr low, BytePtr high, area *to) +{ + LispObj *prev = &(lisp_global(GCABLE_POINTERS)), next; + + while ((*prev) != (LispObj)NULL) { + copy_ivector_reference(prev, low, high, to); + next = *prev; + prev = &(((xmacptr *)ptr_from_lispobj(untag(next)))->link); + } +} + + +void +purify_areas(BytePtr low, BytePtr high, area *target) { area *next_area; @@ -2027,20 +2012,18 @@ switch (code) { case AREA_TSTACK: - purify_tstack_area(next_area, low, high, target, what); + purify_tstack_area(next_area, low, high, target); break; case AREA_VSTACK: - purify_vstack_area(next_area, low, high, target, what); + purify_vstack_area(next_area, low, high, target); break; case AREA_CSTACK: -#ifdef PPC - purify_cstack_area(next_area, low, high, target, what); -#endif + purify_cstack_area(next_area, low, high, target); break; case AREA_STATIC: case AREA_DYNAMIC: - purify_range((LispObj *) next_area->low, (LispObj *) next_area->active, low, high, target, what); + purify_range((LispObj *) next_area->low, (LispObj *) next_area->active, low, high, target); break; @@ -2080,60 +2063,15 @@ lisp_global(IN_GC) = (1<vcell, htab, obj; - package *p; - cons *c; - natural elements, i; - - while (fulltag_of(pkg_list) == fulltag_cons) { - c = (cons *) ptr_from_lispobj(untag(pkg_list)); - p = (package *) ptr_from_lispobj(untag(c->car)); - pkg_list = c->cdr; - c = (cons *) ptr_from_lispobj(untag(p->itab)); - htab = c->car; - elements = header_element_count(header_of(htab)); - for (i = 1; i<= elements; i++) { - obj = deref(htab,i); - if (fulltag_of(obj) == fulltag_misc) { - rawsym = (lispsymbol *) ptr_from_lispobj(untag(obj)); - copy_ivector_reference(&(rawsym->pname), a->low, a->active, new_pure_area, COPY_STRINGS); - } - } - c = (cons *) ptr_from_lispobj(untag(p->etab)); - htab = c->car; - elements = header_element_count(header_of(htab)); - for (i = 1; i<= elements; i++) { - obj = deref(htab,i); - if (fulltag_of(obj) == fulltag_misc) { - rawsym = (lispsymbol *) ptr_from_lispobj(untag(obj)); - copy_ivector_reference(&(rawsym->pname), a->low, a->active, new_pure_area, COPY_STRINGS); - } - } - } - } - purify_areas(a->low, a->active, new_pure_area, COPY_CODE); + purify_areas(a->low, a->active, new_pure_area); other_tcr = tcr; do { - purify_tcr_xframes(other_tcr, a->low, a->active, new_pure_area, COPY_CODE); - purify_tcr_tlb(other_tcr, a->low, a->active, new_pure_area, COPY_CODE); + purify_tcr_xframes(other_tcr, a->low, a->active, new_pure_area); + purify_tcr_tlb(other_tcr, a->low, a->active, new_pure_area); other_tcr = other_tcr->next; } while (other_tcr != tcr); + purify_gcable_ptrs(a->low, a->active, new_pure_area); { @@ -2353,8 +2291,20 @@ } +void +impurify_gcable_ptrs(LispObj low, LispObj high, signed_natural delta) +{ + LispObj *prev = &(lisp_global(GCABLE_POINTERS)), next; + + while ((*prev) != (LispObj)NULL) { + impurify_noderef(prev, low, high, delta); + next = *prev; + prev = &(((xmacptr *)ptr_from_lispobj(untag(next)))->link); + } +} + int impurify(TCR *tcr, signed_natural param) { - area *r = find_readonly_area(); + area *r = readonly_area; if (r) { @@ -2388,4 +2338,6 @@ other_tcr = other_tcr->next; } while (other_tcr != tcr); + + impurify_gcable_ptrs(ptr_to_lispobj(ro_base), ptr_to_lispobj(ro_limit), delta); lisp_global(IN_GC) = 0; }