From: Taylor R Campbell <campbell@mumble.net>
Date: Sun, 5 Sep 2010 05:04:47 +0000 (+0000)
Subject: Fix total botch of last commit.
X-Git-Tag: 20101212-Gtk~64
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=79916a39d29ec13ac00209db70ecad7641095132;p=mit-scheme.git

Fix total botch of last commit.

Make the GC cleverer about reallocating the ephemeron array, in order
to avoid potentially quadratic-time behaviour in MAKE-EPHEMERON and
fasloading files with ephemerons in them.

Now fasls and bands with ephemerons in them should really work, this
time with feeling...
---

diff --git a/src/microcode/extern.h b/src/microcode/extern.h
index 4d0b24918..3b2b48e86 100644
--- a/src/microcode/extern.h
+++ b/src/microcode/extern.h
@@ -192,6 +192,10 @@ extern unsigned long heap_reserved;
 
 /* Amount of space needed when GC requested */
 extern unsigned long gc_space_needed;
+
+/* Number of new ephemerons requested from the GC.  */
+extern unsigned long n_ephemerons_requested;
+extern bool ephemeron_request_hard_p;
 
 /* Arithmetic utilities */
 extern SCHEME_OBJECT Mul (SCHEME_OBJECT, SCHEME_OBJECT);
@@ -279,6 +283,8 @@ extern SCHEME_OBJECT memory_to_symbol (unsigned long, const void *);
 extern SCHEME_OBJECT find_symbol (unsigned long, const char *);
 extern void strengthen_symbol (SCHEME_OBJECT);
 extern void weaken_symbol (SCHEME_OBJECT);
+extern unsigned long compute_extra_ephemeron_space (unsigned long);
+extern void guarantee_extra_ephemeron_space (unsigned long);
 
 /* Random and OS utilities */
 extern int strcmp_ci (const char *, const char *);
diff --git a/src/microcode/fasdump.c b/src/microcode/fasdump.c
index 37c0c6dd7..cbe67be6b 100644
--- a/src/microcode/fasdump.c
+++ b/src/microcode/fasdump.c
@@ -472,7 +472,9 @@ DEFINE_GC_HANDLER (handle_environment)
 static
 DEFINE_GC_HANDLER (handle_ephemeron)
 {
-  dumped_ephemeron_count += 1;
+  /* Count each one once by counting only if there is no borken heart.  */
+  if (0 == (GC_PRECHECK_FROM (OBJECT_ADDRESS (object))))
+    dumped_ephemeron_count += 1;
   return (gc_handle_unaligned_vector (scan, object));
 }
 
