From e3eb628d889b8cb9821a274e41b72f9751b6ee0a Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Thu, 20 Aug 2009 01:56:47 +0200
Subject: [PATCH] Implement precise marking of the VM stack.

Suggested by Andy Wingo.

* libguile/vm.c (VM_ENABLE_PRECISE_STACK_GC_SCAN): New macro.
  (vm_stack_gc_kind): New variable.
  (make_vm)[VM_ENABLE_PRECISE_STACK_GC_SCAN]: Use `GC_generic_malloc ()'
  to allocate the stack.
  (vm_stack_mark): New function.
  (scm_bootstrap_vm)[VM_ENABLE_PRECISE_STACK_GC_SCAN]: Initialize
  `vm_stack_gc_kind'.
---
 libguile/vm.c | 75 +++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 75 insertions(+)

diff --git a/libguile/vm.c b/libguile/vm.c
index 4aa27104a..292092428 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -23,6 +23,11 @@
 #include <stdlib.h>
 #include <alloca.h>
 #include <string.h>
+#include <assert.h>
+
+#include "libguile/boehm-gc.h"
+#include <gc/gc_mark.h>
+
 #include "_scm.h"
 #include "vm-bootstrap.h"
 #include "frames.h"
@@ -56,6 +61,13 @@
 #define VM_ENABLE_ASSERTIONS
 #endif
 
+/* When defined, arrange so that the GC doesn't scan the VM stack beyond its
+   current SP.  This should help avoid excess data retention.  See
+   http://thread.gmane.org/gmane.comp.programming.garbage-collection.boehmgc/3001
+   for a discussion.  */
+#define VM_ENABLE_PRECISE_STACK_GC_SCAN
+
+
 
 /*
  * VM Continuation
@@ -281,6 +293,13 @@ static const scm_t_vm_engine vm_engines[] =
 
 scm_t_bits scm_tc16_vm;
 
+#ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
+
+/* The GC "kind" for the VM stack.  */
+static int vm_stack_gc_kind;
+
+#endif
+
 static SCM
 make_vm (void)
 #define FUNC_NAME "make_vm"
@@ -293,8 +312,21 @@ make_vm (void)
   struct scm_vm *vp = scm_gc_malloc (sizeof (struct scm_vm), "vm");
 
   vp->stack_size  = VM_DEFAULT_STACK_SIZE;
+
+#ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
+  vp->stack_base = GC_generic_malloc (vp->stack_size * sizeof (SCM),
+				      vm_stack_gc_kind);
+
+  /* Keep a pointer to VP so that `vm_stack_mark ()' can know what the stack
+     top is.  */
+  *vp->stack_base = PTR2SCM (vp);
+  vp->stack_base++;
+  vp->stack_size--;
+#else
   vp->stack_base  = scm_gc_malloc (vp->stack_size * sizeof (SCM),
 				   "stack-base");
+#endif
+
 #ifdef VM_ENABLE_STACK_NULLING
   memset (vp->stack_base, 0, vp->stack_size * sizeof (SCM));
 #endif
@@ -313,6 +345,41 @@ make_vm (void)
 }
 #undef FUNC_NAME
 
+#ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
+
+/* Mark the VM stack region between its base and its current top.  */
+static struct GC_ms_entry *
+vm_stack_mark (GC_word *addr, struct GC_ms_entry *mark_stack_ptr,
+	       struct GC_ms_entry *mark_stack_limit, GC_word env)
+{
+  GC_word *word;
+  const struct scm_vm *vm;
+
+  /* The first word of the VM stack should contain a pointer to the
+     corresponding VM.  */
+  vm = * ((struct scm_vm **) addr);
+
+  if (vm->stack_base == NULL)
+    /* ADDR must be a pointer to a free-list element, which we must ignore
+       (see warning in <gc/gc_mark.h>).  */
+    return mark_stack_ptr;
+
+  /* Sanity checks.  */
+  assert ((SCM *) addr == vm->stack_base - 1);
+  assert (vm->sp >= (SCM *) addr);
+  assert (vm->stack_limit - vm->stack_base == vm->stack_size);
+
+  for (word = (GC_word *) vm->stack_base; word <= (GC_word *) vm->sp; word++)
+    mark_stack_ptr = GC_MARK_AND_PUSH ((* (GC_word **) word),
+				       mark_stack_ptr, mark_stack_limit,
+				       NULL);
+
+  return mark_stack_ptr;
+}
+
+#endif /* VM_ENABLE_PRECISE_STACK_GC_SCAN */
+
+
 SCM
 scm_c_vm_run (SCM vm, SCM program, SCM *argv, int nargs)
 {
@@ -595,6 +662,14 @@ scm_bootstrap_vm (void)
                             (scm_t_extension_init_func)scm_init_vm, NULL);
 
   strappage = 1;
+
+#ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
+  vm_stack_gc_kind =
+    GC_new_kind (GC_new_free_list (),
+		 GC_MAKE_PROC (GC_new_proc (vm_stack_mark), 0),
+		 0, 1);
+
+#endif
 }
 
 void