Newer
Older
1
2
3
4
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
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
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
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
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
540
541
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
667
668
669
670
671
672
673
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
725
726
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
783
784
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
841
842
843
844
845
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
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
/* cgc.c -*- Mode: C; comment-column: 40; -*-
* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/cgc.c,v 1.1 1997/01/21 00:28:13 ram Exp $
*
* Conservative Garbage Collector for CMUCL x86.
*
* Copyright (c) Paul F Werkowski, 1996.
*
* There is absolutely NO WARRANTY associated with this code! Use
* at your own risk! If you can't handle the fact that this may
* not work the way you want then just DELETE THIS FILE NOW!
*
* This code is based on software written by William Lott, and
* Public Domain codes from Carnegie Mellon University.
*
* Received from William 27 Jul 95.
*
* Debug, FreeBSD hooks, and integration by Paul Werkowski
*
*/
#include <stdio.h>
#include <assert.h>
#include <signal.h>
#include "os.h" /* for SetSymbolValue */
#include "x86-validate.h" /* for memory layout */
#include "x86-lispregs.h"
#include "lisp.h" /* for object defs */
#include "interrupt.h" /* interrupt_handlers */
#include "internals.h"
#include "cgc.h"
#if !defined MIN
#define MIN(a,b)(((a)<(b))?(a):(b))
#define MAX(a,b)(((a)>(b))?(a):(b))
#endif
#include <unistd.h>
#include <stdlib.h>
#if defined unix
#include <sys/param.h>
#endif
#include <sys/types.h>
#include <sys/time.h>
#include <sys/resource.h>
#define dprintf(t,exp) if(t){printf exp ; fflush(stdout);}
/* Object representation details. The allocator/collector knows
* almost nothing about lisp internals and is fairly general.
*/
#define ALIGN_BITS 3
#define ALIGN_BYTES (1<<ALIGN_BITS)
#define ALIGNEDP(addr) ((((int)addr)&(ALIGN_BYTES-1)) == 0)
/* Type of an object. */
typedef struct object
{
long header;
struct object*data[1];
} *obj_t;
/* Just leave unused space */
#define NOTE_EMPTY(ptr,bytes) {}
/* Collector datastructures */
#define BLOCK_BITS 16
#define BLOCK_BYTES (1<<BLOCK_BITS)
#define BLOCK_NUMBER(ptr) (((long)(ptr))>>BLOCK_BITS)
#define BLOCK_ADDRESS(num) ((void *)((num)<<BLOCK_BITS))
#define CHUNK_BITS 9
#define CHUNK_BYTES (1<<CHUNK_BITS)
#define CHUNK_NUMBER(ptr) (((long)(ptr))>>CHUNK_BITS)
#define CHUNK_ADDRESS(num) ((void *)((num)<<CHUNK_BITS))
#define BLOCK_CHUNKS (1<<(BLOCK_BITS-CHUNK_BITS))
#define ROUNDDOWN(val,x) ((val)&~((x)-1))
#define ROUNDUP(val,x) ROUNDDOWN((val)+(x)-1,x)
#define gc_abort() lose("GC invariant lost! File \"%s\", line %d\n", \
__FILE__, __LINE__)
#if 0
#define gc_assert(ex) {if (!(ex)) gc_abort();}
#else
#define gc_assert(ex)
#endif
char*alloc(int);
struct cluster {
/* Link to the next cluster. */
struct cluster *next;
/* The number of blocks in this cluster. */
int num_blocks;
/* Pointer to the first region. */
struct region *first_region;
/* Table index by the chunk number of some pointer minus the chunk */
/* number for the first region giving the number of chunks past */
/* the chunk holding the region header that spans that pointer. */
/* Actually, it might not be enough. So after backing up that far, */
/* try again. */
unsigned char region_offset[1];
};
/* The first word of this is arranged to look like a fixnum
* so as not to confuse 'room'.
*/
struct region {
unsigned
res1 :2, num_chunks :16, contains_small_objects :1, clean :1, hole :7;
struct region **prev;
struct region *next;
struct space *space;
};
#define REGION_OVERHEAD ROUNDUP(sizeof(struct region), ALIGN_BYTES)
struct space {
struct region *regions;
struct region **regions_tail;
char *alloc_ptr;
char *alloc_end;
};
/* Chain of all the clusters. */
struct cluster *clusters = NULL;
static int num_clusters = 0; /* for debugging */
int cgc_debug = 0; /* maybe set from Lisp */
/* Table indexed by block number giving the cluster that block is part of. */
static struct cluster **block_table = NULL;
/* The allocated memory block_table is offset from. */
static struct cluster **block_table_base = NULL;
/* The maximum bounds on the heap. */
static void *heap_base = NULL;
static void *heap_end = NULL;
/* The two dynamic spaces. */
static struct space space_0 = { NULL };
static struct space space_1 = { NULL };
/* Pointers it whichever dynamic space is currently newspace and oldspace */
static struct space *newspace = NULL;
static struct space *oldspace = NULL;
/* Free lists of regions. */
static struct region *small_region_free_list = NULL;
static struct region *large_region_free_list = NULL;
static void move_to_newspace(struct region *region);
#if defined TESTING
static void print_region(struct region*r)
{
dprintf(1,("[region %x %d <%x %x> %x]\n",
r,r->num_chunks,r->prev,r->next,r->space));
}
static void print_regions(struct region*r, char*str)
{
printf("Regions %s:\n",str);
for(; r != NULL; r = r->next)
print_region(r);
}
static void print_space(struct space*s)
{
struct region*r = s->regions;
dprintf(1,("[space %x %s %s <%x - %x>]\n",
s,
(s == &space_0)? "S0" : "S1",
(s == newspace)? "NewSpace" : "OldSpace",
s->alloc_ptr, s->alloc_end));
print_regions(r,"");
}
void print_spaces()
{
print_space(&space_0);
print_space(&space_1);
print_regions(large_region_free_list,"LRFL");
print_regions(small_region_free_list,"SRFL");
}
void print_cluster(struct cluster*cluster)
{
printf("[cluster %x >%x %d]\n",cluster,cluster->next,cluster->num_blocks);
print_regions(cluster->first_region,"cluster");
}
void print_clusters()
{
struct cluster*cluster;
for(cluster=clusters; cluster != NULL; cluster = cluster->next)
print_cluster(cluster);
}
#endif /* TESTING */
/* Allocation/deallocation routines */
static void init_region(struct region *region, int nchunks)
{
int region_block = BLOCK_NUMBER(region);
struct cluster *cluster = block_table[region_block];
int offset = CHUNK_NUMBER(region) - CHUNK_NUMBER(cluster->first_region);
int i;
dprintf(0,("init region %x %d\n",region,nchunks));
*(long*)region = 0; /* clear fields */
region->num_chunks = nchunks;
if (nchunks > UCHAR_MAX) {
for (i = 0; i < UCHAR_MAX; i++)
cluster->region_offset[offset + i] = i;
for (; i < nchunks; i++)
cluster->region_offset[offset + i] = UCHAR_MAX;
}
else {
for (i = 0; i < nchunks; i++)
cluster->region_offset[offset + i] = i;
}
}
static struct region *maybe_alloc_large_region(int nchunks)
{
struct region *region, **prev;
prev = &large_region_free_list;
while ((region = *prev) != NULL) {
if (region->num_chunks >= nchunks) {
if (region->num_chunks == nchunks)
*prev = region->next;
else {
struct region *new
= (struct region *)((char *)region + nchunks*CHUNK_BYTES);
init_region(new, region->num_chunks - nchunks);
new->next = region->next;
new->prev = NULL;
new->space = NULL;
*prev = new;
region->num_chunks = nchunks;
}
region->next = NULL;
region->prev = NULL;
region->space = NULL;
return region;
}
prev = ®ion->next;
}
return NULL;
}
/* from os_zero */
static void cgc_zero(addr, length)
os_vm_address_t addr;
os_vm_size_t length;
{
os_vm_address_t block_start = os_round_up_to_page(addr);
os_vm_address_t end = addr + length;
os_vm_size_t block_size;
if(block_start > addr)
bzero((char *)addr, MIN(block_start - addr, length));
if(block_start < end)
{
length -= block_start - addr;
block_size =os_trunc_size_to_page(length);
if(block_size < length)
bzero((char *)block_start + block_size,length - block_size);
if (block_size != 0)
{
/* Now deallocate and allocate the block so that it */
/* faults in zero-filled. */
os_invalidate(block_start,block_size);
addr=os_validate(block_start,block_size);
if(addr == NULL || addr != block_start)
fprintf(stderr,"cgc_zero: block moved, 0x%08x ==> 0x%08x!\n",
block_start,addr);
}
}
}
static void compact_cluster(struct cluster *cluster)
{
int show = 0;
struct region *region = cluster->first_region;
struct region *end =
(struct region *)((char *)region + cluster->num_blocks * BLOCK_BYTES);
int grown = 0;
struct region *large_additions = NULL;
struct region **large_prev = &large_additions;
struct region *small_additions = NULL;
struct region **small_prev = &small_additions;
dprintf(show,("compact cluster %x\n",cluster));
while (region < end) {
struct region *next =
(struct region *) ((char *)region + region->num_chunks*CHUNK_BYTES);
if (region->space != newspace) { /* was == NULL */
if (next < end && next->space != newspace) { /* was == NULL */
gc_assert(region->space == NULL);
gc_assert(next->space == NULL);
gc_assert(region->num_chunks > 0);
gc_assert(next->num_chunks > 0);
region->num_chunks += next->num_chunks;
grown = 1;
}
else {
if (grown) {
init_region(region, region->num_chunks);
region->space = NULL;
grown = 0;
}
{
int ovh = REGION_OVERHEAD;
cgc_zero((os_vm_address_t)((char*)region + ovh),
(os_vm_size_t)(region->num_chunks*CHUNK_BYTES) - ovh);
}
if(region->num_chunks == 1) {
*small_prev = region;
small_prev = ®ion->next;
}
else {
*large_prev = region;
large_prev = ®ion->next;
}
region = next;
}
}
else
region = next;
}
*large_prev = large_region_free_list;
large_region_free_list = large_additions;
*small_prev = small_region_free_list;
small_region_free_list = small_additions;
}
static void compact_free_regions()
{
struct cluster*cluster;
large_region_free_list = NULL;
small_region_free_list = NULL;
for (cluster = clusters; cluster != NULL; cluster = cluster->next)
compact_cluster(cluster);
}
/* WL code arranged to allocate new space via the sbrk() mechanism.
* However, I am going to start by allocating from the standard dynamic
* space. The idea is to use the normal allocation scheme for initial
* system build and switch to the cgc allocator when starting up a
* saved image when dynamic space is hopefully clean.
*/
static struct region*new_region(int nblocks)
{
/* take from existing dynamic space */
char*new = (char*)SymbolValue(ALLOCATION_POINTER);
struct region*region = (struct region*)(ROUNDUP((long)new,BLOCK_BYTES));
int bn = BLOCK_NUMBER(region);
new += (nblocks * BLOCK_BYTES + ((char*)region - new));
SetSymbolValue(ALLOCATION_POINTER,(lispobj)new);
return region;
}
static void new_cluster(int min_blocks)
{
int nblocks = min_blocks < 4 ? 4 : min_blocks;
int nchunks = nblocks << (BLOCK_BITS-CHUNK_BITS);
int i;
struct cluster *cluster = malloc(sizeof(struct cluster) + nchunks-1);
struct region*region = new_region(nblocks);
int bn = BLOCK_NUMBER(region);
dprintf(cgc_debug,("new cluster %x region@%x\n",cluster,region));
for (i = 0; i < nblocks; i++)
block_table[bn+i] = cluster;
num_clusters++;
cluster->next = clusters;
clusters = cluster;
cluster->num_blocks = nblocks;
cluster->first_region = region;
init_region(region, nchunks);
region->next = large_region_free_list;
large_region_free_list = region;
region->prev = NULL;
region->space = NULL;
}
unsigned long cgc_bytes_allocated = 0; /* Seen by (dynamic-usage) */
static unsigned long auto_gc_trigger = 0;
static int maybe_gc_called = 0;
static struct region *alloc_large_region(int nchunks)
{
struct region *region;
{
region = maybe_alloc_large_region(nchunks);
if (region == NULL)
{
new_cluster((nchunks + BLOCK_CHUNKS - 1) >> (BLOCK_BITS-CHUNK_BITS));
region = maybe_alloc_large_region(nchunks);
gc_assert(region != NULL);
}
}
gc_assert(region->space == NULL);
return region;
}
static struct region *alloc_small_region()
{
struct region *region = small_region_free_list;
if (region == NULL)
region = alloc_large_region(1);
else
small_region_free_list = region->next;
region->next = NULL;
region->prev = NULL;
region->space = NULL;
move_to_newspace(region);
return region;
}
static int chunks_freed = 0;
static void free_region(struct region *region)
{
gc_assert(region->space && region->space == oldspace);
gc_assert(region->num_chunks > 0);
region->space = NULL; /* for compact_cluster? */
region->prev = NULL; /* housekeeping I hope */
chunks_freed += region->num_chunks;
if (region->num_chunks == 1)
{
region->next = small_region_free_list;
small_region_free_list = region;
}
else
{
region->next = large_region_free_list;
large_region_free_list = region;
}
}
static void *alloc_large(int nbytes)
{
int nchunks = (nbytes+REGION_OVERHEAD+CHUNK_BYTES-1) >> CHUNK_BITS;
struct region *region = alloc_large_region(nchunks);
region->contains_small_objects = 0;
region->next = NULL;
region->prev = NULL;
region->space = NULL;
cgc_bytes_allocated += region->num_chunks*CHUNK_BYTES;
move_to_newspace(region);
return (char *)region + REGION_OVERHEAD;
}
void *cgc_alloc(int nbytes)
{
void*res;
dprintf(0,("alloc %d\n", nbytes));
if (nbytes > (CHUNK_BYTES - REGION_OVERHEAD))
res = alloc_large(nbytes);
else
{
struct space *space = newspace;
if ((space->alloc_ptr + nbytes) > space->alloc_end)
{
struct region *region;
if(space->alloc_ptr != NULL)
{
int hole = space->alloc_end - space->alloc_ptr;
if(hole >= ALIGN_BYTES)
/* This wastes the space, eg suppose one cons
* has been allocated then a request for
* a maximum sized small obj comes in. I'd like
* to remember that there is still a lot of
* room left in this region. Maybe I could actually
* use the small_region_free_list in some way.
*/
NOTE_EMPTY(space->alloc_ptr, hole);
}
region = alloc_small_region();
region->contains_small_objects = 1;
space->alloc_ptr = (char *)region + REGION_OVERHEAD;
space->alloc_end = (char *)region + CHUNK_BYTES;
cgc_bytes_allocated += region->num_chunks*CHUNK_BYTES;
}
res = space->alloc_ptr;
space->alloc_ptr += ROUNDUP(nbytes, ALIGN_BYTES);
}
return res;
}
static void move_to_newspace(struct region *region)
{
/* (maybe) unlink region from oldspace and add to tail of
* newspace regions. Don't attempt to move a region that
* is already in newspace.
*/
struct space *space = newspace;
if(region->space == oldspace)
{
/* Remove region from list. The prev slot holds
* the address of the 'next' slot of the previous
* list entry, not a pointer to that region (why?)
*/
*region->prev = region->next;
if(region->next)
region->next->prev = region->prev;
if(region->space->regions_tail == ®ion->next)
region->space->regions_tail = region->prev;
}
/* Append to newspace unless it has already been promoted. */
if(region->space != newspace)
{
region->prev = space->regions_tail;
region->next = NULL;
*space->regions_tail = region;
space->regions_tail = ®ion->next;
region->space = space;
}
}
static struct region *find_region(void *ptr)
{
struct cluster *cluster;
int cluster_chunk_num;
int chunk_num;
unsigned char delta;
ptr = (void*)((int) ptr & ~0x3);
if (ptr < heap_base || ptr >= heap_end)
return NULL;
cluster = block_table[BLOCK_NUMBER(ptr)];
if (cluster == NULL)
return NULL;
if (ptr < (void*)cluster->first_region)
return NULL;
cluster_chunk_num = CHUNK_NUMBER(cluster->first_region);
chunk_num = CHUNK_NUMBER(ptr);
while (delta = cluster->region_offset[chunk_num - cluster_chunk_num])
chunk_num -= delta;
return CHUNK_ADDRESS(chunk_num);
}
/* Interface to std collector */
static inline boolean
from_space_p(lispobj obj)
{
struct region*region=find_region((void*)obj);
return (region != NULL && region->space == oldspace);
}
static inline boolean
new_space_p(lispobj obj)
{
struct region*region=find_region((void*)obj);
return (region != NULL && region->space == newspace);
}
static inline boolean
static_space_p(lispobj obj)
{
return (STATIC_SPACE_START < obj
&& obj < SymbolValue(STATIC_SPACE_FREE_POINTER));
}
/* Predicate that returns true if an object is a pointer. */
#undef POINTERP
#define POINTERP(obj) Pointerp((obj)->header)
/* Predicate that returns true if an object has been forwarded. */
#define FORWARDED(obj) ((obj_t)(obj)->header == (obj_t)0x1)
/* Returns the forwarding pointer for the given object. */
#define FORWARDING_PTR(obj) ((lispobj)(obj)->data[0])
/* Marks obj as forwarded to new */
#define DEPOSIT_FORWARDING_PTR(obj,new) \
((obj_t)(obj)->header = 0x1, (obj_t)(obj)->data[0] = (obj_t)new)
/* Returns an obj_t for the object starting at addr */
#define OBJECT_AT(addr) ((obj_t)(addr))
/* Returns the size (in bytes) of obj. */
#define OBJECT_SIZE(obj) (sizeOfObject((obj_t)obj)<<2)
/* Scavenges an object. */
#define SCAVENGE_OBJECT(obj) scavengex((lispobj*)obj)
#if 0
/* Makes a region of memory look like some kind of object. */
#define NOTE_EMPTY(ptr,bytes) \
(((obj_t)ptr)->header = (((bytes+ALIGN_BYTES-1)>>ALIGN_BITS)<<8) | 1)
#endif
static unsigned long bytes_copied = 0;
# define HAVE_FASTCOPY
#if defined HAVE_FASTCOPY
#define COPYDUAL(a,b,c) fastcopy16(a,b,c)
void fastcopy16(void*,void*,size_t);
#else
#define COPYDUAL(a,b,c) memmove(a,b,c)
#endif
static inline lispobj
copy(lispobj taggedobj)
{
obj_t source = (obj_t)PTR(taggedobj);
int nbytes = OBJECT_SIZE(source);
gc_assert(Pointerp(taggedobj));
gc_assert(!(nbytes & (ALIGN_BYTES-1)));
{
int lowtag = LowtagOf(taggedobj);
obj_t newobj = cgc_alloc(nbytes);
COPYDUAL(newobj, source, nbytes);
bytes_copied += nbytes;
return ((lispobj)newobj | lowtag);
}
}
#define CEILING(x,y) (((x) + ((y) - 1)) & (~((y) - 1)))
#define NWORDS(x,y) (CEILING((x),(y)) / (y))
#define WEAK_POINTER_NWORDS \
CEILING((sizeof(struct weak_pointer) / sizeof(lispobj)), 2)
static struct weak_pointer *weak_pointers;
/* Scavenging:
* CMU CL objects can be classified as BOXED, UNBOXED or other.
* Boxed objects have a header containing length and type followed
* by LENGTH tagged object descriptors which may be pointers.
* UNBOXED objects have a header but the data is other than
* tagged descriptors, such as floats, bignums, saps or code.
* Others (code) contain a mix of boxed and unboxed and some
* (cons) are like BOXED but without header. The scavenger needs
* to consider these different kinds of objects. I will use a
* table indexed by type to detect the simple cases of boxed
* or unboxed.
*/
#define IMMED_OR_LOSE(thing) gc_assert(sct[TypeOf(thing)].sc_kind == SC_IMMED)
static void scavenge_pointer(lispobj*);
static int noise = 0;
typedef struct { unsigned sc_kind : 3, ve_l2bits : 5;} OSC_t;
OSC_t make_OSC(int kind, int log2bits)
{
OSC_t thing;
thing.sc_kind = kind;
thing.ve_l2bits = log2bits;
return thing;
}
#define SETSCT(indx,kind,logbits) sct[indx] = make_OSC(kind,logbits)
#define SC_ISBOXED 1
#define SC_UNBOXED 2
#define SC_IMMED 3
#define SC_POINTER 4
#define SC_VECTOR 5
#define SC_STRING 6
#define SC_OTHER 7
#define SC_LOSER 0
static OSC_t sct[256];
int sizeOfObject(obj_t obj)
{
int obj_type = TypeOf(obj->header);
OSC_t class = sct[obj_type];
struct vector*vector;
int length = 1;
int nwords = 1;
switch (class.sc_kind)
{
case SC_POINTER:
case SC_IMMED:
return 1;
case SC_ISBOXED:
case SC_UNBOXED:
gc_assert(HeaderValue(obj->header) > 0);
nwords = length = HeaderValue(obj->header) + 1;
break;
case SC_STRING:
case SC_VECTOR:
{
int log2bits = class.ve_l2bits;
int bits_per_el = 1 << log2bits;
int extra = 0;
int els_per_word = 1 << (5 - log2bits);
if(log2bits > 5)
{
els_per_word = 1;
extra = log2bits - 5;
}
length = ((struct vector*)obj)->length;
length = fixnum_value(length); /* Zero Length IS valid */
length += (class.sc_kind == SC_STRING);
length <<= extra;
nwords = NWORDS(length, els_per_word);
nwords += 2; /* header + length */
}
break;
case SC_OTHER:
switch(obj_type)
{
case type_CodeHeader:
{
struct code *code;
int nheader_words, ncode_words;
code = (struct code *)obj;
ncode_words = fixnum_value(code->code_size);
nheader_words = HeaderValue(code->header);
nwords = ncode_words + nheader_words;
} break;
default:
fprintf(stderr,"GC losage: no size for other type %d\n",obj_type);
gc_abort();
}
break;
default:
fprintf(stderr,"GC losage: no size for other type %d\n",obj_type);
gc_abort();
}
return CEILING(nwords,2);
}
static void init_osc()
{
int i;
for (i = 0; i < 256; i++)
SETSCT(i ,SC_LOSER, 0);
for (i = 0; i < 32; i++)
{
SETSCT(type_EvenFixnum|(i<<3) ,SC_IMMED,0);
SETSCT(type_FunctionPointer|(i<<3),SC_POINTER,0);
/* OtherImmediate0 */
SETSCT(type_ListPointer|(i<<3) ,SC_POINTER,0);
SETSCT(type_OddFixnum|(i<<3) ,SC_IMMED,0);
SETSCT(type_InstancePointer|(i<<3),SC_POINTER,0);
/* OtherImmediate1 */
SETSCT(type_OtherPointer|(i<<3) ,SC_POINTER,0);
}
SETSCT(type_Bignum ,SC_UNBOXED,0);
SETSCT(type_Ratio ,SC_ISBOXED,0);
SETSCT(type_SingleFloat ,SC_UNBOXED,0);
SETSCT(type_DoubleFloat ,SC_UNBOXED,0);
SETSCT(type_Complex ,SC_ISBOXED,0);
SETSCT(type_SimpleArray ,SC_ISBOXED,0);
SETSCT(type_SimpleString ,SC_STRING,3);
SETSCT(type_SimpleBitVector ,SC_VECTOR,0);
SETSCT(type_SimpleVector ,SC_VECTOR,5);
SETSCT(type_SimpleArrayUnsignedByte2 ,SC_VECTOR,1);
SETSCT(type_SimpleArrayUnsignedByte4 ,SC_VECTOR,2);
SETSCT(type_SimpleArrayUnsignedByte8 ,SC_VECTOR,3);
SETSCT(type_SimpleArrayUnsignedByte16 ,SC_VECTOR,4);
SETSCT(type_SimpleArrayUnsignedByte32 ,SC_VECTOR,5);
SETSCT(type_SimpleArraySingleFloat ,SC_VECTOR,5);
SETSCT(type_SimpleArrayDoubleFloat ,SC_VECTOR,6);
SETSCT(type_ComplexString ,SC_ISBOXED,0);
SETSCT(type_ComplexBitVector ,SC_ISBOXED,0);
SETSCT(type_ComplexVector ,SC_ISBOXED,0);
SETSCT(type_ComplexArray ,SC_ISBOXED,0);
SETSCT(type_CodeHeader ,SC_OTHER,0);
SETSCT(type_FunctionHeader ,SC_OTHER,0);
SETSCT(type_ClosureFunctionHeader ,SC_OTHER,0);
SETSCT(type_ReturnPcHeader ,SC_OTHER,0);
SETSCT(type_ClosureHeader ,SC_ISBOXED,0);
SETSCT(type_FuncallableInstanceHeader ,SC_ISBOXED,0);
SETSCT(type_ByteCodeFunction ,SC_ISBOXED,0);
SETSCT(type_ByteCodeClosure ,SC_ISBOXED,0);
SETSCT(type_DylanFunctionHeader ,SC_ISBOXED,0);
SETSCT(type_ValueCellHeader ,SC_ISBOXED,0);
SETSCT(type_SymbolHeader ,SC_ISBOXED,0);
SETSCT(type_BaseChar ,SC_IMMED,0);
SETSCT(type_Sap ,SC_UNBOXED,0);
SETSCT(type_UnboundMarker ,SC_IMMED,0);
SETSCT(type_WeakPointer ,SC_UNBOXED,0);
SETSCT(type_InstanceHeader ,SC_ISBOXED,0);
SETSCT(type_Fdefn ,SC_ISBOXED,0);
}
static lispobj* scavenge(lispobj*,int);
static lispobj*scavenge_object(lispobj*);
static lispobj*scavengex(lispobj*);
static inline scavenge_1word_obj(lispobj*addr)
{
if(Pointerp(*addr))
{
if(*addr != NIL && *addr != T)
scavenge_pointer(addr);
}
else
IMMED_OR_LOSE(*addr);
}
static int debug_code = 0;
static int
scav_code_header(lispobj*where)
{
lispobj object = *where;
struct code *code;
int i,nheader_words, ncode_words, nwords;
lispobj fheaderl;
struct function *fheaderp;
dprintf(0,("code: %x %x\n",where,object));
code = (struct code *) where;
ncode_words = fixnum_value(code->code_size);
nheader_words = HeaderValue(object);
nwords = ncode_words + nheader_words;
nwords = CEILING(nwords, 2);
/* Scavenge the boxed section of the code data block */
/* NOTE: seeing a problem where the trace_table_offset slot
* is a bogus list pointer instead of a fixnum such that
* junk gets moved to newspace which causes problems later.
* Purify doesn't look at that slot (a bug?). Need
* to figure out how it happens. Ans: from loading top-level
* forms that init byte-compiled functions like "defun fcn".
* Fix the loader to not do this and save some space!
*/
for(i=1; i < nheader_words; i++)
scavenge_1word_obj(where + i);
/* 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);
gc_assert(TypeOf(fheaderp->header) == type_FunctionHeader);
scavenge_1word_obj(&fheaderp->name);
scavenge_1word_obj(&fheaderp->arglist);
scavenge_1word_obj(&fheaderp->type);
fheaderl = fheaderp->next;
}
return nwords;
}
#define RAW_ADDR_OFFSET (6*sizeof(lispobj) - type_FunctionPointer)
#ifdef i386
static void scavenge_fcn_header(struct function*object)
{
struct function*fheader = object;
unsigned long offset = HeaderValue(fheader->header) * 4;
/* Ok, we don't transport code here, but we do need to
* scavenge the constants and functions (of which this is one).
* This should be done as part of scavenging a live code object
* and we could now be trying to do CPR on a corpse!
*/
struct code*code = (struct code *) ((unsigned long) fheader - offset);
gc_assert(TypeOf(fheader->header) == type_FunctionHeader);
scav_code_header((lispobj*)code);
}
static int docode=0; /* maybe not needed */
static int
scav_closure_header(struct closure*closure)
{
/* Could also be a funcallable_instance. The x86 port has the
* raw code address in the function slot, not a lisp object.
* However, the function object is a known distance from the code.
*/
lispobj fun, fheader1;
int i,words;
gc_assert(ALIGNEDP(closure));
words = HeaderValue(closure->header);
fun = closure->function - RAW_ADDR_OFFSET;
/* This needs to be done to get at live code. I now have no
* way to know if this has already been scavenged so I assume
* that it hasn't. Code that has been seen by purify is
* supposed RO and doesn't (shouldn't) need to be looked at
* so this maybe really redundant.
*
* I have seen one case where FI was incomplete with function
* and lexenv slots == 0! Is this a bug?
*
* Update, it appears this is not needed. I will disable execution
* by default but leave the code here in case something breaks.
*/
if(docode && static_space_p(closure->function))
scavenge_fcn_header((struct function*)PTR(fun));
else /* "normal" */
scavenge_1word_obj(&fun);
/* Now the boxed part of the closure header. */
for(i = 0; i < words - 1; i++)
scavenge_1word_obj(&closure->info[i]);
return CEILING(words + 1, 2);
}
static int fnoise=0; /* experimental */
static int
scav_fdefn(lispobj*where)
{
/* I don't know if this is really needs to be special cased here.
* raw_address should look like a fixnum and function is in static
* space -- unless it is pointing to something in C like closure_tramp
* or maybe undefined_tramp.
* Actually function is in dynamic space if it is a byte-function!
* Hmm, have seen case of function slot containing 1. Bug?
*/
struct fdefn * fdefn = (struct fdefn*)where;
int words = HeaderValue(fdefn->header);
int fix_func = ((char*)(fdefn->function+RAW_ADDR_OFFSET) == fdefn->raw_addr);
scavenge_pointer(&fdefn->name);
if(fnoise && LowtagOf(fdefn->function) == type_FunctionPointer)
{
obj_t fcnobj = (obj_t)PTR(fdefn->function);
switch(TypeOf(fcnobj->header))
{
/* Can only be in static space and may need to scavenge code object.
* Won't be noticed by scavenge_pointer().
*/
case type_FunctionHeader:
scavenge_fcn_header((struct function*)fcnobj);
break;
/* If in static space it was moved there by purify and we are
* doing normal scavenge. Handle normally.
*/
case type_FuncallableInstanceHeader:
case type_ClosureHeader:
scavenge_pointer(&fdefn->function);
break;
default:
dprintf(1,("Ignoring bogus value %x for fdefn function.\n",
*fcnobj));
}
}
else
/* NIL for undefined function? */
scavenge_pointer(&fdefn->function);
if (fix_func)
{ /* This shouldn't be needed yet. */
fdefn->raw_addr = (char *)(fdefn->function + RAW_ADDR_OFFSET);
}
return sizeof(struct fdefn) / sizeof(lispobj);
}
#endif
/* List scavenger taken from gc.c and adapted */
static FILE*log=NULL;
static int scav_ro = 0; /* for testing */
static int debug=0;
static void*trapaddr=0;
void check_trap(void*addr)
{
fprintf(stderr,"Trapped @ %x\n",addr);
}
static lispobj
trans_list(lispobj object)
{
lispobj new_list_pointer;
struct cons *cons, *new_cons;
int n=0;
lispobj cdr;
cons = (struct cons *) PTR(object);
/* copy 'object' */
new_cons = (struct cons *) cgc_alloc(sizeof(struct cons));
new_cons->car = cons->car;
new_cons->cdr = cons->cdr; /* updated later */
new_list_pointer = (lispobj)new_cons | LowtagOf(object);
bytes_copied += sizeof(struct cons);
#if 0
if(scav_ro>1)check_trap(object);
if(log)fprintf(log,"( %d cons @ #x%x -> #x%x car #x%x)\n",