1 /* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013, 2014 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
19 /* For mremap(2) on GNU/Linux systems. */
33 #ifdef HAVE_SYS_MMAN_H
37 #include "libguile/bdw-gc.h"
38 #include <gc/gc_mark.h>
43 #include "gc-inline.h"
44 #include "instructions.h"
49 #include "vm-builtins.h"
51 static int vm_default_engine
= SCM_VM_REGULAR_ENGINE
;
53 /* Unfortunately we can't snarf these: snarfed things are only loaded up from
54 (system vm vm), which might not be loaded before an error happens. */
55 static SCM sym_vm_run
;
56 static SCM sym_vm_error
;
57 static SCM sym_keyword_argument_error
;
58 static SCM sym_regular
;
61 /* The VM has a number of internal assertions that shouldn't normally be
62 necessary, but might be if you think you found a bug in the VM. */
63 /* #define VM_ENABLE_ASSERTIONS */
65 static void vm_expand_stack (struct scm_vm
*vp
, SCM
*new_sp
) SCM_NOINLINE
;
67 /* RESTORE is for the case where we know we have done a PUSH of equal or
68 greater stack size in the past. Otherwise PUSH is the thing, which
69 may expand the stack. */
70 enum vm_increase_sp_kind
{ VM_SP_PUSH
, VM_SP_RESTORE
};
73 vm_increase_sp (struct scm_vm
*vp
, SCM
*new_sp
, enum vm_increase_sp_kind kind
)
75 if (new_sp
<= vp
->sp_max_since_gc
)
81 if (kind
== VM_SP_PUSH
&& new_sp
>= vp
->stack_limit
)
82 vm_expand_stack (vp
, new_sp
);
84 vp
->sp_max_since_gc
= vp
->sp
= new_sp
;
88 vm_push_sp (struct scm_vm
*vp
, SCM
*new_sp
)
90 vm_increase_sp (vp
, new_sp
, VM_SP_PUSH
);
94 vm_restore_sp (struct scm_vm
*vp
, SCM
*new_sp
)
96 vm_increase_sp (vp
, new_sp
, VM_SP_RESTORE
);
105 scm_i_vm_cont_print (SCM x
, SCM port
, scm_print_state
*pstate
)
107 scm_puts_unlocked ("#<vm-continuation ", port
);
108 scm_uintprint (SCM_UNPACK (x
), 16, port
);
109 scm_puts_unlocked (">", port
);
112 /* Ideally we could avoid copying the C stack if the continuation root
113 is inside VM code, and call/cc was invoked within that same call to
114 vm_run. That's currently not implemented. */
116 scm_i_vm_capture_stack (SCM
*stack_base
, SCM
*fp
, SCM
*sp
, scm_t_uint32
*ra
,
117 scm_t_dynstack
*dynstack
, scm_t_uint32 flags
)
119 struct scm_vm_cont
*p
;
121 p
= scm_gc_malloc (sizeof (*p
), "capture_vm_cont");
122 p
->stack_size
= sp
- stack_base
+ 1;
123 p
->stack_base
= scm_gc_malloc (p
->stack_size
* sizeof (SCM
),
128 memcpy (p
->stack_base
, stack_base
, (sp
+ 1 - stack_base
) * sizeof (SCM
));
129 p
->reloc
= p
->stack_base
- stack_base
;
130 p
->dynstack
= dynstack
;
132 return scm_cell (scm_tc7_vm_cont
, (scm_t_bits
)p
);
136 vm_return_to_continuation (struct scm_vm
*vp
, SCM cont
, size_t n
, SCM
*argv
)
138 struct scm_vm_cont
*cp
;
142 argv_copy
= alloca (n
* sizeof(SCM
));
143 memcpy (argv_copy
, argv
, n
* sizeof(SCM
));
145 cp
= SCM_VM_CONT_DATA (cont
);
147 /* FIXME: Need to prevent GC while futzing with the stack; otherwise,
148 another thread causing GC may initiate a mark of a stack in an
149 inconsistent state. */
151 /* We know that there is enough space for the continuation, because we
152 captured it in the past. However there may have been an expansion
153 since the capture, so we may have to re-link the frame
155 reloc
= (vp
->stack_base
- (cp
->stack_base
- cp
->reloc
));
156 vp
->fp
= cp
->fp
+ reloc
;
157 memcpy (vp
->stack_base
, cp
->stack_base
, cp
->stack_size
* sizeof (SCM
));
158 vm_restore_sp (vp
, cp
->sp
+ reloc
);
165 SCM
*next_fp
= SCM_FRAME_DYNAMIC_LINK (fp
);
169 SCM_FRAME_SET_DYNAMIC_LINK (fp
, next_fp
);
175 /* Now we have the continuation properly copied over. We just need to
176 copy the arguments. It is not guaranteed that there is actually
177 space for the arguments, though, so we have to bump the SP first. */
178 vm_push_sp (vp
, vp
->sp
+ 3 + n
);
180 /* Now copy on an empty frame and the return values, as the
181 continuation expects. */
183 SCM
*base
= vp
->sp
+ 1 - 3 - n
;
186 for (i
= 0; i
< 3; i
++)
187 base
[i
] = SCM_BOOL_F
;
189 for (i
= 0; i
< n
; i
++)
190 base
[i
+ 3] = argv_copy
[i
];
196 static struct scm_vm
* thread_vm (scm_i_thread
*t
);
198 scm_i_capture_current_stack (void)
200 scm_i_thread
*thread
;
203 thread
= SCM_I_CURRENT_THREAD
;
204 vp
= thread_vm (thread
);
206 return scm_i_vm_capture_stack (vp
->stack_base
, vp
->fp
, vp
->sp
, vp
->ip
,
207 scm_dynstack_capture_all (&thread
->dynstack
),
211 static void vm_dispatch_apply_hook (struct scm_vm
*vp
) SCM_NOINLINE
;
212 static void vm_dispatch_push_continuation_hook (struct scm_vm
*vp
) SCM_NOINLINE
;
213 static void vm_dispatch_pop_continuation_hook (struct scm_vm
*vp
, SCM
*old_fp
) SCM_NOINLINE
;
214 static void vm_dispatch_next_hook (struct scm_vm
*vp
) SCM_NOINLINE
;
215 static void vm_dispatch_abort_hook (struct scm_vm
*vp
) SCM_NOINLINE
;
218 vm_dispatch_hook (struct scm_vm
*vp
, int hook_num
, SCM
*argv
, int n
)
221 struct scm_frame c_frame
;
223 int saved_trace_level
;
225 hook
= vp
->hooks
[hook_num
];
227 if (SCM_LIKELY (scm_is_false (hook
))
228 || scm_is_null (SCM_HOOK_PROCEDURES (hook
)))
231 saved_trace_level
= vp
->trace_level
;
234 /* Allocate a frame object on the stack. This is more efficient than calling
235 `scm_c_make_frame ()' to allocate on the heap, but it forces hooks to not
236 capture frame objects.
238 At the same time, procedures such as `frame-procedure' make sense only
239 while the stack frame represented by the frame object is visible, so it
240 seems reasonable to limit the lifetime of frame objects. */
242 c_frame
.stack_holder
= vp
;
243 c_frame
.fp_offset
= vp
->fp
- vp
->stack_base
;
244 c_frame
.sp_offset
= vp
->sp
- vp
->stack_base
;
247 /* Arrange for FRAME to be 8-byte aligned, like any other cell. */
248 frame
= alloca (sizeof (*frame
) + 8);
249 frame
= (scm_t_cell
*) ROUND_UP ((scm_t_uintptr
) frame
, 8UL);
251 frame
->word_0
= SCM_PACK (scm_tc7_frame
| (SCM_VM_FRAME_KIND_VM
<< 8));
252 frame
->word_1
= SCM_PACK_POINTER (&c_frame
);
258 args
[0] = SCM_PACK_POINTER (frame
);
259 scm_c_run_hookn (hook
, args
, 1);
265 args
[0] = SCM_PACK_POINTER (frame
);
267 scm_c_run_hookn (hook
, args
, 2);
274 args
= scm_cons (argv
[n
], args
);
275 scm_c_run_hook (hook
, scm_cons (SCM_PACK_POINTER (frame
), args
));
278 vp
->trace_level
= saved_trace_level
;
282 vm_dispatch_apply_hook (struct scm_vm
*vp
)
284 return vm_dispatch_hook (vp
, SCM_VM_APPLY_HOOK
, NULL
, 0);
286 static void vm_dispatch_push_continuation_hook (struct scm_vm
*vp
)
288 return vm_dispatch_hook (vp
, SCM_VM_PUSH_CONTINUATION_HOOK
, NULL
, 0);
290 static void vm_dispatch_pop_continuation_hook (struct scm_vm
*vp
, SCM
*old_fp
)
292 return vm_dispatch_hook (vp
, SCM_VM_POP_CONTINUATION_HOOK
,
293 &SCM_FRAME_LOCAL (old_fp
, 1),
294 SCM_FRAME_NUM_LOCALS (old_fp
, vp
->sp
) - 1);
296 static void vm_dispatch_next_hook (struct scm_vm
*vp
)
298 return vm_dispatch_hook (vp
, SCM_VM_NEXT_HOOK
, NULL
, 0);
300 static void vm_dispatch_abort_hook (struct scm_vm
*vp
)
302 return vm_dispatch_hook (vp
, SCM_VM_ABORT_CONTINUATION_HOOK
,
303 &SCM_FRAME_LOCAL (vp
->fp
, 1),
304 SCM_FRAME_NUM_LOCALS (vp
->fp
, vp
->sp
) - 1);
308 vm_abort (struct scm_vm
*vp
, SCM tag
,
309 size_t nstack
, SCM
*stack_args
, SCM tail
, SCM
*sp
,
310 scm_i_jmp_buf
*current_registers
) SCM_NORETURN
;
313 vm_abort (struct scm_vm
*vp
, SCM tag
,
314 size_t nstack
, SCM
*stack_args
, SCM tail
, SCM
*sp
,
315 scm_i_jmp_buf
*current_registers
)
321 tail_len
= scm_ilength (tail
);
323 scm_misc_error ("vm-engine", "tail values to abort should be a list",
326 argv
= alloca ((nstack
+ tail_len
) * sizeof (SCM
));
327 for (i
= 0; i
< nstack
; i
++)
328 argv
[i
] = stack_args
[i
];
329 for (; i
< nstack
+ tail_len
; i
++, tail
= scm_cdr (tail
))
330 argv
[i
] = scm_car (tail
);
332 /* FIXME: NULLSTACK (SCM_VM_DATA (vp)->sp - sp) */
335 scm_c_abort (vp
, tag
, nstack
+ tail_len
, argv
, current_registers
);
339 vm_reinstate_partial_continuation (struct scm_vm
*vp
, SCM cont
,
341 scm_t_dynstack
*dynstack
,
342 scm_i_jmp_buf
*registers
)
344 struct scm_vm_cont
*cp
;
345 SCM
*argv_copy
, *base
;
349 argv_copy
= alloca (n
* sizeof(SCM
));
350 memcpy (argv_copy
, argv
, n
* sizeof(SCM
));
352 cp
= SCM_VM_CONT_DATA (cont
);
354 vm_push_sp (vp
, SCM_FRAME_LOCALS_ADDRESS (vp
->fp
) + cp
->stack_size
+ n
- 1);
356 base
= SCM_FRAME_LOCALS_ADDRESS (vp
->fp
);
357 reloc
= cp
->reloc
+ (base
- cp
->stack_base
);
359 memcpy (base
, cp
->stack_base
, cp
->stack_size
* sizeof (SCM
));
361 vp
->fp
= cp
->fp
+ reloc
;
364 /* now relocate frame pointers */
368 SCM_FRAME_LOWER_ADDRESS (fp
) > base
;
369 fp
= SCM_FRAME_DYNAMIC_LINK (fp
))
370 SCM_FRAME_SET_DYNAMIC_LINK (fp
, SCM_FRAME_DYNAMIC_LINK (fp
) + reloc
);
373 /* Push the arguments. */
374 for (i
= 0; i
< n
; i
++)
375 vp
->sp
[i
+ 1 - n
] = argv_copy
[i
];
377 /* The prompt captured a slice of the dynamic stack. Here we wind
378 those entries onto the current thread's stack. We also have to
379 relocate any prompts that we see along the way. */
383 for (walk
= SCM_DYNSTACK_FIRST (cp
->dynstack
);
384 SCM_DYNSTACK_TAG (walk
);
385 walk
= SCM_DYNSTACK_NEXT (walk
))
387 scm_t_bits tag
= SCM_DYNSTACK_TAG (walk
);
389 if (SCM_DYNSTACK_TAG_TYPE (tag
) == SCM_DYNSTACK_TYPE_PROMPT
)
390 scm_dynstack_wind_prompt (dynstack
, walk
, reloc
, registers
);
392 scm_dynstack_wind_1 (dynstack
, walk
);
402 static void vm_error (const char *msg
, SCM arg
) SCM_NORETURN
;
403 static void vm_error_bad_instruction (scm_t_uint32 inst
) SCM_NORETURN SCM_NOINLINE
;
404 static void vm_error_unbound (SCM proc
, SCM sym
) SCM_NORETURN SCM_NOINLINE
;
405 static void vm_error_unbound_fluid (SCM proc
, SCM fluid
) SCM_NORETURN SCM_NOINLINE
;
406 static void vm_error_not_a_variable (const char *func_name
, SCM x
) SCM_NORETURN SCM_NOINLINE
;
407 static void vm_error_apply_to_non_list (SCM x
) SCM_NORETURN SCM_NOINLINE
;
408 static void vm_error_kwargs_length_not_even (SCM proc
) SCM_NORETURN SCM_NOINLINE
;
409 static void vm_error_kwargs_invalid_keyword (SCM proc
, SCM obj
) SCM_NORETURN SCM_NOINLINE
;
410 static void vm_error_kwargs_unrecognized_keyword (SCM proc
, SCM kw
) SCM_NORETURN SCM_NOINLINE
;
411 static void vm_error_too_many_args (int nargs
) SCM_NORETURN SCM_NOINLINE
;
412 static void vm_error_wrong_num_args (SCM proc
) SCM_NORETURN SCM_NOINLINE
;
413 static void vm_error_wrong_type_apply (SCM proc
) SCM_NORETURN SCM_NOINLINE
;
414 static void vm_error_stack_underflow (void) SCM_NORETURN SCM_NOINLINE
;
415 static void vm_error_improper_list (SCM x
) SCM_NORETURN SCM_NOINLINE
;
416 static void vm_error_not_a_pair (const char *subr
, SCM x
) SCM_NORETURN SCM_NOINLINE
;
417 static void vm_error_not_a_bytevector (const char *subr
, SCM x
) SCM_NORETURN SCM_NOINLINE
;
418 static void vm_error_not_a_struct (const char *subr
, SCM x
) SCM_NORETURN SCM_NOINLINE
;
419 static void vm_error_not_a_vector (const char *subr
, SCM v
) SCM_NORETURN SCM_NOINLINE
;
420 static void vm_error_out_of_range (const char *subr
, SCM k
) SCM_NORETURN SCM_NOINLINE
;
421 static void vm_error_no_values (void) SCM_NORETURN SCM_NOINLINE
;
422 static void vm_error_not_enough_values (void) SCM_NORETURN SCM_NOINLINE
;
423 static void vm_error_wrong_number_of_values (scm_t_uint32 expected
) SCM_NORETURN SCM_NOINLINE
;
424 static void vm_error_continuation_not_rewindable (SCM cont
) SCM_NORETURN SCM_NOINLINE
;
425 static void vm_error_bad_wide_string_length (size_t len
) SCM_NORETURN SCM_NOINLINE
;
428 vm_error (const char *msg
, SCM arg
)
430 scm_throw (sym_vm_error
,
431 scm_list_3 (sym_vm_run
, scm_from_latin1_string (msg
),
432 SCM_UNBNDP (arg
) ? SCM_EOL
: scm_list_1 (arg
)));
433 abort(); /* not reached */
437 vm_error_bad_instruction (scm_t_uint32 inst
)
439 vm_error ("VM: Bad instruction: ~s", scm_from_uint32 (inst
));
443 vm_error_unbound (SCM proc
, SCM sym
)
445 scm_error_scm (scm_misc_error_key
, proc
,
446 scm_from_latin1_string ("Unbound variable: ~s"),
447 scm_list_1 (sym
), SCM_BOOL_F
);
451 vm_error_unbound_fluid (SCM proc
, SCM fluid
)
453 scm_error_scm (scm_misc_error_key
, proc
,
454 scm_from_latin1_string ("Unbound fluid: ~s"),
455 scm_list_1 (fluid
), SCM_BOOL_F
);
459 vm_error_not_a_variable (const char *func_name
, SCM x
)
461 scm_error (scm_arg_type_key
, func_name
, "Not a variable: ~S",
462 scm_list_1 (x
), scm_list_1 (x
));
466 vm_error_apply_to_non_list (SCM x
)
468 scm_error (scm_arg_type_key
, "apply", "Apply to non-list: ~S",
469 scm_list_1 (x
), scm_list_1 (x
));
473 vm_error_kwargs_length_not_even (SCM proc
)
475 scm_error_scm (sym_keyword_argument_error
, proc
,
476 scm_from_latin1_string ("Odd length of keyword argument list"),
477 SCM_EOL
, SCM_BOOL_F
);
481 vm_error_kwargs_invalid_keyword (SCM proc
, SCM obj
)
483 scm_error_scm (sym_keyword_argument_error
, proc
,
484 scm_from_latin1_string ("Invalid keyword"),
485 SCM_EOL
, scm_list_1 (obj
));
489 vm_error_kwargs_unrecognized_keyword (SCM proc
, SCM kw
)
491 scm_error_scm (sym_keyword_argument_error
, proc
,
492 scm_from_latin1_string ("Unrecognized keyword"),
493 SCM_EOL
, scm_list_1 (kw
));
497 vm_error_too_many_args (int nargs
)
499 vm_error ("VM: Too many arguments", scm_from_int (nargs
));
503 vm_error_wrong_num_args (SCM proc
)
505 scm_wrong_num_args (proc
);
509 vm_error_wrong_type_apply (SCM proc
)
511 scm_error (scm_arg_type_key
, NULL
, "Wrong type to apply: ~S",
512 scm_list_1 (proc
), scm_list_1 (proc
));
516 vm_error_stack_underflow (void)
518 vm_error ("VM: Stack underflow", SCM_UNDEFINED
);
522 vm_error_improper_list (SCM x
)
524 vm_error ("Expected a proper list, but got object with tail ~s", x
);
528 vm_error_not_a_pair (const char *subr
, SCM x
)
530 scm_wrong_type_arg_msg (subr
, 1, x
, "pair");
534 vm_error_not_a_bytevector (const char *subr
, SCM x
)
536 scm_wrong_type_arg_msg (subr
, 1, x
, "bytevector");
540 vm_error_not_a_struct (const char *subr
, SCM x
)
542 scm_wrong_type_arg_msg (subr
, 1, x
, "struct");
546 vm_error_not_a_vector (const char *subr
, SCM x
)
548 scm_wrong_type_arg_msg (subr
, 1, x
, "vector");
552 vm_error_out_of_range (const char *subr
, SCM k
)
555 scm_out_of_range (subr
, k
);
559 vm_error_no_values (void)
561 vm_error ("Zero values returned to single-valued continuation",
566 vm_error_not_enough_values (void)
568 vm_error ("Too few values returned to continuation", SCM_UNDEFINED
);
572 vm_error_wrong_number_of_values (scm_t_uint32 expected
)
574 vm_error ("Wrong number of values returned to continuation (expected ~a)",
575 scm_from_uint32 (expected
));
579 vm_error_continuation_not_rewindable (SCM cont
)
581 vm_error ("Unrewindable partial continuation", cont
);
585 vm_error_bad_wide_string_length (size_t len
)
587 vm_error ("VM: Bad wide string length: ~S", scm_from_size_t (len
));
593 static SCM vm_boot_continuation
;
594 static SCM vm_builtin_apply
;
595 static SCM vm_builtin_values
;
596 static SCM vm_builtin_abort_to_prompt
;
597 static SCM vm_builtin_call_with_values
;
598 static SCM vm_builtin_call_with_current_continuation
;
600 static const scm_t_uint32 vm_boot_continuation_code
[] = {
601 SCM_PACK_OP_24 (halt
, 0)
604 static const scm_t_uint32 vm_builtin_apply_code
[] = {
605 SCM_PACK_OP_24 (assert_nargs_ge
, 3),
606 SCM_PACK_OP_24 (tail_apply
, 0), /* proc in r1, args from r2 */
609 static const scm_t_uint32 vm_builtin_values_code
[] = {
610 SCM_PACK_OP_24 (return_values
, 0) /* vals from r1 */
613 static const scm_t_uint32 vm_builtin_abort_to_prompt_code
[] = {
614 SCM_PACK_OP_24 (assert_nargs_ge
, 2),
615 SCM_PACK_OP_24 (abort
, 0), /* tag in r1, vals from r2 */
616 /* FIXME: Partial continuation should capture caller regs. */
617 SCM_PACK_OP_24 (return_values
, 0) /* vals from r1 */
620 static const scm_t_uint32 vm_builtin_call_with_values_code
[] = {
621 SCM_PACK_OP_24 (assert_nargs_ee
, 3),
622 SCM_PACK_OP_24 (alloc_frame
, 7),
623 SCM_PACK_OP_12_12 (mov
, 6, 1),
624 SCM_PACK_OP_24 (call
, 6), SCM_PACK_OP_ARG_8_24 (0, 1),
625 SCM_PACK_OP_12_12 (mov
, 0, 2),
626 SCM_PACK_OP_24 (tail_call_shuffle
, 7)
629 static const scm_t_uint32 vm_builtin_call_with_current_continuation_code
[] = {
630 SCM_PACK_OP_24 (assert_nargs_ee
, 2),
631 SCM_PACK_OP_24 (call_cc
, 0)
636 scm_vm_builtin_ref (unsigned idx
)
640 #define INDEX_TO_NAME(builtin, BUILTIN, req, opt, rest) \
641 case SCM_VM_BUILTIN_##BUILTIN: return vm_builtin_##builtin;
642 FOR_EACH_VM_BUILTIN(INDEX_TO_NAME
)
649 static SCM scm_sym_values
;
650 static SCM scm_sym_abort_to_prompt
;
651 static SCM scm_sym_call_with_values
;
652 static SCM scm_sym_call_with_current_continuation
;
655 scm_vm_builtin_name_to_index (SCM name
)
656 #define FUNC_NAME "builtin-name->index"
658 SCM_VALIDATE_SYMBOL (1, name
);
660 #define NAME_TO_INDEX(builtin, BUILTIN, req, opt, rest) \
661 if (scm_is_eq (name, scm_sym_##builtin)) \
662 return scm_from_uint (SCM_VM_BUILTIN_##BUILTIN);
663 FOR_EACH_VM_BUILTIN(NAME_TO_INDEX
)
671 scm_vm_builtin_index_to_name (SCM index
)
672 #define FUNC_NAME "builtin-index->name"
676 SCM_VALIDATE_UINT_COPY (1, index
, idx
);
680 #define INDEX_TO_NAME(builtin, BUILTIN, req, opt, rest) \
681 case SCM_VM_BUILTIN_##BUILTIN: return scm_sym_##builtin;
682 FOR_EACH_VM_BUILTIN(INDEX_TO_NAME
)
684 default: return SCM_BOOL_F
;
690 scm_init_vm_builtins (void)
692 scm_c_define_gsubr ("builtin-name->index", 1, 0, 0,
693 scm_vm_builtin_name_to_index
);
694 scm_c_define_gsubr ("builtin-index->name", 1, 0, 0,
695 scm_vm_builtin_index_to_name
);
699 scm_i_call_with_current_continuation (SCM proc
)
701 return scm_call_1 (vm_builtin_call_with_current_continuation
, proc
);
710 static size_t page_size
;
712 /* Initial stack size. Defaults to one page. */
713 static size_t initial_stack_size
;
715 /* Default soft stack limit is 1M words (4 or 8 megabytes). */
716 static size_t default_max_stack_size
= 1024 * 1024;
719 initialize_default_stack_size (void)
721 initial_stack_size
= page_size
/ sizeof (SCM
);
725 size
= scm_getenv_int ("GUILE_STACK_SIZE", (int) default_max_stack_size
);
726 if (size
>= initial_stack_size
727 && (size_t) size
< ((size_t) -1) / sizeof(SCM
))
728 default_max_stack_size
= size
;
732 #define VM_NAME vm_regular_engine
733 #define VM_USE_HOOKS 0
734 #define FUNC_NAME "vm-regular-engine"
735 #include "vm-engine.c"
740 #define VM_NAME vm_debug_engine
741 #define VM_USE_HOOKS 1
742 #define FUNC_NAME "vm-debug-engine"
743 #include "vm-engine.c"
748 typedef SCM (*scm_t_vm_engine
) (scm_i_thread
*current_thread
, struct scm_vm
*vp
,
749 scm_i_jmp_buf
*registers
, int resume
);
751 static const scm_t_vm_engine vm_engines
[SCM_VM_NUM_ENGINES
] =
752 { vm_regular_engine
, vm_debug_engine
};
755 allocate_stack (size_t size
)
756 #define FUNC_NAME "make_vm"
760 if (size
>= ((size_t) -1) / sizeof (SCM
))
763 size
*= sizeof (SCM
);
766 ret
= mmap (NULL
, size
, PROT_READ
| PROT_WRITE
,
767 MAP_PRIVATE
| MAP_ANONYMOUS
, -1, 0);
768 if (ret
== MAP_FAILED
)
776 perror ("allocate_stack failed");
785 free_stack (SCM
*stack
, size_t size
)
787 size
*= sizeof (SCM
);
790 munmap (stack
, size
);
797 expand_stack (SCM
*old_stack
, size_t old_size
, size_t new_size
)
798 #define FUNC_NAME "expand_stack"
800 #if defined MREMAP_MAYMOVE
803 if (new_size
>= ((size_t) -1) / sizeof (SCM
))
806 old_size
*= sizeof (SCM
);
807 new_size
*= sizeof (SCM
);
809 new_stack
= mremap (old_stack
, old_size
, new_size
, MREMAP_MAYMOVE
);
810 if (new_stack
== MAP_FAILED
)
813 return (SCM
*) new_stack
;
817 new_stack
= allocate_stack (new_size
);
821 memcpy (new_stack
, old_stack
, old_size
* sizeof (SCM
));
822 free_stack (old_stack
, old_size
);
829 static struct scm_vm
*
831 #define FUNC_NAME "make_vm"
836 vp
= scm_gc_malloc (sizeof (struct scm_vm
), "vm");
838 vp
->stack_size
= initial_stack_size
;
839 vp
->stack_base
= allocate_stack (vp
->stack_size
);
841 /* As in expand_stack, we don't have any way to throw an exception
842 if we can't allocate one measely page -- there's no stack to
843 handle it. For now, abort. */
845 vp
->stack_limit
= vp
->stack_base
+ vp
->stack_size
;
846 vp
->max_stack_size
= default_max_stack_size
;
848 vp
->sp
= vp
->stack_base
- 1;
850 vp
->engine
= vm_default_engine
;
852 for (i
= 0; i
< SCM_VM_NUM_HOOKS
; i
++)
853 vp
->hooks
[i
] = SCM_BOOL_F
;
860 return_unused_stack_to_os (struct scm_vm
*vp
)
863 scm_t_uintptr start
= (scm_t_uintptr
) (vp
->sp
+ 1);
864 scm_t_uintptr end
= (scm_t_uintptr
) vp
->stack_limit
;
865 /* The second condition is needed to protect against wrap-around. */
866 if (vp
->sp_max_since_gc
< vp
->stack_limit
&& vp
->sp
< vp
->sp_max_since_gc
)
867 end
= (scm_t_uintptr
) (vp
->sp_max_since_gc
+ 1);
869 start
= ((start
- 1U) | (page_size
- 1U)) + 1U; /* round up */
870 end
= ((end
- 1U) | (page_size
- 1U)) + 1U; /* round up */
872 /* Return these pages to the OS. The next time they are paged in,
873 they will be zeroed. */
879 ret
= madvise ((void *) start
, end
- start
, MADV_DONTNEED
);
880 while (ret
&& errno
== -EAGAIN
);
883 perror ("madvise failed");
886 vp
->sp_max_since_gc
= vp
->sp
;
890 #define DEAD_SLOT_MAP_CACHE_SIZE 32U
891 struct dead_slot_map_cache_entry
894 const scm_t_uint8
*map
;
897 struct dead_slot_map_cache
899 struct dead_slot_map_cache_entry entries
[DEAD_SLOT_MAP_CACHE_SIZE
];
902 static const scm_t_uint8
*
903 find_dead_slot_map (scm_t_uint32
*ip
, struct dead_slot_map_cache
*cache
)
905 /* The lower two bits should be zero. FIXME: Use a better hash
906 function; we don't expose scm_raw_hashq currently. */
907 size_t slot
= (((scm_t_uintptr
) ip
) >> 2) % DEAD_SLOT_MAP_CACHE_SIZE
;
908 const scm_t_uint8
*map
;
910 if (cache
->entries
[slot
].ip
== ip
)
911 map
= cache
->entries
[slot
].map
;
914 map
= scm_find_dead_slot_map_unlocked (ip
);
915 cache
->entries
[slot
].ip
= ip
;
916 cache
->entries
[slot
].map
= map
;
922 /* Mark the VM stack region between its base and its current top. */
924 scm_i_vm_mark_stack (struct scm_vm
*vp
, struct GC_ms_entry
*mark_stack_ptr
,
925 struct GC_ms_entry
*mark_stack_limit
)
928 /* The first frame will be marked conservatively (without a dead
929 slot map). This is because GC can happen at any point within the
930 hottest activation, due to multiple threads or per-instruction
931 hooks, and providing dead slot maps for all points in a program
932 would take a prohibitive amount of space. */
933 const scm_t_uint8
*dead_slots
= NULL
;
934 scm_t_uintptr upper
= (scm_t_uintptr
) GC_greatest_plausible_heap_addr
;
935 scm_t_uintptr lower
= (scm_t_uintptr
) GC_least_plausible_heap_addr
;
936 struct dead_slot_map_cache cache
;
938 memset (&cache
, 0, sizeof (cache
));
940 for (fp
= vp
->fp
, sp
= vp
->sp
; fp
; fp
= SCM_FRAME_DYNAMIC_LINK (fp
))
942 for (; sp
>= &SCM_FRAME_LOCAL (fp
, 0); sp
--)
946 && SCM_UNPACK (elt
) >= lower
&& SCM_UNPACK (elt
) <= upper
)
950 size_t slot
= sp
- &SCM_FRAME_LOCAL (fp
, 0);
951 if (dead_slots
[slot
/ 8U] & (1U << (slot
% 8U)))
953 /* This value may become dead as a result of GC,
954 so we can't just leave it on the stack. */
960 mark_stack_ptr
= GC_mark_and_push ((void *) elt
,
966 sp
= SCM_FRAME_PREVIOUS_SP (fp
);
967 /* Inner frames may have a dead slots map for precise marking.
968 Note that there may be other reasons to not have a dead slots
969 map, e.g. if all of the frame's slots below the callee frame
971 dead_slots
= find_dead_slot_map (SCM_FRAME_RETURN_ADDRESS (fp
), &cache
);
974 return_unused_stack_to_os (vp
);
976 return mark_stack_ptr
;
979 /* Free the VM stack, as this thread is exiting. */
981 scm_i_vm_free_stack (struct scm_vm
*vp
)
983 free_stack (vp
->stack_base
, vp
->stack_size
);
984 vp
->stack_base
= vp
->stack_limit
= NULL
;
989 vm_expand_stack (struct scm_vm
*vp
, SCM
*new_sp
)
991 scm_t_ptrdiff stack_size
= new_sp
+ 1 - vp
->stack_base
;
993 /* FIXME: Prevent GC while we expand the stack, to ensure that a
994 stack marker can trace the stack. */
995 if (stack_size
> vp
->stack_size
)
997 SCM
*old_stack
, *new_stack
;
1001 new_size
= vp
->stack_size
;
1002 while (new_size
< stack_size
)
1004 old_stack
= vp
->stack_base
;
1005 new_stack
= expand_stack (vp
->stack_base
, vp
->stack_size
, new_size
);
1007 scm_report_stack_overflow ();
1009 vp
->stack_base
= new_stack
;
1010 vp
->stack_size
= new_size
;
1011 vp
->stack_limit
= vp
->stack_base
+ new_size
;
1012 reloc
= vp
->stack_base
- old_stack
;
1023 SCM
*next_fp
= SCM_FRAME_DYNAMIC_LINK (fp
);
1027 SCM_FRAME_SET_DYNAMIC_LINK (fp
, next_fp
);
1034 vp
->sp_max_since_gc
= vp
->sp
= new_sp
;
1036 if (stack_size
>= vp
->max_stack_size
)
1038 /* Expand the soft limit by 256K entries to give us space to
1039 handle the error. */
1040 vp
->max_stack_size
+= 256 * 1024;
1042 /* If it's still not big enough... it's quite improbable, but go
1043 ahead and set to the full available stack size. */
1044 if (vp
->max_stack_size
< stack_size
)
1045 vp
->max_stack_size
= vp
->stack_size
;
1047 /* Finally, reset the limit, to catch further overflows. */
1048 vp
->stack_limit
= vp
->stack_base
+ vp
->max_stack_size
;
1050 /* FIXME: Use scm_report_stack_overflow, but in a mode that allows
1051 pre-unwind handlers to run. */
1052 vm_error ("VM: Stack overflow", SCM_UNDEFINED
);
1055 /* Otherwise continue, with the new enlarged stack. */
1058 static struct scm_vm
*
1059 thread_vm (scm_i_thread
*t
)
1061 if (SCM_UNLIKELY (!t
->vp
))
1070 return thread_vm (SCM_I_CURRENT_THREAD
);
1074 scm_call_n (SCM proc
, SCM
*argv
, size_t nargs
)
1076 scm_i_thread
*thread
;
1079 ptrdiff_t base_frame_size
;
1080 /* Cached variables. */
1081 scm_i_jmp_buf registers
; /* used for prompts */
1084 thread
= SCM_I_CURRENT_THREAD
;
1085 vp
= thread_vm (thread
);
1089 /* Check that we have enough space: 3 words for the boot continuation,
1090 and 3 + nargs for the procedure application. */
1091 base_frame_size
= 3 + 3 + nargs
;
1092 vm_push_sp (vp
, vp
->sp
+ base_frame_size
);
1093 base
= vp
->sp
+ 1 - base_frame_size
;
1095 /* Since it's possible to receive the arguments on the stack itself,
1096 shuffle up the arguments first. */
1097 for (i
= nargs
; i
> 0; i
--)
1098 base
[6 + i
- 1] = argv
[i
- 1];
1100 /* Push the boot continuation, which calls PROC and returns its
1102 base
[0] = SCM_PACK (vp
->fp
); /* dynamic link */
1103 base
[1] = SCM_PACK (vp
->ip
); /* ra */
1104 base
[2] = vm_boot_continuation
;
1106 vp
->ip
= (scm_t_uint32
*) vm_boot_continuation_code
;
1108 /* The pending call to PROC. */
1109 base
[3] = SCM_PACK (vp
->fp
); /* dynamic link */
1110 base
[4] = SCM_PACK (vp
->ip
); /* ra */
1115 int resume
= SCM_I_SETJMP (registers
);
1117 if (SCM_UNLIKELY (resume
))
1118 /* Non-local return. */
1119 vm_dispatch_abort_hook (vp
);
1121 return vm_engines
[vp
->engine
](thread
, vp
, ®isters
, resume
);
1125 /* Scheme interface */
1127 #define VM_DEFINE_HOOK(n) \
1129 struct scm_vm *vp; \
1130 vp = scm_the_vm (); \
1131 if (scm_is_false (vp->hooks[n])) \
1132 vp->hooks[n] = scm_make_hook (SCM_I_MAKINUM (1)); \
1133 return vp->hooks[n]; \
1136 SCM_DEFINE (scm_vm_apply_hook
, "vm-apply-hook", 0, 0, 0,
1139 #define FUNC_NAME s_scm_vm_apply_hook
1141 VM_DEFINE_HOOK (SCM_VM_APPLY_HOOK
);
1145 SCM_DEFINE (scm_vm_push_continuation_hook
, "vm-push-continuation-hook", 0, 0, 0,
1148 #define FUNC_NAME s_scm_vm_push_continuation_hook
1150 VM_DEFINE_HOOK (SCM_VM_PUSH_CONTINUATION_HOOK
);
1154 SCM_DEFINE (scm_vm_pop_continuation_hook
, "vm-pop-continuation-hook", 0, 0, 0,
1157 #define FUNC_NAME s_scm_vm_pop_continuation_hook
1159 VM_DEFINE_HOOK (SCM_VM_POP_CONTINUATION_HOOK
);
1163 SCM_DEFINE (scm_vm_next_hook
, "vm-next-hook", 0, 0, 0,
1166 #define FUNC_NAME s_scm_vm_next_hook
1168 VM_DEFINE_HOOK (SCM_VM_NEXT_HOOK
);
1172 SCM_DEFINE (scm_vm_abort_continuation_hook
, "vm-abort-continuation-hook", 0, 0, 0,
1175 #define FUNC_NAME s_scm_vm_abort_continuation_hook
1177 VM_DEFINE_HOOK (SCM_VM_ABORT_CONTINUATION_HOOK
);
1181 SCM_DEFINE (scm_vm_trace_level
, "vm-trace-level", 0, 0, 0,
1184 #define FUNC_NAME s_scm_vm_trace_level
1186 return scm_from_int (scm_the_vm ()->trace_level
);
1190 SCM_DEFINE (scm_set_vm_trace_level_x
, "set-vm-trace-level!", 1, 0, 0,
1193 #define FUNC_NAME s_scm_set_vm_trace_level_x
1195 scm_the_vm ()->trace_level
= scm_to_int (level
);
1196 return SCM_UNSPECIFIED
;
1206 symbol_to_vm_engine (SCM engine
, const char *FUNC_NAME
)
1208 if (scm_is_eq (engine
, sym_regular
))
1209 return SCM_VM_REGULAR_ENGINE
;
1210 else if (scm_is_eq (engine
, sym_debug
))
1211 return SCM_VM_DEBUG_ENGINE
;
1213 SCM_MISC_ERROR ("Unknown VM engine: ~a", scm_list_1 (engine
));
1217 vm_engine_to_symbol (int engine
, const char *FUNC_NAME
)
1221 case SCM_VM_REGULAR_ENGINE
:
1223 case SCM_VM_DEBUG_ENGINE
:
1227 SCM_MISC_ERROR ("Unknown VM engine: ~a",
1228 scm_list_1 (scm_from_int (engine
)));
1232 SCM_DEFINE (scm_vm_engine
, "vm-engine", 0, 0, 0,
1235 #define FUNC_NAME s_scm_vm_engine
1237 return vm_engine_to_symbol (scm_the_vm ()->engine
, FUNC_NAME
);
1242 scm_c_set_vm_engine_x (int engine
)
1243 #define FUNC_NAME "set-vm-engine!"
1245 if (engine
< 0 || engine
>= SCM_VM_NUM_ENGINES
)
1246 SCM_MISC_ERROR ("Unknown VM engine: ~a",
1247 scm_list_1 (scm_from_int (engine
)));
1249 scm_the_vm ()->engine
= engine
;
1253 SCM_DEFINE (scm_set_vm_engine_x
, "set-vm-engine!", 1, 0, 0,
1256 #define FUNC_NAME s_scm_set_vm_engine_x
1258 scm_c_set_vm_engine_x (symbol_to_vm_engine (engine
, FUNC_NAME
));
1259 return SCM_UNSPECIFIED
;
1264 scm_c_set_default_vm_engine_x (int engine
)
1265 #define FUNC_NAME "set-default-vm-engine!"
1267 if (engine
< 0 || engine
>= SCM_VM_NUM_ENGINES
)
1268 SCM_MISC_ERROR ("Unknown VM engine: ~a",
1269 scm_list_1 (scm_from_int (engine
)));
1271 vm_default_engine
= engine
;
1275 SCM_DEFINE (scm_set_default_vm_engine_x
, "set-default-vm-engine!", 1, 0, 0,
1278 #define FUNC_NAME s_scm_set_default_vm_engine_x
1280 scm_c_set_default_vm_engine_x (symbol_to_vm_engine (engine
, FUNC_NAME
));
1281 return SCM_UNSPECIFIED
;
1285 /* FIXME: This function makes no sense, but we keep it to make sure we
1286 have a way of switching to the debug or regular VM. */
1287 SCM_DEFINE (scm_call_with_vm
, "call-with-vm", 1, 0, 1,
1288 (SCM proc
, SCM args
),
1289 "Apply @var{proc} to @var{args} in a dynamic extent in which\n"
1290 "@var{vm} is the current VM.")
1291 #define FUNC_NAME s_scm_call_with_vm
1293 return scm_apply_0 (proc
, args
);
1303 scm_load_compiled_with_vm (SCM file
)
1305 return scm_call_0 (scm_load_thunk_from_file (file
));
1310 scm_init_vm_builtin_properties (void)
1312 /* FIXME: Seems hacky to do this here, but oh well :/ */
1313 scm_sym_apply
= scm_from_utf8_symbol ("apply");
1314 scm_sym_values
= scm_from_utf8_symbol ("values");
1315 scm_sym_abort_to_prompt
= scm_from_utf8_symbol ("abort-to-prompt");
1316 scm_sym_call_with_values
= scm_from_utf8_symbol ("call-with-values");
1317 scm_sym_call_with_current_continuation
=
1318 scm_from_utf8_symbol ("call-with-current-continuation");
1320 #define INIT_BUILTIN(builtin, BUILTIN, req, opt, rest) \
1321 scm_set_procedure_property_x (vm_builtin_##builtin, scm_sym_name, \
1322 scm_sym_##builtin); \
1323 scm_set_procedure_minimum_arity_x (vm_builtin_##builtin, \
1324 SCM_I_MAKINUM (req), \
1325 SCM_I_MAKINUM (opt), \
1326 scm_from_bool (rest));
1327 FOR_EACH_VM_BUILTIN (INIT_BUILTIN
);
1332 scm_bootstrap_vm (void)
1334 scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION
,
1336 (scm_t_extension_init_func
)scm_init_vm
, NULL
);
1337 scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION
,
1338 "scm_init_vm_builtins",
1339 (scm_t_extension_init_func
)scm_init_vm_builtins
,
1342 page_size
= getpagesize ();
1343 /* page_size should be a power of two. */
1344 if (page_size
& (page_size
- 1))
1347 initialize_default_stack_size ();
1349 sym_vm_run
= scm_from_latin1_symbol ("vm-run");
1350 sym_vm_error
= scm_from_latin1_symbol ("vm-error");
1351 sym_keyword_argument_error
= scm_from_latin1_symbol ("keyword-argument-error");
1352 sym_regular
= scm_from_latin1_symbol ("regular");
1353 sym_debug
= scm_from_latin1_symbol ("debug");
1355 vm_boot_continuation
= scm_i_make_program (vm_boot_continuation_code
);
1356 SCM_SET_CELL_WORD_0 (vm_boot_continuation
,
1357 (SCM_CELL_WORD_0 (vm_boot_continuation
)
1358 | SCM_F_PROGRAM_IS_BOOT
));
1360 #define DEFINE_BUILTIN(builtin, BUILTIN, req, opt, rest) \
1361 vm_builtin_##builtin = scm_i_make_program (vm_builtin_##builtin##_code);
1362 FOR_EACH_VM_BUILTIN (DEFINE_BUILTIN
);
1363 #undef DEFINE_BUILTIN
1369 #ifndef SCM_MAGIC_SNARFER
1370 #include "libguile/vm.x"