/* -*-C-*-

$Id: bchmmg.c,v 9.104 2003/02/14 18:48:11 cph Exp $

Copyright 1987-2000, 2002 Massachusetts Institute of Technology

This file is part of MIT/GNU Scheme.

MIT/GNU Scheme is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or (at
your option) any later version.

MIT/GNU Scheme is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
General Public License for more details.

You should have received a copy of the GNU General Public License
along with MIT/GNU Scheme; if not, write to the Free Software
Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
USA.

*/

/* Memory management top level.  Garbage collection to disk. */

#include "scheme.h"
#include "prims.h"
#include "memmag.h"
#include "option.h"
#include "osenv.h"
#include "osfs.h"

#ifdef __unix__
#  include "ux.h"
#  define SUB_DIRECTORY_DELIMITER '/'
/* This makes for surprising behavior: */
/* #  define UNLINK_BEFORE_CLOSE */
#endif

#ifdef __WIN32__
#  include "nt.h"
#  define SUB_DIRECTORY_DELIMITER '\\'
#endif

#ifdef __OS2__
#  include "os2.h"
#  define SUB_DIRECTORY_DELIMITER '\\'
#  if defined(__IBMC__) || defined(__WATCOMC__) || defined(__EMX__)
#    include <io.h>
#    include <sys\stat.h>
#  endif
#  ifndef F_OK
#    define F_OK 0
#    define X_OK 1
#    define W_OK 2
#    define R_OK 4
#  endif
#endif

#include "bchgcc.h"
#include "bchdrn.h"

#ifndef SEEK_SET
#  define SEEK_SET 0
#endif

#ifdef USE_SYSV_SHARED_MEMORY
#  define RECORD_GC_STATISTICS
#endif
#define MILLISEC * 1000

#define FLOOR(value,quant)	((quant) * ((value) / (quant)))
#define CEILING(value,quant)	(FLOOR (((value) + ((quant) - 1)), (quant)))

/* Memory management top level.  Garbage collection to disk.

   The algorithm is basically the same as for the 2 space collector,
   except that new space is on the disk, and there are two windows to
   it (the scan and free buffers).  The two windows are physically the
   same whent they correspond to the same section of the address space.
   There may be additional windows used to overlap I/O.

   For information on the 2 space collector, read the comments in the
   replaced files.

   The memory management code is spread over the following files:
   - bchgcc.h: shared header file for bchscheme.
   - bchmmg.c: top level, initialization and I/O.	Replaces memmag.c
   - bchgcl.c: main garbage collector loop.		Replaces gcloop.c
   - bchpur.c: constant/pure space hacking.		Replaces purify.c
   - bchdmp.c: object & world image dumping.		Replaces fasdump.c
   - bchdrn.h: header file for bchmmg.c and the bchdrn.c.
   - bchdrn.c: stand-alone program used as an overlapped I/O drone.
   - bchutl.c: utilities common to bchmmg.c and bchdrn.c.

   Problems with this implementation right now:
   - It only works on Unix (or systems which support Unix I/O calls).
   - Dumpworld does not work because the file is not closed at dump time or
     reopened at restart time.
   - Command-line specified gc files are only locked on versions of Unix
     that have lockf(2).  If your system does not have lockf, two
     processes can try to share the file and get very confused.

oo
   ------------------------------------------
   |        GC Buffer Space                 | (not always contiguous)
   |                                        |
   ------------------------------------------ <- fixed boundary (currently)
   |          Heap Space                    |
   |                                        |
   ------------------------------------------ <- boundary moved by purify
   |     Constant + Pure Space    /\        |
   |                              ||        |
   ------------------------------------------ <- fixed boundary (currently)
   |         Control Stack        ||        |
   |                              \/        |
   ------------------------------------------ <- fixed boundary (currently)
0

   Each area has a pointer to its starting address and a pointer to
   the next free cell (for the stack, it is a pointer to the last cell
   in use).  The GC buffer space contains two (or more) buffers used
   during the garbage collection process.  One is the scan buffer and
   the other is the free buffer, and they are dumped and loaded from
   disk as necessary.  At the beginning and at the end a single buffer
   is used, since transporting will occur into the area being scanned.
*/

/* Exports */

extern void EXFUN (Clear_Memory, (int, int, int));
extern void EXFUN (Setup_Memory, (int, int, int));
extern void EXFUN (Reset_Memory, (void));

long
  absolute_gc_file_end_position,
  gc_file_end_position,
  gc_file_current_position,
  gc_file_start_position;

unsigned long
  gc_buffer_size,
  gc_buffer_bytes,
  gc_buffer_shift,
  gc_buffer_mask,
  gc_buffer_byte_shift;

static unsigned long
  gc_extra_buffer_size,
  gc_buffer_overlap_bytes,
  gc_buffer_remainder_bytes,
  gc_total_buffer_size;

SCHEME_OBJECT
  * scan_buffer_top,		* scan_buffer_bottom,
  * free_buffer_top,		* free_buffer_bottom,
  * virtual_scan_pointer;

static SCHEME_OBJECT
  * virtual_scan_base;

static char
  * gc_file_name = 0;

CONST char
  * drone_file_name = 0;

static int
  keep_gc_file_p = 0,
  gc_file = -1,
  read_overlap = 0,
  write_overlap = 0;

static SCHEME_OBJECT
  * aligned_heap;

static Boolean
  can_dump_directly_p,
  extension_overlap_p,
  scan_buffer_extended_p;

static long
  scan_position,
  free_position,
  pre_read_position,
  extension_overlap_length;

static long
  saved_heap_size,
  saved_constant_size,
  saved_stack_size;

static unsigned long
  read_queue_bitmask; /* Change MAX_READ_OVERLAP if you change this. */

static struct buffer_info
  * free_buffer,
  * scan_buffer,
  * next_scan_buffer;

int
DEFUN (io_error_always_abort, (operation_name, noise),
       char * operation_name AND char * noise)
{
  return (1);
}

#ifdef __WIN32__
#include <windows.h>

int 
DEFUN (io_error_retry_p, (operation_name, noise),
       char * operation_name AND char * noise)
{
  char buf[512];
  extern HANDLE master_tty_window;

  sprintf (&buf[0],
	   "%s: GC file error (code = %d) when manipulating %s.\n"
	   "Choose an option (Cancel = Exit Scheme)",
	   operation_name, (GetLastError ()), noise);
  switch (MessageBox (master_tty_window,
		      &buf[0],
		      "MIT/GNU Scheme garbage-collection problem description",
		      (MB_ICONSTOP | MB_ABORTRETRYIGNORE | MB_APPLMODAL)))
  {
    case IDABORT:
      return (1);

    case IDRETRY:
      return (0);

    case IDIGNORE:
      Microcode_Termination (TERM_EXIT);
  }
  /*NOTREACHED*/
  return (0);
}

#else /* not __WIN32__ */
#ifdef __OS2__

int
io_error_retry_p (char * operation_name, char * noise)
{
  char buf [512];
  sprintf ((&buf[0]),
	   "%s: GC file error (code = %d) when manipulating %s.\n"
	   "Choose an option (Cancel = Exit Scheme)",
	   operation_name, errno, noise);
  switch
    (WinMessageBox (HWND_DESKTOP,
		    NULLHANDLE,
		    (&buf[0]),
		    "MIT/GNU Scheme garbage-collection problem description",
		    0,
		    (MB_ICONHAND | MB_ABORTRETRYIGNORE | MB_APPLMODAL)))
    {
    case MBID_ABORT: return (1);
    case MBID_RETRY: return (0);
    case MBID_IGNORE: Microcode_Termination (TERM_EXIT);
    }
}

#else /* not __OS2__ */

extern char EXFUN (userio_choose_option,
		   (CONST char *, CONST char *, CONST char **));
extern int EXFUN (userio_confirm, (CONST char *));

int 
DEFUN (io_error_retry_p, (operation_name, noise),
       char * operation_name AND char * noise)
{
  static CONST char * retry_choices [] =
    {
      "A = abort the operation",
      "E = exit scheme",
      "K = kill scheme",
      "Q = quit scheme",
      "R = retry the operation",
      "S = sleep for 1 minute and retry the operation",
      "X = exit scheme",
      0};

  outf_error ("\n%s (%s): GC file error (errno = %s) when manipulating %s.\n",
	      scheme_program_name, operation_name, (error_name (errno)),
	      noise);

  while (1)
  {
    switch (userio_choose_option
	    ("Choose one of the following actions:",
	     "Action -> ", retry_choices))
    {
      case 'A':
	return (1);

      case '\0':
	/* IO problems, assume everything is scrod. */
	outf_fatal 
	  ("%s (io_error_retry_p): Problems reading the keyboard; Exitting.\n",
	   scheme_program_name);
	termination_eof ();
	/*NOTREACHED*/

      case 'E': case 'K': case 'Q': case 'X':
	if (!(userio_confirm ("Kill Scheme (Y/N)? ")))
	  continue;
	Microcode_Termination (TERM_EXIT);
	/*NOTREACHED*/

      case 'S':
	sleep (60);
	/* fall through */

      case 'R':
      default:
	return (0);
    }
  }
}

#endif /* not __OS2__ */
#endif /* not __WIN32__ */

static int
DEFUN (verify_write, (position, size, success),
       long position AND long size AND Boolean * success)
{
  if ((position >= gc_file_start_position)
      && ((position + size) <= gc_file_end_position))
    return (0);
  outf_error (
	   "\n%s (verify_write): attempting to write outside allowed area.\n",
	   scheme_program_name);
  outf_error("\tlow position = 0x%lx; high position = 0x%lx.\n",
	     gc_file_start_position, gc_file_end_position);
  outf_error("\twrite position = 0x%lx; size = 0x%lx = %d bytes.\n",
	     position, size, size);
  outf_flush_error();
  if (success == ((Boolean *) NULL))
  {
    Microcode_Termination (TERM_EXIT);
    /*NOTREACHED*/
  }
  *success = ((Boolean) false);
  return (-1);
}

static void
DEFUN (write_data, (from, position, nbytes, noise, success),
       char * from AND long position AND long nbytes
       AND char * noise AND Boolean * success)
{
  if (((verify_write (position, nbytes, success)) != -1)
      && ((retrying_file_operation (((file_operation_t *) write),
				    gc_file,
				    from,
				    position,
				    nbytes,
				    "write",
				    noise,
				    &gc_file_current_position,
				    ((success == ((Boolean *) NULL))
				     ? io_error_retry_p
				     : io_error_always_abort)))
	  == -1)
      && (success != ((Boolean *) NULL)))
    *success = false;
  return;
}

static void
DEFUN (load_data, (position, to, nbytes, noise, success),
       long position AND char * to AND long nbytes
       AND char * noise AND Boolean * success)
{
  (void) (retrying_file_operation (((file_operation_t *) read),
				   gc_file,
				   to,
				   position,
				   nbytes,
				   "read",
				   noise,
				   &gc_file_current_position,
				   ((success == ((Boolean *) NULL))
				    ? io_error_retry_p
				    : io_error_always_abort)));
}

static int
DEFUN (parameterization_termination, (kill_p, init_p),
       int kill_p AND int init_p)
{
  fflush (stderr);
  if (init_p)
    termination_init_error ();			/*NOTREACHED*/
  if (kill_p)
    Microcode_Termination (TERM_EXIT);		/*NOTREACHED*/
  return (-1);
}

struct bch_GC_statistic
{
  char * name;
  long * counter;
};

#ifdef RECORD_GC_STATISTICS

static void EXFUN (statistics_clear, (void));
static void EXFUN (statistics_print, (int, char *));

#  define STATISTICS_INCR(name)			name += 1
#  define STATISTICS_CLEAR()			statistics_clear ()
#  define STATISTICS_PRINT(level, noise)	statistics_print (level, noise)

#else

static struct bch_GC_statistic all_gc_statistics[] =
{ { "invalid last statistic",		((long *) NULL) } };

#  define STATISTICS_INCR(name)			do { } while (0)
#  define STATISTICS_CLEAR()			do { } while (0)
#  define STATISTICS_PRINT(level, noise)	do { } while (0)

#endif

#ifdef USE_SYSV_SHARED_MEMORY

#ifdef RECORD_GC_STATISTICS

static long
  reads_not_overlapped,
  reads_overlapped,
  reads_ready,
  reads_queued,
  reads_pending,
  reads_overlapped_aborted,
  reads_found_in_write_queue,
  reads_found_ready,
  read_wait_cycles,
  writes_not_overlapped,
  writes_overlapped,
  writes_not_deferred,
  writes_restarted,
  writes_retried,
  writes_pending,
  write_wait_cycles,
  pre_reads_aborted,
  pre_reads_ignored,
  pre_reads_found_in_write_queue,
  pre_reads_found_ready,
  pre_reads_not_started,
  pre_reads_started,
  pre_reads_deferred,
  pre_reads_restarted,
  pre_reads_retried,
  pre_reads_not_retried,
  pre_reads_requeued_as_writes,
  ready_buffers_enqueued,
  ready_buffers_not_enqueued,
  drone_wait_cycles,
  drone_request_failures,
  drones_found_dead,
  sleeps_interrupted,  
  await_io_cycles,
  gc_start_time,
  gc_end_transport_time,
  gc_end_weak_update_time,
  gc_start_reload_time,
  gc_end_time;

#define START_TRANSPORT_HOOK()						\
  gc_start_time = ((long) (OS_real_time_clock ()))
  
#define END_TRANSPORT_HOOK()						\
  gc_end_transport_time = ((long) (OS_real_time_clock ()))

#define END_WEAK_UPDATE_HOOK()						\
  gc_end_weak_update_time = ((long) (OS_real_time_clock ()))

#define START_RELOAD_HOOK()						\
  gc_start_reload_time = ((long) (OS_real_time_clock ()))

#define END_GC_HOOK()							\
  gc_end_time = ((long) (OS_real_time_clock ()))

static struct bch_GC_statistic all_gc_statistics[] =
{
  { "reads not overlapped",		&reads_not_overlapped },
  { "reads overlapped",			&reads_overlapped },
  { "reads ready",			&reads_ready },
  { "reads queued",			&reads_queued },
  { "reads pending",			&reads_pending },
  { "reads overlapped aborted",		&reads_overlapped_aborted },
  { "reads found in write queue",	&reads_found_in_write_queue },
  { "reads found ready",		&reads_found_ready },
  { "read wait cycles",			&read_wait_cycles },
  { "writes not overlapped",		&writes_not_overlapped },
  { "writes overlapped",		&writes_overlapped },
  { "writes retried",			&writes_retried },
  { "writes not deferred",		&writes_not_deferred },
  { "writes restarted",			&writes_restarted },
  { "writes retried",			&writes_retried },
  { "writes pending",			&writes_pending },
  { "write wait cycles",		&write_wait_cycles },
  { "pre-reads aborted",		&pre_reads_aborted },
  { "pre-reads ignored",		&pre_reads_ignored },
  { "pre-reads found in write queue",	&pre_reads_found_in_write_queue },
  { "pre-reads found ready",		&pre_reads_found_ready },
  { "pre-reads not started",		&pre_reads_not_started },
  { "pre-reads started",		&pre_reads_started },
  { "pre-reads deferred",		&pre_reads_deferred },
  { "pre-reads restarted",		&pre_reads_restarted },
  { "pre-reads retried",		&pre_reads_retried },
  { "pre-reads not retried",		&pre_reads_not_retried },
  { "pre-reads requeued as writes",	&pre_reads_requeued_as_writes },
  { "ready buffers enqueued",		&ready_buffers_enqueued },
  { "ready buffers not enqueued",	&ready_buffers_not_enqueued },
  { "drone wait cycles",		&drone_wait_cycles },
  { "drone request failures",		&drone_request_failures },
  { "drones found dead",		&drones_found_dead },
  { "sleeps interrupted",		&sleeps_interrupted },
  { "cycles awaiting I/O completion",	&await_io_cycles },
  { "time at gc start",			&gc_start_time },
  { "time at end of transport",		&gc_end_transport_time },
  { "time at end of weak update",	&gc_end_weak_update_time },
  { "time at start of reload",		&gc_start_reload_time },
  { "time at gc end",			&gc_end_time },
  { "invalid last statistic",		((long *) NULL) }
};

