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 /* #define VM_ENABLE_PARANOID_ASSERTIONS */
67 static void vm_expand_stack (struct scm_vm
*vp
, SCM
*new_sp
) SCM_NOINLINE
;
69 /* RESTORE is for the case where we know we have done a PUSH of equal or
70 greater stack size in the past. Otherwise PUSH is the thing, which
71 may expand the stack. */
72 enum vm_increase_sp_kind
{ VM_SP_PUSH
, VM_SP_RESTORE
};
75 vm_increase_sp (struct scm_vm
*vp
, SCM
*new_sp
, enum vm_increase_sp_kind kind
)
77 if (new_sp
<= vp
->sp_max_since_gc
)
83 if (kind
== VM_SP_PUSH
&& new_sp
>= vp
->stack_limit
)
84 vm_expand_stack (vp
, new_sp
);
86 vp
->sp_max_since_gc
= vp
->sp
= new_sp
;
90 vm_push_sp (struct scm_vm
*vp
, SCM
*new_sp
)
92 vm_increase_sp (vp
, new_sp
, VM_SP_PUSH
);
96 vm_restore_sp (struct scm_vm
*vp
, SCM
*new_sp
)
98 vm_increase_sp (vp
, new_sp
, VM_SP_RESTORE
);
107 scm_i_vm_cont_print (SCM x
, SCM port
, scm_print_state
*pstate
)
109 scm_puts_unlocked ("#<vm-continuation ", port
);
110 scm_uintprint (SCM_UNPACK (x
), 16, port
);
111 scm_puts_unlocked (">", port
);
114 /* Ideally we could avoid copying the C stack if the continuation root
115 is inside VM code, and call/cc was invoked within that same call to
116 vm_run. That's currently not implemented. */
118 scm_i_vm_capture_stack (SCM
*stack_base
, SCM
*fp
, SCM
*sp
, scm_t_uint32
*ra
,
119 scm_t_dynstack
*dynstack
, scm_t_uint32 flags
)
121 struct scm_vm_cont
*p
;
123 p
= scm_gc_malloc (sizeof (*p
), "capture_vm_cont");
124 p
->stack_size
= sp
- stack_base
+ 1;
125 p
->stack_base
= scm_gc_malloc (p
->stack_size
* sizeof (SCM
),
130 memcpy (p
->stack_base
, stack_base
, (sp
+ 1 - stack_base
) * sizeof (SCM
));
131 p
->reloc
= p
->stack_base
- stack_base
;
132 p
->dynstack
= dynstack
;
134 return scm_cell (scm_tc7_vm_cont
, (scm_t_bits
)p
);
138 vm_return_to_continuation (struct scm_vm
*vp
, SCM cont
, size_t n
, SCM
*argv
)
140 struct scm_vm_cont
*cp
;
144 argv_copy
= alloca (n
* sizeof(SCM
));
145 memcpy (argv_copy
, argv
, n
* sizeof(SCM
));
147 cp
= SCM_VM_CONT_DATA (cont
);
149 /* FIXME: Need to prevent GC while futzing with the stack; otherwise,
150 another thread causing GC may initiate a mark of a stack in an
151 inconsistent state. */
153 /* We know that there is enough space for the continuation, because we
154 captured it in the past. However there may have been an expansion
155 since the capture, so we may have to re-link the frame
157 reloc
= (vp
->stack_base
- (cp
->stack_base
- cp
->reloc
));
158 vp
->fp
= cp
->fp
+ reloc
;
159 memcpy (vp
->stack_base
, cp
->stack_base
, cp
->stack_size
* sizeof (SCM
));
160 vm_restore_sp (vp
, cp
->sp
+ reloc
);
167 SCM
*next_fp
= SCM_FRAME_DYNAMIC_LINK (fp
);
171 SCM_FRAME_SET_DYNAMIC_LINK (fp
, next_fp
);
177 /* Now we have the continuation properly copied over. We just need to
178 copy the arguments. It is not guaranteed that there is actually
179 space for the arguments, though, so we have to bump the SP first. */
180 vm_push_sp (vp
, vp
->sp
+ 3 + n
);
182 /* Now copy on an empty frame and the return values, as the
183 continuation expects. */
185 SCM
*base
= vp
->sp
+ 1 - 3 - n
;
188 for (i
= 0; i
< 3; i
++)
189 base
[i
] = SCM_BOOL_F
;
191 for (i
= 0; i
< n
; i
++)
192 base
[i
+ 3] = argv_copy
[i
];
198 static struct scm_vm
* thread_vm (scm_i_thread
*t
);
200 scm_i_capture_current_stack (void)
202 scm_i_thread
*thread
;
205 thread
= SCM_I_CURRENT_THREAD
;
206 vp
= thread_vm (thread
);
208 return scm_i_vm_capture_stack (vp
->stack_base
, vp
->fp
, vp
->sp
, vp
->ip
,
209 scm_dynstack_capture_all (&thread
->dynstack
),
213 static void vm_dispatch_apply_hook (struct scm_vm
*vp
) SCM_NOINLINE
;
214 static void vm_dispatch_push_continuation_hook (struct scm_vm
*vp
) SCM_NOINLINE
;
215 static void vm_dispatch_pop_continuation_hook (struct scm_vm
*vp
, SCM
*old_fp
) SCM_NOINLINE
;
216 static void vm_dispatch_next_hook (struct scm_vm
*vp
) SCM_NOINLINE
;
217 static void vm_dispatch_abort_hook (struct scm_vm
*vp
) SCM_NOINLINE
;
220 vm_dispatch_hook (struct scm_vm
*vp
, int hook_num
, SCM
*argv
, int n
)
223 struct scm_frame c_frame
;
225 int saved_trace_level
;
227 hook
= vp
->hooks
[hook_num
];
229 if (SCM_LIKELY (scm_is_false (hook
))
230 || scm_is_null (SCM_HOOK_PROCEDURES (hook
)))
233 saved_trace_level
= vp
->trace_level
;
236 /* Allocate a frame object on the stack. This is more efficient than calling
237 `scm_c_make_frame ()' to allocate on the heap, but it forces hooks to not
238 capture frame objects.
240 At the same time, procedures such as `frame-procedure' make sense only
241 while the stack frame represented by the frame object is visible, so it
242 seems reasonable to limit the lifetime of frame objects. */
244 c_frame
.stack_holder
= vp
;
245 c_frame
.fp_offset
= vp
->fp
- vp
->stack_base
;
246 c_frame
.sp_offset
= vp
->sp
- vp
->stack_base
;
249 /* Arrange for FRAME to be 8-byte aligned, like any other cell. */
250 frame
= alloca (sizeof (*frame
) + 8);
251 frame
= (scm_t_cell
*) ROUND_UP ((scm_t_uintptr
) frame
, 8UL);
253 frame
->word_0
= SCM_PACK (scm_tc7_frame
| (SCM_VM_FRAME_KIND_VM
<< 8));
254 frame
->word_1
= SCM_PACK_POINTER (&c_frame
);
260 args
[0] = SCM_PACK_POINTER (frame
);
261 scm_c_run_hookn (hook
, args
, 1);
267 args
[0] = SCM_PACK_POINTER (frame
);
269 scm_c_run_hookn (hook
, args
, 2);
276 args
= scm_cons (argv
[n
], args
);
277 scm_c_run_hook (hook
, scm_cons (SCM_PACK_POINTER (frame
), args
));
280 vp
->trace_level
= saved_trace_level
;
284 vm_dispatch_apply_hook (struct scm_vm
*vp
)
286 return vm_dispatch_hook (vp
, SCM_VM_APPLY_HOOK
, NULL
, 0);
288 static void vm_dispatch_push_continuation_hook (struct scm_vm
*vp
)
290 return vm_dispatch_hook (vp
, SCM_VM_PUSH_CONTINUATION_HOOK
, NULL
, 0);
292 static void vm_dispatch_pop_continuation_hook (struct scm_vm
*vp
, SCM
*old_fp
)
294 return vm_dispatch_hook (vp
, SCM_VM_POP_CONTINUATION_HOOK
,
295 &SCM_FRAME_LOCAL (old_fp
, 1),
296 SCM_FRAME_NUM_LOCALS (old_fp
, vp
->sp
) - 1);
298 static void vm_dispatch_next_hook (struct scm_vm
*vp
)
300 return vm_dispatch_hook (vp
, SCM_VM_NEXT_HOOK
, NULL
, 0);
302 static void vm_dispatch_abort_hook (struct scm_vm
*vp
)
304 return vm_dispatch_hook (vp
, SCM_VM_ABORT_CONTINUATION_HOOK
,
305 &SCM_FRAME_LOCAL (vp
->fp
, 1),
306 SCM_FRAME_NUM_LOCALS (vp
->fp
, vp
->sp
) - 1);
310 vm_abort (struct scm_vm
*vp
, SCM tag
,
311 size_t nstack
, SCM
*stack_args
, SCM tail
, SCM
*sp
,
312 scm_i_jmp_buf
*current_registers
) SCM_NORETURN
;
315 vm_abort (struct scm_vm
*vp
, SCM tag
,
316 size_t nstack
, SCM
*stack_args
, SCM tail
, SCM
*sp
,
317 scm_i_jmp_buf
*current_registers
)
323 tail_len
= scm_ilength (tail
);
325 scm_misc_error ("vm-engine", "tail values to abort should be a list",
328 argv
= alloca ((nstack
+ tail_len
) * sizeof (SCM
));
329 for (i
= 0; i
< nstack
; i
++)
330 argv
[i
] = stack_args
[i
];
331 for (; i
< nstack
+ tail_len
; i
++, tail
= scm_cdr (tail
))
332 argv
[i
] = scm_car (tail
);
334 /* FIXME: NULLSTACK (SCM_VM_DATA (vp)->sp - sp) */
337 scm_c_abort (vp
, tag
, nstack
+ tail_len
, argv
, current_registers
);
341 vm_reinstate_partial_continuation (struct scm_vm
*vp
, SCM cont
,
343 scm_t_dynstack
*dynstack
,
344 scm_i_jmp_buf
*registers
)
346 struct scm_vm_cont
*cp
;
347 SCM
*argv_copy
, *base
;
351 argv_copy
= alloca (n
* sizeof(SCM
));
352 memcpy (argv_copy
, argv
, n
* sizeof(SCM
));
354 cp
= SCM_VM_CONT_DATA (cont
);
356 vm_push_sp (vp
, SCM_FRAME_LOCALS_ADDRESS (vp
->fp
) + cp
->stack_size
+ n
- 1);
358 base
= SCM_FRAME_LOCALS_ADDRESS (vp
->fp
);
359 reloc
= cp
->reloc
+ (base
- cp
->stack_base
);
361 memcpy (base
, cp
->stack_base
, cp
->stack_size
* sizeof (SCM
));
363 vp
->fp
= cp
->fp
+ reloc
;
366 /* now relocate frame pointers */
370 SCM_FRAME_LOWER_ADDRESS (fp
) > base
;
371 fp
= SCM_FRAME_DYNAMIC_LINK (fp
))
372 SCM_FRAME_SET_DYNAMIC_LINK (fp
, SCM_FRAME_DYNAMIC_LINK (fp
) + reloc
);
375 /* Push the arguments. */
376 for (i
= 0; i
< n
; i
++)
377 vp
->sp
[i
+ 1 - n
] = argv_copy
[i
];
379 /* The prompt captured a slice of the dynamic stack. Here we wind
380 those entries onto the current thread's stack. We also have to
381 relocate any prompts that we see along the way. */
385 for (walk
= SCM_DYNSTACK_FIRST (cp
->dynstack
);
386 SCM_DYNSTACK_TAG (walk
);
387 walk
= SCM_DYNSTACK_NEXT (walk
))
389 scm_t_bits tag
= SCM_DYNSTACK_TAG (walk
);
391 if (SCM_DYNSTACK_TAG_TYPE (tag
) == SCM_DYNSTACK_TYPE_PROMPT
)
392 scm_dynstack_wind_prompt (dynstack
, walk
, reloc
, registers
);
394 scm_dynstack_wind_1 (dynstack
, walk
);
404 static void vm_error (const char *msg
, SCM arg
) SCM_NORETURN
;
405 static void vm_error_bad_instruction (scm_t_uint32 inst
) SCM_NORETURN SCM_NOINLINE
;
406 static void vm_error_unbound (SCM proc
, SCM sym
) SCM_NORETURN SCM_NOINLINE
;
407 static void vm_error_unbound_fluid (SCM proc
, SCM fluid
) SCM_NORETURN SCM_NOINLINE
;
408 static void vm_error_not_a_variable (const char *func_name
, SCM x
) SCM_NORETURN SCM_NOINLINE
;
409 static void vm_error_apply_to_non_list (SCM x
) SCM_NORETURN SCM_NOINLINE
;
410 static void vm_error_kwargs_length_not_even (SCM proc
) SCM_NORETURN SCM_NOINLINE
;
411 static void vm_error_kwargs_invalid_keyword (SCM proc
, SCM obj
) SCM_NORETURN SCM_NOINLINE
;
412 static void vm_error_kwargs_unrecognized_keyword (SCM proc
, SCM kw
) SCM_NORETURN SCM_NOINLINE
;
413 static void vm_error_too_many_args (int nargs
) SCM_NORETURN SCM_NOINLINE
;
414 static void vm_error_wrong_num_args (SCM proc
) SCM_NORETURN SCM_NOINLINE
;
415 static void vm_error_wrong_type_apply (SCM proc
) SCM_NORETURN SCM_NOINLINE
;
416 static void vm_error_stack_underflow (void) SCM_NORETURN SCM_NOINLINE
;
417 static void vm_error_improper_list (SCM x
) SCM_NORETURN SCM_NOINLINE
;
418 static void vm_error_not_a_pair (const char *subr
, SCM x
) SCM_NORETURN SCM_NOINLINE
;
419 static void vm_error_not_a_bytevector (const char *subr
, SCM x
) SCM_NORETURN SCM_NOINLINE
;
420 static void vm_error_not_a_struct (const char *subr
, SCM x
) SCM_NORETURN SCM_NOINLINE
;
421 static void vm_error_not_a_vector (const char *subr
, SCM v
) SCM_NORETURN SCM_NOINLINE
;
422 static void vm_error_out_of_range (const char *subr
, SCM k
) SCM_NORETURN SCM_NOINLINE
;
423 static void vm_error_no_values (void) SCM_NORETURN SCM_NOINLINE
;
424 static void vm_error_not_enough_values (void) SCM_NORETURN SCM_NOINLINE
;
425 static void vm_error_wrong_number_of_values (scm_t_uint32 expected
) SCM_NORETURN SCM_NOINLINE
;
426 static void vm_error_continuation_not_rewindable (SCM cont
) SCM_NORETURN SCM_NOINLINE
;
427 static void vm_error_bad_wide_string_length (size_t len
) SCM_NORETURN SCM_NOINLINE
;
430 vm_error (const char *msg
, SCM arg
)
432 scm_throw (sym_vm_error
,
433 scm_list_3 (sym_vm_run
, scm_from_latin1_string (msg
),
434 SCM_UNBNDP (arg
) ? SCM_EOL
: scm_list_1 (arg
)));
435 abort(); /* not reached */
439 vm_error_bad_instruction (scm_t_uint32 inst
)
441 vm_error ("VM: Bad instruction: ~s", scm_from_uint32 (inst
));
445 vm_error_unbound (SCM proc
, SCM sym
)
447 scm_error_scm (scm_misc_error_key
, proc
,
448 scm_from_latin1_string ("Unbound variable: ~s"),
449 scm_list_1 (sym
), SCM_BOOL_F
);
453 vm_error_unbound_fluid (SCM proc
, SCM fluid
)
455 scm_error_scm (scm_misc_error_key
, proc
,
456 scm_from_latin1_string ("Unbound fluid: ~s"),
457 scm_list_1 (fluid
), SCM_BOOL_F
);
461 vm_error_not_a_variable (const char *func_name
, SCM x
)
463 scm_error (scm_arg_type_key
, func_name
, "Not a variable: ~S",
464 scm_list_1 (x
), scm_list_1 (x
));
468 vm_error_apply_to_non_list (SCM x
)
470 scm_error (scm_arg_type_key
, "apply", "Apply to non-list: ~S",
471 scm_list_1 (x
), scm_list_1 (x
));
475 vm_error_kwargs_length_not_even (SCM proc
)
477 scm_error_scm (sym_keyword_argument_error
, proc
,
478 scm_from_latin1_string ("Odd length of keyword argument list"),
479 SCM_EOL
, SCM_BOOL_F
);
483 vm_error_kwargs_invalid_keyword (SCM proc
, SCM obj
)
485 scm_error_scm (sym_keyword_argument_error
, proc
,
486 scm_from_latin1_string ("Invalid keyword"),
487 SCM_EOL
, scm_list_1 (obj
));
491 vm_error_kwargs_unrecognized_keyword (SCM proc
, SCM kw
)
493 scm_error_scm (sym_keyword_argument_error
, proc
,
494 scm_from_latin1_string ("Unrecognized keyword"),
495 SCM_EOL
, scm_list_1 (kw
));
499 vm_error_too_many_args (int nargs
)
501 vm_error ("VM: Too many arguments", scm_from_int (nargs
));
505 vm_error_wrong_num_args (SCM proc
)
507 scm_wrong_num_args (proc
);
511 vm_error_wrong_type_apply (SCM proc
)
513 scm_error (scm_arg_type_key
, NULL
, "Wrong type to apply: ~S",
514 scm_list_1 (proc
), scm_list_1 (proc
));
518 vm_error_stack_underflow (void)
520 vm_error ("VM: Stack underflow", SCM_UNDEFINED
);
524 vm_error_improper_list (SCM x
)
526 vm_error ("Expected a proper list, but got object with tail ~s", x
);
530 vm_error_not_a_pair (const char *subr
, SCM x
)
532 scm_wrong_type_arg_msg (subr
, 1, x
, "pair");
536 vm_error_not_a_bytevector (const char *subr
, SCM x
)
538 scm_wrong_type_arg_msg (subr
, 1, x
, "bytevector");
542 vm_error_not_a_struct (const char *subr
, SCM x
)
544 scm_wrong_type_arg_msg (subr
, 1, x
, "struct");
548 vm_error_not_a_vector (const char *subr
, SCM x
)
550 scm_wrong_type_arg_msg (subr
, 1, x
, "vector");
554 vm_error_out_of_range (const char *subr
, SCM k
)
557 scm_out_of_range (subr
, k
);
561 vm_error_no_values (void)
563 vm_error ("Zero values returned to single-valued continuation",
568 vm_error_not_enough_values (void)
570 vm_error ("Too few values returned to continuation", SCM_UNDEFINED
);
574 vm_error_wrong_number_of_values (scm_t_uint32 expected
)
576 vm_error ("Wrong number of values returned to continuation (expected ~a)",
577 scm_from_uint32 (expected
));
581 vm_error_continuation_not_rewindable (SCM cont
)
583 vm_error ("Unrewindable partial continuation", cont
);
587 vm_error_bad_wide_string_length (size_t len
)
589 vm_error ("VM: Bad wide string length: ~S", scm_from_size_t (len
));
595 static SCM vm_boot_continuation
;
596 static SCM vm_builtin_apply
;
597 static SCM vm_builtin_values
;
598 static SCM vm_builtin_abort_to_prompt
;
599 static SCM vm_builtin_call_with_values
;
600 static SCM vm_builtin_call_with_current_continuation
;
602 static const scm_t_uint32 vm_boot_continuation_code
[] = {
603 SCM_PACK_OP_24 (halt
, 0)
606 static const scm_t_uint32 vm_builtin_apply_code
[] = {
607 SCM_PACK_OP_24 (assert_nargs_ge
, 3),
608 SCM_PACK_OP_24 (tail_apply
, 0), /* proc in r1, args from r2 */
611 static const scm_t_uint32 vm_builtin_values_code
[] = {
612 SCM_PACK_OP_24 (return_values
, 0) /* vals from r1 */
615 static const scm_t_uint32 vm_builtin_abort_to_prompt_code
[] = {
616 SCM_PACK_OP_24 (assert_nargs_ge
, 2),
617 SCM_PACK_OP_24 (abort
, 0), /* tag in r1, vals from r2 */
618 /* FIXME: Partial continuation should capture caller regs. */
619 SCM_PACK_OP_24 (return_values
, 0) /* vals from r1 */
622 static const scm_t_uint32 vm_builtin_call_with_values_code
[] = {
623 SCM_PACK_OP_24 (assert_nargs_ee
, 3),
624 SCM_PACK_OP_24 (alloc_frame
, 7),
625 SCM_PACK_OP_12_12 (mov
, 6, 1),
626 SCM_PACK_OP_24 (call
, 6), SCM_PACK_OP_ARG_8_24 (0, 1),
627 SCM_PACK_OP_12_12 (mov
, 0, 2),
628 SCM_PACK_OP_24 (tail_call_shuffle
, 7)
631 static const scm_t_uint32 vm_builtin_call_with_current_continuation_code
[] = {
632 SCM_PACK_OP_24 (assert_nargs_ee
, 2),
633 SCM_PACK_OP_24 (call_cc
, 0)
638 scm_vm_builtin_ref (unsigned idx
)
642 #define INDEX_TO_NAME(builtin, BUILTIN, req, opt, rest) \
643 case SCM_VM_BUILTIN_##BUILTIN: return vm_builtin_##builtin;
644 FOR_EACH_VM_BUILTIN(INDEX_TO_NAME
)
651 static SCM scm_sym_values
;
652 static SCM scm_sym_abort_to_prompt
;
653 static SCM scm_sym_call_with_values
;
654 static SCM scm_sym_call_with_current_continuation
;
657 scm_vm_builtin_name_to_index (SCM name
)
658 #define FUNC_NAME "builtin-name->index"
660 SCM_VALIDATE_SYMBOL (1, name
);
662 #define NAME_TO_INDEX(builtin, BUILTIN, req, opt, rest) \
663 if (scm_is_eq (name, scm_sym_##builtin)) \
664 return scm_from_uint (SCM_VM_BUILTIN_##BUILTIN);
665 FOR_EACH_VM_BUILTIN(NAME_TO_INDEX
)
673 scm_vm_builtin_index_to_name (SCM index
)
674 #define FUNC_NAME "builtin-index->name"
678 SCM_VALIDATE_UINT_COPY (1, index
, idx
);
682 #define INDEX_TO_NAME(builtin, BUILTIN, req, opt, rest) \
683 case SCM_VM_BUILTIN_##BUILTIN: return scm_sym_##builtin;
684 FOR_EACH_VM_BUILTIN(INDEX_TO_NAME
)
686 default: return SCM_BOOL_F
;
692 scm_init_vm_builtins (void)
694 scm_c_define_gsubr ("builtin-name->index", 1, 0, 0,
695 scm_vm_builtin_name_to_index
);
696 scm_c_define_gsubr ("builtin-index->name", 1, 0, 0,
697 scm_vm_builtin_index_to_name
);
701 scm_i_call_with_current_continuation (SCM proc
)
703 return scm_call_1 (vm_builtin_call_with_current_continuation
, proc
);
712 static size_t page_size
;
714 /* Initial stack size. Defaults to one page. */
715 static size_t initial_stack_size
;
717 /* Default soft stack limit is 1M words (4 or 8 megabytes). */
718 static size_t default_max_stack_size
= 1024 * 1024;
721 initialize_default_stack_size (void)
723 initial_stack_size
= page_size
/ sizeof (SCM
);
727 size
= scm_getenv_int ("GUILE_STACK_SIZE", (int) default_max_stack_size
);
728 if (size
>= initial_stack_size
729 && (size_t) size
< ((size_t) -1) / sizeof(SCM
))
730 default_max_stack_size
= size
;
734 #define VM_NAME vm_regular_engine
735 #define VM_USE_HOOKS 0
736 #define FUNC_NAME "vm-regular-engine"
737 #include "vm-engine.c"
742 #define VM_NAME vm_debug_engine
743 #define VM_USE_HOOKS 1
744 #define FUNC_NAME "vm-debug-engine"
745 #include "vm-engine.c"
750 typedef SCM (*scm_t_vm_engine
) (scm_i_thread
*current_thread
, struct scm_vm
*vp
,
751 scm_i_jmp_buf
*registers
, int resume
);
753 static const scm_t_vm_engine vm_engines
[SCM_VM_NUM_ENGINES
] =
754 { vm_regular_engine
, vm_debug_engine
};
757 allocate_stack (size_t size
)
758 #define FUNC_NAME "make_vm"
762 if (size
>= ((size_t) -1) / sizeof (SCM
))
765 size
*= sizeof (SCM
);
768 ret
= mmap (NULL
, size
, PROT_READ
| PROT_WRITE
,
769 MAP_PRIVATE
| MAP_ANONYMOUS
, -1, 0);
770 if (ret
== MAP_FAILED
)
778 perror ("allocate_stack failed");
787 free_stack (SCM
*stack
, size_t size
)
789 size
*= sizeof (SCM
);
792 munmap (stack
, size
);
799 expand_stack (SCM
*old_stack
, size_t old_size
, size_t new_size
)
800 #define FUNC_NAME "expand_stack"
802 #if defined MREMAP_MAYMOVE
805 if (new_size
>= ((size_t) -1) / sizeof (SCM
))
808 old_size
*= sizeof (SCM
);
809 new_size
*= sizeof (SCM
);
811 new_stack
= mremap (old_stack
, old_size
, new_size
, MREMAP_MAYMOVE
);
812 if (new_stack
== MAP_FAILED
)
815 return (SCM
*) new_stack
;
819 new_stack
= allocate_stack (new_size
);
823 memcpy (new_stack
, old_stack
, old_size
* sizeof (SCM
));
824 free_stack (old_stack
, old_size
);
831 static struct scm_vm
*
833 #define FUNC_NAME "make_vm"
838 vp
= scm_gc_malloc (sizeof (struct scm_vm
), "vm");
840 vp
->stack_size
= initial_stack_size
;
841 vp
->stack_base
= allocate_stack (vp
->stack_size
);
843 /* As in expand_stack, we don't have any way to throw an exception
844 if we can't allocate one measely page -- there's no stack to
845 handle it. For now, abort. */
847 vp
->stack_limit
= vp
->stack_base
+ vp
->stack_size
;
848 vp
->max_stack_size
= default_max_stack_size
;
850 vp
->sp
= vp
->stack_base
- 1;
852 vp
->engine
= vm_default_engine
;
854 for (i
= 0; i
< SCM_VM_NUM_HOOKS
; i
++)
855 vp
->hooks
[i
] = SCM_BOOL_F
;
862 return_unused_stack_to_os (struct scm_vm
*vp
)
865 scm_t_uintptr start
= (scm_t_uintptr
) (vp
->sp
+ 1);
866 scm_t_uintptr end
= (scm_t_uintptr
) vp
->stack_limit
;
867 /* The second condition is needed to protect against wrap-around. */
868 if (vp
->sp_max_since_gc
< vp
->stack_limit
&& vp
->sp
< vp
->sp_max_since_gc
)
869 end
= (scm_t_uintptr
) (vp
->sp_max_since_gc
+ 1);
871 start
= ((start
- 1U) | (page_size
- 1U)) + 1U; /* round up */
872 end
= ((end
- 1U) | (page_size
- 1U)) + 1U; /* round up */
874 /* Return these pages to the OS. The next time they are paged in,
875 they will be zeroed. */
881 ret
= madvise ((void *) start
, end
- start
, MADV_DONTNEED
);
882 while (ret
&& errno
== -EAGAIN
);
885 perror ("madvise failed");
888 vp
->sp_max_since_gc
= vp
->sp
;
892 #define DEAD_SLOT_MAP_CACHE_SIZE 32U
893 struct dead_slot_map_cache_entry
896 const scm_t_uint8
*map
;
899 struct dead_slot_map_cache
901 struct dead_slot_map_cache_entry entries
[DEAD_SLOT_MAP_CACHE_SIZE
];
904 static const scm_t_uint8
*
905 find_dead_slot_map (scm_t_uint32
*ip
, struct dead_slot_map_cache
*cache
)
907 /* The lower two bits should be zero. FIXME: Use a better hash
908 function; we don't expose scm_raw_hashq currently. */
909 size_t slot
= (((scm_t_uintptr
) ip
) >> 2) % DEAD_SLOT_MAP_CACHE_SIZE
;
910 const scm_t_uint8
*map
;
912 if (cache
->entries
[slot
].ip
== ip
)
913 map
= cache
->entries
[slot
].map
;
916 map
= scm_find_dead_slot_map_unlocked (ip
);
917 cache
->entries
[slot
].ip
= ip
;
918 cache
->entries
[slot
].map
= map
;
924 /* Mark the VM stack region between its base and its current top. */
926 scm_i_vm_mark_stack (struct scm_vm
*vp
, struct GC_ms_entry
*mark_stack_ptr
,
927 struct GC_ms_entry
*mark_stack_limit
)
930 /* The first frame will be marked conservatively (without a dead
931 slot map). This is because GC can happen at any point within the
932 hottest activation, due to multiple threads or per-instruction
933 hooks, and providing dead slot maps for all points in a program
934 would take a prohibitive amount of space. */
935 const scm_t_uint8
*dead_slots
= NULL
;
936 scm_t_uintptr upper
= (scm_t_uintptr
) GC_greatest_plausible_heap_addr
;
937 scm_t_uintptr lower
= (scm_t_uintptr
) GC_least_plausible_heap_addr
;
938 struct dead_slot_map_cache cache
;
940 memset (&cache
, 0, sizeof (cache
));
942 for (fp
= vp
->fp
, sp
= vp
->sp
; fp
; fp
= SCM_FRAME_DYNAMIC_LINK (fp
))
944 for (; sp
>= &SCM_FRAME_LOCAL (fp
, 0); sp
--)
948 && SCM_UNPACK (elt
) >= lower
&& SCM_UNPACK (elt
) <= upper
)
952 size_t slot
= sp
- &SCM_FRAME_LOCAL (fp
, 0);
953 if (dead_slots
[slot
/ 8U] & (1U << (slot
% 8U)))
955 /* This value may become dead as a result of GC,
956 so we can't just leave it on the stack. */
962 mark_stack_ptr
= GC_mark_and_push ((void *) elt
,
968 sp
= SCM_FRAME_PREVIOUS_SP (fp
);
969 /* Inner frames may have a dead slots map for precise marking.
970 Note that there may be other reasons to not have a dead slots
971 map, e.g. if all of the frame's slots below the callee frame
973 dead_slots
= find_dead_slot_map (SCM_FRAME_RETURN_ADDRESS (fp
), &cache
);
976 return_unused_stack_to_os (vp
);
978 return mark_stack_ptr
;
981 /* Free the VM stack, as this thread is exiting. */
983 scm_i_vm_free_stack (struct scm_vm
*vp
)
985 free_stack (vp
->stack_base
, vp
->stack_size
);
986 vp
->stack_base
= vp
->stack_limit
= NULL
;
991 vm_expand_stack (struct scm_vm
*vp
, SCM
*new_sp
)
993 scm_t_ptrdiff stack_size
= new_sp
+ 1 - vp
->stack_base
;
995 /* FIXME: Prevent GC while we expand the stack, to ensure that a
996 stack marker can trace the stack. */
997 if (stack_size
> vp
->stack_size
)
999 SCM
*old_stack
, *new_stack
;
1001 scm_t_ptrdiff reloc
;
1003 new_size
= vp
->stack_size
;
1004 while (new_size
< stack_size
)
1006 old_stack
= vp
->stack_base
;
1007 new_stack
= expand_stack (vp
->stack_base
, vp
->stack_size
, new_size
);
1009 scm_report_stack_overflow ();
1011 vp
->stack_base
= new_stack
;
1012 vp
->stack_size
= new_size
;
1013 vp
->stack_limit
= vp
->stack_base
+ new_size
;
1014 reloc
= vp
->stack_base
- old_stack
;
1021 vp
->sp_max_since_gc
+= reloc
;
1025 SCM
*next_fp
= SCM_FRAME_DYNAMIC_LINK (fp
);
1029 SCM_FRAME_SET_DYNAMIC_LINK (fp
, next_fp
);
1038 if (stack_size
>= vp
->max_stack_size
)
1040 /* Expand the soft limit by 256K entries to give us space to
1041 handle the error. */
1042 vp
->max_stack_size
+= 256 * 1024;
1044 /* If it's still not big enough... it's quite improbable, but go
1045 ahead and set to the full available stack size. */
1046 if (vp
->max_stack_size
< stack_size
)
1047 vp
->max_stack_size
= vp
->stack_size
;
1049 /* Finally, reset the limit, to catch further overflows. */
1050 vp
->stack_limit
= vp
->stack_base
+ vp
->max_stack_size
;
1052 /* FIXME: Use scm_report_stack_overflow, but in a mode that allows
1053 pre-unwind handlers to run. */
1054 vm_error ("VM: Stack overflow", SCM_UNDEFINED
);
1057 /* Otherwise continue, with the new enlarged stack. */
1058 vp
->sp_max_since_gc
= vp
->sp
= new_sp
;
1061 static struct scm_vm
*
1062 thread_vm (scm_i_thread
*t
)
1064 if (SCM_UNLIKELY (!t
->vp
))
1073 return thread_vm (SCM_I_CURRENT_THREAD
);
1077 scm_call_n (SCM proc
, SCM
*argv
, size_t nargs
)
1079 scm_i_thread
*thread
;
1082 ptrdiff_t base_frame_size
;
1083 /* Cached variables. */
1084 scm_i_jmp_buf registers
; /* used for prompts */
1087 thread
= SCM_I_CURRENT_THREAD
;
1088 vp
= thread_vm (thread
);
1092 /* Check that we have enough space: 3 words for the boot continuation,
1093 and 3 + nargs for the procedure application. */
1094 base_frame_size
= 3 + 3 + nargs
;
1095 vm_push_sp (vp
, vp
->sp
+ base_frame_size
);
1096 base
= vp
->sp
+ 1 - base_frame_size
;
1098 /* Since it's possible to receive the arguments on the stack itself,
1099 shuffle up the arguments first. */
1100 for (i
= nargs
; i
> 0; i
--)
1101 base
[6 + i
- 1] = argv
[i
- 1];
1103 /* Push the boot continuation, which calls PROC and returns its
1105 base
[0] = SCM_PACK (vp
->fp
); /* dynamic link */
1106 base
[1] = SCM_PACK (vp
->ip
); /* ra */
1107 base
[2] = vm_boot_continuation
;
1109 vp
->ip
= (scm_t_uint32
*) vm_boot_continuation_code
;
1111 /* The pending call to PROC. */
1112 base
[3] = SCM_PACK (vp
->fp
); /* dynamic link */
1113 base
[4] = SCM_PACK (vp
->ip
); /* ra */
1118 int resume
= SCM_I_SETJMP (registers
);
1120 if (SCM_UNLIKELY (resume
))
1121 /* Non-local return. */
1122 vm_dispatch_abort_hook (vp
);
1124 return vm_engines
[vp
->engine
](thread
, vp
, ®isters
, resume
);
1128 /* Scheme interface */
1130 #define VM_DEFINE_HOOK(n) \
1132 struct scm_vm *vp; \
1133 vp = scm_the_vm (); \
1134 if (scm_is_false (vp->hooks[n])) \
1135 vp->hooks[n] = scm_make_hook (SCM_I_MAKINUM (1)); \
1136 return vp->hooks[n]; \
1139 SCM_DEFINE (scm_vm_apply_hook
, "vm-apply-hook", 0, 0, 0,
1142 #define FUNC_NAME s_scm_vm_apply_hook
1144 VM_DEFINE_HOOK (SCM_VM_APPLY_HOOK
);
1148 SCM_DEFINE (scm_vm_push_continuation_hook
, "vm-push-continuation-hook", 0, 0, 0,
1151 #define FUNC_NAME s_scm_vm_push_continuation_hook
1153 VM_DEFINE_HOOK (SCM_VM_PUSH_CONTINUATION_HOOK
);
1157 SCM_DEFINE (scm_vm_pop_continuation_hook
, "vm-pop-continuation-hook", 0, 0, 0,
1160 #define FUNC_NAME s_scm_vm_pop_continuation_hook
1162 VM_DEFINE_HOOK (SCM_VM_POP_CONTINUATION_HOOK
);
1166 SCM_DEFINE (scm_vm_next_hook
, "vm-next-hook", 0, 0, 0,
1169 #define FUNC_NAME s_scm_vm_next_hook
1171 VM_DEFINE_HOOK (SCM_VM_NEXT_HOOK
);
1175 SCM_DEFINE (scm_vm_abort_continuation_hook
, "vm-abort-continuation-hook", 0, 0, 0,
1178 #define FUNC_NAME s_scm_vm_abort_continuation_hook
1180 VM_DEFINE_HOOK (SCM_VM_ABORT_CONTINUATION_HOOK
);
1184 SCM_DEFINE (scm_vm_trace_level
, "vm-trace-level", 0, 0, 0,
1187 #define FUNC_NAME s_scm_vm_trace_level
1189 return scm_from_int (scm_the_vm ()->trace_level
);
1193 SCM_DEFINE (scm_set_vm_trace_level_x
, "set-vm-trace-level!", 1, 0, 0,
1196 #define FUNC_NAME s_scm_set_vm_trace_level_x
1198 scm_the_vm ()->trace_level
= scm_to_int (level
);
1199 return SCM_UNSPECIFIED
;
1209 symbol_to_vm_engine (SCM engine
, const char *FUNC_NAME
)
1211 if (scm_is_eq (engine
, sym_regular
))
1212 return SCM_VM_REGULAR_ENGINE
;
1213 else if (scm_is_eq (engine
, sym_debug
))
1214 return SCM_VM_DEBUG_ENGINE
;
1216 SCM_MISC_ERROR ("Unknown VM engine: ~a", scm_list_1 (engine
));
1220 vm_engine_to_symbol (int engine
, const char *FUNC_NAME
)
1224 case SCM_VM_REGULAR_ENGINE
:
1226 case SCM_VM_DEBUG_ENGINE
:
1230 SCM_MISC_ERROR ("Unknown VM engine: ~a",
1231 scm_list_1 (scm_from_int (engine
)));
1235 SCM_DEFINE (scm_vm_engine
, "vm-engine", 0, 0, 0,
1238 #define FUNC_NAME s_scm_vm_engine
1240 return vm_engine_to_symbol (scm_the_vm ()->engine
, FUNC_NAME
);
1245 scm_c_set_vm_engine_x (int engine
)
1246 #define FUNC_NAME "set-vm-engine!"
1248 if (engine
< 0 || engine
>= SCM_VM_NUM_ENGINES
)
1249 SCM_MISC_ERROR ("Unknown VM engine: ~a",
1250 scm_list_1 (scm_from_int (engine
)));
1252 scm_the_vm ()->engine
= engine
;
1256 SCM_DEFINE (scm_set_vm_engine_x
, "set-vm-engine!", 1, 0, 0,
1259 #define FUNC_NAME s_scm_set_vm_engine_x
1261 scm_c_set_vm_engine_x (symbol_to_vm_engine (engine
, FUNC_NAME
));
1262 return SCM_UNSPECIFIED
;
1267 scm_c_set_default_vm_engine_x (int engine
)
1268 #define FUNC_NAME "set-default-vm-engine!"
1270 if (engine
< 0 || engine
>= SCM_VM_NUM_ENGINES
)
1271 SCM_MISC_ERROR ("Unknown VM engine: ~a",
1272 scm_list_1 (scm_from_int (engine
)));
1274 vm_default_engine
= engine
;
1278 SCM_DEFINE (scm_set_default_vm_engine_x
, "set-default-vm-engine!", 1, 0, 0,
1281 #define FUNC_NAME s_scm_set_default_vm_engine_x
1283 scm_c_set_default_vm_engine_x (symbol_to_vm_engine (engine
, FUNC_NAME
));
1284 return SCM_UNSPECIFIED
;
1288 /* FIXME: This function makes no sense, but we keep it to make sure we
1289 have a way of switching to the debug or regular VM. */
1290 SCM_DEFINE (scm_call_with_vm
, "call-with-vm", 1, 0, 1,
1291 (SCM proc
, SCM args
),
1292 "Apply @var{proc} to @var{args} in a dynamic extent in which\n"
1293 "@var{vm} is the current VM.")
1294 #define FUNC_NAME s_scm_call_with_vm
1296 return scm_apply_0 (proc
, args
);
1306 scm_load_compiled_with_vm (SCM file
)
1308 return scm_call_0 (scm_load_thunk_from_file (file
));
1313 scm_init_vm_builtin_properties (void)
1315 /* FIXME: Seems hacky to do this here, but oh well :/ */
1316 scm_sym_apply
= scm_from_utf8_symbol ("apply");
1317 scm_sym_values
= scm_from_utf8_symbol ("values");
1318 scm_sym_abort_to_prompt
= scm_from_utf8_symbol ("abort-to-prompt");
1319 scm_sym_call_with_values
= scm_from_utf8_symbol ("call-with-values");
1320 scm_sym_call_with_current_continuation
=
1321 scm_from_utf8_symbol ("call-with-current-continuation");
1323 #define INIT_BUILTIN(builtin, BUILTIN, req, opt, rest) \
1324 scm_set_procedure_property_x (vm_builtin_##builtin, scm_sym_name, \
1325 scm_sym_##builtin); \
1326 scm_set_procedure_minimum_arity_x (vm_builtin_##builtin, \
1327 SCM_I_MAKINUM (req), \
1328 SCM_I_MAKINUM (opt), \
1329 scm_from_bool (rest));
1330 FOR_EACH_VM_BUILTIN (INIT_BUILTIN
);
1335 scm_bootstrap_vm (void)
1337 scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION
,
1339 (scm_t_extension_init_func
)scm_init_vm
, NULL
);
1340 scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION
,
1341 "scm_init_vm_builtins",
1342 (scm_t_extension_init_func
)scm_init_vm_builtins
,
1345 page_size
= getpagesize ();
1346 /* page_size should be a power of two. */
1347 if (page_size
& (page_size
- 1))
1350 initialize_default_stack_size ();
1352 sym_vm_run
= scm_from_latin1_symbol ("vm-run");
1353 sym_vm_error
= scm_from_latin1_symbol ("vm-error");
1354 sym_keyword_argument_error
= scm_from_latin1_symbol ("keyword-argument-error");
1355 sym_regular
= scm_from_latin1_symbol ("regular");
1356 sym_debug
= scm_from_latin1_symbol ("debug");
1358 vm_boot_continuation
= scm_i_make_program (vm_boot_continuation_code
);
1359 SCM_SET_CELL_WORD_0 (vm_boot_continuation
,
1360 (SCM_CELL_WORD_0 (vm_boot_continuation
)
1361 | SCM_F_PROGRAM_IS_BOOT
));
1363 #define DEFINE_BUILTIN(builtin, BUILTIN, req, opt, rest) \
1364 vm_builtin_##builtin = scm_i_make_program (vm_builtin_##builtin##_code);
1365 FOR_EACH_VM_BUILTIN (DEFINE_BUILTIN
);
1366 #undef DEFINE_BUILTIN
1372 #ifndef SCM_MAGIC_SNARFER
1373 #include "libguile/vm.x"