1 /* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
3 * This library is free software; you can redistribute it and/or
4 * modify it under the terms of the GNU Lesser General Public License
5 * as published by the Free Software Foundation; either version 3 of
6 * the License, or (at your option) any later version.
8 * This library is distributed in the hope that it will be useful, but
9 * WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
11 * Lesser General Public License for more details.
13 * You should have received a copy of the GNU Lesser General Public
14 * License along with this library; if not, write to the Free Software
15 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
29 #include "libguile/bdw-gc.h"
30 #include <gc/gc_mark.h>
35 #include "instructions.h"
39 #include "vm-builtins.h"
41 #include "private-gc.h" /* scm_getenv_int */
43 static int vm_default_engine
= SCM_VM_REGULAR_ENGINE
;
45 /* Unfortunately we can't snarf these: snarfed things are only loaded up from
46 (system vm vm), which might not be loaded before an error happens. */
47 static SCM sym_vm_run
;
48 static SCM sym_vm_error
;
49 static SCM sym_keyword_argument_error
;
50 static SCM sym_regular
;
53 /* The VM has a number of internal assertions that shouldn't normally be
54 necessary, but might be if you think you found a bug in the VM. */
55 #define VM_ENABLE_ASSERTIONS
57 /* We can add a mode that ensures that all stack items above the stack pointer
58 are NULL. This is useful for checking the internal consistency of the VM's
59 assumptions and its operators, but isn't necessary for normal operation. It
60 will ensure that assertions are enabled. Slows down the VM by about 30%. */
61 /* NB! If you enable this, search for NULLING in throw.c */
62 /* #define VM_ENABLE_STACK_NULLING */
64 /* #define VM_ENABLE_PARANOID_ASSERTIONS */
66 #if defined (VM_ENABLE_STACK_NULLING) && !defined (VM_ENABLE_ASSERTIONS)
67 #define VM_ENABLE_ASSERTIONS
70 /* When defined, arrange so that the GC doesn't scan the VM stack beyond its
71 current SP. This should help avoid excess data retention. See
72 http://thread.gmane.org/gmane.comp.programming.garbage-collection.boehmgc/3001
74 #define VM_ENABLE_PRECISE_STACK_GC_SCAN
76 /* Size in SCM objects of the stack reserve. The reserve is used to run
77 exception handling code in case of a VM stack overflow. */
78 #define VM_STACK_RESERVE_SIZE 512
87 scm_i_vm_cont_print (SCM x
, SCM port
, scm_print_state
*pstate
)
89 scm_puts_unlocked ("#<vm-continuation ", port
);
90 scm_uintprint (SCM_UNPACK (x
), 16, port
);
91 scm_puts_unlocked (">", port
);
94 /* In theory, a number of vm instances can be active in the call trace, and we
95 only want to reify the continuations of those in the current continuation
96 root. I don't see a nice way to do this -- ideally it would involve dynwinds,
97 and previous values of the *the-vm* fluid within the current continuation
98 root. But we don't have access to continuation roots in the dynwind stack.
99 So, just punt for now, we just capture the continuation for the current VM.
101 While I'm on the topic, ideally we could avoid copying the C stack if the
102 continuation root is inside VM code, and call/cc was invoked within that same
103 call to vm_run; but that's currently not implemented.
106 scm_i_vm_capture_stack (SCM
*stack_base
, SCM
*fp
, SCM
*sp
, scm_t_uint32
*ra
,
107 scm_t_dynstack
*dynstack
, scm_t_uint32 flags
)
109 struct scm_vm_cont
*p
;
111 p
= scm_gc_malloc (sizeof (*p
), "capture_vm_cont");
112 p
->stack_size
= sp
- stack_base
+ 1;
113 p
->stack_base
= scm_gc_malloc (p
->stack_size
* sizeof (SCM
),
115 #if defined(VM_ENABLE_STACK_NULLING) && 0
116 /* Tail continuations leave their frame on the stack for subsequent
117 application, but don't capture the frame -- so there are some elements on
118 the stack then, and this check doesn't work, so disable it for now. */
119 if (sp
>= vp
->stack_base
)
120 if (!vp
->sp
[0] || vp
->sp
[1])
122 memset (p
->stack_base
, 0, p
->stack_size
* sizeof (SCM
));
127 memcpy (p
->stack_base
, stack_base
, (sp
+ 1 - stack_base
) * sizeof (SCM
));
128 p
->reloc
= p
->stack_base
- stack_base
;
129 p
->dynstack
= dynstack
;
131 return scm_cell (scm_tc7_vm_cont
, (scm_t_bits
)p
);
135 vm_return_to_continuation (SCM vm
, SCM cont
, size_t n
, SCM
*argv
)
138 struct scm_vm_cont
*cp
;
141 argv_copy
= alloca (n
* sizeof(SCM
));
142 memcpy (argv_copy
, argv
, n
* sizeof(SCM
));
144 vp
= SCM_VM_DATA (vm
);
145 cp
= SCM_VM_CONT_DATA (cont
);
147 if (vp
->stack_size
< cp
->stack_size
+ n
+ 3)
148 scm_misc_error ("vm-engine", "not enough space to reinstate continuation",
149 scm_list_2 (vm
, cont
));
151 #ifdef VM_ENABLE_STACK_NULLING
153 scm_t_ptrdiff nzero
= (vp
->sp
- cp
->sp
);
155 memset (vp
->stack_base
+ cp
->stack_size
, 0, nzero
* sizeof (SCM
));
156 /* actually nzero should always be negative, because vm_reset_stack will
157 unwind the stack to some point *below* this continuation */
162 memcpy (vp
->stack_base
, cp
->stack_base
, cp
->stack_size
* sizeof (SCM
));
167 /* Push on an empty frame, as the continuation expects. */
168 for (i
= 0; i
< 3; i
++)
171 *vp
->sp
= SCM_BOOL_F
;
174 /* Push the return values. */
175 for (i
= 0; i
< n
; i
++)
178 *vp
->sp
= argv_copy
[i
];
185 scm_i_capture_current_stack (void)
187 scm_i_thread
*thread
;
191 thread
= SCM_I_CURRENT_THREAD
;
193 vp
= SCM_VM_DATA (vm
);
195 return scm_i_vm_capture_stack (vp
->stack_base
, vp
->fp
, vp
->sp
, vp
->ip
,
196 scm_dynstack_capture_all (&thread
->dynstack
),
200 static void vm_dispatch_hook (SCM vm
, int hook_num
,
201 SCM
*argv
, int n
) SCM_NOINLINE
;
204 vm_dispatch_hook (SCM vm
, int hook_num
, SCM
*argv
, int n
)
208 struct scm_frame c_frame
;
210 int saved_trace_level
;
212 vp
= SCM_VM_DATA (vm
);
213 hook
= vp
->hooks
[hook_num
];
215 if (SCM_LIKELY (scm_is_false (hook
))
216 || scm_is_null (SCM_HOOK_PROCEDURES (hook
)))
219 saved_trace_level
= vp
->trace_level
;
222 /* Allocate a frame object on the stack. This is more efficient than calling
223 `scm_c_make_frame ()' to allocate on the heap, but it forces hooks to not
224 capture frame objects.
226 At the same time, procedures such as `frame-procedure' make sense only
227 while the stack frame represented by the frame object is visible, so it
228 seems reasonable to limit the lifetime of frame objects. */
230 c_frame
.stack_holder
= vm
;
236 /* Arrange for FRAME to be 8-byte aligned, like any other cell. */
237 frame
= alloca (sizeof (*frame
) + 8);
238 frame
= (scm_t_cell
*) ROUND_UP ((scm_t_uintptr
) frame
, 8UL);
240 frame
->word_0
= SCM_PACK (scm_tc7_frame
);
241 frame
->word_1
= SCM_PACK_POINTER (&c_frame
);
247 args
[0] = SCM_PACK_POINTER (frame
);
248 scm_c_run_hookn (hook
, args
, 1);
254 args
[0] = SCM_PACK_POINTER (frame
);
256 scm_c_run_hookn (hook
, args
, 2);
263 args
= scm_cons (argv
[n
], args
);
264 scm_c_run_hook (hook
, scm_cons (SCM_PACK_POINTER (frame
), args
));
267 vp
->trace_level
= saved_trace_level
;
271 vm_abort (SCM vm
, SCM tag
, size_t nstack
, SCM
*stack_args
, SCM tail
, SCM
*sp
,
272 scm_i_jmp_buf
*current_registers
) SCM_NORETURN
;
275 vm_abort (SCM vm
, SCM tag
, size_t nstack
, SCM
*stack_args
, SCM tail
, SCM
*sp
,
276 scm_i_jmp_buf
*current_registers
)
282 tail_len
= scm_ilength (tail
);
284 scm_misc_error ("vm-engine", "tail values to abort should be a list",
287 argv
= alloca ((nstack
+ tail_len
) * sizeof (SCM
));
288 for (i
= 0; i
< nstack
; i
++)
289 argv
[i
] = stack_args
[i
];
290 for (; i
< nstack
+ tail_len
; i
++, tail
= scm_cdr (tail
))
291 argv
[i
] = scm_car (tail
);
293 /* FIXME: NULLSTACK (SCM_VM_DATA (vp)->sp - sp) */
294 SCM_VM_DATA (vm
)->sp
= sp
;
296 scm_c_abort (vm
, tag
, nstack
+ tail_len
, argv
, current_registers
);
300 vm_reinstate_partial_continuation (SCM vm
, SCM cont
, size_t n
, SCM
*argv
,
301 scm_t_dynstack
*dynstack
,
302 scm_i_jmp_buf
*registers
)
305 struct scm_vm_cont
*cp
;
306 SCM
*argv_copy
, *base
;
310 argv_copy
= alloca (n
* sizeof(SCM
));
311 memcpy (argv_copy
, argv
, n
* sizeof(SCM
));
313 vp
= SCM_VM_DATA (vm
);
314 cp
= SCM_VM_CONT_DATA (cont
);
315 base
= SCM_FRAME_LOCALS_ADDRESS (vp
->fp
);
316 reloc
= cp
->reloc
+ (base
- cp
->stack_base
);
318 #define RELOC(scm_p) \
319 (((SCM *) (scm_p)) + reloc)
321 if ((base
- vp
->stack_base
) + cp
->stack_size
+ n
+ 1 > vp
->stack_size
)
322 scm_misc_error ("vm-engine",
323 "not enough space to instate partial continuation",
324 scm_list_2 (vm
, cont
));
326 memcpy (base
, cp
->stack_base
, cp
->stack_size
* sizeof (SCM
));
328 /* now relocate frame pointers */
331 for (fp
= RELOC (cp
->fp
);
332 SCM_FRAME_LOWER_ADDRESS (fp
) > base
;
333 fp
= SCM_FRAME_DYNAMIC_LINK (fp
))
334 SCM_FRAME_SET_DYNAMIC_LINK (fp
, RELOC (SCM_FRAME_DYNAMIC_LINK (fp
)));
337 vp
->sp
= base
- 1 + cp
->stack_size
;
338 vp
->fp
= RELOC (cp
->fp
);
341 /* Push the arguments. */
342 for (i
= 0; i
< n
; i
++)
345 *vp
->sp
= argv_copy
[i
];
348 /* The prompt captured a slice of the dynamic stack. Here we wind
349 those entries onto the current thread's stack. We also have to
350 relocate any prompts that we see along the way. */
354 for (walk
= SCM_DYNSTACK_FIRST (cp
->dynstack
);
355 SCM_DYNSTACK_TAG (walk
);
356 walk
= SCM_DYNSTACK_NEXT (walk
))
358 scm_t_bits tag
= SCM_DYNSTACK_TAG (walk
);
360 if (SCM_DYNSTACK_TAG_TYPE (tag
) == SCM_DYNSTACK_TYPE_PROMPT
)
361 scm_dynstack_wind_prompt (dynstack
, walk
, reloc
, registers
);
363 scm_dynstack_wind_1 (dynstack
, walk
);
371 * VM Internal functions
375 scm_i_vm_print (SCM x
, SCM port
, scm_print_state
*pstate
)
377 const struct scm_vm
*vm
;
379 vm
= SCM_VM_DATA (x
);
381 scm_puts_unlocked ("#<vm ", port
);
384 case SCM_VM_REGULAR_ENGINE
:
385 scm_puts_unlocked ("regular-engine ", port
);
388 case SCM_VM_DEBUG_ENGINE
:
389 scm_puts_unlocked ("debug-engine ", port
);
393 scm_puts_unlocked ("unknown-engine ", port
);
395 scm_uintprint (SCM_UNPACK (x
), 16, port
);
396 scm_puts_unlocked (">", port
);
404 static void vm_error (const char *msg
, SCM arg
) SCM_NORETURN
;
405 static void vm_error_bad_instruction (scm_t_uint32 inst
) SCM_NORETURN SCM_NOINLINE
;
406 static void vm_error_unbound (SCM proc
, SCM sym
) SCM_NORETURN SCM_NOINLINE
;
407 static void vm_error_unbound_fluid (SCM proc
, SCM fluid
) SCM_NORETURN SCM_NOINLINE
;
408 static void vm_error_not_a_variable (const char *func_name
, SCM x
) SCM_NORETURN SCM_NOINLINE
;
409 static void vm_error_apply_to_non_list (SCM x
) SCM_NORETURN SCM_NOINLINE
;
410 static void vm_error_kwargs_length_not_even (SCM proc
) SCM_NORETURN SCM_NOINLINE
;
411 static void vm_error_kwargs_invalid_keyword (SCM proc
, SCM obj
) SCM_NORETURN SCM_NOINLINE
;
412 static void vm_error_kwargs_unrecognized_keyword (SCM proc
, SCM kw
) SCM_NORETURN SCM_NOINLINE
;
413 static void vm_error_too_many_args (int nargs
) SCM_NORETURN SCM_NOINLINE
;
414 static void vm_error_wrong_num_args (SCM proc
) SCM_NORETURN SCM_NOINLINE
;
415 static void vm_error_wrong_type_apply (SCM proc
) SCM_NORETURN SCM_NOINLINE
;
416 static void vm_error_stack_overflow (struct scm_vm
*vp
) SCM_NORETURN SCM_NOINLINE
;
417 static void vm_error_stack_underflow (void) SCM_NORETURN SCM_NOINLINE
;
418 static void vm_error_improper_list (SCM x
) SCM_NORETURN SCM_NOINLINE
;
419 static void vm_error_not_a_pair (const char *subr
, SCM x
) SCM_NORETURN SCM_NOINLINE
;
420 static void vm_error_not_a_bytevector (const char *subr
, SCM x
) SCM_NORETURN SCM_NOINLINE
;
421 static void vm_error_not_a_struct (const char *subr
, SCM x
) SCM_NORETURN SCM_NOINLINE
;
422 static void vm_error_no_values (void) SCM_NORETURN SCM_NOINLINE
;
423 static void vm_error_not_enough_values (void) SCM_NORETURN SCM_NOINLINE
;
424 static void vm_error_wrong_number_of_values (scm_t_uint32 expected
) SCM_NORETURN SCM_NOINLINE
;
425 static void vm_error_continuation_not_rewindable (SCM cont
) SCM_NORETURN SCM_NOINLINE
;
426 static void vm_error_bad_wide_string_length (size_t len
) SCM_NORETURN SCM_NOINLINE
;
429 vm_error (const char *msg
, SCM arg
)
431 scm_throw (sym_vm_error
,
432 scm_list_3 (sym_vm_run
, scm_from_latin1_string (msg
),
433 SCM_UNBNDP (arg
) ? SCM_EOL
: scm_list_1 (arg
)));
434 abort(); /* not reached */
438 vm_error_bad_instruction (scm_t_uint32 inst
)
440 vm_error ("VM: Bad instruction: ~s", scm_from_uint32 (inst
));
444 vm_error_unbound (SCM proc
, SCM sym
)
446 scm_error_scm (scm_misc_error_key
, proc
,
447 scm_from_latin1_string ("Unbound variable: ~s"),
448 scm_list_1 (sym
), SCM_BOOL_F
);
452 vm_error_unbound_fluid (SCM proc
, SCM fluid
)
454 scm_error_scm (scm_misc_error_key
, proc
,
455 scm_from_latin1_string ("Unbound fluid: ~s"),
456 scm_list_1 (fluid
), SCM_BOOL_F
);
460 vm_error_not_a_variable (const char *func_name
, SCM x
)
462 scm_error (scm_arg_type_key
, func_name
, "Not a variable: ~S",
463 scm_list_1 (x
), scm_list_1 (x
));
467 vm_error_apply_to_non_list (SCM x
)
469 scm_error (scm_arg_type_key
, "apply", "Apply to non-list: ~S",
470 scm_list_1 (x
), scm_list_1 (x
));
474 vm_error_kwargs_length_not_even (SCM proc
)
476 scm_error_scm (sym_keyword_argument_error
, proc
,
477 scm_from_latin1_string ("Odd length of keyword argument list"),
478 SCM_EOL
, SCM_BOOL_F
);
482 vm_error_kwargs_invalid_keyword (SCM proc
, SCM obj
)
484 scm_error_scm (sym_keyword_argument_error
, proc
,
485 scm_from_latin1_string ("Invalid keyword"),
486 SCM_EOL
, scm_list_1 (obj
));
490 vm_error_kwargs_unrecognized_keyword (SCM proc
, SCM kw
)
492 scm_error_scm (sym_keyword_argument_error
, proc
,
493 scm_from_latin1_string ("Unrecognized keyword"),
494 SCM_EOL
, scm_list_1 (kw
));
498 vm_error_too_many_args (int nargs
)
500 vm_error ("VM: Too many arguments", scm_from_int (nargs
));
504 vm_error_wrong_num_args (SCM proc
)
506 scm_wrong_num_args (proc
);
510 vm_error_wrong_type_apply (SCM proc
)
512 scm_error (scm_arg_type_key
, NULL
, "Wrong type to apply: ~S",
513 scm_list_1 (proc
), scm_list_1 (proc
));
517 vm_error_stack_overflow (struct scm_vm
*vp
)
519 if (vp
->stack_limit
< vp
->stack_base
+ vp
->stack_size
)
520 /* There are VM_STACK_RESERVE_SIZE bytes left. Make them available so
521 that `throw' below can run on this VM. */
522 vp
->stack_limit
= vp
->stack_base
+ vp
->stack_size
;
524 /* There is no space left on the stack. FIXME: Do something more
527 vm_error ("VM: Stack overflow", SCM_UNDEFINED
);
531 vm_error_stack_underflow (void)
533 vm_error ("VM: Stack underflow", SCM_UNDEFINED
);
537 vm_error_improper_list (SCM x
)
539 vm_error ("Expected a proper list, but got object with tail ~s", x
);
543 vm_error_not_a_pair (const char *subr
, SCM x
)
545 scm_wrong_type_arg_msg (subr
, 1, x
, "pair");
549 vm_error_not_a_bytevector (const char *subr
, SCM x
)
551 scm_wrong_type_arg_msg (subr
, 1, x
, "bytevector");
555 vm_error_not_a_struct (const char *subr
, SCM x
)
557 scm_wrong_type_arg_msg (subr
, 1, x
, "struct");
561 vm_error_no_values (void)
563 vm_error ("Zero values returned to single-valued continuation",
568 vm_error_not_enough_values (void)
570 vm_error ("Too few values returned to continuation", SCM_UNDEFINED
);
574 vm_error_wrong_number_of_values (scm_t_uint32 expected
)
576 vm_error ("Wrong number of values returned to continuation (expected ~a)",
577 scm_from_uint32 (expected
));
581 vm_error_continuation_not_rewindable (SCM cont
)
583 vm_error ("Unrewindable partial continuation", cont
);
587 vm_error_bad_wide_string_length (size_t len
)
589 vm_error ("VM: Bad wide string length: ~S", scm_from_size_t (len
));
595 static SCM rtl_boot_continuation
;
596 static SCM vm_builtin_apply
;
597 static SCM vm_builtin_values
;
598 static SCM vm_builtin_abort_to_prompt
;
599 static SCM vm_builtin_call_with_values
;
600 static SCM vm_builtin_call_with_current_continuation
;
602 static const scm_t_uint32 rtl_boot_continuation_code
[] = {
603 SCM_PACK_RTL_24 (scm_rtl_op_halt
, 0)
606 static const scm_t_uint32 vm_builtin_apply_code
[] = {
607 SCM_PACK_RTL_24 (scm_rtl_op_assert_nargs_ge
, 3),
608 SCM_PACK_RTL_24 (scm_rtl_op_tail_apply
, 0), /* proc in r1, args from r2 */
611 static const scm_t_uint32 vm_builtin_values_code
[] = {
612 SCM_PACK_RTL_24 (scm_rtl_op_return_values
, 0) /* vals from r1 */
615 static const scm_t_uint32 vm_builtin_abort_to_prompt_code
[] = {
616 SCM_PACK_RTL_24 (scm_rtl_op_assert_nargs_ge
, 2),
617 SCM_PACK_RTL_24 (scm_rtl_op_abort
, 0), /* tag in r1, vals from r2 */
618 /* FIXME: Partial continuation should capture caller regs. */
619 SCM_PACK_RTL_24 (scm_rtl_op_return_values
, 0) /* vals from r1 */
622 static const scm_t_uint32 vm_builtin_call_with_values_code
[] = {
623 SCM_PACK_RTL_24 (scm_rtl_op_assert_nargs_ee
, 3),
624 SCM_PACK_RTL_24 (scm_rtl_op_alloc_frame
, 7),
625 SCM_PACK_RTL_12_12 (scm_rtl_op_mov
, 6, 1),
626 SCM_PACK_RTL_24 (scm_rtl_op_call
, 6), SCM_PACK_RTL_24 (0, 1),
627 SCM_PACK_RTL_12_12 (scm_rtl_op_mov
, 0, 2),
628 SCM_PACK_RTL_24 (scm_rtl_op_tail_call_shuffle
, 7)
631 static const scm_t_uint32 vm_builtin_call_with_current_continuation_code
[] = {
632 SCM_PACK_RTL_24 (scm_rtl_op_assert_nargs_ee
, 2),
633 SCM_PACK_RTL_24 (scm_rtl_op_call_cc
, 0)
638 scm_vm_builtin_ref (unsigned idx
)
642 #define INDEX_TO_NAME(builtin, BUILTIN, req, opt, rest) \
643 case SCM_VM_BUILTIN_##BUILTIN: return vm_builtin_##builtin;
644 FOR_EACH_VM_BUILTIN(INDEX_TO_NAME
)
651 static SCM scm_sym_values
;
652 static SCM scm_sym_abort_to_prompt
;
653 static SCM scm_sym_call_with_values
;
654 static SCM scm_sym_call_with_current_continuation
;
657 scm_vm_builtin_name_to_index (SCM name
)
658 #define FUNC_NAME "builtin-name->index"
660 SCM_VALIDATE_SYMBOL (1, name
);
662 #define NAME_TO_INDEX(builtin, BUILTIN, req, opt, rest) \
663 if (scm_is_eq (name, scm_sym_##builtin)) \
664 return scm_from_uint (SCM_VM_BUILTIN_##BUILTIN);
665 FOR_EACH_VM_BUILTIN(NAME_TO_INDEX
)
673 scm_vm_builtin_index_to_name (SCM index
)
674 #define FUNC_NAME "builtin-index->name"
678 SCM_VALIDATE_UINT_COPY (1, index
, idx
);
682 #define INDEX_TO_NAME(builtin, BUILTIN, req, opt, rest) \
683 case SCM_VM_BUILTIN_##BUILTIN: return scm_sym_##builtin;
684 FOR_EACH_VM_BUILTIN(INDEX_TO_NAME
)
686 default: return SCM_BOOL_F
;
692 scm_init_vm_builtins (void)
694 scm_c_define_gsubr ("builtin-name->index", 1, 0, 0,
695 scm_vm_builtin_name_to_index
);
696 scm_c_define_gsubr ("builtin-index->name", 1, 0, 0,
697 scm_vm_builtin_index_to_name
);
701 scm_i_call_with_current_continuation (SCM proc
)
703 return scm_call_1 (vm_builtin_call_with_current_continuation
, proc
);
712 resolve_variable (SCM what
, SCM module
)
714 if (SCM_LIKELY (scm_is_symbol (what
)))
716 if (scm_is_true (module
))
717 return scm_module_lookup (module
, what
);
719 return scm_module_lookup (scm_the_root_module (), what
);
723 SCM modname
, sym
, public;
725 modname
= SCM_CAR (what
);
726 sym
= SCM_CADR (what
);
727 public = SCM_CADDR (what
);
729 if (!scm_module_system_booted_p
)
731 #ifdef VM_ENABLE_PARANOID_ASSERTIONS
732 ASSERT (scm_is_false (public));
734 (scm_equal_p (modname
,
735 scm_list_1 (scm_from_utf8_symbol ("guile")))));
737 return scm_lookup (sym
);
739 else if (scm_is_true (public))
740 return scm_public_lookup (modname
, sym
);
742 return scm_private_lookup (modname
, sym
);
746 #define VM_MIN_STACK_SIZE (1024)
747 #define VM_DEFAULT_STACK_SIZE (256 * 1024)
748 static size_t vm_stack_size
= VM_DEFAULT_STACK_SIZE
;
751 initialize_default_stack_size (void)
753 int size
= scm_getenv_int ("GUILE_STACK_SIZE", vm_stack_size
);
754 if (size
>= VM_MIN_STACK_SIZE
)
755 vm_stack_size
= size
;
758 #define RTL_VM_NAME rtl_vm_regular_engine
759 #define FUNC_NAME "vm-regular-engine"
760 #define VM_ENGINE SCM_VM_REGULAR_ENGINE
761 #include "vm-engine.c"
766 #define RTL_VM_NAME rtl_vm_debug_engine
767 #define FUNC_NAME "vm-debug-engine"
768 #define VM_ENGINE SCM_VM_DEBUG_ENGINE
769 #include "vm-engine.c"
774 typedef SCM (*scm_t_rtl_vm_engine
) (SCM vm
, SCM program
, SCM
*argv
, size_t nargs
);
776 static const scm_t_rtl_vm_engine rtl_vm_engines
[] =
777 { rtl_vm_regular_engine
, rtl_vm_debug_engine
};
779 #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
781 /* The GC "kind" for the VM stack. */
782 static int vm_stack_gc_kind
;
788 #define FUNC_NAME "make_vm"
793 vp
= scm_gc_malloc (sizeof (struct scm_vm
), "vm");
795 vp
->stack_size
= vm_stack_size
;
797 #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
798 vp
->stack_base
= (SCM
*)
799 GC_generic_malloc (vp
->stack_size
* sizeof (SCM
), vm_stack_gc_kind
);
801 /* Keep a pointer to VP so that `vm_stack_mark ()' can know what the stack
803 *vp
->stack_base
= SCM_PACK_POINTER (vp
);
807 vp
->stack_base
= scm_gc_malloc (vp
->stack_size
* sizeof (SCM
),
811 #ifdef VM_ENABLE_STACK_NULLING
812 memset (vp
->stack_base
, 0, vp
->stack_size
* sizeof (SCM
));
814 vp
->stack_limit
= vp
->stack_base
+ vp
->stack_size
- VM_STACK_RESERVE_SIZE
;
816 vp
->sp
= vp
->stack_base
- 1;
818 vp
->engine
= vm_default_engine
;
820 for (i
= 0; i
< SCM_VM_NUM_HOOKS
; i
++)
821 vp
->hooks
[i
] = SCM_BOOL_F
;
822 return scm_cell (scm_tc7_vm
, (scm_t_bits
)vp
);
826 #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
828 /* Mark the VM stack region between its base and its current top. */
829 static struct GC_ms_entry
*
830 vm_stack_mark (GC_word
*addr
, struct GC_ms_entry
*mark_stack_ptr
,
831 struct GC_ms_entry
*mark_stack_limit
, GC_word env
)
834 const struct scm_vm
*vm
;
836 /* The first word of the VM stack should contain a pointer to the
838 vm
= * ((struct scm_vm
**) addr
);
841 || (SCM
*) addr
!= vm
->stack_base
- 1)
842 /* ADDR must be a pointer to a free-list element, which we must ignore
843 (see warning in <gc/gc_mark.h>). */
844 return mark_stack_ptr
;
846 for (word
= (GC_word
*) vm
->stack_base
; word
<= (GC_word
*) vm
->sp
; word
++)
847 mark_stack_ptr
= GC_MARK_AND_PUSH ((* (GC_word
**) word
),
848 mark_stack_ptr
, mark_stack_limit
,
851 return mark_stack_ptr
;
854 #endif /* VM_ENABLE_PRECISE_STACK_GC_SCAN */
858 scm_c_vm_run (SCM vm
, SCM program
, SCM
*argv
, int nargs
)
860 struct scm_vm
*vp
= SCM_VM_DATA (vm
);
862 return rtl_vm_engines
[vp
->engine
](vm
, program
, argv
, nargs
);
865 /* Scheme interface */
867 SCM_DEFINE (scm_the_vm
, "the-vm", 0, 0, 0,
869 "Return the current thread's VM.")
870 #define FUNC_NAME s_scm_the_vm
872 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
874 if (SCM_UNLIKELY (scm_is_false (t
->vm
)))
882 SCM_DEFINE (scm_vm_p
, "vm?", 1, 0, 0,
885 #define FUNC_NAME s_scm_vm_p
887 return scm_from_bool (SCM_VM_P (obj
));
891 SCM_DEFINE (scm_make_vm
, "make-vm", 0, 0, 0,
894 #define FUNC_NAME s_scm_make_vm,
900 SCM_DEFINE (scm_vm_ip
, "vm:ip", 1, 0, 0,
903 #define FUNC_NAME s_scm_vm_ip
905 SCM_VALIDATE_VM (1, vm
);
906 return scm_from_unsigned_integer ((scm_t_bits
) SCM_VM_DATA (vm
)->ip
);
910 SCM_DEFINE (scm_vm_sp
, "vm:sp", 1, 0, 0,
913 #define FUNC_NAME s_scm_vm_sp
915 SCM_VALIDATE_VM (1, vm
);
916 return scm_from_unsigned_integer ((scm_t_bits
) SCM_VM_DATA (vm
)->sp
);
920 SCM_DEFINE (scm_vm_fp
, "vm:fp", 1, 0, 0,
923 #define FUNC_NAME s_scm_vm_fp
925 SCM_VALIDATE_VM (1, vm
);
926 return scm_from_unsigned_integer ((scm_t_bits
) SCM_VM_DATA (vm
)->fp
);
930 #define VM_DEFINE_HOOK(n) \
933 SCM_VALIDATE_VM (1, vm); \
934 vp = SCM_VM_DATA (vm); \
935 if (scm_is_false (vp->hooks[n])) \
936 vp->hooks[n] = scm_make_hook (SCM_I_MAKINUM (1)); \
937 return vp->hooks[n]; \
940 SCM_DEFINE (scm_vm_apply_hook
, "vm-apply-hook", 1, 0, 0,
943 #define FUNC_NAME s_scm_vm_apply_hook
945 VM_DEFINE_HOOK (SCM_VM_APPLY_HOOK
);
949 SCM_DEFINE (scm_vm_push_continuation_hook
, "vm-push-continuation-hook", 1, 0, 0,
952 #define FUNC_NAME s_scm_vm_push_continuation_hook
954 VM_DEFINE_HOOK (SCM_VM_PUSH_CONTINUATION_HOOK
);
958 SCM_DEFINE (scm_vm_pop_continuation_hook
, "vm-pop-continuation-hook", 1, 0, 0,
961 #define FUNC_NAME s_scm_vm_pop_continuation_hook
963 VM_DEFINE_HOOK (SCM_VM_POP_CONTINUATION_HOOK
);
967 SCM_DEFINE (scm_vm_next_hook
, "vm-next-hook", 1, 0, 0,
970 #define FUNC_NAME s_scm_vm_next_hook
972 VM_DEFINE_HOOK (SCM_VM_NEXT_HOOK
);
976 SCM_DEFINE (scm_vm_abort_continuation_hook
, "vm-abort-continuation-hook", 1, 0, 0,
979 #define FUNC_NAME s_scm_vm_abort_continuation_hook
981 VM_DEFINE_HOOK (SCM_VM_ABORT_CONTINUATION_HOOK
);
985 SCM_DEFINE (scm_vm_restore_continuation_hook
, "vm-restore-continuation-hook", 1, 0, 0,
988 #define FUNC_NAME s_scm_vm_restore_continuation_hook
990 VM_DEFINE_HOOK (SCM_VM_RESTORE_CONTINUATION_HOOK
);
994 SCM_DEFINE (scm_vm_trace_level
, "vm-trace-level", 1, 0, 0,
997 #define FUNC_NAME s_scm_vm_trace_level
999 SCM_VALIDATE_VM (1, vm
);
1000 return scm_from_int (SCM_VM_DATA (vm
)->trace_level
);
1004 SCM_DEFINE (scm_set_vm_trace_level_x
, "set-vm-trace-level!", 2, 0, 0,
1005 (SCM vm
, SCM level
),
1007 #define FUNC_NAME s_scm_set_vm_trace_level_x
1009 SCM_VALIDATE_VM (1, vm
);
1010 SCM_VM_DATA (vm
)->trace_level
= scm_to_int (level
);
1011 return SCM_UNSPECIFIED
;
1021 symbol_to_vm_engine (SCM engine
, const char *FUNC_NAME
)
1023 if (scm_is_eq (engine
, sym_regular
))
1024 return SCM_VM_REGULAR_ENGINE
;
1025 else if (scm_is_eq (engine
, sym_debug
))
1026 return SCM_VM_DEBUG_ENGINE
;
1028 SCM_MISC_ERROR ("Unknown VM engine: ~a", scm_list_1 (engine
));
1032 vm_engine_to_symbol (int engine
, const char *FUNC_NAME
)
1036 case SCM_VM_REGULAR_ENGINE
:
1038 case SCM_VM_DEBUG_ENGINE
:
1042 SCM_MISC_ERROR ("Unknown VM engine: ~a",
1043 scm_list_1 (scm_from_int (engine
)));
1047 SCM_DEFINE (scm_vm_engine
, "vm-engine", 1, 0, 0,
1050 #define FUNC_NAME s_scm_vm_engine
1052 SCM_VALIDATE_VM (1, vm
);
1053 return vm_engine_to_symbol (SCM_VM_DATA (vm
)->engine
, FUNC_NAME
);
1058 scm_c_set_vm_engine_x (SCM vm
, int engine
)
1059 #define FUNC_NAME "set-vm-engine!"
1061 SCM_VALIDATE_VM (1, vm
);
1063 if (engine
< 0 || engine
>= SCM_VM_NUM_ENGINES
)
1064 SCM_MISC_ERROR ("Unknown VM engine: ~a",
1065 scm_list_1 (scm_from_int (engine
)));
1067 SCM_VM_DATA (vm
)->engine
= engine
;
1071 SCM_DEFINE (scm_set_vm_engine_x
, "set-vm-engine!", 2, 0, 0,
1072 (SCM vm
, SCM engine
),
1074 #define FUNC_NAME s_scm_set_vm_engine_x
1076 scm_c_set_vm_engine_x (vm
, symbol_to_vm_engine (engine
, FUNC_NAME
));
1077 return SCM_UNSPECIFIED
;
1082 scm_c_set_default_vm_engine_x (int engine
)
1083 #define FUNC_NAME "set-default-vm-engine!"
1085 if (engine
< 0 || engine
>= SCM_VM_NUM_ENGINES
)
1086 SCM_MISC_ERROR ("Unknown VM engine: ~a",
1087 scm_list_1 (scm_from_int (engine
)));
1089 vm_default_engine
= engine
;
1093 SCM_DEFINE (scm_set_default_vm_engine_x
, "set-default-vm-engine!", 1, 0, 0,
1096 #define FUNC_NAME s_scm_set_default_vm_engine_x
1098 scm_c_set_default_vm_engine_x (symbol_to_vm_engine (engine
, FUNC_NAME
));
1099 return SCM_UNSPECIFIED
;
1103 static void reinstate_vm (SCM vm
)
1105 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
1109 SCM_DEFINE (scm_call_with_vm
, "call-with-vm", 2, 0, 1,
1110 (SCM vm
, SCM proc
, SCM args
),
1111 "Apply @var{proc} to @var{args} in a dynamic extent in which\n"
1112 "@var{vm} is the current VM.\n\n"
1113 "As an implementation restriction, if @var{vm} is not the same\n"
1114 "as the current thread's VM, continuations captured within the\n"
1115 "call to @var{proc} may not be reinstated once control leaves\n"
1117 #define FUNC_NAME s_scm_call_with_vm
1122 scm_t_wind_flags flags
;
1123 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
1125 SCM_VALIDATE_VM (1, vm
);
1126 SCM_VALIDATE_PROC (2, proc
);
1128 nargs
= scm_ilength (args
);
1129 if (SCM_UNLIKELY (nargs
< 0))
1130 scm_wrong_type_arg_msg (FUNC_NAME
, 3, args
, "list");
1132 argv
= alloca (nargs
* sizeof(SCM
));
1133 for (i
= 0; i
< nargs
; i
++)
1135 argv
[i
] = SCM_CAR (args
);
1136 args
= SCM_CDR (args
);
1141 /* Reentry can happen via invokation of a saved continuation, but
1142 continuations only save the state of the VM that they are in at
1143 capture-time, which might be different from this one. So, in the
1144 case that the VMs are different, set up a non-rewindable frame to
1145 prevent reinstating an incomplete continuation. */
1146 flags
= scm_is_eq (prev_vm
, vm
) ? 0 : SCM_F_WIND_EXPLICITLY
;
1149 scm_dynwind_begin (0);
1150 scm_dynwind_unwind_handler_with_scm (reinstate_vm
, prev_vm
, flags
);
1154 ret
= scm_c_vm_run (vm
, proc
, argv
, nargs
);
1168 SCM
scm_load_compiled_with_vm (SCM file
)
1170 SCM program
= scm_load_thunk_from_file (file
);
1172 return scm_c_vm_run (scm_the_vm (), program
, NULL
, 0);
1177 scm_init_vm_builtin_properties (void)
1179 /* FIXME: Seems hacky to do this here, but oh well :/ */
1180 scm_sym_apply
= scm_from_utf8_symbol ("apply");
1181 scm_sym_values
= scm_from_utf8_symbol ("values");
1182 scm_sym_abort_to_prompt
= scm_from_utf8_symbol ("abort-to-prompt");
1183 scm_sym_call_with_values
= scm_from_utf8_symbol ("call-with-values");
1184 scm_sym_call_with_current_continuation
=
1185 scm_from_utf8_symbol ("call-with-current-continuation");
1187 #define INIT_BUILTIN(builtin, BUILTIN, req, opt, rest) \
1188 scm_set_procedure_property_x (vm_builtin_##builtin, scm_sym_name, \
1189 scm_sym_##builtin); \
1190 scm_set_procedure_minimum_arity_x (vm_builtin_##builtin, \
1191 SCM_I_MAKINUM (req), \
1192 SCM_I_MAKINUM (opt), \
1193 scm_from_bool (rest));
1194 FOR_EACH_VM_BUILTIN (INIT_BUILTIN
);
1199 scm_bootstrap_vm (void)
1201 scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION
,
1203 (scm_t_extension_init_func
)scm_init_vm
, NULL
);
1204 scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION
,
1205 "scm_init_vm_builtins",
1206 (scm_t_extension_init_func
)scm_init_vm_builtins
,
1209 initialize_default_stack_size ();
1211 sym_vm_run
= scm_from_latin1_symbol ("vm-run");
1212 sym_vm_error
= scm_from_latin1_symbol ("vm-error");
1213 sym_keyword_argument_error
= scm_from_latin1_symbol ("keyword-argument-error");
1214 sym_regular
= scm_from_latin1_symbol ("regular");
1215 sym_debug
= scm_from_latin1_symbol ("debug");
1217 rtl_boot_continuation
= scm_i_make_program (rtl_boot_continuation_code
);
1218 SCM_SET_CELL_WORD_0 (rtl_boot_continuation
,
1219 (SCM_CELL_WORD_0 (rtl_boot_continuation
)
1220 | SCM_F_PROGRAM_IS_BOOT
));
1222 #define DEFINE_BUILTIN(builtin, BUILTIN, req, opt, rest) \
1223 vm_builtin_##builtin = scm_i_make_program (vm_builtin_##builtin##_code);
1224 FOR_EACH_VM_BUILTIN (DEFINE_BUILTIN
);
1225 #undef DEFINE_BUILTIN
1227 #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
1229 GC_new_kind (GC_new_free_list (),
1230 GC_MAKE_PROC (GC_new_proc (vm_stack_mark
), 0),
1239 #ifndef SCM_MAGIC_SNARFER
1240 #include "libguile/vm.x"