-/* Copyright (C) 2001, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013 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 "objcodes.h"
#include "programs.h"
#include "vm.h"
+#include "vm-builtins.h"
+
+#include "private-gc.h" /* scm_getenv_int */
static int vm_default_engine = SCM_VM_REGULAR_ENGINE;
0);
}
+static void vm_dispatch_hook (SCM vm, int hook_num,
+ SCM *argv, int n) SCM_NOINLINE;
+
static void
-vm_dispatch_hook (SCM vm, int hook_num)
+vm_dispatch_hook (SCM vm, int hook_num, SCM *argv, int n)
{
struct scm_vm *vp;
SCM hook;
struct scm_frame c_frame;
scm_t_cell *frame;
- SCM args[1];
int saved_trace_level;
vp = SCM_VM_DATA (vm);
frame->word_0 = SCM_PACK (scm_tc7_frame);
frame->word_1 = SCM_PACK_POINTER (&c_frame);
- args[0] = SCM_PACK_POINTER (frame);
- scm_c_run_hookn (hook, args, 1);
+ if (n == 0)
+ {
+ SCM args[1];
+
+ args[0] = SCM_PACK_POINTER (frame);
+ scm_c_run_hookn (hook, args, 1);
+ }
+ else if (n == 1)
+ {
+ SCM args[2];
+
+ args[0] = SCM_PACK_POINTER (frame);
+ args[1] = argv[0];
+ scm_c_run_hookn (hook, args, 2);
+ }
+ else
+ {
+ SCM args = SCM_EOL;
+
+ while (n--)
+ args = scm_cons (argv[n], args);
+ scm_c_run_hook (hook, scm_cons (SCM_PACK_POINTER (frame), args));
+ }
vp->trace_level = saved_trace_level;
}
static void
-vm_abort (SCM vm, size_t n, scm_i_jmp_buf *current_registers) SCM_NORETURN;
+vm_abort (SCM vm, SCM tag, size_t nstack, SCM *stack_args, SCM tail, SCM *sp,
+ scm_i_jmp_buf *current_registers) SCM_NORETURN;
static void
-vm_abort (SCM vm, size_t n, scm_i_jmp_buf *current_registers)
+vm_abort (SCM vm, SCM tag, size_t nstack, SCM *stack_args, SCM tail, SCM *sp,
+ scm_i_jmp_buf *current_registers)
{
size_t i;
ssize_t tail_len;
- SCM tag, tail, *argv;
+ SCM *argv;
- /* FIXME: VM_ENABLE_STACK_NULLING */
- tail = *(SCM_VM_DATA (vm)->sp--);
- /* NULLSTACK (1) */
tail_len = scm_ilength (tail);
if (tail_len < 0)
scm_misc_error ("vm-engine", "tail values to abort should be a list",
scm_list_1 (tail));
- 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 = alloca ((nstack + tail_len) * sizeof (SCM));
+ for (i = 0; i < nstack; i++)
+ argv[i] = stack_args[i];
+ for (; i < nstack + tail_len; i++, tail = scm_cdr (tail))
argv[i] = scm_car (tail);
- /* NULLSTACK (n + 1) */
- SCM_VM_DATA (vm)->sp -= n + 1;
- scm_c_abort (vm, tag, n + tail_len, argv, current_registers);
+ /* FIXME: NULLSTACK (SCM_VM_DATA (vp)->sp - sp) */
+ SCM_VM_DATA (vm)->sp = sp;
+
+ scm_c_abort (vm, tag, nstack + tail_len, argv, current_registers);
}
static void
static void vm_error_not_a_variable (const char *func_name, SCM x) SCM_NORETURN SCM_NOINLINE;
static void vm_error_apply_to_non_list (SCM x) SCM_NORETURN SCM_NOINLINE;
static void vm_error_kwargs_length_not_even (SCM proc) SCM_NORETURN SCM_NOINLINE;
-static void vm_error_kwargs_invalid_keyword (SCM proc) SCM_NORETURN SCM_NOINLINE;
-static void vm_error_kwargs_unrecognized_keyword (SCM proc) SCM_NORETURN SCM_NOINLINE;
+static void vm_error_kwargs_invalid_keyword (SCM proc, SCM obj) SCM_NORETURN SCM_NOINLINE;
+static void vm_error_kwargs_unrecognized_keyword (SCM proc, SCM kw) SCM_NORETURN SCM_NOINLINE;
static void vm_error_too_many_args (int nargs) SCM_NORETURN SCM_NOINLINE;
static void vm_error_wrong_num_args (SCM proc) SCM_NORETURN SCM_NOINLINE;
static void vm_error_wrong_type_apply (SCM proc) SCM_NORETURN SCM_NOINLINE;
static void vm_error_not_a_struct (const char *subr, SCM x) SCM_NORETURN SCM_NOINLINE;
static void vm_error_no_values (void) SCM_NORETURN SCM_NOINLINE;
static void vm_error_not_enough_values (void) SCM_NORETURN SCM_NOINLINE;
+static void vm_error_wrong_number_of_values (scm_t_uint32 expected) SCM_NORETURN SCM_NOINLINE;
static void vm_error_continuation_not_rewindable (SCM cont) SCM_NORETURN SCM_NOINLINE;
static void vm_error_bad_wide_string_length (size_t len) SCM_NORETURN SCM_NOINLINE;
-#if VM_CHECK_IP
-static void vm_error_invalid_address (void) SCM_NORETURN SCM_NOINLINE;
-#endif
-#if VM_CHECK_OBJECT
-static void vm_error_object (void) SCM_NORETURN SCM_NOINLINE;
-#endif
-#if VM_CHECK_FREE_VARIABLES
-static void vm_error_free_variable (void) SCM_NORETURN SCM_NOINLINE;
-#endif
static void
vm_error (const char *msg, SCM arg)
}
static void
-vm_error_kwargs_invalid_keyword (SCM proc)
+vm_error_kwargs_invalid_keyword (SCM proc, SCM obj)
{
scm_error_scm (sym_keyword_argument_error, proc,
scm_from_latin1_string ("Invalid keyword"),
- SCM_EOL, SCM_BOOL_F);
+ SCM_EOL, scm_list_1 (obj));
}
static void
-vm_error_kwargs_unrecognized_keyword (SCM proc)
+vm_error_kwargs_unrecognized_keyword (SCM proc, SCM kw)
{
scm_error_scm (sym_keyword_argument_error, proc,
scm_from_latin1_string ("Unrecognized keyword"),
- SCM_EOL, SCM_BOOL_F);
+ SCM_EOL, scm_list_1 (kw));
}
static void
vm_error ("Too few values returned to continuation", SCM_UNDEFINED);
}
+static void
+vm_error_wrong_number_of_values (scm_t_uint32 expected)
+{
+ vm_error ("Wrong number of values returned to continuation (expected ~a)",
+ scm_from_uint32 (expected));
+}
+
static void
vm_error_continuation_not_rewindable (SCM cont)
{
vm_error ("VM: Bad wide string length: ~S", scm_from_size_t (len));
}
-#ifdef VM_CHECK_IP
-static void
-vm_error_invalid_address (void)
+
+\f
+
+static SCM boot_continuation;
+
+static SCM rtl_boot_continuation;
+static SCM vm_builtin_apply;
+static SCM vm_builtin_values;
+static SCM vm_builtin_abort_to_prompt;
+static SCM vm_builtin_call_with_values;
+static SCM vm_builtin_call_with_current_continuation;
+
+static const scm_t_uint32 rtl_boot_continuation_code[] = {
+ SCM_PACK_RTL_24 (scm_rtl_op_halt, 0)
+};
+
+static const scm_t_uint32 vm_builtin_apply_code[] = {
+ SCM_PACK_RTL_24 (scm_rtl_op_assert_nargs_ge, 3),
+ SCM_PACK_RTL_24 (scm_rtl_op_tail_apply, 0), /* proc in r1, args from r2 */
+};
+
+static const scm_t_uint32 vm_builtin_values_code[] = {
+ SCM_PACK_RTL_24 (scm_rtl_op_return_values, 0) /* vals from r1 */
+};
+
+static const scm_t_uint32 vm_builtin_abort_to_prompt_code[] = {
+ SCM_PACK_RTL_24 (scm_rtl_op_assert_nargs_ge, 2),
+ SCM_PACK_RTL_24 (scm_rtl_op_abort, 0), /* tag in r1, vals from r2 */
+ /* FIXME: Partial continuation should capture caller regs. */
+ SCM_PACK_RTL_24 (scm_rtl_op_return_values, 0) /* vals from r1 */
+};
+
+static const scm_t_uint32 vm_builtin_call_with_values_code[] = {
+ SCM_PACK_RTL_24 (scm_rtl_op_assert_nargs_ee, 3),
+ SCM_PACK_RTL_24 (scm_rtl_op_alloc_frame, 7),
+ SCM_PACK_RTL_12_12 (scm_rtl_op_mov, 6, 1),
+ SCM_PACK_RTL_24 (scm_rtl_op_call, 6), SCM_PACK_RTL_24 (0, 1),
+ SCM_PACK_RTL_12_12 (scm_rtl_op_mov, 0, 2),
+ SCM_PACK_RTL_24 (scm_rtl_op_tail_call_shuffle, 7)
+};
+
+static const scm_t_uint32 vm_builtin_call_with_current_continuation_code[] = {
+ SCM_PACK_RTL_24 (scm_rtl_op_assert_nargs_ee, 2),
+ SCM_PACK_RTL_24 (scm_rtl_op_call_cc, 0)
+};
+
+
+static SCM
+scm_vm_builtin_ref (unsigned idx)
{
- vm_error ("VM: Invalid program address", SCM_UNDEFINED);
+ switch (idx)
+ {
+#define INDEX_TO_NAME(builtin, BUILTIN) \
+ case SCM_VM_BUILTIN_##BUILTIN: return vm_builtin_##builtin;
+ FOR_EACH_VM_BUILTIN(INDEX_TO_NAME)
+#undef INDEX_TO_NAME
+ default: abort();
+ }
}
-#endif
-#if VM_CHECK_OBJECT
-static void
-vm_error_object ()
+static SCM scm_sym_values;
+static SCM scm_sym_abort_to_prompt;
+static SCM scm_sym_call_with_values;
+static SCM scm_sym_call_with_current_continuation;
+
+SCM
+scm_vm_builtin_name_to_index (SCM name)
+#define FUNC_NAME "builtin-name->index"
{
- vm_error ("VM: Invalid object table access", SCM_UNDEFINED);
+ SCM_VALIDATE_SYMBOL (1, name);
+
+#define NAME_TO_INDEX(builtin, BUILTIN) \
+ if (scm_is_eq (name, scm_sym_##builtin)) \
+ return scm_from_uint (SCM_VM_BUILTIN_##BUILTIN);
+ FOR_EACH_VM_BUILTIN(NAME_TO_INDEX)
+#undef NAME_TO_INDEX
+
+ return SCM_BOOL_F;
}
-#endif
+#undef FUNC_NAME
-#if VM_CHECK_FREE_VARIABLES
-static void
-vm_error_free_variable ()
+SCM
+scm_vm_builtin_index_to_name (SCM index)
+#define FUNC_NAME "builtin-index->name"
{
- vm_error ("VM: Invalid free variable access", SCM_UNDEFINED);
+ unsigned idx;
+
+ SCM_VALIDATE_UINT_COPY (1, index, idx);
+
+ switch (idx)
+ {
+#define INDEX_TO_NAME(builtin, BUILTIN) \
+ case SCM_VM_BUILTIN_##BUILTIN: return scm_sym_##builtin;
+ FOR_EACH_VM_BUILTIN(INDEX_TO_NAME)
+#undef INDEX_TO_NAME
+ default: return SCM_BOOL_F;
+ }
}
-#endif
+#undef FUNC_NAME
-\f
+static void
+scm_init_vm_builtins (void)
+{
+ scm_sym_values = scm_from_utf8_symbol ("values");
+ scm_sym_abort_to_prompt = scm_from_utf8_symbol ("abort-to-prompt");
+ scm_sym_call_with_values = scm_from_utf8_symbol ("call-with-values");
+ scm_sym_call_with_current_continuation =
+ scm_from_utf8_symbol ("call-with-current-continuation");
-static SCM boot_continuation;
+ scm_c_define_gsubr ("builtin-name->index", 1, 0, 0,
+ scm_vm_builtin_name_to_index);
+ scm_c_define_gsubr ("builtin-index->name", 1, 0, 0,
+ scm_vm_builtin_index_to_name);
+}
+
+SCM
+scm_i_call_with_current_continuation (SCM proc)
+{
+ return scm_call_1 (vm_builtin_call_with_current_continuation, proc);
+}
\f
/*
*/
static SCM
-resolve_variable (SCM what, SCM program_module)
+resolve_variable (SCM what, SCM module)
{
if (SCM_LIKELY (scm_is_symbol (what)))
{
- if (scm_is_true (program_module))
- return scm_module_lookup (program_module, what);
+ if (scm_is_true (module))
+ return scm_module_lookup (module, what);
else
return scm_module_lookup (scm_the_root_module (), what);
}
else
{
- SCM mod;
- /* compilation of @ or @@
- `what' is a three-element list: (MODNAME SYM INTERFACE?)
- INTERFACE? is #t if we compiled @ or #f if we compiled @@
- */
- mod = scm_resolve_module (SCM_CAR (what));
- if (scm_is_true (SCM_CADDR (what)))
- mod = scm_module_public_interface (mod);
- if (scm_is_false (mod))
- scm_misc_error (NULL, "no such module: ~S",
- scm_list_1 (SCM_CAR (what)));
- /* might longjmp */
- return scm_module_lookup (mod, SCM_CADR (what));
+ SCM modname, sym, public;
+
+ modname = SCM_CAR (what);
+ sym = SCM_CADR (what);
+ public = SCM_CADDR (what);
+
+ if (!scm_module_system_booted_p)
+ {
+#ifdef VM_ENABLE_PARANOID_ASSERTIONS
+ ASSERT (scm_is_false (public));
+ ASSERT (scm_is_true
+ (scm_equal_p (modname,
+ scm_list_1 (scm_from_utf8_symbol ("guile")))));
+#endif
+ return scm_lookup (sym);
+ }
+ else if (scm_is_true (public))
+ return scm_public_lookup (modname, sym);
+ else
+ return scm_private_lookup (modname, sym);
}
}
-#define VM_DEFAULT_STACK_SIZE (64 * 1024)
+#define VM_MIN_STACK_SIZE (1024)
+#define VM_DEFAULT_STACK_SIZE (256 * 1024)
+static size_t vm_stack_size = VM_DEFAULT_STACK_SIZE;
+
+static void
+initialize_default_stack_size (void)
+{
+ int size = scm_getenv_int ("GUILE_STACK_SIZE", vm_stack_size);
+ if (size >= VM_MIN_STACK_SIZE)
+ vm_stack_size = size;
+}
#define VM_NAME vm_regular_engine
+#define RTL_VM_NAME rtl_vm_regular_engine
#define FUNC_NAME "vm-regular-engine"
#define VM_ENGINE SCM_VM_REGULAR_ENGINE
#include "vm-engine.c"
#undef VM_NAME
+#undef RTL_VM_NAME
#undef FUNC_NAME
#undef VM_ENGINE
#define VM_NAME vm_debug_engine
+#define RTL_VM_NAME rtl_vm_debug_engine
#define FUNC_NAME "vm-debug-engine"
#define VM_ENGINE SCM_VM_DEBUG_ENGINE
#include "vm-engine.c"
#undef VM_NAME
+#undef RTL_VM_NAME
#undef FUNC_NAME
#undef VM_ENGINE
static const scm_t_vm_engine vm_engines[] =
{ vm_regular_engine, vm_debug_engine };
+typedef SCM (*scm_t_rtl_vm_engine) (SCM vm, SCM program, SCM *argv, size_t nargs);
+
+static const scm_t_rtl_vm_engine rtl_vm_engines[] =
+ { rtl_vm_regular_engine, rtl_vm_debug_engine };
+
#ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
/* The GC "kind" for the VM stack. */
vp = scm_gc_malloc (sizeof (struct scm_vm), "vm");
- vp->stack_size = VM_DEFAULT_STACK_SIZE;
+ vp->stack_size= vm_stack_size;
#ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
vp->stack_base = (SCM *)
{
struct scm_vm *vp = SCM_VM_DATA (vm);
SCM_CHECK_STACK;
- return vm_engines[vp->engine](vm, program, argv, nargs);
+ if (SCM_PROGRAM_P (program))
+ return vm_engines[vp->engine](vm, program, argv, nargs);
+ else
+ return rtl_vm_engines[vp->engine](vm, program, argv, nargs);
}
/* Scheme interface */
scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
"scm_init_vm",
(scm_t_extension_init_func)scm_init_vm, NULL);
+ scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
+ "scm_init_vm_builtins",
+ (scm_t_extension_init_func)scm_init_vm_builtins,
+ NULL);
+
+ initialize_default_stack_size ();
sym_vm_run = scm_from_latin1_symbol ("vm-run");
sym_vm_error = scm_from_latin1_symbol ("vm-error");
boot_continuation = make_boot_program ();
+ rtl_boot_continuation = scm_i_make_rtl_program (rtl_boot_continuation_code);
+ SCM_SET_CELL_WORD_0 (rtl_boot_continuation,
+ (SCM_CELL_WORD_0 (rtl_boot_continuation)
+ | SCM_F_PROGRAM_IS_BOOT));
+ vm_builtin_apply = scm_i_make_rtl_program (vm_builtin_apply_code);
+ vm_builtin_values = scm_i_make_rtl_program (vm_builtin_values_code);
+ vm_builtin_abort_to_prompt =
+ scm_i_make_rtl_program (vm_builtin_abort_to_prompt_code);
+ vm_builtin_call_with_values =
+ scm_i_make_rtl_program (vm_builtin_call_with_values_code);
+ vm_builtin_call_with_current_continuation =
+ scm_i_make_rtl_program (vm_builtin_call_with_current_continuation_code);
+
#ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
vm_stack_gc_kind =
GC_new_kind (GC_new_free_list (),
HCoop / bpt / guile.git / blobdiff