Clean up RCS ids
[projects/cmucl/cmucl.git] / src / lisp / cgc.c
CommitLineData
5ced0fdf 1/* cgc.c -*- Mode: C; comment-column: 40; -*-
5ced0fdf 2 *
3 * Conservative Garbage Collector for CMUCL x86.
4 *
5ced0fdf 5 * This code is based on software written by William Lott, and
b45824e8 6 * Public Domain codes from Carnegie Mellon University, and has
7 * been placed in the Public Domain.
5ced0fdf 8 *
9 * Received from William 27 Jul 95.
10 *
11 * Debug, FreeBSD hooks, and integration by Paul Werkowski
12 *
b45824e8 13 *
5ced0fdf 14 */
15#include <stdio.h>
16#include <assert.h>
17#include <signal.h>
17f90d1c 18#include <string.h>
9a8c1c2f 19#include "os.h" /* for SetSymbolValue */
20#include "globals.h" /* For dynamic_space_size */
21#include "x86-validate.h" /* for memory layout */
5ced0fdf 22#include "x86-lispregs.h"
9a8c1c2f 23#include "lisp.h" /* for object defs */
24#include "interrupt.h" /* interrupt_handlers */
5ced0fdf 25#include "internals.h"
26#include "cgc.h"
27
28#if !defined MIN
29#define MIN(a,b)(((a)<(b))?(a):(b))
30#define MAX(a,b)(((a)>(b))?(a):(b))
31#endif
32
33#include <unistd.h>
34#include <stdlib.h>
35#if defined unix
36#include <sys/param.h>
37#endif
38#include <sys/types.h>
39#include <sys/time.h>
40#include <sys/resource.h>
41
42
43#define dprintf(t,exp) if(t){printf exp ; fflush(stdout);}
44\f
45/* Object representation details. The allocator/collector knows
46 * almost nothing about lisp internals and is fairly general.
47*/
48
49#define ALIGN_BITS 3
50#define ALIGN_BYTES (1<<ALIGN_BITS)
51#define ALIGNEDP(addr) ((((int)addr)&(ALIGN_BYTES-1)) == 0)
52
53/* Type of an object. */
9a8c1c2f 54typedef struct object {
55 long header;
56 struct object *data[1];
5ced0fdf 57} *obj_t;
58
59/* Just leave unused space */
60#define NOTE_EMPTY(ptr,bytes) {}
5ced0fdf 61\f
9a8c1c2f 62
5ced0fdf 63/* Collector datastructures */
64
65#define BLOCK_BITS 16
66#define BLOCK_BYTES (1<<BLOCK_BITS)
67#define BLOCK_NUMBER(ptr) (((long)(ptr))>>BLOCK_BITS)
68#define BLOCK_ADDRESS(num) ((void *)((num)<<BLOCK_BITS))
69
70#define CHUNK_BITS 9
71#define CHUNK_BYTES (1<<CHUNK_BITS)
72#define CHUNK_NUMBER(ptr) (((long)(ptr))>>CHUNK_BITS)
73#define CHUNK_ADDRESS(num) ((void *)((num)<<CHUNK_BITS))
74
75#define BLOCK_CHUNKS (1<<(BLOCK_BITS-CHUNK_BITS))
76
77
78#define ROUNDDOWN(val,x) ((val)&~((x)-1))
79#define ROUNDUP(val,x) ROUNDDOWN((val)+(x)-1,x)
80
81#define gc_abort() lose("GC invariant lost! File \"%s\", line %d\n", \
82 __FILE__, __LINE__)
83
84#if 0
85#define gc_assert(ex) {if (!(ex)) gc_abort();}
86#else
87#define gc_assert(ex)
88#endif
89
9a8c1c2f 90char *alloc(int);
5ced0fdf 91\f
9a8c1c2f 92
5ced0fdf 93struct cluster {
94 /* Link to the next cluster. */
95 struct cluster *next;
96
97 /* The number of blocks in this cluster. */
98 int num_blocks;
99
100 /* Pointer to the first region. */
101 struct region *first_region;
102
103 /* Table index by the chunk number of some pointer minus the chunk */
104 /* number for the first region giving the number of chunks past */
105 /* the chunk holding the region header that spans that pointer. */
106 /* Actually, it might not be enough. So after backing up that far, */
107 /* try again. */
108 unsigned char region_offset[1];
109};
110
111/* The first word of this is arranged to look like a fixnum
112 * so as not to confuse 'room'.
113 */
114struct region {
9a8c1c2f 115 unsigned
116 res1:2, num_chunks:16, contains_small_objects:1, clean:1, hole:7;
117 struct region **prev;
118 struct region *next;
119 struct space *space;
5ced0fdf 120};
121
122#define REGION_OVERHEAD ROUNDUP(sizeof(struct region), ALIGN_BYTES)
123
124
125struct space {
126 struct region *regions;
127 struct region **regions_tail;
128 char *alloc_ptr;
129 char *alloc_end;
130};
131
132/* Chain of all the clusters. */
133struct cluster *clusters = NULL;
9a8c1c2f 134static int num_clusters = 0; /* for debugging */
135int cgc_debug = 0; /* maybe set from Lisp */
136
5ced0fdf 137/* Table indexed by block number giving the cluster that block is part of. */
138static struct cluster **block_table = NULL;
139
140/* The allocated memory block_table is offset from. */
141static struct cluster **block_table_base = NULL;
142
143/* The maximum bounds on the heap. */
144static void *heap_base = NULL;
145static void *heap_end = NULL;
146
147/* The two dynamic spaces. */
148static struct space space_0 = { NULL };
149static struct space space_1 = { NULL };
9a8c1c2f 150
5ced0fdf 151/* Pointers it whichever dynamic space is currently newspace and oldspace */
152static struct space *newspace = NULL;
153static struct space *oldspace = NULL;
9a8c1c2f 154
5ced0fdf 155/* Free lists of regions. */
156static struct region *small_region_free_list = NULL;
157static struct region *large_region_free_list = NULL;
158static void move_to_newspace(struct region *region);
159\f
160#if defined TESTING
9a8c1c2f 161static void
162print_region(struct region *r)
5ced0fdf 163{
9a8c1c2f 164 dprintf(1, ("[region %x %d <%x %x> %x]\n",
165 r, r->num_chunks, r->prev, r->next, r->space));
5ced0fdf 166}
9a8c1c2f 167static void
168print_regions(struct region *r, char *str)
5ced0fdf 169{
9a8c1c2f 170 printf("Regions %s:\n", str);
171 for (; r != NULL; r = r->next)
172 print_region(r);
5ced0fdf 173}
174
9a8c1c2f 175static void
176print_space(struct space *s)
5ced0fdf 177{
9a8c1c2f 178 struct region *r = s->regions;
179
180 dprintf(1, ("[space %x %s %s <%x - %x>]\n",
181 s,
182 (s == &space_0) ? "S0" : "S1",
183 (s == newspace) ? "NewSpace" : "OldSpace",
184 s->alloc_ptr, s->alloc_end));
185 print_regions(r, "");
5ced0fdf 186
187}
9a8c1c2f 188
189void
b8d0dfaf 190print_spaces(void)
5ced0fdf 191{
9a8c1c2f 192 print_space(&space_0);
193 print_space(&space_1);
194 print_regions(large_region_free_list, "LRFL");
195 print_regions(small_region_free_list, "SRFL");
5ced0fdf 196}
9a8c1c2f 197
198void
199print_cluster(struct cluster *cluster)
5ced0fdf 200{
9a8c1c2f 201 printf("[cluster %x >%x %d]\n", cluster, cluster->next,
202 cluster->num_blocks);
203 print_regions(cluster->first_region, "cluster");
5ced0fdf 204}
9a8c1c2f 205
206void
b8d0dfaf 207print_clusters(void)
5ced0fdf 208{
9a8c1c2f 209 struct cluster *cluster;
210
211 for (cluster = clusters; cluster != NULL; cluster = cluster->next)
212 print_cluster(cluster);
5ced0fdf 213}
214#endif /* TESTING */
5ced0fdf 215\f
9a8c1c2f 216
5ced0fdf 217/* Allocation/deallocation routines */
218
9a8c1c2f 219static void
220init_region(struct region *region, int nchunks)
5ced0fdf 221{
222 int region_block = BLOCK_NUMBER(region);
223 struct cluster *cluster = block_table[region_block];
224 int offset = CHUNK_NUMBER(region) - CHUNK_NUMBER(cluster->first_region);
225 int i;
9a8c1c2f 226
227 dprintf(0, ("init region %x %d\n", region, nchunks));
228 *(long *) region = 0; /* clear fields */
5ced0fdf 229 region->num_chunks = nchunks;
230 if (nchunks > UCHAR_MAX) {
231 for (i = 0; i < UCHAR_MAX; i++)
232 cluster->region_offset[offset + i] = i;
233 for (; i < nchunks; i++)
234 cluster->region_offset[offset + i] = UCHAR_MAX;
9a8c1c2f 235 } else {
5ced0fdf 236 for (i = 0; i < nchunks; i++)
237 cluster->region_offset[offset + i] = i;
238 }
239}
240\f
9a8c1c2f 241static struct region *
242maybe_alloc_large_region(int nchunks)
5ced0fdf 243{
244 struct region *region, **prev;
245
246 prev = &large_region_free_list;
247 while ((region = *prev) != NULL) {
248 if (region->num_chunks >= nchunks) {
249 if (region->num_chunks == nchunks)
250 *prev = region->next;
251 else {
252 struct region *new
9a8c1c2f 253 =
254
255 (struct region *) ((char *) region + nchunks * CHUNK_BYTES);
5ced0fdf 256 init_region(new, region->num_chunks - nchunks);
257 new->next = region->next;
258 new->prev = NULL;
259 new->space = NULL;
260 *prev = new;
261 region->num_chunks = nchunks;
262 }
263 region->next = NULL;
264 region->prev = NULL;
265 region->space = NULL;
266 return region;
267 }
268 prev = &region->next;
269 }
270 return NULL;
271}
272\f
273
274/* from os_zero */
9a8c1c2f 275static void
276cgc_zero(addr, length)
277 os_vm_address_t addr;
278 os_vm_size_t length;
279{
280 os_vm_address_t block_start = os_round_up_to_page(addr);
281 os_vm_address_t end = addr + length;
282 os_vm_size_t block_size;
283
284
285 if (block_start > addr)
286 memset((char *) addr, 0, MIN(block_start - addr, length))
287
288 if (block_start < end) {
289 length -= block_start - addr;
290
291 block_size = os_trunc_size_to_page(length);
292
293 if (block_size < length)
294 memset((char *) block_start + block_size, 0,
295 length - block_size);
296
297 if (block_size != 0) {
298 /* Now deallocate and allocate the block so that it */
299 /* faults in zero-filled. */
300
301 os_invalidate(block_start, block_size);
302 addr = os_validate(block_start, block_size);
303
304 if (addr == NULL || addr != block_start)
305 fprintf(stderr,
306 "cgc_zero: block moved, 0x%08x ==> 0x%08x!\n",
307 block_start, addr);
308 }
5ced0fdf 309 }
5ced0fdf 310}
311\f
9a8c1c2f 312static void
313compact_cluster(struct cluster *cluster)
314{
315 int show = 0;
316 struct region *region = cluster->first_region;
317 struct region *end =
318 (struct region *) ((char *) region + cluster->num_blocks * BLOCK_BYTES);
319 int grown = 0;
320 unsigned max_chunks = cluster->num_blocks * BLOCK_CHUNKS;
321 struct region *large_additions = NULL;
322 struct region **large_prev = &large_additions;
323 struct region *small_additions = NULL;
324 struct region **small_prev = &small_additions;
325
326 dprintf(show, ("compact cluster %x\n", cluster));
327 while (region < end) {
328 struct region *next =
329 (struct region *) ((char *) region +
330
331 region->num_chunks * CHUNK_BYTES);
332 if (region->space != newspace) { /* was == NULL */
333 if (next < end && next->space != newspace) { /* was == NULL */
334 gc_assert(region >= cluster->first_region);
335 gc_assert(region->space == NULL);
336 gc_assert(next->space == NULL);
337 gc_assert(region->num_chunks > 0);
338 gc_assert(next->num_chunks > 0);
339 gc_assert((region->num_chunks + next->num_chunks) <=
340 max_chunks);
341 region->num_chunks += next->num_chunks;
342 grown = 1;
343 } else {
344 if (grown) {
345 init_region(region, region->num_chunks);
346 region->space = NULL;
347 grown = 0;
348 }
349 {
350 int ovh = REGION_OVERHEAD;
5ced0fdf 351
9a8c1c2f 352 cgc_zero((os_vm_address_t) ((char *) region + ovh),
353 (os_vm_size_t) (region->num_chunks * CHUNK_BYTES) -
354 ovh);
355 }
356
357 if (region->num_chunks == 1) {
358 *small_prev = region;
359 small_prev = &region->next;
360 } else {
361 *large_prev = region;
362 large_prev = &region->next;
363 }
364 region = next;
365 }
366 } else
367 region = next;
5ced0fdf 368 }
9a8c1c2f 369
370 *large_prev = large_region_free_list;
371 large_region_free_list = large_additions;
372 *small_prev = small_region_free_list;
373 small_region_free_list = small_additions;
5ced0fdf 374}
375
9a8c1c2f 376static void
b8d0dfaf 377compact_free_regions(void)
5ced0fdf 378{
9a8c1c2f 379 struct cluster *cluster;
380
5ced0fdf 381 large_region_free_list = NULL;
382 small_region_free_list = NULL;
383
384 for (cluster = clusters; cluster != NULL; cluster = cluster->next)
385 compact_cluster(cluster);
386}
387\f
388/* WL code arranged to allocate new space via the sbrk() mechanism.
389 * However, I am going to start by allocating from the standard dynamic
390 * space. The idea is to use the normal allocation scheme for initial
391 * system build and switch to the cgc allocator when starting up a
392 * saved image when dynamic space is hopefully clean.
393 */
9a8c1c2f 394static struct region *
395new_region(int nblocks)
396{
397 /* take from existing dynamic space */
398 char *new = (char *) SymbolValue(ALLOCATION_POINTER);
399 struct region *region =
400
401 (struct region *) (ROUNDUP((long) new, BLOCK_BYTES));
402 int bn = BLOCK_NUMBER(region);
403
404 new += (nblocks * BLOCK_BYTES + ((char *) region - new));
405 SetSymbolValue(ALLOCATION_POINTER, (lispobj) new);
5ced0fdf 406 return region;
407}
408\f
9a8c1c2f 409static void
410new_cluster(int min_blocks)
5ced0fdf 411{
412 int nblocks = min_blocks < 4 ? 4 : min_blocks;
9a8c1c2f 413 int nchunks = nblocks << (BLOCK_BITS - CHUNK_BITS);
5ced0fdf 414 int i;
9a8c1c2f 415 struct cluster *cluster = malloc(sizeof(struct cluster) + nchunks - 1);
416 struct region *region = new_region(nblocks);
5ced0fdf 417
418 int bn = BLOCK_NUMBER(region);
9a8c1c2f 419
420 dprintf(cgc_debug, ("new cluster %x region@%x\n", cluster, region));
5ced0fdf 421 for (i = 0; i < nblocks; i++)
9a8c1c2f 422 block_table[bn + i] = cluster;
5ced0fdf 423
424 num_clusters++;
425 cluster->next = clusters;
426 clusters = cluster;
427 cluster->num_blocks = nblocks;
428 cluster->first_region = region;
429
430 init_region(region, nchunks);
431
432 region->next = large_region_free_list;
433 large_region_free_list = region;
434 region->prev = NULL;
435 region->space = NULL;
436}
437\f
725ab9ee 438unsigned long bytes_allocated = 0; /* Seen by (dynamic-usage) */
5ced0fdf 439static unsigned long auto_gc_trigger = 0;
440static int maybe_gc_called = 0;
441
9a8c1c2f 442static struct region *
443alloc_large_region(int nchunks)
5ced0fdf 444{
9a8c1c2f 445 struct region *region;
5ced0fdf 446
9a8c1c2f 447 {
5ced0fdf 448 region = maybe_alloc_large_region(nchunks);
9a8c1c2f 449
450 if (region == NULL) {
451 new_cluster((nchunks + BLOCK_CHUNKS - 1) >>
452 (BLOCK_BITS - CHUNK_BITS));
453 region = maybe_alloc_large_region(nchunks);
454 gc_assert(region != NULL);
455 }
456 }
457 gc_assert(region->space == NULL);
458 return region;
5ced0fdf 459}
460\f
9a8c1c2f 461static struct region *
b8d0dfaf 462alloc_small_region(void)
5ced0fdf 463{
464 struct region *region = small_region_free_list;
465
466 if (region == NULL)
467 region = alloc_large_region(1);
468 else
469 small_region_free_list = region->next;
470 region->next = NULL;
471 region->prev = NULL;
472 region->space = NULL;
473 move_to_newspace(region);
474 return region;
475}
476
477static int chunks_freed = 0;
478
9a8c1c2f 479static void
480free_region(struct region *region)
5ced0fdf 481{
9a8c1c2f 482 gc_assert(region->space && region->space == oldspace);
483 gc_assert(region->num_chunks > 0);
5ced0fdf 484
9a8c1c2f 485 region->space = NULL; /* for compact_cluster? */
486 region->prev = NULL; /* housekeeping I hope */
487 chunks_freed += region->num_chunks;
5ced0fdf 488
9a8c1c2f 489 if (region->num_chunks == 1) {
490 region->next = small_region_free_list;
491 small_region_free_list = region;
492 } else {
493 region->next = large_region_free_list;
494 large_region_free_list = region;
5ced0fdf 495 }
496}
497\f
9a8c1c2f 498static void *
499alloc_large(int nbytes)
5ced0fdf 500{
9a8c1c2f 501 int nchunks = (nbytes + REGION_OVERHEAD + CHUNK_BYTES - 1) >> CHUNK_BITS;
5ced0fdf 502 struct region *region = alloc_large_region(nchunks);
9a8c1c2f 503
5ced0fdf 504 region->contains_small_objects = 0;
505 region->next = NULL;
506 region->prev = NULL;
507 region->space = NULL;
9a8c1c2f 508 bytes_allocated += region->num_chunks * CHUNK_BYTES;
5ced0fdf 509 move_to_newspace(region);
9a8c1c2f 510 return (char *) region + REGION_OVERHEAD;
5ced0fdf 511}
512\f
9a8c1c2f 513void *
514cgc_alloc(int nbytes)
5ced0fdf 515{
9a8c1c2f 516 void *res;
5ced0fdf 517
9a8c1c2f 518 dprintf(0, ("alloc %d\n", nbytes));
519
520 if (nbytes > (CHUNK_BYTES - REGION_OVERHEAD))
521 res = alloc_large(nbytes);
522 else {
523 struct space *space = newspace;
524
525 if ((space->alloc_ptr + nbytes) > space->alloc_end) {
526 struct region *region;
527
528 if (space->alloc_ptr != NULL) {
529 int hole = space->alloc_end - space->alloc_ptr;
530
531 if (hole >= ALIGN_BYTES)
532 /* This wastes the space, eg suppose one cons
533 * has been allocated then a request for
534 * a maximum sized small obj comes in. I'd like
535 * to remember that there is still a lot of
536 * room left in this region. Maybe I could actually
537 * use the small_region_free_list in some way.
538 */
539 NOTE_EMPTY(space->alloc_ptr, hole);
5ced0fdf 540 }
9a8c1c2f 541 region = alloc_small_region();
542 region->contains_small_objects = 1;
543 space->alloc_ptr = (char *) region + REGION_OVERHEAD;
544 space->alloc_end = (char *) region + CHUNK_BYTES;
545 bytes_allocated += region->num_chunks * CHUNK_BYTES;
5ced0fdf 546 }
9a8c1c2f 547
548 res = space->alloc_ptr;
549 space->alloc_ptr += ROUNDUP(nbytes, ALIGN_BYTES);
5ced0fdf 550 }
9a8c1c2f 551 return res;
5ced0fdf 552}
5ced0fdf 553\f
9a8c1c2f 554
555static void
556move_to_newspace(struct region *region)
5ced0fdf 557{
9a8c1c2f 558 /* (maybe) unlink region from oldspace and add to tail of
559 * newspace regions. Don't attempt to move a region that
560 * is already in newspace.
561 */
5ced0fdf 562 struct space *space = newspace;
9a8c1c2f 563
564 if (region->space == oldspace) {
5ced0fdf 565 /* Remove region from list. The prev slot holds
566 * the address of the 'next' slot of the previous
567 * list entry, not a pointer to that region (why?)
568 */
569 *region->prev = region->next;
9a8c1c2f 570 if (region->next)
571 region->next->prev = region->prev;
572 if (region->space->regions_tail == &region->next)
573 region->space->regions_tail = region->prev;
574 }
5ced0fdf 575 /* Append to newspace unless it has already been promoted. */
9a8c1c2f 576 if (region->space != newspace) {
5ced0fdf 577 region->prev = space->regions_tail;
578 region->next = NULL;
579 *space->regions_tail = region;
580 space->regions_tail = &region->next;
581 region->space = space;
9a8c1c2f 582 }
5ced0fdf 583}
584
9a8c1c2f 585static struct region *
586find_region(void *ptr)
5ced0fdf 587{
588 struct cluster *cluster;
589 int cluster_chunk_num;
590 int chunk_num;
591 unsigned char delta;
592
9a8c1c2f 593 ptr = (void *) ((int) ptr & ~0x3);
5ced0fdf 594 if (ptr < heap_base || ptr >= heap_end)
595 return NULL;
596
597 cluster = block_table[BLOCK_NUMBER(ptr)];
598 if (cluster == NULL)
599 return NULL;
600
9a8c1c2f 601 if (ptr < (void *) cluster->first_region)
5ced0fdf 602 return NULL;
603
604 cluster_chunk_num = CHUNK_NUMBER(cluster->first_region);
605 chunk_num = CHUNK_NUMBER(ptr);
606
607 while (delta = cluster->region_offset[chunk_num - cluster_chunk_num])
608 chunk_num -= delta;
609
610 return CHUNK_ADDRESS(chunk_num);
611}
612\f
613/* Interface to std collector */
614static inline boolean
615from_space_p(lispobj obj)
616{
9a8c1c2f 617 struct region *region = find_region((void *) obj);
618
619 return (region != NULL && region->space == oldspace);
5ced0fdf 620}
621static inline boolean
622new_space_p(lispobj obj)
623{
9a8c1c2f 624 struct region *region = find_region((void *) obj);
625
626 return (region != NULL && region->space == newspace);
5ced0fdf 627}
628static inline boolean
629static_space_p(lispobj obj)
630{
9a8c1c2f 631 return (STATIC_SPACE_START < obj
632 && obj < SymbolValue(STATIC_SPACE_FREE_POINTER));
5ced0fdf 633}
634\f
635/* Predicate that returns true if an object is a pointer. */
636#undef POINTERP
637#define POINTERP(obj) Pointerp((obj)->header)
638
639/* Predicate that returns true if an object has been forwarded. */
640#define FORWARDED(obj) ((obj_t)(obj)->header == (obj_t)0x1)
641
642/* Returns the forwarding pointer for the given object. */
643#define FORWARDING_PTR(obj) ((lispobj)(obj)->data[0])
644
645/* Marks obj as forwarded to new */
646#define DEPOSIT_FORWARDING_PTR(obj,new) \
647 ((obj_t)(obj)->header = 0x1, (obj_t)(obj)->data[0] = (obj_t)new)
648
649/* Returns an obj_t for the object starting at addr */
650#define OBJECT_AT(addr) ((obj_t)(addr))
651
652/* Returns the size (in bytes) of obj. */
653#define OBJECT_SIZE(obj) (sizeOfObject((obj_t)obj)<<2)
654
655/* Scavenges an object. */
656#define SCAVENGE_OBJECT(obj) scavengex((lispobj*)obj)
657
658#if 0
659/* Makes a region of memory look like some kind of object. */
660#define NOTE_EMPTY(ptr,bytes) \
661 (((obj_t)ptr)->header = (((bytes+ALIGN_BYTES-1)>>ALIGN_BITS)<<8) | 1)
662#endif
663\f
664static unsigned long bytes_copied = 0;
9a8c1c2f 665
5ced0fdf 666# define HAVE_FASTCOPY
667#if defined HAVE_FASTCOPY
668#define COPYDUAL(a,b,c) fastcopy16(a,b,c)
9a8c1c2f 669void fastcopy16(void *, void *, size_t);
5ced0fdf 670#else
671#define COPYDUAL(a,b,c) memmove(a,b,c)
672#endif
673static inline lispobj
674copy(lispobj taggedobj)
675{
9a8c1c2f 676 obj_t source = (obj_t) PTR(taggedobj);
677 int nbytes = OBJECT_SIZE(source);
678
679 gc_assert(Pointerp(taggedobj));
680 gc_assert(!(nbytes & (ALIGN_BYTES - 1)));
681 {
682 int lowtag = LowtagOf(taggedobj);
683 obj_t newobj = cgc_alloc(nbytes);
5ced0fdf 684
9a8c1c2f 685 COPYDUAL(newobj, source, nbytes);
686 bytes_copied += nbytes;
687 return ((lispobj) newobj | lowtag);
688 }
689}
5ced0fdf 690\f
9a8c1c2f 691
5ced0fdf 692#define CEILING(x,y) (((x) + ((y) - 1)) & (~((y) - 1)))
693#define NWORDS(x,y) (CEILING((x),(y)) / (y))
694
695#define WEAK_POINTER_NWORDS \
696 CEILING((sizeof(struct weak_pointer) / sizeof(lispobj)), 2)
697static struct weak_pointer *weak_pointers;
5ced0fdf 698\f
9a8c1c2f 699
5ced0fdf 700/* Scavenging:
701 * CMU CL objects can be classified as BOXED, UNBOXED or other.
702 * Boxed objects have a header containing length and type followed
703 * by LENGTH tagged object descriptors which may be pointers.
704 * UNBOXED objects have a header but the data is other than
705 * tagged descriptors, such as floats, bignums, saps or code.
706 * Others (code) contain a mix of boxed and unboxed and some
707 * (cons) are like BOXED but without header. The scavenger needs
708 * to consider these different kinds of objects. I will use a
709 * table indexed by type to detect the simple cases of boxed
710 * or unboxed.
711 */
712#define IMMED_OR_LOSE(thing) gc_assert(sct[TypeOf(thing)].sc_kind == SC_IMMED)
9a8c1c2f 713static void scavenge_pointer(lispobj *);
5ced0fdf 714static int noise = 0;
715
9a8c1c2f 716typedef struct {
717 unsigned sc_kind:3, ve_l2bits:5;
718} OSC_t;
5ced0fdf 719
9a8c1c2f 720OSC_t
721make_OSC(int kind, int log2bits)
5ced0fdf 722{
9a8c1c2f 723 OSC_t thing;
724
725 thing.sc_kind = kind;
726 thing.ve_l2bits = log2bits;
727 return thing;
5ced0fdf 728}
9a8c1c2f 729
5ced0fdf 730#define SETSCT(indx,kind,logbits) sct[indx] = make_OSC(kind,logbits)
731#define SC_ISBOXED 1
732#define SC_UNBOXED 2
733#define SC_IMMED 3
734#define SC_POINTER 4
735#define SC_VECTOR 5
736#define SC_STRING 6
737#define SC_OTHER 7
738#define SC_LOSER 0
739static OSC_t sct[256];
740\f
9a8c1c2f 741int
742sizeOfObject(obj_t obj)
743{
744 int obj_type = TypeOf(obj->header);
745 OSC_t class = sct[obj_type];
746 struct vector *vector;
747 int length = 1;
748 int nwords = 1;
749
750 switch (class.sc_kind) {
751 case SC_POINTER:
752 case SC_IMMED:
753 return 1;
754 case SC_ISBOXED:
755 case SC_UNBOXED:
756 gc_assert(HeaderValue(obj->header) > 0);
757 nwords = length = HeaderValue(obj->header) + 1;
758 break;
759 case SC_STRING:
760 case SC_VECTOR:
5ced0fdf 761 {
9a8c1c2f 762 int log2bits = class.ve_l2bits;
763 int bits_per_el = 1 << log2bits;
764 int extra = 0;
765 int els_per_word = 1 << (5 - log2bits);
766
767 if (log2bits > 5) {
768 els_per_word = 1;
769 extra = log2bits - 5;
770 }
771 length = ((struct vector *) obj)->length;
772 length = fixnum_value(length); /* Zero Length IS valid */
773 length += (class.sc_kind == SC_STRING);
774 length <<= extra;
775 nwords = NWORDS(length, els_per_word);
776 nwords += 2; /* header + length */
5ced0fdf 777 }
9a8c1c2f 778 break;
779 case SC_OTHER:
780 switch (obj_type) {
781 case type_CodeHeader:
782 {
783 struct code *code;
784 int nheader_words, ncode_words;
785
786 code = (struct code *) obj;
787 ncode_words = fixnum_value(code->code_size);
788 nheader_words = HeaderValue(code->header);
789 nwords = ncode_words + nheader_words;
790 } break;
791 default:
792 fprintf(stderr, "GC losage: no size for other type %d\n",
793 obj_type);
794 gc_abort();
795 }
796 break;
797 default:
798 fprintf(stderr, "GC losage: no size for other type %d\n", obj_type);
5ced0fdf 799 gc_abort();
5ced0fdf 800 }
9a8c1c2f 801 return CEILING(nwords, 2);
5ced0fdf 802}
803\f
9a8c1c2f 804static void
b8d0dfaf 805init_osc(void)
5ced0fdf 806{
9a8c1c2f 807 int i;
808
809 for (i = 0; i < 256; i++)
810 SETSCT(i, SC_LOSER, 0);
811 for (i = 0; i < 32; i++) {
812 SETSCT(type_EvenFixnum | (i << 3), SC_IMMED, 0);
813 SETSCT(type_FunctionPointer | (i << 3), SC_POINTER, 0);
814 /* OtherImmediate0 */
815 SETSCT(type_ListPointer | (i << 3), SC_POINTER, 0);
816 SETSCT(type_OddFixnum | (i << 3), SC_IMMED, 0);
817 SETSCT(type_InstancePointer | (i << 3), SC_POINTER, 0);
818 /* OtherImmediate1 */
819 SETSCT(type_OtherPointer | (i << 3), SC_POINTER, 0);
5ced0fdf 820 }
9a8c1c2f 821 SETSCT(type_Bignum, SC_UNBOXED, 0);
822 SETSCT(type_Ratio, SC_ISBOXED, 0);
823 SETSCT(type_SingleFloat, SC_UNBOXED, 0);
824 SETSCT(type_DoubleFloat, SC_UNBOXED, 0);
1ce5fa7d 825#if defined type_ComplexSingleFloat
9a8c1c2f 826 SETSCT(type_ComplexSingleFloat, SC_UNBOXED, 0);
1ce5fa7d 827#endif
828#if defined type_ComplexDoubleFloat
9a8c1c2f 829 SETSCT(type_ComplexDoubleFloat, SC_UNBOXED, 0);
1ce5fa7d 830#endif
9a8c1c2f 831 SETSCT(type_Complex, SC_ISBOXED, 0);
832 SETSCT(type_SimpleArray, SC_ISBOXED, 0);
833 SETSCT(type_SimpleString, SC_STRING, 3);
834 SETSCT(type_SimpleBitVector, SC_VECTOR, 0);
835 SETSCT(type_SimpleVector, SC_VECTOR, 5);
836 SETSCT(type_SimpleArrayUnsignedByte2, SC_VECTOR, 1);
837 SETSCT(type_SimpleArrayUnsignedByte4, SC_VECTOR, 2);
838 SETSCT(type_SimpleArrayUnsignedByte8, SC_VECTOR, 3);
839 SETSCT(type_SimpleArrayUnsignedByte16, SC_VECTOR, 4);
840 SETSCT(type_SimpleArrayUnsignedByte32, SC_VECTOR, 5);
730a0430 841#if defined type_SimpleArraySignedByte8
9a8c1c2f 842 SETSCT(type_SimpleArraySignedByte8, SC_VECTOR, 3);
730a0430 843#endif
844#if defined type_SimpleArraySignedByte16
9a8c1c2f 845 SETSCT(type_SimpleArraySignedByte16, SC_VECTOR, 4);
730a0430 846#endif
847#if defined type_SimpleArraySignedByte30
9a8c1c2f 848 SETSCT(type_SimpleArraySignedByte30, SC_VECTOR, 5);
730a0430 849#endif
850#if defined type_SimpleArraySignedByte32
9a8c1c2f 851 SETSCT(type_SimpleArraySignedByte32, SC_VECTOR, 5);
730a0430 852#endif
9a8c1c2f 853 SETSCT(type_SimpleArraySingleFloat, SC_VECTOR, 5);
854 SETSCT(type_SimpleArrayDoubleFloat, SC_VECTOR, 6);
1ce5fa7d 855#if defined type_SimpleArrayComplexSingleFloat
9a8c1c2f 856 SETSCT(type_SimpleArrayComplexSingleFloat, SC_VECTOR, 6);
1ce5fa7d 857#endif
858#if defined type_SimpleArrayComplexDoubleFloat
9a8c1c2f 859 SETSCT(type_SimpleArrayComplexDoubleFloat, SC_VECTOR, 7);
1ce5fa7d 860#endif
9a8c1c2f 861 SETSCT(type_ComplexString, SC_ISBOXED, 0);
862 SETSCT(type_ComplexBitVector, SC_ISBOXED, 0);
863 SETSCT(type_ComplexVector, SC_ISBOXED, 0);
864 SETSCT(type_ComplexArray, SC_ISBOXED, 0);
865 SETSCT(type_CodeHeader, SC_OTHER, 0);
866 SETSCT(type_FunctionHeader, SC_OTHER, 0);
867 SETSCT(type_ClosureFunctionHeader, SC_OTHER, 0);
868 SETSCT(type_ReturnPcHeader, SC_OTHER, 0);
869 SETSCT(type_ClosureHeader, SC_ISBOXED, 0);
870 SETSCT(type_FuncallableInstanceHeader, SC_ISBOXED, 0);
871 SETSCT(type_ByteCodeFunction, SC_ISBOXED, 0);
872 SETSCT(type_ByteCodeClosure, SC_ISBOXED, 0);
873 SETSCT(type_DylanFunctionHeader, SC_ISBOXED, 0);
874
875 SETSCT(type_ValueCellHeader, SC_ISBOXED, 0);
876 SETSCT(type_SymbolHeader, SC_ISBOXED, 0);
877 SETSCT(type_BaseChar, SC_IMMED, 0);
878 SETSCT(type_Sap, SC_UNBOXED, 0);
879 SETSCT(type_UnboundMarker, SC_IMMED, 0);
880 SETSCT(type_WeakPointer, SC_UNBOXED, 0);
881 SETSCT(type_InstanceHeader, SC_ISBOXED, 0);
882 SETSCT(type_Fdefn, SC_ISBOXED, 0);
5ced0fdf 883}
884\f
9a8c1c2f 885static lispobj *scavenge(lispobj *, int);
886static lispobj *scavenge_object(lispobj *);
887static lispobj *scavengex(lispobj *);
5ced0fdf 888
9a8c1c2f 889static inline
890scavenge_1word_obj(lispobj * addr)
5ced0fdf 891{
9a8c1c2f 892 if (Pointerp(*addr)) {
893 if (*addr != NIL && *addr != T)
894 scavenge_pointer(addr);
895 } else
896 IMMED_OR_LOSE(*addr);
5ced0fdf 897}
898static int debug_code = 0;
899static int
9a8c1c2f 900scav_code_header(lispobj * where)
901{
902 lispobj object = *where;
903 struct code *code;
904 int i, nheader_words, ncode_words, nwords;
905 lispobj fheaderl;
906 struct function *fheaderp;
907
908 dprintf(0, ("code: %x %x\n", where, object));
909 code = (struct code *) where;
910 ncode_words = fixnum_value(code->code_size);
911 nheader_words = HeaderValue(object);
912 nwords = ncode_words + nheader_words;
913 nwords = CEILING(nwords, 2);
914 /* Scavenge the boxed section of the code data block */
915 /* NOTE: seeing a problem where the trace_table_offset slot
916 * is a bogus list pointer instead of a fixnum such that
917 * junk gets moved to newspace which causes problems later.
918 * Purify doesn't look at that slot (a bug?). Need
919 * to figure out how it happens. Ans: from loading top-level
920 * forms that init byte-compiled functions like "defun fcn".
921 * Fix the loader to not do this and save some space!
922 */
923 for (i = 1; i < nheader_words; i++)
924 scavenge_1word_obj(where + i);
925
926 /* Scavenge the boxed section of each function object in the
927 * code data block.
928 */
929 fheaderl = code->entry_points;
930 while (fheaderl != NIL) {
931 fheaderp = (struct function *) PTR(fheaderl);
932 gc_assert(TypeOf(fheaderp->header) == type_FunctionHeader);
933 scavenge_1word_obj(&fheaderp->name);
934 scavenge_1word_obj(&fheaderp->arglist);
935 scavenge_1word_obj(&fheaderp->type);
936 fheaderl = fheaderp->next;
937 }
938 return nwords;
5ced0fdf 939}
940\f
941#define RAW_ADDR_OFFSET (6*sizeof(lispobj) - type_FunctionPointer)
942#ifdef i386
9a8c1c2f 943static void
944scavenge_fcn_header(struct function *object)
945{
946 struct function *fheader = object;
947 unsigned long offset = HeaderValue(fheader->header) * 4;
948
949 /* Ok, we don't transport code here, but we do need to
950 * scavenge the constants and functions (of which this is one).
951 * This should be done as part of scavenging a live code object
952 * and we could now be trying to do CPR on a corpse!
953 */
954 struct code *code = (struct code *) ((unsigned long) fheader - offset);
955
956 gc_assert(TypeOf(fheader->header) == type_FunctionHeader);
957 scav_code_header((lispobj *) code);
5ced0fdf 958}
959\f
9a8c1c2f 960static int docode = 0; /* maybe not needed */
5ced0fdf 961static int
9a8c1c2f 962scav_closure_header(struct closure *closure)
963{
964 /* Could also be a funcallable_instance. The x86 port has the
965 * raw code address in the function slot, not a lisp object.
966 * However, the function object is a known distance from the code.
967 */
968 lispobj fun, fheader1;
969 int i, words;
970
971 gc_assert(ALIGNEDP(closure));
972 words = HeaderValue(closure->header);
973 fun = closure->function - RAW_ADDR_OFFSET;
974 /* This needs to be done to get at live code. I now have no
975 * way to know if this has already been scavenged so I assume
976 * that it hasn't. Code that has been seen by purify is
977 * supposed RO and doesn't (shouldn't) need to be looked at
978 * so this maybe really redundant.
979 *
980 * I have seen one case where FI was incomplete with function
981 * and lexenv slots == 0! Is this a bug?
982 *
983 * Update, it appears this is not needed. I will disable execution
984 * by default but leave the code here in case something breaks.
985 */
986 if (docode && static_space_p(closure->function))
987 scavenge_fcn_header((struct function *) PTR(fun));
988 else /* "normal" */
989 scavenge_1word_obj(&fun);
990
991 /* Now the boxed part of the closure header. */
992 for (i = 0; i < words - 1; i++)
993 scavenge_1word_obj(&closure->info[i]);
994
995 return CEILING(words + 1, 2);
996}
997static int fnoise = 0; /* experimental */
5ced0fdf 998static int
9a8c1c2f 999scav_fdefn(lispobj * where)
1000{
1001 /* I don't know if this is really needs to be special cased here.
1002 * raw_address should look like a fixnum and function is in static
1003 * space -- unless it is pointing to something in C like closure_tramp
1004 * or maybe undefined_tramp.
1005 * Actually function is in dynamic space if it is a byte-function!
1006 * Hmm, have seen case of function slot containing 1. Bug?
1007 */
1008 struct fdefn *fdefn = (struct fdefn *) where;
1009 int words = HeaderValue(fdefn->header);
1010 int fix_func =
1011
1012 ((char *) (fdefn->function + RAW_ADDR_OFFSET) == fdefn->raw_addr);
1013 scavenge_pointer(&fdefn->name);
1014 if (fnoise && LowtagOf(fdefn->function) == type_FunctionPointer) {
1015 obj_t fcnobj = (obj_t) PTR(fdefn->function);
1016
1017 switch (TypeOf(fcnobj->header)) {
1018 /* Can only be in static space and may need to scavenge code object.
1019 * Won't be noticed by scavenge_pointer().
1020 */
1021 case type_FunctionHeader:
1022 scavenge_fcn_header((struct function *) fcnobj);
1023 break;
1024 /* If in static space it was moved there by purify and we are
1025 * doing normal scavenge. Handle normally.
1026 */
1027 case type_FuncallableInstanceHeader:
1028 case type_ClosureHeader:
1029 scavenge_pointer(&fdefn->function);
1030 break;
1031 default:
1032 dprintf(1, ("Ignoring bogus value %x for fdefn function.\n",
1033 *fcnobj));
5ced0fdf 1034 }
9a8c1c2f 1035 } else
1036 /* NIL for undefined function? */
1037 scavenge_pointer(&fdefn->function);
5ced0fdf 1038
9a8c1c2f 1039 if (fix_func) { /* This shouldn't be needed yet. */
1040 fdefn->raw_addr = (char *) (fdefn->function + RAW_ADDR_OFFSET);
5ced0fdf 1041 }
9a8c1c2f 1042 return sizeof(struct fdefn) / sizeof(lispobj);
5ced0fdf 1043}
1044
1045#endif
1046\f
1047/* List scavenger taken from gc.c and adapted */
1048
9a8c1c2f 1049static FILE *log = NULL;
1050static int scav_ro = 0; /* for testing */
1051static int debug = 0;
1052static void *trapaddr = 0;
1053void
1054check_trap(void *addr)
5ced0fdf 1055{
9a8c1c2f 1056 fprintf(stderr, "Trapped @ %x\n", addr);
5ced0fdf 1057}
1058
1059static lispobj
1060trans_list(lispobj object)
1061{
9a8c1c2f 1062 lispobj new_list_pointer;
1063 struct cons *cons, *new_cons;
1064 int n = 0;
1065 lispobj cdr;
1066
1067 cons = (struct cons *) PTR(object);
1068
1069 /* copy 'object' */
1070 new_cons = (struct cons *) cgc_alloc(sizeof(struct cons));
1071
1072 new_cons->car = cons->car;
1073 new_cons->cdr = cons->cdr; /* updated later */
1074 new_list_pointer = (lispobj) new_cons | LowtagOf(object);
1075 bytes_copied += sizeof(struct cons);
1076
5ced0fdf 1077#if 0
9a8c1c2f 1078 if (scav_ro > 1)
1079 check_trap(object);
1080 if (log)
1081 fprintf(log, "( %d cons @ #x%x -> #x%x car #x%x)\n",
1082 n++, cons, new_cons, new_cons->car);
5ced0fdf 1083#endif
9a8c1c2f 1084 /* Grab the cdr before it is clobbered */
1085 cdr = cons->cdr;
1086 /* Set forwarding pointer (clobbers start of list). */
1087 DEPOSIT_FORWARDING_PTR((obj_t) cons, new_list_pointer);
1088
1089 /* Try to linearize the list in the cdr direction to help reduce paging. */
1090 while (1) {
1091 lispobj new_cdr;
1092 struct cons *cdr_cons, *new_cdr_cons;
1093
1094 if (LowtagOf(cdr) != type_ListPointer || !from_space_p(cdr)
1095 || FORWARDED((obj_t) PTR(cdr)))
1096 break;
1097
1098 cdr_cons = (struct cons *) PTR(cdr);
1099
1100 /* copy 'cdr' */
1101 new_cdr_cons = (struct cons *) cgc_alloc(sizeof(struct cons));
1102
1103 new_cdr_cons->car = cdr_cons->car;
1104 new_cdr_cons->cdr = cdr_cons->cdr;
1105 new_cdr = (lispobj) new_cdr_cons | LowtagOf(cdr);
1106 bytes_copied += sizeof(struct cons);
5ced0fdf 1107
5ced0fdf 1108#if 0
9a8c1c2f 1109 if (scav_ro > 1)
1110 check_trap(object);
1111 if (log)
1112 fprintf(log, "( %d cons @ #x%x -> #x%x car #x%x)\n",
1113 n++, cdr_cons, new_cdr_cons, cdr_cons->car);
5ced0fdf 1114#endif
9a8c1c2f 1115 /* Grab the cdr before it is clobbered */
1116 cdr = cdr_cons->cdr;
1117 /* Set forwarding pointer */
1118 DEPOSIT_FORWARDING_PTR((obj_t) cdr_cons, new_cdr);
1119
1120 /* Update the cdr of the last cons copied into new
1121 * space to keep the newspace scavenge from having to do it.
1122 */
1123 new_cons->cdr = new_cdr;
1124
1125 new_cons = new_cdr_cons;
1126 }
1127
1128 return new_list_pointer;
5ced0fdf 1129}
1130\f
1131/* Weak Pointers */
9a8c1c2f 1132static int weak_noise = 0;
1133static int do_weak = 1;
5ced0fdf 1134static int
9a8c1c2f 1135scav_weak_pointer(lispobj * where)
5ced0fdf 1136{
9a8c1c2f 1137 struct weak_pointer *wp = weak_pointers;
5ced0fdf 1138
9a8c1c2f 1139 /* Push the weak pointer onto the list of weak pointers.
1140 * Do I have to watch for duplicates? Originally this was
1141 * part of trans_weak_pointer but that didn't work in the
1142 * case where the WP was in a promoted region.
1143 */
1144
1145 while (wp != NULL) {
1146 if (wp == (struct weak_pointer *) where)
1147 break;
1148 wp = wp->next;
5ced0fdf 1149 }
9a8c1c2f 1150 if (wp == NULL) {
1151 wp = (struct weak_pointer *) where;
1152 wp->next = weak_pointers;
1153 weak_pointers = wp;
1154 if (!do_weak)
1155 scavenge_1word_obj(&wp->value);
5ced0fdf 1156 }
1157
9a8c1c2f 1158 /* Do not let GC scavenge the value slot of the weak pointer
1159 * (that is why it is a weak pointer).
1160 */
5ced0fdf 1161
9a8c1c2f 1162 return WEAK_POINTER_NWORDS;
5ced0fdf 1163}
9a8c1c2f 1164
1165void
1166scan_weak_pointers(void)
1167{
1168 struct weak_pointer *wp;
1169
1170 for (wp = weak_pointers; wp != NULL; wp = wp->next) {
1171 lispobj value = wp->value;
1172 obj_t obj = (obj_t) PTR(value);
1173 lispobj first, *first_pointer;
1174
1175 dprintf(weak_noise, ("Weak pointer at 0x%08x\n", (unsigned long) wp));
1176 dprintf(weak_noise, ("Value: 0x%08x\n", (unsigned long) value));
1177
1178 if (Pointerp(value) && from_space_p(value)) {
1179 /* Now, we need to check if the object has been forwarded.
1180 * If it has been, the weak pointer is still good and needs
1181 * to be updated. Otherwise, the weak pointer needs to be nil'ed out.
1182 */
1183
1184 if (FORWARDED(obj))
1185 wp->value = FORWARDING_PTR(obj);
1186 else { /* break it */
1187 dprintf(weak_noise, ("Broken.\n"));
1188 wp->value = NIL;
1189 wp->broken = T;
5ced0fdf 1190 }
1191 }
1192 }
1193}
1194\f
1195static int
9a8c1c2f 1196scavenge_random_object(lispobj * addr)
5ced0fdf 1197{
9a8c1c2f 1198 lispobj header = *addr;
1199 int count = 1;
1200
1201 dprintf(noise > 1, ("soi: %x @ %x\n", header, addr));
5ced0fdf 1202#if 0
9a8c1c2f 1203 if (trapaddr == addr)
1204 check_trap(addr);
5ced0fdf 1205#endif
9a8c1c2f 1206 gc_assert(ALIGNEDP(addr));
5ced0fdf 1207
9a8c1c2f 1208 switch (TypeOf(header)) {
1209 case type_SimpleVector:
1210 {
1211 struct vector *v = (struct vector *) addr;
1212 int i, n = fixnum_value(v->length);
1213
1214 if (HeaderValue(v->header) == subtype_VectorValidHashing)
1215 v->header =
1216 (subtype_VectorMustRehash << type_Bits) |
1217 type_SimpleVector;
1218 /* Look at each of the vector elements which can be any lisp object. */
1219 for (i = 0; i < n; i++)
1220 scavenge_1word_obj(&v->data[i]);
1221 count = CEILING(n + 2, 2);
1222 }
1223 break;
1224 case type_CodeHeader:
1225 count = scav_code_header(addr);
1226 break;
1227 /* We should never hit any of these, 'cause they occur buried in
1228 * the middle of code objects (and handled by the code just above).
1229 */
1230 case type_ClosureFunctionHeader:
1231 case type_ReturnPcHeader:
1232 gc_abort();
1233
1234 /* Except while looking at an fdefn and wanting to ensure
1235 * code object is looked at.
1236 */
1237 case type_FunctionHeader:
1238 scavenge_fcn_header((struct function *) addr);
1239 break;
5ced0fdf 1240#if defined i386
9a8c1c2f 1241 case type_ClosureHeader:
1242 case type_FuncallableInstanceHeader:
1243 case type_ByteCodeFunction:
1244 case type_ByteCodeClosure:
1245 case type_DylanFunctionHeader:
1246 count = scav_closure_header((struct closure *) addr);
1247 break;
5ced0fdf 1248#endif
9a8c1c2f 1249 case type_WeakPointer:
1250 count = scav_weak_pointer(addr);
1251 break;
1252 case type_Fdefn:
1253 /* We have to handle fdefn objects specially, so we can fix
1254 * up the raw function address.
1255 */
1256 count = scav_fdefn(addr);
1257 break;
1258 default:
5ced0fdf 1259 {
9a8c1c2f 1260 OSC_t class = sct[TypeOf(header)];
1261
1262 switch (class.sc_kind) {
1263 case SC_IMMED:
1264 count = 1;
1265 break;
1266 case SC_ISBOXED:
1267 {
1268 int i, words = 1 + HeaderValue(header);
1269
1270 for (i = 1; i < words; i++)
1271 scavenge_1word_obj(addr + i);
1272 count = CEILING(words, 2);
1273 }
1274 break;
1275 case SC_UNBOXED:
1276 case SC_STRING:
1277 case SC_VECTOR: /* simple vector handled above */
1278 count = sizeOfObject((obj_t) addr);
1279 break;
1280 default:
1281 gc_abort();
1282 }
5ced0fdf 1283 }
5ced0fdf 1284 }
9a8c1c2f 1285 return count;
5ced0fdf 1286}
1287\f
9a8c1c2f 1288static void
1289logcopy(lispobj * addr, lispobj tagged, int hdr, lispobj to)
5ced0fdf 1290{
9a8c1c2f 1291 if (log) {
1292 int kind = TypeOf(hdr);
1293 int words = sizeOfObject((obj_t) PTR(tagged));
1294
1295 fprintf(log, "(copy #x%x @ #x%x (#x%x %d) to #x%x)\n",
1296 tagged, addr, kind, words, to);
5ced0fdf 1297 }
1298}
1299static void
9a8c1c2f 1300maybe_transport(lispobj * addr, lispobj tagged, struct region *region)
5ced0fdf 1301{
9a8c1c2f 1302 obj_t obj = (obj_t) PTR(tagged);
1303
1304 gc_assert(ALIGNEDP(obj));
1305 gc_assert(Pointerp(tagged));
1306 gc_assert((void *) region != (void *) obj);
5ced0fdf 1307#if 0
9a8c1c2f 1308 if ((void *) obj == (void *) trapaddr)
1309 check_trap(obj);
5ced0fdf 1310#endif
9a8c1c2f 1311 if (region->contains_small_objects) {
1312 lispobj new = copy(tagged);
1313
5ced0fdf 1314#if 0
9a8c1c2f 1315 if (scav_ro > 1) /* debugging in RO space */
1316 check_trap(obj);
5ced0fdf 1317#endif
1318#if defined GOOSE_CHASE
9a8c1c2f 1319 if (TypeOf(obj->header) == type_Fdefn) {
1320 struct fdefn *fdefn = (struct fdefn *) PTR(new);
1321
1322 if (fdefn->function < STATIC_SPACE_START)
1323 check_trap(obj);
5ced0fdf 1324 }
1325#endif
9a8c1c2f 1326 dprintf(0, ("copy %x @ %x (%x) to %x\n",
1327 tagged, addr, TypeOf(obj->header), new));
1328 logcopy(addr, tagged, obj->header, new);
1329 DEPOSIT_FORWARDING_PTR(obj, new);
1330 *addr = new;
1331 } else {
1332 move_to_newspace(region);
1333 dprintf(0, ("move %x\n", region));
5ced0fdf 1334 }
1335}
1336\f
1337void
9a8c1c2f 1338scavenge_pointer(lispobj * addr)
5ced0fdf 1339{
9a8c1c2f 1340 lispobj taggedobj = *addr; /* descriptor */
1341 obj_t obj = (obj_t) PTR(taggedobj); /* pointer to object */
1342
1343 gc_assert(Pointerp(taggedobj));
5ced0fdf 1344#if 0
9a8c1c2f 1345 if (addr == trapaddr)
1346 check_trap(addr);
1347 if (obj == trapaddr)
1348 check_trap(obj);
5ced0fdf 1349#endif
9a8c1c2f 1350 /* optimize out common static pointers */
1351 if (taggedobj != NIL && taggedobj != T) {
1352 struct region *region = find_region(obj);
1353
1354 /* Only interested in pointers into oldspace */
1355 if (region && region->space == oldspace) {
1356 if (FORWARDED(obj))
1357 *addr = FORWARDING_PTR(obj);
1358 else
1359 switch (LowtagOf(taggedobj)) {
1360 case type_ListPointer:
1361 dprintf(noise > 1, ("ListPointer @ %x...\n", addr));
1362 *addr = trans_list(taggedobj);
1363 dprintf(noise > 1, ("... -> %x\n", addr));
1364 break;
1365 case type_FunctionPointer:
1366 switch (TypeOf(obj->header)) {
1367 case type_ClosureHeader:
1368 case type_FuncallableInstanceHeader:
1369 case type_ByteCodeFunction:
1370 case type_ByteCodeClosure:
1371 case type_DylanFunctionHeader:
1372 maybe_transport(addr, taggedobj, region);
1373 break;
1374 default:
1375 gc_abort();
1376 }
1377 break;
1378 case type_InstancePointer:
1379 case type_OtherPointer:
1380 maybe_transport(addr, taggedobj, region);
1381 break;
5ced0fdf 1382 default:
9a8c1c2f 1383 /* It was a pointer, but not one of them? */
1384 gc_abort();
1385 }
5ced0fdf 1386 }
1387 }
1388}
1389\f
1390
9a8c1c2f 1391static lispobj *
1392scavenge(lispobj * addr, int ptrs)
5ced0fdf 1393{
9a8c1c2f 1394 /* addr points to an aligned 32-bit word in some space. */
1395 struct region *region;
1396 lispobj *end = addr + ptrs;
1397 lispobj obj;
1398
1399 while (addr < end) {
1400 int count = 1;
1401
1402 obj = *addr; /* the lisp object */
5ced0fdf 1403#if 0
9a8c1c2f 1404 if (trapaddr == addr)
1405 check_trap(addr); /* gdb breakpoint */
5ced0fdf 1406#endif
9a8c1c2f 1407 if (Pointerp(obj)) /* lowtag odd */
1408 scavenge_pointer(addr);
1409 else if (obj & 0x3)
1410 /* some other immediate */
1411 /*
1412 * Some random header. Process some type dependent number
1413 * of words. May still be inside object after call and the
1414 * next cell can be any lisp object. We can either recurse
1415 * by calling scavenge here or let the caller do it.
1416 */
1417 count = scavenge_random_object(addr);
1418 else
1419 IMMED_OR_LOSE(obj);
1420
1421 addr += count;
5ced0fdf 1422 }
9a8c1c2f 1423 return addr;
5ced0fdf 1424}
1425\f
1426static void
9a8c1c2f 1427scavenge_cons(lispobj * where)
1428{
1429 /* Scavenge a two-word space */
1430 scavenge_1word_obj(where + 0); /* car */
1431 scavenge_1word_obj(where + 1); /* cdr */
1432}
1433static lispobj *
1434scavenge_object(lispobj * start)
1435{
1436 int length = sizeOfObject((obj_t) start);
1437 int words = scavenge_random_object(start);
1438
1439 gc_assert(length == words);
1440 return start + length;
1441}
1442static lispobj *
1443scavengex(lispobj * obj)
1444{
1445 /* Thing at this location is one of:
1446 * a - basic object with header.
1447 * b - cons object (no header).
1448 * so that the starting and ending addresses are aligned.
1449 */
1450 gc_assert(ALIGNEDP(obj));
1451 {
1452 lispobj first_word = *obj;
1453 OSC_t sc = sct[TypeOf(first_word)];
1454
1455 if (Pointerp(first_word) || sc.sc_kind == SC_IMMED) { /* Must be a cons object or unused space */
1456 scavenge_cons((lispobj *) obj);
1457 return obj + 2;
1458 } else { /* Must be a complex object with header */
1459 lispobj *next = scavenge_object(obj);
1460
1461 return next;
1462 }
1463 }
5ced0fdf 1464}
1465\f
1466static void
9a8c1c2f 1467scavenge_space(lispobj * where, int words, char *name)
1468{
1469 int allocated = bytes_allocated;
1470 lispobj *end = where + words;
1471 lispobj *last;
1472
1473 bytes_copied = 0;
1474 if (name)
1475 dprintf(noise, (" %s", name));
1476 while (where < end) {
1477 last = where;
1478 where = scavengex(last);
5ced0fdf 1479 }
9a8c1c2f 1480 gc_assert(where == end);
1481 if (name)
1482 dprintf(noise, (" %ld bytes moved, %ld bytes allocated.\n",
1483 bytes_copied, bytes_allocated - allocated));
5ced0fdf 1484}
1485\f
1486static int boxed_registers[] = BOXED_REGISTERS;
1487static void
9a8c1c2f 1488preserve_interrupt_context(os_context_t * context)
5ced0fdf 1489{
9a8c1c2f 1490 int i;
1491
1492 /* Check each boxed register for a valid pointer and promote
1493 * its region when found.
1494 */
1495 for (i = 0; i < (sizeof(boxed_registers) / sizeof(int)); i++) {
1496 int index = boxed_registers[i];
1497 lispobj foo = SC_REG(context, index);
1498 struct region *region = find_region((void *) foo);
1499
1500 if (region && region->space == oldspace)
1501 move_to_newspace(region);
5ced0fdf 1502 }
1503}
9a8c1c2f 1504static void
1505preserve_interrupt_contexts(void)
5ced0fdf 1506{
9a8c1c2f 1507 int i, index;
1508 os_context_t *context;
5ced0fdf 1509
9a8c1c2f 1510 index = fixnum_value(SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX));
1511 dprintf(noise, ("Number of active contexts: %d\n", index));
5ced0fdf 1512
9a8c1c2f 1513 for (i = 0; i < index; i++) {
1514 context = lisp_interrupt_contexts[i];
1515 preserve_interrupt_context(context);
5ced0fdf 1516 }
1517}
5ced0fdf 1518\f
9a8c1c2f 1519
1520static void
b8d0dfaf 1521flip_spaces(void)
5ced0fdf 1522{
1523 struct space *temp = oldspace;
9a8c1c2f 1524
5ced0fdf 1525 oldspace = newspace;
1526 newspace = temp;
1527}
1528
1529/* There should be no lisp objects on the C stack so will limit search
1530 * to just the assigned lisp stack area.
1531 */
1532#if defined i386
44a8f0c7 1533#define BOS (CONTROL_STACK_START+control_stack_size) /* x86-validate.h */
5ced0fdf 1534/* Traverse stack in same direction as it was loaded to try and
1535 * preserve original ordering of pages. Good for the VM system I hope.
9a8c1c2f 1536 */
5ced0fdf 1537#define ACROSS_STACK(var) var=(void**)BOS-1; var > (void**)&var; var--
1538#endif
1539
9a8c1c2f 1540void
1541preserve_pointer(void *ptr)
5ced0fdf 1542{
9a8c1c2f 1543 if (ptr > heap_base && ptr < heap_end) {
1544 struct region *region = find_region(ptr);
1545
1546 if (region != NULL && region->space == oldspace) {
1547 dprintf(0, ("move %x\n", ptr));
1548 move_to_newspace(region);
5ced0fdf 1549 }
1550 }
1551}
2b063326 1552
9a8c1c2f 1553static void
b8d0dfaf 1554preserve_stack(void)
2b063326 1555{
9a8c1c2f 1556 void **addr; /* auto var is current TOS */
1557
1558 for (ACROSS_STACK(addr))
1559 preserve_pointer(*addr);
2b063326 1560}
1561
1562#ifdef CONTROL_STACKS
1563/* Scavenge the thread stack conservative roots. */
9a8c1c2f 1564void
1565scavenge_thread_stacks(void)
1566{
1567 lispobj thread_stacks = SymbolValue(CONTROL_STACKS);
1568 int type = TypeOf(thread_stacks);
1569
1570 if (LowtagOf(thread_stacks) == type_OtherPointer) {
1571 struct vector *vector = (struct vector *) PTR(thread_stacks);
1572 int length, i;
1573
1574 if (TypeOf(vector->header) != type_SimpleVector)
1575 return;
1576 length = fixnum_value(vector->length);
1577 for (i = 0; i < length; i++) {
1578 lispobj stack_obj = vector->data[i];
1579
1580 if (LowtagOf(stack_obj) == type_OtherPointer) {
1581 struct vector *stack = (struct vector *) PTR(stack_obj);
1582 int length, j;
1583
1584 if (TypeOf(stack->header) != type_SimpleArrayUnsignedByte32)
1585 return;
1586 length = fixnum_value(stack->length);
1587 /* fprintf(stderr,"Scavenging control stack %d of length %d words\n",
1588 i,length); */
1589 for (j = 0; j < length; j++)
1590 preserve_pointer((void *) stack->data[j]);
1591 }
1592 }
2b063326 1593 }
2b063326 1594}
1595#endif
1596
9a8c1c2f 1597static void
b8d0dfaf 1598zero_stack(void)
5ced0fdf 1599{
9a8c1c2f 1600 /* This is a bit tricky because we don't want to zap any
1601 * stack frames between here and the call to mmap. For now,
1602 * lets just be slow and careful.
1603 */
1604 long *p, *q;
1605 os_vm_address_t base = (os_vm_address_t) CONTROL_STACK_START;
1606 os_vm_size_t size = (char *) &base - (char *) base;
1607
5ced0fdf 1608#if 0
9a8c1c2f 1609 cgc_zero(base, size);
5ced0fdf 1610#else
9a8c1c2f 1611 p = (long *) base;
1612 q = (long *) &size;
1613 while (p < q)
1614 *p++ = 0;
5ced0fdf 1615#endif
9a8c1c2f 1616
5ced0fdf 1617}
1618\f
1619#if defined STATIC_BLUE_BAG
9a8c1c2f 1620static int fast_static = 1;
1621static void
b8d0dfaf 1622scavenge_static(void)
9a8c1c2f 1623{
1624 /* Static space consists of alternating layers of
1625 * code objects that refer to read-only space (from purify),
1626 * static non-code objects that need looking at, and
1627 * newly loaded code objects that refer to dynamic space.
1628 * The number of these areas depends on how many times purify
1629 * ran while loading the system image. I will extend purify
1630 * to maintain a list of collectable areas and use that list
1631 * here to avoid scanning read-only code sections.
1632 */
1633 lispobj *ss0 = (lispobj *) PTR(NIL);
1634 lispobj *ssa = (lispobj *) (PTR(STATIC_BLUE_BAG));
1635 lispobj *ssz = (lispobj *) SymbolValue(STATIC_SPACE_FREE_POINTER);
1636 lispobj bag = SymbolValue(STATIC_BLUE_BAG);
1637 lispobj *end = NULL;
1638
1639 ssa += sizeOfObject(OBJECT_AT(ssa)); /* Genesis modifies plist entry */
1640 if (fast_static) {
1641 scavenge_space(ss0, ssa - ss0, "Static0");
1642 if (bag != NIL && LowtagOf(bag) == type_ListPointer) {
1643 char sbuf[128];
1644 struct cons *cons = (struct cons *) PTR(bag);
1645
1646 while (LowtagOf(cons->car) == type_ListPointer) {
1647 struct cons *pair = (struct cons *) PTR(cons->car);
1648 lispobj *ss1 = (lispobj *) pair->car;
1649 lispobj *ss2 = (lispobj *) pair->cdr;
1650
1651 if (end == NULL)
1652 end = ss2;
1653 sprintf(sbuf, "Static %x %d", ss1, ss2 - ss1);
1654 scavenge_space(ss1, ss2 - ss1, sbuf);
1655 if (cons->cdr != NIL && LowtagOf(cons->cdr) == type_ListPointer)
1656 cons = (struct cons *) PTR(cons->cdr);
1657 else
1658 break;
5ced0fdf 1659 }
1660 }
9a8c1c2f 1661 if (end != NULL)
1662 scavenge_space(end, ssz - end, "Static");
1663 } else
1664 (scavenge_space(ss0, ssz - ss0, "Static-All"));
5ced0fdf 1665}
1666#endif
1667\f
9a8c1c2f 1668static void
b8d0dfaf 1669scavenge_roots(void)
9a8c1c2f 1670{
1671 /* So what should go here?
1672 * When cgc starts up after purify/save all live objects
1673 * are in read-only or static space, and anything in RO
1674 * can point only to RO or STATIC and can't be changed.
1675 * Anything in STATIC is subject to change (but not move).
1676 * . not read-only-space (probably most of the roots here)
1677 * . static-space (all compiled code at least)
1678 * . binding-stack
1679 * . weak-pointers
1680 ? do I allow GC from interrupt?)
1681 * . interrupt-context (regs same as stack)
1682 ****
1683 * Well, it turns out that RO space ain't exactly that as
1684 * somehow apparently cached 'compact-info-environment' stuff
1685 * modifies at least 2 locations in RO space. There is a note
1686 * in globaldb.lisp that alludes to this and provides a post GC
1687 * hook to blow the cache. Not a problem if gc is called from
1688 * the lisp wrapper. UPDATE: Found purify bug which forced
1689 * boxed vectors into RO. This may be what led to above.
1690 *
1691 */
1692 lispobj *rs0 = (lispobj *) READ_ONLY_SPACE_START;
1693 lispobj *rsz = (lispobj *) SymbolValue(READ_ONLY_SPACE_FREE_POINTER);
1694 lispobj *ss0 = (lispobj *) STATIC_SPACE_START;
1695 lispobj *ssz = (lispobj *) SymbolValue(STATIC_SPACE_FREE_POINTER);
1696 lispobj *bs0 = (lispobj *) BINDING_STACK_START;
1697 lispobj *bsz = (lispobj *) SymbolValue(BINDING_STACK_POINTER);
1698
1699 if (scav_ro) {
1700 scav_ro++;
1701 scavenge_space(rs0, rsz - rs0, "RO");
1702 scav_ro--;
5ced0fdf 1703 }
9a8c1c2f 1704 scavenge_static();
1705 scavenge_space(bs0, bsz - bs0, "Binding Stack");
5ced0fdf 1706
9a8c1c2f 1707 dprintf(noise, ("Interrupt handlers (%u bytes) ...\n",
1708 sizeof(interrupt_handlers)));
5ced0fdf 1709
9a8c1c2f 1710 scavenge((lispobj *) interrupt_handlers,
1711 sizeof(interrupt_handlers) / sizeof(lispobj));
5ced0fdf 1712
1713}
1714\f
9a8c1c2f 1715static void
b8d0dfaf 1716scavenge_newspace(void)
9a8c1c2f 1717{
1718 /* Scavenge is going to start at the beginning of newspace which
1719 * is presumed to have some "root" object pointers lying about due
1720 * to promoting regions that may be aimed at by stack resident pointers,
1721 * copied small objects from scavenge_roots(), or promoted large_object
1722 * regions. Scavenge() will flush out more copied objects/promoted
1723 * regions that will get added to the end of newspace and eventually
1724 * scanned by this code -- until all referenced things (and maybe some
1725 * extra dead stuff) have been examined. At the end of this loop anything
1726 * in oldspace is trash.
1727 */
5ced0fdf 1728 struct region *current;
9a8c1c2f 1729
5ced0fdf 1730 current = newspace->regions;
1731
9a8c1c2f 1732 while (current != NULL) {
1733 if (current->contains_small_objects) {
1734 void *obj = (char *) current + REGION_OVERHEAD;
1735 void *end = (char *) current + current->num_chunks * CHUNK_BYTES;
1736
5ced0fdf 1737 while (obj < end)
9a8c1c2f 1738 obj = SCAVENGE_OBJECT(OBJECT_AT(obj));
5ced0fdf 1739 gc_assert(obj == end);
9a8c1c2f 1740 } else
1741 SCAVENGE_OBJECT(OBJECT_AT(((char *) current + REGION_OVERHEAD)));
5ced0fdf 1742 current = current->next;
9a8c1c2f 1743 }
5ced0fdf 1744}
1745\f
9a8c1c2f 1746static void
b8d0dfaf 1747free_oldspace(void)
5ced0fdf 1748{
1749 struct region *region, *next;
9a8c1c2f 1750
5ced0fdf 1751 chunks_freed = 0;
9a8c1c2f 1752 for (region = oldspace->regions; region != NULL; region = next) {
5ced0fdf 1753 gc_assert(region->space != newspace);
1754 next = region->next;
1755 free_region(region);
9a8c1c2f 1756 }
5ced0fdf 1757 oldspace->alloc_ptr = NULL;
1758 oldspace->alloc_end = NULL;
1759 oldspace->regions = NULL;
1760 oldspace->regions_tail = &oldspace->regions;
1761}
1762\f
9a8c1c2f 1763static void
1764verify_space(lispobj * start, size_t words)
5ced0fdf 1765{
9a8c1c2f 1766 while (words > 0) {
1767 size_t count = 1;
1768 lispobj thing = *(lispobj *) start;
1769
1770 if (Pointerp(thing)) {
1771 struct region *region = find_region((void *) thing);
1772
1773 if (region && region->space == NULL)
1774 fprintf(stderr, "Ptr %x @ %x sees Junk\n", thing, start);
1775 } else if (thing & 0x3) {
1776 obj_t obj = (obj_t) start;
1777
1778 switch (TypeOf(obj->header)) {
5ced0fdf 1779 case type_CodeHeader:
9a8c1c2f 1780 {
1781 lispobj object = *start;
1782 struct code *code;
1783 int nheader_words, ncode_words, nwords;
1784 lispobj fheaderl;
1785 struct function *fheaderp;
1786
1787 code = (struct code *) start;
1788 ncode_words = fixnum_value(code->code_size);
1789 nheader_words = HeaderValue(object);
1790 nwords = ncode_words + nheader_words;
1791 nwords = CEILING(nwords, 2);
1792 /* Scavenge the boxed section of the code data block */
1793 verify_space(start + 1, nheader_words - 1);
1794
1795 /* Scavenge the boxed section of each function object in the
1796 * code data block.
1797 */
1798 fheaderl = code->entry_points;
1799 while (fheaderl != NIL) {
1800 fheaderp = (struct function *) PTR(fheaderl);
1801 gc_assert(TypeOf(fheaderp->header) ==
1802 type_FunctionHeader);
1803 verify_space(&fheaderp->name, 1);
1804 verify_space(&fheaderp->arglist, 1);
1805 verify_space(&fheaderp->type, 1);
1806 fheaderl = fheaderp->next;
1807 }
1808 count = nwords;
1809 break;
5ced0fdf 1810 }
5ced0fdf 1811 default:
9a8c1c2f 1812 {
1813 OSC_t class = sct[TypeOf(obj->header)];
1814
1815 switch (class.sc_kind) {
1816 case SC_ISBOXED:
1817 case SC_IMMED:
1818 count = 1;
1819 break;
1820 case SC_UNBOXED:
1821 case SC_STRING:
1822 case SC_VECTOR:
1823 count = sizeOfObject((obj_t) start);
1824 break;
1825 default:
1826 gc_abort();
1827 }
5ced0fdf 1828 break;
9a8c1c2f 1829 }
1830 }
1831 }
1832 start += count;
1833 words -= count;
5ced0fdf 1834 }
1835}
1836\f
1837/* For debug/test only. */
9a8c1c2f 1838static void
b8d0dfaf 1839verify_gc(void)
5ced0fdf 1840{
9a8c1c2f 1841 lispobj *rs0 = (lispobj *) READ_ONLY_SPACE_START;
1842 lispobj *rsz = (lispobj *) SymbolValue(READ_ONLY_SPACE_FREE_POINTER);
1843 lispobj *ss0 = (lispobj *) STATIC_SPACE_START;
1844 lispobj *ssz = (lispobj *) SymbolValue(STATIC_SPACE_FREE_POINTER);
1845 lispobj *bs0 = (lispobj *) BINDING_STACK_START;
1846 lispobj *bsz = (lispobj *) SymbolValue(BINDING_STACK_POINTER);
1847 lispobj *cs0 = (lispobj *) & rs0;
1848 lispobj *csz = (lispobj *) BOS;
1849
1850 /* can't check stack easily because there may be non-valid
1851 * objects there (thats why we're doing this cgc stuff). In
1852 * particular there are raw return addresses which can be very
1853 * descriptorish looking!!!
1854
1855 verify_space(cs0, csz-cs0);
1856 */
1857 verify_space(rs0, rsz - rs0);
1858 verify_space(ss0, ssz - ss0);
1859 verify_space(bs0, bsz - bs0);
1860}
1861static void
1862fixup_regions(struct region *region)
1863{
1864 do {
1865 lispobj header = (lispobj) OBJECT_AT(region)->header;
1866
1867 if (static_space_p(header)) {
1868 /* Purify thought this header was a cons? Why? */
1869 struct cons *wrong = (struct cons *) PTR(header);
1870 struct cons *fixme = (struct cons *) region;
1871
1872 dprintf(1, ("\n--Fixing region header @ %x.", region));
1873 fixme->car = wrong->car; /* restore region header */
1874 fixme->cdr = wrong->cdr; /* restore prev pointer */
1875 wrong->car = wrong->cdr = 0;
406351a7 1876 }
9a8c1c2f 1877 region = region->next;
406351a7 1878 }
9a8c1c2f 1879 while (region != NULL);
406351a7 1880}
1881
9a8c1c2f 1882static void
1883post_purify_fixup(struct space *space)
1884{
1885 /* Purify may have messed up the region headers. This can happen
1886 * if there is a dead list pointer on the stack that now aims
1887 * at a region header (previously was valid memory). Purify attempts
1888 * to at least check for a valid object header but loses with lists.
1889 * This hack recovers the correct values and keeps us going. Can
1890 * this occur with other dead objects?
1891 */
1892 if (large_region_free_list)
1893 fixup_regions(large_region_free_list);
1894 if (small_region_free_list)
1895 fixup_regions(small_region_free_list);
1896 fixup_regions(space->regions);
406351a7 1897}
5ced0fdf 1898\f
9a8c1c2f 1899
1900static int dolog = 0; /* log copy ops to file */
1901static int dover = 0; /* hunt pointers to oldspace */
1902void
b8d0dfaf 1903cgc_collect_garbage(void)
9a8c1c2f 1904{
1905 unsigned long allocated = bytes_allocated;
1906
1907 dprintf(noise, ("GC\n"));
1908 if (dolog && !log)
1909 log = fopen("LOG.tmp", "w");
1910
1911 /* Initialize the weak pointer list. */
1912 weak_pointers = NULL;
1913
1914 dprintf(noise, ("[Flip Spaces]\n"));
1915 flip_spaces();
1916 preserve_interrupt_contexts();
1917 dprintf(noise, ("[Preserve Stack]\n"));
1918 preserve_stack();
1919 scavenge_thread_stacks();
1920 dprintf(noise, ("[Scavenge Roots]\n"));
1921 scavenge_roots();
1922 dprintf(noise, ("[Scavenge New]\n"));
1923 scavenge_newspace();
1924 scan_weak_pointers();
1925 dprintf(noise, ("[Free Oldspace]\n"));
1926 free_oldspace();
1927 if (dover) {
1928 dprintf(noise, ("[Checking]\n"));
1929 verify_gc();
1930 }
1931 dprintf(noise, ("[Compacting]\n"));
1932 compact_free_regions();
1933 /* The stack will be zeroed by scrub-control-stack in sub-gc which
1934 is more effecient. */
1935 /* zero_stack(); */
1936 if (log)
1937 fclose(log);
1938 log = NULL;
1939 dprintf(noise, (" %ld bytes copied.\n", (bytes_allocated - allocated)));
1940 dprintf(noise, (" %ld bytes (%ld pages) reclaimed.\n",
1941 chunks_freed * CHUNK_BYTES, chunks_freed));
1942 bytes_allocated -= chunks_freed * CHUNK_BYTES;
1943 maybe_gc_called = 0;
5ced0fdf 1944}
1945
9a8c1c2f 1946void
b8d0dfaf 1947cgc_free_heap(void)
9a8c1c2f 1948{
1949 /* Like above but just zap everything 'cause purify has
1950 * cleaned house!
1951 */
1952 unsigned long allocated = bytes_allocated;
1953
1954 flip_spaces();
1955 post_purify_fixup(oldspace);
1956 free_oldspace();
1957 compact_free_regions();
1958#if 0 /* purify is currently running on the C stack so don't do this */
1959 zero_stack();
1960#endif
1961 bytes_allocated -= chunks_freed * CHUNK_BYTES;
1962}
5ced0fdf 1963\f
9a8c1c2f 1964
5ced0fdf 1965void
b8d0dfaf 1966cgc_init_collector(void)
5ced0fdf 1967{
1968 int max_blocks;
9a8c1c2f 1969
1970 heap_base = (void *) DYNAMIC_0_SPACE_START;
5ced0fdf 1971
1972 /* I could actually use both spaces here but just 1 for now */
9a8c1c2f 1973 heap_end = (char *) heap_base + dynamic_space_size;
5ced0fdf 1974
1975 max_blocks = BLOCK_NUMBER(heap_end) - BLOCK_NUMBER(heap_base);
9a8c1c2f 1976 if ((block_table_base = malloc(sizeof(struct cluster *) * max_blocks))
1977 != NULL) {
5ced0fdf 1978 memset(block_table_base, 0, sizeof(struct cluster *) * max_blocks);
9a8c1c2f 1979
5ced0fdf 1980 block_table = (block_table_base - BLOCK_NUMBER(heap_base));
1981
1982 space_0.regions_tail = &space_0.regions;
1983 space_1.regions_tail = &space_1.regions;
1984
1985 newspace = &space_0;
1986 oldspace = &space_1;
9a8c1c2f 1987 } else
1988 perror("malloc cgc block table");
1989 init_osc(); /* Object Storage Class table */
5ced0fdf 1990}
1991\f
1992
1993void do_pending_interrupt(void);
1994
1995int use_cgc_p = 0;
9a8c1c2f 1996char *
1997alloc(int nbytes)
5ced0fdf 1998{
9a8c1c2f 1999 /* Alloc is only called from lisp code to allocate a number of
2000 words, the cgc GC uses cgc_alloc directly as the checks of the
2001 heap size and is not needed and interrupts are allways disabled
2002 during a GC. */
5ced0fdf 2003
9a8c1c2f 2004 /* Assumes nbytes includes alignment. Python arranges for that
2005 * but the C startup code needed some help.
2006 */
5ced0fdf 2007#if 0
9a8c1c2f 2008 int bytes = (nbytes + (ALIGN_BYTES - 1)) & ~(ALIGN_BYTES - 1);
2009
2010 if (bytes != nbytes)
2011 fprintf(stderr, "Fixing unaligned allocation length %d.\n", nbytes);
2012 nbytes = bytes;
5ced0fdf 2013#endif
9a8c1c2f 2014 if (!use_cgc_p) {
2015 char *current = (char *) SymbolValue(ALLOCATION_POINTER);
2016 char *nxtfree = current + nbytes;
2017
2018 SetSymbolValue(ALLOCATION_POINTER, (lispobj) nxtfree);
2019 return current;
2020 } else {
2021 /* Lacking an interrupt driven scheme to notice when a GC might
2022 * be wise, we add some more overhead to the allocator here
2023 * before any needed state is acquired. Only need to do it once
2024 * though because lisp will remember *need to collect garbage*
2025 * and get to it when it can. */
2026 if (auto_gc_trigger /* Only when enabled */
2027 && bytes_allocated > auto_gc_trigger && !maybe_gc_called++) /* Only once */
2028 funcall0(SymbolFunction(MAYBE_GC));
2029
2030 if (SymbolValue(INTERRUPTS_ENABLED) == NIL)
2031 /* Interrupts are disable so no special care is needed */
2032 return cgc_alloc(nbytes);
2033 else {
2034 void *result;
2035
2036 /* Interrupts are enabled so set *interrupt-enabled* to nil
2037 before calling cgc_alloc to prevent cgc_alloc from being
2038 re-entered. */
2039 SetSymbolValue(INTERRUPTS_ENABLED, NIL);
2040
2041 result = cgc_alloc(nbytes);
2042
2043 /* Restore *interrupts-enabled* */
2044 SetSymbolValue(INTERRUPTS_ENABLED, T);
2045
2046 /* Check if an interrupt occured */
2047 if (SymbolValue(INTERRUPT_PENDING) == T)
2048 /* Handle any interrupts that occured during cgc_alloc */
2049 do_pending_interrupt();
2050
2051 return result;
5ced0fdf 2052 }
2053 }
2054}
2055\f
2056/* Interface to history. */
9a8c1c2f 2057void
2058set_auto_gc_trigger(unsigned long dynamic_usage)
5ced0fdf 2059{
9a8c1c2f 2060 auto_gc_trigger += dynamic_usage;
5ced0fdf 2061}
9a8c1c2f 2062
2063void
2064clear_auto_gc_trigger(void)
5ced0fdf 2065{
9a8c1c2f 2066 auto_gc_trigger = 0;
5ced0fdf 2067}
9a8c1c2f 2068
2069void
2070gc_init(void)
5ced0fdf 2071{
2072 cgc_init_collector();
2073}
9a8c1c2f 2074
2075void
b8d0dfaf 2076collect_garbage(void)
5ced0fdf 2077{
9a8c1c2f 2078 /* SUB-GC wraps without-interrupt around call, but this
2079 * is going to absolutely block SIGINT.
2080 */
2081 /* #define REALLY_SAFE */
5ced0fdf 2082#if defined REALLY_SAFE
9a8c1c2f 2083 sigset_t newmask, oldmask;
2084
2085 sigemptyset(&newmask);
2086 sigaddset(&newmask, SIGINT);
2087 sigprocmask(SIG_BLOCK, &newmask, &oldmask);
5ced0fdf 2088#endif
9a8c1c2f 2089 cgc_collect_garbage();
5ced0fdf 2090#if defined REALLY_SAFE
9a8c1c2f 2091 sigprocmask(SIG_SETMASK, &oldmask, NULL);
5ced0fdf 2092#endif
2093
2094}
74c53b9c 2095\f
2096/* Some helpers for the debugger. */
2097
2098/* Scan an area looking for an object which encloses the given
2099 pointer. Returns the object start on success or NULL on failure. */
9a8c1c2f 2100static lispobj *
2101search_space(lispobj * start, size_t words, lispobj * pointer)
2102{
2103 while (words > 0) {
2104 size_t count = 1;
2105 lispobj thing = *start;
2106
2107 /* If thing is an immediate then this is a cons */
2108 if (Pointerp(thing)
2109 || ((thing & 3) == 0) /* fixnum */
2110 ||(TypeOf(thing) == type_BaseChar)
2111 || (TypeOf(thing) == type_UnboundMarker))
2112 count = 2;
2113 else
2114 count = sizeOfObject((obj_t) start);
2115
2116 /* Check if the pointer is within this object? */
2117 if ((pointer >= start) && (pointer < (start + count))) {
2118 /* Found it. */
2119 /* fprintf(stderr,"* Found %x in %x %x\n",pointer, start, thing); */
2120 return (start);
2121 }
2122
2123 /* Round up the count */
2124 count = CEILING(count, 2);
2125
2126 start += count;
2127 words -= count;
74c53b9c 2128 }
9a8c1c2f 2129 return (NULL);
74c53b9c 2130}
2131
9a8c1c2f 2132static lispobj *
2133search_read_only_space(lispobj * pointer)
74c53b9c 2134{
9a8c1c2f 2135 lispobj *start = (lispobj *) READ_ONLY_SPACE_START;
2136 lispobj *end = (lispobj *) SymbolValue(READ_ONLY_SPACE_FREE_POINTER);
2137
2138 if ((pointer < start) || (pointer >= end))
2139 return NULL;
2140 return (search_space(start, (pointer + 2) - start, pointer));
74c53b9c 2141}
2142
9a8c1c2f 2143static lispobj *
2144search_static_space(lispobj * pointer)
74c53b9c 2145{
9a8c1c2f 2146 lispobj *start = (lispobj *) STATIC_SPACE_START;
2147 lispobj *end = (lispobj *) SymbolValue(STATIC_SPACE_FREE_POINTER);
74c53b9c 2148
9a8c1c2f 2149 if ((pointer < start) || (pointer >= end))
2150 return NULL;
2151 return (search_space(start, (pointer + 2) - start, pointer));
74c53b9c 2152}
2153
9a8c1c2f 2154/* Find the code object for the given pc. Return NULL on failure */
2155lispobj *
2156component_ptr_from_pc(lispobj * pc)
2157{
2158 lispobj *object = NULL;
2159
2160 if (object = search_read_only_space(pc));
2161 else
2162 object = search_static_space(pc);
2163
2164 /* Found anything? */
2165 if (object)
2166 /* Check if it is a code object. */
2167 if (TypeOf(*object) == type_CodeHeader)
2168 return (object);
2169
2170 return (NULL);
2171}