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

/*
 * Generational Conservative Garbage Collector for CMUCL x86.
 *
 * This code was written by Douglas T. Crosher, based on Public Domain
 * codes from Carnegie Mellon University. This code has been placed in
 * the public domain, and is provided 'as is'.
 *
 * Douglas Crosher, 1996, 1997, 1998, 1999.
 *
 * $Header: /project/cmucl/cvsroot/src/lisp/gencgc.c,v 1.112 2011-01-09 00:12:36 rtoy Exp $
 *
 */

#include <limits.h>
#include <stdio.h>
#include <stdlib.h>
#include <signal.h>
#include <string.h>
#include "lisp.h"
#include "arch.h"
#include "internals.h"
#include "os.h"
#include "globals.h"
#include "interrupt.h"
#include "validate.h"
#include "lispregs.h"
#include "interr.h"
#include "gencgc.h"

/*
 * This value in a hash table hash-vector means that the key uses
 * EQ-based hashing.  That is, the key might be using EQ or EQL for
 * the test.  This MUST match the value used in hash-new.lisp!
 */
#define EQ_BASED_HASH_VALUE     0x80000000

#define gc_abort() lose("GC invariant lost!  File \"%s\", line %d\n", \
                        __FILE__, __LINE__)

#if (defined(i386) || defined(__x86_64))

#define set_alloc_pointer(value) \
  SetSymbolValue (ALLOCATION_POINTER, (value))
#define get_alloc_pointer() \
  SymbolValue (ALLOCATION_POINTER)
#define get_binding_stack_pointer() \
  SymbolValue (BINDING_STACK_POINTER)
#define get_pseudo_atomic_atomic() \
  SymbolValue (PSEUDO_ATOMIC_ATOMIC)
#define set_pseudo_atomic_atomic() \
  SetSymbolValue (PSEUDO_ATOMIC_ATOMIC, make_fixnum (1))
#define clr_pseudo_atomic_atomic() \
  SetSymbolValue (PSEUDO_ATOMIC_ATOMIC, make_fixnum (0))
#define get_pseudo_atomic_interrupted() \
  SymbolValue (PSEUDO_ATOMIC_INTERRUPTED)
#define clr_pseudo_atomic_interrupted() \
  SetSymbolValue (PSEUDO_ATOMIC_INTERRUPTED, make_fixnum (0))

#define set_current_region_free(value) \
  SetSymbolValue(CURRENT_REGION_FREE_POINTER, (value))
#define set_current_region_end(value) \
  SetSymbolValue(CURRENT_REGION_END_ADDR, (value))
#define get_current_region_free() \
  SymbolValue(CURRENT_REGION_FREE_POINTER)

#define set_current_region_end(value) \
  SetSymbolValue(CURRENT_REGION_END_ADDR, (value))

#elif defined(sparc)

/*
 * current_dynamic_space_free_pointer contains the pseudo-atomic
 * stuff, so we need to preserve those bits when we give it a value.
 * This value better not have any bits set there either!
 */

/*
 * On sparc, we don't need to set the alloc_pointer in the code here
 * because the alloc pointer (current_dynamic_space_free_pointer) is
 * the same as *current-region-free-pointer* and is stored in
 * alloc-tn.
 */
#define set_alloc_pointer(value)
#define get_alloc_pointer() \
  ((unsigned long) current_dynamic_space_free_pointer & ~lowtag_Mask)
#define get_binding_stack_pointer() \
  (current_binding_stack_pointer)
#define get_pseudo_atomic_atomic() \
  ((unsigned long)current_dynamic_space_free_pointer & pseudo_atomic_Value)
#define set_pseudo_atomic_atomic() \
  (current_dynamic_space_free_pointer \
   = (lispobj*) ((unsigned long)current_dynamic_space_free_pointer | pseudo_atomic_Value))
#define clr_pseudo_atomic_atomic() \
  (current_dynamic_space_free_pointer \
   = (lispobj*) ((unsigned long) current_dynamic_space_free_pointer & ~pseudo_atomic_Value))
#define get_pseudo_atomic_interrupted() \
  ((unsigned long) current_dynamic_space_free_pointer & pseudo_atomic_InterruptedValue)
#define clr_pseudo_atomic_interrupted() \
  (current_dynamic_space_free_pointer \
   = (lispobj*) ((unsigned long) current_dynamic_space_free_pointer & ~pseudo_atomic_InterruptedValue))

#define set_current_region_free(value) \
  current_dynamic_space_free_pointer = (lispobj*)((value) | ((long)current_dynamic_space_free_pointer & lowtag_Mask))

#define get_current_region_free() \
  ((long)current_dynamic_space_free_pointer & (~(lowtag_Mask)))

#define set_current_region_end(value) \
  SetSymbolValue(CURRENT_REGION_END_ADDR, (value))

#elif defined(DARWIN) && defined(__ppc__)
#ifndef pseudo_atomic_InterruptedValue
#define pseudo_atomic_InterruptedValue 1
#endif
#ifndef pseudo_atomic_Value
#define pseudo_atomic_Value 4
#endif

#define set_alloc_pointer(value) 
#define get_alloc_pointer() \
  ((unsigned long) current_dynamic_space_free_pointer & ~lowtag_Mask)
#define get_binding_stack_pointer() \
  (current_binding_stack_pointer)
#define get_pseudo_atomic_atomic() \
  ((unsigned long)current_dynamic_space_free_pointer & pseudo_atomic_Value)
#define set_pseudo_atomic_atomic() \
  (current_dynamic_space_free_pointer \
   = (lispobj*) ((unsigned long)current_dynamic_space_free_pointer | pseudo_atomic_Value))
#define clr_pseudo_atomic_atomic() \
  (current_dynamic_space_free_pointer \
   = (lispobj*) ((unsigned long) current_dynamic_space_free_pointer & ~pseudo_atomic_Value))
#define get_pseudo_atomic_interrupted() \
  ((unsigned long) current_dynamic_space_free_pointer & pseudo_atomic_InterruptedValue)
#define clr_pseudo_atomic_interrupted() \
  (current_dynamic_space_free_pointer \
   = (lispobj*) ((unsigned long) current_dynamic_space_free_pointer & ~pseudo_atomic_InterruptedValue))

#define set_current_region_free(value) \
  current_dynamic_space_free_pointer = (lispobj*)((value) | ((long)current_dynamic_space_free_pointer & lowtag_Mask))

#define get_current_region_free() \
  ((long)current_dynamic_space_free_pointer & (~(lowtag_Mask)))

#define set_current_region_end(value) \
  SetSymbolValue(CURRENT_REGION_END_ADDR, (value))

#else
#error gencgc is not supported on this platform
#endif

/* Define for activating assertions.  */

#if defined(x86) && defined(SOLARIS)
#define GC_ASSERTIONS 1
#endif

/* Check for references to stack-allocated objects.  */

#ifdef GC_ASSERTIONS

static void *invalid_stack_start, *invalid_stack_end;

static inline void
check_escaped_stack_object(lispobj * where, lispobj obj)
{
#if !defined(DARWIN) && !defined(__ppc__)
    void *p;

    if (Pointerp(obj)
        && (p = (void *) PTR(obj),
            (p >= (void *) CONTROL_STACK_START
             && p < (void *) control_stack_end))) {
        char *space;

        if (where >= (lispobj *) DYNAMIC_0_SPACE_START
            && where < (lispobj *) (DYNAMIC_0_SPACE_START + dynamic_space_size))
            space = "dynamic space";
        else if (where >= (lispobj *) STATIC_SPACE_START
                 && where <
                 (lispobj *) (STATIC_SPACE_START + static_space_size)) space =
                "static space";
        else if (where >= (lispobj *) READ_ONLY_SPACE_START
                 && where <
                 (lispobj *) (READ_ONLY_SPACE_START +
                              read_only_space_size)) space = "read-only space";
        else
            space = NULL;

        /* GC itself uses some stack, so we can't tell exactly where the
           invalid stack area starts.  Usually, it should be an error if a
           reference to a stack-allocated object is found, although it
           is valid to store a reference to a stack-allocated object
           temporarily in another reachable object, as long as the
           reference goes away at the end of a dynamic extent.  */

        if (p >= invalid_stack_start && p < invalid_stack_end)
            lose("Escaped stack-allocated object 0x%08lx at %p in %s\n",
                 (unsigned long) obj, where, space);
#ifndef i386
        else if ((where >= (lispobj *) CONTROL_STACK_START
                  && where < (lispobj *) (control_stack_end))
                 || (space == NULL)) {
            /* Do nothing if it the reference is from the control stack,
               because that will happen, and that's ok.  Or if it's from
               an unknown space (typically from scavenging an interrupt
               context. */
        }
#endif

        else
            fprintf(stderr,
                    "Reference to stack-allocated object 0x%08lx at %p in %s\n",
                    (unsigned long) obj, where,
                    space ? space : "Unknown space");
    }
#endif
}

#endif /* GC_ASSERTIONS */


#ifdef GC_ASSERTIONS
#define gc_assert(ex)           \
  do {                          \
    if (!(ex)) gc_abort ();     \
  } while (0)
#else
#define gc_assert(ex)  (void) 0
#endif
\f

/*
 * The number of generations, an extra is added to this for use as a temp.
 */
#define NUM_GENERATIONS 6

/* Debugging variables. */

/*
 * The verbose level. All non-error messages are disabled at level 0;
 * and only a few rare messages are printed at level 1.
 */
unsigned gencgc_verbose = 0;
unsigned counters_verbose = 0;

/*
 * If true, then some debugging information is printed when scavenging
 * static (malloc'ed) arrays.
 */
boolean debug_static_array_p = 0;

/*
 * To enable the use of page protection to help avoid the scavenging
 * of pages that don't have pointers to younger generations.
 */
boolean enable_page_protection = TRUE;

/*
 * Hunt for pointers to old-space, when GCing generations >= verify_gen.
 * Set to NUM_GENERATIONS to disable.
 */
int verify_gens = NUM_GENERATIONS;

/*
 * Enable a pre-scan verify of generation 0 before it's GCed.  (This
 * makes GC very, very slow, so don't enable this unless you really
 * need it!)
 */
boolean pre_verify_gen_0 = FALSE;

/*
 * Enable checking for bad pointers after gc_free_heap called from purify.
 */
#if 0 && defined(DARWIN)
boolean verify_after_free_heap = TRUE;
#else
boolean verify_after_free_heap = FALSE;
#endif

/*
 * Enable the printing of a note when code objects are found in the
 * dynamic space during a heap verify.
 */
boolean verify_dynamic_code_check = FALSE;

/*
 * Enable the checking of code objects for fixup errors after they are
 * transported.  (Only used for x86.)
 */
boolean check_code_fixups = FALSE;

/*
 * To enable unmapping of a page and re-mmaping it to have it zero filled.
 * Note: this can waste a lot of swap on FreeBSD and Open/NetBSD(?) so
 * don't unmap.
 */
#if defined(__FreeBSD__) || defined(__OpenBSD__) || defined(__NetBSD__)
boolean gencgc_unmap_zero = FALSE;
#else
boolean gencgc_unmap_zero = TRUE;
#endif

/*
 * Enable checking that newly allocated regions are zero filled.
 */
#if 0 && defined(DARWIN)
boolean gencgc_zero_check = TRUE;
boolean gencgc_enable_verify_zero_fill = TRUE;
#else
boolean gencgc_zero_check = FALSE;
boolean gencgc_enable_verify_zero_fill = FALSE;
#endif

/*
 * Enable checking that free pages are zero filled during gc_free_heap
 * called after purify.
 */
#if 0 && defined(DARWIN)
boolean gencgc_zero_check_during_free_heap = TRUE;
#else
boolean gencgc_zero_check_during_free_heap = FALSE;
#endif

/*
 * The minimum size for a large object.
 */
unsigned large_object_size = 4 * GC_PAGE_SIZE;

/*
 * Enable the filtering of stack/register pointers. This could reduce
 * the number of invalid pointers accepted. It will probably degrades
 * interrupt safety during object initialisation.
 */
boolean enable_pointer_filter = TRUE;
\f

/*
 * The total bytes allocated. Seen by (dynamic-usage)
 */
unsigned long bytes_allocated = 0;

/*
 * The total amount of bytes ever allocated.  Not decreased by GC.
 */

volatile unsigned long long bytes_allocated_sum = 0;

/*
 * GC trigger; a value of 0xffffffff represents disabled.
 */
unsigned long auto_gc_trigger = 0xffffffff;

/*
 * Number of pages to reserve for heap overflow.  We want some space
 * available on the heap when we are close to a heap overflow, so we
 * can handle the overflow.  But how much do we really need?  I (rtoy)
 * think 256 pages is probably a decent amount.  (That's 1 MB for x86,
 * 2 MB for sparc, which has 8K pages.)
 */

unsigned long reserved_heap_pages = 256;

/*
 * The src. and dest. generations. Set before a GC starts scavenging.
 */
static int from_space;
static int new_space;
\f

/*
 * GC structures and variables.
 */

/*
 * Number of pages within the dynamic heap, setup from the size of the
 * dynamic space.
 */
unsigned dynamic_space_pages;

/*
 * An array of page structures is statically allocated.
 * This helps quickly map between an address and its page structure.
 */
struct page *page_table;

/*
 * Heap base, needed for mapping addresses to page structures.
 */
static char *heap_base = NULL;

/*
 * Calculate the start address for the given page number.
 */
static char *
page_address(int page_num)
{
    return heap_base + GC_PAGE_SIZE * page_num;
}

/*
 * Find the page index within the page_table for the given address.
 * Returns -1 on failure.
 */
int
find_page_index(void *addr)
{
    int index = (char *) addr - heap_base;

    if (index >= 0) {
        index = (unsigned int) index / GC_PAGE_SIZE;
        if (index < dynamic_space_pages)
            return index;
    }

    return -1;
}

/*
 * This routine implements a write barrier used to record stores into
 * to boxed regions outside of generation 0.  When such a store occurs
 * this routine will be automatically invoked by the page fault
 * handler.  If passed an address outside of the dynamic space, this
 * routine will return immediately with a value of 0.  Otherwise, the
 * page belonging to the address is made writable, the protection
 * change is recorded in the garbage collector page table, and a value
 * of 1 is returned.
 */
int
gc_write_barrier(void *addr)
{
    int page_index = find_page_index(addr);

    /* Check if the fault is within the dynamic space. */
    if (page_index == -1) {
         return 0;
    }

    /* The page should have been marked write protected */
    if (!PAGE_WRITE_PROTECTED(page_index))
         fprintf(stderr,
                 "*** Page fault in page not marked as write protected\n");

    /* Un-protect the page */
    os_protect((os_vm_address_t) page_address(page_index), GC_PAGE_SIZE, OS_VM_PROT_ALL);
    page_table[page_index].flags &= ~PAGE_WRITE_PROTECTED_MASK;
    page_table[page_index].flags |= PAGE_WRITE_PROTECT_CLEARED_MASK;

    return 1;
}

/*
 * A structure to hold the state of a generation.
 */
#define MEM_AGE_SHIFT 16
#define MEM_AGE_SCALE (1 << MEM_AGE_SHIFT)

struct generation {

    /* The first page that gc_alloc checks on its next call. */
    int alloc_start_page;

    /* The first page that gc_alloc_unboxed checks on its next call. */
    int alloc_unboxed_start_page;

    /*
     * The first page that gc_alloc_large (boxed) considers on its next call.
     * Although it always allocates after the boxed_region.
     */
    int alloc_large_start_page;

    /*
     * The first page that gc_alloc_large (unboxed) considers on its next call.
     * Although it always allocates after the current_unboxed_region.
     */
    int alloc_large_unboxed_start_page;

    /* The bytes allocate to this generation. */
    int bytes_allocated;

    /* The number of bytes at which to trigger a GC */
    int gc_trigger;

