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_uint8
*ra
,
107 scm_t_uint8
*mvra
, scm_t_dynstack
*dynstack
,
110 struct scm_vm_cont
*p
;
112 p
= scm_gc_malloc (sizeof (*p
), "capture_vm_cont");
113 p
->stack_size
= sp
- stack_base
+ 1;
114 p
->stack_base
= scm_gc_malloc (p
->stack_size
* sizeof (SCM
),
116 #if defined(VM_ENABLE_STACK_NULLING) && 0
117 /* Tail continuations leave their frame on the stack for subsequent
118 application, but don't capture the frame -- so there are some elements on
119 the stack then, and this check doesn't work, so disable it for now. */
120 if (sp
>= vp
->stack_base
)
121 if (!vp
->sp
[0] || vp
->sp
[1])
123 memset (p
->stack_base
, 0, p
->stack_size
* sizeof (SCM
));
129 memcpy (p
->stack_base
, stack_base
, (sp
+ 1 - stack_base
) * sizeof (SCM
));
130 p
->reloc
= p
->stack_base
- stack_base
;
131 p
->dynstack
= dynstack
;
133 return scm_cell (scm_tc7_vm_cont
, (scm_t_bits
)p
);
137 vm_return_to_continuation (SCM vm
, SCM cont
, size_t n
, SCM
*argv
)
140 struct scm_vm_cont
*cp
;
143 argv_copy
= alloca (n
* sizeof(SCM
));
144 memcpy (argv_copy
, argv
, n
* sizeof(SCM
));
146 vp
= SCM_VM_DATA (vm
);
147 cp
= SCM_VM_CONT_DATA (cont
);
149 if (n
== 0 && !cp
->mvra
)
150 scm_misc_error (NULL
, "Too few values returned to continuation",
153 if (vp
->stack_size
< cp
->stack_size
+ n
+ 4)
154 scm_misc_error ("vm-engine", "not enough space to reinstate continuation",
155 scm_list_2 (vm
, cont
));
157 #ifdef VM_ENABLE_STACK_NULLING
159 scm_t_ptrdiff nzero
= (vp
->sp
- cp
->sp
);
161 memset (vp
->stack_base
+ cp
->stack_size
, 0, nzero
* sizeof (SCM
));
162 /* actually nzero should always be negative, because vm_reset_stack will
163 unwind the stack to some point *below* this continuation */
168 memcpy (vp
->stack_base
, cp
->stack_base
, cp
->stack_size
* sizeof (SCM
));
173 /* Push on an empty frame, as the continuation expects. */
174 for (i
= 0; i
< 4; i
++)
177 *vp
->sp
= SCM_BOOL_F
;
180 /* Push the return values. */
181 for (i
= 0; i
< n
; i
++)
184 *vp
->sp
= argv_copy
[i
];
191 scm_i_capture_current_stack (void)
193 scm_i_thread
*thread
;
197 thread
= SCM_I_CURRENT_THREAD
;
199 vp
= SCM_VM_DATA (vm
);
201 return scm_i_vm_capture_stack (vp
->stack_base
, vp
->fp
, vp
->sp
, vp
->ip
, NULL
,
202 scm_dynstack_capture_all (&thread
->dynstack
),
206 static void vm_dispatch_hook (SCM vm
, int hook_num
,
207 SCM
*argv
, int n
) SCM_NOINLINE
;
210 vm_dispatch_hook (SCM vm
, int hook_num
, SCM
*argv
, int n
)
214 struct scm_frame c_frame
;
216 int saved_trace_level
;
218 vp
= SCM_VM_DATA (vm
);
219 hook
= vp
->hooks
[hook_num
];
221 if (SCM_LIKELY (scm_is_false (hook
))
222 || scm_is_null (SCM_HOOK_PROCEDURES (hook
)))
225 saved_trace_level
= vp
->trace_level
;
228 /* Allocate a frame object on the stack. This is more efficient than calling
229 `scm_c_make_frame ()' to allocate on the heap, but it forces hooks to not
230 capture frame objects.
232 At the same time, procedures such as `frame-procedure' make sense only
233 while the stack frame represented by the frame object is visible, so it
234 seems reasonable to limit the lifetime of frame objects. */
236 c_frame
.stack_holder
= vm
;
242 /* Arrange for FRAME to be 8-byte aligned, like any other cell. */
243 frame
= alloca (sizeof (*frame
) + 8);
244 frame
= (scm_t_cell
*) ROUND_UP ((scm_t_uintptr
) frame
, 8UL);
246 frame
->word_0
= SCM_PACK (scm_tc7_frame
);
247 frame
->word_1
= SCM_PACK_POINTER (&c_frame
);
253 args
[0] = SCM_PACK_POINTER (frame
);
254 scm_c_run_hookn (hook
, args
, 1);
260 args
[0] = SCM_PACK_POINTER (frame
);
262 scm_c_run_hookn (hook
, args
, 2);
269 args
= scm_cons (argv
[n
], args
);
270 scm_c_run_hook (hook
, scm_cons (SCM_PACK_POINTER (frame
), args
));
273 vp
->trace_level
= saved_trace_level
;
277 vm_abort (SCM vm
, SCM tag
, size_t nstack
, SCM
*stack_args
, SCM tail
, SCM
*sp
,
278 scm_i_jmp_buf
*current_registers
) SCM_NORETURN
;
281 vm_abort (SCM vm
, SCM tag
, size_t nstack
, SCM
*stack_args
, SCM tail
, SCM
*sp
,
282 scm_i_jmp_buf
*current_registers
)
288 tail_len
= scm_ilength (tail
);
290 scm_misc_error ("vm-engine", "tail values to abort should be a list",
293 argv
= alloca ((nstack
+ tail_len
) * sizeof (SCM
));
294 for (i
= 0; i
< nstack
; i
++)
295 argv
[i
] = stack_args
[i
];
296 for (; i
< nstack
+ tail_len
; i
++, tail
= scm_cdr (tail
))
297 argv
[i
] = scm_car (tail
);
299 /* FIXME: NULLSTACK (SCM_VM_DATA (vp)->sp - sp) */
300 SCM_VM_DATA (vm
)->sp
= sp
;
302 scm_c_abort (vm
, tag
, nstack
+ tail_len
, argv
, current_registers
);
306 vm_reinstate_partial_continuation (SCM vm
, SCM cont
, size_t n
, SCM
*argv
,
307 scm_t_dynstack
*dynstack
,
308 scm_i_jmp_buf
*registers
)
311 struct scm_vm_cont
*cp
;
312 SCM
*argv_copy
, *base
;
316 argv_copy
= alloca (n
* sizeof(SCM
));
317 memcpy (argv_copy
, argv
, n
* sizeof(SCM
));
319 vp
= SCM_VM_DATA (vm
);
320 cp
= SCM_VM_CONT_DATA (cont
);
321 base
= SCM_FRAME_UPPER_ADDRESS (vp
->fp
) + 1;
322 reloc
= cp
->reloc
+ (base
- cp
->stack_base
);
324 #define RELOC(scm_p) \
325 (((SCM *) (scm_p)) + reloc)
327 if ((base
- vp
->stack_base
) + cp
->stack_size
+ n
+ 1 > vp
->stack_size
)
328 scm_misc_error ("vm-engine",
329 "not enough space to instate partial continuation",
330 scm_list_2 (vm
, cont
));
332 memcpy (base
, cp
->stack_base
, cp
->stack_size
* sizeof (SCM
));
334 /* now relocate frame pointers */
337 for (fp
= RELOC (cp
->fp
);
338 SCM_FRAME_LOWER_ADDRESS (fp
) > base
;
339 fp
= SCM_FRAME_DYNAMIC_LINK (fp
))
340 SCM_FRAME_SET_DYNAMIC_LINK (fp
, RELOC (SCM_FRAME_DYNAMIC_LINK (fp
)));
343 vp
->sp
= base
- 1 + cp
->stack_size
;
344 vp
->fp
= RELOC (cp
->fp
);
347 /* now push args. ip is in a MV context. */
348 for (i
= 0; i
< n
; i
++)
351 *vp
->sp
= argv_copy
[i
];
354 /* The number-of-values marker, only used by the stack VM. */
356 *vp
->sp
= scm_from_size_t (n
);
359 /* The prompt captured a slice of the dynamic stack. Here we wind
360 those entries onto the current thread's stack. We also have to
361 relocate any prompts that we see along the way. */
365 for (walk
= SCM_DYNSTACK_FIRST (cp
->dynstack
);
366 SCM_DYNSTACK_TAG (walk
);
367 walk
= SCM_DYNSTACK_NEXT (walk
))
369 scm_t_bits tag
= SCM_DYNSTACK_TAG (walk
);
371 if (SCM_DYNSTACK_TAG_TYPE (tag
) == SCM_DYNSTACK_TYPE_PROMPT
)
372 scm_dynstack_wind_prompt (dynstack
, walk
, reloc
, registers
);
374 scm_dynstack_wind_1 (dynstack
, walk
);
382 * VM Internal functions
386 scm_i_vm_print (SCM x
, SCM port
, scm_print_state
*pstate
)
388 const struct scm_vm
*vm
;
390 vm
= SCM_VM_DATA (x
);
392 scm_puts_unlocked ("#<vm ", port
);
395 case SCM_VM_REGULAR_ENGINE
:
396 scm_puts_unlocked ("regular-engine ", port
);
399 case SCM_VM_DEBUG_ENGINE
:
400 scm_puts_unlocked ("debug-engine ", port
);
404 scm_puts_unlocked ("unknown-engine ", port
);
406 scm_uintprint (SCM_UNPACK (x
), 16, port
);
407 scm_puts_unlocked (">", port
);
415 static void vm_error (const char *msg
, SCM arg
) SCM_NORETURN
;
416 static void vm_error_bad_instruction (scm_t_uint32 inst
) SCM_NORETURN SCM_NOINLINE
;
417 static void vm_error_unbound (SCM proc
, SCM sym
) SCM_NORETURN SCM_NOINLINE
;
418 static void vm_error_unbound_fluid (SCM proc
, SCM fluid
) SCM_NORETURN SCM_NOINLINE
;
419 static void vm_error_not_a_variable (const char *func_name
, SCM x
) SCM_NORETURN SCM_NOINLINE
;
420 static void vm_error_apply_to_non_list (SCM x
) SCM_NORETURN SCM_NOINLINE
;
421 static void vm_error_kwargs_length_not_even (SCM proc
) SCM_NORETURN SCM_NOINLINE
;
422 static void vm_error_kwargs_invalid_keyword (SCM proc
, SCM obj
) SCM_NORETURN SCM_NOINLINE
;
423 static void vm_error_kwargs_unrecognized_keyword (SCM proc
, SCM kw
) SCM_NORETURN SCM_NOINLINE
;
424 static void vm_error_too_many_args (int nargs
) SCM_NORETURN SCM_NOINLINE
;
425 static void vm_error_wrong_num_args (SCM proc
) SCM_NORETURN SCM_NOINLINE
;
426 static void vm_error_wrong_type_apply (SCM proc
) SCM_NORETURN SCM_NOINLINE
;
427 static void vm_error_stack_overflow (struct scm_vm
*vp
) SCM_NORETURN SCM_NOINLINE
;
428 static void vm_error_stack_underflow (void) SCM_NORETURN SCM_NOINLINE
;
429 static void vm_error_improper_list (SCM x
) SCM_NORETURN SCM_NOINLINE
;
430 static void vm_error_not_a_pair (const char *subr
, SCM x
) SCM_NORETURN SCM_NOINLINE
;
431 static void vm_error_not_a_bytevector (const char *subr
, SCM x
) SCM_NORETURN SCM_NOINLINE
;
432 static void vm_error_not_a_struct (const char *subr
, SCM x
) SCM_NORETURN SCM_NOINLINE
;
433 static void vm_error_no_values (void) SCM_NORETURN SCM_NOINLINE
;
434 static void vm_error_not_enough_values (void) SCM_NORETURN SCM_NOINLINE
;
435 static void vm_error_wrong_number_of_values (scm_t_uint32 expected
) SCM_NORETURN SCM_NOINLINE
;
436 static void vm_error_continuation_not_rewindable (SCM cont
) SCM_NORETURN SCM_NOINLINE
;
437 static void vm_error_bad_wide_string_length (size_t len
) SCM_NORETURN SCM_NOINLINE
;
440 vm_error (const char *msg
, SCM arg
)
442 scm_throw (sym_vm_error
,
443 scm_list_3 (sym_vm_run
, scm_from_latin1_string (msg
),
444 SCM_UNBNDP (arg
) ? SCM_EOL
: scm_list_1 (arg
)));
445 abort(); /* not reached */
449 vm_error_bad_instruction (scm_t_uint32 inst
)
451 vm_error ("VM: Bad instruction: ~s", scm_from_uint32 (inst
));
455 vm_error_unbound (SCM proc
, SCM sym
)
457 scm_error_scm (scm_misc_error_key
, proc
,
458 scm_from_latin1_string ("Unbound variable: ~s"),
459 scm_list_1 (sym
), SCM_BOOL_F
);
463 vm_error_unbound_fluid (SCM proc
, SCM fluid
)
465 scm_error_scm (scm_misc_error_key
, proc
,
466 scm_from_latin1_string ("Unbound fluid: ~s"),
467 scm_list_1 (fluid
), SCM_BOOL_F
);
471 vm_error_not_a_variable (const char *func_name
, SCM x
)
473 scm_error (scm_arg_type_key
, func_name
, "Not a variable: ~S",
474 scm_list_1 (x
), scm_list_1 (x
));
478 vm_error_apply_to_non_list (SCM x
)
480 scm_error (scm_arg_type_key
, "apply", "Apply to non-list: ~S",
481 scm_list_1 (x
), scm_list_1 (x
));
485 vm_error_kwargs_length_not_even (SCM proc
)
487 scm_error_scm (sym_keyword_argument_error
, proc
,
488 scm_from_latin1_string ("Odd length of keyword argument list"),
489 SCM_EOL
, SCM_BOOL_F
);
493 vm_error_kwargs_invalid_keyword (SCM proc
, SCM obj
)
495 scm_error_scm (sym_keyword_argument_error
, proc
,
496 scm_from_latin1_string ("Invalid keyword"),
497 SCM_EOL
, scm_list_1 (obj
));
501 vm_error_kwargs_unrecognized_keyword (SCM proc
, SCM kw
)
503 scm_error_scm (sym_keyword_argument_error
, proc
,
504 scm_from_latin1_string ("Unrecognized keyword"),
505 SCM_EOL
, scm_list_1 (kw
));
509 vm_error_too_many_args (int nargs
)
511 vm_error ("VM: Too many arguments", scm_from_int (nargs
));
515 vm_error_wrong_num_args (SCM proc
)
517 scm_wrong_num_args (proc
);
521 vm_error_wrong_type_apply (SCM proc
)
523 scm_error (scm_arg_type_key
, NULL
, "Wrong type to apply: ~S",
524 scm_list_1 (proc
), scm_list_1 (proc
));
528 vm_error_stack_overflow (struct scm_vm
*vp
)
530 if (vp
->stack_limit
< vp
->stack_base
+ vp
->stack_size
)
531 /* There are VM_STACK_RESERVE_SIZE bytes left. Make them available so
532 that `throw' below can run on this VM. */
533 vp
->stack_limit
= vp
->stack_base
+ vp
->stack_size
;
535 /* There is no space left on the stack. FIXME: Do something more
538 vm_error ("VM: Stack overflow", SCM_UNDEFINED
);
542 vm_error_stack_underflow (void)
544 vm_error ("VM: Stack underflow", SCM_UNDEFINED
);
548 vm_error_improper_list (SCM x
)
550 vm_error ("Expected a proper list, but got object with tail ~s", x
);
554 vm_error_not_a_pair (const char *subr
, SCM x
)
556 scm_wrong_type_arg_msg (subr
, 1, x
, "pair");
560 vm_error_not_a_bytevector (const char *subr
, SCM x
)
562 scm_wrong_type_arg_msg (subr
, 1, x
, "bytevector");
566 vm_error_not_a_struct (const char *subr
, SCM x
)
568 scm_wrong_type_arg_msg (subr
, 1, x
, "struct");
572 vm_error_no_values (void)
574 vm_error ("Zero values returned to single-valued continuation",
579 vm_error_not_enough_values (void)
581 vm_error ("Too few values returned to continuation", SCM_UNDEFINED
);
585 vm_error_wrong_number_of_values (scm_t_uint32 expected
)
587 vm_error ("Wrong number of values returned to continuation (expected ~a)",
588 scm_from_uint32 (expected
));
592 vm_error_continuation_not_rewindable (SCM cont
)
594 vm_error ("Unrewindable partial continuation", cont
);
598 vm_error_bad_wide_string_length (size_t len
)
600 vm_error ("VM: Bad wide string length: ~S", scm_from_size_t (len
));
606 static SCM rtl_boot_continuation
;
607 static SCM vm_builtin_apply
;
608 static SCM vm_builtin_values
;
609 static SCM vm_builtin_abort_to_prompt
;
610 static SCM vm_builtin_call_with_values
;
611 static SCM vm_builtin_call_with_current_continuation
;
613 static const scm_t_uint32 rtl_boot_continuation_code
[] = {
614 SCM_PACK_RTL_24 (scm_rtl_op_halt
, 0)
617 static const scm_t_uint32 vm_builtin_apply_code
[] = {
618 SCM_PACK_RTL_24 (scm_rtl_op_assert_nargs_ge
, 3),
619 SCM_PACK_RTL_24 (scm_rtl_op_tail_apply
, 0), /* proc in r1, args from r2 */
622 static const scm_t_uint32 vm_builtin_values_code
[] = {
623 SCM_PACK_RTL_24 (scm_rtl_op_return_values
, 0) /* vals from r1 */
626 static const scm_t_uint32 vm_builtin_abort_to_prompt_code
[] = {
627 SCM_PACK_RTL_24 (scm_rtl_op_assert_nargs_ge
, 2),
628 SCM_PACK_RTL_24 (scm_rtl_op_abort
, 0), /* tag in r1, vals from r2 */
629 /* FIXME: Partial continuation should capture caller regs. */
630 SCM_PACK_RTL_24 (scm_rtl_op_return_values
, 0) /* vals from r1 */
633 static const scm_t_uint32 vm_builtin_call_with_values_code
[] = {
634 SCM_PACK_RTL_24 (scm_rtl_op_assert_nargs_ee
, 3),
635 SCM_PACK_RTL_24 (scm_rtl_op_alloc_frame
, 7),
636 SCM_PACK_RTL_12_12 (scm_rtl_op_mov
, 6, 1),
637 SCM_PACK_RTL_24 (scm_rtl_op_call
, 6), SCM_PACK_RTL_24 (0, 1),
638 SCM_PACK_RTL_12_12 (scm_rtl_op_mov
, 0, 2),
639 SCM_PACK_RTL_24 (scm_rtl_op_tail_call_shuffle
, 7)
642 static const scm_t_uint32 vm_builtin_call_with_current_continuation_code
[] = {
643 SCM_PACK_RTL_24 (scm_rtl_op_assert_nargs_ee
, 2),
644 SCM_PACK_RTL_24 (scm_rtl_op_call_cc
, 0)
649 scm_vm_builtin_ref (unsigned idx
)
653 #define INDEX_TO_NAME(builtin, BUILTIN, req, opt, rest) \
654 case SCM_VM_BUILTIN_##BUILTIN: return vm_builtin_##builtin;
655 FOR_EACH_VM_BUILTIN(INDEX_TO_NAME
)
662 static SCM scm_sym_values
;
663 static SCM scm_sym_abort_to_prompt
;
664 static SCM scm_sym_call_with_values
;
665 static SCM scm_sym_call_with_current_continuation
;
668 scm_vm_builtin_name_to_index (SCM name
)
669 #define FUNC_NAME "builtin-name->index"
671 SCM_VALIDATE_SYMBOL (1, name
);
673 #define NAME_TO_INDEX(builtin, BUILTIN, req, opt, rest) \
674 if (scm_is_eq (name, scm_sym_##builtin)) \
675 return scm_from_uint (SCM_VM_BUILTIN_##BUILTIN);
676 FOR_EACH_VM_BUILTIN(NAME_TO_INDEX
)
684 scm_vm_builtin_index_to_name (SCM index
)
685 #define FUNC_NAME "builtin-index->name"
689 SCM_VALIDATE_UINT_COPY (1, index
, idx
);
693 #define INDEX_TO_NAME(builtin, BUILTIN, req, opt, rest) \
694 case SCM_VM_BUILTIN_##BUILTIN: return scm_sym_##builtin;
695 FOR_EACH_VM_BUILTIN(INDEX_TO_NAME
)
697 default: return SCM_BOOL_F
;
703 scm_init_vm_builtins (void)
705 scm_c_define_gsubr ("builtin-name->index", 1, 0, 0,
706 scm_vm_builtin_name_to_index
);
707 scm_c_define_gsubr ("builtin-index->name", 1, 0, 0,
708 scm_vm_builtin_index_to_name
);
712 scm_i_call_with_current_continuation (SCM proc
)
714 return scm_call_1 (vm_builtin_call_with_current_continuation
, proc
);
723 resolve_variable (SCM what
, SCM module
)
725 if (SCM_LIKELY (scm_is_symbol (what
)))
727 if (scm_is_true (module
))
728 return scm_module_lookup (module
, what
);
730 return scm_module_lookup (scm_the_root_module (), what
);
734 SCM modname
, sym
, public;
736 modname
= SCM_CAR (what
);
737 sym
= SCM_CADR (what
);
738 public = SCM_CADDR (what
);
740 if (!scm_module_system_booted_p
)
742 #ifdef VM_ENABLE_PARANOID_ASSERTIONS
743 ASSERT (scm_is_false (public));
745 (scm_equal_p (modname
,
746 scm_list_1 (scm_from_utf8_symbol ("guile")))));
748 return scm_lookup (sym
);
750 else if (scm_is_true (public))
751 return scm_public_lookup (modname
, sym
);
753 return scm_private_lookup (modname
, sym
);
757 #define VM_MIN_STACK_SIZE (1024)
758 #define VM_DEFAULT_STACK_SIZE (256 * 1024)
759 static size_t vm_stack_size
= VM_DEFAULT_STACK_SIZE
;
762 initialize_default_stack_size (void)
764 int size
= scm_getenv_int ("GUILE_STACK_SIZE", vm_stack_size
);
765 if (size
>= VM_MIN_STACK_SIZE
)
766 vm_stack_size
= size
;
769 #define RTL_VM_NAME rtl_vm_regular_engine
770 #define FUNC_NAME "vm-regular-engine"
771 #define VM_ENGINE SCM_VM_REGULAR_ENGINE
772 #include "vm-engine.c"
777 #define RTL_VM_NAME rtl_vm_debug_engine
778 #define FUNC_NAME "vm-debug-engine"
779 #define VM_ENGINE SCM_VM_DEBUG_ENGINE
780 #include "vm-engine.c"
785 typedef SCM (*scm_t_rtl_vm_engine
) (SCM vm
, SCM program
, SCM
*argv
, size_t nargs
);
787 static const scm_t_rtl_vm_engine rtl_vm_engines
[] =
788 { rtl_vm_regular_engine
, rtl_vm_debug_engine
};
790 #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
792 /* The GC "kind" for the VM stack. */
793 static int vm_stack_gc_kind
;
799 #define FUNC_NAME "make_vm"
804 vp
= scm_gc_malloc (sizeof (struct scm_vm
), "vm");
806 vp
->stack_size
= vm_stack_size
;
808 #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
809 vp
->stack_base
= (SCM
*)
810 GC_generic_malloc (vp
->stack_size
* sizeof (SCM
), vm_stack_gc_kind
);
812 /* Keep a pointer to VP so that `vm_stack_mark ()' can know what the stack
814 *vp
->stack_base
= SCM_PACK_POINTER (vp
);
818 vp
->stack_base
= scm_gc_malloc (vp
->stack_size
* sizeof (SCM
),
822 #ifdef VM_ENABLE_STACK_NULLING
823 memset (vp
->stack_base
, 0, vp
->stack_size
* sizeof (SCM
));
825 vp
->stack_limit
= vp
->stack_base
+ vp
->stack_size
- VM_STACK_RESERVE_SIZE
;
827 vp
->sp
= vp
->stack_base
- 1;
829 vp
->engine
= vm_default_engine
;
831 for (i
= 0; i
< SCM_VM_NUM_HOOKS
; i
++)
832 vp
->hooks
[i
] = SCM_BOOL_F
;
833 return scm_cell (scm_tc7_vm
, (scm_t_bits
)vp
);
837 #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
839 /* Mark the VM stack region between its base and its current top. */
840 static struct GC_ms_entry
*
841 vm_stack_mark (GC_word
*addr
, struct GC_ms_entry
*mark_stack_ptr
,
842 struct GC_ms_entry
*mark_stack_limit
, GC_word env
)
845 const struct scm_vm
*vm
;
847 /* The first word of the VM stack should contain a pointer to the
849 vm
= * ((struct scm_vm
**) addr
);
852 || (SCM
*) addr
!= vm
->stack_base
- 1)
853 /* ADDR must be a pointer to a free-list element, which we must ignore
854 (see warning in <gc/gc_mark.h>). */
855 return mark_stack_ptr
;
857 for (word
= (GC_word
*) vm
->stack_base
; word
<= (GC_word
*) vm
->sp
; word
++)
858 mark_stack_ptr
= GC_MARK_AND_PUSH ((* (GC_word
**) word
),
859 mark_stack_ptr
, mark_stack_limit
,
862 return mark_stack_ptr
;
865 #endif /* VM_ENABLE_PRECISE_STACK_GC_SCAN */
869 scm_c_vm_run (SCM vm
, SCM program
, SCM
*argv
, int nargs
)
871 struct scm_vm
*vp
= SCM_VM_DATA (vm
);
873 return rtl_vm_engines
[vp
->engine
](vm
, program
, argv
, nargs
);
876 /* Scheme interface */
878 SCM_DEFINE (scm_the_vm
, "the-vm", 0, 0, 0,
880 "Return the current thread's VM.")
881 #define FUNC_NAME s_scm_the_vm
883 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
885 if (SCM_UNLIKELY (scm_is_false (t
->vm
)))
893 SCM_DEFINE (scm_vm_p
, "vm?", 1, 0, 0,
896 #define FUNC_NAME s_scm_vm_p
898 return scm_from_bool (SCM_VM_P (obj
));
902 SCM_DEFINE (scm_make_vm
, "make-vm", 0, 0, 0,
905 #define FUNC_NAME s_scm_make_vm,
911 SCM_DEFINE (scm_vm_ip
, "vm:ip", 1, 0, 0,
914 #define FUNC_NAME s_scm_vm_ip
916 SCM_VALIDATE_VM (1, vm
);
917 return scm_from_unsigned_integer ((scm_t_bits
) SCM_VM_DATA (vm
)->ip
);
921 SCM_DEFINE (scm_vm_sp
, "vm:sp", 1, 0, 0,
924 #define FUNC_NAME s_scm_vm_sp
926 SCM_VALIDATE_VM (1, vm
);
927 return scm_from_unsigned_integer ((scm_t_bits
) SCM_VM_DATA (vm
)->sp
);
931 SCM_DEFINE (scm_vm_fp
, "vm:fp", 1, 0, 0,
934 #define FUNC_NAME s_scm_vm_fp
936 SCM_VALIDATE_VM (1, vm
);
937 return scm_from_unsigned_integer ((scm_t_bits
) SCM_VM_DATA (vm
)->fp
);
941 #define VM_DEFINE_HOOK(n) \
944 SCM_VALIDATE_VM (1, vm); \
945 vp = SCM_VM_DATA (vm); \
946 if (scm_is_false (vp->hooks[n])) \
947 vp->hooks[n] = scm_make_hook (SCM_I_MAKINUM (1)); \
948 return vp->hooks[n]; \
951 SCM_DEFINE (scm_vm_apply_hook
, "vm-apply-hook", 1, 0, 0,
954 #define FUNC_NAME s_scm_vm_apply_hook
956 VM_DEFINE_HOOK (SCM_VM_APPLY_HOOK
);
960 SCM_DEFINE (scm_vm_push_continuation_hook
, "vm-push-continuation-hook", 1, 0, 0,
963 #define FUNC_NAME s_scm_vm_push_continuation_hook
965 VM_DEFINE_HOOK (SCM_VM_PUSH_CONTINUATION_HOOK
);
969 SCM_DEFINE (scm_vm_pop_continuation_hook
, "vm-pop-continuation-hook", 1, 0, 0,
972 #define FUNC_NAME s_scm_vm_pop_continuation_hook
974 VM_DEFINE_HOOK (SCM_VM_POP_CONTINUATION_HOOK
);
978 SCM_DEFINE (scm_vm_next_hook
, "vm-next-hook", 1, 0, 0,
981 #define FUNC_NAME s_scm_vm_next_hook
983 VM_DEFINE_HOOK (SCM_VM_NEXT_HOOK
);
987 SCM_DEFINE (scm_vm_abort_continuation_hook
, "vm-abort-continuation-hook", 1, 0, 0,
990 #define FUNC_NAME s_scm_vm_abort_continuation_hook
992 VM_DEFINE_HOOK (SCM_VM_ABORT_CONTINUATION_HOOK
);
996 SCM_DEFINE (scm_vm_restore_continuation_hook
, "vm-restore-continuation-hook", 1, 0, 0,
999 #define FUNC_NAME s_scm_vm_restore_continuation_hook
1001 VM_DEFINE_HOOK (SCM_VM_RESTORE_CONTINUATION_HOOK
);
1005 SCM_DEFINE (scm_vm_trace_level
, "vm-trace-level", 1, 0, 0,
1008 #define FUNC_NAME s_scm_vm_trace_level
1010 SCM_VALIDATE_VM (1, vm
);
1011 return scm_from_int (SCM_VM_DATA (vm
)->trace_level
);
1015 SCM_DEFINE (scm_set_vm_trace_level_x
, "set-vm-trace-level!", 2, 0, 0,
1016 (SCM vm
, SCM level
),
1018 #define FUNC_NAME s_scm_set_vm_trace_level_x
1020 SCM_VALIDATE_VM (1, vm
);
1021 SCM_VM_DATA (vm
)->trace_level
= scm_to_int (level
);
1022 return SCM_UNSPECIFIED
;
1032 symbol_to_vm_engine (SCM engine
, const char *FUNC_NAME
)
1034 if (scm_is_eq (engine
, sym_regular
))
1035 return SCM_VM_REGULAR_ENGINE
;
1036 else if (scm_is_eq (engine
, sym_debug
))
1037 return SCM_VM_DEBUG_ENGINE
;
1039 SCM_MISC_ERROR ("Unknown VM engine: ~a", scm_list_1 (engine
));
1043 vm_engine_to_symbol (int engine
, const char *FUNC_NAME
)
1047 case SCM_VM_REGULAR_ENGINE
:
1049 case SCM_VM_DEBUG_ENGINE
:
1053 SCM_MISC_ERROR ("Unknown VM engine: ~a",
1054 scm_list_1 (scm_from_int (engine
)));
1058 SCM_DEFINE (scm_vm_engine
, "vm-engine", 1, 0, 0,
1061 #define FUNC_NAME s_scm_vm_engine
1063 SCM_VALIDATE_VM (1, vm
);
1064 return vm_engine_to_symbol (SCM_VM_DATA (vm
)->engine
, FUNC_NAME
);
1069 scm_c_set_vm_engine_x (SCM vm
, int engine
)
1070 #define FUNC_NAME "set-vm-engine!"
1072 SCM_VALIDATE_VM (1, vm
);
1074 if (engine
< 0 || engine
>= SCM_VM_NUM_ENGINES
)
1075 SCM_MISC_ERROR ("Unknown VM engine: ~a",
1076 scm_list_1 (scm_from_int (engine
)));
1078 SCM_VM_DATA (vm
)->engine
= engine
;
1082 SCM_DEFINE (scm_set_vm_engine_x
, "set-vm-engine!", 2, 0, 0,
1083 (SCM vm
, SCM engine
),
1085 #define FUNC_NAME s_scm_set_vm_engine_x
1087 scm_c_set_vm_engine_x (vm
, symbol_to_vm_engine (engine
, FUNC_NAME
));
1088 return SCM_UNSPECIFIED
;
1093 scm_c_set_default_vm_engine_x (int engine
)
1094 #define FUNC_NAME "set-default-vm-engine!"
1096 if (engine
< 0 || engine
>= SCM_VM_NUM_ENGINES
)
1097 SCM_MISC_ERROR ("Unknown VM engine: ~a",
1098 scm_list_1 (scm_from_int (engine
)));
1100 vm_default_engine
= engine
;
1104 SCM_DEFINE (scm_set_default_vm_engine_x
, "set-default-vm-engine!", 1, 0, 0,
1107 #define FUNC_NAME s_scm_set_default_vm_engine_x
1109 scm_c_set_default_vm_engine_x (symbol_to_vm_engine (engine
, FUNC_NAME
));
1110 return SCM_UNSPECIFIED
;
1114 static void reinstate_vm (SCM vm
)
1116 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
1120 SCM_DEFINE (scm_call_with_vm
, "call-with-vm", 2, 0, 1,
1121 (SCM vm
, SCM proc
, SCM args
),
1122 "Apply @var{proc} to @var{args} in a dynamic extent in which\n"
1123 "@var{vm} is the current VM.\n\n"
1124 "As an implementation restriction, if @var{vm} is not the same\n"
1125 "as the current thread's VM, continuations captured within the\n"
1126 "call to @var{proc} may not be reinstated once control leaves\n"
1128 #define FUNC_NAME s_scm_call_with_vm
1133 scm_t_wind_flags flags
;
1134 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
1136 SCM_VALIDATE_VM (1, vm
);
1137 SCM_VALIDATE_PROC (2, proc
);
1139 nargs
= scm_ilength (args
);
1140 if (SCM_UNLIKELY (nargs
< 0))
1141 scm_wrong_type_arg_msg (FUNC_NAME
, 3, args
, "list");
1143 argv
= alloca (nargs
* sizeof(SCM
));
1144 for (i
= 0; i
< nargs
; i
++)
1146 argv
[i
] = SCM_CAR (args
);
1147 args
= SCM_CDR (args
);
1152 /* Reentry can happen via invokation of a saved continuation, but
1153 continuations only save the state of the VM that they are in at
1154 capture-time, which might be different from this one. So, in the
1155 case that the VMs are different, set up a non-rewindable frame to
1156 prevent reinstating an incomplete continuation. */
1157 flags
= scm_is_eq (prev_vm
, vm
) ? 0 : SCM_F_WIND_EXPLICITLY
;
1160 scm_dynwind_begin (0);
1161 scm_dynwind_unwind_handler_with_scm (reinstate_vm
, prev_vm
, flags
);
1165 ret
= scm_c_vm_run (vm
, proc
, argv
, nargs
);
1179 SCM
scm_load_compiled_with_vm (SCM file
)
1181 SCM program
= scm_load_thunk_from_file (file
);
1183 return scm_c_vm_run (scm_the_vm (), program
, NULL
, 0);
1188 scm_init_vm_builtin_properties (void)
1190 /* FIXME: Seems hacky to do this here, but oh well :/ */
1191 scm_sym_apply
= scm_from_utf8_symbol ("apply");
1192 scm_sym_values
= scm_from_utf8_symbol ("values");
1193 scm_sym_abort_to_prompt
= scm_from_utf8_symbol ("abort-to-prompt");
1194 scm_sym_call_with_values
= scm_from_utf8_symbol ("call-with-values");
1195 scm_sym_call_with_current_continuation
=
1196 scm_from_utf8_symbol ("call-with-current-continuation");
1198 #define INIT_BUILTIN(builtin, BUILTIN, req, opt, rest) \
1199 scm_set_procedure_property_x (vm_builtin_##builtin, scm_sym_name, \
1200 scm_sym_##builtin); \
1201 scm_set_procedure_minimum_arity_x (vm_builtin_##builtin, \
1202 SCM_I_MAKINUM (req), \
1203 SCM_I_MAKINUM (opt), \
1204 scm_from_bool (rest));
1205 FOR_EACH_VM_BUILTIN (INIT_BUILTIN
);
1210 scm_bootstrap_vm (void)
1212 scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION
,
1214 (scm_t_extension_init_func
)scm_init_vm
, NULL
);
1215 scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION
,
1216 "scm_init_vm_builtins",
1217 (scm_t_extension_init_func
)scm_init_vm_builtins
,
1220 initialize_default_stack_size ();
1222 sym_vm_run
= scm_from_latin1_symbol ("vm-run");
1223 sym_vm_error
= scm_from_latin1_symbol ("vm-error");
1224 sym_keyword_argument_error
= scm_from_latin1_symbol ("keyword-argument-error");
1225 sym_regular
= scm_from_latin1_symbol ("regular");
1226 sym_debug
= scm_from_latin1_symbol ("debug");
1228 rtl_boot_continuation
= scm_i_make_rtl_program (rtl_boot_continuation_code
);
1229 SCM_SET_CELL_WORD_0 (rtl_boot_continuation
,
1230 (SCM_CELL_WORD_0 (rtl_boot_continuation
)
1231 | SCM_F_PROGRAM_IS_BOOT
));
1233 #define DEFINE_BUILTIN(builtin, BUILTIN, req, opt, rest) \
1234 vm_builtin_##builtin = scm_i_make_rtl_program (vm_builtin_##builtin##_code);
1235 FOR_EACH_VM_BUILTIN (DEFINE_BUILTIN
);
1236 #undef DEFINE_BUILTIN
1238 #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
1240 GC_new_kind (GC_new_free_list (),
1241 GC_MAKE_PROC (GC_new_proc (vm_stack_mark
), 0),
1250 #ifndef SCM_MAGIC_SNARFER
1251 #include "libguile/vm.x"