diff --git a/src/microcode/fasload.c b/src/microcode/fasload.c
index 3e7cf3f40..31b9952da 100644
--- a/src/microcode/fasload.c
+++ b/src/microcode/fasload.c
@@ -50,10 +50,7 @@ static SCHEME_OBJECT * new_prim_table;
 #define REQUIRED_HEAP(h)						\
   ((FASLHDR_HEAP_SIZE (h))						\
    + (FASLHDR_N_PRIMITIVES (h))						\
-   + (FASLHDR_PRIMITIVE_TABLE_SIZE (h))					\
-   + (((FASLHDR_VERSION (h)) >= FASL_VERSION_EPHEMERONS)		\
-      ? (VECTOR_DATA + (FASLHDR_EPHEMERON_COUNT (h)))			\
-      : 0))
+   + (FASLHDR_PRIMITIVE_TABLE_SIZE (h)))
 
 struct load_band_termination_state
 {
@@ -102,6 +99,8 @@ that was dumped.")
   fasl_file_handle_t handle;
   static unsigned long failed_heap_length = 0;
   unsigned long heap_length;
+  unsigned long n_ephemerons = 0;
+  unsigned long extra_ephemeron_space = 0;
   SCHEME_OBJECT result;
   PRIMITIVE_HEADER (1);
 
@@ -113,11 +112,19 @@ that was dumped.")
     signal_error_from_primitive (ERR_FASL_FILE_TOO_BIG);
 
   heap_length = (REQUIRED_HEAP (fh));
-  if (GC_NEEDED_P (heap_length))
+  if ((FASLHDR_VERSION (fh)) >= FASL_VERSION_EPHEMERONS)
+    {
+      n_ephemerons = (FASLHDR_EPHEMERON_COUNT (fh));
+      extra_ephemeron_space
+	= (compute_extra_ephemeron_space (ephemeron_count + n_ephemerons));
+    }
+  if (GC_NEEDED_P (heap_length + extra_ephemeron_space))
     {
       if (heap_length == failed_heap_length)
 	signal_error_from_primitive (ERR_FASL_FILE_TOO_BIG);
       failed_heap_length = heap_length;
+      n_ephemerons_requested = n_ephemerons;
+      ephemeron_request_hard_p = false;
       REQUEST_GC (heap_length);
       signal_interrupt_from_primitive ();
     }
@@ -245,9 +252,13 @@ read_band_file (SCHEME_OBJECT s)
   transaction_record_action (tat_abort, terminate_band_load, state);
 
   init_fasl_file (file_name, true, (&handle));
-  if (!allocations_ok_p ((FASLHDR_CONSTANT_SIZE (fh)),
-			 (REQUIRED_HEAP (fh)),
-			 (FASLHDR_HEAP_RESERVED (fh))))
+  if (!allocations_ok_p
+      ((FASLHDR_CONSTANT_SIZE (fh)),
+       ((REQUIRED_HEAP (fh))
+	+ (((FASLHDR_VERSION (fh)) >= FASL_VERSION_EPHEMERONS)
+	   ? (compute_extra_ephemeron_space (FASLHDR_EPHEMERON_COUNT (fh)))
+	   : 0)),
+       (FASLHDR_HEAP_RESERVED (fh))))
     signal_error_from_primitive (ERR_FASL_FILE_TOO_BIG);
 
   /* Now read the file into memory.  Past this point we can't abort
@@ -257,6 +268,8 @@ read_band_file (SCHEME_OBJECT s)
 
   reset_allocator_parameters
     ((FASLHDR_CONSTANT_SIZE (fh)), (FASLHDR_HEAP_RESERVED (fh)));
+  /* We cleared the heap; the ephemeron array is now bogus.  */
+  ephemeron_array = SHARP_F;
   result = (load_file (handle, 0));
 
   /* Done -- we have the new image.  */
@@ -355,7 +368,7 @@ execute_reload_cleanups (void)
 }
 
 static SCHEME_OBJECT