    /* To calculate a new level for gc_trigger */
    int bytes_consed_between_gc;

    /* The number of GCs since the last raise. */
    int num_gc;

    /*
     * The average age at after which a GC will raise objects to the
     * next generation.
     */
    int trigger_age;

    /*
     * The cumulative sum of the bytes allocated to this generation. It
     * is cleared after a GC on this generation, and update before new
     * objects are added from a GC of a younger generation. Dividing by
     * the bytes_allocated will give the average age of the memory in
     * this generation since its last GC.
     */
    int cum_sum_bytes_allocated;

    /*
     * A minimum average memory age before a GC will occur helps prevent
     * a GC when a large number of new live objects have been added, in
     * which case a GC could be a waste of time.
     *
     * The age is represented as an integer between 0 and 32767
     * corresponding to an age of 0 to (just less than) 1.
     */
    int min_av_mem_age;
};

/*
 * An array of generation structures. There needs to be one more
 * generation structure than actual generations as the oldest
 * generations is temporarily raised then lowered.
 */
static struct generation generations[NUM_GENERATIONS + 1];

/* Statistics about a generation, extracted from the generations
   array.  This gets returned to Lisp.
*/

struct generation_stats {
    int bytes_allocated;
    int gc_trigger;
    int bytes_consed_between_gc;
    int num_gc;
    int trigger_age;
    int cum_sum_bytes_allocated;
    int min_av_mem_age;
};


/*
 * The oldest generation that will currently be GCed by default.
 * Valid values are: 0, 1, ... (NUM_GENERATIONS - 1)
 *
 * The default of (NUM_GENERATIONS - 1) enables GC on all generations.
 *
 * Setting this to 0 effectively disables the generational nature of
 * the GC. In some applications generational GC may not be useful
 * because there are no long-lived objects.
 *
 * An intermediate value could be handy after moving long-lived data
 * into an older generation so an unnecessary GC of this long-lived
 * data can be avoided.
 */
unsigned int gencgc_oldest_gen_to_gc = NUM_GENERATIONS - 1;


/*
 * The maximum free page in the heap is maintained and used to update
 * ALLOCATION_POINTER which is used by the room function to limit its
 * search of the heap. XX Gencgc obviously needs to be better
 * integrated with the lisp code.
 *
 * Except on sparc and ppc, there's no ALLOCATION_POINTER, so it's
 * never updated.  So make this available (non-static).
 */
int last_free_page;
\f

static void scan_weak_tables(void);
static void scan_weak_objects(void);

/*
 * Misc. heap functions.
 */

/*
 * Count the number of write protected pages within the given generation.
 */
static int
count_write_protect_generation_pages(int generation)
{
    int i;
    int cnt = 0;
    int mmask, mflags;

    mmask = PAGE_ALLOCATED_MASK | PAGE_WRITE_PROTECTED_MASK
        | PAGE_GENERATION_MASK;
    mflags = PAGE_ALLOCATED_MASK | PAGE_WRITE_PROTECTED_MASK | generation;

    for (i = 0; i < last_free_page; i++)
        if (PAGE_FLAGS(i, mmask) == mflags)
            cnt++;
    return cnt;
}

/*
 * Count the number of pages within the given generation.
 */
static int
count_generation_pages(int generation)
{
    int i;
    int cnt = 0;
    int mmask, mflags;

    mmask = PAGE_ALLOCATED_MASK | PAGE_GENERATION_MASK;
    mflags = PAGE_ALLOCATED_MASK | generation;

    for (i = 0; i < last_free_page; i++)
        if (PAGE_FLAGS(i, mmask) == mflags)
            cnt++;
    return cnt;
}

/*
 * Count the number of dont_move pages.
 */
static int
count_dont_move_pages(void)
{
    int i;
    int cnt = 0;
    int mmask;

    mmask = PAGE_ALLOCATED_MASK | PAGE_DONT_MOVE_MASK;

    for (i = 0; i < last_free_page; i++)
        if (PAGE_FLAGS(i, mmask) == mmask)
            cnt++;
    return cnt;
}

/*
 * Work through the pages and add up the number of bytes used for the
 * given generation.
 */
#ifdef GC_ASSERTIONS
static int
generation_bytes_allocated(int generation)
{
    int i;
    int bytes_allocated = 0;
    int mmask, mflags;

    mmask = PAGE_ALLOCATED_MASK | PAGE_GENERATION_MASK;
    mflags = PAGE_ALLOCATED_MASK | generation;

    for (i = 0; i < last_free_page; i++) {
        if (PAGE_FLAGS(i, mmask) == mflags)
            bytes_allocated += page_table[i].bytes_used;
    }
    return bytes_allocated;
}
#endif

/*
 * Return the average age of the memory in a generation.
 */
static int
gen_av_mem_age(int gen)
{
    if (generations[gen].bytes_allocated == 0)
        return 0;

    return (((long long) generations[gen].cum_sum_bytes_allocated) << MEM_AGE_SHIFT) /
        generations[gen].bytes_allocated;
}


void
save_fpu_state(void* state)
{
#if defined(i386) || defined(__x86_64)
    if (fpu_mode == SSE2) {
        sse_save(state);
    } else {
        fpu_save(state);
    }
#else
    fpu_save(state);
#endif    
}

void
restore_fpu_state(void* state)
{
#if defined(i386) || defined(__x86_64)
    if (fpu_mode == SSE2) {
        sse_restore(state);
    } else {
        fpu_restore(state);
    }
#else
    fpu_restore(state);
#endif
}


/*
 * The verbose argument controls how much to print out:
 * 0 for normal level of detail; 1 for debugging.
 */
void
print_generation_stats(int verbose)
{
    int i, gens;

    FPU_STATE(fpu_state);
    
    /*
     * This code uses the FP instructions which may be setup for Lisp so
     * they need to the saved and reset for C.
     */

    save_fpu_state(fpu_state);

    /* Number of generations to print out. */
    if (verbose)
        gens = NUM_GENERATIONS + 1;
    else
        gens = NUM_GENERATIONS;

    /* Print the heap stats */
    fprintf(stderr, "          Page count (%d KB)\n", GC_PAGE_SIZE / 1024);
    fprintf(stderr,
            "   Gen  Boxed Unboxed  LB   LUB    Alloc    Waste    Trigger   WP  GCs Mem-age\n");

    for (i = 0; i < gens; i++) {
        int j;
        int boxed_cnt = 0;
        int unboxed_cnt = 0;
        int large_boxed_cnt = 0;
        int large_unboxed_cnt = 0;

        for (j = 0; j < last_free_page; j++) {
            int flags = page_table[j].flags;

            if ((flags & PAGE_GENERATION_MASK) == i) {
                if (flags & PAGE_ALLOCATED_MASK) {
                    /*
                     * Count the number of boxed and unboxed pages within the
                     * given generation.
                     */
                    if (flags & PAGE_UNBOXED_MASK)
                        if (flags & PAGE_LARGE_OBJECT_MASK)
                            large_unboxed_cnt++;
                        else
                            unboxed_cnt++;
                    else if (flags & PAGE_LARGE_OBJECT_MASK)
                        large_boxed_cnt++;
                    else
                        boxed_cnt++;
                }
            }
        }

        gc_assert(generations[i].bytes_allocated ==
                  generation_bytes_allocated(i));
        fprintf(stderr, " %5d: %5d %5d %5d %5d %10d %6d %10d %4d %3d %7.4f\n",
                i, boxed_cnt, unboxed_cnt, large_boxed_cnt, large_unboxed_cnt,
                generations[i].bytes_allocated,
                GC_PAGE_SIZE * count_generation_pages(i) -
                generations[i].bytes_allocated, generations[i].gc_trigger,
                count_write_protect_generation_pages(i), generations[i].num_gc,
                (double)gen_av_mem_age(i) / MEM_AGE_SCALE);
    }
    fprintf(stderr, "   Total bytes alloc=%ld\n", bytes_allocated);

    restore_fpu_state(fpu_state);
}

/* Get statistics that are kept "on the fly" out of the generation
   array.
*/
void
get_generation_stats(int gen, struct generation_stats *stats)
{
    if (gen <= NUM_GENERATIONS) {
        stats->bytes_allocated = generations[gen].bytes_allocated;
        stats->gc_trigger = generations[gen].gc_trigger;
        stats->bytes_consed_between_gc =
            generations[gen].bytes_consed_between_gc;
        stats->num_gc = generations[gen].num_gc;
        stats->trigger_age = generations[gen].trigger_age;
        stats->cum_sum_bytes_allocated =
            generations[gen].cum_sum_bytes_allocated;
        stats->min_av_mem_age = generations[gen].min_av_mem_age;
    }
}

void
set_gc_trigger(int gen, int trigger)
{
    if (gen <= NUM_GENERATIONS) {
        generations[gen].gc_trigger = trigger;
    }
}

void
set_trigger_age(int gen, int trigger_age)
{
    if (gen <= NUM_GENERATIONS) {
        generations[gen].trigger_age = trigger_age;
    }
}

void
set_min_mem_age(int gen, double min_mem_age)
{
    if (gen <= NUM_GENERATIONS) {
        generations[gen].min_av_mem_age = min_mem_age * MEM_AGE_SCALE;
    }
}
\f
/*
 * Allocation routines.
 *
 *
 * To support quick and inline allocation, regions of memory can be
 * allocated and then allocated from with just a free pointer and a
 * check against an end address.
 *
 * Since objects can be allocated to spaces with different properties
 * e.g. boxed/unboxed, generation, ages; there may need to be many
 * allocation regions.
 *
 * Each allocation region may be start within a partly used page.
 * Many features of memory use are noted on a page wise basis,
 * E.g. the generation; so if a region starts within an existing
 * allocated page it must be consistent with this page.
 *
 * During the scavenging of the newspace, objects will be transported
 * into an allocation region, and pointers updated to point to this
 * allocation region. It is possible that these pointers will be
 * scavenged again before the allocation region is closed, E.g. due to
 * trans_list which jumps all over the place to cleanup the list. It
 * is important to be able to determine properties of all objects
 * pointed to when scavenging, E.g to detect pointers to the
 * oldspace. Thus it's important that the allocation regions have the
 * correct properties set when allocated, and not just set when
 * closed.  The region allocation routines return regions with the
 * specified properties, and grab all the pages, setting there
 * properties appropriately, except that the amount used is not known.
 *
 * These regions are used to support quicker allocation using just a
 * free pointer. The actual space used by the region is not reflected
 * in the pages tables until it is closed. It can't be scavenged until
 * closed.
 *
 * When finished with the region it should be closed, which will
 * update the page tables for the actual space used returning unused
 * space. Further it may be noted in the new regions which is
 * necessary when scavenging the newspace.
 *
 * Large objects may be allocated directly without an allocation
 * region, the page tables are updated immediately.
 *
 * Unboxed objects don't contain points to other objects so don't need
 * scavenging. Further they can't contain pointers to younger
 * generations so WP is not needed.  By allocating pages to unboxed
 * objects the whole page never needs scavenging or write protecting.
 */

/*
 * Only using two regions at present, both are for the current
 * newspace generation.
 */
struct alloc_region boxed_region;
struct alloc_region unboxed_region;

#if 0
/*
 * X hack. current lisp code uses the following. Need coping in/out.
 */
void *current_region_free_pointer;
void *current_region_end_addr;
#endif

/* The generation currently being allocated to. X */
static int gc_alloc_generation = 0;

extern void do_dynamic_space_overflow_warning(void);
extern void do_dynamic_space_overflow_error(void);

/* Handle heap overflow here, maybe. */
static void
handle_heap_overflow(const char *msg, int size)
{
    unsigned long heap_size_mb;

    if (msg) {
        fprintf(stderr, msg, size);
    }
#ifndef SPARSE_BLOCK_SIZE
#define SPARSE_BLOCK_SIZE (0)
#endif

    /* Figure out how many MB of heap we have */
    heap_size_mb = (dynamic_space_size + SPARSE_BLOCK_SIZE) >> 20;

    fprintf(stderr, " CMUCL has run out of dynamic heap space (%lu MB).\n",
            heap_size_mb);
    /* Try to handle heap overflow somewhat gracefully if we can. */
#if defined(trap_DynamicSpaceOverflow) || defined(FEATURE_HEAP_OVERFLOW_CHECK)
    if (reserved_heap_pages == 0) {
        fprintf(stderr, "\n Returning to top-level.\n");
        do_dynamic_space_overflow_error();
    } else {
        fprintf(stderr,
                "  You can control heap size with the -dynamic-space-size commandline option.\n");
        do_dynamic_space_overflow_warning();
    }
#else
    print_generation_stats(1);

    exit(1);
#endif
}

/*
 * Find a new region with room for at least the given number of bytes.
 *
 * It starts looking at the current generations alloc_start_page. So
 * may pick up from the previous region if there is enough space. This
 * keeps the allocation contiguous when scavenging the newspace.
 *
 * The alloc_region should have been closed by a call to
 * gc_alloc_update_page_tables, and will thus be in an empty state.
 *
 * To assist the scavenging functions, write protected pages are not
 * used. Free pages should not be write protected.
 *
 * It is critical to the conservative GC that the start of regions be
 * known. To help achieve this only small regions are allocated at a
 * time.
 *
 * During scavenging, pointers may be found that point within the
 * current region and the page generation must be set so pointers to
 * the from space can be recognised.  So the generation of pages in
 * the region are set to gc_alloc_generation.  To prevent another
 * allocation call using the same pages, all the pages in the region
 * are allocated, although they will initially be empty.
 */
