/* -*-C-*- $Id: wabbit.c,v 1.9 2001/12/16 06:01:33 cph Exp $ Copyright (c) 1994-2001 Massachusetts Institute of Technology This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ /* * * What's opera, doc?! * This file contains the wabbit-hunting garbage collector, * by Ziggy and GJR. * */ #include "scheme.h" #include "gccode.h" extern SCHEME_OBJECT Weak_Chain; extern SCHEME_OBJECT * EXFUN (wabbit_hunting_gcloop, (SCHEME_OBJECT *, SCHEME_OBJECT **)); extern void EXFUN (wabbit_season, (SCHEME_OBJECT)); extern void EXFUN (duck_season, (SCHEME_OBJECT)); extern void EXFUN (fix_weak_chain_and_hunt_wabbits, (void)); /* Wabbit hunting code */ /* Be wary, wary, quiet... */ #define TC_HEADLESS_REFERENCE TC_NULL #define TC_REFERENCE_TO_STACK TC_STACK_ENVIRONMENT #define TC_REFERENCE_TO_CONSTANT_SPACE TC_CHARACTER Boolean wabbit_holes_discarded_p, wabbit_holes_overwritten_p, wabbit_all_dead_p; SCHEME_OBJECT * wabbit_holes, * wabbit_holes_hi, * wabbit_lo_address, * wabbit_hi_address, * wabbit_of_Seville, * wabbit_buffer_lo, * wabbit_buffer_ptr, * wabbit_buffer_hi, * old_wabbit_buffer, * old_wabbit_buffer_end, * hares_lo, * hares_hi; #define ELMER_FUDGE_FACTOR 4 /* Size of QUAD */ #define ELMER_HUNG_FACTOR 20 /* 1 / (Sales tax in MA in 1994) */ #define RAJIV_SURATI_FACTOR -20 /* -1 * ELMER_HUNG_FACTOR */ void EXFUN (kill_da_wabbit, (SCHEME_OBJECT *, SCHEME_OBJECT)); Boolean EXFUN (discard_wabbit_holes_p, (SCHEME_OBJECT *, SCHEME_OBJECT *)); /* We need not check wabbit_lo_address by construction: wabbit_lo_address is Free at the beginning of the GC, and all forwarded objects will point above that, except for the wabbit of Seville, a.k.a. the wabbit vector. */ #define WABBIT_P(addr) \ (((addr) < wabbit_hi_address) \ && ((addr) != wabbit_of_Seville)) #define HARE_P(addr) \ (((OBJECT_TYPE (* addr)) == TC_BROKEN_HEART) \ && ((OBJECT_ADDRESS (* addr)) >= old_wabbit_buffer) \ && ((OBJECT_ADDRESS (* addr)) < old_wabbit_buffer_end)) #define RECORD_WABBIT_HOLE(tag, address) do \ { \ if ((wabbit_holes > (new_space_free + ELMER_FUDGE_FACTOR)) \ || (discard_wabbit_holes_p (scan, new_space_free))) \ *--wabbit_holes = (MAKE_POINTER_OBJECT (tag, address)); \ } while (0) #define KILL_DA_WABBIT(where, last_object) do \ { \ if ((wabbit_buffer_ptr + 2) <= wabbit_buffer_hi) \ kill_da_wabbit (where, last_object); \ else \ wabbit_all_dead_p = false; \ } while (0) /* Oh, what have I done! I've killed the little bunny wabbit... */ #define COPY_CELL() \ { \ *new_space_free++ = *old_space_addr; \ } #define COPY_PAIR() \ { \ *new_space_free++ = *old_space_addr++; \ *new_space_free++ = *old_space_addr; \ } #define COPY_TRIPLE() \ { \ *new_space_free++ = *old_space_addr++; \ *new_space_free++ = *old_space_addr++; \ *new_space_free++ = *old_space_addr; \ } #define COPY_QUADRUPLE() \ { \ *new_space_free++ = *old_space_addr++; \ *new_space_free++ = *old_space_addr++; \ *new_space_free++ = *old_space_addr++; \ *new_space_free++ = *old_space_addr; \ } #define COPY_VECTOR() \ { \ long veclen = (1 + (OBJECT_DATUM (* old_space_addr))); \ SCHEME_OBJECT * vecend = (new_space_free + veclen); \ \ if (vecend > wabbit_holes) \ discard_wabbit_holes_p (scan, new_space_free); \ while (new_space_free != vecend) \ *new_space_free++ = *old_space_addr++; \ } #define COPY_WEAK_PAIR() \ { \ long car_tag = (OBJECT_TYPE (* old_space_addr)); \ (*new_space_free++) \ = (OBJECT_NEW_TYPE (TC_NULL, (* old_space_addr))); \ *new_space_free++ = *++old_space_addr; \ * old_space_addr = (OBJECT_NEW_TYPE (car_tag, Weak_Chain)); \ Weak_Chain = this_object; \ } #define RELOCATE_NORMAL_SETUP() \ { \ old_space_addr = (OBJECT_ADDRESS (this_object)); \ if (old_space_addr < low_heap) \ { \ if (HARE_P (old_space_addr)) \ KILL_DA_WABBIT (scan, SHARP_F); \ continue; \ } \ if ((OBJECT_TYPE (* old_space_addr)) == TC_BROKEN_HEART) \ { \ new_space_addr = (OBJECT_ADDRESS (* old_space_addr)); \ if (WABBIT_P (new_space_addr)) \ KILL_DA_WABBIT (scan, SHARP_F); \ * scan = (MAKE_OBJECT_FROM_OBJECTS (this_object, \ (* old_space_addr))); \ continue; \ } \ } #define RELOCATE_NORMAL_END() \ { \ (* (OBJECT_ADDRESS (this_object))) \ = (MAKE_BROKEN_HEART (new_space_addr)); \ (* scan) = (MAKE_POINTER_OBJECT ((OBJECT_TYPE (this_object)), \ new_space_addr)); \ continue; \ } #define RELOCATE_NORMAL_POINTER(copy_code) \ { \ RELOCATE_NORMAL_SETUP (); \ new_space_addr = new_space_free; \ copy_code; \ RECORD_WABBIT_HOLE ((OBJECT_TYPE (this_object)), new_space_addr); \ RELOCATE_NORMAL_END (); \ } #define RELOCATE_ALIGNED_POINTER(copy_code) \ { \ RELOCATE_NORMAL_SETUP (); \ ALIGN_FLOAT (new_space_free); \ new_space_addr = new_space_free; \ copy_code; \ RECORD_WABBIT_HOLE ((OBJECT_TYPE (this_object)), new_space_addr); \ RELOCATE_NORMAL_END (); \ } #define RELOCATE_RAW_POINTER(tag, copy_code, last_object) \ { \ old_space_addr = ((SCHEME_OBJECT *) this_object); \ if (old_space_addr < low_heap) \ { \ if (HARE_P (old_space_addr)) \ KILL_DA_WABBIT (scan, last_object); \ continue; \ } \ if ((OBJECT_TYPE (* old_space_addr)) == TC_BROKEN_HEART) \ { \ new_space_addr = (OBJECT_ADDRESS (* old_space_addr)); \ if (WABBIT_P (new_space_addr)) \ KILL_DA_WABBIT (scan, last_object); \ * scan = ((SCHEME_OBJECT) new_space_addr); \ continue; \ } \ { \ SCHEME_OBJECT * saved_old_addr = old_space_addr; \ \ new_space_addr = new_space_free; \ copy_code; \ RECORD_WABBIT_HOLE (tag, new_space_addr); \ (* saved_old_addr) = (MAKE_BROKEN_HEART (new_space_addr)); \ (* scan) = ((SCHEME_OBJECT) new_space_addr); \ continue; \ } \ } #define RELOCATE_COMPILED_ENTRY(last_object) \ { \ Get_Compiled_Block (old_space_addr, \ ((SCHEME_OBJECT *) this_entry)); \ if (old_space_addr < low_heap) \ { \ if (HARE_P (old_space_addr)) \ KILL_DA_WABBIT (scan, last_object); \ new_entry = this_entry; \ } \ else if ((OBJECT_TYPE (* old_space_addr)) == TC_BROKEN_HEART) \ { \ new_space_addr = (OBJECT_ADDRESS (* old_space_addr)); \ if (WABBIT_P (new_space_addr)) \ KILL_DA_WABBIT (scan, last_object); \ new_entry = \ ((SCHEME_OBJECT) \ (RELOCATE_COMPILED_INTERNAL (this_entry, \ new_space_addr, \ old_space_addr))); \ } \ else \ { \ SCHEME_OBJECT * saved_old_addr = old_space_addr; \ \ ALIGN_FLOAT (new_space_free); \ new_space_addr = new_space_free; \ new_entry = \ ((SCHEME_OBJECT) \ (RELOCATE_COMPILED_INTERNAL (this_entry, \ new_space_addr, \ old_space_addr))); \ COPY_VECTOR (); \ RECORD_WABBIT_HOLE (TC_COMPILED_CODE_BLOCK, new_space_addr); \ (* saved_old_addr) = (MAKE_BROKEN_HEART (new_space_addr)); \ } \ } SCHEME_OBJECT * DEFUN (wabbit_hunting_gcloop, (scan, new_space_free_loc), fast SCHEME_OBJECT * scan AND SCHEME_OBJECT ** new_space_free_loc) { long last_nmv_length; fast SCHEME_OBJECT * new_space_free, * old_space_addr, this_object, * low_heap, * new_space_addr, this_entry, new_entry; SCHEME_OBJECT last_object, * last_object_end, * last_nmv, * last_hare, last_hare_head, magic_cookie, saved_cookie, * saved_addr; last_object = SHARP_F; last_object_end = 0; last_nmv = (scan - 2); /* Make comparison fail until */ last_nmv_length = 0; /* an NMV is found. */ last_hare = (scan - 2); /* Same here */ last_hare_head = SHARP_F; magic_cookie = SHARP_F; saved_cookie = SHARP_F; saved_addr = 0; new_space_free = * new_space_free_loc; low_heap = Constant_Top; for ( ; scan != new_space_free; scan++) { this_object = * scan; repeat_dispatch: Switch_by_GC_Type (this_object) { case TC_BROKEN_HEART: old_space_addr = (OBJECT_ADDRESS (this_object)); if (scan == old_space_addr) { if (this_object == magic_cookie) { magic_cookie = SHARP_F; last_hare = (scan - 1); last_hare_head = scan[-1]; saved_addr[0] = scan[-1]; scan[-1] = (MAKE_BROKEN_HEART (saved_addr)); *scan = saved_cookie; this_object = saved_cookie; goto repeat_dispatch; } else { * new_space_free_loc = new_space_free; return (scan); } } else if ((old_space_addr < old_wabbit_buffer) || (old_space_addr >= old_wabbit_buffer_end)) { sprintf (gc_death_message_buffer, "wabbit_hunting_gcloop: broken heart (0x%lx) in scan", this_object); gc_death (TERM_BROKEN_HEART, gc_death_message_buffer, scan, new_space_free); /*NOTREACHED*/ } else { SCHEME_OBJECT old_head = old_space_addr[0]; switch (GC_Type_Map [(OBJECT_TYPE (old_head))]) { default: case GC_Non_Pointer: last_hare = scan; last_hare_head = old_head; break; case GC_Special: if (((OBJECT_TYPE (old_head)) != TC_REFERENCE_TRAP) || ((OBJECT_DATUM (old_head)) <= TRAP_MAX_IMMEDIATE)) { this_object = old_head; last_hare = scan; last_hare_head = old_head; goto repeat_dispatch; } /* fall through */ case GC_Cell: case GC_Pair: case GC_Triple: case GC_Quadruple: case GC_Vector: if ((OBJECT_ADDRESS (old_head)) == scan) { last_hare = scan; last_hare_head = old_head; KILL_DA_WABBIT (scan, old_head); break; } /* fall through */ case GC_Compiled: saved_addr = old_space_addr; saved_cookie = scan[1]; magic_cookie = (MAKE_BROKEN_HEART (scan + 1)); scan[1] = magic_cookie; this_object = old_head; *scan = old_head; goto repeat_dispatch; } } break; case TC_MANIFEST_NM_VECTOR: case TC_MANIFEST_SPECIAL_NM_VECTOR: if ((last_nmv + (1 + last_nmv_length)) == scan) last_object = SHARP_F; else if ((OBJECT_TYPE (scan[-1])) == TC_MANIFEST_VECTOR) { last_object = (MAKE_POINTER_OBJECT (TC_COMPILED_CODE_BLOCK, (scan - 1))); last_object_end = (scan + (OBJECT_DATUM (scan [-1]))); } else if (((scan - 1) == last_hare) && ((OBJECT_TYPE (last_hare_head)) == TC_MANIFEST_VECTOR)) { last_object = (MAKE_POINTER_OBJECT (TC_COMPILED_CODE_BLOCK, (scan - 1))); last_object_end = (scan + (OBJECT_DATUM (last_hare_head))); } else last_object = SHARP_F; last_nmv = scan; last_nmv_length = (OBJECT_DATUM (this_object)); scan += last_nmv_length; break; /* Compiled code relocation. */ case TC_LINKAGE_SECTION: { SCHEME_OBJECT saved_last_object, * saved_last_object_end; saved_last_object = last_object; saved_last_object_end = last_object_end; if ((last_object == SHARP_F) || (last_object_end < scan)) { last_object = (MAKE_POINTER_OBJECT (TC_HEADLESS_REFERENCE, scan)); last_object_end = (scan + (1 + (READ_CACHE_LINKAGE_COUNT (this_object)))); } switch (READ_LINKAGE_KIND (this_object)) { case REFERENCE_LINKAGE_KIND: case ASSIGNMENT_LINKAGE_KIND: { /* Assumes that all others are objects of type TC_QUAD without their type codes. */ fast long count; scan++; for (count = (READ_CACHE_LINKAGE_COUNT (this_object)); --count >= 0; scan += 1) { this_object = (* scan); RELOCATE_RAW_POINTER (TC_QUAD, COPY_QUADRUPLE (), last_object); } scan -= 1; break; } case OPERATOR_LINKAGE_KIND: case GLOBAL_OPERATOR_LINKAGE_KIND: { fast long count; fast char * word_ptr; SCHEME_OBJECT * end_scan; START_OPERATOR_RELOCATION (scan); count = (READ_OPERATOR_LINKAGE_COUNT (this_object)); word_ptr = (FIRST_OPERATOR_LINKAGE_ENTRY (scan)); end_scan = (END_OPERATOR_LINKAGE_AREA (scan, count)); while (--count >= 0) { scan = ((SCHEME_OBJECT *) word_ptr); word_ptr = (NEXT_LINKAGE_OPERATOR_ENTRY (word_ptr)); EXTRACT_OPERATOR_LINKAGE_ADDRESS (this_entry, scan); RELOCATE_COMPILED_ENTRY (last_object); STORE_OPERATOR_LINKAGE_ADDRESS (new_entry, scan); } scan = end_scan; END_OPERATOR_RELOCATION (scan); break; } case CLOSURE_PATTERN_LINKAGE_KIND: scan += (READ_CACHE_LINKAGE_COUNT (this_object)); break; default: { gc_death (TERM_EXIT, "GC: Unknown compiler linkage kind.", scan, Free); /*NOTREACHED*/ } } last_object = saved_last_object; last_object_end = saved_last_object_end; break; } case TC_MANIFEST_CLOSURE: { fast long count; fast char * word_ptr; SCHEME_OBJECT * area_end; SCHEME_OBJECT saved_last_object, * saved_last_object_end; saved_last_object = last_object; saved_last_object_end = last_object_end; if ((last_object == SHARP_F) || (last_object_end < scan)) { last_object = (MAKE_POINTER_OBJECT (TC_COMPILED_CODE_BLOCK, scan)); last_object_end = (scan + (1 + (OBJECT_DATUM (this_object)))); } START_CLOSURE_RELOCATION (scan); scan += 1; count = (MANIFEST_CLOSURE_COUNT (scan)); word_ptr = (FIRST_MANIFEST_CLOSURE_ENTRY (scan)); area_end = ((MANIFEST_CLOSURE_END (scan, count)) - 1); while ((--count) >= 0) { scan = ((SCHEME_OBJECT *) (word_ptr)); word_ptr = (NEXT_MANIFEST_CLOSURE_ENTRY (word_ptr)); EXTRACT_CLOSURE_ENTRY_ADDRESS (this_entry, scan); RELOCATE_COMPILED_ENTRY (last_object); STORE_CLOSURE_ENTRY_ADDRESS (new_entry, scan); } scan = area_end; END_CLOSURE_RELOCATION (scan); last_object = saved_last_object; last_object_end = saved_last_object_end; break; } case_compiled_entry_point: { this_entry = ((SCHEME_OBJECT) (OBJECT_ADDRESS (this_object))); RELOCATE_COMPILED_ENTRY (SHARP_F); (* scan) = (MAKE_POINTER_OBJECT ((OBJECT_TYPE (this_object)), ((SCHEME_OBJECT *) new_entry))); continue; } case_Cell: RELOCATE_NORMAL_POINTER (COPY_CELL ()); break; case TC_REFERENCE_TRAP: if ((OBJECT_DATUM (this_object)) <= TRAP_MAX_IMMEDIATE) { /* It is a non pointer. */ break; } /* Fall Through. */ case_Pair: RELOCATE_NORMAL_POINTER (COPY_PAIR ()); break; case TC_VARIABLE: case_Triple: RELOCATE_NORMAL_POINTER (COPY_TRIPLE ()); break; case_Quadruple: RELOCATE_NORMAL_POINTER (COPY_QUADRUPLE ()); break; case_Aligned_Vector: RELOCATE_ALIGNED_POINTER (COPY_VECTOR ()); break; case TC_FUTURE: if (Future_Spliceable (this_object)) { * scan = (Future_Value (this_object)); scan -= 1; continue; } /* fall through */ case_Vector: RELOCATE_NORMAL_POINTER (COPY_VECTOR ()); break; case TC_WEAK_CONS: RELOCATE_NORMAL_POINTER (COPY_WEAK_PAIR ()); break; default: sprintf (gc_death_message_buffer, "wabbit_hunting_gcloop: bad type code (0x%02x)", ((unsigned int) (OBJECT_TYPE (this_object)))); gc_death (TERM_INVALID_TYPE_CODE, gc_death_message_buffer, scan, new_space_free); /*NOTREACHED*/ case_Non_Pointer: break; } /* Switch_by_GC_Type */ } /* For loop */ * new_space_free_loc = new_space_free; return (new_space_free); } /* wabbit_hunting_gcloop */ void DEFUN (wabbit_season, (wabbit_descriptor), SCHEME_OBJECT wabbit_descriptor) { long n_wabbits, buf_len, ctr; SCHEME_OBJECT * result, * area, * saved_area, wabbit_buffer, wabbit_vector, * wabbit_vector_ptr; wabbit_vector = (VECTOR_REF (wabbit_descriptor, 1)); wabbit_buffer = (VECTOR_REF (wabbit_descriptor, 2)); buf_len = (VECTOR_LENGTH (wabbit_buffer)); n_wabbits = (VECTOR_LENGTH (wabbit_vector)); wabbit_all_dead_p = true; wabbit_holes_overwritten_p = false; wabbit_holes_discarded_p = false; wabbit_holes_hi = Heap_Top; wabbit_holes = wabbit_holes_hi; saved_area = area = Free; wabbit_lo_address = saved_area; wabbit_hi_address = saved_area; wabbit_of_Seville = saved_area; wabbit_vector_ptr = (MEMORY_LOC (wabbit_vector, 0)); for (ctr = n_wabbits; ctr >= 0; ctr -= 1) *area++ = *wabbit_vector_ptr++; MEMORY_SET (wabbit_vector, 0, (MAKE_BROKEN_HEART (saved_area))); *area = (MAKE_BROKEN_HEART (area)); Free = (area + 1); result = (wabbit_hunting_gcloop (saved_area, &Free)); if (result != area) { outf_fatal ("\nwabbit_hunt Wabbit scan ended too early.\n"); Microcode_Termination (TERM_BROKEN_HEART); } *area = SHARP_F; /* Remove broken heart on Valentine's day */ wabbit_lo_address = (area + 1); wabbit_hi_address = Free; if (BROKEN_HEART_P (MEMORY_REF (wabbit_buffer, 0))) /* One of the wabbits is the wabbit buffer itself! */ wabbit_buffer_lo = (OBJECT_ADDRESS (MEMORY_REF (wabbit_buffer, 0))); else { wabbit_buffer_lo = Free; MEMORY_SET (wabbit_buffer, 0, (MAKE_BROKEN_HEART (wabbit_buffer_lo))); Free += (1 + buf_len); } wabbit_buffer_hi = (wabbit_buffer_lo + (1 + buf_len)); * wabbit_buffer_lo = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, buf_len)); wabbit_buffer_ptr = (wabbit_buffer_lo + 3); /* Check whether any wabbits are hares, and if so, mark them so. */ old_wabbit_buffer = ((OBJECT_ADDRESS (wabbit_buffer)) + 3); old_wabbit_buffer[-1] = (MAKE_BROKEN_HEART (old_wabbit_buffer - 1)); wabbit_vector_ptr = (MEMORY_LOC (wabbit_vector, 1)); for (area = old_wabbit_buffer, ctr = n_wabbits; --ctr >= 0; ) { SCHEME_OBJECT wabbit = *wabbit_vector_ptr++; SCHEME_OBJECT old_head; switch (GC_Type_Map [(OBJECT_TYPE (wabbit))]) { case GC_Non_Pointer: /* Sucker -- should crash his scheme */ break; case GC_Special: if (((OBJECT_TYPE (wabbit)) != TC_REFERENCE_TRAP) || ((OBJECT_DATUM (wabbit)) <= TRAP_MAX_IMMEDIATE)) break; /* fall through */ case GC_Cell: case GC_Pair: case GC_Triple: case GC_Quadruple: case GC_Vector: if ((OBJECT_ADDRESS (wabbit)) >= Constant_Top) break; old_head = (MEMORY_REF (wabbit, 0)); MEMORY_SET (wabbit, 0, (MAKE_BROKEN_HEART (area))); *area++ = old_head; *area++ = wabbit; break; case GC_Compiled: { SCHEME_OBJECT * block; if ((OBJECT_ADDRESS (wabbit)) >= Constant_Top) break; Get_Compiled_Block (block, (OBJECT_ADDRESS (wabbit))); old_head = *block; *block = (MAKE_BROKEN_HEART (area)); *area++ = old_head; *area++ = (MAKE_POINTER_OBJECT (TC_COMPILED_CODE_BLOCK, block)); break; } default: /* Loser -- shouldn't happen */ break; } } old_wabbit_buffer_end = area; result = (wabbit_hunting_gcloop (wabbit_lo_address, &Free)); if (Free != result) { outf_fatal ("\nwabbit_hunt: heap scan ended too early.\n"); Microcode_Termination (TERM_BROKEN_HEART); } return; } void DEFUN (duck_season, (wabbit_descriptor), SCHEME_OBJECT wabbit_descriptor) { SCHEME_OBJECT * ptr; /* Restore hares' heads */ for (ptr = old_wabbit_buffer; ptr < old_wabbit_buffer_end; ptr += 2) MEMORY_SET (ptr[1], 0, ptr[0]); wabbit_buffer_lo[2] = (LONG_TO_UNSIGNED_FIXNUM (wabbit_buffer_ptr - (wabbit_buffer_lo + 1))); while (wabbit_buffer_ptr < wabbit_buffer_hi) *wabbit_buffer_ptr++ = SHARP_F; wabbit_buffer_lo[1] = (BOOLEAN_TO_OBJECT (wabbit_all_dead_p)); wabbit_buffer_lo[0] = (MAKE_OBJECT (TC_MANIFEST_VECTOR, (wabbit_buffer_hi - (wabbit_buffer_lo + 1)))); if ((VECTOR_REF (wabbit_descriptor, 3)) == SHARP_T) { SCHEME_OBJECT * guaranteed_free = (Free + (GC_Reserve + 2)); SCHEME_OBJECT * source, * dest, result; long len; if (guaranteed_free > wabbit_holes) { wabbit_holes_discarded_p = true; wabbit_holes = guaranteed_free; } dest = Free; result = (MAKE_POINTER_OBJECT (TC_VECTOR, dest)); source = wabbit_holes; len = (wabbit_holes_hi - source); *dest++ = (MAKE_OBJECT (TC_MANIFEST_VECTOR, (len + 1))); *dest++ = (BOOLEAN_TO_OBJECT (! (wabbit_holes_discarded_p || wabbit_holes_overwritten_p))); while (--len >= 0) *dest++ = *source++; Free = dest; VECTOR_SET (wabbit_descriptor, 3, result); } VECTOR_SET (wabbit_descriptor, 0, SHARP_T); return; } SCHEME_OBJECT * DEFUN (hunt_wabbit, (where), SCHEME_OBJECT * where) { SCHEME_OBJECT * ptr_lo, * ptr_hi, * ptr_mid, * hole; ptr_lo = wabbit_holes; ptr_hi = (wabbit_holes_hi - 1); while (ptr_lo < ptr_hi) { ptr_mid = (ptr_lo + ((ptr_hi - ptr_lo) / 2)); hole = (OBJECT_ADDRESS (* ptr_mid)); if (where < hole) ptr_lo = (ptr_mid + 1); else if (where > hole) ptr_hi = ptr_mid; else { ptr_hi = ptr_mid; ptr_lo = ptr_mid; break; } } return (ptr_lo); } Boolean DEFUN (discard_wabbit_holes_p, (scan, free), SCHEME_OBJECT * scan AND SCHEME_OBJECT * free) { SCHEME_OBJECT * hole, * new_hole; long keep_index; if (free > wabbit_holes) { wabbit_holes_overwritten_p = true; wabbit_holes = free; } if (scan < Constant_Top) return (free < wabbit_holes); hole = ((hunt_wabbit (scan)) + 1); /* This guarantees that we don't get into quadratic copying: We discard only if the fraction of holes being discarded is at least 1/ELMER_HUNG_FACTOR of the total number of holes. */ if ((ELMER_HUNG_FACTOR * (wabbit_holes_hi - hole)) < (wabbit_holes_hi - wabbit_holes)) return (free < wabbit_holes); keep_index = (hole - wabbit_holes); new_hole = wabbit_holes_hi; while (--keep_index >= 0) *--new_hole = *--hole; wabbit_holes = new_hole; wabbit_holes_discarded_p = true; return (free < wabbit_holes); } void DEFUN (kill_da_wabbit, (where, current_object), SCHEME_OBJECT * where AND SCHEME_OBJECT current_object) { SCHEME_OBJECT * hole, wabbit, * wabbit_addr; long offset, max_offset; /* With my sword and magic helmet... */ if (where < Constant_Top) { SCHEME_OBJECT head; if (current_object != SHARP_F) { offset = (where - (OBJECT_ADDRESS (current_object))); head = current_object; } else { /* If we do cwcc before calling the special garbage collector, there should be no references to the stack. */ offset = 0; if (where < Stack_Top) head = (MAKE_POINTER_OBJECT (TC_REFERENCE_TO_STACK, where)); else head = (MAKE_POINTER_OBJECT (TC_REFERENCE_TO_CONSTANT_SPACE, where)); } *wabbit_buffer_ptr++ = head; *wabbit_buffer_ptr++ = (LONG_TO_UNSIGNED_FIXNUM (offset)); return; } if (wabbit_holes >= wabbit_holes_hi) return; hole = (hunt_wabbit (where)); wabbit = (* hole); wabbit_addr = (OBJECT_ADDRESS (wabbit)); offset = (where - wabbit_addr); *wabbit_buffer_ptr++ = wabbit; *wabbit_buffer_ptr++ = (LONG_TO_UNSIGNED_FIXNUM (offset)); if ((hole == wabbit_holes) && wabbit_holes_overwritten_p && (where != wabbit_addr)) { switch (GC_Type_Map[(OBJECT_TYPE (wabbit))]) { case GC_Pair: max_offset = 2; break; case GC_Triple: max_offset = 3; break; case GC_Quadruple: max_offset = 4; break; case GC_Vector: max_offset = (1 + (OBJECT_DATUM (* wabbit_addr))); break; case GC_Special: if ((OBJECT_TYPE (* hole)) == TC_REFERENCE_TRAP) { max_offset = 2; break; } /* fall through */ case GC_Cell: /* => (where == wabbit_addr), already tested */ default: max_offset = -1; } if ((max_offset == -1) || (where > (wabbit_addr + max_offset))) { wabbit_buffer_ptr -= 2; wabbit_all_dead_p = false; } } return; } /* Alternate version of Fix_Weak_Chain that hunts wabbits. */ #ifndef EMPTY_WEAK_CHAIN #define EMPTY_WEAK_CHAIN EMPTY_LIST #endif void DEFUN_VOID (fix_weak_chain_and_hunt_wabbits) { fast SCHEME_OBJECT * old_weak_pair, * scan, nulled_car, * new_space_addr, this_object, * old_space_addr, * low_heap; low_heap = Constant_Top; while (Weak_Chain != EMPTY_WEAK_CHAIN) { old_weak_pair = (OBJECT_ADDRESS (Weak_Chain)); scan = (OBJECT_ADDRESS (*old_weak_pair++)); Weak_Chain = * old_weak_pair; nulled_car = * scan; this_object = (MAKE_OBJECT_FROM_OBJECTS (Weak_Chain, nulled_car)); Weak_Chain = (OBJECT_NEW_TYPE (TC_NULL, Weak_Chain)); switch (GC_Type (this_object)) { case GC_Non_Pointer: *scan = this_object; continue; case GC_Special: if ((OBJECT_TYPE (this_object)) != TC_REFERENCE_TRAP) { /* No other special type makes sense here. */ goto fail; } if ((OBJECT_DATUM (this_object)) <= TRAP_MAX_IMMEDIATE) { * scan = this_object; continue; } /* Otherwise, it is a pointer. Fall through */ /* Normal pointer types, the broken heart is in the first word. Note that most special types are treated normally here. */ case GC_Cell: case GC_Pair: case GC_Triple: case GC_Quadruple: case GC_Vector: * scan = this_object; /* In case it points to constant space */ RELOCATE_NORMAL_SETUP (); * scan = SHARP_F; continue; case GC_Compiled: * scan = this_object; old_space_addr = (OBJECT_ADDRESS (this_object)); if (old_space_addr < low_heap) continue; Get_Compiled_Block (old_space_addr, old_space_addr); if ((OBJECT_TYPE (* old_space_addr)) == TC_BROKEN_HEART) { new_space_addr = (OBJECT_ADDRESS (* old_space_addr)); if (WABBIT_P (new_space_addr)) KILL_DA_WABBIT (scan, (MAKE_POINTER_OBJECT (TC_WEAK_CONS, scan))); * scan = (RELOCATE_COMPILED (this_object, new_space_addr, old_space_addr)); continue; } * scan = SHARP_F; continue; case GC_Undefined: outf_error ("\nfix_weak_chain_and_hunt_wabbits: Clearing bad object 0x%08lx.\n", this_object); * scan = SHARP_F; continue; default: /* Non Marked Headers and Broken Hearts */ fail: outf_fatal ("\nfix_weak_chain_and_hunt_wabbits: Bad Object: 0x%08lx.\n", this_object); * scan = SHARP_F; /*NOTREACHED*/ } } return; } /* What did you expect from opera, a happy ending? */