#endif /* RECORD_GC_STATISTICS */

/* The limit on MAX_READ_OVERLAP is the number of bits in read_queue_bitmask.
   The limit on MAX_GC_DRONES is the number of bits in (* wait_mask).
   There is no direct limit on MAX_WRITE_OVERLAP.
   On the other hand, the explicit searches through the queues
   will become slower as the numbers are increased.
 */

#define MAX_READ_OVERLAP	((sizeof (long)) * CHAR_BIT)
#define MAX_WRITE_OVERLAP	MAX_READ_OVERLAP
#define MAX_GC_DRONES		((sizeof (long)) * CHAR_BIT)
#define MAX_OVERLAPPED_RETRIES	2

static char * shared_memory = ((char *) -1);
static char * malloc_memory = ((char *) NULL);
static int drones_initialized_p = 0;
static int shmid = -1;
static int n_gc_buffers, n_gc_drones, gc_next_buffer, gc_next_drone;
static struct gc_queue_entry * gc_read_queue, * gc_write_queue;
static struct drone_info * gc_drones;
static struct buffer_info * gc_buffers;
static unsigned long * wait_mask, * drone_version;

static long default_sleep_period = 20 MILLISEC;

#define GET_SLEEP_DELTA()	default_sleep_period
#define SET_SLEEP_DELTA(value)	default_sleep_period = (value)

static void
DEFUN (sleep_awaiting_drones, (microsec, mask),
       unsigned int microsec AND unsigned long mask)
{
  int saved_errno;
  int retval;

  *wait_mask = mask;
#ifdef HAVE_POLL
  retval = (poll (0, 0, (microsec / 1000)));
#else
  {
    int dummy = 0;
    struct timeval timeout;
    timeout.tv_sec = 0;
    timeout.tv_usec = microsec;
    retval
      = (select (0,
		 ((SELECT_TYPE *) &dummy),
		 ((SELECT_TYPE *) &dummy),
		 ((SELECT_TYPE *) &dummy),
		 &timeout));
  }
#endif
  *wait_mask = ((unsigned long) 0);
  saved_errno = errno;

  if ((retval == -1) && (saved_errno == EINTR))
    STATISTICS_INCR (sleeps_interrupted);
}

#ifndef _SUNOS4
#  define SYSV_SPRINTF sprintf
#else
/* Losing SunOS sprintf */

#  define SYSV_SPRINTF sysV_sprintf

static int
DEFUN (sysV_sprintf, (string, format, value),
       char * string AND char * format AND long value)
{
  sprintf (string, format, value);
  return (strlen (string));
}

#endif /* _SUNOS4 */

#ifdef SIGCONT
static void
DEFUN (continue_running, (sig), int sig)
{
  RE_INSTALL_HANDLER (SIGCONT, continue_running);
}
#endif

static void
DEFUN (start_gc_drones, (first_drone, how_many, restarting),
       int first_drone AND int how_many AND int restarting)
{
  pid_t pid;
  char arguments[512];
  struct drone_info *drone;
  char
    * shmid_string,		/* shared memory handle */
    * tdron_string,		/* total number of drones */
    * nbuf_string,		/* total number of buffers */
    * bufsiz_string,		/* size of each buffer in bytes */
    * sdron_string,		/* index of first drone to start */
    * ndron_string;		/* number of drones to start */

  shmid_string = &arguments[0];
  tdron_string =
    (shmid_string + (1 + (SYSV_SPRINTF (shmid_string, "%d", shmid))));
  nbuf_string =
    (tdron_string + (1 + (SYSV_SPRINTF (tdron_string, "%d", n_gc_drones))));
  bufsiz_string =
    (nbuf_string + (1 + (SYSV_SPRINTF (nbuf_string, "%d", n_gc_buffers))));
  sdron_string =
    (bufsiz_string
     + (1 + (SYSV_SPRINTF (bufsiz_string, "%ld",
			   (gc_total_buffer_size
			    * (sizeof (SCHEME_OBJECT)))))));
  ndron_string =
    (sdron_string + (1 + (SYSV_SPRINTF (sdron_string, "%d", first_drone))));
  (void) (SYSV_SPRINTF (ndron_string, "%d", how_many));

  drone = (gc_drones + first_drone);
  if (restarting && (drone->state != drone_dead))
    (void) (kill (drone->DRONE_PID, SIGTERM));
  drone->state = drone_not_ready;
  (* drone_version) = ((unsigned long) DRONE_VERSION_NUMBER);

  if ((pid = (vfork ())) == 0)
  {
    execlp (drone_file_name, drone_file_name, gc_file_name, shmid_string,
	    tdron_string, nbuf_string, bufsiz_string,
	    sdron_string, ndron_string, (keep_gc_file_p ? "1" : "0"),
	    ((char *) 0));
    outf_error ("\n%s (start_gc_drones): execlp (%s) failed (errno = %s).\n",
		scheme_program_name, drone_file_name, (error_name (errno)));
    drone->state = drone_dead;
    (void) (kill ((getppid ()), SIGCONT));
    _exit (1);
  }
  else if (pid == -1)
  {
    outf_error ("\n%s (start_gc_drones): vfork failed (errno = %s).\n",
		scheme_program_name, (error_name (errno)));
    drone->state = drone_dead;
  }
  else
  {
    sigset_t old_mask, new_mask;

    UX_sigemptyset (&new_mask);
    UX_sigaddset ((&new_mask), SIGCONT);
    UX_sigprocmask (SIG_BLOCK, (&new_mask), (&old_mask));
    if (drone->state == drone_not_ready)
      UX_sigsuspend (&old_mask);
    UX_sigprocmask (SIG_SETMASK, (&old_mask), 0);

    if ((drone->state != drone_idle) && !restarting)
    {
      /* Do the wait only at startup since Scheme handles SIGCHLD
	 for all children. */
      ((void) (waitpid (pid, ((int *) 0), WNOHANG)));
      drone->state = drone_dead;
    }
  }
  return;
}

static int
DEFUN (invoke_gc_drone,
       (entry, operation, buffer, position, size),
       struct gc_queue_entry * entry
       AND enum drone_state operation
       AND struct buffer_info * buffer
       AND long position
       AND long size)
{
  int result, drone_index;
  struct drone_info * drone;
  enum buffer_state old_state;

  drone_index = (entry->drone_index);
  drone = (gc_drones + drone_index);
  drone->buffer_index = buffer->index;
  drone->entry_offset = (((char *) entry) - ((char *) drone));
  
  old_state = buffer->state;
  buffer->state = ((operation == drone_reading)
		   ? buffer_being_read
		   : buffer_being_written);
  buffer->position = position;
  buffer->size = size;
  entry->buffer = buffer;
  entry->state = entry_busy;

  drone->state = operation;	/* Previously drone_idle */
  if ((result = (kill (drone->DRONE_PID, SIGCONT))) == -1)
  {
    entry->state = entry_idle;
    buffer->state = old_state;
    drone->state = drone_dead;
    if (errno != ESRCH)
      outf_error
	("\n%s (invoke_gc_drone): kill (%d, SIGCONT) failed; errno = %s.\n",
	 scheme_program_name, drone->DRONE_PID, (error_name (errno)));
    start_gc_drones (drone_index, 1, 1);
  }
  return (result != -1);
}

/* The following don't do a wait/waitpid because Scheme handles SIGCHLD. */

static void
DEFUN_VOID (kill_all_gc_drones)
{
  int count;
  struct drone_info * drone;

  for (count = 0, drone = gc_drones; count < n_gc_drones; count++, drone++)
    (void) (kill (drone->DRONE_PID, SIGTERM));
  return;
}

static int
DEFUN (probe_gc_drone, (drone), struct drone_info * drone)
{
  int result;

  if ((result = (kill ((drone->DRONE_PID), 0))) == -1)
  {
    if (errno != ESRCH)
      (void) (kill ((drone->DRONE_PID), SIGTERM));
    drone->state = drone_dead;
  }
  return (result == 0);
}

static void EXFUN (handle_drone_death, (struct drone_info *));

static void
DEFUN (probe_all_gc_drones, (wait_p), int wait_p)
{
  int count;
  unsigned long running;
  struct drone_info * drone;

  do {
    for (count = 0, drone = gc_drones, running = ((unsigned long) 0);
	 count < n_gc_drones;
	 count++, drone++)
    {
      if (drone->state != drone_idle)
      {
	running |= (((unsigned long) 1) << drone->index);
	if ((kill (drone->DRONE_PID, 0)) == -1)
	{
	  if (errno != ESRCH)
	    (void) (kill (drone->DRONE_PID, SIGTERM));
	  drone->state = drone_dead;
	  start_gc_drones (drone->index, 1, 1);
	  handle_drone_death (drone);
	}
      }
    }
    if (wait_p && (running != ((unsigned long) 0)))
    {
      sleep_awaiting_drones (default_sleep_period, running);
      STATISTICS_INCR (await_io_cycles);
    }
  } while (wait_p && (running != ((unsigned long) 0)));
  return;
}

static void EXFUN (open_gc_file, (long, int));

static int
DEFUN (sysV_initialize, (first_time_p, size, r_overlap, w_overlap, drfnam),
       int first_time_p
       AND long size AND int r_overlap AND int w_overlap
       AND CONST char * drfnam)
{
  SCHEME_OBJECT * bufptr;
  int cntr;
  long buffer_space, shared_size, malloc_size;
  struct buffer_info * buffer;

  if (r_overlap < 0)
    r_overlap = 0;
  else if (r_overlap > MAX_READ_OVERLAP)
    r_overlap = MAX_READ_OVERLAP;
  read_overlap = r_overlap;

  if (w_overlap < 0)
    w_overlap = 0;
  else if (w_overlap > MAX_WRITE_OVERLAP)
    w_overlap = MAX_WRITE_OVERLAP;
  write_overlap = w_overlap;

  if ((n_gc_drones = (read_overlap + write_overlap)) > MAX_GC_DRONES)
  {
    read_overlap = ((read_overlap * MAX_GC_DRONES) / n_gc_drones);
    write_overlap = ((write_overlap * MAX_GC_DRONES) / n_gc_drones);
    n_gc_drones = (read_overlap + write_overlap);
  }
  n_gc_buffers = (2 + n_gc_drones);

  /* The second argument to open_gc_file should be (n_gc_drones == 0),
     but we can't do this since we can change the number of drones.
   */

  if (first_time_p)
  {
    open_gc_file (size, 0);
#ifdef F_SETFD
    /* Set the close on exec flag, the drones re-open it to get a
       different file pointer so that all the processes can independently
       lseek without clobbering each other.
     */
    (void) (fcntl (gc_file, F_SETFD, 1));
#endif
  }

  buffer_space = (n_gc_buffers
		  * (gc_total_buffer_size * (sizeof (SCHEME_OBJECT))));
  shared_size =
    (ALIGN_UP_TO_IO_PAGE (buffer_space
			  + (n_gc_buffers * (sizeof (struct buffer_info)))
			  + (n_gc_drones * (sizeof (struct drone_info)))
			  + (sizeof (long))
			  + (sizeof (long))
			  + (r_overlap * (sizeof (struct gc_queue_entry)))
			  + (w_overlap * (sizeof (struct gc_queue_entry)))
			  + IO_PAGE_SIZE));

  malloc_size = ((n_gc_drones == 0)
		 ? shared_size
		 : (first_time_p ? MALLOC_SPACE : 0));

  if (malloc_size > 0)
  {
    malloc_memory = ((char *) (malloc (malloc_size)));
    if (malloc_memory == ((char *) NULL))
    {
      outf_error
	("%s (sysV_initialize): Unable to allocate %d bytes (errno = %s).\n",
	 scheme_program_name, malloc_size, (error_name (errno)));
      return (parameterization_termination (1, first_time_p));
    }
  }

  if (n_gc_drones == 0)
    shared_memory = ((char *) (ALIGN_UP_TO_IO_PAGE (malloc_memory)));
  else
  {
    if ((shmid = (shmget (IPC_PRIVATE, shared_size, 0600))) == -1)
    {
      outf_error
	("%s (sysV_initialize): shmget (-, %d, -) failed (errno = %s).\n\
          \tUnable to allocate shared memory for drone processes.\n",
	 scheme_program_name, shared_size, (error_name (errno)));
      return (parameterization_termination (0, first_time_p));
    }
    shared_memory = (shmat (shmid, ATTACH_POINT, 0));
    if (shared_memory == ((char *) -1))
    {
      int saved_errno = errno;

      (void) (shmctl (shmid, IPC_RMID, 0));
      shmid = -1;
      outf_error
	("%s (sysV_initialize): shmat (%d, 0x%lx, 0) failed. (errno = %s).\n\
	  \tUnable to attach shared memory for drone processes.\n",
	 scheme_program_name, shmid, shared_size, (error_name (saved_errno)));
      return (parameterization_termination (0, first_time_p));
    }
    signal (SIGCONT, continue_running);
  }

  if (!(ALIGNED_TO_IO_PAGE_P (shared_memory)))
  {
    outf_error
      ("%s (sysV_initialize): buffer space is not aligned properly.\n\
        \taddress = 0x%lx; IO_PAGE_SIZE = 0x%lx.\n",
       ((long) shared_memory), ((long) IO_PAGE_SIZE));
    return (parameterization_termination (0, first_time_p));
  }

  if ((n_gc_drones != 0) && (malloc_size > 0)
      && (malloc_memory != ((char *) NULL)))
  {
    free (malloc_memory);
    malloc_memory = ((char *) NULL);
  }

  gc_buffers = ((struct buffer_info *) (shared_memory + buffer_space));
  gc_drones = ((struct drone_info *) (gc_buffers + n_gc_buffers));
  drone_version = ((unsigned long *) (gc_drones + n_gc_drones));
  wait_mask = (drone_version + 1);
  gc_read_queue = ((struct gc_queue_entry *) (drone_version + 2));
  gc_write_queue = (gc_read_queue + r_overlap);

  /* Initialize structures. */

  *wait_mask = ((unsigned long) 0);
  gc_next_drone = 0;
  gc_next_buffer = 0;

  drone_file_name = ((char *) drfnam);
  if ((drfnam != ((char *) NULL)) && (drfnam[0] != SUB_DIRECTORY_DELIMITER))
  {
    CONST char * temp = (search_for_library_file (drfnam));

    if (temp != ((char *) NULL))
    {
      drone_file_name = temp;
      if (drfnam != option_gc_drone)
	free ((PTR) drfnam);
    }
  }

  for (bufptr = ((SCHEME_OBJECT *) shared_memory), cntr = 0,
       buffer = gc_buffers;
       (cntr < n_gc_buffers);
       bufptr = buffer->end, cntr++, buffer++)
  {
    buffer->index = cntr;
    buffer->state = buffer_idle;
    buffer->position = -1;
    buffer->bottom = ((PTR) bufptr);
    buffer->top = ((PTR) (bufptr + gc_buffer_size));
    buffer->end = ((PTR) (bufptr + gc_total_buffer_size));
  }

  if (n_gc_drones == 0)
    shared_memory = ((char *) -1);
  else
  {
    struct gc_queue_entry * entry;
    struct drone_info * drone;

    /* Make sure that SIGCONT is enabled. */
    {
      sigset_t mask;

      UX_sigemptyset (&mask);
      UX_sigaddset ((&mask), SIGCONT);
      UX_sigprocmask (SIG_UNBLOCK, (&mask), 0);
    }

    for (cntr = 0, entry = gc_read_queue;
	 cntr < read_overlap;
	 cntr++, entry++)
    {
      entry->index = cntr;
      entry->state = entry_idle;
      entry->retry_count = 0;
    }

    for (cntr = 0, entry = gc_write_queue;
	 cntr < write_overlap;
	 cntr++, entry++)
    {
      entry->index = cntr;
      entry->state = entry_idle;
      entry->retry_count = 0;
    }

    for (cntr = 0, drone = gc_drones;
	 cntr < n_gc_drones;
	 cntr++, drone++)
    {
      drone->index = cntr;
      drone->state = drone_not_ready;
    }

    start_gc_drones (0, n_gc_drones, 0);
    if (gc_drones->state != drone_idle)
    {
      outf_error
	("%s (sysV_initialize): Problems starting up the GC drones%s.\n",
	 scheme_program_name,
	 (((* drone_version) != ((unsigned long) DRONE_VERSION_NUMBER))
	  ? " (wrong drone version)"
	  : ""));
      return (parameterization_termination (0, first_time_p));
    }
    drones_initialized_p = 1;
  }
  return (0);
}