static void
gc_alloc_new_region(int nbytes, int unboxed, struct alloc_region *alloc_region)
{
    int first_page;
    int last_page;
    int region_size;
    int restart_page;
    int bytes_found;
    int num_pages;
    int i;
    int mmask, mflags;

    /* Shut up some compiler warnings */
    last_page = bytes_found = 0;

#if 0
    fprintf(stderr, "alloc_new_region for %d bytes from gen %d\n",
            nbytes, gc_alloc_generation);
#endif

    /* Check that the region is in a reset state. */
    gc_assert(alloc_region->first_page == 0
              && alloc_region->last_page == -1
              && alloc_region->free_pointer == alloc_region->end_addr);

    if (unboxed)
        restart_page =
            generations[gc_alloc_generation].alloc_unboxed_start_page;
    else
        restart_page = generations[gc_alloc_generation].alloc_start_page;

    /*
     * Search for a contiguous free region of at least nbytes with the
     * given properties: boxed/unboxed, generation. First setting up the
     * mask and matching flags.
     */

    mmask = PAGE_ALLOCATED_MASK | PAGE_WRITE_PROTECTED_MASK
        | PAGE_LARGE_OBJECT_MASK | PAGE_DONT_MOVE_MASK
        | PAGE_UNBOXED_MASK | PAGE_GENERATION_MASK;
    mflags = PAGE_ALLOCATED_MASK | (unboxed << PAGE_UNBOXED_SHIFT)
        | gc_alloc_generation;

    do {
        first_page = restart_page;

        /*
         * First search for a page with at least 32 bytes free, that is
         * not write protected, or marked dont_move.
         */

        while (first_page < dynamic_space_pages) {
            int flags = page_table[first_page].flags;

            if (!(flags & PAGE_ALLOCATED_MASK)
                || ((flags & mmask) == mflags &&
                    page_table[first_page].bytes_used < GC_PAGE_SIZE - 32))
                break;
            first_page++;
        }

        /* Check for a failure */
        if (first_page >= dynamic_space_pages - reserved_heap_pages) {
#if 0
            handle_heap_overflow("*A2 gc_alloc_new_region failed, nbytes=%d.\n",
                                 nbytes);
#else
            break;
#endif
        }

        gc_assert(!PAGE_WRITE_PROTECTED(first_page));

#if 0
        fprintf(stderr, "  first_page=%d bytes_used=%d\n",
                first_page, page_table[first_page].bytes_used);
#endif

        /*
         * Now search forward to calculate the available region size.  It
         * tries to keeps going until nbytes are found and the number of
         * pages is greater than some level. This helps keep down the
         * number of pages in a region.
         */
        last_page = first_page;
        bytes_found = GC_PAGE_SIZE - page_table[first_page].bytes_used;
        num_pages = 1;
        while ((bytes_found < nbytes || num_pages < 2)
               && last_page < dynamic_space_pages - 1
               && !PAGE_ALLOCATED(last_page + 1)) {
            last_page++;
            num_pages++;
            bytes_found += GC_PAGE_SIZE;
            gc_assert(!PAGE_WRITE_PROTECTED(last_page));
        }

        region_size = (GC_PAGE_SIZE - page_table[first_page].bytes_used)
            + GC_PAGE_SIZE * (last_page - first_page);

        gc_assert(bytes_found == region_size);

#if 0
        fprintf(stderr, "  last_page=%d bytes_found=%d num_pages=%d\n",
                last_page, bytes_found, num_pages);
#endif

        restart_page = last_page + 1;
    }
    while (restart_page < dynamic_space_pages && bytes_found < nbytes);

    if (first_page >= dynamic_space_pages - reserved_heap_pages) {
        handle_heap_overflow("*A2 gc_alloc_new_region failed, nbytes=%d.\n",
                             nbytes);
    }

    /* Check for a failure */
    if (restart_page >= (dynamic_space_pages - reserved_heap_pages)
        && bytes_found < nbytes) {
        handle_heap_overflow("*A1 gc_alloc_new_region failed, nbytes=%d.\n",
                             nbytes);
    }
#if 0
    fprintf(stderr,
            "gc_alloc_new_region gen %d: %d bytes: from pages %d to %d: addr=%x\n",
            gc_alloc_generation, bytes_found, first_page, last_page,
            page_address(first_page));
#endif

    /* Setup the alloc_region. */
    alloc_region->first_page = first_page;
    alloc_region->last_page = last_page;
    alloc_region->start_addr = page_table[first_page].bytes_used
        + page_address(first_page);
    alloc_region->free_pointer = alloc_region->start_addr;
    alloc_region->end_addr = alloc_region->start_addr + bytes_found;

    if (gencgc_zero_check) {
        int *p;

        for (p = (int *) alloc_region->start_addr;
             p < (int *) alloc_region->end_addr; p++)
            if (*p != 0)
                fprintf(stderr, "** new region not zero @ %lx\n",
                        (unsigned long) p);
    }

    /* Setup the pages. */

    /* The first page may have already been in use. */
    if (page_table[first_page].bytes_used == 0) {
        PAGE_FLAGS_UPDATE(first_page, mmask, mflags);
        page_table[first_page].first_object_offset = 0;
    }

    gc_assert(PAGE_ALLOCATED(first_page));
    gc_assert(PAGE_UNBOXED_VAL(first_page) == unboxed);
    gc_assert(PAGE_GENERATION(first_page) == gc_alloc_generation);
    gc_assert(!PAGE_LARGE_OBJECT(first_page));

    for (i = first_page + 1; i <= last_page; i++) {
        PAGE_FLAGS_UPDATE(i, PAGE_ALLOCATED_MASK | PAGE_LARGE_OBJECT_MASK
                          | PAGE_UNBOXED_MASK | PAGE_GENERATION_MASK,
                          PAGE_ALLOCATED_MASK | (unboxed << PAGE_UNBOXED_SHIFT)
                          | gc_alloc_generation);
        /*
         * This may not be necessary for unboxed regions (think it was
         * broken before!)
         */
        page_table[i].first_object_offset =
            alloc_region->start_addr - page_address(i);
    }

    /* Bump up the last_free_page */
    if (last_page + 1 > last_free_page) {
        last_free_page = last_page + 1;
        set_alloc_pointer((lispobj) ((char *) heap_base +
                                     GC_PAGE_SIZE * last_free_page));

    }
}



/*
 * If the record_new_objects flag is 2 then all new regions created
 * are recorded.
 *
 * If it's 1 then it is only recorded if the first page of the
 * current region is <= new_areas_ignore_page. This helps avoid
 * unnecessary recording when doing full scavenge pass.
 *
 * The new_object structure holds the page, byte offset, and size of
 * new regions of objects. Each new area is placed in the array of
 * these structures pointed to by new_areas; new_areas_index holds the
 * offset into new_areas.
 *
 * If new_area overflows NUM_NEW_AREAS then it stops adding them. The
 * later code must detect this an handle it, probably by doing a full
 * scavenge of a generation.
 */

#define NUM_NEW_AREAS 512
static int record_new_objects = 0;
static int new_areas_ignore_page;
struct new_area {
    int page;
    int offset;
    int size;
};
static struct new_area (*new_areas)[];
static int new_areas_index = 0;
int max_new_areas;

/* Add a new area to new_areas. */
static void
add_new_area(int first_page, int offset, int size)
{
    unsigned new_area_start, c;
    int i;

    /* Ignore if full */
    if (new_areas_index >= NUM_NEW_AREAS)
        return;

    switch (record_new_objects) {
      case 0:
          return;
      case 1:
          if (first_page > new_areas_ignore_page)
              return;
          break;
      case 2:
          break;
      default:
          gc_abort();
    }

    new_area_start = GC_PAGE_SIZE * first_page + offset;

    /*
     * Search backwards for a prior area that this follows from.  If
     * found this will save adding a new area.
     */
    for (i = new_areas_index - 1, c = 0; i >= 0 && c < 8; i--, c++) {
        unsigned area_end = GC_PAGE_SIZE * (*new_areas)[i].page
            + (*new_areas)[i].offset + (*new_areas)[i].size;

#if 0
        fprintf(stderr, "*S1 %d %d %d %d\n", i, c, new_area_start, area_end);
#endif
        if (new_area_start == area_end) {
#if 0
            fprintf(stderr, "-> Adding to [%d] %d %d %d with %d %d %d:\n",
                    i, (*new_areas)[i].page, (*new_areas)[i].offset,
                    (*new_areas)[i].size, first_page, offset, size);
#endif
            (*new_areas)[i].size += size;
            return;
        }
    }
#if 0
    fprintf(stderr, "*S1 %d %d %d\n", i, c, new_area_start);
#endif

    (*new_areas)[new_areas_index].page = first_page;
    (*new_areas)[new_areas_index].offset = offset;
    (*new_areas)[new_areas_index].size = size;
#if 0
    fprintf(stderr, "  new_area %d page %d offset %d size %d\n",
            new_areas_index, first_page, offset, size);
#endif
    new_areas_index++;

    /* Note the max new_areas used. */
    if (new_areas_index > max_new_areas)
        max_new_areas = new_areas_index;
}


/*
 * Update the tables for the alloc_region. The region may be added to
 * the new_areas.
 *
 * When done the alloc_region its setup so that the next quick alloc
 * will fail safely and thus a new region will be allocated. Further
 * it is safe to try and re-update the page table of this reset
 * alloc_region.
 */
void
gc_alloc_update_page_tables(int unboxed, struct alloc_region *alloc_region)
{
    int more;
    int first_page;
    int next_page;
    int bytes_used;
    int orig_first_page_bytes_used;
    int region_size;
    int byte_cnt;

#if 0
    fprintf(stderr, "gc_alloc_update_page_tables to gen %d: ",
            gc_alloc_generation);
#endif

    first_page = alloc_region->first_page;

    /* Catch an unused alloc_region. */
    if (first_page == 0 && alloc_region->last_page == -1)
        return;

    next_page = first_page + 1;

    /* Skip if no bytes were allocated */
    if (alloc_region->free_pointer != alloc_region->start_addr) {
        orig_first_page_bytes_used = page_table[first_page].bytes_used;

        gc_assert(alloc_region->start_addr == page_address(first_page) +
                  page_table[first_page].bytes_used);

        /* All the pages used need to be updated */

        /* Update the first page. */

#if 0
        fprintf(stderr, "0");
#endif

        /* If the page was free then setup the gen, and first_object_offset. */
        if (page_table[first_page].bytes_used == 0)
            gc_assert(page_table[first_page].first_object_offset == 0);

        gc_assert(PAGE_ALLOCATED(first_page));
        gc_assert(PAGE_UNBOXED_VAL(first_page) == unboxed);
        gc_assert(PAGE_GENERATION(first_page) == gc_alloc_generation);
        gc_assert(!PAGE_LARGE_OBJECT(first_page));

        byte_cnt = 0;

        /*
         * Calc. the number of bytes used in this page. This is not always
         * the number of new bytes, unless it was free.
         */
        more = 0;
        bytes_used = alloc_region->free_pointer - page_address(first_page);
        if (bytes_used > GC_PAGE_SIZE) {
            bytes_used = GC_PAGE_SIZE;
            more = 1;
        }
        page_table[first_page].bytes_used = bytes_used;
        byte_cnt += bytes_used;

        /*
         * All the rest of the pages should be free. Need to set their
         * first_object_offset pointer to the start of the region, and set
         * the bytes_used.
         */
        while (more) {
#if 0
            fprintf(stderr, "+");
#endif
            gc_assert(PAGE_ALLOCATED(next_page));
            gc_assert(PAGE_UNBOXED_VAL(next_page) == unboxed);
            gc_assert(page_table[next_page].bytes_used == 0);
            gc_assert(PAGE_GENERATION(next_page) == gc_alloc_generation);
            gc_assert(!PAGE_LARGE_OBJECT(next_page));

            gc_assert(page_table[next_page].first_object_offset ==
                      alloc_region->start_addr - page_address(next_page));

            /* Calc. the number of bytes used in this page. */
            more = 0;
            bytes_used = alloc_region->free_pointer - page_address(next_page);
            if (bytes_used > GC_PAGE_SIZE) {
                bytes_used = GC_PAGE_SIZE;
                more = 1;
            }
            page_table[next_page].bytes_used = bytes_used;
            byte_cnt += bytes_used;

            next_page++;
        }

        region_size = alloc_region->free_pointer - alloc_region->start_addr;
        bytes_allocated += region_size;
        generations[gc_alloc_generation].bytes_allocated += region_size;

        gc_assert(byte_cnt - orig_first_page_bytes_used == region_size);

        /*
         * Set the generations alloc restart page to the last page of
         * the region.
         */
        if (unboxed)
            generations[gc_alloc_generation].alloc_unboxed_start_page =
                next_page - 1;
        else
            generations[gc_alloc_generation].alloc_start_page = next_page - 1;

        /* Add the region to the new_areas if requested. */
        if (!unboxed)
            add_new_area(first_page, orig_first_page_bytes_used, region_size);

#if 0
        fprintf(stderr,
                "  gc_alloc_update_page_tables update %d bytes to gen %d\n",
                region_size, gc_alloc_generation);
#endif
    } else
        /*
         * No bytes allocated. Unallocate the first_page if there are 0 bytes_used.
         */
    if (page_table[first_page].bytes_used == 0)
        page_table[first_page].flags &= ~PAGE_ALLOCATED_MASK;

    /* Unallocate any unused pages. */
    while (next_page <= alloc_region->last_page) {
        gc_assert(page_table[next_page].bytes_used == 0);
        page_table[next_page].flags &= ~PAGE_ALLOCATED_MASK;
        next_page++;
    }

    /* Reset the alloc_region. */
    alloc_region->first_page = 0;
    alloc_region->last_page = -1;
    alloc_region->start_addr = page_address(0);
    alloc_region->free_pointer = page_address(0);
    alloc_region->end_addr = page_address(0);

#if 0
    fprintf(stderr, "\n");
#endif
}



static inline void *gc_quick_alloc(int nbytes);

/*
 * Allocate a possibly large object.
 */
static void *
gc_alloc_large(int nbytes, int unboxed, struct alloc_region *alloc_region)
{
    int first_page;
    int last_page;
    int region_size;
    int restart_page;
    int bytes_found;
    int num_pages;
    int orig_first_page_bytes_used;
    int byte_cnt;
    int more;
    int bytes_used;
    int next_page;
    int large = (nbytes >= large_object_size);
    int mmask, mflags;


    /* Shut up some compiler warnings */
    last_page = bytes_found = 0;

#if 0
    if (nbytes > 200000)
        fprintf(stderr, "*** alloc_large %d\n", nbytes);
#endif

#if 0
    fprintf(stderr, "gc_alloc_large for %d bytes from gen %d\n",
            nbytes, gc_alloc_generation);
#endif

    /*
     * If the object is small, and there is room in the current region
     * then allocation it in the current region.
     */
    if (!large && alloc_region->end_addr - alloc_region->free_pointer >= nbytes)
        return gc_quick_alloc(nbytes);

    /*
     * Search for a contiguous free region of at least nbytes. If it's a
     * large object then align it on a page boundary by searching for a
     * free page.
     */

    /*
     * To allow the allocation of small objects without the danger of
     * using a page in the current boxed region, the search starts after
     * the current boxed free region. XX could probably keep a page
     * index ahead of the current region and bumped up here to save a
     * lot of re-scanning.
     */
    if (unboxed)
        restart_page =
            generations[gc_alloc_generation].alloc_large_unboxed_start_page;
    else
        restart_page = generations[gc_alloc_generation].alloc_large_start_page;
    if (restart_page <= alloc_region->last_page)
        restart_page = alloc_region->last_page + 1;

    /* Setup the mask and matching flags. */

    mmask = PAGE_ALLOCATED_MASK | PAGE_WRITE_PROTECTED_MASK
        | PAGE_LARGE_OBJECT_MASK | PAGE_DONT_MOVE_MASK
        | PAGE_UNBOXED_MASK | PAGE_GENERATION_MASK;
    mflags = PAGE_ALLOCATED_MASK | (unboxed << PAGE_UNBOXED_SHIFT)
        | gc_alloc_generation;

    do {
        first_page = restart_page;

        if (large)
            while (first_page < dynamic_space_pages
                   && PAGE_ALLOCATED(first_page)) first_page++;
        else
            while (first_page < dynamic_space_pages) {
                int flags = page_table[first_page].flags;

                if (!(flags & PAGE_ALLOCATED_MASK)
                    || ((flags & mmask) == mflags &&
                        page_table[first_page].bytes_used < GC_PAGE_SIZE - 32))
                    break;
                first_page++;
            }

        /* Check for a failure */
        if (first_page >= dynamic_space_pages - reserved_heap_pages) {
#if 0
            handle_heap_overflow("*A2 gc_alloc_large failed, nbytes=%d.\n",
                                 nbytes);
#else
            break;
#endif
        }
        gc_assert(!PAGE_WRITE_PROTECTED(first_page));

#if 0
        fprintf(stderr, "  first_page=%d bytes_used=%d\n",
                first_page, page_table[first_page].bytes_used);
#endif

        last_page = first_page;
        bytes_found = GC_PAGE_SIZE - page_table[first_page].bytes_used;
        num_pages = 1;
        while (bytes_found < nbytes
               && last_page < dynamic_space_pages - 1
               && !PAGE_ALLOCATED(last_page + 1)) {
            last_page++;
            num_pages++;
            bytes_found += GC_PAGE_SIZE;
            gc_assert(!PAGE_WRITE_PROTECTED(last_page));
        }

        region_size = (GC_PAGE_SIZE - page_table[first_page].bytes_used)
            + GC_PAGE_SIZE * (last_page - first_page);

        gc_assert(bytes_found == region_size);

#if 0
        fprintf(stderr, "  last_page=%d bytes_found=%d num_pages=%d\n",
                last_page, bytes_found, num_pages);
#endif

        restart_page = last_page + 1;
    }
    while ((restart_page < dynamic_space_pages) && (bytes_found < nbytes));

    if (first_page >= dynamic_space_pages - reserved_heap_pages) {
        handle_heap_overflow("*A2 gc_alloc_large failed, nbytes=%d.\n", nbytes);
    }

    /* Check for a failure */
    if (restart_page >= (dynamic_space_pages - reserved_heap_pages)
        && bytes_found < nbytes) {
        handle_heap_overflow("*A1 gc_alloc_large failed, nbytes=%d.\n", nbytes);
    }
#if 0
    if (large)
        fprintf(stderr,
                "gc_alloc_large gen %d: %d of %d bytes: from pages %d to %d: addr=%x\n",
                gc_alloc_generation, nbytes, bytes_found, first_page, last_page,
                page_address(first_page));
#endif

    gc_assert(first_page > alloc_region->last_page);
    if (unboxed)
        generations[gc_alloc_generation].alloc_large_unboxed_start_page =
            last_page;
    else
        generations[gc_alloc_generation].alloc_large_start_page = last_page;

    /* Setup the pages. */
    orig_first_page_bytes_used = page_table[first_page].bytes_used;

    /*
     * If the first page was free then setup the gen, and
     * first_object_offset.
     */

    if (large)
        mflags |= PAGE_LARGE_OBJECT_MASK;
    if (page_table[first_page].bytes_used == 0) {
        PAGE_FLAGS_UPDATE(first_page, mmask, mflags);
        page_table[first_page].first_object_offset = 0;
    }

    gc_assert(PAGE_ALLOCATED(first_page));
    gc_assert(PAGE_UNBOXED_VAL(first_page) == unboxed);
    gc_assert(PAGE_GENERATION(first_page) == gc_alloc_generation);
    gc_assert(PAGE_LARGE_OBJECT_VAL(first_page) == large);

    byte_cnt = 0;

    /*
     * Calc. the number of bytes used in this page. This is not
     * always the number of new bytes, unless it was free.
     */
    more = 0;
    bytes_used = nbytes + orig_first_page_bytes_used;
    if (bytes_used > GC_PAGE_SIZE) {
        bytes_used = GC_PAGE_SIZE;
        more = 1;
    }
    page_table[first_page].bytes_used = bytes_used;
    byte_cnt += bytes_used;

    next_page = first_page + 1;

    /*
     * All the rest of the pages should be free. Need to set their
     * first_object_offset pointer to the start of the region, and set
     * the bytes_used.
     */
    while (more) {
#if 0
        fprintf(stderr, "+");
#endif

        gc_assert(!PAGE_ALLOCATED(next_page));
        gc_assert(page_table[next_page].bytes_used == 0);
        PAGE_FLAGS_UPDATE(next_page, mmask, mflags);

        page_table[next_page].first_object_offset =
            orig_first_page_bytes_used - GC_PAGE_SIZE * (next_page - first_page);

        /* Calc. the number of bytes used in this page. */
        more = 0;
        bytes_used = nbytes + orig_first_page_bytes_used - byte_cnt;
        if (bytes_used > GC_PAGE_SIZE) {
            bytes_used = GC_PAGE_SIZE;
            more = 1;
        }
        page_table[next_page].bytes_used = bytes_used;
        byte_cnt += bytes_used;

        next_page++;
    }

    gc_assert(byte_cnt - orig_first_page_bytes_used == nbytes);

    bytes_allocated += nbytes;
    generations[gc_alloc_generation].bytes_allocated += nbytes;

    /* Add the region to the new_areas if requested. */
    if (!unboxed)
        add_new_area(first_page, orig_first_page_bytes_used, nbytes);

    /* Bump up the last_free_page */
    if (last_page + 1 > last_free_page) {
        last_free_page = last_page + 1;
        set_alloc_pointer((lispobj) ((char *) heap_base +
                                     GC_PAGE_SIZE * last_free_page));
    }

    return (void *) (page_address(first_page) + orig_first_page_bytes_used);
}

