Clean up RCS ids

[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.
 *
 */

#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