[projects/cmucl/cmucl.git] / src / lisp / cgc.c

/* cgc.c -*- Mode: C; comment-column: 40; -*-
 * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/cgc.c,v 1.14 2008/03/19 09:17:10 cshapiro Rel $
 *
 * Conservative Garbage Collector for CMUCL x86.
 *
 * This code is based on software written by William Lott, and
 * Public Domain codes from Carnegie Mellon University, and has
 * been placed in the Public Domain.
 *
 * Received from William 27 Jul 95.
 *
 * Debug, FreeBSD hooks, and integration by Paul Werkowski
 *
 *
 */
#include <stdio.h>
#include <assert.h>
#include <signal.h>
#include <string.h>
#include "os.h"                 /* for SetSymbolValue */
#include "globals.h"            /* For dynamic_space_size */
#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);}
\f
/* 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) {}
\f

/* 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);
\f

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);
\f
#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(void)
{
    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(void)
{
    struct cluster *cluster;

    for (cluster = clusters; cluster != NULL; cluster = cluster->next)
        print_cluster(cluster);
}
#endif /* TESTING */
\f

/* 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;
    }
}
\f
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 = &region->next;
    }
    return NULL;
}
\f

/* 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)
        memset((char *) addr, 0, 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)
                memset((char *) block_start + block_size, 0,
                       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);
            }
        }
}
\f
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;
    unsigned max_chunks = cluster->num_blocks * BLOCK_CHUNKS;
    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 >= cluster->first_region);
                gc_assert(region->space == NULL);
                gc_assert(next->space == NULL);
                gc_assert(region->num_chunks > 0);
                gc_assert(next->num_chunks > 0);
                gc_assert((region->num_chunks + next->num_chunks) <=
                          max_chunks);
                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 = &region->next;
                } else {
                    *large_prev = region;
                    large_prev = &region->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(void)
{
    struct cluster *cluster;

    large_region_free_list = NULL;
    small_region_free_list = NULL;

    for (cluster = clusters; cluster != NULL; cluster = cluster->next)
        compact_cluster(cluster);
}
\f
/* 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;
}
\f
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;
}
\f
unsigned long 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;
}
\f
static struct region *
alloc_small_region(void)
{
    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;
    }
}
\f
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;
    bytes_allocated += region->num_chunks * CHUNK_BYTES;
    move_to_newspace(region);
    return (char *) region + REGION_OVERHEAD;
}
\f
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;
            bytes_allocated += region->num_chunks * CHUNK_BYTES;
        }

        res = space->alloc_ptr;
        space->alloc_ptr += ROUNDUP(nbytes, ALIGN_BYTES);
    }
    return res;
}
\f

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 == &region->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 = &region->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);
}
\f
/* 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));
}
\f
/* 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
\f
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);
    }
}
\f

#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;
\f

/* 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];
\f
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);
}
\f
static void
init_osc(void)
{
    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);
#if defined type_ComplexSingleFloat
    SETSCT(type_ComplexSingleFloat, SC_UNBOXED, 0);
#endif
#if defined type_ComplexDoubleFloat
    SETSCT(type_ComplexDoubleFloat, SC_UNBOXED, 0);
#endif
    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);
#if defined type_SimpleArraySignedByte8
    SETSCT(type_SimpleArraySignedByte8, SC_VECTOR, 3);
#endif
#if defined type_SimpleArraySignedByte16
    SETSCT(type_SimpleArraySignedByte16, SC_VECTOR, 4);
#endif
#if defined type_SimpleArraySignedByte30
    SETSCT(type_SimpleArraySignedByte30, SC_VECTOR, 5);
#endif
#if defined type_SimpleArraySignedByte32
    SETSCT(type_SimpleArraySignedByte32, SC_VECTOR, 5);
#endif
    SETSCT(type_SimpleArraySingleFloat, SC_VECTOR, 5);
    SETSCT(type_SimpleArrayDoubleFloat, SC_VECTOR, 6);
#if defined type_SimpleArrayComplexSingleFloat
    SETSCT(type_SimpleArrayComplexSingleFloat, SC_VECTOR, 6);
#endif
#if defined type_SimpleArrayComplexDoubleFloat
    SETSCT(type_SimpleArrayComplexDoubleFloat, SC_VECTOR, 7);
#endif
    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);
}
\f
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;
}
\f
#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);
}
\f
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
\f
/* 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",
                n++, cons, new_cons, new_cons->car);
#endif
    /* Grab the cdr before it is clobbered */
    cdr = cons->cdr;
    /* Set forwarding pointer (clobbers start of list). */
    DEPOSIT_FORWARDING_PTR((obj_t) cons, new_list_pointer);

    /* Try to linearize the list in the cdr direction to help reduce paging. */
    while (1) {
        lispobj new_cdr;
        struct cons *cdr_cons, *new_cdr_cons;

        if (LowtagOf(cdr) != type_ListPointer || !from_space_p(cdr)
            || FORWARDED((obj_t) PTR(cdr)))
            break;

        cdr_cons = (struct cons *) PTR(cdr);

        /* copy 'cdr' */
        new_cdr_cons = (struct cons *) cgc_alloc(sizeof(struct cons));

        new_cdr_cons->car = cdr_cons->car;
        new_cdr_cons->cdr = cdr_cons->cdr;
        new_cdr = (lispobj) new_cdr_cons | LowtagOf(cdr);
        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",
                    n++, cdr_cons, new_cdr_cons, cdr_cons->car);