/*
 * If the current region has more than this much space left, we don't
 * want to abandon the region (wasting space), but do a "large" alloc
 * to a new region.
 */

int region_empty_threshold = 32;


/*
 * How many consecutive large alloc we can do before we abandon the
 * current region.
 */
int consecutive_large_alloc_limit = 10;


/*
 * Statistics for the current region
 */
struct alloc_stats 
{
    /*
     * How many consecutive allocations we have tried with the current
     * region (in saved_region)
     */
    int consecutive_alloc;
    /*
     * How many times we tried to allocate to this region but didn't
     * because we didn't have enough room and did a large alloc in a
     * different region.
     */
    int abandon_region_count;

    /*
     * A copy of the current allocation region which we use to compare
     * against.
     */
    struct alloc_region saved_region;
};

/* Statistics for boxed and unboxed regions */
struct alloc_stats boxed_stats =
{0, 0, 
 {NULL, NULL, -1, -1, NULL}};
     
struct alloc_stats unboxed_stats =
{0, 0, 
 {NULL, NULL, -1, -1, NULL}};

/*
 * Try to allocate from the current region.  If it's possible, do the
 * allocation and return the object.  If it's not possible, return
 * (void*) -1.
 */
static inline void *
gc_alloc_try_current_region(int nbytes, struct alloc_region *region, int unboxed,
                            struct alloc_stats *stats)
{
    char *new_free_pointer;

    /* Check if there is room in the current alloc region. */
    new_free_pointer = region->free_pointer + nbytes;

    if (new_free_pointer <= region->end_addr) {
        /* If so then allocate from the current alloc region. */
        char *new_obj = region->free_pointer;

        region->free_pointer = new_free_pointer;

        /* Check if the alloc region is almost empty. */
        if (region->end_addr - region->free_pointer <= region_empty_threshold) {
            /* If so finished with the current region. */
            gc_alloc_update_page_tables(unboxed, region);
            /* Setup a new region. */
            gc_alloc_new_region(region_empty_threshold, unboxed, region);
        }

        stats->consecutive_alloc = 0;
        stats->abandon_region_count = 0;
        memcpy(&stats->saved_region, region, sizeof(stats->saved_region));
        
        return (void *) new_obj;
    } else {
        return (void *) -1;
    }
}

/*
 * Allocate bytes from a boxed or unboxed region. It first checks if
 * there is room, if not then it calls gc_alloc_new_region to find a
 * new region with enough space. A pointer to the start of the region
 * is returned.  The parameter "unboxed" should be 0 (boxed) or 1
 * (unboxed).
 */
static void *
gc_alloc_region(int nbytes, struct alloc_region *region, int unboxed, struct alloc_stats *stats)
{
    void *new_obj;
    
#if 0
    fprintf(stderr, "gc_alloc %d\n", nbytes);
#endif

    /* Check if there is room in the current alloc region. */

    new_obj = gc_alloc_try_current_region(nbytes, region, unboxed, stats);
    if (new_obj != (void *) -1) {
        return new_obj;
    }

    /* Else not enough free space in the current region. */

    /*
     * If the allocation is large enough, always do a large alloc This
     * helps GC so we don't have to copy this object again.
     */
    
    if (nbytes >= large_object_size) {
        return gc_alloc_large(nbytes, unboxed, region);
    }
    
    /*
     * If there is a bit of room left in the current region then
     * allocate a large object.
     */

    /*
     * This has potentially very bad behavior on sparc if the current
     * boxed region is too small for the allocation, but the free
     * space is greater than 32 (region_empty_threshold).  The
     * scenario is where we're always allocating something that won't
     * fit in the boxed region, and we keep calling gc_alloc_large.
     * Since gc_alloc_large doesn't change the region, the next
     * allocation will again be out-of-line and we hit a kernel trap
     * again.  And so on, so we waste all of our time doing kernel
     * traps to allocate small things.  This also affects ppc.
     *
     * X86 has the same issue, but the affect is less because the
     * out-of-line allocation is a just a function call, not a kernel
     * trap.
     *
     * Heuristic: If we do too many consecutive large allocations
     * because the current region has some space left, we give up and
     * abandon the region. This will prevent the bad scenario above
     * from killing allocation performance.
     *
     */

    if ((region->end_addr - region->free_pointer > region_empty_threshold)
        && (stats->consecutive_alloc < consecutive_large_alloc_limit)) {
        /*
         * Is the saved region the same as the current region?  If so,
         * update the counter.  If not, that means we did some other
         * (inline) allocation, so reset the counters and region to
         * the current region.
         */
        if (memcmp(&stats->saved_region, region, sizeof(stats->saved_region)) == 0) {
            ++stats->consecutive_alloc;
        } else {
            stats->consecutive_alloc = 0;
            stats->abandon_region_count = 0;
            memcpy(&stats->saved_region, region, sizeof(stats->saved_region));
        }
        
        return gc_alloc_large(nbytes, unboxed, region);
    }

    /*
     * We given up on the current region because the
     * consecutive_large_alloc_limit has been reached.
     */
    stats->consecutive_alloc = 0;
    ++stats->abandon_region_count;

    /* Finished with the current region. */
    gc_alloc_update_page_tables(unboxed, region);

    /* Setup a new region. */
    gc_alloc_new_region(nbytes, unboxed, region);

    /* Should now be enough room. */

    new_obj = gc_alloc_try_current_region(nbytes, region, unboxed, stats);
    if (new_obj != (void *) -1) {
        return new_obj;
    }

    /* Shouldn't happen? */
    gc_assert(0);
    return 0;
}

/*
 * Allocate bytes from the boxed_region. It first checks if there is
 * room, if not then it calls gc_alloc_new_region to find a new region
 * with enough space. A pointer to the start of the region is returned.
 */
static inline void *
gc_alloc(int nbytes)
{
    void* obj;

    obj = gc_alloc_region(nbytes, &boxed_region, 0, &boxed_stats);

    return obj;
}

/*
 * Allocate space from the boxed_region. If there is not enough free
 * space then call gc_alloc to do the job. A pointer to the start of
 * the region is returned.
 */
static inline void *
gc_quick_alloc(int nbytes)
{
    char *new_free_pointer;

    /* Check if there is room in the current region. */
    new_free_pointer = boxed_region.free_pointer + nbytes;

    if (new_free_pointer <= boxed_region.end_addr) {
        /* If so then allocate from the current region. */
        void *new_obj = boxed_region.free_pointer;

        boxed_region.free_pointer = new_free_pointer;
        return (void *) new_obj;
    }

    /* Else call gc_alloc */
    return gc_alloc(nbytes);
}

/*
 * Allocate space for the boxed object. If it is a large object then
 * do a large alloc else allocate from the current region. If there is
 * not enough free space then call gc_alloc to do the job. A pointer
 * to the start of the region is returned.
 */
static inline void *
gc_quick_alloc_large(int nbytes)
{
    char *new_free_pointer;

    if (nbytes >= large_object_size)
        return gc_alloc_large(nbytes, 0, &boxed_region);

    /* Check if there is room in the current region. */
    new_free_pointer = boxed_region.free_pointer + nbytes;

    if (new_free_pointer <= boxed_region.end_addr) {
        /* If so then allocate from the current region. */
        void *new_obj = boxed_region.free_pointer;

        boxed_region.free_pointer = new_free_pointer;
        return (void *) new_obj;
    }

    /* Else call gc_alloc */
    return gc_alloc(nbytes);
}

static inline void *
gc_alloc_unboxed(int nbytes)
{
    void *obj;

    obj = gc_alloc_region(nbytes, &unboxed_region, 1, &unboxed_stats);

    return obj;
}

static inline void *
gc_quick_alloc_unboxed(int nbytes)
{
    char *new_free_pointer;

    /* Check if there is room in the current region. */
    new_free_pointer = unboxed_region.free_pointer + nbytes;

    if (new_free_pointer <= unboxed_region.end_addr) {
        /* If so then allocate from the current region. */
        void *new_obj = unboxed_region.free_pointer;

        unboxed_region.free_pointer = new_free_pointer;

        return (void *) new_obj;
    }

    /* Else call gc_alloc */
    return gc_alloc_unboxed(nbytes);
}

/*
 * Allocate space for the object. If it is a large object then do a
 * large alloc else allocate from the current region. If there is not
 * enough free space then call gc_alloc to do the job.
 *
 * A pointer to the start of the region is returned.
 */
static inline void *
gc_quick_alloc_large_unboxed(int nbytes)
{
    char *new_free_pointer;

    if (nbytes >= large_object_size)
        return gc_alloc_large(nbytes, 1, &unboxed_region);

    /* Check if there is room in the current region. */
    new_free_pointer = unboxed_region.free_pointer + nbytes;

    if (new_free_pointer <= unboxed_region.end_addr) {
        /* If so then allocate from the current region. */
        void *new_obj = unboxed_region.free_pointer;

        unboxed_region.free_pointer = new_free_pointer;

        return (void *) new_obj;
    }

    /* Else call gc_alloc */
    return gc_alloc_unboxed(nbytes);
}

/***************************************************************************/
\f

/* Scavenging/transporting routines derived from gc.c */

static int (*scavtab[256]) (lispobj * where, lispobj object);
static lispobj(*transother[256]) (lispobj object);
static int (*sizetab[256]) (lispobj * where);

static struct weak_pointer *weak_pointers;
static struct scavenger_hook *scavenger_hooks = (struct scavenger_hook *) NIL;

/* Like (ceiling x y), but y is constrained to be a power of two */
#define CEILING(x,y) (((x) + ((y) - 1)) & (~((y) - 1)))
\f

/* Predicates */

static inline boolean
from_space_p(lispobj obj)
{
    int page_index = (char *) obj - heap_base;

    return page_index >= 0
        && (page_index =
            (unsigned int) page_index / GC_PAGE_SIZE) < dynamic_space_pages
        && PAGE_GENERATION(page_index) == from_space;
}

static inline boolean
new_space_p(lispobj obj)
{
    int page_index = (char *) obj - heap_base;

    return page_index >= 0
        && (page_index =
            (unsigned int) page_index / GC_PAGE_SIZE) < dynamic_space_pages
        && PAGE_GENERATION(page_index) == new_space;
}

static inline boolean
dynamic_space_p(lispobj obj)
{
    lispobj end = DYNAMIC_0_SPACE_START + DYNAMIC_SPACE_SIZE;

    return (obj >= DYNAMIC_0_SPACE_START) && (obj < end);
}

static inline boolean
static_space_p(lispobj obj)
{
    lispobj end = SymbolValue(STATIC_SPACE_FREE_POINTER);

    return (obj >= STATIC_SPACE_START) && (obj < end);
}

static inline boolean
read_only_space_p(lispobj obj)
{
    lispobj end = SymbolValue(READ_ONLY_SPACE_FREE_POINTER);

    return (obj >= READ_ONLY_SPACE_START) && (obj < end);
}

static inline boolean
control_stack_space_p(lispobj obj)
{
    lispobj end = CONTROL_STACK_START + control_stack_size;

    return (obj >= CONTROL_STACK_START) && (obj < end);
}

static inline boolean
binding_stack_space_p(lispobj obj)
{
    lispobj end = BINDING_STACK_START + binding_stack_size;

    return (obj >= BINDING_STACK_START) && (obj < end);
}
    
static inline boolean
signal_space_p(lispobj obj)
{
#ifdef SIGNAL_STACK_START
    lispobj end = SIGNAL_STACK_START + SIGSTKSZ;

    return (obj >= SIGNAL_STACK_START) && (obj < end);
#else
    return FALSE;
#endif    
}

#if (defined(DARWIN) && defined(__ppc__))
/*
 * The assembly code defines these as functions, so we make them
 * functions.  We only care about their addresses anyway.
 */
extern char closure_tramp();
extern char undefined_tramp();
#elif defined(sparc)
/* closure tramp and undefined tramp are Lisp assembly routines */
#elif (defined(i386) || defined(__x86_64))
/* undefined tramp are Lisp assembly routines */
#else
extern int undefined_tramp;
#endif

/*
 * Other random places that can't be in malloc space.  Return TRUE if
 * obj is in some other known space
 */