static void EXFUN (close_gc_file, (int));

static void
DEFUN (sysV_shutdown, (final_time_p), int final_time_p)
{
  /* arg should be (n_gc_drones > 0), see sysV_initialize */
  if (final_time_p)
    close_gc_file (1);

  if (malloc_memory != ((char *) NULL))
  {
    free (malloc_memory);
    malloc_memory = ((char *) NULL);    
  }

  if ((n_gc_drones != 0) && (drones_initialized_p))
  {
    kill_all_gc_drones ();
    drones_initialized_p = 0;
  }

  if ((shared_memory != ((char *) -1)) && ((shmdt (shared_memory)) == -1))
    outf_error ("\n%s (sysV_shutdown): shmdt failed.  errno = %s.\n",
		scheme_program_name, (error_name (errno)));
  shared_memory = ((char *) -1);

  if ((shmid != -1)
      && (shmctl (shmid, IPC_RMID, ((struct shmid_ds *) 0))) == -1)
    outf_error ("\n%s (sysV_shutdown): shmctl failed.  errno = %s.\n",
		scheme_program_name, (error_name (errno)));
  shmid = -1;

  return;
}

static int
DEFUN (find_idle_drone, (wait_p), int wait_p)
{
  int drone_index, next_drone_index, count = 0;
  struct drone_info * drone;

  drone_index = gc_next_drone;
  while (1)
  {
    count += 1;
    do
    {
      next_drone_index = (drone_index + 1);
      if (next_drone_index >= n_gc_drones)
	next_drone_index = 0;

      drone = (gc_drones + drone_index);
      switch (drone->state)
      {
      case drone_idle:
	gc_next_drone = next_drone_index;
	return (drone_index);

      case drone_dead:
	start_gc_drones (drone_index, 1, 1);
	/* fall through, look at it on next pass. */

      default:
	break;	    
      }
      drone_index = next_drone_index;
    } while (drone_index != gc_next_drone);

    /* All the drones are busy... */

    if (!wait_p)
    {
      STATISTICS_INCR (drone_request_failures);
      return (-1);
    }

    if (count == 10)
    {
      probe_all_gc_drones (0);
      count = 0;
    }
    else
    {
      /* Use -1 as the mask to awaken when any drone becomes idle. */

      sleep_awaiting_drones (default_sleep_period, ((unsigned long) -1));
      STATISTICS_INCR (drone_wait_cycles);
    }
  }
}

static void
DEFUN (abort_gc_drone, (drone), struct drone_info * drone)
{
  int restart_p = 0;
  sigset_t block_mask, signal_mask;
  
  UX_sigemptyset (&block_mask);
  UX_sigaddset ((&block_mask), SIGCONT);
  UX_sigprocmask (SIG_BLOCK, (&block_mask), (&signal_mask));

  *wait_mask = (((unsigned long) 1) << drone->index);
  if (drone->state != drone_idle)
  {
    if ((kill (drone->DRONE_PID, SIGQUIT)) == -1)
      restart_p = 1;
    else if (drone->state != drone_idle)
      UX_sigsuspend (&signal_mask);
  }
  *wait_mask = ((unsigned long) 0);
  UX_sigprocmask (SIG_SETMASK, (&signal_mask), 0);
  if (restart_p)
    start_gc_drones (drone->index, 1, 1);
  return;
}

static struct gc_queue_entry *
DEFUN (find_queue_entry, (queue, queue_size, position, drone_index),
       struct gc_queue_entry * queue AND int queue_size
       AND long position AND int drone_index)
{
  struct gc_queue_entry * entry; 
  int cntr;

  for (cntr = 0, entry = queue; cntr < queue_size; cntr++, entry++)
  {
    if ((entry->state != entry_idle)
	&& (((entry->buffer)->position == position)
	    || (entry->drone_index == drone_index)))
      return (entry);
  }
  return ((struct gc_queue_entry *) NULL);
}

enum allocate_request
{
  request_read,
  request_write,
  request_ready
};

static struct gc_queue_entry *
DEFUN (allocate_queue_entry, (queue, queue_size, position, request, mask),
       struct gc_queue_entry * queue AND int queue_size AND long position
       AND enum allocate_request request AND unsigned long * mask)
{
  struct gc_queue_entry * entry; 
  int cntr, queue_index, drone_index;
  unsigned long drone_mask;

  /* Examine all entries for duplicates, ergo no `break' */

  queue_index = -1;
  drone_mask = ((unsigned long) 0);
  for (cntr = 0, entry = queue; cntr < queue_size; cntr++, entry++)
  {
    if (entry->state == entry_idle)
      queue_index = cntr;
    else if ((entry->buffer)->position == position)
      return (entry);
    else if (entry->state == entry_error)
    {
      struct buffer_info * buffer = entry->buffer;

      entry->retry_count += 1;
      if (entry->retry_count <= MAX_OVERLAPPED_RETRIES)
      {
	if (request == request_write)
	{
	  /* This was done when originally queued, but we are paranoid. */
	  (void) (verify_write (buffer->position, buffer->size,
				((Boolean *) NULL)));
	  do
	    entry->drone_index = (find_idle_drone (1));
	  while (!(invoke_gc_drone (entry, drone_writing, entry->buffer,
				    buffer->position, buffer->size)));
	  STATISTICS_INCR (writes_retried);
	}
	else
	{
	  entry->drone_index = (find_idle_drone (0));
	  if ((entry->drone_index != -1)
	      && (invoke_gc_drone (entry, drone_reading, entry->buffer,
				   buffer->position, buffer->size)))
	    STATISTICS_INCR (pre_reads_retried);
	  else
	    STATISTICS_INCR (pre_reads_not_retried);
	}
      }
      else if (request == request_write)
      {
	STATISTICS_INCR (writes_not_deferred);
	write_data (((char *) (buffer->bottom)),
		    buffer->position, buffer->size,
		    "a queued buffer", ((Boolean *) NULL));
	buffer->state = buffer_idle;
	entry->state = entry_idle;
	entry->retry_count = 0;
	queue_index = cntr;
      }
      else
	/* If pre-reading, it will be taken care of later. */
	STATISTICS_INCR (pre_reads_deferred);
    }
    else if ((drone_index = (entry->drone_index)) != -1)
      drone_mask |= (((unsigned long) 1) << drone_index);
  }

  if (queue_index == -1)
  {
    probe_all_gc_drones (0);
    if (mask != ((unsigned long *) NULL))
      (* mask) = drone_mask;
    return ((struct gc_queue_entry *) NULL);
  }

  entry = (queue + queue_index);
  entry->buffer = ((struct buffer_info *) NULL);
  return (entry);
}

static struct buffer_info *
DEFUN_VOID (find_idle_buffer)
{
  int next_buffer, new_next_buffer;
  struct buffer_info *buffer;

  next_buffer = gc_next_buffer;
  do
  {
    new_next_buffer = (next_buffer + 1);
    if (new_next_buffer >= n_gc_buffers)
      new_next_buffer = 0;
    buffer = (gc_buffers + next_buffer);
    if (buffer->state == buffer_idle)
    {
      gc_next_buffer = new_next_buffer;
      return (buffer);
    }
    next_buffer = new_next_buffer;
  } while (next_buffer != gc_next_buffer);

  outf_fatal ("\n%s (find_idle_buffer): All buffers are in use!\n",
	      scheme_program_name);
  Microcode_Termination (TERM_GC_OUT_OF_SPACE);
  /*NOTREACHED*/
  return (0);
}

static struct buffer_info * 
DEFUN (find_ready_buffer, (position, size), long position AND long size)
{
  int next_buffer, new_next_buffer;
  struct buffer_info *buffer;

  next_buffer = gc_next_buffer;
  do
  {
    new_next_buffer = (next_buffer + 1);
    if (new_next_buffer >= n_gc_buffers)
      new_next_buffer = 0;
    buffer = (gc_buffers + next_buffer);
    if ((buffer->state == buffer_idle) /* && (buffer->size == size) */
	&& (buffer->position == position))
    {
      gc_next_buffer = new_next_buffer;
      return (buffer);
    }
    next_buffer = new_next_buffer;
  } while (next_buffer != gc_next_buffer);
  return ((struct buffer_info *) NULL);
}

static struct buffer_info *
DEFUN_VOID (get_gc_buffer)
{
  struct buffer_info * buffer;

  buffer = (find_idle_buffer ());
  buffer->state = buffer_busy;
  return (buffer);
}

static struct buffer_info *
DEFUN (read_buffer, (posn, size, noise),
       long posn AND long size AND char * noise)
{
  struct gc_queue_entry * entry;
  struct buffer_info * buffer;

  if ((read_overlap > 0)
      && ((entry = (find_queue_entry (gc_read_queue, read_overlap, posn, -2)))
	  != ((struct gc_queue_entry *) NULL))
      && ((buffer = entry->buffer) != ((struct buffer_info *) NULL)))
  {
    switch (buffer->state)
    {
      default:
        outf_error
	  ("\n%s (read_buffer %s): invalid state.\n\
	    \tindex = %d; state = %d; position = 0x%lx.\n",
	   scheme_program_name, noise, buffer->index, buffer->state, posn);
	/* fall through */

      case buffer_read_error:
	/* Try synchronously, and complain then if the condition persists. */
	break;

      case buffer_being_read:
      {
	int count;
	struct drone_info * drone = (gc_drones + entry->drone_index);

	for (count = 1; (buffer->state == buffer_being_read) ; count++)
	{
	  if (count == 10)
	  {
	    if (probe_gc_drone (drone))
	      count = 0;
	    else
	    {
	      start_gc_drones (drone->index, 1, 1);
	      goto buffer_failed;
	    }
	  }
	  else
	    sleep_awaiting_drones (default_sleep_period,
				   (((unsigned long) 1) << drone->index));
	  STATISTICS_INCR (read_wait_cycles);
	}

	if (buffer->state != buffer_ready)
	{
buffer_failed:
	  entry->state = entry_idle;
	  entry->retry_count = 0;
	  buffer->state = buffer_idle;
	  buffer->position = -1;
	  STATISTICS_INCR (reads_overlapped_aborted);
	  break;
	}
	STATISTICS_INCR (reads_pending);
	goto buffer_available;
      }

      case buffer_queued:
	STATISTICS_INCR (reads_queued);
	goto buffer_available;

      case buffer_ready:
	STATISTICS_INCR (reads_ready);

buffer_available:
	/* This should check size, but they are all the same. */
	entry->state = entry_idle;
	entry->retry_count = 0;
	buffer->state = buffer_busy;
	STATISTICS_INCR (reads_overlapped);
	return (buffer);
    }
  }
  else if ((write_overlap > 0)
	   && ((entry = (find_queue_entry (gc_write_queue, write_overlap,
					   posn, -2)))
	       != ((struct gc_queue_entry *) NULL)))
  {
    int index;

    /* This should check size, but they are all the same. */

    entry->state = entry_idle;
    entry->retry_count = 0;
    buffer = entry->buffer;
    index = entry->drone_index;
    if (index != -1)
      abort_gc_drone (gc_drones + index);
    buffer->state = buffer_busy;
    STATISTICS_INCR (reads_found_in_write_queue);
    return (buffer);
  }
  else if ((buffer = (find_ready_buffer (posn, size)))
	   != ((struct buffer_info *) NULL))
  {
    /* This should check size, but they are all the same. */

    buffer->state = buffer_busy;
    STATISTICS_INCR (reads_found_ready);
    return (buffer);
  }

  /* (read_overlap == 0) or not pre-read. */
  {
    buffer = (find_idle_buffer ());

    load_data (posn, ((char *) buffer->bottom), size,
	       noise, ((Boolean *) NULL));
    buffer->state = buffer_busy;
    STATISTICS_INCR (reads_not_overlapped);
    return (buffer);
  }
}

static void
DEFUN (write_buffer, (buffer, position, size, success, noise),
       struct buffer_info * buffer AND long position
       AND long size AND Boolean * success AND char * noise)
{
  if ((write_overlap > 0) && ((verify_write (position, size, success)) != -1))
  {
    unsigned long drone_mask;
    struct gc_queue_entry * entry =
      (allocate_queue_entry (gc_write_queue, write_overlap,
			     position, request_write, (& drone_mask)));

    if (entry == ((struct gc_queue_entry *) NULL))
    {
      STATISTICS_INCR (writes_pending);
      do
      {
	sleep_awaiting_drones (default_sleep_period, drone_mask);
	entry =
	  (allocate_queue_entry (gc_write_queue, write_overlap,
				 position, request_write, (& drone_mask)));
	STATISTICS_INCR (write_wait_cycles);
      } while (entry == ((struct gc_queue_entry *) NULL));
    }
    else if (entry->buffer != NULL)
    {
      int index = entry->drone_index;
      struct buffer_info * old_buffer;

      if (index != -1)
	abort_gc_drone (gc_drones + index);
      old_buffer = entry->buffer;
      old_buffer->state = buffer_idle;
      entry->buffer = buffer;
      outf_error ("\n%s (write_buffer %s): duplicate write at 0x%lx.\n",
		  scheme_program_name, noise, position);
    }
    do
      entry->drone_index = (find_idle_drone (1));
    while (!(invoke_gc_drone (entry, drone_writing, buffer, position, size)));
    STATISTICS_INCR (writes_overlapped);
    return;
  }

  STATISTICS_INCR (writes_not_overlapped);
  write_data (((char *) buffer->bottom), position, size, noise, success);
  buffer->state = buffer_idle;
  return;
}

