summaryrefslogtreecommitdiff
path: root/libguile/vm.c
diff options
context:
space:
mode:
Diffstat (limited to 'libguile/vm.c')
-rw-r--r--libguile/vm.c145
1 files changed, 63 insertions, 82 deletions
diff --git a/libguile/vm.c b/libguile/vm.c
index 660f25cb4..d215f4d79 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
@@ -63,56 +75,6 @@
scm_t_bits scm_tc16_vm_cont;
-static void
-vm_mark_stack (SCM *base, scm_t_ptrdiff size, SCM *fp, scm_t_ptrdiff reloc)
-{
- SCM *sp, *mark;
- sp = base + size - 1;
-
- while (sp > base && fp)
- {
- mark = SCM_FRAME_LOWER_ADDRESS (fp) + 3;
-
- for (; sp >= mark; sp--)
- if (SCM_NIMP (*sp))
- {
- if (scm_in_heap_p (*sp))
- scm_gc_mark (*sp);
- /* this can happen for open frames */
- /* else fprintf (stderr, "BADNESS: crap on the stack: %p\n", *sp); */
- }
-
-
- /* skip ra, mvra */
- sp -= 2;
-
- /* update fp from the dynamic link */
- fp = (SCM*)*sp-- + reloc;
- }
-}
-
-static SCM
-vm_cont_mark (SCM obj)
-{
- struct scm_vm_cont *p = SCM_VM_CONT_DATA (obj);
-
- if (p->stack_size)
- vm_mark_stack (p->stack_base, p->stack_size, p->fp + p->reloc, p->reloc);
-
- return SCM_BOOL_F;
-}
-
-static size_t
-vm_cont_free (SCM obj)
-{
- struct scm_vm_cont *p = SCM_VM_CONT_DATA (obj);
-
- scm_gc_free (p->stack_base, p->stack_size * sizeof (SCM), "stack-base");
- scm_gc_free (p, sizeof (*p), "vm-cont");
-
- return 0;
-}
-
static SCM
capture_vm_cont (struct scm_vm *vp)
{
@@ -330,6 +292,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"
@@ -342,12 +311,25 @@ 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
- vp->stack_limit = vp->stack_base + vp->stack_size - 3;
+ vp->stack_limit = vp->stack_base + vp->stack_size;
vp->ip = NULL;
vp->sp = vp->stack_base - 1;
vp->fp = NULL;
@@ -362,41 +344,36 @@ make_vm (void)
}
#undef FUNC_NAME
-static SCM
-vm_mark (SCM obj)
-{
- int i;
- struct scm_vm *vp = SCM_VM_DATA (obj);
+#ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
-#ifdef VM_ENABLE_STACK_NULLING
- if (vp->sp >= vp->stack_base)
- if (!vp->sp[0] || vp->sp[1])
- abort ();
-#endif
+/* 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;
- /* mark the stack, precisely */
- vm_mark_stack (vp->stack_base, vp->sp + 1 - vp->stack_base, vp->fp, 0);
+ /* The first word of the VM stack should contain a pointer to the
+ corresponding VM. */
+ vm = * ((struct scm_vm **) addr);
- /* mark other objects */
- for (i = 0; i < SCM_VM_NUM_HOOKS; i++)
- scm_gc_mark (vp->hooks[i]);
+ if ((SCM *) addr != vm->stack_base - 1
+ || vm->stack_limit - vm->stack_base != vm->stack_size)
+ /* 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;
- scm_gc_mark (vp->trace_frame);
+ 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 vp->options;
+ return mark_stack_ptr;
}
-static size_t
-vm_free (SCM obj)
-{
- struct scm_vm *vp = SCM_VM_DATA (obj);
+#endif /* VM_ENABLE_PRECISE_STACK_GC_SCAN */
- scm_gc_free (vp->stack_base, vp->stack_size * sizeof (SCM),
- "stack-base");
- scm_gc_free (vp, sizeof (struct scm_vm), "vm");
-
- return 0;
-}
SCM
scm_c_vm_run (SCM vm, SCM program, SCM *argv, int nargs)
@@ -664,12 +641,8 @@ scm_bootstrap_vm (void)
scm_bootstrap_programs ();
scm_tc16_vm_cont = scm_make_smob_type ("vm-cont", 0);
- scm_set_smob_mark (scm_tc16_vm_cont, vm_cont_mark);
- scm_set_smob_free (scm_tc16_vm_cont, vm_cont_free);
scm_tc16_vm = scm_make_smob_type ("vm", 0);
- scm_set_smob_mark (scm_tc16_vm, vm_mark);
- scm_set_smob_free (scm_tc16_vm, vm_free);
scm_set_smob_apply (scm_tc16_vm, scm_vm_apply, 1, 0, 1);
scm_c_define ("load-compiled",
@@ -684,6 +657,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