diff options
Diffstat (limited to 'libguile/vm.c')
-rw-r--r-- | libguile/vm.c | 145 |
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 |