- return;
-
- /* It's ok if it's byte compiled code. The trace table offset will
- * be a fixnum if it's x86 compiled code - check. */
- if (code->trace_table_offset & 0x3) {
- FSHOW((stderr, "/Sniffing byte compiled code object at %x.\n", code));
- return;
- }
-
- /* Else it's x86 machine code. */
-
- ncode_words = fixnum_value(code->code_size);
- nheader_words = HeaderValue(*(lispobj *)code);
- nwords = ncode_words + nheader_words;
-
- constants_start_addr = (void *)code + 5*4;
- constants_end_addr = (void *)code + nheader_words*4;
- code_start_addr = (void *)code + nheader_words*4;
- code_end_addr = (void *)code + nwords*4;
-
- /* Work through the unboxed code. */
- for (p = code_start_addr; p < code_end_addr; p++) {
- void *data = *(void **)p;
- unsigned d1 = *((unsigned char *)p - 1);
- unsigned d2 = *((unsigned char *)p - 2);
- unsigned d3 = *((unsigned char *)p - 3);
- unsigned d4 = *((unsigned char *)p - 4);
- unsigned d5 = *((unsigned char *)p - 5);
- unsigned d6 = *((unsigned char *)p - 6);
-
- /* Check for code references. */
- /* Check for a 32 bit word that looks like an absolute
- reference to within the code adea of the code object. */
- if ((data >= (code_start_addr-displacement))
- && (data < (code_end_addr-displacement))) {
- /* function header */
- if ((d4 == 0x5e)
- && (((unsigned)p - 4 - 4*HeaderValue(*((unsigned *)p-1))) == (unsigned)code)) {
- /* Skip the function header */
- p += 6*4 - 4 - 1;
- continue;
- }
- /* the case of PUSH imm32 */
- if (d1 == 0x68) {
- fixup_found = 1;
- FSHOW((stderr,
- "/code ref @%x: %.2x %.2x %.2x %.2x %.2x %.2x (%.8x)\n",
- p, d6, d5, d4, d3, d2, d1, data));
- FSHOW((stderr, "/PUSH $0x%.8x\n", data));
- }
- /* the case of MOV [reg-8],imm32 */
- if ((d3 == 0xc7)
- && (d2==0x40 || d2==0x41 || d2==0x42 || d2==0x43
- || d2==0x45 || d2==0x46 || d2==0x47)
- && (d1 == 0xf8)) {
- fixup_found = 1;
- FSHOW((stderr,
- "/code ref @%x: %.2x %.2x %.2x %.2x %.2x %.2x (%.8x)\n",
- p, d6, d5, d4, d3, d2, d1, data));
- FSHOW((stderr, "/MOV [reg-8],$0x%.8x\n", data));
- }
- /* the case of LEA reg,[disp32] */
- if ((d2 == 0x8d) && ((d1 & 0xc7) == 5)) {
- fixup_found = 1;
- FSHOW((stderr,
- "/code ref @%x: %.2x %.2x %.2x %.2x %.2x %.2x (%.8x)\n",
- p, d6, d5, d4, d3, d2, d1, data));
- FSHOW((stderr,"/LEA reg,[$0x%.8x]\n", data));
- }
- }
-
- /* Check for constant references. */
- /* Check for a 32 bit word that looks like an absolute
- reference to within the constant vector. Constant references
- will be aligned. */
- if ((data >= (constants_start_addr-displacement))
- && (data < (constants_end_addr-displacement))
- && (((unsigned)data & 0x3) == 0)) {
- /* Mov eax,m32 */
- if (d1 == 0xa1) {
- fixup_found = 1;
- FSHOW((stderr,
- "/abs const ref @%x: %.2x %.2x %.2x %.2x %.2x %.2x (%.8x)\n",
- p, d6, d5, d4, d3, d2, d1, data));
- FSHOW((stderr,"/MOV eax,0x%.8x\n", data));
- }
-
- /* the case of MOV m32,EAX */
- if (d1 == 0xa3) {
- fixup_found = 1;
- FSHOW((stderr,
- "/abs const ref @%x: %.2x %.2x %.2x %.2x %.2x %.2x (%.8x)\n",
- p, d6, d5, d4, d3, d2, d1, data));
- FSHOW((stderr, "/MOV 0x%.8x,eax\n", data));
- }
-
- /* the case of CMP m32,imm32 */
- if ((d1 == 0x3d) && (d2 == 0x81)) {
- fixup_found = 1;
- FSHOW((stderr,
- "/abs const ref @%x: %.2x %.2x %.2x %.2x %.2x %.2x (%.8x)\n",
- p, d6, d5, d4, d3, d2, d1, data));
- /* XX Check this */
- FSHOW((stderr, "/CMP 0x%.8x,immed32\n", data));
- }
-
- /* Check for a mod=00, r/m=101 byte. */
- if ((d1 & 0xc7) == 5) {
- /* Cmp m32,reg */
- if (d2 == 0x39) {
- fixup_found = 1;
- FSHOW((stderr,
- "/abs const ref @%x: %.2x %.2x %.2x %.2x %.2x %.2x (%.8x)\n",
- p, d6, d5, d4, d3, d2, d1, data));
- FSHOW((stderr,"/CMP 0x%.8x,reg\n", data));
- }
- /* the case of CMP reg32,m32 */
- if (d2 == 0x3b) {
- fixup_found = 1;
- FSHOW((stderr,
- "/abs const ref @%x: %.2x %.2x %.2x %.2x %.2x %.2x (%.8x)\n",
- p, d6, d5, d4, d3, d2, d1, data));
- FSHOW((stderr, "/CMP reg32,0x%.8x\n", data));
- }
- /* the case of MOV m32,reg32 */
- if (d2 == 0x89) {
- fixup_found = 1;
- FSHOW((stderr,
- "/abs const ref @%x: %.2x %.2x %.2x %.2x %.2x %.2x (%.8x)\n",
- p, d6, d5, d4, d3, d2, d1, data));
- FSHOW((stderr, "/MOV 0x%.8x,reg32\n", data));
- }
- /* the case of MOV reg32,m32 */
- if (d2 == 0x8b) {
- fixup_found = 1;
- FSHOW((stderr,
- "/abs const ref @%x: %.2x %.2x %.2x %.2x %.2x %.2x (%.8x)\n",
- p, d6, d5, d4, d3, d2, d1, data));
- FSHOW((stderr, "/MOV reg32,0x%.8x\n", data));
- }
- /* the case of LEA reg32,m32 */
- if (d2 == 0x8d) {
- fixup_found = 1;
- FSHOW((stderr,
- "abs const ref @%x: %.2x %.2x %.2x %.2x %.2x %.2x (%.8x)\n",
- p, d6, d5, d4, d3, d2, d1, data));
- FSHOW((stderr, "/LEA reg32,0x%.8x\n", data));
- }
- }
- }
- }
-
- /* If anything was found, print some information on the code
- * object. */
- if (fixup_found) {
- FSHOW((stderr,
- "/compiled code object at %x: header words = %d, code words = %d\n",
- code, nheader_words, ncode_words));
- FSHOW((stderr,
- "/const start = %x, end = %x\n",
- constants_start_addr, constants_end_addr));
- FSHOW((stderr,
- "/code start = %x, end = %x\n",
- code_start_addr, code_end_addr));
- }
-}
-
-static void
-apply_code_fixups(struct code *old_code, struct code *new_code)
-{
- int nheader_words, ncode_words, nwords;
- void *constants_start_addr, *constants_end_addr;
- void *code_start_addr, *code_end_addr;
- lispobj fixups = NIL;
- unsigned displacement = (unsigned)new_code - (unsigned)old_code;
- struct vector *fixups_vector;
-
- /* It's OK if it's byte compiled code. The trace table offset will
- * be a fixnum if it's x86 compiled code - check. */
- if (new_code->trace_table_offset & 0x3) {
-/* FSHOW((stderr, "/byte compiled code object at %x\n", new_code)); */
- return;
- }
-
- /* Else it's x86 machine code. */
- ncode_words = fixnum_value(new_code->code_size);
- nheader_words = HeaderValue(*(lispobj *)new_code);
- nwords = ncode_words + nheader_words;
- /* FSHOW((stderr,
- "/compiled code object at %x: header words = %d, code words = %d\n",
- new_code, nheader_words, ncode_words)); */
- constants_start_addr = (void *)new_code + 5*4;
- constants_end_addr = (void *)new_code + nheader_words*4;
- code_start_addr = (void *)new_code + nheader_words*4;
- code_end_addr = (void *)new_code + nwords*4;
- /*
- FSHOW((stderr,
- "/const start = %x, end = %x\n",
- constants_start_addr,constants_end_addr));
- FSHOW((stderr,
- "/code start = %x; end = %x\n",
- code_start_addr,code_end_addr));
- */
-
- /* The first constant should be a pointer to the fixups for this
- code objects. Check. */
- fixups = new_code->constants[0];
-
- /* It will be 0 or the unbound-marker if there are no fixups, and
- * will be an other pointer if it is valid. */
- if ((fixups == 0) || (fixups == type_UnboundMarker) || !Pointerp(fixups)) {
- /* Check for possible errors. */
- if (check_code_fixups)
- sniff_code_object(new_code, displacement);
-
- /*fprintf(stderr,"Fixups for code object not found!?\n");
- fprintf(stderr,"*** Compiled code object at %x: header_words=%d code_words=%d .\n",
- new_code, nheader_words, ncode_words);
- fprintf(stderr,"*** Const. start = %x; end= %x; Code start = %x; end = %x\n",
- constants_start_addr,constants_end_addr,
- code_start_addr,code_end_addr);*/
- return;
- }
-
- fixups_vector = (struct vector *)PTR(fixups);
-
- /* Could be pointing to a forwarding pointer. */
- if (Pointerp(fixups) && (find_page_index((void*)fixups_vector) != -1)
- && (fixups_vector->header == 0x01)) {
- /* If so, then follow it. */
- /*SHOW("following pointer to a forwarding pointer");*/
- fixups_vector = (struct vector *)PTR((lispobj)fixups_vector->length);
- }
-
- /*SHOW("got fixups");*/
-
- if (TypeOf(fixups_vector->header) == type_SimpleArrayUnsignedByte32) {
- /* Got the fixups for the code block. Now work through the vector,
- and apply a fixup at each address. */
- int length = fixnum_value(fixups_vector->length);
- int i;
- for (i = 0; i < length; i++) {
- unsigned offset = fixups_vector->data[i];
- /* Now check the current value of offset. */
- unsigned old_value =
- *(unsigned *)((unsigned)code_start_addr + offset);
-
- /* If it's within the old_code object then it must be an
- * absolute fixup (relative ones are not saved) */
- if ((old_value >= (unsigned)old_code)
- && (old_value < ((unsigned)old_code + nwords*4)))
- /* So add the dispacement. */
- *(unsigned *)((unsigned)code_start_addr + offset) =
- old_value + displacement;
- else
- /* It is outside the old code object so it must be a
- * relative fixup (absolute fixups are not saved). So
- * subtract the displacement. */
- *(unsigned *)((unsigned)code_start_addr + offset) =
- old_value - displacement;
- }
- }
-
- /* Check for possible errors. */
- if (check_code_fixups) {
- sniff_code_object(new_code,displacement);
- }
-}
-
-static struct code *
-trans_code(struct code *code)
-{
- struct code *new_code;
- lispobj l_code, l_new_code;
- int nheader_words, ncode_words, nwords;
- unsigned long displacement;
- lispobj fheaderl, *prev_pointer;
-
- /* FSHOW((stderr,
- "\n/transporting code object located at 0x%08x\n",
- (unsigned long) code)); */
-
- /* If object has already been transported, just return pointer. */
- if (*((lispobj *)code) == 0x01)
- return (struct code*)(((lispobj *)code)[1]);
-
- gc_assert(TypeOf(code->header) == type_CodeHeader);
-
- /* Prepare to transport the code vector. */
- l_code = (lispobj) code | type_OtherPointer;
-
- ncode_words = fixnum_value(code->code_size);
- nheader_words = HeaderValue(code->header);
- nwords = ncode_words + nheader_words;
- nwords = CEILING(nwords, 2);
-
- l_new_code = copy_large_object(l_code, nwords);
- new_code = (struct code *) PTR(l_new_code);
-
- /* may not have been moved.. */
- if (new_code == code)
- return new_code;
-
- displacement = l_new_code - l_code;
-
- /*
- FSHOW((stderr,
- "/old code object at 0x%08x, new code object at 0x%08x\n",
- (unsigned long) code,
- (unsigned long) new_code));
- FSHOW((stderr, "/Code object is %d words long.\n", nwords));
- */
-
- /* Set forwarding pointer. */
- ((lispobj *)code)[0] = 0x01;
- ((lispobj *)code)[1] = l_new_code;
-
- /* Set forwarding pointers for all the function headers in the
- * code object. Also fix all self pointers. */
-
- fheaderl = code->entry_points;
- prev_pointer = &new_code->entry_points;
-
- while (fheaderl != NIL) {
- struct function *fheaderp, *nfheaderp;
- lispobj nfheaderl;
-
- fheaderp = (struct function *) PTR(fheaderl);
- gc_assert(TypeOf(fheaderp->header) == type_FunctionHeader);
-
- /* Calculate the new function pointer and the new */
- /* function header. */
- nfheaderl = fheaderl + displacement;
- nfheaderp = (struct function *) PTR(nfheaderl);
-
- /* Set forwarding pointer. */
- ((lispobj *)fheaderp)[0] = 0x01;
- ((lispobj *)fheaderp)[1] = nfheaderl;
-
- /* Fix self pointer. */
- nfheaderp->self = nfheaderl + RAW_ADDR_OFFSET;
-
- *prev_pointer = nfheaderl;
-
- fheaderl = fheaderp->next;
- prev_pointer = &nfheaderp->next;
- }
-
- /* sniff_code_object(new_code,displacement);*/
- apply_code_fixups(code,new_code);
-
- return new_code;
-}
-
-static int
-scav_code_header(lispobj *where, lispobj object)
-{
- struct code *code;
- int n_header_words, n_code_words, n_words;
- lispobj entry_point; /* tagged pointer to entry point */
- struct function *function_ptr; /* untagged pointer to entry point */
-
- code = (struct code *) where;
- n_code_words = fixnum_value(code->code_size);
- n_header_words = HeaderValue(object);
- n_words = n_code_words + n_header_words;
- n_words = CEILING(n_words, 2);
-
- /* Scavenge the boxed section of the code data block. */
- scavenge(where + 1, n_header_words - 1);
-
- /* 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) {
-
- gc_assert(Pointerp(entry_point));
-
- function_ptr = (struct function *) PTR(entry_point);
- gc_assert(TypeOf(function_ptr->header) == type_FunctionHeader);
-
- scavenge(&function_ptr->name, 1);
- scavenge(&function_ptr->arglist, 1);
- scavenge(&function_ptr->type, 1);
- }
-
- return n_words;
-}
-
-static lispobj
-trans_code_header(lispobj object)
-{
- struct code *ncode;
-
- ncode = trans_code((struct code *) PTR(object));
- return (lispobj) ncode | type_OtherPointer;
-}
-
-static int
-size_code_header(lispobj *where)
-{
- struct code *code;
- int 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;
- nwords = CEILING(nwords, 2);
-
- return nwords;
-}
-
-static int
-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);
- return 0; /* bogus return value to satisfy static type checking */
-}
-
-static lispobj
-trans_return_pc_header(lispobj object)
-{
- struct function *return_pc;
- unsigned long offset;
- struct code *code, *ncode;
-
- SHOW("/trans_return_pc_header: Will this work?");
-
- return_pc = (struct function *) PTR(object);
- offset = HeaderValue(return_pc->header) * 4;
-
- /* Transport the whole code object. */
- code = (struct code *) ((unsigned long) return_pc - offset);
- ncode = trans_code(code);
-
- return ((lispobj) ncode + offset) | type_OtherPointer;
-}
-
-/* On the 386, closures hold a pointer to the raw address instead of the
- * function object. */
-#ifdef __i386__
-static int
-scav_closure_header(lispobj *where, lispobj object)
-{
- struct closure *closure;
- lispobj fun;
-
- closure = (struct closure *)where;
- fun = closure->function - RAW_ADDR_OFFSET;
- scavenge(&fun, 1);
- /* The function may have moved so update the raw address. But
- * don't write unnecessarily. */
- if (closure->function != fun + RAW_ADDR_OFFSET)
- closure->function = fun + RAW_ADDR_OFFSET;
-
- return 2;
-}
-#endif
-
-static int
-scav_function_header(lispobj *where, lispobj object)
-{
- lose("attempted to scavenge a function header where=0x%08x object=0x%08x",
- (unsigned long) where,
- (unsigned long) object);
- return 0; /* bogus return value to satisfy static type checking */
-}
-
-static lispobj
-trans_function_header(lispobj object)
-{
- struct function *fheader;
- unsigned long offset;
- struct code *code, *ncode;
-
- fheader = (struct function *) PTR(object);
- offset = HeaderValue(fheader->header) * 4;
-
- /* Transport the whole code object. */
- code = (struct code *) ((unsigned long) fheader - offset);
- ncode = trans_code(code);
-
- return ((lispobj) ncode + offset) | type_FunctionPointer;
-}
-\f
-/*
- * instances
- */
-
-static int
-scav_instance_pointer(lispobj *where, lispobj object)
-{
- lispobj copy, *first_pointer;
-
- /* Object is a pointer into from space - not a FP. */
- copy = trans_boxed(object);
-
- gc_assert(copy != object);
-
- first_pointer = (lispobj *) PTR(object);
-
- /* Set forwarding pointer. */
- first_pointer[0] = 0x01;
- first_pointer[1] = copy;
- *where = copy;
-
- return 1;
-}
-\f
-/*
- * lists and conses
- */
-
-static lispobj trans_list(lispobj object);
-
-static int
-scav_list_pointer(lispobj *where, lispobj object)
-{
- lispobj first, *first_pointer;
-
- gc_assert(Pointerp(object));
-
- /* Object is a pointer into from space - not FP. */
-
- first = trans_list(object);
- gc_assert(first != object);
-
- first_pointer = (lispobj *) PTR(object);
-
- /* Set forwarding pointer */
- first_pointer[0] = 0x01;
- first_pointer[1] = first;
-
- gc_assert(Pointerp(first));
- gc_assert(!from_space_p(first));
- *where = first;
- return 1;
-}
-
-static lispobj
-trans_list(lispobj object)
-{
- lispobj new_list_pointer;
- struct cons *cons, *new_cons;
- lispobj cdr;
-
- gc_assert(from_space_p(object));
-
- cons = (struct cons *) PTR(object);
-
- /* Copy 'object'. */
- new_cons = (struct cons *) gc_quick_alloc(sizeof(struct cons));
- new_cons->car = cons->car;
- new_cons->cdr = cons->cdr; /* updated later */
- new_list_pointer = (lispobj)new_cons | LowtagOf(object);
-
- /* Grab the cdr before it is clobbered. */
- cdr = cons->cdr;
-
- /* Set forwarding pointer (clobbers start of list). */
- cons->car = 0x01;
- cons->cdr = new_list_pointer;
-
- /* 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 (LowtagOf(cdr) != type_ListPointer || !from_space_p(cdr)
- || (*((lispobj *)PTR(cdr)) == 0x01))
- break;
-
- cdr_cons = (struct cons *) PTR(cdr);
-
- /* Copy 'cdr'. */
- new_cdr_cons = (struct cons*) gc_quick_alloc(sizeof(struct cons));
- new_cdr_cons->car = cdr_cons->car;
- new_cdr_cons->cdr = cdr_cons->cdr;
- new_cdr = (lispobj)new_cdr_cons | LowtagOf(cdr);
-
- /* Grab the cdr before it is clobbered. */
- cdr = cdr_cons->cdr;
-
- /* Set forwarding pointer. */
- cdr_cons->car = 0x01;
- cdr_cons->cdr = 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;
-}
-
-\f
-/*
- * scavenging and transporting other pointers
- */
-
-static int
-scav_other_pointer(lispobj *where, lispobj object)
-{
- lispobj first, *first_pointer;
-
- gc_assert(Pointerp(object));
-
- /* Object is a pointer into from space - not FP. */
- first_pointer = (lispobj *) PTR(object);
-
- first = (transother[TypeOf(*first_pointer)])(object);
-
- if (first != object) {
- /* Set forwarding pointer. */
- first_pointer[0] = 0x01;
- first_pointer[1] = first;
- *where = first;
- }
-
- gc_assert(Pointerp(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(Pointerp(object));
-
- header = *((lispobj *) PTR(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(Pointerp(object));
-
- header = *((lispobj *) PTR(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->function, fdefn->raw_addr)); */
-
- if ((char *)(fdefn->function + 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->function + RAW_ADDR_OFFSET))
- fdefn->raw_addr = (char *)(fdefn->function + 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(Pointerp(object));
-
- header = *((lispobj *) PTR(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(Pointerp(object));
-
- header = *((lispobj *) PTR(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(Pointerp(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 *) PTR(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 << type_Bits) | type_SimpleVector;
- 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 (!Pointerp(where[2])) {
- lose("no pointer at %x in hash table", where[2]);
- }
- hash_table = (lispobj *)PTR(where[2]);
- /*FSHOW((stderr,"/hash_table = %x\n", hash_table));*/
- if (TypeOf(hash_table[0]) != type_InstanceHeader) {
- 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 (!Pointerp(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 (TypeOf(*(lispobj *)PTR(empty_symbol)) != type_SymbolHeader) {
- lose("not a symbol where empty-hash-table-slot symbol expected: %x",
- *(lispobj *)PTR(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 *)PTR(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 (Pointerp(index_vector_obj) &&
- (TypeOf(*(lispobj *)PTR(index_vector_obj)) == type_SimpleArrayUnsignedByte32)) {
- index_vector = ((unsigned int *)PTR(index_vector_obj)) + 2;
- /*FSHOW((stderr, "/index_vector = %x\n",index_vector));*/
- length = fixnum_value(((unsigned int *)PTR(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 (Pointerp(next_vector_obj) &&
- (TypeOf(*(lispobj *)PTR(next_vector_obj)) == type_SimpleArrayUnsignedByte32)) {
- next_vector = ((unsigned int *)PTR(next_vector_obj)) + 2;
- /*FSHOW((stderr, "/next_vector = %x\n", next_vector));*/
- next_vector_length = fixnum_value(((unsigned int *)PTR(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 (Pointerp(hash_vector_obj) &&
- (TypeOf(*(lispobj *)PTR(hash_vector_obj))
- == type_SimpleArrayUnsignedByte32)) {
- hash_vector = ((unsigned int *)PTR(hash_vector_obj)) + 2;
- /*FSHOW((stderr, "/hash_vector = %x\n", hash_vector));*/
- gc_assert(fixnum_value(((unsigned int *)PTR(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(Pointerp(object));
-
- vector = (struct vector *) PTR(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(Pointerp(object));
-
- vector = (struct vector *) PTR(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(Pointerp(object));
-
- vector = (struct vector *) PTR(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(Pointerp(object));
-
- vector = (struct vector *) PTR(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(Pointerp(object));
-
- vector = (struct vector *) PTR(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(Pointerp(object));
-
- vector = (struct vector *) PTR(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(Pointerp(object));
-
- vector = (struct vector *) PTR(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(Pointerp(object));
-
- vector = (struct vector *) PTR(object);
- length = fixnum_value(vector->length);
- nwords = CEILING(length + 2, 2);
-
- return copy_large_unboxed_object(object, nwords);
-}