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
);
135 struct return_to_continuation_data
137 struct scm_vm_cont
*cp
;
141 /* Called with the GC lock to prevent the stack marker from traversing a
142 stack in an inconsistent state. */
144 vm_return_to_continuation_inner (void *data_ptr
)
146 struct return_to_continuation_data
*data
= data_ptr
;
147 struct scm_vm
*vp
= data
->vp
;
148 struct scm_vm_cont
*cp
= data
->cp
;
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
);
179 vm_return_to_continuation (struct scm_vm
*vp
, SCM cont
, size_t n
, SCM
*argv
)
181 struct scm_vm_cont
*cp
;
183 struct return_to_continuation_data data
;
185 argv_copy
= alloca (n
* sizeof(SCM
));
186 memcpy (argv_copy
, argv
, n
* sizeof(SCM
));
188 cp
= SCM_VM_CONT_DATA (cont
);
192 GC_call_with_alloc_lock (vm_return_to_continuation_inner
, &data
);
194 /* Now we have the continuation properly copied over. We just need to
195 copy the arguments. It is not guaranteed that there is actually
196 space for the arguments, though, so we have to bump the SP first. */
197 vm_push_sp (vp
, vp
->sp
+ 3 + n
);
199 /* Now copy on an empty frame and the return values, as the
200 continuation expects. */
202 SCM
*base
= vp
->sp
+ 1 - 3 - n
;
205 for (i
= 0; i
< 3; i
++)
206 base
[i
] = SCM_BOOL_F
;
208 for (i
= 0; i
< n
; i
++)
209 base
[i
+ 3] = argv_copy
[i
];
215 static struct scm_vm
* thread_vm (scm_i_thread
*t
);
217 scm_i_capture_current_stack (void)
219 scm_i_thread
*thread
;
222 thread
= SCM_I_CURRENT_THREAD
;
223 vp
= thread_vm (thread
);
225 return scm_i_vm_capture_stack (vp
->stack_base
, vp
->fp
, vp
->sp
, vp
->ip
,
226 scm_dynstack_capture_all (&thread
->dynstack
),
230 static void vm_dispatch_apply_hook (struct scm_vm
*vp
) SCM_NOINLINE
;
231 static void vm_dispatch_push_continuation_hook (struct scm_vm
*vp
) SCM_NOINLINE
;
232 static void vm_dispatch_pop_continuation_hook (struct scm_vm
*vp
, SCM
*old_fp
) SCM_NOINLINE
;
233 static void vm_dispatch_next_hook (struct scm_vm
*vp
) SCM_NOINLINE
;
234 static void vm_dispatch_abort_hook (struct scm_vm
*vp
) SCM_NOINLINE
;
237 vm_dispatch_hook (struct scm_vm
*vp
, int hook_num
, SCM
*argv
, int n
)
240 struct scm_frame c_frame
;
242 int saved_trace_level
;
244 hook
= vp
->hooks
[hook_num
];
246 if (SCM_LIKELY (scm_is_false (hook
))
247 || scm_is_null (SCM_HOOK_PROCEDURES (hook
)))
250 saved_trace_level
= vp
->trace_level
;
253 /* Allocate a frame object on the stack. This is more efficient than calling
254 `scm_c_make_frame ()' to allocate on the heap, but it forces hooks to not
255 capture frame objects.
257 At the same time, procedures such as `frame-procedure' make sense only
258 while the stack frame represented by the frame object is visible, so it
259 seems reasonable to limit the lifetime of frame objects. */
261 c_frame
.stack_holder
= vp
;
262 c_frame
.fp_offset
= vp
->fp
- vp
->stack_base
;
263 c_frame
.sp_offset
= vp
->sp
- vp
->stack_base
;
266 /* Arrange for FRAME to be 8-byte aligned, like any other cell. */
267 frame
= alloca (sizeof (*frame
) + 8);
268 frame
= (scm_t_cell
*) ROUND_UP ((scm_t_uintptr
) frame
, 8UL);
270 frame
->word_0
= SCM_PACK (scm_tc7_frame
| (SCM_VM_FRAME_KIND_VM
<< 8));
271 frame
->word_1
= SCM_PACK_POINTER (&c_frame
);
277 args
[0] = SCM_PACK_POINTER (frame
);
278 scm_c_run_hookn (hook
, args
, 1);
284 args
[0] = SCM_PACK_POINTER (frame
);
286 scm_c_run_hookn (hook
, args
, 2);
293 args
= scm_cons (argv
[n
], args
);
294 scm_c_run_hook (hook
, scm_cons (SCM_PACK_POINTER (frame
), args
));
297 vp
->trace_level
= saved_trace_level
;
301 vm_dispatch_apply_hook (struct scm_vm
*vp
)
303 return vm_dispatch_hook (vp
, SCM_VM_APPLY_HOOK
, NULL
, 0);
305 static void vm_dispatch_push_continuation_hook (struct scm_vm
*vp
)
307 return vm_dispatch_hook (vp
, SCM_VM_PUSH_CONTINUATION_HOOK
, NULL
, 0);
309 static void vm_dispatch_pop_continuation_hook (struct scm_vm
*vp
, SCM
*old_fp
)
311 return vm_dispatch_hook (vp
, SCM_VM_POP_CONTINUATION_HOOK
,
312 &SCM_FRAME_LOCAL (old_fp
, 1),
313 SCM_FRAME_NUM_LOCALS (old_fp
, vp
->sp
) - 1);
315 static void vm_dispatch_next_hook (struct scm_vm
*vp
)
317 return vm_dispatch_hook (vp
, SCM_VM_NEXT_HOOK
, NULL
, 0);
319 static void vm_dispatch_abort_hook (struct scm_vm
*vp
)
321 return vm_dispatch_hook (vp
, SCM_VM_ABORT_CONTINUATION_HOOK
,
322 &SCM_FRAME_LOCAL (vp
->fp
, 1),
323 SCM_FRAME_NUM_LOCALS (vp
->fp
, vp
->sp
) - 1);
327 vm_abort (struct scm_vm
*vp
, SCM tag
,
328 size_t nstack
, SCM
*stack_args
, SCM tail
, SCM
*sp
,
329 scm_i_jmp_buf
*current_registers
) SCM_NORETURN
;
332 vm_abort (struct scm_vm
*vp
, SCM tag
,
333 size_t nstack
, SCM
*stack_args
, SCM tail
, SCM
*sp
,
334 scm_i_jmp_buf
*current_registers
)
340 tail_len
= scm_ilength (tail
);
342 scm_misc_error ("vm-engine", "tail values to abort should be a list",
345 argv
= alloca ((nstack
+ tail_len
) * sizeof (SCM
));
346 for (i
= 0; i
< nstack
; i
++)
347 argv
[i
] = stack_args
[i
];
348 for (; i
< nstack
+ tail_len
; i
++, tail
= scm_cdr (tail
))
349 argv
[i
] = scm_car (tail
);
353 scm_c_abort (vp
, tag
, nstack
+ tail_len
, argv
, current_registers
);
356 struct vm_reinstate_partial_continuation_data
359 struct scm_vm_cont
*cp
;
364 vm_reinstate_partial_continuation_inner (void *data_ptr
)
366 struct vm_reinstate_partial_continuation_data
*data
= data_ptr
;
367 struct scm_vm
*vp
= data
->vp
;
368 struct scm_vm_cont
*cp
= data
->cp
;
372 base
= SCM_FRAME_LOCALS_ADDRESS (vp
->fp
);
373 reloc
= cp
->reloc
+ (base
- cp
->stack_base
);
375 memcpy (base
, cp
->stack_base
, cp
->stack_size
* sizeof (SCM
));
377 vp
->fp
= cp
->fp
+ reloc
;
380 /* now relocate frame pointers */
384 SCM_FRAME_LOWER_ADDRESS (fp
) > base
;
385 fp
= SCM_FRAME_DYNAMIC_LINK (fp
))
386 SCM_FRAME_SET_DYNAMIC_LINK (fp
, SCM_FRAME_DYNAMIC_LINK (fp
) + reloc
);
395 vm_reinstate_partial_continuation (struct scm_vm
*vp
, SCM cont
,
397 scm_t_dynstack
*dynstack
,
398 scm_i_jmp_buf
*registers
)
400 struct vm_reinstate_partial_continuation_data data
;
401 struct scm_vm_cont
*cp
;
406 argv_copy
= alloca (n
* sizeof(SCM
));
407 memcpy (argv_copy
, argv
, n
* sizeof(SCM
));
409 cp
= SCM_VM_CONT_DATA (cont
);
411 vm_push_sp (vp
, SCM_FRAME_LOCALS_ADDRESS (vp
->fp
) + cp
->stack_size
+ n
- 1);
415 GC_call_with_alloc_lock (vm_reinstate_partial_continuation_inner
, &data
);
418 /* Push the arguments. */
419 for (i
= 0; i
< n
; i
++)
420 vp
->sp
[i
+ 1 - n
] = argv_copy
[i
];
422 /* The prompt captured a slice of the dynamic stack. Here we wind
423 those entries onto the current thread's stack. We also have to
424 relocate any prompts that we see along the way. */
428 for (walk
= SCM_DYNSTACK_FIRST (cp
->dynstack
);
429 SCM_DYNSTACK_TAG (walk
);
430 walk
= SCM_DYNSTACK_NEXT (walk
))
432 scm_t_bits tag
= SCM_DYNSTACK_TAG (walk
);
434 if (SCM_DYNSTACK_TAG_TYPE (tag
) == SCM_DYNSTACK_TYPE_PROMPT
)
435 scm_dynstack_wind_prompt (dynstack
, walk
, reloc
, registers
);
437 scm_dynstack_wind_1 (dynstack
, walk
);
447 static void vm_error (const char *msg
, SCM arg
) SCM_NORETURN
;
448 static void vm_error_bad_instruction (scm_t_uint32 inst
) SCM_NORETURN SCM_NOINLINE
;
449 static void vm_error_unbound (SCM proc
, SCM sym
) SCM_NORETURN SCM_NOINLINE
;
450 static void vm_error_unbound_fluid (SCM proc
, SCM fluid
) SCM_NORETURN SCM_NOINLINE
;
451 static void vm_error_not_a_variable (const char *func_name
, SCM x
) SCM_NORETURN SCM_NOINLINE
;
452 static void vm_error_apply_to_non_list (SCM x
) SCM_NORETURN SCM_NOINLINE
;
453 static void vm_error_kwargs_length_not_even (SCM proc
) SCM_NORETURN SCM_NOINLINE
;
454 static void vm_error_kwargs_invalid_keyword (SCM proc
, SCM obj
) SCM_NORETURN SCM_NOINLINE
;
455 static void vm_error_kwargs_unrecognized_keyword (SCM proc
, SCM kw
) SCM_NORETURN SCM_NOINLINE
;
456 static void vm_error_too_many_args (int nargs
) SCM_NORETURN SCM_NOINLINE
;
457 static void vm_error_wrong_num_args (SCM proc
) SCM_NORETURN SCM_NOINLINE
;
458 static void vm_error_wrong_type_apply (SCM proc
) SCM_NORETURN SCM_NOINLINE
;
459 static void vm_error_stack_underflow (void) SCM_NORETURN SCM_NOINLINE
;
460 static void vm_error_improper_list (SCM x
) SCM_NORETURN SCM_NOINLINE
;
461 static void vm_error_not_a_pair (const char *subr
, SCM x
) SCM_NORETURN SCM_NOINLINE
;
462 static void vm_error_not_a_bytevector (const char *subr
, SCM x
) SCM_NORETURN SCM_NOINLINE
;
463 static void vm_error_not_a_struct (const char *subr
, SCM x
) SCM_NORETURN SCM_NOINLINE
;
464 static void vm_error_not_a_vector (const char *subr
, SCM v
) SCM_NORETURN SCM_NOINLINE
;
465 static void vm_error_out_of_range (const char *subr
, SCM k
) SCM_NORETURN SCM_NOINLINE
;
466 static void vm_error_no_values (void) SCM_NORETURN SCM_NOINLINE
;
467 static void vm_error_not_enough_values (void) SCM_NORETURN SCM_NOINLINE
;
468 static void vm_error_wrong_number_of_values (scm_t_uint32 expected
) SCM_NORETURN SCM_NOINLINE
;
469 static void vm_error_continuation_not_rewindable (SCM cont
) SCM_NORETURN SCM_NOINLINE
;
470 static void vm_error_bad_wide_string_length (size_t len
) SCM_NORETURN SCM_NOINLINE
;
473 vm_error (const char *msg
, SCM arg
)
475 scm_throw (sym_vm_error
,
476 scm_list_3 (sym_vm_run
, scm_from_latin1_string (msg
),
477 SCM_UNBNDP (arg
) ? SCM_EOL
: scm_list_1 (arg
)));
478 abort(); /* not reached */
482 vm_error_bad_instruction (scm_t_uint32 inst
)
484 vm_error ("VM: Bad instruction: ~s", scm_from_uint32 (inst
));
488 vm_error_unbound (SCM proc
, SCM sym
)
490 scm_error_scm (scm_misc_error_key
, proc
,
491 scm_from_latin1_string ("Unbound variable: ~s"),
492 scm_list_1 (sym
), SCM_BOOL_F
);
496 vm_error_unbound_fluid (SCM proc
, SCM fluid
)
498 scm_error_scm (scm_misc_error_key
, proc
,
499 scm_from_latin1_string ("Unbound fluid: ~s"),
500 scm_list_1 (fluid
), SCM_BOOL_F
);
504 vm_error_not_a_variable (const char *func_name
, SCM x
)
506 scm_error (scm_arg_type_key
, func_name
, "Not a variable: ~S",
507 scm_list_1 (x
), scm_list_1 (x
));
511 vm_error_apply_to_non_list (SCM x
)
513 scm_error (scm_arg_type_key
, "apply", "Apply to non-list: ~S",
514 scm_list_1 (x
), scm_list_1 (x
));
518 vm_error_kwargs_length_not_even (SCM proc
)
520 scm_error_scm (sym_keyword_argument_error
, proc
,
521 scm_from_latin1_string ("Odd length of keyword argument list"),
522 SCM_EOL
, SCM_BOOL_F
);
526 vm_error_kwargs_invalid_keyword (SCM proc
, SCM obj
)
528 scm_error_scm (sym_keyword_argument_error
, proc
,
529 scm_from_latin1_string ("Invalid keyword"),
530 SCM_EOL
, scm_list_1 (obj
));
534 vm_error_kwargs_unrecognized_keyword (SCM proc
, SCM kw
)
536 scm_error_scm (sym_keyword_argument_error
, proc
,
537 scm_from_latin1_string ("Unrecognized keyword"),
538 SCM_EOL
, scm_list_1 (kw
));
542 vm_error_too_many_args (int nargs
)
544 vm_error ("VM: Too many arguments", scm_from_int (nargs
));
548 vm_error_wrong_num_args (SCM proc
)
550 scm_wrong_num_args (proc
);
554 vm_error_wrong_type_apply (SCM proc
)
556 scm_error (scm_arg_type_key
, NULL
, "Wrong type to apply: ~S",
557 scm_list_1 (proc
), scm_list_1 (proc
));
561 vm_error_stack_underflow (void)
563 vm_error ("VM: Stack underflow", SCM_UNDEFINED
);
567 vm_error_improper_list (SCM x
)
569 vm_error ("Expected a proper list, but got object with tail ~s", x
);
573 vm_error_not_a_pair (const char *subr
, SCM x
)
575 scm_wrong_type_arg_msg (subr
, 1, x
, "pair");
579 vm_error_not_a_bytevector (const char *subr
, SCM x
)
581 scm_wrong_type_arg_msg (subr
, 1, x
, "bytevector");
585 vm_error_not_a_struct (const char *subr
, SCM x
)
587 scm_wrong_type_arg_msg (subr
, 1, x
, "struct");
591 vm_error_not_a_vector (const char *subr
, SCM x
)
593 scm_wrong_type_arg_msg (subr
, 1, x
, "vector");
597 vm_error_out_of_range (const char *subr
, SCM k
)
600 scm_out_of_range (subr
, k
);
604 vm_error_no_values (void)
606 vm_error ("Zero values returned to single-valued continuation",
611 vm_error_not_enough_values (void)
613 vm_error ("Too few values returned to continuation", SCM_UNDEFINED
);
617 vm_error_wrong_number_of_values (scm_t_uint32 expected
)
619 vm_error ("Wrong number of values returned to continuation (expected ~a)",
620 scm_from_uint32 (expected
));
624 vm_error_continuation_not_rewindable (SCM cont
)
626 vm_error ("Unrewindable partial continuation", cont
);
630 vm_error_bad_wide_string_length (size_t len
)
632 vm_error ("VM: Bad wide string length: ~S", scm_from_size_t (len
));
638 static SCM vm_boot_continuation
;
639 static SCM vm_builtin_apply
;
640 static SCM vm_builtin_values
;
641 static SCM vm_builtin_abort_to_prompt
;
642 static SCM vm_builtin_call_with_values
;
643 static SCM vm_builtin_call_with_current_continuation
;
645 static const scm_t_uint32 vm_boot_continuation_code
[] = {
646 SCM_PACK_OP_24 (halt
, 0)
649 static const scm_t_uint32 vm_builtin_apply_code
[] = {
650 SCM_PACK_OP_24 (assert_nargs_ge
, 3),
651 SCM_PACK_OP_24 (tail_apply
, 0), /* proc in r1, args from r2 */
654 static const scm_t_uint32 vm_builtin_values_code
[] = {
655 SCM_PACK_OP_24 (return_values
, 0) /* vals from r1 */
658 static const scm_t_uint32 vm_builtin_abort_to_prompt_code
[] = {
659 SCM_PACK_OP_24 (assert_nargs_ge
, 2),
660 SCM_PACK_OP_24 (abort
, 0), /* tag in r1, vals from r2 */
661 /* FIXME: Partial continuation should capture caller regs. */
662 SCM_PACK_OP_24 (return_values
, 0) /* vals from r1 */
665 static const scm_t_uint32 vm_builtin_call_with_values_code
[] = {
666 SCM_PACK_OP_24 (assert_nargs_ee
, 3),
667 SCM_PACK_OP_24 (alloc_frame
, 7),
668 SCM_PACK_OP_12_12 (mov
, 6, 1),
669 SCM_PACK_OP_24 (call
, 6), SCM_PACK_OP_ARG_8_24 (0, 1),
670 SCM_PACK_OP_12_12 (mov
, 0, 2),
671 SCM_PACK_OP_24 (tail_call_shuffle
, 7)
674 static const scm_t_uint32 vm_builtin_call_with_current_continuation_code
[] = {
675 SCM_PACK_OP_24 (assert_nargs_ee
, 2),
676 SCM_PACK_OP_24 (call_cc
, 0)
681 scm_vm_builtin_ref (unsigned idx
)
685 #define INDEX_TO_NAME(builtin, BUILTIN, req, opt, rest) \
686 case SCM_VM_BUILTIN_##BUILTIN: return vm_builtin_##builtin;
687 FOR_EACH_VM_BUILTIN(INDEX_TO_NAME
)
694 static SCM scm_sym_values
;
695 static SCM scm_sym_abort_to_prompt
;
696 static SCM scm_sym_call_with_values
;
697 static SCM scm_sym_call_with_current_continuation
;
700 scm_vm_builtin_name_to_index (SCM name
)
701 #define FUNC_NAME "builtin-name->index"
703 SCM_VALIDATE_SYMBOL (1, name
);
705 #define NAME_TO_INDEX(builtin, BUILTIN, req, opt, rest) \
706 if (scm_is_eq (name, scm_sym_##builtin)) \
707 return scm_from_uint (SCM_VM_BUILTIN_##BUILTIN);
708 FOR_EACH_VM_BUILTIN(NAME_TO_INDEX
)
716 scm_vm_builtin_index_to_name (SCM index
)
717 #define FUNC_NAME "builtin-index->name"
721 SCM_VALIDATE_UINT_COPY (1, index
, idx
);
725 #define INDEX_TO_NAME(builtin, BUILTIN, req, opt, rest) \
726 case SCM_VM_BUILTIN_##BUILTIN: return scm_sym_##builtin;
727 FOR_EACH_VM_BUILTIN(INDEX_TO_NAME
)
729 default: return SCM_BOOL_F
;
735 scm_init_vm_builtins (void)
737 scm_c_define_gsubr ("builtin-name->index", 1, 0, 0,
738 scm_vm_builtin_name_to_index
);
739 scm_c_define_gsubr ("builtin-index->name", 1, 0, 0,
740 scm_vm_builtin_index_to_name
);
744 scm_i_call_with_current_continuation (SCM proc
)
746 return scm_call_1 (vm_builtin_call_with_current_continuation
, proc
);
755 static size_t page_size
;
757 /* Initial stack size. Defaults to one page. */
758 static size_t initial_stack_size
;
760 /* Default soft stack limit is 1M words (4 or 8 megabytes). */
761 static size_t default_max_stack_size
= 1024 * 1024;
764 initialize_default_stack_size (void)
766 initial_stack_size
= page_size
/ sizeof (SCM
);
770 size
= scm_getenv_int ("GUILE_STACK_SIZE", (int) default_max_stack_size
);
771 if (size
>= initial_stack_size
772 && (size_t) size
< ((size_t) -1) / sizeof(SCM
))
773 default_max_stack_size
= size
;
777 #define VM_NAME vm_regular_engine
778 #define VM_USE_HOOKS 0
779 #define FUNC_NAME "vm-regular-engine"
780 #include "vm-engine.c"
785 #define VM_NAME vm_debug_engine
786 #define VM_USE_HOOKS 1
787 #define FUNC_NAME "vm-debug-engine"
788 #include "vm-engine.c"
793 typedef SCM (*scm_t_vm_engine
) (scm_i_thread
*current_thread
, struct scm_vm
*vp
,
794 scm_i_jmp_buf
*registers
, int resume
);
796 static const scm_t_vm_engine vm_engines
[SCM_VM_NUM_ENGINES
] =
797 { vm_regular_engine
, vm_debug_engine
};
800 allocate_stack (size_t size
)
801 #define FUNC_NAME "make_vm"
805 if (size
>= ((size_t) -1) / sizeof (SCM
))
808 size
*= sizeof (SCM
);
811 ret
= mmap (NULL
, size
, PROT_READ
| PROT_WRITE
,
812 MAP_PRIVATE
| MAP_ANONYMOUS
, -1, 0);
813 if (ret
== MAP_FAILED
)
821 perror ("allocate_stack failed");
830 free_stack (SCM
*stack
, size_t size
)
832 size
*= sizeof (SCM
);
835 munmap (stack
, size
);
842 expand_stack (SCM
*old_stack
, size_t old_size
, size_t new_size
)
843 #define FUNC_NAME "expand_stack"
845 #if defined MREMAP_MAYMOVE
848 if (new_size
>= ((size_t) -1) / sizeof (SCM
))
851 old_size
*= sizeof (SCM
);
852 new_size
*= sizeof (SCM
);
854 new_stack
= mremap (old_stack
, old_size
, new_size
, MREMAP_MAYMOVE
);
855 if (new_stack
== MAP_FAILED
)
858 return (SCM
*) new_stack
;
862 new_stack
= allocate_stack (new_size
);
866 memcpy (new_stack
, old_stack
, old_size
* sizeof (SCM
));
867 free_stack (old_stack
, old_size
);
874 static struct scm_vm
*
876 #define FUNC_NAME "make_vm"
881 vp
= scm_gc_malloc (sizeof (struct scm_vm
), "vm");
883 vp
->stack_size
= initial_stack_size
;
884 vp
->stack_base
= allocate_stack (vp
->stack_size
);
886 /* As in expand_stack, we don't have any way to throw an exception
887 if we can't allocate one measely page -- there's no stack to
888 handle it. For now, abort. */
890 vp
->stack_limit
= vp
->stack_base
+ vp
->stack_size
;
891 vp
->max_stack_size
= default_max_stack_size
;
893 vp
->sp
= vp
->stack_base
- 1;
895 vp
->engine
= vm_default_engine
;
897 for (i
= 0; i
< SCM_VM_NUM_HOOKS
; i
++)
898 vp
->hooks
[i
] = SCM_BOOL_F
;
905 return_unused_stack_to_os (struct scm_vm
*vp
)
908 scm_t_uintptr start
= (scm_t_uintptr
) (vp
->sp
+ 1);
909 scm_t_uintptr end
= (scm_t_uintptr
) vp
->stack_limit
;
910 /* The second condition is needed to protect against wrap-around. */
911 if (vp
->sp_max_since_gc
< vp
->stack_limit
&& vp
->sp
< vp
->sp_max_since_gc
)
912 end
= (scm_t_uintptr
) (vp
->sp_max_since_gc
+ 1);
914 start
= ((start
- 1U) | (page_size
- 1U)) + 1U; /* round up */
915 end
= ((end
- 1U) | (page_size
- 1U)) + 1U; /* round up */
917 /* Return these pages to the OS. The next time they are paged in,
918 they will be zeroed. */
924 ret
= madvise ((void *) start
, end
- start
, MADV_DONTNEED
);
925 while (ret
&& errno
== -EAGAIN
);
928 perror ("madvise failed");
931 vp
->sp_max_since_gc
= vp
->sp
;
935 #define DEAD_SLOT_MAP_CACHE_SIZE 32U
936 struct dead_slot_map_cache_entry
939 const scm_t_uint8
*map
;
942 struct dead_slot_map_cache
944 struct dead_slot_map_cache_entry entries
[DEAD_SLOT_MAP_CACHE_SIZE
];
947 static const scm_t_uint8
*
948 find_dead_slot_map (scm_t_uint32
*ip
, struct dead_slot_map_cache
*cache
)
950 /* The lower two bits should be zero. FIXME: Use a better hash
951 function; we don't expose scm_raw_hashq currently. */
952 size_t slot
= (((scm_t_uintptr
) ip
) >> 2) % DEAD_SLOT_MAP_CACHE_SIZE
;
953 const scm_t_uint8
*map
;
955 if (cache
->entries
[slot
].ip
== ip
)
956 map
= cache
->entries
[slot
].map
;
959 map
= scm_find_dead_slot_map_unlocked (ip
);
960 cache
->entries
[slot
].ip
= ip
;
961 cache
->entries
[slot
].map
= map
;
967 /* Mark the VM stack region between its base and its current top. */
969 scm_i_vm_mark_stack (struct scm_vm
*vp
, struct GC_ms_entry
*mark_stack_ptr
,
970 struct GC_ms_entry
*mark_stack_limit
)
973 /* The first frame will be marked conservatively (without a dead
974 slot map). This is because GC can happen at any point within the
975 hottest activation, due to multiple threads or per-instruction
976 hooks, and providing dead slot maps for all points in a program
977 would take a prohibitive amount of space. */
978 const scm_t_uint8
*dead_slots
= NULL
;
979 scm_t_uintptr upper
= (scm_t_uintptr
) GC_greatest_plausible_heap_addr
;
980 scm_t_uintptr lower
= (scm_t_uintptr
) GC_least_plausible_heap_addr
;
981 struct dead_slot_map_cache cache
;
983 memset (&cache
, 0, sizeof (cache
));
985 for (fp
= vp
->fp
, sp
= vp
->sp
; fp
; fp
= SCM_FRAME_DYNAMIC_LINK (fp
))
987 for (; sp
>= &SCM_FRAME_LOCAL (fp
, 0); sp
--)
991 && SCM_UNPACK (elt
) >= lower
&& SCM_UNPACK (elt
) <= upper
)
995 size_t slot
= sp
- &SCM_FRAME_LOCAL (fp
, 0);
996 if (dead_slots
[slot
/ 8U] & (1U << (slot
% 8U)))
998 /* This value may become dead as a result of GC,
999 so we can't just leave it on the stack. */
1005 mark_stack_ptr
= GC_mark_and_push ((void *) elt
,
1011 sp
= SCM_FRAME_PREVIOUS_SP (fp
);
1012 /* Inner frames may have a dead slots map for precise marking.
1013 Note that there may be other reasons to not have a dead slots
1014 map, e.g. if all of the frame's slots below the callee frame
1016 dead_slots
= find_dead_slot_map (SCM_FRAME_RETURN_ADDRESS (fp
), &cache
);
1019 return_unused_stack_to_os (vp
);
1021 return mark_stack_ptr
;
1024 /* Free the VM stack, as this thread is exiting. */
1026 scm_i_vm_free_stack (struct scm_vm
*vp
)
1028 free_stack (vp
->stack_base
, vp
->stack_size
);
1029 vp
->stack_base
= vp
->stack_limit
= NULL
;
1033 struct vm_expand_stack_data
1041 vm_expand_stack_inner (void *data_ptr
)
1043 struct vm_expand_stack_data
*data
= data_ptr
;
1045 struct scm_vm
*vp
= data
->vp
;
1046 SCM
*old_stack
, *new_stack
;
1048 scm_t_ptrdiff reloc
;
1050 new_size
= vp
->stack_size
;
1051 while (new_size
< data
->stack_size
)
1053 old_stack
= vp
->stack_base
;
1055 new_stack
= expand_stack (vp
->stack_base
, vp
->stack_size
, new_size
);
1059 vp
->stack_base
= new_stack
;
1060 vp
->stack_size
= new_size
;
1061 vp
->stack_limit
= vp
->stack_base
+ new_size
;
1062 reloc
= vp
->stack_base
- old_stack
;
1069 data
->new_sp
+= reloc
;
1073 SCM
*next_fp
= SCM_FRAME_DYNAMIC_LINK (fp
);
1077 SCM_FRAME_SET_DYNAMIC_LINK (fp
, next_fp
);
1087 vm_expand_stack (struct scm_vm
*vp
, SCM
*new_sp
)
1089 scm_t_ptrdiff stack_size
= new_sp
+ 1 - vp
->stack_base
;
1091 if (stack_size
> vp
->stack_size
)
1093 struct vm_expand_stack_data data
;
1096 data
.stack_size
= stack_size
;
1097 data
.new_sp
= new_sp
;
1099 if (!GC_call_with_alloc_lock (vm_expand_stack_inner
, &data
))
1100 scm_report_stack_overflow ();
1102 new_sp
= data
.new_sp
;
1105 vp
->sp_max_since_gc
= vp
->sp
= new_sp
;
1107 if (stack_size
>= vp
->max_stack_size
)
1109 /* Expand the soft limit by 256K entries to give us space to
1110 handle the error. */
1111 vp
->max_stack_size
+= 256 * 1024;
1113 /* If it's still not big enough... it's quite improbable, but go
1114 ahead and set to the full available stack size. */
1115 if (vp
->max_stack_size
< stack_size
)
1116 vp
->max_stack_size
= vp
->stack_size
;
1118 /* Finally, reset the limit, to catch further overflows. */
1119 vp
->stack_limit
= vp
->stack_base
+ vp
->max_stack_size
;
1121 /* FIXME: Use scm_report_stack_overflow, but in a mode that allows
1122 pre-unwind handlers to run. */
1123 vm_error ("VM: Stack overflow", SCM_UNDEFINED
);
1126 /* Otherwise continue, with the new enlarged stack. */
1129 static struct scm_vm
*
1130 thread_vm (scm_i_thread
*t
)
1132 if (SCM_UNLIKELY (!t
->vp
))
1141 return thread_vm (SCM_I_CURRENT_THREAD
);
1145 scm_call_n (SCM proc
, SCM
*argv
, size_t nargs
)
1147 scm_i_thread
*thread
;
1150 ptrdiff_t base_frame_size
;
1151 /* Cached variables. */
1152 scm_i_jmp_buf registers
; /* used for prompts */
1155 thread
= SCM_I_CURRENT_THREAD
;
1156 vp
= thread_vm (thread
);
1160 /* Check that we have enough space: 3 words for the boot continuation,
1161 and 3 + nargs for the procedure application. */
1162 base_frame_size
= 3 + 3 + nargs
;
1163 vm_push_sp (vp
, vp
->sp
+ base_frame_size
);
1164 base
= vp
->sp
+ 1 - base_frame_size
;
1166 /* Since it's possible to receive the arguments on the stack itself,
1167 shuffle up the arguments first. */
1168 for (i
= nargs
; i
> 0; i
--)
1169 base
[6 + i
- 1] = argv
[i
- 1];
1171 /* Push the boot continuation, which calls PROC and returns its
1173 base
[0] = SCM_PACK (vp
->fp
); /* dynamic link */
1174 base
[1] = SCM_PACK (vp
->ip
); /* ra */
1175 base
[2] = vm_boot_continuation
;
1177 vp
->ip
= (scm_t_uint32
*) vm_boot_continuation_code
;
1179 /* The pending call to PROC. */
1180 base
[3] = SCM_PACK (vp
->fp
); /* dynamic link */
1181 base
[4] = SCM_PACK (vp
->ip
); /* ra */
1186 int resume
= SCM_I_SETJMP (registers
);
1188 if (SCM_UNLIKELY (resume
))
1189 /* Non-local return. */
1190 vm_dispatch_abort_hook (vp
);
1192 return vm_engines
[vp
->engine
](thread
, vp
, ®isters
, resume
);
1196 /* Scheme interface */
1198 #define VM_DEFINE_HOOK(n) \
1200 struct scm_vm *vp; \
1201 vp = scm_the_vm (); \
1202 if (scm_is_false (vp->hooks[n])) \
1203 vp->hooks[n] = scm_make_hook (SCM_I_MAKINUM (1)); \
1204 return vp->hooks[n]; \
1207 SCM_DEFINE (scm_vm_apply_hook
, "vm-apply-hook", 0, 0, 0,
1210 #define FUNC_NAME s_scm_vm_apply_hook
1212 VM_DEFINE_HOOK (SCM_VM_APPLY_HOOK
);
1216 SCM_DEFINE (scm_vm_push_continuation_hook
, "vm-push-continuation-hook", 0, 0, 0,
1219 #define FUNC_NAME s_scm_vm_push_continuation_hook
1221 VM_DEFINE_HOOK (SCM_VM_PUSH_CONTINUATION_HOOK
);
1225 SCM_DEFINE (scm_vm_pop_continuation_hook
, "vm-pop-continuation-hook", 0, 0, 0,
1228 #define FUNC_NAME s_scm_vm_pop_continuation_hook
1230 VM_DEFINE_HOOK (SCM_VM_POP_CONTINUATION_HOOK
);
1234 SCM_DEFINE (scm_vm_next_hook
, "vm-next-hook", 0, 0, 0,
1237 #define FUNC_NAME s_scm_vm_next_hook
1239 VM_DEFINE_HOOK (SCM_VM_NEXT_HOOK
);
1243 SCM_DEFINE (scm_vm_abort_continuation_hook
, "vm-abort-continuation-hook", 0, 0, 0,
1246 #define FUNC_NAME s_scm_vm_abort_continuation_hook
1248 VM_DEFINE_HOOK (SCM_VM_ABORT_CONTINUATION_HOOK
);
1252 SCM_DEFINE (scm_vm_trace_level
, "vm-trace-level", 0, 0, 0,
1255 #define FUNC_NAME s_scm_vm_trace_level
1257 return scm_from_int (scm_the_vm ()->trace_level
);
1261 SCM_DEFINE (scm_set_vm_trace_level_x
, "set-vm-trace-level!", 1, 0, 0,
1264 #define FUNC_NAME s_scm_set_vm_trace_level_x
1266 scm_the_vm ()->trace_level
= scm_to_int (level
);
1267 return SCM_UNSPECIFIED
;
1277 symbol_to_vm_engine (SCM engine
, const char *FUNC_NAME
)
1279 if (scm_is_eq (engine
, sym_regular
))
1280 return SCM_VM_REGULAR_ENGINE
;
1281 else if (scm_is_eq (engine
, sym_debug
))
1282 return SCM_VM_DEBUG_ENGINE
;
1284 SCM_MISC_ERROR ("Unknown VM engine: ~a", scm_list_1 (engine
));
1288 vm_engine_to_symbol (int engine
, const char *FUNC_NAME
)
1292 case SCM_VM_REGULAR_ENGINE
:
1294 case SCM_VM_DEBUG_ENGINE
:
1298 SCM_MISC_ERROR ("Unknown VM engine: ~a",
1299 scm_list_1 (scm_from_int (engine
)));
1303 SCM_DEFINE (scm_vm_engine
, "vm-engine", 0, 0, 0,
1306 #define FUNC_NAME s_scm_vm_engine
1308 return vm_engine_to_symbol (scm_the_vm ()->engine
, FUNC_NAME
);
1313 scm_c_set_vm_engine_x (int engine
)
1314 #define FUNC_NAME "set-vm-engine!"
1316 if (engine
< 0 || engine
>= SCM_VM_NUM_ENGINES
)
1317 SCM_MISC_ERROR ("Unknown VM engine: ~a",
1318 scm_list_1 (scm_from_int (engine
)));
1320 scm_the_vm ()->engine
= engine
;
1324 SCM_DEFINE (scm_set_vm_engine_x
, "set-vm-engine!", 1, 0, 0,
1327 #define FUNC_NAME s_scm_set_vm_engine_x
1329 scm_c_set_vm_engine_x (symbol_to_vm_engine (engine
, FUNC_NAME
));
1330 return SCM_UNSPECIFIED
;
1335 scm_c_set_default_vm_engine_x (int engine
)
1336 #define FUNC_NAME "set-default-vm-engine!"
1338 if (engine
< 0 || engine
>= SCM_VM_NUM_ENGINES
)
1339 SCM_MISC_ERROR ("Unknown VM engine: ~a",
1340 scm_list_1 (scm_from_int (engine
)));
1342 vm_default_engine
= engine
;
1346 SCM_DEFINE (scm_set_default_vm_engine_x
, "set-default-vm-engine!", 1, 0, 0,
1349 #define FUNC_NAME s_scm_set_default_vm_engine_x
1351 scm_c_set_default_vm_engine_x (symbol_to_vm_engine (engine
, FUNC_NAME
));
1352 return SCM_UNSPECIFIED
;
1356 /* FIXME: This function makes no sense, but we keep it to make sure we
1357 have a way of switching to the debug or regular VM. */
1358 SCM_DEFINE (scm_call_with_vm
, "call-with-vm", 1, 0, 1,
1359 (SCM proc
, SCM args
),
1360 "Apply @var{proc} to @var{args} in a dynamic extent in which\n"
1361 "@var{vm} is the current VM.")
1362 #define FUNC_NAME s_scm_call_with_vm
1364 return scm_apply_0 (proc
, args
);
1374 scm_load_compiled_with_vm (SCM file
)
1376 return scm_call_0 (scm_load_thunk_from_file (file
));
1381 scm_init_vm_builtin_properties (void)
1383 /* FIXME: Seems hacky to do this here, but oh well :/ */
1384 scm_sym_apply
= scm_from_utf8_symbol ("apply");
1385 scm_sym_values
= scm_from_utf8_symbol ("values");
1386 scm_sym_abort_to_prompt
= scm_from_utf8_symbol ("abort-to-prompt");
1387 scm_sym_call_with_values
= scm_from_utf8_symbol ("call-with-values");
1388 scm_sym_call_with_current_continuation
=
1389 scm_from_utf8_symbol ("call-with-current-continuation");
1391 #define INIT_BUILTIN(builtin, BUILTIN, req, opt, rest) \
1392 scm_set_procedure_property_x (vm_builtin_##builtin, scm_sym_name, \
1393 scm_sym_##builtin); \
1394 scm_set_procedure_minimum_arity_x (vm_builtin_##builtin, \
1395 SCM_I_MAKINUM (req), \
1396 SCM_I_MAKINUM (opt), \
1397 scm_from_bool (rest));
1398 FOR_EACH_VM_BUILTIN (INIT_BUILTIN
);
1403 scm_bootstrap_vm (void)
1405 scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION
,
1407 (scm_t_extension_init_func
)scm_init_vm
, NULL
);
1408 scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION
,
1409 "scm_init_vm_builtins",
1410 (scm_t_extension_init_func
)scm_init_vm_builtins
,
1413 page_size
= getpagesize ();
1414 /* page_size should be a power of two. */
1415 if (page_size
& (page_size
- 1))
1418 initialize_default_stack_size ();
1420 sym_vm_run
= scm_from_latin1_symbol ("vm-run");
1421 sym_vm_error
= scm_from_latin1_symbol ("vm-error");
1422 sym_keyword_argument_error
= scm_from_latin1_symbol ("keyword-argument-error");
1423 sym_regular
= scm_from_latin1_symbol ("regular");
1424 sym_debug
= scm_from_latin1_symbol ("debug");
1426 vm_boot_continuation
= scm_i_make_program (vm_boot_continuation_code
);
1427 SCM_SET_CELL_WORD_0 (vm_boot_continuation
,
1428 (SCM_CELL_WORD_0 (vm_boot_continuation
)
1429 | SCM_F_PROGRAM_IS_BOOT
));
1431 #define DEFINE_BUILTIN(builtin, BUILTIN, req, opt, rest) \
1432 vm_builtin_##builtin = scm_i_make_program (vm_builtin_##builtin##_code);
1433 FOR_EACH_VM_BUILTIN (DEFINE_BUILTIN
);
1434 #undef DEFINE_BUILTIN
1440 #ifndef SCM_MAGIC_SNARFER
1441 #include "libguile/vm.x"