#endif
        /* Grab the cdr before it is clobbered */
        cdr = cdr_cons->cdr;
        /* Set forwarding pointer */
        DEPOSIT_FORWARDING_PTR((obj_t) cdr_cons, new_cdr);

        /* Update the cdr of the last cons copied into new
         * space to keep the newspace scavenge from having to do it.
         */
        new_cons->cdr = new_cdr;

        new_cons = new_cdr_cons;
    }

    return new_list_pointer;
}
\f
/* Weak Pointers */
static int weak_noise = 0;
static int do_weak = 1;
static int
scav_weak_pointer(lispobj * where)
{
    struct weak_pointer *wp = weak_pointers;

    /* Push the weak pointer onto the list of weak pointers.
     * Do I have to watch for duplicates? Originally this was
     * part of trans_weak_pointer but that didn't work in the
     * case where the WP was in a promoted region.
     */

    while (wp != NULL) {
        if (wp == (struct weak_pointer *) where)
            break;
        wp = wp->next;
    }
    if (wp == NULL) {
        wp = (struct weak_pointer *) where;
        wp->next = weak_pointers;
        weak_pointers = wp;
        if (!do_weak)
            scavenge_1word_obj(&wp->value);
    }

    /* Do not let GC scavenge the value slot of the weak pointer
     * (that is why it is a weak pointer).
     */

    return WEAK_POINTER_NWORDS;
}

