Newer
Older
* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/gc.c,v 1.13 1997/04/21 00:52:21 dtc 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
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;
#ifdef POSIX_SIGS
sigset_t tmp, old;
#else
#ifdef PRINTNOISE
printf("[Collecting garbage ... \n");
getrusage(RUSAGE_SELF, &start_rusage);
gettimeofday(&start_tv, (struct timezone *) 0);
#endif
#ifdef POSIX_SIGS
sigemptyset(&tmp);
FILLBLOCKSET(&tmp);
sigprocmask(SIG_BLOCK, &tmp, &old);
#else
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
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();
#ifdef POSIX_SIGS
sigprocmask(SIG_SETMASK, &old, 0);
#else
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
#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 */
#define DIRECT_SCAV 0
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
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
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
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
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
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
}
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");
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
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);
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
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;
}
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
667
668
669
670
671
672
673
#else
static int
scav_function_pointer(lispobj *where, lispobj object)
{
lispobj *first_pointer;
lispobj copy;
lispobj first;
int type;
gc_assert(Pointerp(object));
/* object is a pointer into from space. Not a FP */
first_pointer = (lispobj *) PTR(object);
first = *first_pointer;
/* 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;
}
#endif
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
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);
785
786
787
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
832
833
834
835
836
837
838
839
840
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);
846
847
848
849
850
851
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
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)
{
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;
}
#else
static int
scav_instance_pointer(lispobj *where, lispobj object)
{
lispobj *first_pointer;
/* object is a pointer into from space. Not a FP */
first_pointer = (lispobj *) PTR(object);
*where = *first_pointer = trans_boxed(object);
return 1;
}
#endif
/* 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;
}
#else
static int
scav_list_pointer(lispobj *where, lispobj object)
{
lispobj first, *first_pointer;
gc_assert(Pointerp(object));
/* object is a pointer into from space. Not a FP. */
first_pointer = (lispobj *) PTR(object);
first = *first_pointer = trans_list(object);
gc_assert(Pointerp(first));
gc_assert(!from_space_p(first));
*where = first;
return 1;
}
#endif
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);