static inline boolean
other_space_p(lispobj obj)
{
    boolean in_space = FALSE;
    
#if defined(sparc)
    extern char _end;
    
    /*
     * Skip over any objects in the C runtime which includes the
     * closure_tramp and undefined_tramp objects.  There appears to be
     * one other object that points to somewhere in call_into_c, but I
     * don't know what that is.  I think that's probably all for
     * sparc.
     */
    if ((char*) obj <= &_end) {
        in_space = TRUE;
    }
#elif defined(i386)
#if defined(DARWIN) || defined(__linux__) || defined(__FreeBSD__) || defined(__NetBSD__)
    /*
     * For x86, we see some object at 0xffffffe9.  I (rtoy) am not
     * sure that is, but it clearly can't be in malloc space so we
     * want to skip that (by returning TRUE).
     *
     * Is there anything else?
     */
    if (obj == (lispobj) 0xffffffe9) {
        in_space = TRUE;
    }
#elif defined(__ppc__)
    /*
     * For ppc, just ignore anything below fpu_restore, which is
     * currently at the end of ppc-assem.S.
     */
    if (obj <= (lispobj) &fpu_restore) {
        in_space = TRUE;
    }
#endif
#endif  

    return in_space;
}

\f

/* Copying Objects */


/* Copying Boxed Objects */
static inline lispobj
copy_object(lispobj object, int nwords)
{
    int tag;
    lispobj *new;
    lispobj *source, *dest;

    gc_assert(Pointerp(object));
    gc_assert(from_space_p(object));
    gc_assert((nwords & 0x01) == 0);

    /* get tag of object */
    tag = LowtagOf(object);

    /* allocate space */
    new = gc_quick_alloc(nwords * sizeof(lispobj));

    dest = new;
    source = (lispobj *) PTR(object);

    /* copy the object */
    while (nwords > 0) {
        dest[0] = source[0];
        dest[1] = source[1];
        dest += 2;
        source += 2;
        nwords -= 2;
    }

    /* return lisp pointer of new object */
    return (lispobj) new | tag;
}

/*
 * Copying Large Boxed Objects. If the object is in a large object
 * region then it is simply promoted, else it is copied. If it's large
 * enough then it's copied to a large object region.
 *
 * Vectors may have shrunk. If the object is not copied the space
 * needs to be reclaimed, and the page_tables corrected.
 */
static lispobj
copy_large_object(lispobj object, int nwords)
{
    int tag;
    lispobj *new;
    lispobj *source, *dest;
    int first_page;

    gc_assert(Pointerp(object));
    gc_assert(from_space_p(object));
    gc_assert((nwords & 0x01) == 0);

    if (gencgc_verbose && nwords > 1024 * 1024)
        fprintf(stderr, "** copy_large_object: %lu\n",
                (unsigned long) (nwords * sizeof(lispobj)));

    /* Check if it's a large object. */
    first_page = find_page_index((void *) object);
    gc_assert(first_page >= 0);

    if (PAGE_LARGE_OBJECT(first_page)) {
        /* Promote the object. */
        int remaining_bytes;
        int next_page;
        int bytes_freed;
        int old_bytes_used;
        int mmask, mflags;

        /*
         * Note: Any page write protection must be removed, else a later
         * scavenge_newspace may incorrectly not scavenge these pages.
         * This would not be necessary if they are added to the new areas,
         * but lets do it for them all (they'll probably be written
         * anyway?).
         */

        gc_assert(page_table[first_page].first_object_offset == 0);

        next_page = first_page;
        remaining_bytes = nwords * sizeof(lispobj);
        while (remaining_bytes > GC_PAGE_SIZE) {
            gc_assert(PAGE_GENERATION(next_page) == from_space);
            gc_assert(PAGE_ALLOCATED(next_page));
            gc_assert(!PAGE_UNBOXED(next_page));
            gc_assert(PAGE_LARGE_OBJECT(next_page));
            gc_assert(page_table[next_page].first_object_offset ==
                      GC_PAGE_SIZE * (first_page - next_page));
            gc_assert(page_table[next_page].bytes_used == GC_PAGE_SIZE);

            PAGE_FLAGS_UPDATE(next_page, PAGE_GENERATION_MASK, new_space);

            /*
             * Remove any write protection.  Should be able to religh on the
             * WP flag to avoid redundant calls.
             */
            if (PAGE_WRITE_PROTECTED(next_page)) {
                os_protect((os_vm_address_t) page_address(next_page), GC_PAGE_SIZE,
                           OS_VM_PROT_ALL);
                page_table[next_page].flags &= ~PAGE_WRITE_PROTECTED_MASK;
            }
            remaining_bytes -= GC_PAGE_SIZE;
            next_page++;
        }

        /*
         * Now only one page remains, but the object may have shrunk so
         * there may be more unused pages which will be freed.
         */

        /* Object may have shrunk but shouldn't have grown - check. */
        gc_assert(page_table[next_page].bytes_used >= remaining_bytes);

        PAGE_FLAGS_UPDATE(next_page, PAGE_GENERATION_MASK, new_space);
        gc_assert(PAGE_ALLOCATED(next_page));
        gc_assert(!PAGE_UNBOXED(next_page));

        /* Adjust the bytes_used. */
        old_bytes_used = page_table[next_page].bytes_used;
        page_table[next_page].bytes_used = remaining_bytes;

        bytes_freed = old_bytes_used - remaining_bytes;

        mmask = PAGE_ALLOCATED_MASK | PAGE_UNBOXED_MASK | PAGE_LARGE_OBJECT_MASK
            | PAGE_GENERATION_MASK;
        mflags = PAGE_ALLOCATED_MASK | PAGE_LARGE_OBJECT_MASK | from_space;

        /* Free any remaining pages; needs care. */
        next_page++;
        while (old_bytes_used == GC_PAGE_SIZE &&
               PAGE_FLAGS(next_page, mmask) == mflags &&
               page_table[next_page].first_object_offset ==
               GC_PAGE_SIZE * (first_page - next_page)) {
            /*
             * Checks out OK, free the page. Don't need to both zeroing
             * pages as this should have been done before shrinking the
             * object. These pages shouldn't be write protected as they
             * should be zero filled.
             */
            gc_assert(!PAGE_WRITE_PROTECTED(next_page));

            old_bytes_used = page_table[next_page].bytes_used;
            page_table[next_page].flags &= ~PAGE_ALLOCATED_MASK;
            page_table[next_page].bytes_used = 0;
            bytes_freed += old_bytes_used;
            next_page++;
        }

        if (gencgc_verbose && bytes_freed > 0)
            fprintf(stderr, "* copy_large_boxed bytes_freed %d\n", bytes_freed);

        generations[from_space].bytes_allocated -=
            sizeof(lispobj) * nwords + bytes_freed;
        generations[new_space].bytes_allocated += sizeof(lispobj) * nwords;
        bytes_allocated -= bytes_freed;

        /* Add the region to the new_areas if requested. */
        add_new_area(first_page, 0, nwords * sizeof(lispobj));

        return object;
    } else {
        /* get tag of object */
        tag = LowtagOf(object);

        /* allocate space */
        new = gc_quick_alloc_large(nwords * sizeof(lispobj));

        dest = new;
        source = (lispobj *) PTR(object);

        /* copy the object */
        while (nwords > 0) {
            dest[0] = source[0];
            dest[1] = source[1];
            dest += 2;
            source += 2;
            nwords -= 2;
        }

        /* return lisp pointer of new object */
        return (lispobj) new | tag;
    }
}

/* Copying UnBoxed Objects. */
static inline lispobj
copy_unboxed_object(lispobj object, int nwords)
{
    int tag;
    lispobj *new;
    lispobj *source, *dest;

    gc_assert(Pointerp(object));
    gc_assert(from_space_p(object));
    gc_assert((nwords & 0x01) == 0);

    /* get tag of object */
    tag = LowtagOf(object);

    /* allocate space */
    new = gc_quick_alloc_unboxed(nwords * sizeof(lispobj));

    dest = new;
    source = (lispobj *) PTR(object);

    /* Copy the object */
    while (nwords > 0) {
        dest[0] = source[0];
        dest[1] = source[1];
        dest += 2;
        source += 2;
        nwords -= 2;
    }

    /* Return lisp pointer of new object. */
    return (lispobj) new | tag;
}


/*
 * Copying Large Unboxed Objects. If the object is in a large object
 * region then it is simply promoted, else it is copied. If it's large
 * enough then it's copied to a large object region.
 *
 * Bignums and vectors may have shrunk. If the object is not copied
 * the space needs to be reclaimed, and the page_tables corrected.
 */
static lispobj
copy_large_unboxed_object(lispobj object, int nwords)
{
    int tag;
    lispobj *new;
    lispobj *source, *dest;
    int first_page;

    gc_assert(Pointerp(object));
    gc_assert(from_space_p(object));
    gc_assert((nwords & 0x01) == 0);

    if (gencgc_verbose && nwords > 1024 * 1024)
        fprintf(stderr, "** copy_large_unboxed_object: %lu\n",
                (unsigned long) (nwords * sizeof(lispobj)));

    /* Check if it's a large object. */
    first_page = find_page_index((void *) object);
    gc_assert(first_page >= 0);

    if (PAGE_LARGE_OBJECT(first_page)) {
        /*
         * Promote the object. Note: Unboxed objects may have been
         * allocated to a BOXED region so it may be necessary to change
         * the region to UNBOXED.
         */
        int remaining_bytes;
        int next_page;
        int bytes_freed;
        int old_bytes_used;
        int mmask, mflags;

        gc_assert(page_table[first_page].first_object_offset == 0);

        next_page = first_page;
        remaining_bytes = nwords * sizeof(lispobj);
        while (remaining_bytes > GC_PAGE_SIZE) {
            gc_assert(PAGE_GENERATION(next_page) == from_space);
            gc_assert(PAGE_ALLOCATED(next_page));
            gc_assert(PAGE_LARGE_OBJECT(next_page));
            gc_assert(page_table[next_page].first_object_offset ==
                      GC_PAGE_SIZE * (first_page - next_page));
            gc_assert(page_table[next_page].bytes_used == GC_PAGE_SIZE);

            PAGE_FLAGS_UPDATE(next_page,
                              PAGE_UNBOXED_MASK | PAGE_GENERATION_MASK,
                              PAGE_UNBOXED_MASK | new_space);
            remaining_bytes -= GC_PAGE_SIZE;
            next_page++;
        }

        /*
         * Now only one page remains, but the object may have shrunk so
         * there may be more unused pages which will be freed.
         */

        /* Object may have shrunk but shouldn't have grown - check. */
        gc_assert(page_table[next_page].bytes_used >= remaining_bytes);

        PAGE_FLAGS_UPDATE(next_page, PAGE_ALLOCATED_MASK | PAGE_UNBOXED_MASK
                          | PAGE_GENERATION_MASK,
                          PAGE_ALLOCATED_MASK | PAGE_UNBOXED_MASK | new_space);

        /* Adjust the bytes_used. */
        old_bytes_used = page_table[next_page].bytes_used;
        page_table[next_page].bytes_used = remaining_bytes;

        bytes_freed = old_bytes_used - remaining_bytes;

        mmask = PAGE_ALLOCATED_MASK | PAGE_LARGE_OBJECT_MASK
            | PAGE_GENERATION_MASK;
        mflags = PAGE_ALLOCATED_MASK | PAGE_LARGE_OBJECT_MASK | from_space;

        /* Free any remaining pages; needs care. */
        next_page++;
        while (old_bytes_used == GC_PAGE_SIZE &&
               PAGE_FLAGS(next_page, mmask) == mflags &&
               page_table[next_page].first_object_offset ==
               GC_PAGE_SIZE * (first_page - next_page)) {
            /*
             * Checks out OK, free the page. Don't need to both zeroing
             * pages as this should have been done before shrinking the
             * object. These pages shouldn't be write protected, even if
             * boxed they should be zero filled.
             */
            gc_assert(!PAGE_WRITE_PROTECTED(next_page));

            old_bytes_used = page_table[next_page].bytes_used;
            page_table[next_page].flags &= ~PAGE_ALLOCATED_MASK;
            page_table[next_page].bytes_used = 0;
            bytes_freed += old_bytes_used;
            next_page++;
        }

        if (gencgc_verbose && bytes_freed > 0)
            fprintf(stderr, "* copy_large_unboxed bytes_freed %d\n",
                    bytes_freed);

        generations[from_space].bytes_allocated -=
            sizeof(lispobj) * nwords + bytes_freed;
        generations[new_space].bytes_allocated += sizeof(lispobj) * nwords;
        bytes_allocated -= bytes_freed;

        return object;
    } else {
        /* get tag of object */
        tag = LowtagOf(object);

        /* allocate space */
        new = gc_quick_alloc_large_unboxed(nwords * sizeof(lispobj));

        dest = new;
        source = (lispobj *) PTR(object);

        /* copy the object */
        while (nwords > 0) {
            dest[0] = source[0];
            dest[1] = source[1];
            dest += 2;
            source += 2;
            nwords -= 2;
        }

        /* return lisp pointer of new object */
        return (lispobj) new | tag;
    }
}

static inline boolean
maybe_static_array_p(lispobj header)
{
    boolean result;
    
    switch (TypeOf(header)) {
        /*
         * This needs to be coordinated to the set of allowed
         * static vectors in make-array.
         */
      case type_SimpleString:
      case type_SimpleArrayUnsignedByte8:
      case type_SimpleArrayUnsignedByte16:
      case type_SimpleArrayUnsignedByte32:
#ifdef type_SimpleArraySignedByte8
      case type_SimpleArraySignedByte8:
#endif
#ifdef type_SimpleArraySignedByte16
      case type_SimpleArraySignedByte16:
#endif
#ifdef type_SimpleArraySignedByte32
      case type_SimpleArraySignedByte32:
#endif
      case type_SimpleArraySingleFloat:
      case type_SimpleArrayDoubleFloat:
#ifdef type_SimpleArrayLongFloat
      case type_SimpleArrayLongFloat:
#endif
#ifdef type_SimpleArrayComplexSingleFloat
      case type_SimpleArrayComplexSingleFloat:
#endif
#ifdef type_SimpleArrayComplexDoubleFloat
      case type_SimpleArrayComplexDoubleFloat:
#endif
#ifdef type_SimpleArrayComplexLongFloat
      case type_SimpleArrayComplexLongFloat:
#endif
          result = TRUE;
          break;
      default:
          result = FALSE;
    }
    return result;
}

\f

/* Scavenging */

/*
 * Douglas Crosher says:
 *
 * There were two different ways in which the scavenger dispatched,
 * and DIRECT_SCAV was one option.  This code did work at one stage
 * but testing showed it to be slower.  When DIRECT_SCAV is enabled
 * the scavenger dispatches via the scavtab for all objects, and when
 * disabled the scavenger firstly detects and handles some common
 * cases itself before dispatching.
 */

#define DIRECT_SCAV 0