void
scan_weak_pointers(void)
{
    struct weak_pointer *wp;

    for (wp = weak_pointers; wp != NULL; wp = wp->next) {
        lispobj value = wp->value;
        obj_t obj = (obj_t) PTR(value);
        lispobj first, *first_pointer;

        dprintf(weak_noise, ("Weak pointer at 0x%08x\n", (unsigned long) wp));
        dprintf(weak_noise, ("Value: 0x%08x\n", (unsigned long) value));

        if (Pointerp(value) && from_space_p(value)) {
            /* Now, we need to check if the object has been forwarded.
             * If it has been, the weak pointer is still good and needs
             * to be updated. Otherwise, the weak pointer needs to be nil'ed out.
             */

            if (FORWARDED(obj))
                wp->value = FORWARDING_PTR(obj);
            else {              /* break it */
                dprintf(weak_noise, ("Broken.\n"));
                wp->value = NIL;
                wp->broken = T;
            }
        }
    }
}
\f
static int
scavenge_random_object(lispobj * addr)
{
    lispobj header = *addr;
    int count = 1;

    dprintf(noise > 1, ("soi: %x @ %x\n", header, addr));
#if 0
    if (trapaddr == addr)
        check_trap(addr);
#endif
    gc_assert(ALIGNEDP(addr));

    switch (TypeOf(header)) {
      case type_SimpleVector:
          {
              struct vector *v = (struct vector *) addr;
              int i, n = fixnum_value(v->length);

              if (HeaderValue(v->header) == subtype_VectorValidHashing)
                  v->header =
                      (subtype_VectorMustRehash << type_Bits) |
                      type_SimpleVector;
              /* Look at each of the vector elements which can be any lisp object. */
              for (i = 0; i < n; i++)
                  scavenge_1word_obj(&v->data[i]);
              count = CEILING(n + 2, 2);
          }
          break;
      case type_CodeHeader:
          count = scav_code_header(addr);
          break;
          /* We should never hit any of these, 'cause they occur buried in
           * the middle of code objects (and handled by the code just above).
           */
      case type_ClosureFunctionHeader:
      case type_ReturnPcHeader:
          gc_abort();

          /* Except while looking at an fdefn and wanting to ensure
           * code object is looked at.
           */
      case type_FunctionHeader:
          scavenge_fcn_header((struct function *) addr);
          break;
#if defined i386
      case type_ClosureHeader:
      case type_FuncallableInstanceHeader:
      case type_ByteCodeFunction:
      case type_ByteCodeClosure:
      case type_DylanFunctionHeader:
          count = scav_closure_header((struct closure *) addr);
          break;
#endif
      case type_WeakPointer:
          count = scav_weak_pointer(addr);
          break;
      case type_Fdefn:
          /* We have to handle fdefn objects specially, so we can fix
           * up the raw function address.
           */
          count = scav_fdefn(addr);
          break;
      default:
          {
              OSC_t class = sct[TypeOf(header)];

              switch (class.sc_kind) {
                case SC_IMMED:
                    count = 1;
                    break;
                case SC_ISBOXED:
                    {
                        int i, words = 1 + HeaderValue(header);

                        for (i = 1; i < words; i++)
                            scavenge_1word_obj(addr + i);
                        count = CEILING(words, 2);
                    }
                    break;
                case SC_UNBOXED:
                case SC_STRING:
                case SC_VECTOR: /* simple vector handled above */
                    count = sizeOfObject((obj_t) addr);
                    break;
                default:
                    gc_abort();
              }
          }
    }
    return count;
}
\f
static void
logcopy(lispobj * addr, lispobj tagged, int hdr, lispobj to)
{
    if (log) {
        int kind = TypeOf(hdr);
        int words = sizeOfObject((obj_t) PTR(tagged));

        fprintf(log, "(copy #x%x @ #x%x (#x%x %d) to #x%x)\n",
                tagged, addr, kind, words, to);
    }
}
static void
maybe_transport(lispobj * addr, lispobj tagged, struct region *region)
{
    obj_t obj = (obj_t) PTR(tagged);

    gc_assert(ALIGNEDP(obj));
    gc_assert(Pointerp(tagged));
    gc_assert((void *) region != (void *) obj);
#if 0
    if ((void *) obj == (void *) trapaddr)
        check_trap(obj);
#endif
    if (region->contains_small_objects) {
        lispobj new = copy(tagged);

#if 0
        if (scav_ro > 1)        /* debugging in RO space */
            check_trap(obj);
#endif
#if defined GOOSE_CHASE
        if (TypeOf(obj->header) == type_Fdefn) {
            struct fdefn *fdefn = (struct fdefn *) PTR(new);

            if (fdefn->function < STATIC_SPACE_START)
                check_trap(obj);
        }
#endif
        dprintf(0, ("copy %x @ %x (%x) to %x\n",
                    tagged, addr, TypeOf(obj->header), new));
        logcopy(addr, tagged, obj->header, new);
        DEPOSIT_FORWARDING_PTR(obj, new);
        *addr = new;
    } else {
        move_to_newspace(region);
        dprintf(0, ("move %x\n", region));
    }
}
\f
void
scavenge_pointer(lispobj * addr)
{
    lispobj taggedobj = *addr;  /* descriptor */
    obj_t obj = (obj_t) PTR(taggedobj); /* pointer to object */

    gc_assert(Pointerp(taggedobj));
#if 0
    if (addr == trapaddr)
        check_trap(addr);
    if (obj == trapaddr)
        check_trap(obj);
#endif
    /* optimize out common static pointers */
    if (taggedobj != NIL && taggedobj != T) {
        struct region *region = find_region(obj);

        /* Only interested in pointers into oldspace */
        if (region && region->space == oldspace) {
            if (FORWARDED(obj))
                *addr = FORWARDING_PTR(obj);
            else
                switch (LowtagOf(taggedobj)) {
                  case type_ListPointer:
                      dprintf(noise > 1, ("ListPointer @ %x...\n", addr));
                      *addr = trans_list(taggedobj);
                      dprintf(noise > 1, ("... -> %x\n", addr));
                      break;
                  case type_FunctionPointer:
                      switch (TypeOf(obj->header)) {
                        case type_ClosureHeader:
                        case type_FuncallableInstanceHeader:
                        case type_ByteCodeFunction:
                        case type_ByteCodeClosure:
                        case type_DylanFunctionHeader:
                            maybe_transport(addr, taggedobj, region);
                            break;
                        default:
                            gc_abort();
                      }
                      break;
                  case type_InstancePointer:
                  case type_OtherPointer:
                      maybe_transport(addr, taggedobj, region);
                      break;
                  default:
                      /* It was a pointer, but not one of them? */
                      gc_abort();
                }
        }
    }
}
\f

