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_apply_hook (SCM vm
) SCM_NOINLINE
;
172 static void vm_dispatch_push_continuation_hook (SCM vm
) SCM_NOINLINE
;
173 static void vm_dispatch_pop_continuation_hook (SCM vm
, SCM
*old_fp
) SCM_NOINLINE
;
174 static void vm_dispatch_next_hook (SCM vm
) SCM_NOINLINE
;
175 static void vm_dispatch_abort_hook (SCM vm
) SCM_NOINLINE
;
176 static void vm_dispatch_restore_continuation_hook (SCM vm
) SCM_NOINLINE
;
179 vm_dispatch_hook (SCM vm
, int hook_num
, SCM
*argv
, int n
)
183 struct scm_frame c_frame
;
185 int saved_trace_level
;
187 vp
= SCM_VM_DATA (vm
);
188 hook
= vp
->hooks
[hook_num
];
190 if (SCM_LIKELY (scm_is_false (hook
))
191 || scm_is_null (SCM_HOOK_PROCEDURES (hook
)))
194 saved_trace_level
= vp
->trace_level
;
197 /* Allocate a frame object on the stack. This is more efficient than calling
198 `scm_c_make_frame ()' to allocate on the heap, but it forces hooks to not
199 capture frame objects.
201 At the same time, procedures such as `frame-procedure' make sense only
202 while the stack frame represented by the frame object is visible, so it
203 seems reasonable to limit the lifetime of frame objects. */
205 c_frame
.stack_holder
= vm
;
206 c_frame
.fp_offset
= vp
->fp
- vp
->stack_base
;
207 c_frame
.sp_offset
= vp
->sp
- vp
->stack_base
;
210 /* Arrange for FRAME to be 8-byte aligned, like any other cell. */
211 frame
= alloca (sizeof (*frame
) + 8);
212 frame
= (scm_t_cell
*) ROUND_UP ((scm_t_uintptr
) frame
, 8UL);
214 frame
->word_0
= SCM_PACK (scm_tc7_frame
);
215 frame
->word_1
= SCM_PACK_POINTER (&c_frame
);
221 args
[0] = SCM_PACK_POINTER (frame
);
222 scm_c_run_hookn (hook
, args
, 1);
228 args
[0] = SCM_PACK_POINTER (frame
);
230 scm_c_run_hookn (hook
, args
, 2);
237 args
= scm_cons (argv
[n
], args
);
238 scm_c_run_hook (hook
, scm_cons (SCM_PACK_POINTER (frame
), args
));
241 vp
->trace_level
= saved_trace_level
;
245 vm_dispatch_apply_hook (SCM vm
)
247 return vm_dispatch_hook (vm
, SCM_VM_APPLY_HOOK
, NULL
, 0);
249 static void vm_dispatch_push_continuation_hook (SCM vm
)
251 return vm_dispatch_hook (vm
, SCM_VM_PUSH_CONTINUATION_HOOK
, NULL
, 0);
253 static void vm_dispatch_pop_continuation_hook (SCM vm
, SCM
*old_fp
)
255 struct scm_vm
*vp
= SCM_VM_DATA (vm
);
256 return vm_dispatch_hook (vm
, SCM_VM_POP_CONTINUATION_HOOK
,
257 &SCM_FRAME_LOCAL (old_fp
, 1),
258 SCM_FRAME_NUM_LOCALS (old_fp
, vp
->sp
) - 1);
260 static void vm_dispatch_next_hook (SCM vm
)
262 return vm_dispatch_hook (vm
, SCM_VM_NEXT_HOOK
, NULL
, 0);
264 static void vm_dispatch_abort_hook (SCM vm
)
266 struct scm_vm
*vp
= SCM_VM_DATA (vm
);
267 return vm_dispatch_hook (vm
, SCM_VM_ABORT_CONTINUATION_HOOK
,
268 &SCM_FRAME_LOCAL (vp
->fp
, 1),
269 SCM_FRAME_NUM_LOCALS (vp
->fp
, vp
->sp
) - 1);
271 static void vm_dispatch_restore_continuation_hook (SCM vm
)
273 return vm_dispatch_hook (vm
, SCM_VM_RESTORE_CONTINUATION_HOOK
, NULL
, 0);
277 vm_abort (SCM vm
, SCM tag
, size_t nstack
, SCM
*stack_args
, SCM tail
, SCM
*sp
,
278 scm_i_jmp_buf
*current_registers
) SCM_NORETURN
;
281 vm_abort (SCM vm
, SCM tag
, size_t nstack
, SCM
*stack_args
, SCM tail
, SCM
*sp
,
282 scm_i_jmp_buf
*current_registers
)
288 tail_len
= scm_ilength (tail
);
290 scm_misc_error ("vm-engine", "tail values to abort should be a list",
293 argv
= alloca ((nstack
+ tail_len
) * sizeof (SCM
));
294 for (i
= 0; i
< nstack
; i
++)
295 argv
[i
] = stack_args
[i
];
296 for (; i
< nstack
+ tail_len
; i
++, tail
= scm_cdr (tail
))
297 argv
[i
] = scm_car (tail
);
299 /* FIXME: NULLSTACK (SCM_VM_DATA (vp)->sp - sp) */
300 SCM_VM_DATA (vm
)->sp
= sp
;
302 scm_c_abort (vm
, tag
, nstack
+ tail_len
, argv
, current_registers
);
306 vm_reinstate_partial_continuation (SCM vm
, SCM cont
, size_t n
, SCM
*argv
,
307 scm_t_dynstack
*dynstack
,
308 scm_i_jmp_buf
*registers
)
311 struct scm_vm_cont
*cp
;
312 SCM
*argv_copy
, *base
;
316 argv_copy
= alloca (n
* sizeof(SCM
));
317 memcpy (argv_copy
, argv
, n
* sizeof(SCM
));
319 vp
= SCM_VM_DATA (vm
);
320 cp
= SCM_VM_CONT_DATA (cont
);
321 base
= SCM_FRAME_LOCALS_ADDRESS (vp
->fp
);
322 reloc
= cp
->reloc
+ (base
- cp
->stack_base
);
324 #define RELOC(scm_p) \
325 (((SCM *) (scm_p)) + reloc)
327 if ((base
- vp
->stack_base
) + cp
->stack_size
+ n
+ 1 > vp
->stack_size
)
328 scm_misc_error ("vm-engine",
329 "not enough space to instate partial continuation",
330 scm_list_2 (vm
, cont
));
332 memcpy (base
, cp
->stack_base
, cp
->stack_size
* sizeof (SCM
));
334 /* now relocate frame pointers */
337 for (fp
= RELOC (cp
->fp
);
338 SCM_FRAME_LOWER_ADDRESS (fp
) > base
;
339 fp
= SCM_FRAME_DYNAMIC_LINK (fp
))
340 SCM_FRAME_SET_DYNAMIC_LINK (fp
, RELOC (SCM_FRAME_DYNAMIC_LINK (fp
)));
343 vp
->sp
= base
- 1 + cp
->stack_size
;
344 vp
->fp
= RELOC (cp
->fp
);
347 /* Push the arguments. */
348 for (i
= 0; i
< n
; i
++)
351 *vp
->sp
= argv_copy
[i
];
354 /* The prompt captured a slice of the dynamic stack. Here we wind
355 those entries onto the current thread's stack. We also have to
356 relocate any prompts that we see along the way. */
360 for (walk
= SCM_DYNSTACK_FIRST (cp
->dynstack
);
361 SCM_DYNSTACK_TAG (walk
);
362 walk
= SCM_DYNSTACK_NEXT (walk
))
364 scm_t_bits tag
= SCM_DYNSTACK_TAG (walk
);
366 if (SCM_DYNSTACK_TAG_TYPE (tag
) == SCM_DYNSTACK_TYPE_PROMPT
)
367 scm_dynstack_wind_prompt (dynstack
, walk
, reloc
, registers
);
369 scm_dynstack_wind_1 (dynstack
, walk
);
377 * VM Internal functions
381 scm_i_vm_print (SCM x
, SCM port
, scm_print_state
*pstate
)
383 const struct scm_vm
*vm
;
385 vm
= SCM_VM_DATA (x
);
387 scm_puts_unlocked ("#<vm ", port
);
390 case SCM_VM_REGULAR_ENGINE
:
391 scm_puts_unlocked ("regular-engine ", port
);
394 case SCM_VM_DEBUG_ENGINE
:
395 scm_puts_unlocked ("debug-engine ", port
);
399 scm_puts_unlocked ("unknown-engine ", port
);
401 scm_uintprint (SCM_UNPACK (x
), 16, port
);
402 scm_puts_unlocked (">", port
);
410 static void vm_error (const char *msg
, SCM arg
) SCM_NORETURN
;
411 static void vm_error_bad_instruction (scm_t_uint32 inst
) SCM_NORETURN SCM_NOINLINE
;
412 static void vm_error_unbound (SCM proc
, SCM sym
) SCM_NORETURN SCM_NOINLINE
;
413 static void vm_error_unbound_fluid (SCM proc
, SCM fluid
) SCM_NORETURN SCM_NOINLINE
;
414 static void vm_error_not_a_variable (const char *func_name
, SCM x
) SCM_NORETURN SCM_NOINLINE
;
415 static void vm_error_apply_to_non_list (SCM x
) SCM_NORETURN SCM_NOINLINE
;
416 static void vm_error_kwargs_length_not_even (SCM proc
) SCM_NORETURN SCM_NOINLINE
;
417 static void vm_error_kwargs_invalid_keyword (SCM proc
, SCM obj
) SCM_NORETURN SCM_NOINLINE
;
418 static void vm_error_kwargs_unrecognized_keyword (SCM proc
, SCM kw
) SCM_NORETURN SCM_NOINLINE
;
419 static void vm_error_too_many_args (int nargs
) SCM_NORETURN SCM_NOINLINE
;
420 static void vm_error_wrong_num_args (SCM proc
) SCM_NORETURN SCM_NOINLINE
;
421 static void vm_error_wrong_type_apply (SCM proc
) SCM_NORETURN SCM_NOINLINE
;
422 static void vm_error_stack_overflow (struct scm_vm
*vp
) SCM_NORETURN SCM_NOINLINE
;
423 static void vm_error_stack_underflow (void) SCM_NORETURN SCM_NOINLINE
;
424 static void vm_error_improper_list (SCM x
) SCM_NORETURN SCM_NOINLINE
;
425 static void vm_error_not_a_pair (const char *subr
, SCM x
) SCM_NORETURN SCM_NOINLINE
;
426 static void vm_error_not_a_bytevector (const char *subr
, SCM x
) SCM_NORETURN SCM_NOINLINE
;
427 static void vm_error_not_a_struct (const char *subr
, SCM x
) SCM_NORETURN SCM_NOINLINE
;
428 static void vm_error_no_values (void) SCM_NORETURN SCM_NOINLINE
;
429 static void vm_error_not_enough_values (void) SCM_NORETURN SCM_NOINLINE
;
430 static void vm_error_wrong_number_of_values (scm_t_uint32 expected
) SCM_NORETURN SCM_NOINLINE
;
431 static void vm_error_continuation_not_rewindable (SCM cont
) SCM_NORETURN SCM_NOINLINE
;
432 static void vm_error_bad_wide_string_length (size_t len
) SCM_NORETURN SCM_NOINLINE
;
435 vm_error (const char *msg
, SCM arg
)
437 scm_throw (sym_vm_error
,
438 scm_list_3 (sym_vm_run
, scm_from_latin1_string (msg
),
439 SCM_UNBNDP (arg
) ? SCM_EOL
: scm_list_1 (arg
)));
440 abort(); /* not reached */
444 vm_error_bad_instruction (scm_t_uint32 inst
)
446 vm_error ("VM: Bad instruction: ~s", scm_from_uint32 (inst
));
450 vm_error_unbound (SCM proc
, SCM sym
)
452 scm_error_scm (scm_misc_error_key
, proc
,
453 scm_from_latin1_string ("Unbound variable: ~s"),
454 scm_list_1 (sym
), SCM_BOOL_F
);
458 vm_error_unbound_fluid (SCM proc
, SCM fluid
)
460 scm_error_scm (scm_misc_error_key
, proc
,
461 scm_from_latin1_string ("Unbound fluid: ~s"),
462 scm_list_1 (fluid
), SCM_BOOL_F
);
466 vm_error_not_a_variable (const char *func_name
, SCM x
)
468 scm_error (scm_arg_type_key
, func_name
, "Not a variable: ~S",
469 scm_list_1 (x
), scm_list_1 (x
));
473 vm_error_apply_to_non_list (SCM x
)
475 scm_error (scm_arg_type_key
, "apply", "Apply to non-list: ~S",
476 scm_list_1 (x
), scm_list_1 (x
));
480 vm_error_kwargs_length_not_even (SCM proc
)
482 scm_error_scm (sym_keyword_argument_error
, proc
,
483 scm_from_latin1_string ("Odd length of keyword argument list"),
484 SCM_EOL
, SCM_BOOL_F
);
488 vm_error_kwargs_invalid_keyword (SCM proc
, SCM obj
)
490 scm_error_scm (sym_keyword_argument_error
, proc
,
491 scm_from_latin1_string ("Invalid keyword"),
492 SCM_EOL
, scm_list_1 (obj
));
496 vm_error_kwargs_unrecognized_keyword (SCM proc
, SCM kw
)
498 scm_error_scm (sym_keyword_argument_error
, proc
,
499 scm_from_latin1_string ("Unrecognized keyword"),
500 SCM_EOL
, scm_list_1 (kw
));
504 vm_error_too_many_args (int nargs
)
506 vm_error ("VM: Too many arguments", scm_from_int (nargs
));
510 vm_error_wrong_num_args (SCM proc
)
512 scm_wrong_num_args (proc
);
516 vm_error_wrong_type_apply (SCM proc
)
518 scm_error (scm_arg_type_key
, NULL
, "Wrong type to apply: ~S",
519 scm_list_1 (proc
), scm_list_1 (proc
));
523 vm_error_stack_overflow (struct scm_vm
*vp
)
525 if (vp
->stack_limit
< vp
->stack_base
+ vp
->stack_size
)
526 /* There are VM_STACK_RESERVE_SIZE bytes left. Make them available so
527 that `throw' below can run on this VM. */
528 vp
->stack_limit
= vp
->stack_base
+ vp
->stack_size
;
530 /* There is no space left on the stack. FIXME: Do something more
533 vm_error ("VM: Stack overflow", SCM_UNDEFINED
);
537 vm_error_stack_underflow (void)
539 vm_error ("VM: Stack underflow", SCM_UNDEFINED
);
543 vm_error_improper_list (SCM x
)
545 vm_error ("Expected a proper list, but got object with tail ~s", x
);
549 vm_error_not_a_pair (const char *subr
, SCM x
)
551 scm_wrong_type_arg_msg (subr
, 1, x
, "pair");
555 vm_error_not_a_bytevector (const char *subr
, SCM x
)
557 scm_wrong_type_arg_msg (subr
, 1, x
, "bytevector");
561 vm_error_not_a_struct (const char *subr
, SCM x
)
563 scm_wrong_type_arg_msg (subr
, 1, x
, "struct");
567 vm_error_no_values (void)
569 vm_error ("Zero values returned to single-valued continuation",
574 vm_error_not_enough_values (void)
576 vm_error ("Too few values returned to continuation", SCM_UNDEFINED
);
580 vm_error_wrong_number_of_values (scm_t_uint32 expected
)
582 vm_error ("Wrong number of values returned to continuation (expected ~a)",
583 scm_from_uint32 (expected
));
587 vm_error_continuation_not_rewindable (SCM cont
)
589 vm_error ("Unrewindable partial continuation", cont
);
593 vm_error_bad_wide_string_length (size_t len
)
595 vm_error ("VM: Bad wide string length: ~S", scm_from_size_t (len
));
601 static SCM vm_boot_continuation
;
602 static SCM vm_builtin_apply
;
603 static SCM vm_builtin_values
;
604 static SCM vm_builtin_abort_to_prompt
;
605 static SCM vm_builtin_call_with_values
;
606 static SCM vm_builtin_call_with_current_continuation
;
608 static const scm_t_uint32 vm_boot_continuation_code
[] = {
609 SCM_PACK_OP_24 (halt
, 0)
612 static const scm_t_uint32 vm_builtin_apply_code
[] = {
613 SCM_PACK_OP_24 (assert_nargs_ge
, 3),
614 SCM_PACK_OP_24 (tail_apply
, 0), /* proc in r1, args from r2 */
617 static const scm_t_uint32 vm_builtin_values_code
[] = {
618 SCM_PACK_OP_24 (return_values
, 0) /* vals from r1 */
621 static const scm_t_uint32 vm_builtin_abort_to_prompt_code
[] = {
622 SCM_PACK_OP_24 (assert_nargs_ge
, 2),
623 SCM_PACK_OP_24 (abort
, 0), /* tag in r1, vals from r2 */
624 /* FIXME: Partial continuation should capture caller regs. */
625 SCM_PACK_OP_24 (return_values
, 0) /* vals from r1 */
628 static const scm_t_uint32 vm_builtin_call_with_values_code
[] = {
629 SCM_PACK_OP_24 (assert_nargs_ee
, 3),
630 SCM_PACK_OP_24 (alloc_frame
, 7),
631 SCM_PACK_OP_12_12 (mov
, 6, 1),
632 SCM_PACK_OP_24 (call
, 6), SCM_PACK_OP_ARG_8_24 (0, 1),
633 SCM_PACK_OP_12_12 (mov
, 0, 2),
634 SCM_PACK_OP_24 (tail_call_shuffle
, 7)
637 static const scm_t_uint32 vm_builtin_call_with_current_continuation_code
[] = {
638 SCM_PACK_OP_24 (assert_nargs_ee
, 2),
639 SCM_PACK_OP_24 (call_cc
, 0)
644 scm_vm_builtin_ref (unsigned idx
)
648 #define INDEX_TO_NAME(builtin, BUILTIN, req, opt, rest) \
649 case SCM_VM_BUILTIN_##BUILTIN: return vm_builtin_##builtin;
650 FOR_EACH_VM_BUILTIN(INDEX_TO_NAME
)
657 static SCM scm_sym_values
;
658 static SCM scm_sym_abort_to_prompt
;
659 static SCM scm_sym_call_with_values
;
660 static SCM scm_sym_call_with_current_continuation
;
663 scm_vm_builtin_name_to_index (SCM name
)
664 #define FUNC_NAME "builtin-name->index"
666 SCM_VALIDATE_SYMBOL (1, name
);
668 #define NAME_TO_INDEX(builtin, BUILTIN, req, opt, rest) \
669 if (scm_is_eq (name, scm_sym_##builtin)) \
670 return scm_from_uint (SCM_VM_BUILTIN_##BUILTIN);
671 FOR_EACH_VM_BUILTIN(NAME_TO_INDEX
)
679 scm_vm_builtin_index_to_name (SCM index
)
680 #define FUNC_NAME "builtin-index->name"
684 SCM_VALIDATE_UINT_COPY (1, index
, idx
);
688 #define INDEX_TO_NAME(builtin, BUILTIN, req, opt, rest) \
689 case SCM_VM_BUILTIN_##BUILTIN: return scm_sym_##builtin;
690 FOR_EACH_VM_BUILTIN(INDEX_TO_NAME
)
692 default: return SCM_BOOL_F
;
698 scm_init_vm_builtins (void)
700 scm_c_define_gsubr ("builtin-name->index", 1, 0, 0,
701 scm_vm_builtin_name_to_index
);
702 scm_c_define_gsubr ("builtin-index->name", 1, 0, 0,
703 scm_vm_builtin_index_to_name
);
707 scm_i_call_with_current_continuation (SCM proc
)
709 return scm_call_1 (vm_builtin_call_with_current_continuation
, proc
);
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 #define VM_DEFINE_HOOK(n) \
862 SCM_VALIDATE_VM (1, vm); \
863 vp = SCM_VM_DATA (vm); \
864 if (scm_is_false (vp->hooks[n])) \
865 vp->hooks[n] = scm_make_hook (SCM_I_MAKINUM (1)); \
866 return vp->hooks[n]; \
869 SCM_DEFINE (scm_vm_apply_hook
, "vm-apply-hook", 1, 0, 0,
872 #define FUNC_NAME s_scm_vm_apply_hook
874 VM_DEFINE_HOOK (SCM_VM_APPLY_HOOK
);
878 SCM_DEFINE (scm_vm_push_continuation_hook
, "vm-push-continuation-hook", 1, 0, 0,
881 #define FUNC_NAME s_scm_vm_push_continuation_hook
883 VM_DEFINE_HOOK (SCM_VM_PUSH_CONTINUATION_HOOK
);
887 SCM_DEFINE (scm_vm_pop_continuation_hook
, "vm-pop-continuation-hook", 1, 0, 0,
890 #define FUNC_NAME s_scm_vm_pop_continuation_hook
892 VM_DEFINE_HOOK (SCM_VM_POP_CONTINUATION_HOOK
);
896 SCM_DEFINE (scm_vm_next_hook
, "vm-next-hook", 1, 0, 0,
899 #define FUNC_NAME s_scm_vm_next_hook
901 VM_DEFINE_HOOK (SCM_VM_NEXT_HOOK
);
905 SCM_DEFINE (scm_vm_abort_continuation_hook
, "vm-abort-continuation-hook", 1, 0, 0,
908 #define FUNC_NAME s_scm_vm_abort_continuation_hook
910 VM_DEFINE_HOOK (SCM_VM_ABORT_CONTINUATION_HOOK
);
914 SCM_DEFINE (scm_vm_restore_continuation_hook
, "vm-restore-continuation-hook", 1, 0, 0,
917 #define FUNC_NAME s_scm_vm_restore_continuation_hook
919 VM_DEFINE_HOOK (SCM_VM_RESTORE_CONTINUATION_HOOK
);
923 SCM_DEFINE (scm_vm_trace_level
, "vm-trace-level", 1, 0, 0,
926 #define FUNC_NAME s_scm_vm_trace_level
928 SCM_VALIDATE_VM (1, vm
);
929 return scm_from_int (SCM_VM_DATA (vm
)->trace_level
);
933 SCM_DEFINE (scm_set_vm_trace_level_x
, "set-vm-trace-level!", 2, 0, 0,
936 #define FUNC_NAME s_scm_set_vm_trace_level_x
938 SCM_VALIDATE_VM (1, vm
);
939 SCM_VM_DATA (vm
)->trace_level
= scm_to_int (level
);
940 return SCM_UNSPECIFIED
;
950 symbol_to_vm_engine (SCM engine
, const char *FUNC_NAME
)
952 if (scm_is_eq (engine
, sym_regular
))
953 return SCM_VM_REGULAR_ENGINE
;
954 else if (scm_is_eq (engine
, sym_debug
))
955 return SCM_VM_DEBUG_ENGINE
;
957 SCM_MISC_ERROR ("Unknown VM engine: ~a", scm_list_1 (engine
));
961 vm_engine_to_symbol (int engine
, const char *FUNC_NAME
)
965 case SCM_VM_REGULAR_ENGINE
:
967 case SCM_VM_DEBUG_ENGINE
:
971 SCM_MISC_ERROR ("Unknown VM engine: ~a",
972 scm_list_1 (scm_from_int (engine
)));
976 SCM_DEFINE (scm_vm_engine
, "vm-engine", 1, 0, 0,
979 #define FUNC_NAME s_scm_vm_engine
981 SCM_VALIDATE_VM (1, vm
);
982 return vm_engine_to_symbol (SCM_VM_DATA (vm
)->engine
, FUNC_NAME
);
987 scm_c_set_vm_engine_x (SCM vm
, int engine
)
988 #define FUNC_NAME "set-vm-engine!"
990 SCM_VALIDATE_VM (1, vm
);
992 if (engine
< 0 || engine
>= SCM_VM_NUM_ENGINES
)
993 SCM_MISC_ERROR ("Unknown VM engine: ~a",
994 scm_list_1 (scm_from_int (engine
)));
996 SCM_VM_DATA (vm
)->engine
= engine
;
1000 SCM_DEFINE (scm_set_vm_engine_x
, "set-vm-engine!", 2, 0, 0,
1001 (SCM vm
, SCM engine
),
1003 #define FUNC_NAME s_scm_set_vm_engine_x
1005 scm_c_set_vm_engine_x (vm
, symbol_to_vm_engine (engine
, FUNC_NAME
));
1006 return SCM_UNSPECIFIED
;
1011 scm_c_set_default_vm_engine_x (int engine
)
1012 #define FUNC_NAME "set-default-vm-engine!"
1014 if (engine
< 0 || engine
>= SCM_VM_NUM_ENGINES
)
1015 SCM_MISC_ERROR ("Unknown VM engine: ~a",
1016 scm_list_1 (scm_from_int (engine
)));
1018 vm_default_engine
= engine
;
1022 SCM_DEFINE (scm_set_default_vm_engine_x
, "set-default-vm-engine!", 1, 0, 0,
1025 #define FUNC_NAME s_scm_set_default_vm_engine_x
1027 scm_c_set_default_vm_engine_x (symbol_to_vm_engine (engine
, FUNC_NAME
));
1028 return SCM_UNSPECIFIED
;
1032 static void reinstate_vm (SCM vm
)
1034 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
1038 SCM_DEFINE (scm_call_with_vm
, "call-with-vm", 2, 0, 1,
1039 (SCM vm
, SCM proc
, SCM args
),
1040 "Apply @var{proc} to @var{args} in a dynamic extent in which\n"
1041 "@var{vm} is the current VM.\n\n"
1042 "As an implementation restriction, if @var{vm} is not the same\n"
1043 "as the current thread's VM, continuations captured within the\n"
1044 "call to @var{proc} may not be reinstated once control leaves\n"
1046 #define FUNC_NAME s_scm_call_with_vm
1051 scm_t_wind_flags flags
;
1052 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
1054 SCM_VALIDATE_VM (1, vm
);
1055 SCM_VALIDATE_PROC (2, proc
);
1057 nargs
= scm_ilength (args
);
1058 if (SCM_UNLIKELY (nargs
< 0))
1059 scm_wrong_type_arg_msg (FUNC_NAME
, 3, args
, "list");
1061 argv
= alloca (nargs
* sizeof(SCM
));
1062 for (i
= 0; i
< nargs
; i
++)
1064 argv
[i
] = SCM_CAR (args
);
1065 args
= SCM_CDR (args
);
1070 /* Reentry can happen via invokation of a saved continuation, but
1071 continuations only save the state of the VM that they are in at
1072 capture-time, which might be different from this one. So, in the
1073 case that the VMs are different, set up a non-rewindable frame to
1074 prevent reinstating an incomplete continuation. */
1075 flags
= scm_is_eq (prev_vm
, vm
) ? 0 : SCM_F_WIND_EXPLICITLY
;
1078 scm_dynwind_begin (0);
1079 scm_dynwind_unwind_handler_with_scm (reinstate_vm
, prev_vm
, flags
);
1083 ret
= scm_c_vm_run (vm
, proc
, argv
, nargs
);
1097 SCM
scm_load_compiled_with_vm (SCM file
)
1099 SCM program
= scm_load_thunk_from_file (file
);
1101 return scm_c_vm_run (scm_the_vm (), program
, NULL
, 0);
1106 scm_init_vm_builtin_properties (void)
1108 /* FIXME: Seems hacky to do this here, but oh well :/ */
1109 scm_sym_apply
= scm_from_utf8_symbol ("apply");
1110 scm_sym_values
= scm_from_utf8_symbol ("values");
1111 scm_sym_abort_to_prompt
= scm_from_utf8_symbol ("abort-to-prompt");
1112 scm_sym_call_with_values
= scm_from_utf8_symbol ("call-with-values");
1113 scm_sym_call_with_current_continuation
=
1114 scm_from_utf8_symbol ("call-with-current-continuation");
1116 #define INIT_BUILTIN(builtin, BUILTIN, req, opt, rest) \
1117 scm_set_procedure_property_x (vm_builtin_##builtin, scm_sym_name, \
1118 scm_sym_##builtin); \
1119 scm_set_procedure_minimum_arity_x (vm_builtin_##builtin, \
1120 SCM_I_MAKINUM (req), \
1121 SCM_I_MAKINUM (opt), \
1122 scm_from_bool (rest));
1123 FOR_EACH_VM_BUILTIN (INIT_BUILTIN
);
1128 scm_bootstrap_vm (void)
1130 scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION
,
1132 (scm_t_extension_init_func
)scm_init_vm
, NULL
);
1133 scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION
,
1134 "scm_init_vm_builtins",
1135 (scm_t_extension_init_func
)scm_init_vm_builtins
,
1138 initialize_default_stack_size ();
1140 sym_vm_run
= scm_from_latin1_symbol ("vm-run");
1141 sym_vm_error
= scm_from_latin1_symbol ("vm-error");
1142 sym_keyword_argument_error
= scm_from_latin1_symbol ("keyword-argument-error");
1143 sym_regular
= scm_from_latin1_symbol ("regular");
1144 sym_debug
= scm_from_latin1_symbol ("debug");
1146 vm_boot_continuation
= scm_i_make_program (vm_boot_continuation_code
);
1147 SCM_SET_CELL_WORD_0 (vm_boot_continuation
,
1148 (SCM_CELL_WORD_0 (vm_boot_continuation
)
1149 | SCM_F_PROGRAM_IS_BOOT
));
1151 #define DEFINE_BUILTIN(builtin, BUILTIN, req, opt, rest) \
1152 vm_builtin_##builtin = scm_i_make_program (vm_builtin_##builtin##_code);
1153 FOR_EACH_VM_BUILTIN (DEFINE_BUILTIN
);
1154 #undef DEFINE_BUILTIN
1156 #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
1158 GC_new_kind (GC_new_free_list (),
1159 GC_MAKE_PROC (GC_new_proc (vm_stack_mark
), 0),
1168 #ifndef SCM_MAGIC_SNARFER
1169 #include "libguile/vm.x"