From: Matt Birkholz <puck@birchwood-abbey.net>
Date: Fri, 19 Dec 2014 23:53:42 +0000 (-0700)
Subject: smp: Add configure option --enable-smp.
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=b9a4a7b;p=mit-scheme.git

smp: Add configure option --enable-smp.

Arrange for multiple Scheme machines, "processors" (pthreads), to
share the heap.  Each gets its own stack and "local" heap areas.
Gc-flips trace the stacks and evacuate the local heaps into the shared
heap.  The dump-band primitive now works like half a gc-flip,
evacuating the local heaps and saving the shared heap to disk before
the primitive gc daemons can start consing in a local heap again.
---

diff --git a/src/microcode/boot.c b/src/microcode/boot.c
index 0c00674d6..3fccf6dd9 100644
--- a/src/microcode/boot.c
+++ b/src/microcode/boot.c
@@ -116,9 +116,18 @@ main_name (int argc, const char ** argv)
   reload_saved_string_length = 0;
   read_command_line_options (argc, argv);
 
+#ifndef ENABLE_SMP
   setup_memory ((BLOCKS_TO_BYTES (option_heap_size)),
 		(BLOCKS_TO_BYTES (option_stack_size)),
 		(BLOCKS_TO_BYTES (option_constant_size)));
+#else
+  setup_memory ((BLOCKS_TO_BYTES (option_heap_size)),
+		(BLOCKS_TO_BYTES (option_constant_size)),
+		option_processor_count,
+		(BLOCKS_TO_BYTES (option_processor_heap_size)),
+		(BLOCKS_TO_BYTES (option_stack_size)));
+  smp_initialize (option_processor_count);
+#endif
 
   initialize_primitives ();
   compiler_initialize (option_fasl_file != 0);
diff --git a/src/microcode/cmpint.c b/src/microcode/cmpint.c
index 521e94d47..5774d1b22 100644
--- a/src/microcode/cmpint.c
+++ b/src/microcode/cmpint.c
@@ -1717,6 +1717,10 @@ plausible_cc_block_p (SCHEME_OBJECT * block)
     SCHEME_OBJECT * block_end = ((CC_BLOCK_ADDR_END (block)) - 1);
     return
       ((((HEAP_ADDRESS_P (block)) && (HEAP_ADDRESS_P (block_end)))
+#ifdef ENABLE_SMP
+	|| ((SHARED_HEAP_ADDRESS_P (block))
+	    && (SHARED_HEAP_ADDRESS_P (block_end)))
+#endif
 	|| ((ADDRESS_IN_CONSTANT_P (block))
 	    && (ADDRESS_IN_CONSTANT_P (block_end))))
        && (ENVIRONMENT_P (*block_end)));
diff --git a/src/microcode/configure.ac b/src/microcode/configure.ac
index c7f4b0b13..585a215d8 100644
--- a/src/microcode/configure.ac
+++ b/src/microcode/configure.ac
@@ -130,6 +130,11 @@ AC_ARG_ENABLE([native-code],
 	[Support native compiled code if available [[yes]]]))
 : ${enable_native_code='yes'}
 
+AC_ARG_ENABLE([smp],
+    AS_HELP_STRING([--enable-smp],
+	[Support multi-processing if available [[no]]]))
+: ${enable_smp='no'}
+
 AC_ARG_WITH([openssl],
     AS_HELP_STRING([--with-openssl],
 	[Use OpenSSL crypto library if available [[yes]]]))
@@ -1045,6 +1050,19 @@ if test ${enable_valgrind_mode} != no; then
     M4_FLAGS="${M4_FLAGS} -P VALGRIND_MODE,1"
 fi
 
+dnl Check for pthreads.
+if test "${enable_smp}" != no; then
+    AC_CHECK_HEADER([pthread.h],
+	[
+	AC_DEFINE([ENABLE_SMP], [1],
+	    [Define to 1 for Symmetric Multiple Processor support.])
+	CFLAGS="-pthread ${CFLAGS}"
+	LDFLAGS="-pthread ${LDFLAGS}"
+	M4_FLAGS="${M4_FLAGS} -P ENABLE_SMP,1"
+	],
+	AC_MSG_ERROR([SMP support requires <pthread.h>]))
+fi
+
 OPTIONAL_BASES="${OPTIONAL_BASES} cmpint cmpintmd comutl"
 
 case ${mit_scheme_native_code} in
diff --git a/src/microcode/confshared.h b/src/microcode/confshared.h
index 307cddc04..ae091b7f1 100644
--- a/src/microcode/confshared.h
+++ b/src/microcode/confshared.h
@@ -693,4 +693,8 @@ extern void win32_stack_reset (void);
 #  define HEAP_FREE(address)
 #endif
 
+#ifndef ENABLE_SMP
+#define __thread
+#endif
+
 #endif /* SCM_CONFSHARED_H */
diff --git a/src/microcode/debug.c b/src/microcode/debug.c
index 5e7a36d4a..22c2d7993 100644
--- a/src/microcode/debug.c
+++ b/src/microcode/debug.c
@@ -952,7 +952,12 @@ verify_heap (void)
 {
   bool c = verify_heap_area ("constants", constant_start, constant_alloc_next);
   bool h = verify_heap_area ("heap", heap_start, Free);
+#ifdef ENABLE_SMP
+  bool s = verify_heap_area ("shared heap",shared_heap_start,shared_heap_free);
+  return (c && h && s);
+#else
   return (c && h);
+#endif
 }
 
 #else  /* !ENABLE_DEBUGGING_TOOLS */
diff --git a/src/microcode/extern.h b/src/microcode/extern.h
index e55cd1736..515abce7a 100644
--- a/src/microcode/extern.h
+++ b/src/microcode/extern.h
@@ -143,6 +143,12 @@ extern SCHEME_OBJECT * Free_primitive;
 extern SCHEME_OBJECT * heap_alloc_limit;
 extern SCHEME_OBJECT * heap_start;
 extern SCHEME_OBJECT * heap_end;
+#ifdef ENABLE_SMP
+extern SCHEME_OBJECT * p0_heap_start;
+extern SCHEME_OBJECT * shared_heap_start;
+extern SCHEME_OBJECT * shared_heap_free;
+extern SCHEME_OBJECT * shared_heap_end;
+#endif
 
 extern SCHEME_OBJECT * stack_pointer;
 extern SCHEME_OBJECT * stack_guard;
@@ -184,10 +190,6 @@ extern const char * OS_Variant;
 extern struct obstack scratch_obstack;
 extern struct obstack ffi_obstack;
 
-extern unsigned long n_heap_blocks;
-extern unsigned long n_constant_blocks;
-extern unsigned long n_stack_blocks;
-
 extern SCHEME_OBJECT * memory_block_start;
 extern SCHEME_OBJECT * memory_block_end;
 
@@ -195,6 +197,9 @@ extern unsigned long heap_reserved;
 
 /* Amount of space needed when GC requested */
 extern unsigned long gc_space_needed;
+#ifdef ENABLE_SMP
+extern unsigned long gc_shared_space_needed;
+#endif
 
 /* Number of new ephemerons requested from the GC.  */
 extern unsigned long n_ephemerons_requested;
@@ -320,7 +325,12 @@ extern unsigned char * lookup_external_string (SCHEME_OBJECT, unsigned long *);
 extern bool object_in_constant_space_p (SCHEME_OBJECT);
 extern SCHEME_OBJECT * copy_to_constant_space (SCHEME_OBJECT *, unsigned long);
 
+#ifndef ENABLE_SMP
 extern void setup_memory (unsigned long, unsigned long, unsigned long);
+#else
+extern void setup_memory (unsigned long, unsigned long,
+			  int, unsigned long, unsigned long);
+#endif
 extern void reset_memory (void);
 
 /* Utilities for primitives */
@@ -356,6 +366,9 @@ extern void termination_end_of_computation (void) NORETURN;
 extern void termination_trap (void) NORETURN;
 extern void termination_no_error_handler (void) NORETURN;
 extern void termination_gc_out_of_space (void) NORETURN;
+#ifdef ENABLE_SMP
+extern void termination_gc_out_of_shared_space (void) NORETURN;
+#endif
 extern void termination_eof (void) NORETURN;
 extern void termination_signal (const char * signal_name) NORETURN;
 
diff --git a/src/microcode/fasdump.c b/src/microcode/fasdump.c
index 07b83c9d5..e04c5b7fa 100644
--- a/src/microcode/fasdump.c
+++ b/src/microcode/fasdump.c
@@ -32,6 +32,7 @@ USA.
 #include "osio.h"
 #include "osfile.h"
 #include "osfs.h"
+#include "ossmp.h"
 #define In_Fasdump
 #include "gccode.h"
 #include "trap.h"
@@ -103,6 +104,14 @@ static void initialize_fasl_header (bool, bool);
 static void finalize_fasl_header (unsigned long);
 static bool write_fasl_file
   (SCHEME_OBJECT *, SCHEME_OBJECT *, fasl_file_handle_t);