static lispobj *
scavenge(lispobj * addr, int ptrs)
{
    /* addr points to an aligned 32-bit word in some space. */
    struct region *region;
    lispobj *end = addr + ptrs;
    lispobj obj;

    while (addr < end) {
        int count = 1;

        obj = *addr;            /* the lisp object */
#if 0
        if (trapaddr == addr)
            check_trap(addr);   /* gdb breakpoint */
#endif
        if (Pointerp(obj))      /* lowtag odd      */
            scavenge_pointer(addr);
        else if (obj & 0x3)
            /* some other immediate */
            /*
               * Some random header. Process some type dependent number
               * of words. May still be inside object after call and the
               * next cell can be any lisp object. We can either recurse
               * by calling scavenge here or let the caller do it.
             */
            count = scavenge_random_object(addr);
        else
            IMMED_OR_LOSE(obj);

        addr += count;
    }
    return addr;
}
\f
static void
scavenge_cons(lispobj * where)
{
    /* Scavenge a two-word space */
    scavenge_1word_obj(where + 0);      /* car */
    scavenge_1word_obj(where + 1);      /* cdr */
}
static lispobj *
scavenge_object(lispobj * start)
{
    int length = sizeOfObject((obj_t) start);
    int words = scavenge_random_object(start);

    gc_assert(length == words);
    return start + length;
}
static lispobj *
scavengex(lispobj * obj)
{
    /* Thing at this location is one of:
     * a - basic object with header.
     * b - cons object (no header).
     * so that the starting and ending addresses are aligned.
     */
    gc_assert(ALIGNEDP(obj));
    {
        lispobj first_word = *obj;
        OSC_t sc = sct[TypeOf(first_word)];

        if (Pointerp(first_word) || sc.sc_kind == SC_IMMED) {   /* Must be a cons object or unused space */
            scavenge_cons((lispobj *) obj);
            return obj + 2;
        } else {                /* Must be a complex object with header */
            lispobj *next = scavenge_object(obj);

            return next;
        }
    }
}
\f
static void
scavenge_space(lispobj * where, int words, char *name)
{
    int allocated = bytes_allocated;
    lispobj *end = where + words;
    lispobj *last;

    bytes_copied = 0;
    if (name)
        dprintf(noise, ("  %s", name));
    while (where < end) {
        last = where;
        where = scavengex(last);
    }
    gc_assert(where == end);
    if (name)
        dprintf(noise, (" %ld bytes moved, %ld bytes allocated.\n",
                        bytes_copied, bytes_allocated - allocated));
}
\f
static int boxed_registers[] = BOXED_REGISTERS;
static void
preserve_interrupt_context(os_context_t * context)
{
    int i;

    /* Check each boxed register for a valid pointer and promote
     * its region when found.
     */
    for (i = 0; i < (sizeof(boxed_registers) / sizeof(int)); i++) {
        int index = boxed_registers[i];
        lispobj foo = SC_REG(context, index);
        struct region *region = find_region((void *) foo);

        if (region && region->space == oldspace)
            move_to_newspace(region);
    }
}
static void
preserve_interrupt_contexts(void)
{
    int i, index;
    os_context_t *context;

    index = fixnum_value(SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX));
    dprintf(noise, ("Number of active contexts: %d\n", index));

    for (i = 0; i < index; i++) {
        context = lisp_interrupt_contexts[i];
        preserve_interrupt_context(context);
    }
}
\f

static void
flip_spaces(void)
{
    struct space *temp = oldspace;

    oldspace = newspace;
    newspace = temp;
}

/* There should be no lisp objects on the C stack so will limit search
 * to just the assigned lisp stack area.
 */
#if defined i386
#define BOS (CONTROL_STACK_START+control_stack_size)    /* x86-validate.h */
/* Traverse stack in same direction as it was loaded to try and
 * preserve original ordering of pages. Good for the VM system I hope.
 */
#define ACROSS_STACK(var) var=(void**)BOS-1; var > (void**)&var; var--
#endif

void
preserve_pointer(void *ptr)
{
    if (ptr > heap_base && ptr < heap_end) {
        struct region *region = find_region(ptr);

        if (region != NULL && region->space == oldspace) {
            dprintf(0, ("move %x\n", ptr));
            move_to_newspace(region);
        }
    }
}

static void
preserve_stack(void)
{
    void **addr;                /* auto var is current TOS */

    for (ACROSS_STACK(addr))
        preserve_pointer(*addr);
}

#ifdef CONTROL_STACKS
/* Scavenge the thread stack conservative roots. */
void
scavenge_thread_stacks(void)
{
    lispobj thread_stacks = SymbolValue(CONTROL_STACKS);
    int type = TypeOf(thread_stacks);

    if (LowtagOf(thread_stacks) == type_OtherPointer) {
        struct vector *vector = (struct vector *) PTR(thread_stacks);
        int length, i;

        if (TypeOf(vector->header) != type_SimpleVector)
            return;
        length = fixnum_value(vector->length);
        for (i = 0; i < length; i++) {
            lispobj stack_obj = vector->data[i];

            if (LowtagOf(stack_obj) == type_OtherPointer) {
                struct vector *stack = (struct vector *) PTR(stack_obj);
                int length, j;

                if (TypeOf(stack->header) != type_SimpleArrayUnsignedByte32)
                    return;
                length = fixnum_value(stack->length);
                /* fprintf(stderr,"Scavenging control stack %d of length %d words\n",
                   i,length); */
                for (j = 0; j < length; j++)
                    preserve_pointer((void *) stack->data[j]);
            }
        }
    }
}
#endif