static void
DEFUN (enqueue_buffer, (entry, buffer, position, size, state),
       struct gc_queue_entry * entry AND struct buffer_info * buffer
       AND long position AND long size AND enum buffer_state state)
{
  buffer->state = state;
  buffer->position = position;
  buffer->size = size;
  entry->buffer = buffer;
  entry->drone_index = -1;
  entry->state = entry_busy;
  return;
}

static void
DEFUN (enqueue_ready_buffer, (buffer, position, size),
       struct buffer_info * buffer AND long position AND long size)
{
  struct gc_queue_entry * entry;

  if ((read_overlap == 0)
      || ((entry = (allocate_queue_entry (gc_read_queue, read_overlap,
					  position, request_ready,
					  ((unsigned long *) NULL))))
	  == ((struct gc_queue_entry *) NULL)))
  {
    write_buffer (buffer, position, size, ((char *) NULL), "a ready buffer");
    STATISTICS_INCR (ready_buffers_not_enqueued);
    return;
  }
  if (entry->buffer != NULL)  
  {
    int index = entry->drone_index;
    struct buffer_info * old_buffer = entry->buffer;

    if (index != -1)
      abort_gc_drone (gc_drones + index);
    old_buffer->state = buffer_idle;
    outf_error ("\n%s (enqueue_ready_buffer): Duplicate pre-read at 0x%lx.\n",
		scheme_program_name, old_buffer->position);
  }
  enqueue_buffer (entry, buffer, position, size, buffer_queued);
  STATISTICS_INCR (ready_buffers_enqueued);
  return;
}

static void
DEFUN (abort_pre_read, (position), long position)
{
  int index;
  struct gc_queue_entry * entry;
  struct buffer_info * buffer;
  
  entry = (find_queue_entry (gc_read_queue, read_overlap, position, -2));
  if (entry == ((struct gc_queue_entry *) NULL))
    return;
  buffer = entry->buffer;
  if (buffer->state == buffer_queued)
  {
    entry->state = entry_idle;
    entry->retry_count = 0;
    write_buffer (buffer, buffer->position, buffer->size,
		  ((Boolean *) NULL), "a queued buffer");
    STATISTICS_INCR (pre_reads_requeued_as_writes);
    return;
  }
  index = entry->drone_index;
  if (index != -1)
    abort_gc_drone (gc_drones + index);
  buffer->state = buffer_idle;
  buffer->position = -1;
  entry->state = entry_idle;
  entry->retry_count = 0;
  STATISTICS_INCR (pre_reads_aborted);
  return;
}

static int
DEFUN (pre_read_buffer, (position, size), long position AND long size)
{
  struct gc_queue_entry * rentry, * wentry;
  struct buffer_info * buffer;

  if (read_overlap <= 0)
    return (0);

  /* Do this first, to guarantee that we can insert it in the queue.
     Otherwise there is no point in aborting a write, etc.
     It is not really allocated until enqueue_buffer or invoke_gc_drone.
   */

  rentry = (allocate_queue_entry (gc_read_queue, read_overlap,
				  position, request_read,
				  ((unsigned long *) NULL)));
  if (rentry == ((struct gc_queue_entry *) NULL))
  {
    STATISTICS_INCR (pre_reads_ignored);
    return (0);
  }
  else if (rentry->buffer != NULL)
    /* Already being pre-read */
    return (1);

  if ((write_overlap > 0)
      && ((wentry = (find_queue_entry (gc_write_queue, write_overlap,
				       position, -2)))
	  != ((struct gc_queue_entry *) NULL)))
  {
    int index = wentry->drone_index;

    buffer = wentry->buffer;
    if (index != -1)
      abort_gc_drone (gc_drones + index);
    wentry->state = entry_idle;
    wentry->retry_count = 0;
    enqueue_buffer (rentry, buffer, position, size, buffer_queued);
    STATISTICS_INCR (pre_reads_found_in_write_queue);
    return (1);
  }
  else if ((buffer = (find_ready_buffer (position, size)))
	   != ((struct buffer_info *) NULL))
  {
    enqueue_buffer (rentry, buffer, position, size, buffer_ready);
    STATISTICS_INCR (pre_reads_found_ready);
    return (1);
  }

  if (((rentry->drone_index = (find_idle_drone (0))) == -1)
      || (!(invoke_gc_drone (rentry, drone_reading, (find_idle_buffer ()),
			     position, size))))
  {
    STATISTICS_INCR (pre_reads_not_started);
    return (0);
  }
  STATISTICS_INCR (pre_reads_started);
  return (1);
}

static void
DEFUN (handle_drone_death, (drone), struct drone_info * drone)
{
  struct buffer_info * buffer;
  struct gc_queue_entry * entry;

  STATISTICS_INCR (drones_found_dead);
  if ((entry = (find_queue_entry (gc_write_queue, write_overlap,
				  -1, drone->index)))
      != ((struct gc_queue_entry *) NULL))
  {
    buffer = entry->buffer;
    entry->state = entry_idle;
    entry->retry_count = 0;
    if (buffer->state != buffer_idle)
    {
      write_buffer (buffer, buffer->position, buffer->size,
		    ((Boolean *) NULL), "a queued buffer whose drone died");
      STATISTICS_INCR (writes_restarted);
    }
  }
  else if ((entry = (find_queue_entry (gc_read_queue, read_overlap,
				       -1, drone->index)))
	   != ((struct gc_queue_entry *) NULL))
  {
    buffer = entry->buffer;
    if (buffer->state != buffer_ready)
    {
      entry->state = entry_idle;
      entry->retry_count = 0;
      buffer->state = buffer_idle;
      STATISTICS_INCR (pre_reads_restarted);
      (void) (pre_read_buffer (buffer->position, buffer->size));
    }
  }
  return;
}

static void
DEFUN (await_io_completion, (start_p), int start_p)
{
  int cntr;
  struct buffer_info * buffer;
  struct gc_queue_entry * entry;

  if (n_gc_drones != 0)
    probe_all_gc_drones (1);
  if (start_p)
  {
    for (cntr = 0, buffer = gc_buffers; cntr < n_gc_buffers; cntr++, buffer++)
    {
      buffer->state = buffer_idle;
      buffer->position = -1;
    }
    for (cntr = 0, entry = gc_read_queue; cntr < read_overlap; cntr++, entry++)
      entry->state = entry_idle;
    for (cntr = 0, entry = gc_write_queue; cntr < write_overlap;
	 cntr++, entry++)
      entry->state = entry_idle;
  }
  return;
}

#define CAN_RECONFIGURE_GC_BUFFERS	1

#define GC_BUFFER_ALLOCATION(space)	0

#define INITIALIZE_GC_BUFFERS(ft, start, size, ro, wo, gcd)		\
 sysV_initialize (ft, size, ro, wo, gcd)

#define RE_INITIALIZE_GC_BUFFERS(ft, start, size, ro, wo, gcd)		\
 sysV_initialize (ft, size, ro, wo, gcd)

#define BUFFER_SHUTDOWN(lt)		sysV_shutdown (lt)

#define INITIALIZE_IO()			await_io_completion (1)
#define AWAIT_IO_COMPLETION()		await_io_completion (0)

#define INITIAL_SCAN_BUFFER()		free_buffer		/* NOP */
#define INITIAL_FREE_BUFFER()		get_gc_buffer ()
#define OTHER_BUFFER(buffer)		get_gc_buffer ()

#define GC_BUFFER_BOTTOM(buffer) 	((SCHEME_OBJECT *) buffer->bottom)
#define GC_BUFFER_TOP(buffer) 		((SCHEME_OBJECT *) buffer->top)

#define READ_BUFFER			read_buffer
#define DUMP_BUFFER			write_buffer
#define PRE_READ_BUFFER			pre_read_buffer
#define ABORT_PRE_READ			abort_pre_read
#define ENQUEUE_READY_BUFFER		enqueue_ready_buffer

#define LOAD_BUFFER(buffer, position, size, noise)			\
  buffer = (read_buffer (position, size, noise))

#else /* not USE_SYSV_SHARED_MEMORY */

static struct buffer_info
  * gc_disk_buffer_1,
  * gc_disk_buffer_2;

#define CAN_RECONFIGURE_GC_BUFFERS	0

#define GC_BUFFER_ALLOCATION(space)	space

#define INITIALIZE_GC_BUFFERS(ft, start, size, ro, wo, gcd)		\
do {									\
  SCHEME_OBJECT * ptr = (start);					\
									\
  gc_disk_buffer_1 = ((struct buffer_info *) ptr);			\
  gc_disk_buffer_2 = ((struct buffer_info *)				\
		      (ptr + gc_total_buffer_size));			\
  open_gc_file (size, 1);						\
} while (0)

#define BUFFER_SHUTDOWN(lt)	close_gc_file (lt)

#define INITIALIZE_IO()		do { } while (0)
#define AWAIT_IO_COMPLETION()	do { } while (0)

#define INITIAL_FREE_BUFFER()	gc_disk_buffer_1
#define INITIAL_SCAN_BUFFER()	OTHER_BUFFER(free_buffer)

/* (gc_disk_buffer_1 - (gc_disk_buffer_2 - (buffer))) does not work
   because scan_buffer is not initialized until after scanning
   constant space.  */

#define OTHER_BUFFER(buffer)	(((buffer) == gc_disk_buffer_1)		\
				 ? gc_disk_buffer_2			\
				 : gc_disk_buffer_1)

#define GC_BUFFER_BOTTOM(buffer) ((SCHEME_OBJECT *) (buffer))
#define GC_BUFFER_TOP(buffer) (((SCHEME_OBJECT *) (buffer)) + gc_buffer_size)

static int
DEFUN (catastrophic_failure, (name), char * name)
{
  outf_fatal ("\n%s: Procedure %s should never be called!\n",
	      scheme_program_name, name);
  Microcode_Termination (TERM_EXIT);
  /*NOTREACHED*/
  return (0);
}

#define GCDIE(m)			catastrophic_failure (m)

#define RE_INITIALIZE_GC_BUFFERS(f,s,z,r,w,g)				\
					GCDIE ("RE_INITIALIZE_GC_BUFFERS")
#define READ_BUFFER(p,s,n)		GCDIE ("read_buffer")
#define PRE_READ_BUFFER(p,s)		GCDIE ("pre_read_buffer")
#define ABORT_PRE_READ(p)		GCDIE ("abort_pre_read")
#define ENQUEUE_READY_BUFFER(b,p,s)	GCDIE ("enqueue_ready_buffer")

#define LOAD_BUFFER(buffer, position, size, noise)			\
  load_data (position, ((char *) buffer), size, noise, ((Boolean *) NULL))

#define DUMP_BUFFER(buffer, position, size, successp, noise)		\
  write_data (((char *) buffer), position, size, noise, successp)

#endif /* not USE_SYSV_SHARED_MEMORY */

#define DUMP_SCAN_BUFFER(success)					\
  DUMP_BUFFER (scan_buffer, scan_position, gc_buffer_bytes,		\
	       success, "the scan buffer")

#define DUMP_FREE_BUFFER(success)					\
  DUMP_BUFFER (free_buffer, free_position, gc_buffer_bytes,		\
	       success, "the free buffer")

#define LOAD_SCAN_BUFFER()						\
  LOAD_BUFFER (scan_buffer, scan_position, gc_buffer_bytes,		\
	       "the scan buffer")

#define LOAD_FREE_BUFFER()						\
  LOAD_BUFFER (free_buffer, free_position, gc_buffer_bytes,		\
	       "the free buffer")

static int
DEFUN (next_exponent_of_two, (value), int value)
{
  unsigned int power;
  int exponent;

  if (value < 0)
    return (0);
  
  for (power = 1, exponent = 0;
       power < ((unsigned int) value);
       power = (power << 1), exponent += 1)
    ;
  return (exponent);
}

/* Hacking the gc file */

static int
  saved_gc_file = -1,
  saved_read_overlap,
  saved_write_overlap;

static long
  saved_start_position,
  saved_end_position;

int
DEFUN (swap_gc_file, (fid), int fid)
{
  /* Do not use overlapped I/O for fasdump because the drone processes
     will continue writing to the same old file!
   */
  saved_gc_file = gc_file;
  saved_read_overlap = read_overlap;
  saved_write_overlap = write_overlap;
  saved_start_position = gc_file_start_position;
  saved_end_position = gc_file_end_position;
  gc_file = fid;
  read_overlap = 0;
  write_overlap = 0;
  gc_file_end_position
    = (absolute_gc_file_end_position - gc_file_start_position);
  gc_file_start_position = 0L;
  return (saved_gc_file);
}

void
DEFUN_VOID (restore_gc_file)
{
  gc_file = saved_gc_file;
  read_overlap = saved_read_overlap;
  write_overlap = saved_write_overlap;
  gc_file_start_position = saved_start_position;
  gc_file_end_position = saved_end_position;
  saved_gc_file = -1;
  return;
}

static void
DEFUN (close_gc_file, (unlink_p), int unlink_p)
{
#ifdef HAVE_LOCKF
  if (gc_file != -1)
    {
      if ((lseek (gc_file, gc_file_start_position, SEEK_SET)) < 0)
	perror ("lseek");
      if ((lockf (gc_file, F_ULOCK,
		  (gc_file_end_position - gc_file_start_position)))
	  < 0)
	perror ("lockf");
    }
#endif
  if ((gc_file != -1) && ((close (gc_file)) == -1))
    outf_error ("\n%s (close_gc_file): error: GC file = \"%s\"; errno = %s.\n",
		scheme_program_name, gc_file_name, (error_name (errno)));
  gc_file = -1;
  if (!keep_gc_file_p && unlink_p)
    unlink (gc_file_name);
  OS_free (gc_file_name);
  gc_file_name = 0;
  keep_gc_file_p = 0;
}

#define EMPTY_STRING_P(string)						\
  (((string) == ((char *) NULL)) || ((*(string)) == '\0'))

static void
DEFUN (termination_open_gc_file, (operation, extra),
       CONST char * operation AND CONST char * extra)
{
  if ((! (EMPTY_STRING_P (operation))) && (! (EMPTY_STRING_P (extra))))
    outf_fatal
      ("%s (open_gc_file): %s (\"%s\") failed, (errno = %s).\n\t%s.\n",
       scheme_program_name, operation, gc_file_name, (error_name (errno)),
       extra);
  else if (! (EMPTY_STRING_P (operation)))
    outf_fatal
      ("%s (open_gc_file): %s (\"%s\") failed, (errno = %s).\n",
       scheme_program_name, operation, gc_file_name, (error_name (errno)));
  else if (! (EMPTY_STRING_P (extra)))
    outf_fatal ("\t%s.\n", extra);
  termination_init_error ();
  /*NOTREACHED*/
}

char *
DEFUN (make_gc_file_name, (suffix), CONST char * suffix)
{
  unsigned int s = (strlen (suffix));
  if ((option_gc_file[0]) == SUB_DIRECTORY_DELIMITER)
    {
      unsigned int n
	= (((strrchr (option_gc_file, SUB_DIRECTORY_DELIMITER))
	    - option_gc_file)
	   + 1);
      char * result = (OS_malloc (n + s + 1));
      strncpy (result, option_gc_file, n);
      (result[n]) = '\0';
      strcat (result, suffix);
      return (result);
    }
  {
    unsigned int l = (strlen (option_gc_directory));
    if ((option_gc_directory [l - 1]) == SUB_DIRECTORY_DELIMITER)
      {
	unsigned int n = l;
	char * result = (OS_malloc (n + s + 1));
	sprintf (result, "%s%s", option_gc_directory, suffix);
	return (result);
      }
    else
      {
	unsigned int n = (l + 1);
	char * result = (OS_malloc (n + s + 1));
	sprintf (result, "%s%c%s",
		 option_gc_directory, SUB_DIRECTORY_DELIMITER, suffix);
	return (result);
      }
  }
}