static void
scavenge(void *start_obj, long nwords)
{
    lispobj *start;

    start = (lispobj *) start_obj;

    while (nwords > 0) {
        lispobj object;
        int words_scavenged;

        object = *start;
        /* Not a forwarding pointer. */
        gc_assert(object != 0x01);

#if DIRECT_SCAV
        words_scavenged = scavtab[TypeOf(object)] (start, object);
#else /* not DIRECT_SCAV */
        if (Pointerp(object)) {
#ifdef GC_ASSERTIONS
            check_escaped_stack_object(start, object);
#endif

            if (from_space_p(object)) {
                lispobj *ptr = (lispobj *) PTR(object);
                lispobj first_word = *ptr;

                if (first_word == 0x01) {
                    *start = ptr[1];
                    words_scavenged = 1;
                } else {
                    words_scavenged = scavtab[TypeOf(object)] (start, object);
                }
            } else if (dynamic_space_p(object) || new_space_p(object) || static_space_p(object)
                       || read_only_space_p(object) || control_stack_space_p(object)
                       || binding_stack_space_p(object) || signal_space_p(object)
                       || other_space_p(object)) {
                words_scavenged = 1;
            } else {
                lispobj *ptr = (lispobj *) PTR(object);
                words_scavenged = 1;
                if (debug_static_array_p) {
                    fprintf(stderr, "Not in Lisp spaces:  object = %p, ptr = %p\n",
                            (void*)object, ptr);    
                }
                
                if (1) {
                    lispobj header = *ptr;
                    if (debug_static_array_p) {
                        fprintf(stderr, "  Header value = 0x%lx\n", (unsigned long) header);
                    }
                    
                    if (maybe_static_array_p(header)) {
                        int static_p;

                        if (debug_static_array_p) {
                            fprintf(stderr, "Possible static vector at %p.  header = 0x%lx\n",
                                    ptr, (unsigned long) header);
                        }
                      
                        static_p = (HeaderValue(header) & 1) == 1;
                        if (static_p) {
                            /*
                             * We have a static vector.  Mark it as
                             * reachable by setting the MSB of the header.
                             */
                            *ptr = header | 0x80000000;
                            if (debug_static_array_p) {
                                fprintf(stderr, "Scavenged static vector @%p, header = 0x%lx\n",
                                        ptr, (unsigned long) header);
                            }
                        }
                    }
                }
            }
        } else if ((object & 3) == 0)
            words_scavenged = 1;
        else
            words_scavenged = scavtab[TypeOf(object)] (start, object);
#endif /* not DIRECT_SCAV */

        start += words_scavenged;
        nwords -= words_scavenged;
    }

    gc_assert(nwords == 0);
}
\f

#if !(defined(i386) || defined(__x86_64))
/* Scavenging Interrupt Contexts */

static int boxed_registers[] = BOXED_REGISTERS;

/* The GC has a notion of an "interior pointer" register, an unboxed
 * register that typically contains a pointer to inside an object
 * referenced by another pointer.  The most obvious of these is the
 * program counter, although many compiler backends define a "Lisp
 * Interior Pointer" register known as reg_LIP, and various CPU
 * architectures have other registers that also partake of the
 * interior-pointer nature.  As the code for pairing an interior
 * pointer value up with its "base" register, and fixing it up after
 * scavenging is complete is horribly repetitive, a few macros paper
 * over the monotony.  --AB, 2010-Jul-14 */

#define INTERIOR_POINTER_VARS(name) \
    unsigned long name;             \
    unsigned long name##_offset;    \
    int name##_register_pair

