From: Taylor R Campbell <campbell@mumble.net>
Date: Sun, 26 Jun 2011 20:29:15 +0000 (+0000)
Subject: Fix Primitive_GC to request the right amount of space from the GC.
X-Git-Tag: release-9.1.0~3^2
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=ca08b665a91491093722534a66a31c67cc995ec5;p=mit-scheme.git

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 982c199ff..b9425bcc1 100644
--- 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 5d72e5246..e397de5a2 100644
--- 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 e6dbb098d..aeccc02fa 100644
--- 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 9b7ae288d..44e9d5afb 100644
--- 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;