int
DEFUN (allocate_gc_file, (name), char * name)
{
  /* `name' must end in 6 `X' characters.  */
  char * exxes = (name + ((strlen (name)) - 6));
  unsigned int n = 0;

  while (n < 1000000)
    {
      sprintf (exxes, "%06d", n);
      if (OS_file_touch (name))
	return (1);
      n += 1;
    }
  return (0);
}

void
DEFUN (protect_gc_file_name, (name), CONST char * name)
{
  CONST char ** p = (dstack_alloc (sizeof (char *)));
  (*p) = name;
  transaction_record_action (tat_always, OS_free, p);
}

#ifndef _POSIX_VERSION
extern off_t EXFUN (lseek, (int, off_t, int));
#endif

static void
DEFUN (open_gc_file, (size, unlink_p),
       long size AND
       int unlink_p)
{
  struct stat file_info;
  int flags;
  Boolean temp_p, exists_p;

  gc_file_name
    = (make_gc_file_name
       (((option_gc_file[0]) == SUB_DIRECTORY_DELIMITER)
	? ((strrchr (option_gc_file, SUB_DIRECTORY_DELIMITER)) + 1)
	: option_gc_file));

  {
    unsigned int n = (strlen (option_gc_file));
    if ((n >= 6) && ((strcmp ((option_gc_file + (n - 6)), "XXXXXX")) == 0))
      {
	if (!allocate_gc_file (gc_file_name))
	  {
	    outf_fatal
	      ("%s: Unable to allocate a temporary file for the spare heap.\n",
	       scheme_program_name);
	    termination_open_gc_file (0, 0);
	    /*NOTREACHED*/
	  }
	temp_p = true;
      }
    else
      temp_p = false;
  }

  flags = GC_FILE_FLAGS;
  gc_file_start_position = (ALIGN_UP_TO_IO_PAGE (option_gc_start_position));
  gc_file_end_position = option_gc_end_position;
  if (gc_file_end_position == -1)
    gc_file_end_position = (gc_file_start_position + size);
  gc_file_end_position = (ALIGN_DOWN_TO_IO_PAGE (gc_file_end_position));
  if (gc_file_end_position < gc_file_start_position)
  {
    outf_fatal
      ("%s (open_gc_file): file bounds are inconsistent.\n\
        \trequested start = 0x%lx;\taligned start = 0x%lx.\n\
	\trequested end   = 0x%lx;\taligned end   = 0x%lx.\n",
       scheme_program_name,
       option_gc_start_position, gc_file_start_position,
       option_gc_end_position, gc_file_end_position);
    termination_open_gc_file (0, 0);
  }

  absolute_gc_file_end_position = gc_file_end_position;

  if ((stat (gc_file_name, &file_info)) == -1)
  {
    exists_p = false;
    can_dump_directly_p = true;
    flags |= O_EXCL;
  }
  else
  {
#ifdef __unix__
    /* If it is S_IFCHR, it should determine the IO block
       size and make sure that it will work.
       I don't know how to do that.
       ustat(2) will do that for a mounted file system,
       but obviously, if a raw device file is used,
       there better not be a file system on the device or partition.
       Does st_blksize give the correct value? -- Apparently not.
       */

    exists_p = true;
    if ((file_info.st_mode & S_IFMT) == S_IFCHR)
      can_dump_directly_p = false;

    else if (((file_info.st_mode & S_IFMT) != S_IFREG)
	     && ((file_info.st_mode & S_IFMT) != S_IFBLK))
    {
      outf_fatal
	("%s (open_gc_file): file \"%s\" has unknown/bad type 0x%x.\n\
	  \tKnown types: S_IFREG (0x%x), S_IFBLK (0x%x), S_IFCHR (0x%x).\n",
	 scheme_program_name, gc_file_name,
	 ((int) (file_info.st_mode & S_IFMT)),
	 S_IFREG, S_IFBLK, S_IFCHR);
      termination_open_gc_file (((char *) NULL), ((char *) NULL));
    }
    else
      can_dump_directly_p = true;
#else
    /* Assume that it will be a normal file.  */
    exists_p = true;
    can_dump_directly_p = true;
#endif
  }

  gc_file = (open (gc_file_name, flags, GC_FILE_MASK));
  if (gc_file == -1)
  {
#ifndef __unix__
    /* errno does not give sufficient information except under unix. */

    int saved_errno = errno;
    char
      directory_buffer[FILE_NAME_LENGTH],
      * directory, * directory_end;

    directory = &directory_buffer[0];
    strcpy (directory, gc_file_name);
    directory_end = (strrchr (directory, SUB_DIRECTORY_DELIMITER));
    if (directory_end != ((char *) NULL))
      * directory_end = '\0';
    if ((access (directory, F_OK)) != 0)
    {
      outf_fatal
	("\n%s (open_gc_file): GC directory \"%s\" does not exist.\n",
	 scheme_program_name, directory);
      termination_open_gc_file (((char *) NULL), ((char *) NULL));
    }
    else if ((access (directory, W_OK)) != 0)
    {
      outf_fatal
	("\n%s (open_gc_file): GC directory \"%s\" is read protected.\n",
	 scheme_program_name, directory);
      termination_open_gc_file (((char *) NULL), ((char *) NULL));
    }      
    else
      errno = saved_errno;
#endif /* not __unix__ */
    termination_open_gc_file ("open", ((char *) NULL));
  }

  keep_gc_file_p = (option_gc_keep || (exists_p && (!temp_p)));

#ifdef UNLINK_BEFORE_CLOSE
  if (!keep_gc_file_p && unlink_p)
    unlink (gc_file_name);
#endif  

#ifdef HAVE_PREALLOC
  if (!exists_p)
    prealloc (gc_file, ((unsigned int) gc_file_end_position));
#endif

#ifdef HAVE_LOCKF
  if (exists_p)
    {
      if ((lseek (gc_file, gc_file_start_position, SEEK_SET)) < 0)
	termination_open_gc_file ("lseek", ((char *) NULL));

      if ((lockf (gc_file, F_TLOCK, size)) < 0)
	termination_open_gc_file
	  ("lockf",
	   "The GC file is probably being used by another process");
    }
#endif

  gc_file_current_position = -1;	/* Unknown position */

#ifdef __unix__
  /* Determine whether it is a seekable file. */
  if (exists_p && ((file_info.st_mode & S_IFMT) == S_IFCHR))
  {
#ifdef HAVE_FCNTL
    int fcntl_flags;
#endif
    Boolean ignore;
    static char message[] = "This is a test message to the GC file.\n";
    char * buffer;
  
    buffer = ((char *) aligned_heap);
    strcpy (buffer, &message[0]);
    strncpy ((buffer + ((sizeof (message)) - 1)),
	     buffer,
	     (IO_PAGE_SIZE - (sizeof (message))));
    (* (buffer + (IO_PAGE_SIZE - 1))) = '\n';

#ifdef HAVE_FCNTL
    fcntl_flags = (fcntl (gc_file, F_GETFL, 0));
    if (fcntl_flags != (-1))
      fcntl (gc_file, F_SETFL, (fcntl_flags | O_NONBLOCK));
#endif

    write_data (buffer,
		(gc_file_start_position + ((long) IO_PAGE_SIZE)),
		((long) IO_PAGE_SIZE),
		"a test buffer (1)",
		&ignore);
    load_data (gc_file_start_position,
	       (buffer + IO_PAGE_SIZE),
	       ((long) (2 * IO_PAGE_SIZE)),
	       "a test buffer (2)",
	       &ignore);
    if ((strncmp (buffer, (buffer + (2 * IO_PAGE_SIZE)), IO_PAGE_SIZE)) != 0)
    {
      outf_fatal ("\n%s (open_gc_file): \"%s\" is not a seek-able device.\n",
		  scheme_program_name, gc_file_name);
      termination_open_gc_file (((char *) NULL), ((char *) NULL));
    }
#ifdef HAVE_FCNTL
    if (fcntl_flags != (-1))
      fcntl (gc_file, F_SETFL, fcntl_flags);
#endif
  }
#endif /* __unix__ */
}

#define CONSTANT_SPACE_FUDGE	128

Boolean
DEFUN (update_allocator_parameters, (ctop), SCHEME_OBJECT * ctop)
{
  SCHEME_OBJECT * htop;
  long new_end;

  /* buffer for impurify, etc. */
  ctop = ((SCHEME_OBJECT *)
	  (ALIGN_UP_TO_IO_PAGE (ctop + CONSTANT_SPACE_FUDGE)));
  htop = ((SCHEME_OBJECT *)
	  (ALIGN_DOWN_TO_IO_PAGE (Highest_Allocated_Address)));
  if (ctop >= htop)
    return (FALSE);

  new_end = (((char *) htop) - ((char *) ctop));
  new_end = (CEILING (new_end, gc_buffer_bytes));
  new_end += gc_file_start_position;
  if ((new_end > absolute_gc_file_end_position)
      && (! option_gc_end_position))
    return (FALSE);

  gc_file_end_position = new_end;
  Constant_Top = ctop;
  Heap_Bottom = Constant_Top;
  Heap_Top = htop;
  aligned_heap = Heap_Bottom;
  Local_Heap_Base = Heap_Bottom;
  Unused_Heap_Bottom = Heap_Top;
  Unused_Heap_Top = Highest_Allocated_Address;
  Free = Heap_Bottom;
  SET_MEMTOP (Heap_Top - GC_Reserve);
  return (TRUE);
}

Boolean
DEFUN_VOID (recompute_gc_end_position)
{
  SCHEME_OBJECT * htop;
  long new_end, delta;

  if ((((gc_file_end_position - gc_file_start_position) % gc_buffer_bytes)
       == 0)
      || option_gc_end_position)
    return (TRUE);

  htop = ((SCHEME_OBJECT *)
	  (ALIGN_DOWN_TO_IO_PAGE (Highest_Allocated_Address)));
  new_end = (CEILING ((((char *) htop) - ((char *) Constant_Top)),
		      gc_buffer_bytes));
  new_end += gc_file_start_position;
  if (new_end <= absolute_gc_file_end_position)
  {
    gc_file_end_position = new_end;
    return (TRUE);
  }
  delta = (FLOOR ((absolute_gc_file_end_position - gc_file_start_position),
		  gc_buffer_bytes));
  if ((((char *) Constant_Top) + delta) <= (((char *) Free) + GC_Reserve))
    /* This should really GC and retry, but ... */
    return (FALSE);
  Heap_Top = ((SCHEME_OBJECT *) (((char *) Constant_Top) + delta));
  SET_MEMTOP (Heap_Top - GC_Reserve);
  return (TRUE);
}

void
DEFUN_VOID (reset_allocator_parameters)
{
  GC_Reserve = 4500;
  GC_Space_Needed = 0;
  Stack_Bottom = ((SCHEME_OBJECT *)
		  (ALIGN_UP_TO_IO_PAGE (Lowest_Allocated_Address)));
  Stack_Top = ((SCHEME_OBJECT *)
	       (ALIGN_DOWN_TO_IO_PAGE
		(Stack_Bottom + (STACK_ALLOCATION_SIZE (saved_stack_size)))));
  Constant_Space = Stack_Top;
  Free_Constant = Constant_Space;
  (void) update_allocator_parameters (Free_Constant);
  SET_CONSTANT_TOP ();
  ALIGN_FLOAT (Free);
  INITIALIZE_STACK ();
  STACK_RESET ();
  return;
}

void
DEFUN (Clear_Memory, (heap_size, stack_size, constant_space_size),
       int heap_size
       AND int stack_size
       AND int constant_space_size)
{
  saved_heap_size = heap_size;
  saved_constant_size = constant_space_size;
  saved_stack_size = stack_size;
  reset_allocator_parameters ();
}

void
DEFUN_VOID (Reset_Memory)
{
  BUFFER_SHUTDOWN (1);
  HEAP_FREE (Lowest_Allocated_Address);
  DEALLOCATE_REGISTERS ();
  return;
}

#define BLOCK_TO_IO_SIZE(size)						\
  ((ALIGN_UP_TO_IO_PAGE ((size) * (sizeof (SCHEME_OBJECT))))		\
   / (sizeof (SCHEME_OBJECT)))

static int
DEFUN (set_gc_buffer_sizes, (new_buffer_shift), unsigned long new_buffer_shift)
{
  unsigned long
    new_buffer_size, new_buffer_bytes, new_buffer_byte_shift,
    new_buffer_overlap_bytes, new_extra_buffer_size;
  
  new_buffer_size = (1L << new_buffer_shift);
  new_buffer_bytes = (new_buffer_size * (sizeof (SCHEME_OBJECT)));
  if (! (ALIGNED_TO_IO_PAGE_P (new_buffer_bytes)))
  {
    outf_error
      ("%s (Setup_Memory): improper new_buffer_size.\n\
	\tIO_PAGE_SIZE   = 0x%lx bytes.\n\
	\tgc_buffer_size = 0x%lx bytes = 0x%lx objects.\n\
	\tIO_PAGE_SIZE should divide gc_buffer_size.\n",
       scheme_program_name,
       ((long) IO_PAGE_SIZE),
       new_buffer_bytes, new_buffer_size);
    return (-1);
  }

  new_buffer_byte_shift = (next_exponent_of_two (new_buffer_bytes));
  if ((((unsigned long) 1L) << new_buffer_byte_shift) != new_buffer_bytes)
  {
    outf_error
      ("%s (Setup_Memory): gc_buffer_bytes (0x%lx) is not a power of 2.\n",
       scheme_program_name, new_buffer_bytes);
    return (-1);
  }

  new_buffer_overlap_bytes = IO_PAGE_SIZE;
  new_extra_buffer_size
    = (new_buffer_overlap_bytes / (sizeof (SCHEME_OBJECT)));
  if ((new_extra_buffer_size * (sizeof (SCHEME_OBJECT)))
      != new_buffer_overlap_bytes)
  {
    outf_error
      (" %s (Setup_Memory): improper IO_PAGE_SIZE.\n\
	\tIO_PAGE_SIZE = 0x%lx; (sizeof (SCHEME_OBJECT)) = 0x%lx.\n\
	\t(sizeof (SCHEME_OBJECT)) should divide IO_PAGE_SIZE.\n",
       scheme_program_name,
       ((long) IO_PAGE_SIZE), ((long) (sizeof (SCHEME_OBJECT))));
    return (-1);
  }

  gc_buffer_shift = new_buffer_shift;
  gc_buffer_size = new_buffer_size;
  gc_buffer_bytes = new_buffer_bytes;
  gc_buffer_mask = (gc_buffer_size - 1);
  gc_buffer_byte_shift = new_buffer_byte_shift;
  gc_buffer_overlap_bytes = new_buffer_overlap_bytes;
  gc_extra_buffer_size = new_extra_buffer_size;
  gc_buffer_remainder_bytes = (gc_buffer_bytes - gc_buffer_overlap_bytes);
  gc_total_buffer_size = (gc_buffer_size + gc_extra_buffer_size);
  return (0);
}