static void
zero_stack(void)
{
    /* This is a bit tricky because we don't want to zap any
     * stack frames between here and the call to mmap. For now,
     * lets just be slow and careful.
     */
    long *p, *q;
    os_vm_address_t base = (os_vm_address_t) CONTROL_STACK_START;
    os_vm_size_t size = (char *) &base - (char *) base;

#if 0
    cgc_zero(base, size);
#else
    p = (long *) base;
    q = (long *) &size;
    while (p < q)
        *p++ = 0;
#endif

}
\f
#if defined STATIC_BLUE_BAG
static int fast_static = 1;
static void
scavenge_static(void)
{
    /* Static space consists of alternating layers of
     * code objects that refer to read-only space (from purify),
     * static non-code objects that need looking at, and
     * newly loaded code objects that refer to dynamic space.
     * The number of these areas depends on how many times purify
     * ran while loading the system image. I will extend purify
     * to maintain a list of collectable areas and use that list
     * here to avoid scanning read-only code sections.
     */
    lispobj *ss0 = (lispobj *) PTR(NIL);
    lispobj *ssa = (lispobj *) (PTR(STATIC_BLUE_BAG));
    lispobj *ssz = (lispobj *) SymbolValue(STATIC_SPACE_FREE_POINTER);
    lispobj bag = SymbolValue(STATIC_BLUE_BAG);
    lispobj *end = NULL;

    ssa += sizeOfObject(OBJECT_AT(ssa));        /* Genesis modifies plist entry */
    if (fast_static) {
        scavenge_space(ss0, ssa - ss0, "Static0");
        if (bag != NIL && LowtagOf(bag) == type_ListPointer) {
            char sbuf[128];
            struct cons *cons = (struct cons *) PTR(bag);

            while (LowtagOf(cons->car) == type_ListPointer) {
                struct cons *pair = (struct cons *) PTR(cons->car);
                lispobj *ss1 = (lispobj *) pair->car;
                lispobj *ss2 = (lispobj *) pair->cdr;

                if (end == NULL)
                    end = ss2;
                sprintf(sbuf, "Static %x %d", ss1, ss2 - ss1);
                scavenge_space(ss1, ss2 - ss1, sbuf);
                if (cons->cdr != NIL && LowtagOf(cons->cdr) == type_ListPointer)
                    cons = (struct cons *) PTR(cons->cdr);
                else
                    break;
            }
        }
        if (end != NULL)
            scavenge_space(end, ssz - end, "Static");
    } else
        (scavenge_space(ss0, ssz - ss0, "Static-All"));
}
#endif
\f
static void
scavenge_roots(void)
{
    /* So what should go here?
     * When cgc starts up after purify/save all live objects
     * are in read-only or static space, and anything in RO
     * can point only to RO or STATIC and can't be changed.
     * Anything in STATIC is subject to change (but not move).
     * . not read-only-space      (probably most of the roots here)
     * . static-space             (all compiled code at least)
     * . binding-stack
     * . weak-pointers
     ?   do I allow GC from interrupt?)
     * . interrupt-context        (regs same as stack)
     ****
     * Well, it turns out that RO space ain't exactly that as
     * somehow apparently cached 'compact-info-environment' stuff
     * modifies at least 2 locations in RO space. There is a note
     * in globaldb.lisp that alludes to this and provides a post GC
     * hook to blow the cache. Not a problem if gc is called from
     * the lisp wrapper. UPDATE: Found purify bug which forced
     * boxed vectors into RO. This may be what led to above.
     *
     */
    lispobj *rs0 = (lispobj *) READ_ONLY_SPACE_START;
    lispobj *rsz = (lispobj *) SymbolValue(READ_ONLY_SPACE_FREE_POINTER);
    lispobj *ss0 = (lispobj *) STATIC_SPACE_START;
    lispobj *ssz = (lispobj *) SymbolValue(STATIC_SPACE_FREE_POINTER);
    lispobj *bs0 = (lispobj *) BINDING_STACK_START;
    lispobj *bsz = (lispobj *) SymbolValue(BINDING_STACK_POINTER);

    if (scav_ro) {
        scav_ro++;
        scavenge_space(rs0, rsz - rs0, "RO");
        scav_ro--;
    }
    scavenge_static();
    scavenge_space(bs0, bsz - bs0, "Binding Stack");

    dprintf(noise, ("Interrupt handlers (%u bytes) ...\n",
                    sizeof(interrupt_handlers)));

    scavenge((lispobj *) interrupt_handlers,
             sizeof(interrupt_handlers) / sizeof(lispobj));

}
\f
static void
scavenge_newspace(void)
{
    /* Scavenge is going to start at the beginning of newspace which
     * is presumed to have some "root" object pointers lying about due
     * to promoting regions that may be aimed at by stack resident pointers,
     * copied small objects from scavenge_roots(), or promoted large_object
     * regions. Scavenge() will flush out more copied objects/promoted
     * regions that will get added to the end of newspace and eventually
     * scanned by this code -- until all referenced things (and maybe some
     * extra dead stuff) have been examined. At the end of this loop anything
     * in oldspace is trash.
     */
    struct region *current;

    current = newspace->regions;

    while (current != NULL) {
        if (current->contains_small_objects) {
            void *obj = (char *) current + REGION_OVERHEAD;
            void *end = (char *) current + current->num_chunks * CHUNK_BYTES;

            while (obj < end)
                obj = SCAVENGE_OBJECT(OBJECT_AT(obj));
            gc_assert(obj == end);
        } else
            SCAVENGE_OBJECT(OBJECT_AT(((char *) current + REGION_OVERHEAD)));
        current = current->next;
    }
}
\f
static void
free_oldspace(void)
{
    struct region *region, *next;

    chunks_freed = 0;
    for (region = oldspace->regions; region != NULL; region = next) {
        gc_assert(region->space != newspace);
        next = region->next;
        free_region(region);
    }
    oldspace->alloc_ptr = NULL;
    oldspace->alloc_end = NULL;
    oldspace->regions = NULL;
    oldspace->regions_tail = &oldspace->regions;
}
\f
static void
verify_space(lispobj * start, size_t words)
{
    while (words > 0) {
        size_t count = 1;
        lispobj thing = *(lispobj *) start;

        if (Pointerp(thing)) {
            struct region *region = find_region((void *) thing);

            if (region && region->space == NULL)
                fprintf(stderr, "Ptr %x @ %x sees Junk\n", thing, start);
        } else if (thing & 0x3) {
            obj_t obj = (obj_t) start;

            switch (TypeOf(obj->header)) {
              case type_CodeHeader:
                  {
                      lispobj object = *start;
                      struct code *code;
                      int nheader_words, ncode_words, nwords;
                      lispobj fheaderl;
                      struct function *fheaderp;

                      code = (struct code *) start;
                      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 */
                      verify_space(start + 1, nheader_words - 1);

                      /* Scavenge the boxed section of each function object in the
                       * code data block.
                       */
                      fheaderl = code->entry_points;
                      while (fheaderl != NIL) {
                          fheaderp = (struct function *) PTR(fheaderl);
                          gc_assert(TypeOf(fheaderp->header) ==
                                    type_FunctionHeader);
                          verify_space(&fheaderp->name, 1);
                          verify_space(&fheaderp->arglist, 1);
                          verify_space(&fheaderp->type, 1);
                          fheaderl = fheaderp->next;
                      }
                      count = nwords;
                      break;
                  }
              default:
                  {
                      OSC_t class = sct[TypeOf(obj->header)];

                      switch (class.sc_kind) {
                        case SC_ISBOXED:
                        case SC_IMMED:
                            count = 1;
                            break;
                        case SC_UNBOXED:
                        case SC_STRING:
                        case SC_VECTOR:
                            count = sizeOfObject((obj_t) start);
                            break;
                        default:
                            gc_abort();
                      }
                      break;
                  }
            }
        }
        start += count;
        words -= count;
    }
}
\f
/* For debug/test only. */
static void
verify_gc(void)
{
    lispobj *rs0 = (lispobj *) READ_ONLY_SPACE_START;
    lispobj *rsz = (lispobj *) SymbolValue(READ_ONLY_SPACE_FREE_POINTER);
    lispobj *ss0 = (lispobj *) STATIC_SPACE_START;
    lispobj *ssz = (lispobj *) SymbolValue(STATIC_SPACE_FREE_POINTER);
    lispobj *bs0 = (lispobj *) BINDING_STACK_START;
    lispobj *bsz = (lispobj *) SymbolValue(BINDING_STACK_POINTER);
    lispobj *cs0 = (lispobj *) & rs0;
    lispobj *csz = (lispobj *) BOS;

    /* can't check stack easily because there may be non-valid 
     * objects there (thats why we're doing this cgc stuff). In
     * particular there are raw return addresses which can be very
     * descriptorish looking!!!

     verify_space(cs0, csz-cs0);
     */
    verify_space(rs0, rsz - rs0);
    verify_space(ss0, ssz - ss0);
    verify_space(bs0, bsz - bs0);
}
static void
fixup_regions(struct region *region)
{
    do {
        lispobj header = (lispobj) OBJECT_AT(region)->header;

        if (static_space_p(header)) {
            /* Purify thought this header was a cons? Why? */
            struct cons *wrong = (struct cons *) PTR(header);
            struct cons *fixme = (struct cons *) region;

            dprintf(1, ("\n--Fixing region header @ %x.", region));
            fixme->car = wrong->car;    /* restore region header */
            fixme->cdr = wrong->cdr;    /* restore prev pointer  */
            wrong->car = wrong->cdr = 0;
        }
        region = region->next;
    }
    while (region != NULL);
}

