- new_cons = new_cdr_cons;
- }
-
- return new_list_pointer;
-}
-
-\f
-/*
- * scavenging and transporting other pointers
- */
-
-static int
-scav_other_pointer(lispobj *where, lispobj object)
-{
- lispobj first, *first_pointer;
-
- gc_assert(is_lisp_pointer(object));
-
- /* Object is a pointer into from space - not FP. */
- first_pointer = (lispobj *) native_pointer(object);
-
- first = (transother[widetag_of(*first_pointer)])(object);
-
- if (first != object) {
- /* Set forwarding pointer. */
- first_pointer[0] = 0x01;
- first_pointer[1] = first;
- *where = first;
- }
-
- gc_assert(is_lisp_pointer(first));
- gc_assert(!from_space_p(first));
-
- return 1;
-}
-\f
-/*
- * immediate, boxed, and unboxed objects
- */
-
-static int
-size_pointer(lispobj *where)
-{
- return 1;
-}
-
-static int
-scav_immediate(lispobj *where, lispobj object)
-{
- return 1;
-}
-
-static lispobj
-trans_immediate(lispobj object)
-{
- lose("trying to transport an immediate");
- return NIL; /* bogus return value to satisfy static type checking */
-}
-
-static int
-size_immediate(lispobj *where)
-{
- return 1;
-}
-
-
-static int
-scav_boxed(lispobj *where, lispobj object)
-{
- return 1;
-}
-
-static lispobj
-trans_boxed(lispobj object)
-{
- lispobj header;
- unsigned long length;
-
- gc_assert(is_lisp_pointer(object));
-
- header = *((lispobj *) native_pointer(object));
- length = HeaderValue(header) + 1;
- length = CEILING(length, 2);
-
- return copy_object(object, length);
-}
-
-static lispobj
-trans_boxed_large(lispobj object)
-{
- lispobj header;
- unsigned long length;
-
- gc_assert(is_lisp_pointer(object));
-
- header = *((lispobj *) native_pointer(object));
- length = HeaderValue(header) + 1;
- length = CEILING(length, 2);
-
- return copy_large_object(object, length);
-}
-
-static int
-size_boxed(lispobj *where)
-{
- lispobj header;
- unsigned long length;
-
- header = *where;
- length = HeaderValue(header) + 1;
- length = CEILING(length, 2);
-
- return length;
-}
-
-static int
-scav_fdefn(lispobj *where, lispobj object)
-{
- struct fdefn *fdefn;
-
- fdefn = (struct fdefn *)where;
-
- /* FSHOW((stderr, "scav_fdefn, function = %p, raw_addr = %p\n",
- fdefn->fun, fdefn->raw_addr)); */
-
- if ((char *)(fdefn->fun + FUN_RAW_ADDR_OFFSET) == fdefn->raw_addr) {
- scavenge(where + 1, sizeof(struct fdefn)/sizeof(lispobj) - 1);
-
- /* Don't write unnecessarily. */
- if (fdefn->raw_addr != (char *)(fdefn->fun + FUN_RAW_ADDR_OFFSET))
- fdefn->raw_addr = (char *)(fdefn->fun + FUN_RAW_ADDR_OFFSET);
-
- return sizeof(struct fdefn) / sizeof(lispobj);
- } else {
- return 1;
- }
-}
-
-static int
-scav_unboxed(lispobj *where, lispobj object)
-{
- unsigned long length;
-
- length = HeaderValue(object) + 1;
- length = CEILING(length, 2);
-
- return length;
-}
-
-static lispobj
-trans_unboxed(lispobj object)
-{
- lispobj header;
- unsigned long length;
-
-
- gc_assert(is_lisp_pointer(object));
-
- header = *((lispobj *) native_pointer(object));
- length = HeaderValue(header) + 1;
- length = CEILING(length, 2);
-
- return copy_unboxed_object(object, length);
-}
-
-static lispobj
-trans_unboxed_large(lispobj object)
-{
- lispobj header;
- unsigned long length;
-
-
- gc_assert(is_lisp_pointer(object));
-
- header = *((lispobj *) native_pointer(object));
- length = HeaderValue(header) + 1;
- length = CEILING(length, 2);
-
- return copy_large_unboxed_object(object, length);
-}
-
-static int
-size_unboxed(lispobj *where)
-{
- lispobj header;
- unsigned long length;
-
- header = *where;
- length = HeaderValue(header) + 1;
- length = CEILING(length, 2);
-
- return length;
-}
-\f
-/*
- * vector-like objects
- */
-
-#define NWORDS(x,y) (CEILING((x),(y)) / (y))
-
-static int
-scav_string(lispobj *where, lispobj object)
-{
- struct vector *vector;
- int length, nwords;
-
- /* NOTE: Strings contain one more byte of data than the length */
- /* slot indicates. */
-
- vector = (struct vector *) where;
- length = fixnum_value(vector->length) + 1;
- nwords = CEILING(NWORDS(length, 4) + 2, 2);
-
- return nwords;
-}
-
-static lispobj
-trans_string(lispobj object)
-{
- struct vector *vector;
- int length, nwords;
-
- gc_assert(is_lisp_pointer(object));
-
- /* NOTE: A string contains one more byte of data (a terminating
- * '\0' to help when interfacing with C functions) than indicated
- * by the length slot. */
-
- vector = (struct vector *) native_pointer(object);
- length = fixnum_value(vector->length) + 1;
- nwords = CEILING(NWORDS(length, 4) + 2, 2);
-
- return copy_large_unboxed_object(object, nwords);
-}
-
-static int
-size_string(lispobj *where)
-{
- struct vector *vector;
- int length, nwords;
-
- /* NOTE: A string contains one more byte of data (a terminating
- * '\0' to help when interfacing with C functions) than indicated
- * by the length slot. */
-
- vector = (struct vector *) where;
- length = fixnum_value(vector->length) + 1;
- nwords = CEILING(NWORDS(length, 4) + 2, 2);
-
- return nwords;
-}
-
-/* FIXME: What does this mean? */
-int gencgc_hash = 1;
-
-static int
-scav_vector(lispobj *where, lispobj object)
-{
- unsigned int kv_length;
- lispobj *kv_vector;
- unsigned int length = 0; /* (0 = dummy to stop GCC warning) */
- lispobj *hash_table;
- lispobj empty_symbol;
- unsigned int *index_vector = NULL; /* (NULL = dummy to stop GCC warning) */
- unsigned int *next_vector = NULL; /* (NULL = dummy to stop GCC warning) */
- unsigned int *hash_vector = NULL; /* (NULL = dummy to stop GCC warning) */
- lispobj weak_p_obj;
- unsigned next_vector_length = 0;
-
- /* FIXME: A comment explaining this would be nice. It looks as
- * though SB-VM:VECTOR-VALID-HASHING-SUBTYPE is set for EQ-based
- * hash tables in the Lisp HASH-TABLE code, and nowhere else. */
- if (HeaderValue(object) != subtype_VectorValidHashing)
- return 1;
-
- if (!gencgc_hash) {
- /* This is set for backward compatibility. FIXME: Do we need
- * this any more? */
- *where =
- (subtype_VectorMustRehash<<N_WIDETAG_BITS) | SIMPLE_VECTOR_WIDETAG;
- return 1;
- }
-
- kv_length = fixnum_value(where[1]);
- kv_vector = where + 2; /* Skip the header and length. */
- /*FSHOW((stderr,"/kv_length = %d\n", kv_length));*/
-
- /* Scavenge element 0, which may be a hash-table structure. */
- scavenge(where+2, 1);
- if (!is_lisp_pointer(where[2])) {
- lose("no pointer at %x in hash table", where[2]);
- }
- hash_table = (lispobj *)native_pointer(where[2]);
- /*FSHOW((stderr,"/hash_table = %x\n", hash_table));*/
- if (widetag_of(hash_table[0]) != INSTANCE_HEADER_WIDETAG) {
- lose("hash table not instance (%x at %x)", hash_table[0], hash_table);
- }
-
- /* Scavenge element 1, which should be some internal symbol that
- * the hash table code reserves for marking empty slots. */
- scavenge(where+3, 1);
- if (!is_lisp_pointer(where[3])) {
- lose("not empty-hash-table-slot symbol pointer: %x", where[3]);
- }
- empty_symbol = where[3];
- /* fprintf(stderr,"* empty_symbol = %x\n", empty_symbol);*/
- if (widetag_of(*(lispobj *)native_pointer(empty_symbol)) !=
- SYMBOL_HEADER_WIDETAG) {
- lose("not a symbol where empty-hash-table-slot symbol expected: %x",
- *(lispobj *)native_pointer(empty_symbol));
- }
-
- /* Scavenge hash table, which will fix the positions of the other
- * needed objects. */
- scavenge(hash_table, 16);
-
- /* Cross-check the kv_vector. */
- if (where != (lispobj *)native_pointer(hash_table[9])) {
- lose("hash_table table!=this table %x", hash_table[9]);
- }
-
- /* WEAK-P */
- weak_p_obj = hash_table[10];
-
- /* index vector */
- {
- lispobj index_vector_obj = hash_table[13];
-
- if (is_lisp_pointer(index_vector_obj) &&
- (widetag_of(*(lispobj *)native_pointer(index_vector_obj)) ==
- SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG)) {
- index_vector = ((unsigned int *)native_pointer(index_vector_obj)) + 2;
- /*FSHOW((stderr, "/index_vector = %x\n",index_vector));*/
- length = fixnum_value(((unsigned int *)native_pointer(index_vector_obj))[1]);
- /*FSHOW((stderr, "/length = %d\n", length));*/
- } else {
- lose("invalid index_vector %x", index_vector_obj);
- }
- }
-
- /* next vector */
- {
- lispobj next_vector_obj = hash_table[14];
-
- if (is_lisp_pointer(next_vector_obj) &&
- (widetag_of(*(lispobj *)native_pointer(next_vector_obj)) ==
- SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG)) {
- next_vector = ((unsigned int *)native_pointer(next_vector_obj)) + 2;
- /*FSHOW((stderr, "/next_vector = %x\n", next_vector));*/
- next_vector_length = fixnum_value(((unsigned int *)native_pointer(next_vector_obj))[1]);
- /*FSHOW((stderr, "/next_vector_length = %d\n", next_vector_length));*/
- } else {
- lose("invalid next_vector %x", next_vector_obj);
- }
- }
-
- /* maybe hash vector */
- {
- /* FIXME: This bare "15" offset should become a symbolic
- * expression of some sort. And all the other bare offsets
- * too. And the bare "16" in scavenge(hash_table, 16). And
- * probably other stuff too. Ugh.. */
- lispobj hash_vector_obj = hash_table[15];
-
- if (is_lisp_pointer(hash_vector_obj) &&
- (widetag_of(*(lispobj *)native_pointer(hash_vector_obj))
- == SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG)) {
- hash_vector = ((unsigned int *)native_pointer(hash_vector_obj)) + 2;
- /*FSHOW((stderr, "/hash_vector = %x\n", hash_vector));*/
- gc_assert(fixnum_value(((unsigned int *)native_pointer(hash_vector_obj))[1])
- == next_vector_length);
- } else {
- hash_vector = NULL;
- /*FSHOW((stderr, "/no hash_vector: %x\n", hash_vector_obj));*/
- }
- }
-
- /* These lengths could be different as the index_vector can be a
- * different length from the others, a larger index_vector could help
- * reduce collisions. */
- gc_assert(next_vector_length*2 == kv_length);
-
- /* now all set up.. */
-
- /* Work through the KV vector. */
- {
- int i;
- for (i = 1; i < next_vector_length; i++) {
- lispobj old_key = kv_vector[2*i];
- unsigned int old_index = (old_key & 0x1fffffff)%length;
-
- /* Scavenge the key and value. */
- scavenge(&kv_vector[2*i],2);
-
- /* Check whether the key has moved and is EQ based. */
- {
- lispobj new_key = kv_vector[2*i];
- unsigned int new_index = (new_key & 0x1fffffff)%length;
-
- if ((old_index != new_index) &&
- ((!hash_vector) || (hash_vector[i] == 0x80000000)) &&
- ((new_key != empty_symbol) ||
- (kv_vector[2*i] != empty_symbol))) {
-
- /*FSHOW((stderr,
- "* EQ key %d moved from %x to %x; index %d to %d\n",
- i, old_key, new_key, old_index, new_index));*/
-
- if (index_vector[old_index] != 0) {
- /*FSHOW((stderr, "/P1 %d\n", index_vector[old_index]));*/
-
- /* Unlink the key from the old_index chain. */
- if (index_vector[old_index] == i) {
- /*FSHOW((stderr, "/P2a %d\n", next_vector[i]));*/
- index_vector[old_index] = next_vector[i];
- /* Link it into the needing rehash chain. */
- next_vector[i] = fixnum_value(hash_table[11]);
- hash_table[11] = make_fixnum(i);
- /*SHOW("P2");*/
- } else {
- unsigned prior = index_vector[old_index];
- unsigned next = next_vector[prior];
-
- /*FSHOW((stderr, "/P3a %d %d\n", prior, next));*/
-
- while (next != 0) {
- /*FSHOW((stderr, "/P3b %d %d\n", prior, next));*/
- if (next == i) {
- /* Unlink it. */
- next_vector[prior] = next_vector[next];
- /* Link it into the needing rehash
- * chain. */
- next_vector[next] =
- fixnum_value(hash_table[11]);
- hash_table[11] = make_fixnum(next);
- /*SHOW("/P3");*/
- break;
- }
- prior = next;
- next = next_vector[next];
- }
- }
- }
- }
- }
- }
- }
- return (CEILING(kv_length + 2, 2));
-}
-
-static lispobj
-trans_vector(lispobj object)
-{
- struct vector *vector;
- int length, nwords;
-
- gc_assert(is_lisp_pointer(object));
-
- vector = (struct vector *) native_pointer(object);
-
- length = fixnum_value(vector->length);
- nwords = CEILING(length + 2, 2);
-
- return copy_large_object(object, nwords);
-}
-
-static int
-size_vector(lispobj *where)
-{
- struct vector *vector;
- int length, nwords;
-
- vector = (struct vector *) where;
- length = fixnum_value(vector->length);
- nwords = CEILING(length + 2, 2);
-
- return nwords;
-}
-
-
-static int
-scav_vector_bit(lispobj *where, lispobj object)
-{
- struct vector *vector;
- int length, nwords;
-
- vector = (struct vector *) where;
- length = fixnum_value(vector->length);
- nwords = CEILING(NWORDS(length, 32) + 2, 2);
-
- return nwords;
-}
-
-static lispobj
-trans_vector_bit(lispobj object)
-{
- struct vector *vector;
- int length, nwords;
-
- gc_assert(is_lisp_pointer(object));
-
- vector = (struct vector *) native_pointer(object);
- length = fixnum_value(vector->length);
- nwords = CEILING(NWORDS(length, 32) + 2, 2);
-
- return copy_large_unboxed_object(object, nwords);
-}
-
-static int
-size_vector_bit(lispobj *where)
-{
- struct vector *vector;
- int length, nwords;
-
- vector = (struct vector *) where;
- length = fixnum_value(vector->length);
- nwords = CEILING(NWORDS(length, 32) + 2, 2);
-
- return nwords;
-}
-
-
-static int
-scav_vector_unsigned_byte_2(lispobj *where, lispobj object)
-{
- struct vector *vector;
- int length, nwords;
-
- vector = (struct vector *) where;
- length = fixnum_value(vector->length);
- nwords = CEILING(NWORDS(length, 16) + 2, 2);
-
- return nwords;
-}
-
-static lispobj
-trans_vector_unsigned_byte_2(lispobj object)
-{
- struct vector *vector;
- int length, nwords;
-
- gc_assert(is_lisp_pointer(object));
-
- vector = (struct vector *) native_pointer(object);
- length = fixnum_value(vector->length);
- nwords = CEILING(NWORDS(length, 16) + 2, 2);
-
- return copy_large_unboxed_object(object, nwords);
-}
-
-static int
-size_vector_unsigned_byte_2(lispobj *where)
-{
- struct vector *vector;
- int length, nwords;
-
- vector = (struct vector *) where;
- length = fixnum_value(vector->length);
- nwords = CEILING(NWORDS(length, 16) + 2, 2);
-
- return nwords;
-}
-
-
-static int
-scav_vector_unsigned_byte_4(lispobj *where, lispobj object)
-{
- struct vector *vector;
- int length, nwords;
-
- vector = (struct vector *) where;
- length = fixnum_value(vector->length);
- nwords = CEILING(NWORDS(length, 8) + 2, 2);
-
- return nwords;
-}
-
-static lispobj
-trans_vector_unsigned_byte_4(lispobj object)
-{
- struct vector *vector;
- int length, nwords;
-
- gc_assert(is_lisp_pointer(object));
-
- vector = (struct vector *) native_pointer(object);
- length = fixnum_value(vector->length);
- nwords = CEILING(NWORDS(length, 8) + 2, 2);
-
- return copy_large_unboxed_object(object, nwords);
-}
-
-static int
-size_vector_unsigned_byte_4(lispobj *where)
-{
- struct vector *vector;
- int length, nwords;
-
- vector = (struct vector *) where;
- length = fixnum_value(vector->length);
- nwords = CEILING(NWORDS(length, 8) + 2, 2);
-
- return nwords;
-}
-
-static int
-scav_vector_unsigned_byte_8(lispobj *where, lispobj object)
-{
- struct vector *vector;
- int length, nwords;
-
- vector = (struct vector *) where;
- length = fixnum_value(vector->length);
- nwords = CEILING(NWORDS(length, 4) + 2, 2);
-
- return nwords;
-}
-
-static lispobj
-trans_vector_unsigned_byte_8(lispobj object)
-{
- struct vector *vector;
- int length, nwords;
-
- gc_assert(is_lisp_pointer(object));
-
- vector = (struct vector *) native_pointer(object);
- length = fixnum_value(vector->length);
- nwords = CEILING(NWORDS(length, 4) + 2, 2);
-
- return copy_large_unboxed_object(object, nwords);
-}
-
-static int
-size_vector_unsigned_byte_8(lispobj *where)
-{
- struct vector *vector;
- int length, nwords;
-
- vector = (struct vector *) where;
- length = fixnum_value(vector->length);
- nwords = CEILING(NWORDS(length, 4) + 2, 2);
-
- return nwords;
-}
-
-
-static int
-scav_vector_unsigned_byte_16(lispobj *where, lispobj object)
-{
- struct vector *vector;
- int length, nwords;
-
- vector = (struct vector *) where;
- length = fixnum_value(vector->length);
- nwords = CEILING(NWORDS(length, 2) + 2, 2);
-
- return nwords;
-}
-
-static lispobj
-trans_vector_unsigned_byte_16(lispobj object)
-{
- struct vector *vector;
- int length, nwords;
-
- gc_assert(is_lisp_pointer(object));
-
- vector = (struct vector *) native_pointer(object);
- length = fixnum_value(vector->length);
- nwords = CEILING(NWORDS(length, 2) + 2, 2);
-
- return copy_large_unboxed_object(object, nwords);
-}
-
-static int
-size_vector_unsigned_byte_16(lispobj *where)
-{
- struct vector *vector;
- int length, nwords;
-
- vector = (struct vector *) where;
- length = fixnum_value(vector->length);
- nwords = CEILING(NWORDS(length, 2) + 2, 2);
-
- return nwords;
-}
-
-static int
-scav_vector_unsigned_byte_32(lispobj *where, lispobj object)
-{
- struct vector *vector;
- int length, nwords;
-
- vector = (struct vector *) where;
- length = fixnum_value(vector->length);
- nwords = CEILING(length + 2, 2);
-
- return nwords;
-}
-
-static lispobj
-trans_vector_unsigned_byte_32(lispobj object)
-{
- struct vector *vector;
- int length, nwords;
-
- gc_assert(is_lisp_pointer(object));
-
- vector = (struct vector *) native_pointer(object);
- length = fixnum_value(vector->length);
- nwords = CEILING(length + 2, 2);
-
- return copy_large_unboxed_object(object, nwords);
-}
-
-static int
-size_vector_unsigned_byte_32(lispobj *where)
-{
- struct vector *vector;
- int length, nwords;
-
- vector = (struct vector *) where;
- length = fixnum_value(vector->length);
- nwords = CEILING(length + 2, 2);
-
- return nwords;
-}
-
-static int
-scav_vector_single_float(lispobj *where, lispobj object)
-{
- struct vector *vector;
- int length, nwords;
-
- vector = (struct vector *) where;
- length = fixnum_value(vector->length);
- nwords = CEILING(length + 2, 2);
-
- return nwords;
-}
-
-static lispobj
-trans_vector_single_float(lispobj object)
-{
- struct vector *vector;
- int length, nwords;
-
- gc_assert(is_lisp_pointer(object));
-
- vector = (struct vector *) native_pointer(object);
- length = fixnum_value(vector->length);
- nwords = CEILING(length + 2, 2);
-
- return copy_large_unboxed_object(object, nwords);
-}
-
-static int
-size_vector_single_float(lispobj *where)
-{
- struct vector *vector;
- int length, nwords;
-
- vector = (struct vector *) where;
- length = fixnum_value(vector->length);
- nwords = CEILING(length + 2, 2);
-
- return nwords;
-}
-
-static int
-scav_vector_double_float(lispobj *where, lispobj object)
-{
- struct vector *vector;
- int length, nwords;
-
- vector = (struct vector *) where;
- length = fixnum_value(vector->length);
- nwords = CEILING(length * 2 + 2, 2);
-
- return nwords;
-}
-
-static lispobj
-trans_vector_double_float(lispobj object)
-{
- struct vector *vector;
- int length, nwords;
-
- gc_assert(is_lisp_pointer(object));
-
- vector = (struct vector *) native_pointer(object);
- length = fixnum_value(vector->length);
- nwords = CEILING(length * 2 + 2, 2);
-
- return copy_large_unboxed_object(object, nwords);
-}
-
-static int
-size_vector_double_float(lispobj *where)
-{
- struct vector *vector;
- int length, nwords;
-
- vector = (struct vector *) where;
- length = fixnum_value(vector->length);
- nwords = CEILING(length * 2 + 2, 2);
-
- return nwords;
-}
-
-#ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
-static int
-scav_vector_long_float(lispobj *where, lispobj object)
-{
- struct vector *vector;
- int length, nwords;
-
- vector = (struct vector *) where;
- length = fixnum_value(vector->length);
- nwords = CEILING(length * 3 + 2, 2);
-
- return nwords;
-}
-
-static lispobj
-trans_vector_long_float(lispobj object)
-{
- struct vector *vector;
- int length, nwords;
-
- gc_assert(is_lisp_pointer(object));
-
- vector = (struct vector *) native_pointer(object);
- length = fixnum_value(vector->length);
- nwords = CEILING(length * 3 + 2, 2);
-
- return copy_large_unboxed_object(object, nwords);
-}
-
-static int
-size_vector_long_float(lispobj *where)
-{
- struct vector *vector;
- int length, nwords;
-
- vector = (struct vector *) where;
- length = fixnum_value(vector->length);
- nwords = CEILING(length * 3 + 2, 2);
-
- return nwords;
-}
-#endif
-
-
-#ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
-static int
-scav_vector_complex_single_float(lispobj *where, lispobj object)
-{
- struct vector *vector;
- int length, nwords;
-
- vector = (struct vector *) where;
- length = fixnum_value(vector->length);
- nwords = CEILING(length * 2 + 2, 2);
-
- return nwords;
-}
-
-static lispobj
-trans_vector_complex_single_float(lispobj object)
-{
- struct vector *vector;
- int length, nwords;
-
- gc_assert(is_lisp_pointer(object));
-
- vector = (struct vector *) native_pointer(object);
- length = fixnum_value(vector->length);
- nwords = CEILING(length * 2 + 2, 2);
-
- return copy_large_unboxed_object(object, nwords);
-}
-
-static int
-size_vector_complex_single_float(lispobj *where)
-{
- struct vector *vector;
- int length, nwords;
-
- vector = (struct vector *) where;
- length = fixnum_value(vector->length);
- nwords = CEILING(length * 2 + 2, 2);
-
- return nwords;
-}
-#endif
-
-#ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
-static int
-scav_vector_complex_double_float(lispobj *where, lispobj object)
-{
- struct vector *vector;
- int length, nwords;
-
- vector = (struct vector *) where;
- length = fixnum_value(vector->length);
- nwords = CEILING(length * 4 + 2, 2);
-
- return nwords;
-}
-
-static lispobj
-trans_vector_complex_double_float(lispobj object)
-{
- struct vector *vector;
- int length, nwords;
-
- gc_assert(is_lisp_pointer(object));
-
- vector = (struct vector *) native_pointer(object);
- length = fixnum_value(vector->length);
- nwords = CEILING(length * 4 + 2, 2);
-
- return copy_large_unboxed_object(object, nwords);
-}
-
-static int
-size_vector_complex_double_float(lispobj *where)
-{
- struct vector *vector;
- int length, nwords;
-
- vector = (struct vector *) where;
- length = fixnum_value(vector->length);
- nwords = CEILING(length * 4 + 2, 2);
-
- return nwords;
-}
-#endif
-
-
-#ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
-static int
-scav_vector_complex_long_float(lispobj *where, lispobj object)
-{
- struct vector *vector;
- int length, nwords;
-
- vector = (struct vector *) where;
- length = fixnum_value(vector->length);
- nwords = CEILING(length * 6 + 2, 2);
-
- return nwords;
-}
-
-static lispobj
-trans_vector_complex_long_float(lispobj object)
-{
- struct vector *vector;
- int length, nwords;
-
- gc_assert(is_lisp_pointer(object));
-
- vector = (struct vector *) native_pointer(object);
- length = fixnum_value(vector->length);
- nwords = CEILING(length * 6 + 2, 2);
-
- return copy_large_unboxed_object(object, nwords);
-}
-
-static int
-size_vector_complex_long_float(lispobj *where)
-{
- struct vector *vector;
- int length, nwords;
-
- vector = (struct vector *) where;
- length = fixnum_value(vector->length);
- nwords = CEILING(length * 6 + 2, 2);
-
- return nwords;
-}
-#endif
-
-\f
-/*
- * weak pointers
- */
-
-/* XX This is a hack adapted from cgc.c. These don't work too well with the
- * gencgc as a list of the weak pointers is maintained within the
- * objects which causes writes to the pages. A limited attempt is made
- * to avoid unnecessary writes, but this needs a re-think. */
-
-#define WEAK_POINTER_NWORDS \
- CEILING((sizeof(struct weak_pointer) / sizeof(lispobj)), 2)
-
-static int
-scav_weak_pointer(lispobj *where, lispobj object)
-{
- struct weak_pointer *wp = weak_pointers;
- /* Push the weak pointer onto the list of weak pointers.
- * Do I have to watch for duplicates? Originally this was
- * part of trans_weak_pointer but that didn't work in the
- * case where the WP was in a promoted region.
- */
-
- /* Check whether it's already in the list. */
- while (wp != NULL) {
- if (wp == (struct weak_pointer*)where) {
- break;
- }
- wp = wp->next;
- }
- if (wp == NULL) {
- /* Add it to the start of the list. */
- wp = (struct weak_pointer*)where;
- if (wp->next != weak_pointers) {
- wp->next = weak_pointers;
- } else {
- /*SHOW("avoided write to weak pointer");*/
- }
- weak_pointers = wp;
- }
-
- /* Do not let GC scavenge the value slot of the weak pointer.
- * (That is why it is a weak pointer.) */
-
- return WEAK_POINTER_NWORDS;
-}
-
-static lispobj
-trans_weak_pointer(lispobj object)
-{
- lispobj copy;
- /* struct weak_pointer *wp; */
-
- gc_assert(is_lisp_pointer(object));
-
-#if defined(DEBUG_WEAK)
- FSHOW((stderr, "Transporting weak pointer from 0x%08x\n", object));
-#endif
-
- /* Need to remember where all the weak pointers are that have */
- /* been transported so they can be fixed up in a post-GC pass. */
-
- copy = copy_object(object, WEAK_POINTER_NWORDS);
- /* wp = (struct weak_pointer *) native_pointer(copy);*/
-
-
- /* Push the weak pointer onto the list of weak pointers. */
- /* wp->next = weak_pointers;
- * weak_pointers = wp;*/
-
- return copy;
-}
-
-static int
-size_weak_pointer(lispobj *where)
-{
- return WEAK_POINTER_NWORDS;
-}
-
-void scan_weak_pointers(void)
-{
- struct weak_pointer *wp;
- for (wp = weak_pointers; wp != NULL; wp = wp->next) {
- lispobj value = wp->value;
- lispobj *first_pointer;
-
- first_pointer = (lispobj *)native_pointer(value);
-
- if (is_lisp_pointer(value) && from_space_p(value)) {
- /* Now, we need to check whether the object has been forwarded. If
- * it has been, the weak pointer is still good and needs to be
- * updated. Otherwise, the weak pointer needs to be nil'ed
- * out. */
- if (first_pointer[0] == 0x01) {
- wp->value = first_pointer[1];
- } else {
- /* Break it. */
- wp->value = NIL;
- wp->broken = T;
- }
- }
- }
-}
-\f
-/*
- * initialization
- */
-
-static int
-scav_lose(lispobj *where, lispobj object)
-{
- lose("no scavenge function for object 0x%08x (widetag 0x%x)",
- (unsigned long)object,
- widetag_of(*(lispobj*)native_pointer(object)));
- return 0; /* bogus return value to satisfy static type checking */
-}
-
-static lispobj
-trans_lose(lispobj object)
-{
- lose("no transport function for object 0x%08x (widetag 0x%x)",
- (unsigned long)object,
- widetag_of(*(lispobj*)native_pointer(object)));
- return NIL; /* bogus return value to satisfy static type checking */
-}
-
-static int
-size_lose(lispobj *where)
-{
- lose("no size function for object at 0x%08x (widetag 0x%x)",
- (unsigned long)where,
- widetag_of(where));
- return 1; /* bogus return value to satisfy static type checking */
-}
-
-static void
-gc_init_tables(void)
-{
- int i;
-
- /* Set default value in all slots of scavenge table. */
- for (i = 0; i < 256; i++) { /* FIXME: bare constant length, ick! */
- scavtab[i] = scav_lose;
- }
-
- /* For each type which can be selected by the lowtag alone, set
- * multiple entries in our widetag scavenge table (one for each
- * possible value of the high bits).
- *
- * FIXME: bare constant 32 and 3 here, ick! */
- for (i = 0; i < 32; i++) {
- scavtab[EVEN_FIXNUM_LOWTAG|(i<<3)] = scav_immediate;
- scavtab[FUN_POINTER_LOWTAG|(i<<3)] = scav_fun_pointer;
- /* skipping OTHER_IMMEDIATE_0_LOWTAG */
- scavtab[LIST_POINTER_LOWTAG|(i<<3)] = scav_list_pointer;
- scavtab[ODD_FIXNUM_LOWTAG|(i<<3)] = scav_immediate;
- scavtab[INSTANCE_POINTER_LOWTAG|(i<<3)] = scav_instance_pointer;
- /* skipping OTHER_IMMEDIATE_1_LOWTAG */
- scavtab[OTHER_POINTER_LOWTAG|(i<<3)] = scav_other_pointer;
- }
-
- /* Other-pointer types (those selected by all eight bits of the
- * tag) get one entry each in the scavenge table. */
- scavtab[BIGNUM_WIDETAG] = scav_unboxed;
- scavtab[RATIO_WIDETAG] = scav_boxed;
- scavtab[SINGLE_FLOAT_WIDETAG] = scav_unboxed;
- scavtab[DOUBLE_FLOAT_WIDETAG] = scav_unboxed;
-#ifdef LONG_FLOAT_WIDETAG
- scavtab[LONG_FLOAT_WIDETAG] = scav_unboxed;
-#endif
- scavtab[COMPLEX_WIDETAG] = scav_boxed;
-#ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
- scavtab[COMPLEX_SINGLE_FLOAT_WIDETAG] = scav_unboxed;
-#endif
-#ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
- scavtab[COMPLEX_DOUBLE_FLOAT_WIDETAG] = scav_unboxed;
-#endif
-#ifdef COMPLEX_LONG_FLOAT_WIDETAG
- scavtab[COMPLEX_LONG_FLOAT_WIDETAG] = scav_unboxed;
-#endif
- scavtab[SIMPLE_ARRAY_WIDETAG] = scav_boxed;
- scavtab[SIMPLE_STRING_WIDETAG] = scav_string;
- scavtab[SIMPLE_BIT_VECTOR_WIDETAG] = scav_vector_bit;
- scavtab[SIMPLE_VECTOR_WIDETAG] = scav_vector;
- scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG] =
- scav_vector_unsigned_byte_2;
- scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG] =
- scav_vector_unsigned_byte_4;
- scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG] =
- scav_vector_unsigned_byte_8;
- scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG] =
- scav_vector_unsigned_byte_16;
- scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG] =
- scav_vector_unsigned_byte_32;
-#ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
- scavtab[SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG] = scav_vector_unsigned_byte_8;
-#endif
-#ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
- scavtab[SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG] =
- scav_vector_unsigned_byte_16;
-#endif
-#ifdef SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG
- scavtab[SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG] =
- scav_vector_unsigned_byte_32;
-#endif
-#ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
- scavtab[SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG] =
- scav_vector_unsigned_byte_32;
-#endif
- scavtab[SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG] = scav_vector_single_float;
- scavtab[SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG] = scav_vector_double_float;
-#ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
- scavtab[SIMPLE_ARRAY_LONG_FLOAT_WIDETAG] = scav_vector_long_float;
-#endif
-#ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
- scavtab[SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG] =
- scav_vector_complex_single_float;
-#endif
-#ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
- scavtab[SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG] =
- scav_vector_complex_double_float;
-#endif
-#ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
- scavtab[SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG] =
- scav_vector_complex_long_float;
-#endif
- scavtab[COMPLEX_STRING_WIDETAG] = scav_boxed;
- scavtab[COMPLEX_BIT_VECTOR_WIDETAG] = scav_boxed;
- scavtab[COMPLEX_VECTOR_WIDETAG] = scav_boxed;
- scavtab[COMPLEX_ARRAY_WIDETAG] = scav_boxed;
- scavtab[CODE_HEADER_WIDETAG] = scav_code_header;
- /*scavtab[SIMPLE_FUN_HEADER_WIDETAG] = scav_fun_header;*/
- /*scavtab[CLOSURE_FUN_HEADER_WIDETAG] = scav_fun_header;*/
- /*scavtab[RETURN_PC_HEADER_WIDETAG] = scav_return_pc_header;*/
-#ifdef __i386__
- scavtab[CLOSURE_HEADER_WIDETAG] = scav_closure_header;
- scavtab[FUNCALLABLE_INSTANCE_HEADER_WIDETAG] = scav_closure_header;
-#else
- scavtab[CLOSURE_HEADER_WIDETAG] = scav_boxed;
- scavtab[FUNCALLABLE_INSTANCE_HEADER_WIDETAG] = scav_boxed;
-#endif
- scavtab[VALUE_CELL_HEADER_WIDETAG] = scav_boxed;
- scavtab[SYMBOL_HEADER_WIDETAG] = scav_boxed;
- scavtab[BASE_CHAR_WIDETAG] = scav_immediate;
- scavtab[SAP_WIDETAG] = scav_unboxed;
- scavtab[UNBOUND_MARKER_WIDETAG] = scav_immediate;
- scavtab[WEAK_POINTER_WIDETAG] = scav_weak_pointer;
- scavtab[INSTANCE_HEADER_WIDETAG] = scav_boxed;
- scavtab[FDEFN_WIDETAG] = scav_fdefn;
-
- /* transport other table, initialized same way as scavtab */
- for (i = 0; i < 256; i++)
- transother[i] = trans_lose;
- transother[BIGNUM_WIDETAG] = trans_unboxed;
- transother[RATIO_WIDETAG] = trans_boxed;
- transother[SINGLE_FLOAT_WIDETAG] = trans_unboxed;
- transother[DOUBLE_FLOAT_WIDETAG] = trans_unboxed;
-#ifdef LONG_FLOAT_WIDETAG
- transother[LONG_FLOAT_WIDETAG] = trans_unboxed;
-#endif
- transother[COMPLEX_WIDETAG] = trans_boxed;
-#ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
- transother[COMPLEX_SINGLE_FLOAT_WIDETAG] = trans_unboxed;
-#endif
-#ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
- transother[COMPLEX_DOUBLE_FLOAT_WIDETAG] = trans_unboxed;
-#endif
-#ifdef COMPLEX_LONG_FLOAT_WIDETAG
- transother[COMPLEX_LONG_FLOAT_WIDETAG] = trans_unboxed;
-#endif
- transother[SIMPLE_ARRAY_WIDETAG] = trans_boxed_large;
- transother[SIMPLE_STRING_WIDETAG] = trans_string;
- transother[SIMPLE_BIT_VECTOR_WIDETAG] = trans_vector_bit;
- transother[SIMPLE_VECTOR_WIDETAG] = trans_vector;
- transother[SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG] =
- trans_vector_unsigned_byte_2;
- transother[SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG] =
- trans_vector_unsigned_byte_4;
- transother[SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG] =
- trans_vector_unsigned_byte_8;
- transother[SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG] =
- trans_vector_unsigned_byte_16;
- transother[SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG] =
- trans_vector_unsigned_byte_32;
-#ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
- transother[SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG] =
- trans_vector_unsigned_byte_8;
-#endif
-#ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
- transother[SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG] =
- trans_vector_unsigned_byte_16;
-#endif
-#ifdef SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG
- transother[SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG] =
- trans_vector_unsigned_byte_32;
-#endif
-#ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
- transother[SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG] =
- trans_vector_unsigned_byte_32;
-#endif
- transother[SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG] =
- trans_vector_single_float;
- transother[SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG] =
- trans_vector_double_float;
-#ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
- transother[SIMPLE_ARRAY_LONG_FLOAT_WIDETAG] =
- trans_vector_long_float;
-#endif
-#ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
- transother[SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG] =
- trans_vector_complex_single_float;
-#endif
-#ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
- transother[SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG] =
- trans_vector_complex_double_float;
-#endif
-#ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
- transother[SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG] =
- trans_vector_complex_long_float;
-#endif
- transother[COMPLEX_STRING_WIDETAG] = trans_boxed;
- transother[COMPLEX_BIT_VECTOR_WIDETAG] = trans_boxed;
- transother[COMPLEX_VECTOR_WIDETAG] = trans_boxed;
- transother[COMPLEX_ARRAY_WIDETAG] = trans_boxed;
- transother[CODE_HEADER_WIDETAG] = trans_code_header;
- transother[SIMPLE_FUN_HEADER_WIDETAG] = trans_fun_header;
- transother[CLOSURE_FUN_HEADER_WIDETAG] = trans_fun_header;
- transother[RETURN_PC_HEADER_WIDETAG] = trans_return_pc_header;
- transother[CLOSURE_HEADER_WIDETAG] = trans_boxed;
- transother[FUNCALLABLE_INSTANCE_HEADER_WIDETAG] = trans_boxed;
- transother[VALUE_CELL_HEADER_WIDETAG] = trans_boxed;
- transother[SYMBOL_HEADER_WIDETAG] = trans_boxed;
- transother[BASE_CHAR_WIDETAG] = trans_immediate;
- transother[SAP_WIDETAG] = trans_unboxed;
- transother[UNBOUND_MARKER_WIDETAG] = trans_immediate;
- transother[WEAK_POINTER_WIDETAG] = trans_weak_pointer;
- transother[INSTANCE_HEADER_WIDETAG] = trans_boxed;
- transother[FDEFN_WIDETAG] = trans_boxed;
-
- /* size table, initialized the same way as scavtab */
- for (i = 0; i < 256; i++)
- sizetab[i] = size_lose;
- for (i = 0; i < 32; i++) {
- sizetab[EVEN_FIXNUM_LOWTAG|(i<<3)] = size_immediate;
- sizetab[FUN_POINTER_LOWTAG|(i<<3)] = size_pointer;
- /* skipping OTHER_IMMEDIATE_0_LOWTAG */
- sizetab[LIST_POINTER_LOWTAG|(i<<3)] = size_pointer;
- sizetab[ODD_FIXNUM_LOWTAG|(i<<3)] = size_immediate;
- sizetab[INSTANCE_POINTER_LOWTAG|(i<<3)] = size_pointer;
- /* skipping OTHER_IMMEDIATE_1_LOWTAG */
- sizetab[OTHER_POINTER_LOWTAG|(i<<3)] = size_pointer;
- }
- sizetab[BIGNUM_WIDETAG] = size_unboxed;
- sizetab[RATIO_WIDETAG] = size_boxed;
- sizetab[SINGLE_FLOAT_WIDETAG] = size_unboxed;
- sizetab[DOUBLE_FLOAT_WIDETAG] = size_unboxed;
-#ifdef LONG_FLOAT_WIDETAG
- sizetab[LONG_FLOAT_WIDETAG] = size_unboxed;
-#endif
- sizetab[COMPLEX_WIDETAG] = size_boxed;
-#ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
- sizetab[COMPLEX_SINGLE_FLOAT_WIDETAG] = size_unboxed;
-#endif
-#ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
- sizetab[COMPLEX_DOUBLE_FLOAT_WIDETAG] = size_unboxed;
-#endif
-#ifdef COMPLEX_LONG_FLOAT_WIDETAG
- sizetab[COMPLEX_LONG_FLOAT_WIDETAG] = size_unboxed;
-#endif
- sizetab[SIMPLE_ARRAY_WIDETAG] = size_boxed;
- sizetab[SIMPLE_STRING_WIDETAG] = size_string;
- sizetab[SIMPLE_BIT_VECTOR_WIDETAG] = size_vector_bit;
- sizetab[SIMPLE_VECTOR_WIDETAG] = size_vector;
- sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG] =
- size_vector_unsigned_byte_2;
- sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG] =
- size_vector_unsigned_byte_4;
- sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG] =
- size_vector_unsigned_byte_8;
- sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG] =
- size_vector_unsigned_byte_16;
- sizetab[SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG] =
- size_vector_unsigned_byte_32;
-#ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
- sizetab[SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG] = size_vector_unsigned_byte_8;
-#endif
-#ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
- sizetab[SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG] =
- size_vector_unsigned_byte_16;
-#endif
-#ifdef SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG
- sizetab[SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG] =
- size_vector_unsigned_byte_32;
-#endif
-#ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
- sizetab[SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG] =
- size_vector_unsigned_byte_32;
-#endif
- sizetab[SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG] = size_vector_single_float;
- sizetab[SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG] = size_vector_double_float;
-#ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
- sizetab[SIMPLE_ARRAY_LONG_FLOAT_WIDETAG] = size_vector_long_float;
-#endif
-#ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
- sizetab[SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG] =
- size_vector_complex_single_float;
-#endif
-#ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
- sizetab[SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG] =
- size_vector_complex_double_float;
-#endif
-#ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
- sizetab[SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG] =
- size_vector_complex_long_float;
-#endif
- sizetab[COMPLEX_STRING_WIDETAG] = size_boxed;
- sizetab[COMPLEX_BIT_VECTOR_WIDETAG] = size_boxed;
- sizetab[COMPLEX_VECTOR_WIDETAG] = size_boxed;
- sizetab[COMPLEX_ARRAY_WIDETAG] = size_boxed;
- sizetab[CODE_HEADER_WIDETAG] = size_code_header;
-#if 0
- /* We shouldn't see these, so just lose if it happens. */
- sizetab[SIMPLE_FUN_HEADER_WIDETAG] = size_function_header;
- sizetab[CLOSURE_FUN_HEADER_WIDETAG] = size_function_header;
- sizetab[RETURN_PC_HEADER_WIDETAG] = size_return_pc_header;
-#endif
- sizetab[CLOSURE_HEADER_WIDETAG] = size_boxed;
- sizetab[FUNCALLABLE_INSTANCE_HEADER_WIDETAG] = size_boxed;
- sizetab[VALUE_CELL_HEADER_WIDETAG] = size_boxed;
- sizetab[SYMBOL_HEADER_WIDETAG] = size_boxed;
- sizetab[BASE_CHAR_WIDETAG] = size_immediate;
- sizetab[SAP_WIDETAG] = size_unboxed;
- sizetab[UNBOUND_MARKER_WIDETAG] = size_immediate;
- sizetab[WEAK_POINTER_WIDETAG] = size_weak_pointer;
- sizetab[INSTANCE_HEADER_WIDETAG] = size_boxed;
- sizetab[FDEFN_WIDETAG] = size_boxed;
-}
-\f
-/* Scan an area looking for an object which encloses the given pointer.
- * Return the object start on success or NULL on failure. */
-static lispobj *
-search_space(lispobj *start, size_t words, lispobj *pointer)
-{
- while (words > 0) {
- size_t count = 1;
- lispobj thing = *start;
-
- /* If thing is an immediate then this is a cons. */
- if (is_lisp_pointer(thing)
- || ((thing & 3) == 0) /* fixnum */
- || (widetag_of(thing) == BASE_CHAR_WIDETAG)
- || (widetag_of(thing) == UNBOUND_MARKER_WIDETAG))
- count = 2;
- else
- count = (sizetab[widetag_of(thing)])(start);
-
- /* Check whether the pointer is within this object. */
- if ((pointer >= start) && (pointer < (start+count))) {
- /* found it! */
- /*FSHOW((stderr,"/found %x in %x %x\n", pointer, start, thing));*/
- return(start);
- }
-
- /* Round up the count. */
- count = CEILING(count,2);
-
- start += count;
- words -= count;
- }
- return (NULL);
-}
-
-static lispobj*
-search_read_only_space(lispobj *pointer)
-{
- lispobj* start = (lispobj*)READ_ONLY_SPACE_START;
- lispobj* end = (lispobj*)SymbolValue(READ_ONLY_SPACE_FREE_POINTER);
- if ((pointer < start) || (pointer >= end))
- return NULL;
- return (search_space(start, (pointer+2)-start, pointer));
-}
-
-static lispobj *
-search_static_space(lispobj *pointer)
-{
- lispobj* start = (lispobj*)STATIC_SPACE_START;
- lispobj* end = (lispobj*)SymbolValue(STATIC_SPACE_FREE_POINTER);
- if ((pointer < start) || (pointer >= end))
- return NULL;
- return (search_space(start, (pointer+2)-start, pointer));
-}
-
-/* a faster version for searching the dynamic space. This will work even
- * if the object is in a current allocation region. */
-lispobj *
-search_dynamic_space(lispobj *pointer)
-{
- int page_index = find_page_index(pointer);
- lispobj *start;
-
- /* The address may be invalid, so do some checks. */
- if ((page_index == -1) || (page_table[page_index].allocated == FREE_PAGE))
- return NULL;
- start = (lispobj *)((void *)page_address(page_index)
- + page_table[page_index].first_object_offset);
- return (search_space(start, (pointer+2)-start, pointer));
-}
-
-/* Is there any possibility that pointer is a valid Lisp object
- * reference, and/or something else (e.g. subroutine call return
- * address) which should prevent us from moving the referred-to thing? */
-static int
-possibly_valid_dynamic_space_pointer(lispobj *pointer)
-{
- lispobj *start_addr;
-
- /* Find the object start address. */
- if ((start_addr = search_dynamic_space(pointer)) == NULL) {
- return 0;
- }
-
- /* 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) {
- /* XXX could do some further checks here */
- return 1;
- }
-
- /* 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.
- *
- * FIXME: It's not safe to rely on the result from this check
- * before an object is initialized. Thus, if we were interrupted
- * just as an object had been allocated but not initialized, the
- * GC relying on this result could bogusly reclaim the memory.
- * However, we can't really afford to do without this check. So
- * we should make it safe somehow.
- * (1) Perhaps just review the code to make sure
- * that WITHOUT-GCING or WITHOUT-INTERRUPTS or some such
- * thing is wrapped around critical sections where allocated
- * memory type bits haven't been set.
- * (2) Perhaps find some other hack to protect against this, e.g.
- * recording the result of the last call to allocate-lisp-memory,
- * and returning true from this function when *pointer is
- * a reference to that result. */
- 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 ((unsigned)pointer !=
- ((unsigned)start_addr+FUN_POINTER_LOWTAG)) {
- if (gencgc_verbose)
- FSHOW((stderr,
- "/Wf2: %x %x %x\n",
- pointer, start_addr, *start_addr));
- return 0;
- }
- break;
- default:
- if (gencgc_verbose)
- FSHOW((stderr,
- "/Wf3: %x %x %x\n",
- pointer, start_addr, *start_addr));
- return 0;
- }
- break;
- case LIST_POINTER_LOWTAG:
- if ((unsigned)pointer !=
- ((unsigned)start_addr+LIST_POINTER_LOWTAG)) {
- if (gencgc_verbose)
- FSHOW((stderr,
- "/Wl1: %x %x %x\n",
- pointer, start_addr, *start_addr));
- return 0;
- }
- /* Is it plausible cons? */
- if ((is_lisp_pointer(start_addr[0])
- || ((start_addr[0] & 3) == 0) /* fixnum */
- || (widetag_of(start_addr[0]) == BASE_CHAR_WIDETAG)
- || (widetag_of(start_addr[0]) == UNBOUND_MARKER_WIDETAG))
- && (is_lisp_pointer(start_addr[1])
- || ((start_addr[1] & 3) == 0) /* fixnum */
- || (widetag_of(start_addr[1]) == BASE_CHAR_WIDETAG)
- || (widetag_of(start_addr[1]) == UNBOUND_MARKER_WIDETAG)))
- break;
- else {
- if (gencgc_verbose)
- FSHOW((stderr,
- "/Wl2: %x %x %x\n",
- pointer, start_addr, *start_addr));
- return 0;
- }
- case INSTANCE_POINTER_LOWTAG:
- if ((unsigned)pointer !=
- ((unsigned)start_addr+INSTANCE_POINTER_LOWTAG)) {
- if (gencgc_verbose)
- FSHOW((stderr,
- "/Wi1: %x %x %x\n",
- pointer, start_addr, *start_addr));
- return 0;
- }
- if (widetag_of(start_addr[0]) != INSTANCE_HEADER_WIDETAG) {
- if (gencgc_verbose)
- FSHOW((stderr,
- "/Wi2: %x %x %x\n",
- pointer, start_addr, *start_addr));
- return 0;
- }
- break;
- case OTHER_POINTER_LOWTAG:
- if ((unsigned)pointer !=
- ((int)start_addr+OTHER_POINTER_LOWTAG)) {
- if (gencgc_verbose)
- FSHOW((stderr,
- "/Wo1: %x %x %x\n",
- pointer, start_addr, *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] & 3) == 0)) {
- if (gencgc_verbose)
- FSHOW((stderr,
- "/Wo2: %x %x %x\n",
- pointer, start_addr, *start_addr));
- return 0;
- }
- switch (widetag_of(start_addr[0])) {
- case UNBOUND_MARKER_WIDETAG:
- case BASE_CHAR_WIDETAG:
- if (gencgc_verbose)
- FSHOW((stderr,
- "*Wo3: %x %x %x\n",
- pointer, start_addr, *start_addr));
- return 0;
-
- /* only pointed to by function pointers? */
- case CLOSURE_HEADER_WIDETAG:
- case FUNCALLABLE_INSTANCE_HEADER_WIDETAG:
- if (gencgc_verbose)
- FSHOW((stderr,
- "*Wo4: %x %x %x\n",
- pointer, start_addr, *start_addr));
- return 0;
-
- case INSTANCE_HEADER_WIDETAG:
- if (gencgc_verbose)
- FSHOW((stderr,
- "*Wo5: %x %x %x\n",
- pointer, start_addr, *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_STRING_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:
- case SINGLE_FLOAT_WIDETAG:
- case DOUBLE_FLOAT_WIDETAG:
-#ifdef LONG_FLOAT_WIDETAG
- case LONG_FLOAT_WIDETAG:
-#endif
- case SIMPLE_STRING_WIDETAG:
- case SIMPLE_BIT_VECTOR_WIDETAG:
- case SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG:
- case SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG:
- case SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG:
- case SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG:
- case SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG:
-#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
- 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:
- break;
-
- default:
- if (gencgc_verbose)
- FSHOW((stderr,
- "/Wo6: %x %x %x\n",
- pointer, start_addr, *start_addr));
- return 0;
- }
- break;
- default:
- if (gencgc_verbose)
- FSHOW((stderr,
- "*W?: %x %x %x\n",
- pointer, start_addr, *start_addr));
- return 0;