void
DEFUN (Setup_Memory, (heap_size, stack_size, constant_space_size),
       int heap_size
       AND int stack_size
       AND int constant_space_size)
{
  SCHEME_OBJECT test_value;
  int real_stack_size;
  long gc_buffer_allocation;

  ALLOCATE_REGISTERS ();

  /* Consistency check 1 */
  if (heap_size == 0)
  {
    outf_fatal ("%s (Setup_Memory): Configuration won't hold initial data.\n",
		scheme_program_name);
    termination_init_error ();
    /*NOTREACHED*/
  }

  real_stack_size = (STACK_ALLOCATION_SIZE (stack_size));

  /* add log(1024)/log(2) to exponent */
  if ((set_gc_buffer_sizes (10
			    + (next_exponent_of_two (option_gc_window_size))))
      != 0)
    parameterization_termination (1, 1);

  /* Use multiples of IO_PAGE_SIZE. */

  heap_size = (BLOCK_TO_IO_SIZE (heap_size));
  constant_space_size = (BLOCK_TO_IO_SIZE (constant_space_size));
  real_stack_size = (BLOCK_TO_IO_SIZE (real_stack_size));
  gc_buffer_allocation = (GC_BUFFER_ALLOCATION (2 * gc_total_buffer_size));

  /* Allocate. */

  ALLOCATE_HEAP_SPACE ((heap_size
			+ constant_space_size + real_stack_size
			+ gc_buffer_allocation
			+ (IO_PAGE_SIZE / (sizeof (SCHEME_OBJECT)))),
		       Lowest_Allocated_Address,
		       Highest_Allocated_Address);

  /* Consistency check 2 */
  if (Lowest_Allocated_Address == NULL)
  {
    outf_fatal
      ("%s (Setup_Memory): Not enough memory for this configuration.\n",
       scheme_program_name);
    termination_init_error ();
    /*NOTREACHED*/
  }

  Highest_Allocated_Address -= gc_buffer_allocation;

  /* Consistency check 3 */
  test_value =
    (MAKE_POINTER_OBJECT (LAST_TYPE_CODE, Highest_Allocated_Address));

  if (((OBJECT_TYPE (test_value)) != LAST_TYPE_CODE) ||
      ((OBJECT_ADDRESS (test_value)) != Highest_Allocated_Address))
  {
    outf_fatal
      ("%s (Setup_Memory): \
	Largest address does not fit in datum field of object.\n\
	\tAllocate less space or re-configure without HEAP_IN_LOW_MEMORY.\n",
       scheme_program_name);
    Reset_Memory ();
    termination_init_error ();
    /*NOTREACHED*/
  }

  Clear_Memory (heap_size, stack_size, constant_space_size);
  INITIALIZE_GC_BUFFERS (1,
			 Highest_Allocated_Address,
			 ((sizeof (SCHEME_OBJECT))
			  * (CEILING ((heap_size + constant_space_size),
				      gc_buffer_size))),
			 option_gc_read_overlap,
			 option_gc_write_overlap,
			 option_gc_drone);
  return;
}

/* Utilities for the GC proper. */ 

static void
DEFUN (enqueue_free_buffer, (success), Boolean * success)
{
  int diff;

  diff = ((free_position - pre_read_position) >> gc_buffer_byte_shift);
  if (diff >= read_overlap)
    DUMP_FREE_BUFFER (success);
  else
  {
    ENQUEUE_READY_BUFFER (free_buffer, free_position, gc_buffer_bytes);
    read_queue_bitmask |= (1L << diff);
  }
  return;
}

static void
DEFUN_VOID (schedule_pre_reads)
{
  int cntr;
  long position;
  unsigned long bit;

  if (pre_read_position == scan_position)
  {
    read_queue_bitmask = (read_queue_bitmask >> 1);
    pre_read_position += gc_buffer_bytes;
  }
  for (cntr = 0, bit = 1L, position = pre_read_position;
       ((cntr < read_overlap) && (position < free_position));
       cntr++, bit = (bit << 1), position += gc_buffer_bytes)
  {
    if ((read_queue_bitmask & bit) != bit)
      if (PRE_READ_BUFFER (position, gc_buffer_bytes))
	read_queue_bitmask |= bit;
  }
  return;
}

static void
DEFUN_VOID (abort_pre_reads)
{
  while (scan_position > pre_read_position)
  {
    ABORT_PRE_READ (pre_read_position);
    pre_read_position += gc_buffer_bytes;
    read_queue_bitmask = (read_queue_bitmask >> 1);
  }
  schedule_pre_reads ();
  return;
}

static void
DEFUN (reload_scan_buffer, (skip), unsigned long skip)
{
  scan_position += (skip << gc_buffer_byte_shift);
  virtual_scan_pointer += (skip << gc_buffer_shift);

  if ((read_overlap > 0) && (scan_position > pre_read_position))
    abort_pre_reads ();

  if (scan_position == free_position)
  {
    pre_read_position = (free_position + gc_buffer_bytes);
    read_queue_bitmask = 0L;
    scan_buffer = free_buffer;
    scan_buffer_bottom = free_buffer_bottom;
    scan_buffer_top = free_buffer_top;
    return;
  }
  LOAD_SCAN_BUFFER ();
  scan_buffer_bottom = (GC_BUFFER_BOTTOM (scan_buffer));
  scan_buffer_top = (GC_BUFFER_TOP (scan_buffer));
  *scan_buffer_top = (MAKE_POINTER_OBJECT (TC_BROKEN_HEART, scan_buffer_top));
  
  if (read_overlap > 0)
    schedule_pre_reads ();
}

SCHEME_OBJECT *
DEFUN (dump_and_reload_scan_buffer, (end, success),
       SCHEME_OBJECT * end AND
       Boolean * success)
{
  unsigned long number_to_skip = (end - scan_buffer_top);
  DUMP_SCAN_BUFFER (success);
  reload_scan_buffer (1 + (number_to_skip >> gc_buffer_shift));
  return (scan_buffer_bottom + (number_to_skip & gc_buffer_mask));
}

SCHEME_OBJECT *
DEFUN (dump_and_reset_free_buffer, (current_free, success),
       SCHEME_OBJECT * current_free AND
       Boolean * success)
{
  unsigned long overflow = (current_free - free_buffer_top);
  SCHEME_OBJECT * from = free_buffer_top;
  Boolean buffer_overlap_p = extension_overlap_p;
  Boolean same_buffer_p = (scan_buffer == free_buffer);

  if (read_overlap > 0)
    {
      if (buffer_overlap_p)
	{
	  extension_overlap_p = false;
	  next_scan_buffer = free_buffer;
	}
      else if (!same_buffer_p)
	enqueue_free_buffer (success);
    }
  else if (!same_buffer_p)
    DUMP_FREE_BUFFER (success);

  /* Otherwise there is no need to dump now, it will be dumped
     when scan is dumped.  Note that the next buffer may be dumped
     before this one, but there should be no problem lseeking past the
     end of file.  */
  free_position += gc_buffer_bytes;
  free_buffer = (OTHER_BUFFER (scan_buffer));
  free_buffer_bottom = (GC_BUFFER_BOTTOM (free_buffer));
  free_buffer_top = (GC_BUFFER_TOP (free_buffer));
  {
    SCHEME_OBJECT * into = free_buffer_bottom;
    SCHEME_OBJECT * end = (into + overflow);
    while (into < end)
      (*into++) = (*from++);
    if (same_buffer_p && (!buffer_overlap_p))
      (*scan_buffer_top)
	= (MAKE_POINTER_OBJECT (TC_BROKEN_HEART, scan_buffer_top));
    return (into);
  }
}

/* These utilities are needed when pointers fall accross window boundaries.

   Between both they effectively do a dump_and_reload_scan_buffer, in two
   stages.
*/

void
DEFUN (extend_scan_buffer, (to_where, current_free),
       char * to_where AND
       SCHEME_OBJECT * current_free)
{
  fast char * source, * dest;
  long new_scan_position = (scan_position + gc_buffer_bytes);

  /* Is there buffer overlap?, i.e. is the next bufferful the one cached
     in the free pointer window?
   */

  scan_buffer_extended_p = true;
  dest = ((char *) scan_buffer_top);
  extension_overlap_length = (to_where - dest);
  extension_overlap_p = (new_scan_position == free_position);

  if (extension_overlap_p)
  {
    long temp;

    source = ((char *) free_buffer_bottom);
    temp = (((char *) current_free) - source);
    if (temp < extension_overlap_length)
    {
      /* This should only happen when Scan and Free are very close. */
      extension_overlap_length = temp;
    }
  }
  else if (read_overlap == 0)
  {
    load_data (new_scan_position, dest, gc_buffer_overlap_bytes,
	       "the next scan buffer", ((Boolean *) NULL));
    return;
  }
  else
  {
    LOAD_BUFFER (next_scan_buffer, new_scan_position,
		 gc_buffer_bytes, "the next scan buffer");
    source = ((char *) (GC_BUFFER_BOTTOM (next_scan_buffer)));
  }

  while (dest < to_where)
    *dest++ = *source++;
  return;
}

char *
DEFUN (end_scan_buffer_extension, (to_relocate), char * to_relocate)
{
  char * result;
  if (extension_overlap_p)
  {
    /* There was overlap between the scan buffer and the free buffer,
       there may no longer be, but dump_and_reload_scan_buffer will
       get us the correct next buffer.
       The old scan buffer may be written, but the while loop below
       will read storage contiguous to it (in the buffer extension).
     */
    SCHEME_OBJECT old, new;
    fast char * source, * dest, * limit;

    extension_overlap_p = false;
    source = ((char *) scan_buffer_top);
    old = (* ((SCHEME_OBJECT *) source));
    limit = (source + extension_overlap_length);
    dest = ((char *) (dump_and_reload_scan_buffer (scan_buffer_top, 0)));
    /* The following is only necesary if we are reusing the scan buffer. */
    new = (* scan_buffer_top);
    (* ((SCHEME_OBJECT *) source)) = old;
    result = (dest + (to_relocate - source));
    while (source < limit)
      *dest++ = *source++;
    (* scan_buffer_top) = new;
  }
  else if (next_scan_buffer == ((struct buffer_info *) NULL))
  {
    /* There was no buffer overlap and no read overlap */

    fast SCHEME_OBJECT * source, * dest, * limit;

    source = scan_buffer_top;
    limit = (source + gc_extra_buffer_size);

    DUMP_SCAN_BUFFER (0);
    scan_position += gc_buffer_bytes;
    virtual_scan_pointer += gc_buffer_size;

    scan_buffer = (OTHER_BUFFER (free_buffer));
    scan_buffer_bottom = (GC_BUFFER_BOTTOM (scan_buffer));
    scan_buffer_top = (GC_BUFFER_TOP (scan_buffer));

    dest = scan_buffer_bottom;
    result = (((char *) dest) + (to_relocate - ((char *) source)));

    while (source < limit)
      *dest++ = *source++;

    if (gc_buffer_remainder_bytes != 0)
      load_data ((scan_position + gc_buffer_overlap_bytes),
		 ((char *) dest), gc_buffer_remainder_bytes,
		 "the scan buffer", ((Boolean *) NULL));

    (* scan_buffer_top) =
      (MAKE_POINTER_OBJECT (TC_BROKEN_HEART, scan_buffer_top));
  }
  else
  {
    /* There is overlap with the next bufferful (not the free bufferful). */

    fast char * source, * dest, * limit;

    source = ((char *) scan_buffer_top);
    limit = (source + extension_overlap_length);
    dest = ((char *) (GC_BUFFER_BOTTOM (next_scan_buffer)));
    result = (dest + (to_relocate - source));

    while (source < limit)
      *dest++ = *source++;
    
    DUMP_SCAN_BUFFER (0);
    scan_position += gc_buffer_bytes;
    virtual_scan_pointer += gc_buffer_size;

    scan_buffer = next_scan_buffer;
    next_scan_buffer = NULL;
    scan_buffer_bottom = (GC_BUFFER_BOTTOM (scan_buffer));
    scan_buffer_top = (GC_BUFFER_TOP (scan_buffer));
    (* scan_buffer_top) =
      (MAKE_POINTER_OBJECT (TC_BROKEN_HEART, scan_buffer_top));
    schedule_pre_reads ();
  }
  scan_buffer_extended_p = false; 
  return (result);
}

/* This is used to avoid unnecessary copying when copying a large
   non-marked area.
 */

SCHEME_OBJECT *
DEFUN (dump_free_directly, (from, nbuffers, success),
       fast SCHEME_OBJECT * from
       AND fast long nbuffers
       AND Boolean * success)
{
  if (((read_overlap + write_overlap) == 0)
      && (can_dump_directly_p || (ALIGNED_TO_IO_PAGE_P (from))))
  {
    long byte_length = (nbuffers << gc_buffer_byte_shift);

    write_data (((char *) from), free_position, byte_length,
		"free buffers", success);
    free_position += byte_length;
  }
  else
  {
    /* This assumes that the free buffer has no valid data, so it can be
       used as scratch.
       This code is executed when there is I/O overlap, or when the
       data is not aligned to be written to a raw (character) device.
     */

    while ((--nbuffers) >= 0)
    {
      fast SCHEME_OBJECT * to, * bufend;

      for (to = free_buffer_bottom, bufend = free_buffer_top; to != bufend; )
	*to++ = *from++;

      (void) (dump_and_reset_free_buffer (to, success));
    }
  }
  return (free_buffer_bottom);
}

/* This code is needed by purify.  After the purified object is
   copied, the next step is to scan constant space.  In order to do
   this, it's necessary to save the current scan position, reset the
   scan limit pointers to scan constant space, then restore the saved
   scan position and finish scanning the heap.  These procedures
   provide the necessary functionality to do this.  */

static void
DEFUN_VOID (reset_scan_buffer)
{
  virtual_scan_pointer = 0;
  scan_position = (-1L);
  scan_buffer = 0;
  scan_buffer_bottom = 0;
  scan_buffer_top = Highest_Allocated_Address;
  next_scan_buffer = 0;
  scan_buffer_extended_p = false;
  extension_overlap_p = false;
  extension_overlap_length = 0;
}

void
DEFUN (save_scan_state, (state, scan),
       struct saved_scan_state * state AND
       SCHEME_OBJECT * scan)
{
  (state -> virtual_scan_pointer) = virtual_scan_pointer;
  (state -> scan_position) = scan_position;
  (state -> scan_offset) = (scan - scan_buffer_bottom);
  if (scan_position != free_position)
    DUMP_SCAN_BUFFER (0);
  reset_scan_buffer ();
}

SCHEME_OBJECT *
DEFUN (restore_scan_state, (state), struct saved_scan_state * state)
{
  virtual_scan_pointer = (state -> virtual_scan_pointer);
  scan_position = (state -> scan_position);
  if (scan_position == free_position)
    {
      scan_buffer = free_buffer;
      scan_buffer_bottom = free_buffer_bottom;
      scan_buffer_top = free_buffer_top;
    }
  else
    {
      scan_buffer = (OTHER_BUFFER (free_buffer));
      scan_buffer_bottom = (GC_BUFFER_BOTTOM (scan_buffer));
      scan_buffer_top = (GC_BUFFER_TOP (scan_buffer));
      LOAD_SCAN_BUFFER ();
    }
  return (scan_buffer_bottom + (state -> scan_offset));
}