static void
post_purify_fixup(struct space *space)
{
    /* Purify may have messed up the region headers. This can happen
     * if there is a dead list pointer on the stack that now aims
     * at a region header (previously was valid memory). Purify attempts
     * to at least check for a valid object header but loses with lists.
     * This hack recovers the correct values and keeps us going. Can
     * this occur with other dead objects?
     */
    if (large_region_free_list)
        fixup_regions(large_region_free_list);
    if (small_region_free_list)
        fixup_regions(small_region_free_list);
    fixup_regions(space->regions);
}
\f

static int dolog = 0;           /* log copy ops to file */
static int dover = 0;           /* hunt pointers to oldspace */
void
cgc_collect_garbage(void)
{
    unsigned long allocated = bytes_allocated;

    dprintf(noise, ("GC\n"));
    if (dolog && !log)
        log = fopen("LOG.tmp", "w");

    /* Initialize the weak pointer list. */
    weak_pointers = NULL;

    dprintf(noise, ("[Flip Spaces]\n"));
    flip_spaces();
    preserve_interrupt_contexts();
    dprintf(noise, ("[Preserve Stack]\n"));
    preserve_stack();
    scavenge_thread_stacks();
    dprintf(noise, ("[Scavenge Roots]\n"));
    scavenge_roots();
    dprintf(noise, ("[Scavenge New]\n"));
    scavenge_newspace();
    scan_weak_pointers();
    dprintf(noise, ("[Free Oldspace]\n"));
    free_oldspace();
    if (dover) {
        dprintf(noise, ("[Checking]\n"));
        verify_gc();
    }
    dprintf(noise, ("[Compacting]\n"));
    compact_free_regions();
    /* The stack will be zeroed by scrub-control-stack in sub-gc which
       is more effecient. */
    /* zero_stack(); */
    if (log)
        fclose(log);
    log = NULL;
    dprintf(noise, ("  %ld bytes copied.\n", (bytes_allocated - allocated)));
    dprintf(noise, ("  %ld bytes (%ld pages) reclaimed.\n",
                    chunks_freed * CHUNK_BYTES, chunks_freed));
    bytes_allocated -= chunks_freed * CHUNK_BYTES;
    maybe_gc_called = 0;
}

