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
;
211 /* Arrange for FRAME to be 8-byte aligned, like any other cell. */
212 frame
= alloca (sizeof (*frame
) + 8);
213 frame
= (scm_t_cell
*) ROUND_UP ((scm_t_uintptr
) frame
, 8UL);
215 frame
->word_0
= SCM_PACK (scm_tc7_frame
);
216 frame
->word_1
= SCM_PACK_POINTER (&c_frame
);
222 args
[0] = SCM_PACK_POINTER (frame
);
223 scm_c_run_hookn (hook
, args
, 1);
229 args
[0] = SCM_PACK_POINTER (frame
);
231 scm_c_run_hookn (hook
, args
, 2);
238 args
= scm_cons (argv
[n
], args
);
239 scm_c_run_hook (hook
, scm_cons (SCM_PACK_POINTER (frame
), args
));
242 vp
->trace_level
= saved_trace_level
;
246 vm_dispatch_apply_hook (SCM vm
)
248 return vm_dispatch_hook (vm
, SCM_VM_APPLY_HOOK
, NULL
, 0);
250 static void vm_dispatch_push_continuation_hook (SCM vm
)
252 return vm_dispatch_hook (vm
, SCM_VM_PUSH_CONTINUATION_HOOK
, NULL
, 0);
254 static void vm_dispatch_pop_continuation_hook (SCM vm
, SCM
*old_fp
)
256 struct scm_vm
*vp
= SCM_VM_DATA (vm
);
257 return vm_dispatch_hook (vm
, SCM_VM_POP_CONTINUATION_HOOK
,
258 &SCM_FRAME_LOCAL (old_fp
, 1),
259 SCM_FRAME_NUM_LOCALS (old_fp
, vp
->sp
) - 1);
261 static void vm_dispatch_next_hook (SCM vm
)
263 return vm_dispatch_hook (vm
, SCM_VM_NEXT_HOOK
, NULL
, 0);
265 static void vm_dispatch_abort_hook (SCM vm
)
267 struct scm_vm
*vp
= SCM_VM_DATA (vm
);
268 return vm_dispatch_hook (vm
, SCM_VM_ABORT_CONTINUATION_HOOK
,
269 &SCM_FRAME_LOCAL (vp
->fp
, 1),
270 SCM_FRAME_NUM_LOCALS (vp
->fp
, vp
->sp
) - 1);
272 static void vm_dispatch_restore_continuation_hook (SCM vm
)
274 return vm_dispatch_hook (vm
, SCM_VM_RESTORE_CONTINUATION_HOOK
, NULL
, 0);
278 vm_abort (SCM vm
, SCM tag
, size_t nstack
, SCM
*stack_args
, SCM tail
, SCM
*sp
,
279 scm_i_jmp_buf
*current_registers
) SCM_NORETURN
;
282 vm_abort (SCM vm
, SCM tag
, size_t nstack
, SCM
*stack_args
, SCM tail
, SCM
*sp
,
283 scm_i_jmp_buf
*current_registers
)
289 tail_len
= scm_ilength (tail
);
291 scm_misc_error ("vm-engine", "tail values to abort should be a list",
294 argv
= alloca ((nstack
+ tail_len
) * sizeof (SCM
));
295 for (i
= 0; i
< nstack
; i
++)
296 argv
[i
] = stack_args
[i
];
297 for (; i
< nstack
+ tail_len
; i
++, tail
= scm_cdr (tail
))
298 argv
[i
] = scm_car (tail
);
300 /* FIXME: NULLSTACK (SCM_VM_DATA (vp)->sp - sp) */
301 SCM_VM_DATA (vm
)->sp
= sp
;
303 scm_c_abort (vm
, tag
, nstack
+ tail_len
, argv
, current_registers
);
307 vm_reinstate_partial_continuation (SCM vm
, SCM cont
, size_t n
, SCM
*argv
,
308 scm_t_dynstack
*dynstack
,
309 scm_i_jmp_buf
*registers
)
312 struct scm_vm_cont
*cp
;
313 SCM
*argv_copy
, *base
;
317 argv_copy
= alloca (n
* sizeof(SCM
));
318 memcpy (argv_copy
, argv
, n
* sizeof(SCM
));
320 vp
= SCM_VM_DATA (vm
);
321 cp
= SCM_VM_CONT_DATA (cont
);
322 base
= SCM_FRAME_LOCALS_ADDRESS (vp
->fp
);
323 reloc
= cp
->reloc
+ (base
- cp
->stack_base
);
325 #define RELOC(scm_p) \
326 (((SCM *) (scm_p)) + reloc)
328 if ((base
- vp
->stack_base
) + cp
->stack_size
+ n
+ 1 > vp
->stack_size
)
329 scm_misc_error ("vm-engine",
330 "not enough space to instate partial continuation",
331 scm_list_2 (vm
, cont
));
333 memcpy (base
, cp
->stack_base
, cp
->stack_size
* sizeof (SCM
));
335 /* now relocate frame pointers */
338 for (fp
= RELOC (cp
->fp
);
339 SCM_FRAME_LOWER_ADDRESS (fp
) > base
;
340 fp
= SCM_FRAME_DYNAMIC_LINK (fp
))
341 SCM_FRAME_SET_DYNAMIC_LINK (fp
, RELOC (SCM_FRAME_DYNAMIC_LINK (fp
)));
344 vp
->sp
= base
- 1 + cp
->stack_size
;
345 vp
->fp
= RELOC (cp
->fp
);
348 /* Push the arguments. */
349 for (i
= 0; i
< n
; i
++)
352 *vp
->sp
= argv_copy
[i
];
355 /* The prompt captured a slice of the dynamic stack. Here we wind
356 those entries onto the current thread's stack. We also have to
357 relocate any prompts that we see along the way. */
361 for (walk
= SCM_DYNSTACK_FIRST (cp
->dynstack
);
362 SCM_DYNSTACK_TAG (walk
);
363 walk
= SCM_DYNSTACK_NEXT (walk
))
365 scm_t_bits tag
= SCM_DYNSTACK_TAG (walk
);
367 if (SCM_DYNSTACK_TAG_TYPE (tag
) == SCM_DYNSTACK_TYPE_PROMPT
)
368 scm_dynstack_wind_prompt (dynstack
, walk
, reloc
, registers
);
370 scm_dynstack_wind_1 (dynstack
, walk
);
378 * VM Internal functions
382 scm_i_vm_print (SCM x
, SCM port
, scm_print_state
*pstate
)
384 const struct scm_vm
*vm
;
386 vm
= SCM_VM_DATA (x
);
388 scm_puts_unlocked ("#<vm ", port
);
391 case SCM_VM_REGULAR_ENGINE
:
392 scm_puts_unlocked ("regular-engine ", port
);
395 case SCM_VM_DEBUG_ENGINE
:
396 scm_puts_unlocked ("debug-engine ", port
);
400 scm_puts_unlocked ("unknown-engine ", port
);
402 scm_uintprint (SCM_UNPACK (x
), 16, port
);
403 scm_puts_unlocked (">", port
);
411 static void vm_error (const char *msg
, SCM arg
) SCM_NORETURN
;
412 static void vm_error_bad_instruction (scm_t_uint32 inst
) SCM_NORETURN SCM_NOINLINE
;
413 static void vm_error_unbound (SCM proc
, SCM sym
) SCM_NORETURN SCM_NOINLINE
;
414 static void vm_error_unbound_fluid (SCM proc
, SCM fluid
) SCM_NORETURN SCM_NOINLINE
;
415 static void vm_error_not_a_variable (const char *func_name
, SCM x
) SCM_NORETURN SCM_NOINLINE
;
416 static void vm_error_apply_to_non_list (SCM x
) SCM_NORETURN SCM_NOINLINE
;
417 static void vm_error_kwargs_length_not_even (SCM proc
) SCM_NORETURN SCM_NOINLINE
;
418 static void vm_error_kwargs_invalid_keyword (SCM proc
, SCM obj
) SCM_NORETURN SCM_NOINLINE
;
419 static void vm_error_kwargs_unrecognized_keyword (SCM proc
, SCM kw
) SCM_NORETURN SCM_NOINLINE
;
420 static void vm_error_too_many_args (int nargs
) SCM_NORETURN SCM_NOINLINE
;
421 static void vm_error_wrong_num_args (SCM proc
) SCM_NORETURN SCM_NOINLINE
;
422 static void vm_error_wrong_type_apply (SCM proc
) SCM_NORETURN SCM_NOINLINE
;
423 static void vm_error_stack_overflow (struct scm_vm
*vp
) SCM_NORETURN SCM_NOINLINE
;
424 static void vm_error_stack_underflow (void) SCM_NORETURN SCM_NOINLINE
;
425 static void vm_error_improper_list (SCM x
) SCM_NORETURN SCM_NOINLINE
;
426 static void vm_error_not_a_pair (const char *subr
, SCM x
) SCM_NORETURN SCM_NOINLINE
;
427 static void vm_error_not_a_bytevector (const char *subr
, SCM x
) SCM_NORETURN SCM_NOINLINE
;
428 static void vm_error_not_a_struct (const char *subr
, SCM x
) SCM_NORETURN SCM_NOINLINE
;
429 static void vm_error_no_values (void) SCM_NORETURN SCM_NOINLINE
;
430 static void vm_error_not_enough_values (void) SCM_NORETURN SCM_NOINLINE
;
431 static void vm_error_wrong_number_of_values (scm_t_uint32 expected
) SCM_NORETURN SCM_NOINLINE
;
432 static void vm_error_continuation_not_rewindable (SCM cont
) SCM_NORETURN SCM_NOINLINE
;
433 static void vm_error_bad_wide_string_length (size_t len
) SCM_NORETURN SCM_NOINLINE
;
436 vm_error (const char *msg
, SCM arg
)
438 scm_throw (sym_vm_error
,
439 scm_list_3 (sym_vm_run
, scm_from_latin1_string (msg
),
440 SCM_UNBNDP (arg
) ? SCM_EOL
: scm_list_1 (arg
)));
441 abort(); /* not reached */
445 vm_error_bad_instruction (scm_t_uint32 inst
)
447 vm_error ("VM: Bad instruction: ~s", scm_from_uint32 (inst
));
451 vm_error_unbound (SCM proc
, SCM sym
)
453 scm_error_scm (scm_misc_error_key
, proc
,
454 scm_from_latin1_string ("Unbound variable: ~s"),
455 scm_list_1 (sym
), SCM_BOOL_F
);
459 vm_error_unbound_fluid (SCM proc
, SCM fluid
)
461 scm_error_scm (scm_misc_error_key
, proc
,
462 scm_from_latin1_string ("Unbound fluid: ~s"),
463 scm_list_1 (fluid
), SCM_BOOL_F
);
467 vm_error_not_a_variable (const char *func_name
, SCM x
)
469 scm_error (scm_arg_type_key
, func_name
, "Not a variable: ~S",
470 scm_list_1 (x
), scm_list_1 (x
));
474 vm_error_apply_to_non_list (SCM x
)
476 scm_error (scm_arg_type_key
, "apply", "Apply to non-list: ~S",
477 scm_list_1 (x
), scm_list_1 (x
));
481 vm_error_kwargs_length_not_even (SCM proc
)
483 scm_error_scm (sym_keyword_argument_error
, proc
,
484 scm_from_latin1_string ("Odd length of keyword argument list"),
485 SCM_EOL
, SCM_BOOL_F
);
489 vm_error_kwargs_invalid_keyword (SCM proc
, SCM obj
)
491 scm_error_scm (sym_keyword_argument_error
, proc
,
492 scm_from_latin1_string ("Invalid keyword"),
493 SCM_EOL
, scm_list_1 (obj
));
497 vm_error_kwargs_unrecognized_keyword (SCM proc
, SCM kw
)
499 scm_error_scm (sym_keyword_argument_error
, proc
,
500 scm_from_latin1_string ("Unrecognized keyword"),
501 SCM_EOL
, scm_list_1 (kw
));
505 vm_error_too_many_args (int nargs
)
507 vm_error ("VM: Too many arguments", scm_from_int (nargs
));
511 vm_error_wrong_num_args (SCM proc
)
513 scm_wrong_num_args (proc
);
517 vm_error_wrong_type_apply (SCM proc
)
519 scm_error (scm_arg_type_key
, NULL
, "Wrong type to apply: ~S",
520 scm_list_1 (proc
), scm_list_1 (proc
));
524 vm_error_stack_overflow (struct scm_vm
*vp
)
526 if (vp
->stack_limit
< vp
->stack_base
+ vp
->stack_size
)
527 /* There are VM_STACK_RESERVE_SIZE bytes left. Make them available so
528 that `throw' below can run on this VM. */
529 vp
->stack_limit
= vp
->stack_base
+ vp
->stack_size
;
531 /* There is no space left on the stack. FIXME: Do something more
534 vm_error ("VM: Stack overflow", SCM_UNDEFINED
);
538 vm_error_stack_underflow (void)
540 vm_error ("VM: Stack underflow", SCM_UNDEFINED
);
544 vm_error_improper_list (SCM x
)
546 vm_error ("Expected a proper list, but got object with tail ~s", x
);
550 vm_error_not_a_pair (const char *subr
, SCM x
)
552 scm_wrong_type_arg_msg (subr
, 1, x
, "pair");
556 vm_error_not_a_bytevector (const char *subr
, SCM x
)
558 scm_wrong_type_arg_msg (subr
, 1, x
, "bytevector");
562 vm_error_not_a_struct (const char *subr
, SCM x
)
564 scm_wrong_type_arg_msg (subr
, 1, x
, "struct");
568 vm_error_no_values (void)
570 vm_error ("Zero values returned to single-valued continuation",
575 vm_error_not_enough_values (void)
577 vm_error ("Too few values returned to continuation", SCM_UNDEFINED
);
581 vm_error_wrong_number_of_values (scm_t_uint32 expected
)
583 vm_error ("Wrong number of values returned to continuation (expected ~a)",
584 scm_from_uint32 (expected
));
588 vm_error_continuation_not_rewindable (SCM cont
)
590 vm_error ("Unrewindable partial continuation", cont
);
594 vm_error_bad_wide_string_length (size_t len
)
596 vm_error ("VM: Bad wide string length: ~S", scm_from_size_t (len
));
602 static SCM vm_boot_continuation
;
603 static SCM vm_builtin_apply
;
604 static SCM vm_builtin_values
;
605 static SCM vm_builtin_abort_to_prompt
;
606 static SCM vm_builtin_call_with_values
;
607 static SCM vm_builtin_call_with_current_continuation
;
609 static const scm_t_uint32 vm_boot_continuation_code
[] = {
610 SCM_PACK_OP_24 (halt
, 0)
613 static const scm_t_uint32 vm_builtin_apply_code
[] = {
614 SCM_PACK_OP_24 (assert_nargs_ge
, 3),
615 SCM_PACK_OP_24 (tail_apply
, 0), /* proc in r1, args from r2 */
618 static const scm_t_uint32 vm_builtin_values_code
[] = {
619 SCM_PACK_OP_24 (return_values
, 0) /* vals from r1 */
622 static const scm_t_uint32 vm_builtin_abort_to_prompt_code
[] = {
623 SCM_PACK_OP_24 (assert_nargs_ge
, 2),
624 SCM_PACK_OP_24 (abort
, 0), /* tag in r1, vals from r2 */
625 /* FIXME: Partial continuation should capture caller regs. */
626 SCM_PACK_OP_24 (return_values
, 0) /* vals from r1 */
629 static const scm_t_uint32 vm_builtin_call_with_values_code
[] = {
630 SCM_PACK_OP_24 (assert_nargs_ee
, 3),
631 SCM_PACK_OP_24 (alloc_frame
, 7),
632 SCM_PACK_OP_12_12 (mov
, 6, 1),
633 SCM_PACK_OP_24 (call
, 6), SCM_PACK_OP_ARG_8_24 (0, 1),
634 SCM_PACK_OP_12_12 (mov
, 0, 2),
635 SCM_PACK_OP_24 (tail_call_shuffle
, 7)
638 static const scm_t_uint32 vm_builtin_call_with_current_continuation_code
[] = {
639 SCM_PACK_OP_24 (assert_nargs_ee
, 2),
640 SCM_PACK_OP_24 (call_cc
, 0)
645 scm_vm_builtin_ref (unsigned idx
)
649 #define INDEX_TO_NAME(builtin, BUILTIN, req, opt, rest) \
650 case SCM_VM_BUILTIN_##BUILTIN: return vm_builtin_##builtin;
651 FOR_EACH_VM_BUILTIN(INDEX_TO_NAME
)
658 static SCM scm_sym_values
;
659 static SCM scm_sym_abort_to_prompt
;
660 static SCM scm_sym_call_with_values
;
661 static SCM scm_sym_call_with_current_continuation
;
664 scm_vm_builtin_name_to_index (SCM name
)
665 #define FUNC_NAME "builtin-name->index"
667 SCM_VALIDATE_SYMBOL (1, name
);
669 #define NAME_TO_INDEX(builtin, BUILTIN, req, opt, rest) \
670 if (scm_is_eq (name, scm_sym_##builtin)) \
671 return scm_from_uint (SCM_VM_BUILTIN_##BUILTIN);
672 FOR_EACH_VM_BUILTIN(NAME_TO_INDEX
)
680 scm_vm_builtin_index_to_name (SCM index
)
681 #define FUNC_NAME "builtin-index->name"
685 SCM_VALIDATE_UINT_COPY (1, index
, idx
);
689 #define INDEX_TO_NAME(builtin, BUILTIN, req, opt, rest) \
690 case SCM_VM_BUILTIN_##BUILTIN: return scm_sym_##builtin;
691 FOR_EACH_VM_BUILTIN(INDEX_TO_NAME
)
693 default: return SCM_BOOL_F
;
699 scm_init_vm_builtins (void)
701 scm_c_define_gsubr ("builtin-name->index", 1, 0, 0,
702 scm_vm_builtin_name_to_index
);
703 scm_c_define_gsubr ("builtin-index->name", 1, 0, 0,
704 scm_vm_builtin_index_to_name
);
708 scm_i_call_with_current_continuation (SCM proc
)
710 return scm_call_1 (vm_builtin_call_with_current_continuation
, proc
);
718 #define VM_MIN_STACK_SIZE (1024)
719 #define VM_DEFAULT_STACK_SIZE (256 * 1024)
720 static size_t vm_stack_size
= VM_DEFAULT_STACK_SIZE
;
723 initialize_default_stack_size (void)
725 int size
= scm_getenv_int ("GUILE_STACK_SIZE", vm_stack_size
);
726 if (size
>= VM_MIN_STACK_SIZE
)
727 vm_stack_size
= size
;
730 #define VM_NAME vm_regular_engine
731 #define VM_USE_HOOKS 0
732 #define FUNC_NAME "vm-regular-engine"
733 #include "vm-engine.c"
738 #define VM_NAME vm_debug_engine
739 #define VM_USE_HOOKS 1
740 #define FUNC_NAME "vm-debug-engine"
741 #include "vm-engine.c"
746 typedef SCM (*scm_t_vm_engine
) (SCM vm
, SCM program
, SCM
*argv
, size_t nargs
);
748 static const scm_t_vm_engine vm_engines
[SCM_VM_NUM_ENGINES
] =
749 { vm_regular_engine
, vm_debug_engine
};
751 #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
753 /* The GC "kind" for the VM stack. */
754 static int vm_stack_gc_kind
;
760 #define FUNC_NAME "make_vm"
765 vp
= scm_gc_malloc (sizeof (struct scm_vm
), "vm");
767 vp
->stack_size
= vm_stack_size
;
769 #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
770 vp
->stack_base
= (SCM
*)
771 GC_generic_malloc (vp
->stack_size
* sizeof (SCM
), vm_stack_gc_kind
);
773 /* Keep a pointer to VP so that `vm_stack_mark ()' can know what the stack
775 *vp
->stack_base
= SCM_PACK_POINTER (vp
);
779 vp
->stack_base
= scm_gc_malloc (vp
->stack_size
* sizeof (SCM
),
783 vp
->stack_limit
= vp
->stack_base
+ vp
->stack_size
- VM_STACK_RESERVE_SIZE
;
785 vp
->sp
= vp
->stack_base
- 1;
787 vp
->engine
= vm_default_engine
;
789 for (i
= 0; i
< SCM_VM_NUM_HOOKS
; i
++)
790 vp
->hooks
[i
] = SCM_BOOL_F
;
791 return scm_cell (scm_tc7_vm
, (scm_t_bits
)vp
);
795 #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
797 /* Mark the VM stack region between its base and its current top. */
798 static struct GC_ms_entry
*
799 vm_stack_mark (GC_word
*addr
, struct GC_ms_entry
*mark_stack_ptr
,
800 struct GC_ms_entry
*mark_stack_limit
, GC_word env
)
803 const struct scm_vm
*vm
;
805 /* The first word of the VM stack should contain a pointer to the
807 vm
= * ((struct scm_vm
**) addr
);
810 || (SCM
*) addr
!= vm
->stack_base
- 1)
811 /* ADDR must be a pointer to a free-list element, which we must ignore
812 (see warning in <gc/gc_mark.h>). */
813 return mark_stack_ptr
;
815 for (word
= (GC_word
*) vm
->stack_base
; word
<= (GC_word
*) vm
->sp
; word
++)
816 mark_stack_ptr
= GC_MARK_AND_PUSH ((* (GC_word
**) word
),
817 mark_stack_ptr
, mark_stack_limit
,
820 return mark_stack_ptr
;
823 #endif /* VM_ENABLE_PRECISE_STACK_GC_SCAN */
827 scm_c_vm_run (SCM vm
, SCM program
, SCM
*argv
, int nargs
)
829 struct scm_vm
*vp
= SCM_VM_DATA (vm
);
831 return vm_engines
[vp
->engine
](vm
, program
, argv
, nargs
);
834 /* Scheme interface */
836 SCM_DEFINE (scm_the_vm
, "the-vm", 0, 0, 0,
838 "Return the current thread's VM.")
839 #define FUNC_NAME s_scm_the_vm
841 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
843 if (SCM_UNLIKELY (scm_is_false (t
->vm
)))
851 SCM_DEFINE (scm_vm_p
, "vm?", 1, 0, 0,
854 #define FUNC_NAME s_scm_vm_p
856 return scm_from_bool (SCM_VM_P (obj
));
860 SCM_DEFINE (scm_make_vm
, "make-vm", 0, 0, 0,
863 #define FUNC_NAME s_scm_make_vm,
869 SCM_DEFINE (scm_vm_ip
, "vm:ip", 1, 0, 0,
872 #define FUNC_NAME s_scm_vm_ip
874 SCM_VALIDATE_VM (1, vm
);
875 return scm_from_unsigned_integer ((scm_t_bits
) SCM_VM_DATA (vm
)->ip
);
879 SCM_DEFINE (scm_vm_sp
, "vm:sp", 1, 0, 0,
882 #define FUNC_NAME s_scm_vm_sp
884 SCM_VALIDATE_VM (1, vm
);
885 return scm_from_unsigned_integer ((scm_t_bits
) SCM_VM_DATA (vm
)->sp
);
889 SCM_DEFINE (scm_vm_fp
, "vm:fp", 1, 0, 0,
892 #define FUNC_NAME s_scm_vm_fp
894 SCM_VALIDATE_VM (1, vm
);
895 return scm_from_unsigned_integer ((scm_t_bits
) SCM_VM_DATA (vm
)->fp
);
899 #define VM_DEFINE_HOOK(n) \
902 SCM_VALIDATE_VM (1, vm); \
903 vp = SCM_VM_DATA (vm); \
904 if (scm_is_false (vp->hooks[n])) \
905 vp->hooks[n] = scm_make_hook (SCM_I_MAKINUM (1)); \
906 return vp->hooks[n]; \
909 SCM_DEFINE (scm_vm_apply_hook
, "vm-apply-hook", 1, 0, 0,
912 #define FUNC_NAME s_scm_vm_apply_hook
914 VM_DEFINE_HOOK (SCM_VM_APPLY_HOOK
);
918 SCM_DEFINE (scm_vm_push_continuation_hook
, "vm-push-continuation-hook", 1, 0, 0,
921 #define FUNC_NAME s_scm_vm_push_continuation_hook
923 VM_DEFINE_HOOK (SCM_VM_PUSH_CONTINUATION_HOOK
);
927 SCM_DEFINE (scm_vm_pop_continuation_hook
, "vm-pop-continuation-hook", 1, 0, 0,
930 #define FUNC_NAME s_scm_vm_pop_continuation_hook
932 VM_DEFINE_HOOK (SCM_VM_POP_CONTINUATION_HOOK
);
936 SCM_DEFINE (scm_vm_next_hook
, "vm-next-hook", 1, 0, 0,
939 #define FUNC_NAME s_scm_vm_next_hook
941 VM_DEFINE_HOOK (SCM_VM_NEXT_HOOK
);
945 SCM_DEFINE (scm_vm_abort_continuation_hook
, "vm-abort-continuation-hook", 1, 0, 0,
948 #define FUNC_NAME s_scm_vm_abort_continuation_hook
950 VM_DEFINE_HOOK (SCM_VM_ABORT_CONTINUATION_HOOK
);
954 SCM_DEFINE (scm_vm_restore_continuation_hook
, "vm-restore-continuation-hook", 1, 0, 0,
957 #define FUNC_NAME s_scm_vm_restore_continuation_hook
959 VM_DEFINE_HOOK (SCM_VM_RESTORE_CONTINUATION_HOOK
);
963 SCM_DEFINE (scm_vm_trace_level
, "vm-trace-level", 1, 0, 0,
966 #define FUNC_NAME s_scm_vm_trace_level
968 SCM_VALIDATE_VM (1, vm
);
969 return scm_from_int (SCM_VM_DATA (vm
)->trace_level
);
973 SCM_DEFINE (scm_set_vm_trace_level_x
, "set-vm-trace-level!", 2, 0, 0,
976 #define FUNC_NAME s_scm_set_vm_trace_level_x
978 SCM_VALIDATE_VM (1, vm
);
979 SCM_VM_DATA (vm
)->trace_level
= scm_to_int (level
);
980 return SCM_UNSPECIFIED
;
990 symbol_to_vm_engine (SCM engine
, const char *FUNC_NAME
)
992 if (scm_is_eq (engine
, sym_regular
))
993 return SCM_VM_REGULAR_ENGINE
;
994 else if (scm_is_eq (engine
, sym_debug
))
995 return SCM_VM_DEBUG_ENGINE
;
997 SCM_MISC_ERROR ("Unknown VM engine: ~a", scm_list_1 (engine
));
1001 vm_engine_to_symbol (int engine
, const char *FUNC_NAME
)
1005 case SCM_VM_REGULAR_ENGINE
:
1007 case SCM_VM_DEBUG_ENGINE
:
1011 SCM_MISC_ERROR ("Unknown VM engine: ~a",
1012 scm_list_1 (scm_from_int (engine
)));
1016 SCM_DEFINE (scm_vm_engine
, "vm-engine", 1, 0, 0,
1019 #define FUNC_NAME s_scm_vm_engine
1021 SCM_VALIDATE_VM (1, vm
);
1022 return vm_engine_to_symbol (SCM_VM_DATA (vm
)->engine
, FUNC_NAME
);
1027 scm_c_set_vm_engine_x (SCM vm
, int engine
)
1028 #define FUNC_NAME "set-vm-engine!"
1030 SCM_VALIDATE_VM (1, vm
);
1032 if (engine
< 0 || engine
>= SCM_VM_NUM_ENGINES
)
1033 SCM_MISC_ERROR ("Unknown VM engine: ~a",
1034 scm_list_1 (scm_from_int (engine
)));
1036 SCM_VM_DATA (vm
)->engine
= engine
;
1040 SCM_DEFINE (scm_set_vm_engine_x
, "set-vm-engine!", 2, 0, 0,
1041 (SCM vm
, SCM engine
),
1043 #define FUNC_NAME s_scm_set_vm_engine_x
1045 scm_c_set_vm_engine_x (vm
, symbol_to_vm_engine (engine
, FUNC_NAME
));
1046 return SCM_UNSPECIFIED
;
1051 scm_c_set_default_vm_engine_x (int engine
)
1052 #define FUNC_NAME "set-default-vm-engine!"
1054 if (engine
< 0 || engine
>= SCM_VM_NUM_ENGINES
)
1055 SCM_MISC_ERROR ("Unknown VM engine: ~a",
1056 scm_list_1 (scm_from_int (engine
)));
1058 vm_default_engine
= engine
;
1062 SCM_DEFINE (scm_set_default_vm_engine_x
, "set-default-vm-engine!", 1, 0, 0,
1065 #define FUNC_NAME s_scm_set_default_vm_engine_x
1067 scm_c_set_default_vm_engine_x (symbol_to_vm_engine (engine
, FUNC_NAME
));
1068 return SCM_UNSPECIFIED
;
1072 static void reinstate_vm (SCM vm
)
1074 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
1078 SCM_DEFINE (scm_call_with_vm
, "call-with-vm", 2, 0, 1,
1079 (SCM vm
, SCM proc
, SCM args
),
1080 "Apply @var{proc} to @var{args} in a dynamic extent in which\n"
1081 "@var{vm} is the current VM.\n\n"
1082 "As an implementation restriction, if @var{vm} is not the same\n"
1083 "as the current thread's VM, continuations captured within the\n"
1084 "call to @var{proc} may not be reinstated once control leaves\n"
1086 #define FUNC_NAME s_scm_call_with_vm
1091 scm_t_wind_flags flags
;
1092 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
1094 SCM_VALIDATE_VM (1, vm
);
1095 SCM_VALIDATE_PROC (2, proc
);
1097 nargs
= scm_ilength (args
);
1098 if (SCM_UNLIKELY (nargs
< 0))
1099 scm_wrong_type_arg_msg (FUNC_NAME
, 3, args
, "list");
1101 argv
= alloca (nargs
* sizeof(SCM
));
1102 for (i
= 0; i
< nargs
; i
++)
1104 argv
[i
] = SCM_CAR (args
);
1105 args
= SCM_CDR (args
);
1110 /* Reentry can happen via invokation of a saved continuation, but
1111 continuations only save the state of the VM that they are in at
1112 capture-time, which might be different from this one. So, in the
1113 case that the VMs are different, set up a non-rewindable frame to
1114 prevent reinstating an incomplete continuation. */
1115 flags
= scm_is_eq (prev_vm
, vm
) ? 0 : SCM_F_WIND_EXPLICITLY
;
1118 scm_dynwind_begin (0);
1119 scm_dynwind_unwind_handler_with_scm (reinstate_vm
, prev_vm
, flags
);
1123 ret
= scm_c_vm_run (vm
, proc
, argv
, nargs
);
1137 SCM
scm_load_compiled_with_vm (SCM file
)
1139 SCM program
= scm_load_thunk_from_file (file
);
1141 return scm_c_vm_run (scm_the_vm (), program
, NULL
, 0);
1146 scm_init_vm_builtin_properties (void)
1148 /* FIXME: Seems hacky to do this here, but oh well :/ */
1149 scm_sym_apply
= scm_from_utf8_symbol ("apply");
1150 scm_sym_values
= scm_from_utf8_symbol ("values");
1151 scm_sym_abort_to_prompt
= scm_from_utf8_symbol ("abort-to-prompt");
1152 scm_sym_call_with_values
= scm_from_utf8_symbol ("call-with-values");
1153 scm_sym_call_with_current_continuation
=
1154 scm_from_utf8_symbol ("call-with-current-continuation");
1156 #define INIT_BUILTIN(builtin, BUILTIN, req, opt, rest) \
1157 scm_set_procedure_property_x (vm_builtin_##builtin, scm_sym_name, \
1158 scm_sym_##builtin); \
1159 scm_set_procedure_minimum_arity_x (vm_builtin_##builtin, \
1160 SCM_I_MAKINUM (req), \
1161 SCM_I_MAKINUM (opt), \
1162 scm_from_bool (rest));
1163 FOR_EACH_VM_BUILTIN (INIT_BUILTIN
);
1168 scm_bootstrap_vm (void)
1170 scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION
,
1172 (scm_t_extension_init_func
)scm_init_vm
, NULL
);
1173 scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION
,
1174 "scm_init_vm_builtins",
1175 (scm_t_extension_init_func
)scm_init_vm_builtins
,
1178 initialize_default_stack_size ();
1180 sym_vm_run
= scm_from_latin1_symbol ("vm-run");
1181 sym_vm_error
= scm_from_latin1_symbol ("vm-error");
1182 sym_keyword_argument_error
= scm_from_latin1_symbol ("keyword-argument-error");
1183 sym_regular
= scm_from_latin1_symbol ("regular");
1184 sym_debug
= scm_from_latin1_symbol ("debug");
1186 vm_boot_continuation
= scm_i_make_program (vm_boot_continuation_code
);
1187 SCM_SET_CELL_WORD_0 (vm_boot_continuation
,
1188 (SCM_CELL_WORD_0 (vm_boot_continuation
)
1189 | SCM_F_PROGRAM_IS_BOOT
));
1191 #define DEFINE_BUILTIN(builtin, BUILTIN, req, opt, rest) \
1192 vm_builtin_##builtin = scm_i_make_program (vm_builtin_##builtin##_code);
1193 FOR_EACH_VM_BUILTIN (DEFINE_BUILTIN
);
1194 #undef DEFINE_BUILTIN
1196 #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
1198 GC_new_kind (GC_new_free_list (),
1199 GC_MAKE_PROC (GC_new_proc (vm_stack_mark
), 0),
1208 #ifndef SCM_MAGIC_SNARFER
1209 #include "libguile/vm.x"