scm_newline (scm_current_error_port ()); \
}
+/* The VM has a number of internal assertions that shouldn't normally be
+ necessary, but might be if you think you found a bug in the VM. */
+#define VM_ENABLE_ASSERTIONS
+
+/* We can add a mode that ensures that all stack items above the stack pointer
+ are NULL. This is useful for checking the internal consistency of the VM's
+ assumptions and its operators, but isn't necessary for normal operation. It
+ will ensure that assertions are enabled. */
+#define VM_ENABLE_STACK_NULLING
+
+#if defined (VM_ENABLE_STACK_NULLING) && !defined (VM_ENABLE_ASSERTIONS)
+#define VM_ENABLE_ASSERTIONS
+#endif
+
\f
/*
* VM Continuation
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, *upper, *lower;
+ sp = base + size - 1;
-#define SCM_VM_CONT_P(OBJ) SCM_SMOB_PREDICATE (scm_tc16_vm_cont, OBJ)
-#define SCM_VM_CONT_VP(CONT) ((struct scm_vm *) SCM_CELL_WORD_1 (CONT))
+ while (sp > base && fp)
+ {
+ upper = SCM_FRAME_UPPER_ADDRESS (fp);
+ lower = SCM_FRAME_LOWER_ADDRESS (fp);
+
+ for (; sp >= upper; sp--)
+ if (SCM_NIMP (*sp))
+ {
+ if (scm_in_heap_p (*sp))
+ scm_gc_mark (*sp);
+ 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;
+
+ /* mark from the el down to the lower address */
+ for (; sp >= lower; sp--)
+ if (*sp && SCM_NIMP (*sp))
+ scm_gc_mark (*sp);
+ }
+}
+
+static SCM
+vm_cont_mark (SCM obj)
+{
+ struct scm_vm_cont *p = SCM_VM_CONT_DATA (obj);
+
+ vm_mark_stack (p->stack_base, p->stack_size, p->stack_base + p->fp, p->reloc);
+
+ return SCM_BOOL_F;
+}
+
+static scm_sizet
+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 (struct scm_vm), "vm");
+
+ return 0;
+}
static SCM
capture_vm_cont (struct scm_vm *vp)
{
- struct scm_vm *p = scm_gc_malloc (sizeof (*p), "capture_vm_cont");
- p->stack_size = vp->stack_limit - vp->sp;
+ struct scm_vm_cont *p = scm_gc_malloc (sizeof (*p), "capture_vm_cont");
+ p->stack_size = vp->sp - vp->stack_base + 1;
p->stack_base = scm_gc_malloc (p->stack_size * sizeof (SCM),
"capture_vm_cont");
- p->stack_limit = p->stack_base + p->stack_size - 2;
+#ifdef VM_ENABLE_STACK_NULLING
+ if (vp->sp >= vp->stack_base)
+ if (!vp->sp[0] || vp->sp[1])
+ abort ();
+ memset (p->stack_base, 0, p->stack_size * sizeof (SCM));
+#endif
p->ip = vp->ip;
- p->sp = (SCM *) (vp->stack_limit - vp->sp);
- p->fp = (SCM *) (vp->stack_limit - vp->fp);
- memcpy (p->stack_base, vp->sp + 1, vp->stack_size * sizeof (SCM));
+ p->sp = vp->sp - vp->stack_base;
+ p->fp = vp->fp - vp->stack_base;
+ memcpy (p->stack_base, vp->stack_base, p->stack_size * sizeof (SCM));
+ p->reloc = p->stack_base - vp->stack_base;
SCM_RETURN_NEWSMOB (scm_tc16_vm_cont, p);
}
static void
reinstate_vm_cont (struct scm_vm *vp, SCM cont)
{
- struct scm_vm *p = SCM_VM_CONT_VP (cont);
+ struct scm_vm_cont *p = SCM_VM_CONT_DATA (cont);
if (vp->stack_size < p->stack_size)
{
/* puts ("FIXME: Need to expand"); */
abort ();
}
+#ifdef VM_ENABLE_STACK_NULLING
+ {
+ scm_t_ptrdiff nzero = (vp->sp - vp->stack_base) - p->sp;
+ if (nzero > 0)
+ memset (vp->stack_base + p->stack_size, 0, nzero * sizeof (SCM));
+ /* actually nzero should always be negative, because vm_reset_stack will
+ unwind the stack to some point *below* this continuation */
+ }
+#endif
vp->ip = p->ip;
- vp->sp = vp->stack_limit - (intptr_t) p->sp;
- vp->fp = vp->stack_limit - (intptr_t) p->fp;
- memcpy (vp->sp + 1, p->stack_base, p->stack_size * sizeof (SCM));
+ vp->sp = vp->stack_base + p->sp;
+ vp->fp = vp->stack_base + p->fp;
+ memcpy (vp->stack_base, p->stack_base, p->stack_size * sizeof (SCM));
+}
+
+/* In theory, a number of vm instances can be active in the call trace, and we
+ only want to reify the continuations of those in the current continuation
+ root. I don't see a nice way to do this -- ideally it would involve dynwinds,
+ and previous values of the *the-vm* fluid within the current continuation
+ root. But we don't have access to continuation roots in the dynwind stack.
+ So, just punt for now -- take the current value of *the-vm*.
+
+ While I'm on the topic, ideally we could avoid copying the C stack if the
+ continuation root is inside VM code, and call/cc was invoked within that same
+ call to vm_run; but that's currently not implemented.
+ */
+SCM
+scm_vm_capture_continuations (void)
+{
+ SCM vm = scm_the_vm ();
+ return scm_acons (vm, capture_vm_cont (SCM_VM_DATA (vm)), SCM_EOL);
+}
+
+void
+scm_vm_reinstate_continuations (SCM conts)
+{
+ for (; conts != SCM_EOL; conts = SCM_CDR (conts))
+ reinstate_vm_cont (SCM_VM_DATA (SCM_CAAR (conts)), SCM_CDAR (conts));
}
struct vm_unwind_data
struct scm_vm *vp;
SCM *sp;
SCM *fp;
- SCM this_frame;
};
static void
vm_reset_stack (void *data)
{
struct vm_unwind_data *w = data;
+ struct scm_vm *vp = w->vp;
- w->vp->sp = w->sp;
- w->vp->fp = w->fp;
- w->vp->this_frame = w->this_frame;
+ vp->sp = w->sp;
+ vp->fp = w->fp;
+#ifdef VM_ENABLE_STACK_NULLING
+ memset (vp->sp + 1, 0, (vp->stack_size - (vp->sp + 1 - vp->stack_base)) * sizeof(SCM));
+#endif
}
-static SCM
-vm_cont_mark (SCM obj)
-{
- SCM *p;
- struct scm_vm *vp = SCM_VM_CONT_VP (obj);
- for (p = vp->stack_base; p <= vp->stack_limit; p++)
- if (SCM_NIMP (*p))
- scm_gc_mark (*p);
- return SCM_BOOL_F;
+static void enfalsen_frame (void *p)
+{
+ struct scm_vm *vp = p;
+ vp->trace_frame = SCM_BOOL_F;
}
-static scm_sizet
-vm_cont_free (SCM obj)
+static void
+vm_dispatch_hook (SCM vm, SCM hook, SCM hook_args)
{
- struct scm_vm *p = SCM_VM_CONT_VP (obj);
+ struct scm_vm *vp = SCM_VM_DATA (vm);
- scm_gc_free (p->stack_base, p->stack_size * sizeof (SCM), "stack-base");
- scm_gc_free (p, sizeof (struct scm_vm), "vm");
+ if (!SCM_FALSEP (vp->trace_frame))
+ return;
+
+ scm_dynwind_begin (0);
+ vp->trace_frame = scm_c_make_vm_frame (vm, vp->fp, vp->sp, vp->ip, 0);
+ scm_dynwind_unwind_handler (enfalsen_frame, vp, SCM_F_WIND_EXPLICITLY);
- return 0;
+ scm_c_run_hook (hook, hook_args);
+
+ scm_dynwind_end ();
}
\f
return ip;
}
-static SCM
-vm_heapify_frames_1 (struct scm_vm *vp, SCM *fp, SCM *sp, SCM **destp)
-{
- SCM frame;
- SCM *dl = SCM_FRAME_DYNAMIC_LINK (fp);
-#if 0
- SCM *src = SCM_FRAME_UPPER_ADDRESS (fp);
-#endif
- SCM *dest = SCM_FRAME_LOWER_ADDRESS (fp);
-
- if (!dl)
- {
- /* The top frame */
- frame = scm_c_make_heap_frame (fp);
- fp = SCM_HEAP_FRAME_POINTER (frame);
- SCM_FRAME_HEAP_LINK (fp) = SCM_BOOL_T;
- }
- else
- {
- /* Child frames */
- SCM link = SCM_FRAME_HEAP_LINK (dl);
- if (!SCM_FALSEP (link))
- link = SCM_FRAME_LOWER_ADDRESS (dl)[-1]; /* self link */
- else
- link = vm_heapify_frames_1 (vp, dl, dest - 1, &dest);
- frame = scm_c_make_heap_frame (fp);
- fp = SCM_HEAP_FRAME_POINTER (frame);
- SCM_FRAME_HEAP_LINK (fp) = link;
- SCM_FRAME_SET_DYNAMIC_LINK (fp, SCM_HEAP_FRAME_POINTER (link));
- }
-
- /* Apparently the intention here is to be able to have a frame on the heap,
- but data on the stack, so that you can push as much as you want on the
- stack; but I think that it's currently causing borkage with nonlocal exits
- and the unwind handler, which reinstates the sp and fp, but it's no longer
- pointing at a valid stack frame. So disable for now, we'll get back to
- this later. */
-#if 0
- /* Move stack data */
- for (; src <= sp; src++, dest++)
- *dest = *src;
- *destp = dest;
-#endif
-
- return frame;
-}
-
-static SCM
-vm_heapify_frames (SCM vm)
-{
- struct scm_vm *vp = SCM_VM_DATA (vm);
- if (SCM_FALSEP (SCM_FRAME_HEAP_LINK (vp->fp)))
- {
- SCM *dest;
- vp->this_frame = vm_heapify_frames_1 (vp, vp->fp, vp->sp, &dest);
- vp->fp = SCM_HEAP_FRAME_POINTER (vp->this_frame);
- vp->sp = dest - 1;
- }
- return vp->this_frame;
-}
-
\f
/*
* VM
scm_t_bits scm_tc16_vm;
-SCM scm_the_vm_fluid;
-
static SCM
make_vm (void)
#define FUNC_NAME "make_vm"
vp->stack_size = VM_DEFAULT_STACK_SIZE;
vp->stack_base = scm_gc_malloc (vp->stack_size * sizeof (SCM),
"stack-base");
+#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->ip = NULL;
vp->sp = vp->stack_base - 1;
vp->time = 0;
vp->clock = 0;
vp->options = SCM_EOL;
- vp->this_frame = SCM_BOOL_F;
- vp->last_frame = SCM_BOOL_F;
- vp->last_ip = NULL;
for (i = 0; i < SCM_VM_NUM_HOOKS; i++)
vp->hooks[i] = SCM_BOOL_F;
+ vp->trace_frame = SCM_BOOL_F;
SCM_RETURN_NEWSMOB (scm_tc16_vm, vp);
}
#undef FUNC_NAME
int i;
struct scm_vm *vp = SCM_VM_DATA (obj);
- /* mark the stack conservatively */
- scm_mark_locations ((SCM_STACKITEM *) vp->stack_base,
- sizeof (SCM) * (vp->sp - vp->stack_base + 1));
+#ifdef VM_ENABLE_STACK_NULLING
+ if (vp->sp >= vp->stack_base)
+ if (!vp->sp[0] || vp->sp[1])
+ abort ();
+#endif
+
+ /* mark the stack, precisely */
+ vm_mark_stack (vp->stack_base, vp->sp + 1 - vp->stack_base, vp->fp, 0);
/* mark other objects */
for (i = 0; i < SCM_VM_NUM_HOOKS; i++)
scm_gc_mark (vp->hooks[i]);
- scm_gc_mark (vp->this_frame);
- scm_gc_mark (vp->last_frame);
+
+ scm_gc_mark (vp->trace_frame);
+
return vp->options;
}
"")
#define FUNC_NAME s_scm_the_vm
{
- return scm_fluid_ref (scm_the_vm_fluid);
+ scm_i_thread *t = SCM_I_CURRENT_THREAD;
+
+ if (SCM_UNLIKELY (SCM_FALSEP ((t->vm))))
+ t->vm = make_vm ();
+
+ return t->vm;
}
#undef FUNC_NAME
}
#undef FUNC_NAME
-#define VM_CHECK_RUNNING(vm) \
- if (!SCM_VM_DATA (vm)->ip) \
- SCM_MISC_ERROR ("Not running", SCM_LIST1 (vm))
-
-SCM_DEFINE (scm_vm_this_frame, "vm-this-frame", 1, 0, 0,
+SCM_DEFINE (scm_vm_trace_frame, "vm-trace-frame", 1, 0, 0,
(SCM vm),
"")
-#define FUNC_NAME s_scm_vm_this_frame
+#define FUNC_NAME s_scm_vm_trace_frame
{
SCM_VALIDATE_VM (1, vm);
- return SCM_VM_DATA (vm)->this_frame;
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_vm_last_frame, "vm-last-frame", 1, 0, 0,
- (SCM vm),
- "")
-#define FUNC_NAME s_scm_vm_last_frame
-{
- SCM_VALIDATE_VM (1, vm);
- return SCM_VM_DATA (vm)->last_frame;
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_vm_last_ip, "vm:last-ip", 1, 0, 0,
- (SCM vm),
- "")
-#define FUNC_NAME s_scm_vm_last_ip
-{
- SCM_VALIDATE_VM (1, vm);
- return scm_from_ulong ((unsigned long) SCM_VM_DATA (vm)->last_ip);
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_vm_save_stack, "vm-save-stack", 1, 0, 0,
- (SCM vm),
- "")
-#define FUNC_NAME s_scm_vm_save_stack
-{
- struct scm_vm *vp;
- SCM *dest;
- SCM_VALIDATE_VM (1, vm);
- vp = SCM_VM_DATA (vm);
-
- if (vp->fp)
- {
- vp->last_frame = vm_heapify_frames_1 (vp, vp->fp, vp->sp, &dest);
- vp->last_ip = vp->ip;
- }
- else
- {
- vp->last_frame = SCM_BOOL_F;
- }
-
-
- return vp->last_frame;
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_vm_fetch_code, "vm-fetch-code", 1, 0, 0,
- (SCM vm),
- "")
-#define FUNC_NAME s_scm_vm_fetch_code
-{
- int i;
- SCM list;
- scm_byte_t *ip;
- struct scm_instruction *p;
-
- SCM_VALIDATE_VM (1, vm);
- VM_CHECK_RUNNING (vm);
-
- ip = SCM_VM_DATA (vm)->ip;
- p = SCM_INSTRUCTION (*ip);
-
- list = SCM_LIST1 (scm_str2symbol (p->name));
- for (i = 1; i <= p->len; i++)
- list = scm_cons (SCM_I_MAKINUM (ip[i]), list);
- return scm_reverse_x (list, SCM_EOL);
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_vm_fetch_stack, "vm-fetch-stack", 1, 0, 0,
- (SCM vm),
- "")
-#define FUNC_NAME s_scm_vm_fetch_stack
-{
- SCM *sp;
- SCM ls = SCM_EOL;
- struct scm_vm *vp;
-
- SCM_VALIDATE_VM (1, vm);
- VM_CHECK_RUNNING (vm);
-
- vp = SCM_VM_DATA (vm);
- for (sp = vp->stack_base; sp <= vp->sp; sp++)
- ls = scm_cons (*sp, ls);
- return ls;
+ return SCM_VM_DATA (vm)->trace_frame;
}
#undef FUNC_NAME
SCM scm_load_compiled_with_vm (SCM file)
{
- SCM program = scm_objcode_to_program (scm_load_objcode (file));
+ SCM program = scm_objcode_to_program (scm_load_objcode (file), SCM_EOL);
return vm_run (scm_the_vm (), program, SCM_EOL);
}
scm_set_smob_free (scm_tc16_vm, vm_free);
scm_set_smob_apply (scm_tc16_vm, scm_vm_apply, 1, 0, 1);
- scm_the_vm_fluid = scm_permanent_object (scm_make_fluid ());
- scm_fluid_set_x (scm_the_vm_fluid, make_vm ());
- scm_c_define ("*the-vm*", scm_the_vm_fluid);
-
scm_c_define ("load-compiled",
scm_c_make_gsubr ("load-compiled/vm", 1, 0, 0,
scm_load_compiled_with_vm));
HCoop / bpt / guile.git / blobdiff