void
DEFUN (set_fixed_scan_area, (bottom, top),
       SCHEME_OBJECT * bottom AND
       SCHEME_OBJECT * top)
{
  virtual_scan_pointer = bottom;
  scan_buffer_bottom = bottom;
  scan_buffer_top = top;
}

#ifndef START_TRANSPORT_HOOK
#define START_TRANSPORT_HOOK()		do { } while (0)
#endif

#ifndef END_TRANSPORT_HOOK
#define END_TRANSPORT_HOOK()		do { } while (0)
#endif

#ifndef END_WEAK_UPDATE_HOOK
#define END_WEAK_UPDATE_HOOK()		do { } while (0)
#endif

#ifndef START_RELOAD_HOOK
#define START_RELOAD_HOOK()		do { } while (0)
#endif

#ifndef END_GC_HOOK
#define END_GC_HOOK()			do { } while (0)
#endif

/* This hacks the scan buffer also so that Scan is always below
   scan_buffer_top until the scan buffer is initialized.
   Various parts of the garbage collector depend on scan_buffer_top
   having an aligned value.
*/

SCHEME_OBJECT *
DEFUN_VOID (initialize_free_buffer)
{
  STATISTICS_CLEAR ();
  START_TRANSPORT_HOOK ();
  read_queue_bitmask = 0L;
  pre_read_position = gc_file_start_position;
  free_position = gc_file_start_position;
  INITIALIZE_IO ();
  free_buffer = (INITIAL_FREE_BUFFER ());
  free_buffer_bottom = (GC_BUFFER_BOTTOM (free_buffer));
  free_buffer_top = (GC_BUFFER_TOP (free_buffer));
  reset_scan_buffer ();
  /* Force first write to do an lseek. */
  gc_file_current_position = -1;
  return (free_buffer_bottom);
}

SCHEME_OBJECT *
DEFUN (initialize_scan_buffer, (block_start), SCHEME_OBJECT * block_start)
{
  virtual_scan_base = block_start;
  virtual_scan_pointer = virtual_scan_base;
  scan_position = gc_file_start_position;
  scan_buffer = (INITIAL_SCAN_BUFFER ());
  scan_buffer_bottom = (GC_BUFFER_BOTTOM (scan_buffer));
  scan_buffer_top = (GC_BUFFER_TOP (scan_buffer));
  reload_scan_buffer (0);
  return (scan_buffer_bottom);
}

void
DEFUN (end_transport, (success), Boolean * success)
{
  DUMP_SCAN_BUFFER (success);
  scan_position += gc_buffer_bytes;
  virtual_scan_pointer += gc_buffer_size;
  free_position = scan_position;
  END_TRANSPORT_HOOK ();
  STATISTICS_PRINT (2, "after transport");
  return;
}

void
DEFUN (final_reload, (to, length, noise),
       SCHEME_OBJECT * to AND unsigned long length AND char * noise)
{
  unsigned long byte_length;

  byte_length = (ALIGN_UP_TO_IO_PAGE (length * (sizeof (SCHEME_OBJECT))));
  END_WEAK_UPDATE_HOOK ();
  AWAIT_IO_COMPLETION ();
  START_RELOAD_HOOK ();
  load_data (gc_file_start_position, ((char *) to), byte_length,
	     noise, ((Boolean *) NULL));
  END_GC_HOOK ();
  STATISTICS_PRINT (1, "after final reload");
  return;
}

static int
  weak_buffer_pre_read_count;

static long
  weak_pair_buffer_position;

static struct buffer_info
  * weak_pair_buffer;

static SCHEME_OBJECT
  weak_pair_break;

/* This procedure is not very smart.

   It does not attempt to figure out whether the position being
   requested is already being pre-read, nor does it look further down
   the weak chain list for duplicate positions, to avoid early writes.

   On the other hand, pre_read_buffer will ignore the request if it is
   a duplicate, and will abort a pending write if a read for the same
   position is requested.
 */   

static void
DEFUN (pre_read_weak_pair_buffers, (low_heap), SCHEME_OBJECT * low_heap)
{
  SCHEME_OBJECT next, * pair_addr, * obj_addr;
  long position, last_position;

  last_position = -1;
  next = weak_pair_break;
  while (next != EMPTY_WEAK_CHAIN)
  {
    pair_addr = (OBJECT_ADDRESS (next));
    obj_addr = (OBJECT_ADDRESS (*pair_addr++));
    if (! (obj_addr < low_heap))
    {
      position = (obj_addr - aligned_heap);
      position = (position >> gc_buffer_shift);
      position = (position << gc_buffer_byte_shift);
      position += gc_file_start_position;

      if ((position != last_position)
	  && (position != weak_pair_buffer_position))
      {
	last_position = position;
	if ((weak_buffer_pre_read_count >= read_overlap)
	    || (!(PRE_READ_BUFFER (position, gc_buffer_bytes))))
	  break;
	weak_buffer_pre_read_count += 1;
      }
    }
    next = (OBJECT_NEW_TYPE (TC_NULL, (*pair_addr)));
  }
  weak_pair_break = next;
  return;
}

/* The following code depends on being called in between copying objects,
   so that the "free" pointer points to the middle of the free buffer,
   and thus the overlap area at the end of the free buffer is available
   as temporary storage.  In addition, because we have not yet moved free,
   next_scan_buffer has not been set even if we are in the middle of a
   scan buffer extension.
 */

SCHEME_OBJECT
DEFUN (read_newspace_address, (addr), SCHEME_OBJECT * addr)
{
  long position;
  unsigned long offset;
  SCHEME_OBJECT result;

  if ((addr >= Constant_Space) && (addr < Free_Constant))
    return (* addr);

  position = (addr - virtual_scan_base);
  offset = (position & gc_buffer_mask);
  position = (position >> gc_buffer_shift);
  position = (position << gc_buffer_byte_shift);
  position += gc_file_start_position;

  if (position > free_position)
  {
    outf_fatal
      ("\n%s (read_newspace_address): Reading outside of GC window!\n\
	\t         addr = 0x%lx;\t     position = 0x%lx.\n\
	\tscan_position = 0x%lx;\tfree_position = 0x%lx.\n",
       scheme_program_name,
       addr, position,
       scan_position, free_position);
    Microcode_Termination (TERM_EXIT);
    /*NOTREACHED*/    
  }
  if (position == scan_position)
    result = (* (scan_buffer_bottom + offset));
  else if (position == free_position)
    result = (* (free_buffer_bottom + offset));
  else if ((position == ((long) (scan_position + gc_buffer_bytes)))
	   && scan_buffer_extended_p
	   && ((read_overlap != 0) || (offset < gc_extra_buffer_size)))
  {
    /* Note: we need not worry about the state of extension_overlap_p,
       because if there is overlap between the scan extension and the free
       buffer, then (position == free_position) would be true,
       and that case has already been taken care of.
     */
       
    result = ((read_overlap == 0)
	      ? (* (scan_buffer_top + offset))
	      : (* ((GC_BUFFER_BOTTOM (next_scan_buffer)) + offset)));
  }
  else if ((read_overlap <= 0) || (position > pre_read_position))
  {
    unsigned long position2;

    position = (((char *) addr) - ((char *) virtual_scan_base));
    position2 = (ALIGN_DOWN_TO_IO_PAGE (position));
    offset = (position - position2);
    position2 += gc_file_start_position;
    
    load_data (position2,
	       ((char *) free_buffer_top),
	       IO_PAGE_SIZE,
	       "a buffer for read_newspace_address",
	       ((Boolean *) NULL));
    result = (* ((SCHEME_OBJECT *) (((char *) free_buffer_top) + offset)));
  }
  else
  {
    /* The buffer is pre-read or in the process of being pre-read.
       Force completion of the read, fetch the location,
       and re-queue the buffer as ready.
     */

    LOAD_BUFFER (next_scan_buffer, position, gc_buffer_bytes,
		 "a buffer for read_newspace_address");
    result = ((GC_BUFFER_BOTTOM (next_scan_buffer)) [offset]);
    ENQUEUE_READY_BUFFER (next_scan_buffer, position, gc_buffer_bytes);
    next_scan_buffer = ((struct buffer_info *) NULL);
  }
  return (result);
}

static void
DEFUN (initialize_new_space_buffer, (chain, low_heap),
       SCHEME_OBJECT chain AND
       SCHEME_OBJECT * low_heap)
{
  if (read_overlap == 0)
  {
    weak_pair_break = EMPTY_WEAK_CHAIN;
    weak_pair_buffer = (INITIAL_FREE_BUFFER ());
    weak_pair_buffer_position = -1;
  }
  else
  {
    weak_pair_break = chain;
    weak_pair_buffer = ((struct buffer_info *) NULL);
    weak_pair_buffer_position = -1;
    weak_buffer_pre_read_count = 0;
    pre_read_weak_pair_buffers (low_heap);
  }
}

static void
DEFUN_VOID (flush_new_space_buffer)
{
  if (weak_pair_buffer_position == -1)
    return;
  DUMP_BUFFER (weak_pair_buffer, weak_pair_buffer_position,
	       gc_buffer_bytes, ((Boolean *) NULL),
	       "the weak pair buffer");
  weak_pair_buffer_position = -1;
  return;
}

static SCHEME_OBJECT *
DEFUN (guarantee_in_memory, (addr, low_heap),
       SCHEME_OBJECT * addr AND
       SCHEME_OBJECT * low_heap)
{
  long position, offset;

  if (addr < low_heap)
    return (addr);

  position = (addr - aligned_heap);
  offset = (position & gc_buffer_mask);
  position = (position >> gc_buffer_shift);
  position = (position << gc_buffer_byte_shift);
  position += gc_file_start_position;

  if (position != weak_pair_buffer_position)
  {
    flush_new_space_buffer ();
    LOAD_BUFFER (weak_pair_buffer, position, gc_buffer_bytes,
		 "the weak pair buffer");
    weak_pair_buffer_position = position;
    if (weak_pair_break != EMPTY_WEAK_CHAIN)
    {
      weak_buffer_pre_read_count -= 1;
      pre_read_weak_pair_buffers (low_heap);
    }
  }
  return ((GC_BUFFER_BOTTOM (weak_pair_buffer)) + offset);
}

/* For a description of the algorithm, see memmag.c and gccode.h.
   This has been modified only to account for the fact that new space
   is on disk.  Old space is in memory.
   Note: Compiled_BH requires the names Temp and Old!
*/

static SCHEME_OBJECT
DEFUN (update_weak_pointer, (Temp, low_heap),
       SCHEME_OBJECT Temp AND
       SCHEME_OBJECT * low_heap)
{
  SCHEME_OBJECT * Old;

  switch (GC_Type (Temp))
  {
    case GC_Non_Pointer:
      return (Temp);
  
    case GC_Special:
      if ((OBJECT_TYPE (Temp)) != TC_REFERENCE_TRAP)
	/* No other special type makes sense here. */
	goto fail;
      if ((OBJECT_DATUM (Temp)) <= TRAP_MAX_IMMEDIATE)
	return (Temp);
      /* Otherwise, it is a pointer.  Fall through */

    /* Normal pointer types, the broken heart is in the first word.
       Note that most special types are treated normally here.
       The BH code updates *Scan if the object has been relocated.
       Otherwise it falls through and we replace it with a full SHARP_F.
       Eliminating this assignment would keep old data (pl. of datum).
     */
    case GC_Cell:
    case GC_Pair:
    case GC_Triple:
    case GC_Quadruple:
    case GC_Vector:
      Old = (OBJECT_ADDRESS (Temp));
      if (Old < low_heap)
	return (Temp);

      if ((OBJECT_TYPE (*Old)) == TC_BROKEN_HEART)
	return (MAKE_OBJECT_FROM_OBJECTS (Temp, *Old));
      else
	return (SHARP_F);

    case GC_Compiled:
      Old = (OBJECT_ADDRESS (Temp));
      if (Old < low_heap)
	return (Temp);
      Compiled_BH (false, { return Temp; });
      return (SHARP_F);

    default:			/* Non Marked Headers and Broken Hearts */
    case GC_Undefined:
    fail:
      outf_error ("\n%s (update_weak_pointer): Clearing bad object 0x%08lx.\n",
		  scheme_program_name, Temp);
      return (SHARP_F);
  }
}

SCHEME_OBJECT
  Weak_Chain,
  * weak_pair_stack_ptr,
  * weak_pair_stack_limit;

void
DEFUN (initialize_weak_pair_transport, (limit), SCHEME_OBJECT * limit)
{
  Weak_Chain = EMPTY_WEAK_CHAIN;
  weak_pair_stack_ptr = sp_register;
  weak_pair_stack_limit = (limit + 1); /* in case it's odd */
  return;
}

void
DEFUN (fix_weak_chain_1, (low_heap), SCHEME_OBJECT * low_heap)
{
  fast SCHEME_OBJECT chain, * old_weak_cell, * scan, * ptr, * limit;

  chain = Weak_Chain;
  initialize_new_space_buffer (chain, low_heap);

  limit = sp_register;
  for (ptr = weak_pair_stack_ptr; ptr < limit ; ptr += 2)
    *ptr = (update_weak_pointer (*ptr, low_heap));

  while (chain != EMPTY_WEAK_CHAIN)
  {
    old_weak_cell = (OBJECT_ADDRESS (Weak_Chain));
    scan
      = (guarantee_in_memory ((OBJECT_ADDRESS (*old_weak_cell++)), low_heap));
    Weak_Chain = (* old_weak_cell);
    *scan
      = (update_weak_pointer
	 ((MAKE_OBJECT_FROM_OBJECTS (Weak_Chain, (* scan))), low_heap));
    Weak_Chain = (OBJECT_NEW_TYPE (TC_NULL, Weak_Chain));
  }
  flush_new_space_buffer ();
  Weak_Chain = chain;
  return;
}

void
DEFUN_VOID (fix_weak_chain_2)
{
  SCHEME_OBJECT * ptr, * limit, new_car, * addr;

  limit = sp_register;
  for (ptr = weak_pair_stack_ptr; ptr < limit ; )
  {
    new_car = *ptr++;
    addr = ((SCHEME_OBJECT *) (*ptr++));
    if (new_car != SHARP_F)
      *addr = new_car;
  }
  weak_pair_stack_ptr = limit;
  return;
}

long
DEFUN (GC_relocate_root, (free_buffer_ptr), SCHEME_OBJECT ** free_buffer_ptr)
{
  long skip;
  SCHEME_OBJECT * initial_free_buffer, * free_buffer;

  free_buffer = * free_buffer_ptr;
  initial_free_buffer = free_buffer;
  SET_MEMTOP (Heap_Top - GC_Reserve);

  /* Save the microcode registers so that they can be relocated */

  Set_Fixed_Obj_Slot (Precious_Objects, SHARP_F);
  Set_Fixed_Obj_Slot (Lost_Objects_Base, SHARP_F);

  *free_buffer++ = Fixed_Objects;
  *free_buffer++ = (MAKE_POINTER_OBJECT (UNMARKED_HISTORY_TYPE, history_register));
  *free_buffer++ = (Get_Current_Stacklet ());
  *free_buffer++ = ((Prev_Restore_History_Stacklet == NULL) ?
		    SHARP_F :
		    (MAKE_POINTER_OBJECT (TC_CONTROL_POINT,
					  Prev_Restore_History_Stacklet)));

  *free_buffer++ = Current_State_Point;
  *free_buffer++ = Fluid_Bindings;
  skip = (free_buffer - initial_free_buffer);
  if (free_buffer >= free_buffer_top)
    free_buffer = (dump_and_reset_free_buffer (free_buffer, 0));
  * free_buffer_ptr = free_buffer;
  return (skip);
}

