home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / microcode / bchmmg.c < prev    next >
C/C++ Source or Header  |  2000-12-05  |  107KB  |  3,679 lines
  1. /* -*-C-*-
  2.  
  3. $Id: bchmmg.c,v 9.98 2000/12/05 21:34:56 cph Exp $
  4.  
  5. Copyright (c) 1987-2000 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. */
  21.  
  22. /* Memory management top level.  Garbage collection to disk. */
  23.  
  24. #include "scheme.h"
  25. #include "prims.h"
  26. #include "memmag.h"
  27. #include "option.h"
  28. #include "osenv.h"
  29. #include "osfs.h"
  30.  
  31. #ifdef __unix__
  32. #  include "ux.h"
  33. #  define SUB_DIRECTORY_DELIMITER '/'
  34. /* This makes for surprising behavior: */
  35. /* #  define UNLINK_BEFORE_CLOSE */
  36. #endif
  37.  
  38. #ifdef __WIN32__
  39. #  include "nt.h"
  40. #  define SUB_DIRECTORY_DELIMITER '\\'
  41. #endif
  42.  
  43. #ifdef __OS2__
  44. #  include "os2.h"
  45. #  define SUB_DIRECTORY_DELIMITER '\\'
  46. #  if defined(__IBMC__) || defined(__WATCOMC__) || defined(__EMX__)
  47. #    include <io.h>
  48. #    include <sys\stat.h>
  49. #  endif
  50. #  ifndef F_OK
  51. #    define F_OK 0
  52. #    define X_OK 1
  53. #    define W_OK 2
  54. #    define R_OK 4
  55. #  endif
  56. #endif
  57.  
  58. #include "bchgcc.h"
  59. #include "bchdrn.h"
  60.  
  61. #ifndef SEEK_SET
  62. #  define SEEK_SET 0
  63. #endif
  64.  
  65. #ifdef USE_SYSV_SHARED_MEMORY
  66. #  define RECORD_GC_STATISTICS
  67. #endif
  68. #define MILLISEC * 1000
  69.  
  70. #define FLOOR(value,quant)    ((quant) * ((value) / (quant)))
  71. #define CEILING(value,quant)    (FLOOR (((value) + ((quant) - 1)), (quant)))
  72.  
  73. /* Memory management top level.  Garbage collection to disk.
  74.  
  75.    The algorithm is basically the same as for the 2 space collector,
  76.    except that new space is on the disk, and there are two windows to
  77.    it (the scan and free buffers).  The two windows are physically the
  78.    same whent they correspond to the same section of the address space.
  79.    There may be additional windows used to overlap I/O.
  80.  
  81.    For information on the 2 space collector, read the comments in the
  82.    replaced files.
  83.  
  84.    The memory management code is spread over the following files:
  85.    - bchgcc.h: shared header file for bchscheme.
  86.    - bchmmg.c: top level, initialization and I/O.    Replaces memmag.c
  87.    - bchgcl.c: main garbage collector loop.        Replaces gcloop.c
  88.    - bchpur.c: constant/pure space hacking.        Replaces purify.c
  89.    - bchdmp.c: object & world image dumping.        Replaces fasdump.c
  90.    - bchdrn.h: header file for bchmmg.c and the bchdrn.c.
  91.    - bchdrn.c: stand-alone program used as an overlapped I/O drone.
  92.    - bchutl.c: utilities common to bchmmg.c and bchdrn.c.
  93.  
  94.    Problems with this implementation right now:
  95.    - It only works on Unix (or systems which support Unix I/O calls).
  96.    - Dumpworld does not work because the file is not closed at dump time or
  97.      reopened at restart time.
  98.    - Command-line specified gc files are only locked on versions of Unix
  99.      that have lockf(2).  If your system does not have lockf, two
  100.      processes can try to share the file and get very confused.
  101.  
  102. oo
  103.    ------------------------------------------
  104.    |        GC Buffer Space                 | (not always contiguous)
  105.    |                                        |
  106.    ------------------------------------------ <- fixed boundary (currently)
  107.    |          Heap Space                    |
  108.    |                                        |
  109.    ------------------------------------------ <- boundary moved by purify
  110.    |     Constant + Pure Space    /\        |
  111.    |                              ||        |
  112.    ------------------------------------------ <- fixed boundary (currently)
  113.    |         Control Stack        ||        |
  114.    |                              \/        |
  115.    ------------------------------------------ <- fixed boundary (currently)
  116. 0
  117.  
  118.    Each area has a pointer to its starting address and a pointer to
  119.    the next free cell (for the stack, it is a pointer to the last cell
  120.    in use).  The GC buffer space contains two (or more) buffers used
  121.    during the garbage collection process.  One is the scan buffer and
  122.    the other is the free buffer, and they are dumped and loaded from
  123.    disk as necessary.  At the beginning and at the end a single buffer
  124.    is used, since transporting will occur into the area being scanned.
  125. */
  126.  
  127. /* Exports */
  128.  
  129. extern void EXFUN (Clear_Memory, (int, int, int));
  130. extern void EXFUN (Setup_Memory, (int, int, int));
  131. extern void EXFUN (Reset_Memory, (void));
  132.  
  133. long
  134.   absolute_gc_file_end_position,
  135.   gc_file_end_position,
  136.   gc_file_current_position,
  137.   gc_file_start_position;
  138.  
  139. unsigned long
  140.   gc_buffer_size,
  141.   gc_buffer_bytes,
  142.   gc_buffer_shift,
  143.   gc_buffer_mask,
  144.   gc_buffer_byte_shift;
  145.  
  146. static unsigned long
  147.   gc_extra_buffer_size,
  148.   gc_buffer_overlap_bytes,
  149.   gc_buffer_remainder_bytes,
  150.   gc_total_buffer_size;
  151.  
  152. SCHEME_OBJECT
  153.   * scan_buffer_top,        * scan_buffer_bottom,
  154.   * free_buffer_top,        * free_buffer_bottom,
  155.   * virtual_scan_pointer;
  156.  
  157. static SCHEME_OBJECT
  158.   * virtual_scan_base;
  159.  
  160. static char
  161.   * gc_file_name = 0;
  162.  
  163. CONST char
  164.   * drone_file_name = 0;
  165.  
  166. static int
  167.   keep_gc_file_p = 0,
  168.   gc_file = -1,
  169.   read_overlap = 0,
  170.   write_overlap = 0;
  171.  
  172. static SCHEME_OBJECT
  173.   * aligned_heap;
  174.  
  175. static Boolean
  176.   can_dump_directly_p,
  177.   extension_overlap_p,
  178.   scan_buffer_extended_p;
  179.  
  180. static long
  181.   scan_position,
  182.   free_position,
  183.   pre_read_position,
  184.   extension_overlap_length;
  185.  
  186. static long
  187.   saved_heap_size,
  188.   saved_constant_size,
  189.   saved_stack_size;
  190.  
  191. static unsigned long
  192.   read_queue_bitmask; /* Change MAX_READ_OVERLAP if you change this. */
  193.  
  194. static struct buffer_info
  195.   * free_buffer,
  196.   * scan_buffer,
  197.   * next_scan_buffer;
  198.  
  199. int
  200. DEFUN (io_error_always_abort, (operation_name, noise),
  201.        char * operation_name AND char * noise)
  202. {
  203.   return (1);
  204. }
  205.  
  206. #ifdef __WIN32__
  207. #include <windows.h>
  208.  
  209. int 
  210. DEFUN (io_error_retry_p, (operation_name, noise),
  211.        char * operation_name AND char * noise)
  212. {
  213.   char buf[512];
  214.   extern HANDLE master_tty_window;
  215.  
  216.   sprintf (&buf[0],
  217.        "%s: GC file error (code = %d) when manipulating %s.\n"
  218.        "Choose an option (Cancel = Exit Scheme)",
  219.        operation_name, (GetLastError ()), noise);
  220.   switch (MessageBox (master_tty_window,
  221.               &buf[0],
  222.               "MIT Scheme garbage-collection problem description",
  223.               (MB_ICONSTOP | MB_ABORTRETRYIGNORE | MB_APPLMODAL)))
  224.   {
  225.     case IDABORT:
  226.       return (1);
  227.  
  228.     case IDRETRY:
  229.       return (0);
  230.  
  231.     case IDIGNORE:
  232.       Microcode_Termination (TERM_EXIT);
  233.   }
  234.   /*NOTREACHED*/
  235.   return (0);
  236. }
  237.  
  238. #else /* not __WIN32__ */
  239. #ifdef __OS2__
  240.  
  241. int
  242. io_error_retry_p (char * operation_name, char * noise)
  243. {
  244.   char buf [512];
  245.   sprintf ((&buf[0]),
  246.        "%s: GC file error (code = %d) when manipulating %s.\n"
  247.        "Choose an option (Cancel = Exit Scheme)",
  248.        operation_name, errno, noise);
  249.   switch (WinMessageBox (HWND_DESKTOP,
  250.              NULLHANDLE,
  251.              (&buf[0]),
  252.              "MIT Scheme garbage-collection problem description",
  253.              0,
  254.              (MB_ICONHAND | MB_ABORTRETRYIGNORE | MB_APPLMODAL)))
  255.     {
  256.     case MBID_ABORT: return (1);
  257.     case MBID_RETRY: return (0);
  258.     case MBID_IGNORE: Microcode_Termination (TERM_EXIT);
  259.     }
  260. }
  261.  
  262. #else /* not __OS2__ */
  263.  
  264. extern char EXFUN (userio_choose_option,
  265.            (CONST char *, CONST char *, CONST char **));
  266. extern int EXFUN (userio_confirm, (CONST char *));
  267.  
  268. int 
  269. DEFUN (io_error_retry_p, (operation_name, noise),
  270.        char * operation_name AND char * noise)
  271. {
  272.   static CONST char * retry_choices [] =
  273.     {
  274.       "A = abort the operation",
  275.       "E = exit scheme",
  276.       "K = kill scheme",
  277.       "Q = quit scheme",
  278.       "R = retry the operation",
  279.       "S = sleep for 1 minute and retry the operation",
  280.       "X = exit scheme",
  281.       0};
  282.  
  283.   outf_error ("\n%s (%s): GC file error (errno = %s) when manipulating %s.\n",
  284.           scheme_program_name, operation_name, (error_name (errno)),
  285.           noise);
  286.  
  287.   while (1)
  288.   {
  289.     switch (userio_choose_option
  290.         ("Choose one of the following actions:",
  291.          "Action -> ", retry_choices))
  292.     {
  293.       case 'A':
  294.     return (1);
  295.  
  296.       case '\0':
  297.     /* IO problems, assume everything is scrod. */
  298.     outf_fatal 
  299.       ("%s (io_error_retry_p): Problems reading the keyboard; Exitting.\n",
  300.        scheme_program_name);
  301.     termination_eof ();
  302.     /*NOTREACHED*/
  303.  
  304.       case 'E': case 'K': case 'Q': case 'X':
  305.     if (!(userio_confirm ("Kill Scheme (Y/N)? ")))
  306.       continue;
  307.     Microcode_Termination (TERM_EXIT);
  308.     /*NOTREACHED*/
  309.  
  310.       case 'S':
  311.     sleep (60);
  312.     /* fall through */
  313.  
  314.       case 'R':
  315.       default:
  316.     return (0);
  317.     }
  318.   }
  319. }
  320.  
  321. #endif /* not __OS2__ */
  322. #endif /* not __WIN32__ */
  323.  
  324. static int
  325. DEFUN (verify_write, (position, size, success),
  326.        long position AND long size AND Boolean * success)
  327. {
  328.   if ((position >= gc_file_start_position)
  329.       && ((position + size) <= gc_file_end_position))
  330.     return (0);
  331.   outf_error (
  332.        "\n%s (verify_write): attempting to write outside allowed area.\n",
  333.        scheme_program_name);
  334.   outf_error("\tlow position = 0x%lx; high position = 0x%lx.\n",
  335.          gc_file_start_position, gc_file_end_position);
  336.   outf_error("\twrite position = 0x%lx; size = 0x%lx = %d bytes.\n",
  337.          position, size, size);
  338.   outf_flush_error();
  339.   if (success == ((Boolean *) NULL))
  340.   {
  341.     Microcode_Termination (TERM_EXIT);
  342.     /*NOTREACHED*/
  343.   }
  344.   *success = ((Boolean) false);
  345.   return (-1);
  346. }
  347.  
  348. static void
  349. DEFUN (write_data, (from, position, nbytes, noise, success),
  350.        char * from AND long position AND long nbytes
  351.        AND char * noise AND Boolean * success)
  352. {
  353.   if (((verify_write (position, nbytes, success)) != -1)
  354.       && ((retrying_file_operation (((file_operation_t *) write),
  355.                     gc_file,
  356.                     from,
  357.                     position,
  358.                     nbytes,
  359.                     "write",
  360.                     noise,
  361.                     &gc_file_current_position,
  362.                     ((success == ((Boolean *) NULL))
  363.                      ? io_error_retry_p
  364.                      : io_error_always_abort)))
  365.       == -1)
  366.       && (success != ((Boolean *) NULL)))
  367.     *success = false;
  368.   return;
  369. }
  370.  
  371. static void
  372. DEFUN (load_data, (position, to, nbytes, noise, success),
  373.        long position AND char * to AND long nbytes
  374.        AND char * noise AND Boolean * success)
  375. {
  376.   (void) (retrying_file_operation (((file_operation_t *) read),
  377.                    gc_file,
  378.                    to,
  379.                    position,
  380.                    nbytes,
  381.                    "read",
  382.                    noise,
  383.                    &gc_file_current_position,
  384.                    ((success == ((Boolean *) NULL))
  385.                     ? io_error_retry_p
  386.                     : io_error_always_abort)));
  387. }
  388.  
  389. static int
  390. DEFUN (parameterization_termination, (kill_p, init_p),
  391.        int kill_p AND int init_p)
  392. {
  393.   fflush (stderr);
  394.   if (init_p)
  395.     termination_init_error ();            /*NOTREACHED*/
  396.   if (kill_p)
  397.     Microcode_Termination (TERM_EXIT);        /*NOTREACHED*/
  398.   return (-1);
  399. }
  400.  
  401. struct bch_GC_statistic
  402. {
  403.   char * name;
  404.   long * counter;
  405. };
  406.  
  407. #ifdef RECORD_GC_STATISTICS
  408.  
  409. static void EXFUN (statistics_clear, (void));
  410. static void EXFUN (statistics_print, (int, char *));
  411.  
  412. #  define STATISTICS_INCR(name)            name += 1
  413. #  define STATISTICS_CLEAR()            statistics_clear ()
  414. #  define STATISTICS_PRINT(level, noise)    statistics_print (level, noise)
  415.  
  416. #else
  417.  
  418. static struct bch_GC_statistic all_gc_statistics[] =
  419. { { "invalid last statistic",        ((long *) NULL) } };
  420.  
  421. #  define STATISTICS_INCR(name)            do { } while (0)
  422. #  define STATISTICS_CLEAR()            do { } while (0)
  423. #  define STATISTICS_PRINT(level, noise)    do { } while (0)
  424.  
  425. #endif
  426.  
  427. #ifdef USE_SYSV_SHARED_MEMORY
  428.  
  429. #ifdef RECORD_GC_STATISTICS
  430.  
  431. static long
  432.   reads_not_overlapped,
  433.   reads_overlapped,
  434.   reads_ready,
  435.   reads_queued,
  436.   reads_pending,
  437.   reads_overlapped_aborted,
  438.   reads_found_in_write_queue,
  439.   reads_found_ready,
  440.   read_wait_cycles,
  441.   writes_not_overlapped,
  442.   writes_overlapped,
  443.   writes_not_deferred,
  444.   writes_restarted,
  445.   writes_retried,
  446.   writes_pending,
  447.   write_wait_cycles,
  448.   pre_reads_aborted,
  449.   pre_reads_ignored,
  450.   pre_reads_found_in_write_queue,
  451.   pre_reads_found_ready,
  452.   pre_reads_not_started,
  453.   pre_reads_started,
  454.   pre_reads_deferred,
  455.   pre_reads_restarted,
  456.   pre_reads_retried,
  457.   pre_reads_not_retried,
  458.   pre_reads_requeued_as_writes,
  459.   ready_buffers_enqueued,
  460.   ready_buffers_not_enqueued,
  461.   drone_wait_cycles,
  462.   drone_request_failures,
  463.   drones_found_dead,
  464.   sleeps_interrupted,  
  465.   await_io_cycles,
  466.   gc_start_time,
  467.   gc_end_transport_time,
  468.   gc_end_weak_update_time,
  469.   gc_start_reload_time,
  470.   gc_end_time;
  471.  
  472. #define START_TRANSPORT_HOOK()                        \
  473.   gc_start_time = ((long) (OS_real_time_clock ()))
  474.   
  475. #define END_TRANSPORT_HOOK()                        \
  476.   gc_end_transport_time = ((long) (OS_real_time_clock ()))
  477.  
  478. #define END_WEAK_UPDATE_HOOK()                        \
  479.   gc_end_weak_update_time = ((long) (OS_real_time_clock ()))
  480.  
  481. #define START_RELOAD_HOOK()                        \
  482.   gc_start_reload_time = ((long) (OS_real_time_clock ()))
  483.  
  484. #define END_GC_HOOK()                            \
  485.   gc_end_time = ((long) (OS_real_time_clock ()))
  486.  
  487. static struct bch_GC_statistic all_gc_statistics[] =
  488. {
  489.   { "reads not overlapped",        &reads_not_overlapped },
  490.   { "reads overlapped",            &reads_overlapped },
  491.   { "reads ready",            &reads_ready },
  492.   { "reads queued",            &reads_queued },
  493.   { "reads pending",            &reads_pending },
  494.   { "reads overlapped aborted",        &reads_overlapped_aborted },
  495.   { "reads found in write queue",    &reads_found_in_write_queue },
  496.   { "reads found ready",        &reads_found_ready },
  497.   { "read wait cycles",            &read_wait_cycles },
  498.   { "writes not overlapped",        &writes_not_overlapped },
  499.   { "writes overlapped",        &writes_overlapped },
  500.   { "writes retried",            &writes_retried },
  501.   { "writes not deferred",        &writes_not_deferred },
  502.   { "writes restarted",            &writes_restarted },
  503.   { "writes retried",            &writes_retried },
  504.   { "writes pending",            &writes_pending },
  505.   { "write wait cycles",        &write_wait_cycles },
  506.   { "pre-reads aborted",        &pre_reads_aborted },
  507.   { "pre-reads ignored",        &pre_reads_ignored },
  508.   { "pre-reads found in write queue",    &pre_reads_found_in_write_queue },
  509.   { "pre-reads found ready",        &pre_reads_found_ready },
  510.   { "pre-reads not started",        &pre_reads_not_started },
  511.   { "pre-reads started",        &pre_reads_started },
  512.   { "pre-reads deferred",        &pre_reads_deferred },
  513.   { "pre-reads restarted",        &pre_reads_restarted },
  514.   { "pre-reads retried",        &pre_reads_retried },
  515.   { "pre-reads not retried",        &pre_reads_not_retried },
  516.   { "pre-reads requeued as writes",    &pre_reads_requeued_as_writes },
  517.   { "ready buffers enqueued",        &ready_buffers_enqueued },
  518.   { "ready buffers not enqueued",    &ready_buffers_not_enqueued },
  519.   { "drone wait cycles",        &drone_wait_cycles },
  520.   { "drone request failures",        &drone_request_failures },
  521.   { "drones found dead",        &drones_found_dead },
  522.   { "sleeps interrupted",        &sleeps_interrupted },
  523.   { "cycles awaiting I/O completion",    &await_io_cycles },
  524.   { "time at gc start",            &gc_start_time },
  525.   { "time at end of transport",        &gc_end_transport_time },
  526.   { "time at end of weak update",    &gc_end_weak_update_time },
  527.   { "time at start of reload",        &gc_start_reload_time },
  528.   { "time at gc end",            &gc_end_time },
  529.   { "invalid last statistic",        ((long *) NULL) }
  530. };
  531.  
  532. #endif /* RECORD_GC_STATISTICS */
  533.  
  534. /* The limit on MAX_READ_OVERLAP is the number of bits in read_queue_bitmask.
  535.    The limit on MAX_GC_DRONES is the number of bits in (* wait_mask).
  536.    There is no direct limit on MAX_WRITE_OVERLAP.
  537.    On the other hand, the explicit searches through the queues
  538.    will become slower as the numbers are increased.
  539.  */
  540.  
  541. #define MAX_READ_OVERLAP    ((sizeof (long)) * CHAR_BIT)
  542. #define MAX_WRITE_OVERLAP    MAX_READ_OVERLAP
  543. #define MAX_GC_DRONES        ((sizeof (long)) * CHAR_BIT)
  544. #define MAX_OVERLAPPED_RETRIES    2
  545.  
  546. static char * shared_memory = ((char *) -1);
  547. static char * malloc_memory = ((char *) NULL);
  548. static int drones_initialized_p = 0;
  549. static int shmid = -1;
  550. static int n_gc_buffers, n_gc_drones, gc_next_buffer, gc_next_drone;
  551. static struct gc_queue_entry * gc_read_queue, * gc_write_queue;
  552. static struct drone_info * gc_drones;
  553. static struct buffer_info * gc_buffers;
  554. static unsigned long * wait_mask, * drone_version;
  555.  
  556. static long default_sleep_period = 20 MILLISEC;
  557.  
  558. #define GET_SLEEP_DELTA()    default_sleep_period
  559. #define SET_SLEEP_DELTA(value)    default_sleep_period = (value)
  560.  
  561. static void
  562. DEFUN (sleep_awaiting_drones, (microsec, mask),
  563.        unsigned int microsec AND unsigned long mask)
  564. {
  565.   int saved_errno;
  566.   int retval;
  567.  
  568.   *wait_mask = mask;
  569. #ifdef HAVE_POLL
  570.   retval = (poll (0, 0, (microsec / 1000)));
  571. #else
  572.   {
  573.     int dummy = 0;
  574.     struct timeval timeout;
  575.     timeout.tv_sec = 0;
  576.     timeout.tv_usec = microsec;
  577.     retval
  578.       = (select (0,
  579.          ((SELECT_TYPE *) &dummy),
  580.          ((SELECT_TYPE *) &dummy),
  581.          ((SELECT_TYPE *) &dummy),
  582.          &timeout));
  583.   }
  584. #endif
  585.   *wait_mask = ((unsigned long) 0);
  586.   saved_errno = errno;
  587.  
  588.   if ((retval == -1) && (saved_errno == EINTR))
  589.     STATISTICS_INCR (sleeps_interrupted);
  590. }
  591.  
  592. #ifndef _SUNOS4
  593. #  define SYSV_SPRINTF sprintf
  594. #else
  595. /* Losing SunOS sprintf */
  596.  
  597. #  define SYSV_SPRINTF sysV_sprintf
  598.  
  599. static int
  600. DEFUN (sysV_sprintf, (string, format, value),
  601.        char * string AND char * format AND long value)
  602. {
  603.   sprintf (string, format, value);
  604.   return (strlen (string));
  605. }
  606.  
  607. #endif /* _SUNOS4 */
  608.  
  609. #ifdef SIGCONT
  610. static void
  611. DEFUN (continue_running, (sig), int sig)
  612. {
  613.   RE_INSTALL_HANDLER (SIGCONT, continue_running);
  614. }
  615. #endif
  616.  
  617. static void
  618. DEFUN (start_gc_drones, (first_drone, how_many, restarting),
  619.        int first_drone AND int how_many AND int restarting)
  620. {
  621.   pid_t pid;
  622.   char arguments[512];
  623.   struct drone_info *drone;
  624.   char
  625.     * shmid_string,        /* shared memory handle */
  626.     * tdron_string,        /* total number of drones */
  627.     * nbuf_string,        /* total number of buffers */
  628.     * bufsiz_string,        /* size of each buffer in bytes */
  629.     * sdron_string,        /* index of first drone to start */
  630.     * ndron_string;        /* number of drones to start */
  631.  
  632.   shmid_string = &arguments[0];
  633.   tdron_string =
  634.     (shmid_string + (1 + (SYSV_SPRINTF (shmid_string, "%d", shmid))));
  635.   nbuf_string =
  636.     (tdron_string + (1 + (SYSV_SPRINTF (tdron_string, "%d", n_gc_drones))));
  637.   bufsiz_string =
  638.     (nbuf_string + (1 + (SYSV_SPRINTF (nbuf_string, "%d", n_gc_buffers))));
  639.   sdron_string =
  640.     (bufsiz_string
  641.      + (1 + (SYSV_SPRINTF (bufsiz_string, "%ld",
  642.                (gc_total_buffer_size
  643.                 * (sizeof (SCHEME_OBJECT)))))));
  644.   ndron_string =
  645.     (sdron_string + (1 + (SYSV_SPRINTF (sdron_string, "%d", first_drone))));
  646.   (void) (SYSV_SPRINTF (ndron_string, "%d", how_many));
  647.  
  648.   drone = (gc_drones + first_drone);
  649.   if (restarting && (drone->state != drone_dead))
  650.     (void) (kill (drone->DRONE_PID, SIGTERM));
  651.   drone->state = drone_not_ready;
  652.   (* drone_version) = ((unsigned long) DRONE_VERSION_NUMBER);
  653.  
  654.   if ((pid = (vfork ())) == 0)
  655.   {
  656.     execlp (drone_file_name, drone_file_name, gc_file_name, shmid_string,
  657.         tdron_string, nbuf_string, bufsiz_string,
  658.         sdron_string, ndron_string, (keep_gc_file_p ? "1" : "0"),
  659.         ((char *) 0));
  660.     outf_error ("\n%s (start_gc_drones): execlp (%s) failed (errno = %s).\n",
  661.         scheme_program_name, drone_file_name, (error_name (errno)));
  662.     drone->state = drone_dead;
  663.     (void) (kill ((getppid ()), SIGCONT));
  664.     _exit (1);
  665.   }
  666.   else if (pid == -1)
  667.   {
  668.     outf_error ("\n%s (start_gc_drones): vfork failed (errno = %s).\n",
  669.         scheme_program_name, (error_name (errno)));
  670.     drone->state = drone_dead;
  671.   }
  672.   else
  673.   {
  674.     sigset_t old_mask, new_mask;
  675.  
  676.     UX_sigemptyset (&new_mask);
  677.     UX_sigaddset ((&new_mask), SIGCONT);
  678.     UX_sigprocmask (SIG_BLOCK, (&new_mask), (&old_mask));
  679.     if (drone->state == drone_not_ready)
  680.       UX_sigsuspend (&old_mask);
  681.     UX_sigprocmask (SIG_SETMASK, (&old_mask), 0);
  682.  
  683.     if ((drone->state != drone_idle) && !restarting)
  684.     {
  685.       /* Do the wait only at startup since Scheme handles SIGCHLD
  686.      for all children. */
  687.       ((void) (waitpid (pid, ((int *) 0), WNOHANG)));
  688.       drone->state = drone_dead;
  689.     }
  690.   }
  691.   return;
  692. }
  693.  
  694. static int
  695. DEFUN (invoke_gc_drone,
  696.        (entry, operation, buffer, position, size),
  697.        struct gc_queue_entry * entry
  698.        AND enum drone_state operation
  699.        AND struct buffer_info * buffer
  700.        AND long position
  701.        AND long size)
  702. {
  703.   int result, drone_index;
  704.   struct drone_info * drone;
  705.   enum buffer_state old_state;
  706.  
  707.   drone_index = (entry->drone_index);
  708.   drone = (gc_drones + drone_index);
  709.   drone->buffer_index = buffer->index;
  710.   drone->entry_offset = (((char *) entry) - ((char *) drone));
  711.   
  712.   old_state = buffer->state;
  713.   buffer->state = ((operation == drone_reading)
  714.            ? buffer_being_read
  715.            : buffer_being_written);
  716.   buffer->position = position;
  717.   buffer->size = size;
  718.   entry->buffer = buffer;
  719.   entry->state = entry_busy;
  720.  
  721.   drone->state = operation;    /* Previously drone_idle */
  722.   if ((result = (kill (drone->DRONE_PID, SIGCONT))) == -1)
  723.   {
  724.     entry->state = entry_idle;
  725.     buffer->state = old_state;
  726.     drone->state = drone_dead;
  727.     if (errno != ESRCH)
  728.       outf_error
  729.     ("\n%s (invoke_gc_drone): kill (%d, SIGCONT) failed; errno = %s.\n",
  730.      scheme_program_name, drone->DRONE_PID, (error_name (errno)));
  731.     start_gc_drones (drone_index, 1, 1);
  732.   }
  733.   return (result != -1);
  734. }
  735.  
  736. /* The following don't do a wait/waitpid because Scheme handles SIGCHLD. */
  737.  
  738. static void
  739. DEFUN_VOID (kill_all_gc_drones)
  740. {
  741.   int count;
  742.   struct drone_info * drone;
  743.  
  744.   for (count = 0, drone = gc_drones; count < n_gc_drones; count++, drone++)
  745.     (void) (kill (drone->DRONE_PID, SIGTERM));
  746.   return;
  747. }
  748.  
  749. static int
  750. DEFUN (probe_gc_drone, (drone), struct drone_info * drone)
  751. {
  752.   int result;
  753.  
  754.   if ((result = (kill ((drone->DRONE_PID), 0))) == -1)
  755.   {
  756.     if (errno != ESRCH)
  757.       (void) (kill ((drone->DRONE_PID), SIGTERM));
  758.     drone->state = drone_dead;
  759.   }
  760.   return (result == 0);
  761. }
  762.  
  763. static void EXFUN (handle_drone_death, (struct drone_info *));
  764.  
  765. static void
  766. DEFUN (probe_all_gc_drones, (wait_p), int wait_p)
  767. {
  768.   int count;
  769.   unsigned long running;
  770.   struct drone_info * drone;
  771.  
  772.   do {
  773.     for (count = 0, drone = gc_drones, running = ((unsigned long) 0);
  774.      count < n_gc_drones;
  775.      count++, drone++)
  776.     {
  777.       if (drone->state != drone_idle)
  778.       {
  779.     running |= (((unsigned long) 1) << drone->index);
  780.     if ((kill (drone->DRONE_PID, 0)) == -1)
  781.     {
  782.       if (errno != ESRCH)
  783.         (void) (kill (drone->DRONE_PID, SIGTERM));
  784.       drone->state = drone_dead;
  785.       start_gc_drones (drone->index, 1, 1);
  786.       handle_drone_death (drone);
  787.     }
  788.       }
  789.     }
  790.     if (wait_p && (running != ((unsigned long) 0)))
  791.     {
  792.       sleep_awaiting_drones (default_sleep_period, running);
  793.       STATISTICS_INCR (await_io_cycles);
  794.     }
  795.   } while (wait_p && (running != ((unsigned long) 0)));
  796.   return;
  797. }
  798.  
  799. static void EXFUN (open_gc_file, (long, int));
  800.  
  801. static int
  802. DEFUN (sysV_initialize, (first_time_p, size, r_overlap, w_overlap, drfnam),
  803.        int first_time_p
  804.        AND long size AND int r_overlap AND int w_overlap
  805.        AND CONST char * drfnam)
  806. {
  807.   SCHEME_OBJECT * bufptr;
  808.   int cntr;
  809.   long buffer_space, shared_size, malloc_size;
  810.   struct buffer_info * buffer;
  811.  
  812.   if (r_overlap < 0)
  813.     r_overlap = 0;
  814.   else if (r_overlap > MAX_READ_OVERLAP)
  815.     r_overlap = MAX_READ_OVERLAP;
  816.   read_overlap = r_overlap;
  817.  
  818.   if (w_overlap < 0)
  819.     w_overlap = 0;
  820.   else if (w_overlap > MAX_WRITE_OVERLAP)
  821.     w_overlap = MAX_WRITE_OVERLAP;
  822.   write_overlap = w_overlap;
  823.  
  824.   if ((n_gc_drones = (read_overlap + write_overlap)) > MAX_GC_DRONES)
  825.   {
  826.     read_overlap = ((read_overlap * MAX_GC_DRONES) / n_gc_drones);
  827.     write_overlap = ((write_overlap * MAX_GC_DRONES) / n_gc_drones);
  828.     n_gc_drones = (read_overlap + write_overlap);
  829.   }
  830.   n_gc_buffers = (2 + n_gc_drones);
  831.  
  832.   /* The second argument to open_gc_file should be (n_gc_drones == 0),
  833.      but we can't do this since we can change the number of drones.
  834.    */
  835.  
  836.   if (first_time_p)
  837.   {
  838.     open_gc_file (size, 0);
  839. #ifdef F_SETFD
  840.     /* Set the close on exec flag, the drones re-open it to get a
  841.        different file pointer so that all the processes can independently
  842.        lseek without clobbering each other.
  843.      */
  844.     (void) (fcntl (gc_file, F_SETFD, 1));
  845. #endif
  846.   }
  847.  
  848.   buffer_space = (n_gc_buffers
  849.           * (gc_total_buffer_size * (sizeof (SCHEME_OBJECT))));
  850.   shared_size =
  851.     (ALIGN_UP_TO_IO_PAGE (buffer_space
  852.               + (n_gc_buffers * (sizeof (struct buffer_info)))
  853.               + (n_gc_drones * (sizeof (struct drone_info)))
  854.               + (sizeof (long))
  855.               + (sizeof (long))
  856.               + (r_overlap * (sizeof (struct gc_queue_entry)))
  857.               + (w_overlap * (sizeof (struct gc_queue_entry)))
  858.               + IO_PAGE_SIZE));
  859.  
  860.   malloc_size = ((n_gc_drones == 0)
  861.          ? shared_size
  862.          : (first_time_p ? MALLOC_SPACE : 0));
  863.  
  864.   if (malloc_size > 0)
  865.   {
  866.     malloc_memory = ((char *) (malloc (malloc_size)));
  867.     if (malloc_memory == ((char *) NULL))
  868.     {
  869.       outf_error
  870.     ("%s (sysV_initialize): Unable to allocate %d bytes (errno = %s).\n",
  871.      scheme_program_name, malloc_size, (error_name (errno)));
  872.       return (parameterization_termination (1, first_time_p));
  873.     }
  874.   }
  875.  
  876.   if (n_gc_drones == 0)
  877.     shared_memory = ((char *) (ALIGN_UP_TO_IO_PAGE (malloc_memory)));
  878.   else
  879.   {
  880.     if ((shmid = (shmget (IPC_PRIVATE, shared_size, 0600))) == -1)
  881.     {
  882.       outf_error
  883.     ("%s (sysV_initialize): shmget (-, %d, -) failed (errno = %s).\n\
  884.           \tUnable to allocate shared memory for drone processes.\n",
  885.      scheme_program_name, shared_size, (error_name (errno)));
  886.       return (parameterization_termination (0, first_time_p));
  887.     }
  888.     shared_memory = (shmat (shmid, ATTACH_POINT, 0));
  889.     if (shared_memory == ((char *) -1))
  890.     {
  891.       int saved_errno = errno;
  892.  
  893.       (void) (shmctl (shmid, IPC_RMID, 0));
  894.       shmid = -1;
  895.       outf_error
  896.     ("%s (sysV_initialize): shmat (%d, 0x%lx, 0) failed. (errno = %s).\n\
  897.       \tUnable to attach shared memory for drone processes.\n",
  898.      scheme_program_name, shmid, shared_size, (error_name (saved_errno)));
  899.       return (parameterization_termination (0, first_time_p));
  900.     }
  901.     signal (SIGCONT, continue_running);
  902.   }
  903.  
  904.   if (!(ALIGNED_TO_IO_PAGE_P (shared_memory)))
  905.   {
  906.     outf_error
  907.       ("%s (sysV_initialize): buffer space is not aligned properly.\n\
  908.         \taddress = 0x%lx; IO_PAGE_SIZE = 0x%lx.\n",
  909.        ((long) shared_memory), ((long) IO_PAGE_SIZE));
  910.     return (parameterization_termination (0, first_time_p));
  911.   }
  912.  
  913.   if ((n_gc_drones != 0) && (malloc_size > 0)
  914.       && (malloc_memory != ((char *) NULL)))
  915.   {
  916.     free (malloc_memory);
  917.     malloc_memory = ((char *) NULL);
  918.   }
  919.  
  920.   gc_buffers = ((struct buffer_info *) (shared_memory + buffer_space));
  921.   gc_drones = ((struct drone_info *) (gc_buffers + n_gc_buffers));
  922.   drone_version = ((unsigned long *) (gc_drones + n_gc_drones));
  923.   wait_mask = (drone_version + 1);
  924.   gc_read_queue = ((struct gc_queue_entry *) (drone_version + 2));
  925.   gc_write_queue = (gc_read_queue + r_overlap);
  926.  
  927.   /* Initialize structures. */
  928.  
  929.   *wait_mask = ((unsigned long) 0);
  930.   gc_next_drone = 0;
  931.   gc_next_buffer = 0;
  932.  
  933.   drone_file_name = ((char *) drfnam);
  934.   if ((drfnam != ((char *) NULL)) && (drfnam[0] != SUB_DIRECTORY_DELIMITER))
  935.   {
  936.     CONST char * temp = (search_for_library_file (drfnam));
  937.  
  938.     if (temp != ((char *) NULL))
  939.     {
  940.       drone_file_name = temp;
  941.       if (drfnam != option_gc_drone)
  942.     free ((PTR) drfnam);
  943.     }
  944.   }
  945.  
  946.   for (bufptr = ((SCHEME_OBJECT *) shared_memory), cntr = 0,
  947.        buffer = gc_buffers;
  948.        (cntr < n_gc_buffers);
  949.        bufptr = buffer->end, cntr++, buffer++)
  950.   {
  951.     buffer->index = cntr;
  952.     buffer->state = buffer_idle;
  953.     buffer->position = -1;
  954.     buffer->bottom = ((PTR) bufptr);
  955.     buffer->top = ((PTR) (bufptr + gc_buffer_size));
  956.     buffer->end = ((PTR) (bufptr + gc_total_buffer_size));
  957.   }
  958.  
  959.   if (n_gc_drones == 0)
  960.     shared_memory = ((char *) -1);
  961.   else
  962.   {
  963.     struct gc_queue_entry * entry;
  964.     struct drone_info * drone;
  965.  
  966.     /* Make sure that SIGCONT is enabled. */
  967.     {
  968.       sigset_t mask;
  969.  
  970.       UX_sigemptyset (&mask);
  971.       UX_sigaddset ((&mask), SIGCONT);
  972.       UX_sigprocmask (SIG_UNBLOCK, (&mask), 0);
  973.     }
  974.  
  975.     for (cntr = 0, entry = gc_read_queue;
  976.      cntr < read_overlap;
  977.      cntr++, entry++)
  978.     {
  979.       entry->index = cntr;
  980.       entry->state = entry_idle;
  981.       entry->retry_count = 0;
  982.     }
  983.  
  984.     for (cntr = 0, entry = gc_write_queue;
  985.      cntr < write_overlap;
  986.      cntr++, entry++)
  987.     {
  988.       entry->index = cntr;
  989.       entry->state = entry_idle;
  990.       entry->retry_count = 0;
  991.     }
  992.  
  993.     for (cntr = 0, drone = gc_drones;
  994.      cntr < n_gc_drones;
  995.      cntr++, drone++)
  996.     {
  997.       drone->index = cntr;
  998.       drone->state = drone_not_ready;
  999.     }
  1000.  
  1001.     start_gc_drones (0, n_gc_drones, 0);
  1002.     if (gc_drones->state != drone_idle)
  1003.     {
  1004.       outf_error
  1005.     ("%s (sysV_initialize): Problems starting up the GC drones%s.\n",
  1006.      scheme_program_name,
  1007.      (((* drone_version) != ((unsigned long) DRONE_VERSION_NUMBER))
  1008.       ? " (wrong drone version)"
  1009.       : ""));
  1010.       return (parameterization_termination (0, first_time_p));
  1011.     }
  1012.     drones_initialized_p = 1;
  1013.   }
  1014.   return (0);
  1015. }
  1016.  
  1017. static void EXFUN (close_gc_file, (int));
  1018.  
  1019. static void
  1020. DEFUN (sysV_shutdown, (final_time_p), int final_time_p)
  1021. {
  1022.   /* arg should be (n_gc_drones > 0), see sysV_initialize */
  1023.   if (final_time_p)
  1024.     close_gc_file (1);
  1025.  
  1026.   if (malloc_memory != ((char *) NULL))
  1027.   {
  1028.     free (malloc_memory);
  1029.     malloc_memory = ((char *) NULL);    
  1030.   }
  1031.  
  1032.   if ((n_gc_drones != 0) && (drones_initialized_p))
  1033.   {
  1034.     kill_all_gc_drones ();
  1035.     drones_initialized_p = 0;
  1036.   }
  1037.  
  1038.   if ((shared_memory != ((char *) -1)) && ((shmdt (shared_memory)) == -1))
  1039.     outf_error ("\n%s (sysV_shutdown): shmdt failed.  errno = %s.\n",
  1040.         scheme_program_name, (error_name (errno)));
  1041.   shared_memory = ((char *) -1);
  1042.  
  1043.   if ((shmid != -1)
  1044.       && (shmctl (shmid, IPC_RMID, ((struct shmid_ds *) 0))) == -1)
  1045.     outf_error ("\n%s (sysV_shutdown): shmctl failed.  errno = %s.\n",
  1046.         scheme_program_name, (error_name (errno)));
  1047.   shmid = -1;
  1048.  
  1049.   return;
  1050. }
  1051.  
  1052. static int
  1053. DEFUN (find_idle_drone, (wait_p), int wait_p)
  1054. {
  1055.   int drone_index, next_drone_index, count = 0;
  1056.   struct drone_info * drone;
  1057.  
  1058.   drone_index = gc_next_drone;
  1059.   while (1)
  1060.   {
  1061.     count += 1;
  1062.     do
  1063.     {
  1064.       next_drone_index = (drone_index + 1);
  1065.       if (next_drone_index >= n_gc_drones)
  1066.     next_drone_index = 0;
  1067.  
  1068.       drone = (gc_drones + drone_index);
  1069.       switch (drone->state)
  1070.       {
  1071.       case drone_idle:
  1072.     gc_next_drone = next_drone_index;
  1073.     return (drone_index);
  1074.  
  1075.       case drone_dead:
  1076.     start_gc_drones (drone_index, 1, 1);
  1077.     /* fall through, look at it on next pass. */
  1078.  
  1079.       default:
  1080.     break;        
  1081.       }
  1082.       drone_index = next_drone_index;
  1083.     } while (drone_index != gc_next_drone);
  1084.  
  1085.     /* All the drones are busy... */
  1086.  
  1087.     if (!wait_p)
  1088.     {
  1089.       STATISTICS_INCR (drone_request_failures);
  1090.       return (-1);
  1091.     }
  1092.  
  1093.     if (count == 10)
  1094.     {
  1095.       probe_all_gc_drones (0);
  1096.       count = 0;
  1097.     }
  1098.     else
  1099.     {
  1100.       /* Use -1 as the mask to awaken when any drone becomes idle. */
  1101.  
  1102.       sleep_awaiting_drones (default_sleep_period, ((unsigned long) -1));
  1103.       STATISTICS_INCR (drone_wait_cycles);
  1104.     }
  1105.   }
  1106. }
  1107.  
  1108. static void
  1109. DEFUN (abort_gc_drone, (drone), struct drone_info * drone)
  1110. {
  1111.   int restart_p = 0;
  1112.   sigset_t block_mask, signal_mask;
  1113.   
  1114.   UX_sigemptyset (&block_mask);
  1115.   UX_sigaddset ((&block_mask), SIGCONT);
  1116.   UX_sigprocmask (SIG_BLOCK, (&block_mask), (&signal_mask));
  1117.  
  1118.   *wait_mask = (((unsigned long) 1) << drone->index);
  1119.   if (drone->state != drone_idle)
  1120.   {
  1121.     if ((kill (drone->DRONE_PID, SIGQUIT)) == -1)
  1122.       restart_p = 1;
  1123.     else if (drone->state != drone_idle)
  1124.       UX_sigsuspend (&signal_mask);
  1125.   }
  1126.   *wait_mask = ((unsigned long) 0);
  1127.   UX_sigprocmask (SIG_SETMASK, (&signal_mask), 0);
  1128.   if (restart_p)
  1129.     start_gc_drones (drone->index, 1, 1);
  1130.   return;
  1131. }
  1132.  
  1133. static struct gc_queue_entry *
  1134. DEFUN (find_queue_entry, (queue, queue_size, position, drone_index),
  1135.        struct gc_queue_entry * queue AND int queue_size
  1136.        AND long position AND int drone_index)
  1137. {
  1138.   struct gc_queue_entry * entry; 
  1139.   int cntr;
  1140.  
  1141.   for (cntr = 0, entry = queue; cntr < queue_size; cntr++, entry++)
  1142.   {
  1143.     if ((entry->state != entry_idle)
  1144.     && (((entry->buffer)->position == position)
  1145.         || (entry->drone_index == drone_index)))
  1146.       return (entry);
  1147.   }
  1148.   return ((struct gc_queue_entry *) NULL);
  1149. }
  1150.  
  1151. enum allocate_request
  1152. {
  1153.   request_read,
  1154.   request_write,
  1155.   request_ready
  1156. };
  1157.  
  1158. static struct gc_queue_entry *
  1159. DEFUN (allocate_queue_entry, (queue, queue_size, position, request, mask),
  1160.        struct gc_queue_entry * queue AND int queue_size AND long position
  1161.        AND enum allocate_request request AND unsigned long * mask)
  1162. {
  1163.   struct gc_queue_entry * entry; 
  1164.   int cntr, queue_index, drone_index;
  1165.   unsigned long drone_mask;
  1166.  
  1167.   /* Examine all entries for duplicates, ergo no `break' */
  1168.  
  1169.   queue_index = -1;
  1170.   drone_mask = ((unsigned long) 0);
  1171.   for (cntr = 0, entry = queue; cntr < queue_size; cntr++, entry++)
  1172.   {
  1173.     if (entry->state == entry_idle)
  1174.       queue_index = cntr;
  1175.     else if ((entry->buffer)->position == position)
  1176.       return (entry);
  1177.     else if (entry->state == entry_error)
  1178.     {
  1179.       struct buffer_info * buffer = entry->buffer;
  1180.  
  1181.       entry->retry_count += 1;
  1182.       if (entry->retry_count <= MAX_OVERLAPPED_RETRIES)
  1183.       {
  1184.     if (request == request_write)
  1185.     {
  1186.       /* This was done when originally queued, but we are paranoid. */
  1187.       (void) (verify_write (buffer->position, buffer->size,
  1188.                 ((Boolean *) NULL)));
  1189.       do
  1190.         entry->drone_index = (find_idle_drone (1));
  1191.       while (!(invoke_gc_drone (entry, drone_writing, entry->buffer,
  1192.                     buffer->position, buffer->size)));
  1193.       STATISTICS_INCR (writes_retried);
  1194.     }
  1195.     else
  1196.     {
  1197.       entry->drone_index = (find_idle_drone (0));
  1198.       if ((entry->drone_index != -1)
  1199.           && (invoke_gc_drone (entry, drone_reading, entry->buffer,
  1200.                    buffer->position, buffer->size)))
  1201.         STATISTICS_INCR (pre_reads_retried);
  1202.       else
  1203.         STATISTICS_INCR (pre_reads_not_retried);
  1204.     }
  1205.       }
  1206.       else if (request == request_write)
  1207.       {
  1208.     STATISTICS_INCR (writes_not_deferred);
  1209.     write_data (((char *) (buffer->bottom)),
  1210.             buffer->position, buffer->size,
  1211.             "a queued buffer", ((Boolean *) NULL));
  1212.     buffer->state = buffer_idle;
  1213.     entry->state = entry_idle;
  1214.     entry->retry_count = 0;
  1215.     queue_index = cntr;
  1216.       }
  1217.       else
  1218.     /* If pre-reading, it will be taken care of later. */
  1219.     STATISTICS_INCR (pre_reads_deferred);
  1220.     }
  1221.     else if ((drone_index = (entry->drone_index)) != -1)
  1222.       drone_mask |= (((unsigned long) 1) << drone_index);
  1223.   }
  1224.  
  1225.   if (queue_index == -1)
  1226.   {
  1227.     probe_all_gc_drones (0);
  1228.     if (mask != ((unsigned long *) NULL))
  1229.       (* mask) = drone_mask;
  1230.     return ((struct gc_queue_entry *) NULL);
  1231.   }
  1232.  
  1233.   entry = (queue + queue_index);
  1234.   entry->buffer = ((struct buffer_info *) NULL);
  1235.   return (entry);
  1236. }
  1237.  
  1238. static struct buffer_info *
  1239. DEFUN_VOID (find_idle_buffer)
  1240. {
  1241.   int next_buffer, new_next_buffer;
  1242.   struct buffer_info *buffer;
  1243.  
  1244.   next_buffer = gc_next_buffer;
  1245.   do
  1246.   {
  1247.     new_next_buffer = (next_buffer + 1);
  1248.     if (new_next_buffer >= n_gc_buffers)
  1249.       new_next_buffer = 0;
  1250.     buffer = (gc_buffers + next_buffer);
  1251.     if (buffer->state == buffer_idle)
  1252.     {
  1253.       gc_next_buffer = new_next_buffer;
  1254.       return (buffer);
  1255.     }
  1256.     next_buffer = new_next_buffer;
  1257.   } while (next_buffer != gc_next_buffer);
  1258.  
  1259.   outf_fatal ("\n%s (find_idle_buffer): All buffers are in use!\n",
  1260.           scheme_program_name);
  1261.   Microcode_Termination (TERM_GC_OUT_OF_SPACE);
  1262.   /*NOTREACHED*/
  1263.   return (0);
  1264. }
  1265.  
  1266. static struct buffer_info * 
  1267. DEFUN (find_ready_buffer, (position, size), long position AND long size)
  1268. {
  1269.   int next_buffer, new_next_buffer;
  1270.   struct buffer_info *buffer;
  1271.  
  1272.   next_buffer = gc_next_buffer;
  1273.   do
  1274.   {
  1275.     new_next_buffer = (next_buffer + 1);
  1276.     if (new_next_buffer >= n_gc_buffers)
  1277.       new_next_buffer = 0;
  1278.     buffer = (gc_buffers + next_buffer);
  1279.     if ((buffer->state == buffer_idle) /* && (buffer->size == size) */
  1280.     && (buffer->position == position))
  1281.     {
  1282.       gc_next_buffer = new_next_buffer;
  1283.       return (buffer);
  1284.     }
  1285.     next_buffer = new_next_buffer;
  1286.   } while (next_buffer != gc_next_buffer);
  1287.   return ((struct buffer_info *) NULL);
  1288. }
  1289.  
  1290. static struct buffer_info *
  1291. DEFUN_VOID (get_gc_buffer)
  1292. {
  1293.   struct buffer_info * buffer;
  1294.  
  1295.   buffer = (find_idle_buffer ());
  1296.   buffer->state = buffer_busy;
  1297.   return (buffer);
  1298. }
  1299.  
  1300. static struct buffer_info *
  1301. DEFUN (read_buffer, (posn, size, noise),
  1302.        long posn AND long size AND char * noise)
  1303. {
  1304.   struct gc_queue_entry * entry;
  1305.   struct buffer_info * buffer;
  1306.  
  1307.   if ((read_overlap > 0)
  1308.       && ((entry = (find_queue_entry (gc_read_queue, read_overlap, posn, -2)))
  1309.       != ((struct gc_queue_entry *) NULL))
  1310.       && ((buffer = entry->buffer) != ((struct buffer_info *) NULL)))
  1311.   {
  1312.     switch (buffer->state)
  1313.     {
  1314.       default:
  1315.         outf_error
  1316.       ("\n%s (read_buffer %s): invalid state.\n\
  1317.         \tindex = %d; state = %d; position = 0x%lx.\n",
  1318.        scheme_program_name, noise, buffer->index, buffer->state, posn);
  1319.     /* fall through */
  1320.  
  1321.       case buffer_read_error:
  1322.     /* Try synchronously, and complain then if the condition persists. */
  1323.     break;
  1324.  
  1325.       case buffer_being_read:
  1326.       {
  1327.     int count;
  1328.     struct drone_info * drone = (gc_drones + entry->drone_index);
  1329.  
  1330.     for (count = 1; (buffer->state == buffer_being_read) ; count++)
  1331.     {
  1332.       if (count == 10)
  1333.       {
  1334.         if (probe_gc_drone (drone))
  1335.           count = 0;
  1336.         else
  1337.         {
  1338.           start_gc_drones (drone->index, 1, 1);
  1339.           goto buffer_failed;
  1340.         }
  1341.       }
  1342.       else
  1343.         sleep_awaiting_drones (default_sleep_period,
  1344.                    (((unsigned long) 1) << drone->index));
  1345.       STATISTICS_INCR (read_wait_cycles);
  1346.     }
  1347.  
  1348.     if (buffer->state != buffer_ready)
  1349.     {
  1350. buffer_failed:
  1351.       entry->state = entry_idle;
  1352.       entry->retry_count = 0;
  1353.       buffer->state = buffer_idle;
  1354.       buffer->position = -1;
  1355.       STATISTICS_INCR (reads_overlapped_aborted);
  1356.       break;
  1357.     }
  1358.     STATISTICS_INCR (reads_pending);
  1359.     goto buffer_available;
  1360.       }
  1361.  
  1362.       case buffer_queued:
  1363.     STATISTICS_INCR (reads_queued);
  1364.     goto buffer_available;
  1365.  
  1366.       case buffer_ready:
  1367.     STATISTICS_INCR (reads_ready);
  1368.  
  1369. buffer_available:
  1370.     /* This should check size, but they are all the same. */
  1371.     entry->state = entry_idle;
  1372.     entry->retry_count = 0;
  1373.     buffer->state = buffer_busy;
  1374.     STATISTICS_INCR (reads_overlapped);
  1375.     return (buffer);
  1376.     }
  1377.   }
  1378.   else if ((write_overlap > 0)
  1379.        && ((entry = (find_queue_entry (gc_write_queue, write_overlap,
  1380.                        posn, -2)))
  1381.            != ((struct gc_queue_entry *) NULL)))
  1382.   {
  1383.     int index;
  1384.  
  1385.     /* This should check size, but they are all the same. */
  1386.  
  1387.     entry->state = entry_idle;
  1388.     entry->retry_count = 0;
  1389.     buffer = entry->buffer;
  1390.     index = entry->drone_index;
  1391.     if (index != -1)
  1392.       abort_gc_drone (gc_drones + index);
  1393.     buffer->state = buffer_busy;
  1394.     STATISTICS_INCR (reads_found_in_write_queue);
  1395.     return (buffer);
  1396.   }
  1397.   else if ((buffer = (find_ready_buffer (posn, size)))
  1398.        != ((struct buffer_info *) NULL))
  1399.   {
  1400.     /* This should check size, but they are all the same. */
  1401.  
  1402.     buffer->state = buffer_busy;
  1403.     STATISTICS_INCR (reads_found_ready);
  1404.     return (buffer);
  1405.   }
  1406.  
  1407.   /* (read_overlap == 0) or not pre-read. */
  1408.   {
  1409.     buffer = (find_idle_buffer ());
  1410.  
  1411.     load_data (posn, ((char *) buffer->bottom), size,
  1412.            noise, ((Boolean *) NULL));
  1413.     buffer->state = buffer_busy;
  1414.     STATISTICS_INCR (reads_not_overlapped);
  1415.     return (buffer);
  1416.   }
  1417. }
  1418.  
  1419. static void
  1420. DEFUN (write_buffer, (buffer, position, size, success, noise),
  1421.        struct buffer_info * buffer AND long position
  1422.        AND long size AND Boolean * success AND char * noise)
  1423. {
  1424.   if ((write_overlap > 0) && ((verify_write (position, size, success)) != -1))
  1425.   {
  1426.     unsigned long drone_mask;
  1427.     struct gc_queue_entry * entry =
  1428.       (allocate_queue_entry (gc_write_queue, write_overlap,
  1429.                  position, request_write, (& drone_mask)));
  1430.  
  1431.     if (entry == ((struct gc_queue_entry *) NULL))
  1432.     {
  1433.       STATISTICS_INCR (writes_pending);
  1434.       do
  1435.       {
  1436.     sleep_awaiting_drones (default_sleep_period, drone_mask);
  1437.     entry =
  1438.       (allocate_queue_entry (gc_write_queue, write_overlap,
  1439.                  position, request_write, (& drone_mask)));
  1440.     STATISTICS_INCR (write_wait_cycles);
  1441.       } while (entry == ((struct gc_queue_entry *) NULL));
  1442.     }
  1443.     else if (entry->buffer != NULL)
  1444.     {
  1445.       int index = entry->drone_index;
  1446.       struct buffer_info * old_buffer;
  1447.  
  1448.       if (index != -1)
  1449.     abort_gc_drone (gc_drones + index);
  1450.       old_buffer = entry->buffer;
  1451.       old_buffer->state = buffer_idle;
  1452.       entry->buffer = buffer;
  1453.       outf_error ("\n%s (write_buffer %s): duplicate write at 0x%lx.\n",
  1454.           scheme_program_name, noise, position);
  1455.     }
  1456.     do
  1457.       entry->drone_index = (find_idle_drone (1));
  1458.     while (!(invoke_gc_drone (entry, drone_writing, buffer, position, size)));
  1459.     STATISTICS_INCR (writes_overlapped);
  1460.     return;
  1461.   }
  1462.  
  1463.   STATISTICS_INCR (writes_not_overlapped);
  1464.   write_data (((char *) buffer->bottom), position, size, noise, success);
  1465.   buffer->state = buffer_idle;
  1466.   return;
  1467. }
  1468.  
  1469. static void
  1470. DEFUN (enqueue_buffer, (entry, buffer, position, size, state),
  1471.        struct gc_queue_entry * entry AND struct buffer_info * buffer
  1472.        AND long position AND long size AND enum buffer_state state)
  1473. {
  1474.   buffer->state = state;
  1475.   buffer->position = position;
  1476.   buffer->size = size;
  1477.   entry->buffer = buffer;
  1478.   entry->drone_index = -1;
  1479.   entry->state = entry_busy;
  1480.   return;
  1481. }
  1482.  
  1483. static void
  1484. DEFUN (enqueue_ready_buffer, (buffer, position, size),
  1485.        struct buffer_info * buffer AND long position AND long size)
  1486. {
  1487.   struct gc_queue_entry * entry;
  1488.  
  1489.   if ((read_overlap == 0)
  1490.       || ((entry = (allocate_queue_entry (gc_read_queue, read_overlap,
  1491.                       position, request_ready,
  1492.                       ((unsigned long *) NULL))))
  1493.       == ((struct gc_queue_entry *) NULL)))
  1494.   {
  1495.     write_buffer (buffer, position, size, ((char *) NULL), "a ready buffer");
  1496.     STATISTICS_INCR (ready_buffers_not_enqueued);
  1497.     return;
  1498.   }
  1499.   if (entry->buffer != NULL)  
  1500.   {
  1501.     int index = entry->drone_index;
  1502.     struct buffer_info * old_buffer = entry->buffer;
  1503.  
  1504.     if (index != -1)
  1505.       abort_gc_drone (gc_drones + index);
  1506.     old_buffer->state = buffer_idle;
  1507.     outf_error ("\n%s (enqueue_ready_buffer): Duplicate pre-read at 0x%lx.\n",
  1508.         scheme_program_name, old_buffer->position);
  1509.   }
  1510.   enqueue_buffer (entry, buffer, position, size, buffer_queued);
  1511.   STATISTICS_INCR (ready_buffers_enqueued);
  1512.   return;
  1513. }
  1514.  
  1515. static void
  1516. DEFUN (abort_pre_read, (position), long position)
  1517. {
  1518.   int index;
  1519.   struct gc_queue_entry * entry;
  1520.   struct buffer_info * buffer;
  1521.   
  1522.   entry = (find_queue_entry (gc_read_queue, read_overlap, position, -2));
  1523.   if (entry == ((struct gc_queue_entry *) NULL))
  1524.     return;
  1525.   buffer = entry->buffer;
  1526.   if (buffer->state == buffer_queued)
  1527.   {
  1528.     entry->state = entry_idle;
  1529.     entry->retry_count = 0;
  1530.     write_buffer (buffer, buffer->position, buffer->size,
  1531.           ((Boolean *) NULL), "a queued buffer");
  1532.     STATISTICS_INCR (pre_reads_requeued_as_writes);
  1533.     return;
  1534.   }
  1535.   index = entry->drone_index;
  1536.   if (index != -1)
  1537.     abort_gc_drone (gc_drones + index);
  1538.   buffer->state = buffer_idle;
  1539.   buffer->position = -1;
  1540.   entry->state = entry_idle;
  1541.   entry->retry_count = 0;
  1542.   STATISTICS_INCR (pre_reads_aborted);
  1543.   return;
  1544. }
  1545.  
  1546. static int
  1547. DEFUN (pre_read_buffer, (position, size), long position AND long size)
  1548. {
  1549.   struct gc_queue_entry * rentry, * wentry;
  1550.   struct buffer_info * buffer;
  1551.  
  1552.   if (read_overlap <= 0)
  1553.     return (0);
  1554.  
  1555.   /* Do this first, to guarantee that we can insert it in the queue.
  1556.      Otherwise there is no point in aborting a write, etc.
  1557.      It is not really allocated until enqueue_buffer or invoke_gc_drone.
  1558.    */
  1559.  
  1560.   rentry = (allocate_queue_entry (gc_read_queue, read_overlap,
  1561.                   position, request_read,
  1562.                   ((unsigned long *) NULL)));
  1563.   if (rentry == ((struct gc_queue_entry *) NULL))
  1564.   {
  1565.     STATISTICS_INCR (pre_reads_ignored);
  1566.     return (0);
  1567.   }
  1568.   else if (rentry->buffer != NULL)
  1569.     /* Already being pre-read */
  1570.     return (1);
  1571.  
  1572.   if ((write_overlap > 0)
  1573.       && ((wentry = (find_queue_entry (gc_write_queue, write_overlap,
  1574.                        position, -2)))
  1575.       != ((struct gc_queue_entry *) NULL)))
  1576.   {
  1577.     int index = wentry->drone_index;
  1578.  
  1579.     buffer = wentry->buffer;
  1580.     if (index != -1)
  1581.       abort_gc_drone (gc_drones + index);
  1582.     wentry->state = entry_idle;
  1583.     wentry->retry_count = 0;
  1584.     enqueue_buffer (rentry, buffer, position, size, buffer_queued);
  1585.     STATISTICS_INCR (pre_reads_found_in_write_queue);
  1586.     return (1);
  1587.   }
  1588.   else if ((buffer = (find_ready_buffer (position, size)))
  1589.        != ((struct buffer_info *) NULL))
  1590.   {
  1591.     enqueue_buffer (rentry, buffer, position, size, buffer_ready);
  1592.     STATISTICS_INCR (pre_reads_found_ready);
  1593.     return (1);
  1594.   }
  1595.  
  1596.   if (((rentry->drone_index = (find_idle_drone (0))) == -1)
  1597.       || (!(invoke_gc_drone (rentry, drone_reading, (find_idle_buffer ()),
  1598.                  position, size))))
  1599.   {
  1600.     STATISTICS_INCR (pre_reads_not_started);
  1601.     return (0);
  1602.   }
  1603.   STATISTICS_INCR (pre_reads_started);
  1604.   return (1);
  1605. }
  1606.  
  1607. static void
  1608. DEFUN (handle_drone_death, (drone), struct drone_info * drone)
  1609. {
  1610.   struct buffer_info * buffer;
  1611.   struct gc_queue_entry * entry;
  1612.  
  1613.   STATISTICS_INCR (drones_found_dead);
  1614.   if ((entry = (find_queue_entry (gc_write_queue, write_overlap,
  1615.                   -1, drone->index)))
  1616.       != ((struct gc_queue_entry *) NULL))
  1617.   {
  1618.     buffer = entry->buffer;
  1619.     entry->state = entry_idle;
  1620.     entry->retry_count = 0;
  1621.     if (buffer->state != buffer_idle)
  1622.     {
  1623.       write_buffer (buffer, buffer->position, buffer->size,
  1624.             ((Boolean *) NULL), "a queued buffer whose drone died");
  1625.       STATISTICS_INCR (writes_restarted);
  1626.     }
  1627.   }
  1628.   else if ((entry = (find_queue_entry (gc_read_queue, read_overlap,
  1629.                        -1, drone->index)))
  1630.        != ((struct gc_queue_entry *) NULL))
  1631.   {
  1632.     buffer = entry->buffer;
  1633.     if (buffer->state != buffer_ready)
  1634.     {
  1635.       entry->state = entry_idle;
  1636.       entry->retry_count = 0;
  1637.       buffer->state = buffer_idle;
  1638.       STATISTICS_INCR (pre_reads_restarted);
  1639.       (void) (pre_read_buffer (buffer->position, buffer->size));
  1640.     }
  1641.   }
  1642.   return;
  1643. }
  1644.  
  1645. static void
  1646. DEFUN (await_io_completion, (start_p), int start_p)
  1647. {
  1648.   int cntr;
  1649.   struct buffer_info * buffer;
  1650.   struct gc_queue_entry * entry;
  1651.  
  1652.   if (n_gc_drones != 0)
  1653.     probe_all_gc_drones (1);
  1654.   if (start_p)
  1655.   {
  1656.     for (cntr = 0, buffer = gc_buffers; cntr < n_gc_buffers; cntr++, buffer++)
  1657.     {
  1658.       buffer->state = buffer_idle;
  1659.       buffer->position = -1;
  1660.     }
  1661.     for (cntr = 0, entry = gc_read_queue; cntr < read_overlap; cntr++, entry++)
  1662.       entry->state = entry_idle;
  1663.     for (cntr = 0, entry = gc_write_queue; cntr < write_overlap;
  1664.      cntr++, entry++)
  1665.       entry->state = entry_idle;
  1666.   }
  1667.   return;
  1668. }
  1669.  
  1670. #define CAN_RECONFIGURE_GC_BUFFERS    1
  1671.  
  1672. #define GC_BUFFER_ALLOCATION(space)    0
  1673.  
  1674. #define INITIALIZE_GC_BUFFERS(ft, start, size, ro, wo, gcd)        \
  1675.  sysV_initialize (ft, size, ro, wo, gcd)
  1676.  
  1677. #define RE_INITIALIZE_GC_BUFFERS(ft, start, size, ro, wo, gcd)        \
  1678.  sysV_initialize (ft, size, ro, wo, gcd)
  1679.  
  1680. #define BUFFER_SHUTDOWN(lt)        sysV_shutdown (lt)
  1681.  
  1682. #define INITIALIZE_IO()            await_io_completion (1)
  1683. #define AWAIT_IO_COMPLETION()        await_io_completion (0)
  1684.  
  1685. #define INITIAL_SCAN_BUFFER()        free_buffer        /* NOP */
  1686. #define INITIAL_FREE_BUFFER()        get_gc_buffer ()
  1687. #define OTHER_BUFFER(buffer)        get_gc_buffer ()
  1688.  
  1689. #define GC_BUFFER_BOTTOM(buffer)     ((SCHEME_OBJECT *) buffer->bottom)
  1690. #define GC_BUFFER_TOP(buffer)         ((SCHEME_OBJECT *) buffer->top)
  1691.  
  1692. #define READ_BUFFER            read_buffer
  1693. #define DUMP_BUFFER            write_buffer
  1694. #define PRE_READ_BUFFER            pre_read_buffer
  1695. #define ABORT_PRE_READ            abort_pre_read
  1696. #define ENQUEUE_READY_BUFFER        enqueue_ready_buffer
  1697.  
  1698. #define LOAD_BUFFER(buffer, position, size, noise)            \
  1699.   buffer = (read_buffer (position, size, noise))
  1700.  
  1701. #else /* not USE_SYSV_SHARED_MEMORY */
  1702.  
  1703. static struct buffer_info
  1704.   * gc_disk_buffer_1,
  1705.   * gc_disk_buffer_2;
  1706.  
  1707. #define CAN_RECONFIGURE_GC_BUFFERS    0
  1708.  
  1709. #define GC_BUFFER_ALLOCATION(space)    space
  1710.  
  1711. #define INITIALIZE_GC_BUFFERS(ft, start, size, ro, wo, gcd)        \
  1712. do {                                    \
  1713.   SCHEME_OBJECT * ptr = (start);                    \
  1714.                                     \
  1715.   gc_disk_buffer_1 = ((struct buffer_info *) ptr);            \
  1716.   gc_disk_buffer_2 = ((struct buffer_info *)                \
  1717.               (ptr + gc_total_buffer_size));            \
  1718.   open_gc_file (size, 1);                        \
  1719. } while (0)
  1720.  
  1721. #define BUFFER_SHUTDOWN(lt)    close_gc_file (lt)
  1722.  
  1723. #define INITIALIZE_IO()        do { } while (0)
  1724. #define AWAIT_IO_COMPLETION()    do { } while (0)
  1725.  
  1726. #define INITIAL_FREE_BUFFER()    gc_disk_buffer_1
  1727. #define INITIAL_SCAN_BUFFER()    OTHER_BUFFER(free_buffer)
  1728.  
  1729. /* (gc_disk_buffer_1 - (gc_disk_buffer_2 - (buffer))) does not work
  1730.    because scan_buffer is not initialized until after scanning
  1731.    constant space.  */
  1732.  
  1733. #define OTHER_BUFFER(buffer)    (((buffer) == gc_disk_buffer_1)        \
  1734.                  ? gc_disk_buffer_2            \
  1735.                  : gc_disk_buffer_1)
  1736.  
  1737. #define GC_BUFFER_BOTTOM(buffer) ((SCHEME_OBJECT *) (buffer))
  1738. #define GC_BUFFER_TOP(buffer) (((SCHEME_OBJECT *) (buffer)) + gc_buffer_size)
  1739.  
  1740. static int
  1741. DEFUN (catastrophic_failure, (name), char * name)
  1742. {
  1743.   outf_fatal ("\n%s: Procedure %s should never be called!\n",
  1744.           scheme_program_name, name);
  1745.   Microcode_Termination (TERM_EXIT);
  1746.   /*NOTREACHED*/
  1747.   return (0);
  1748. }
  1749.  
  1750. #define GCDIE(m)            catastrophic_failure (m)
  1751.  
  1752. #define RE_INITIALIZE_GC_BUFFERS(f,s,z,r,w,g)                \
  1753.                     GCDIE ("RE_INITIALIZE_GC_BUFFERS")
  1754. #define READ_BUFFER(p,s,n)        GCDIE ("read_buffer")
  1755. #define PRE_READ_BUFFER(p,s)        GCDIE ("pre_read_buffer")
  1756. #define ABORT_PRE_READ(p)        GCDIE ("abort_pre_read")
  1757. #define ENQUEUE_READY_BUFFER(b,p,s)    GCDIE ("enqueue_ready_buffer")
  1758.  
  1759. #define LOAD_BUFFER(buffer, position, size, noise)            \
  1760.   load_data (position, ((char *) buffer), size, noise, ((Boolean *) NULL))
  1761.  
  1762. #define DUMP_BUFFER(buffer, position, size, successp, noise)        \
  1763.   write_data (((char *) buffer), position, size, noise, successp)
  1764.  
  1765. #endif /* not USE_SYSV_SHARED_MEMORY */
  1766.  
  1767. #define DUMP_SCAN_BUFFER(success)                    \
  1768.   DUMP_BUFFER (scan_buffer, scan_position, gc_buffer_bytes,        \
  1769.            success, "the scan buffer")
  1770.  
  1771. #define DUMP_FREE_BUFFER(success)                    \
  1772.   DUMP_BUFFER (free_buffer, free_position, gc_buffer_bytes,        \
  1773.            success, "the free buffer")
  1774.  
  1775. #define LOAD_SCAN_BUFFER()                        \
  1776.   LOAD_BUFFER (scan_buffer, scan_position, gc_buffer_bytes,        \
  1777.            "the scan buffer")
  1778.  
  1779. #define LOAD_FREE_BUFFER()                        \
  1780.   LOAD_BUFFER (free_buffer, free_position, gc_buffer_bytes,        \
  1781.            "the free buffer")
  1782.  
  1783. static int
  1784. DEFUN (next_exponent_of_two, (value), int value)
  1785. {
  1786.   unsigned int power;
  1787.   int exponent;
  1788.  
  1789.   if (value < 0)
  1790.     return (0);
  1791.   
  1792.   for (power = 1, exponent = 0;
  1793.        power < ((unsigned int) value);
  1794.        power = (power << 1), exponent += 1)
  1795.     ;
  1796.   return (exponent);
  1797. }
  1798.  
  1799. /* Hacking the gc file */
  1800.  
  1801. static int
  1802.   saved_gc_file = -1,
  1803.   saved_read_overlap,
  1804.   saved_write_overlap;
  1805.  
  1806. static long
  1807.   saved_start_position,
  1808.   saved_end_position;
  1809.  
  1810. int
  1811. DEFUN (swap_gc_file, (fid), int fid)
  1812. {
  1813.   /* Do not use overlapped I/O for fasdump because the drone processes
  1814.      will continue writing to the same old file!
  1815.    */
  1816.   saved_gc_file = gc_file;
  1817.   saved_read_overlap = read_overlap;
  1818.   saved_write_overlap = write_overlap;
  1819.   saved_start_position = gc_file_start_position;
  1820.   saved_end_position = gc_file_end_position;
  1821.   gc_file = fid;
  1822.   read_overlap = 0;
  1823.   write_overlap = 0;
  1824.   gc_file_end_position
  1825.     = (absolute_gc_file_end_position - gc_file_start_position);
  1826.   gc_file_start_position = 0L;
  1827.   return (saved_gc_file);
  1828. }
  1829.  
  1830. void
  1831. DEFUN_VOID (restore_gc_file)
  1832. {
  1833.   gc_file = saved_gc_file;
  1834.   read_overlap = saved_read_overlap;
  1835.   write_overlap = saved_write_overlap;
  1836.   gc_file_start_position = saved_start_position;
  1837.   gc_file_end_position = saved_end_position;
  1838.   saved_gc_file = -1;
  1839.   return;
  1840. }
  1841.  
  1842. static void
  1843. DEFUN (close_gc_file, (unlink_p), int unlink_p)
  1844. {
  1845. #ifdef HAVE_LOCKF
  1846.   if (gc_file != -1)
  1847.     {
  1848.       if ((lseek (gc_file, gc_file_start_position, SEEK_SET)) < 0)
  1849.     perror ("lseek");
  1850.       if ((lockf (gc_file, F_ULOCK,
  1851.           (gc_file_end_position - gc_file_start_position)))
  1852.       < 0)
  1853.     perror ("lockf");
  1854.     }
  1855. #endif
  1856.   if ((gc_file != -1) && ((close (gc_file)) == -1))
  1857.     outf_error ("\n%s (close_gc_file): error: GC file = \"%s\"; errno = %s.\n",
  1858.         scheme_program_name, gc_file_name, (error_name (errno)));
  1859.   gc_file = -1;
  1860.   if (!keep_gc_file_p && unlink_p)
  1861.     unlink (gc_file_name);
  1862.   OS_free (gc_file_name);
  1863.   gc_file_name = 0;
  1864.   keep_gc_file_p = 0;
  1865. }
  1866.  
  1867. #define EMPTY_STRING_P(string)                        \
  1868.   (((string) == ((char *) NULL)) || ((*(string)) == '\0'))
  1869.  
  1870. static void
  1871. DEFUN (termination_open_gc_file, (operation, extra),
  1872.        CONST char * operation AND CONST char * extra)
  1873. {
  1874.   if ((! (EMPTY_STRING_P (operation))) && (! (EMPTY_STRING_P (extra))))
  1875.     outf_fatal
  1876.       ("%s (open_gc_file): %s (\"%s\") failed, (errno = %s).\n\t%s.\n",
  1877.        scheme_program_name, operation, gc_file_name, (error_name (errno)),
  1878.        extra);
  1879.   else if (! (EMPTY_STRING_P (operation)))
  1880.     outf_fatal
  1881.       ("%s (open_gc_file): %s (\"%s\") failed, (errno = %s).\n",
  1882.        scheme_program_name, operation, gc_file_name, (error_name (errno)));
  1883.   else if (! (EMPTY_STRING_P (extra)))
  1884.     outf_fatal ("\t%s.\n", extra);
  1885.   termination_init_error ();
  1886.   /*NOTREACHED*/
  1887. }
  1888.  
  1889. char *
  1890. DEFUN (make_gc_file_name, (suffix), CONST char * suffix)
  1891. {
  1892.   unsigned int s = (strlen (suffix));
  1893.   if ((option_gc_file[0]) == SUB_DIRECTORY_DELIMITER)
  1894.     {
  1895.       unsigned int n
  1896.     = (((strrchr (option_gc_file, SUB_DIRECTORY_DELIMITER))
  1897.         - option_gc_file)
  1898.        + 1);
  1899.       char * result = (OS_malloc (n + s + 1));
  1900.       strncpy (result, option_gc_file, n);
  1901.       (result[n]) = '\0';
  1902.       strcat (result, suffix);
  1903.       return (result);
  1904.     }
  1905.   {
  1906.     unsigned int l = (strlen (option_gc_directory));
  1907.     if ((option_gc_directory [l - 1]) == SUB_DIRECTORY_DELIMITER)
  1908.       {
  1909.     unsigned int n = l;
  1910.     char * result = (OS_malloc (n + s + 1));
  1911.     sprintf (result, "%s%s", option_gc_directory, suffix);
  1912.     return (result);
  1913.       }
  1914.     else
  1915.       {
  1916.     unsigned int n = (l + 1);
  1917.     char * result = (OS_malloc (n + s + 1));
  1918.     sprintf (result, "%s%c%s",
  1919.          option_gc_directory, SUB_DIRECTORY_DELIMITER, suffix);
  1920.     return (result);
  1921.       }
  1922.   }
  1923. }
  1924.  
  1925. int
  1926. DEFUN (allocate_gc_file, (name), char * name)
  1927. {
  1928.   /* `name' must end in 6 `X' characters.  */
  1929.   char * exxes = (name + ((strlen (name)) - 6));
  1930.   unsigned int n = 0;
  1931.  
  1932.   while (n < 1000000)
  1933.     {
  1934.       sprintf (exxes, "%06d", n);
  1935.       if (OS_file_touch (name))
  1936.     return (1);
  1937.       n += 1;
  1938.     }
  1939.   return (0);
  1940. }
  1941.  
  1942. void
  1943. DEFUN (protect_gc_file_name, (name), CONST char * name)
  1944. {
  1945.   CONST char ** p = (dstack_alloc (sizeof (char *)));
  1946.   (*p) = name;
  1947.   transaction_record_action (tat_always, OS_free, p);
  1948. }
  1949.  
  1950. #ifndef _POSIX_VERSION
  1951. extern off_t EXFUN (lseek, (int, off_t, int));
  1952. #endif
  1953.  
  1954. static void
  1955. DEFUN (open_gc_file, (size, unlink_p),
  1956.        long size AND
  1957.        int unlink_p)
  1958. {
  1959.   struct stat file_info;
  1960.   int flags;
  1961.   Boolean temp_p, exists_p;
  1962.  
  1963.   gc_file_name
  1964.     = (make_gc_file_name
  1965.        (((option_gc_file[0]) == SUB_DIRECTORY_DELIMITER)
  1966.     ? ((strrchr (option_gc_file, SUB_DIRECTORY_DELIMITER)) + 1)
  1967.     : option_gc_file));
  1968.  
  1969.   {
  1970.     unsigned int n = (strlen (option_gc_file));
  1971.     if ((n >= 6) && ((strcmp ((option_gc_file + (n - 6)), "XXXXXX")) == 0))
  1972.       {
  1973.     if (!allocate_gc_file (gc_file_name))
  1974.       {
  1975.         outf_fatal
  1976.           ("%s: Unable to allocate a temporary file for the spare heap.\n",
  1977.            scheme_program_name);
  1978.         termination_open_gc_file (0, 0);
  1979.         /*NOTREACHED*/
  1980.       }
  1981.     temp_p = true;
  1982.       }
  1983.     else
  1984.       temp_p = false;
  1985.   }
  1986.  
  1987.   flags = GC_FILE_FLAGS;
  1988.   gc_file_start_position = (ALIGN_UP_TO_IO_PAGE (option_gc_start_position));
  1989.   gc_file_end_position = option_gc_end_position;
  1990.   if (gc_file_end_position == -1)
  1991.     gc_file_end_position = (gc_file_start_position + size);
  1992.   gc_file_end_position = (ALIGN_DOWN_TO_IO_PAGE (gc_file_end_position));
  1993.   if (gc_file_end_position < gc_file_start_position)
  1994.   {
  1995.     outf_fatal
  1996.       ("%s (open_gc_file): file bounds are inconsistent.\n\
  1997.         \trequested start = 0x%lx;\taligned start = 0x%lx.\n\
  1998.     \trequested end   = 0x%lx;\taligned end   = 0x%lx.\n",
  1999.        scheme_program_name,
  2000.        option_gc_start_position, gc_file_start_position,
  2001.        option_gc_end_position, gc_file_end_position);
  2002.     termination_open_gc_file (0, 0);
  2003.   }
  2004.  
  2005.   absolute_gc_file_end_position = gc_file_end_position;
  2006.  
  2007.   if ((stat (gc_file_name, &file_info)) == -1)
  2008.   {
  2009.     exists_p = false;
  2010.     can_dump_directly_p = true;
  2011.     flags |= O_EXCL;
  2012.   }
  2013.   else
  2014.   {
  2015. #ifdef __unix__
  2016.     /* If it is S_IFCHR, it should determine the IO block
  2017.        size and make sure that it will work.
  2018.        I don't know how to do that.
  2019.        ustat(2) will do that for a mounted file system,
  2020.        but obviously, if a raw device file is used,
  2021.        there better not be a file system on the device or partition.
  2022.        Does st_blksize give the correct value? -- Apparently not.
  2023.        */
  2024.  
  2025.     exists_p = true;
  2026.     if ((file_info.st_mode & S_IFMT) == S_IFCHR)
  2027.       can_dump_directly_p = false;
  2028.  
  2029.     else if (((file_info.st_mode & S_IFMT) != S_IFREG)
  2030.          && ((file_info.st_mode & S_IFMT) != S_IFBLK))
  2031.     {
  2032.       outf_fatal
  2033.     ("%s (open_gc_file): file \"%s\" has unknown/bad type 0x%x.\n\
  2034.       \tKnown types: S_IFREG (0x%x), S_IFBLK (0x%x), S_IFCHR (0x%x).\n",
  2035.      scheme_program_name, gc_file_name,
  2036.      ((int) (file_info.st_mode & S_IFMT)),
  2037.      S_IFREG, S_IFBLK, S_IFCHR);
  2038.       termination_open_gc_file (((char *) NULL), ((char *) NULL));
  2039.     }
  2040.     else
  2041.       can_dump_directly_p = true;
  2042. #else
  2043.     /* Assume that it will be a normal file.  */
  2044.     exists_p = true;
  2045.     can_dump_directly_p = true;
  2046. #endif
  2047.   }
  2048.  
  2049.   gc_file = (open (gc_file_name, flags, GC_FILE_MASK));
  2050.   if (gc_file == -1)
  2051.   {
  2052. #ifndef __unix__
  2053.     /* errno does not give sufficient information except under unix. */
  2054.  
  2055.     int saved_errno = errno;
  2056.     char
  2057.       directory_buffer[FILE_NAME_LENGTH],
  2058.       * directory, * directory_end;
  2059.  
  2060.     directory = &directory_buffer[0];
  2061.     strcpy (directory, gc_file_name);
  2062.     directory_end = (strrchr (directory, SUB_DIRECTORY_DELIMITER));
  2063.     if (directory_end != ((char *) NULL))
  2064.       * directory_end = '\0';
  2065.     if ((access (directory, F_OK)) != 0)
  2066.     {
  2067.       outf_fatal
  2068.     ("\n%s (open_gc_file): GC directory \"%s\" does not exist.\n",
  2069.      scheme_program_name, directory);
  2070.       termination_open_gc_file (((char *) NULL), ((char *) NULL));
  2071.     }
  2072.     else if ((access (directory, W_OK)) != 0)
  2073.     {
  2074.       outf_fatal
  2075.     ("\n%s (open_gc_file): GC directory \"%s\" is read protected.\n",
  2076.      scheme_program_name, directory);
  2077.       termination_open_gc_file (((char *) NULL), ((char *) NULL));
  2078.     }      
  2079.     else
  2080.       errno = saved_errno;
  2081. #endif /* not __unix__ */
  2082.     termination_open_gc_file ("open", ((char *) NULL));
  2083.   }
  2084.  
  2085.   keep_gc_file_p = (option_gc_keep || (exists_p && (!temp_p)));
  2086.  
  2087. #ifdef UNLINK_BEFORE_CLOSE
  2088.   if (!keep_gc_file_p && unlink_p)
  2089.     unlink (gc_file_name);
  2090. #endif  
  2091.  
  2092. #ifdef HAVE_PREALLOC
  2093.   if (!exists_p)
  2094.     prealloc (gc_file, ((unsigned int) gc_file_end_position));
  2095. #endif
  2096.  
  2097. #ifdef HAVE_LOCKF
  2098.   if (exists_p)
  2099.     {
  2100.       if ((lseek (gc_file, gc_file_start_position, SEEK_SET)) < 0)
  2101.     termination_open_gc_file ("lseek", ((char *) NULL));
  2102.  
  2103.       if ((lockf (gc_file, F_TLOCK, size)) < 0)
  2104.     termination_open_gc_file
  2105.       ("lockf",
  2106.        "The GC file is probably being used by another process");
  2107.     }
  2108. #endif
  2109.  
  2110.   gc_file_current_position = -1;    /* Unknown position */
  2111.  
  2112. #ifdef __unix__
  2113.   /* Determine whether it is a seekable file. */
  2114.   if (exists_p && ((file_info.st_mode & S_IFMT) == S_IFCHR))
  2115.   {
  2116. #ifdef HAVE_FCNTL
  2117.     int fcntl_flags;
  2118. #endif
  2119.     Boolean ignore;
  2120.     static char message[] = "This is a test message to the GC file.\n";
  2121.     char * buffer;
  2122.   
  2123.     buffer = ((char *) aligned_heap);
  2124.     strcpy (buffer, &message[0]);
  2125.     strncpy ((buffer + ((sizeof (message)) - 1)),
  2126.          buffer,
  2127.          (IO_PAGE_SIZE - (sizeof (message))));
  2128.     (* (buffer + (IO_PAGE_SIZE - 1))) = '\n';
  2129.  
  2130. #ifdef HAVE_FCNTL
  2131.     fcntl_flags = (fcntl (gc_file, F_GETFL, 0));
  2132.     if (fcntl_flags != (-1))
  2133.       fcntl (gc_file, F_SETFL, (fcntl_flags | O_NONBLOCK));
  2134. #endif
  2135.  
  2136.     write_data (buffer,
  2137.         (gc_file_start_position + ((long) IO_PAGE_SIZE)),
  2138.         ((long) IO_PAGE_SIZE),
  2139.         "a test buffer (1)",
  2140.         &ignore);
  2141.     load_data (gc_file_start_position,
  2142.            (buffer + IO_PAGE_SIZE),
  2143.            ((long) (2 * IO_PAGE_SIZE)),
  2144.            "a test buffer (2)",
  2145.            &ignore);
  2146.     if ((strncmp (buffer, (buffer + (2 * IO_PAGE_SIZE)), IO_PAGE_SIZE)) != 0)
  2147.     {
  2148.       outf_fatal ("\n%s (open_gc_file): \"%s\" is not a seek-able device.\n",
  2149.           scheme_program_name, gc_file_name);
  2150.       termination_open_gc_file (((char *) NULL), ((char *) NULL));
  2151.     }
  2152. #ifdef HAVE_FCNTL
  2153.     if (fcntl_flags != (-1))
  2154.       fcntl (gc_file, F_SETFL, fcntl_flags);
  2155. #endif
  2156.   }
  2157. #endif /* __unix__ */
  2158. }
  2159.  
  2160. #define CONSTANT_SPACE_FUDGE    128
  2161.  
  2162. Boolean
  2163. DEFUN (update_allocator_parameters, (ctop), SCHEME_OBJECT * ctop)
  2164. {
  2165.   SCHEME_OBJECT * htop;
  2166.   long new_end;
  2167.  
  2168.   /* buffer for impurify, etc. */
  2169.   ctop = ((SCHEME_OBJECT *)
  2170.       (ALIGN_UP_TO_IO_PAGE (ctop + CONSTANT_SPACE_FUDGE)));
  2171.   htop = ((SCHEME_OBJECT *)
  2172.       (ALIGN_DOWN_TO_IO_PAGE (Highest_Allocated_Address)));
  2173.   if (ctop >= htop)
  2174.     return (FALSE);
  2175.  
  2176.   new_end = (((char *) htop) - ((char *) ctop));
  2177.   new_end = (CEILING (new_end, gc_buffer_bytes));
  2178.   new_end += gc_file_start_position;
  2179.   if ((new_end > absolute_gc_file_end_position)
  2180.       && (! option_gc_end_position))
  2181.     return (FALSE);
  2182.  
  2183.   gc_file_end_position = new_end;
  2184.   Constant_Top = ctop;
  2185.   Heap_Bottom = Constant_Top;
  2186.   Heap_Top = htop;
  2187.   aligned_heap = Heap_Bottom;
  2188.   Local_Heap_Base = Heap_Bottom;
  2189.   Unused_Heap_Bottom = Heap_Top;
  2190.   Unused_Heap_Top = Highest_Allocated_Address;
  2191.   Free = Heap_Bottom;
  2192.   SET_MEMTOP (Heap_Top - GC_Reserve);
  2193.   return (TRUE);
  2194. }
  2195.  
  2196. Boolean
  2197. DEFUN_VOID (recompute_gc_end_position)
  2198. {
  2199.   SCHEME_OBJECT * htop;
  2200.   long new_end, delta;
  2201.  
  2202.   if ((((gc_file_end_position - gc_file_start_position) % gc_buffer_bytes)
  2203.        == 0)
  2204.       || option_gc_end_position)
  2205.     return (TRUE);
  2206.  
  2207.   htop = ((SCHEME_OBJECT *)
  2208.       (ALIGN_DOWN_TO_IO_PAGE (Highest_Allocated_Address)));
  2209.   new_end = (CEILING ((((char *) htop) - ((char *) Constant_Top)),
  2210.               gc_buffer_bytes));
  2211.   new_end += gc_file_start_position;
  2212.   if (new_end <= absolute_gc_file_end_position)
  2213.   {
  2214.     gc_file_end_position = new_end;
  2215.     return (TRUE);
  2216.   }
  2217.   delta = (FLOOR ((absolute_gc_file_end_position - gc_file_start_position),
  2218.           gc_buffer_bytes));
  2219.   if ((((char *) Constant_Top) + delta) <= (((char *) Free) + GC_Reserve))
  2220.     /* This should really GC and retry, but ... */
  2221.     return (FALSE);
  2222.   Heap_Top = ((SCHEME_OBJECT *) (((char *) Constant_Top) + delta));
  2223.   SET_MEMTOP (Heap_Top - GC_Reserve);
  2224.   return (TRUE);
  2225. }
  2226.  
  2227. void
  2228. DEFUN_VOID (reset_allocator_parameters)
  2229. {
  2230.   GC_Reserve = 4500;
  2231.   GC_Space_Needed = 0;
  2232.   Stack_Bottom = ((SCHEME_OBJECT *)
  2233.           (ALIGN_UP_TO_IO_PAGE (Lowest_Allocated_Address)));
  2234.   Stack_Top = ((SCHEME_OBJECT *)
  2235.            (ALIGN_DOWN_TO_IO_PAGE
  2236.         (Stack_Bottom + (STACK_ALLOCATION_SIZE (saved_stack_size)))));
  2237.   Constant_Space = Stack_Top;
  2238.   Free_Constant = Constant_Space;
  2239.   (void) update_allocator_parameters (Free_Constant);
  2240.   SET_CONSTANT_TOP ();
  2241.   ALIGN_FLOAT (Free);
  2242.   INITIALIZE_STACK ();
  2243.   STACK_RESET ();
  2244.   return;
  2245. }
  2246.  
  2247. void
  2248. DEFUN (Clear_Memory, (heap_size, stack_size, constant_space_size),
  2249.        int heap_size
  2250.        AND int stack_size
  2251.        AND int constant_space_size)
  2252. {
  2253.   saved_heap_size = heap_size;
  2254.   saved_constant_size = constant_space_size;
  2255.   saved_stack_size = stack_size;
  2256.   reset_allocator_parameters ();
  2257. }
  2258.  
  2259. void
  2260. DEFUN_VOID (Reset_Memory)
  2261. {
  2262.   BUFFER_SHUTDOWN (1);
  2263.   HEAP_FREE (Lowest_Allocated_Address);
  2264.   DEALLOCATE_REGISTERS ();
  2265.   return;
  2266. }
  2267.  
  2268. #define BLOCK_TO_IO_SIZE(size)                        \
  2269.   ((ALIGN_UP_TO_IO_PAGE ((size) * (sizeof (SCHEME_OBJECT))))        \
  2270.    / (sizeof (SCHEME_OBJECT)))
  2271.  
  2272. static int
  2273. DEFUN (set_gc_buffer_sizes, (new_buffer_shift), unsigned long new_buffer_shift)
  2274. {
  2275.   unsigned long
  2276.     new_buffer_size, new_buffer_bytes, new_buffer_byte_shift,
  2277.     new_buffer_overlap_bytes, new_extra_buffer_size;
  2278.   
  2279.   new_buffer_size = (1L << new_buffer_shift);
  2280.   new_buffer_bytes = (new_buffer_size * (sizeof (SCHEME_OBJECT)));
  2281.   if (! (ALIGNED_TO_IO_PAGE_P (new_buffer_bytes)))
  2282.   {
  2283.     outf_error
  2284.       ("%s (Setup_Memory): improper new_buffer_size.\n\
  2285.     \tIO_PAGE_SIZE   = 0x%lx bytes.\n\
  2286.     \tgc_buffer_size = 0x%lx bytes = 0x%lx objects.\n\
  2287.     \tIO_PAGE_SIZE should divide gc_buffer_size.\n",
  2288.        scheme_program_name,
  2289.        ((long) IO_PAGE_SIZE),
  2290.        new_buffer_bytes, new_buffer_size);
  2291.     return (-1);
  2292.   }
  2293.  
  2294.   new_buffer_byte_shift = (next_exponent_of_two (new_buffer_bytes));
  2295.   if ((((unsigned long) 1L) << new_buffer_byte_shift) != new_buffer_bytes)
  2296.   {
  2297.     outf_error
  2298.       ("%s (Setup_Memory): gc_buffer_bytes (0x%lx) is not a power of 2.\n",
  2299.        scheme_program_name, new_buffer_bytes);
  2300.     return (-1);
  2301.   }
  2302.  
  2303.   new_buffer_overlap_bytes = IO_PAGE_SIZE;
  2304.   new_extra_buffer_size
  2305.     = (new_buffer_overlap_bytes / (sizeof (SCHEME_OBJECT)));
  2306.   if ((new_extra_buffer_size * (sizeof (SCHEME_OBJECT)))
  2307.       != new_buffer_overlap_bytes)
  2308.   {
  2309.     outf_error
  2310.       (" %s (Setup_Memory): improper IO_PAGE_SIZE.\n\
  2311.     \tIO_PAGE_SIZE = 0x%lx; (sizeof (SCHEME_OBJECT)) = 0x%lx.\n\
  2312.     \t(sizeof (SCHEME_OBJECT)) should divide IO_PAGE_SIZE.\n",
  2313.        scheme_program_name,
  2314.        ((long) IO_PAGE_SIZE), ((long) (sizeof (SCHEME_OBJECT))));
  2315.     return (-1);
  2316.   }
  2317.  
  2318.   gc_buffer_shift = new_buffer_shift;
  2319.   gc_buffer_size = new_buffer_size;
  2320.   gc_buffer_bytes = new_buffer_bytes;
  2321.   gc_buffer_mask = (gc_buffer_size - 1);
  2322.   gc_buffer_byte_shift = new_buffer_byte_shift;
  2323.   gc_buffer_overlap_bytes = new_buffer_overlap_bytes;
  2324.   gc_extra_buffer_size = new_extra_buffer_size;
  2325.   gc_buffer_remainder_bytes = (gc_buffer_bytes - gc_buffer_overlap_bytes);
  2326.   gc_total_buffer_size = (gc_buffer_size + gc_extra_buffer_size);
  2327.   return (0);
  2328. }
  2329.  
  2330. void
  2331. DEFUN (Setup_Memory, (heap_size, stack_size, constant_space_size),
  2332.        int heap_size
  2333.        AND int stack_size
  2334.        AND int constant_space_size)
  2335. {
  2336.   SCHEME_OBJECT test_value;
  2337.   int real_stack_size;
  2338.   long gc_buffer_allocation;
  2339.  
  2340.   ALLOCATE_REGISTERS ();
  2341.  
  2342.   /* Consistency check 1 */
  2343.   if (heap_size == 0)
  2344.   {
  2345.     outf_fatal ("%s (Setup_Memory): Configuration won't hold initial data.\n",
  2346.         scheme_program_name);
  2347.     termination_init_error ();
  2348.     /*NOTREACHED*/
  2349.   }
  2350.  
  2351.   real_stack_size = (STACK_ALLOCATION_SIZE (stack_size));
  2352.  
  2353.   /* add log(1024)/log(2) to exponent */
  2354.   if ((set_gc_buffer_sizes (10
  2355.                 + (next_exponent_of_two (option_gc_window_size))))
  2356.       != 0)
  2357.     parameterization_termination (1, 1);
  2358.  
  2359.   /* Use multiples of IO_PAGE_SIZE. */
  2360.  
  2361.   heap_size = (BLOCK_TO_IO_SIZE (heap_size));
  2362.   constant_space_size = (BLOCK_TO_IO_SIZE (constant_space_size));
  2363.   real_stack_size = (BLOCK_TO_IO_SIZE (real_stack_size));
  2364.   gc_buffer_allocation = (GC_BUFFER_ALLOCATION (2 * gc_total_buffer_size));
  2365.  
  2366.   /* Allocate. */
  2367.  
  2368.   ALLOCATE_HEAP_SPACE ((heap_size
  2369.             + constant_space_size + real_stack_size
  2370.             + gc_buffer_allocation
  2371.             + (IO_PAGE_SIZE / (sizeof (SCHEME_OBJECT)))),
  2372.                Lowest_Allocated_Address,
  2373.                Highest_Allocated_Address);
  2374.  
  2375.   /* Consistency check 2 */
  2376.   if (Lowest_Allocated_Address == NULL)
  2377.   {
  2378.     outf_fatal
  2379.       ("%s (Setup_Memory): Not enough memory for this configuration.\n",
  2380.        scheme_program_name);
  2381.     termination_init_error ();
  2382.     /*NOTREACHED*/
  2383.   }
  2384.  
  2385.   Highest_Allocated_Address -= gc_buffer_allocation;
  2386.  
  2387.   /* Consistency check 3 */
  2388.   test_value =
  2389.     (MAKE_POINTER_OBJECT (LAST_TYPE_CODE, Highest_Allocated_Address));
  2390.  
  2391.   if (((OBJECT_TYPE (test_value)) != LAST_TYPE_CODE) ||
  2392.       ((OBJECT_ADDRESS (test_value)) != Highest_Allocated_Address))
  2393.   {
  2394.     outf_fatal
  2395.       ("%s (Setup_Memory): \
  2396.     Largest address does not fit in datum field of object.\n\
  2397.     \tAllocate less space or re-configure without HEAP_IN_LOW_MEMORY.\n",
  2398.        scheme_program_name);
  2399.     Reset_Memory ();
  2400.     termination_init_error ();
  2401.     /*NOTREACHED*/
  2402.   }
  2403.  
  2404.   Clear_Memory (heap_size, stack_size, constant_space_size);
  2405.   INITIALIZE_GC_BUFFERS (1,
  2406.              Highest_Allocated_Address,
  2407.              ((sizeof (SCHEME_OBJECT))
  2408.               * (CEILING ((heap_size + constant_space_size),
  2409.                       gc_buffer_size))),
  2410.              option_gc_read_overlap,
  2411.              option_gc_write_overlap,
  2412.              option_gc_drone);
  2413.   return;
  2414. }
  2415.  
  2416. /* Utilities for the GC proper. */ 
  2417.  
  2418. static void
  2419. DEFUN (enqueue_free_buffer, (success), Boolean * success)
  2420. {
  2421.   int diff;
  2422.  
  2423.   diff = ((free_position - pre_read_position) >> gc_buffer_byte_shift);
  2424.   if (diff >= read_overlap)
  2425.     DUMP_FREE_BUFFER (success);
  2426.   else
  2427.   {
  2428.     ENQUEUE_READY_BUFFER (free_buffer, free_position, gc_buffer_bytes);
  2429.     read_queue_bitmask |= (1L << diff);
  2430.   }
  2431.   return;
  2432. }
  2433.  
  2434. static void
  2435. DEFUN_VOID (schedule_pre_reads)
  2436. {
  2437.   int cntr;
  2438.   long position;
  2439.   unsigned long bit;
  2440.  
  2441.   if (pre_read_position == scan_position)
  2442.   {
  2443.     read_queue_bitmask = (read_queue_bitmask >> 1);
  2444.     pre_read_position += gc_buffer_bytes;
  2445.   }
  2446.   for (cntr = 0, bit = 1L, position = pre_read_position;
  2447.        ((cntr < read_overlap) && (position < free_position));
  2448.        cntr++, bit = (bit << 1), position += gc_buffer_bytes)
  2449.   {
  2450.     if ((read_queue_bitmask & bit) != bit)
  2451.       if (PRE_READ_BUFFER (position, gc_buffer_bytes))
  2452.     read_queue_bitmask |= bit;
  2453.   }
  2454.   return;
  2455. }
  2456.  
  2457. static void
  2458. DEFUN_VOID (abort_pre_reads)
  2459. {
  2460.   while (scan_position > pre_read_position)
  2461.   {
  2462.     ABORT_PRE_READ (pre_read_position);
  2463.     pre_read_position += gc_buffer_bytes;
  2464.     read_queue_bitmask = (read_queue_bitmask >> 1);
  2465.   }
  2466.   schedule_pre_reads ();
  2467.   return;
  2468. }
  2469.  
  2470. static void
  2471. DEFUN (reload_scan_buffer, (skip), unsigned long skip)
  2472. {
  2473.   scan_position += (skip << gc_buffer_byte_shift);
  2474.   virtual_scan_pointer += (skip << gc_buffer_shift);
  2475.  
  2476.   if ((read_overlap > 0) && (scan_position > pre_read_position))
  2477.     abort_pre_reads ();
  2478.  
  2479.   if (scan_position == free_position)
  2480.   {
  2481.     pre_read_position = (free_position + gc_buffer_bytes);
  2482.     read_queue_bitmask = 0L;
  2483.     scan_buffer = free_buffer;
  2484.     scan_buffer_bottom = free_buffer_bottom;
  2485.     scan_buffer_top = free_buffer_top;
  2486.     return;
  2487.   }
  2488.   LOAD_SCAN_BUFFER ();
  2489.   scan_buffer_bottom = (GC_BUFFER_BOTTOM (scan_buffer));
  2490.   scan_buffer_top = (GC_BUFFER_TOP (scan_buffer));
  2491.   *scan_buffer_top = (MAKE_POINTER_OBJECT (TC_BROKEN_HEART, scan_buffer_top));
  2492.   
  2493.   if (read_overlap > 0)
  2494.     schedule_pre_reads ();
  2495. }
  2496.  
  2497. SCHEME_OBJECT *
  2498. DEFUN (dump_and_reload_scan_buffer, (end, success),
  2499.        SCHEME_OBJECT * end AND
  2500.        Boolean * success)
  2501. {
  2502.   unsigned long number_to_skip = (end - scan_buffer_top);
  2503.   DUMP_SCAN_BUFFER (success);
  2504.   reload_scan_buffer (1 + (number_to_skip >> gc_buffer_shift));
  2505.   return (scan_buffer_bottom + (number_to_skip & gc_buffer_mask));
  2506. }
  2507.  
  2508. SCHEME_OBJECT *
  2509. DEFUN (dump_and_reset_free_buffer, (current_free, success),
  2510.        SCHEME_OBJECT * current_free AND
  2511.        Boolean * success)
  2512. {
  2513.   unsigned long overflow = (current_free - free_buffer_top);
  2514.   SCHEME_OBJECT * from = free_buffer_top;
  2515.   Boolean buffer_overlap_p = extension_overlap_p;
  2516.   Boolean same_buffer_p = (scan_buffer == free_buffer);
  2517.  
  2518.   if (read_overlap > 0)
  2519.     {
  2520.       if (buffer_overlap_p)
  2521.     {
  2522.       extension_overlap_p = false;
  2523.       next_scan_buffer = free_buffer;
  2524.     }
  2525.       else if (!same_buffer_p)
  2526.     enqueue_free_buffer (success);
  2527.     }
  2528.   else if (!same_buffer_p)
  2529.     DUMP_FREE_BUFFER (success);
  2530.  
  2531.   /* Otherwise there is no need to dump now, it will be dumped
  2532.      when scan is dumped.  Note that the next buffer may be dumped
  2533.      before this one, but there should be no problem lseeking past the
  2534.      end of file.  */
  2535.   free_position += gc_buffer_bytes;
  2536.   free_buffer = (OTHER_BUFFER (scan_buffer));
  2537.   free_buffer_bottom = (GC_BUFFER_BOTTOM (free_buffer));
  2538.   free_buffer_top = (GC_BUFFER_TOP (free_buffer));
  2539.   {
  2540.     SCHEME_OBJECT * into = free_buffer_bottom;
  2541.     SCHEME_OBJECT * end = (into + overflow);
  2542.     while (into < end)
  2543.       (*into++) = (*from++);
  2544.     if (same_buffer_p && (!buffer_overlap_p))
  2545.       (*scan_buffer_top)
  2546.     = (MAKE_POINTER_OBJECT (TC_BROKEN_HEART, scan_buffer_top));
  2547.     return (into);
  2548.   }
  2549. }
  2550.  
  2551. /* These utilities are needed when pointers fall accross window boundaries.
  2552.  
  2553.    Between both they effectively do a dump_and_reload_scan_buffer, in two
  2554.    stages.
  2555. */
  2556.  
  2557. void
  2558. DEFUN (extend_scan_buffer, (to_where, current_free),
  2559.        char * to_where AND
  2560.        SCHEME_OBJECT * current_free)
  2561. {
  2562.   fast char * source, * dest;
  2563.   long new_scan_position = (scan_position + gc_buffer_bytes);
  2564.  
  2565.   /* Is there buffer overlap?, i.e. is the next bufferful the one cached
  2566.      in the free pointer window?
  2567.    */
  2568.  
  2569.   scan_buffer_extended_p = true;
  2570.   dest = ((char *) scan_buffer_top);
  2571.   extension_overlap_length = (to_where - dest);
  2572.   extension_overlap_p = (new_scan_position == free_position);
  2573.  
  2574.   if (extension_overlap_p)
  2575.   {
  2576.     long temp;
  2577.  
  2578.     source = ((char *) free_buffer_bottom);
  2579.     temp = (((char *) current_free) - source);
  2580.     if (temp < extension_overlap_length)
  2581.     {
  2582.       /* This should only happen when Scan and Free are very close. */
  2583.       extension_overlap_length = temp;
  2584.     }
  2585.   }
  2586.   else if (read_overlap == 0)
  2587.   {
  2588.     load_data (new_scan_position, dest, gc_buffer_overlap_bytes,
  2589.            "the next scan buffer", ((Boolean *) NULL));
  2590.     return;
  2591.   }
  2592.   else
  2593.   {
  2594.     LOAD_BUFFER (next_scan_buffer, new_scan_position,
  2595.          gc_buffer_bytes, "the next scan buffer");
  2596.     source = ((char *) (GC_BUFFER_BOTTOM (next_scan_buffer)));
  2597.   }
  2598.  
  2599.   while (dest < to_where)
  2600.     *dest++ = *source++;
  2601.   return;
  2602. }
  2603.  
  2604. char *
  2605. DEFUN (end_scan_buffer_extension, (to_relocate), char * to_relocate)
  2606. {
  2607.   char * result;
  2608.   if (extension_overlap_p)
  2609.   {
  2610.     /* There was overlap between the scan buffer and the free buffer,
  2611.        there may no longer be, but dump_and_reload_scan_buffer will
  2612.        get us the correct next buffer.
  2613.        The old scan buffer may be written, but the while loop below
  2614.        will read storage contiguous to it (in the buffer extension).
  2615.      */
  2616.     SCHEME_OBJECT old, new;
  2617.     fast char * source, * dest, * limit;
  2618.  
  2619.     extension_overlap_p = false;
  2620.     source = ((char *) scan_buffer_top);
  2621.     old = (* ((SCHEME_OBJECT *) source));
  2622.     limit = (source + extension_overlap_length);
  2623.     dest = ((char *) (dump_and_reload_scan_buffer (scan_buffer_top, 0)));
  2624.     /* The following is only necesary if we are reusing the scan buffer. */
  2625.     new = (* scan_buffer_top);
  2626.     (* ((SCHEME_OBJECT *) source)) = old;
  2627.     result = (dest + (to_relocate - source));
  2628.     while (source < limit)
  2629.       *dest++ = *source++;
  2630.     (* scan_buffer_top) = new;
  2631.   }
  2632.   else if (next_scan_buffer == ((struct buffer_info *) NULL))
  2633.   {
  2634.     /* There was no buffer overlap and no read overlap */
  2635.  
  2636.     fast SCHEME_OBJECT * source, * dest, * limit;
  2637.  
  2638.     source = scan_buffer_top;
  2639.     limit = (source + gc_extra_buffer_size);
  2640.  
  2641.     DUMP_SCAN_BUFFER (0);
  2642.     scan_position += gc_buffer_bytes;
  2643.     virtual_scan_pointer += gc_buffer_size;
  2644.  
  2645.     scan_buffer = (OTHER_BUFFER (free_buffer));
  2646.     scan_buffer_bottom = (GC_BUFFER_BOTTOM (scan_buffer));
  2647.     scan_buffer_top = (GC_BUFFER_TOP (scan_buffer));
  2648.  
  2649.     dest = scan_buffer_bottom;
  2650.     result = (((char *) dest) + (to_relocate - ((char *) source)));
  2651.  
  2652.     while (source < limit)
  2653.       *dest++ = *source++;
  2654.  
  2655.     if (gc_buffer_remainder_bytes != 0)
  2656.       load_data ((scan_position + gc_buffer_overlap_bytes),
  2657.          ((char *) dest), gc_buffer_remainder_bytes,
  2658.          "the scan buffer", ((Boolean *) NULL));
  2659.  
  2660.     (* scan_buffer_top) =
  2661.       (MAKE_POINTER_OBJECT (TC_BROKEN_HEART, scan_buffer_top));
  2662.   }
  2663.   else
  2664.   {
  2665.     /* There is overlap with the next bufferful (not the free bufferful). */
  2666.  
  2667.     fast char * source, * dest, * limit;
  2668.  
  2669.     source = ((char *) scan_buffer_top);
  2670.     limit = (source + extension_overlap_length);
  2671.     dest = ((char *) (GC_BUFFER_BOTTOM (next_scan_buffer)));
  2672.     result = (dest + (to_relocate - source));
  2673.  
  2674.     while (source < limit)
  2675.       *dest++ = *source++;
  2676.     
  2677.     DUMP_SCAN_BUFFER (0);
  2678.     scan_position += gc_buffer_bytes;
  2679.     virtual_scan_pointer += gc_buffer_size;
  2680.  
  2681.     scan_buffer = next_scan_buffer;
  2682.     next_scan_buffer = NULL;
  2683.     scan_buffer_bottom = (GC_BUFFER_BOTTOM (scan_buffer));
  2684.     scan_buffer_top = (GC_BUFFER_TOP (scan_buffer));
  2685.     (* scan_buffer_top) =
  2686.       (MAKE_POINTER_OBJECT (TC_BROKEN_HEART, scan_buffer_top));
  2687.     schedule_pre_reads ();
  2688.   }
  2689.   scan_buffer_extended_p = false; 
  2690.   return (result);
  2691. }
  2692.  
  2693. /* This is used to avoid unnecessary copying when copying a large
  2694.    non-marked area.
  2695.  */
  2696.  
  2697. SCHEME_OBJECT *
  2698. DEFUN (dump_free_directly, (from, nbuffers, success),
  2699.        fast SCHEME_OBJECT * from
  2700.        AND fast long nbuffers
  2701.        AND Boolean * success)
  2702. {
  2703.   if (((read_overlap + write_overlap) == 0)
  2704.       && (can_dump_directly_p || (ALIGNED_TO_IO_PAGE_P (from))))
  2705.   {
  2706.     long byte_length = (nbuffers << gc_buffer_byte_shift);
  2707.  
  2708.     write_data (((char *) from), free_position, byte_length,
  2709.         "free buffers", success);
  2710.     free_position += byte_length;
  2711.   }
  2712.   else
  2713.   {
  2714.     /* This assumes that the free buffer has no valid data, so it can be
  2715.        used as scratch.
  2716.        This code is executed when there is I/O overlap, or when the
  2717.        data is not aligned to be written to a raw (character) device.
  2718.      */
  2719.  
  2720.     while ((--nbuffers) >= 0)
  2721.     {
  2722.       fast SCHEME_OBJECT * to, * bufend;
  2723.  
  2724.       for (to = free_buffer_bottom, bufend = free_buffer_top; to != bufend; )
  2725.     *to++ = *from++;
  2726.  
  2727.       (void) (dump_and_reset_free_buffer (to, success));
  2728.     }
  2729.   }
  2730.   return (free_buffer_bottom);
  2731. }
  2732.  
  2733. /* This code is needed by purify.  After the purified object is
  2734.    copied, the next step is to scan constant space.  In order to do
  2735.    this, it's necessary to save the current scan position, reset the
  2736.    scan limit pointers to scan constant space, then restore the saved
  2737.    scan position and finish scanning the heap.  These procedures
  2738.    provide the necessary functionality to do this.  */
  2739.  
  2740. static void
  2741. DEFUN_VOID (reset_scan_buffer)
  2742. {
  2743.   virtual_scan_pointer = 0;
  2744.   scan_position = (-1L);
  2745.   scan_buffer = 0;
  2746.   scan_buffer_bottom = 0;
  2747.   scan_buffer_top = Highest_Allocated_Address;
  2748.   next_scan_buffer = 0;
  2749.   scan_buffer_extended_p = false;
  2750.   extension_overlap_p = false;
  2751.   extension_overlap_length = 0;
  2752. }
  2753.  
  2754. void
  2755. DEFUN (save_scan_state, (state, scan),
  2756.        struct saved_scan_state * state AND
  2757.        SCHEME_OBJECT * scan)
  2758. {
  2759.   (state -> virtual_scan_pointer) = virtual_scan_pointer;
  2760.   (state -> scan_position) = scan_position;
  2761.   (state -> scan_offset) = (scan - scan_buffer_bottom);
  2762.   if (scan_position != free_position)
  2763.     DUMP_SCAN_BUFFER (0);
  2764.   reset_scan_buffer ();
  2765. }
  2766.  
  2767. SCHEME_OBJECT *
  2768. DEFUN (restore_scan_state, (state), struct saved_scan_state * state)
  2769. {
  2770.   virtual_scan_pointer = (state -> virtual_scan_pointer);
  2771.   scan_position = (state -> scan_position);
  2772.   if (scan_position == free_position)
  2773.     {
  2774.       scan_buffer = free_buffer;
  2775.       scan_buffer_bottom = free_buffer_bottom;
  2776.       scan_buffer_top = free_buffer_top;
  2777.     }
  2778.   else
  2779.     {
  2780.       scan_buffer = (OTHER_BUFFER (free_buffer));
  2781.       scan_buffer_bottom = (GC_BUFFER_BOTTOM (scan_buffer));
  2782.       scan_buffer_top = (GC_BUFFER_TOP (scan_buffer));
  2783.       LOAD_SCAN_BUFFER ();
  2784.     }
  2785.   return (scan_buffer_bottom + (state -> scan_offset));
  2786. }
  2787.  
  2788. void
  2789. DEFUN (set_fixed_scan_area, (bottom, top),
  2790.        SCHEME_OBJECT * bottom AND
  2791.        SCHEME_OBJECT * top)
  2792. {
  2793.   virtual_scan_pointer = bottom;
  2794.   scan_buffer_bottom = bottom;
  2795.   scan_buffer_top = top;
  2796. }
  2797.  
  2798. #ifndef START_TRANSPORT_HOOK
  2799. #define START_TRANSPORT_HOOK()        do { } while (0)
  2800. #endif
  2801.  
  2802. #ifndef END_TRANSPORT_HOOK
  2803. #define END_TRANSPORT_HOOK()        do { } while (0)
  2804. #endif
  2805.  
  2806. #ifndef END_WEAK_UPDATE_HOOK
  2807. #define END_WEAK_UPDATE_HOOK()        do { } while (0)
  2808. #endif
  2809.  
  2810. #ifndef START_RELOAD_HOOK
  2811. #define START_RELOAD_HOOK()        do { } while (0)
  2812. #endif
  2813.  
  2814. #ifndef END_GC_HOOK
  2815. #define END_GC_HOOK()            do { } while (0)
  2816. #endif
  2817.  
  2818. /* This hacks the scan buffer also so that Scan is always below
  2819.    scan_buffer_top until the scan buffer is initialized.
  2820.    Various parts of the garbage collector depend on scan_buffer_top
  2821.    having an aligned value.
  2822. */
  2823.  
  2824. SCHEME_OBJECT *
  2825. DEFUN_VOID (initialize_free_buffer)
  2826. {
  2827.   STATISTICS_CLEAR ();
  2828.   START_TRANSPORT_HOOK ();
  2829.   read_queue_bitmask = 0L;
  2830.   pre_read_position = gc_file_start_position;
  2831.   free_position = gc_file_start_position;
  2832.   INITIALIZE_IO ();
  2833.   free_buffer = (INITIAL_FREE_BUFFER ());
  2834.   free_buffer_bottom = (GC_BUFFER_BOTTOM (free_buffer));
  2835.   free_buffer_top = (GC_BUFFER_TOP (free_buffer));
  2836.   reset_scan_buffer ();
  2837.   /* Force first write to do an lseek. */
  2838.   gc_file_current_position = -1;
  2839.   return (free_buffer_bottom);
  2840. }
  2841.  
  2842. SCHEME_OBJECT *
  2843. DEFUN (initialize_scan_buffer, (block_start), SCHEME_OBJECT * block_start)
  2844. {
  2845.   virtual_scan_base = block_start;
  2846.   virtual_scan_pointer = virtual_scan_base;
  2847.   scan_position = gc_file_start_position;
  2848.   scan_buffer = (INITIAL_SCAN_BUFFER ());
  2849.   scan_buffer_bottom = (GC_BUFFER_BOTTOM (scan_buffer));
  2850.   scan_buffer_top = (GC_BUFFER_TOP (scan_buffer));
  2851.   reload_scan_buffer (0);
  2852.   return (scan_buffer_bottom);
  2853. }
  2854.  
  2855. void
  2856. DEFUN (end_transport, (success), Boolean * success)
  2857. {
  2858.   DUMP_SCAN_BUFFER (success);
  2859.   scan_position += gc_buffer_bytes;
  2860.   virtual_scan_pointer += gc_buffer_size;
  2861.   free_position = scan_position;
  2862.   END_TRANSPORT_HOOK ();
  2863.   STATISTICS_PRINT (2, "after transport");
  2864.   return;
  2865. }
  2866.  
  2867. void
  2868. DEFUN (final_reload, (to, length, noise),
  2869.        SCHEME_OBJECT * to AND unsigned long length AND char * noise)
  2870. {
  2871.   unsigned long byte_length;
  2872.  
  2873.   byte_length = (ALIGN_UP_TO_IO_PAGE (length * (sizeof (SCHEME_OBJECT))));
  2874.   END_WEAK_UPDATE_HOOK ();
  2875.   AWAIT_IO_COMPLETION ();
  2876.   START_RELOAD_HOOK ();
  2877.   load_data (gc_file_start_position, ((char *) to), byte_length,
  2878.          noise, ((Boolean *) NULL));
  2879.   END_GC_HOOK ();
  2880.   STATISTICS_PRINT (1, "after final reload");
  2881.   return;
  2882. }
  2883.  
  2884. static int
  2885.   weak_buffer_pre_read_count;
  2886.  
  2887. static long
  2888.   weak_pair_buffer_position;
  2889.  
  2890. static struct buffer_info
  2891.   * weak_pair_buffer;
  2892.  
  2893. static SCHEME_OBJECT
  2894.   weak_pair_break;
  2895.  
  2896. /* This procedure is not very smart.
  2897.  
  2898.    It does not attempt to figure out whether the position being
  2899.    requested is already being pre-read, nor does it look further down
  2900.    the weak chain list for duplicate positions, to avoid early writes.
  2901.  
  2902.    On the other hand, pre_read_buffer will ignore the request if it is
  2903.    a duplicate, and will abort a pending write if a read for the same
  2904.    position is requested.
  2905.  */   
  2906.  
  2907. static void
  2908. DEFUN (pre_read_weak_pair_buffers, (low_heap), SCHEME_OBJECT * low_heap)
  2909. {
  2910.   SCHEME_OBJECT next, * pair_addr, * obj_addr;
  2911.   long position, last_position;
  2912.  
  2913.   last_position = -1;
  2914.   next = weak_pair_break;
  2915.   while (next != EMPTY_WEAK_CHAIN)
  2916.   {
  2917.     pair_addr = (OBJECT_ADDRESS (next));
  2918.     obj_addr = (OBJECT_ADDRESS (*pair_addr++));
  2919.     if (! (obj_addr < low_heap))
  2920.     {
  2921.       position = (obj_addr - aligned_heap);
  2922.       position = (position >> gc_buffer_shift);
  2923.       position = (position << gc_buffer_byte_shift);
  2924.       position += gc_file_start_position;
  2925.  
  2926.       if ((position != last_position)
  2927.       && (position != weak_pair_buffer_position))
  2928.       {
  2929.     last_position = position;
  2930.     if ((weak_buffer_pre_read_count >= read_overlap)
  2931.         || (!(PRE_READ_BUFFER (position, gc_buffer_bytes))))
  2932.       break;
  2933.     weak_buffer_pre_read_count += 1;
  2934.       }
  2935.     }
  2936.     next = (OBJECT_NEW_TYPE (TC_NULL, (*pair_addr)));
  2937.   }
  2938.   weak_pair_break = next;
  2939.   return;
  2940. }
  2941.  
  2942. /* The following code depends on being called in between copying objects,
  2943.    so that the "free" pointer points to the middle of the free buffer,
  2944.    and thus the overlap area at the end of the free buffer is available
  2945.    as temporary storage.  In addition, because we have not yet moved free,
  2946.    next_scan_buffer has not been set even if we are in the middle of a
  2947.    scan buffer extension.
  2948.  */
  2949.  
  2950. SCHEME_OBJECT
  2951. DEFUN (read_newspace_address, (addr), SCHEME_OBJECT * addr)
  2952. {
  2953.   long position;
  2954.   unsigned long offset;
  2955.   SCHEME_OBJECT result;
  2956.  
  2957.   if ((addr >= Constant_Space) && (addr < Free_Constant))
  2958.     return (* addr);
  2959.  
  2960.   position = (addr - virtual_scan_base);
  2961.   offset = (position & gc_buffer_mask);
  2962.   position = (position >> gc_buffer_shift);
  2963.   position = (position << gc_buffer_byte_shift);
  2964.   position += gc_file_start_position;
  2965.  
  2966.   if (position > free_position)
  2967.   {
  2968.     outf_fatal
  2969.       ("\n%s (read_newspace_address): Reading outside of GC window!\n\
  2970.     \t         addr = 0x%lx;\t     position = 0x%lx.\n\
  2971.     \tscan_position = 0x%lx;\tfree_position = 0x%lx.\n",
  2972.        scheme_program_name,
  2973.        addr, position,
  2974.        scan_position, free_position);
  2975.     Microcode_Termination (TERM_EXIT);
  2976.     /*NOTREACHED*/    
  2977.   }
  2978.   if (position == scan_position)
  2979.     result = (* (scan_buffer_bottom + offset));
  2980.   else if (position == free_position)
  2981.     result = (* (free_buffer_bottom + offset));
  2982.   else if ((position == ((long) (scan_position + gc_buffer_bytes)))
  2983.        && scan_buffer_extended_p
  2984.        && ((read_overlap != 0) || (offset < gc_extra_buffer_size)))
  2985.   {
  2986.     /* Note: we need not worry about the state of extension_overlap_p,
  2987.        because if there is overlap between the scan extension and the free
  2988.        buffer, then (position == free_position) would be true,
  2989.        and that case has already been taken care of.
  2990.      */
  2991.        
  2992.     result = ((read_overlap == 0)
  2993.           ? (* (scan_buffer_top + offset))
  2994.           : (* ((GC_BUFFER_BOTTOM (next_scan_buffer)) + offset)));
  2995.   }
  2996.   else if ((read_overlap <= 0) || (position > pre_read_position))
  2997.   {
  2998.     unsigned long position2;
  2999.  
  3000.     position = (((char *) addr) - ((char *) virtual_scan_base));
  3001.     position2 = (ALIGN_DOWN_TO_IO_PAGE (position));
  3002.     offset = (position - position2);
  3003.     position2 += gc_file_start_position;
  3004.     
  3005.     load_data (position2,
  3006.            ((char *) free_buffer_top),
  3007.            IO_PAGE_SIZE,
  3008.            "a buffer for read_newspace_address",
  3009.            ((Boolean *) NULL));
  3010.     result = (* ((SCHEME_OBJECT *) (((char *) free_buffer_top) + offset)));
  3011.   }
  3012.   else
  3013.   {
  3014.     /* The buffer is pre-read or in the process of being pre-read.
  3015.        Force completion of the read, fetch the location,
  3016.        and re-queue the buffer as ready.
  3017.      */
  3018.  
  3019.     LOAD_BUFFER (next_scan_buffer, position, gc_buffer_bytes,
  3020.          "a buffer for read_newspace_address");
  3021.     result = ((GC_BUFFER_BOTTOM (next_scan_buffer)) [offset]);
  3022.     ENQUEUE_READY_BUFFER (next_scan_buffer, position, gc_buffer_bytes);
  3023.     next_scan_buffer = ((struct buffer_info *) NULL);
  3024.   }
  3025.   return (result);
  3026. }
  3027.  
  3028. static void
  3029. DEFUN (initialize_new_space_buffer, (chain, low_heap),
  3030.        SCHEME_OBJECT chain AND
  3031.        SCHEME_OBJECT * low_heap)
  3032. {
  3033.   if (read_overlap == 0)
  3034.   {
  3035.     weak_pair_break = EMPTY_WEAK_CHAIN;
  3036.     weak_pair_buffer = (INITIAL_FREE_BUFFER ());
  3037.     weak_pair_buffer_position = -1;
  3038.   }
  3039.   else
  3040.   {
  3041.     weak_pair_break = chain;
  3042.     weak_pair_buffer = ((struct buffer_info *) NULL);
  3043.     weak_pair_buffer_position = -1;
  3044.     weak_buffer_pre_read_count = 0;
  3045.     pre_read_weak_pair_buffers (low_heap);
  3046.   }
  3047. }
  3048.  
  3049. static void
  3050. DEFUN_VOID (flush_new_space_buffer)
  3051. {
  3052.   if (weak_pair_buffer_position == -1)
  3053.     return;
  3054.   DUMP_BUFFER (weak_pair_buffer, weak_pair_buffer_position,
  3055.            gc_buffer_bytes, ((Boolean *) NULL),
  3056.            "the weak pair buffer");
  3057.   weak_pair_buffer_position = -1;
  3058.   return;
  3059. }
  3060.  
  3061. static SCHEME_OBJECT *
  3062. DEFUN (guarantee_in_memory, (addr, low_heap),
  3063.        SCHEME_OBJECT * addr AND
  3064.        SCHEME_OBJECT * low_heap)
  3065. {
  3066.   long position, offset;
  3067.  
  3068.   if (addr < low_heap)
  3069.     return (addr);
  3070.  
  3071.   position = (addr - aligned_heap);
  3072.   offset = (position & gc_buffer_mask);
  3073.   position = (position >> gc_buffer_shift);
  3074.   position = (position << gc_buffer_byte_shift);
  3075.   position += gc_file_start_position;
  3076.  
  3077.   if (position != weak_pair_buffer_position)
  3078.   {
  3079.     flush_new_space_buffer ();
  3080.     LOAD_BUFFER (weak_pair_buffer, position, gc_buffer_bytes,
  3081.          "the weak pair buffer");
  3082.     weak_pair_buffer_position = position;
  3083.     if (weak_pair_break != EMPTY_WEAK_CHAIN)
  3084.     {
  3085.       weak_buffer_pre_read_count -= 1;
  3086.       pre_read_weak_pair_buffers (low_heap);
  3087.     }
  3088.   }
  3089.   return ((GC_BUFFER_BOTTOM (weak_pair_buffer)) + offset);
  3090. }
  3091.  
  3092. /* For a description of the algorithm, see memmag.c and gccode.h.
  3093.    This has been modified only to account for the fact that new space
  3094.    is on disk.  Old space is in memory.
  3095.    Note: Compiled_BH requires the names Temp and Old!
  3096. */
  3097.  
  3098. static SCHEME_OBJECT
  3099. DEFUN (update_weak_pointer, (Temp, low_heap),
  3100.        SCHEME_OBJECT Temp AND
  3101.        SCHEME_OBJECT * low_heap)
  3102. {
  3103.   SCHEME_OBJECT * Old;
  3104.  
  3105.   switch (GC_Type (Temp))
  3106.   {
  3107.     case GC_Non_Pointer:
  3108.       return (Temp);
  3109.   
  3110.     case GC_Special:
  3111.       if ((OBJECT_TYPE (Temp)) != TC_REFERENCE_TRAP)
  3112.     /* No other special type makes sense here. */
  3113.     goto fail;
  3114.       if ((OBJECT_DATUM (Temp)) <= TRAP_MAX_IMMEDIATE)
  3115.     return (Temp);
  3116.       /* Otherwise, it is a pointer.  Fall through */
  3117.  
  3118.     /* Normal pointer types, the broken heart is in the first word.
  3119.        Note that most special types are treated normally here.
  3120.        The BH code updates *Scan if the object has been relocated.
  3121.        Otherwise it falls through and we replace it with a full SHARP_F.
  3122.        Eliminating this assignment would keep old data (pl. of datum).
  3123.      */
  3124.     case GC_Cell:
  3125.     case GC_Pair:
  3126.     case GC_Triple:
  3127.     case GC_Quadruple:
  3128.     case GC_Vector:
  3129.       Old = (OBJECT_ADDRESS (Temp));
  3130.       if (Old < low_heap)
  3131.     return (Temp);
  3132.  
  3133.       if ((OBJECT_TYPE (*Old)) == TC_BROKEN_HEART)
  3134.     return (MAKE_OBJECT_FROM_OBJECTS (Temp, *Old));
  3135.       else
  3136.     return (SHARP_F);
  3137.  
  3138.     case GC_Compiled:
  3139.       Old = (OBJECT_ADDRESS (Temp));
  3140.       if (Old < low_heap)
  3141.     return (Temp);
  3142.       Compiled_BH (false, { return Temp; });
  3143.       return (SHARP_F);
  3144.  
  3145.     default:            /* Non Marked Headers and Broken Hearts */
  3146.     case GC_Undefined:
  3147.     fail:
  3148.       outf_error ("\n%s (update_weak_pointer): Clearing bad object 0x%08lx.\n",
  3149.           scheme_program_name, Temp);
  3150.       return (SHARP_F);
  3151.   }
  3152. }
  3153.  
  3154. SCHEME_OBJECT
  3155.   Weak_Chain,
  3156.   * weak_pair_stack_ptr,
  3157.   * weak_pair_stack_limit;
  3158.  
  3159. void
  3160. DEFUN (initialize_weak_pair_transport, (limit), SCHEME_OBJECT * limit)
  3161. {
  3162.   Weak_Chain = EMPTY_WEAK_CHAIN;
  3163.   weak_pair_stack_ptr = Stack_Pointer;
  3164.   weak_pair_stack_limit = (limit + 1); /* in case it's odd */
  3165.   return;
  3166. }
  3167.  
  3168. void
  3169. DEFUN (fix_weak_chain_1, (low_heap), SCHEME_OBJECT * low_heap)
  3170. {
  3171.   fast SCHEME_OBJECT chain, * old_weak_cell, * scan, * ptr, * limit;
  3172.  
  3173.   chain = Weak_Chain;
  3174.   initialize_new_space_buffer (chain, low_heap);
  3175.  
  3176.   limit = Stack_Pointer;
  3177.   for (ptr = weak_pair_stack_ptr; ptr < limit ; ptr += 2)
  3178.     *ptr = (update_weak_pointer (*ptr, low_heap));
  3179.  
  3180.   while (chain != EMPTY_WEAK_CHAIN)
  3181.   {
  3182.     old_weak_cell = (OBJECT_ADDRESS (Weak_Chain));
  3183.     scan
  3184.       = (guarantee_in_memory ((OBJECT_ADDRESS (*old_weak_cell++)), low_heap));
  3185.     Weak_Chain = (* old_weak_cell);
  3186.     *scan
  3187.       = (update_weak_pointer
  3188.      ((MAKE_OBJECT_FROM_OBJECTS (Weak_Chain, (* scan))), low_heap));
  3189.     Weak_Chain = (OBJECT_NEW_TYPE (TC_NULL, Weak_Chain));
  3190.   }
  3191.   flush_new_space_buffer ();
  3192.   Weak_Chain = chain;
  3193.   return;
  3194. }
  3195.  
  3196. void
  3197. DEFUN_VOID (fix_weak_chain_2)
  3198. {
  3199.   fast SCHEME_OBJECT * ptr, * limit, new_car, * addr;
  3200.  
  3201.   limit = Stack_Pointer;
  3202.   for (ptr = weak_pair_stack_ptr; ptr < limit ; )
  3203.   {
  3204.     new_car = *ptr++;
  3205.     addr = ((SCHEME_OBJECT *) (*ptr++));
  3206.     if (new_car != SHARP_F)
  3207.       *addr = new_car;
  3208.   }
  3209.   weak_pair_stack_ptr = limit;
  3210.   return;
  3211. }
  3212.  
  3213. long
  3214. DEFUN (GC_relocate_root, (free_buffer_ptr), SCHEME_OBJECT ** free_buffer_ptr)
  3215. {
  3216.   long skip;
  3217.   SCHEME_OBJECT * initial_free_buffer, * free_buffer;
  3218.  
  3219.   free_buffer = * free_buffer_ptr;
  3220.   initial_free_buffer = free_buffer;
  3221.   SET_MEMTOP (Heap_Top - GC_Reserve);
  3222.  
  3223.   /* Save the microcode registers so that they can be relocated */
  3224.  
  3225.   Set_Fixed_Obj_Slot (Precious_Objects, SHARP_F);
  3226.   Set_Fixed_Obj_Slot (Lost_Objects_Base, SHARP_F);
  3227.  
  3228.   *free_buffer++ = Fixed_Objects;
  3229.   *free_buffer++ = (MAKE_POINTER_OBJECT (UNMARKED_HISTORY_TYPE, History));
  3230.   *free_buffer++ = (Get_Current_Stacklet ());
  3231.   *free_buffer++ = ((Prev_Restore_History_Stacklet == NULL) ?
  3232.             SHARP_F :
  3233.             (MAKE_POINTER_OBJECT (TC_CONTROL_POINT,
  3234.                       Prev_Restore_History_Stacklet)));
  3235.  
  3236.   *free_buffer++ = Current_State_Point;
  3237.   *free_buffer++ = Fluid_Bindings;
  3238.   skip = (free_buffer - initial_free_buffer);
  3239.   if (free_buffer >= free_buffer_top)
  3240.     free_buffer = (dump_and_reset_free_buffer (free_buffer, 0));
  3241.   * free_buffer_ptr = free_buffer;
  3242.   return (skip);
  3243. }
  3244.  
  3245. void
  3246. DEFUN (GC_end_root_relocation, (root, root2),
  3247.        SCHEME_OBJECT * root AND SCHEME_OBJECT * root2)
  3248. {
  3249.   /* Make the microcode registers point to the copies in new-space. */
  3250.  
  3251.   Fixed_Objects = *root++;
  3252.   Set_Fixed_Obj_Slot (Precious_Objects, *root2);
  3253.   Set_Fixed_Obj_Slot
  3254.     (Lost_Objects_Base, (LONG_TO_UNSIGNED_FIXNUM (ADDRESS_TO_DATUM (root2))));
  3255.  
  3256.   History = (OBJECT_ADDRESS (*root++));
  3257.   Set_Current_Stacklet (* root);
  3258.   root += 1;
  3259.   if ((* root) != SHARP_F)
  3260.     Prev_Restore_History_Stacklet = (OBJECT_ADDRESS (*root++));
  3261.   else
  3262.   {
  3263.     Prev_Restore_History_Stacklet = NULL;
  3264.     root += 1;
  3265.   }
  3266.   Current_State_Point = *root++;
  3267.   Fluid_Bindings = *root++;
  3268.   Free_Stacklets = NULL;
  3269.   COMPILER_TRANSPORT_END ();
  3270.   CLEAR_INTERRUPT (INT_GC);
  3271.   return;
  3272. }
  3273.  
  3274. /* Here is the set up for the full garbage collection:
  3275.  
  3276.    - First it makes the constant space and stack into one large area
  3277.    by "hiding" the gap between them with a non-marked header.
  3278.  
  3279.    - Then it saves away all the relevant microcode registers into new
  3280.    space, making this the root for garbage collection.
  3281.  
  3282.    - Then it does the actual garbage collection in 4 steps:
  3283.      1) Trace constant space.
  3284.      2) Trace objects pointed out by the root and constant space.
  3285.      3) Trace the precious objects, remembering where consing started.
  3286.      4) Update all weak pointers.
  3287.  
  3288.    - Load new space to memory.
  3289.  
  3290.    - Finally it restores the microcode registers from the copies in
  3291.    new space.
  3292. */
  3293.  
  3294. void
  3295. DEFUN (GC, (weak_pair_transport_initialized_p),
  3296.        int weak_pair_transport_initialized_p)
  3297. {
  3298.   SCHEME_OBJECT * root;
  3299.   SCHEME_OBJECT * end_of_constant_area;
  3300.   SCHEME_OBJECT the_precious_objects;
  3301.   SCHEME_OBJECT * root2;
  3302.   SCHEME_OBJECT * free_buffer;
  3303.   SCHEME_OBJECT * block_start;
  3304.   SCHEME_OBJECT * saved_ctop;
  3305.   long skip_length;
  3306.  
  3307.   saved_ctop = Constant_Top;
  3308.   if (((Constant_Top - Free_Constant) < CONSTANT_SPACE_FUDGE)
  3309.       && (update_allocator_parameters (Free_Constant)))
  3310.     Constant_Top = saved_ctop;
  3311.  
  3312.   if (!weak_pair_transport_initialized_p)
  3313.     initialize_weak_pair_transport (Stack_Bottom);
  3314.  
  3315.   free_buffer = (initialize_free_buffer ());
  3316.   Free = Heap_Bottom;
  3317.   ALIGN_FLOAT (Free);
  3318.   block_start = aligned_heap;
  3319.   skip_length = (Free - block_start);
  3320.   free_buffer += skip_length;
  3321.  
  3322.   Terminate_Old_Stacklet ();
  3323.   SEAL_CONSTANT_SPACE ();
  3324.   end_of_constant_area = (CONSTANT_AREA_END ());
  3325.   the_precious_objects = (Get_Fixed_Obj_Slot (Precious_Objects));
  3326.   root = Free;
  3327.  
  3328.   /* The 4 step GC */
  3329.  
  3330.   Free += (GC_relocate_root (&free_buffer));
  3331.  
  3332.   {
  3333.     SCHEME_OBJECT * new_scan
  3334.       = (gc_loop ((CONSTANT_AREA_START ()), (&free_buffer), (&Free),
  3335.           Constant_Top, NORMAL_GC, 0));
  3336.     if (new_scan != end_of_constant_area)
  3337.       {
  3338.     gc_death (TERM_EXIT, "gc_loop ended too early", new_scan, free_buffer);
  3339.     /*NOTREACHED*/
  3340.       }
  3341.   }
  3342.  
  3343.   {
  3344.     SCHEME_OBJECT * scan
  3345.       = (gc_loop (((initialize_scan_buffer (block_start)) + skip_length),
  3346.           (&free_buffer), (&Free), Constant_Top, NORMAL_GC, 1));
  3347.  
  3348.     root2 = Free;
  3349.     (*free_buffer++) = the_precious_objects;
  3350.     Free += 1;
  3351.     if (free_buffer >= free_buffer_top)
  3352.       free_buffer = (dump_and_reset_free_buffer (free_buffer, 0));
  3353.  
  3354.     gc_loop (scan, (&free_buffer), (&Free), Constant_Top, NORMAL_GC, 1);
  3355.   }
  3356.  
  3357.   end_transport (0);
  3358.   fix_weak_chain_1 (Constant_Top);
  3359.  
  3360.   /* Load new space into memory. */
  3361.   final_reload (block_start, (Free - block_start), "new space");
  3362.  
  3363.   fix_weak_chain_2 ();
  3364.   GC_end_root_relocation (root, root2);
  3365.   Constant_Top = saved_ctop;
  3366.   SET_CONSTANT_TOP ();
  3367. }
  3368.  
  3369. /* (GARBAGE-COLLECT SLACK)
  3370.    Requests a garbage collection leaving the specified amount of slack
  3371.    for the top of heap check on the next GC.  The primitive ends by
  3372.    invoking the GC daemon if there is one.
  3373. */
  3374.  
  3375. DEFINE_PRIMITIVE ("GARBAGE-COLLECT", Prim_garbage_collect, 1, 1, 0)
  3376. {
  3377.   extern unsigned long gc_counter;
  3378.   SCHEME_OBJECT daemon;
  3379.   PRIMITIVE_HEADER (1);
  3380.   PRIMITIVE_CANONICALIZE_CONTEXT ();
  3381.  
  3382.   STACK_SANITY_CHECK ("GC");
  3383.   if (Free > Heap_Top)
  3384.     termination_gc_out_of_space ();
  3385.  
  3386.   GC_Reserve = (arg_nonnegative_integer (1));
  3387.   POP_PRIMITIVE_FRAME (1);
  3388.  
  3389.   ENTER_CRITICAL_SECTION ("garbage collector");
  3390.   run_pre_gc_hooks ();
  3391.   gc_counter += 1;
  3392.   GC (0);
  3393.   run_post_gc_hooks ();
  3394.   daemon = (Get_Fixed_Obj_Slot (GC_Daemon));
  3395.  
  3396.  Will_Push (CONTINUATION_SIZE);
  3397.   Store_Return (RC_NORMAL_GC_DONE);
  3398.   Store_Expression (LONG_TO_UNSIGNED_FIXNUM (MemTop - Free));
  3399.   Save_Cont ();
  3400.  Pushed ();
  3401.  
  3402.   RENAME_CRITICAL_SECTION ("garbage collector daemon");
  3403.   if (daemon == SHARP_F)
  3404.     PRIMITIVE_ABORT (PRIM_POP_RETURN);
  3405.     /*NOTREACHED*/
  3406.  
  3407.  Will_Push (2);
  3408.   STACK_PUSH (daemon);
  3409.   STACK_PUSH (STACK_FRAME_HEADER);
  3410.  Pushed ();
  3411.   PRIMITIVE_ABORT (PRIM_APPLY);
  3412.   /*NOTREACHED*/
  3413.   return (0);
  3414. }
  3415.  
  3416. #ifdef RECORD_GC_STATISTICS
  3417.  
  3418. static void
  3419. DEFUN_VOID (statistics_clear)
  3420. {
  3421.   int cntr, arlen;
  3422.   struct bch_GC_statistic * ptr;
  3423.  
  3424.   arlen = (((sizeof (all_gc_statistics))
  3425.         / (sizeof (struct bch_GC_statistic)))
  3426.        - 1);
  3427.   for (cntr = 0, ptr = &all_gc_statistics[0]; cntr < arlen; cntr++, ptr++)
  3428.     (* (ptr->counter)) = 0;
  3429.   return;
  3430. }
  3431.  
  3432. static int statistics_print_level = 0;
  3433.  
  3434. static void
  3435. DEFUN (statistics_print, (level, noise), int level AND char * noise)
  3436. {
  3437.   char format[30];
  3438.   int cntr, arlen, len, name_len;
  3439.   struct bch_GC_statistic * ptr;
  3440.  
  3441.   if (level > statistics_print_level)
  3442.     return;
  3443.   arlen = (((sizeof (all_gc_statistics))
  3444.         / (sizeof (struct bch_GC_statistic)))
  3445.        - 1);
  3446.   name_len = -1;
  3447.   for (cntr = 0, ptr = &all_gc_statistics[0];
  3448.        cntr < arlen;
  3449.        cntr++, ptr++)
  3450.     if ((* (ptr->counter)) != 0L)
  3451.     {
  3452.       len = (strlen (ptr->name));
  3453.       if (len > name_len)
  3454.     name_len = len;
  3455.     }
  3456.  
  3457.   if (name_len >= 0)
  3458.   {
  3459.     sprintf (&format[0], "\t%%-%ds : %%ld\n", name_len);
  3460.  
  3461.     outf_console ("\nGC I/O statistics %s:\n", noise);
  3462.     for (cntr = 0, ptr = &all_gc_statistics[0]; cntr < arlen; cntr++, ptr++)
  3463.       if ((* (ptr->counter)) != 0L)
  3464.     outf_console (&format[0], ptr->name, (* (ptr->counter)));
  3465.     outf_flush_console ();
  3466.   }
  3467.   return;
  3468. }
  3469. #endif /* RECORD_GC_STATISTICS */
  3470.  
  3471. static SCHEME_OBJECT
  3472. DEFUN_VOID (statistics_names)
  3473. {
  3474.   SCHEME_OBJECT vector, * scan;
  3475.   struct bch_GC_statistic * ptr;
  3476.   int len, cntr;
  3477.  
  3478.   len = (((sizeof (all_gc_statistics))
  3479.       / (sizeof (struct bch_GC_statistic)))
  3480.      - 1);
  3481.   if (len == 0)
  3482.     return (SHARP_F);
  3483.  
  3484.   vector = (allocate_marked_vector (TC_VECTOR, len, true));
  3485.   for (cntr = 0, ptr = &all_gc_statistics[0], scan = (VECTOR_LOC (vector, 0));
  3486.        cntr < len;
  3487.        cntr++, ptr++)
  3488.     *scan++ = (char_pointer_to_string ((unsigned char *) ptr->name));
  3489.   return (vector);
  3490. }
  3491.  
  3492. static void
  3493. DEFUN_VOID (statistics_read)
  3494. {
  3495.   SCHEME_OBJECT vector, *scan;
  3496.   struct bch_GC_statistic * ptr;
  3497.   int len, cntr;
  3498.  
  3499.   len = (((sizeof (all_gc_statistics))
  3500.       / (sizeof (struct bch_GC_statistic)))
  3501.      - 1);
  3502.   if (len == 0)
  3503.     signal_error_from_primitive (ERR_UNDEFINED_PRIMITIVE);
  3504.  
  3505.   vector = (VECTOR_ARG (1));
  3506.   if (len != ((int) (VECTOR_LENGTH (vector))))
  3507.     error_bad_range_arg (1);
  3508.   
  3509.   for (cntr = 0, ptr = &all_gc_statistics[0], scan = (VECTOR_LOC (vector, 0));
  3510.        cntr < len;
  3511.        cntr++, ptr++)
  3512.     *scan++ = (long_to_integer (* (ptr->counter)));
  3513.   return;
  3514. }
  3515.  
  3516. /* Additional primitives for statistics collection and
  3517.    manipulation of parameters from Scheme
  3518.  */
  3519.  
  3520. DEFINE_PRIMITIVE ("BCHSCHEME-STATISTICS-NAMES", Prim_bchscheme_stat_names, 0, 0, 0)
  3521. {
  3522.   PRIMITIVE_HEADER (0);
  3523.   PRIMITIVE_RETURN (statistics_names ());
  3524. }
  3525.  
  3526. DEFINE_PRIMITIVE ("BCHSCHEME-STATISTICS-READ!", Prim_bchscheme_read_stats, 1, 1, 0)
  3527. {
  3528.   PRIMITIVE_HEADER (1);
  3529.   statistics_read ();
  3530.   PRIMITIVE_RETURN (UNSPECIFIC);
  3531. }
  3532.  
  3533. /* There are other parameters that could be set, especially the drone program
  3534.    to run, and the file to gc from, but...
  3535.  */
  3536.  
  3537. #ifndef GET_SLEEP_DELTA
  3538. #define GET_SLEEP_DELTA()    -1
  3539. #define SET_SLEEP_DELTA(v)    do { } while (0)
  3540. #endif
  3541.  
  3542. #define N_PARAMS    6
  3543.  
  3544. DEFINE_PRIMITIVE ("BCHSCHEME-PARAMETERS-GET", Prim_bchscheme_get_params, 0, 0, 0)
  3545. {
  3546.   SCHEME_OBJECT vector;
  3547.   PRIMITIVE_HEADER (0);
  3548.  
  3549.   vector = (allocate_marked_vector (TC_VECTOR, N_PARAMS, true));
  3550.  
  3551.   VECTOR_SET (vector, 0,
  3552.           (long_to_integer ((long) CAN_RECONFIGURE_GC_BUFFERS)));
  3553.   VECTOR_SET (vector, 1, (long_to_integer ((long) gc_buffer_size)));
  3554.   VECTOR_SET (vector, 2, (long_to_integer ((long) read_overlap)));
  3555.   VECTOR_SET (vector, 3, (long_to_integer ((long) write_overlap)));
  3556.   VECTOR_SET (vector, 4, (long_to_integer ((long) (GET_SLEEP_DELTA ()))));
  3557.   VECTOR_SET (vector, 5, (char_pointer_to_string
  3558.               ((unsigned char *) drone_file_name)));
  3559.  
  3560.   PRIMITIVE_RETURN (vector);
  3561. }
  3562.  
  3563. #if CAN_RECONFIGURE_GC_BUFFERS
  3564. static long
  3565. DEFUN (bchscheme_long_parameter, (vector, index),
  3566.        SCHEME_OBJECT vector AND int index)
  3567. {
  3568.   SCHEME_OBJECT temp;
  3569.   long value;
  3570.  
  3571.   temp = (VECTOR_REF (vector, index));
  3572.   if ((! (INTEGER_P (temp))) || (! (integer_to_long_p (temp))))
  3573.     error_bad_range_arg (1);
  3574.   value = (integer_to_long (temp));
  3575.   if (value < 0)
  3576.     error_bad_range_arg (1);
  3577.   return (value);
  3578. }
  3579. #endif /* CAN_RECONFIGURE_GC_BUFFERS */
  3580.  
  3581. DEFINE_PRIMITIVE ("BCHSCHEME-PARAMETERS-SET!", Prim_bchscheme_set_params, 1, 1, 0)
  3582. {
  3583.   PRIMITIVE_HEADER (1);
  3584.  
  3585. #if !CAN_RECONFIGURE_GC_BUFFERS
  3586.   signal_error_from_primitive (ERR_UNDEFINED_PRIMITIVE);
  3587.   /*NOTREACHED*/
  3588.   return (0);
  3589. #else
  3590.  
  3591.   {
  3592.     char * new_drone_ptr;
  3593.     SCHEME_OBJECT vector, new_drone;
  3594.     long
  3595.       new_buffer_size, new_read_overlap,
  3596.       new_write_overlap, new_sleep_period,
  3597.       old_buffer_size = gc_buffer_size,
  3598.       old_buffer_shift = gc_buffer_shift;
  3599.  
  3600.     vector = (VECTOR_ARG (1));
  3601.     if ((VECTOR_LENGTH (vector)) != N_PARAMS)
  3602.       error_bad_range_arg (1);
  3603.  
  3604.     /* Slot 0 ignored. */
  3605.     new_buffer_size = (bchscheme_long_parameter (vector, 1));
  3606.     new_read_overlap = (bchscheme_long_parameter (vector, 2));
  3607.     new_write_overlap = (bchscheme_long_parameter (vector, 3));
  3608.     new_sleep_period = (bchscheme_long_parameter (vector, 4));
  3609.     new_drone = (VECTOR_REF (vector, 5));
  3610.     if (! (STRING_P (new_drone)))
  3611.       error_bad_range_arg (1);
  3612.     if ((STRING_LENGTH (new_drone)) == 0)
  3613.       new_drone_ptr = ((char *) NULL);
  3614.     else
  3615.     {
  3616.       new_drone_ptr = ((char *) (malloc ((STRING_LENGTH (new_drone)) + 1)));
  3617.       if (new_drone_ptr != ((char *) NULL))
  3618.     strcpy (new_drone_ptr, ((char *) (STRING_LOC (new_drone, 0))));
  3619.     }
  3620.  
  3621.     if (new_buffer_size != old_buffer_size)
  3622.     {
  3623.       int power = (next_exponent_of_two (new_buffer_size));
  3624.  
  3625.       if (((1L << power) != new_buffer_size)
  3626.       || ((set_gc_buffer_sizes (power)) != 0))
  3627.     error_bad_range_arg (1);
  3628.       if (! (recompute_gc_end_position ()))
  3629.       {
  3630.     set_gc_buffer_sizes (old_buffer_shift);
  3631.     error_bad_range_arg (1);
  3632.       }
  3633.     }
  3634.  
  3635.     BUFFER_SHUTDOWN (0);
  3636.     SET_SLEEP_DELTA (new_sleep_period);
  3637.     if ((drone_file_name != ((char *) NULL))
  3638.     && (drone_file_name != option_gc_drone))
  3639.       free ((PTR) drone_file_name);
  3640.  
  3641.     if ((RE_INITIALIZE_GC_BUFFERS (0,
  3642.                    Highest_Allocated_Address,
  3643.                    ((sizeof (SCHEME_OBJECT))
  3644.                     * (CEILING ((saved_heap_size
  3645.                          + saved_constant_size),
  3646.                         gc_buffer_size))),
  3647.                    new_read_overlap,
  3648.                    new_write_overlap,
  3649.                    new_drone_ptr))
  3650.     == 0)
  3651.       PRIMITIVE_RETURN (UNSPECIFIC);
  3652.     else
  3653.     {
  3654.       if (new_buffer_size != old_buffer_size)
  3655.       {
  3656.     set_gc_buffer_sizes (old_buffer_shift);
  3657.     recompute_gc_end_position ();
  3658.       }
  3659.  
  3660.       BUFFER_SHUTDOWN (0);
  3661.       if (new_drone_ptr != ((char *) NULL))
  3662.     free (new_drone_ptr);
  3663.  
  3664.       if ((RE_INITIALIZE_GC_BUFFERS (0,
  3665.                      Highest_Allocated_Address,
  3666.                      (saved_heap_size
  3667.                       * (sizeof (SCHEME_OBJECT))),
  3668.                      0, 0,
  3669.                      option_gc_drone)) != 0)
  3670.     Microcode_Termination (TERM_EXIT);
  3671.       else
  3672.     signal_error_from_primitive (ERR_EXTERNAL_RETURN);
  3673.     }
  3674.     /*NOTREACHED*/
  3675.     return (0);
  3676.   }
  3677. #endif /* (CAN_RECONFIGURE_GC_BUFFERS == 0) */
  3678. }
  3679.