X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/26d148066f9cb20e395a7dc4fefdf2e2ef0b2fb0..89b235afd34482f2e7d2af553f43d0744895ee83:/libguile/vm.c diff --git a/libguile/vm.c b/libguile/vm.c index ccc182afe..acb325044 100644 --- a/libguile/vm.c +++ b/libguile/vm.c @@ -33,9 +33,10 @@ #include "control.h" #include "frames.h" #include "instructions.h" -#include "objcodes.h" +#include "loader.h" #include "programs.h" #include "vm.h" +#include "vm-builtins.h" #include "private-gc.h" /* scm_getenv_int */ @@ -53,19 +54,8 @@ static SCM sym_debug; 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. Slows down the VM by about 30%. */ -/* NB! If you enable this, search for NULLING in throw.c */ -/* #define VM_ENABLE_STACK_NULLING */ - /* #define VM_ENABLE_PARANOID_ASSERTIONS */ -#if defined (VM_ENABLE_STACK_NULLING) && !defined (VM_ENABLE_ASSERTIONS) -#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 @@ -102,9 +92,8 @@ scm_i_vm_cont_print (SCM x, SCM port, scm_print_state *pstate) call to vm_run; but that's currently not implemented. */ SCM -scm_i_vm_capture_stack (SCM *stack_base, SCM *fp, SCM *sp, scm_t_uint8 *ra, - scm_t_uint8 *mvra, scm_t_dynstack *dynstack, - scm_t_uint32 flags) +scm_i_vm_capture_stack (SCM *stack_base, SCM *fp, SCM *sp, scm_t_uint32 *ra, + scm_t_dynstack *dynstack, scm_t_uint32 flags) { struct scm_vm_cont *p; @@ -112,17 +101,7 @@ scm_i_vm_capture_stack (SCM *stack_base, SCM *fp, SCM *sp, scm_t_uint8 *ra, p->stack_size = sp - stack_base + 1; p->stack_base = scm_gc_malloc (p->stack_size * sizeof (SCM), "capture_vm_cont"); -#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->ra = ra; - p->mvra = mvra; p->sp = sp; p->fp = fp; memcpy (p->stack_base, stack_base, (sp + 1 - stack_base) * sizeof (SCM)); @@ -145,45 +124,32 @@ vm_return_to_continuation (SCM vm, SCM cont, size_t n, SCM *argv) 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) + if (vp->stack_size < cp->stack_size + n + 3) scm_misc_error ("vm-engine", "not enough space to reinstate continuation", scm_list_2 (vm, cont)); -#ifdef VM_ENABLE_STACK_NULLING - { - scm_t_ptrdiff nzero = (vp->sp - cp->sp); - if (nzero > 0) - 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->sp = cp->sp; vp->fp = cp->fp; memcpy (vp->stack_base, cp->stack_base, cp->stack_size * sizeof (SCM)); - 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; - } + { + size_t i; + + /* Push on an empty frame, as the continuation expects. */ + for (i = 0; i < 3; i++) + { + vp->sp++; + *vp->sp = SCM_BOOL_F; + } + + /* Push the return values. */ + for (i = 0; i < n; i++) + { + vp->sp++; + *vp->sp = argv_copy[i]; + } + vp->ip = cp->ra; + } } SCM @@ -197,19 +163,25 @@ scm_i_capture_current_stack (void) vm = scm_the_vm (); vp = SCM_VM_DATA (vm); - return scm_i_vm_capture_stack (vp->stack_base, vp->fp, vp->sp, vp->ip, NULL, + return scm_i_vm_capture_stack (vp->stack_base, vp->fp, vp->sp, vp->ip, scm_dynstack_capture_all (&thread->dynstack), 0); } +static void vm_dispatch_apply_hook (SCM vm) SCM_NOINLINE; +static void vm_dispatch_push_continuation_hook (SCM vm) SCM_NOINLINE; +static void vm_dispatch_pop_continuation_hook (SCM vm, SCM *old_fp) SCM_NOINLINE; +static void vm_dispatch_next_hook (SCM vm) SCM_NOINLINE; +static void vm_dispatch_abort_hook (SCM vm) SCM_NOINLINE; +static void vm_dispatch_restore_continuation_hook (SCM vm) 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); @@ -231,10 +203,9 @@ vm_dispatch_hook (SCM vm, int hook_num) seems reasonable to limit the lifetime of frame objects. */ c_frame.stack_holder = vm; - c_frame.fp = vp->fp; - c_frame.sp = vp->sp; + c_frame.fp_offset = vp->fp - vp->stack_base; + c_frame.sp_offset = vp->sp - vp->stack_base; c_frame.ip = vp->ip; - c_frame.offset = 0; /* Arrange for FRAME to be 8-byte aligned, like any other cell. */ frame = alloca (sizeof (*frame) + 8); @@ -242,41 +213,93 @@ vm_dispatch_hook (SCM vm, int hook_num) 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_dispatch_apply_hook (SCM vm) +{ + return vm_dispatch_hook (vm, SCM_VM_APPLY_HOOK, NULL, 0); +} +static void vm_dispatch_push_continuation_hook (SCM vm) +{ + return vm_dispatch_hook (vm, SCM_VM_PUSH_CONTINUATION_HOOK, NULL, 0); +} +static void vm_dispatch_pop_continuation_hook (SCM vm, SCM *old_fp) +{ + struct scm_vm *vp = SCM_VM_DATA (vm); + return vm_dispatch_hook (vm, SCM_VM_POP_CONTINUATION_HOOK, + &SCM_FRAME_LOCAL (old_fp, 1), + SCM_FRAME_NUM_LOCALS (old_fp, vp->sp) - 1); +} +static void vm_dispatch_next_hook (SCM vm) +{ + return vm_dispatch_hook (vm, SCM_VM_NEXT_HOOK, NULL, 0); +} +static void vm_dispatch_abort_hook (SCM vm) +{ + struct scm_vm *vp = SCM_VM_DATA (vm); + return vm_dispatch_hook (vm, SCM_VM_ABORT_CONTINUATION_HOOK, + &SCM_FRAME_LOCAL (vp->fp, 1), + SCM_FRAME_NUM_LOCALS (vp->fp, vp->sp) - 1); +} +static void vm_dispatch_restore_continuation_hook (SCM vm) +{ + return vm_dispatch_hook (vm, SCM_VM_RESTORE_CONTINUATION_HOOK, NULL, 0); +} 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) SCM_NORETURN; + +static void +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 @@ -295,7 +318,7 @@ vm_reinstate_partial_continuation (SCM vm, SCM cont, size_t n, SCM *argv, vp = SCM_VM_DATA (vm); cp = SCM_VM_CONT_DATA (cont); - base = SCM_FRAME_UPPER_ADDRESS (vp->fp) + 1; + base = SCM_FRAME_LOCALS_ADDRESS (vp->fp); reloc = cp->reloc + (base - cp->stack_base); #define RELOC(scm_p) \ @@ -319,16 +342,14 @@ vm_reinstate_partial_continuation (SCM vm, SCM cont, size_t n, SCM *argv, vp->sp = base - 1 + cp->stack_size; vp->fp = RELOC (cp->fp); - vp->ip = cp->mvra; + vp->ip = cp->ra; - /* now push args. ip is in a MV context. */ + /* Push the arguments. */ for (i = 0; i < n; i++) { vp->sp++; *vp->sp = argv_copy[i]; } - vp->sp++; - *vp->sp = scm_from_size_t (n); /* The prompt captured a slice of the dynamic stack. Here we wind those entries onto the current thread's stack. We also have to @@ -393,8 +414,8 @@ static void vm_error_unbound_fluid (SCM proc, SCM fluid) SCM_NORETURN SCM_NOINLI 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; @@ -406,17 +427,9 @@ static void vm_error_not_a_bytevector (const char *subr, SCM x) SCM_NORETURN SCM 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) @@ -472,19 +485,19 @@ vm_error_kwargs_length_not_even (SCM proc) } 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 @@ -563,6 +576,13 @@ vm_error_not_enough_values (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) { @@ -575,69 +595,127 @@ vm_error_bad_wide_string_length (size_t len) vm_error ("VM: Bad wide string length: ~S", scm_from_size_t (len)); } -#ifdef VM_CHECK_IP -static void -vm_error_invalid_address (void) + + + +static SCM vm_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 vm_boot_continuation_code[] = { + SCM_PACK_OP_24 (halt, 0) +}; + +static const scm_t_uint32 vm_builtin_apply_code[] = { + SCM_PACK_OP_24 (assert_nargs_ge, 3), + SCM_PACK_OP_24 (tail_apply, 0), /* proc in r1, args from r2 */ +}; + +static const scm_t_uint32 vm_builtin_values_code[] = { + SCM_PACK_OP_24 (return_values, 0) /* vals from r1 */ +}; + +static const scm_t_uint32 vm_builtin_abort_to_prompt_code[] = { + SCM_PACK_OP_24 (assert_nargs_ge, 2), + SCM_PACK_OP_24 (abort, 0), /* tag in r1, vals from r2 */ + /* FIXME: Partial continuation should capture caller regs. */ + SCM_PACK_OP_24 (return_values, 0) /* vals from r1 */ +}; + +static const scm_t_uint32 vm_builtin_call_with_values_code[] = { + SCM_PACK_OP_24 (assert_nargs_ee, 3), + SCM_PACK_OP_24 (alloc_frame, 7), + SCM_PACK_OP_12_12 (mov, 6, 1), + SCM_PACK_OP_24 (call, 6), SCM_PACK_OP_ARG_8_24 (0, 1), + SCM_PACK_OP_12_12 (mov, 0, 2), + SCM_PACK_OP_24 (tail_call_shuffle, 7) +}; + +static const scm_t_uint32 vm_builtin_call_with_current_continuation_code[] = { + SCM_PACK_OP_24 (assert_nargs_ee, 2), + SCM_PACK_OP_24 (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, req, opt, rest) \ + 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 () +SCM scm_sym_apply; +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, req, opt, rest) \ + 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, req, opt, rest) \ + 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 - +static void +scm_init_vm_builtins (void) +{ + 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); +} -static SCM boot_continuation; +SCM +scm_i_call_with_current_continuation (SCM proc) +{ + return scm_call_1 (vm_builtin_call_with_current_continuation, proc); +} /* * VM */ -static SCM -resolve_variable (SCM what, SCM program_module) -{ - if (SCM_LIKELY (scm_is_symbol (what))) - { - if (scm_is_true (program_module)) - return scm_module_lookup (program_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)); - } -} - #define VM_MIN_STACK_SIZE (1024) -#define VM_DEFAULT_STACK_SIZE (64 * 1024) +#define VM_DEFAULT_STACK_SIZE (256 * 1024) static size_t vm_stack_size = VM_DEFAULT_STACK_SIZE; static void @@ -648,23 +726,25 @@ initialize_default_stack_size (void) vm_stack_size = size; } -#define VM_NAME vm_regular_engine +#define VM_NAME vm_regular_engine +#define VM_USE_HOOKS 0 #define FUNC_NAME "vm-regular-engine" -#define VM_ENGINE SCM_VM_REGULAR_ENGINE #include "vm-engine.c" -#undef VM_NAME #undef FUNC_NAME -#undef VM_ENGINE +#undef VM_USE_HOOKS +#undef VM_NAME -#define VM_NAME vm_debug_engine +#define VM_NAME vm_debug_engine +#define VM_USE_HOOKS 1 #define FUNC_NAME "vm-debug-engine" -#define VM_ENGINE SCM_VM_DEBUG_ENGINE #include "vm-engine.c" -#undef VM_NAME #undef FUNC_NAME -#undef VM_ENGINE +#undef VM_USE_HOOKS +#undef VM_NAME -static const scm_t_vm_engine vm_engines[] = +typedef SCM (*scm_t_vm_engine) (SCM vm, SCM program, SCM *argv, size_t nargs); + +static const scm_t_vm_engine vm_engines[SCM_VM_NUM_ENGINES] = { vm_regular_engine, vm_debug_engine }; #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN @@ -699,9 +779,6 @@ make_vm (void) "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 - VM_STACK_RESERVE_SIZE; vp->ip = NULL; vp->sp = vp->stack_base - 1; @@ -1064,30 +1141,26 @@ SCM scm_load_compiled_with_vm (SCM file) } -static SCM -make_boot_program (void) -{ - struct scm_objcode *bp; - size_t bp_size; - SCM u8vec, ret; - - const scm_t_uint8 text[] = { - scm_op_make_int8_1, - scm_op_halt - }; - - bp_size = sizeof (struct scm_objcode) + sizeof (text); - bp = scm_gc_malloc_pointerless (bp_size, "boot-program"); - memcpy (SCM_C_OBJCODE_BASE (bp), text, sizeof (text)); - bp->len = sizeof(text); - bp->metalen = 0; - - u8vec = scm_c_take_gc_bytevector ((scm_t_int8*)bp, bp_size, SCM_BOOL_F); - ret = scm_make_program (scm_bytecode_to_objcode (u8vec, SCM_UNDEFINED), - SCM_BOOL_F, SCM_BOOL_F); - SCM_SET_CELL_WORD_0 (ret, (SCM_CELL_WORD_0 (ret) | SCM_F_PROGRAM_IS_BOOT)); - - return ret; +void +scm_init_vm_builtin_properties (void) +{ + /* FIXME: Seems hacky to do this here, but oh well :/ */ + scm_sym_apply = scm_from_utf8_symbol ("apply"); + 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"); + +#define INIT_BUILTIN(builtin, BUILTIN, req, opt, rest) \ + scm_set_procedure_property_x (vm_builtin_##builtin, scm_sym_name, \ + scm_sym_##builtin); \ + scm_set_procedure_minimum_arity_x (vm_builtin_##builtin, \ + SCM_I_MAKINUM (req), \ + SCM_I_MAKINUM (opt), \ + scm_from_bool (rest)); + FOR_EACH_VM_BUILTIN (INIT_BUILTIN); +#undef INIT_BUILTIN } void @@ -1096,6 +1169,10 @@ scm_bootstrap_vm (void) 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 (); @@ -1105,7 +1182,15 @@ scm_bootstrap_vm (void) sym_regular = scm_from_latin1_symbol ("regular"); sym_debug = scm_from_latin1_symbol ("debug"); - boot_continuation = make_boot_program (); + vm_boot_continuation = scm_i_make_program (vm_boot_continuation_code); + SCM_SET_CELL_WORD_0 (vm_boot_continuation, + (SCM_CELL_WORD_0 (vm_boot_continuation) + | SCM_F_PROGRAM_IS_BOOT)); + +#define DEFINE_BUILTIN(builtin, BUILTIN, req, opt, rest) \ + vm_builtin_##builtin = scm_i_make_program (vm_builtin_##builtin##_code); + FOR_EACH_VM_BUILTIN (DEFINE_BUILTIN); +#undef DEFINE_BUILTIN #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN vm_stack_gc_kind =