void
cgc_free_heap(void)
{
    /* Like above but just zap everything 'cause purify has
     * cleaned house!
     */
    unsigned long allocated = bytes_allocated;

    flip_spaces();
    post_purify_fixup(oldspace);
    free_oldspace();
    compact_free_regions();
#if 0                           /* purify is currently running on the C stack so don't do this */
    zero_stack();
#endif
    bytes_allocated -= chunks_freed * CHUNK_BYTES;
}
\f

void
cgc_init_collector(void)
{
    int max_blocks;

    heap_base = (void *) DYNAMIC_0_SPACE_START;

    /* I could actually use both spaces here but just 1 for now */
    heap_end = (char *) heap_base + dynamic_space_size;

    max_blocks = BLOCK_NUMBER(heap_end) - BLOCK_NUMBER(heap_base);
    if ((block_table_base = malloc(sizeof(struct cluster *) * max_blocks))
        != NULL) {
        memset(block_table_base, 0, sizeof(struct cluster *) * max_blocks);

        block_table = (block_table_base - BLOCK_NUMBER(heap_base));

        space_0.regions_tail = &space_0.regions;
        space_1.regions_tail = &space_1.regions;

        newspace = &space_0;
        oldspace = &space_1;
    } else
        perror("malloc cgc block table");
    init_osc();                 /* Object Storage Class table */
}
\f

void do_pending_interrupt(void);

