Fix Primitive_GC to request the right amount of space from the GC.

New variable Free_primitive is set during primitive invocations to
the value of Free on entry, so that Primitive_GC can find the total
amount of space requested so far from the GC, rather than the amount
currently being requested.  Avoids endless GC loops, particularly in,
e.g., bignum primitives.

diff --git a/src/microcode/extern.h b/src/microcode/extern.h
index 982c199ff3b9f3e35f60005f9106e992c8859923..b9425bcc10b7b9e98801c94000549c7c06bcf1ff 100644 (file)
--- a/src/microcode/extern.h
+++ b/src/microcode/extern.h
@@ -138,6 +138,7 @@ extern void set_ulong_register (unsigned int, unsigned long);
 #endif
 
 extern SCHEME_OBJECT * Free;
+extern SCHEME_OBJECT * Free_primitive;
 extern SCHEME_OBJECT * heap_alloc_limit;
 extern SCHEME_OBJECT * heap_start;
 extern SCHEME_OBJECT * heap_end;

diff --git a/src/microcode/interp.h b/src/microcode/interp.h
index 5d72e5246526885dae277d4d321a0bdcce906c45..e397de5a268e719bf20087abf9934d13c0278e74 100644 (file)
--- a/src/microcode/interp.h
+++ b/src/microcode/interp.h
@@ -119,6 +119,7 @@ USA.
 {                                                                      \
   void * PRIMITIVE_APPLY_INTERNAL_position = dstack_position;          \
   SET_PRIMITIVE (primitive);                                           \
+  Free_primitive = Free;                                               \
   SET_VAL                                                              \
     ((* (Primitive_Procedure_Table [PRIMITIVE_NUMBER (primitive)]))    \
      ());                                                              \
@@ -129,6 +130,7 @@ USA.
                  (PRIMITIVE_NAME (primitive)));                        \
       Microcode_Termination (TERM_EXIT);                               \
     }                                                                  \
+  Free_primitive = 0;                                                  \
   SET_PRIMITIVE (SHARP_F);                                             \
 } while (0)
 

diff --git a/src/microcode/prims.h b/src/microcode/prims.h
index e6dbb098daa858a24667b641ea68a9a51665fb8f..aeccc02fabf2fe6d13995faafb70ab90d01943e7 100644 (file)
--- a/src/microcode/prims.h
+++ b/src/microcode/prims.h
@@ -58,7 +58,18 @@ SCHEME_OBJECT fn_name (void)
 
 #define Primitive_GC(Amount) do                                                \
 {                                                                      \
-  REQUEST_GC (Amount);                                                 \
+  if (Free_primitive < heap_start)                                     \
+    {                                                                  \
+      outf_fatal                                                       \
+        ("\nMicrocode requested primitive GC outside primitive!\n");   \
+      Microcode_Termination (TERM_EXIT);                               \
+    }                                                                  \
+  if (Free < Free_primitive)                                           \
+    {                                                                  \
+      outf_fatal ("\nFree has gone backwards!\n");                     \
+      Microcode_Termination (TERM_EXIT);                               \
+    }                                                                  \
+  REQUEST_GC ((Amount) + (Free - Free_primitive));                     \
   signal_interrupt_from_primitive ();                                  \
 } while (0)
 

diff --git a/src/microcode/storage.c b/src/microcode/storage.c
index 9b7ae288d2564fd6265a085405f0f9e2e8cce3f3..44e9d5afba8160524c8be88a6143d0b315c5d1ce 100644 (file)
--- a/src/microcode/storage.c
+++ b/src/microcode/storage.c
@@ -35,6 +35,9 @@ USA.
 /* next free word in heap */
 SCHEME_OBJECT * Free;
 
+/* value of Free on entry to primitive, or 0 if not in primitive */
+SCHEME_OBJECT * Free_primitive = 0;
+
 /* strict limit for Free */
 SCHEME_OBJECT * heap_alloc_limit;