void
DEFUN (GC_end_root_relocation, (root, root2),
       SCHEME_OBJECT * root AND SCHEME_OBJECT * root2)
{
  /* Make the microcode registers point to the copies in new-space. */

  Fixed_Objects = *root++;
  Set_Fixed_Obj_Slot (Precious_Objects, *root2);
  Set_Fixed_Obj_Slot
    (Lost_Objects_Base, (LONG_TO_UNSIGNED_FIXNUM (ADDRESS_TO_DATUM (root2))));

  history_register = (OBJECT_ADDRESS (*root++));
  Set_Current_Stacklet (* root);
  root += 1;
  if ((* root) != SHARP_F)
    Prev_Restore_History_Stacklet = (OBJECT_ADDRESS (*root++));
  else
  {
    Prev_Restore_History_Stacklet = NULL;
    root += 1;
  }
  Current_State_Point = *root++;
  Fluid_Bindings = *root++;
  Free_Stacklets = NULL;
  COMPILER_TRANSPORT_END ();
  CLEAR_INTERRUPT (INT_GC);
  return;
}

/* Here is the set up for the full garbage collection:

   - First it makes the constant space and stack into one large area
   by "hiding" the gap between them with a non-marked header.

   - Then it saves away all the relevant microcode registers into new
   space, making this the root for garbage collection.

   - Then it does the actual garbage collection in 4 steps:
     1) Trace constant space.
     2) Trace objects pointed out by the root and constant space.
     3) Trace the precious objects, remembering where consing started.
     4) Update all weak pointers.

   - Load new space to memory.

   - Finally it restores the microcode registers from the copies in
   new space.
*/

void
DEFUN (GC, (weak_pair_transport_initialized_p),
       int weak_pair_transport_initialized_p)
{
  SCHEME_OBJECT * root;
  SCHEME_OBJECT * end_of_constant_area;
  SCHEME_OBJECT the_precious_objects;
  SCHEME_OBJECT * root2;
  SCHEME_OBJECT * free_buffer;
  SCHEME_OBJECT * block_start;
  SCHEME_OBJECT * saved_ctop;
  long skip_length;

  saved_ctop = Constant_Top;
  if (((Constant_Top - Free_Constant) < CONSTANT_SPACE_FUDGE)
      && (update_allocator_parameters (Free_Constant)))
    Constant_Top = saved_ctop;

  if (!weak_pair_transport_initialized_p)
    initialize_weak_pair_transport (Stack_Bottom);

  free_buffer = (initialize_free_buffer ());
  Free = Heap_Bottom;
  ALIGN_FLOAT (Free);
  block_start = aligned_heap;
  skip_length = (Free - block_start);
  free_buffer += skip_length;

  Terminate_Old_Stacklet ();
  SEAL_CONSTANT_SPACE ();
  end_of_constant_area = (CONSTANT_AREA_END ());
  the_precious_objects = (Get_Fixed_Obj_Slot (Precious_Objects));
  root = Free;

  /* The 4 step GC */

  Free += (GC_relocate_root (&free_buffer));

  {
    SCHEME_OBJECT * new_scan
      = (gc_loop ((CONSTANT_AREA_START ()), (&free_buffer), (&Free),
		  Constant_Top, NORMAL_GC, 0));
    if (new_scan != end_of_constant_area)
      {
	gc_death (TERM_EXIT, "gc_loop ended too early", new_scan, free_buffer);
	/*NOTREACHED*/
      }
  }

  {
    SCHEME_OBJECT * scan
      = (gc_loop (((initialize_scan_buffer (block_start)) + skip_length),
		  (&free_buffer), (&Free), Constant_Top, NORMAL_GC, 1));

    root2 = Free;
    (*free_buffer++) = the_precious_objects;
    Free += 1;
    if (free_buffer >= free_buffer_top)
      free_buffer = (dump_and_reset_free_buffer (free_buffer, 0));

    gc_loop (scan, (&free_buffer), (&Free), Constant_Top, NORMAL_GC, 1);
  }

  end_transport (0);
  fix_weak_chain_1 (Constant_Top);

  /* Load new space into memory. */
  final_reload (block_start, (Free - block_start), "new space");

  fix_weak_chain_2 ();
  GC_end_root_relocation (root, root2);
  Constant_Top = saved_ctop;
  SET_CONSTANT_TOP ();
}

/* (GARBAGE-COLLECT SLACK)
   Requests a garbage collection leaving the specified amount of slack
   for the top of heap check on the next GC.  The primitive ends by
   invoking the GC daemon if there is one.
*/

DEFINE_PRIMITIVE ("GARBAGE-COLLECT", Prim_garbage_collect, 1, 1, 0)
{
  extern unsigned long gc_counter;
  SCHEME_OBJECT daemon;
  PRIMITIVE_HEADER (1);
  PRIMITIVE_CANONICALIZE_CONTEXT ();

  STACK_SANITY_CHECK ("GC");
  if (Free > Heap_Top)
    termination_gc_out_of_space ();

  GC_Reserve = (arg_nonnegative_integer (1));
  POP_PRIMITIVE_FRAME (1);

  ENTER_CRITICAL_SECTION ("garbage collector");
  run_pre_gc_hooks ();
  gc_counter += 1;
  GC (0);
  run_post_gc_hooks ();
  daemon = (Get_Fixed_Obj_Slot (GC_Daemon));

 Will_Push (CONTINUATION_SIZE);
  Store_Return (RC_NORMAL_GC_DONE);
  exp_register = (LONG_TO_UNSIGNED_FIXNUM (MemTop - Free));
  Save_Cont ();
 Pushed ();

  RENAME_CRITICAL_SECTION ("garbage collector daemon");
  if (daemon == SHARP_F)
    PRIMITIVE_ABORT (PRIM_POP_RETURN);
    /*NOTREACHED*/

 Will_Push (2);
  STACK_PUSH (daemon);
  STACK_PUSH (STACK_FRAME_HEADER);
 Pushed ();
  PRIMITIVE_ABORT (PRIM_APPLY);
  /*NOTREACHED*/
  return (0);
}

#ifdef RECORD_GC_STATISTICS

static void
DEFUN_VOID (statistics_clear)
{
  int cntr, arlen;
  struct bch_GC_statistic * ptr;

  arlen = (((sizeof (all_gc_statistics))
	    / (sizeof (struct bch_GC_statistic)))
	   - 1);
  for (cntr = 0, ptr = &all_gc_statistics[0]; cntr < arlen; cntr++, ptr++)
    (* (ptr->counter)) = 0;
  return;
}

static int statistics_print_level = 0;

static void
DEFUN (statistics_print, (level, noise), int level AND char * noise)
{
  char format[30];
  int cntr, arlen, len, name_len;
  struct bch_GC_statistic * ptr;

  if (level > statistics_print_level)
    return;
  arlen = (((sizeof (all_gc_statistics))
	    / (sizeof (struct bch_GC_statistic)))
	   - 1);
  name_len = -1;
  for (cntr = 0, ptr = &all_gc_statistics[0];
       cntr < arlen;
       cntr++, ptr++)
    if ((* (ptr->counter)) != 0L)
    {
      len = (strlen (ptr->name));
      if (len > name_len)
	name_len = len;
    }

  if (name_len >= 0)
  {
    sprintf (&format[0], "\t%%-%ds : %%ld\n", name_len);

    outf_console ("\nGC I/O statistics %s:\n", noise);
    for (cntr = 0, ptr = &all_gc_statistics[0]; cntr < arlen; cntr++, ptr++)
      if ((* (ptr->counter)) != 0L)
	outf_console (&format[0], ptr->name, (* (ptr->counter)));
    outf_flush_console ();
  }
  return;
}
#endif /* RECORD_GC_STATISTICS */

static SCHEME_OBJECT
DEFUN_VOID (statistics_names)
{
  SCHEME_OBJECT vector, * scan;
  struct bch_GC_statistic * ptr;
  int len, cntr;

  len = (((sizeof (all_gc_statistics))
	  / (sizeof (struct bch_GC_statistic)))
	 - 1);
  if (len == 0)
    return (SHARP_F);

  vector = (allocate_marked_vector (TC_VECTOR, len, true));
  for (cntr = 0, ptr = &all_gc_statistics[0], scan = (VECTOR_LOC (vector, 0));
       cntr < len;
       cntr++, ptr++)
    *scan++ = (char_pointer_to_string ((unsigned char *) ptr->name));
  return (vector);
}

static void
DEFUN_VOID (statistics_read)
{
  SCHEME_OBJECT vector, *scan;
  struct bch_GC_statistic * ptr;
  int len, cntr;

  len = (((sizeof (all_gc_statistics))
	  / (sizeof (struct bch_GC_statistic)))
	 - 1);
  if (len == 0)
    signal_error_from_primitive (ERR_UNDEFINED_PRIMITIVE);

  vector = (VECTOR_ARG (1));
  if (len != ((int) (VECTOR_LENGTH (vector))))
    error_bad_range_arg (1);
  
  for (cntr = 0, ptr = &all_gc_statistics[0], scan = (VECTOR_LOC (vector, 0));
       cntr < len;
       cntr++, ptr++)
    *scan++ = (long_to_integer (* (ptr->counter)));
  return;
}

/* Additional primitives for statistics collection and
   manipulation of parameters from Scheme
 */

DEFINE_PRIMITIVE ("BCHSCHEME-STATISTICS-NAMES", Prim_bchscheme_stat_names, 0, 0, 0)
{
  PRIMITIVE_HEADER (0);
  PRIMITIVE_RETURN (statistics_names ());
}

DEFINE_PRIMITIVE ("BCHSCHEME-STATISTICS-READ!", Prim_bchscheme_read_stats, 1, 1, 0)
{
  PRIMITIVE_HEADER (1);
  statistics_read ();
  PRIMITIVE_RETURN (UNSPECIFIC);
}

/* There are other parameters that could be set, especially the drone program
   to run, and the file to gc from, but...
 */

#ifndef GET_SLEEP_DELTA
#define GET_SLEEP_DELTA()	-1
#define SET_SLEEP_DELTA(v)	do { } while (0)
#endif

#define N_PARAMS	6

DEFINE_PRIMITIVE ("BCHSCHEME-PARAMETERS-GET", Prim_bchscheme_get_params, 0, 0, 0)
{
  SCHEME_OBJECT vector;
  PRIMITIVE_HEADER (0);

  vector = (allocate_marked_vector (TC_VECTOR, N_PARAMS, true));

  VECTOR_SET (vector, 0,
	      (long_to_integer ((long) CAN_RECONFIGURE_GC_BUFFERS)));
  VECTOR_SET (vector, 1, (long_to_integer ((long) gc_buffer_size)));
  VECTOR_SET (vector, 2, (long_to_integer ((long) read_overlap)));
  VECTOR_SET (vector, 3, (long_to_integer ((long) write_overlap)));
  VECTOR_SET (vector, 4, (long_to_integer ((long) (GET_SLEEP_DELTA ()))));
  VECTOR_SET (vector, 5, (char_pointer_to_string
			  ((unsigned char *) drone_file_name)));

  PRIMITIVE_RETURN (vector);
}

#if CAN_RECONFIGURE_GC_BUFFERS
static long
DEFUN (bchscheme_long_parameter, (vector, index),
       SCHEME_OBJECT vector AND int index)
{
  SCHEME_OBJECT temp;
  long value;

  temp = (VECTOR_REF (vector, index));
  if ((! (INTEGER_P (temp))) || (! (integer_to_long_p (temp))))
    error_bad_range_arg (1);
  value = (integer_to_long (temp));
  if (value < 0)
    error_bad_range_arg (1);
  return (value);
}
#endif /* CAN_RECONFIGURE_GC_BUFFERS */

DEFINE_PRIMITIVE ("BCHSCHEME-PARAMETERS-SET!", Prim_bchscheme_set_params, 1, 1, 0)
{
  PRIMITIVE_HEADER (1);

#if !CAN_RECONFIGURE_GC_BUFFERS
  signal_error_from_primitive (ERR_UNDEFINED_PRIMITIVE);
  /*NOTREACHED*/
  return (0);
#else

  {
    char * new_drone_ptr;
    SCHEME_OBJECT vector, new_drone;
    long
      new_buffer_size, new_read_overlap,
      new_write_overlap, new_sleep_period,
      old_buffer_size = gc_buffer_size,
      old_buffer_shift = gc_buffer_shift;

    vector = (VECTOR_ARG (1));
    if ((VECTOR_LENGTH (vector)) != N_PARAMS)
      error_bad_range_arg (1);

    /* Slot 0 ignored. */
    new_buffer_size = (bchscheme_long_parameter (vector, 1));
    new_read_overlap = (bchscheme_long_parameter (vector, 2));
    new_write_overlap = (bchscheme_long_parameter (vector, 3));
    new_sleep_period = (bchscheme_long_parameter (vector, 4));
    new_drone = (VECTOR_REF (vector, 5));
    if (! (STRING_P (new_drone)))
      error_bad_range_arg (1);
    if ((STRING_LENGTH (new_drone)) == 0)
      new_drone_ptr = ((char *) NULL);
    else
    {
      new_drone_ptr = ((char *) (malloc ((STRING_LENGTH (new_drone)) + 1)));
      if (new_drone_ptr != ((char *) NULL))
	strcpy (new_drone_ptr, ((char *) (STRING_LOC (new_drone, 0))));
    }

    if (new_buffer_size != old_buffer_size)
    {
      int power = (next_exponent_of_two (new_buffer_size));

      if (((1L << power) != new_buffer_size)
	  || ((set_gc_buffer_sizes (power)) != 0))
	error_bad_range_arg (1);
      if (! (recompute_gc_end_position ()))
      {
	set_gc_buffer_sizes (old_buffer_shift);
	error_bad_range_arg (1);
      }
    }

    BUFFER_SHUTDOWN (0);
    SET_SLEEP_DELTA (new_sleep_period);
    if ((drone_file_name != ((char *) NULL))
	&& (drone_file_name != option_gc_drone))
      free ((PTR) drone_file_name);

    if ((RE_INITIALIZE_GC_BUFFERS (0,
				   Highest_Allocated_Address,
				   ((sizeof (SCHEME_OBJECT))
				    * (CEILING ((saved_heap_size
						 + saved_constant_size),
						gc_buffer_size))),
				   new_read_overlap,
				   new_write_overlap,
				   new_drone_ptr))
	== 0)
      PRIMITIVE_RETURN (UNSPECIFIC);
    else
    {
      if (new_buffer_size != old_buffer_size)
      {
	set_gc_buffer_sizes (old_buffer_shift);
	recompute_gc_end_position ();
      }

      BUFFER_SHUTDOWN (0);
      if (new_drone_ptr != ((char *) NULL))
	free (new_drone_ptr);

      if ((RE_INITIALIZE_GC_BUFFERS (0,
				     Highest_Allocated_Address,
				     (saved_heap_size
				      * (sizeof (SCHEME_OBJECT))),
				     0, 0,
				     option_gc_drone)) != 0)
	Microcode_Termination (TERM_EXIT);
      else
	signal_error_from_primitive (ERR_EXTERNAL_RETURN);
    }
    /*NOTREACHED*/
    return (0);
  }
#endif /* (CAN_RECONFIGURE_GC_BUFFERS == 0) */
}