int use_cgc_p = 0;
char *
alloc(int nbytes)
{
    /* Alloc is only called from lisp code to allocate a number of
       words, the cgc GC uses cgc_alloc directly as the checks of the
       heap size and is not needed and interrupts are allways disabled
       during a GC. */

    /* Assumes nbytes includes alignment. Python arranges for that
     * but the C startup code needed some help.
     */
#if 0
    int bytes = (nbytes + (ALIGN_BYTES - 1)) & ~(ALIGN_BYTES - 1);

    if (bytes != nbytes)
        fprintf(stderr, "Fixing unaligned allocation length %d.\n", nbytes);
    nbytes = bytes;
#endif
    if (!use_cgc_p) {
        char *current = (char *) SymbolValue(ALLOCATION_POINTER);
        char *nxtfree = current + nbytes;

        SetSymbolValue(ALLOCATION_POINTER, (lispobj) nxtfree);
        return current;
    } else {
        /* Lacking an interrupt driven scheme to notice when a GC might
         * be wise, we add some more overhead to the allocator here
         * before any needed state is acquired. Only need to do it once
         * though because lisp will remember *need to collect garbage*
         * and get to it when it can.  */
        if (auto_gc_trigger     /* Only when enabled */
            && bytes_allocated > auto_gc_trigger && !maybe_gc_called++) /* Only once         */
            funcall0(SymbolFunction(MAYBE_GC));

        if (SymbolValue(INTERRUPTS_ENABLED) == NIL)
            /* Interrupts are disable so no special care is needed */
            return cgc_alloc(nbytes);
        else {
            void *result;

            /* Interrupts are enabled so set *interrupt-enabled* to nil
               before calling cgc_alloc to prevent cgc_alloc from being
               re-entered. */
            SetSymbolValue(INTERRUPTS_ENABLED, NIL);

            result = cgc_alloc(nbytes);

            /* Restore *interrupts-enabled* */
            SetSymbolValue(INTERRUPTS_ENABLED, T);

            /* Check if an interrupt occured */
            if (SymbolValue(INTERRUPT_PENDING) == T)
                /* Handle any interrupts that occured during cgc_alloc */
                do_pending_interrupt();

            return result;
        }
    }
}
\f
/* Interface to history. */
void
set_auto_gc_trigger(unsigned long dynamic_usage)
{
    auto_gc_trigger += dynamic_usage;
}

void
clear_auto_gc_trigger(void)
{
    auto_gc_trigger = 0;
}

void
gc_init(void)
{
    cgc_init_collector();
}

void
collect_garbage(void)
{
    /* SUB-GC wraps without-interrupt around call, but this
     * is going to absolutely block SIGINT.
     */
    /* #define REALLY_SAFE */
#if defined REALLY_SAFE
    sigset_t newmask, oldmask;

    sigemptyset(&newmask);
    sigaddset(&newmask, SIGINT);
    sigprocmask(SIG_BLOCK, &newmask, &oldmask);
#endif
    cgc_collect_garbage();
#if defined REALLY_SAFE
    sigprocmask(SIG_SETMASK, &oldmask, NULL);
#endif

}
\f
/* Some helpers for the debugger. */

/* Scan an area looking for an object which encloses the given
   pointer. Returns the object start on success or NULL on failure. */
static lispobj *
search_space(lispobj * start, size_t words, lispobj * pointer)
{
    while (words > 0) {
        size_t count = 1;
        lispobj thing = *start;

        /* If thing is an immediate then this is a cons */
        if (Pointerp(thing)
            || ((thing & 3) == 0)       /* fixnum */
            ||(TypeOf(thing) == type_BaseChar)
            || (TypeOf(thing) == type_UnboundMarker))
            count = 2;
        else
            count = sizeOfObject((obj_t) start);

        /* Check if the pointer is within this object? */
        if ((pointer >= start) && (pointer < (start + count))) {
            /* Found it. */
            /*          fprintf(stderr,"* Found %x in %x %x\n",pointer, start, thing); */
            return (start);
        }

        /* Round up the count */
        count = CEILING(count, 2);

        start += count;
        words -= count;
    }
    return (NULL);
}

static lispobj *
search_read_only_space(lispobj * pointer)
{
    lispobj *start = (lispobj *) READ_ONLY_SPACE_START;
    lispobj *end = (lispobj *) SymbolValue(READ_ONLY_SPACE_FREE_POINTER);

    if ((pointer < start) || (pointer >= end))
        return NULL;
    return (search_space(start, (pointer + 2) - start, pointer));
}

static lispobj *
search_static_space(lispobj * pointer)
{
    lispobj *start = (lispobj *) STATIC_SPACE_START;
    lispobj *end = (lispobj *) SymbolValue(STATIC_SPACE_FREE_POINTER);

    if ((pointer < start) || (pointer >= end))
        return NULL;
    return (search_space(start, (pointer + 2) - start, pointer));
}

/* Find the code object for the given pc. Return NULL on failure */
lispobj *
component_ptr_from_pc(lispobj * pc)
{
    lispobj *object = NULL;

    if (object = search_read_only_space(pc));
    else
        object = search_static_space(pc);

    /* Found anything? */
    if (object)
        /* Check if it is a code object. */
        if (TypeOf(*object) == type_CodeHeader)
            return (object);

    return (NULL);
}