+
+#ifndef ENABLE_SMP
+#define HEAP_START heap_start
+#define HEAP_END heap_end
+#else
+#define HEAP_START shared_heap_start
+#define HEAP_END shared_heap_end
+#endif
 
 /* FASDUMP:
 
@@ -111,9 +120,8 @@ static bool write_fasl_file
    copy must have the global value cell of symbols set to UNBOUND.
    Second, and worse, all the broken hearts created during the process
    must be restored to their original values.  This last is done by
-   growing the copy of the object in the bottom of spare heap, keeping
-   track of the locations of broken hearts and original contents at
-   the top of the spare heap.  */
+   keeping track of the locations of broken hearts and original
+   contents in a malloced/realloced array of fixup_ts. */
 
 DEFINE_PRIMITIVE ("PRIMITIVE-FASDUMP", Prim_prim_fasdump, 3, 3,
 		  "(OBJECT NAMESTRING FLAG)\n\
@@ -141,7 +149,7 @@ at by compiled code are ignored (and discarded).")
     error_bad_range_arg (2);
   transaction_record_action (tat_always, close_fasl_file, (&ff_info));
 
-  open_tospace (heap_start);
+  open_tospace (HEAP_START);
   /* This must be _before_ the call to initialize_fixups(): */
   transaction_record_action (tat_abort, abort_fasdump, 0);
   initialize_fixups ();
@@ -183,6 +191,7 @@ at by compiled code are ignored (and discarded).")
 
   ok = ((write_fasl_header (fh, (ff_info . handle)))
 	&& (save_tospace (save_tospace_write, (&ff_info))));
+
   transaction_commit ();	/* 1 */
 
   COMPARE_GC_VARS ();
@@ -222,6 +231,11 @@ static SCHEME_OBJECT * fasdump_saved_stack_pointer;
 static SCHEME_OBJECT * fasdump_saved_stack_guard;
 static SCHEME_OBJECT * fasdump_saved_stack_start;
 static SCHEME_OBJECT * fasdump_saved_stack_end;
+#ifdef ENABLE_SMP
+static SCHEME_OBJECT * fasdump_saved_shared_heap_free;
+static SCHEME_OBJECT * fasdump_saved_shared_heap_start;
+static SCHEME_OBJECT * fasdump_saved_shared_heap_end;
+#endif
 static SCHEME_OBJECT * fasdump_saved_constant_alloc_next;
 static SCHEME_OBJECT * fasdump_saved_constant_start;
 static SCHEME_OBJECT * fasdump_saved_constant_end;
@@ -239,6 +253,11 @@ save_gc_vars (void)
   SAVE_GC_VAR (stack_guard);
   SAVE_GC_VAR (stack_start);
   SAVE_GC_VAR (stack_end);
+#ifdef ENABLE_SMP
+  SAVE_GC_VAR (shared_heap_free);
+  SAVE_GC_VAR (shared_heap_start);
+  SAVE_GC_VAR (shared_heap_end);
+#endif
   SAVE_GC_VAR (constant_alloc_next);
   SAVE_GC_VAR (constant_start);
   SAVE_GC_VAR (constant_end);
@@ -262,6 +281,11 @@ compare_gc_vars (void)
   COMPARE_GC_VAR (stack_guard);
   COMPARE_GC_VAR (stack_start);
   COMPARE_GC_VAR (stack_end);
+#ifdef ENABLE_SMP
+  COMPARE_GC_VAR (shared_heap_free);
+  COMPARE_GC_VAR (shared_heap_start);
+  COMPARE_GC_VAR (shared_heap_end);
+#endif
   COMPARE_GC_VAR (constant_alloc_next);
   COMPARE_GC_VAR (constant_start);
   COMPARE_GC_VAR (constant_end);
@@ -315,6 +339,13 @@ compute_memory_checksum (void)
 		fasdump_saved_heap_start,
 		((fasdump_saved_Free - fasdump_saved_heap_start)
 		 * SIZEOF_SCHEME_OBJECT));
+#ifdef ENABLE_SMP
+  (void) mhash (ctx,
+		fasdump_saved_shared_heap_start,
+		((fasdump_saved_shared_heap_free
+		  - fasdump_saved_shared_heap_start)
+		 * SIZEOF_SCHEME_OBJECT));
+#endif
   return (mhash_end (ctx));
 }
 