-load_file (fasl_file_handle_t handle, unsigned long prior_ephemeron_count)
+load_file (fasl_file_handle_t handle, unsigned long old_ephemeron_count)
 {
   new_heap_start = Free;
   new_constant_start = constant_alloc_next;
@@ -436,11 +449,8 @@ load_file (fasl_file_handle_t handle, unsigned long prior_ephemeron_count)
 #endif
 
   if ((FASLHDR_VERSION (fh)) >= FASL_VERSION_EPHEMERONS)
-    {
-      ephemeron_count
-	= (prior_ephemeron_count + (FASLHDR_EPHEMERON_COUNT (fh)));
-      ephemeron_array = (make_vector (ephemeron_count, SHARP_F, false));
-    }
+    guarantee_extra_ephemeron_space
+      (old_ephemeron_count + (FASLHDR_EPHEMERON_COUNT (fh)));
 
   return
     (* ((SCHEME_OBJECT *)
diff --git a/src/microcode/memmag.c b/src/microcode/memmag.c
index be686bc07..498514e49 100644
--- a/src/microcode/memmag.c
+++ b/src/microcode/memmag.c
@@ -73,6 +73,8 @@ static gc_tospace_allocator_t allocate_tospace;
 static gc_abort_handler_t abort_gc NORETURN;
 static gc_walk_proc_t save_tospace_copy;
 
+static unsigned long compute_ephemeron_array_length (unsigned long);
+
 /* Memory Allocation, sequential processor:
 
 oo
@@ -320,14 +322,28 @@ std_gc_pt2 (void)
   history_register = (OBJECT_ADDRESS (*saved_to++));
   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_request_hard_p)
+	  gc_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 at least as many slots as there
-     are live ephemerons.  Add one for the vector's manifest.  */
-  if (GC_NEEDED_P (ephemeron_count + 1))
-    std_gc_death ("No room for ephemeron array");
+	/* 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))
+	  std_gc_death ("No room for ephemeron array");
 #endif
-  ephemeron_array = (make_vector (ephemeron_count, SHARP_F, false));
+      }
+    ephemeron_array = (make_vector (length, SHARP_F, false));
+    n_ephemerons_requested = 0;
+    ephemeron_request_hard_p = false;
+  }
 
   CC_TRANSPORT_END ();
   CLEAR_INTERRUPT (INT_GC);
@@ -383,19 +399,19 @@ static unsigned long primes [] =
   };
 
 static unsigned long
-compute_ephemeron_array_length (void)
+compute_ephemeron_array_length (unsigned long n)
 {
   unsigned int start = 0, end = ((sizeof primes) / (sizeof (*primes)));
   unsigned int index;
 
-  if ((primes [end - 1]) < ephemeron_count)
+  if ((primes [end - 1]) < n)
     return (primes [end - 1]);
 
   do {
     index = (start + ((end - start) / 2));
-    if ((primes [index]) < ephemeron_count)
+    if ((primes [index]) < n)
       start = (index + 1);
-    else if (ephemeron_count < (primes [index]))
+    else if (n < (primes [index]))
       end = index;
     else
       return (primes [index]);
@@ -404,30 +420,60 @@ compute_ephemeron_array_length (void)
   return (primes [start]);
 }
 
-static void
-guarantee_ephemeron_space (void)
+static bool
+ephemeron_array_big_enough_p (unsigned long n)
+{
+  return
+    ((n == 0)
+     || ((VECTOR_P (ephemeron_array))
+	 && (n <= (VECTOR_LENGTH (ephemeron_array)))));
+}
+
+unsigned long
+compute_extra_ephemeron_space (unsigned long n)
 {
-  /* Guarantee space after Free and in the ephemeron array for one
-     ephemeron.  */
-  if ((VECTOR_P (ephemeron_array))
-      && (ephemeron_count <= (VECTOR_LENGTH (ephemeron_array))))
-    Primitive_GC_If_Needed (EPHEMERON_SIZE);
+  if (ephemeron_array_big_enough_p (n))
+    return (0);
   else
+    return (VECTOR_DATA + (compute_ephemeron_array_length (n)));
+}
+
+void
+guarantee_extra_ephemeron_space (unsigned long n)
+{
+  ephemeron_count = n;
+  if (!ephemeron_array_big_enough_p (n))
     {
-      unsigned long length = (compute_ephemeron_array_length ());
-      /* We could be cleverer about expanding the ephemeron array, and
-	 tell the GC (above) that we really want an ephemeron array
-	 that is one slot larger.  */
-      Primitive_GC_If_Needed (EPHEMERON_SIZE + VECTOR_DATA + length);
+      unsigned long length = (compute_ephemeron_array_length (n));
+      assert (HEAP_AVAILABLE_P (VECTOR_DATA + length));
       ephemeron_array = (make_vector (length, SHARP_F, false));
     }
 }
+
+static void
+gc_if_needed_for_ephemeron (unsigned long extra_space)
+{
+  if (GC_NEEDED_P (EPHEMERON_SIZE + extra_space))
+    {
+      n_ephemerons_requested = 1;
+      ephemeron_request_hard_p = true;
+      Primitive_GC (EPHEMERON_SIZE);
+    }
+}
 
 DEFINE_PRIMITIVE ("MAKE-EPHEMERON", Prim_make_ephemeron, 2, 2, 0)
 {
   PRIMITIVE_HEADER (2);
   ephemeron_count += 1;
-  guarantee_ephemeron_space ();
+  if (ephemeron_array_big_enough_p (ephemeron_count))
+    gc_if_needed_for_ephemeron (0);
+  else
+    {
+      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));
+    }
   {
     SCHEME_OBJECT * addr = Free;
     (*Free++) = MARKED_EPHEMERON_MANIFEST;
diff --git a/src/microcode/storage.c b/src/microcode/storage.c
index 432734020..782d53e38 100644
--- a/src/microcode/storage.c
+++ b/src/microcode/storage.c
@@ -84,6 +84,10 @@ unsigned long heap_reserved;
 /* Amount of space needed when GC requested */
 unsigned long gc_space_needed;
 
+/* Number of new ephemerons requested from the GC.  */
+unsigned long n_ephemerons_requested;
+bool ephemeron_request_hard_p;
+
 #ifndef HEAP_IN_LOW_MEMORY
    SCHEME_OBJECT * memory_base;
 #endif