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 #ifdef HAVE_SYS_MMAN_H
33 #include "libguile/bdw-gc.h"
34 #include <gc/gc_mark.h>
39 #include "instructions.h"
43 #include "vm-builtins.h"
45 #include "private-gc.h" /* scm_getenv_int */
47 static int vm_default_engine
= SCM_VM_REGULAR_ENGINE
;
49 /* Unfortunately we can't snarf these: snarfed things are only loaded up from
50 (system vm vm), which might not be loaded before an error happens. */
51 static SCM sym_vm_run
;
52 static SCM sym_vm_error
;
53 static SCM sym_keyword_argument_error
;
54 static SCM sym_regular
;
57 /* The VM has a number of internal assertions that shouldn't normally be
58 necessary, but might be if you think you found a bug in the VM. */
59 #define VM_ENABLE_ASSERTIONS
61 /* #define VM_ENABLE_PARANOID_ASSERTIONS */
63 /* Size in SCM objects of the stack reserve. The reserve is used to run
64 exception handling code in case of a VM stack overflow. */
65 #define VM_STACK_RESERVE_SIZE 512
74 scm_i_vm_cont_print (SCM x
, SCM port
, scm_print_state
*pstate
)
76 scm_puts_unlocked ("#<vm-continuation ", port
);
77 scm_uintprint (SCM_UNPACK (x
), 16, port
);
78 scm_puts_unlocked (">", port
);
81 /* In theory, a number of vm instances can be active in the call trace, and we
82 only want to reify the continuations of those in the current continuation
83 root. I don't see a nice way to do this -- ideally it would involve dynwinds,
84 and previous values of the *the-vm* fluid within the current continuation
85 root. But we don't have access to continuation roots in the dynwind stack.
86 So, just punt for now, we just capture the continuation for the current VM.
88 While I'm on the topic, ideally we could avoid copying the C stack if the
89 continuation root is inside VM code, and call/cc was invoked within that same
90 call to vm_run; but that's currently not implemented.
93 scm_i_vm_capture_stack (SCM
*stack_base
, SCM
*fp
, SCM
*sp
, scm_t_uint32
*ra
,
94 scm_t_dynstack
*dynstack
, scm_t_uint32 flags
)
96 struct scm_vm_cont
*p
;
98 p
= scm_gc_malloc (sizeof (*p
), "capture_vm_cont");
99 p
->stack_size
= sp
- stack_base
+ 1;
100 p
->stack_base
= scm_gc_malloc (p
->stack_size
* sizeof (SCM
),
105 memcpy (p
->stack_base
, stack_base
, (sp
+ 1 - stack_base
) * sizeof (SCM
));
106 p
->reloc
= p
->stack_base
- stack_base
;
107 p
->dynstack
= dynstack
;
109 return scm_cell (scm_tc7_vm_cont
, (scm_t_bits
)p
);
113 vm_return_to_continuation (struct scm_vm
*vp
, SCM cont
, size_t n
, SCM
*argv
)
115 struct scm_vm_cont
*cp
;
118 argv_copy
= alloca (n
* sizeof(SCM
));
119 memcpy (argv_copy
, argv
, n
* sizeof(SCM
));
121 cp
= SCM_VM_CONT_DATA (cont
);
123 if (vp
->stack_size
< cp
->stack_size
+ n
+ 3)
124 scm_misc_error ("vm-engine", "not enough space to reinstate continuation",
129 memcpy (vp
->stack_base
, cp
->stack_base
, cp
->stack_size
* sizeof (SCM
));
134 /* Push on an empty frame, as the continuation expects. */
135 for (i
= 0; i
< 3; i
++)
138 *vp
->sp
= SCM_BOOL_F
;
141 /* Push the return values. */
142 for (i
= 0; i
< n
; i
++)
145 *vp
->sp
= argv_copy
[i
];
151 static struct scm_vm
* thread_vm (scm_i_thread
*t
);
153 scm_i_capture_current_stack (void)
155 scm_i_thread
*thread
;
158 thread
= SCM_I_CURRENT_THREAD
;
159 vp
= thread_vm (thread
);
161 return scm_i_vm_capture_stack (vp
->stack_base
, vp
->fp
, vp
->sp
, vp
->ip
,
162 scm_dynstack_capture_all (&thread
->dynstack
),
166 static void vm_dispatch_apply_hook (struct scm_vm
*vp
) SCM_NOINLINE
;
167 static void vm_dispatch_push_continuation_hook (struct scm_vm
*vp
) SCM_NOINLINE
;
168 static void vm_dispatch_pop_continuation_hook (struct scm_vm
*vp
, SCM
*old_fp
) SCM_NOINLINE
;
169 static void vm_dispatch_next_hook (struct scm_vm
*vp
) SCM_NOINLINE
;
170 static void vm_dispatch_abort_hook (struct scm_vm
*vp
) SCM_NOINLINE
;
171 static void vm_dispatch_restore_continuation_hook (struct scm_vm
*vp
) SCM_NOINLINE
;
174 vm_dispatch_hook (struct scm_vm
*vp
, int hook_num
, SCM
*argv
, int n
)
177 struct scm_frame c_frame
;
179 int saved_trace_level
;
181 hook
= vp
->hooks
[hook_num
];
183 if (SCM_LIKELY (scm_is_false (hook
))
184 || scm_is_null (SCM_HOOK_PROCEDURES (hook
)))
187 saved_trace_level
= vp
->trace_level
;
190 /* Allocate a frame object on the stack. This is more efficient than calling
191 `scm_c_make_frame ()' to allocate on the heap, but it forces hooks to not
192 capture frame objects.
194 At the same time, procedures such as `frame-procedure' make sense only
195 while the stack frame represented by the frame object is visible, so it
196 seems reasonable to limit the lifetime of frame objects. */
198 c_frame
.stack_holder
= vp
;
199 c_frame
.fp_offset
= vp
->fp
- vp
->stack_base
;
200 c_frame
.sp_offset
= vp
->sp
- vp
->stack_base
;
203 /* Arrange for FRAME to be 8-byte aligned, like any other cell. */
204 frame
= alloca (sizeof (*frame
) + 8);
205 frame
= (scm_t_cell
*) ROUND_UP ((scm_t_uintptr
) frame
, 8UL);
207 frame
->word_0
= SCM_PACK (scm_tc7_frame
| (SCM_VM_FRAME_KIND_VM
<< 8));
208 frame
->word_1
= SCM_PACK_POINTER (&c_frame
);
214 args
[0] = SCM_PACK_POINTER (frame
);
215 scm_c_run_hookn (hook
, args
, 1);
221 args
[0] = SCM_PACK_POINTER (frame
);
223 scm_c_run_hookn (hook
, args
, 2);
230 args
= scm_cons (argv
[n
], args
);
231 scm_c_run_hook (hook
, scm_cons (SCM_PACK_POINTER (frame
), args
));
234 vp
->trace_level
= saved_trace_level
;
238 vm_dispatch_apply_hook (struct scm_vm
*vp
)
240 return vm_dispatch_hook (vp
, SCM_VM_APPLY_HOOK
, NULL
, 0);
242 static void vm_dispatch_push_continuation_hook (struct scm_vm
*vp
)
244 return vm_dispatch_hook (vp
, SCM_VM_PUSH_CONTINUATION_HOOK
, NULL
, 0);
246 static void vm_dispatch_pop_continuation_hook (struct scm_vm
*vp
, SCM
*old_fp
)
248 return vm_dispatch_hook (vp
, SCM_VM_POP_CONTINUATION_HOOK
,
249 &SCM_FRAME_LOCAL (old_fp
, 1),
250 SCM_FRAME_NUM_LOCALS (old_fp
, vp
->sp
) - 1);
252 static void vm_dispatch_next_hook (struct scm_vm
*vp
)
254 return vm_dispatch_hook (vp
, SCM_VM_NEXT_HOOK
, NULL
, 0);
256 static void vm_dispatch_abort_hook (struct scm_vm
*vp
)
258 return vm_dispatch_hook (vp
, SCM_VM_ABORT_CONTINUATION_HOOK
,
259 &SCM_FRAME_LOCAL (vp
->fp
, 1),
260 SCM_FRAME_NUM_LOCALS (vp
->fp
, vp
->sp
) - 1);
262 static void vm_dispatch_restore_continuation_hook (struct scm_vm
*vp
)
264 return vm_dispatch_hook (vp
, SCM_VM_RESTORE_CONTINUATION_HOOK
, NULL
, 0);
268 vm_abort (struct scm_vm
*vp
, SCM tag
,
269 size_t nstack
, SCM
*stack_args
, SCM tail
, SCM
*sp
,
270 scm_i_jmp_buf
*current_registers
) SCM_NORETURN
;
273 vm_abort (struct scm_vm
*vp
, SCM tag
,
274 size_t nstack
, SCM
*stack_args
, SCM tail
, SCM
*sp
,
275 scm_i_jmp_buf
*current_registers
)
281 tail_len
= scm_ilength (tail
);
283 scm_misc_error ("vm-engine", "tail values to abort should be a list",
286 argv
= alloca ((nstack
+ tail_len
) * sizeof (SCM
));
287 for (i
= 0; i
< nstack
; i
++)
288 argv
[i
] = stack_args
[i
];
289 for (; i
< nstack
+ tail_len
; i
++, tail
= scm_cdr (tail
))
290 argv
[i
] = scm_car (tail
);
292 /* FIXME: NULLSTACK (SCM_VM_DATA (vp)->sp - sp) */
295 scm_c_abort (vp
, tag
, nstack
+ tail_len
, argv
, current_registers
);
299 vm_reinstate_partial_continuation (struct scm_vm
*vp
, SCM cont
,
301 scm_t_dynstack
*dynstack
,
302 scm_i_jmp_buf
*registers
)
304 struct scm_vm_cont
*cp
;
305 SCM
*argv_copy
, *base
;
309 argv_copy
= alloca (n
* sizeof(SCM
));
310 memcpy (argv_copy
, argv
, n
* sizeof(SCM
));
312 cp
= SCM_VM_CONT_DATA (cont
);
313 base
= SCM_FRAME_LOCALS_ADDRESS (vp
->fp
);
314 reloc
= cp
->reloc
+ (base
- cp
->stack_base
);
316 #define RELOC(scm_p) \
317 (((SCM *) (scm_p)) + reloc)
319 if ((base
- vp
->stack_base
) + cp
->stack_size
+ n
+ 1 > vp
->stack_size
)
320 scm_misc_error ("vm-engine",
321 "not enough space to instate partial continuation",
324 memcpy (base
, cp
->stack_base
, cp
->stack_size
* sizeof (SCM
));
326 /* now relocate frame pointers */
329 for (fp
= RELOC (cp
->fp
);
330 SCM_FRAME_LOWER_ADDRESS (fp
) > base
;
331 fp
= SCM_FRAME_DYNAMIC_LINK (fp
))
332 SCM_FRAME_SET_DYNAMIC_LINK (fp
, RELOC (SCM_FRAME_DYNAMIC_LINK (fp
)));
335 vp
->sp
= base
- 1 + cp
->stack_size
;
336 vp
->fp
= RELOC (cp
->fp
);
339 /* Push the arguments. */
340 for (i
= 0; i
< n
; i
++)
343 *vp
->sp
= argv_copy
[i
];
346 /* The prompt captured a slice of the dynamic stack. Here we wind
347 those entries onto the current thread's stack. We also have to
348 relocate any prompts that we see along the way. */
352 for (walk
= SCM_DYNSTACK_FIRST (cp
->dynstack
);
353 SCM_DYNSTACK_TAG (walk
);
354 walk
= SCM_DYNSTACK_NEXT (walk
))
356 scm_t_bits tag
= SCM_DYNSTACK_TAG (walk
);
358 if (SCM_DYNSTACK_TAG_TYPE (tag
) == SCM_DYNSTACK_TYPE_PROMPT
)
359 scm_dynstack_wind_prompt (dynstack
, walk
, reloc
, registers
);
361 scm_dynstack_wind_1 (dynstack
, walk
);
372 static void vm_error (const char *msg
, SCM arg
) SCM_NORETURN
;
373 static void vm_error_bad_instruction (scm_t_uint32 inst
) SCM_NORETURN SCM_NOINLINE
;
374 static void vm_error_unbound (SCM proc
, SCM sym
) SCM_NORETURN SCM_NOINLINE
;
375 static void vm_error_unbound_fluid (SCM proc
, SCM fluid
) SCM_NORETURN SCM_NOINLINE
;
376 static void vm_error_not_a_variable (const char *func_name
, SCM x
) SCM_NORETURN SCM_NOINLINE
;
377 static void vm_error_apply_to_non_list (SCM x
) SCM_NORETURN SCM_NOINLINE
;
378 static void vm_error_kwargs_length_not_even (SCM proc
) SCM_NORETURN SCM_NOINLINE
;
379 static void vm_error_kwargs_invalid_keyword (SCM proc
, SCM obj
) SCM_NORETURN SCM_NOINLINE
;
380 static void vm_error_kwargs_unrecognized_keyword (SCM proc
, SCM kw
) SCM_NORETURN SCM_NOINLINE
;
381 static void vm_error_too_many_args (int nargs
) SCM_NORETURN SCM_NOINLINE
;
382 static void vm_error_wrong_num_args (SCM proc
) SCM_NORETURN SCM_NOINLINE
;
383 static void vm_error_wrong_type_apply (SCM proc
) SCM_NORETURN SCM_NOINLINE
;
384 static void vm_error_stack_overflow (struct scm_vm
*vp
) SCM_NORETURN SCM_NOINLINE
;
385 static void vm_error_stack_underflow (void) SCM_NORETURN SCM_NOINLINE
;
386 static void vm_error_improper_list (SCM x
) SCM_NORETURN SCM_NOINLINE
;
387 static void vm_error_not_a_pair (const char *subr
, SCM x
) SCM_NORETURN SCM_NOINLINE
;
388 static void vm_error_not_a_bytevector (const char *subr
, SCM x
) SCM_NORETURN SCM_NOINLINE
;
389 static void vm_error_not_a_struct (const char *subr
, SCM x
) SCM_NORETURN SCM_NOINLINE
;
390 static void vm_error_no_values (void) SCM_NORETURN SCM_NOINLINE
;
391 static void vm_error_not_enough_values (void) SCM_NORETURN SCM_NOINLINE
;
392 static void vm_error_wrong_number_of_values (scm_t_uint32 expected
) SCM_NORETURN SCM_NOINLINE
;
393 static void vm_error_continuation_not_rewindable (SCM cont
) SCM_NORETURN SCM_NOINLINE
;
394 static void vm_error_bad_wide_string_length (size_t len
) SCM_NORETURN SCM_NOINLINE
;
397 vm_error (const char *msg
, SCM arg
)
399 scm_throw (sym_vm_error
,
400 scm_list_3 (sym_vm_run
, scm_from_latin1_string (msg
),
401 SCM_UNBNDP (arg
) ? SCM_EOL
: scm_list_1 (arg
)));
402 abort(); /* not reached */
406 vm_error_bad_instruction (scm_t_uint32 inst
)
408 vm_error ("VM: Bad instruction: ~s", scm_from_uint32 (inst
));
412 vm_error_unbound (SCM proc
, SCM sym
)
414 scm_error_scm (scm_misc_error_key
, proc
,
415 scm_from_latin1_string ("Unbound variable: ~s"),
416 scm_list_1 (sym
), SCM_BOOL_F
);
420 vm_error_unbound_fluid (SCM proc
, SCM fluid
)
422 scm_error_scm (scm_misc_error_key
, proc
,
423 scm_from_latin1_string ("Unbound fluid: ~s"),
424 scm_list_1 (fluid
), SCM_BOOL_F
);
428 vm_error_not_a_variable (const char *func_name
, SCM x
)
430 scm_error (scm_arg_type_key
, func_name
, "Not a variable: ~S",
431 scm_list_1 (x
), scm_list_1 (x
));
435 vm_error_apply_to_non_list (SCM x
)
437 scm_error (scm_arg_type_key
, "apply", "Apply to non-list: ~S",
438 scm_list_1 (x
), scm_list_1 (x
));
442 vm_error_kwargs_length_not_even (SCM proc
)
444 scm_error_scm (sym_keyword_argument_error
, proc
,
445 scm_from_latin1_string ("Odd length of keyword argument list"),
446 SCM_EOL
, SCM_BOOL_F
);
450 vm_error_kwargs_invalid_keyword (SCM proc
, SCM obj
)
452 scm_error_scm (sym_keyword_argument_error
, proc
,
453 scm_from_latin1_string ("Invalid keyword"),
454 SCM_EOL
, scm_list_1 (obj
));
458 vm_error_kwargs_unrecognized_keyword (SCM proc
, SCM kw
)
460 scm_error_scm (sym_keyword_argument_error
, proc
,
461 scm_from_latin1_string ("Unrecognized keyword"),
462 SCM_EOL
, scm_list_1 (kw
));
466 vm_error_too_many_args (int nargs
)
468 vm_error ("VM: Too many arguments", scm_from_int (nargs
));
472 vm_error_wrong_num_args (SCM proc
)
474 scm_wrong_num_args (proc
);
478 vm_error_wrong_type_apply (SCM proc
)
480 scm_error (scm_arg_type_key
, NULL
, "Wrong type to apply: ~S",
481 scm_list_1 (proc
), scm_list_1 (proc
));
485 vm_error_stack_overflow (struct scm_vm
*vp
)
487 if (vp
->stack_limit
< vp
->stack_base
+ vp
->stack_size
)
488 /* There are VM_STACK_RESERVE_SIZE bytes left. Make them available so
489 that `throw' below can run on this VM. */
490 vp
->stack_limit
= vp
->stack_base
+ vp
->stack_size
;
492 /* There is no space left on the stack. FIXME: Do something more
495 vm_error ("VM: Stack overflow", SCM_UNDEFINED
);
499 vm_error_stack_underflow (void)
501 vm_error ("VM: Stack underflow", SCM_UNDEFINED
);
505 vm_error_improper_list (SCM x
)
507 vm_error ("Expected a proper list, but got object with tail ~s", x
);
511 vm_error_not_a_pair (const char *subr
, SCM x
)
513 scm_wrong_type_arg_msg (subr
, 1, x
, "pair");
517 vm_error_not_a_bytevector (const char *subr
, SCM x
)
519 scm_wrong_type_arg_msg (subr
, 1, x
, "bytevector");
523 vm_error_not_a_struct (const char *subr
, SCM x
)
525 scm_wrong_type_arg_msg (subr
, 1, x
, "struct");
529 vm_error_no_values (void)
531 vm_error ("Zero values returned to single-valued continuation",
536 vm_error_not_enough_values (void)
538 vm_error ("Too few values returned to continuation", SCM_UNDEFINED
);
542 vm_error_wrong_number_of_values (scm_t_uint32 expected
)
544 vm_error ("Wrong number of values returned to continuation (expected ~a)",
545 scm_from_uint32 (expected
));
549 vm_error_continuation_not_rewindable (SCM cont
)
551 vm_error ("Unrewindable partial continuation", cont
);
555 vm_error_bad_wide_string_length (size_t len
)
557 vm_error ("VM: Bad wide string length: ~S", scm_from_size_t (len
));
563 static SCM vm_boot_continuation
;
564 static SCM vm_builtin_apply
;
565 static SCM vm_builtin_values
;
566 static SCM vm_builtin_abort_to_prompt
;
567 static SCM vm_builtin_call_with_values
;
568 static SCM vm_builtin_call_with_current_continuation
;
570 static const scm_t_uint32 vm_boot_continuation_code
[] = {
571 SCM_PACK_OP_24 (halt
, 0)
574 static const scm_t_uint32 vm_builtin_apply_code
[] = {
575 SCM_PACK_OP_24 (assert_nargs_ge
, 3),
576 SCM_PACK_OP_24 (tail_apply
, 0), /* proc in r1, args from r2 */
579 static const scm_t_uint32 vm_builtin_values_code
[] = {
580 SCM_PACK_OP_24 (return_values
, 0) /* vals from r1 */
583 static const scm_t_uint32 vm_builtin_abort_to_prompt_code
[] = {
584 SCM_PACK_OP_24 (assert_nargs_ge
, 2),
585 SCM_PACK_OP_24 (abort
, 0), /* tag in r1, vals from r2 */
586 /* FIXME: Partial continuation should capture caller regs. */
587 SCM_PACK_OP_24 (return_values
, 0) /* vals from r1 */
590 static const scm_t_uint32 vm_builtin_call_with_values_code
[] = {
591 SCM_PACK_OP_24 (assert_nargs_ee
, 3),
592 SCM_PACK_OP_24 (alloc_frame
, 7),
593 SCM_PACK_OP_12_12 (mov
, 6, 1),
594 SCM_PACK_OP_24 (call
, 6), SCM_PACK_OP_ARG_8_24 (0, 1),
595 SCM_PACK_OP_12_12 (mov
, 0, 2),
596 SCM_PACK_OP_24 (tail_call_shuffle
, 7)
599 static const scm_t_uint32 vm_builtin_call_with_current_continuation_code
[] = {
600 SCM_PACK_OP_24 (assert_nargs_ee
, 2),
601 SCM_PACK_OP_24 (call_cc
, 0)
606 scm_vm_builtin_ref (unsigned idx
)
610 #define INDEX_TO_NAME(builtin, BUILTIN, req, opt, rest) \
611 case SCM_VM_BUILTIN_##BUILTIN: return vm_builtin_##builtin;
612 FOR_EACH_VM_BUILTIN(INDEX_TO_NAME
)
619 static SCM scm_sym_values
;
620 static SCM scm_sym_abort_to_prompt
;
621 static SCM scm_sym_call_with_values
;
622 static SCM scm_sym_call_with_current_continuation
;
625 scm_vm_builtin_name_to_index (SCM name
)
626 #define FUNC_NAME "builtin-name->index"
628 SCM_VALIDATE_SYMBOL (1, name
);
630 #define NAME_TO_INDEX(builtin, BUILTIN, req, opt, rest) \
631 if (scm_is_eq (name, scm_sym_##builtin)) \
632 return scm_from_uint (SCM_VM_BUILTIN_##BUILTIN);
633 FOR_EACH_VM_BUILTIN(NAME_TO_INDEX
)
641 scm_vm_builtin_index_to_name (SCM index
)
642 #define FUNC_NAME "builtin-index->name"
646 SCM_VALIDATE_UINT_COPY (1, index
, idx
);
650 #define INDEX_TO_NAME(builtin, BUILTIN, req, opt, rest) \
651 case SCM_VM_BUILTIN_##BUILTIN: return scm_sym_##builtin;
652 FOR_EACH_VM_BUILTIN(INDEX_TO_NAME
)
654 default: return SCM_BOOL_F
;
660 scm_init_vm_builtins (void)
662 scm_c_define_gsubr ("builtin-name->index", 1, 0, 0,
663 scm_vm_builtin_name_to_index
);
664 scm_c_define_gsubr ("builtin-index->name", 1, 0, 0,
665 scm_vm_builtin_index_to_name
);
669 scm_i_call_with_current_continuation (SCM proc
)
671 return scm_call_1 (vm_builtin_call_with_current_continuation
, proc
);
679 #define VM_MIN_STACK_SIZE (1024)
680 #define VM_DEFAULT_STACK_SIZE (256 * 1024)
681 static size_t vm_stack_size
= VM_DEFAULT_STACK_SIZE
;
684 initialize_default_stack_size (void)
686 int size
= scm_getenv_int ("GUILE_STACK_SIZE", vm_stack_size
);
687 if (size
>= VM_MIN_STACK_SIZE
)
688 vm_stack_size
= size
;
691 #define VM_NAME vm_regular_engine
692 #define VM_USE_HOOKS 0
693 #define FUNC_NAME "vm-regular-engine"
694 #include "vm-engine.c"
699 #define VM_NAME vm_debug_engine
700 #define VM_USE_HOOKS 1
701 #define FUNC_NAME "vm-debug-engine"
702 #include "vm-engine.c"
707 typedef SCM (*scm_t_vm_engine
) (scm_i_thread
*current_thread
, struct scm_vm
*vp
,
708 scm_i_jmp_buf
*registers
, int resume
);
710 static const scm_t_vm_engine vm_engines
[SCM_VM_NUM_ENGINES
] =
711 { vm_regular_engine
, vm_debug_engine
};
714 allocate_stack (size_t size
)
715 #define FUNC_NAME "make_vm"
719 if (size
>= ((size_t) -1) / sizeof (SCM
))
722 size
*= sizeof (SCM
);
725 ret
= mmap (NULL
, size
, PROT_READ
| PROT_WRITE
,
726 MAP_PRIVATE
| MAP_ANONYMOUS
, -1, 0);
727 if (ret
== MAP_FAILED
)
740 free_stack (SCM
*stack
, size_t size
)
742 size
*= sizeof (SCM
);
745 munmap (stack
, size
);
751 static struct scm_vm
*
753 #define FUNC_NAME "make_vm"
758 vp
= scm_gc_malloc (sizeof (struct scm_vm
), "vm");
760 vp
->stack_size
= vm_stack_size
;
761 vp
->stack_base
= allocate_stack (vp
->stack_size
);
762 vp
->stack_limit
= vp
->stack_base
+ vp
->stack_size
- VM_STACK_RESERVE_SIZE
;
764 vp
->sp
= vp
->stack_base
- 1;
766 vp
->engine
= vm_default_engine
;
768 for (i
= 0; i
< SCM_VM_NUM_HOOKS
; i
++)
769 vp
->hooks
[i
] = SCM_BOOL_F
;
775 /* Mark the VM stack region between its base and its current top. */
777 scm_i_vm_mark_stack (struct scm_vm
*vp
, struct GC_ms_entry
*mark_stack_ptr
,
778 struct GC_ms_entry
*mark_stack_limit
)
782 for (fp
= vp
->fp
, sp
= vp
->sp
; fp
; fp
= SCM_FRAME_DYNAMIC_LINK (fp
))
784 for (; sp
>= &SCM_FRAME_LOCAL (fp
, 0); sp
--)
788 mark_stack_ptr
= GC_MARK_AND_PUSH ((GC_word
*) elt
,
789 mark_stack_ptr
, mark_stack_limit
,
792 sp
= SCM_FRAME_PREVIOUS_SP (fp
);
795 return mark_stack_ptr
;
798 /* Free the VM stack, as this thread is exiting. */
800 scm_i_vm_free_stack (struct scm_vm
*vp
)
802 free_stack (vp
->stack_base
, vp
->stack_size
);
803 vp
->stack_base
= vp
->stack_limit
= NULL
;
807 static struct scm_vm
*
808 thread_vm (scm_i_thread
*t
)
810 if (SCM_UNLIKELY (!t
->vp
))
819 return thread_vm (SCM_I_CURRENT_THREAD
);
823 scm_call_n (SCM proc
, SCM
*argv
, size_t nargs
)
825 scm_i_thread
*thread
;
828 ptrdiff_t base_frame_size
;
829 /* Cached variables. */
830 scm_i_jmp_buf registers
; /* used for prompts */
833 thread
= SCM_I_CURRENT_THREAD
;
834 vp
= thread_vm (thread
);
838 /* Check that we have enough space: 3 words for the boot
839 continuation, 3 + nargs for the procedure application, and 3 for
840 setting up a new frame. */
841 base_frame_size
= 3 + 3 + nargs
+ 3;
842 vp
->sp
+= base_frame_size
;
843 if (vp
->sp
>= vp
->stack_limit
)
844 vm_error_stack_overflow (vp
);
845 base
= vp
->sp
+ 1 - base_frame_size
;
847 /* Since it's possible to receive the arguments on the stack itself,
848 shuffle up the arguments first. */
849 for (i
= nargs
; i
> 0; i
--)
850 base
[6 + i
- 1] = argv
[i
- 1];
852 /* Push the boot continuation, which calls PROC and returns its
854 base
[0] = SCM_PACK (vp
->fp
); /* dynamic link */
855 base
[1] = SCM_PACK (vp
->ip
); /* ra */
856 base
[2] = vm_boot_continuation
;
858 vp
->ip
= (scm_t_uint32
*) vm_boot_continuation_code
;
860 /* The pending call to PROC. */
861 base
[3] = SCM_PACK (vp
->fp
); /* dynamic link */
862 base
[4] = SCM_PACK (vp
->ip
); /* ra */
865 vp
->sp
= &SCM_FRAME_LOCAL (vp
->fp
, nargs
);
868 int resume
= SCM_I_SETJMP (registers
);
870 if (SCM_UNLIKELY (resume
))
871 /* Non-local return. */
872 vm_dispatch_abort_hook (vp
);
874 return vm_engines
[vp
->engine
](thread
, vp
, ®isters
, resume
);
878 /* Scheme interface */
880 #define VM_DEFINE_HOOK(n) \
883 vp = scm_the_vm (); \
884 if (scm_is_false (vp->hooks[n])) \
885 vp->hooks[n] = scm_make_hook (SCM_I_MAKINUM (1)); \
886 return vp->hooks[n]; \
889 SCM_DEFINE (scm_vm_apply_hook
, "vm-apply-hook", 0, 0, 0,
892 #define FUNC_NAME s_scm_vm_apply_hook
894 VM_DEFINE_HOOK (SCM_VM_APPLY_HOOK
);
898 SCM_DEFINE (scm_vm_push_continuation_hook
, "vm-push-continuation-hook", 0, 0, 0,
901 #define FUNC_NAME s_scm_vm_push_continuation_hook
903 VM_DEFINE_HOOK (SCM_VM_PUSH_CONTINUATION_HOOK
);
907 SCM_DEFINE (scm_vm_pop_continuation_hook
, "vm-pop-continuation-hook", 0, 0, 0,
910 #define FUNC_NAME s_scm_vm_pop_continuation_hook
912 VM_DEFINE_HOOK (SCM_VM_POP_CONTINUATION_HOOK
);
916 SCM_DEFINE (scm_vm_next_hook
, "vm-next-hook", 0, 0, 0,
919 #define FUNC_NAME s_scm_vm_next_hook
921 VM_DEFINE_HOOK (SCM_VM_NEXT_HOOK
);
925 SCM_DEFINE (scm_vm_abort_continuation_hook
, "vm-abort-continuation-hook", 0, 0, 0,
928 #define FUNC_NAME s_scm_vm_abort_continuation_hook
930 VM_DEFINE_HOOK (SCM_VM_ABORT_CONTINUATION_HOOK
);
934 SCM_DEFINE (scm_vm_restore_continuation_hook
, "vm-restore-continuation-hook", 0, 0, 0,
937 #define FUNC_NAME s_scm_vm_restore_continuation_hook
939 VM_DEFINE_HOOK (SCM_VM_RESTORE_CONTINUATION_HOOK
);
943 SCM_DEFINE (scm_vm_trace_level
, "vm-trace-level", 0, 0, 0,
946 #define FUNC_NAME s_scm_vm_trace_level
948 return scm_from_int (scm_the_vm ()->trace_level
);
952 SCM_DEFINE (scm_set_vm_trace_level_x
, "set-vm-trace-level!", 1, 0, 0,
955 #define FUNC_NAME s_scm_set_vm_trace_level_x
957 scm_the_vm ()->trace_level
= scm_to_int (level
);
958 return SCM_UNSPECIFIED
;
968 symbol_to_vm_engine (SCM engine
, const char *FUNC_NAME
)
970 if (scm_is_eq (engine
, sym_regular
))
971 return SCM_VM_REGULAR_ENGINE
;
972 else if (scm_is_eq (engine
, sym_debug
))
973 return SCM_VM_DEBUG_ENGINE
;
975 SCM_MISC_ERROR ("Unknown VM engine: ~a", scm_list_1 (engine
));
979 vm_engine_to_symbol (int engine
, const char *FUNC_NAME
)
983 case SCM_VM_REGULAR_ENGINE
:
985 case SCM_VM_DEBUG_ENGINE
:
989 SCM_MISC_ERROR ("Unknown VM engine: ~a",
990 scm_list_1 (scm_from_int (engine
)));
994 SCM_DEFINE (scm_vm_engine
, "vm-engine", 0, 0, 0,
997 #define FUNC_NAME s_scm_vm_engine
999 return vm_engine_to_symbol (scm_the_vm ()->engine
, FUNC_NAME
);
1004 scm_c_set_vm_engine_x (int engine
)
1005 #define FUNC_NAME "set-vm-engine!"
1007 if (engine
< 0 || engine
>= SCM_VM_NUM_ENGINES
)
1008 SCM_MISC_ERROR ("Unknown VM engine: ~a",
1009 scm_list_1 (scm_from_int (engine
)));
1011 scm_the_vm ()->engine
= engine
;
1015 SCM_DEFINE (scm_set_vm_engine_x
, "set-vm-engine!", 1, 0, 0,
1018 #define FUNC_NAME s_scm_set_vm_engine_x
1020 scm_c_set_vm_engine_x (symbol_to_vm_engine (engine
, FUNC_NAME
));
1021 return SCM_UNSPECIFIED
;
1026 scm_c_set_default_vm_engine_x (int engine
)
1027 #define FUNC_NAME "set-default-vm-engine!"
1029 if (engine
< 0 || engine
>= SCM_VM_NUM_ENGINES
)
1030 SCM_MISC_ERROR ("Unknown VM engine: ~a",
1031 scm_list_1 (scm_from_int (engine
)));
1033 vm_default_engine
= engine
;
1037 SCM_DEFINE (scm_set_default_vm_engine_x
, "set-default-vm-engine!", 1, 0, 0,
1040 #define FUNC_NAME s_scm_set_default_vm_engine_x
1042 scm_c_set_default_vm_engine_x (symbol_to_vm_engine (engine
, FUNC_NAME
));
1043 return SCM_UNSPECIFIED
;
1047 /* FIXME: This function makes no sense, but we keep it to make sure we
1048 have a way of switching to the debug or regular VM. */
1049 SCM_DEFINE (scm_call_with_vm
, "call-with-vm", 1, 0, 1,
1050 (SCM proc
, SCM args
),
1051 "Apply @var{proc} to @var{args} in a dynamic extent in which\n"
1052 "@var{vm} is the current VM.")
1053 #define FUNC_NAME s_scm_call_with_vm
1055 return scm_apply_0 (proc
, args
);
1065 scm_load_compiled_with_vm (SCM file
)
1067 return scm_call_0 (scm_load_thunk_from_file (file
));
1072 scm_init_vm_builtin_properties (void)
1074 /* FIXME: Seems hacky to do this here, but oh well :/ */
1075 scm_sym_apply
= scm_from_utf8_symbol ("apply");
1076 scm_sym_values
= scm_from_utf8_symbol ("values");
1077 scm_sym_abort_to_prompt
= scm_from_utf8_symbol ("abort-to-prompt");
1078 scm_sym_call_with_values
= scm_from_utf8_symbol ("call-with-values");
1079 scm_sym_call_with_current_continuation
=
1080 scm_from_utf8_symbol ("call-with-current-continuation");
1082 #define INIT_BUILTIN(builtin, BUILTIN, req, opt, rest) \
1083 scm_set_procedure_property_x (vm_builtin_##builtin, scm_sym_name, \
1084 scm_sym_##builtin); \
1085 scm_set_procedure_minimum_arity_x (vm_builtin_##builtin, \
1086 SCM_I_MAKINUM (req), \
1087 SCM_I_MAKINUM (opt), \
1088 scm_from_bool (rest));
1089 FOR_EACH_VM_BUILTIN (INIT_BUILTIN
);
1094 scm_bootstrap_vm (void)
1096 scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION
,
1098 (scm_t_extension_init_func
)scm_init_vm
, NULL
);
1099 scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION
,
1100 "scm_init_vm_builtins",
1101 (scm_t_extension_init_func
)scm_init_vm_builtins
,
1104 initialize_default_stack_size ();
1106 sym_vm_run
= scm_from_latin1_symbol ("vm-run");
1107 sym_vm_error
= scm_from_latin1_symbol ("vm-error");
1108 sym_keyword_argument_error
= scm_from_latin1_symbol ("keyword-argument-error");
1109 sym_regular
= scm_from_latin1_symbol ("regular");
1110 sym_debug
= scm_from_latin1_symbol ("debug");
1112 vm_boot_continuation
= scm_i_make_program (vm_boot_continuation_code
);
1113 SCM_SET_CELL_WORD_0 (vm_boot_continuation
,
1114 (SCM_CELL_WORD_0 (vm_boot_continuation
)
1115 | SCM_F_PROGRAM_IS_BOOT
));
1117 #define DEFINE_BUILTIN(builtin, BUILTIN, req, opt, rest) \
1118 vm_builtin_##builtin = scm_i_make_program (vm_builtin_##builtin##_code);
1119 FOR_EACH_VM_BUILTIN (DEFINE_BUILTIN
);
1120 #undef DEFINE_BUILTIN
1126 #ifndef SCM_MAGIC_SNARFER
1127 #include "libguile/vm.x"