#define PAIR_INTERIOR_POINTER(name, accessor)           \
    name = accessor;                                    \
    pair_interior_pointer(context, name,                \
                          &name##_offset,               \
                          &name##_register_pair)

/*
 * Do we need to check if the register we're fixing up is in the
 * from-space?
 */
#define FIXUP_INTERIOR_POINTER(name, accessor)                          \
    do {                                                                \
        if (name##_register_pair >= 0) {                                \
            accessor =                                                  \
                PTR(SC_REG(context, name##_register_pair))              \
                + name##_offset;                                        \
        }                                                               \
    } while (0)


static void
pair_interior_pointer(os_context_t *context, unsigned long pointer,
                      unsigned long *saved_offset, int *register_pair)
{
    int i;

    /*
     * I (RLT) think this is trying to find the boxed register that is
     * closest to the LIP address, without going past it.  Usually, it's
     * reg_CODE or reg_LRA.  But sometimes, nothing can be found.
     */
    *saved_offset = 0x7FFFFFFF;
    *register_pair = -1;
    for (i = 0; i < (sizeof(boxed_registers) / sizeof(int)); i++) {
        unsigned long reg;
        long offset;
        int index;

        index = boxed_registers[i];
        reg = SC_REG(context, index);

        /* An interior pointer is never relative to a non-pointer
         * register (an oversight in the original implementation).
         * The simplest argument for why this is true is to consider
         * the fixnum that happens by coincide to be the word-index in
         * memory of the header for some object plus two.  This is
         * happenstance would cause the register containing the fixnum
         * to be selected as the register_pair if the interior pointer
         * is to anywhere after the first two words of the object.
         * The fixnum won't be changed during GC, but the object might
         * move, thus destroying the interior pointer.  --AB,
         * 2010-Jul-14 */

        if (Pointerp(reg) && (PTR(reg) <= pointer)) {
            offset = pointer - PTR(reg);
            if (offset < *saved_offset) {
                *saved_offset = offset;
                *register_pair = index;
            }
        }
    }
}


static void
scavenge_interrupt_context(os_context_t * context)
{
    int i;

    INTERIOR_POINTER_VARS(pc);
#ifdef reg_LIP
    INTERIOR_POINTER_VARS(lip);
#endif
#ifdef reg_LR
    INTERIOR_POINTER_VARS(lr);
#endif
#ifdef reg_CTR    
    INTERIOR_POINTER_VARS(ctr);
#endif
#ifdef SC_NPC
    INTERIOR_POINTER_VARS(npc);
#endif

#ifdef reg_LIP
    PAIR_INTERIOR_POINTER(lip, SC_REG(context, reg_LIP));
#endif /* reg_LIP */

    PAIR_INTERIOR_POINTER(pc, SC_PC(context));

#ifdef SC_NPC
    PAIR_INTERIOR_POINTER(npc, SC_NPC(context));
#endif    

#ifdef reg_LR
    PAIR_INTERIOR_POINTER(lr, SC_REG(context, reg_LR));
#endif

#ifdef reg_CTR
    PAIR_INTERIOR_POINTER(ctr, SC_REG(context, reg_CTR));
#endif    
    
    /* Scanvenge all boxed registers in the context. */
    for (i = 0; i < (sizeof(boxed_registers) / sizeof(int)); i++) {
        int index;
        lispobj foo;

        index = boxed_registers[i];
        foo = SC_REG(context, index);
        scavenge(&foo, 1);
        SC_REG(context, index) = foo;

        scavenge(&(SC_REG(context, index)), 1);
    }

    /*
     * Now that the scavenging is done, repair the various interior
     * pointers.
     */
#ifdef reg_LIP
    FIXUP_INTERIOR_POINTER(lip, SC_REG(context, reg_LIP));
#endif

    FIXUP_INTERIOR_POINTER(pc, SC_PC(context));

#ifdef SC_NPC
    FIXUP_INTERIOR_POINTER(npc, SC_NPC(context));
#endif

#ifdef reg_LR
    FIXUP_INTERIOR_POINTER(lr, SC_REG(context, reg_LR));
#endif

#ifdef reg_CTR
    FIXUP_INTERIOR_POINTER(ctr, SC_REG(context, reg_CTR));
#endif
}

void
scavenge_interrupt_contexts(void)
{
    int i, index;
    os_context_t *context;

#ifdef PRINTNOISE
    printf("Scavenging interrupt contexts ...\n");
#endif

    index = fixnum_value(SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX));

#if defined(DEBUG_PRINT_CONTEXT_INDEX)
    printf("Number of active contexts: %d\n", index);
#endif

    for (i = 0; i < index; i++) {
        context = lisp_interrupt_contexts[i];
        scavenge_interrupt_context(context);
    }
}
#endif
\f
/* Code and Code-Related Objects */

/*
 * Aargh!  Why is SPARC so different here?  What is the advantage of
 * making it different from all the other ports?
 */
#if defined(sparc) || (defined(DARWIN) && defined(__ppc__))
#define RAW_ADDR_OFFSET 0
#else
#define RAW_ADDR_OFFSET (6 * sizeof(lispobj) - type_FunctionPointer)
#endif

static lispobj trans_function_header(lispobj object);
static lispobj trans_boxed(lispobj object);

#if DIRECT_SCAV
static int
scav_function_pointer(lispobj * where, lispobj object)
{
    gc_assert(Pointerp(object));

    if (from_space_p(object)) {
        lispobj first, *first_pointer;

        /*
         * Object is a pointer into from space - check to see if it has
         * been forwarded.
         */
        first_pointer = (lispobj *) PTR(object);
        first = *first_pointer;

        if (first == 0x01) {
            /* Forwarded */
            *where = first_pointer[1];
            return 1;
        } else {
            int type;
            lispobj copy;

            /*
             * Must transport object -- object may point to either a
             * function header, a closure function header, or to a closure
             * header.
             */

            type = TypeOf(first);
            switch (type) {
              case type_FunctionHeader:
              case type_ClosureFunctionHeader:
                  copy = trans_function_header(object);
                  break;
              default:
                  copy = trans_boxed(object);
                  break;
            }

            if (copy != object) {
                /* Set forwarding pointer. */
                first_pointer[0] = 0x01;
                first_pointer[1] = copy;
            }

            first = copy;
        }

        gc_assert(Pointerp(first));
        gc_assert(!from_space_p(first));

        *where = first;
    }
    return 1;
}
#else
static int
scav_function_pointer(lispobj * where, lispobj object)
{
    lispobj *first_pointer;
    lispobj copy;

    gc_assert(Pointerp(object));

    /* Object is a pointer into from space - no a FP. */
    first_pointer = (lispobj *) PTR(object);

    /*
     * Must transport object -- object may point to either a function
     * header, a closure function header, or to a closure header.
     */

    switch (TypeOf(*first_pointer)) {
      case type_FunctionHeader:
      case type_ClosureFunctionHeader:
          copy = trans_function_header(object);
          break;
      default:
          copy = trans_boxed(object);
          break;
    }

    if (copy != object) {
        /* Set forwarding pointer */
        first_pointer[0] = 0x01;
        first_pointer[1] = copy;
    }

    gc_assert(Pointerp(copy));
    gc_assert(!from_space_p(copy));

    *where = copy;

    return 1;
}
#endif

#if defined(i386) || defined(__x86_64)
/*
 * Scan an x86 compiled code object, looking for possible fixups that
 * have been missed after a move.
 *
 * Two types of fixups are needed:
 *      1. Absolution fixups to within the code object.
 *      2. Relative fixups to outside the code object.
 *
 * Currently only absolution fixups to the constant vector, or to the
 * code area are checked.
 */
void
sniff_code_object(struct code *code, unsigned displacement)
{
    int nheader_words, ncode_words, nwords;
    char *p;
    char *constants_start_addr, *constants_end_addr;
    char *code_start_addr, *code_end_addr;
    int fixup_found = 0;

    if (!check_code_fixups)
        return;

    /*
     * It's ok if it's byte compiled code. The trace table offset will
     * be a fixnum if it's x86 compiled code - check.
     */
    if (code->trace_table_offset & 0x3) {
#if 0
        fprintf(stderr, "*** Sniffing byte compiled code object at %x.\n",
                code);
#endif
        return;
    }

    /* Else it's x86 machine code. */

    ncode_words = fixnum_value(code->code_size);
    nheader_words = HeaderValue(*(lispobj *) code);
    nwords = ncode_words + nheader_words;

    constants_start_addr = (char *) code + 5 * sizeof(lispobj);
    constants_end_addr = (char *) code + nheader_words * sizeof(lispobj);
    code_start_addr = (char *) code + nheader_words * sizeof(lispobj);
    code_end_addr = (char *) code + nwords * sizeof(lispobj);

    /* Work through the unboxed code. */
    for (p = code_start_addr; p < code_end_addr; p++) {
        char *data = *(char **) p;
        unsigned d1 = *((unsigned char *) p - 1);
        unsigned d2 = *((unsigned char *) p - 2);
        unsigned d3 = *((unsigned char *) p - 3);
        unsigned d4 = *((unsigned char *) p - 4);
        unsigned d5 = *((unsigned char *) p - 5);
        unsigned d6 = *((unsigned char *) p - 6);

        /*
         * Check for code references.
         *
         * Check for a 32 bit word that looks like an absolute reference
         * to within the code adea of the code object.
         */
        if (data >= code_start_addr - displacement
            && data < code_end_addr - displacement) {
            /* Function header */
            if (d4 == 0x5e
                && ((unsigned long) p - 4 -
                    4 * HeaderValue(*((unsigned long *) p - 1))) ==
                (unsigned long) code) {
                /* Skip the function header */
                p += 6 * 4 - 4 - 1;
                continue;
            }
            /* Push imm32 */
            if (d1 == 0x68) {
                fixup_found = 1;
                fprintf(stderr,
                        "Code ref. @ %lx: %.2x %.2x %.2x %.2x %.2x %.2x (%.8lx)\n",
                        (unsigned long) p, d6, d5, d4, d3, d2, d1,
                        (unsigned long) data);
                fprintf(stderr, "***  Push $0x%.8lx\n", (unsigned long) data);
            }
            /* Mov [reg-8],imm32 */
            if (d3 == 0xc7
                && (d2 == 0x40 || d2 == 0x41 || d2 == 0x42 || d2 == 0x43
                    || d2 == 0x45 || d2 == 0x46 || d2 == 0x47)
                && d1 == 0xf8) {
                fixup_found = 1;
                fprintf(stderr,
                        "Code ref. @ %lx: %.2x %.2x %.2x %.2x %.2x %.2x (%.8lx)\n",
                        (unsigned long) p, d6, d5, d4, d3, d2, d1,
                        (unsigned long) data);
                fprintf(stderr, "***  Mov [reg-8],$0x%.8lx\n",
                        (unsigned long) data);
            }
            /* Lea reg, [disp32] */
            if (d2 == 0x8d && (d1 & 0xc7) == 5) {
                fixup_found = 1;
                fprintf(stderr,
                        "Code ref. @ %lx: %.2x %.2x %.2x %.2x %.2x %.2x (%.8lx)\n",
                        (unsigned long) p, d6, d5, d4, d3, d2, d1,
                        (unsigned long) data);
                fprintf(stderr, "***  Lea reg,[$0x%.8lx]\n",
                        (unsigned long) data);
            }
        }

        /*
         * Check for constant references.
         *
         * Check for a 32 bit word that looks like an absolution reference
         * to within the constant vector. Constant references will be
         * aligned.
         */
        if (data >= constants_start_addr - displacement
            && data < constants_end_addr - displacement
            && ((unsigned long) data & 0x3) == 0) {
            /*  Mov eax,m32 */
            if (d1 == 0xa1) {
                fixup_found = 1;
                fprintf(stderr,
                        "Abs. const. ref. @ %lx: %.2x %.2x %.2x %.2x %.2x %.2x (%.8lx)\n",
                        (unsigned long) p, d6, d5, d4, d3, d2, d1,
                        (unsigned long) data);
                fprintf(stderr, "***  Mov eax,0x%.8lx\n", (unsigned long) data);
            }

            /*  Mov m32,eax */
            if (d1 == 0xa3) {
                fixup_found = 1;
                fprintf(stderr,
                        "Abs. const. ref. @ %lx: %.2x %.2x %.2x %.2x %.2x %.2x (%.8lx)\n",
                        (unsigned long) p, d6, d5, d4, d3, d2, d1,
                        (unsigned long) data);
                fprintf(stderr, "***  Mov 0x%.8lx,eax\n", (unsigned long) data);
            }

            /* Cmp m32,imm32 */
            if (d1 == 0x3d && d2 == 0x81) {
                fixup_found = 1;
                fprintf(stderr,
                        "Abs. const. ref. @ %lx: %.2x %.2x %.2x %.2x %.2x %.2x (%.8lx)\n",
                        (unsigned long) p, d6, d5, d4, d3, d2, d1,
                        (unsigned long) data);
                /* XX Check this */
                fprintf(stderr, "***  Cmp 0x%.8lx,immed32\n",
                        (unsigned long) data);
            }

            /* Check for a mod=00, r/m=101 byte. */
            if ((d1 & 0xc7) == 5) {
                /* Cmp m32,reg */
                if (d2 == 0x39) {
                    fixup_found = 1;
                    fprintf(stderr,
                            "Abs. const. ref. @ %lx: %.2x %.2x %.2x %.2x %.2x %.2x (%.8lx)\n",
                            (unsigned long) p, d6, d5, d4, d3, d2, d1,
                            (unsigned long) data);
                    fprintf(stderr, "***  Cmp 0x%.8lx,reg\n",
                            (unsigned long) data);
                }
                /* Cmp reg32,m32 */
                if (d2 == 0x3b) {
                    fixup_found = 1;
                    fprintf(stderr,
                            "Abs. const. ref. @ %lx: %.2x %.2x %.2x %.2x %.2x %.2x (%.8lx)\n",
                            (unsigned long) p, d6, d5, d4, d3, d2, d1,
                            (unsigned long) data);
                    fprintf(stderr, "***  Cmp reg32,0x%.8lx\n",
                            (unsigned long) data);
                }
                /* Mov m32,reg32 */
                if (d2 == 0x89) {
                    fixup_found = 1;
                    fprintf(stderr,
                            "Abs. const. ref. @ %lx: %.2x %.2x %.2x %.2x %.2x %.2x (%.8lx)\n",
                            (unsigned long) p, d6, d5, d4, d3, d2, d1,
                            (unsigned long) data);
                    fprintf(stderr, "***  Mov 0x%.8lx,reg32\n",
                            (unsigned long) data);
                }
                /* Mov reg32,m32 */
                if (d2 == 0x8b) {
                    fixup_found = 1;
                    fprintf(stderr,
                            "Abs. const. ref. @ %lx: %.2x %.2x %.2x %.2x %.2x %.2x (%.8lx)\n",
                            (unsigned long) p, d6, d5, d4, d3, d2, d1,
                            (unsigned long) data);
                    fprintf(stderr, "***  Mov reg32,0x%.8lx\n",
                            (unsigned long) data);
                }
                /* Lea reg32,m32 */
                if (d2 == 0x8d) {
                    fixup_found = 1;
                    fprintf(stderr,
                            "Abs. const. ref. @ %lx: %.2x %.2x %.2x %.2x %.2x %.2x (%.8lx)\n",
                            (unsigned long) p, d6, d5, d4, d3, d2, d1,
                            (unsigned long) data);
                    fprintf(stderr, "***  Lea reg32,0x%.8lx\n",
                            (unsigned long) data);
                }
            }
        }
    }

    /* If anything was found print out some info. on the code object. */
    if (fixup_found) {
        fprintf(stderr,
                "*** Compiled code object at %lx: header_words=%d code_words=%d .\n",
                (unsigned long) code, nheader_words, ncode_words);
        fprintf(stderr,
                "*** Const. start = %lx; end= %lx; Code start = %lx; end = %lx\n",
                (unsigned long) constants_start_addr,
                (unsigned long) constants_end_addr,
                (unsigned long) code_start_addr, (unsigned long) code_end_addr);
    }
}

static void
apply_code_fixups(struct code *old_code, struct code *new_code)
{
    int nheader_words, ncode_words, nwords;
    char *constants_start_addr, *constants_end_addr;
    char *code_start_addr, *code_end_addr;
    lispobj fixups = NIL;
    unsigned long displacement =

        (unsigned long) new_code - (unsigned long) old_code;
    struct vector *fixups_vector;

    /*
     * It's ok if it's byte compiled code. The trace table offset will
     * be a fixnum if it's x86 compiled code - check.
     */
    if (new_code->trace_table_offset & 0x3) {
#if 0
        fprintf(stderr, "*** Byte compiled code object at %x.\n", new_code);
#endif
        return;
    }

    /* Else it's x86 machine code. */
    ncode_words = fixnum_value(new_code->code_size);
    nheader_words = HeaderValue(*(lispobj *) new_code);
    nwords = ncode_words + nheader_words;
#if 0
    fprintf(stderr,
            "*** Compiled code object at %x: header_words=%d code_words=%d .\n",
            new_code, nheader_words, ncode_words);
#endif
    constants_start_addr = (char *) new_code + 5 * sizeof(lispobj);
    constants_end_addr = (char *) new_code + nheader_words * sizeof(lispobj);
    code_start_addr = (char *) new_code + nheader_words * sizeof(lispobj);
    code_end_addr = (char *) new_code + nwords * sizeof(lispobj);
#if 0
    fprintf(stderr,
            "*** Const. start = %x; end= %x; Code start = %x; end = %x\n",
            constants_start_addr, constants_end_addr, code_start_addr,
            code_end_addr);
#endif

    /*
     * The first constant should be a pointer to the fixups for this
     * code objects - Check.
     */
    fixups = new_code->constants[0];

    /*
     * It will be 0 or the unbound-marker if there are no fixups, and
     * will be an other pointer if it is valid.
     */
    if (fixups == 0 || fixups == type_UnboundMarker || !Pointerp(fixups)) {
        /* Check for possible errors. */
        if (check_code_fixups)
            sniff_code_object(new_code, displacement);

#if 0
        fprintf(stderr, "Fixups for code object not found!?\n");
        fprintf(stderr,
                "*** Compiled code object at %x: header_words=%d code_words=%d .\n",
                new_code, nheader_words, ncode_words);
        fprintf(stderr,
                "*** Const. start = %x; end= %x; Code start = %x; end = %x\n",
                constants_start_addr, constants_end_addr, code_start_addr,
                code_end_addr);
#endif
        return;
    }

    fixups_vector = (struct vector *) PTR(fixups);

    /* Could be pointing to a forwarding pointer. */
    if (Pointerp(fixups) && find_page_index((void *) fixups_vector) != -1
        && fixups_vector->header == 0x01) {
#if 0
        fprintf(stderr, "* FF\n");
#endif
        /* If so then follow it. */
        fixups_vector = (struct vector *) PTR((lispobj) fixups_vector->length);
    }
#if 0
    fprintf(stderr, "Got the fixups\n");
#endif

    if (TypeOf(fixups_vector->header) == type_SimpleArrayUnsignedByte32) {
        /*
         * Got the fixups for the code block.  Now work through the
         * vector, and apply a fixup at each address.
         */
        int length = fixnum_value(fixups_vector->length);
        int i;

        for (i = 0; i < length; i++) {
            unsigned offset = fixups_vector->data[i];

            /* Now check the current value of offset. */
            unsigned long old_value =
                *(unsigned long *) ((unsigned long) code_start_addr + offset);

            /*
             * If it's within the old_code object then it must be an
             * absolute fixup (relative ones are not saved).
             */
            if (old_value >= (unsigned long) old_code
                && old_value <
                (unsigned long) old_code + nwords * sizeof(lispobj))
                /* So add the dispacement. */
                *(unsigned long *) ((unsigned long) code_start_addr + offset) =
                    old_value + displacement;
            else
                /*
                 * It is outside the old code object so it must be a relative
                 * fixup (absolute fixups are not saved). So subtract the
                 * displacement.
                 */
                *(unsigned long *) ((unsigned long) code_start_addr + offset) =
                    old_value - displacement;
        }
    }

    /* Check for possible errors. */
    if (check_code_fixups)
        sniff_code_object(new_code, displacement);
}
#endif

static struct code *
trans_code(struct code *code)
{
    struct code *new_code;
    lispobj l_code, l_new_code;
    int nheader_words, ncode_words, nwords;
    unsigned long displacement;
    lispobj fheaderl, *prev_pointer;

#if 0
    fprintf(stderr, "\nTransporting code object located at 0x%08x.\n",
            (unsigned long) code);
#endif

    /* If object has already been transported, just return pointer */
    if (*(lispobj *) code == 0x01) {
        return (struct code *) (((lispobj *) code)[1]);
    }


    gc_assert(TypeOf(code->header) == type_CodeHeader);

    /* prepare to transport the code vector */
    l_code = (lispobj) code | type_OtherPointer;

    ncode_words = fixnum_value(code->code_size);
    nheader_words = HeaderValue(code->header);
    nwords = ncode_words + nheader_words;
    nwords = CEILING(nwords, 2);

    l_new_code = copy_large_object(l_code, nwords);
    new_code = (struct code *) PTR(l_new_code);

    /* May not have been moved. */
    if (new_code == code)
        return new_code;

    displacement = l_new_code - l_code;

#if 0
    fprintf(stderr, "Old code object at 0x%08x, new code object at 0x%08x.\n",
            (unsigned long) code, (unsigned long) new_code);
    fprintf(stderr, "Code object is %d words long.\n", nwords);
#endif

    /* set forwarding pointer */
    ((lispobj *) code)[0] = 0x01;
    ((lispobj *) code)[1] = l_new_code;

    /*
     * Set forwarding pointers for all the function headers in the code
     * object; also fix all self pointers.
     */

    fheaderl = code->entry_points;
    prev_pointer = &new_code->entry_points;

    while (fheaderl != NIL) {
        struct function *fheaderp, *nfheaderp;
        lispobj nfheaderl;

        fheaderp = (struct function *) PTR(fheaderl);
        gc_assert(TypeOf(fheaderp->header) == type_FunctionHeader);

        /*
         * Calcuate the new function pointer and the new function header.
         */
        nfheaderl = fheaderl + displacement;
        nfheaderp = (struct function *) PTR(nfheaderl);

        /* set forwarding pointer */
        ((lispobj *) fheaderp)[0] = 0x01;
        ((lispobj *) fheaderp)[1] = nfheaderl;

        /* Fix self pointer */
        nfheaderp->self = nfheaderl + RAW_ADDR_OFFSET;

        *prev_pointer = nfheaderl;

        fheaderl = fheaderp->next;
        prev_pointer = &nfheaderp->next;
    }

#if 0
    sniff_code_object(new_code, displacement);
#endif
#if defined(i386) || defined(__x86_64)
    apply_code_fixups(code, new_code);
#else
    /* From gc.c */
#ifndef MACH
    os_flush_icache((os_vm_address_t) (((int *) new_code) + nheader_words),
                    ncode_words * sizeof(int));
#endif
#endif

    return new_code;
}

static int
scav_code_header(lispobj * where, lispobj object)
{
    struct code *code;
    int nheader_words, ncode_words, nwords;
    lispobj fheaderl;
    struct function *fheaderp;

    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 */
    scavenge(where + 1, nheader_words - 1);

    /*
     * Scavenge the boxed section of each function object in the code
     * data block
     */
    fheaderl = code->entry_points;
    while (fheaderl != NIL) {
        fheaderp = (struct function *) PTR(fheaderl);
        gc_assert(TypeOf(fheaderp->header) == type_FunctionHeader);

        scavenge(&fheaderp->name, 1);
        scavenge(&fheaderp->arglist, 1);
        scavenge(&fheaderp->type, 1);

        fheaderl = fheaderp->next;
    }

    return nwords;
}

static lispobj
trans_code_header(lispobj object)
{
    struct code *ncode;

    ncode = trans_code((struct code *) PTR(object));
    return (lispobj) ncode | type_OtherPointer;
}

static int
size_code_header(lispobj * where)
{
    struct code *code;
    int nheader_words, ncode_words, nwords;

    code = (struct code *) where;

    ncode_words = fixnum_value(code->code_size);
    nheader_words = HeaderValue(code->header);
    nwords = ncode_words + nheader_words;
    nwords = CEILING(nwords, 2);

    return nwords;
}

#if !(defined(i386) || defined(__x86_64))

static int
scav_return_pc_header(lispobj * where, lispobj object)
{
    fprintf(stderr, "GC lossage.  Should not be scavenging a ");
    fprintf(stderr, "Return PC Header.\n");
    fprintf(stderr, "where = 0x%08lx, object = 0x%08lx",
            (unsigned long) where, (unsigned long) object);
    lose(NULL);
    return 0;
}

#endif /* not i386 */

static lispobj
trans_return_pc_header(lispobj object)
{
    struct function *return_pc;
    unsigned long offset;
    struct code *code, *ncode;

    return_pc = (struct function *) PTR(object);
    offset = HeaderValue(return_pc->header) * sizeof(lispobj);

    /* Transport the whole code object */
    code = (struct code *) ((unsigned long) return_pc - offset);

    ncode = trans_code(code);

    return ((lispobj) ncode + offset) | type_OtherPointer;
}

/*
 * On the 386, closures hold a pointer to the raw address instead of
 * the function object.
 */
#if defined(i386) || defined(__x86_64)

static int
scav_closure_header(lispobj * where, lispobj object)
{
    struct closure *closure;
    lispobj fun;

    closure = (struct closure *) where;
    fun = closure->function - RAW_ADDR_OFFSET;
#if !(defined(i386) && defined(SOLARIS))
    scavenge(&fun, 1);
    /* The function may have moved so update the raw address. But don't
       write unnecessarily. */
    if (closure->function != fun + RAW_ADDR_OFFSET)
        closure->function = fun + RAW_ADDR_OFFSET;
#else
    /*
     * For some reason, on solaris/x86, we get closures (actually, it
     * appears to be funcallable instances where the closure function
     * is zero.  I don't know why, but they are.  They don't seem to
     * be created anywhere and it doesn't seem to be caused by GC
     * transport.
     *
     * Anyway, we check for zero and skip scavenging if so.
     * (Previously, we'd get a segfault scavenging the object at
     * address -RAW_ADDR_OFFSET.
     */
    if (closure->function) {
        scavenge(&fun, 1);
        /*
         * The function may have moved so update the raw address. But don't
         * write unnecessarily.
         */
        if (closure->function != fun + RAW_ADDR_OFFSET) {
#if 0
            fprintf(stderr, "closure header 0x%04x moved from %p to %p\n",
                    closure->header, (void*) closure->function, (void*) (fun + RAW_ADDR_OFFSET));
#endif
            closure->function = fun + RAW_ADDR_OFFSET;
        }
    }
#if 0
     else {
        fprintf(stderr, "Weird closure!\n");
        fprintf(stderr, " where = %p, object = 0x%04x\n", where, object);
        fprintf(stderr, " closure->function = %p, fun = %p\n", closure->function, fun);
    }
#endif
#endif
    return 2;
}

#endif /* i386 */

#if !(defined(i386) || defined(__x86_64))

static int
scav_function_header(lispobj * where, lispobj object)
{
    fprintf(stderr, "GC lossage.  Should not be scavenging a ");
    fprintf(stderr, "Function Header.\n");
    fprintf(stderr, "where = 0x%08lx, object = 0x%08lx",
            (unsigned long) where, (unsigned long) object);
    lose(NULL);
    return 0;
}

#endif /* not i386 */

static lispobj
trans_function_header(lispobj object)
{
    struct function *fheader;
    unsigned long offset;
    struct code *code, *ncode;

    fheader = (struct function *) PTR(object);
    offset = HeaderValue(fheader->header) * sizeof(lispobj);

    /* Transport the whole code object */
    code = (struct code *) ((unsigned long) fheader - offset);
    ncode = trans_code(code);

    return ((lispobj) ncode + offset) | type_FunctionPointer;
}
\f

/* Instances */

#if DIRECT_SCAV
static int
scav_instance_pointer(lispobj * where, lispobj object)
{
    if (from_space_p(object)) {
        lispobj first, *first_pointer;

        /*
         * object is a pointer into from space.  check to see if it has
         * been forwarded
         */
        first_pointer = (lispobj *) PTR(object);
        first = *first_pointer;

        if (first == 0x01)
            /* Forwarded. */
            first = first_pointer[1];
        else {
            first = trans_boxed(object);
            gc_assert(first != object);
            /* Set forwarding pointer */
            first_pointer[0] = 0x01;
            first_pointer[1] = first;
        }
        *where = first;
    }
    return 1;
}
#else
static int
scav_instance_pointer(lispobj * where, lispobj object)
{
    lispobj copy, *first_pointer;

    /* Object is a pointer into from space - not a FP */
    copy = trans_boxed(object);

    gc_assert(copy != object);

    first_pointer = (lispobj *) PTR(object);

    /* Set forwarding pointer. */
    first_pointer[0] = 0x01;
    first_pointer[1] = copy;
    *where = copy;

    return 1;
}
#endif
\f

/* Lists and Conses */

static lispobj trans_list(lispobj object);

#if DIRECT_SCAV
static int
scav_list_pointer(lispobj * where, lispobj object)
{
    gc_assert(Pointerp(object));

    if (from_space_p(object)) {
        lispobj first, *first_pointer;

        /*
         * Object is a pointer into from space - check to see if it has
         * been forwarded.
         */
        first_pointer = (lispobj *) PTR(object);
        first = *first_pointer;

        if (first == 0x01)
            /* Forwarded. */
            first = first_pointer[1];
        else {
            first = trans_list(object);

            /* Set forwarding pointer */
            first_pointer[0] = 0x01;
            first_pointer[1] = first;
        }

        gc_assert(Pointerp(first));
        gc_assert(!from_space_p(first));
        *where = first;
    }
    return 1;
}
#else
static int
scav_list_pointer(lispobj * where, lispobj object)
{
    lispobj first, *first_pointer;

    gc_assert(Pointerp(object));

    /* Object is a pointer into from space - not FP */

    first = trans_list(object);
    gc_assert(first != object);

    first_pointer = (lispobj *) PTR(object);

    /* Set forwarding pointer */
    first_pointer[0] = 0x01;
    first_pointer[1] = first;

    gc_assert(Pointerp(first));
    gc_assert(!from_space_p(first));
    *where = first;
    return 1;
}
#endif

static lispobj
trans_list(lispobj object)
{
    lispobj new_list_pointer;
    struct cons *cons, *new_cons;
    lispobj cdr;

    gc_assert(from_space_p(object));

    cons = (struct cons *) PTR(object);

    /* copy 'object' */
    new_cons = (struct cons *) gc_quick_alloc(sizeof(struct cons));

    new_cons->car = cons->car;
    new_cons->cdr = cons->cdr;  /* updated later */
    new_list_pointer = (lispobj) new_cons | LowtagOf(object);

    /* Grab the cdr before it is clobbered */
    cdr = cons->cdr;

    /* Set forwarding pointer (clobbers start of list). */
    cons->car = 0x01;
    cons->cdr = 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)
            || *((lispobj *) PTR(cdr)) == 0x01)
            break;

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

        /* copy 'cdr' */
        new_cdr_cons = (struct cons *) gc_quick_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);

        /* Grab the cdr before it is clobbered */
        cdr = cdr_cons->cdr;

        /* Set forwarding pointer */
        cdr_cons->car = 0x01;
        cdr_cons->cdr = 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

