/[cmucl]/src/lisp/gc.c
ViewVC logotype

Contents of /src/lisp/gc.c

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5