Newer
Older
* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/gc.c,v 1.8 1994/07/05 16:07:20 hallgren Exp $
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
*
* Written by Christopher Hoover.
*/
#include <stdio.h>
#include <sys/time.h>
#include <sys/resource.h>
#include <signal.h>
#include "lisp.h"
#include "internals.h"
#include "os.h"
#include "gc.h"
#include "globals.h"
#include "interrupt.h"
#include "validate.h"
#include "lispregs.h"
#include "interr.h"
static lispobj *from_space;
static lispobj *from_space_free_pointer;
static lispobj *new_space;
static lispobj *new_space_free_pointer;
static int (*scavtab[256])(lispobj *where, lispobj object);
static lispobj (*transother[256])(lispobj object);
static int (*sizetab[256])(lispobj *where);
static struct weak_pointer *weak_pointers;
static void scavenge(lispobj *start, long nwords);
static void scavenge_newspace(void);
static void scavenge_interrupt_contexts(void);
static void scan_weak_pointers(void);
#define gc_abort() lose("GC invariant lost! File \"%s\", line %d\n", \
__FILE__, __LINE__)
#if 0
#define gc_assert(ex) do { \
if (!(ex)) gc_abort(); \
} while (0)
#else
#define gc_assert(ex)
#endif
#define CEILING(x,y) (((x) + ((y) - 1)) & (~((y) - 1)))
/* Predicates */
#if defined(DEBUG_SPACE_PREDICATES)
boolean from_space_p(lispobj object)
{
lispobj *ptr;
gc_assert(Pointerp(object));
ptr = (lispobj *) PTR(object);
return ((from_space <= ptr) &&
(ptr < from_space_free_pointer));
}
boolean new_space_p(lispobj object)
{
lispobj *ptr;
gc_assert(Pointerp(object));
ptr = (lispobj *) PTR(object);
return ((new_space <= ptr) &&
(ptr < new_space_free_pointer));
}
#else
#define from_space_p(ptr) \
((from_space <= ((lispobj *) ptr)) && \
(((lispobj *) ptr) < from_space_free_pointer))
#define new_space_p(ptr) \
((new_space <= ((lispobj *) ptr)) && \
(((lispobj *) ptr) < new_space_free_pointer))
#endif
/* Copying Objects */
static lispobj
copy_object(lispobj object, int nwords)
{
int tag;
lispobj *new;
lispobj *source, *dest;
gc_assert(Pointerp(object));
gc_assert(from_space_p(object));
gc_assert((nwords & 0x01) == 0);
/* get tag of object */
tag = LowtagOf(object);
/* allocate space */
new = new_space_free_pointer;
new_space_free_pointer += nwords;
dest = new;
source = (lispobj *) PTR(object);
/* copy the object */
while (nwords > 0) {
dest[0] = source[0];
dest[1] = source[1];
dest += 2;
source += 2;
nwords -= 2;
}
/* return lisp pointer of new object */
return ((lispobj) new) | tag;
}
/* Collect Garbage */
#ifdef PRINTNOISE
static double tv_diff(struct timeval *x, struct timeval *y)
{
return (((double) x->tv_sec + (double) x->tv_usec * 1.0e-6) -
((double) y->tv_sec + (double) y->tv_usec * 1.0e-6));
}
#endif
#define BYTES_ZERO_BEFORE_END (1<<12)
static void zero_stack(void)
{
unsigned long *ptr = (unsigned long *)current_control_stack_pointer;
#else
u32 *ptr = (u32 *)current_control_stack_pointer;
#endif
#else
} while (((u32)ptr) & (BYTES_ZERO_BEFORE_END-1));
#endif
#else
} while (((u32)ptr) & (BYTES_ZERO_BEFORE_END-1));
#endif
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
goto search;
}
void collect_garbage(void)
{
#ifdef PRINTNOISE
struct timeval start_tv, stop_tv;
struct rusage start_rusage, stop_rusage;
double real_time, system_time, user_time;
double percent_retained, gc_rate;
unsigned long size_discarded;
unsigned long size_retained;
#endif
lispobj *current_static_space_free_pointer;
unsigned long static_space_size;
unsigned long control_stack_size, binding_stack_size;
int oldmask;
#ifdef PRINTNOISE
printf("[Collecting garbage ... \n");
getrusage(RUSAGE_SELF, &start_rusage);
gettimeofday(&start_tv, (struct timezone *) 0);
#endif
oldmask = sigblock(BLOCKABLE);
current_static_space_free_pointer =
(lispobj *) SymbolValue(STATIC_SPACE_FREE_POINTER);
/* Set up from space and new space pointers. */
from_space = current_dynamic_space;
#ifndef ibmrt
from_space_free_pointer = current_dynamic_space_free_pointer;
#else
from_space_free_pointer = (lispobj *)SymbolValue(ALLOCATION_POINTER);
#endif
if (current_dynamic_space == dynamic_0_space)
new_space = dynamic_1_space;
else if (current_dynamic_space == dynamic_1_space)
new_space = dynamic_0_space;
else
lose("GC lossage. Current dynamic space is bogus!\n");
new_space_free_pointer = new_space;
/* Initialize the weak pointer list. */
weak_pointers = (struct weak_pointer *) NULL;
/* Scavenge all of the roots. */
#ifdef PRINTNOISE
printf("Scavenging interrupt contexts ...\n");
#endif
scavenge_interrupt_contexts();
#ifdef PRINTNOISE
printf("Scavenging interrupt handlers (%d bytes) ...\n",
sizeof(interrupt_handlers));
#endif
scavenge((lispobj *) interrupt_handlers,
sizeof(interrupt_handlers) / sizeof(lispobj));
control_stack_size = current_control_stack_pointer - control_stack;
#ifdef PRINTNOISE
printf("Scavenging the control stack (%d bytes) ...\n",
control_stack_size * sizeof(lispobj));
#endif
scavenge(control_stack, control_stack_size);
#ifndef ibmrt
binding_stack_size = current_binding_stack_pointer - binding_stack;
#else
binding_stack_size =
(lispobj *)SymbolValue(BINDING_STACK_POINTER) - binding_stack;
#endif
#ifdef PRINTNOISE
printf("Scavenging the binding stack (%d bytes) ...\n",
binding_stack_size * sizeof(lispobj));
#endif
scavenge(binding_stack, binding_stack_size);
static_space_size = current_static_space_free_pointer - static_space;
#ifdef PRINTNOISE
printf("Scavenging static space (%d bytes) ...\n",
static_space_size * sizeof(lispobj));
#endif
scavenge(static_space, static_space_size);
/* Scavenge newspace. */
#ifdef PRINTNOISE
printf("Scavenging new space (%d bytes) ...\n",
(new_space_free_pointer - new_space) * sizeof(lispobj));
#endif
scavenge_newspace();
#if defined(DEBUG_PRINT_GARBAGE)
print_garbage(from_space, from_space_free_pointer);
#endif
/* Scan the weak pointers. */
#ifdef PRINTNOISE
printf("Scanning weak pointers ...\n");
#endif
scan_weak_pointers();
/* Flip spaces. */
#ifdef PRINTNOISE
printf("Flipping spaces ...\n");
#endif
os_zero((os_vm_address_t) current_dynamic_space,
(os_vm_size_t) DYNAMIC_SPACE_SIZE);
current_dynamic_space = new_space;
#ifndef ibmrt
current_dynamic_space_free_pointer = new_space_free_pointer;
#else
SetSymbolValue(ALLOCATION_POINTER, (lispobj)new_space_free_pointer);
#endif
#ifdef PRINTNOISE
size_discarded = (from_space_free_pointer - from_space) * sizeof(lispobj);
size_retained = (new_space_free_pointer - new_space) * sizeof(lispobj);
#endif
/* Zero stack. */
#ifdef PRINTNOISE
printf("Zeroing empty part of control stack ...\n");
#endif
zero_stack();
(void) sigsetmask(oldmask);
#ifdef PRINTNOISE
gettimeofday(&stop_tv, (struct timezone *) 0);
getrusage(RUSAGE_SELF, &stop_rusage);
printf("done.]\n");
percent_retained = (((float) size_retained) /
((float) size_discarded)) * 100.0;
printf("Total of %d bytes out of %d bytes retained (%3.2f%%).\n",
size_retained, size_discarded, percent_retained);
real_time = tv_diff(&stop_tv, &start_tv);
user_time = tv_diff(&stop_rusage.ru_utime, &start_rusage.ru_utime);
system_time = tv_diff(&stop_rusage.ru_stime, &start_rusage.ru_stime);
#if 0
printf("Statistics:\n");
printf("%10.2f sec of real time\n", real_time);
printf("%10.2f sec of user time,\n", user_time);
printf("%10.2f sec of system time.\n", system_time);
#else
printf("Statistics: %10.2fs real, %10.2fs user, %10.2fs system.\n",
real_time, user_time, system_time);
#endif
gc_rate = ((float) size_retained / (float) (1<<20)) / real_time;
printf("%10.2f M bytes/sec collected.\n", gc_rate);
#endif
}
/* Scavenging */
static void
scavenge(lispobj *start, long nwords)
{
while (nwords > 0) {
lispobj object;
int type, words_scavenged;
object = *start;
type = TypeOf(object);
#if defined(DEBUG_SCAVENGE_VERBOSE)
printf("Scavenging object at 0x%08x, object = 0x%08x, type = %d\n",
(unsigned long) start, (unsigned long) object, type);
#endif
#if 0
words_scavenged = (scavtab[type])(start, object);
#else
if (Pointerp(object)) {
/* It be a pointer. */
if (from_space_p(object)) {
/* It currently points to old space. Check for a */
/* forwarding pointer. */
lispobj first_word;
first_word = *((lispobj *)PTR(object));
if (Pointerp(first_word) && new_space_p(first_word)) {
/* Yep, there be a forwarding pointer. */
*start = first_word;
words_scavenged = 1;
}
else {
/* Scavenge that pointer. */
words_scavenged = (scavtab[type])(start, object);
}
}
else {
/* It points somewhere other than oldspace. Leave */
/* it alone. */
words_scavenged = 1;
}
}
else if ((object & 3) == 0) {
/* It's a fixnum. Real easy. */
words_scavenged = 1;
}
else {
/* It's some random header object. */
words_scavenged = (scavtab[type])(start, object);
}
#endif
start += words_scavenged;
nwords -= words_scavenged;
}
gc_assert(nwords == 0);
}
static void scavenge_newspace(void)
{
lispobj *here, *next;
here = new_space;
while (here < new_space_free_pointer) {
next = new_space_free_pointer;
scavenge(here, next - here);
here = next;
}
}
/* Scavenging Interrupt Contexts */
static int boxed_registers[] = BOXED_REGISTERS;
static void scavenge_interrupt_context(struct sigcontext *context)
{
int i;
#ifdef reg_LIP
unsigned long lip;
unsigned long lip_offset;
int lip_register_pair;
#endif
#ifdef SC_NPC
unsigned long npc_code_offset;
#endif
/* Find the LIP's register pair and calculate it's offset */
/* before we scavenge the context. */
#ifdef reg_LIP
lip = SC_REG(context, reg_LIP);
lip_offset = 0x7FFFFFFF;
lip_register_pair = -1;
for (i = 0; i < (sizeof(boxed_registers) / sizeof(int)); i++) {
unsigned long reg;
long offset;
int index;
index = boxed_registers[i];
reg = SC_REG(context, index);
if (PTR(reg) <= lip) {
offset = lip - reg;
if (offset < lip_offset) {
lip_offset = offset;
lip_register_pair = index;
}
}
}
#endif reg_LIP
/* Compute the PC's offset from the start of the CODE */
/* register. */
pc_code_offset = SC_PC(context) - SC_REG(context, reg_CODE);
#ifdef SC_NPC
npc_code_offset = SC_NPC(context) - SC_REG(context, reg_CODE);
#endif SC_NPC
/* Scanvenge all boxed registers in the context. */
for (i = 0; i < (sizeof(boxed_registers) / sizeof(int)); i++) {
int index;
foo = SC_REG(context,index);
scavenge((lispobj *) &foo, 1);
SC_REG(context,index) = foo;
scavenge((lispobj *) &(SC_REG(context, index)), 1);
}
#ifdef reg_LIP
/* Fix the LIP */
SC_REG(context, reg_LIP) =
SC_REG(context, lip_register_pair) + lip_offset;
#endif reg_LIP
/* Fix the PC if it was in from space */
if (from_space_p(SC_PC(context)))
SC_PC(context) = SC_REG(context, reg_CODE) + pc_code_offset;
#ifdef SC_NPC
if (from_space_p(SC_NPC(context)))
SC_NPC(context) = SC_REG(context, reg_CODE) + npc_code_offset;
#endif SC_NPC
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
}
void scavenge_interrupt_contexts(void)
{
int i, index;
struct sigcontext *context;
index = fixnum_value(SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX));
#if defined(DEBUG_PRINT_CONTEXT_INDEX)
printf("Number of active contexts: %d\n", index);
#endif
for (i = 0; i < index; i++) {
context = lisp_interrupt_contexts[i];
scavenge_interrupt_context(context);
}
}
/* Debugging Code */
void print_garbage(lispobj *from_space, lispobj *from_space_free_pointer)
{
lispobj *start;
int total_words_not_copied;
printf("Scanning from space ...\n");
total_words_not_copied = 0;
start = from_space;
while (start < from_space_free_pointer) {
lispobj object;
int forwardp, type, nwords;
lispobj header;
object = *start;
forwardp = Pointerp(object) && new_space_p(object);
if (forwardp) {
int tag;
lispobj *pointer;
tag = LowtagOf(object);
switch (tag) {
case type_ListPointer:
nwords = 2;
break;
case type_InstancePointer:
printf("Don't know about instances yet!\n");
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
nwords = 1;
break;
case type_FunctionPointer:
nwords = 1;
break;
case type_OtherPointer:
pointer = (lispobj *) PTR(object);
header = *pointer;
type = TypeOf(header);
nwords = (sizetab[type])(pointer);
}
} else {
type = TypeOf(object);
nwords = (sizetab[type])(start);
total_words_not_copied += nwords;
printf("%4d words not copied at 0x%08x; ",
nwords, (unsigned long) start);
printf("Header word is 0x%08x\n", (unsigned long) object);
}
start += nwords;
}
printf("%d total words not copied.\n", total_words_not_copied);
}
/* Code and Code-Related Objects */
#define RAW_ADDR_OFFSET (6*sizeof(lispobj) - type_FunctionPointer)
static lispobj trans_function_header(lispobj object);
static lispobj trans_boxed(lispobj object);
static int
scav_function_pointer(lispobj *where, lispobj object)
{
gc_assert(Pointerp(object));
if (from_space_p(object)) {
lispobj first, *first_pointer;
/* object is a pointer into from space. check to see */
/* if it has been forwarded */
first_pointer = (lispobj *) PTR(object);
first = *first_pointer;
if (!(Pointerp(first) && new_space_p(first))) {
int type;
lispobj copy;
/* must transport object -- object may point */
/* to either a function header, a closure */
/* function header, or to a closure header. */
type = TypeOf(first);
switch (type) {
case type_FunctionHeader:
case type_ClosureFunctionHeader:
copy = trans_function_header(object);
break;
default:
copy = trans_boxed(object);
break;
}
first = *first_pointer = copy;
}
gc_assert(Pointerp(first));
gc_assert(!from_space_p(first));
*where = first;
}
return 1;
}
static struct code *
trans_code(struct code *code)
{
struct code *new_code;
lispobj first, l_code, l_new_code;
int nheader_words, ncode_words, nwords;
unsigned long displacement;
lispobj fheaderl, *prev_pointer;
#if defined(DEBUG_CODE_GC)
printf("\nTransporting code object located at 0x%08x.\n",
(unsigned long) code);
#endif
/* if object has already been transported, just return pointer */
first = code->header;
if (Pointerp(first) && new_space_p(first))
return (struct code *) PTR(first);
gc_assert(TypeOf(first) == type_CodeHeader);
/* prepare to transport the code vector */
l_code = (lispobj) code | type_OtherPointer;
ncode_words = fixnum_value(code->code_size);
nheader_words = HeaderValue(code->header);
nwords = ncode_words + nheader_words;
nwords = CEILING(nwords, 2);
l_new_code = copy_object(l_code, nwords);
new_code = (struct code *) PTR(l_new_code);
displacement = l_new_code - l_code;
#if defined(DEBUG_CODE_GC)
printf("Old code object at 0x%08x, new code object at 0x%08x.\n",
(unsigned long) code, (unsigned long) new_code);
printf("Code object is %d words long.\n", nwords);
#endif
/* set forwarding pointer */
code->header = l_new_code;
/* set forwarding pointers for all the function headers in the */
/* code object. also fix all self pointers */
fheaderl = code->entry_points;
prev_pointer = &new_code->entry_points;
while (fheaderl != NIL) {
struct function *fheaderp, *nfheaderp;
fheaderp = (struct function *) PTR(fheaderl);
gc_assert(TypeOf(fheaderp->header) == type_FunctionHeader);
/* calcuate the new function pointer and the new */
/* function header */
nfheaderl = fheaderl + displacement;
nfheaderp = (struct function *) PTR(nfheaderl);
/* set forwarding pointer */
fheaderp->header = nfheaderl;
/* fix self pointer */
nfheaderp->self = nfheaderl;
*prev_pointer = nfheaderl;
fheaderl = fheaderp->next;
prev_pointer = &nfheaderp->next;
}
os_flush_icache((os_vm_address_t) (((int *)new_code) + nheader_words),
ncode_words * sizeof(int));
#endif
return new_code;
}
static int
scav_code_header(lispobj *where, lispobj object)
{
struct code *code;
int nheader_words, ncode_words, nwords;
lispobj fheaderl;
code = (struct code *) where;
ncode_words = fixnum_value(code->code_size);
nheader_words = HeaderValue(object);
nwords = ncode_words + nheader_words;
nwords = CEILING(nwords, 2);
#if defined(DEBUG_CODE_GC)
printf("\nScavening code object at 0x%08x.\n",
(unsigned long) where);
printf("Code object is %d words long.\n", nwords);
printf("Scavenging boxed section of code data block (%d words).\n",
nheader_words - 1);
#endif
/* Scavenge the boxed section of the code data block */
scavenge(where + 1, nheader_words - 1);
/* Scavenge the boxed section of each function object in the */
/* code data block */
fheaderl = code->entry_points;
while (fheaderl != NIL) {
fheaderp = (struct function *) PTR(fheaderl);
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
gc_assert(TypeOf(fheaderp->header) == type_FunctionHeader);
#if defined(DEBUG_CODE_GC)
printf("Scavenging boxed section of entry point located at 0x%08x.\n",
(unsigned long) PTR(fheaderl));
#endif
scavenge(&fheaderp->name, 1);
scavenge(&fheaderp->arglist, 1);
scavenge(&fheaderp->type, 1);
fheaderl = fheaderp->next;
}
return nwords;
}
static lispobj
trans_code_header(lispobj object)
{
struct code *ncode;
ncode = trans_code((struct code *) PTR(object));
return (lispobj) ncode | type_OtherPointer;
}
static int
size_code_header(lispobj *where)
{
struct code *code;
int nheader_words, ncode_words, nwords;
code = (struct code *) where;
ncode_words = fixnum_value(code->code_size);
nheader_words = HeaderValue(code->header);
nwords = ncode_words + nheader_words;
nwords = CEILING(nwords, 2);
return nwords;
}
static int
scav_return_pc_header(lispobj *where, lispobj object)
{
fprintf(stderr, "GC lossage. Should not be scavenging a ");
fprintf(stderr, "Return PC Header.\n");
fprintf(stderr, "where = 0x%08x, object = 0x%08x",
(unsigned long) where, (unsigned long) object);
lose(NULL);
return 0;
}
static lispobj
trans_return_pc_header(lispobj object)
{
return_pc = (struct function *) PTR(object);
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
offset = HeaderValue(return_pc->header) * 4;
/* Transport the whole code object */
code = (struct code *) ((unsigned long) return_pc - offset);
ncode = trans_code(code);
return ((lispobj) ncode + offset) | type_OtherPointer;
}
/* On the 386, closures hold a pointer to the raw address instead of the
function object, so we can use CALL [$FDEFN+const] to invoke the function
without loading it into a register. Given that code objects don't move,
we don't need to update anything, but we do have to figure out that the
function is still live. */
#ifdef i386
static
scav_closure_header(where, object)
lispobj *where, object;
{
struct closure *closure;
lispobj fun;
closure = (struct closure *)where;
fun = closure->function - RAW_ADDR_OFFSET;
scavenge(&fun, 1);
return 2;
}
#endif
static int
scav_function_header(lispobj *where, lispobj object)
{
fprintf(stderr, "GC lossage. Should not be scavenging a ");
fprintf(stderr, "Function Header.\n");
fprintf(stderr, "where = 0x%08x, object = 0x%08x",
(unsigned long) where, (unsigned long) object);
lose(NULL);
return 0;
}
static lispobj
trans_function_header(lispobj object)
{
fheader = (struct function *) PTR(object);
offset = HeaderValue(fheader->header) * 4;
/* Transport the whole code object */
code = (struct code *) ((unsigned long) fheader - offset);
ncode = trans_code(code);
return ((lispobj) ncode + offset) | type_FunctionPointer;
}
scav_instance_pointer(lispobj *where, lispobj object)
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
{
if (from_space_p(object)) {
lispobj first, *first_pointer;
/* object is a pointer into from space. check to see */
/* if it has been forwarded */
first_pointer = (lispobj *) PTR(object);
first = *first_pointer;
if (!(Pointerp(first) && new_space_p(first)))
first = *first_pointer = trans_boxed(object);
*where = first;
}
return 1;
}
/* Lists and Conses */
static lispobj trans_list(lispobj object);
static int
scav_list_pointer(lispobj *where, lispobj object)
{
gc_assert(Pointerp(object));
if (from_space_p(object)) {
lispobj first, *first_pointer;
/* object is a pointer into from space. check to see */
/* if it has been forwarded */
first_pointer = (lispobj *) PTR(object);
first = *first_pointer;
if (!(Pointerp(first) && new_space_p(first)))
first = *first_pointer = trans_list(object);
gc_assert(Pointerp(first));
gc_assert(!from_space_p(first));
*where = first;
}
return 1;
}
static lispobj
trans_list(lispobj object)
{
lispobj new_list_pointer;
struct cons *cons, *new_cons;
cons = (struct cons *) PTR(object);
/* ### Don't use copy_object here. */
new_list_pointer = copy_object(object, 2);
new_cons = (struct cons *) PTR(new_list_pointer);
/* Set forwarding pointer. */
cons->car = new_list_pointer;
/* Try to linearize the list in the cdr direction to help reduce */
/* paging. */
while (1) {
lispobj cdr, new_cdr, first;
struct cons *cdr_cons, *new_cdr_cons;
cdr = cons->cdr;
if (LowtagOf(cdr) != type_ListPointer ||
!from_space_p(cdr) ||
(Pointerp(first = *(lispobj *)PTR(cdr)) &&
new_space_p(first)))
break;
cdr_cons = (struct cons *) PTR(cdr);
/* ### Don't use copy_object here */
new_cdr = copy_object(cdr, 2);
new_cdr_cons = (struct cons *) PTR(new_cdr);
/* Set forwarding pointer */
cdr_cons->car = new_cdr;
/* Update the cdr of the last cons copied into new */
/* space to keep the newspace scavenge from having to */
/* do it. */
new_cons->cdr = new_cdr;
cons = cdr_cons;
new_cons = new_cdr_cons;
}
return new_list_pointer;
}
/* Scavenging and Transporting Other Pointers */
static int
scav_other_pointer(lispobj *where, lispobj object)
{
gc_assert(Pointerp(object));
if (from_space_p(object)) {
lispobj first, *first_pointer;
/* object is a pointer into from space. check to see */
/* if it has been forwarded */
first_pointer = (lispobj *) PTR(object);
first = *first_pointer;
if (!(Pointerp(first) && new_space_p(first)))
first = *first_pointer =
(transother[TypeOf(first)])(object);
gc_assert(Pointerp(first));
gc_assert(!from_space_p(first));
*where = first;
}
return 1;
}
/* Immediate, Boxed, and Unboxed Objects */
static int
size_pointer(lispobj *where)
{
return 1;
}
static int
scav_immediate(lispobj *where, lispobj object)
{
return 1;
}
static lispobj
trans_immediate(lispobj object)
{
fprintf(stderr, "GC lossage. Trying to transport an immediate!?\n");
lose(NULL);
return NIL;
}
static int
size_immediate(lispobj *where)