/* Scavenging and Transporting Other Pointers */

#if DIRECT_SCAV
static int
scav_other_pointer(lispobj * where, lispobj object)
{
    gc_assert(Pointerp(object));

    if (from_space_p(object)) {
        lispobj first, *first_pointer;

        /*
         * Object is a pointer into from space.  check to see if it has
         * been forwarded.
         */
        first_pointer = (lispobj *) PTR(object);
        first = *first_pointer;

        if (first == 0x01) {
            /* Forwarded. */
            first = first_pointer[1];
            *where = first;
        } else {
            first = (transother[TypeOf(first)]) (object);

            if (first != object) {
                /* Set forwarding pointer */
                first_pointer[0] = 0x01;
                first_pointer[1] = first;
                *where = first;
            }
        }

        gc_assert(Pointerp(first));
        gc_assert(!from_space_p(first));
    }
    return 1;
}
#else
static int
scav_other_pointer(lispobj * where, lispobj object)
{
    lispobj first, *first_pointer;

    gc_assert(Pointerp(object));

    /* Object is a pointer into from space - not FP */
    first_pointer = (lispobj *) PTR(object);

    first = (transother[TypeOf(*first_pointer)]) (object);

    if (first != object) {
        /* Set forwarding pointer */
        first_pointer[0] = 0x01;
        first_pointer[1] = first;
        *where = first;
    }

    gc_assert(Pointerp(first));
    gc_assert(!from_space_p(first));

    return 1;
}
#endif
\f

/* Immediate, Boxed, and Unboxed Objects */

static int
size_pointer(lispobj * where)
{
    return 1;
}

static int
scav_immediate(lispobj * where, lispobj object)
{
    return 1;
}

static lispobj
trans_immediate(lispobj object)
{
    fprintf(stderr, "GC lossage.  Trying to transport an immediate!?\n");
    lose(NULL);
    return NIL;
}

static int
size_immediate(lispobj * where)
{
    return 1;
}


static int
scav_boxed(lispobj * where, lispobj object)
{
    return 1;
}

static lispobj
trans_boxed(lispobj object)
{
    lispobj header;
    unsigned long length;

    gc_assert(Pointerp(object));

    header = *((lispobj *) PTR(object));
    length = HeaderValue(header) + 1;
    length = CEILING(length, 2);

    return copy_object(object, length);
}

static lispobj
trans_boxed_large(lispobj object)
{
    lispobj header;
    unsigned long length;

    gc_assert(Pointerp(object));

    header = *((lispobj *) PTR(object));
    length = HeaderValue(header) + 1;
    length = CEILING(length, 2);

    return copy_large_object(object, length);
}

static int
size_boxed(lispobj * where)
{
    lispobj header;
    unsigned long length;

    header = *where;
    length = HeaderValue(header) + 1;
    length = CEILING(length, 2);

    return length;
}

/* Not needed on sparc and ppc because the raw_addr has a function lowtag */
#if !(defined(sparc) || (defined(DARWIN) && defined(__ppc__)))
static int
scav_fdefn(lispobj * where, lispobj object)
{
    struct fdefn *fdefn;

    fdefn = (struct fdefn *) where;

    if ((char *) (fdefn->function + RAW_ADDR_OFFSET) == fdefn->raw_addr) {
        scavenge(where + 1, sizeof(struct fdefn) / sizeof(lispobj) - 1);

        /* Don't write unnecessarily */
        if (fdefn->raw_addr != (char *) (fdefn->function + RAW_ADDR_OFFSET))
            fdefn->raw_addr = (char *) (fdefn->function + RAW_ADDR_OFFSET);

        return sizeof(struct fdefn) / sizeof(lispobj);
    } else
        return 1;
}
#endif

static int
scav_unboxed(lispobj * where, lispobj object)
{
    unsigned long length;

    length = HeaderValue(object) + 1;
    length = CEILING(length, 2);

    return length;
}

static lispobj
trans_unboxed(lispobj object)
{
    lispobj header;
    unsigned long length;


    gc_assert(Pointerp(object));

    header = *((lispobj *) PTR(object));
    length = HeaderValue(header) + 1;
    length = CEILING(length, 2);

    return copy_unboxed_object(object, length);
}

static lispobj
trans_unboxed_large(lispobj object)
{
    lispobj header;
    unsigned long length;


    gc_assert(Pointerp(object));

    header = *((lispobj *) PTR(object));
    length = HeaderValue(header) + 1;
    length = CEILING(length, 2);

    return copy_large_unboxed_object(object, length);
}

static int
size_unboxed(lispobj * where)
{
    lispobj header;
    unsigned long length;

    header = *where;
    length = HeaderValue(header) + 1;
    length = CEILING(length, 2);

    return length;
}
\f

/* Vector-Like Objects */

#define NWORDS(x,y) (CEILING((x),(y)) / (y))

static int
size_string(lispobj * where)
{
    struct vector *vector;
    int length, nwords;

    /*
     * NOTE: Strings contain one more byte of data than the length
     * slot indicates.
     */

    vector = (struct vector *) where;
    length = fixnum_value(vector->length) + 1;
#ifndef UNICODE
#ifdef __x86_64
    nwords = CEILING(NWORDS(length, 8) + 2, 2);
#else
    nwords = CEILING(NWORDS(length, 4) + 2, 2);
#endif
#else
    /*
     * Strings are just like arrays with 16-bit elements, and contain
     * one more element than the slot length indicates.
     */
    nwords = CEILING(NWORDS(length, 2) + 2, 2);
#endif
    return nwords;
}

static int
scav_string(lispobj * where, lispobj object)
{
    return size_string(where);
}

static lispobj
trans_string(lispobj object)
{
    gc_assert(Pointerp(object));
    return copy_large_unboxed_object(object,
                                     size_string((lispobj *) PTR(object)));
}
\f

/************************************************************************
                             Hash Tables
************************************************************************/

/* This struct corresponds to the Lisp HASH-TABLE structure defined in
   hash-new.lisp.  */

struct hash_table {
    lispobj instance_header;    /* 0 */
    lispobj dummy2;
    lispobj test;
    lispobj test_fun;
    lispobj hash_fun;
    lispobj rehash_size;        /* 5 */
    lispobj rehash_threshold;
    lispobj rehash_trigger;
    lispobj number_entries;
    lispobj table;
    lispobj weak_p;             /* 10 */
    lispobj needing_rehash;
    lispobj next_free_kv;
    lispobj index_vector;
    lispobj next_vector;
    lispobj hash_vector;        /* 15 */
    lispobj next_weak_table;
};

/* The size of a hash-table in Lisp objects.  */

#define HASH_TABLE_SIZE (sizeof (struct hash_table) / sizeof (lispobj))

/* Compute the EQ-hash of KEY.  This must be the same as what's used
   in hash-new.lisp.  */

#define EQ_HASH(key) ((key) & 0x1fffffff)

/* List of weak hash tables chained through their WEAK-P slot.  Set to
   NIL at the start of a collection.

   This is not optimal because, when a table is tenured, it won't be
   processed automatically; only the yougest generation is GC'd by
   default.  On the other hand, all applications will need an
   occasional full GC anyway, so it's not that bad either.  */

static lispobj weak_hash_tables;

/* Return true if OBJ will survive the current GC.  */

static inline int
survives_gc(lispobj obj)
{
    if (!Pointerp(obj) || !from_space_p(obj))
        return 1;
    return *(lispobj *) PTR(obj) == 1;
}

/* If OBJ is a (UNSIGNED-BYTE 32) array, return a pointer to its first
   element, otherwise return null.  If LENGTH is not null, return in it
   the array's length.  */

static inline unsigned *
u32_vector(lispobj obj, unsigned *length)
{
    unsigned *ptr = NULL;

    if (Pointerp(obj)) {
        lispobj *p = (lispobj *) PTR(obj);

        if (TypeOf(p[0]) == type_SimpleArrayUnsignedByte32) {
            ptr = (unsigned *) (p + 2);
            if (length)
                *length = fixnum_value(p[1]);
        }
    }

    return ptr;
}

/* Free an entry of hash-table HASH-TABLE whose hash index (index in
   the hash-table's INDEX-VECTOR) is HASH_INDEX, and whose index
   in the hash-table's TABLE vector is KV_INDEX.  */

static inline void
free_hash_entry(struct hash_table *hash_table, int hash_index, int kv_index)
{
    unsigned length = UINT_MAX; // to compare to
    unsigned *index_vector = u32_vector(hash_table->index_vector, &length);
    unsigned *next_vector = u32_vector(hash_table->next_vector, 0);
    int free_p = 1;
    
    gc_assert(length != UINT_MAX);

    if (index_vector[hash_index] == kv_index)
        /* The entry is the first in the collinion chain.
           Pop it from the list.  */
        index_vector[hash_index] = next_vector[kv_index];
    else {
        /* The entry is not the first in the collision chain.  */
        unsigned prev = index_vector[hash_index];
        unsigned i = next_vector[prev];

        while (i && i != kv_index)
            prev = i, i = next_vector[i];

        if (i == kv_index)
            next_vector[prev] = next_vector[kv_index];
        else
            free_p = 0;
    }

    if (free_p) {
        unsigned count = fixnum_value(hash_table->number_entries);
        lispobj* kv_vector = (lispobj *) PTR(hash_table->table);
        unsigned *hash_vector = u32_vector(hash_table->hash_vector, 0);
        unsigned hash_index;
        lispobj empty_symbol;
        
        gc_assert(count > 0);
        hash_table->number_entries = make_fixnum(count - 1);
        next_vector[kv_index] = fixnum_value(hash_table->next_free_kv);
        hash_table->next_free_kv = make_fixnum(kv_index);
        /*
         * I (rtoy) think we also need to clear out the key and value
         * in the kv-vector.  If we don't, maphash and
         * with-hash-table-iterator thinks this entry is not empty.
         */
        
        kv_vector += 2;         /* Skip over vector header and length slots */
        empty_symbol = kv_vector[1];

        hash_index = EQ_HASH(kv_vector[2 * kv_index]) % length;
        
        kv_vector[2 * kv_index] = empty_symbol;
        kv_vector[2 * kv_index + 1] = empty_symbol;
        if (hash_vector) {
            hash_vector[hash_index] = EQ_BASED_HASH_VALUE;
        }
    }
}

/* Record an entry of hash-table HASH-TABLE whose hash index (index in
   the hash-table's INDEX-VECTOR) is HASH_INDEX, and whose index
   in the hash-table's TABLE vector is KV_INDEX, for rehashing.  */

static inline void
record_for_rehashing(struct hash_table *hash_table, int hash_index,
                     int kv_index)
{
    unsigned *index_vector = u32_vector(hash_table->index_vector, 0);
    unsigned *next_vector = u32_vector(hash_table->next_vector, 0);
    int rehash_p = 1;

    if (index_vector[hash_index] == kv_index)
        /* This entry is at the head of the collision chain.
           Pop it from that list. */
        index_vector[hash_index] = next_vector[kv_index];
    else {
        unsigned prev = index_vector[hash_index];
        unsigned i = next_vector[prev];

        while (i && i != kv_index)
            prev = i, i = next_vector[i];

        if (i == kv_index)
            next_vector[prev] = next_vector[kv_index];
        else
            rehash_p = 0;
    }

    if (rehash_p) {
        next_vector[kv_index] = fixnum_value(hash_table->needing_rehash);
        hash_table->needing_rehash = make_fixnum(kv_index);
    }
}

static inline boolean
eq_based_hash_vector(unsigned int* hash_vector, unsigned int index)
{
    return (hash_vector == 0) || (hash_vector[index] == EQ_BASED_HASH_VALUE);
}

static inline boolean
removable_weak_key(lispobj old_key, unsigned int index_value, boolean eq_hash_p)
{
  return (!survives_gc(old_key)
          && eq_hash_p
          && (index_value != 0));
}

static inline boolean
removable_weak_value(lispobj value, unsigned int index_value)
{
    /*
     * The entry can be removed if the value can be GCed.
     */
    return (!survives_gc(value)
            && (index_value != 0));
}

static inline boolean
removable_weak_key_and_value(lispobj old_key, lispobj value, unsigned int index_value,
                             boolean eq_hash_p)
{
  boolean removable_key;
  boolean removable_val;
  
  removable_key = (!survives_gc(old_key)
                   && eq_hash_p
                   && (index_value != 0));
  removable_val = (!survives_gc(value)
                   && (index_value != 0));

  /*
   * The entry must stay if the key and value are alive.  In other
   * words, the entry can be removed if the key or value can be GCed.
   */
  return removable_key || removable_val;
}

static inline boolean
removable_weak_key_or_value(lispobj old_key, lispobj value, unsigned int index_value,
                            boolean eq_hash_p)
{
  boolean removable_key;
  boolean removable_val;
  
  removable_key = (!survives_gc(old_key)
                   && eq_hash_p
                   && (index_value != 0));
  removable_val = (!survives_gc(value)
                   && (index_value != 0));

  /*
   * The entry must be kept if either the key or value is alive.  In
   * other words, the entry can be removed only if both the key and
   * value can be GCed.
   */
  return (removable_key && removable_val);
}

static void
maybe_record_for_rehashing(struct hash_table *hash_table, lispobj* kv_vector,