Clean up RCS ids
[projects/cmucl/cmucl.git] / src / lisp / gc.c
CommitLineData
62957726 1/*
2 * Stop and Copy GC based on Cheney's algorithm.
3 *
62957726 4 * Written by Christopher Hoover.
5 */
6
7#include <stdio.h>
8#include <sys/time.h>
9#include <sys/resource.h>
10#include <signal.h>
11#include "lisp.h"
12#include "internals.h"
13#include "os.h"
14#include "gc.h"
15#include "globals.h"
16#include "interrupt.h"
17#include "validate.h"
18#include "lispregs.h"
19#include "interr.h"
20
21static lispobj *from_space;
22static lispobj *from_space_free_pointer;
23
24static lispobj *new_space;
25static lispobj *new_space_free_pointer;
26
9a8c1c2f 27static int (*scavtab[256]) (lispobj * where, lispobj object);
28static lispobj(*transother[256]) (lispobj object);
29static int (*sizetab[256]) (lispobj * where);
62957726 30
31static struct weak_pointer *weak_pointers;
32
9a8c1c2f 33static void scavenge(lispobj * start, long nwords);
62957726 34static void scavenge_newspace(void);
35static void scavenge_interrupt_contexts(void);
36static void scan_weak_pointers(void);
37
38#define gc_abort() lose("GC invariant lost! File \"%s\", line %d\n", \
39 __FILE__, __LINE__)
40
34b793ce 41#if DEBUG
62957726 42#define gc_assert(ex) do { \
43 if (!(ex)) gc_abort(); \
44} while (0)
45#else
46#define gc_assert(ex)
47#endif
48
49#define CEILING(x,y) (((x) + ((y) - 1)) & (~((y) - 1)))
62957726 50\f
9a8c1c2f 51
62957726 52/* Predicates */
53
54#if defined(DEBUG_SPACE_PREDICATES)
55
9a8c1c2f 56boolean
57from_space_p(lispobj object)
62957726 58{
9a8c1c2f 59 lispobj *ptr;
62957726 60
9a8c1c2f 61 ptr = (lispobj *) PTR(object);
62957726 62
9a8c1c2f 63 return ((from_space <= ptr) && (ptr < from_space_free_pointer));
64}
62957726 65
9a8c1c2f 66boolean
67new_space_p(lispobj object)
62957726 68{
9a8c1c2f 69 lispobj *ptr;
62957726 70
9a8c1c2f 71 gc_assert(Pointerp(object));
62957726 72
9a8c1c2f 73 ptr = (lispobj *) PTR(object);
74
75 return ((new_space <= ptr) && (ptr < new_space_free_pointer));
76}
62957726 77
78#else
79
80#define from_space_p(ptr) \
81 ((from_space <= ((lispobj *) ptr)) && \
82 (((lispobj *) ptr) < from_space_free_pointer))
83
84#define new_space_p(ptr) \
85 ((new_space <= ((lispobj *) ptr)) && \
86 (((lispobj *) ptr) < new_space_free_pointer))
87
88#endif
62957726 89\f
9a8c1c2f 90
62957726 91/* Copying Objects */
92
93static lispobj
94copy_object(lispobj object, int nwords)
95{
9a8c1c2f 96 int tag;
97 lispobj *new;
98 lispobj *source, *dest;
62957726 99
9a8c1c2f 100 gc_assert(Pointerp(object));
101 gc_assert(from_space_p(object));
102 gc_assert((nwords & 0x01) == 0);
62957726 103
9a8c1c2f 104 /* get tag of object */
105 tag = LowtagOf(object);
62957726 106
9a8c1c2f 107 /* allocate space */
108 new = new_space_free_pointer;
109 new_space_free_pointer += nwords;
62957726 110
9a8c1c2f 111 dest = new;
112 source = (lispobj *) PTR(object);
62957726 113
9a8c1c2f 114 /* copy the object */
115 while (nwords > 0) {
116 dest[0] = source[0];
117 dest[1] = source[1];
118 dest += 2;
119 source += 2;
120 nwords -= 2;
121 }
62957726 122
9a8c1c2f 123 /* return lisp pointer of new object */
124 return ((lispobj) new) | tag;
62957726 125}
62957726 126\f
9a8c1c2f 127
62957726 128/* Collect Garbage */
129
130#ifdef PRINTNOISE
9a8c1c2f 131static double
132tv_diff(struct timeval *x, struct timeval *y)
62957726 133{
134 return (((double) x->tv_sec + (double) x->tv_usec * 1.0e-6) -
135 ((double) y->tv_sec + (double) y->tv_usec * 1.0e-6));
136}
137#endif
138
139#define BYTES_ZERO_BEFORE_END (1<<12)
140
9a8c1c2f 141static void
142zero_stack(void)
62957726 143{
6f4a04e5 144#ifndef alpha
9a8c1c2f 145 unsigned long *ptr = (unsigned long *) current_control_stack_pointer;
6f4a04e5 146#else
9a8c1c2f 147 u32 *ptr = (u32 *) current_control_stack_pointer;
6f4a04e5 148#endif
62957726 149 search:
150 do {
151 if (*ptr)
152 goto fill;
153 ptr++;
6f4a04e5 154#ifndef alpha
9a8c1c2f 155 } while (((unsigned long) ptr) & (BYTES_ZERO_BEFORE_END - 1));
6f4a04e5 156#else
9a8c1c2f 157 } while (((u32) ptr) & (BYTES_ZERO_BEFORE_END - 1));
6f4a04e5 158#endif
62957726 159 return;
160
161 fill:
162 do {
163 *ptr++ = 0;
6f4a04e5 164#ifndef alpha
9a8c1c2f 165 } while (((unsigned long) ptr) & (BYTES_ZERO_BEFORE_END - 1));
6f4a04e5 166#else
9a8c1c2f 167 } while (((u32) ptr) & (BYTES_ZERO_BEFORE_END - 1));
6f4a04e5 168#endif
62957726 169 goto search;
170}
171
9a8c1c2f 172void
173collect_garbage(void)
62957726 174{
175#ifdef PRINTNOISE
9a8c1c2f 176 struct timeval start_tv, stop_tv;
177 struct rusage start_rusage, stop_rusage;
178 double real_time, system_time, user_time;
179 double percent_retained, gc_rate;
180 unsigned long size_discarded;
181 unsigned long size_retained;
182#endif
183 lispobj *current_static_space_free_pointer;
184 unsigned long static_space_size;
185 unsigned long control_stack_size, binding_stack_size;
186
9a8c1c2f 187 sigset_t tmp, old;
9a8c1c2f 188
189 SAVE_CONTEXT();
eb3d28bd 190
62957726 191#ifdef PRINTNOISE
9a8c1c2f 192 printf("[Collecting garbage ... \n");
62957726 193
9a8c1c2f 194 getrusage(RUSAGE_SELF, &start_rusage);
195 gettimeofday(&start_tv, (struct timezone *) 0);
62957726 196#endif
197
9a8c1c2f 198 sigemptyset(&tmp);
199 FILLBLOCKSET(&tmp);
200 sigprocmask(SIG_BLOCK, &tmp, &old);
62957726 201
9a8c1c2f 202 current_static_space_free_pointer =
203 (lispobj *) SymbolValue(STATIC_SPACE_FREE_POINTER);
62957726 204
205
9a8c1c2f 206 /* Set up from space and new space pointers. */
62957726 207
9a8c1c2f 208 from_space = current_dynamic_space;
62957726 209#ifndef ibmrt
9a8c1c2f 210 from_space_free_pointer = current_dynamic_space_free_pointer;
62957726 211#else
9a8c1c2f 212 from_space_free_pointer = (lispobj *) SymbolValue(ALLOCATION_POINTER);
62957726 213#endif
214
9a8c1c2f 215 if (current_dynamic_space == dynamic_0_space)
216 new_space = dynamic_1_space;
217 else if (current_dynamic_space == dynamic_1_space)
218 new_space = dynamic_0_space;
219 else
220 lose("GC lossage. Current dynamic space is bogus!\n");
62957726 221
9a8c1c2f 222 new_space_free_pointer = new_space;
62957726 223
224
9a8c1c2f 225 /* Initialize the weak pointer list. */
226 weak_pointers = (struct weak_pointer *) NULL;
62957726 227
228
9a8c1c2f 229 /* Scavenge all of the roots. */
62957726 230#ifdef PRINTNOISE
9a8c1c2f 231 printf("Scavenging interrupt contexts ...\n");
62957726 232#endif
9a8c1c2f 233 scavenge_interrupt_contexts();
62957726 234
235#ifdef PRINTNOISE
9a8c1c2f 236 printf("Scavenging interrupt handlers (%d bytes) ...\n",
237 sizeof(interrupt_handlers));
62957726 238#endif
9a8c1c2f 239 scavenge((lispobj *) interrupt_handlers,
240 sizeof(interrupt_handlers) / sizeof(lispobj));
62957726 241
9a8c1c2f 242 control_stack_size = current_control_stack_pointer - control_stack;
62957726 243#ifdef PRINTNOISE
9a8c1c2f 244 printf("Scavenging the control stack (%d bytes) ...\n",
245 control_stack_size * sizeof(lispobj));
62957726 246#endif
9a8c1c2f 247 scavenge(control_stack, control_stack_size);
62957726 248
249#ifndef ibmrt
9a8c1c2f 250 binding_stack_size = current_binding_stack_pointer - binding_stack;
62957726 251#else
9a8c1c2f 252 binding_stack_size =
253 (lispobj *) SymbolValue(BINDING_STACK_POINTER) - binding_stack;
62957726 254#endif
255#ifdef PRINTNOISE
9a8c1c2f 256 printf("Scavenging the binding stack (%d bytes) ...\n",
257 binding_stack_size * sizeof(lispobj));
62957726 258#endif
9a8c1c2f 259 scavenge(binding_stack, binding_stack_size);
62957726 260
9a8c1c2f 261 static_space_size = current_static_space_free_pointer - static_space;
62957726 262#ifdef PRINTNOISE
9a8c1c2f 263 printf("Scavenging static space (%d bytes) ...\n",
264 static_space_size * sizeof(lispobj));
62957726 265#endif
9a8c1c2f 266 scavenge(static_space, static_space_size);
62957726 267
268
9a8c1c2f 269 /* Scavenge newspace. */
62957726 270#ifdef PRINTNOISE
9a8c1c2f 271 printf("Scavenging new space (%d bytes) ...\n",
272 (new_space_free_pointer - new_space) * sizeof(lispobj));
62957726 273#endif
9a8c1c2f 274 scavenge_newspace();
62957726 275
276
277#if defined(DEBUG_PRINT_GARBAGE)
9a8c1c2f 278 print_garbage(from_space, from_space_free_pointer);
62957726 279#endif
280
9a8c1c2f 281 /* Scan the weak pointers. */
62957726 282#ifdef PRINTNOISE
9a8c1c2f 283 printf("Scanning weak pointers ...\n");
62957726 284#endif
9a8c1c2f 285 scan_weak_pointers();
62957726 286
287
9a8c1c2f 288 /* Flip spaces. */
62957726 289#ifdef PRINTNOISE
9a8c1c2f 290 printf("Flipping spaces ...\n");
62957726 291#endif
292
9a8c1c2f 293 os_zero((os_vm_address_t) current_dynamic_space,
294 (os_vm_size_t) dynamic_space_size);
62957726 295
9a8c1c2f 296 current_dynamic_space = new_space;
62957726 297#ifndef ibmrt
9a8c1c2f 298 current_dynamic_space_free_pointer = new_space_free_pointer;
62957726 299#else
9a8c1c2f 300 SetSymbolValue(ALLOCATION_POINTER, (lispobj) new_space_free_pointer);
62957726 301#endif
302
303#ifdef PRINTNOISE
9a8c1c2f 304 size_discarded = (from_space_free_pointer - from_space) * sizeof(lispobj);
305 size_retained = (new_space_free_pointer - new_space) * sizeof(lispobj);
62957726 306#endif
307
9a8c1c2f 308 /* Zero stack. */
62957726 309#ifdef PRINTNOISE
9a8c1c2f 310 printf("Zeroing empty part of control stack ...\n");
62957726 311#endif
9a8c1c2f 312 zero_stack();
62957726 313
9a8c1c2f 314 sigprocmask(SIG_SETMASK, &old, 0);
62957726 315
316
317#ifdef PRINTNOISE
9a8c1c2f 318 gettimeofday(&stop_tv, (struct timezone *) 0);
319 getrusage(RUSAGE_SELF, &stop_rusage);
62957726 320
9a8c1c2f 321 printf("done.]\n");
62957726 322
9a8c1c2f 323 percent_retained = (((float) size_retained) /
324 ((float) size_discarded)) * 100.0;
62957726 325
9a8c1c2f 326 printf("Total of %d bytes out of %d bytes retained (%3.2f%%).\n",
327 size_retained, size_discarded, percent_retained);
328
329 real_time = tv_diff(&stop_tv, &start_tv);
330 user_time = tv_diff(&stop_rusage.ru_utime, &start_rusage.ru_utime);
331 system_time = tv_diff(&stop_rusage.ru_stime, &start_rusage.ru_stime);
62957726 332
333#if 0
9a8c1c2f 334 printf("Statistics:\n");
335 printf("%10.2f sec of real time\n", real_time);
336 printf("%10.2f sec of user time,\n", user_time);
337 printf("%10.2f sec of system time.\n", system_time);
62957726 338#else
9a8c1c2f 339 printf("Statistics: %10.2fs real, %10.2fs user, %10.2fs system.\n",
340 real_time, user_time, system_time);
341#endif
62957726 342
9a8c1c2f 343 gc_rate = ((float) size_retained / (float) (1 << 20)) / real_time;
62957726 344
9a8c1c2f 345 printf("%10.2f M bytes/sec collected.\n", gc_rate);
62957726 346#endif
347}
62957726 348\f
9a8c1c2f 349
62957726 350/* Scavenging */
351
18369c77 352#define DIRECT_SCAV 0
353
62957726 354static void
9a8c1c2f 355scavenge(lispobj * start, long nwords)
62957726 356{
9a8c1c2f 357 while (nwords > 0) {
358 lispobj object;
359 int type, words_scavenged;
62957726 360
9a8c1c2f 361 object = *start;
362 type = TypeOf(object);
62957726 363
364#if defined(DEBUG_SCAVENGE_VERBOSE)
9a8c1c2f 365 printf("Scavenging object at 0x%08x, object = 0x%08x, type = %d\n",
366 (unsigned long) start, (unsigned long) object, type);
62957726 367#endif
368
18369c77 369#if DIRECT_SCAV
9a8c1c2f 370 words_scavenged = (scavtab[type]) (start, object);
62957726 371#else
9a8c1c2f 372 if (Pointerp(object)) {
373 /* It be a pointer. */
374 if (from_space_p(object)) {
375 /* It currently points to old space. Check for a */
376 /* forwarding pointer. */
377 lispobj first_word;
378
379 first_word = *((lispobj *) PTR(object));
380 if (Pointerp(first_word) && new_space_p(first_word)) {
381 /* Yep, there be a forwarding pointer. */
382 *start = first_word;
383 words_scavenged = 1;
384 } else {
385 /* Scavenge that pointer. */
386 words_scavenged = (scavtab[type]) (start, object);
387 }
388 } else {
389 /* It points somewhere other than oldspace. Leave */
390 /* it alone. */
391 words_scavenged = 1;
392 }
393 } else if ((object & 3) == 0) {
394 /* It's a fixnum. Real easy. */
395 words_scavenged = 1;
396 } else {
397 /* It's some random header object. */
398 words_scavenged = (scavtab[type]) (start, object);
62957726 399 }
9a8c1c2f 400#endif
401
402 start += words_scavenged;
403 nwords -= words_scavenged;
404 }
405 gc_assert(nwords == 0);
62957726 406}
407
9a8c1c2f 408static void
409scavenge_newspace(void)
62957726 410{
411 lispobj *here, *next;
412
413 here = new_space;
414 while (here < new_space_free_pointer) {
415 next = new_space_free_pointer;
416 scavenge(here, next - here);
417 here = next;
418 }
419}
62957726 420\f
9a8c1c2f 421
62957726 422/* Scavenging Interrupt Contexts */
423
424static int boxed_registers[] = BOXED_REGISTERS;
425
9a8c1c2f 426static void
427scavenge_interrupt_context(os_context_t * context)
62957726 428{
9a8c1c2f 429 int i;
430
62957726 431#ifdef reg_LIP
9a8c1c2f 432 unsigned long lip;
433 unsigned long lip_offset;
434 int lip_register_pair;
6541e259 435#endif
9a8c1c2f 436 unsigned long pc_code_offset;
437
6541e259 438#ifdef SC_NPC
9a8c1c2f 439 unsigned long npc_code_offset;
62957726 440#endif
441
9a8c1c2f 442 /* Find the LIP's register pair and calculate it's offset */
443 /* before we scavenge the context. */
62957726 444#ifdef reg_LIP
9a8c1c2f 445 lip = SC_REG(context, reg_LIP);
446 lip_offset = 0x7FFFFFFF;
447 lip_register_pair = -1;
448 for (i = 0; i < (sizeof(boxed_registers) / sizeof(int)); i++) {
449 unsigned long reg;
450 long offset;
451 int index;
452
453 index = boxed_registers[i];
454 reg = SC_REG(context, index);
455 if (Pointerp(reg) && PTR(reg) <= lip) {
456 offset = lip - reg;
457 if (offset < lip_offset) {
458 lip_offset = offset;
459 lip_register_pair = index;
460 }
62957726 461 }
9a8c1c2f 462 }
48cccfec 463#endif /* reg_LIP */
62957726 464
9a8c1c2f 465 /* Compute the PC's offset from the start of the CODE */
466 /* register. */
467 pc_code_offset = SC_PC(context) - SC_REG(context, reg_CODE);
6541e259 468#ifdef SC_NPC
9a8c1c2f 469 npc_code_offset = SC_NPC(context) - SC_REG(context, reg_CODE);
48cccfec 470#endif /* SC_NPC */
9a8c1c2f 471
472 /* Scanvenge all boxed registers in the context. */
473 for (i = 0; i < (sizeof(boxed_registers) / sizeof(int)); i++) {
474 int index;
475 lispobj foo;
476
477 index = boxed_registers[i];
478 foo = SC_REG(context, index);
479 scavenge((lispobj *) & foo, 1);
480 SC_REG(context, index) = foo;
481
482 scavenge((lispobj *) & (SC_REG(context, index)), 1);
483 }
62957726 484
485#ifdef reg_LIP
9a8c1c2f 486 /* Fix the LIP */
487 SC_REG(context, reg_LIP) = SC_REG(context, lip_register_pair) + lip_offset;
48cccfec 488#endif /* reg_LIP */
9a8c1c2f 489
490 /* Fix the PC if it was in from space */
491 if (from_space_p(SC_PC(context)))
492 SC_PC(context) = SC_REG(context, reg_CODE) + pc_code_offset;
6541e259 493#ifdef SC_NPC
9a8c1c2f 494 if (from_space_p(SC_NPC(context)))
495 SC_NPC(context) = SC_REG(context, reg_CODE) + npc_code_offset;
48cccfec 496#endif /* SC_NPC */
62957726 497}
498
9a8c1c2f 499void
500scavenge_interrupt_contexts(void)
62957726 501{
9a8c1c2f 502 int i, index;
503 os_context_t *context;
62957726 504
9a8c1c2f 505 index = fixnum_value(SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX));
62957726 506#if defined(DEBUG_PRINT_CONTEXT_INDEX)
9a8c1c2f 507 printf("Number of active contexts: %d\n", index);
62957726 508#endif
509
9a8c1c2f 510 for (i = 0; i < index; i++) {
511 context = lisp_interrupt_contexts[i];
512 scavenge_interrupt_context(context);
513 }
62957726 514}
62957726 515\f
9a8c1c2f 516
62957726 517/* Debugging Code */
518
9a8c1c2f 519void
520print_garbage(lispobj * from_space, lispobj * from_space_free_pointer)
521{
522 lispobj *start;
523 int total_words_not_copied;
524
525 printf("Scanning from space ...\n");
526
527 total_words_not_copied = 0;
528 start = from_space;
529 while (start < from_space_free_pointer) {
530 lispobj object;
531 int forwardp, type, nwords;
532 lispobj header;
533
534 object = *start;
535 forwardp = Pointerp(object) && new_space_p(object);
536
537 if (forwardp) {
538 int tag;
539 lispobj *pointer;
540
541 tag = LowtagOf(object);
542
543 switch (tag) {
544 case type_ListPointer:
545 nwords = 2;
546 break;
547 case type_InstancePointer:
548 printf("Don't know about instances yet!\n");
549 nwords = 1;
550 break;
551 case type_FunctionPointer:
552 nwords = 1;
553 break;
554 case type_OtherPointer:
555 pointer = (lispobj *) PTR(object);
556 header = *pointer;
557 type = TypeOf(header);
558 nwords = (sizetab[type]) (pointer);
559 }
560 } else {
561 type = TypeOf(object);
562 nwords = (sizetab[type]) (start);
563 total_words_not_copied += nwords;
564 printf("%4d words not copied at 0x%08x; ",
565 nwords, (unsigned long) start);
566 printf("Header word is 0x%08x\n", (unsigned long) object);
62957726 567 }
9a8c1c2f 568 start += nwords;
569 }
570 printf("%d total words not copied.\n", total_words_not_copied);
62957726 571}
62957726 572\f
9a8c1c2f 573
62957726 574/* Code and Code-Related Objects */
575
576#define RAW_ADDR_OFFSET (6*sizeof(lispobj) - type_FunctionPointer)
577
578static lispobj trans_function_header(lispobj object);
579static lispobj trans_boxed(lispobj object);
580
18369c77 581#if DIRECT_SCAV
62957726 582static int
9a8c1c2f 583scav_function_pointer(lispobj * where, lispobj object)
584{
585 gc_assert(Pointerp(object));
62957726 586
9a8c1c2f 587 if (from_space_p(object)) {
588 lispobj first, *first_pointer;
589
590 /* object is a pointer into from space. check to see */
591 /* if it has been forwarded */
592 first_pointer = (lispobj *) PTR(object);
593 first = *first_pointer;
62957726 594
9a8c1c2f 595 if (!(Pointerp(first) && new_space_p(first))) {
596 int type;
597 lispobj copy;
598
599 /* must transport object -- object may point */
600 /* to either a function header, a closure */
601 /* function header, or to a closure header. */
602
603 type = TypeOf(first);
604 switch (type) {
605 case type_FunctionHeader:
606 case type_ClosureFunctionHeader:
607 copy = trans_function_header(object);
608 break;
609 default:
610 copy = trans_boxed(object);
611 break;
612 }
613
614 first = *first_pointer = copy;
62957726 615 }
9a8c1c2f 616
617 gc_assert(Pointerp(first));
618 gc_assert(!from_space_p(first));
619
620 *where = first;
621 }
622 return 1;
62957726 623}
18369c77 624#else
625static int
9a8c1c2f 626scav_function_pointer(lispobj * where, lispobj object)
627{
628 lispobj *first_pointer;
629 lispobj copy;
630 lispobj first;
631 int type;
632
633 gc_assert(Pointerp(object));
634
635 /* object is a pointer into from space. Not a FP */
636 first_pointer = (lispobj *) PTR(object);
637 first = *first_pointer;
638
639 /* must transport object -- object may point */
640 /* to either a function header, a closure */
641 /* function header, or to a closure header. */
642
643 type = TypeOf(first);
644 switch (type) {
645 case type_FunctionHeader:
646 case type_ClosureFunctionHeader:
647 copy = trans_function_header(object);
648 break;
649 default:
650 copy = trans_boxed(object);
651 break;
652 }
653
654 first = *first_pointer = copy;
655
656 gc_assert(Pointerp(first));
657 gc_assert(!from_space_p(first));
658
659 *where = first;
660 return 1;
18369c77 661}
662#endif
62957726 663
664static struct code *
665trans_code(struct code *code)
666{
9a8c1c2f 667 struct code *new_code;
668 lispobj first, l_code, l_new_code;
669 int nheader_words, ncode_words, nwords;
670 unsigned long displacement;
671 lispobj fheaderl, *prev_pointer;
62957726 672
673#if defined(DEBUG_CODE_GC)
9a8c1c2f 674 printf("\nTransporting code object located at 0x%08x.\n",
675 (unsigned long) code);
62957726 676#endif
677
9a8c1c2f 678 /* if object has already been transported, just return pointer */
679 first = code->header;
680 if (Pointerp(first) && new_space_p(first))
681 return (struct code *) PTR(first);
682
683 gc_assert(TypeOf(first) == type_CodeHeader);
62957726 684
9a8c1c2f 685 /* prepare to transport the code vector */
686 l_code = (lispobj) code | type_OtherPointer;
62957726 687
9a8c1c2f 688 ncode_words = fixnum_value(code->code_size);
689 nheader_words = HeaderValue(code->header);
690 nwords = ncode_words + nheader_words;
691 nwords = CEILING(nwords, 2);
62957726 692
9a8c1c2f 693 l_new_code = copy_object(l_code, nwords);
694 new_code = (struct code *) PTR(l_new_code);
62957726 695
9a8c1c2f 696 displacement = l_new_code - l_code;
62957726 697
698#if defined(DEBUG_CODE_GC)
9a8c1c2f 699 printf("Old code object at 0x%08x, new code object at 0x%08x.\n",
700 (unsigned long) code, (unsigned long) new_code);
701 printf("Code object is %d words long.\n", nwords);
62957726 702#endif
703
9a8c1c2f 704 /* set forwarding pointer */
705 code->header = l_new_code;
706
707 /* set forwarding pointers for all the function headers in the */
708 /* code object. also fix all self pointers */
709
710 fheaderl = code->entry_points;
711 prev_pointer = &new_code->entry_points;
712
713 while (fheaderl != NIL) {
714 struct function *fheaderp, *nfheaderp;
715 lispobj nfheaderl;
716
717 fheaderp = (struct function *) PTR(fheaderl);
718 gc_assert(TypeOf(fheaderp->header) == type_FunctionHeader);
719
720 /* calcuate the new function pointer and the new */
721 /* function header */
722 nfheaderl = fheaderl + displacement;
723 nfheaderp = (struct function *) PTR(nfheaderl);
724
62957726 725 /* set forwarding pointer */
9a8c1c2f 726 fheaderp->header = nfheaderl;
727
728 /* fix self pointer */
729 nfheaderp->self = nfheaderl;
730
731 *prev_pointer = nfheaderl;
732
733 fheaderl = fheaderp->next;
734 prev_pointer = &nfheaderp->next;
735 }
62957726 736
cdac17ab 737#ifndef MACH
9a8c1c2f 738 os_flush_icache((os_vm_address_t) (((int *) new_code) + nheader_words),
739 ncode_words * sizeof(int));
a76b7b5a 740#endif
9a8c1c2f 741 return new_code;
62957726 742}
743
744static int
9a8c1c2f 745scav_code_header(lispobj * where, lispobj object)
62957726 746{
9a8c1c2f 747 struct code *code;
748 int nheader_words, ncode_words, nwords;
749 lispobj fheaderl;
750 struct function *fheaderp;
62957726 751
9a8c1c2f 752 code = (struct code *) where;
753 ncode_words = fixnum_value(code->code_size);
754 nheader_words = HeaderValue(object);
755 nwords = ncode_words + nheader_words;
756 nwords = CEILING(nwords, 2);
62957726 757
758#if defined(DEBUG_CODE_GC)
9a8c1c2f 759 printf("\nScavening code object at 0x%08x.\n", (unsigned long) where);
760 printf("Code object is %d words long.\n", nwords);
761 printf("Scavenging boxed section of code data block (%d words).\n",
762 nheader_words - 1);
763#endif
764
765 /* Scavenge the boxed section of the code data block */
766 scavenge(where + 1, nheader_words - 1);
767
768 /* Scavenge the boxed section of each function object in the */
769 /* code data block */
770 fheaderl = code->entry_points;
771 while (fheaderl != NIL) {
772 fheaderp = (struct function *) PTR(fheaderl);
773 gc_assert(TypeOf(fheaderp->header) == type_FunctionHeader);
774
62957726 775#if defined(DEBUG_CODE_GC)
9a8c1c2f 776 printf("Scavenging boxed section of entry point located at 0x%08x.\n",
777 (unsigned long) PTR(fheaderl));
778#endif
779 scavenge(&fheaderp->name, 1);
780 scavenge(&fheaderp->arglist, 1);
781 scavenge(&fheaderp->type, 1);
782
783 fheaderl = fheaderp->next;
784 }
785
786 return nwords;
62957726 787}
788
789static lispobj
790trans_code_header(lispobj object)
791{
9a8c1c2f 792 struct code *ncode;
62957726 793
9a8c1c2f 794 ncode = trans_code((struct code *) PTR(object));
795 return (lispobj) ncode | type_OtherPointer;
62957726 796}
797
798static int
9a8c1c2f 799size_code_header(lispobj * where)
62957726 800{
9a8c1c2f 801 struct code *code;
802 int nheader_words, ncode_words, nwords;
803
804 code = (struct code *) where;
62957726 805
9a8c1c2f 806 ncode_words = fixnum_value(code->code_size);
807 nheader_words = HeaderValue(code->header);
808 nwords = ncode_words + nheader_words;
809 nwords = CEILING(nwords, 2);
62957726 810
9a8c1c2f 811 return nwords;
62957726 812}
813
814
815static int
9a8c1c2f 816scav_return_pc_header(lispobj * where, lispobj object)
62957726 817{
818 fprintf(stderr, "GC lossage. Should not be scavenging a ");
819 fprintf(stderr, "Return PC Header.\n");
820 fprintf(stderr, "where = 0x%08x, object = 0x%08x",
821 (unsigned long) where, (unsigned long) object);
822 lose(NULL);
823 return 0;
824}
825
826static lispobj
827trans_return_pc_header(lispobj object)
828{
9a8c1c2f 829 struct function *return_pc;
830 unsigned long offset;
831 struct code *code, *ncode;
832
833 return_pc = (struct function *) PTR(object);
834 offset = HeaderValue(return_pc->header) * 4;
62957726 835
9a8c1c2f 836 /* Transport the whole code object */
837 code = (struct code *) ((unsigned long) return_pc - offset);
838 ncode = trans_code(code);
62957726 839
9a8c1c2f 840 return ((lispobj) ncode + offset) | type_OtherPointer;
62957726 841}
842
843/* On the 386, closures hold a pointer to the raw address instead of the
844 function object, so we can use CALL [$FDEFN+const] to invoke the function
845 without loading it into a register. Given that code objects don't move,
846 we don't need to update anything, but we do have to figure out that the
847 function is still live. */
848#ifdef i386
849static
850scav_closure_header(where, object)
9a8c1c2f 851 lispobj *where, object;
62957726 852{
9a8c1c2f 853 struct closure *closure;
854 lispobj fun;
62957726 855
9a8c1c2f 856 closure = (struct closure *) where;
857 fun = closure->function - RAW_ADDR_OFFSET;
858 scavenge(&fun, 1);
62957726 859
9a8c1c2f 860 return 2;
62957726 861}
862#endif
863
864static int
9a8c1c2f 865scav_function_header(lispobj * where, lispobj object)
62957726 866{
867 fprintf(stderr, "GC lossage. Should not be scavenging a ");
868 fprintf(stderr, "Function Header.\n");
869 fprintf(stderr, "where = 0x%08x, object = 0x%08x",
870 (unsigned long) where, (unsigned long) object);
871 lose(NULL);
872 return 0;
873}
874
875static lispobj
876trans_function_header(lispobj object)
877{
9a8c1c2f 878 struct function *fheader;
879 unsigned long offset;
880 struct code *code, *ncode;
62957726 881
9a8c1c2f 882 fheader = (struct function *) PTR(object);
883 offset = HeaderValue(fheader->header) * 4;
62957726 884
9a8c1c2f 885 /* Transport the whole code object */
886 code = (struct code *) ((unsigned long) fheader - offset);
887 ncode = trans_code(code);
888
889 return ((lispobj) ncode + offset) | type_FunctionPointer;
62957726 890}
9a8c1c2f 891\f
62957726 892
893
26831fda 894/* Instances */
62957726 895
18369c77 896#if DIRECT_SCAV
62957726 897static int
9a8c1c2f 898scav_instance_pointer(lispobj * where, lispobj object)
62957726 899{
900 if (from_space_p(object)) {
901 lispobj first, *first_pointer;
902
903 /* object is a pointer into from space. check to see */
904 /* if it has been forwarded */
905 first_pointer = (lispobj *) PTR(object);
906 first = *first_pointer;
9a8c1c2f 907
62957726 908 if (!(Pointerp(first) && new_space_p(first)))
909 first = *first_pointer = trans_boxed(object);
910 *where = first;
911 }
912 return 1;
913}
18369c77 914#else
915static int
9a8c1c2f 916scav_instance_pointer(lispobj * where, lispobj object)
18369c77 917{
9a8c1c2f 918 lispobj *first_pointer;
919
920 /* object is a pointer into from space. Not a FP */
921 first_pointer = (lispobj *) PTR(object);
922
923 *where = *first_pointer = trans_boxed(object);
924 return 1;
18369c77 925}
926#endif
62957726 927\f
9a8c1c2f 928
62957726 929/* Lists and Conses */
930
931static lispobj trans_list(lispobj object);
932
18369c77 933#if DIRECT_SCAV
62957726 934static int
9a8c1c2f 935scav_list_pointer(lispobj * where, lispobj object)
62957726 936{
9a8c1c2f 937 gc_assert(Pointerp(object));
938
939 if (from_space_p(object)) {
940 lispobj first, *first_pointer;
62957726 941
9a8c1c2f 942 /* object is a pointer into from space. check to see */
943 /* if it has been forwarded */
944 first_pointer = (lispobj *) PTR(object);
945 first = *first_pointer;
62957726 946
9a8c1c2f 947 if (!(Pointerp(first) && new_space_p(first)))
948 first = *first_pointer = trans_list(object);
62957726 949
9a8c1c2f 950 gc_assert(Pointerp(first));
951 gc_assert(!from_space_p(first));
952
953 *where = first;
954 }
955 return 1;
62957726 956}
18369c77 957#else
958static int
9a8c1c2f 959scav_list_pointer(lispobj * where, lispobj object)
18369c77 960{
9a8c1c2f 961 lispobj first, *first_pointer;
962
963 gc_assert(Pointerp(object));
18369c77 964
9a8c1c2f 965 /* object is a pointer into from space. Not a FP. */
966 first_pointer = (lispobj *) PTR(object);
18369c77 967
9a8c1c2f 968 first = *first_pointer = trans_list(object);
969
970 gc_assert(Pointerp(first));
971 gc_assert(!from_space_p(first));
972
973 *where = first;
974 return 1;
18369c77 975}
976#endif
62957726 977
978static lispobj
979trans_list(lispobj object)
980{
9a8c1c2f 981 lispobj new_list_pointer;
982 struct cons *cons, *new_cons;
62957726 983
9a8c1c2f 984 cons = (struct cons *) PTR(object);
985
986 /* ### Don't use copy_object here. */
987 new_list_pointer = copy_object(object, 2);
988 new_cons = (struct cons *) PTR(new_list_pointer);
989
990 /* Set forwarding pointer. */
991 cons->car = new_list_pointer;
992
993 /* Try to linearize the list in the cdr direction to help reduce */
994 /* paging. */
995
996 while (1) {
997 lispobj cdr, new_cdr, first;
998 struct cons *cdr_cons, *new_cdr_cons;
999
1000 cdr = cons->cdr;
1001
1002 if (LowtagOf(cdr) != type_ListPointer ||
1003 !from_space_p(cdr) ||
1004 (Pointerp(first = *(lispobj *) PTR(cdr)) && new_space_p(first)))
1005 break;
1006
1007 cdr_cons = (struct cons *) PTR(cdr);
62957726 1008
9a8c1c2f 1009 /* ### Don't use copy_object here */
1010 new_cdr = copy_object(cdr, 2);
1011 new_cdr_cons = (struct cons *) PTR(new_cdr);
1012
1013 /* Set forwarding pointer */
1014 cdr_cons->car = new_cdr;
1015
1016 /* Update the cdr of the last cons copied into new */
1017 /* space to keep the newspace scavenge from having to */
1018 /* do it. */
1019 new_cons->cdr = new_cdr;
1020
1021 cons = cdr_cons;
1022 new_cons = new_cdr_cons;
1023 }
1024
1025 return new_list_pointer;
1026}
62957726 1027\f
9a8c1c2f 1028
62957726 1029/* Scavenging and Transporting Other Pointers */
1030
18369c77 1031#if DIRECT_SCAV
62957726 1032static int
9a8c1c2f 1033scav_other_pointer(lispobj * where, lispobj object)
62957726 1034{
9a8c1c2f 1035 gc_assert(Pointerp(object));
1036
1037 if (from_space_p(object)) {
1038 lispobj first, *first_pointer;
62957726 1039
9a8c1c2f 1040 /* object is a pointer into from space. check to see */
1041 /* if it has been forwarded */
1042 first_pointer = (lispobj *) PTR(object);
1043 first = *first_pointer;
62957726 1044
9a8c1c2f 1045 if (!(Pointerp(first) && new_space_p(first)))
1046 first = *first_pointer = (transother[TypeOf(first)]) (object);
62957726 1047
9a8c1c2f 1048 gc_assert(Pointerp(first));
1049 gc_assert(!from_space_p(first));
62957726 1050
9a8c1c2f 1051 *where = first;
1052 }
1053 return 1;
62957726 1054}
18369c77 1055#else
1056static int
9a8c1c2f 1057scav_other_pointer(lispobj * where, lispobj object)
18369c77 1058{
9a8c1c2f 1059 lispobj first, *first_pointer;
18369c77 1060
9a8c1c2f 1061 gc_assert(Pointerp(object));
18369c77 1062
9a8c1c2f 1063 /* Object is a pointer into from space - not a FP */
1064 first_pointer = (lispobj *) PTR(object);
1065 first = *first_pointer = (transother[TypeOf(*first_pointer)]) (object);
18369c77 1066
9a8c1c2f 1067 gc_assert(Pointerp(first));
1068 gc_assert(!from_space_p(first));
18369c77 1069
9a8c1c2f 1070 *where = first;
1071 return 1;
18369c77 1072}
1073#endif
62957726 1074\f
9a8c1c2f 1075
62957726 1076/* Immediate, Boxed, and Unboxed Objects */
1077
1078static int
9a8c1c2f 1079size_pointer(lispobj * where)
62957726 1080{
1081 return 1;
1082}
1083
1084static int
9a8c1c2f 1085scav_immediate(lispobj * where, lispobj object)
62957726 1086{
1087 return 1;
1088}
1089
1090static lispobj
1091trans_immediate(lispobj object)
1092{
1093 fprintf(stderr, "GC lossage. Trying to transport an immediate!?\n");
1094 lose(NULL);
1095 return NIL;
1096}
1097
1098static int
9a8c1c2f 1099size_immediate(lispobj * where)
62957726 1100{
1101 return 1;
1102}
1103
1104
1105static int
9a8c1c2f 1106scav_boxed(lispobj * where, lispobj object)
62957726 1107{
1108 return 1;
1109}
1110
1111static lispobj
1112trans_boxed(lispobj object)
1113{
9a8c1c2f 1114 lispobj header;
1115 unsigned long length;
62957726 1116
9a8c1c2f 1117 gc_assert(Pointerp(object));
62957726 1118
9a8c1c2f 1119 header = *((lispobj *) PTR(object));
1120 length = HeaderValue(header) + 1;
1121 length = CEILING(length, 2);
62957726 1122
9a8c1c2f 1123 return copy_object(object, length);
62957726 1124}
1125
1126static int
9a8c1c2f 1127size_boxed(lispobj * where)
62957726 1128{
9a8c1c2f 1129 lispobj header;
1130 unsigned long length;
62957726 1131
9a8c1c2f 1132 header = *where;
1133 length = HeaderValue(header) + 1;
1134 length = CEILING(length, 2);
62957726 1135
9a8c1c2f 1136 return length;
62957726 1137}
1138
1139/* Note: on the sparc we don't have to do anything special for fdefns, */
1140/* cause the raw-addr has a function lowtag. */
903edb2a 1141#if !(defined(sparc) || defined(DARWIN))
62957726 1142static int
9a8c1c2f 1143scav_fdefn(lispobj * where, lispobj object)
62957726 1144{
1145 struct fdefn *fdefn;
1146
9a8c1c2f 1147 fdefn = (struct fdefn *) where;
1148
1149 if ((char *) (fdefn->function + RAW_ADDR_OFFSET) == fdefn->raw_addr) {
1150 scavenge(where + 1, sizeof(struct fdefn) / sizeof(lispobj) - 1);
1151
1152 fdefn->raw_addr = (char *) (fdefn->function + RAW_ADDR_OFFSET);
1153 return sizeof(struct fdefn) / sizeof(lispobj);
1154 } else
1155 return 1;
62957726 1156}
1157#endif
1158
1159static int
9a8c1c2f 1160scav_unboxed(lispobj * where, lispobj object)
62957726 1161{
9a8c1c2f 1162 unsigned long length;
62957726 1163
9a8c1c2f 1164 length = HeaderValue(object) + 1;
1165 length = CEILING(length, 2);
62957726 1166
9a8c1c2f 1167 return length;
62957726 1168}
1169
1170static lispobj
1171trans_unboxed(lispobj object)
1172{
9a8c1c2f 1173 lispobj header;
1174 unsigned long length;
62957726 1175
1176
9a8c1c2f 1177 gc_assert(Pointerp(object));
62957726 1178
9a8c1c2f 1179 header = *((lispobj *) PTR(object));
1180 length = HeaderValue(header) + 1;
1181 length = CEILING(length, 2);
62957726 1182
9a8c1c2f 1183 return copy_object(object, length);
62957726 1184}
1185
1186static int
9a8c1c2f 1187size_unboxed(lispobj * where)
62957726 1188{
9a8c1c2f 1189 lispobj header;
1190 unsigned long length;
62957726 1191
9a8c1c2f 1192 header = *where;
1193 length = HeaderValue(header) + 1;
1194 length = CEILING(length, 2);
62957726 1195
9a8c1c2f 1196 return length;
62957726 1197}
62957726 1198\f
9a8c1c2f 1199
62957726 1200/* Vector-Like Objects */
1201
1202#define NWORDS(x,y) (CEILING((x),(y)) / (y))
1203
1204static int
9a8c1c2f 1205scav_string(lispobj * where, lispobj object)
62957726 1206{
9a8c1c2f 1207 struct vector *vector;
1208 int length, nwords;
62957726 1209
9a8c1c2f 1210 /* NOTE: Strings contain one more byte of data than the length */
1211 /* slot indicates. */
62957726 1212
9a8c1c2f 1213 vector = (struct vector *) where;
1214 length = fixnum_value(vector->length) + 1;
1215 nwords = CEILING(NWORDS(length, 4) + 2, 2);
62957726 1216
9a8c1c2f 1217 return nwords;
62957726 1218}
1219
1220static lispobj
1221trans_string(lispobj object)
1222{
9a8c1c2f 1223 struct vector *vector;
1224 int length, nwords;
62957726 1225
9a8c1c2f 1226 gc_assert(Pointerp(object));
62957726 1227
9a8c1c2f 1228 /* NOTE: Strings contain one more byte of data than the length */
1229 /* slot indicates. */
62957726 1230
9a8c1c2f 1231 vector = (struct vector *) PTR(object);
1232 length = fixnum_value(vector->length) + 1;
1233 nwords = CEILING(NWORDS(length, 4) + 2, 2);
62957726 1234
9a8c1c2f 1235 return copy_object(object, nwords);
62957726 1236}
1237
1238static int
9a8c1c2f 1239size_string(lispobj * where)
62957726 1240{
9a8c1c2f 1241 struct vector *vector;
1242 int length, nwords;
62957726 1243
9a8c1c2f 1244 /* NOTE: Strings contain one more byte of data than the length */
1245 /* slot indicates. */
62957726 1246
9a8c1c2f 1247 vector = (struct vector *) where;
1248 length = fixnum_value(vector->length) + 1;
1249 nwords = CEILING(NWORDS(length, 4) + 2, 2);
62957726 1250
9a8c1c2f 1251 return nwords;
62957726 1252}
1253
1254static int
9a8c1c2f 1255scav_vector(lispobj * where, lispobj object)
62957726 1256{
1257 if (HeaderValue(object) == subtype_VectorValidHashing)
9a8c1c2f 1258 *where = (subtype_VectorMustRehash << type_Bits) | type_SimpleVector;
62957726 1259
1260 return 1;
1261}
1262
1263
1264static lispobj
1265trans_vector(lispobj object)
1266{
9a8c1c2f 1267 struct vector *vector;
1268 int length, nwords;
62957726 1269
9a8c1c2f 1270 gc_assert(Pointerp(object));
62957726 1271
9a8c1c2f 1272 vector = (struct vector *) PTR(object);
62957726 1273
9a8c1c2f 1274 length = fixnum_value(vector->length);
1275 nwords = CEILING(length + 2, 2);
62957726 1276
9a8c1c2f 1277 return copy_object(object, nwords);
62957726 1278}
1279
1280static int
9a8c1c2f 1281size_vector(lispobj * where)
62957726 1282{
9a8c1c2f 1283 struct vector *vector;
1284 int length, nwords;
62957726 1285
9a8c1c2f 1286 vector = (struct vector *) where;
1287 length = fixnum_value(vector->length);
1288 nwords = CEILING(length + 2, 2);
62957726 1289
9a8c1c2f 1290 return nwords;
62957726 1291}
1292
1293
1294static int
9a8c1c2f 1295scav_vector_bit(lispobj * where, lispobj object)
62957726 1296{
9a8c1c2f 1297 struct vector *vector;
1298 int length, nwords;
62957726 1299
9a8c1c2f 1300 vector = (struct vector *) where;
1301 length = fixnum_value(vector->length);
1302 nwords = CEILING(NWORDS(length, 32) + 2, 2);
62957726 1303
9a8c1c2f 1304 return nwords;
62957726 1305}
1306
1307static lispobj
1308trans_vector_bit(lispobj object)
1309{
9a8c1c2f 1310 struct vector *vector;
1311 int length, nwords;
62957726 1312
9a8c1c2f 1313 gc_assert(Pointerp(object));
62957726 1314
9a8c1c2f 1315 vector = (struct vector *) PTR(object);
1316 length = fixnum_value(vector->length);
1317 nwords = CEILING(NWORDS(length, 32) + 2, 2);
62957726 1318
9a8c1c2f 1319 return copy_object(object, nwords);
62957726 1320}
1321
1322static int
9a8c1c2f 1323size_vector_bit(lispobj * where)
62957726 1324{
9a8c1c2f 1325 struct vector *vector;
1326 int length, nwords;
62957726 1327
9a8c1c2f 1328 vector = (struct vector *) where;
1329 length = fixnum_value(vector->length);
1330 nwords = CEILING(NWORDS(length, 32) + 2, 2);
62957726 1331
9a8c1c2f 1332 return nwords;
62957726 1333}
1334
1335
1336static int
9a8c1c2f 1337scav_vector_unsigned_byte_2(lispobj * where, lispobj object)
62957726 1338{
9a8c1c2f 1339 struct vector *vector;
1340 int length, nwords;
62957726 1341
9a8c1c2f 1342 vector = (struct vector *) where;
1343 length = fixnum_value(vector->length);
1344 nwords = CEILING(NWORDS(length, 16) + 2, 2);
62957726 1345
9a8c1c2f 1346 return nwords;
62957726 1347}
1348
1349static lispobj
1350trans_vector_unsigned_byte_2(lispobj object)
1351{
9a8c1c2f 1352 struct vector *vector;
1353 int length, nwords;
62957726 1354
9a8c1c2f 1355 gc_assert(Pointerp(object));
62957726 1356
9a8c1c2f 1357 vector = (struct vector *) PTR(object);
1358 length = fixnum_value(vector->length);
1359 nwords = CEILING(NWORDS(length, 16) + 2, 2);
62957726 1360
9a8c1c2f 1361 return copy_object(object, nwords);
62957726 1362}
1363
1364static int
9a8c1c2f 1365size_vector_unsigned_byte_2(lispobj * where)
62957726 1366{
9a8c1c2f 1367 struct vector *vector;
1368 int length, nwords;
62957726 1369
9a8c1c2f 1370 vector = (struct vector *) where;
1371 length = fixnum_value(vector->length);
1372 nwords = CEILING(NWORDS(length, 16) + 2, 2);
62957726 1373
9a8c1c2f 1374 return nwords;
62957726 1375}
1376
1377
1378static int
9a8c1c2f 1379scav_vector_unsigned_byte_4(lispobj * where, lispobj object)
62957726 1380{
9a8c1c2f 1381 struct vector *vector;
1382 int length, nwords;
62957726 1383
9a8c1c2f 1384 vector = (struct vector *) where;
1385 length = fixnum_value(vector->length);
1386 nwords = CEILING(NWORDS(length, 8) + 2, 2);
62957726 1387
9a8c1c2f 1388 return nwords;
62957726 1389}
1390
1391static lispobj
1392trans_vector_unsigned_byte_4(lispobj object)
1393{
9a8c1c2f 1394 struct vector *vector;
1395 int length, nwords;
62957726 1396
9a8c1c2f 1397 gc_assert(Pointerp(object));
62957726 1398
9a8c1c2f 1399 vector = (struct vector *) PTR(object);
1400 length = fixnum_value(vector->length);
1401 nwords = CEILING(NWORDS(length, 8) + 2, 2);
62957726 1402
9a8c1c2f 1403 return copy_object(object, nwords);
62957726 1404}
1405
1406static int
9a8c1c2f 1407size_vector_unsigned_byte_4(lispobj * where)
62957726 1408{
9a8c1c2f 1409 struct vector *vector;
1410 int length, nwords;
62957726 1411
9a8c1c2f 1412 vector = (struct vector *) where;
1413 length = fixnum_value(vector->length);
1414 nwords = CEILING(NWORDS(length, 8) + 2, 2);
62957726 1415
9a8c1c2f 1416 return nwords;
62957726 1417}
1418
1419
1420static int
9a8c1c2f 1421scav_vector_unsigned_byte_8(lispobj * where, lispobj object)
62957726 1422{
9a8c1c2f 1423 struct vector *vector;
1424 int length, nwords;
62957726 1425
9a8c1c2f 1426 vector = (struct vector *) where;
1427 length = fixnum_value(vector->length);
1428 nwords = CEILING(NWORDS(length, 4) + 2, 2);
62957726 1429
9a8c1c2f 1430 return nwords;
62957726 1431}
1432
1433static lispobj
1434trans_vector_unsigned_byte_8(lispobj object)
1435{
9a8c1c2f 1436 struct vector *vector;
1437 int length, nwords;
62957726 1438
9a8c1c2f 1439 gc_assert(Pointerp(object));
62957726 1440
9a8c1c2f 1441 vector = (struct vector *) PTR(object);
1442 length = fixnum_value(vector->length);
1443 nwords = CEILING(NWORDS(length, 4) + 2, 2);
62957726 1444
9a8c1c2f 1445 return copy_object(object, nwords);
62957726 1446}
1447
1448static int
9a8c1c2f 1449size_vector_unsigned_byte_8(lispobj * where)
62957726 1450{
9a8c1c2f 1451 struct vector *vector;
1452 int length, nwords;
62957726 1453
9a8c1c2f 1454 vector = (struct vector *) where;
1455 length = fixnum_value(vector->length);
1456 nwords = CEILING(NWORDS(length, 4) + 2, 2);
62957726 1457
9a8c1c2f 1458 return nwords;
62957726 1459}
1460
1461
1462static int
9a8c1c2f 1463scav_vector_unsigned_byte_16(lispobj * where, lispobj object)
62957726 1464{
9a8c1c2f 1465 struct vector *vector;
1466 int length, nwords;
62957726 1467
9a8c1c2f 1468 vector = (struct vector *) where;
1469 length = fixnum_value(vector->length);
1470 nwords = CEILING(NWORDS(length, 2) + 2, 2);
62957726 1471
9a8c1c2f 1472 return nwords;
62957726 1473}
1474
1475static lispobj
1476trans_vector_unsigned_byte_16(lispobj object)
1477{
9a8c1c2f 1478 struct vector *vector;
1479 int length, nwords;
62957726 1480
9a8c1c2f 1481 gc_assert(Pointerp(object));
62957726 1482
9a8c1c2f 1483 vector = (struct vector *) PTR(object);
1484 length = fixnum_value(vector->length);
1485 nwords = CEILING(NWORDS(length, 2) + 2, 2);
62957726 1486
9a8c1c2f 1487 return copy_object(object, nwords);
62957726 1488}
1489
1490static int
9a8c1c2f 1491size_vector_unsigned_byte_16(lispobj * where)
62957726 1492{
9a8c1c2f 1493 struct vector *vector;
1494 int length, nwords;
62957726 1495
9a8c1c2f 1496 vector = (struct vector *) where;
1497 length = fixnum_value(vector->length);
1498 nwords = CEILING(NWORDS(length, 2) + 2, 2);
62957726 1499
9a8c1c2f 1500 return nwords;
62957726 1501}
1502
1503
1504static int
9a8c1c2f 1505scav_vector_unsigned_byte_32(lispobj * where, lispobj object)
62957726 1506{
9a8c1c2f 1507 struct vector *vector;
1508 int length, nwords;
62957726 1509
9a8c1c2f 1510 vector = (struct vector *) where;
1511 length = fixnum_value(vector->length);
1512 nwords = CEILING(length + 2, 2);
62957726 1513
9a8c1c2f 1514 return nwords;
62957726 1515}
1516
1517static lispobj
1518trans_vector_unsigned_byte_32(lispobj object)
1519{
9a8c1c2f 1520 struct vector *vector;
1521 int length, nwords;
62957726 1522
9a8c1c2f 1523 gc_assert(Pointerp(object));
62957726 1524
9a8c1c2f 1525 vector = (struct vector *) PTR(object);
1526 length = fixnum_value(vector->length);
1527 nwords = CEILING(length + 2, 2);
62957726 1528
9a8c1c2f 1529 return copy_object(object, nwords);
62957726 1530}
1531
1532static int
9a8c1c2f 1533size_vector_unsigned_byte_32(lispobj * where)
62957726 1534{
9a8c1c2f 1535 struct vector *vector;
1536 int length, nwords;
62957726 1537
9a8c1c2f 1538 vector = (struct vector *) where;
1539 length = fixnum_value(vector->length);
1540 nwords = CEILING(length + 2, 2);
62957726 1541
9a8c1c2f 1542 return nwords;
62957726 1543}
1544
1545
1546static int
9a8c1c2f 1547scav_vector_single_float(lispobj * where, lispobj object)
62957726 1548{
9a8c1c2f 1549 struct vector *vector;
1550 int length, nwords;
62957726 1551
9a8c1c2f 1552 vector = (struct vector *) where;
1553 length = fixnum_value(vector->length);
1554 nwords = CEILING(length + 2, 2);
62957726 1555
9a8c1c2f 1556 return nwords;
62957726 1557}
1558
1559static lispobj
1560trans_vector_single_float(lispobj object)
1561{
9a8c1c2f 1562 struct vector *vector;
1563 int length, nwords;
62957726 1564
9a8c1c2f 1565 gc_assert(Pointerp(object));
62957726 1566
9a8c1c2f 1567 vector = (struct vector *) PTR(object);
1568 length = fixnum_value(vector->length);
1569 nwords = CEILING(length + 2, 2);
62957726 1570
9a8c1c2f 1571 return copy_object(object, nwords);
62957726 1572}
1573
1574static int
9a8c1c2f 1575size_vector_single_float(lispobj * where)
62957726 1576{
9a8c1c2f 1577 struct vector *vector;
1578 int length, nwords;
62957726 1579
9a8c1c2f 1580 vector = (struct vector *) where;
1581 length = fixnum_value(vector->length);
1582 nwords = CEILING(length + 2, 2);
62957726 1583
9a8c1c2f 1584 return nwords;
62957726 1585}
1586
1587
1588static int
9a8c1c2f 1589scav_vector_double_float(lispobj * where, lispobj object)
62957726 1590{
9a8c1c2f 1591 struct vector *vector;
1592 int length, nwords;
62957726 1593
9a8c1c2f 1594 vector = (struct vector *) where;
1595 length = fixnum_value(vector->length);
1596 nwords = CEILING(length * 2 + 2, 2);
62957726 1597
9a8c1c2f 1598 return nwords;
62957726 1599}
1600
1601static lispobj
1602trans_vector_double_float(lispobj object)
1603{
9a8c1c2f 1604 struct vector *vector;
1605 int length, nwords;
62957726 1606
9a8c1c2f 1607 gc_assert(Pointerp(object));
62957726 1608
9a8c1c2f 1609 vector = (struct vector *) PTR(object);
1610 length = fixnum_value(vector->length);
1611 nwords = CEILING(length * 2 + 2, 2);
62957726 1612
9a8c1c2f 1613 return copy_object(object, nwords);
62957726 1614}
1615
1616static int
9a8c1c2f 1617size_vector_double_float(lispobj * where)
62957726 1618{
9a8c1c2f 1619 struct vector *vector;
1620 int length, nwords;
62957726 1621
9a8c1c2f 1622 vector = (struct vector *) where;
1623 length = fixnum_value(vector->length);
1624 nwords = CEILING(length * 2 + 2, 2);
62957726 1625
9a8c1c2f 1626 return nwords;
62957726 1627}
1628
8de15dca 1629
1630#ifdef type_SimpleArrayLongFloat
1631static int
9a8c1c2f 1632scav_vector_long_float(lispobj * where, lispobj object)
8de15dca 1633{
9a8c1c2f 1634 struct vector *vector;
1635 int length, nwords;
8de15dca 1636
9a8c1c2f 1637 vector = (struct vector *) where;
1638 length = fixnum_value(vector->length);
8de15dca 1639#ifdef sparc
9a8c1c2f 1640 nwords = CEILING(length * 4 + 2, 2);
8de15dca 1641#endif
1642
9a8c1c2f 1643 return nwords;
8de15dca 1644}
1645
1646static lispobj
1647trans_vector_long_float(lispobj object)
1648{
9a8c1c2f 1649 struct vector *vector;
1650 int length, nwords;
8de15dca 1651
9a8c1c2f 1652 gc_assert(Pointerp(object));
8de15dca 1653
9a8c1c2f 1654 vector = (struct vector *) PTR(object);
1655 length = fixnum_value(vector->length);
8de15dca 1656#ifdef sparc
9a8c1c2f 1657 nwords = CEILING(length * 4 + 2, 2);
8de15dca 1658#endif
1659
9a8c1c2f 1660 return copy_object(object, nwords);
8de15dca 1661}
1662
1663static int
9a8c1c2f 1664size_vector_long_float(lispobj * where)
8de15dca 1665{
9a8c1c2f 1666 struct vector *vector;
1667 int length, nwords;
8de15dca 1668
9a8c1c2f 1669 vector = (struct vector *) where;
1670 length = fixnum_value(vector->length);
8de15dca 1671#ifdef sparc
9a8c1c2f 1672 nwords = CEILING(length * 4 + 2, 2);
8de15dca 1673#endif
1674
9a8c1c2f 1675 return nwords;
8de15dca 1676}
1677#endif
1678
1679
cf3681ae 1680#ifdef type_SimpleArrayDoubleDoubleFloat
1681static int
1682size_vector_double_double_float(lispobj * where)
1683{
1684 struct vector *vector;
1685 int length, nwords;
1686
1687 vector = (struct vector *) where;
1688 length = fixnum_value(vector->length);
1689 nwords = CEILING(length * 4 + 2, 2);
1690
1691 return nwords;
1692}
1693
1694static int
1695scav_vector_double_double_float(lispobj * where, lispobj object)
1696{
1697 return size_vector_double_double_float(where);
1698}
1699
1700static lispobj
1701trans_vector_double_double_float(lispobj object)
1702{
1703 gc_assert(Pointerp(object));
1704 return copy_object(object, size_vector_double_double_float((lispobj *)
1705 PTR(object)));
1706}
1707#endif
1708
1709
4c3b1bb6 1710#ifdef type_SimpleArrayComplexSingleFloat
1711static int
9a8c1c2f 1712scav_vector_complex_single_float(lispobj * where, lispobj object)
4c3b1bb6 1713{
9a8c1c2f 1714 struct vector *vector;
1715 int length, nwords;
4c3b1bb6 1716
9a8c1c2f 1717 vector = (struct vector *) where;
1718 length = fixnum_value(vector->length);
1719 nwords = CEILING(length * 2 + 2, 2);
4c3b1bb6 1720
9a8c1c2f 1721 return nwords;
4c3b1bb6 1722}
1723
1724static lispobj
1725trans_vector_complex_single_float(lispobj object)
1726{
9a8c1c2f 1727 struct vector *vector;
1728 int length, nwords;
4c3b1bb6 1729
9a8c1c2f 1730 gc_assert(Pointerp(object));
4c3b1bb6 1731
9a8c1c2f 1732 vector = (struct vector *) PTR(object);
1733 length = fixnum_value(vector->length);
1734 nwords = CEILING(length * 2 + 2, 2);
4c3b1bb6 1735
9a8c1c2f 1736 return copy_object(object, nwords);
4c3b1bb6 1737}
1738
1739static int
9a8c1c2f 1740size_vector_complex_single_float(lispobj * where)
4c3b1bb6 1741{
9a8c1c2f 1742 struct vector *vector;
1743 int length, nwords;
4c3b1bb6 1744
9a8c1c2f 1745 vector = (struct vector *) where;
1746 length = fixnum_value(vector->length);
1747 nwords = CEILING(length * 2 + 2, 2);
4c3b1bb6 1748
9a8c1c2f 1749 return nwords;
4c3b1bb6 1750}
1751#endif
1752
1753#ifdef type_SimpleArrayComplexDoubleFloat
1754static int
9a8c1c2f 1755scav_vector_complex_double_float(lispobj * where, lispobj object)
4c3b1bb6 1756{
9a8c1c2f 1757 struct vector *vector;
1758 int length, nwords;
4c3b1bb6 1759
9a8c1c2f 1760 vector = (struct vector *) where;
1761 length = fixnum_value(vector->length);
1762 nwords = CEILING(length * 4 + 2, 2);
4c3b1bb6 1763
9a8c1c2f 1764 return nwords;
4c3b1bb6 1765}
1766
1767static lispobj
1768trans_vector_complex_double_float(lispobj object)
1769{
9a8c1c2f 1770 struct vector *vector;
1771 int length, nwords;
4c3b1bb6 1772
9a8c1c2f 1773 gc_assert(Pointerp(object));
4c3b1bb6 1774
9a8c1c2f 1775 vector = (struct vector *) PTR(object);
1776 length = fixnum_value(vector->length);
1777 nwords = CEILING(length * 4 + 2, 2);
4c3b1bb6 1778
9a8c1c2f 1779 return copy_object(object, nwords);
4c3b1bb6 1780}
1781
1782static int
9a8c1c2f 1783size_vector_complex_double_float(lispobj * where)
4c3b1bb6 1784{
9a8c1c2f 1785 struct vector *vector;
1786 int length, nwords;
4c3b1bb6 1787
9a8c1c2f 1788 vector = (struct vector *) where;
1789 length = fixnum_value(vector->length);
1790 nwords = CEILING(length * 4 + 2, 2);
4c3b1bb6 1791
9a8c1c2f 1792 return nwords;
4c3b1bb6 1793}
1794#endif
1795
8de15dca 1796#ifdef type_SimpleArrayComplexLongFloat
1797static int
9a8c1c2f 1798scav_vector_complex_long_float(lispobj * where, lispobj object)
8de15dca 1799{
9a8c1c2f 1800 struct vector *vector;
1801 int length, nwords;
8de15dca 1802
9a8c1c2f 1803 vector = (struct vector *) where;
1804 length = fixnum_value(vector->length);
8de15dca 1805#ifdef sparc
9a8c1c2f 1806 nwords = CEILING(length * 8 + 2, 2);
8de15dca 1807#endif
1808
9a8c1c2f 1809 return nwords;
8de15dca 1810}
1811
1812static lispobj
1813trans_vector_complex_long_float(lispobj object)
1814{
9a8c1c2f 1815 struct vector *vector;
1816 int length, nwords;
8de15dca 1817
9a8c1c2f 1818 gc_assert(Pointerp(object));
8de15dca 1819
9a8c1c2f 1820 vector = (struct vector *) PTR(object);
1821 length = fixnum_value(vector->length);
8de15dca 1822#ifdef sparc
9a8c1c2f 1823 nwords = CEILING(length * 8 + 2, 2);
8de15dca 1824#endif
1825
9a8c1c2f 1826 return copy_object(object, nwords);
8de15dca 1827}
1828
1829static int
9a8c1c2f 1830size_vector_complex_long_float(lispobj * where)
8de15dca 1831{
9a8c1c2f 1832 struct vector *vector;
1833 int length, nwords;
8de15dca 1834
9a8c1c2f 1835 vector = (struct vector *) where;
1836 length = fixnum_value(vector->length);
8de15dca 1837#ifdef sparc
9a8c1c2f 1838 nwords = CEILING(length * 8 + 2, 2);
8de15dca 1839#endif
1840
9a8c1c2f 1841 return nwords;
8de15dca 1842}
1843#endif
cf3681ae 1844
1845#ifdef type_SimpleArrayComplexDoubleDoubleFloat
1846static int
1847size_vector_complex_double_double_float(lispobj * where)
1848{
1849 struct vector *vector;
1850 int length, nwords;
1851
1852 vector = (struct vector *) where;
1853 length = fixnum_value(vector->length);
1854 nwords = length * 8 + 2;
1855
1856 return nwords;
1857}
1858
1859static int
1860scav_vector_complex_double_double_float(lispobj * where, lispobj object)
1861{
1862 return size_vector_complex_double_double_float(where);
1863}
1864
1865static lispobj
1866trans_vector_complex_double_double_float(lispobj object)
1867{
1868 gc_assert(Pointerp(object));
1869 return copy_object(object,
1870 size_vector_complex_double_double_float((lispobj *)
1871 PTR(object)));
1872}
1873#endif
62957726 1874\f
9a8c1c2f 1875
62957726 1876/* Weak Pointers */
1877
1878#define WEAK_POINTER_NWORDS \
1879 CEILING((sizeof(struct weak_pointer) / sizeof(lispobj)), 2)
1880
1881static int
9a8c1c2f 1882scav_weak_pointer(lispobj * where, lispobj object)
62957726 1883{
9a8c1c2f 1884 /* Do not let GC scavenge the value slot of the weak pointer */
1885 /* (that is why it is a weak pointer). Note: we could use */
1886 /* the scav_unboxed method here. */
62957726 1887
9a8c1c2f 1888 return WEAK_POINTER_NWORDS;
62957726 1889}
1890
1891static lispobj
1892trans_weak_pointer(lispobj object)
1893{
9a8c1c2f 1894 lispobj copy;
1895 struct weak_pointer *wp;
62957726 1896
9a8c1c2f 1897 gc_assert(Pointerp(object));
62957726 1898
1899#if defined(DEBUG_WEAK)
9a8c1c2f 1900 printf("Transporting weak pointer from 0x%08x\n", object);
62957726 1901#endif
1902
9a8c1c2f 1903 /* Need to remember where all the weak pointers are that have */
1904 /* been transported so they can be fixed up in a post-GC pass. */
62957726 1905
9a8c1c2f 1906 copy = copy_object(object, WEAK_POINTER_NWORDS);
1907 wp = (struct weak_pointer *) PTR(copy);
62957726 1908
62957726 1909
9a8c1c2f 1910 /* Push the weak pointer onto the list of weak pointers. */
1911 wp->next = weak_pointers;
1912 weak_pointers = wp;
1913
1914 return copy;
62957726 1915}
1916
1917static int
9a8c1c2f 1918size_weak_pointer(lispobj * where)
62957726 1919{
9a8c1c2f 1920 return WEAK_POINTER_NWORDS;
62957726 1921}
1922
9a8c1c2f 1923void
1924scan_weak_pointers(void)
62957726 1925{
9a8c1c2f 1926 struct weak_pointer *wp;
62957726 1927
9a8c1c2f 1928 for (wp = weak_pointers; wp != (struct weak_pointer *) NULL; wp = wp->next) {
1929 lispobj value;
1930 lispobj first, *first_pointer;
62957726 1931
9a8c1c2f 1932 value = wp->value;
62957726 1933
1934#if defined(DEBUG_WEAK)
9a8c1c2f 1935 printf("Weak pointer at 0x%08x\n", (unsigned long) wp);
1936 printf("Value: 0x%08x\n", (unsigned long) value);
1937#endif
62957726 1938
9a8c1c2f 1939 if (!(Pointerp(value) && from_space_p(value)))
1940 continue;
62957726 1941
9a8c1c2f 1942 /* Now, we need to check if the object has been */
1943 /* forwarded. If it has been, the weak pointer is */
1944 /* still good and needs to be updated. Otherwise, the */
1945 /* weak pointer needs to be nil'ed out. */
1946
1947 first_pointer = (lispobj *) PTR(value);
1948 first = *first_pointer;
62957726 1949
62957726 1950#if defined(DEBUG_WEAK)
9a8c1c2f 1951 printf("First: 0x%08x\n", (unsigned long) first);
1952#endif
1953
1954 if (Pointerp(first) && new_space_p(first))
1955 wp->value = first;
1956 else {
1957 wp->value = NIL;
1958 wp->broken = T;
62957726 1959 }
9a8c1c2f 1960 }
62957726 1961}
9a8c1c2f 1962\f
62957726 1963
1964
62957726 1965/* Initialization */
1966
1967static int
9a8c1c2f 1968scav_lose(lispobj * where, lispobj object)
62957726 1969{
1970 fprintf(stderr, "GC lossage. No scavenge function for object 0x%08x\n",
1971 (unsigned long) object);
1972 lose(NULL);
1973 return 0;
1974}
1975
1976static lispobj
1977trans_lose(lispobj object)
1978{
1979 fprintf(stderr, "GC lossage. No transport function for object 0x%08x\n",
1980 (unsigned long) object);
1981 lose(NULL);
1982 return NIL;
1983}
1984
1985static int
9a8c1c2f 1986size_lose(lispobj * where)
62957726 1987{
9a8c1c2f 1988 fprintf(stderr, "Size lossage. No size function for object at 0x%08x\n",
1989 (unsigned long) where);
1990 fprintf(stderr, "First word of object: 0x%08x\n", (unsigned long) *where);
1991 return 1;
62957726 1992}
1993
9a8c1c2f 1994void
1995gc_init(void)
62957726 1996{
9a8c1c2f 1997 int i;
62957726 1998
9a8c1c2f 1999 /* Scavenge Table */
2000 for (i = 0; i < 256; i++)
2001 scavtab[i] = scav_lose;
62957726 2002
9a8c1c2f 2003 for (i = 0; i < 32; i++) {
2004 scavtab[type_EvenFixnum | (i << 3)] = scav_immediate;
2005 scavtab[type_FunctionPointer | (i << 3)] = scav_function_pointer;
2006 /* OtherImmediate0 */
2007 scavtab[type_ListPointer | (i << 3)] = scav_list_pointer;
2008 scavtab[type_OddFixnum | (i << 3)] = scav_immediate;
2009 scavtab[type_InstancePointer | (i << 3)] = scav_instance_pointer;
2010 /* OtherImmediate1 */
2011 scavtab[type_OtherPointer | (i << 3)] = scav_other_pointer;
2012 }
62957726 2013
9a8c1c2f 2014 scavtab[type_Bignum] = scav_unboxed;
2015 scavtab[type_Ratio] = scav_boxed;
2016 scavtab[type_SingleFloat] = scav_unboxed;
2017 scavtab[type_DoubleFloat] = scav_unboxed;
8de15dca 2018#ifdef type_LongFloat
9a8c1c2f 2019 scavtab[type_LongFloat] = scav_unboxed;
8de15dca 2020#endif
cf3681ae 2021#ifdef type_DoubleDoubleFloat
2022 scavtab[type_DoubleDoubleFloat] = scav_unboxed;
2023#endif
9a8c1c2f 2024 scavtab[type_Complex] = scav_boxed;
4c3b1bb6 2025#ifdef type_ComplexSingleFloat
9a8c1c2f 2026 scavtab[type_ComplexSingleFloat] = scav_unboxed;
4c3b1bb6 2027#endif
2028#ifdef type_ComplexDoubleFloat
9a8c1c2f 2029 scavtab[type_ComplexDoubleFloat] = scav_unboxed;
4c3b1bb6 2030#endif
8de15dca 2031#ifdef type_ComplexLongFloat
9a8c1c2f 2032 scavtab[type_ComplexLongFloat] = scav_unboxed;
2033#endif
cf3681ae 2034#ifdef type_ComplexDoubleDoubleFloat
2035 scavtab[type_ComplexDoubleDoubleFloat] = scav_unboxed;
2036#endif
9a8c1c2f 2037 scavtab[type_SimpleArray] = scav_boxed;
2038 scavtab[type_SimpleString] = scav_string;
2039 scavtab[type_SimpleBitVector] = scav_vector_bit;
2040 scavtab[type_SimpleVector] = scav_vector;
2041 scavtab[type_SimpleArrayUnsignedByte2] = scav_vector_unsigned_byte_2;
2042 scavtab[type_SimpleArrayUnsignedByte4] = scav_vector_unsigned_byte_4;
2043 scavtab[type_SimpleArrayUnsignedByte8] = scav_vector_unsigned_byte_8;
2044 scavtab[type_SimpleArrayUnsignedByte16] = scav_vector_unsigned_byte_16;
2045 scavtab[type_SimpleArrayUnsignedByte32] = scav_vector_unsigned_byte_32;
d5d4504f 2046#ifdef type_SimpleArraySignedByte8
9a8c1c2f 2047 scavtab[type_SimpleArraySignedByte8] = scav_vector_unsigned_byte_8;
d5d4504f 2048#endif
2049#ifdef type_SimpleArraySignedByte16
9a8c1c2f 2050 scavtab[type_SimpleArraySignedByte16] = scav_vector_unsigned_byte_16;
d5d4504f 2051#endif
2052#ifdef type_SimpleArraySignedByte30
9a8c1c2f 2053 scavtab[type_SimpleArraySignedByte30] = scav_vector_unsigned_byte_32;
d5d4504f 2054#endif
2055#ifdef type_SimpleArraySignedByte32
9a8c1c2f 2056 scavtab[type_SimpleArraySignedByte32] = scav_vector_unsigned_byte_32;
d5d4504f 2057#endif
9a8c1c2f 2058 scavtab[type_SimpleArraySingleFloat] = scav_vector_single_float;
2059 scavtab[type_SimpleArrayDoubleFloat] = scav_vector_double_float;
8de15dca 2060#ifdef type_SimpleArrayLongFloat
9a8c1c2f 2061 scavtab[type_SimpleArrayLongFloat] = scav_vector_long_float;
8de15dca 2062#endif
cf3681ae 2063#ifdef type_SimpleArrayDoubleDoubleFloat
2064 scavtab[type_SimpleArrayDoubleDoubleFloat] = scav_vector_double_double_float;
2065#endif
4c3b1bb6 2066#ifdef type_SimpleArrayComplexSingleFloat
9a8c1c2f 2067 scavtab[type_SimpleArrayComplexSingleFloat] =
2068 scav_vector_complex_single_float;
4c3b1bb6 2069#endif
2070#ifdef type_SimpleArrayComplexDoubleFloat
9a8c1c2f 2071 scavtab[type_SimpleArrayComplexDoubleFloat] =
2072 scav_vector_complex_double_float;
4c3b1bb6 2073#endif
8de15dca 2074#ifdef type_SimpleArrayComplexLongFloat
9a8c1c2f 2075 scavtab[type_SimpleArrayComplexLongFloat] = scav_vector_complex_long_float;
2076#endif
cf3681ae 2077#ifdef type_SimpleArrayComplexDoubleDoubleFloat
2078 scavtab[type_SimpleArrayComplexDoubleDoubleFloat] =
2079 scav_vector_complex_double_double_float;
2080#endif
9a8c1c2f 2081 scavtab[type_ComplexString] = scav_boxed;
2082 scavtab[type_ComplexBitVector] = scav_boxed;
2083 scavtab[type_ComplexVector] = scav_boxed;
2084 scavtab[type_ComplexArray] = scav_boxed;
2085 scavtab[type_CodeHeader] = scav_code_header;
2086 scavtab[type_FunctionHeader] = scav_function_header;
2087 scavtab[type_ClosureFunctionHeader] = scav_function_header;
2088 scavtab[type_ReturnPcHeader] = scav_return_pc_header;
62957726 2089#ifdef i386
9a8c1c2f 2090 scavtab[type_ClosureHeader] = scav_closure_header;
2091 scavtab[type_FuncallableInstanceHeader] = scav_closure_header;
2092 scavtab[type_ByteCodeFunction] = scav_closure_header;
2093 scavtab[type_ByteCodeClosure] = scav_closure_header;
2094 scavtab[type_DylanFunctionHeader] = scav_closure_header;
62957726 2095#else
9a8c1c2f 2096 scavtab[type_ClosureHeader] = scav_boxed;
2097 scavtab[type_FuncallableInstanceHeader] = scav_boxed;
2098 scavtab[type_ByteCodeFunction] = scav_boxed;
2099 scavtab[type_ByteCodeClosure] = scav_boxed;
cf3681ae 2100#ifdef type_DylanFunctionHeader
9a8c1c2f 2101 scavtab[type_DylanFunctionHeader] = scav_boxed;
2102#endif
cf3681ae 2103#endif
9a8c1c2f 2104 scavtab[type_ValueCellHeader] = scav_boxed;
2105 scavtab[type_SymbolHeader] = scav_boxed;
2106 scavtab[type_BaseChar] = scav_immediate;
2107 scavtab[type_Sap] = scav_unboxed;
2108 scavtab[type_UnboundMarker] = scav_immediate;
2109 scavtab[type_WeakPointer] = scav_weak_pointer;
2110 scavtab[type_InstanceHeader] = scav_boxed;
903edb2a 2111#if !(defined(sparc) || defined(DARWIN))
9a8c1c2f 2112 scavtab[type_Fdefn] = scav_fdefn;
62957726 2113#else
9a8c1c2f 2114 scavtab[type_Fdefn] = scav_boxed;
62957726 2115#endif
2116
9a8c1c2f 2117 /* Transport Other Table */
2118 for (i = 0; i < 256; i++)
2119 transother[i] = trans_lose;
62957726 2120
9a8c1c2f 2121 transother[type_Bignum] = trans_unboxed;
2122 transother[type_Ratio] = trans_boxed;
2123 transother[type_SingleFloat] = trans_unboxed;
2124 transother[type_DoubleFloat] = trans_unboxed;
8de15dca 2125#ifdef type_LongFloat
9a8c1c2f 2126 transother[type_LongFloat] = trans_unboxed;
8de15dca 2127#endif
cf3681ae 2128#ifdef type_DoubleDoubleFloat
2129 transother[type_DoubleDoubleFloat] = trans_unboxed;
2130#endif
9a8c1c2f 2131 transother[type_Complex] = trans_boxed;
4c3b1bb6 2132#ifdef type_ComplexSingleFloat
9a8c1c2f 2133 transother[type_ComplexSingleFloat] = trans_unboxed;
4c3b1bb6 2134#endif
2135#ifdef type_ComplexDoubleFloat
9a8c1c2f 2136 transother[type_ComplexDoubleFloat] = trans_unboxed;
4c3b1bb6 2137#endif
8de15dca 2138#ifdef type_ComplexLongFloat
9a8c1c2f 2139 transother[type_ComplexLongFloat] = trans_unboxed;
2140#endif
cf3681ae 2141#ifdef type_ComplexDoubleDoubleFloat
2142 transother[type_ComplexDoubleDoubleFloat] = trans_unboxed;
2143#endif
9a8c1c2f 2144 transother[type_SimpleArray] = trans_boxed;
2145 transother[type_SimpleString] = trans_string;
2146 transother[type_SimpleBitVector] = trans_vector_bit;
2147 transother[type_SimpleVector] = trans_vector;
2148 transother[type_SimpleArrayUnsignedByte2] = trans_vector_unsigned_byte_2;
2149 transother[type_SimpleArrayUnsignedByte4] = trans_vector_unsigned_byte_4;
2150 transother[type_SimpleArrayUnsignedByte8] = trans_vector_unsigned_byte_8;
2151 transother[type_SimpleArrayUnsignedByte16] = trans_vector_unsigned_byte_16;
2152 transother[type_SimpleArrayUnsignedByte32] = trans_vector_unsigned_byte_32;
d5d4504f 2153#ifdef type_SimpleArraySignedByte8
9a8c1c2f 2154 transother[type_SimpleArraySignedByte8] = trans_vector_unsigned_byte_8;
d5d4504f 2155#endif
2156#ifdef type_SimpleArraySignedByte16
9a8c1c2f 2157 transother[type_SimpleArraySignedByte16] = trans_vector_unsigned_byte_16;
d5d4504f 2158#endif
2159#ifdef type_SimpleArraySignedByte30
9a8c1c2f 2160 transother[type_SimpleArraySignedByte30] = trans_vector_unsigned_byte_32;
d5d4504f 2161#endif
2162#ifdef type_SimpleArraySignedByte32
9a8c1c2f 2163 transother[type_SimpleArraySignedByte32] = trans_vector_unsigned_byte_32;
d5d4504f 2164#endif
9a8c1c2f 2165 transother[type_SimpleArraySingleFloat] = trans_vector_single_float;
2166 transother[type_SimpleArrayDoubleFloat] = trans_vector_double_float;
8de15dca 2167#ifdef type_SimpleArrayLongFloat
9a8c1c2f 2168 transother[type_SimpleArrayLongFloat] = trans_vector_long_float;
8de15dca 2169#endif
cf3681ae 2170#ifdef type_SimpleArrayDoubleDoubleFloat
2171 transother[type_SimpleArrayDoubleDoubleFloat] = trans_vector_double_double_float;
2172#endif
4c3b1bb6 2173#ifdef type_SimpleArrayComplexSingleFloat
9a8c1c2f 2174 transother[type_SimpleArrayComplexSingleFloat] =
2175 trans_vector_complex_single_float;
4c3b1bb6 2176#endif
2177#ifdef type_SimpleArrayComplexDoubleFloat
9a8c1c2f 2178 transother[type_SimpleArrayComplexDoubleFloat] =
2179 trans_vector_complex_double_float;
4c3b1bb6 2180#endif
8de15dca 2181#ifdef type_SimpleArrayComplexLongFloat
9a8c1c2f 2182 transother[type_SimpleArrayComplexLongFloat] =
2183 trans_vector_complex_long_float;
2184#endif
cf3681ae 2185#ifdef type_SimpleArrayComplexDoubleDoubleFloat
2186 transother[type_SimpleArrayComplexDoubleDoubleFloat] =
2187 trans_vector_complex_double_double_float;
2188#endif
9a8c1c2f 2189 transother[type_ComplexString] = trans_boxed;
2190 transother[type_ComplexBitVector] = trans_boxed;
2191 transother[type_ComplexVector] = trans_boxed;
2192 transother[type_ComplexArray] = trans_boxed;
2193 transother[type_CodeHeader] = trans_code_header;
2194 transother[type_FunctionHeader] = trans_function_header;
2195 transother[type_ClosureFunctionHeader] = trans_function_header;
2196 transother[type_ReturnPcHeader] = trans_return_pc_header;
2197 transother[type_ClosureHeader] = trans_boxed;
2198 transother[type_FuncallableInstanceHeader] = trans_boxed;
2199 transother[type_ByteCodeFunction] = trans_boxed;
2200 transother[type_ByteCodeClosure] = trans_boxed;
2201 transother[type_ValueCellHeader] = trans_boxed;
2202 transother[type_SymbolHeader] = trans_boxed;
2203 transother[type_BaseChar] = trans_immediate;
2204 transother[type_Sap] = trans_unboxed;
2205 transother[type_UnboundMarker] = trans_immediate;
2206 transother[type_WeakPointer] = trans_weak_pointer;
2207 transother[type_InstanceHeader] = trans_boxed;
2208 transother[type_Fdefn] = trans_boxed;
2209
2210 /* Size table */
2211
2212 for (i = 0; i < 256; i++)
2213 sizetab[i] = size_lose;
2214
2215 for (i = 0; i < 32; i++) {
2216 sizetab[type_EvenFixnum | (i << 3)] = size_immediate;
2217 sizetab[type_FunctionPointer | (i << 3)] = size_pointer;
2218 /* OtherImmediate0 */
2219 sizetab[type_ListPointer | (i << 3)] = size_pointer;
2220 sizetab[type_OddFixnum | (i << 3)] = size_immediate;
2221 sizetab[type_InstancePointer | (i << 3)] = size_pointer;
2222 /* OtherImmediate1 */
2223 sizetab[type_OtherPointer | (i << 3)] = size_pointer;
2224 }
62957726 2225
9a8c1c2f 2226 sizetab[type_Bignum] = size_unboxed;
2227 sizetab[type_Ratio] = size_boxed;
2228 sizetab[type_SingleFloat] = size_unboxed;
2229 sizetab[type_DoubleFloat] = size_unboxed;
8de15dca 2230#ifdef type_LongFloat
9a8c1c2f 2231 sizetab[type_LongFloat] = size_unboxed;
8de15dca 2232#endif
cf3681ae 2233#ifdef type_DoubleDoubleFloat
2234 sizetab[type_DoubleDoubleFloat] = size_unboxed;
2235#endif
9a8c1c2f 2236 sizetab[type_Complex] = size_boxed;
4c3b1bb6 2237#ifdef type_ComplexSingleFloat
9a8c1c2f 2238 sizetab[type_ComplexSingleFloat] = size_unboxed;
4c3b1bb6 2239#endif
2240#ifdef type_ComplexDoubleFloat
9a8c1c2f 2241 sizetab[type_ComplexDoubleFloat] = size_unboxed;
4c3b1bb6 2242#endif
8de15dca 2243#ifdef type_ComplexLongFloat
9a8c1c2f 2244 sizetab[type_ComplexLongFloat] = size_unboxed;
2245#endif
cf3681ae 2246#ifdef type_ComplexDoubleDoubleFloat
2247 sizetab[type_ComplexDoubleDoubleFloat] = size_unboxed;
2248#endif
9a8c1c2f 2249 sizetab[type_SimpleArray] = size_boxed;
2250 sizetab[type_SimpleString] = size_string;
2251 sizetab[type_SimpleBitVector] = size_vector_bit;
2252 sizetab[type_SimpleVector] = size_vector;
2253 sizetab[type_SimpleArrayUnsignedByte2] = size_vector_unsigned_byte_2;
2254 sizetab[type_SimpleArrayUnsignedByte4] = size_vector_unsigned_byte_4;
2255 sizetab[type_SimpleArrayUnsignedByte8] = size_vector_unsigned_byte_8;
2256 sizetab[type_SimpleArrayUnsignedByte16] = size_vector_unsigned_byte_16;
2257 sizetab[type_SimpleArrayUnsignedByte32] = size_vector_unsigned_byte_32;
d5d4504f 2258#ifdef type_SimpleArraySignedByte8
9a8c1c2f 2259 sizetab[type_SimpleArraySignedByte8] = size_vector_unsigned_byte_8;
d5d4504f 2260#endif
2261#ifdef type_SimpleArraySignedByte16
9a8c1c2f 2262 sizetab[type_SimpleArraySignedByte16] = size_vector_unsigned_byte_16;
d5d4504f 2263#endif
2264#ifdef type_SimpleArraySignedByte30
9a8c1c2f 2265 sizetab[type_SimpleArraySignedByte30] = size_vector_unsigned_byte_32;
d5d4504f 2266#endif
2267#ifdef type_SimpleArraySignedByte32
9a8c1c2f 2268 sizetab[type_SimpleArraySignedByte32] = size_vector_unsigned_byte_32;
d5d4504f 2269#endif
9a8c1c2f 2270 sizetab[type_SimpleArraySingleFloat] = size_vector_single_float;
2271 sizetab[type_SimpleArrayDoubleFloat] = size_vector_double_float;
8de15dca 2272#ifdef type_SimpleArrayLongFloat
9a8c1c2f 2273 sizetab[type_SimpleArrayLongFloat] = size_vector_long_float;
8de15dca 2274#endif
cf3681ae 2275#ifdef type_SimpleArrayDoubleDoubleFloat
2276 sizetab[type_SimpleArrayDoubleDoubleFloat] = size_vector_double_double_float;
2277#endif
4c3b1bb6 2278#ifdef type_SimpleArrayComplexSingleFloat
9a8c1c2f 2279 sizetab[type_SimpleArrayComplexSingleFloat] =
2280 size_vector_complex_single_float;
4c3b1bb6 2281#endif
2282#ifdef type_SimpleArrayComplexDoubleFloat
9a8c1c2f 2283 sizetab[type_SimpleArrayComplexDoubleFloat] =
2284 size_vector_complex_double_float;
4c3b1bb6 2285#endif
8de15dca 2286#ifdef type_SimpleArrayComplexLongFloat
9a8c1c2f 2287 sizetab[type_SimpleArrayComplexLongFloat] = size_vector_complex_long_float;
8de15dca 2288#endif
cf3681ae 2289#ifdef type_SimpleArrayComplexDoubleDoubleFloat
2290 sizetab[type_SimpleArrayComplexDoubleDoubleFloat] =
2291 size_vector_complex_double_double_float;
2292#endif
9a8c1c2f 2293 sizetab[type_ComplexString] = size_boxed;
2294 sizetab[type_ComplexBitVector] = size_boxed;
2295 sizetab[type_ComplexVector] = size_boxed;
2296 sizetab[type_ComplexArray] = size_boxed;
2297 sizetab[type_CodeHeader] = size_code_header;
62957726 2298#if 0
9a8c1c2f 2299 /* Shouldn't see these so just lose if it happens */
2300 sizetab[type_FunctionHeader] = size_function_header;
2301 sizetab[type_ClosureFunctionHeader] = size_function_header;
2302 sizetab[type_ReturnPcHeader] = size_return_pc_header;
2303#endif
2304 sizetab[type_ClosureHeader] = size_boxed;
2305 sizetab[type_FuncallableInstanceHeader] = size_boxed;
2306 sizetab[type_ValueCellHeader] = size_boxed;
2307 sizetab[type_SymbolHeader] = size_boxed;
2308 sizetab[type_BaseChar] = size_immediate;
2309 sizetab[type_Sap] = size_unboxed;
2310 sizetab[type_UnboundMarker] = size_immediate;
2311 sizetab[type_WeakPointer] = size_weak_pointer;
2312 sizetab[type_InstanceHeader] = size_boxed;
2313 sizetab[type_Fdefn] = size_boxed;
62957726 2314}
9a8c1c2f 2315\f
62957726 2316
2317
62957726 2318/* Noise to manipulate the gc trigger stuff. */
2319
2320#ifndef ibmrt
2321
9a8c1c2f 2322void
2323set_auto_gc_trigger(os_vm_size_t dynamic_usage)
62957726 2324{
9a8c1c2f 2325 os_vm_address_t addr = (os_vm_address_t) current_dynamic_space +
2326
62957726 2327 dynamic_usage;
2328 long length =
62957726 2329
9a8c1c2f 2330 dynamic_space_size + (os_vm_address_t) current_dynamic_space - addr;
2331
2332 if (addr < (os_vm_address_t) current_dynamic_space_free_pointer) {
62957726 2333 fprintf(stderr,
9a8c1c2f 2334 "set_auto_gc_trigger: tried to set gc trigger too low! (%d < %d)\n",
62957726 2335 dynamic_usage,
9a8c1c2f 2336 (os_vm_address_t) current_dynamic_space_free_pointer
2337 - (os_vm_address_t) current_dynamic_space);
62957726 2338 return;
9a8c1c2f 2339 } else if (length < 0) {
62957726 2340 fprintf(stderr,
2341 "set_auto_gc_trigger: tried to set gc trigger too high! (%d)\n",
2342 dynamic_usage);
2343 return;
2344 }
2345
9a8c1c2f 2346 addr = os_round_up_to_page(addr);
2347 length = os_trunc_size_to_page(length);
62957726 2348
eb3d28bd 2349#if defined(SUNOS) || defined(SOLARIS)
9a8c1c2f 2350 os_invalidate(addr, length);
62957726 2351#else
2352 os_protect(addr, length, 0);
2353#endif
2354
34b793ce 2355 current_auto_gc_trigger = (lispobj *) addr;
2356
2357#ifdef PRINTNOISE
9a8c1c2f 2358 fprintf(stderr, "current_auto_gc_trigger set to %p\n",
2359 current_auto_gc_trigger);
34b793ce 2360#endif
2361
62957726 2362}
2363
9a8c1c2f 2364void
2365clear_auto_gc_trigger(void)
62957726 2366{
9a8c1c2f 2367 if (current_auto_gc_trigger != NULL) {
2368#if defined(SUNOS) || defined(SOLARIS) /* don't want to force whole space into swapping mode... */
2369 os_vm_address_t addr = (os_vm_address_t) current_auto_gc_trigger;
2370 os_vm_size_t length =
2371 dynamic_space_size + (os_vm_address_t) current_dynamic_space - addr;
62957726 2372
9a8c1c2f 2373 os_validate(addr, length);
62957726 2374#else
9a8c1c2f 2375 os_protect((os_vm_address_t) current_dynamic_space,
2376 dynamic_space_size, OS_VM_PROT_ALL);
62957726 2377#endif
2378
2379 current_auto_gc_trigger = NULL;
2380 }
2381}
2382
2383#endif