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_unlocked ("#<vm-continuation ", port
);
87 scm_uintprint (SCM_UNPACK (x
), 16, port
);
88 scm_puts_unlocked (">", 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
= SCM_PACK_POINTER (&c_frame
);
232 args
[0] = SCM_PACK_POINTER (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_unlocked ("#<vm ", port
);
358 case SCM_VM_REGULAR_ENGINE
:
359 scm_puts_unlocked ("regular-engine ", port
);
362 case SCM_VM_DEBUG_ENGINE
:
363 scm_puts_unlocked ("debug-engine ", port
);
367 scm_puts_unlocked ("unknown-engine ", port
);
369 scm_uintprint (SCM_UNPACK (x
), 16, port
);
370 scm_puts_unlocked (">", 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
),
397 ret
= scm_make_program (scm_bytecode_to_native_objcode (u8vec
),
398 SCM_BOOL_F
, SCM_BOOL_F
);
399 SCM_SET_CELL_WORD_0 (ret
, SCM_CELL_WORD_0 (ret
) | SCM_F_PROGRAM_IS_BOOT
);
403 #define NUM_BOOT_PROGS 8
405 vm_make_boot_program (long nargs
)
407 static SCM programs
[NUM_BOOT_PROGS
] = { SCM_BOOL_F
, };
409 if (SCM_UNLIKELY (scm_is_false (programs
[0])))
412 for (i
= 0; i
< NUM_BOOT_PROGS
; i
++)
413 programs
[i
] = really_make_boot_program (i
);
416 if (SCM_LIKELY (nargs
< NUM_BOOT_PROGS
))
417 return programs
[nargs
];
419 return really_make_boot_program (nargs
);
428 resolve_variable (SCM what
, SCM program_module
)
430 if (SCM_LIKELY (scm_is_symbol (what
)))
432 if (SCM_LIKELY (scm_module_system_booted_p
433 && scm_is_true (program_module
)))
435 return scm_module_lookup (program_module
, what
);
438 SCM v
= scm_sym2var (what
, SCM_BOOL_F
, SCM_BOOL_F
);
439 if (scm_is_false (v
))
440 scm_misc_error (NULL
, "unbound variable: ~S", scm_list_1 (what
));
448 /* compilation of @ or @@
449 `what' is a three-element list: (MODNAME SYM INTERFACE?)
450 INTERFACE? is #t if we compiled @ or #f if we compiled @@
452 mod
= scm_resolve_module (SCM_CAR (what
));
453 if (scm_is_true (SCM_CADDR (what
)))
454 mod
= scm_module_public_interface (mod
);
455 if (scm_is_false (mod
))
456 scm_misc_error (NULL
, "no such module: ~S",
457 scm_list_1 (SCM_CAR (what
)));
459 return scm_module_lookup (mod
, SCM_CADR (what
));
463 #define VM_DEFAULT_STACK_SIZE (64 * 1024)
465 #define VM_NAME vm_regular_engine
466 #define FUNC_NAME "vm-regular-engine"
467 #define VM_ENGINE SCM_VM_REGULAR_ENGINE
468 #include "vm-engine.c"
473 #define VM_NAME vm_debug_engine
474 #define FUNC_NAME "vm-debug-engine"
475 #define VM_ENGINE SCM_VM_DEBUG_ENGINE
476 #include "vm-engine.c"
481 static const scm_t_vm_engine vm_engines
[] =
482 { vm_regular_engine
, vm_debug_engine
};
484 #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
486 /* The GC "kind" for the VM stack. */
487 static int vm_stack_gc_kind
;
493 #define FUNC_NAME "make_vm"
498 vp
= scm_gc_malloc (sizeof (struct scm_vm
), "vm");
500 vp
->stack_size
= VM_DEFAULT_STACK_SIZE
;
502 #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
503 vp
->stack_base
= (SCM
*)
504 GC_generic_malloc (vp
->stack_size
* sizeof (SCM
), vm_stack_gc_kind
);
506 /* Keep a pointer to VP so that `vm_stack_mark ()' can know what the stack
508 *vp
->stack_base
= SCM_PACK_POINTER (vp
);
512 vp
->stack_base
= scm_gc_malloc (vp
->stack_size
* sizeof (SCM
),
516 #ifdef VM_ENABLE_STACK_NULLING
517 memset (vp
->stack_base
, 0, vp
->stack_size
* sizeof (SCM
));
519 vp
->stack_limit
= vp
->stack_base
+ vp
->stack_size
- VM_STACK_RESERVE_SIZE
;
521 vp
->sp
= vp
->stack_base
- 1;
523 vp
->engine
= vm_default_engine
;
525 for (i
= 0; i
< SCM_VM_NUM_HOOKS
; i
++)
526 vp
->hooks
[i
] = SCM_BOOL_F
;
528 return scm_cell (scm_tc7_vm
, (scm_t_bits
)vp
);
532 #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
534 /* Mark the VM stack region between its base and its current top. */
535 static struct GC_ms_entry
*
536 vm_stack_mark (GC_word
*addr
, struct GC_ms_entry
*mark_stack_ptr
,
537 struct GC_ms_entry
*mark_stack_limit
, GC_word env
)
540 const struct scm_vm
*vm
;
542 /* The first word of the VM stack should contain a pointer to the
544 vm
= * ((struct scm_vm
**) addr
);
547 || (SCM
*) addr
!= vm
->stack_base
- 1)
548 /* ADDR must be a pointer to a free-list element, which we must ignore
549 (see warning in <gc/gc_mark.h>). */
550 return mark_stack_ptr
;
552 for (word
= (GC_word
*) vm
->stack_base
; word
<= (GC_word
*) vm
->sp
; word
++)
553 mark_stack_ptr
= GC_MARK_AND_PUSH ((* (GC_word
**) word
),
554 mark_stack_ptr
, mark_stack_limit
,
557 return mark_stack_ptr
;
560 #endif /* VM_ENABLE_PRECISE_STACK_GC_SCAN */
564 scm_c_vm_run (SCM vm
, SCM program
, SCM
*argv
, int nargs
)
566 struct scm_vm
*vp
= SCM_VM_DATA (vm
);
568 return vm_engines
[vp
->engine
](vm
, program
, argv
, nargs
);
571 /* Scheme interface */
573 SCM_DEFINE (scm_the_vm
, "the-vm", 0, 0, 0,
575 "Return the current thread's VM.")
576 #define FUNC_NAME s_scm_the_vm
578 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
580 if (SCM_UNLIKELY (scm_is_false (t
->vm
)))
588 SCM_DEFINE (scm_vm_p
, "vm?", 1, 0, 0,
591 #define FUNC_NAME s_scm_vm_p
593 return scm_from_bool (SCM_VM_P (obj
));
597 SCM_DEFINE (scm_make_vm
, "make-vm", 0, 0, 0,
600 #define FUNC_NAME s_scm_make_vm,
606 SCM_DEFINE (scm_vm_ip
, "vm:ip", 1, 0, 0,
609 #define FUNC_NAME s_scm_vm_ip
611 SCM_VALIDATE_VM (1, vm
);
612 return scm_from_unsigned_integer ((scm_t_bits
) SCM_VM_DATA (vm
)->ip
);
616 SCM_DEFINE (scm_vm_sp
, "vm:sp", 1, 0, 0,
619 #define FUNC_NAME s_scm_vm_sp
621 SCM_VALIDATE_VM (1, vm
);
622 return scm_from_unsigned_integer ((scm_t_bits
) SCM_VM_DATA (vm
)->sp
);
626 SCM_DEFINE (scm_vm_fp
, "vm:fp", 1, 0, 0,
629 #define FUNC_NAME s_scm_vm_fp
631 SCM_VALIDATE_VM (1, vm
);
632 return scm_from_unsigned_integer ((scm_t_bits
) SCM_VM_DATA (vm
)->fp
);
636 #define VM_DEFINE_HOOK(n) \
639 SCM_VALIDATE_VM (1, vm); \
640 vp = SCM_VM_DATA (vm); \
641 if (scm_is_false (vp->hooks[n])) \
642 vp->hooks[n] = scm_make_hook (SCM_I_MAKINUM (1)); \
643 return vp->hooks[n]; \
646 SCM_DEFINE (scm_vm_apply_hook
, "vm-apply-hook", 1, 0, 0,
649 #define FUNC_NAME s_scm_vm_apply_hook
651 VM_DEFINE_HOOK (SCM_VM_APPLY_HOOK
);
655 SCM_DEFINE (scm_vm_push_continuation_hook
, "vm-push-continuation-hook", 1, 0, 0,
658 #define FUNC_NAME s_scm_vm_push_continuation_hook
660 VM_DEFINE_HOOK (SCM_VM_PUSH_CONTINUATION_HOOK
);
664 SCM_DEFINE (scm_vm_pop_continuation_hook
, "vm-pop-continuation-hook", 1, 0, 0,
667 #define FUNC_NAME s_scm_vm_pop_continuation_hook
669 VM_DEFINE_HOOK (SCM_VM_POP_CONTINUATION_HOOK
);
673 SCM_DEFINE (scm_vm_next_hook
, "vm-next-hook", 1, 0, 0,
676 #define FUNC_NAME s_scm_vm_next_hook
678 VM_DEFINE_HOOK (SCM_VM_NEXT_HOOK
);
682 SCM_DEFINE (scm_vm_abort_continuation_hook
, "vm-abort-continuation-hook", 1, 0, 0,
685 #define FUNC_NAME s_scm_vm_abort_continuation_hook
687 VM_DEFINE_HOOK (SCM_VM_ABORT_CONTINUATION_HOOK
);
691 SCM_DEFINE (scm_vm_restore_continuation_hook
, "vm-restore-continuation-hook", 1, 0, 0,
694 #define FUNC_NAME s_scm_vm_restore_continuation_hook
696 VM_DEFINE_HOOK (SCM_VM_RESTORE_CONTINUATION_HOOK
);
700 SCM_DEFINE (scm_vm_trace_level
, "vm-trace-level", 1, 0, 0,
703 #define FUNC_NAME s_scm_vm_trace_level
705 SCM_VALIDATE_VM (1, vm
);
706 return scm_from_int (SCM_VM_DATA (vm
)->trace_level
);
710 SCM_DEFINE (scm_set_vm_trace_level_x
, "set-vm-trace-level!", 2, 0, 0,
713 #define FUNC_NAME s_scm_set_vm_trace_level_x
715 SCM_VALIDATE_VM (1, vm
);
716 SCM_VM_DATA (vm
)->trace_level
= scm_to_int (level
);
717 return SCM_UNSPECIFIED
;
727 symbol_to_vm_engine (SCM engine
, const char *FUNC_NAME
)
729 if (scm_is_eq (engine
, sym_regular
))
730 return SCM_VM_REGULAR_ENGINE
;
731 else if (scm_is_eq (engine
, sym_debug
))
732 return SCM_VM_DEBUG_ENGINE
;
734 SCM_MISC_ERROR ("Unknown VM engine: ~a", scm_list_1 (engine
));
738 vm_engine_to_symbol (int engine
, const char *FUNC_NAME
)
742 case SCM_VM_REGULAR_ENGINE
:
744 case SCM_VM_DEBUG_ENGINE
:
748 SCM_MISC_ERROR ("Unknown VM engine: ~a",
749 scm_list_1 (scm_from_int (engine
)));
753 SCM_DEFINE (scm_vm_engine
, "vm-engine", 1, 0, 0,
756 #define FUNC_NAME s_scm_vm_engine
758 SCM_VALIDATE_VM (1, vm
);
759 return vm_engine_to_symbol (SCM_VM_DATA (vm
)->engine
, FUNC_NAME
);
764 scm_c_set_vm_engine_x (SCM vm
, int engine
)
765 #define FUNC_NAME "set-vm-engine!"
767 SCM_VALIDATE_VM (1, vm
);
769 if (engine
< 0 || engine
>= SCM_VM_NUM_ENGINES
)
770 SCM_MISC_ERROR ("Unknown VM engine: ~a",
771 scm_list_1 (scm_from_int (engine
)));
773 SCM_VM_DATA (vm
)->engine
= engine
;
777 SCM_DEFINE (scm_set_vm_engine_x
, "set-vm-engine!", 2, 0, 0,
778 (SCM vm
, SCM engine
),
780 #define FUNC_NAME s_scm_set_vm_engine_x
782 scm_c_set_vm_engine_x (vm
, symbol_to_vm_engine (engine
, FUNC_NAME
));
783 return SCM_UNSPECIFIED
;
788 scm_c_set_default_vm_engine_x (int engine
)
789 #define FUNC_NAME "set-default-vm-engine!"
791 if (engine
< 0 || engine
>= SCM_VM_NUM_ENGINES
)
792 SCM_MISC_ERROR ("Unknown VM engine: ~a",
793 scm_list_1 (scm_from_int (engine
)));
795 vm_default_engine
= engine
;
799 SCM_DEFINE (scm_set_default_vm_engine_x
, "set-default-vm-engine!", 1, 0, 0,
802 #define FUNC_NAME s_scm_set_default_vm_engine_x
804 scm_c_set_default_vm_engine_x (symbol_to_vm_engine (engine
, FUNC_NAME
));
805 return SCM_UNSPECIFIED
;
809 static void reinstate_vm (SCM vm
)
811 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
815 SCM_DEFINE (scm_call_with_vm
, "call-with-vm", 2, 0, 1,
816 (SCM vm
, SCM proc
, SCM args
),
817 "Apply @var{proc} to @var{args} in a dynamic extent in which\n"
818 "@var{vm} is the current VM.\n\n"
819 "As an implementation restriction, if @var{vm} is not the same\n"
820 "as the current thread's VM, continuations captured within the\n"
821 "call to @var{proc} may not be reinstated once control leaves\n"
823 #define FUNC_NAME s_scm_call_with_vm
828 scm_t_wind_flags flags
;
829 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
831 SCM_VALIDATE_VM (1, vm
);
832 SCM_VALIDATE_PROC (2, proc
);
834 nargs
= scm_ilength (args
);
835 if (SCM_UNLIKELY (nargs
< 0))
836 scm_wrong_type_arg_msg (FUNC_NAME
, 3, args
, "list");
838 argv
= alloca (nargs
* sizeof(SCM
));
839 for (i
= 0; i
< nargs
; i
++)
841 argv
[i
] = SCM_CAR (args
);
842 args
= SCM_CDR (args
);
847 /* Reentry can happen via invokation of a saved continuation, but
848 continuations only save the state of the VM that they are in at
849 capture-time, which might be different from this one. So, in the
850 case that the VMs are different, set up a non-rewindable frame to
851 prevent reinstating an incomplete continuation. */
852 flags
= scm_is_eq (prev_vm
, vm
) ? 0 : SCM_F_WIND_EXPLICITLY
;
855 scm_dynwind_begin (0);
856 scm_dynwind_unwind_handler_with_scm (reinstate_vm
, prev_vm
, flags
);
860 ret
= scm_c_vm_run (vm
, proc
, argv
, nargs
);
874 SCM
scm_load_compiled_with_vm (SCM file
)
876 SCM program
= scm_make_program (scm_load_objcode (file
),
877 SCM_BOOL_F
, SCM_BOOL_F
);
879 return scm_c_vm_run (scm_the_vm (), program
, NULL
, 0);
883 scm_bootstrap_vm (void)
885 scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION
,
887 (scm_t_extension_init_func
)scm_init_vm
, NULL
);
889 sym_vm_run
= scm_from_latin1_symbol ("vm-run");
890 sym_vm_error
= scm_from_latin1_symbol ("vm-error");
891 sym_keyword_argument_error
= scm_from_latin1_symbol ("keyword-argument-error");
892 sym_regular
= scm_from_latin1_symbol ("regular");
893 sym_debug
= scm_from_latin1_symbol ("debug");
895 #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
897 GC_new_kind (GC_new_free_list (),
898 GC_MAKE_PROC (GC_new_proc (vm_stack_mark
), 0),
907 #ifndef SCM_MAGIC_SNARFER
908 #include "libguile/vm.x"