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"
40 #include "private-gc.h" /* scm_getenv_int */
42 static int vm_default_engine
= SCM_VM_REGULAR_ENGINE
;
44 /* Unfortunately we can't snarf these: snarfed things are only loaded up from
45 (system vm vm), which might not be loaded before an error happens. */
46 static SCM sym_vm_run
;
47 static SCM sym_vm_error
;
48 static SCM sym_keyword_argument_error
;
49 static SCM sym_regular
;
52 /* The VM has a number of internal assertions that shouldn't normally be
53 necessary, but might be if you think you found a bug in the VM. */
54 #define VM_ENABLE_ASSERTIONS
56 /* We can add a mode that ensures that all stack items above the stack pointer
57 are NULL. This is useful for checking the internal consistency of the VM's
58 assumptions and its operators, but isn't necessary for normal operation. It
59 will ensure that assertions are enabled. Slows down the VM by about 30%. */
60 /* NB! If you enable this, search for NULLING in throw.c */
61 /* #define VM_ENABLE_STACK_NULLING */
63 /* #define VM_ENABLE_PARANOID_ASSERTIONS */
65 #if defined (VM_ENABLE_STACK_NULLING) && !defined (VM_ENABLE_ASSERTIONS)
66 #define VM_ENABLE_ASSERTIONS
69 /* When defined, arrange so that the GC doesn't scan the VM stack beyond its
70 current SP. This should help avoid excess data retention. See
71 http://thread.gmane.org/gmane.comp.programming.garbage-collection.boehmgc/3001
73 #define VM_ENABLE_PRECISE_STACK_GC_SCAN
75 /* Size in SCM objects of the stack reserve. The reserve is used to run
76 exception handling code in case of a VM stack overflow. */
77 #define VM_STACK_RESERVE_SIZE 512
86 scm_i_vm_cont_print (SCM x
, SCM port
, scm_print_state
*pstate
)
88 scm_puts_unlocked ("#<vm-continuation ", port
);
89 scm_uintprint (SCM_UNPACK (x
), 16, port
);
90 scm_puts_unlocked (">", port
);
93 /* In theory, a number of vm instances can be active in the call trace, and we
94 only want to reify the continuations of those in the current continuation
95 root. I don't see a nice way to do this -- ideally it would involve dynwinds,
96 and previous values of the *the-vm* fluid within the current continuation
97 root. But we don't have access to continuation roots in the dynwind stack.
98 So, just punt for now, we just capture the continuation for the current VM.
100 While I'm on the topic, ideally we could avoid copying the C stack if the
101 continuation root is inside VM code, and call/cc was invoked within that same
102 call to vm_run; but that's currently not implemented.
105 scm_i_vm_capture_stack (SCM
*stack_base
, SCM
*fp
, SCM
*sp
, scm_t_uint8
*ra
,
106 scm_t_uint8
*mvra
, scm_t_dynstack
*dynstack
,
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
));
128 memcpy (p
->stack_base
, stack_base
, (sp
+ 1 - stack_base
) * sizeof (SCM
));
129 p
->reloc
= p
->stack_base
- stack_base
;
130 p
->dynstack
= dynstack
;
132 return scm_cell (scm_tc7_vm_cont
, (scm_t_bits
)p
);
136 vm_return_to_continuation (SCM vm
, SCM cont
, size_t n
, SCM
*argv
)
139 struct scm_vm_cont
*cp
;
142 argv_copy
= alloca (n
* sizeof(SCM
));
143 memcpy (argv_copy
, argv
, n
* sizeof(SCM
));
145 vp
= SCM_VM_DATA (vm
);
146 cp
= SCM_VM_CONT_DATA (cont
);
148 if (n
== 0 && !cp
->mvra
)
149 scm_misc_error (NULL
, "Too few values returned to continuation",
152 if (vp
->stack_size
< cp
->stack_size
+ n
+ 1)
153 scm_misc_error ("vm-engine", "not enough space to reinstate continuation",
154 scm_list_2 (vm
, cont
));
156 #ifdef VM_ENABLE_STACK_NULLING
158 scm_t_ptrdiff nzero
= (vp
->sp
- cp
->sp
);
160 memset (vp
->stack_base
+ cp
->stack_size
, 0, nzero
* sizeof (SCM
));
161 /* actually nzero should always be negative, because vm_reset_stack will
162 unwind the stack to some point *below* this continuation */
167 memcpy (vp
->stack_base
, cp
->stack_base
, cp
->stack_size
* sizeof (SCM
));
169 if (n
== 1 || !cp
->mvra
)
173 *vp
->sp
= argv_copy
[0];
178 for (i
= 0; i
< n
; i
++)
181 *vp
->sp
= argv_copy
[i
];
184 *vp
->sp
= scm_from_size_t (n
);
190 scm_i_capture_current_stack (void)
192 scm_i_thread
*thread
;
196 thread
= SCM_I_CURRENT_THREAD
;
198 vp
= SCM_VM_DATA (vm
);
200 return scm_i_vm_capture_stack (vp
->stack_base
, vp
->fp
, vp
->sp
, vp
->ip
, NULL
,
201 scm_dynstack_capture_all (&thread
->dynstack
),
205 static void vm_dispatch_hook (SCM vm
, int hook_num
,
206 SCM
*argv
, int n
) SCM_NOINLINE
;
209 vm_dispatch_hook (SCM vm
, int hook_num
, SCM
*argv
, int n
)
213 struct scm_frame c_frame
;
215 int saved_trace_level
;
217 vp
= SCM_VM_DATA (vm
);
218 hook
= vp
->hooks
[hook_num
];
220 if (SCM_LIKELY (scm_is_false (hook
))
221 || scm_is_null (SCM_HOOK_PROCEDURES (hook
)))
224 saved_trace_level
= vp
->trace_level
;
227 /* Allocate a frame object on the stack. This is more efficient than calling
228 `scm_c_make_frame ()' to allocate on the heap, but it forces hooks to not
229 capture frame objects.
231 At the same time, procedures such as `frame-procedure' make sense only
232 while the stack frame represented by the frame object is visible, so it
233 seems reasonable to limit the lifetime of frame objects. */
235 c_frame
.stack_holder
= vm
;
241 /* Arrange for FRAME to be 8-byte aligned, like any other cell. */
242 frame
= alloca (sizeof (*frame
) + 8);
243 frame
= (scm_t_cell
*) ROUND_UP ((scm_t_uintptr
) frame
, 8UL);
245 frame
->word_0
= SCM_PACK (scm_tc7_frame
);
246 frame
->word_1
= SCM_PACK_POINTER (&c_frame
);
252 args
[0] = SCM_PACK_POINTER (frame
);
253 scm_c_run_hookn (hook
, args
, 1);
259 args
[0] = SCM_PACK_POINTER (frame
);
261 scm_c_run_hookn (hook
, args
, 2);
268 args
= scm_cons (argv
[n
], args
);
269 scm_c_run_hook (hook
, scm_cons (SCM_PACK_POINTER (frame
), args
));
272 vp
->trace_level
= saved_trace_level
;
276 vm_abort (SCM vm
, size_t n
, scm_i_jmp_buf
*current_registers
) SCM_NORETURN
;
279 vm_abort (SCM vm
, size_t n
, scm_i_jmp_buf
*current_registers
)
283 SCM tag
, tail
, *argv
;
285 /* FIXME: VM_ENABLE_STACK_NULLING */
286 tail
= *(SCM_VM_DATA (vm
)->sp
--);
288 tail_len
= scm_ilength (tail
);
290 scm_misc_error ("vm-engine", "tail values to abort should be a list",
293 tag
= SCM_VM_DATA (vm
)->sp
[-n
];
294 argv
= alloca ((n
+ tail_len
) * sizeof (SCM
));
295 for (i
= 0; i
< n
; i
++)
296 argv
[i
] = SCM_VM_DATA (vm
)->sp
[-(n
-1-i
)];
297 for (; i
< n
+ tail_len
; i
++, tail
= scm_cdr (tail
))
298 argv
[i
] = scm_car (tail
);
299 /* NULLSTACK (n + 1) */
300 SCM_VM_DATA (vm
)->sp
-= n
+ 1;
302 scm_c_abort (vm
, tag
, n
+ 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 *vp
->sp
= scm_from_size_t (n
);
356 /* The prompt captured a slice of the dynamic stack. Here we wind
357 those entries onto the current thread's stack. We also have to
358 relocate any prompts that we see along the way. */
362 for (walk
= SCM_DYNSTACK_FIRST (cp
->dynstack
);
363 SCM_DYNSTACK_TAG (walk
);
364 walk
= SCM_DYNSTACK_NEXT (walk
))
366 scm_t_bits tag
= SCM_DYNSTACK_TAG (walk
);
368 if (SCM_DYNSTACK_TAG_TYPE (tag
) == SCM_DYNSTACK_TYPE_PROMPT
)
369 scm_dynstack_wind_prompt (dynstack
, walk
, reloc
, registers
);
371 scm_dynstack_wind_1 (dynstack
, walk
);
379 * VM Internal functions
383 scm_i_vm_print (SCM x
, SCM port
, scm_print_state
*pstate
)
385 const struct scm_vm
*vm
;
387 vm
= SCM_VM_DATA (x
);
389 scm_puts_unlocked ("#<vm ", port
);
392 case SCM_VM_REGULAR_ENGINE
:
393 scm_puts_unlocked ("regular-engine ", port
);
396 case SCM_VM_DEBUG_ENGINE
:
397 scm_puts_unlocked ("debug-engine ", port
);
401 scm_puts_unlocked ("unknown-engine ", port
);
403 scm_uintprint (SCM_UNPACK (x
), 16, port
);
404 scm_puts_unlocked (">", port
);
412 static void vm_error (const char *msg
, SCM arg
) SCM_NORETURN
;
413 static void vm_error_bad_instruction (scm_t_uint32 inst
) SCM_NORETURN SCM_NOINLINE
;
414 static void vm_error_unbound (SCM proc
, SCM sym
) SCM_NORETURN SCM_NOINLINE
;
415 static void vm_error_unbound_fluid (SCM proc
, SCM fluid
) SCM_NORETURN SCM_NOINLINE
;
416 static void vm_error_not_a_variable (const char *func_name
, SCM x
) SCM_NORETURN SCM_NOINLINE
;
417 static void vm_error_apply_to_non_list (SCM x
) SCM_NORETURN SCM_NOINLINE
;
418 static void vm_error_kwargs_length_not_even (SCM proc
) SCM_NORETURN SCM_NOINLINE
;
419 static void vm_error_kwargs_invalid_keyword (SCM proc
, SCM obj
) SCM_NORETURN SCM_NOINLINE
;
420 static void vm_error_kwargs_unrecognized_keyword (SCM proc
, SCM kw
) SCM_NORETURN SCM_NOINLINE
;
421 static void vm_error_too_many_args (int nargs
) SCM_NORETURN SCM_NOINLINE
;
422 static void vm_error_wrong_num_args (SCM proc
) SCM_NORETURN SCM_NOINLINE
;
423 static void vm_error_wrong_type_apply (SCM proc
) SCM_NORETURN SCM_NOINLINE
;
424 static void vm_error_stack_overflow (struct scm_vm
*vp
) SCM_NORETURN SCM_NOINLINE
;
425 static void vm_error_stack_underflow (void) SCM_NORETURN SCM_NOINLINE
;
426 static void vm_error_improper_list (SCM x
) SCM_NORETURN SCM_NOINLINE
;
427 static void vm_error_not_a_pair (const char *subr
, SCM x
) SCM_NORETURN SCM_NOINLINE
;
428 static void vm_error_not_a_bytevector (const char *subr
, SCM x
) SCM_NORETURN SCM_NOINLINE
;
429 static void vm_error_not_a_struct (const char *subr
, SCM x
) SCM_NORETURN SCM_NOINLINE
;
430 static void vm_error_no_values (void) SCM_NORETURN SCM_NOINLINE
;
431 static void vm_error_not_enough_values (void) SCM_NORETURN SCM_NOINLINE
;
432 static void vm_error_continuation_not_rewindable (SCM cont
) SCM_NORETURN SCM_NOINLINE
;
433 static void vm_error_bad_wide_string_length (size_t len
) SCM_NORETURN SCM_NOINLINE
;
436 vm_error (const char *msg
, SCM arg
)
438 scm_throw (sym_vm_error
,
439 scm_list_3 (sym_vm_run
, scm_from_latin1_string (msg
),
440 SCM_UNBNDP (arg
) ? SCM_EOL
: scm_list_1 (arg
)));
441 abort(); /* not reached */
445 vm_error_bad_instruction (scm_t_uint32 inst
)
447 vm_error ("VM: Bad instruction: ~s", scm_from_uint32 (inst
));
451 vm_error_unbound (SCM proc
, SCM sym
)
453 scm_error_scm (scm_misc_error_key
, proc
,
454 scm_from_latin1_string ("Unbound variable: ~s"),
455 scm_list_1 (sym
), SCM_BOOL_F
);
459 vm_error_unbound_fluid (SCM proc
, SCM fluid
)
461 scm_error_scm (scm_misc_error_key
, proc
,
462 scm_from_latin1_string ("Unbound fluid: ~s"),
463 scm_list_1 (fluid
), SCM_BOOL_F
);
467 vm_error_not_a_variable (const char *func_name
, SCM x
)
469 scm_error (scm_arg_type_key
, func_name
, "Not a variable: ~S",
470 scm_list_1 (x
), scm_list_1 (x
));
474 vm_error_apply_to_non_list (SCM x
)
476 scm_error (scm_arg_type_key
, "apply", "Apply to non-list: ~S",
477 scm_list_1 (x
), scm_list_1 (x
));
481 vm_error_kwargs_length_not_even (SCM proc
)
483 scm_error_scm (sym_keyword_argument_error
, proc
,
484 scm_from_latin1_string ("Odd length of keyword argument list"),
485 SCM_EOL
, SCM_BOOL_F
);
489 vm_error_kwargs_invalid_keyword (SCM proc
, SCM obj
)
491 scm_error_scm (sym_keyword_argument_error
, proc
,
492 scm_from_latin1_string ("Invalid keyword"),
493 SCM_EOL
, scm_list_1 (obj
));
497 vm_error_kwargs_unrecognized_keyword (SCM proc
, SCM kw
)
499 scm_error_scm (sym_keyword_argument_error
, proc
,
500 scm_from_latin1_string ("Unrecognized keyword"),
501 SCM_EOL
, scm_list_1 (kw
));
505 vm_error_too_many_args (int nargs
)
507 vm_error ("VM: Too many arguments", scm_from_int (nargs
));
511 vm_error_wrong_num_args (SCM proc
)
513 scm_wrong_num_args (proc
);
517 vm_error_wrong_type_apply (SCM proc
)
519 scm_error (scm_arg_type_key
, NULL
, "Wrong type to apply: ~S",
520 scm_list_1 (proc
), scm_list_1 (proc
));
524 vm_error_stack_overflow (struct scm_vm
*vp
)
526 if (vp
->stack_limit
< vp
->stack_base
+ vp
->stack_size
)
527 /* There are VM_STACK_RESERVE_SIZE bytes left. Make them available so
528 that `throw' below can run on this VM. */
529 vp
->stack_limit
= vp
->stack_base
+ vp
->stack_size
;
531 /* There is no space left on the stack. FIXME: Do something more
534 vm_error ("VM: Stack overflow", SCM_UNDEFINED
);
538 vm_error_stack_underflow (void)
540 vm_error ("VM: Stack underflow", SCM_UNDEFINED
);
544 vm_error_improper_list (SCM x
)
546 vm_error ("Expected a proper list, but got object with tail ~s", x
);
550 vm_error_not_a_pair (const char *subr
, SCM x
)
552 scm_wrong_type_arg_msg (subr
, 1, x
, "pair");
556 vm_error_not_a_bytevector (const char *subr
, SCM x
)
558 scm_wrong_type_arg_msg (subr
, 1, x
, "bytevector");
562 vm_error_not_a_struct (const char *subr
, SCM x
)
564 scm_wrong_type_arg_msg (subr
, 1, x
, "struct");
568 vm_error_no_values (void)
570 vm_error ("Zero values returned to single-valued continuation",
575 vm_error_not_enough_values (void)
577 vm_error ("Too few values returned to continuation", SCM_UNDEFINED
);
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 boot_continuation
;
597 static SCM rtl_boot_continuation
;
598 static SCM rtl_apply
;
599 static SCM rtl_values
;
601 static const scm_t_uint32 rtl_boot_continuation_code
[] = {
602 SCM_PACK_RTL_24 (scm_rtl_op_halt_values
, 0),
603 SCM_PACK_RTL_24 (scm_rtl_op_halt
, 0)
606 static scm_t_uint32
* rtl_boot_multiple_value_continuation_code
=
607 (scm_t_uint32
*) rtl_boot_continuation_code
;
609 static scm_t_uint32
* rtl_boot_single_value_continuation_code
=
610 (scm_t_uint32
*) rtl_boot_continuation_code
+ 1;
612 static const scm_t_uint32 rtl_apply_code
[] = {
613 SCM_PACK_RTL_24 (scm_rtl_op_apply
, 0) /* proc in r1, args from r2, nargs set */
616 static const scm_t_uint32 rtl_values_code
[] = {
617 SCM_PACK_RTL_24 (scm_rtl_op_values
, 0) /* vals from r1 */
627 resolve_variable (SCM what
, SCM module
)
629 if (SCM_LIKELY (scm_is_symbol (what
)))
631 if (scm_is_true (module
))
632 return scm_module_lookup (module
, what
);
634 return scm_module_lookup (scm_the_root_module (), what
);
638 SCM modname
, sym
, public;
640 modname
= SCM_CAR (what
);
641 sym
= SCM_CADR (what
);
642 public = SCM_CADDR (what
);
644 if (scm_is_true (public))
645 return scm_public_lookup (modname
, sym
);
647 return scm_private_lookup (modname
, sym
);
651 #define VM_MIN_STACK_SIZE (1024)
652 #define VM_DEFAULT_STACK_SIZE (64 * 1024)
653 static size_t vm_stack_size
= VM_DEFAULT_STACK_SIZE
;
656 initialize_default_stack_size (void)
658 int size
= scm_getenv_int ("GUILE_STACK_SIZE", vm_stack_size
);
659 if (size
>= VM_MIN_STACK_SIZE
)
660 vm_stack_size
= size
;
663 #define VM_NAME vm_regular_engine
664 #define RTL_VM_NAME rtl_vm_regular_engine
665 #define FUNC_NAME "vm-regular-engine"
666 #define VM_ENGINE SCM_VM_REGULAR_ENGINE
667 #include "vm-engine.c"
673 #define VM_NAME vm_debug_engine
674 #define RTL_VM_NAME rtl_vm_debug_engine
675 #define FUNC_NAME "vm-debug-engine"
676 #define VM_ENGINE SCM_VM_DEBUG_ENGINE
677 #include "vm-engine.c"
683 static const scm_t_vm_engine vm_engines
[] =
684 { vm_regular_engine
, vm_debug_engine
};
686 #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
688 /* The GC "kind" for the VM stack. */
689 static int vm_stack_gc_kind
;
695 #define FUNC_NAME "make_vm"
700 vp
= scm_gc_malloc (sizeof (struct scm_vm
), "vm");
702 vp
->stack_size
= vm_stack_size
;
704 #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
705 vp
->stack_base
= (SCM
*)
706 GC_generic_malloc (vp
->stack_size
* sizeof (SCM
), vm_stack_gc_kind
);
708 /* Keep a pointer to VP so that `vm_stack_mark ()' can know what the stack
710 *vp
->stack_base
= SCM_PACK_POINTER (vp
);
714 vp
->stack_base
= scm_gc_malloc (vp
->stack_size
* sizeof (SCM
),
718 #ifdef VM_ENABLE_STACK_NULLING
719 memset (vp
->stack_base
, 0, vp
->stack_size
* sizeof (SCM
));
721 vp
->stack_limit
= vp
->stack_base
+ vp
->stack_size
- VM_STACK_RESERVE_SIZE
;
723 vp
->sp
= vp
->stack_base
- 1;
725 vp
->engine
= vm_default_engine
;
727 for (i
= 0; i
< SCM_VM_NUM_HOOKS
; i
++)
728 vp
->hooks
[i
] = SCM_BOOL_F
;
729 return scm_cell (scm_tc7_vm
, (scm_t_bits
)vp
);
733 #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
735 /* Mark the VM stack region between its base and its current top. */
736 static struct GC_ms_entry
*
737 vm_stack_mark (GC_word
*addr
, struct GC_ms_entry
*mark_stack_ptr
,
738 struct GC_ms_entry
*mark_stack_limit
, GC_word env
)
741 const struct scm_vm
*vm
;
743 /* The first word of the VM stack should contain a pointer to the
745 vm
= * ((struct scm_vm
**) addr
);
748 || (SCM
*) addr
!= vm
->stack_base
- 1)
749 /* ADDR must be a pointer to a free-list element, which we must ignore
750 (see warning in <gc/gc_mark.h>). */
751 return mark_stack_ptr
;
753 for (word
= (GC_word
*) vm
->stack_base
; word
<= (GC_word
*) vm
->sp
; word
++)
754 mark_stack_ptr
= GC_MARK_AND_PUSH ((* (GC_word
**) word
),
755 mark_stack_ptr
, mark_stack_limit
,
758 return mark_stack_ptr
;
761 #endif /* VM_ENABLE_PRECISE_STACK_GC_SCAN */
765 scm_c_vm_run (SCM vm
, SCM program
, SCM
*argv
, int nargs
)
767 struct scm_vm
*vp
= SCM_VM_DATA (vm
);
769 return vm_engines
[vp
->engine
](vm
, program
, argv
, nargs
);
772 /* Scheme interface */
774 SCM_DEFINE (scm_the_vm
, "the-vm", 0, 0, 0,
776 "Return the current thread's VM.")
777 #define FUNC_NAME s_scm_the_vm
779 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
781 if (SCM_UNLIKELY (scm_is_false (t
->vm
)))
789 SCM_DEFINE (scm_vm_p
, "vm?", 1, 0, 0,
792 #define FUNC_NAME s_scm_vm_p
794 return scm_from_bool (SCM_VM_P (obj
));
798 SCM_DEFINE (scm_make_vm
, "make-vm", 0, 0, 0,
801 #define FUNC_NAME s_scm_make_vm,
807 SCM_DEFINE (scm_vm_ip
, "vm:ip", 1, 0, 0,
810 #define FUNC_NAME s_scm_vm_ip
812 SCM_VALIDATE_VM (1, vm
);
813 return scm_from_unsigned_integer ((scm_t_bits
) SCM_VM_DATA (vm
)->ip
);
817 SCM_DEFINE (scm_vm_sp
, "vm:sp", 1, 0, 0,
820 #define FUNC_NAME s_scm_vm_sp
822 SCM_VALIDATE_VM (1, vm
);
823 return scm_from_unsigned_integer ((scm_t_bits
) SCM_VM_DATA (vm
)->sp
);
827 SCM_DEFINE (scm_vm_fp
, "vm:fp", 1, 0, 0,
830 #define FUNC_NAME s_scm_vm_fp
832 SCM_VALIDATE_VM (1, vm
);
833 return scm_from_unsigned_integer ((scm_t_bits
) SCM_VM_DATA (vm
)->fp
);
837 #define VM_DEFINE_HOOK(n) \
840 SCM_VALIDATE_VM (1, vm); \
841 vp = SCM_VM_DATA (vm); \
842 if (scm_is_false (vp->hooks[n])) \
843 vp->hooks[n] = scm_make_hook (SCM_I_MAKINUM (1)); \
844 return vp->hooks[n]; \
847 SCM_DEFINE (scm_vm_apply_hook
, "vm-apply-hook", 1, 0, 0,
850 #define FUNC_NAME s_scm_vm_apply_hook
852 VM_DEFINE_HOOK (SCM_VM_APPLY_HOOK
);
856 SCM_DEFINE (scm_vm_push_continuation_hook
, "vm-push-continuation-hook", 1, 0, 0,
859 #define FUNC_NAME s_scm_vm_push_continuation_hook
861 VM_DEFINE_HOOK (SCM_VM_PUSH_CONTINUATION_HOOK
);
865 SCM_DEFINE (scm_vm_pop_continuation_hook
, "vm-pop-continuation-hook", 1, 0, 0,
868 #define FUNC_NAME s_scm_vm_pop_continuation_hook
870 VM_DEFINE_HOOK (SCM_VM_POP_CONTINUATION_HOOK
);
874 SCM_DEFINE (scm_vm_next_hook
, "vm-next-hook", 1, 0, 0,
877 #define FUNC_NAME s_scm_vm_next_hook
879 VM_DEFINE_HOOK (SCM_VM_NEXT_HOOK
);
883 SCM_DEFINE (scm_vm_abort_continuation_hook
, "vm-abort-continuation-hook", 1, 0, 0,
886 #define FUNC_NAME s_scm_vm_abort_continuation_hook
888 VM_DEFINE_HOOK (SCM_VM_ABORT_CONTINUATION_HOOK
);
892 SCM_DEFINE (scm_vm_restore_continuation_hook
, "vm-restore-continuation-hook", 1, 0, 0,
895 #define FUNC_NAME s_scm_vm_restore_continuation_hook
897 VM_DEFINE_HOOK (SCM_VM_RESTORE_CONTINUATION_HOOK
);
901 SCM_DEFINE (scm_vm_trace_level
, "vm-trace-level", 1, 0, 0,
904 #define FUNC_NAME s_scm_vm_trace_level
906 SCM_VALIDATE_VM (1, vm
);
907 return scm_from_int (SCM_VM_DATA (vm
)->trace_level
);
911 SCM_DEFINE (scm_set_vm_trace_level_x
, "set-vm-trace-level!", 2, 0, 0,
914 #define FUNC_NAME s_scm_set_vm_trace_level_x
916 SCM_VALIDATE_VM (1, vm
);
917 SCM_VM_DATA (vm
)->trace_level
= scm_to_int (level
);
918 return SCM_UNSPECIFIED
;
928 symbol_to_vm_engine (SCM engine
, const char *FUNC_NAME
)
930 if (scm_is_eq (engine
, sym_regular
))
931 return SCM_VM_REGULAR_ENGINE
;
932 else if (scm_is_eq (engine
, sym_debug
))
933 return SCM_VM_DEBUG_ENGINE
;
935 SCM_MISC_ERROR ("Unknown VM engine: ~a", scm_list_1 (engine
));
939 vm_engine_to_symbol (int engine
, const char *FUNC_NAME
)
943 case SCM_VM_REGULAR_ENGINE
:
945 case SCM_VM_DEBUG_ENGINE
:
949 SCM_MISC_ERROR ("Unknown VM engine: ~a",
950 scm_list_1 (scm_from_int (engine
)));
954 SCM_DEFINE (scm_vm_engine
, "vm-engine", 1, 0, 0,
957 #define FUNC_NAME s_scm_vm_engine
959 SCM_VALIDATE_VM (1, vm
);
960 return vm_engine_to_symbol (SCM_VM_DATA (vm
)->engine
, FUNC_NAME
);
965 scm_c_set_vm_engine_x (SCM vm
, int engine
)
966 #define FUNC_NAME "set-vm-engine!"
968 SCM_VALIDATE_VM (1, vm
);
970 if (engine
< 0 || engine
>= SCM_VM_NUM_ENGINES
)
971 SCM_MISC_ERROR ("Unknown VM engine: ~a",
972 scm_list_1 (scm_from_int (engine
)));
974 SCM_VM_DATA (vm
)->engine
= engine
;
978 SCM_DEFINE (scm_set_vm_engine_x
, "set-vm-engine!", 2, 0, 0,
979 (SCM vm
, SCM engine
),
981 #define FUNC_NAME s_scm_set_vm_engine_x
983 scm_c_set_vm_engine_x (vm
, symbol_to_vm_engine (engine
, FUNC_NAME
));
984 return SCM_UNSPECIFIED
;
989 scm_c_set_default_vm_engine_x (int engine
)
990 #define FUNC_NAME "set-default-vm-engine!"
992 if (engine
< 0 || engine
>= SCM_VM_NUM_ENGINES
)
993 SCM_MISC_ERROR ("Unknown VM engine: ~a",
994 scm_list_1 (scm_from_int (engine
)));
996 vm_default_engine
= engine
;
1000 SCM_DEFINE (scm_set_default_vm_engine_x
, "set-default-vm-engine!", 1, 0, 0,
1003 #define FUNC_NAME s_scm_set_default_vm_engine_x
1005 scm_c_set_default_vm_engine_x (symbol_to_vm_engine (engine
, FUNC_NAME
));
1006 return SCM_UNSPECIFIED
;
1010 static void reinstate_vm (SCM vm
)
1012 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
1016 SCM_DEFINE (scm_call_with_vm
, "call-with-vm", 2, 0, 1,
1017 (SCM vm
, SCM proc
, SCM args
),
1018 "Apply @var{proc} to @var{args} in a dynamic extent in which\n"
1019 "@var{vm} is the current VM.\n\n"
1020 "As an implementation restriction, if @var{vm} is not the same\n"
1021 "as the current thread's VM, continuations captured within the\n"
1022 "call to @var{proc} may not be reinstated once control leaves\n"
1024 #define FUNC_NAME s_scm_call_with_vm
1029 scm_t_wind_flags flags
;
1030 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
1032 SCM_VALIDATE_VM (1, vm
);
1033 SCM_VALIDATE_PROC (2, proc
);
1035 nargs
= scm_ilength (args
);
1036 if (SCM_UNLIKELY (nargs
< 0))
1037 scm_wrong_type_arg_msg (FUNC_NAME
, 3, args
, "list");
1039 argv
= alloca (nargs
* sizeof(SCM
));
1040 for (i
= 0; i
< nargs
; i
++)
1042 argv
[i
] = SCM_CAR (args
);
1043 args
= SCM_CDR (args
);
1048 /* Reentry can happen via invokation of a saved continuation, but
1049 continuations only save the state of the VM that they are in at
1050 capture-time, which might be different from this one. So, in the
1051 case that the VMs are different, set up a non-rewindable frame to
1052 prevent reinstating an incomplete continuation. */
1053 flags
= scm_is_eq (prev_vm
, vm
) ? 0 : SCM_F_WIND_EXPLICITLY
;
1056 scm_dynwind_begin (0);
1057 scm_dynwind_unwind_handler_with_scm (reinstate_vm
, prev_vm
, flags
);
1061 ret
= scm_c_vm_run (vm
, proc
, argv
, nargs
);
1075 SCM
scm_load_compiled_with_vm (SCM file
)
1077 SCM program
= scm_load_thunk_from_file (file
);
1079 return scm_c_vm_run (scm_the_vm (), program
, NULL
, 0);
1084 make_boot_program (void)
1086 struct scm_objcode
*bp
;
1090 const scm_t_uint8 text
[] = {
1095 bp_size
= sizeof (struct scm_objcode
) + sizeof (text
);
1096 bp
= scm_gc_malloc_pointerless (bp_size
, "boot-program");
1097 memcpy (SCM_C_OBJCODE_BASE (bp
), text
, sizeof (text
));
1098 bp
->len
= sizeof(text
);
1101 u8vec
= scm_c_take_gc_bytevector ((scm_t_int8
*)bp
, bp_size
, SCM_BOOL_F
);
1102 ret
= scm_make_program (scm_bytecode_to_objcode (u8vec
, SCM_UNDEFINED
),
1103 SCM_BOOL_F
, SCM_BOOL_F
);
1104 SCM_SET_CELL_WORD_0 (ret
, (SCM_CELL_WORD_0 (ret
) | SCM_F_PROGRAM_IS_BOOT
));
1110 scm_bootstrap_vm (void)
1112 scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION
,
1114 (scm_t_extension_init_func
)scm_init_vm
, NULL
);
1116 initialize_default_stack_size ();
1118 sym_vm_run
= scm_from_latin1_symbol ("vm-run");
1119 sym_vm_error
= scm_from_latin1_symbol ("vm-error");
1120 sym_keyword_argument_error
= scm_from_latin1_symbol ("keyword-argument-error");
1121 sym_regular
= scm_from_latin1_symbol ("regular");
1122 sym_debug
= scm_from_latin1_symbol ("debug");
1124 boot_continuation
= make_boot_program ();
1126 #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
1128 GC_new_kind (GC_new_free_list (),
1129 GC_MAKE_PROC (GC_new_proc (vm_stack_mark
), 0),
1138 #ifndef SCM_MAGIC_SNARFER
1139 #include "libguile/vm.x"
1142 rtl_boot_continuation
= scm_i_make_rtl_program (rtl_boot_continuation_code
);
1143 rtl_apply
= scm_i_make_rtl_program (rtl_apply_code
);
1144 rtl_values
= scm_i_make_rtl_program (rtl_values_code
);