@@ -472,7 +503,7 @@ DEFINE_GC_HANDLER (handle_environment)
 static
 DEFINE_GC_HANDLER (handle_ephemeron)
 {
-  /* Count each one once by counting only if there is no borken heart.  */
+  /* Count each one once by counting only if there is no broken heart.  */
   if (0 == (GC_PRECHECK_FROM (OBJECT_ADDRESS (object))))
     dumped_ephemeron_count += 1;
   return (gc_handle_unaligned_vector (scan, object));
@@ -532,7 +563,7 @@ DEFINE_PRIMITIVE ("DUMP-BAND", Prim_band_dump, 2, 2,
 Saves an image of the current world to the file NAMESTRING.\n\
 When the file is reloaded, PROCEDURE is called with an argument of #F.")
 {
-  SCHEME_OBJECT * to = Free;
+  SCHEME_OBJECT * to;
   SCHEME_OBJECT * prim_table_start;
   SCHEME_OBJECT * c_code_table_start;
   bool result;
@@ -541,7 +572,26 @@ When the file is reloaded, PROCEDURE is called with an argument of #F.")
   CHECK_ARG (1, INTERPRETER_APPLICABLE_P);
   CHECK_ARG (2, STRING_P);
 
-  Primitive_GC_If_Needed (5);
+#ifndef ENABLE_SMP
+  to = Free;
+  Primitive_GC_If_Needed (6);
+#else
+
+  ENTER_CRITICAL_SECTION ("band dump");
+
+  open_tospace (shared_heap_start);
+
+  initialize_weak_chain ();
+  ephemeron_count = 0;
+
+  std_gc_pt1 ();
+  std_gc_pt2 ();
+
+  to = shared_heap_free;
+
+  assert (Free == heap_start);
+  assert (SHARED_HEAP_AVAILABLE_P (6));
+#endif
   initialize_fasl_header (true, true);
   {
     SCHEME_OBJECT comb;
@@ -573,7 +623,7 @@ When the file is reloaded, PROCEDURE is called with an argument of #F.")
   to += (FASLHDR_C_CODE_TABLE_SIZE (fh));
 #endif
 
-  if (to > heap_end)
+  if (to > HEAP_END)
     result = false;
   else
     {
@@ -585,7 +635,7 @@ When the file is reloaded, PROCEDURE is called with an argument of #F.")
       export_c_code_table (c_code_table_start);
 #endif
 
-      (FASLHDR_HEAP_START (fh)) = heap_start;
+      (FASLHDR_HEAP_START (fh)) = HEAP_START;
       (FASLHDR_HEAP_END (fh)) = prim_table_start;
       (FASLHDR_CONSTANT_START (fh)) = constant_start;
       (FASLHDR_CONSTANT_END (fh)) = constant_alloc_next;
diff --git a/src/microcode/fasload.c b/src/microcode/fasload.c
index 7d6d5e0f7..75d6b72fa 100644
--- a/src/microcode/fasload.c
+++ b/src/microcode/fasload.c
@@ -34,6 +34,7 @@ USA.
 #include "osscheme.h"
 #include "osfile.h"
 #include "osio.h"
+#include "ossmp.h"
 #include "gccode.h"
 #include "trap.h"
 #include "option.h"
@@ -269,6 +270,9 @@ read_band_file (SCHEME_OBJECT s)
 
   reset_allocator_parameters
     ((FASLHDR_CONSTANT_SIZE (fh)), (FASLHDR_HEAP_RESERVED (fh)));
+#ifdef ENABLE_SMP
+  reset_processor_allocator (self);
+#endif
   /* We cleared the heap; the ephemeron array is now bogus.  */
   ephemeron_array = SHARP_F;
   result = (load_file (handle, 0));
diff --git a/src/microcode/gccode.h b/src/microcode/gccode.h
index 721d92747..23fd5cf13 100644
--- a/src/microcode/gccode.h
+++ b/src/microcode/gccode.h
@@ -186,9 +186,14 @@ typedef void gc_tospace_allocator_t
 typedef void gc_abort_handler_t (void);
 typedef bool gc_walk_proc_t (SCHEME_OBJECT *, SCHEME_OBJECT *, void *);
 
+#ifndef ENABLE_SMP
 extern void initialize_gc
   (unsigned long, SCHEME_OBJECT **, SCHEME_OBJECT **,
    gc_tospace_allocator_t *, gc_abort_handler_t * NORETURN);
+#else
+extern void initialize_gc
+  (unsigned long, gc_tospace_allocator_t *, gc_abort_handler_t * NORETURN);
+#endif
 
 extern void resize_tospace (unsigned long);
 extern void open_tospace (SCHEME_OBJECT *);
diff --git a/src/microcode/gcloop.c b/src/microcode/gcloop.c
index 561a3b34f..9d69e0bb1 100644
--- a/src/microcode/gcloop.c
+++ b/src/microcode/gcloop.c
@@ -60,7 +60,7 @@ USA.
 */
 
 #include "object.h"
-#include "outf.h"
+#include "extern.h"
 #include "gccode.h"
 
 /* For ephemeron layout.  */
@@ -69,8 +69,6 @@ USA.
 /* For memory advice.  */
 #include "ostop.h"
 
-static SCHEME_OBJECT ** p_fromspace_start;
-static SCHEME_OBJECT ** p_fromspace_end;
 static gc_tospace_allocator_t * gc_tospace_allocator;
 static gc_abort_handler_t * gc_abort_handler NORETURN;
 
@@ -85,10 +83,23 @@ gc_table_t * current_gc_table;
 static SCHEME_OBJECT * current_scan;
 static SCHEME_OBJECT current_object;
 
+#ifndef ENABLE_SMP
+static SCHEME_OBJECT ** p_fromspace_start;
+static SCHEME_OBJECT ** p_fromspace_end;
+
 #define ADDRESS_IN_FROMSPACE_P(addr)					\
   ((((void *) (addr)) >= ((void *) (*p_fromspace_start)))		\
    && (((void *) (addr)) < ((void *) (*p_fromspace_end))))
 
+#else /* ENABLE_SMP */
+
+#define ADDRESS_IN_FROMSPACE_P(addr)					\
+  (((((void *) (addr)) >= ((void *) (p0_heap_start)))			\
+    && (((void *) (addr)) < ((void *) (constant_start))))		\
+   || ((((void *) (addr)) >= ((void *) (shared_heap_start)))		\
+       && (((void *) (addr)) < ((void *) (shared_heap_free)))))
+#endif
+
 #define TOSPACE_TO_NEWSPACE(p) (((p) - tospace_start) + newspace_start)
 #define NEWSPACE_TO_TOSPACE(p) (((p) - newspace_start) + tospace_start)
 
@@ -140,9 +151,6 @@ static SCHEME_OBJECT ephemeron_list = SHARP_F;
 static SCHEME_OBJECT ephemeron_queue = SHARP_F;
 static bool scanning_ephemerons_p = false;
 
-extern SCHEME_OBJECT ephemeron_array;
-extern unsigned long ephemeron_count;
-
 static void queue_ephemerons_for_key (SCHEME_OBJECT *);
 static SCHEME_OBJECT gc_transport_weak_pair (SCHEME_OBJECT);
 static SCHEME_OBJECT gc_transport_ephemeron (SCHEME_OBJECT);
@@ -190,13 +198,17 @@ static void tospace_open (void) NORETURN;
 
 void
 initialize_gc (unsigned long n_words,
+#ifndef ENABLE_SMP
 	       SCHEME_OBJECT ** pf_start,
 	       SCHEME_OBJECT ** pf_end,
+#endif
 	       gc_tospace_allocator_t * allocator,
 	       gc_abort_handler_t * abort_handler NORETURN)
 {
+#ifndef ENABLE_SMP
   p_fromspace_start = pf_start;
   p_fromspace_end = pf_end;
+#endif
   gc_tospace_allocator = allocator;
   gc_abort_handler = abort_handler;
   CLOSE_TOSPACE ();
diff --git a/src/microcode/interp.c b/src/microcode/interp.c
index 17393cb3d..057ce4a91 100644
--- a/src/microcode/interp.c
+++ b/src/microcode/interp.c
@@ -1080,6 +1080,11 @@ Interpret (int pop_return_p)
       if (GC_NEEDED_P (gc_space_needed))
 	termination_gc_out_of_space ();
       gc_space_needed = 0;
+#ifdef ENABLE_SMP
+      if (!SHARED_HEAP_AVAILABLE_P(gc_shared_space_needed))
+	termination_gc_out_of_shared_space ();
+      gc_shared_space_needed = 0;
+#endif
       EXIT_CRITICAL_SECTION ({ SAVE_CONT (); });
       break;
 
diff --git a/src/microcode/makegen/files-os-prim.scm b/src/microcode/makegen/files-os-prim.scm
index d05c8f36a..c1f784490 100644
--- a/src/microcode/makegen/files-os-prim.scm
+++ b/src/microcode/makegen/files-os-prim.scm
@@ -35,3 +35,4 @@ USA.
 "prosterm"
 "prostty"
 "pruxsock" ;Misnamed, should be "prossock".
+"prossmp"
diff --git a/src/microcode/memmag.c b/src/microcode/memmag.c
index 1603167ab..50db38bd1 100644
--- a/src/microcode/memmag.c
+++ b/src/microcode/memmag.c
@@ -32,6 +32,7 @@ USA.
 #include "gccode.h"
 #include "osscheme.h"
 #include "ostop.h"
+#include "ossmp.h"
 
 #ifdef __WIN32__
    extern void win32_allocate_registers (void);
@@ -69,7 +70,11 @@ USA.
 
 static unsigned long saved_heap_size;
 static unsigned long saved_constant_size;
-static unsigned long saved_stack_size;
+unsigned long saved_stack_size;
+#ifdef ENABLE_SMP
+int saved_processor_count;
+unsigned long saved_processor_heap_size;
+#endif
 
 static gc_tospace_allocator_t allocate_tospace;
 static gc_abort_handler_t abort_gc NORETURN;
@@ -77,6 +82,8 @@ static gc_walk_proc_t save_tospace_copy;
 
 static unsigned long compute_ephemeron_array_length (unsigned long);
 
+#ifndef ENABLE_SMP
+
 /* Memory Allocation, sequential processor:
 
 oo
@@ -156,6 +163,141 @@ setup_memory (unsigned long heap_size,
   initialize_gc (heap_size, (&heap_start), (&Free), allocate_tospace, abort_gc);
 }
 
+#else /* ENABLE_SMP */
+
+/* Memory Allocation, multi-processor:
+
+   Machine variables, both   thread-local    & shared:
+oo                           ----------------  ---------------------------------
+   -------------------------
+   |       To Space        |
+   |                       |
+   ------------------------- <-                 to_space, malloced
+   .                       .
+   .                       .
+   .                       .
+   ------------------------- <-                 memory_block_end
+   |    (Shared) Heap      |                    & shared_heap_end
+   |                       |
+   | --------------------- | <-                 shared_heap_free
+   |               /\      |
+   |               ||      |
+   ------------------------- <-                 shared_heap_start
+   |  Constant (& Pure)    |                    & constant_end, moved by purify
+   |                       |
+   | --------------------  | <-                 constant_alloc_next
+   |               /\      |
+   |               ||      |
+   |               ||      |
+   ------------------------- <- heap_end       constant_start & pN->heap_end
+   | --------------------- | <- heap_alloc_limit
+   |                       |
+   | --------------------- | <- Free           pN->heap_free
+   |                   /\  |
+   | ProcessorN Heap   ||  |
+   ------------------------- <- heap_start     pN->heap_start
+             ...
+   ------------------------- <- heap_end       p0->heap_end & p1->heap_start
+   | --------------------- | <- heap_alloc_limit
+   |                       |
+   | --------------------- | <- Free           p0->free_pointer
+   |                   /\  |
+   | Processor0 Heap   ||  |
+   ------------------------- <- heap_start     p0->heap_start & p0_heap_start
+   | ProcessorN Stack  ||  |                   & pN->stack_end
+   |                   \/  |
+   | --------------------- | <- stack_pointer  pN->stack_pointer
+   |                       |
+   | --------------------- | <- stack_guard
+   ------------------------- <- stack_start    pN->stack_start
+             ...
+   ------------------------- <-                p0->stack_end
+   | Processor0 Stack  ||  |
+   |                   \/  |
+   | ----------------------| <- stack_pointer  p0->stack_pointer
+   |                       |
+   | ----------------------| <- stack_guard
+   ------------------------- <- stack_start    p0->stack_start
+0                                              & memory_block_start
+
+   Each area has a pointer to the next free word.  For the stack it is
+   a pointer to the last word in use. */
+
+void
+setup_memory (unsigned long heap_size,
+	      unsigned long constant_size,
+	      int processor_count,
+	      unsigned long processor_heap_size,
+	      unsigned long stack_size)
+{
+  unsigned long total_size;
+  ALLOCATE_REGISTERS ();
+
+  if (heap_size == 0)
+    {
+      outf_fatal ("Invalid (zero) heap size.\n");
+      outf_flush_fatal ();
+      exit (1);
+    }
+  if (stack_size == 0)
+    {
+      outf_fatal ("Invalid (zero) stack size.\n");
+      outf_flush_fatal ();
+      exit (1);
+    }
+  if (processor_count == 0)
+    {
+      outf_fatal ("Invalid (zero) processor count.\n");
+      outf_flush_fatal ();
+      exit (1);
+    }
+
+  if (processor_heap_size == 0)
+    {
+      processor_heap_size = heap_size; /* / 2 / processor_count; ??? */
+      if (processor_heap_size < SIZEOF_SCHEME_OBJECT*1024*1024)
+	processor_heap_size = SIZEOF_SCHEME_OBJECT*1024*1024;
+    }
+  total_size = (heap_size + constant_size
+		+ (processor_count * (stack_size + processor_heap_size)));
+
+  if (total_size >= DATUM_MASK)
+    {
+      outf_fatal ("Not enough heap addresses for this configuration.\n");
+      outf_flush_fatal ();
+      exit (1);
+    }
+
+  /* Allocate */
+  ALLOCATE_HEAP_SPACE (total_size, memory_block_start, memory_block_end);
+
+  if (memory_block_start == 0)
+    {
+      outf_fatal ("Not enough memory for this configuration.\n");
+      outf_flush_fatal ();
+      reset_memory ();
+      exit (1);
+    }
+
+  if ((ADDRESS_TO_DATUM (memory_block_end)) > DATUM_MASK)
+    {
+      outf_fatal ("Requested allocation is too large.\n");
+      outf_fatal ("Try again with a smaller argument to '--heap'.\n");
+      outf_flush_fatal ();
+      reset_memory ();
+      exit (1);
+    }
+
+  saved_heap_size = heap_size;
+  saved_stack_size = stack_size;
+  saved_constant_size = constant_size;
+  saved_processor_count = processor_count;
+  saved_processor_heap_size = processor_heap_size;
+  reset_allocator_parameters (0, 0);
+  initialize_gc (saved_heap_size, allocate_tospace, abort_gc);
+}
+#endif /* ENABLE_SMP */
+
 void
 reset_memory (void)
 {
@@ -169,13 +311,14 @@ allocations_ok_p (unsigned long n_constant,
 		  unsigned long n_reserved)
 {
   return
-    ((memory_block_start
-      + saved_stack_size
+    ((constant_start
       + n_constant + CONSTANT_SPACE_FUDGE
       + n_heap + ((n_reserved == 0) ? DEFAULT_HEAP_RESERVED : n_reserved))
      < memory_block_end);
 }
 
+#ifndef ENABLE_SMP
+
 void
 reset_allocator_parameters (unsigned long n_constant, unsigned long reserved)
 {
@@ -194,6 +337,51 @@ reset_allocator_parameters (unsigned long n_constant, unsigned long reserved)
   STACK_RESET ();
 }
 
+#else /* ENABLE_SMP */
+
+void
+reset_allocator_parameters (unsigned long n_constant, unsigned long reserved)
+{
+  heap_reserved = ((reserved == 0) ? DEFAULT_HEAP_RESERVED : reserved);
+  p0_heap_start = (memory_block_start
+		   + saved_processor_count * saved_stack_size);
+  constant_start = (memory_block_start
+		    + saved_processor_count * (saved_stack_size
+					       + saved_processor_heap_size));
+  constant_alloc_next = constant_start;
+  constant_end = (constant_alloc_next + n_constant + CONSTANT_SPACE_FUDGE);
+  shared_heap_start = constant_end;
+  shared_heap_free = shared_heap_start;
+  shared_heap_end = memory_block_end;
+}
+
+void
+reset_processor_allocator (processor_t *p)
+{
+  /* All of these variables should be thread-local. */
+  gc_space_needed = 0;
+  gc_shared_space_needed = 0;
+  SET_STACK_LIMITS (p->stack_start, saved_stack_size);
+  heap_start = p->heap_start;
+  heap_end = p->heap_end;
+  Free = heap_start;
+
+  RESET_HEAP_ALLOC_LIMIT ();
+  INITIALIZE_STACK ();
+  STACK_RESET ();
+}
+
+#define FOR_EACH_PROCESSOR(stmt) do {				\
+  processor_t *P = processors;					\
+  while (P != NULL)						\
+    {								\
+      stmt;							\
+      P = P->next;						\
+    }								\
+  } while (0)
+
+#endif
+
 static void
 allocate_tospace (unsigned long n_words,
 		  SCHEME_OBJECT ** start_r, SCHEME_OBJECT ** end_r)
@@ -231,7 +419,11 @@ bool
 object_in_heap_p (SCHEME_OBJECT object)
 {
   SCHEME_OBJECT * address = (get_object_address (object));
-  return ((address != 0) && (ADDRESS_IN_HEAP_P (address)));
+  return ((address != 0) && ((ADDRESS_IN_HEAP_P (address))
+#ifdef ENABLE_SMP
+			     || (ADDRESS_IN_SHARED_HEAP_P (address))
+#endif
+			     ));
 }
 
 DEFINE_PRIMITIVE ("GARBAGE-COLLECT", Prim_garbage_collect, 1, 1,
@@ -248,7 +440,11 @@ the primitive GC daemons before returning.")
   STACK_CHECK_FATAL ("GC");
   if (Free > heap_end)
     {
+#ifndef ENABLE_SMP
       outf_fatal ("\nGC has been delayed too long!\n");
+#else
+      outf_fatal ("\n;%d GC has been delayed too long!\n", self->id);
+#endif
       outf_fatal
 	("Free = %#lx; heap_alloc_limit = %#lx; heap_end = %#lx\n",
 	 ((unsigned long) Free),
@@ -270,7 +466,16 @@ the primitive GC daemons before returning.")
   if (GC_Debug == true) verify_heap ();
 #endif
 
+#ifndef ENABLE_SMP
+
   open_tospace (heap_start);
+
+#else
+
+  open_tospace (shared_heap_start);
+
+#endif /* ENABLE_SMP */
+
   initialize_weak_chain ();
   ephemeron_count = 0;
 
@@ -312,11 +517,22 @@ std_gc_pt1 (void)
 
   saved_to = (get_newspace_ptr ());
   add_to_tospace (fixed_objects);
+#ifndef ENABLE_SMP
   add_to_tospace
     (MAKE_POINTER_OBJECT (UNMARKED_HISTORY_TYPE, history_register));
+#else
+  FOR_EACH_PROCESSOR
+    (add_to_tospace (MAKE_POINTER_OBJECT (UNMARKED_HISTORY_TYPE,
+					  P->history_register)));
+#endif
 
   current_gc_table = (std_gc_table ());
+#ifndef ENABLE_SMP
   gc_scan_oldspace (stack_pointer, stack_end);
+#else
+  FOR_EACH_PROCESSOR
+    (gc_scan_oldspace (P->stack_pointer, P->stack_end));
+#endif
   gc_scan_oldspace (constant_start, constant_alloc_next);
   gc_scan_tospace (saved_to, 0);
 
@@ -326,36 +542,75 @@ std_gc_pt1 (void)
   update_weak_pointers ();
 }
 
+#ifndef ENABLE_SMP
+
+#define EPHEMERON_GC_NEEDED(length,n_ephemerons)			\
+  !HEAP_AVAILABLE_P ((VECTOR_DATA + length) + (n_ephemerons * EPHEMERON_SIZE))
+
+#define SPACE_NEEDED gc_space_needed
+
+#define make_ephemeron_vector(length) (make_vector (length, SHARP_F, false))
+
+#else
+
+#define EPHEMERON_GC_NEEDED(length,n_ephemerons)			\
+  !((HEAP_AVAILABLE_P (n_ephemerons * EPHEMERON_SIZE))			\
+    && SHARED_HEAP_AVAILABLE_P (VECTOR_DATA + length))
+
+#define SPACE_NEEDED gc_shared_space_needed
+
+static SCHEME_OBJECT
+make_ephemeron_vector (unsigned long length)
+{
+  SCHEME_OBJECT result;
+  result = (MAKE_POINTER_OBJECT (TC_VECTOR, shared_heap_free));
+  (*shared_heap_free++) = (MAKE_OBJECT (TC_MANIFEST_VECTOR, length));
+  while ((length--) > 0)
+    (*shared_heap_free++) = SHARP_F;
+  return (result);
+}
+#endif
+
 void
 std_gc_pt2 (void)
 {
   SCHEME_OBJECT * p = (get_newspace_ptr ());
   (void) save_tospace (save_tospace_copy, 0);
+#ifndef ENABLE_SMP
   Free = p;
+#else
+  shared_heap_free = p;
+  Free = heap_start;
+#endif
 
   fixed_objects = (*saved_to++);
+#ifndef ENABLE_SMP
   history_register = (OBJECT_ADDRESS (*saved_to++));
+#else
+  FOR_EACH_PROCESSOR
+    (P->history_register = (OBJECT_ADDRESS (*saved_to++)));
+  history_register = self->history_register;
+#endif
   saved_to = 0;
 
   {
     unsigned long length
       = (compute_ephemeron_array_length
 	 (ephemeron_count + n_ephemerons_requested));
-    if (!HEAP_AVAILABLE_P
-	((VECTOR_DATA + length) + (n_ephemerons_requested * EPHEMERON_SIZE)))
+    if (EPHEMERON_GC_NEEDED (length, n_ephemerons_requested))
       {
 	if (ephemeron_request_hard_p)
-	  gc_space_needed += (VECTOR_DATA + length);
+	  SPACE_NEEDED += (VECTOR_DATA + length);
 	length = (compute_ephemeron_array_length (ephemeron_count));
 #ifdef ENABLE_GC_DEBUGGING_TOOLS
 	/* This should never trigger, because we discard the previous
 	   ephemeron array, which always has room for at least as many
 	   ephemerons as are now live.  */
-	if (!HEAP_AVAILABLE_P (VECTOR_DATA + length))
+	if (!SHARED_HEAP_AVAILABLE_P (VECTOR_DATA + length))
 	  std_gc_death ("No room for ephemeron array");
 #endif
       }
-    ephemeron_array = (make_vector (length, SHARP_F, false));
+    ephemeron_array = make_ephemeron_vector (length);
     n_ephemerons_requested = 0;
     ephemeron_request_hard_p = false;
   }
@@ -460,20 +715,31 @@ guarantee_extra_ephemeron_space (unsigned long n)
   if (!ephemeron_array_big_enough_p (n))
     {
       unsigned long length = (compute_ephemeron_array_length (n));
-      assert (HEAP_AVAILABLE_P (VECTOR_DATA + length));
-      ephemeron_array = (make_vector (length, SHARP_F, false));
+      assert (SHARED_HEAP_AVAILABLE_P (VECTOR_DATA + length));
+      ephemeron_array = make_ephemeron_vector (length);
     }
 }
 
 static void
-gc_if_needed_for_ephemeron (unsigned long extra_space)
+gc_if_needed_for_ephemeron (unsigned long table_space)
 {
-  if (GC_NEEDED_P (EPHEMERON_SIZE + extra_space))
+#ifndef ENABLE_SMP
+  if (GC_NEEDED_P (EPHEMERON_SIZE + table_space))
     {
       n_ephemerons_requested = 1;
       ephemeron_request_hard_p = true;
       Primitive_GC (EPHEMERON_SIZE);
     }
+#else
+  if ((GC_NEEDED_P (EPHEMERON_SIZE))
+      || ((!SHARED_HEAP_AVAILABLE_P (table_space))
+	  && (GC_ENABLED_P())))
+    {
+      n_ephemerons_requested = 1;
+      ephemeron_request_hard_p = true;
+      Primitive_GC (EPHEMERON_SIZE);
+    }
+#endif
 }
 
 DEFINE_PRIMITIVE ("MAKE-EPHEMERON", Prim_make_ephemeron, 2, 2, 0)
@@ -487,7 +753,7 @@ DEFINE_PRIMITIVE ("MAKE-EPHEMERON", Prim_make_ephemeron, 2, 2, 0)
       unsigned long length
 	= (compute_ephemeron_array_length (ephemeron_count));
       gc_if_needed_for_ephemeron (VECTOR_DATA + length);
-      ephemeron_array = (make_vector (length, SHARP_F, false));
+      ephemeron_array = (make_ephemeron_vector (length));
     }
   {
     SCHEME_OBJECT * addr = Free;
diff --git a/src/microcode/memmag.h b/src/microcode/memmag.h
index 847a096a7..0d87d6a6d 100644
--- a/src/microcode/memmag.h
+++ b/src/microcode/memmag.h
@@ -36,6 +36,15 @@ USA.
 #define HEAP_AVAILABLE							\
   ((unsigned long) ((FREE_OK_P (Free)) ? (heap_alloc_limit - Free) : 0))
 
+#ifndef ENABLE_SMP
+#  define SHARED_HEAP_AVAILABLE_P HEAP_AVAILABLE_P
+#else
+#  define SHARED_HEAP_AVAILABLE_P(n_words)				\
+    ((shared_heap_free + (n_words)) < shared_heap_end)
+#  define SHARED_HEAP_AVAILABLE						\
+    ((unsigned long) (shared_heap_end - shared_heap_free))
+#endif
+
 #define FREE_OK_P(free)							\
   (((free) >= heap_start) && ((free) < heap_alloc_limit))
 
@@ -73,6 +82,11 @@ USA.
 #define ADDRESS_IN_HEAP_P(address)					\
   (((address) >= heap_start) && ((address) < heap_end))
 
+#ifdef ENABLE_SMP
+#define ADDRESS_IN_SHARED_HEAP_P(address)				\
+  (((address) >= shared_heap_start) && ((address) < shared_heap_end))
+#endif
+
 #define ADDRESS_IN_STACK_P(address)					\
   (((address) >= stack_start) && ((address) < stack_end))
 
@@ -86,6 +100,10 @@ USA.
 
 extern bool allocations_ok_p (unsigned long, unsigned long, unsigned long);
 extern void reset_allocator_parameters (unsigned long, unsigned long);
+#ifdef ENABLE_SMP
+#include "ossmp.h"
+extern void reset_processor_allocator (processor_t *p);
+#endif
 extern bool object_in_heap_p (SCHEME_OBJECT);
 extern void std_gc_pt1 (void);
 extern void std_gc_pt2 (void);
diff --git a/src/microcode/object.h b/src/microcode/object.h
index f77779e24..255c61728 100644
--- a/src/microcode/object.h
+++ b/src/microcode/object.h
@@ -455,6 +455,10 @@ extern SCHEME_OBJECT * memory_base;
 
 #define HEAP_ADDRESS_P(address)						\
   (((address) >= heap_start) && ((address) < Free))
+#ifdef ENABLE_SMP
+#define SHARED_HEAP_ADDRESS_P(address)					\
+  (((address) >= shared_heap_start) && ((address) < shared_heap_free))
+#endif
 
 #ifndef FLOATING_ALIGNMENT
 #  define FLOATING_ALIGNMENT 0
diff --git a/src/microcode/option.c b/src/microcode/option.c
index 583d9737f..306e15e72 100644
--- a/src/microcode/option.c
+++ b/src/microcode/option.c
@@ -91,6 +91,8 @@ static const char * option_raw_band;
 static const char * option_raw_heap;
 static const char * option_raw_constant;
 static const char * option_raw_stack;
+static const char * option_raw_processor_count;
+static const char * option_raw_processor_heap;
 
 /* Command-line arguments */
 int option_saved_argc;
@@ -118,6 +120,8 @@ const char * option_fasl_file = 0;
 unsigned long option_heap_size;
 unsigned long option_constant_size;
 unsigned long option_stack_size;
+int option_processor_count;
+unsigned long option_processor_heap_size;
 
 void
 print_help (void)
@@ -254,6 +258,14 @@ Additional options may be supported by the band (and described below).\n\
 #ifndef STACK_SIZE_VARIABLE
 #  define STACK_SIZE_VARIABLE "MITSCHEME_STACK_SIZE"
 #endif
+
+#ifndef PROCESSORS_VARIABLE
+#  define PROCESSORS_VARIABLE "MITSCHEME_PROCESSORS"
+#endif
+
+#ifndef PROCESSOR_HEAP_SIZE_VARIABLE
+#  define PROCESSOR_HEAP_SIZE_VARIABLE "MITSCHEME_PROCESSOR_HEAP_SIZE"
+#endif
 
 static int
 string_compare_ci (const char * string1, const char * string2)
@@ -502,6 +514,8 @@ parse_standard_options (int argc, const char ** argv)
   option_argument ("silent", false, (&option_batch_mode));
   option_argument ("stack", true, (&option_raw_stack));
   option_argument ("version", false, (&option_show_version));
+  option_argument ("processors", true, (&option_raw_processor_count));
+  option_argument ("processor-heap", true, (&option_raw_processor_heap));
 
   /* These are deprecated: */
   option_argument ("compiler", false, 0);
@@ -860,6 +874,12 @@ describe_size_option (const char * name, unsigned int value)
   outf_fatal ("  %s size: %d\n", name, value);
 }
 
+static void
+describe_number_option (const char * name, unsigned int value)
+{
+  outf_fatal ("  number of %s: %d\n", name, value);
+}
+
 static void
 describe_path_option (const char * name, const char ** value)
 {
@@ -893,6 +913,8 @@ describe_options (void)
   describe_boolean_option ("force interactive", option_force_interactive);
   describe_boolean_option ("disable core dump", option_disable_core_dump);
   describe_boolean_option ("suppress noise", option_batch_mode);
+  describe_number_option ("processors", option_processor_count);
+  describe_size_option ("processor heap", option_processor_heap_size);
   if (option_unused_argc == 0)
     outf_fatal ("  no unused arguments\n");
   else
@@ -1004,6 +1026,16 @@ read_command_line_options (int argc, const char ** argv)
 				option_raw_stack,
 				STACK_SIZE_VARIABLE,
 				DEFAULT_STACK_SIZE));
+  option_processor_count
+    = (standard_numeric_option ("processors",
+				option_raw_processor_count,
+				PROCESSORS_VARIABLE,
+				1));
+  option_processor_heap_size
+    = (standard_numeric_option ("processor-heap",
+				option_raw_processor_heap,
+				PROCESSOR_HEAP_SIZE_VARIABLE,
+				0));
   if (option_show_version)
     {
       outf_console ("%s\n", PACKAGE_STRING);
diff --git a/src/microcode/option.h b/src/microcode/option.h
index 051dd13d7..c5e90d2b4 100644
--- a/src/microcode/option.h
+++ b/src/microcode/option.h
@@ -54,6 +54,8 @@ extern const char * option_fasl_file;
 extern unsigned long option_heap_size;
 extern unsigned long option_constant_size;
 extern unsigned long option_stack_size;
+extern int option_processor_count;
+extern unsigned long option_processor_heap_size;
 
 extern void read_command_line_options (int argc, const char ** argv);
 
diff --git a/src/microcode/os2xcpt.c b/src/microcode/os2xcpt.c
index d597759ba..77d64dee7 100644
--- a/src/microcode/os2xcpt.c
+++ b/src/microcode/os2xcpt.c
@@ -421,6 +421,11 @@ continue_from_trap (PEXCEPTIONREPORTRECORD report, PCONTEXTRECORD context)
       pc_location = pc_in_heap;
       block_address = (find_block_address (((void *) pc), heap_start));
     }
+  else if ((((ULONG)shared_heap_start) <= pc)&&(pc < ((ULONG)shared_heap_end)))
+    {
+      pc_location = pc_in_heap;
+      block_address = (find_block_address (((void *) pc), shared_heap_start));
+    }
   else if ((((ULONG) constant_start) <= pc) && (pc < ((ULONG) constant_end)))
     {
       pc_location = pc_in_heap;
diff --git a/src/microcode/ossmp.h b/src/microcode/ossmp.h
new file mode 100644
index 000000000..5adef326b
--- /dev/null
+++ b/src/microcode/ossmp.h
@@ -0,0 +1,66 @@
+/* -*-C-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+    2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014 Massachusetts
+    Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+*/
+
+#ifndef SCM_OSSMP_H
+#define SCM_OSSMP_H
+
+#include "config.h"
+
+#ifdef ENABLE_SMP
+
+typedef enum {
+  PROCESSOR_NEW,
+  PROCESSOR_RUNNING,
+  PROCESSOR_PAUSED,
+  PROCESSOR_DEAD
+} processor_state_t;
+
+typedef struct processor processor_t;
+
+struct processor {
+  struct processor *next;
+  char id;
+  processor_state_t state;
+  pthread_t pthread;
+  SCHEME_OBJECT * stack_end;
+  SCHEME_OBJECT * stack_start;
+  SCHEME_OBJECT * heap_end;
+  SCHEME_OBJECT * heap_start;
+  /* The values of the thread-local Free, stack_pointer and
+     history_register are copied here when entering the GC-WAIT
+     state, and copied back when gc_finished. */
+  SCHEME_OBJECT * stack_pointer;
+  SCHEME_OBJECT * free_pointer;
+  SCHEME_OBJECT * history_register;
+};
+
+extern processor_t *processors;
+extern __thread processor_t *self;
+
+extern void smp_initialize (int processor_count);
+#endif
+
+#endif /* SCM_OSSMP_H */
diff --git a/src/microcode/prossmp.c b/src/microcode/prossmp.c
new file mode 100644
index 000000000..bfcbe5700
--- /dev/null
+++ b/src/microcode/prossmp.c
@@ -0,0 +1,241 @@
+/* -*-C-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+    2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014 Massachusetts
+    Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+*/
+
+/* Primitives for "symmetric multi-processing". */
+
+#include "prims.h"
+
+#ifdef ENABLE_SMP
+
+#include "history.h"
+#include "osio.h"
+#include "ossmp.h"
+#include <pthread.h>
+
+/* The chain of processors, starting with processor0 -- main()'s thread: */
+processor_t *processors;
+
+/* The mutex that serializes thread switches. */
+static pthread_mutex_t thread_mutex = PTHREAD_MUTEX_INITIALIZER;
+
+/* The current pthread's processor. */
+__thread processor_t *self;
+
+extern int saved_processor_count;
+extern int saved_processor_heap_size;
+extern int saved_stack_size;
+
+#ifdef ENABLE_DEBUGGING_TOOLS
+
+static bool smp_trace_p = false;
+
+static void
+trace (const char * format, ...)
+{
+  va_list args;
+  va_start (args, format);
+  if (smp_trace_p == true)
+    voutf_error_line (format, args);
+  va_end (args);
+}
+
+#else
+
+#define trace(...) do {} while (false)
+
+#endif
+
+#endif
+
+DEFINE_PRIMITIVE ("SMP-ID", Prim_smp_id, 0, 0, "(SMP-ID)\n\
+A fixnum identifying the current processor.")
+{
+  PRIMITIVE_HEADER (0);
+#ifdef ENABLE_SMP
+  PRIMITIVE_RETURN (LONG_TO_FIXNUM (self->id));
+#else
+  PRIMITIVE_RETURN (FIXNUM_ZERO);
+#endif
+}
+
+DEFINE_PRIMITIVE ("SMP-COUNT", Prim_smp_count, 0, 0, "(SMP-COUNT)\n\
+The number of concurrently running Symmetric Multi-Processors.")
+{
+  PRIMITIVE_HEADER (0);
+#ifdef ENABLE_SMP
+  PRIMITIVE_RETURN (LONG_TO_FIXNUM (saved_processor_count));
+#else
+  PRIMITIVE_RETURN (SHARP_F);
+#endif
+}
+
+DEFINE_PRIMITIVE ("SMP-LOCK-THREADS", Prim_smp_lock_threads, 1, 1,
+		  "(SMP-LOCK-THREADS LOCK?)\n\
+When LOCK? is #F/non-#F, unlock/lock the pthread mutex serializing\n\
+thread switches.")
+{
+  PRIMITIVE_HEADER (1);
+  {
+#ifdef ENABLE_SMP
+    SCHEME_OBJECT which = ARG_REF (1);
+    if (which == SHARP_F)
+      {
+	int ret;
+
+	ret = pthread_mutex_unlock (&thread_mutex);
+	if (ret != 0)
+	  error_external_return ();
+      }
+    else
+      {
+	int ret = pthread_mutex_lock (&thread_mutex);
+	if (ret != 0)
+	  error_external_return ();
+      }
+#endif
+  }
+  PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+#ifdef ENABLE_SMP
+
+static void make_processors (int);
+
+void
+smp_initialize (int count)
+{
+  make_processors (count-1);
+
+  self = processors;
+  assert (self->id == 0);
+  self->pthread = pthread_self ();
+  /* assert (C_Stack_Pointer == NULL); */
+  reset_processor_allocator (self);
+  RESET_HISTORY ();
+}
+
+static void *
+work (void *p)
+{
+  SCHEME_OBJECT expr;
+  self = (processor_t *)p;
+  trace (";%d Start.", self->id);
+  assert (self->id != 0);
+  assert (self != processors);
+  reset_processor_allocator (self);
+  RESET_HISTORY ();
+
+  /* expr: (SMP-PAUSE) */
+  expr = (MAKE_POINTER_OBJECT (TC_COMBINATION, Free));
+  (*Free++) = MAKE_OBJECT (TC_MANIFEST_VECTOR, 1);
+  (*Free++) = make_primitive ("SMP-PAUSE", 0);
+
+  /* Setup registers */
+  INITIALIZE_INTERRUPTS (0);
+  SET_ENV (THE_GLOBAL_ENV);
+  trapping = false;
+
+  /* Give the interpreter something to chew on, and ... */
+  Will_Push (CONTINUATION_SIZE);
+  SET_RC (RC_END_OF_COMPUTATION);
+  SET_EXP (SHARP_F);
+  SAVE_CONT ();
+  Pushed ();
+
+  SET_EXP (expr);
+
+  /* Go to it! */
+  gc_space_needed = 0;
+  gc_shared_space_needed = 0;
+
+  Interpret (0);
+
+  trace (";%d Died.", self->id);
+  self->state = PROCESSOR_DEAD;
+  return (NULL);
+}
+
+static void
+make_processors (int id)
+{
+  SCHEME_OBJECT *stack_start, *heap_start;
+  processor_t *new;
+
+  trace (";%d Setup.", id);
+  new = malloc (sizeof (processor_t));
+  if (new == NULL)
+    {
+      outf_fatal ("\n;%d could not malloc processor_t\n", id);
+      outf_flush_fatal ();
+      Microcode_Termination (TERM_NO_SPACE);
+    }
+  stack_start = memory_block_start + id * saved_stack_size;
+  heap_start = memory_block_start + (saved_processor_count * saved_stack_size
+				     + id * saved_processor_heap_size);
+  new->next = processors;
+  new->id = id;
+  new->state = PROCESSOR_NEW;
+  new->stack_start = stack_start;
+  new->stack_end = stack_start + saved_stack_size;
+  new->heap_start = heap_start;
+  new->heap_end = heap_start + saved_processor_heap_size;
+  processors = new;
+
+  if (id != 0)
+    {
+      int err = pthread_create (&new->pthread, NULL, &work, new);
+      if (err)
+	{
+	  outf_fatal ("pthread_create failed: %d\n", err);
+	  outf_flush_fatal ();
+	  exit (1);
+	}
+    }
+
+  trace (";%d heap:  0x%0lx-0x%0lx", id,
+	 (ulong)new->heap_start, (ulong)new->heap_end);
+  trace (";%d stack: 0x%0lx-0x%0lx", id,
+	 (ulong)new->stack_start, (ulong)new->stack_end);
+
+  if (id > 0)
+    make_processors (id - 1);
+}
+#endif
+
+DEFINE_PRIMITIVE ("SMP-PAUSE", Prim_smp_pause, 0, 0, "(SMP-PAUSE)\n\
+Pause a new processor.")
+{
+  PRIMITIVE_HEADER (0);
+#ifdef ENABLE_SMP
+  assert (self->id != 0);
+  self->state = PROCESSOR_PAUSED;
+  OS_pause ();
+  self->state = PROCESSOR_RUNNING;
+#else
+  signal_error_from_primitive (ERR_UNIMPLEMENTED_PRIMITIVE);
+#endif
+  PRIMITIVE_RETURN (UNSPECIFIC);
+}
diff --git a/src/microcode/purify.c b/src/microcode/purify.c
index e1a69ae18..a1744deba 100644
--- a/src/microcode/purify.c
+++ b/src/microcode/purify.c
@@ -27,9 +27,18 @@ USA.
 /* Copy objects into constant/pure space.  */
 
 #include "scheme.h"
+#include "ossmp.h"
 #include "prims.h"
 #include "gccode.h"
 
+#ifndef ENABLE_SMP
+#define HEAP_START heap_start
+#define HEAP_END heap_end
+#else
+#define HEAP_START shared_heap_start
+#define HEAP_END shared_heap_end
+#endif
+
 static void purify (SCHEME_OBJECT);
 
 /* Purify increases the size of constant space at the expense of the
@@ -95,6 +104,7 @@ purify (SCHEME_OBJECT object)
 
   open_tospace (constant_alloc_next);
   initialize_weak_chain ();
+  ephemeron_count = 0;
 
   start_copy = (get_newspace_ptr ());
   add_to_tospace (object);
@@ -110,9 +120,9 @@ purify (SCHEME_OBJECT object)
 
   constant_alloc_next = new_constant_alloc_next;
   constant_end = heap_copy_start;
-  heap_start = constant_end;
+  HEAP_START = constant_end;
 
   std_gc_pt2 ();
 
-  resize_tospace (heap_end - heap_start);
+  resize_tospace (HEAP_END - HEAP_START);
 }
diff --git a/src/microcode/storage.c b/src/microcode/storage.c
index 39121de9e..246413973 100644
--- a/src/microcode/storage.c
+++ b/src/microcode/storage.c
@@ -41,7 +41,19 @@ SCHEME_OBJECT * Free_primitive = 0;
 /* strict limit for Free */
 SCHEME_OBJECT * heap_alloc_limit;
 
-/* limits of active heap */
+#ifdef ENABLE_SMP
+/* the start of From space */
+SCHEME_OBJECT * p0_heap_start;
+
+/* limits of shared heap */
+SCHEME_OBJECT * shared_heap_start;
+SCHEME_OBJECT * shared_heap_end;
+
+/* next free word in the shared heap */
+SCHEME_OBJECT * shared_heap_free;
+#endif
+
+/* limits of local heap */
 SCHEME_OBJECT * heap_start;
 SCHEME_OBJECT * heap_end;
 
@@ -77,9 +89,6 @@ unsigned long ephemeron_count = 0;
 
 bool trapping;
 
-unsigned long n_heap_blocks;
-unsigned long n_constant_blocks;
-unsigned long n_stack_blocks;
 SCHEME_OBJECT * memory_block_start;
 SCHEME_OBJECT * memory_block_end;
 
@@ -87,6 +96,9 @@ unsigned long heap_reserved;
 
 /* Amount of space needed when GC requested */
 unsigned long gc_space_needed;
+#ifdef ENABLE_SMP
+unsigned long gc_shared_space_needed;
+#endif
 
 /* Number of new ephemerons requested from the GC.  */
 unsigned long n_ephemerons_requested;
diff --git a/src/microcode/sysprim.c b/src/microcode/sysprim.c
index 719637c25..6f8c23b28 100644
--- a/src/microcode/sysprim.c
+++ b/src/microcode/sysprim.c
@@ -118,7 +118,11 @@ DEFINE_PRIMITIVE ("GC-SPACE-STATUS", Prim_gc_space_status, 0, 0, 0)
 {
   PRIMITIVE_HEADER (0);
   {
+#ifdef ENABLE_SMP
+    SCHEME_OBJECT v = (make_vector (15, SHARP_F, true));
+#else
     SCHEME_OBJECT v = (make_vector (12, SHARP_F, true));
+#endif
     VECTOR_SET (v, 0, (ULONG_TO_FIXNUM (sizeof (SCHEME_OBJECT))));
     VECTOR_SET (v, 1, (CONVERT_ADDRESS (constant_start)));
     VECTOR_SET (v, 2, (CONVERT_ADDRESS (constant_alloc_next)));
@@ -131,6 +135,11 @@ DEFINE_PRIMITIVE ("GC-SPACE-STATUS", Prim_gc_space_status, 0, 0, 0)
     VECTOR_SET (v, 9, (CONVERT_ADDRESS (stack_pointer)));
     VECTOR_SET (v, 10, (CONVERT_ADDRESS (stack_guard)));
     VECTOR_SET (v, 11, (CONVERT_ADDRESS (stack_end)));
+#ifdef ENABLE_SMP
+    VECTOR_SET (v, 12, (CONVERT_ADDRESS (shared_heap_start)));
+    VECTOR_SET (v, 13, (CONVERT_ADDRESS (shared_heap_free)));
+    VECTOR_SET (v, 14, (CONVERT_ADDRESS (shared_heap_end)));
+#endif
     PRIMITIVE_RETURN (v);
   }
 }
diff --git a/src/microcode/term.c b/src/microcode/term.c
index de63d2537..5984fa92f 100644
--- a/src/microcode/term.c
+++ b/src/microcode/term.c
@@ -245,6 +245,22 @@ termination_gc_out_of_space (void)
   termination_suffix_trace (TERM_GC_OUT_OF_SPACE);
 }
 
+#ifdef ENABLE_SMP
+void
+termination_gc_out_of_shared_space (void)
+{
+  termination_prefix (TERM_GC_OUT_OF_SPACE);
+  outf_fatal ("You are out of shared heap at the end of a garbage collection!\n");
+  outf_fatal
+    ("shared_heap_free = %#lx; shared_heap_end = %#lx\n",
+     ((unsigned long) shared_heap_free),
+     ((unsigned long) shared_heap_end));
+  outf_fatal ("# words needed = %lu; # words available = %lu\n",
+	      gc_shared_space_needed, SHARED_HEAP_AVAILABLE);
+  termination_suffix_trace (TERM_GC_OUT_OF_SPACE);
+}
+#endif
+
 void
 termination_eof (void)
 {
diff --git a/src/microcode/utils.c b/src/microcode/utils.c
index 35466bb24..2ed5d4bf1 100644
--- a/src/microcode/utils.c
+++ b/src/microcode/utils.c
@@ -173,10 +173,17 @@ err_print (long error_code, outf_channel where)
     = ((error_code <= MAX_ERROR)
        ? (Error_Names[error_code])
        : 0);
+#ifndef ENABLE_SMP
   if (message == 0)
     outf (where, "Unknown error code %#lx.\n", error_code);
   else
     outf (where, "Error code %#lx (%s).\n", error_code, message);
+#else /* ENABLE_SMP */
+  if (message == 0)
+    outf (where, ";%d Unknown error code %#lx.\n", self->id, error_code);
+  else
+    outf (where, ";%d Error code %#lx (%s).\n", self->id, error_code, message);
+#endif
 }
 
 long death_blow;
@@ -549,6 +556,7 @@ Do_Micro_Error (long error_code, bool from_pop_return_p)
 
 #ifdef ENABLE_DEBUGGING_TOOLS
   err_print (error_code, ERROR_OUTPUT);
+#ifndef ENABLE_SMP
   if ((GET_RC == RC_INTERNAL_APPLY)
       || (GET_RC == RC_INTERNAL_APPLY_VAL))
     {
@@ -576,6 +584,38 @@ Do_Micro_Error (long error_code, bool from_pop_return_p)
     }
   Print_Return ("Return code");
   outf_error ("\n");
+#else /* ENABLE_SMP */
+  if ((GET_RC == RC_INTERNAL_APPLY)
+      || (GET_RC == RC_INTERNAL_APPLY_VAL))
+    {
+      outf_error (";%d   Procedure: ", self->id);
+      Print_Expression (STACK_REF(CONTINUATION_SIZE + STACK_ENV_FUNCTION), "");
+      outf_error ("\n");
+      {
+	int i;
+	int nargs = (APPLY_FRAME_HEADER_N_ARGS
+		     (STACK_REF (CONTINUATION_SIZE + STACK_ENV_HEADER)));
+	for (i = 0; i < nargs; i++)
+	  {
+	    outf_error (";%d   Argument %d: ", self->id, i+1);
+	    Print_Expression ((STACK_REF(CONTINUATION_SIZE
+					 + STACK_ENV_FIRST_ARG + i)), "");
+	    outf_error ("\n");
+	  }
+      }
+    }
+  else
+    {
+      outf_error (";%d   Expression: ", self->id);
+      Print_Expression (GET_EXP, "");
+      outf_error ("\n");
+      outf_error (";%d   Environment: ", self->id);
+      Print_Expression (GET_ENV, "");
+      outf_error ("\n");
+    }
+  outf_error (";%d   Return code", self->id);
+  Print_Return ("");
+#endif /* ENABLE_SMP */
 #endif
 
   if (Trace_On_Error)
diff --git a/src/microcode/uxtrap.c b/src/microcode/uxtrap.c
index c83d8f08b..ceef616e7 100644
--- a/src/microcode/uxtrap.c
+++ b/src/microcode/uxtrap.c
@@ -50,7 +50,6 @@ USA.
 
 extern const char * find_signal_name (int);
 extern void UX_dump_core (void);
-extern void * initial_C_stack_pointer;
 
 struct ux_sig_code_desc
 {
@@ -77,6 +76,9 @@ static struct ux_sig_code_desc ux_signal_codes [64];
 enum pc_location
 {
   pcl_heap,
+#ifdef ENABLE_SMP
+  pcl_shared_heap,
+#endif
   pcl_constant,
   pcl_builtin,
   pcl_utility,
@@ -106,6 +108,9 @@ static void continue_from_trap
 
 #ifdef CC_SUPPORT_P
    static SCHEME_OBJECT * find_heap_address (unsigned long);
+#ifdef ENABLE_SMP
+   static SCHEME_OBJECT * find_shared_heap_address (unsigned long);
+#endif
    static SCHEME_OBJECT * find_constant_address (unsigned long);
 #  ifdef ENABLE_TRAP_RECOVERY
      static SCHEME_OBJECT * find_block_address (unsigned long, SCHEME_OBJECT *);
@@ -345,8 +350,8 @@ continue_from_trap (int signo, SIGINFO_T info, SIGCONTEXT_T * scp)
 {
   unsigned long pc = (SIGCONTEXT_PC (scp));
   SCHEME_OBJECT primitive = GET_PRIMITIVE;
-  SCHEME_OBJECT * block_addr;
-  unsigned int index;
+  SCHEME_OBJECT * block_addr = NULL;
+  unsigned int index = 0;
   SCHEME_OBJECT * new_sp = 0;
   struct trap_recovery_info recovery_info;
 
@@ -367,6 +372,9 @@ continue_from_trap (int signo, SIGINFO_T info, SIGCONTEXT_T * scp)
       break;
 
     case pcl_heap:
+#ifdef ENABLE_SMP
+    case pcl_shared_heap:
+#endif
     case pcl_constant:
 #ifdef CC_SUPPORT_P
 
@@ -469,6 +477,14 @@ find_heap_address (unsigned long pc)
   return (find_block_address (pc, heap_start));
 }
 
+#ifdef ENABLE_SMP
+static SCHEME_OBJECT *
+find_shared_heap_address (unsigned long pc)
+{
+  return (find_block_address (pc, shared_heap_start));
+}
+#endif
+
 static SCHEME_OBJECT *
 find_constant_address (unsigned long pc)
 {
@@ -571,6 +587,14 @@ find_heap_address (unsigned long pc)
   return (0);
 }
 
+#ifdef ENABLE_SMP
+static SCHEME_OBJECT *
+find_shared_heap_address (unsigned long pc)
+{
+  return (0);
+}
+#endif
+
 static SCHEME_OBJECT *
 find_constant_address (unsigned long pc)
 {
@@ -711,27 +735,29 @@ classify_pc (unsigned long pc,
 	     unsigned int * r_index)
 {
 #ifdef CC_SUPPORT_P
+  enum pc_location type = pcl_unknown;
+  SCHEME_OBJECT * block_addr = NULL;
+
   if (PC_ALIGNED_P (pc))
     {
       if (HEAP_ADDRESS_P ((SCHEME_OBJECT *) pc))
 	{
-	  SCHEME_OBJECT * block_addr = (find_heap_address (pc));
-	  if (block_addr == 0)
-	    return (pcl_unknown);
-	  if (r_block_addr != 0)
-	    (*r_block_addr) = block_addr;
-	  return (pcl_heap);
+	  block_addr = (find_heap_address (pc));
+	  type = pcl_heap;
 	}
-      if (ADDRESS_IN_CONSTANT_P ((SCHEME_OBJECT *) pc))
+#ifdef ENABLE_SMP
+      else if (SHARED_HEAP_ADDRESS_P ((SCHEME_OBJECT *) pc))
 	{
-	  SCHEME_OBJECT * block_addr = (find_constant_address (pc));
-	  if (block_addr == 0)
-	    return (pcl_unknown);
-	  if (r_block_addr != 0)
-	    (*r_block_addr) = block_addr;
-	  return (pcl_constant);
+	  block_addr = (find_shared_heap_address (pc));
+	  type = pcl_shared_heap;
 	}
-      if (ADDRESS_UCODE_P (pc))
+#endif
+      else if (ADDRESS_IN_CONSTANT_P ((SCHEME_OBJECT *) pc))
+	{
+	  block_addr = (find_constant_address (pc));
+	  type = pcl_constant;
+	}
+      else if (ADDRESS_UCODE_P (pc))
 	{
 	  int index = (pc_to_builtin_index (pc));
 	  if (index >= 0)
@@ -750,6 +776,10 @@ classify_pc (unsigned long pc,
 	  if ((OBJECT_TYPE (GET_PRIMITIVE)) == TC_PRIMITIVE)
 	    return (pcl_primitive);
 	}
+
+      if (r_block_addr != 0)
+	(*r_block_addr) = block_addr;
+      return (type);
     }
 #else
   if ((ADDRESS_UCODE_P (pc))
diff --git a/src/microcode/xdebug.c b/src/microcode/xdebug.c
index ee1ee4852..168cebe10 100644
--- a/src/microcode/xdebug.c
+++ b/src/microcode/xdebug.c
@@ -159,9 +159,18 @@ Find_Who_Points (SCHEME_OBJECT Obj, int Find_Mode, int Collect_Mode)
   n += Find_In_Area("Constant Space",
 		    constant_start, constant_alloc_next, Obj,
 		    Find_Mode, print_p, store_p);
+#ifndef ENABLE_SMP
   n += Find_In_Area("the Heap",
 		    heap_start, Saved_Free, Obj,
 		    Find_Mode, print_p, store_p);
+#else
+  n += Find_In_Area("the local Heap",
+		    heap_start, Saved_Free, Obj,
+		    Find_Mode, print_p, store_p);
+  n += Find_In_Area("the shared Heap",
+		    shared_heap_start, shared_heap_free, Obj,
+		    Find_Mode, print_p, store_p);
+#endif
   n += Find_In_Area("the Stack",
 		    stack_pointer, stack_end, Obj,
 		    Find_Mode, print_p, store_p);
diff --git a/src/runtime/savres.scm b/src/runtime/savres.scm
index 3e5688cc8..eecfd60d5 100644
--- a/src/runtime/savres.scm
+++ b/src/runtime/savres.scm
@@ -55,27 +55,10 @@ USA.
       (lambda ()
 	(call-with-current-continuation
 	 (lambda (continuation)
-	   ;; GC cannot be allowed before the fixed-objects-vector
-	   ;; is reset after restoring.
-	   (with-absolutely-no-interrupts
-	     (lambda ()
-	       (let ((fixed-objects (get-fixed-objects-vector)))
-		 ((ucode-primitive call-with-current-continuation)
-		  (lambda (restart)
-		    (with-interrupt-mask interrupt-mask/gc-ok
-		      (lambda (interrupt-mask)
-			interrupt-mask
-			(gc-flip)
-			(do ()
-			    (((ucode-primitive dump-band) restart filename))
-			  (with-simple-restart 'RETRY "Try again."
-			    (lambda ()
-			      (error "Disk save failed:" filename))))
-			(continuation
-			 (lambda ()
-			   (set! time-world-saved time)
-			   (if (string? id) unspecific #f)))))))
-		 ((ucode-primitive set-fixed-objects-vector!) fixed-objects))))
+	   (if (implemented-primitive-procedure?
+		(ucode-primitive smp-count 0))
+	       (smp-drop-band continuation filename id time)
+	       (drop-band continuation filename id time))
 	   (read-microcode-tables!)
 	   (lambda ()
 	     (set! time-world-saved time)
@@ -95,6 +78,57 @@ USA.
 		   (else
 		    (event-distributor/invoke! event:after-restart)
 		    #t))))))))))
+
+(define (drop-band continuation filename id time)
+  ;; GC cannot be allowed before the fixed-objects-vector
+  ;; is reset after restoring.
+  (with-absolutely-no-interrupts
+   (lambda ()
+     (let ((fixed-objects (get-fixed-objects-vector)))
+       ((ucode-primitive call-with-current-continuation)
+	(lambda (restart)
+	  (with-interrupt-mask interrupt-mask/gc-ok
+	    (lambda (interrupt-mask)
+	      interrupt-mask
+	      (gc-flip)
+	      (do ()
+		  (((ucode-primitive dump-band) restart filename))
+		(with-simple-restart 'RETRY "Try again."
+		  (lambda ()
+		    (error "Disk save failed:" filename))))
+	      (continuation
+	       (lambda ()
+		 (set! time-world-saved time)
+		 (if (string? id) unspecific #f)))))))
+       ((ucode-primitive set-fixed-objects-vector!) fixed-objects)))))
+
+(define (smp-drop-band continuation filename id time)
+  ;; Just like drop-band, except dump-band starts the flip
+  ;; and RESTART will finish it as well as restore the
+  ;; fixed-objects.
+  (with-absolutely-no-interrupts
+   (lambda ()
+     (let ((fixed-objects (get-fixed-objects-vector)))
+       (define-integrable (trigger-primitive-gc-daemons!)
+	 ((vector-ref fixed-objects #x0B)))
+       ((ucode-primitive call-with-current-continuation)
+	(lambda (restart)
+	  (do ()
+	      (((ucode-primitive dump-band) restart filename))
+	    (trigger-primitive-gc-daemons!)
+	    (with-interrupt-mask interrupt-mask/gc-ok
+	      (lambda (interrupt-mask)
+		interrupt-mask
+		(with-simple-restart 'RETRY "Try again."
+		  (lambda ()
+		    (error "Disk save failed:" filename))))))
+	  (continuation
+	   (lambda ()
+	     (trigger-primitive-gc-daemons!)
+	     (set! time-world-saved time)
+	     (if (string? id) unspecific #f)))))
+       ((ucode-primitive set-fixed-objects-vector!) fixed-objects)
+       (trigger-primitive-gc-daemons!)))))
 
 (define (disk-restore #!optional filename)
   ;; Force order of events -- no need to run event:before-exit if