X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fruntime%2Fgc-common.c;h=f84d1505a39fae3dfeb8edca60531ea0850ce46a;hb=cb83aa22932bf4b9bc74ac6f0fcd91db1702ad33;hp=8e8b3fa244598cc0e8e871ee1afc66fcc7289871;hpb=f3f677703e37f5a335b3be7fa64f7748ad969517;p=sbcl.git diff --git a/src/runtime/gc-common.c b/src/runtime/gc-common.c index 8e8b3fa..f84d150 100644 --- a/src/runtime/gc-common.c +++ b/src/runtime/gc-common.c @@ -1,5 +1,5 @@ /* - * Garbage Collection common functions for scavenging, moving and sizing + * Garbage Collection common functions for scavenging, moving and sizing * objects. These are for use with both GC (stop & copy GC) and GENCGC */ @@ -42,6 +42,7 @@ #include "genesis/primitive-objects.h" #include "genesis/static-symbols.h" #include "genesis/layout.h" +#include "genesis/hash-table.h" #include "gc-internal.h" #ifdef LISP_FEATURE_SPARC @@ -52,14 +53,16 @@ #endif #endif -inline static boolean +size_t dynamic_space_size = DEFAULT_DYNAMIC_SPACE_SIZE; + +inline static boolean forwarding_pointer_p(lispobj *pointer) { - lispobj first_word=*pointer; + lispobj first_word=*pointer; #ifdef LISP_FEATURE_GENCGC return (first_word == 0x01); #else return (is_lisp_pointer(first_word) - && new_space_p(first_word)); + && new_space_p(first_word)); #endif } @@ -127,67 +130,71 @@ scavenge(lispobj *start, long n_words) lispobj *end = start + n_words; lispobj *object_ptr; long n_words_scavenged; - for (object_ptr = start; - object_ptr < end; - object_ptr += n_words_scavenged) { + for (object_ptr = start; + object_ptr < end; + object_ptr += n_words_scavenged) { - lispobj object = *object_ptr; + lispobj object = *object_ptr; #ifdef LISP_FEATURE_GENCGC - gc_assert(!forwarding_pointer_p(object_ptr)); -#endif - if (is_lisp_pointer(object)) { - if (from_space_p(object)) { - /* It currently points to old space. Check for a - * forwarding pointer. */ - lispobj *ptr = native_pointer(object); - if (forwarding_pointer_p(ptr)) { - /* Yes, there's a forwarding pointer. */ - *object_ptr = LOW_WORD(forwarding_pointer_value(ptr)); - n_words_scavenged = 1; - } else { - /* Scavenge that pointer. */ - n_words_scavenged = - (scavtab[widetag_of(object)])(object_ptr, object); - } - } else { - /* It points somewhere other than oldspace. Leave it - * alone. */ - n_words_scavenged = 1; - } - } -#ifndef LISP_FEATURE_GENCGC - /* this workaround is probably not necessary for gencgc; at least, the - * behaviour it describes has never been reported */ - else if (n_words==1) { - /* there are some situations where an - other-immediate may end up in a descriptor - register. I'm not sure whether this is - supposed to happen, but if it does then we - don't want to (a) barf or (b) scavenge over the - data-block, because there isn't one. So, if - we're checking a single word and it's anything - other than a pointer, just hush it up */ - int type=widetag_of(object); - n_words_scavenged=1; - - if ((scavtab[type]==scav_lose) || - (((scavtab[type])(start,object))>1)) { - fprintf(stderr,"warning: attempted to scavenge non-descriptor value %x at %p. If you can\nreproduce this warning, send a bug report (see manual page for details)\n", - object,start); - } - } -#endif - else if (fixnump(object)) { - /* It's a fixnum: really easy.. */ - n_words_scavenged = 1; - } else { - /* It's some sort of header object or another. */ - n_words_scavenged = - (scavtab[widetag_of(object)])(object_ptr, object); - } + gc_assert(!forwarding_pointer_p(object_ptr)); +#endif + if (is_lisp_pointer(object)) { + if (from_space_p(object)) { + /* It currently points to old space. Check for a + * forwarding pointer. */ + lispobj *ptr = native_pointer(object); + if (forwarding_pointer_p(ptr)) { + /* Yes, there's a forwarding pointer. */ + *object_ptr = LOW_WORD(forwarding_pointer_value(ptr)); + n_words_scavenged = 1; + } else { + /* Scavenge that pointer. */ + n_words_scavenged = + (scavtab[widetag_of(object)])(object_ptr, object); + } + } else { + /* It points somewhere other than oldspace. Leave it + * alone. */ + n_words_scavenged = 1; + } + } +#if !defined(LISP_FEATURE_X86) && !defined(LISP_FEATURE_X86_64) + /* This workaround is probably not needed for those ports + which don't have a partitioned register set (and therefore + scan the stack conservatively for roots). */ + else if (n_words == 1) { + /* there are some situations where an other-immediate may + end up in a descriptor register. I'm not sure whether + this is supposed to happen, but if it does then we + don't want to (a) barf or (b) scavenge over the + data-block, because there isn't one. So, if we're + checking a single word and it's anything other than a + pointer, just hush it up */ + int widetag = widetag_of(object); + n_words_scavenged = 1; + + if ((scavtab[widetag] == scav_lose) || + (((sizetab[widetag])(object_ptr)) > 1)) { + fprintf(stderr,"warning: \ +attempted to scavenge non-descriptor value %x at %p.\n\n\ +If you can reproduce this warning, please send a bug report\n\ +(see manual page for details).\n", + object, object_ptr); + } + } +#endif + else if (fixnump(object)) { + /* It's a fixnum: really easy.. */ + n_words_scavenged = 1; + } else { + /* It's some sort of header object or another. */ + n_words_scavenged = + (scavtab[widetag_of(object)])(object_ptr, object); + } } - gc_assert(object_ptr == end); + gc_assert_verbose(object_ptr == end, "Final object pointer %p, start %p, end %p\n", + object_ptr, start, end); } static lispobj trans_fun_header(lispobj object); /* forward decls */ @@ -209,16 +216,16 @@ scav_fun_pointer(lispobj *where, lispobj object) switch (widetag_of(*first_pointer)) { case SIMPLE_FUN_HEADER_WIDETAG: - copy = trans_fun_header(object); - break; + copy = trans_fun_header(object); + break; default: - copy = trans_boxed(object); - break; + copy = trans_boxed(object); + break; } if (copy != object) { - /* Set forwarding pointer */ - set_forwarding_pointer(first_pointer,copy); + /* Set forwarding pointer */ + set_forwarding_pointer(first_pointer,copy); } gc_assert(is_lisp_pointer(copy)); @@ -243,12 +250,12 @@ trans_code(struct code *code) first = code->header; if (forwarding_pointer_p((lispobj *)code)) { #ifdef DEBUG_CODE_GC - printf("Was already transported\n"); + printf("Was already transported\n"); #endif - return (struct code *) forwarding_pointer_value - ((lispobj *)((pointer_sized_uint_t) code)); + return (struct code *) forwarding_pointer_value + ((lispobj *)((pointer_sized_uint_t) code)); } - + gc_assert(widetag_of(first) == CODE_HEADER_WIDETAG); /* prepare to transport the code vector */ @@ -264,19 +271,19 @@ trans_code(struct code *code) #if defined(DEBUG_CODE_GC) printf("Old code object at 0x%08x, new code object at 0x%08x.\n", - (unsigned long) code, (unsigned long) new_code); + (unsigned long) code, (unsigned long) new_code); printf("Code object is %d words long.\n", nwords); #endif #ifdef LISP_FEATURE_GENCGC if (new_code == code) - return new_code; + return new_code; #endif displacement = l_new_code - l_code; set_forwarding_pointer((lispobj *)code, l_new_code); - + /* set forwarding pointers for all the function headers in the */ /* code object. also fix all self pointers */ @@ -284,40 +291,47 @@ trans_code(struct code *code) prev_pointer = &new_code->entry_points; while (fheaderl != NIL) { - struct simple_fun *fheaderp, *nfheaderp; - lispobj nfheaderl; - - fheaderp = (struct simple_fun *) native_pointer(fheaderl); - gc_assert(widetag_of(fheaderp->header) == SIMPLE_FUN_HEADER_WIDETAG); + struct simple_fun *fheaderp, *nfheaderp; + lispobj nfheaderl; + + fheaderp = (struct simple_fun *) native_pointer(fheaderl); + gc_assert(widetag_of(fheaderp->header) == SIMPLE_FUN_HEADER_WIDETAG); - /* Calculate the new function pointer and the new */ - /* function header. */ - nfheaderl = fheaderl + displacement; - nfheaderp = (struct simple_fun *) native_pointer(nfheaderl); + /* Calculate the new function pointer and the new */ + /* function header. */ + nfheaderl = fheaderl + displacement; + nfheaderp = (struct simple_fun *) native_pointer(nfheaderl); #ifdef DEBUG_CODE_GC - printf("fheaderp->header (at %x) <- %x\n", - &(fheaderp->header) , nfheaderl); + printf("fheaderp->header (at %x) <- %x\n", + &(fheaderp->header) , nfheaderl); #endif - set_forwarding_pointer((lispobj *)fheaderp, nfheaderl); - - /* fix self pointer. */ - nfheaderp->self = + set_forwarding_pointer((lispobj *)fheaderp, nfheaderl); + + /* fix self pointer. */ + nfheaderp->self = #if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64) - FUN_RAW_ADDR_OFFSET + + FUN_RAW_ADDR_OFFSET + #endif - nfheaderl; - - *prev_pointer = nfheaderl; + nfheaderl; + + *prev_pointer = nfheaderl; - fheaderl = fheaderp->next; - prev_pointer = &nfheaderp->next; + fheaderl = fheaderp->next; + prev_pointer = &nfheaderp->next; } - os_flush_icache((os_vm_address_t) (((long *)new_code) + nheader_words), - ncode_words * sizeof(long)); #ifdef LISP_FEATURE_GENCGC + /* Cheneygc doesn't need this os_flush_icache, it flushes the whole + spaces once when all copying is done. */ + os_flush_icache((os_vm_address_t) (((long *)new_code) + nheader_words), + ncode_words * sizeof(long)); + +#endif + +#if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64) gencgc_apply_code_fixups(code, new_code); #endif + return new_code; } @@ -326,7 +340,7 @@ scav_code_header(lispobj *where, lispobj object) { struct code *code; long n_header_words, n_code_words, n_words; - lispobj entry_point; /* tagged pointer to entry point */ + lispobj entry_point; /* tagged pointer to entry point */ struct simple_fun *function_ptr; /* untagged pointer to entry point */ code = (struct code *) where; @@ -341,19 +355,21 @@ scav_code_header(lispobj *where, lispobj object) /* Scavenge the boxed section of each function object in the * code data block. */ for (entry_point = code->entry_points; - entry_point != NIL; - entry_point = function_ptr->next) { + entry_point != NIL; + entry_point = function_ptr->next) { - gc_assert(is_lisp_pointer(entry_point)); + gc_assert_verbose(is_lisp_pointer(entry_point), "Entry point %lx\n", + (long)entry_point); - function_ptr = (struct simple_fun *) native_pointer(entry_point); - gc_assert(widetag_of(function_ptr->header)==SIMPLE_FUN_HEADER_WIDETAG); + function_ptr = (struct simple_fun *) native_pointer(entry_point); + gc_assert(widetag_of(function_ptr->header)==SIMPLE_FUN_HEADER_WIDETAG); - scavenge(&function_ptr->name, 1); - scavenge(&function_ptr->arglist, 1); - scavenge(&function_ptr->type, 1); + scavenge(&function_ptr->name, 1); + scavenge(&function_ptr->arglist, 1); + scavenge(&function_ptr->type, 1); + scavenge(&function_ptr->xrefs, 1); } - + return n_words; } @@ -374,7 +390,7 @@ size_code_header(lispobj *where) long nheader_words, ncode_words, nwords; code = (struct code *) where; - + ncode_words = fixnum_value(code->code_size); nheader_words = HeaderValue(code->header); nwords = ncode_words + nheader_words; @@ -387,9 +403,9 @@ size_code_header(lispobj *where) static long scav_return_pc_header(lispobj *where, lispobj object) { - lose("attempted to scavenge a return PC header where=0x%08x object=0x%08x", - (unsigned long) where, - (unsigned long) object); + lose("attempted to scavenge a return PC header where=0x%08x object=0x%08x\n", + (unsigned long) where, + (unsigned long) object); return 0; /* bogus return value to satisfy static type checking */ } #endif /* LISP_FEATURE_X86 */ @@ -432,7 +448,7 @@ scav_closure_header(lispobj *where, lispobj object) /* The function may have moved so update the raw address. But * don't write unnecessarily. */ if (closure->fun != fun + FUN_RAW_ADDR_OFFSET) - closure->fun = fun + FUN_RAW_ADDR_OFFSET; + closure->fun = fun + FUN_RAW_ADDR_OFFSET; #endif return 2; } @@ -442,9 +458,9 @@ scav_closure_header(lispobj *where, lispobj object) static long scav_fun_header(lispobj *where, lispobj object) { - lose("attempted to scavenge a function header where=0x%08x object=0x%08x", - (unsigned long) where, - (unsigned long) object); + lose("attempted to scavenge a function header where=0x%08x object=0x%08x\n", + (unsigned long) where, + (unsigned long) object); return 0; /* bogus return value to satisfy static type checking */ } #endif /* LISP_FEATURE_X86 */ @@ -455,7 +471,7 @@ trans_fun_header(lispobj object) struct simple_fun *fheader; unsigned long offset; struct code *code, *ncode; - + fheader = (struct simple_fun *) native_pointer(object); /* FIXME: was times 4, should it really be N_WORD_BYTES? */ offset = HeaderValue(fheader->header) * N_WORD_BYTES; @@ -532,8 +548,8 @@ trans_list(lispobj object) cons = (struct cons *) native_pointer(object); /* Copy 'object'. */ - new_cons = (struct cons *) - gc_general_alloc(sizeof(struct cons),ALLOC_BOXED,ALLOC_QUICK); + new_cons = (struct cons *) + gc_general_alloc(sizeof(struct cons),ALLOC_BOXED,ALLOC_QUICK); new_cons->car = cons->car; new_cons->cdr = cons->cdr; /* updated later */ new_list_pointer = make_lispobj(new_cons,lowtag_of(object)); @@ -546,32 +562,32 @@ trans_list(lispobj object) /* Try to linearize the list in the cdr direction to help reduce * paging. */ while (1) { - lispobj new_cdr; - struct cons *cdr_cons, *new_cdr_cons; - - if(lowtag_of(cdr) != LIST_POINTER_LOWTAG || - !from_space_p(cdr) || - forwarding_pointer_p((lispobj *)native_pointer(cdr))) - break; - - cdr_cons = (struct cons *) native_pointer(cdr); - - /* Copy 'cdr'. */ - new_cdr_cons = (struct cons*) - gc_general_alloc(sizeof(struct cons),ALLOC_BOXED,ALLOC_QUICK); - new_cdr_cons->car = cdr_cons->car; - new_cdr_cons->cdr = cdr_cons->cdr; - new_cdr = make_lispobj(new_cdr_cons, lowtag_of(cdr)); - - /* Grab the cdr before it is clobbered. */ - cdr = cdr_cons->cdr; - set_forwarding_pointer((lispobj *)cdr_cons, new_cdr); - - /* Update the cdr of the last cons copied into new space to - * keep the newspace scavenge from having to do it. */ - new_cons->cdr = new_cdr; - - new_cons = new_cdr_cons; + lispobj new_cdr; + struct cons *cdr_cons, *new_cdr_cons; + + if(lowtag_of(cdr) != LIST_POINTER_LOWTAG || + !from_space_p(cdr) || + forwarding_pointer_p((lispobj *)native_pointer(cdr))) + break; + + cdr_cons = (struct cons *) native_pointer(cdr); + + /* Copy 'cdr'. */ + new_cdr_cons = (struct cons*) + gc_general_alloc(sizeof(struct cons),ALLOC_BOXED,ALLOC_QUICK); + new_cdr_cons->car = cdr_cons->car; + new_cdr_cons->cdr = cdr_cons->cdr; + new_cdr = make_lispobj(new_cdr_cons, lowtag_of(cdr)); + + /* Grab the cdr before it is clobbered. */ + cdr = cdr_cons->cdr; + set_forwarding_pointer((lispobj *)cdr_cons, new_cdr); + + /* Update the cdr of the last cons copied into new space to + * keep the newspace scavenge from having to do it. */ + new_cons->cdr = new_cdr; + + new_cons = new_cdr_cons; } return new_list_pointer; @@ -594,9 +610,9 @@ scav_other_pointer(lispobj *where, lispobj object) first = (transother[widetag_of(*first_pointer)])(object); if (first != object) { - set_forwarding_pointer(first_pointer, first); + set_forwarding_pointer(first_pointer, first); #ifdef LISP_FEATURE_GENCGC - *where = first; + *where = first; #endif } #ifndef LISP_FEATURE_GENCGC @@ -627,7 +643,7 @@ scav_immediate(lispobj *where, lispobj object) static lispobj trans_immediate(lispobj object) { - lose("trying to transport an immediate"); + lose("trying to transport an immediate\n"); return NIL; /* bogus return value to satisfy static type checking */ } @@ -649,10 +665,10 @@ scav_instance(lispobj *where, lispobj object) { lispobj nuntagged; long ntotal = HeaderValue(object); - lispobj layout = ((struct instance *)native_pointer(where))->slots[0]; + lispobj layout = ((struct instance *)where)->slots[0]; if (!layout) - return 1; + return 1; if (forwarding_pointer_p(native_pointer(layout))) layout = (lispobj) forwarding_pointer_value(native_pointer(layout)); @@ -693,7 +709,7 @@ size_boxed(lispobj *where) /* Note: on the sparc we don't have to do anything special for fdefns, */ /* 'cause the raw-addr has a function lowtag. */ -#ifndef LISP_FEATURE_SPARC +#if !defined(LISP_FEATURE_SPARC) static long scav_fdefn(lispobj *where, lispobj object) { @@ -701,23 +717,23 @@ scav_fdefn(lispobj *where, lispobj object) fdefn = (struct fdefn *)where; - /* FSHOW((stderr, "scav_fdefn, function = %p, raw_addr = %p\n", + /* FSHOW((stderr, "scav_fdefn, function = %p, raw_addr = %p\n", fdefn->fun, fdefn->raw_addr)); */ - if ((char *)(fdefn->fun + FUN_RAW_ADDR_OFFSET) - == (char *)((unsigned long)(fdefn->raw_addr))) { - scavenge(where + 1, sizeof(struct fdefn)/sizeof(lispobj) - 1); + if ((char *)(fdefn->fun + FUN_RAW_ADDR_OFFSET) + == (char *)((unsigned long)(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); - /* gc.c has more casts here, which may be relevant or alternatively - may be compiler warning defeaters. try + /* 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); + /* gc.c has more casts here, which may be relevant or alternatively + may be compiler warning defeaters. try fdefn->raw_addr = ((char *) LOW_WORD(fdefn->fun)) + FUN_RAW_ADDR_OFFSET; - */ - return sizeof(struct fdefn) / sizeof(lispobj); + */ + return sizeof(struct fdefn) / sizeof(lispobj); } else { - return 1; + return 1; } } #endif @@ -1300,9 +1316,9 @@ scav_vector_long_float(lispobj *where, lispobj object) vector = (struct vector *) where; length = fixnum_value(vector->length); - nwords = CEILING(length * - LONG_FLOAT_SIZE - + 2, 2); + nwords = CEILING(length * + LONG_FLOAT_SIZE + + 2, 2); return nwords; } @@ -1467,7 +1483,7 @@ size_vector_complex_long_float(lispobj *where) #endif #define WEAK_POINTER_NWORDS \ - CEILING((sizeof(struct weak_pointer) / sizeof(lispobj)), 2) + CEILING((sizeof(struct weak_pointer) / sizeof(lispobj)), 2) static lispobj trans_weak_pointer(lispobj object) @@ -1488,10 +1504,10 @@ trans_weak_pointer(lispobj object) copy = copy_object(object, WEAK_POINTER_NWORDS); #ifndef LISP_FEATURE_GENCGC wp = (struct weak_pointer *) native_pointer(copy); - + gc_assert(widetag_of(wp->header)==WEAK_POINTER_WIDETAG); /* Push the weak pointer onto the list of weak pointers. */ - wp->next = LOW_WORD(weak_pointers); + wp->next = (struct weak_pointer *)LOW_WORD(weak_pointers); weak_pointers = wp; #endif return copy; @@ -1507,32 +1523,385 @@ size_weak_pointer(lispobj *where) void scan_weak_pointers(void) { struct weak_pointer *wp; - for (wp = weak_pointers; wp != NULL; - wp=(struct weak_pointer *)native_pointer(wp->next)) { - lispobj value = wp->value; - lispobj *first_pointer; - gc_assert(widetag_of(wp->header)==WEAK_POINTER_WIDETAG); - if (!(is_lisp_pointer(value) && from_space_p(value))) - continue; - - /* 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. */ - - first_pointer = (lispobj *)native_pointer(value); - - if (forwarding_pointer_p(first_pointer)) { - wp->value= - (lispobj)LOW_WORD(forwarding_pointer_value(first_pointer)); - } else { - /* Break it. */ - wp->value = NIL; - wp->broken = T; - } + for (wp = weak_pointers; wp != NULL; wp=wp->next) { + lispobj value = wp->value; + lispobj *first_pointer; + gc_assert(widetag_of(wp->header)==WEAK_POINTER_WIDETAG); + if (!(is_lisp_pointer(value) && from_space_p(value))) + continue; + + /* 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. */ + + first_pointer = (lispobj *)native_pointer(value); + + if (forwarding_pointer_p(first_pointer)) { + wp->value= + (lispobj)LOW_WORD(forwarding_pointer_value(first_pointer)); + } else { + /* Break it. */ + wp->value = NIL; + wp->broken = T; + } } } + +/* Hash tables */ + +#if N_WORD_BITS == 32 +#define EQ_HASH_MASK 0x1fffffff +#elif N_WORD_BITS == 64 +#define EQ_HASH_MASK 0x1fffffffffffffff +#endif + +/* Compute the EQ-hash of KEY. This must match POINTER-HASH in + * target-hash-table.lisp. */ +#define EQ_HASH(key) ((key) & EQ_HASH_MASK) + +/* List of weak hash tables chained through their NEXT-WEAK-HASH-TABLE + * slot. Set to NULL at the end of a collection. + * + * This is not optimal because, when a table is tenured, it won't be + * processed automatically; only the yougest generation is GC'd by + * default. On the other hand, all applications will need an + * occasional full GC anyway, so it's not that bad either. */ +struct hash_table *weak_hash_tables = NULL; + +/* Return true if OBJ has already survived the current GC. */ +static inline int +survived_gc_yet (lispobj obj) +{ + return (!is_lisp_pointer(obj) || !from_space_p(obj) || + forwarding_pointer_p(native_pointer(obj))); +} + +static inline int +weak_hash_entry_alivep (lispobj weakness, lispobj key, lispobj value) +{ + switch (weakness) { + case KEY: + return survived_gc_yet(key); + case VALUE: + return survived_gc_yet(value); + case KEY_OR_VALUE: + return (survived_gc_yet(key) || survived_gc_yet(value)); + case KEY_AND_VALUE: + return (survived_gc_yet(key) && survived_gc_yet(value)); + default: + gc_assert(0); + /* Shut compiler up. */ + return 0; + } +} + +/* Return the beginning of data in ARRAY (skipping the header and the + * length) or NULL if it isn't an array of the specified widetag after + * all. */ +static inline lispobj * +get_array_data (lispobj array, int widetag, unsigned long *length) +{ + if (is_lisp_pointer(array) && + (widetag_of(*(lispobj *)native_pointer(array)) == widetag)) { + if (length != NULL) + *length = fixnum_value(((lispobj *)native_pointer(array))[1]); + return ((lispobj *)native_pointer(array)) + 2; + } else { + return NULL; + } +} + +/* Only need to worry about scavenging the _real_ entries in the + * table. Phantom entries such as the hash table itself at index 0 and + * the empty marker at index 1 were scavenged by scav_vector that + * either called this function directly or arranged for it to be + * called later by pushing the hash table onto weak_hash_tables. */ +static void +scav_hash_table_entries (struct hash_table *hash_table) +{ + lispobj *kv_vector; + unsigned long kv_length; + lispobj *index_vector; + unsigned long length; + lispobj *next_vector; + unsigned long next_vector_length; + lispobj *hash_vector; + unsigned long hash_vector_length; + lispobj empty_symbol; + lispobj weakness = hash_table->weakness; + long i; + + kv_vector = get_array_data(hash_table->table, + SIMPLE_VECTOR_WIDETAG, &kv_length); + if (kv_vector == NULL) + lose("invalid kv_vector %x\n", hash_table->table); + + index_vector = get_array_data(hash_table->index_vector, + SIMPLE_ARRAY_WORD_WIDETAG, &length); + if (index_vector == NULL) + lose("invalid index_vector %x\n", hash_table->index_vector); + + next_vector = get_array_data(hash_table->next_vector, + SIMPLE_ARRAY_WORD_WIDETAG, + &next_vector_length); + if (next_vector == NULL) + lose("invalid next_vector %x\n", hash_table->next_vector); + + hash_vector = get_array_data(hash_table->hash_vector, + SIMPLE_ARRAY_WORD_WIDETAG, + &hash_vector_length); + if (hash_vector != NULL) + gc_assert(hash_vector_length == next_vector_length); + + /* 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); + + empty_symbol = kv_vector[1]; + /* 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\n", + *(lispobj *)native_pointer(empty_symbol)); + } + + /* Work through the KV vector. */ + for (i = 1; i < next_vector_length; i++) { + lispobj old_key = kv_vector[2*i]; + lispobj value = kv_vector[2*i+1]; + if ((weakness == NIL) || + weak_hash_entry_alivep(weakness, old_key, value)) { + + /* Scavenge the key and value. */ + scavenge(&kv_vector[2*i],2); + + /* Rehashing of EQ based keys. */ + if ((!hash_vector) || + (hash_vector[i] == MAGIC_HASH_VECTOR_VALUE)) { +#ifndef LISP_FEATURE_GENCGC + /* For GENCGC scav_hash_table_entries only rehashes + * the entries whose keys were moved. Cheneygc always + * moves the objects so here we let the lisp side know + * that rehashing is needed for the whole table. */ + *(kv_vector - 2) = (subtype_VectorMustRehash<needing_rehash); + hash_table->needing_rehash = make_fixnum(i); + /*SHOW("P2");*/ + } else { + unsigned long prior = index_vector[old_index]; + unsigned long 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->needing_rehash); + hash_table->needing_rehash = make_fixnum(next); + /*SHOW("/P3");*/ + break; + } + prior = next; + next = next_vector[next]; + } + } + } +#endif + } + } + } +} + +long +scav_vector (lispobj *where, lispobj object) +{ + unsigned long kv_length; + lispobj *kv_vector; + struct hash_table *hash_table; + + /* SB-VM:VECTOR-VALID-HASHING-SUBTYPE is set for EQ-based and weak + * hash tables in the Lisp HASH-TABLE code to indicate need for + * special GC support. */ + if (HeaderValue(object) == subtype_VectorNormal) + 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\n", where[2]); + } + hash_table = (struct hash_table *)native_pointer(where[2]); + /*FSHOW((stderr,"/hash_table = %x\n", hash_table));*/ + if (widetag_of(hash_table->header) != INSTANCE_HEADER_WIDETAG) { + lose("hash table not instance (%x at %x)\n", + hash_table->header, + 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\n", where[3]); + } + + /* Scavenge hash table, which will fix the positions of the other + * needed objects. */ + scavenge((lispobj *)hash_table, + sizeof(struct hash_table) / sizeof(lispobj)); + + /* Cross-check the kv_vector. */ + if (where != (lispobj *)native_pointer(hash_table->table)) { + lose("hash_table table!=this table %x\n", hash_table->table); + } + + if (hash_table->weakness == NIL) { + scav_hash_table_entries(hash_table); + } else { + /* Delay scavenging of this table by pushing it onto + * weak_hash_tables (if it's not there already) for the weak + * object phase. */ + if (hash_table->next_weak_hash_table == NIL) { + hash_table->next_weak_hash_table = (lispobj)weak_hash_tables; + weak_hash_tables = hash_table; + } + } + + return (CEILING(kv_length + 2, 2)); +} + +void +scav_weak_hash_tables (void) +{ + struct hash_table *table; + + /* Scavenge entries whose triggers are known to survive. */ + for (table = weak_hash_tables; table != NULL; + table = (struct hash_table *)table->next_weak_hash_table) { + scav_hash_table_entries(table); + } +} + +/* Walk through the chain whose first element is *FIRST and remove + * dead weak entries. */ +static inline void +scan_weak_hash_table_chain (struct hash_table *hash_table, lispobj *prev, + lispobj *kv_vector, lispobj *index_vector, + lispobj *next_vector, lispobj *hash_vector, + lispobj empty_symbol, lispobj weakness) +{ + unsigned index = *prev; + while (index) { + unsigned next = next_vector[index]; + lispobj key = kv_vector[2 * index]; + lispobj value = kv_vector[2 * index + 1]; + gc_assert(key != empty_symbol); + gc_assert(value != empty_symbol); + if (!weak_hash_entry_alivep(weakness, key, value)) { + unsigned count = fixnum_value(hash_table->number_entries); + gc_assert(count > 0); + *prev = next; + hash_table->number_entries = make_fixnum(count - 1); + next_vector[index] = fixnum_value(hash_table->next_free_kv); + hash_table->next_free_kv = make_fixnum(index); + kv_vector[2 * index] = empty_symbol; + kv_vector[2 * index + 1] = empty_symbol; + if (hash_vector) + hash_vector[index] = MAGIC_HASH_VECTOR_VALUE; + } else { + prev = &next_vector[index]; + } + index = next; + } +} + +static void +scan_weak_hash_table (struct hash_table *hash_table) +{ + lispobj *kv_vector; + lispobj *index_vector; + unsigned long length = 0; /* prevent warning */ + lispobj *next_vector; + unsigned long next_vector_length = 0; /* prevent warning */ + lispobj *hash_vector; + lispobj empty_symbol; + lispobj weakness = hash_table->weakness; + long i; + + kv_vector = get_array_data(hash_table->table, + SIMPLE_VECTOR_WIDETAG, NULL); + index_vector = get_array_data(hash_table->index_vector, + SIMPLE_ARRAY_WORD_WIDETAG, &length); + next_vector = get_array_data(hash_table->next_vector, + SIMPLE_ARRAY_WORD_WIDETAG, + &next_vector_length); + hash_vector = get_array_data(hash_table->hash_vector, + SIMPLE_ARRAY_WORD_WIDETAG, NULL); + empty_symbol = kv_vector[1]; + + for (i = 0; i < length; i++) { + scan_weak_hash_table_chain(hash_table, &index_vector[i], + kv_vector, index_vector, next_vector, + hash_vector, empty_symbol, weakness); + } + { + lispobj first = fixnum_value(hash_table->needing_rehash); + scan_weak_hash_table_chain(hash_table, &first, + kv_vector, index_vector, next_vector, + hash_vector, empty_symbol, weakness); + hash_table->needing_rehash = make_fixnum(first); + } +} + +/* Remove dead entries from weak hash tables. */ +void +scan_weak_hash_tables (void) +{ + struct hash_table *table, *next; + + for (table = weak_hash_tables; table != NULL; table = next) { + next = (struct hash_table *)table->next_weak_hash_table; + table->next_weak_hash_table = NIL; + scan_weak_hash_table(table); + } + + weak_hash_tables = NULL; +} /* @@ -1542,7 +1911,7 @@ void scan_weak_pointers(void) static long scav_lose(lispobj *where, lispobj object) { - lose("no scavenge function for object 0x%08x (widetag 0x%x)", + lose("no scavenge function for object 0x%08x (widetag 0x%x)\n", (unsigned long)object, widetag_of(*(lispobj*)native_pointer(object))); @@ -1552,18 +1921,18 @@ scav_lose(lispobj *where, lispobj object) 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))); + lose("no transport function for object 0x%08x (widetag 0x%x)\n", + (unsigned long)object, + widetag_of(*(lispobj*)native_pointer(object))); return NIL; /* bogus return value to satisfy static type checking */ } static long size_lose(lispobj *where) { - lose("no size function for object at 0x%08x (widetag 0x%x)", - (unsigned long)where, - widetag_of(LOW_WORD(where))); + lose("no size function for object at 0x%08x (widetag 0x%x)\n", + (unsigned long)where, + widetag_of(LOW_WORD(where))); return 1; /* bogus return value to satisfy static type checking */ } @@ -1580,8 +1949,8 @@ gc_init_tables(void) /* Set default value in all slots of scavenge table. FIXME * replace this gnarly sizeof with something based on * N_WIDETAG_BITS */ - for (i = 0; i < ((sizeof scavtab)/(sizeof scavtab[0])); i++) { - scavtab[i] = scav_lose; + for (i = 0; i < ((sizeof scavtab)/(sizeof scavtab[0])); i++) { + scavtab[i] = scav_lose; } /* For each type which can be selected by the lowtag alone, set @@ -1590,14 +1959,14 @@ gc_init_tables(void) */ for (i = 0; i < (1<<(N_WIDETAG_BITS-N_LOWTAG_BITS)); i++) { - scavtab[EVEN_FIXNUM_LOWTAG|(i< 0) { - size_t count = 1; - lispobj thing = *start; + size_t count = 1; + lispobj thing = *start; - /* If thing is an immediate then this is a cons. */ - if (is_lisp_pointer(thing) - || (fixnump(thing)) - || (widetag_of(thing) == CHARACTER_WIDETAG) + /* If thing is an immediate then this is a cons. */ + if (is_lisp_pointer(thing) + || (fixnump(thing)) + || (widetag_of(thing) == CHARACTER_WIDETAG) #if N_WORD_BITS == 64 - || (widetag_of(thing) == SINGLE_FLOAT_WIDETAG) + || (widetag_of(thing) == SINGLE_FLOAT_WIDETAG) #endif - || (widetag_of(thing) == UNBOUND_MARKER_WIDETAG)) - count = 2; - else - count = (sizetab[widetag_of(thing)])(start); + || (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); - } + /* 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); + /* Round up the count. */ + count = CEILING(count,2); - start += count; - words -= count; + start += count; + words -= count; } return (NULL); }