-/* Copyright (C) 2001, 2009 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
#include <stdlib.h>
#include <alloca.h>
#include <string.h>
-#include <assert.h>
#include "libguile/bdw-gc.h"
#include <gc/gc_mark.h>
#include "_scm.h"
-#include "vm-bootstrap.h"
+#include "control.h"
#include "frames.h"
#include "instructions.h"
#include "objcodes.h"
* VM Continuation
*/
-scm_t_bits scm_tc16_vm_cont;
+void
+scm_i_vm_cont_print (SCM x, SCM port, scm_print_state *pstate)
+{
+ scm_puts ("#<vm-continuation ", port);
+ scm_uintprint (SCM_UNPACK (x), 16, port);
+ scm_puts (">", port);
+}
+
+/* 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, we just capture the continuation for the current 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.
+ */
static SCM
-capture_vm_cont (struct scm_vm *vp)
+vm_capture_continuation (SCM *stack_base,
+ SCM *fp, SCM *sp, scm_t_uint8 *ra, scm_t_uint8 *mvra)
{
- struct scm_vm_cont *p = scm_gc_malloc (sizeof (*p), "capture_vm_cont");
- p->stack_size = vp->sp - vp->stack_base + 1;
+ struct scm_vm_cont *p;
+
+ p = scm_gc_malloc (sizeof (*p), "capture_vm_cont");
+ p->stack_size = sp - stack_base + 1;
p->stack_base = scm_gc_malloc (p->stack_size * sizeof (SCM),
"capture_vm_cont");
-#ifdef VM_ENABLE_STACK_NULLING
- if (vp->sp >= vp->stack_base)
+#if defined(VM_ENABLE_STACK_NULLING) && 0
+ /* Tail continuations leave their frame on the stack for subsequent
+ application, but don't capture the frame -- so there are some elements on
+ the stack then, and this check doesn't work, so disable it for now. */
+ if (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 = vp->sp;
- p->fp = vp->fp;
- 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);
+ p->ra = ra;
+ p->mvra = mvra;
+ p->sp = sp;
+ p->fp = fp;
+ memcpy (p->stack_base, stack_base, (sp + 1 - stack_base) * sizeof (SCM));
+ p->reloc = p->stack_base - stack_base;
+ return scm_cell (scm_tc7_vm_cont, (scm_t_bits)p);
}
static void
-reinstate_vm_cont (struct scm_vm *vp, SCM cont)
+vm_return_to_continuation (SCM vm, SCM cont, size_t n, SCM *argv)
{
- struct scm_vm_cont *p = SCM_VM_CONT_DATA (cont);
- if (vp->stack_size < p->stack_size)
+ struct scm_vm *vp;
+ struct scm_vm_cont *cp;
+ SCM *argv_copy;
+
+ argv_copy = alloca (n * sizeof(SCM));
+ memcpy (argv_copy, argv, n * sizeof(SCM));
+
+ vp = SCM_VM_DATA (vm);
+ cp = SCM_VM_CONT_DATA (cont);
+
+ if (n == 0 && !cp->mvra)
+ scm_misc_error (NULL, "Too few values returned to continuation",
+ SCM_EOL);
+
+ if (vp->stack_size < cp->stack_size + n + 1)
{
/* puts ("FIXME: Need to expand"); */
abort ();
}
#ifdef VM_ENABLE_STACK_NULLING
{
- scm_t_ptrdiff nzero = (vp->sp - p->sp);
+ scm_t_ptrdiff nzero = (vp->sp - cp->sp);
if (nzero > 0)
- memset (vp->stack_base + p->stack_size, 0, nzero * sizeof (SCM));
+ memset (vp->stack_base + cp->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 = p->sp;
- vp->fp = p->fp;
- memcpy (vp->stack_base, p->stack_base, p->stack_size * sizeof (SCM));
-}
+ vp->sp = cp->sp;
+ vp->fp = cp->fp;
+ memcpy (vp->stack_base, cp->stack_base, cp->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*.
+ if (n == 1 || !cp->mvra)
+ {
+ vp->ip = cp->ra;
+ vp->sp++;
+ *vp->sp = argv_copy[0];
+ }
+ else
+ {
+ size_t i;
+ for (i = 0; i < n; i++)
+ {
+ vp->sp++;
+ *vp->sp = argv_copy[i];
+ }
+ vp->sp++;
+ *vp->sp = scm_from_size_t (n);
+ vp->ip = cp->mvra;
+ }
+}
- 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_i_vm_capture_continuation (SCM vm)
{
- SCM vm = scm_the_vm ();
- return scm_acons (vm, capture_vm_cont (SCM_VM_DATA (vm)), SCM_EOL);
+ struct scm_vm *vp = SCM_VM_DATA (vm);
+ return vm_capture_continuation (vp->stack_base, vp->fp, vp->sp, vp->ip, NULL);
}
-void
-scm_vm_reinstate_continuations (SCM conts)
+static void
+vm_dispatch_hook (SCM vm, int hook_num)
{
- for (; conts != SCM_EOL; conts = SCM_CDR (conts))
- reinstate_vm_cont (SCM_VM_DATA (SCM_CAAR (conts)), SCM_CDAR (conts));
-}
+ struct scm_vm *vp;
+ SCM hook;
+ SCM frame;
+
+ vp = SCM_VM_DATA (vm);
+ hook = vp->hooks[hook_num];
-static void enfalsen_frame (void *p)
-{
- struct scm_vm *vp = p;
- vp->trace_frame = SCM_BOOL_F;
+ if (SCM_LIKELY (scm_is_false (hook))
+ || scm_is_null (SCM_HOOK_PROCEDURES (hook)))
+ return;
+
+ vp->trace_level--;
+ frame = scm_c_make_frame (vm, vp->fp, vp->sp, vp->ip, 0);
+ scm_c_run_hookn (hook, &frame, 1);
+ vp->trace_level++;
}
+static void vm_abort (SCM vm, size_t n) SCM_NORETURN;
static void
-vm_dispatch_hook (struct scm_vm *vp, SCM hook, SCM hook_args)
+vm_abort (SCM vm, size_t n)
{
- if (!scm_is_false (vp->trace_frame))
- return;
-
- scm_dynwind_begin (0);
- /* FIXME, stack holder should be the vm */
- vp->trace_frame = scm_c_make_vm_frame (SCM_BOOL_F, vp->fp, vp->sp, vp->ip, 0);
- scm_dynwind_unwind_handler (enfalsen_frame, vp, SCM_F_WIND_EXPLICITLY);
-
- scm_c_run_hook (hook, hook_args);
+ size_t i;
+ ssize_t tail_len;
+ SCM tag, tail, *argv;
+
+ /* FIXME: VM_ENABLE_STACK_NULLING */
+ tail = *(SCM_VM_DATA (vm)->sp--);
+ /* NULLSTACK (1) */
+ tail_len = scm_ilength (tail);
+ if (tail_len < 0)
+ abort ();
+ tag = SCM_VM_DATA (vm)->sp[-n];
+ argv = alloca ((n + tail_len) * sizeof (SCM));
+ for (i = 0; i < n; i++)
+ argv[i] = SCM_VM_DATA (vm)->sp[-(n-1-i)];
+ for (; i < n + tail_len; i++, tail = scm_cdr (tail))
+ argv[i] = scm_car (tail);
+ /* NULLSTACK (n + 1) */
+ SCM_VM_DATA (vm)->sp -= n + 1;
- scm_dynwind_end ();
+ scm_c_abort (vm, tag, n + tail_len, argv);
}
\f
* VM Internal functions
*/
-static SCM sym_vm_run;
-static SCM sym_vm_error;
-static SCM sym_debug;
+SCM_SYMBOL (sym_vm_run, "vm-run");
+SCM_SYMBOL (sym_vm_error, "vm-error");
+SCM_SYMBOL (sym_keyword_argument_error, "keyword-argument-error");
+SCM_SYMBOL (sym_debug, "debug");
+
+void
+scm_i_vm_print (SCM x, SCM port, scm_print_state *pstate)
+{
+ scm_puts ("#<vm ", port);
+ scm_uintprint (SCM_UNPACK (x), 16, port);
+ scm_puts (">", port);
+}
static SCM
really_make_boot_program (long nargs)
text[1] = (scm_t_uint8)nargs;
bp = scm_malloc (sizeof (struct scm_objcode) + sizeof (text));
- memcpy (bp->base, text, sizeof (text));
+ memcpy (SCM_C_OBJCODE_BASE (bp), text, sizeof (text));
bp->len = sizeof(text);
bp->metalen = 0;
- u8vec = scm_take_u8vector ((scm_t_uint8*)bp,
- sizeof (struct scm_objcode) + sizeof (text));
+ u8vec = scm_c_take_bytevector ((scm_t_int8*)bp,
+ sizeof (struct scm_objcode) + sizeof (text));
ret = scm_make_program (scm_bytecode_to_objcode (u8vec),
SCM_BOOL_F, SCM_BOOL_F);
SCM_SET_CELL_WORD_0 (ret, SCM_CELL_WORD_0 (ret) | SCM_F_PROGRAM_IS_BOOT);
{
int i;
for (i = 0; i < NUM_BOOT_PROGS; i++)
- programs[i] = scm_permanent_object (really_make_boot_program (i));
+ programs[i] = really_make_boot_program (i);
}
if (SCM_LIKELY (nargs < NUM_BOOT_PROGS))
mod = scm_resolve_module (SCM_CAR (what));
if (scm_is_true (SCM_CADDR (what)))
mod = scm_module_public_interface (mod);
- if (SCM_FALSEP (mod))
+ if (scm_is_false (mod))
scm_misc_error (NULL, "no such module: ~S",
scm_list_1 (SCM_CAR (what)));
/* might longjmp */
}
}
-
#define VM_DEFAULT_STACK_SIZE (64 * 1024)
#define VM_NAME vm_regular_engine
static const scm_t_vm_engine vm_engines[] =
{ vm_regular_engine, vm_debug_engine };
-scm_t_bits scm_tc16_vm;
-
#ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
/* The GC "kind" for the VM stack. */
int i;
struct scm_vm *vp;
- if (!scm_tc16_vm)
- return SCM_BOOL_F; /* not booted yet */
-
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);
+ vp->stack_base = (SCM *)
+ 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->sp = vp->stack_base - 1;
vp->fp = NULL;
vp->engine = SCM_VM_DEBUG_ENGINE;
- vp->time = 0;
- vp->clock = 0;
vp->options = SCM_EOL;
+ vp->trace_level = 0;
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);
+ vp->cookie = 0;
+ return scm_cell (scm_tc7_vm, (scm_t_bits)vp);
}
#undef FUNC_NAME
scm_c_vm_run (SCM vm, SCM program, SCM *argv, int nargs)
{
struct scm_vm *vp = SCM_VM_DATA (vm);
- return vm_engines[vp->engine](vp, program, argv, nargs);
+ return vm_engines[vp->engine](vm, program, argv, nargs);
}
-SCM
-scm_vm_apply (SCM vm, SCM program, SCM args)
-#define FUNC_NAME "scm_vm_apply"
+SCM_DEFINE (scm_vm_apply, "vm-apply", 3, 0, 0,
+ (SCM vm, SCM program, SCM args),
+ "")
+#define FUNC_NAME s_scm_vm_apply
{
SCM *argv;
int i, nargs;
SCM_VALIDATE_VM (1, vm);
- SCM_VALIDATE_PROGRAM (2, program);
+ SCM_VALIDATE_PROC (2, program);
nargs = scm_ilength (args);
if (SCM_UNLIKELY (nargs < 0))
}
#undef FUNC_NAME
+SCM
+scm_vm_call_with_new_stack (SCM vm, SCM thunk, SCM id)
+{
+ return scm_c_vm_run (vm, thunk, NULL, 0);
+}
+
/* Scheme interface */
SCM_DEFINE (scm_vm_version, "vm-version", 0, 0, 0,
{
scm_i_thread *t = SCM_I_CURRENT_THREAD;
- if (SCM_UNLIKELY (SCM_FALSEP ((t->vm))))
+ if (SCM_UNLIKELY (scm_is_false ((t->vm))))
t->vm = make_vm ();
return t->vm;
struct scm_vm *vp; \
SCM_VALIDATE_VM (1, vm); \
vp = SCM_VM_DATA (vm); \
- if (SCM_FALSEP (vp->hooks[n])) \
+ if (scm_is_false (vp->hooks[n])) \
vp->hooks[n] = scm_make_hook (SCM_I_MAKINUM (1)); \
return vp->hooks[n]; \
}
}
#undef FUNC_NAME
-SCM_DEFINE (scm_vm_stats, "vm-stats", 1, 0, 0,
+SCM_DEFINE (scm_vm_trace_level, "vm-trace-level", 1, 0, 0,
(SCM vm),
"")
-#define FUNC_NAME s_scm_vm_stats
+#define FUNC_NAME s_scm_vm_trace_level
{
- SCM stats;
-
SCM_VALIDATE_VM (1, vm);
-
- stats = scm_make_vector (SCM_I_MAKINUM (2), SCM_UNSPECIFIED);
- scm_vector_set_x (stats, SCM_I_MAKINUM (0),
- scm_from_ulong (SCM_VM_DATA (vm)->time));
- scm_vector_set_x (stats, SCM_I_MAKINUM (1),
- scm_from_ulong (SCM_VM_DATA (vm)->clock));
-
- return stats;
+ return scm_from_int (SCM_VM_DATA (vm)->trace_level);
}
#undef FUNC_NAME
-SCM_DEFINE (scm_vm_trace_frame, "vm-trace-frame", 1, 0, 0,
- (SCM vm),
+SCM_DEFINE (scm_set_vm_trace_level_x, "set-vm-trace-level!", 2, 0, 0,
+ (SCM vm, SCM level),
"")
-#define FUNC_NAME s_scm_vm_trace_frame
+#define FUNC_NAME s_scm_set_vm_trace_level_x
{
SCM_VALIDATE_VM (1, vm);
- return SCM_VM_DATA (vm)->trace_frame;
+ SCM_VM_DATA (vm)->trace_level = scm_to_int (level);
+ return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
void
scm_bootstrap_vm (void)
{
- static int strappage = 0;
-
- if (strappage)
- return;
-
- scm_bootstrap_frames ();
- scm_bootstrap_instructions ();
- scm_bootstrap_objcodes ();
- scm_bootstrap_programs ();
-
- scm_tc16_vm_cont = scm_make_smob_type ("vm-cont", 0);
-
- scm_tc16_vm = scm_make_smob_type ("vm", 0);
- scm_set_smob_apply (scm_tc16_vm, scm_vm_apply, 1, 0, 1);
-
- scm_c_define ("load-compiled",
- scm_c_make_gsubr ("load-compiled/vm", 1, 0, 0,
- scm_load_compiled_with_vm));
-
- sym_vm_run = scm_permanent_object (scm_from_locale_symbol ("vm-run"));
- sym_vm_error = scm_permanent_object (scm_from_locale_symbol ("vm-error"));
- sym_debug = scm_permanent_object (scm_from_locale_symbol ("debug"));
-
scm_c_register_extension ("libguile", "scm_init_vm",
(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 (),
void
scm_init_vm (void)
{
- scm_bootstrap_vm ();
-
#ifndef SCM_MAGIC_SNARFER
#include "libguile/vm.x"
#endif
HCoop / bpt / guile.git / blobdiff