1 /* Copyright (C) 2001, 2009, 2010, 2011, 2012 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 static int vm_default_engine
= SCM_VM_REGULAR_ENGINE
;
42 /* Unfortunately we can't snarf these: snarfed things are only loaded up from
43 (system vm vm), which might not be loaded before an error happens. */
44 static SCM sym_vm_run
;
45 static SCM sym_vm_error
;
46 static SCM sym_keyword_argument_error
;
47 static SCM sym_regular
;
50 /* The VM has a number of internal assertions that shouldn't normally be
51 necessary, but might be if you think you found a bug in the VM. */
52 #define VM_ENABLE_ASSERTIONS
54 /* We can add a mode that ensures that all stack items above the stack pointer
55 are NULL. This is useful for checking the internal consistency of the VM's
56 assumptions and its operators, but isn't necessary for normal operation. It
57 will ensure that assertions are enabled. Slows down the VM by about 30%. */
58 /* NB! If you enable this, search for NULLING in throw.c */
59 /* #define VM_ENABLE_STACK_NULLING */
61 /* #define VM_ENABLE_PARANOID_ASSERTIONS */
63 #if defined (VM_ENABLE_STACK_NULLING) && !defined (VM_ENABLE_ASSERTIONS)
64 #define VM_ENABLE_ASSERTIONS
67 /* When defined, arrange so that the GC doesn't scan the VM stack beyond its
68 current SP. This should help avoid excess data retention. See
69 http://thread.gmane.org/gmane.comp.programming.garbage-collection.boehmgc/3001
71 #define VM_ENABLE_PRECISE_STACK_GC_SCAN
73 /* Size in SCM objects of the stack reserve. The reserve is used to run
74 exception handling code in case of a VM stack overflow. */
75 #define VM_STACK_RESERVE_SIZE 512
84 scm_i_vm_cont_print (SCM x
, SCM port
, scm_print_state
*pstate
)
86 scm_puts ("#<vm-continuation ", port
);
87 scm_uintprint (SCM_UNPACK (x
), 16, port
);
91 /* In theory, a number of vm instances can be active in the call trace, and we
92 only want to reify the continuations of those in the current continuation
93 root. I don't see a nice way to do this -- ideally it would involve dynwinds,
94 and previous values of the *the-vm* fluid within the current continuation
95 root. But we don't have access to continuation roots in the dynwind stack.
96 So, just punt for now, we just capture the continuation for the current VM.
98 While I'm on the topic, ideally we could avoid copying the C stack if the
99 continuation root is inside VM code, and call/cc was invoked within that same
100 call to vm_run; but that's currently not implemented.
103 scm_i_vm_capture_stack (SCM
*stack_base
, SCM
*fp
, SCM
*sp
, scm_t_uint8
*ra
,
104 scm_t_uint8
*mvra
, scm_t_uint32 flags
)
106 struct scm_vm_cont
*p
;
108 p
= scm_gc_malloc (sizeof (*p
), "capture_vm_cont");
109 p
->stack_size
= sp
- stack_base
+ 1;
110 p
->stack_base
= scm_gc_malloc (p
->stack_size
* sizeof (SCM
),
112 #if defined(VM_ENABLE_STACK_NULLING) && 0
113 /* Tail continuations leave their frame on the stack for subsequent
114 application, but don't capture the frame -- so there are some elements on
115 the stack then, and this check doesn't work, so disable it for now. */
116 if (sp
>= vp
->stack_base
)
117 if (!vp
->sp
[0] || vp
->sp
[1])
119 memset (p
->stack_base
, 0, p
->stack_size
* sizeof (SCM
));
125 memcpy (p
->stack_base
, stack_base
, (sp
+ 1 - stack_base
) * sizeof (SCM
));
126 p
->reloc
= p
->stack_base
- stack_base
;
128 return scm_cell (scm_tc7_vm_cont
, (scm_t_bits
)p
);
132 vm_return_to_continuation (SCM vm
, SCM cont
, size_t n
, SCM
*argv
)
135 struct scm_vm_cont
*cp
;
138 argv_copy
= alloca (n
* sizeof(SCM
));
139 memcpy (argv_copy
, argv
, n
* sizeof(SCM
));
141 vp
= SCM_VM_DATA (vm
);
142 cp
= SCM_VM_CONT_DATA (cont
);
144 if (n
== 0 && !cp
->mvra
)
145 scm_misc_error (NULL
, "Too few values returned to continuation",
148 if (vp
->stack_size
< cp
->stack_size
+ n
+ 1)
149 scm_misc_error ("vm-engine", "not enough space to reinstate continuation",
150 scm_list_2 (vm
, cont
));
152 #ifdef VM_ENABLE_STACK_NULLING
154 scm_t_ptrdiff nzero
= (vp
->sp
- cp
->sp
);
156 memset (vp
->stack_base
+ cp
->stack_size
, 0, nzero
* sizeof (SCM
));
157 /* actually nzero should always be negative, because vm_reset_stack will
158 unwind the stack to some point *below* this continuation */
163 memcpy (vp
->stack_base
, cp
->stack_base
, cp
->stack_size
* sizeof (SCM
));
165 if (n
== 1 || !cp
->mvra
)
169 *vp
->sp
= argv_copy
[0];
174 for (i
= 0; i
< n
; i
++)
177 *vp
->sp
= argv_copy
[i
];
180 *vp
->sp
= scm_from_size_t (n
);
186 scm_i_vm_capture_continuation (SCM vm
)
188 struct scm_vm
*vp
= SCM_VM_DATA (vm
);
189 return scm_i_vm_capture_stack (vp
->stack_base
, vp
->fp
, vp
->sp
, vp
->ip
, NULL
, 0);
193 vm_dispatch_hook (SCM vm
, int hook_num
)
197 struct scm_frame c_frame
;
200 int saved_trace_level
;
202 vp
= SCM_VM_DATA (vm
);
203 hook
= vp
->hooks
[hook_num
];
205 if (SCM_LIKELY (scm_is_false (hook
))
206 || scm_is_null (SCM_HOOK_PROCEDURES (hook
)))
209 saved_trace_level
= vp
->trace_level
;
212 /* Allocate a frame object on the stack. This is more efficient than calling
213 `scm_c_make_frame ()' to allocate on the heap, but it forces hooks to not
214 capture frame objects.
216 At the same time, procedures such as `frame-procedure' make sense only
217 while the stack frame represented by the frame object is visible, so it
218 seems reasonable to limit the lifetime of frame objects. */
220 c_frame
.stack_holder
= vm
;
226 /* Arrange for FRAME to be 8-byte aligned, like any other cell. */
227 frame
= alloca (sizeof (*frame
) + 8);
228 frame
= (scm_t_cell
*) ROUND_UP ((scm_t_uintptr
) frame
, 8UL);
230 frame
->word_0
= SCM_PACK (scm_tc7_frame
);
231 frame
->word_1
= PTR2SCM (&c_frame
);
232 args
[0] = PTR2SCM (frame
);
234 scm_c_run_hookn (hook
, args
, 1);
236 vp
->trace_level
= saved_trace_level
;
239 static void vm_abort (SCM vm
, size_t n
, scm_t_int64 cookie
) SCM_NORETURN
;
241 vm_abort (SCM vm
, size_t n
, scm_t_int64 vm_cookie
)
245 SCM tag
, tail
, *argv
;
247 /* FIXME: VM_ENABLE_STACK_NULLING */
248 tail
= *(SCM_VM_DATA (vm
)->sp
--);
250 tail_len
= scm_ilength (tail
);
252 scm_misc_error ("vm-engine", "tail values to abort should be a list",
255 tag
= SCM_VM_DATA (vm
)->sp
[-n
];
256 argv
= alloca ((n
+ tail_len
) * sizeof (SCM
));
257 for (i
= 0; i
< n
; i
++)
258 argv
[i
] = SCM_VM_DATA (vm
)->sp
[-(n
-1-i
)];
259 for (; i
< n
+ tail_len
; i
++, tail
= scm_cdr (tail
))
260 argv
[i
] = scm_car (tail
);
261 /* NULLSTACK (n + 1) */
262 SCM_VM_DATA (vm
)->sp
-= n
+ 1;
264 scm_c_abort (vm
, tag
, n
+ tail_len
, argv
, vm_cookie
);
268 vm_reinstate_partial_continuation (SCM vm
, SCM cont
, SCM intwinds
,
269 size_t n
, SCM
*argv
, scm_t_int64 vm_cookie
)
272 struct scm_vm_cont
*cp
;
273 SCM
*argv_copy
, *base
;
276 argv_copy
= alloca (n
* sizeof(SCM
));
277 memcpy (argv_copy
, argv
, n
* sizeof(SCM
));
279 vp
= SCM_VM_DATA (vm
);
280 cp
= SCM_VM_CONT_DATA (cont
);
281 base
= SCM_FRAME_UPPER_ADDRESS (vp
->fp
) + 1;
283 #define RELOC(scm_p) \
284 (((SCM *) (scm_p)) + cp->reloc + (base - cp->stack_base))
286 if ((base
- vp
->stack_base
) + cp
->stack_size
+ n
+ 1 > vp
->stack_size
)
287 scm_misc_error ("vm-engine",
288 "not enough space to instate partial continuation",
289 scm_list_2 (vm
, cont
));
291 memcpy (base
, cp
->stack_base
, cp
->stack_size
* sizeof (SCM
));
293 /* now relocate frame pointers */
296 for (fp
= RELOC (cp
->fp
);
297 SCM_FRAME_LOWER_ADDRESS (fp
) > base
;
298 fp
= SCM_FRAME_DYNAMIC_LINK (fp
))
299 SCM_FRAME_SET_DYNAMIC_LINK (fp
, RELOC (SCM_FRAME_DYNAMIC_LINK (fp
)));
302 vp
->sp
= base
- 1 + cp
->stack_size
;
303 vp
->fp
= RELOC (cp
->fp
);
306 /* now push args. ip is in a MV context. */
307 for (i
= 0; i
< n
; i
++)
310 *vp
->sp
= argv_copy
[i
];
313 *vp
->sp
= scm_from_size_t (n
);
315 /* Finally, rewind the dynamic state.
317 We have to treat prompts specially, because we could be rewinding the
318 dynamic state from a different thread, or just a different position on the
319 C and/or VM stack -- so we need to reset the jump buffers so that an abort
320 comes back here, with appropriately adjusted sp and fp registers. */
323 SCM newwinds
= scm_i_dynwinds ();
324 for (; scm_is_pair (intwinds
); intwinds
= scm_cdr (intwinds
), delta
--)
326 SCM x
= scm_car (intwinds
);
327 if (SCM_PROMPT_P (x
))
328 /* the jmpbuf will be reset by our caller */
329 x
= scm_c_make_prompt (SCM_PROMPT_TAG (x
),
330 RELOC (SCM_PROMPT_REGISTERS (x
)->fp
),
331 RELOC (SCM_PROMPT_REGISTERS (x
)->sp
),
332 SCM_PROMPT_REGISTERS (x
)->ip
,
333 SCM_PROMPT_ESCAPE_P (x
),
336 newwinds
= scm_cons (x
, newwinds
);
338 scm_dowinds (newwinds
, delta
);
345 * VM Internal functions
349 scm_i_vm_print (SCM x
, SCM port
, scm_print_state
*pstate
)
351 const struct scm_vm
*vm
;
353 vm
= SCM_VM_DATA (x
);
355 scm_puts ("#<vm ", port
);
358 case SCM_VM_REGULAR_ENGINE
:
359 scm_puts ("regular-engine ", port
);
362 case SCM_VM_DEBUG_ENGINE
:
363 scm_puts ("debug-engine ", port
);
367 scm_puts ("unknown-engine ", port
);
369 scm_uintprint (SCM_UNPACK (x
), 16, port
);
370 scm_puts (">", port
);
374 really_make_boot_program (long nargs
)
377 scm_t_uint8 text
[] = { scm_op_mv_call
, 0, 0, 0, 1,
378 scm_op_make_int8_1
, scm_op_halt
};
379 struct scm_objcode
*bp
;
382 if (SCM_UNLIKELY (nargs
> 255 || nargs
< 0))
383 scm_misc_error ("vm-engine", "too many args when making boot procedure",
384 scm_list_1 (scm_from_long (nargs
)));
386 text
[1] = (scm_t_uint8
)nargs
;
388 bp
= scm_gc_malloc_pointerless (sizeof (struct scm_objcode
) + sizeof (text
),
390 memcpy (SCM_C_OBJCODE_BASE (bp
), text
, sizeof (text
));
391 bp
->len
= sizeof(text
);
394 u8vec
= scm_c_take_gc_bytevector ((scm_t_int8
*)bp
,
395 sizeof (struct scm_objcode
) + sizeof (text
));
396 ret
= scm_make_program (scm_bytecode_to_native_objcode (u8vec
),
397 SCM_BOOL_F
, SCM_BOOL_F
);
398 SCM_SET_CELL_WORD_0 (ret
, SCM_CELL_WORD_0 (ret
) | SCM_F_PROGRAM_IS_BOOT
);
402 #define NUM_BOOT_PROGS 8
404 vm_make_boot_program (long nargs
)
406 static SCM programs
[NUM_BOOT_PROGS
] = { SCM_BOOL_F
, };
408 if (SCM_UNLIKELY (scm_is_false (programs
[0])))
411 for (i
= 0; i
< NUM_BOOT_PROGS
; i
++)
412 programs
[i
] = really_make_boot_program (i
);
415 if (SCM_LIKELY (nargs
< NUM_BOOT_PROGS
))
416 return programs
[nargs
];
418 return really_make_boot_program (nargs
);
427 resolve_variable (SCM what
, SCM program_module
)
429 if (SCM_LIKELY (scm_is_symbol (what
)))
431 if (SCM_LIKELY (scm_module_system_booted_p
432 && scm_is_true (program_module
)))
434 return scm_module_lookup (program_module
, what
);
437 SCM v
= scm_sym2var (what
, SCM_BOOL_F
, SCM_BOOL_F
);
438 if (scm_is_false (v
))
439 scm_misc_error (NULL
, "unbound variable: ~S", scm_list_1 (what
));
447 /* compilation of @ or @@
448 `what' is a three-element list: (MODNAME SYM INTERFACE?)
449 INTERFACE? is #t if we compiled @ or #f if we compiled @@
451 mod
= scm_resolve_module (SCM_CAR (what
));
452 if (scm_is_true (SCM_CADDR (what
)))
453 mod
= scm_module_public_interface (mod
);
454 if (scm_is_false (mod
))
455 scm_misc_error (NULL
, "no such module: ~S",
456 scm_list_1 (SCM_CAR (what
)));
458 return scm_module_lookup (mod
, SCM_CADR (what
));
462 #define VM_DEFAULT_STACK_SIZE (64 * 1024)
464 #define VM_NAME vm_regular_engine
465 #define FUNC_NAME "vm-regular-engine"
466 #define VM_ENGINE SCM_VM_REGULAR_ENGINE
467 #include "vm-engine.c"
472 #define VM_NAME vm_debug_engine
473 #define FUNC_NAME "vm-debug-engine"
474 #define VM_ENGINE SCM_VM_DEBUG_ENGINE
475 #include "vm-engine.c"
480 static const scm_t_vm_engine vm_engines
[] =
481 { vm_regular_engine
, vm_debug_engine
};
483 #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
485 /* The GC "kind" for the VM stack. */
486 static int vm_stack_gc_kind
;
492 #define FUNC_NAME "make_vm"
497 vp
= scm_gc_malloc (sizeof (struct scm_vm
), "vm");
499 vp
->stack_size
= VM_DEFAULT_STACK_SIZE
;
501 #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
502 vp
->stack_base
= (SCM
*)
503 GC_generic_malloc (vp
->stack_size
* sizeof (SCM
), vm_stack_gc_kind
);
505 /* Keep a pointer to VP so that `vm_stack_mark ()' can know what the stack
507 *vp
->stack_base
= PTR2SCM (vp
);
511 vp
->stack_base
= scm_gc_malloc (vp
->stack_size
* sizeof (SCM
),
515 #ifdef VM_ENABLE_STACK_NULLING
516 memset (vp
->stack_base
, 0, vp
->stack_size
* sizeof (SCM
));
518 vp
->stack_limit
= vp
->stack_base
+ vp
->stack_size
- VM_STACK_RESERVE_SIZE
;
520 vp
->sp
= vp
->stack_base
- 1;
522 vp
->engine
= vm_default_engine
;
524 for (i
= 0; i
< SCM_VM_NUM_HOOKS
; i
++)
525 vp
->hooks
[i
] = SCM_BOOL_F
;
527 return scm_cell (scm_tc7_vm
, (scm_t_bits
)vp
);
531 #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
533 /* Mark the VM stack region between its base and its current top. */
534 static struct GC_ms_entry
*
535 vm_stack_mark (GC_word
*addr
, struct GC_ms_entry
*mark_stack_ptr
,
536 struct GC_ms_entry
*mark_stack_limit
, GC_word env
)
539 const struct scm_vm
*vm
;
541 /* The first word of the VM stack should contain a pointer to the
543 vm
= * ((struct scm_vm
**) addr
);
546 || (SCM
*) addr
!= vm
->stack_base
- 1)
547 /* ADDR must be a pointer to a free-list element, which we must ignore
548 (see warning in <gc/gc_mark.h>). */
549 return mark_stack_ptr
;
551 for (word
= (GC_word
*) vm
->stack_base
; word
<= (GC_word
*) vm
->sp
; word
++)
552 mark_stack_ptr
= GC_MARK_AND_PUSH ((* (GC_word
**) word
),
553 mark_stack_ptr
, mark_stack_limit
,
556 return mark_stack_ptr
;
559 #endif /* VM_ENABLE_PRECISE_STACK_GC_SCAN */
563 scm_c_vm_run (SCM vm
, SCM program
, SCM
*argv
, int nargs
)
565 struct scm_vm
*vp
= SCM_VM_DATA (vm
);
567 return vm_engines
[vp
->engine
](vm
, program
, argv
, nargs
);
570 /* Scheme interface */
572 SCM_DEFINE (scm_the_vm
, "the-vm", 0, 0, 0,
574 "Return the current thread's VM.")
575 #define FUNC_NAME s_scm_the_vm
577 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
579 if (SCM_UNLIKELY (scm_is_false (t
->vm
)))
587 SCM_DEFINE (scm_vm_p
, "vm?", 1, 0, 0,
590 #define FUNC_NAME s_scm_vm_p
592 return scm_from_bool (SCM_VM_P (obj
));
596 SCM_DEFINE (scm_make_vm
, "make-vm", 0, 0, 0,
599 #define FUNC_NAME s_scm_make_vm,
605 SCM_DEFINE (scm_vm_ip
, "vm:ip", 1, 0, 0,
608 #define FUNC_NAME s_scm_vm_ip
610 SCM_VALIDATE_VM (1, vm
);
611 return scm_from_unsigned_integer ((scm_t_bits
) SCM_VM_DATA (vm
)->ip
);
615 SCM_DEFINE (scm_vm_sp
, "vm:sp", 1, 0, 0,
618 #define FUNC_NAME s_scm_vm_sp
620 SCM_VALIDATE_VM (1, vm
);
621 return scm_from_unsigned_integer ((scm_t_bits
) SCM_VM_DATA (vm
)->sp
);
625 SCM_DEFINE (scm_vm_fp
, "vm:fp", 1, 0, 0,
628 #define FUNC_NAME s_scm_vm_fp
630 SCM_VALIDATE_VM (1, vm
);
631 return scm_from_unsigned_integer ((scm_t_bits
) SCM_VM_DATA (vm
)->fp
);
635 #define VM_DEFINE_HOOK(n) \
638 SCM_VALIDATE_VM (1, vm); \
639 vp = SCM_VM_DATA (vm); \
640 if (scm_is_false (vp->hooks[n])) \
641 vp->hooks[n] = scm_make_hook (SCM_I_MAKINUM (1)); \
642 return vp->hooks[n]; \
645 SCM_DEFINE (scm_vm_apply_hook
, "vm-apply-hook", 1, 0, 0,
648 #define FUNC_NAME s_scm_vm_apply_hook
650 VM_DEFINE_HOOK (SCM_VM_APPLY_HOOK
);
654 SCM_DEFINE (scm_vm_push_continuation_hook
, "vm-push-continuation-hook", 1, 0, 0,
657 #define FUNC_NAME s_scm_vm_push_continuation_hook
659 VM_DEFINE_HOOK (SCM_VM_PUSH_CONTINUATION_HOOK
);
663 SCM_DEFINE (scm_vm_pop_continuation_hook
, "vm-pop-continuation-hook", 1, 0, 0,
666 #define FUNC_NAME s_scm_vm_pop_continuation_hook
668 VM_DEFINE_HOOK (SCM_VM_POP_CONTINUATION_HOOK
);
672 SCM_DEFINE (scm_vm_next_hook
, "vm-next-hook", 1, 0, 0,
675 #define FUNC_NAME s_scm_vm_next_hook
677 VM_DEFINE_HOOK (SCM_VM_NEXT_HOOK
);
681 SCM_DEFINE (scm_vm_abort_continuation_hook
, "vm-abort-continuation-hook", 1, 0, 0,
684 #define FUNC_NAME s_scm_vm_abort_continuation_hook
686 VM_DEFINE_HOOK (SCM_VM_ABORT_CONTINUATION_HOOK
);
690 SCM_DEFINE (scm_vm_restore_continuation_hook
, "vm-restore-continuation-hook", 1, 0, 0,
693 #define FUNC_NAME s_scm_vm_restore_continuation_hook
695 VM_DEFINE_HOOK (SCM_VM_RESTORE_CONTINUATION_HOOK
);
699 SCM_DEFINE (scm_vm_trace_level
, "vm-trace-level", 1, 0, 0,
702 #define FUNC_NAME s_scm_vm_trace_level
704 SCM_VALIDATE_VM (1, vm
);
705 return scm_from_int (SCM_VM_DATA (vm
)->trace_level
);
709 SCM_DEFINE (scm_set_vm_trace_level_x
, "set-vm-trace-level!", 2, 0, 0,
712 #define FUNC_NAME s_scm_set_vm_trace_level_x
714 SCM_VALIDATE_VM (1, vm
);
715 SCM_VM_DATA (vm
)->trace_level
= scm_to_int (level
);
716 return SCM_UNSPECIFIED
;
726 symbol_to_vm_engine (SCM engine
, const char *FUNC_NAME
)
728 if (scm_is_eq (engine
, sym_regular
))
729 return SCM_VM_REGULAR_ENGINE
;
730 else if (scm_is_eq (engine
, sym_debug
))
731 return SCM_VM_DEBUG_ENGINE
;
733 SCM_MISC_ERROR ("Unknown VM engine: ~a", scm_list_1 (engine
));
737 vm_engine_to_symbol (int engine
, const char *FUNC_NAME
)
741 case SCM_VM_REGULAR_ENGINE
:
743 case SCM_VM_DEBUG_ENGINE
:
747 SCM_MISC_ERROR ("Unknown VM engine: ~a",
748 scm_list_1 (scm_from_int (engine
)));
752 SCM_DEFINE (scm_vm_engine
, "vm-engine", 1, 0, 0,
755 #define FUNC_NAME s_scm_vm_engine
757 SCM_VALIDATE_VM (1, vm
);
758 return vm_engine_to_symbol (SCM_VM_DATA (vm
)->engine
, FUNC_NAME
);
763 scm_c_set_vm_engine_x (SCM vm
, int engine
)
764 #define FUNC_NAME "set-vm-engine!"
766 SCM_VALIDATE_VM (1, vm
);
768 if (engine
< 0 || engine
>= SCM_VM_NUM_ENGINES
)
769 SCM_MISC_ERROR ("Unknown VM engine: ~a",
770 scm_list_1 (scm_from_int (engine
)));
772 SCM_VM_DATA (vm
)->engine
= engine
;
776 SCM_DEFINE (scm_set_vm_engine_x
, "set-vm-engine!", 2, 0, 0,
777 (SCM vm
, SCM engine
),
779 #define FUNC_NAME s_scm_set_vm_engine_x
781 scm_c_set_vm_engine_x (vm
, symbol_to_vm_engine (engine
, FUNC_NAME
));
782 return SCM_UNSPECIFIED
;
787 scm_c_set_default_vm_engine_x (int engine
)
788 #define FUNC_NAME "set-default-vm-engine!"
790 if (engine
< 0 || engine
>= SCM_VM_NUM_ENGINES
)
791 SCM_MISC_ERROR ("Unknown VM engine: ~a",
792 scm_list_1 (scm_from_int (engine
)));
794 vm_default_engine
= engine
;
798 SCM_DEFINE (scm_set_default_vm_engine_x
, "set-default-vm-engine!", 1, 0, 0,
801 #define FUNC_NAME s_scm_set_default_vm_engine_x
803 scm_c_set_default_vm_engine_x (symbol_to_vm_engine (engine
, FUNC_NAME
));
804 return SCM_UNSPECIFIED
;
808 static void reinstate_vm (SCM vm
)
810 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
814 SCM_DEFINE (scm_call_with_vm
, "call-with-vm", 2, 0, 1,
815 (SCM vm
, SCM proc
, SCM args
),
816 "Apply @var{proc} to @var{args} in a dynamic extent in which\n"
817 "@var{vm} is the current VM.\n\n"
818 "As an implementation restriction, if @var{vm} is not the same\n"
819 "as the current thread's VM, continuations captured within the\n"
820 "call to @var{proc} may not be reinstated once control leaves\n"
822 #define FUNC_NAME s_scm_call_with_vm
827 scm_t_wind_flags flags
;
828 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
830 SCM_VALIDATE_VM (1, vm
);
831 SCM_VALIDATE_PROC (2, proc
);
833 nargs
= scm_ilength (args
);
834 if (SCM_UNLIKELY (nargs
< 0))
835 scm_wrong_type_arg_msg (FUNC_NAME
, 3, args
, "list");
837 argv
= alloca (nargs
* sizeof(SCM
));
838 for (i
= 0; i
< nargs
; i
++)
840 argv
[i
] = SCM_CAR (args
);
841 args
= SCM_CDR (args
);
846 /* Reentry can happen via invokation of a saved continuation, but
847 continuations only save the state of the VM that they are in at
848 capture-time, which might be different from this one. So, in the
849 case that the VMs are different, set up a non-rewindable frame to
850 prevent reinstating an incomplete continuation. */
851 flags
= scm_is_eq (prev_vm
, vm
) ? 0 : SCM_F_WIND_EXPLICITLY
;
854 scm_dynwind_begin (0);
855 scm_dynwind_unwind_handler_with_scm (reinstate_vm
, prev_vm
, flags
);
859 ret
= scm_c_vm_run (vm
, proc
, argv
, nargs
);
873 SCM
scm_load_compiled_with_vm (SCM file
)
875 SCM program
= scm_make_program (scm_load_objcode (file
),
876 SCM_BOOL_F
, SCM_BOOL_F
);
878 return scm_c_vm_run (scm_the_vm (), program
, NULL
, 0);
882 scm_bootstrap_vm (void)
884 scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION
,
886 (scm_t_extension_init_func
)scm_init_vm
, NULL
);
888 sym_vm_run
= scm_from_latin1_symbol ("vm-run");
889 sym_vm_error
= scm_from_latin1_symbol ("vm-error");
890 sym_keyword_argument_error
= scm_from_latin1_symbol ("keyword-argument-error");
891 sym_regular
= scm_from_latin1_symbol ("regular");
892 sym_debug
= scm_from_latin1_symbol ("debug");
894 #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
896 GC_new_kind (GC_new_free_list (),
897 GC_MAKE_PROC (GC_new_proc (vm_stack_mark
), 0),
906 #ifndef SCM_MAGIC_SNARFER
907 #include "libguile/vm.x"