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 ("#<vm-continuation ", port
);
89 scm_uintprint (SCM_UNPACK (x
), 16, 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_uint32 flags
)
108 struct scm_vm_cont
*p
;
110 p
= scm_gc_malloc (sizeof (*p
), "capture_vm_cont");
111 p
->stack_size
= sp
- stack_base
+ 1;
112 p
->stack_base
= scm_gc_malloc (p
->stack_size
* sizeof (SCM
),
114 #if defined(VM_ENABLE_STACK_NULLING) && 0
115 /* Tail continuations leave their frame on the stack for subsequent
116 application, but don't capture the frame -- so there are some elements on
117 the stack then, and this check doesn't work, so disable it for now. */
118 if (sp
>= vp
->stack_base
)
119 if (!vp
->sp
[0] || vp
->sp
[1])
121 memset (p
->stack_base
, 0, p
->stack_size
* sizeof (SCM
));
127 memcpy (p
->stack_base
, stack_base
, (sp
+ 1 - stack_base
) * sizeof (SCM
));
128 p
->reloc
= p
->stack_base
- stack_base
;
130 return scm_cell (scm_tc7_vm_cont
, (scm_t_bits
)p
);
134 vm_return_to_continuation (SCM vm
, SCM cont
, size_t n
, SCM
*argv
)
137 struct scm_vm_cont
*cp
;
140 argv_copy
= alloca (n
* sizeof(SCM
));
141 memcpy (argv_copy
, argv
, n
* sizeof(SCM
));
143 vp
= SCM_VM_DATA (vm
);
144 cp
= SCM_VM_CONT_DATA (cont
);
146 if (n
== 0 && !cp
->mvra
)
147 scm_misc_error (NULL
, "Too few values returned to continuation",
150 if (vp
->stack_size
< cp
->stack_size
+ n
+ 1)
151 scm_misc_error ("vm-engine", "not enough space to reinstate continuation",
152 scm_list_2 (vm
, cont
));
154 #ifdef VM_ENABLE_STACK_NULLING
156 scm_t_ptrdiff nzero
= (vp
->sp
- cp
->sp
);
158 memset (vp
->stack_base
+ cp
->stack_size
, 0, nzero
* sizeof (SCM
));
159 /* actually nzero should always be negative, because vm_reset_stack will
160 unwind the stack to some point *below* this continuation */
165 memcpy (vp
->stack_base
, cp
->stack_base
, cp
->stack_size
* sizeof (SCM
));
167 if (n
== 1 || !cp
->mvra
)
171 *vp
->sp
= argv_copy
[0];
176 for (i
= 0; i
< n
; i
++)
179 *vp
->sp
= argv_copy
[i
];
182 *vp
->sp
= scm_from_size_t (n
);
188 scm_i_vm_capture_continuation (SCM vm
)
190 struct scm_vm
*vp
= SCM_VM_DATA (vm
);
191 return scm_i_vm_capture_stack (vp
->stack_base
, vp
->fp
, vp
->sp
, vp
->ip
, NULL
, 0);
195 vm_dispatch_hook (SCM vm
, int hook_num
)
199 struct scm_frame c_frame
;
202 int saved_trace_level
;
204 vp
= SCM_VM_DATA (vm
);
205 hook
= vp
->hooks
[hook_num
];
207 if (SCM_LIKELY (scm_is_false (hook
))
208 || scm_is_null (SCM_HOOK_PROCEDURES (hook
)))
211 saved_trace_level
= vp
->trace_level
;
214 /* Allocate a frame object on the stack. This is more efficient than calling
215 `scm_c_make_frame ()' to allocate on the heap, but it forces hooks to not
216 capture frame objects.
218 At the same time, procedures such as `frame-procedure' make sense only
219 while the stack frame represented by the frame object is visible, so it
220 seems reasonable to limit the lifetime of frame objects. */
222 c_frame
.stack_holder
= vm
;
228 /* Arrange for FRAME to be 8-byte aligned, like any other cell. */
229 frame
= alloca (sizeof (*frame
) + 8);
230 frame
= (scm_t_cell
*) ROUND_UP ((scm_t_uintptr
) frame
, 8UL);
232 frame
->word_0
= SCM_PACK (scm_tc7_frame
);
233 frame
->word_1
= PTR2SCM (&c_frame
);
234 args
[0] = PTR2SCM (frame
);
236 scm_c_run_hookn (hook
, args
, 1);
238 vp
->trace_level
= saved_trace_level
;
241 static void vm_abort (SCM vm
, size_t n
, scm_t_int64 cookie
) SCM_NORETURN
;
243 vm_abort (SCM vm
, size_t n
, scm_t_int64 vm_cookie
)
247 SCM tag
, tail
, *argv
;
249 /* FIXME: VM_ENABLE_STACK_NULLING */
250 tail
= *(SCM_VM_DATA (vm
)->sp
--);
252 tail_len
= scm_ilength (tail
);
254 scm_misc_error ("vm-engine", "tail values to abort should be a list",
257 tag
= SCM_VM_DATA (vm
)->sp
[-n
];
258 argv
= alloca ((n
+ tail_len
) * sizeof (SCM
));
259 for (i
= 0; i
< n
; i
++)
260 argv
[i
] = SCM_VM_DATA (vm
)->sp
[-(n
-1-i
)];
261 for (; i
< n
+ tail_len
; i
++, tail
= scm_cdr (tail
))
262 argv
[i
] = scm_car (tail
);
263 /* NULLSTACK (n + 1) */
264 SCM_VM_DATA (vm
)->sp
-= n
+ 1;
266 scm_c_abort (vm
, tag
, n
+ tail_len
, argv
, vm_cookie
);
270 vm_reinstate_partial_continuation (SCM vm
, SCM cont
, SCM intwinds
,
271 size_t n
, SCM
*argv
, scm_t_int64 vm_cookie
)
274 struct scm_vm_cont
*cp
;
275 SCM
*argv_copy
, *base
;
278 argv_copy
= alloca (n
* sizeof(SCM
));
279 memcpy (argv_copy
, argv
, n
* sizeof(SCM
));
281 vp
= SCM_VM_DATA (vm
);
282 cp
= SCM_VM_CONT_DATA (cont
);
283 base
= SCM_FRAME_UPPER_ADDRESS (vp
->fp
) + 1;
285 #define RELOC(scm_p) \
286 (((SCM *) (scm_p)) + cp->reloc + (base - cp->stack_base))
288 if ((base
- vp
->stack_base
) + cp
->stack_size
+ n
+ 1 > vp
->stack_size
)
289 scm_misc_error ("vm-engine",
290 "not enough space to instate partial continuation",
291 scm_list_2 (vm
, cont
));
293 memcpy (base
, cp
->stack_base
, cp
->stack_size
* sizeof (SCM
));
295 /* now relocate frame pointers */
298 for (fp
= RELOC (cp
->fp
);
299 SCM_FRAME_LOWER_ADDRESS (fp
) > base
;
300 fp
= SCM_FRAME_DYNAMIC_LINK (fp
))
301 SCM_FRAME_SET_DYNAMIC_LINK (fp
, RELOC (SCM_FRAME_DYNAMIC_LINK (fp
)));
304 vp
->sp
= base
- 1 + cp
->stack_size
;
305 vp
->fp
= RELOC (cp
->fp
);
308 /* now push args. ip is in a MV context. */
309 for (i
= 0; i
< n
; i
++)
312 *vp
->sp
= argv_copy
[i
];
315 *vp
->sp
= scm_from_size_t (n
);
317 /* Finally, rewind the dynamic state.
319 We have to treat prompts specially, because we could be rewinding the
320 dynamic state from a different thread, or just a different position on the
321 C and/or VM stack -- so we need to reset the jump buffers so that an abort
322 comes back here, with appropriately adjusted sp and fp registers. */
325 SCM newwinds
= scm_i_dynwinds ();
326 for (; scm_is_pair (intwinds
); intwinds
= scm_cdr (intwinds
), delta
--)
328 SCM x
= scm_car (intwinds
);
329 if (SCM_PROMPT_P (x
))
330 /* the jmpbuf will be reset by our caller */
331 x
= scm_c_make_prompt (SCM_PROMPT_TAG (x
),
332 RELOC (SCM_PROMPT_REGISTERS (x
)->fp
),
333 RELOC (SCM_PROMPT_REGISTERS (x
)->sp
),
334 SCM_PROMPT_REGISTERS (x
)->ip
,
335 SCM_PROMPT_ESCAPE_P (x
),
338 newwinds
= scm_cons (x
, newwinds
);
340 scm_dowinds (newwinds
, delta
);
347 * VM Internal functions
351 scm_i_vm_print (SCM x
, SCM port
, scm_print_state
*pstate
)
353 const struct scm_vm
*vm
;
355 vm
= SCM_VM_DATA (x
);
357 scm_puts ("#<vm ", port
);
360 case SCM_VM_REGULAR_ENGINE
:
361 scm_puts ("regular-engine ", port
);
364 case SCM_VM_DEBUG_ENGINE
:
365 scm_puts ("debug-engine ", port
);
369 scm_puts ("unknown-engine ", port
);
371 scm_uintprint (SCM_UNPACK (x
), 16, port
);
372 scm_puts (">", port
);
380 static void vm_error (const char *msg
, SCM arg
) SCM_NORETURN
;
381 static void vm_error_bad_instruction (scm_t_uint32 inst
) SCM_NORETURN
;
382 static void vm_error_unbound (SCM proc
, SCM sym
) SCM_NORETURN
;
383 static void vm_error_unbound_fluid (SCM proc
, SCM fluid
) SCM_NORETURN
;
384 static void vm_error_not_a_variable (const char *func_name
, SCM x
) SCM_NORETURN
;
385 static void vm_error_not_a_thunk (const char *func_name
, SCM x
) SCM_NORETURN
;
386 static void vm_error_apply_to_non_list (SCM x
) SCM_NORETURN
;
387 static void vm_error_kwargs_length_not_even (SCM proc
) SCM_NORETURN
;
388 static void vm_error_kwargs_invalid_keyword (SCM proc
, SCM obj
) SCM_NORETURN
;
389 static void vm_error_kwargs_unrecognized_keyword (SCM proc
, SCM kw
) SCM_NORETURN
;
390 static void vm_error_too_many_args (int nargs
) SCM_NORETURN
;
391 static void vm_error_wrong_num_args (SCM proc
) SCM_NORETURN
;
392 static void vm_error_wrong_type_apply (SCM proc
) SCM_NORETURN
;
393 static void vm_error_stack_overflow (struct scm_vm
*vp
) SCM_NORETURN
;
394 static void vm_error_stack_underflow (void) SCM_NORETURN
;
395 static void vm_error_improper_list (SCM x
) SCM_NORETURN
;
396 static void vm_error_not_a_pair (const char *subr
, SCM x
) SCM_NORETURN
;
397 static void vm_error_not_a_bytevector (const char *subr
, SCM x
) SCM_NORETURN
;
398 static void vm_error_not_a_struct (const char *subr
, SCM x
) SCM_NORETURN
;
399 static void vm_error_no_values (void) SCM_NORETURN
;
400 static void vm_error_not_enough_values (void) SCM_NORETURN
;
401 static void vm_error_continuation_not_rewindable (SCM cont
) SCM_NORETURN
;
402 static void vm_error_bad_wide_string_length (size_t len
) SCM_NORETURN
;
404 static void vm_error_invalid_address (void) SCM_NORETURN
;
407 static void vm_error_object (void) SCM_NORETURN
;
409 #if VM_CHECK_FREE_VARIABLES
410 static void vm_error_free_variable (void) SCM_NORETURN
;
414 vm_error (const char *msg
, SCM arg
)
416 scm_throw (sym_vm_error
,
417 scm_list_3 (sym_vm_run
, scm_from_latin1_string (msg
),
418 SCM_UNBNDP (arg
) ? SCM_EOL
: scm_list_1 (arg
)));
419 abort(); /* not reached */
423 vm_error_bad_instruction (scm_t_uint32 inst
)
425 vm_error ("VM: Bad instruction: ~s", scm_from_uint32 (inst
));
429 vm_error_unbound (SCM proc
, SCM sym
)
431 scm_error_scm (scm_misc_error_key
, proc
,
432 scm_from_latin1_string ("Unbound variable: ~s"),
433 scm_list_1 (sym
), SCM_BOOL_F
);
437 vm_error_unbound_fluid (SCM proc
, SCM fluid
)
439 scm_error_scm (scm_misc_error_key
, proc
,
440 scm_from_latin1_string ("Unbound fluid: ~s"),
441 scm_list_1 (fluid
), SCM_BOOL_F
);
445 vm_error_not_a_variable (const char *func_name
, SCM x
)
447 scm_error (scm_arg_type_key
, func_name
, "Not a variable: ~S",
448 scm_list_1 (x
), scm_list_1 (x
));
452 vm_error_not_a_thunk (const char *func_name
, SCM x
)
454 scm_error (scm_arg_type_key
, func_name
, "Not a thunk: ~S",
455 scm_list_1 (x
), scm_list_1 (x
));
459 vm_error_apply_to_non_list (SCM x
)
461 scm_error (scm_arg_type_key
, "apply", "Apply to non-list: ~S",
462 scm_list_1 (x
), scm_list_1 (x
));
466 vm_error_kwargs_length_not_even (SCM proc
)
468 scm_error_scm (sym_keyword_argument_error
, proc
,
469 scm_from_latin1_string ("Odd length of keyword argument list"),
470 SCM_EOL
, SCM_BOOL_F
);
474 vm_error_kwargs_invalid_keyword (SCM proc
, SCM obj
)
476 scm_error_scm (sym_keyword_argument_error
, proc
,
477 scm_from_latin1_string ("Invalid keyword"),
478 SCM_EOL
, scm_list_1 (obj
));
482 vm_error_kwargs_unrecognized_keyword (SCM proc
, SCM kw
)
484 scm_error_scm (sym_keyword_argument_error
, proc
,
485 scm_from_latin1_string ("Unrecognized keyword"),
486 SCM_EOL
, scm_list_1 (kw
));
490 vm_error_too_many_args (int nargs
)
492 vm_error ("VM: Too many arguments", scm_from_int (nargs
));
496 vm_error_wrong_num_args (SCM proc
)
498 scm_wrong_num_args (proc
);
502 vm_error_wrong_type_apply (SCM proc
)
504 scm_error (scm_arg_type_key
, NULL
, "Wrong type to apply: ~S",
505 scm_list_1 (proc
), scm_list_1 (proc
));
509 vm_error_stack_overflow (struct scm_vm
*vp
)
511 if (vp
->stack_limit
< vp
->stack_base
+ vp
->stack_size
)
512 /* There are VM_STACK_RESERVE_SIZE bytes left. Make them available so
513 that `throw' below can run on this VM. */
514 vp
->stack_limit
= vp
->stack_base
+ vp
->stack_size
;
516 /* There is no space left on the stack. FIXME: Do something more
519 vm_error ("VM: Stack overflow", SCM_UNDEFINED
);
523 vm_error_stack_underflow (void)
525 vm_error ("VM: Stack underflow", SCM_UNDEFINED
);
529 vm_error_improper_list (SCM x
)
531 vm_error ("Expected a proper list, but got object with tail ~s", x
);
535 vm_error_not_a_pair (const char *subr
, SCM x
)
537 scm_wrong_type_arg_msg (subr
, 1, x
, "pair");
541 vm_error_not_a_bytevector (const char *subr
, SCM x
)
543 scm_wrong_type_arg_msg (subr
, 1, x
, "bytevector");
547 vm_error_not_a_struct (const char *subr
, SCM x
)
549 scm_wrong_type_arg_msg (subr
, 1, x
, "struct");
553 vm_error_no_values (void)
555 vm_error ("Zero values returned to single-valued continuation",
560 vm_error_not_enough_values (void)
562 vm_error ("Too few values returned to continuation", SCM_UNDEFINED
);
566 vm_error_continuation_not_rewindable (SCM cont
)
568 vm_error ("Unrewindable partial continuation", cont
);
572 vm_error_bad_wide_string_length (size_t len
)
574 vm_error ("VM: Bad wide string length: ~S", scm_from_size_t (len
));
579 vm_error_invalid_address (void)
581 vm_error ("VM: Invalid program address", SCM_UNDEFINED
);
589 vm_error ("VM: Invalid object table access", SCM_UNDEFINED
);
593 #if VM_CHECK_FREE_VARIABLES
595 vm_error_free_variable ()
597 vm_error ("VM: Invalid free variable access", SCM_UNDEFINED
);
603 static SCM boot_continuation
;
611 resolve_variable (SCM what
, SCM program_module
)
613 if (SCM_LIKELY (scm_is_symbol (what
)))
615 if (scm_is_true (program_module
))
616 return scm_module_lookup (program_module
, what
);
618 return scm_module_lookup (scm_the_root_module (), what
);
623 /* compilation of @ or @@
624 `what' is a three-element list: (MODNAME SYM INTERFACE?)
625 INTERFACE? is #t if we compiled @ or #f if we compiled @@
627 mod
= scm_resolve_module (SCM_CAR (what
));
628 if (scm_is_true (SCM_CADDR (what
)))
629 mod
= scm_module_public_interface (mod
);
630 if (scm_is_false (mod
))
631 scm_misc_error (NULL
, "no such module: ~S",
632 scm_list_1 (SCM_CAR (what
)));
634 return scm_module_lookup (mod
, SCM_CADR (what
));
638 #define VM_MIN_STACK_SIZE (1024)
639 #define VM_DEFAULT_STACK_SIZE (64 * 1024)
640 static size_t vm_stack_size
= VM_DEFAULT_STACK_SIZE
;
643 initialize_default_stack_size (void)
645 int size
= scm_getenv_int ("GUILE_STACK_SIZE", vm_stack_size
);
646 if (size
>= VM_MIN_STACK_SIZE
)
647 vm_stack_size
= size
;
650 #define VM_NAME vm_regular_engine
651 #define FUNC_NAME "vm-regular-engine"
652 #define VM_ENGINE SCM_VM_REGULAR_ENGINE
653 #include "vm-engine.c"
658 #define VM_NAME vm_debug_engine
659 #define FUNC_NAME "vm-debug-engine"
660 #define VM_ENGINE SCM_VM_DEBUG_ENGINE
661 #include "vm-engine.c"
666 static const scm_t_vm_engine vm_engines
[] =
667 { vm_regular_engine
, vm_debug_engine
};
669 #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
671 /* The GC "kind" for the VM stack. */
672 static int vm_stack_gc_kind
;
678 #define FUNC_NAME "make_vm"
683 vp
= scm_gc_malloc (sizeof (struct scm_vm
), "vm");
685 vp
->stack_size
= vm_stack_size
;
687 #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
688 vp
->stack_base
= (SCM
*)
689 GC_generic_malloc (vp
->stack_size
* sizeof (SCM
), vm_stack_gc_kind
);
691 /* Keep a pointer to VP so that `vm_stack_mark ()' can know what the stack
693 *vp
->stack_base
= PTR2SCM (vp
);
697 vp
->stack_base
= scm_gc_malloc (vp
->stack_size
* sizeof (SCM
),
701 #ifdef VM_ENABLE_STACK_NULLING
702 memset (vp
->stack_base
, 0, vp
->stack_size
* sizeof (SCM
));
704 vp
->stack_limit
= vp
->stack_base
+ vp
->stack_size
- VM_STACK_RESERVE_SIZE
;
706 vp
->sp
= vp
->stack_base
- 1;
708 vp
->engine
= vm_default_engine
;
710 for (i
= 0; i
< SCM_VM_NUM_HOOKS
; i
++)
711 vp
->hooks
[i
] = SCM_BOOL_F
;
713 return scm_cell (scm_tc7_vm
, (scm_t_bits
)vp
);
717 #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
719 /* Mark the VM stack region between its base and its current top. */
720 static struct GC_ms_entry
*
721 vm_stack_mark (GC_word
*addr
, struct GC_ms_entry
*mark_stack_ptr
,
722 struct GC_ms_entry
*mark_stack_limit
, GC_word env
)
725 const struct scm_vm
*vm
;
727 /* The first word of the VM stack should contain a pointer to the
729 vm
= * ((struct scm_vm
**) addr
);
732 || (SCM
*) addr
!= vm
->stack_base
- 1)
733 /* ADDR must be a pointer to a free-list element, which we must ignore
734 (see warning in <gc/gc_mark.h>). */
735 return mark_stack_ptr
;
737 for (word
= (GC_word
*) vm
->stack_base
; word
<= (GC_word
*) vm
->sp
; word
++)
738 mark_stack_ptr
= GC_MARK_AND_PUSH ((* (GC_word
**) word
),
739 mark_stack_ptr
, mark_stack_limit
,
742 return mark_stack_ptr
;
745 #endif /* VM_ENABLE_PRECISE_STACK_GC_SCAN */
749 scm_c_vm_run (SCM vm
, SCM program
, SCM
*argv
, int nargs
)
751 struct scm_vm
*vp
= SCM_VM_DATA (vm
);
753 return vm_engines
[vp
->engine
](vm
, program
, argv
, nargs
);
756 /* Scheme interface */
758 SCM_DEFINE (scm_the_vm
, "the-vm", 0, 0, 0,
760 "Return the current thread's VM.")
761 #define FUNC_NAME s_scm_the_vm
763 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
765 if (SCM_UNLIKELY (scm_is_false (t
->vm
)))
773 SCM_DEFINE (scm_vm_p
, "vm?", 1, 0, 0,
776 #define FUNC_NAME s_scm_vm_p
778 return scm_from_bool (SCM_VM_P (obj
));
782 SCM_DEFINE (scm_make_vm
, "make-vm", 0, 0, 0,
785 #define FUNC_NAME s_scm_make_vm,
791 SCM_DEFINE (scm_vm_ip
, "vm:ip", 1, 0, 0,
794 #define FUNC_NAME s_scm_vm_ip
796 SCM_VALIDATE_VM (1, vm
);
797 return scm_from_unsigned_integer ((scm_t_bits
) SCM_VM_DATA (vm
)->ip
);
801 SCM_DEFINE (scm_vm_sp
, "vm:sp", 1, 0, 0,
804 #define FUNC_NAME s_scm_vm_sp
806 SCM_VALIDATE_VM (1, vm
);
807 return scm_from_unsigned_integer ((scm_t_bits
) SCM_VM_DATA (vm
)->sp
);
811 SCM_DEFINE (scm_vm_fp
, "vm:fp", 1, 0, 0,
814 #define FUNC_NAME s_scm_vm_fp
816 SCM_VALIDATE_VM (1, vm
);
817 return scm_from_unsigned_integer ((scm_t_bits
) SCM_VM_DATA (vm
)->fp
);
821 #define VM_DEFINE_HOOK(n) \
824 SCM_VALIDATE_VM (1, vm); \
825 vp = SCM_VM_DATA (vm); \
826 if (scm_is_false (vp->hooks[n])) \
827 vp->hooks[n] = scm_make_hook (SCM_I_MAKINUM (1)); \
828 return vp->hooks[n]; \
831 SCM_DEFINE (scm_vm_apply_hook
, "vm-apply-hook", 1, 0, 0,
834 #define FUNC_NAME s_scm_vm_apply_hook
836 VM_DEFINE_HOOK (SCM_VM_APPLY_HOOK
);
840 SCM_DEFINE (scm_vm_push_continuation_hook
, "vm-push-continuation-hook", 1, 0, 0,
843 #define FUNC_NAME s_scm_vm_push_continuation_hook
845 VM_DEFINE_HOOK (SCM_VM_PUSH_CONTINUATION_HOOK
);
849 SCM_DEFINE (scm_vm_pop_continuation_hook
, "vm-pop-continuation-hook", 1, 0, 0,
852 #define FUNC_NAME s_scm_vm_pop_continuation_hook
854 VM_DEFINE_HOOK (SCM_VM_POP_CONTINUATION_HOOK
);
858 SCM_DEFINE (scm_vm_next_hook
, "vm-next-hook", 1, 0, 0,
861 #define FUNC_NAME s_scm_vm_next_hook
863 VM_DEFINE_HOOK (SCM_VM_NEXT_HOOK
);
867 SCM_DEFINE (scm_vm_abort_continuation_hook
, "vm-abort-continuation-hook", 1, 0, 0,
870 #define FUNC_NAME s_scm_vm_abort_continuation_hook
872 VM_DEFINE_HOOK (SCM_VM_ABORT_CONTINUATION_HOOK
);
876 SCM_DEFINE (scm_vm_restore_continuation_hook
, "vm-restore-continuation-hook", 1, 0, 0,
879 #define FUNC_NAME s_scm_vm_restore_continuation_hook
881 VM_DEFINE_HOOK (SCM_VM_RESTORE_CONTINUATION_HOOK
);
885 SCM_DEFINE (scm_vm_trace_level
, "vm-trace-level", 1, 0, 0,
888 #define FUNC_NAME s_scm_vm_trace_level
890 SCM_VALIDATE_VM (1, vm
);
891 return scm_from_int (SCM_VM_DATA (vm
)->trace_level
);
895 SCM_DEFINE (scm_set_vm_trace_level_x
, "set-vm-trace-level!", 2, 0, 0,
898 #define FUNC_NAME s_scm_set_vm_trace_level_x
900 SCM_VALIDATE_VM (1, vm
);
901 SCM_VM_DATA (vm
)->trace_level
= scm_to_int (level
);
902 return SCM_UNSPECIFIED
;
912 symbol_to_vm_engine (SCM engine
, const char *FUNC_NAME
)
914 if (scm_is_eq (engine
, sym_regular
))
915 return SCM_VM_REGULAR_ENGINE
;
916 else if (scm_is_eq (engine
, sym_debug
))
917 return SCM_VM_DEBUG_ENGINE
;
919 SCM_MISC_ERROR ("Unknown VM engine: ~a", scm_list_1 (engine
));
923 vm_engine_to_symbol (int engine
, const char *FUNC_NAME
)
927 case SCM_VM_REGULAR_ENGINE
:
929 case SCM_VM_DEBUG_ENGINE
:
933 SCM_MISC_ERROR ("Unknown VM engine: ~a",
934 scm_list_1 (scm_from_int (engine
)));
938 SCM_DEFINE (scm_vm_engine
, "vm-engine", 1, 0, 0,
941 #define FUNC_NAME s_scm_vm_engine
943 SCM_VALIDATE_VM (1, vm
);
944 return vm_engine_to_symbol (SCM_VM_DATA (vm
)->engine
, FUNC_NAME
);
949 scm_c_set_vm_engine_x (SCM vm
, int engine
)
950 #define FUNC_NAME "set-vm-engine!"
952 SCM_VALIDATE_VM (1, vm
);
954 if (engine
< 0 || engine
>= SCM_VM_NUM_ENGINES
)
955 SCM_MISC_ERROR ("Unknown VM engine: ~a",
956 scm_list_1 (scm_from_int (engine
)));
958 SCM_VM_DATA (vm
)->engine
= engine
;
962 SCM_DEFINE (scm_set_vm_engine_x
, "set-vm-engine!", 2, 0, 0,
963 (SCM vm
, SCM engine
),
965 #define FUNC_NAME s_scm_set_vm_engine_x
967 scm_c_set_vm_engine_x (vm
, symbol_to_vm_engine (engine
, FUNC_NAME
));
968 return SCM_UNSPECIFIED
;
973 scm_c_set_default_vm_engine_x (int engine
)
974 #define FUNC_NAME "set-default-vm-engine!"
976 if (engine
< 0 || engine
>= SCM_VM_NUM_ENGINES
)
977 SCM_MISC_ERROR ("Unknown VM engine: ~a",
978 scm_list_1 (scm_from_int (engine
)));
980 vm_default_engine
= engine
;
984 SCM_DEFINE (scm_set_default_vm_engine_x
, "set-default-vm-engine!", 1, 0, 0,
987 #define FUNC_NAME s_scm_set_default_vm_engine_x
989 scm_c_set_default_vm_engine_x (symbol_to_vm_engine (engine
, FUNC_NAME
));
990 return SCM_UNSPECIFIED
;
994 static void reinstate_vm (SCM vm
)
996 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
1000 SCM_DEFINE (scm_call_with_vm
, "call-with-vm", 2, 0, 1,
1001 (SCM vm
, SCM proc
, SCM args
),
1002 "Apply @var{proc} to @var{args} in a dynamic extent in which\n"
1003 "@var{vm} is the current VM.\n\n"
1004 "As an implementation restriction, if @var{vm} is not the same\n"
1005 "as the current thread's VM, continuations captured within the\n"
1006 "call to @var{proc} may not be reinstated once control leaves\n"
1008 #define FUNC_NAME s_scm_call_with_vm
1013 scm_t_wind_flags flags
;
1014 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
1016 SCM_VALIDATE_VM (1, vm
);
1017 SCM_VALIDATE_PROC (2, proc
);
1019 nargs
= scm_ilength (args
);
1020 if (SCM_UNLIKELY (nargs
< 0))
1021 scm_wrong_type_arg_msg (FUNC_NAME
, 3, args
, "list");
1023 argv
= alloca (nargs
* sizeof(SCM
));
1024 for (i
= 0; i
< nargs
; i
++)
1026 argv
[i
] = SCM_CAR (args
);
1027 args
= SCM_CDR (args
);
1032 /* Reentry can happen via invokation of a saved continuation, but
1033 continuations only save the state of the VM that they are in at
1034 capture-time, which might be different from this one. So, in the
1035 case that the VMs are different, set up a non-rewindable frame to
1036 prevent reinstating an incomplete continuation. */
1037 flags
= scm_is_eq (prev_vm
, vm
) ? 0 : SCM_F_WIND_EXPLICITLY
;
1040 scm_dynwind_begin (0);
1041 scm_dynwind_unwind_handler_with_scm (reinstate_vm
, prev_vm
, flags
);
1045 ret
= scm_c_vm_run (vm
, proc
, argv
, nargs
);
1059 SCM
scm_load_compiled_with_vm (SCM file
)
1061 SCM program
= scm_make_program (scm_load_objcode (file
),
1062 SCM_BOOL_F
, SCM_BOOL_F
);
1064 return scm_c_vm_run (scm_the_vm (), program
, NULL
, 0);
1069 make_boot_program (void)
1071 struct scm_objcode
*bp
;
1075 const scm_t_uint8 text
[] = {
1080 bp_size
= sizeof (struct scm_objcode
) + sizeof (text
);
1081 bp
= scm_gc_malloc_pointerless (bp_size
, "boot-program");
1082 memcpy (SCM_C_OBJCODE_BASE (bp
), text
, sizeof (text
));
1083 bp
->len
= sizeof(text
);
1086 u8vec
= scm_c_take_gc_bytevector ((scm_t_int8
*)bp
, bp_size
);
1087 ret
= scm_make_program (scm_bytecode_to_native_objcode (u8vec
),
1088 SCM_BOOL_F
, SCM_BOOL_F
);
1089 SCM_SET_CELL_WORD_0 (ret
, (SCM_CELL_WORD_0 (ret
) | SCM_F_PROGRAM_IS_BOOT
));
1095 scm_bootstrap_vm (void)
1097 scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION
,
1099 (scm_t_extension_init_func
)scm_init_vm
, NULL
);
1101 initialize_default_stack_size ();
1103 sym_vm_run
= scm_from_latin1_symbol ("vm-run");
1104 sym_vm_error
= scm_from_latin1_symbol ("vm-error");
1105 sym_keyword_argument_error
= scm_from_latin1_symbol ("keyword-argument-error");
1106 sym_regular
= scm_from_latin1_symbol ("regular");
1107 sym_debug
= scm_from_latin1_symbol ("debug");
1109 boot_continuation
= make_boot_program ();
1111 #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
1113 GC_new_kind (GC_new_free_list (),
1114 GC_MAKE_PROC (GC_new_proc (vm_stack_mark
), 0),
1123 #ifndef SCM_MAGIC_SNARFER
1124 #include "libguile/vm.x"