1 /* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
3 * This library is free software; you can redistribute it and/or
4 * modify it under the terms of the GNU Lesser General Public License
5 * as published by the Free Software Foundation; either version 3 of
6 * the License, or (at your option) any later version.
8 * This library is distributed in the hope that it will be useful, but
9 * WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
11 * Lesser General Public License for more details.
13 * You should have received a copy of the GNU Lesser General Public
14 * License along with this library; if not, write to the Free Software
15 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
29 #include "libguile/bdw-gc.h"
30 #include <gc/gc_mark.h>
35 #include "instructions.h"
39 #include "vm-builtins.h"
41 #include "private-gc.h" /* scm_getenv_int */
43 static int vm_default_engine
= SCM_VM_REGULAR_ENGINE
;
45 /* Unfortunately we can't snarf these: snarfed things are only loaded up from
46 (system vm vm), which might not be loaded before an error happens. */
47 static SCM sym_vm_run
;
48 static SCM sym_vm_error
;
49 static SCM sym_keyword_argument_error
;
50 static SCM sym_regular
;
53 /* The VM has a number of internal assertions that shouldn't normally be
54 necessary, but might be if you think you found a bug in the VM. */
55 #define VM_ENABLE_ASSERTIONS
57 /* #define VM_ENABLE_PARANOID_ASSERTIONS */
59 /* When defined, arrange so that the GC doesn't scan the VM stack beyond its
60 current SP. This should help avoid excess data retention. See
61 http://thread.gmane.org/gmane.comp.programming.garbage-collection.boehmgc/3001
63 #define VM_ENABLE_PRECISE_STACK_GC_SCAN
65 /* Size in SCM objects of the stack reserve. The reserve is used to run
66 exception handling code in case of a VM stack overflow. */
67 #define VM_STACK_RESERVE_SIZE 512
76 scm_i_vm_cont_print (SCM x
, SCM port
, scm_print_state
*pstate
)
78 scm_puts_unlocked ("#<vm-continuation ", port
);
79 scm_uintprint (SCM_UNPACK (x
), 16, port
);
80 scm_puts_unlocked (">", port
);
83 /* In theory, a number of vm instances can be active in the call trace, and we
84 only want to reify the continuations of those in the current continuation
85 root. I don't see a nice way to do this -- ideally it would involve dynwinds,
86 and previous values of the *the-vm* fluid within the current continuation
87 root. But we don't have access to continuation roots in the dynwind stack.
88 So, just punt for now, we just capture the continuation for the current VM.
90 While I'm on the topic, ideally we could avoid copying the C stack if the
91 continuation root is inside VM code, and call/cc was invoked within that same
92 call to vm_run; but that's currently not implemented.
95 scm_i_vm_capture_stack (SCM
*stack_base
, SCM
*fp
, SCM
*sp
, scm_t_uint32
*ra
,
96 scm_t_dynstack
*dynstack
, scm_t_uint32 flags
)
98 struct scm_vm_cont
*p
;
100 p
= scm_gc_malloc (sizeof (*p
), "capture_vm_cont");
101 p
->stack_size
= sp
- stack_base
+ 1;
102 p
->stack_base
= scm_gc_malloc (p
->stack_size
* sizeof (SCM
),
107 memcpy (p
->stack_base
, stack_base
, (sp
+ 1 - stack_base
) * sizeof (SCM
));
108 p
->reloc
= p
->stack_base
- stack_base
;
109 p
->dynstack
= dynstack
;
111 return scm_cell (scm_tc7_vm_cont
, (scm_t_bits
)p
);
115 vm_return_to_continuation (SCM vm
, SCM cont
, size_t n
, SCM
*argv
)
118 struct scm_vm_cont
*cp
;
121 argv_copy
= alloca (n
* sizeof(SCM
));
122 memcpy (argv_copy
, argv
, n
* sizeof(SCM
));
124 vp
= SCM_VM_DATA (vm
);
125 cp
= SCM_VM_CONT_DATA (cont
);
127 if (vp
->stack_size
< cp
->stack_size
+ n
+ 3)
128 scm_misc_error ("vm-engine", "not enough space to reinstate continuation",
129 scm_list_2 (vm
, cont
));
133 memcpy (vp
->stack_base
, cp
->stack_base
, cp
->stack_size
* sizeof (SCM
));
138 /* Push on an empty frame, as the continuation expects. */
139 for (i
= 0; i
< 3; i
++)
142 *vp
->sp
= SCM_BOOL_F
;
145 /* Push the return values. */
146 for (i
= 0; i
< n
; i
++)
149 *vp
->sp
= argv_copy
[i
];
156 scm_i_capture_current_stack (void)
158 scm_i_thread
*thread
;
162 thread
= SCM_I_CURRENT_THREAD
;
164 vp
= SCM_VM_DATA (vm
);
166 return scm_i_vm_capture_stack (vp
->stack_base
, vp
->fp
, vp
->sp
, vp
->ip
,
167 scm_dynstack_capture_all (&thread
->dynstack
),
171 static void vm_dispatch_hook (SCM vm
, int hook_num
,
172 SCM
*argv
, int n
) SCM_NOINLINE
;
175 vm_dispatch_hook (SCM vm
, int hook_num
, SCM
*argv
, int n
)
179 struct scm_frame c_frame
;
181 int saved_trace_level
;
183 vp
= SCM_VM_DATA (vm
);
184 hook
= vp
->hooks
[hook_num
];
186 if (SCM_LIKELY (scm_is_false (hook
))
187 || scm_is_null (SCM_HOOK_PROCEDURES (hook
)))
190 saved_trace_level
= vp
->trace_level
;
193 /* Allocate a frame object on the stack. This is more efficient than calling
194 `scm_c_make_frame ()' to allocate on the heap, but it forces hooks to not
195 capture frame objects.
197 At the same time, procedures such as `frame-procedure' make sense only
198 while the stack frame represented by the frame object is visible, so it
199 seems reasonable to limit the lifetime of frame objects. */
201 c_frame
.stack_holder
= vm
;
207 /* Arrange for FRAME to be 8-byte aligned, like any other cell. */
208 frame
= alloca (sizeof (*frame
) + 8);
209 frame
= (scm_t_cell
*) ROUND_UP ((scm_t_uintptr
) frame
, 8UL);
211 frame
->word_0
= SCM_PACK (scm_tc7_frame
);
212 frame
->word_1
= SCM_PACK_POINTER (&c_frame
);
218 args
[0] = SCM_PACK_POINTER (frame
);
219 scm_c_run_hookn (hook
, args
, 1);
225 args
[0] = SCM_PACK_POINTER (frame
);
227 scm_c_run_hookn (hook
, args
, 2);
234 args
= scm_cons (argv
[n
], args
);
235 scm_c_run_hook (hook
, scm_cons (SCM_PACK_POINTER (frame
), args
));
238 vp
->trace_level
= saved_trace_level
;
242 vm_abort (SCM vm
, SCM tag
, size_t nstack
, SCM
*stack_args
, SCM tail
, SCM
*sp
,
243 scm_i_jmp_buf
*current_registers
) SCM_NORETURN
;
246 vm_abort (SCM vm
, SCM tag
, size_t nstack
, SCM
*stack_args
, SCM tail
, SCM
*sp
,
247 scm_i_jmp_buf
*current_registers
)
253 tail_len
= scm_ilength (tail
);
255 scm_misc_error ("vm-engine", "tail values to abort should be a list",
258 argv
= alloca ((nstack
+ tail_len
) * sizeof (SCM
));
259 for (i
= 0; i
< nstack
; i
++)
260 argv
[i
] = stack_args
[i
];
261 for (; i
< nstack
+ tail_len
; i
++, tail
= scm_cdr (tail
))
262 argv
[i
] = scm_car (tail
);
264 /* FIXME: NULLSTACK (SCM_VM_DATA (vp)->sp - sp) */
265 SCM_VM_DATA (vm
)->sp
= sp
;
267 scm_c_abort (vm
, tag
, nstack
+ tail_len
, argv
, current_registers
);
271 vm_reinstate_partial_continuation (SCM vm
, SCM cont
, size_t n
, SCM
*argv
,
272 scm_t_dynstack
*dynstack
,
273 scm_i_jmp_buf
*registers
)
276 struct scm_vm_cont
*cp
;
277 SCM
*argv_copy
, *base
;
281 argv_copy
= alloca (n
* sizeof(SCM
));
282 memcpy (argv_copy
, argv
, n
* sizeof(SCM
));
284 vp
= SCM_VM_DATA (vm
);
285 cp
= SCM_VM_CONT_DATA (cont
);
286 base
= SCM_FRAME_LOCALS_ADDRESS (vp
->fp
);
287 reloc
= cp
->reloc
+ (base
- cp
->stack_base
);
289 #define RELOC(scm_p) \
290 (((SCM *) (scm_p)) + reloc)
292 if ((base
- vp
->stack_base
) + cp
->stack_size
+ n
+ 1 > vp
->stack_size
)
293 scm_misc_error ("vm-engine",
294 "not enough space to instate partial continuation",
295 scm_list_2 (vm
, cont
));
297 memcpy (base
, cp
->stack_base
, cp
->stack_size
* sizeof (SCM
));
299 /* now relocate frame pointers */
302 for (fp
= RELOC (cp
->fp
);
303 SCM_FRAME_LOWER_ADDRESS (fp
) > base
;
304 fp
= SCM_FRAME_DYNAMIC_LINK (fp
))
305 SCM_FRAME_SET_DYNAMIC_LINK (fp
, RELOC (SCM_FRAME_DYNAMIC_LINK (fp
)));
308 vp
->sp
= base
- 1 + cp
->stack_size
;
309 vp
->fp
= RELOC (cp
->fp
);
312 /* Push the arguments. */
313 for (i
= 0; i
< n
; i
++)
316 *vp
->sp
= argv_copy
[i
];
319 /* The prompt captured a slice of the dynamic stack. Here we wind
320 those entries onto the current thread's stack. We also have to
321 relocate any prompts that we see along the way. */
325 for (walk
= SCM_DYNSTACK_FIRST (cp
->dynstack
);
326 SCM_DYNSTACK_TAG (walk
);
327 walk
= SCM_DYNSTACK_NEXT (walk
))
329 scm_t_bits tag
= SCM_DYNSTACK_TAG (walk
);
331 if (SCM_DYNSTACK_TAG_TYPE (tag
) == SCM_DYNSTACK_TYPE_PROMPT
)
332 scm_dynstack_wind_prompt (dynstack
, walk
, reloc
, registers
);
334 scm_dynstack_wind_1 (dynstack
, walk
);
342 * VM Internal functions
346 scm_i_vm_print (SCM x
, SCM port
, scm_print_state
*pstate
)
348 const struct scm_vm
*vm
;
350 vm
= SCM_VM_DATA (x
);
352 scm_puts_unlocked ("#<vm ", port
);
355 case SCM_VM_REGULAR_ENGINE
:
356 scm_puts_unlocked ("regular-engine ", port
);
359 case SCM_VM_DEBUG_ENGINE
:
360 scm_puts_unlocked ("debug-engine ", port
);
364 scm_puts_unlocked ("unknown-engine ", port
);
366 scm_uintprint (SCM_UNPACK (x
), 16, port
);
367 scm_puts_unlocked (">", port
);
375 static void vm_error (const char *msg
, SCM arg
) SCM_NORETURN
;
376 static void vm_error_bad_instruction (scm_t_uint32 inst
) SCM_NORETURN SCM_NOINLINE
;
377 static void vm_error_unbound (SCM proc
, SCM sym
) SCM_NORETURN SCM_NOINLINE
;
378 static void vm_error_unbound_fluid (SCM proc
, SCM fluid
) SCM_NORETURN SCM_NOINLINE
;
379 static void vm_error_not_a_variable (const char *func_name
, SCM x
) SCM_NORETURN SCM_NOINLINE
;
380 static void vm_error_apply_to_non_list (SCM x
) SCM_NORETURN SCM_NOINLINE
;
381 static void vm_error_kwargs_length_not_even (SCM proc
) SCM_NORETURN SCM_NOINLINE
;
382 static void vm_error_kwargs_invalid_keyword (SCM proc
, SCM obj
) SCM_NORETURN SCM_NOINLINE
;
383 static void vm_error_kwargs_unrecognized_keyword (SCM proc
, SCM kw
) SCM_NORETURN SCM_NOINLINE
;
384 static void vm_error_too_many_args (int nargs
) SCM_NORETURN SCM_NOINLINE
;
385 static void vm_error_wrong_num_args (SCM proc
) SCM_NORETURN SCM_NOINLINE
;
386 static void vm_error_wrong_type_apply (SCM proc
) SCM_NORETURN SCM_NOINLINE
;
387 static void vm_error_stack_overflow (struct scm_vm
*vp
) SCM_NORETURN SCM_NOINLINE
;
388 static void vm_error_stack_underflow (void) SCM_NORETURN SCM_NOINLINE
;
389 static void vm_error_improper_list (SCM x
) SCM_NORETURN SCM_NOINLINE
;
390 static void vm_error_not_a_pair (const char *subr
, SCM x
) SCM_NORETURN SCM_NOINLINE
;
391 static void vm_error_not_a_bytevector (const char *subr
, SCM x
) SCM_NORETURN SCM_NOINLINE
;
392 static void vm_error_not_a_struct (const char *subr
, SCM x
) SCM_NORETURN SCM_NOINLINE
;
393 static void vm_error_no_values (void) SCM_NORETURN SCM_NOINLINE
;
394 static void vm_error_not_enough_values (void) SCM_NORETURN SCM_NOINLINE
;
395 static void vm_error_wrong_number_of_values (scm_t_uint32 expected
) SCM_NORETURN SCM_NOINLINE
;
396 static void vm_error_continuation_not_rewindable (SCM cont
) SCM_NORETURN SCM_NOINLINE
;
397 static void vm_error_bad_wide_string_length (size_t len
) SCM_NORETURN SCM_NOINLINE
;
400 vm_error (const char *msg
, SCM arg
)
402 scm_throw (sym_vm_error
,
403 scm_list_3 (sym_vm_run
, scm_from_latin1_string (msg
),
404 SCM_UNBNDP (arg
) ? SCM_EOL
: scm_list_1 (arg
)));
405 abort(); /* not reached */
409 vm_error_bad_instruction (scm_t_uint32 inst
)
411 vm_error ("VM: Bad instruction: ~s", scm_from_uint32 (inst
));
415 vm_error_unbound (SCM proc
, SCM sym
)
417 scm_error_scm (scm_misc_error_key
, proc
,
418 scm_from_latin1_string ("Unbound variable: ~s"),
419 scm_list_1 (sym
), SCM_BOOL_F
);
423 vm_error_unbound_fluid (SCM proc
, SCM fluid
)
425 scm_error_scm (scm_misc_error_key
, proc
,
426 scm_from_latin1_string ("Unbound fluid: ~s"),
427 scm_list_1 (fluid
), SCM_BOOL_F
);
431 vm_error_not_a_variable (const char *func_name
, SCM x
)
433 scm_error (scm_arg_type_key
, func_name
, "Not a variable: ~S",
434 scm_list_1 (x
), scm_list_1 (x
));
438 vm_error_apply_to_non_list (SCM x
)
440 scm_error (scm_arg_type_key
, "apply", "Apply to non-list: ~S",
441 scm_list_1 (x
), scm_list_1 (x
));
445 vm_error_kwargs_length_not_even (SCM proc
)
447 scm_error_scm (sym_keyword_argument_error
, proc
,
448 scm_from_latin1_string ("Odd length of keyword argument list"),
449 SCM_EOL
, SCM_BOOL_F
);
453 vm_error_kwargs_invalid_keyword (SCM proc
, SCM obj
)
455 scm_error_scm (sym_keyword_argument_error
, proc
,
456 scm_from_latin1_string ("Invalid keyword"),
457 SCM_EOL
, scm_list_1 (obj
));
461 vm_error_kwargs_unrecognized_keyword (SCM proc
, SCM kw
)
463 scm_error_scm (sym_keyword_argument_error
, proc
,
464 scm_from_latin1_string ("Unrecognized keyword"),
465 SCM_EOL
, scm_list_1 (kw
));
469 vm_error_too_many_args (int nargs
)
471 vm_error ("VM: Too many arguments", scm_from_int (nargs
));
475 vm_error_wrong_num_args (SCM proc
)
477 scm_wrong_num_args (proc
);
481 vm_error_wrong_type_apply (SCM proc
)
483 scm_error (scm_arg_type_key
, NULL
, "Wrong type to apply: ~S",
484 scm_list_1 (proc
), scm_list_1 (proc
));
488 vm_error_stack_overflow (struct scm_vm
*vp
)
490 if (vp
->stack_limit
< vp
->stack_base
+ vp
->stack_size
)
491 /* There are VM_STACK_RESERVE_SIZE bytes left. Make them available so
492 that `throw' below can run on this VM. */
493 vp
->stack_limit
= vp
->stack_base
+ vp
->stack_size
;
495 /* There is no space left on the stack. FIXME: Do something more
498 vm_error ("VM: Stack overflow", SCM_UNDEFINED
);
502 vm_error_stack_underflow (void)
504 vm_error ("VM: Stack underflow", SCM_UNDEFINED
);
508 vm_error_improper_list (SCM x
)
510 vm_error ("Expected a proper list, but got object with tail ~s", x
);
514 vm_error_not_a_pair (const char *subr
, SCM x
)
516 scm_wrong_type_arg_msg (subr
, 1, x
, "pair");
520 vm_error_not_a_bytevector (const char *subr
, SCM x
)
522 scm_wrong_type_arg_msg (subr
, 1, x
, "bytevector");
526 vm_error_not_a_struct (const char *subr
, SCM x
)
528 scm_wrong_type_arg_msg (subr
, 1, x
, "struct");
532 vm_error_no_values (void)
534 vm_error ("Zero values returned to single-valued continuation",
539 vm_error_not_enough_values (void)
541 vm_error ("Too few values returned to continuation", SCM_UNDEFINED
);
545 vm_error_wrong_number_of_values (scm_t_uint32 expected
)
547 vm_error ("Wrong number of values returned to continuation (expected ~a)",
548 scm_from_uint32 (expected
));
552 vm_error_continuation_not_rewindable (SCM cont
)
554 vm_error ("Unrewindable partial continuation", cont
);
558 vm_error_bad_wide_string_length (size_t len
)
560 vm_error ("VM: Bad wide string length: ~S", scm_from_size_t (len
));
566 static SCM vm_boot_continuation
;
567 static SCM vm_builtin_apply
;
568 static SCM vm_builtin_values
;
569 static SCM vm_builtin_abort_to_prompt
;
570 static SCM vm_builtin_call_with_values
;
571 static SCM vm_builtin_call_with_current_continuation
;
573 static const scm_t_uint32 vm_boot_continuation_code
[] = {
574 SCM_PACK_OP_24 (halt
, 0)
577 static const scm_t_uint32 vm_builtin_apply_code
[] = {
578 SCM_PACK_OP_24 (assert_nargs_ge
, 3),
579 SCM_PACK_OP_24 (tail_apply
, 0), /* proc in r1, args from r2 */
582 static const scm_t_uint32 vm_builtin_values_code
[] = {
583 SCM_PACK_OP_24 (return_values
, 0) /* vals from r1 */
586 static const scm_t_uint32 vm_builtin_abort_to_prompt_code
[] = {
587 SCM_PACK_OP_24 (assert_nargs_ge
, 2),
588 SCM_PACK_OP_24 (abort
, 0), /* tag in r1, vals from r2 */
589 /* FIXME: Partial continuation should capture caller regs. */
590 SCM_PACK_OP_24 (return_values
, 0) /* vals from r1 */
593 static const scm_t_uint32 vm_builtin_call_with_values_code
[] = {
594 SCM_PACK_OP_24 (assert_nargs_ee
, 3),
595 SCM_PACK_OP_24 (alloc_frame
, 7),
596 SCM_PACK_OP_12_12 (mov
, 6, 1),
597 SCM_PACK_OP_24 (call
, 6), SCM_PACK_OP_ARG_8_24 (0, 1),
598 SCM_PACK_OP_12_12 (mov
, 0, 2),
599 SCM_PACK_OP_24 (tail_call_shuffle
, 7)
602 static const scm_t_uint32 vm_builtin_call_with_current_continuation_code
[] = {
603 SCM_PACK_OP_24 (assert_nargs_ee
, 2),
604 SCM_PACK_OP_24 (call_cc
, 0)
609 scm_vm_builtin_ref (unsigned idx
)
613 #define INDEX_TO_NAME(builtin, BUILTIN, req, opt, rest) \
614 case SCM_VM_BUILTIN_##BUILTIN: return vm_builtin_##builtin;
615 FOR_EACH_VM_BUILTIN(INDEX_TO_NAME
)
622 static SCM scm_sym_values
;
623 static SCM scm_sym_abort_to_prompt
;
624 static SCM scm_sym_call_with_values
;
625 static SCM scm_sym_call_with_current_continuation
;
628 scm_vm_builtin_name_to_index (SCM name
)
629 #define FUNC_NAME "builtin-name->index"
631 SCM_VALIDATE_SYMBOL (1, name
);
633 #define NAME_TO_INDEX(builtin, BUILTIN, req, opt, rest) \
634 if (scm_is_eq (name, scm_sym_##builtin)) \
635 return scm_from_uint (SCM_VM_BUILTIN_##BUILTIN);
636 FOR_EACH_VM_BUILTIN(NAME_TO_INDEX
)
644 scm_vm_builtin_index_to_name (SCM index
)
645 #define FUNC_NAME "builtin-index->name"
649 SCM_VALIDATE_UINT_COPY (1, index
, idx
);
653 #define INDEX_TO_NAME(builtin, BUILTIN, req, opt, rest) \
654 case SCM_VM_BUILTIN_##BUILTIN: return scm_sym_##builtin;
655 FOR_EACH_VM_BUILTIN(INDEX_TO_NAME
)
657 default: return SCM_BOOL_F
;
663 scm_init_vm_builtins (void)
665 scm_c_define_gsubr ("builtin-name->index", 1, 0, 0,
666 scm_vm_builtin_name_to_index
);
667 scm_c_define_gsubr ("builtin-index->name", 1, 0, 0,
668 scm_vm_builtin_index_to_name
);
672 scm_i_call_with_current_continuation (SCM proc
)
674 return scm_call_1 (vm_builtin_call_with_current_continuation
, proc
);
683 resolve_variable (SCM what
, SCM module
)
685 if (SCM_LIKELY (scm_is_symbol (what
)))
687 if (scm_is_true (module
))
688 return scm_module_lookup (module
, what
);
690 return scm_module_lookup (scm_the_root_module (), what
);
694 SCM modname
, sym
, public;
696 modname
= SCM_CAR (what
);
697 sym
= SCM_CADR (what
);
698 public = SCM_CADDR (what
);
700 if (!scm_module_system_booted_p
)
702 #ifdef VM_ENABLE_PARANOID_ASSERTIONS
703 ASSERT (scm_is_false (public));
705 (scm_equal_p (modname
,
706 scm_list_1 (scm_from_utf8_symbol ("guile")))));
708 return scm_lookup (sym
);
710 else if (scm_is_true (public))
711 return scm_public_lookup (modname
, sym
);
713 return scm_private_lookup (modname
, sym
);
717 #define VM_MIN_STACK_SIZE (1024)
718 #define VM_DEFAULT_STACK_SIZE (256 * 1024)
719 static size_t vm_stack_size
= VM_DEFAULT_STACK_SIZE
;
722 initialize_default_stack_size (void)
724 int size
= scm_getenv_int ("GUILE_STACK_SIZE", vm_stack_size
);
725 if (size
>= VM_MIN_STACK_SIZE
)
726 vm_stack_size
= size
;
729 #define VM_NAME vm_regular_engine
730 #define VM_USE_HOOKS 0
731 #define FUNC_NAME "vm-regular-engine"
732 #include "vm-engine.c"
737 #define VM_NAME vm_debug_engine
738 #define VM_USE_HOOKS 1
739 #define FUNC_NAME "vm-debug-engine"
740 #include "vm-engine.c"
745 typedef SCM (*scm_t_vm_engine
) (SCM vm
, SCM program
, SCM
*argv
, size_t nargs
);
747 static const scm_t_vm_engine vm_engines
[SCM_VM_NUM_ENGINES
] =
748 { vm_regular_engine
, vm_debug_engine
};
750 #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
752 /* The GC "kind" for the VM stack. */
753 static int vm_stack_gc_kind
;
759 #define FUNC_NAME "make_vm"
764 vp
= scm_gc_malloc (sizeof (struct scm_vm
), "vm");
766 vp
->stack_size
= vm_stack_size
;
768 #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
769 vp
->stack_base
= (SCM
*)
770 GC_generic_malloc (vp
->stack_size
* sizeof (SCM
), vm_stack_gc_kind
);
772 /* Keep a pointer to VP so that `vm_stack_mark ()' can know what the stack
774 *vp
->stack_base
= SCM_PACK_POINTER (vp
);
778 vp
->stack_base
= scm_gc_malloc (vp
->stack_size
* sizeof (SCM
),
782 vp
->stack_limit
= vp
->stack_base
+ vp
->stack_size
- VM_STACK_RESERVE_SIZE
;
784 vp
->sp
= vp
->stack_base
- 1;
786 vp
->engine
= vm_default_engine
;
788 for (i
= 0; i
< SCM_VM_NUM_HOOKS
; i
++)
789 vp
->hooks
[i
] = SCM_BOOL_F
;
790 return scm_cell (scm_tc7_vm
, (scm_t_bits
)vp
);
794 #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
796 /* Mark the VM stack region between its base and its current top. */
797 static struct GC_ms_entry
*
798 vm_stack_mark (GC_word
*addr
, struct GC_ms_entry
*mark_stack_ptr
,
799 struct GC_ms_entry
*mark_stack_limit
, GC_word env
)
802 const struct scm_vm
*vm
;
804 /* The first word of the VM stack should contain a pointer to the
806 vm
= * ((struct scm_vm
**) addr
);
809 || (SCM
*) addr
!= vm
->stack_base
- 1)
810 /* ADDR must be a pointer to a free-list element, which we must ignore
811 (see warning in <gc/gc_mark.h>). */
812 return mark_stack_ptr
;
814 for (word
= (GC_word
*) vm
->stack_base
; word
<= (GC_word
*) vm
->sp
; word
++)
815 mark_stack_ptr
= GC_MARK_AND_PUSH ((* (GC_word
**) word
),
816 mark_stack_ptr
, mark_stack_limit
,
819 return mark_stack_ptr
;
822 #endif /* VM_ENABLE_PRECISE_STACK_GC_SCAN */
826 scm_c_vm_run (SCM vm
, SCM program
, SCM
*argv
, int nargs
)
828 struct scm_vm
*vp
= SCM_VM_DATA (vm
);
830 return vm_engines
[vp
->engine
](vm
, program
, argv
, nargs
);
833 /* Scheme interface */
835 SCM_DEFINE (scm_the_vm
, "the-vm", 0, 0, 0,
837 "Return the current thread's VM.")
838 #define FUNC_NAME s_scm_the_vm
840 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
842 if (SCM_UNLIKELY (scm_is_false (t
->vm
)))
850 SCM_DEFINE (scm_vm_p
, "vm?", 1, 0, 0,
853 #define FUNC_NAME s_scm_vm_p
855 return scm_from_bool (SCM_VM_P (obj
));
859 SCM_DEFINE (scm_make_vm
, "make-vm", 0, 0, 0,
862 #define FUNC_NAME s_scm_make_vm,
868 SCM_DEFINE (scm_vm_ip
, "vm:ip", 1, 0, 0,
871 #define FUNC_NAME s_scm_vm_ip
873 SCM_VALIDATE_VM (1, vm
);
874 return scm_from_unsigned_integer ((scm_t_bits
) SCM_VM_DATA (vm
)->ip
);
878 SCM_DEFINE (scm_vm_sp
, "vm:sp", 1, 0, 0,
881 #define FUNC_NAME s_scm_vm_sp
883 SCM_VALIDATE_VM (1, vm
);
884 return scm_from_unsigned_integer ((scm_t_bits
) SCM_VM_DATA (vm
)->sp
);
888 SCM_DEFINE (scm_vm_fp
, "vm:fp", 1, 0, 0,
891 #define FUNC_NAME s_scm_vm_fp
893 SCM_VALIDATE_VM (1, vm
);
894 return scm_from_unsigned_integer ((scm_t_bits
) SCM_VM_DATA (vm
)->fp
);
898 #define VM_DEFINE_HOOK(n) \
901 SCM_VALIDATE_VM (1, vm); \
902 vp = SCM_VM_DATA (vm); \
903 if (scm_is_false (vp->hooks[n])) \
904 vp->hooks[n] = scm_make_hook (SCM_I_MAKINUM (1)); \
905 return vp->hooks[n]; \
908 SCM_DEFINE (scm_vm_apply_hook
, "vm-apply-hook", 1, 0, 0,
911 #define FUNC_NAME s_scm_vm_apply_hook
913 VM_DEFINE_HOOK (SCM_VM_APPLY_HOOK
);
917 SCM_DEFINE (scm_vm_push_continuation_hook
, "vm-push-continuation-hook", 1, 0, 0,
920 #define FUNC_NAME s_scm_vm_push_continuation_hook
922 VM_DEFINE_HOOK (SCM_VM_PUSH_CONTINUATION_HOOK
);
926 SCM_DEFINE (scm_vm_pop_continuation_hook
, "vm-pop-continuation-hook", 1, 0, 0,
929 #define FUNC_NAME s_scm_vm_pop_continuation_hook
931 VM_DEFINE_HOOK (SCM_VM_POP_CONTINUATION_HOOK
);
935 SCM_DEFINE (scm_vm_next_hook
, "vm-next-hook", 1, 0, 0,
938 #define FUNC_NAME s_scm_vm_next_hook
940 VM_DEFINE_HOOK (SCM_VM_NEXT_HOOK
);
944 SCM_DEFINE (scm_vm_abort_continuation_hook
, "vm-abort-continuation-hook", 1, 0, 0,
947 #define FUNC_NAME s_scm_vm_abort_continuation_hook
949 VM_DEFINE_HOOK (SCM_VM_ABORT_CONTINUATION_HOOK
);
953 SCM_DEFINE (scm_vm_restore_continuation_hook
, "vm-restore-continuation-hook", 1, 0, 0,
956 #define FUNC_NAME s_scm_vm_restore_continuation_hook
958 VM_DEFINE_HOOK (SCM_VM_RESTORE_CONTINUATION_HOOK
);
962 SCM_DEFINE (scm_vm_trace_level
, "vm-trace-level", 1, 0, 0,
965 #define FUNC_NAME s_scm_vm_trace_level
967 SCM_VALIDATE_VM (1, vm
);
968 return scm_from_int (SCM_VM_DATA (vm
)->trace_level
);
972 SCM_DEFINE (scm_set_vm_trace_level_x
, "set-vm-trace-level!", 2, 0, 0,
975 #define FUNC_NAME s_scm_set_vm_trace_level_x
977 SCM_VALIDATE_VM (1, vm
);
978 SCM_VM_DATA (vm
)->trace_level
= scm_to_int (level
);
979 return SCM_UNSPECIFIED
;
989 symbol_to_vm_engine (SCM engine
, const char *FUNC_NAME
)
991 if (scm_is_eq (engine
, sym_regular
))
992 return SCM_VM_REGULAR_ENGINE
;
993 else if (scm_is_eq (engine
, sym_debug
))
994 return SCM_VM_DEBUG_ENGINE
;
996 SCM_MISC_ERROR ("Unknown VM engine: ~a", scm_list_1 (engine
));
1000 vm_engine_to_symbol (int engine
, const char *FUNC_NAME
)
1004 case SCM_VM_REGULAR_ENGINE
:
1006 case SCM_VM_DEBUG_ENGINE
:
1010 SCM_MISC_ERROR ("Unknown VM engine: ~a",
1011 scm_list_1 (scm_from_int (engine
)));
1015 SCM_DEFINE (scm_vm_engine
, "vm-engine", 1, 0, 0,
1018 #define FUNC_NAME s_scm_vm_engine
1020 SCM_VALIDATE_VM (1, vm
);
1021 return vm_engine_to_symbol (SCM_VM_DATA (vm
)->engine
, FUNC_NAME
);
1026 scm_c_set_vm_engine_x (SCM vm
, int engine
)
1027 #define FUNC_NAME "set-vm-engine!"
1029 SCM_VALIDATE_VM (1, vm
);
1031 if (engine
< 0 || engine
>= SCM_VM_NUM_ENGINES
)
1032 SCM_MISC_ERROR ("Unknown VM engine: ~a",
1033 scm_list_1 (scm_from_int (engine
)));
1035 SCM_VM_DATA (vm
)->engine
= engine
;
1039 SCM_DEFINE (scm_set_vm_engine_x
, "set-vm-engine!", 2, 0, 0,
1040 (SCM vm
, SCM engine
),
1042 #define FUNC_NAME s_scm_set_vm_engine_x
1044 scm_c_set_vm_engine_x (vm
, symbol_to_vm_engine (engine
, FUNC_NAME
));
1045 return SCM_UNSPECIFIED
;
1050 scm_c_set_default_vm_engine_x (int engine
)
1051 #define FUNC_NAME "set-default-vm-engine!"
1053 if (engine
< 0 || engine
>= SCM_VM_NUM_ENGINES
)
1054 SCM_MISC_ERROR ("Unknown VM engine: ~a",
1055 scm_list_1 (scm_from_int (engine
)));
1057 vm_default_engine
= engine
;
1061 SCM_DEFINE (scm_set_default_vm_engine_x
, "set-default-vm-engine!", 1, 0, 0,
1064 #define FUNC_NAME s_scm_set_default_vm_engine_x
1066 scm_c_set_default_vm_engine_x (symbol_to_vm_engine (engine
, FUNC_NAME
));
1067 return SCM_UNSPECIFIED
;
1071 static void reinstate_vm (SCM vm
)
1073 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
1077 SCM_DEFINE (scm_call_with_vm
, "call-with-vm", 2, 0, 1,
1078 (SCM vm
, SCM proc
, SCM args
),
1079 "Apply @var{proc} to @var{args} in a dynamic extent in which\n"
1080 "@var{vm} is the current VM.\n\n"
1081 "As an implementation restriction, if @var{vm} is not the same\n"
1082 "as the current thread's VM, continuations captured within the\n"
1083 "call to @var{proc} may not be reinstated once control leaves\n"
1085 #define FUNC_NAME s_scm_call_with_vm
1090 scm_t_wind_flags flags
;
1091 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
1093 SCM_VALIDATE_VM (1, vm
);
1094 SCM_VALIDATE_PROC (2, proc
);
1096 nargs
= scm_ilength (args
);
1097 if (SCM_UNLIKELY (nargs
< 0))
1098 scm_wrong_type_arg_msg (FUNC_NAME
, 3, args
, "list");
1100 argv
= alloca (nargs
* sizeof(SCM
));
1101 for (i
= 0; i
< nargs
; i
++)
1103 argv
[i
] = SCM_CAR (args
);
1104 args
= SCM_CDR (args
);
1109 /* Reentry can happen via invokation of a saved continuation, but
1110 continuations only save the state of the VM that they are in at
1111 capture-time, which might be different from this one. So, in the
1112 case that the VMs are different, set up a non-rewindable frame to
1113 prevent reinstating an incomplete continuation. */
1114 flags
= scm_is_eq (prev_vm
, vm
) ? 0 : SCM_F_WIND_EXPLICITLY
;
1117 scm_dynwind_begin (0);
1118 scm_dynwind_unwind_handler_with_scm (reinstate_vm
, prev_vm
, flags
);
1122 ret
= scm_c_vm_run (vm
, proc
, argv
, nargs
);
1136 SCM
scm_load_compiled_with_vm (SCM file
)
1138 SCM program
= scm_load_thunk_from_file (file
);
1140 return scm_c_vm_run (scm_the_vm (), program
, NULL
, 0);
1145 scm_init_vm_builtin_properties (void)
1147 /* FIXME: Seems hacky to do this here, but oh well :/ */
1148 scm_sym_apply
= scm_from_utf8_symbol ("apply");
1149 scm_sym_values
= scm_from_utf8_symbol ("values");
1150 scm_sym_abort_to_prompt
= scm_from_utf8_symbol ("abort-to-prompt");
1151 scm_sym_call_with_values
= scm_from_utf8_symbol ("call-with-values");
1152 scm_sym_call_with_current_continuation
=
1153 scm_from_utf8_symbol ("call-with-current-continuation");
1155 #define INIT_BUILTIN(builtin, BUILTIN, req, opt, rest) \
1156 scm_set_procedure_property_x (vm_builtin_##builtin, scm_sym_name, \
1157 scm_sym_##builtin); \
1158 scm_set_procedure_minimum_arity_x (vm_builtin_##builtin, \
1159 SCM_I_MAKINUM (req), \
1160 SCM_I_MAKINUM (opt), \
1161 scm_from_bool (rest));
1162 FOR_EACH_VM_BUILTIN (INIT_BUILTIN
);
1167 scm_bootstrap_vm (void)
1169 scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION
,
1171 (scm_t_extension_init_func
)scm_init_vm
, NULL
);
1172 scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION
,
1173 "scm_init_vm_builtins",
1174 (scm_t_extension_init_func
)scm_init_vm_builtins
,
1177 initialize_default_stack_size ();
1179 sym_vm_run
= scm_from_latin1_symbol ("vm-run");
1180 sym_vm_error
= scm_from_latin1_symbol ("vm-error");
1181 sym_keyword_argument_error
= scm_from_latin1_symbol ("keyword-argument-error");
1182 sym_regular
= scm_from_latin1_symbol ("regular");
1183 sym_debug
= scm_from_latin1_symbol ("debug");
1185 vm_boot_continuation
= scm_i_make_program (vm_boot_continuation_code
);
1186 SCM_SET_CELL_WORD_0 (vm_boot_continuation
,
1187 (SCM_CELL_WORD_0 (vm_boot_continuation
)
1188 | SCM_F_PROGRAM_IS_BOOT
));
1190 #define DEFINE_BUILTIN(builtin, BUILTIN, req, opt, rest) \
1191 vm_builtin_##builtin = scm_i_make_program (vm_builtin_##builtin##_code);
1192 FOR_EACH_VM_BUILTIN (DEFINE_BUILTIN
);
1193 #undef DEFINE_BUILTIN
1195 #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
1197 GC_new_kind (GC_new_free_list (),
1198 GC_MAKE_PROC (GC_new_proc (vm_stack_mark
), 0),
1207 #ifndef SCM_MAGIC_SNARFER
1208 #include "libguile/vm.x"