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_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
)
78 if (new_sp
> vp
->sp_max_since_gc
)
80 vp
->sp_max_since_gc
= new_sp
;
81 if (kind
== VM_SP_PUSH
&& new_sp
>= vp
->stack_limit
)
87 vm_push_sp (struct scm_vm
*vp
, SCM
*new_sp
)
89 vm_increase_sp (vp
, new_sp
, VM_SP_PUSH
);
93 vm_restore_sp (struct scm_vm
*vp
, SCM
*new_sp
)
95 vm_increase_sp (vp
, new_sp
, VM_SP_RESTORE
);
104 scm_i_vm_cont_print (SCM x
, SCM port
, scm_print_state
*pstate
)
106 scm_puts_unlocked ("#<vm-continuation ", port
);
107 scm_uintprint (SCM_UNPACK (x
), 16, port
);
108 scm_puts_unlocked (">", port
);
111 /* In theory, a number of vm instances can be active in the call trace, and we
112 only want to reify the continuations of those in the current continuation
113 root. I don't see a nice way to do this -- ideally it would involve dynwinds,
114 and previous values of the *the-vm* fluid within the current continuation
115 root. But we don't have access to continuation roots in the dynwind stack.
116 So, just punt for now, we just capture the continuation for the current VM.
118 While I'm on the topic, ideally we could avoid copying the C stack if the
119 continuation root is inside VM code, and call/cc was invoked within that same
120 call to vm_run; but that's currently not implemented.
123 scm_i_vm_capture_stack (SCM
*stack_base
, SCM
*fp
, SCM
*sp
, scm_t_uint32
*ra
,
124 scm_t_dynstack
*dynstack
, scm_t_uint32 flags
)
126 struct scm_vm_cont
*p
;
128 p
= scm_gc_malloc (sizeof (*p
), "capture_vm_cont");
129 p
->stack_size
= sp
- stack_base
+ 1;
130 p
->stack_base
= scm_gc_malloc (p
->stack_size
* sizeof (SCM
),
135 memcpy (p
->stack_base
, stack_base
, (sp
+ 1 - stack_base
) * sizeof (SCM
));
136 p
->reloc
= p
->stack_base
- stack_base
;
137 p
->dynstack
= dynstack
;
139 return scm_cell (scm_tc7_vm_cont
, (scm_t_bits
)p
);
143 vm_return_to_continuation (struct scm_vm
*vp
, SCM cont
, size_t n
, SCM
*argv
)
145 struct scm_vm_cont
*cp
;
149 argv_copy
= alloca (n
* sizeof(SCM
));
150 memcpy (argv_copy
, argv
, n
* sizeof(SCM
));
152 cp
= SCM_VM_CONT_DATA (cont
);
154 /* FIXME: Need to prevent GC while futzing with the stack; otherwise,
155 another thread causing GC may initiate a mark of a stack in an
156 inconsistent state. */
158 /* We know that there is enough space for the continuation, because we
159 captured it in the past. However there may have been an expansion
160 since the capture, so we may have to re-link the frame
162 reloc
= (vp
->stack_base
- (cp
->stack_base
- cp
->reloc
));
163 vp
->fp
= cp
->fp
+ reloc
;
164 memcpy (vp
->stack_base
, cp
->stack_base
, cp
->stack_size
* sizeof (SCM
));
165 vm_restore_sp (vp
, cp
->sp
+ reloc
);
172 SCM
*next_fp
= SCM_FRAME_DYNAMIC_LINK (fp
);
176 SCM_FRAME_SET_DYNAMIC_LINK (fp
, next_fp
);
182 /* Now we have the continuation properly copied over. We just need to
183 copy the arguments. It is not guaranteed that there is actually
184 space for the arguments, though, so we have to bump the SP first. */
185 vm_push_sp (vp
, vp
->sp
+ 3 + n
);
187 /* Now copy on an empty frame and the return values, as the
188 continuation expects. */
190 SCM
*base
= vp
->sp
+ 1 - 3 - n
;
193 for (i
= 0; i
< 3; i
++)
194 base
[i
] = SCM_BOOL_F
;
196 for (i
= 0; i
< n
; i
++)
197 base
[i
+ 3] = argv_copy
[i
];
203 static struct scm_vm
* thread_vm (scm_i_thread
*t
);
205 scm_i_capture_current_stack (void)
207 scm_i_thread
*thread
;
210 thread
= SCM_I_CURRENT_THREAD
;
211 vp
= thread_vm (thread
);
213 return scm_i_vm_capture_stack (vp
->stack_base
, vp
->fp
, vp
->sp
, vp
->ip
,
214 scm_dynstack_capture_all (&thread
->dynstack
),
218 static void vm_dispatch_apply_hook (struct scm_vm
*vp
) SCM_NOINLINE
;
219 static void vm_dispatch_push_continuation_hook (struct scm_vm
*vp
) SCM_NOINLINE
;
220 static void vm_dispatch_pop_continuation_hook (struct scm_vm
*vp
, SCM
*old_fp
) SCM_NOINLINE
;
221 static void vm_dispatch_next_hook (struct scm_vm
*vp
) SCM_NOINLINE
;
222 static void vm_dispatch_abort_hook (struct scm_vm
*vp
) SCM_NOINLINE
;
225 vm_dispatch_hook (struct scm_vm
*vp
, int hook_num
, SCM
*argv
, int n
)
228 struct scm_frame c_frame
;
230 int saved_trace_level
;
232 hook
= vp
->hooks
[hook_num
];
234 if (SCM_LIKELY (scm_is_false (hook
))
235 || scm_is_null (SCM_HOOK_PROCEDURES (hook
)))
238 saved_trace_level
= vp
->trace_level
;
241 /* Allocate a frame object on the stack. This is more efficient than calling
242 `scm_c_make_frame ()' to allocate on the heap, but it forces hooks to not
243 capture frame objects.
245 At the same time, procedures such as `frame-procedure' make sense only
246 while the stack frame represented by the frame object is visible, so it
247 seems reasonable to limit the lifetime of frame objects. */
249 c_frame
.stack_holder
= vp
;
250 c_frame
.fp_offset
= vp
->fp
- vp
->stack_base
;
251 c_frame
.sp_offset
= vp
->sp
- vp
->stack_base
;
254 /* Arrange for FRAME to be 8-byte aligned, like any other cell. */
255 frame
= alloca (sizeof (*frame
) + 8);
256 frame
= (scm_t_cell
*) ROUND_UP ((scm_t_uintptr
) frame
, 8UL);
258 frame
->word_0
= SCM_PACK (scm_tc7_frame
| (SCM_VM_FRAME_KIND_VM
<< 8));
259 frame
->word_1
= SCM_PACK_POINTER (&c_frame
);
265 args
[0] = SCM_PACK_POINTER (frame
);
266 scm_c_run_hookn (hook
, args
, 1);
272 args
[0] = SCM_PACK_POINTER (frame
);
274 scm_c_run_hookn (hook
, args
, 2);
281 args
= scm_cons (argv
[n
], args
);
282 scm_c_run_hook (hook
, scm_cons (SCM_PACK_POINTER (frame
), args
));
285 vp
->trace_level
= saved_trace_level
;
289 vm_dispatch_apply_hook (struct scm_vm
*vp
)
291 return vm_dispatch_hook (vp
, SCM_VM_APPLY_HOOK
, NULL
, 0);
293 static void vm_dispatch_push_continuation_hook (struct scm_vm
*vp
)
295 return vm_dispatch_hook (vp
, SCM_VM_PUSH_CONTINUATION_HOOK
, NULL
, 0);
297 static void vm_dispatch_pop_continuation_hook (struct scm_vm
*vp
, SCM
*old_fp
)
299 return vm_dispatch_hook (vp
, SCM_VM_POP_CONTINUATION_HOOK
,
300 &SCM_FRAME_LOCAL (old_fp
, 1),
301 SCM_FRAME_NUM_LOCALS (old_fp
, vp
->sp
) - 1);
303 static void vm_dispatch_next_hook (struct scm_vm
*vp
)
305 return vm_dispatch_hook (vp
, SCM_VM_NEXT_HOOK
, NULL
, 0);
307 static void vm_dispatch_abort_hook (struct scm_vm
*vp
)
309 return vm_dispatch_hook (vp
, SCM_VM_ABORT_CONTINUATION_HOOK
,
310 &SCM_FRAME_LOCAL (vp
->fp
, 1),
311 SCM_FRAME_NUM_LOCALS (vp
->fp
, vp
->sp
) - 1);
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
) SCM_NORETURN
;
320 vm_abort (struct scm_vm
*vp
, SCM tag
,
321 size_t nstack
, SCM
*stack_args
, SCM tail
, SCM
*sp
,
322 scm_i_jmp_buf
*current_registers
)
328 tail_len
= scm_ilength (tail
);
330 scm_misc_error ("vm-engine", "tail values to abort should be a list",
333 argv
= alloca ((nstack
+ tail_len
) * sizeof (SCM
));
334 for (i
= 0; i
< nstack
; i
++)
335 argv
[i
] = stack_args
[i
];
336 for (; i
< nstack
+ tail_len
; i
++, tail
= scm_cdr (tail
))
337 argv
[i
] = scm_car (tail
);
339 /* FIXME: NULLSTACK (SCM_VM_DATA (vp)->sp - sp) */
342 scm_c_abort (vp
, tag
, nstack
+ tail_len
, argv
, current_registers
);
346 vm_reinstate_partial_continuation (struct scm_vm
*vp
, SCM cont
,
348 scm_t_dynstack
*dynstack
,
349 scm_i_jmp_buf
*registers
)
351 struct scm_vm_cont
*cp
;
352 SCM
*argv_copy
, *base
;
356 argv_copy
= alloca (n
* sizeof(SCM
));
357 memcpy (argv_copy
, argv
, n
* sizeof(SCM
));
359 cp
= SCM_VM_CONT_DATA (cont
);
361 vm_push_sp (vp
, SCM_FRAME_LOCALS_ADDRESS (vp
->fp
) + cp
->stack_size
+ n
- 1);
363 base
= SCM_FRAME_LOCALS_ADDRESS (vp
->fp
);
364 reloc
= cp
->reloc
+ (base
- cp
->stack_base
);
366 memcpy (base
, cp
->stack_base
, cp
->stack_size
* sizeof (SCM
));
368 vp
->fp
= cp
->fp
+ reloc
;
371 /* now relocate frame pointers */
375 SCM_FRAME_LOWER_ADDRESS (fp
) > base
;
376 fp
= SCM_FRAME_DYNAMIC_LINK (fp
))
377 SCM_FRAME_SET_DYNAMIC_LINK (fp
, SCM_FRAME_DYNAMIC_LINK (fp
) + reloc
);
380 /* Push the arguments. */
381 for (i
= 0; i
< n
; i
++)
382 vp
->sp
[i
+ 1 - n
] = argv_copy
[i
];
384 /* The prompt captured a slice of the dynamic stack. Here we wind
385 those entries onto the current thread's stack. We also have to
386 relocate any prompts that we see along the way. */
390 for (walk
= SCM_DYNSTACK_FIRST (cp
->dynstack
);
391 SCM_DYNSTACK_TAG (walk
);
392 walk
= SCM_DYNSTACK_NEXT (walk
))
394 scm_t_bits tag
= SCM_DYNSTACK_TAG (walk
);
396 if (SCM_DYNSTACK_TAG_TYPE (tag
) == SCM_DYNSTACK_TYPE_PROMPT
)
397 scm_dynstack_wind_prompt (dynstack
, walk
, reloc
, registers
);
399 scm_dynstack_wind_1 (dynstack
, walk
);
409 static void vm_error (const char *msg
, SCM arg
) SCM_NORETURN
;
410 static void vm_error_bad_instruction (scm_t_uint32 inst
) SCM_NORETURN SCM_NOINLINE
;
411 static void vm_error_unbound (SCM proc
, SCM sym
) SCM_NORETURN SCM_NOINLINE
;
412 static void vm_error_unbound_fluid (SCM proc
, SCM fluid
) SCM_NORETURN SCM_NOINLINE
;
413 static void vm_error_not_a_variable (const char *func_name
, SCM x
) SCM_NORETURN SCM_NOINLINE
;
414 static void vm_error_apply_to_non_list (SCM x
) SCM_NORETURN SCM_NOINLINE
;
415 static void vm_error_kwargs_length_not_even (SCM proc
) SCM_NORETURN SCM_NOINLINE
;
416 static void vm_error_kwargs_invalid_keyword (SCM proc
, SCM obj
) SCM_NORETURN SCM_NOINLINE
;
417 static void vm_error_kwargs_unrecognized_keyword (SCM proc
, SCM kw
) SCM_NORETURN SCM_NOINLINE
;
418 static void vm_error_too_many_args (int nargs
) SCM_NORETURN SCM_NOINLINE
;
419 static void vm_error_wrong_num_args (SCM proc
) SCM_NORETURN SCM_NOINLINE
;
420 static void vm_error_wrong_type_apply (SCM proc
) SCM_NORETURN SCM_NOINLINE
;
421 static void vm_error_stack_underflow (void) SCM_NORETURN SCM_NOINLINE
;
422 static void vm_error_improper_list (SCM x
) SCM_NORETURN SCM_NOINLINE
;
423 static void vm_error_not_a_pair (const char *subr
, SCM x
) SCM_NORETURN SCM_NOINLINE
;
424 static void vm_error_not_a_bytevector (const char *subr
, SCM x
) SCM_NORETURN SCM_NOINLINE
;
425 static void vm_error_not_a_struct (const char *subr
, SCM x
) SCM_NORETURN SCM_NOINLINE
;
426 static void vm_error_not_a_vector (const char *subr
, SCM v
) SCM_NORETURN SCM_NOINLINE
;
427 static void vm_error_out_of_range (const char *subr
, SCM k
) SCM_NORETURN SCM_NOINLINE
;
428 static void vm_error_no_values (void) SCM_NORETURN SCM_NOINLINE
;
429 static void vm_error_not_enough_values (void) SCM_NORETURN SCM_NOINLINE
;
430 static void vm_error_wrong_number_of_values (scm_t_uint32 expected
) SCM_NORETURN SCM_NOINLINE
;
431 static void vm_error_continuation_not_rewindable (SCM cont
) SCM_NORETURN SCM_NOINLINE
;
432 static void vm_error_bad_wide_string_length (size_t len
) SCM_NORETURN SCM_NOINLINE
;
435 vm_error (const char *msg
, SCM arg
)
437 scm_throw (sym_vm_error
,
438 scm_list_3 (sym_vm_run
, scm_from_latin1_string (msg
),
439 SCM_UNBNDP (arg
) ? SCM_EOL
: scm_list_1 (arg
)));
440 abort(); /* not reached */
444 vm_error_bad_instruction (scm_t_uint32 inst
)
446 vm_error ("VM: Bad instruction: ~s", scm_from_uint32 (inst
));
450 vm_error_unbound (SCM proc
, SCM sym
)
452 scm_error_scm (scm_misc_error_key
, proc
,
453 scm_from_latin1_string ("Unbound variable: ~s"),
454 scm_list_1 (sym
), SCM_BOOL_F
);
458 vm_error_unbound_fluid (SCM proc
, SCM fluid
)
460 scm_error_scm (scm_misc_error_key
, proc
,
461 scm_from_latin1_string ("Unbound fluid: ~s"),
462 scm_list_1 (fluid
), SCM_BOOL_F
);
466 vm_error_not_a_variable (const char *func_name
, SCM x
)
468 scm_error (scm_arg_type_key
, func_name
, "Not a variable: ~S",
469 scm_list_1 (x
), scm_list_1 (x
));
473 vm_error_apply_to_non_list (SCM x
)
475 scm_error (scm_arg_type_key
, "apply", "Apply to non-list: ~S",
476 scm_list_1 (x
), scm_list_1 (x
));
480 vm_error_kwargs_length_not_even (SCM proc
)
482 scm_error_scm (sym_keyword_argument_error
, proc
,
483 scm_from_latin1_string ("Odd length of keyword argument list"),
484 SCM_EOL
, SCM_BOOL_F
);
488 vm_error_kwargs_invalid_keyword (SCM proc
, SCM obj
)
490 scm_error_scm (sym_keyword_argument_error
, proc
,
491 scm_from_latin1_string ("Invalid keyword"),
492 SCM_EOL
, scm_list_1 (obj
));
496 vm_error_kwargs_unrecognized_keyword (SCM proc
, SCM kw
)
498 scm_error_scm (sym_keyword_argument_error
, proc
,
499 scm_from_latin1_string ("Unrecognized keyword"),
500 SCM_EOL
, scm_list_1 (kw
));
504 vm_error_too_many_args (int nargs
)
506 vm_error ("VM: Too many arguments", scm_from_int (nargs
));
510 vm_error_wrong_num_args (SCM proc
)
512 scm_wrong_num_args (proc
);
516 vm_error_wrong_type_apply (SCM proc
)
518 scm_error (scm_arg_type_key
, NULL
, "Wrong type to apply: ~S",
519 scm_list_1 (proc
), scm_list_1 (proc
));
523 vm_error_stack_underflow (void)
525 vm_error ("VM: Stack underflow", SCM_UNDEFINED
);
529 vm_error_improper_list (SCM x
)
531 vm_error ("Expected a proper list, but got object with tail ~s", x
);
535 vm_error_not_a_pair (const char *subr
, SCM x
)
537 scm_wrong_type_arg_msg (subr
, 1, x
, "pair");
541 vm_error_not_a_bytevector (const char *subr
, SCM x
)
543 scm_wrong_type_arg_msg (subr
, 1, x
, "bytevector");
547 vm_error_not_a_struct (const char *subr
, SCM x
)
549 scm_wrong_type_arg_msg (subr
, 1, x
, "struct");
553 vm_error_not_a_vector (const char *subr
, SCM x
)
555 scm_wrong_type_arg_msg (subr
, 1, x
, "vector");
559 vm_error_out_of_range (const char *subr
, SCM k
)
562 scm_out_of_range (subr
, k
);
566 vm_error_no_values (void)
568 vm_error ("Zero values returned to single-valued continuation",
573 vm_error_not_enough_values (void)
575 vm_error ("Too few values returned to continuation", SCM_UNDEFINED
);
579 vm_error_wrong_number_of_values (scm_t_uint32 expected
)
581 vm_error ("Wrong number of values returned to continuation (expected ~a)",
582 scm_from_uint32 (expected
));
586 vm_error_continuation_not_rewindable (SCM cont
)
588 vm_error ("Unrewindable partial continuation", cont
);
592 vm_error_bad_wide_string_length (size_t len
)
594 vm_error ("VM: Bad wide string length: ~S", scm_from_size_t (len
));
600 static SCM vm_boot_continuation
;
601 static SCM vm_builtin_apply
;
602 static SCM vm_builtin_values
;
603 static SCM vm_builtin_abort_to_prompt
;
604 static SCM vm_builtin_call_with_values
;
605 static SCM vm_builtin_call_with_current_continuation
;
607 static const scm_t_uint32 vm_boot_continuation_code
[] = {
608 SCM_PACK_OP_24 (halt
, 0)
611 static const scm_t_uint32 vm_builtin_apply_code
[] = {
612 SCM_PACK_OP_24 (assert_nargs_ge
, 3),
613 SCM_PACK_OP_24 (tail_apply
, 0), /* proc in r1, args from r2 */
616 static const scm_t_uint32 vm_builtin_values_code
[] = {
617 SCM_PACK_OP_24 (return_values
, 0) /* vals from r1 */
620 static const scm_t_uint32 vm_builtin_abort_to_prompt_code
[] = {
621 SCM_PACK_OP_24 (assert_nargs_ge
, 2),
622 SCM_PACK_OP_24 (abort
, 0), /* tag in r1, vals from r2 */
623 /* FIXME: Partial continuation should capture caller regs. */
624 SCM_PACK_OP_24 (return_values
, 0) /* vals from r1 */
627 static const scm_t_uint32 vm_builtin_call_with_values_code
[] = {
628 SCM_PACK_OP_24 (assert_nargs_ee
, 3),
629 SCM_PACK_OP_24 (alloc_frame
, 7),
630 SCM_PACK_OP_12_12 (mov
, 6, 1),
631 SCM_PACK_OP_24 (call
, 6), SCM_PACK_OP_ARG_8_24 (0, 1),
632 SCM_PACK_OP_12_12 (mov
, 0, 2),
633 SCM_PACK_OP_24 (tail_call_shuffle
, 7)
636 static const scm_t_uint32 vm_builtin_call_with_current_continuation_code
[] = {
637 SCM_PACK_OP_24 (assert_nargs_ee
, 2),
638 SCM_PACK_OP_24 (call_cc
, 0)
643 scm_vm_builtin_ref (unsigned idx
)
647 #define INDEX_TO_NAME(builtin, BUILTIN, req, opt, rest) \
648 case SCM_VM_BUILTIN_##BUILTIN: return vm_builtin_##builtin;
649 FOR_EACH_VM_BUILTIN(INDEX_TO_NAME
)
656 static SCM scm_sym_values
;
657 static SCM scm_sym_abort_to_prompt
;
658 static SCM scm_sym_call_with_values
;
659 static SCM scm_sym_call_with_current_continuation
;
662 scm_vm_builtin_name_to_index (SCM name
)
663 #define FUNC_NAME "builtin-name->index"
665 SCM_VALIDATE_SYMBOL (1, name
);
667 #define NAME_TO_INDEX(builtin, BUILTIN, req, opt, rest) \
668 if (scm_is_eq (name, scm_sym_##builtin)) \
669 return scm_from_uint (SCM_VM_BUILTIN_##BUILTIN);
670 FOR_EACH_VM_BUILTIN(NAME_TO_INDEX
)
678 scm_vm_builtin_index_to_name (SCM index
)
679 #define FUNC_NAME "builtin-index->name"
683 SCM_VALIDATE_UINT_COPY (1, index
, idx
);
687 #define INDEX_TO_NAME(builtin, BUILTIN, req, opt, rest) \
688 case SCM_VM_BUILTIN_##BUILTIN: return scm_sym_##builtin;
689 FOR_EACH_VM_BUILTIN(INDEX_TO_NAME
)
691 default: return SCM_BOOL_F
;
697 scm_init_vm_builtins (void)
699 scm_c_define_gsubr ("builtin-name->index", 1, 0, 0,
700 scm_vm_builtin_name_to_index
);
701 scm_c_define_gsubr ("builtin-index->name", 1, 0, 0,
702 scm_vm_builtin_index_to_name
);
706 scm_i_call_with_current_continuation (SCM proc
)
708 return scm_call_1 (vm_builtin_call_with_current_continuation
, proc
);
717 static size_t page_size
;
719 /* Hard stack limit is 512M words: 2 gigabytes on 32-bit machines, 4 on
721 static const size_t hard_max_stack_size
= 512 * 1024 * 1024;
723 /* Initial stack size. Defaults to one page. */
724 static size_t initial_stack_size
;
726 /* Default soft stack limit is 1M words (4 or 8 megabytes). */
727 static size_t default_max_stack_size
= 1024 * 1024;
730 initialize_default_stack_size (void)
732 initial_stack_size
= page_size
/ sizeof (SCM
);
736 size
= scm_getenv_int ("GUILE_STACK_SIZE", (int) default_max_stack_size
);
737 if (size
>= initial_stack_size
738 && (size_t) size
< ((size_t) -1) / sizeof(SCM
))
739 default_max_stack_size
= size
;
743 #define VM_NAME vm_regular_engine
744 #define VM_USE_HOOKS 0
745 #define FUNC_NAME "vm-regular-engine"
746 #include "vm-engine.c"
751 #define VM_NAME vm_debug_engine
752 #define VM_USE_HOOKS 1
753 #define FUNC_NAME "vm-debug-engine"
754 #include "vm-engine.c"
759 typedef SCM (*scm_t_vm_engine
) (scm_i_thread
*current_thread
, struct scm_vm
*vp
,
760 scm_i_jmp_buf
*registers
, int resume
);
762 static const scm_t_vm_engine vm_engines
[SCM_VM_NUM_ENGINES
] =
763 { vm_regular_engine
, vm_debug_engine
};
766 allocate_stack (size_t size
)
767 #define FUNC_NAME "make_vm"
771 if (size
>= ((size_t) -1) / sizeof (SCM
))
774 size
*= sizeof (SCM
);
777 ret
= mmap (NULL
, size
, PROT_READ
| PROT_WRITE
,
778 MAP_PRIVATE
| MAP_ANONYMOUS
, -1, 0);
779 if (ret
== MAP_FAILED
)
787 perror ("allocate_stack failed");
796 free_stack (SCM
*stack
, size_t size
)
798 size
*= sizeof (SCM
);
801 munmap (stack
, size
);
808 expand_stack (SCM
*old_stack
, size_t old_size
, size_t new_size
)
809 #define FUNC_NAME "expand_stack"
811 #if defined MREMAP_MAYMOVE
814 if (new_size
>= ((size_t) -1) / sizeof (SCM
))
817 old_size
*= sizeof (SCM
);
818 new_size
*= sizeof (SCM
);
820 new_stack
= mremap (old_stack
, old_size
, new_size
, MREMAP_MAYMOVE
);
821 if (new_stack
== MAP_FAILED
)
824 return (SCM
*) new_stack
;
828 new_stack
= allocate_stack (new_size
);
832 memcpy (new_stack
, old_stack
, old_size
* sizeof (SCM
));
833 free_stack (old_stack
, old_size
);
840 static struct scm_vm
*
842 #define FUNC_NAME "make_vm"
847 vp
= scm_gc_malloc (sizeof (struct scm_vm
), "vm");
849 vp
->stack_size
= initial_stack_size
;
850 vp
->stack_base
= allocate_stack (vp
->stack_size
);
852 /* As in expand_stack, we don't have any way to throw an exception
853 if we can't allocate one measely page -- there's no stack to
854 handle it. For now, abort. */
856 vp
->stack_limit
= vp
->stack_base
+ vp
->stack_size
;
857 vp
->max_stack_size
= default_max_stack_size
;
859 vp
->sp
= vp
->stack_base
- 1;
861 vp
->engine
= vm_default_engine
;
863 for (i
= 0; i
< SCM_VM_NUM_HOOKS
; i
++)
864 vp
->hooks
[i
] = SCM_BOOL_F
;
871 return_unused_stack_to_os (struct scm_vm
*vp
)
874 scm_t_uintptr start
= (scm_t_uintptr
) (vp
->sp
+ 1);
875 scm_t_uintptr end
= (scm_t_uintptr
) vp
->stack_limit
;
876 /* The second condition is needed to protect against wrap-around. */
877 if (vp
->sp_max_since_gc
< vp
->stack_limit
&& vp
->sp
< vp
->sp_max_since_gc
)
878 end
= (scm_t_uintptr
) (vp
->sp_max_since_gc
+ 1);
880 start
= ((start
- 1U) | (page_size
- 1U)) + 1U; /* round up */
881 end
= ((end
- 1U) | (page_size
- 1U)) + 1U; /* round up */
883 /* Return these pages to the OS. The next time they are paged in,
884 they will be zeroed. */
890 ret
= madvise ((void *) start
, end
- start
, MADV_DONTNEED
);
891 while (ret
&& errno
== -EAGAIN
);
894 perror ("madvise failed");
897 vp
->sp_max_since_gc
= vp
->sp
;
901 #define DEAD_SLOT_MAP_CACHE_SIZE 32U
902 struct dead_slot_map_cache_entry
905 const scm_t_uint8
*map
;
908 struct dead_slot_map_cache
910 struct dead_slot_map_cache_entry entries
[DEAD_SLOT_MAP_CACHE_SIZE
];
913 static const scm_t_uint8
*
914 find_dead_slot_map (scm_t_uint32
*ip
, struct dead_slot_map_cache
*cache
)
916 /* The lower two bits should be zero. FIXME: Use a better hash
917 function; we don't expose scm_raw_hashq currently. */
918 size_t slot
= (((scm_t_uintptr
) ip
) >> 2) % DEAD_SLOT_MAP_CACHE_SIZE
;
919 const scm_t_uint8
*map
;
921 if (cache
->entries
[slot
].ip
== ip
)
922 map
= cache
->entries
[slot
].map
;
925 map
= scm_find_dead_slot_map_unlocked (ip
);
926 cache
->entries
[slot
].ip
= ip
;
927 cache
->entries
[slot
].map
= map
;
933 /* Mark the VM stack region between its base and its current top. */
935 scm_i_vm_mark_stack (struct scm_vm
*vp
, struct GC_ms_entry
*mark_stack_ptr
,
936 struct GC_ms_entry
*mark_stack_limit
)
939 /* The first frame will be marked conservatively (without a dead
940 slot map). This is because GC can happen at any point within the
941 hottest activation, due to multiple threads or per-instruction
942 hooks, and providing dead slot maps for all points in a program
943 would take a prohibitive amount of space. */
944 const scm_t_uint8
*dead_slots
= NULL
;
945 scm_t_uintptr upper
= (scm_t_uintptr
) GC_greatest_plausible_heap_addr
;
946 scm_t_uintptr lower
= (scm_t_uintptr
) GC_least_plausible_heap_addr
;
947 struct dead_slot_map_cache cache
;
949 memset (&cache
, 0, sizeof (cache
));
951 for (fp
= vp
->fp
, sp
= vp
->sp
; fp
; fp
= SCM_FRAME_DYNAMIC_LINK (fp
))
953 for (; sp
>= &SCM_FRAME_LOCAL (fp
, 0); sp
--)
957 && SCM_UNPACK (elt
) >= lower
&& SCM_UNPACK (elt
) <= upper
)
961 size_t slot
= sp
- &SCM_FRAME_LOCAL (fp
, 0);
962 if (dead_slots
[slot
/ 8U] & (1U << (slot
% 8U)))
964 /* This value may become dead as a result of GC,
965 so we can't just leave it on the stack. */
971 mark_stack_ptr
= GC_mark_and_push ((void *) elt
,
977 sp
= SCM_FRAME_PREVIOUS_SP (fp
);
978 /* Inner frames may have a dead slots map for precise marking.
979 Note that there may be other reasons to not have a dead slots
980 map, e.g. if all of the frame's slots below the callee frame
982 dead_slots
= find_dead_slot_map (SCM_FRAME_RETURN_ADDRESS (fp
), &cache
);
985 return_unused_stack_to_os (vp
);
987 return mark_stack_ptr
;
990 /* Free the VM stack, as this thread is exiting. */
992 scm_i_vm_free_stack (struct scm_vm
*vp
)
994 free_stack (vp
->stack_base
, vp
->stack_size
);
995 vp
->stack_base
= vp
->stack_limit
= NULL
;
1000 vm_expand_stack (struct scm_vm
*vp
)
1002 scm_t_ptrdiff stack_size
= vp
->sp
+ 1 - vp
->stack_base
;
1004 if (stack_size
> hard_max_stack_size
)
1006 /* We have expanded the soft limit to the point that we reached a
1007 hard limit. There is nothing sensible to do. */
1008 fprintf (stderr
, "Hard stack size limit (%zu words) reached; aborting.\n",
1009 hard_max_stack_size
);
1013 /* FIXME: Prevent GC while we expand the stack, to ensure that a
1014 stack marker can trace the stack. */
1015 if (stack_size
> vp
->stack_size
)
1017 SCM
*old_stack
, *new_stack
;
1019 scm_t_ptrdiff reloc
;
1021 new_size
= vp
->stack_size
;
1022 while (new_size
< stack_size
)
1024 old_stack
= vp
->stack_base
;
1025 new_stack
= expand_stack (vp
->stack_base
, vp
->stack_size
, new_size
);
1027 /* It would be nice to throw an exception here, but that is
1028 extraordinarily hard. Exceptionally hard, you might say!
1029 "throw" is implemented in Scheme, and there may be arbitrary
1030 pre-unwind handlers that push on more frames. We will
1031 endeavor to do so in the future, but for now we just
1035 vp
->stack_base
= new_stack
;
1036 vp
->stack_size
= new_size
;
1037 vp
->stack_limit
= vp
->stack_base
+ new_size
;
1038 reloc
= vp
->stack_base
- old_stack
;
1046 vp
->sp_max_since_gc
+= reloc
;
1050 SCM
*next_fp
= SCM_FRAME_DYNAMIC_LINK (fp
);
1054 SCM_FRAME_SET_DYNAMIC_LINK (fp
, next_fp
);
1061 if (stack_size
>= vp
->max_stack_size
)
1063 /* Expand the soft limit by 256K entries to give us space to
1064 handle the error. */
1065 vp
->max_stack_size
+= 256 * 1024;
1067 /* If it's still not big enough... it's quite improbable, but go
1068 ahead and set to the full available stack size. */
1069 if (vp
->max_stack_size
< stack_size
)
1070 vp
->max_stack_size
= vp
->stack_size
;
1072 /* But don't exceed the hard maximum. */
1073 if (vp
->max_stack_size
> hard_max_stack_size
)
1074 vp
->max_stack_size
= hard_max_stack_size
;
1076 /* Finally, reset the limit, to catch further overflows. */
1077 vp
->stack_limit
= vp
->stack_base
+ vp
->max_stack_size
;
1079 vm_error ("VM: Stack overflow", SCM_UNDEFINED
);
1082 /* Otherwise continue, with the new enlarged stack. */
1085 static struct scm_vm
*
1086 thread_vm (scm_i_thread
*t
)
1088 if (SCM_UNLIKELY (!t
->vp
))
1097 return thread_vm (SCM_I_CURRENT_THREAD
);
1101 scm_call_n (SCM proc
, SCM
*argv
, size_t nargs
)
1103 scm_i_thread
*thread
;
1106 ptrdiff_t base_frame_size
;
1107 /* Cached variables. */
1108 scm_i_jmp_buf registers
; /* used for prompts */
1111 thread
= SCM_I_CURRENT_THREAD
;
1112 vp
= thread_vm (thread
);
1116 /* Check that we have enough space: 3 words for the boot continuation,
1117 and 3 + nargs for the procedure application. */
1118 base_frame_size
= 3 + 3 + nargs
;
1119 vm_push_sp (vp
, vp
->sp
+ base_frame_size
);
1120 base
= vp
->sp
+ 1 - base_frame_size
;
1122 /* Since it's possible to receive the arguments on the stack itself,
1123 shuffle up the arguments first. */
1124 for (i
= nargs
; i
> 0; i
--)
1125 base
[6 + i
- 1] = argv
[i
- 1];
1127 /* Push the boot continuation, which calls PROC and returns its
1129 base
[0] = SCM_PACK (vp
->fp
); /* dynamic link */
1130 base
[1] = SCM_PACK (vp
->ip
); /* ra */
1131 base
[2] = vm_boot_continuation
;
1133 vp
->ip
= (scm_t_uint32
*) vm_boot_continuation_code
;
1135 /* The pending call to PROC. */
1136 base
[3] = SCM_PACK (vp
->fp
); /* dynamic link */
1137 base
[4] = SCM_PACK (vp
->ip
); /* ra */
1142 int resume
= SCM_I_SETJMP (registers
);
1144 if (SCM_UNLIKELY (resume
))
1145 /* Non-local return. */
1146 vm_dispatch_abort_hook (vp
);
1148 return vm_engines
[vp
->engine
](thread
, vp
, ®isters
, resume
);
1152 /* Scheme interface */
1154 #define VM_DEFINE_HOOK(n) \
1156 struct scm_vm *vp; \
1157 vp = scm_the_vm (); \
1158 if (scm_is_false (vp->hooks[n])) \
1159 vp->hooks[n] = scm_make_hook (SCM_I_MAKINUM (1)); \
1160 return vp->hooks[n]; \
1163 SCM_DEFINE (scm_vm_apply_hook
, "vm-apply-hook", 0, 0, 0,
1166 #define FUNC_NAME s_scm_vm_apply_hook
1168 VM_DEFINE_HOOK (SCM_VM_APPLY_HOOK
);
1172 SCM_DEFINE (scm_vm_push_continuation_hook
, "vm-push-continuation-hook", 0, 0, 0,
1175 #define FUNC_NAME s_scm_vm_push_continuation_hook
1177 VM_DEFINE_HOOK (SCM_VM_PUSH_CONTINUATION_HOOK
);
1181 SCM_DEFINE (scm_vm_pop_continuation_hook
, "vm-pop-continuation-hook", 0, 0, 0,
1184 #define FUNC_NAME s_scm_vm_pop_continuation_hook
1186 VM_DEFINE_HOOK (SCM_VM_POP_CONTINUATION_HOOK
);
1190 SCM_DEFINE (scm_vm_next_hook
, "vm-next-hook", 0, 0, 0,
1193 #define FUNC_NAME s_scm_vm_next_hook
1195 VM_DEFINE_HOOK (SCM_VM_NEXT_HOOK
);
1199 SCM_DEFINE (scm_vm_abort_continuation_hook
, "vm-abort-continuation-hook", 0, 0, 0,
1202 #define FUNC_NAME s_scm_vm_abort_continuation_hook
1204 VM_DEFINE_HOOK (SCM_VM_ABORT_CONTINUATION_HOOK
);
1208 SCM_DEFINE (scm_vm_trace_level
, "vm-trace-level", 0, 0, 0,
1211 #define FUNC_NAME s_scm_vm_trace_level
1213 return scm_from_int (scm_the_vm ()->trace_level
);
1217 SCM_DEFINE (scm_set_vm_trace_level_x
, "set-vm-trace-level!", 1, 0, 0,
1220 #define FUNC_NAME s_scm_set_vm_trace_level_x
1222 scm_the_vm ()->trace_level
= scm_to_int (level
);
1223 return SCM_UNSPECIFIED
;
1233 symbol_to_vm_engine (SCM engine
, const char *FUNC_NAME
)
1235 if (scm_is_eq (engine
, sym_regular
))
1236 return SCM_VM_REGULAR_ENGINE
;
1237 else if (scm_is_eq (engine
, sym_debug
))
1238 return SCM_VM_DEBUG_ENGINE
;
1240 SCM_MISC_ERROR ("Unknown VM engine: ~a", scm_list_1 (engine
));
1244 vm_engine_to_symbol (int engine
, const char *FUNC_NAME
)
1248 case SCM_VM_REGULAR_ENGINE
:
1250 case SCM_VM_DEBUG_ENGINE
:
1254 SCM_MISC_ERROR ("Unknown VM engine: ~a",
1255 scm_list_1 (scm_from_int (engine
)));
1259 SCM_DEFINE (scm_vm_engine
, "vm-engine", 0, 0, 0,
1262 #define FUNC_NAME s_scm_vm_engine
1264 return vm_engine_to_symbol (scm_the_vm ()->engine
, FUNC_NAME
);
1269 scm_c_set_vm_engine_x (int engine
)
1270 #define FUNC_NAME "set-vm-engine!"
1272 if (engine
< 0 || engine
>= SCM_VM_NUM_ENGINES
)
1273 SCM_MISC_ERROR ("Unknown VM engine: ~a",
1274 scm_list_1 (scm_from_int (engine
)));
1276 scm_the_vm ()->engine
= engine
;
1280 SCM_DEFINE (scm_set_vm_engine_x
, "set-vm-engine!", 1, 0, 0,
1283 #define FUNC_NAME s_scm_set_vm_engine_x
1285 scm_c_set_vm_engine_x (symbol_to_vm_engine (engine
, FUNC_NAME
));
1286 return SCM_UNSPECIFIED
;
1291 scm_c_set_default_vm_engine_x (int engine
)
1292 #define FUNC_NAME "set-default-vm-engine!"
1294 if (engine
< 0 || engine
>= SCM_VM_NUM_ENGINES
)
1295 SCM_MISC_ERROR ("Unknown VM engine: ~a",
1296 scm_list_1 (scm_from_int (engine
)));
1298 vm_default_engine
= engine
;
1302 SCM_DEFINE (scm_set_default_vm_engine_x
, "set-default-vm-engine!", 1, 0, 0,
1305 #define FUNC_NAME s_scm_set_default_vm_engine_x
1307 scm_c_set_default_vm_engine_x (symbol_to_vm_engine (engine
, FUNC_NAME
));
1308 return SCM_UNSPECIFIED
;
1312 /* FIXME: This function makes no sense, but we keep it to make sure we
1313 have a way of switching to the debug or regular VM. */
1314 SCM_DEFINE (scm_call_with_vm
, "call-with-vm", 1, 0, 1,
1315 (SCM proc
, SCM args
),
1316 "Apply @var{proc} to @var{args} in a dynamic extent in which\n"
1317 "@var{vm} is the current VM.")
1318 #define FUNC_NAME s_scm_call_with_vm
1320 return scm_apply_0 (proc
, args
);
1330 scm_load_compiled_with_vm (SCM file
)
1332 return scm_call_0 (scm_load_thunk_from_file (file
));
1337 scm_init_vm_builtin_properties (void)
1339 /* FIXME: Seems hacky to do this here, but oh well :/ */
1340 scm_sym_apply
= scm_from_utf8_symbol ("apply");
1341 scm_sym_values
= scm_from_utf8_symbol ("values");
1342 scm_sym_abort_to_prompt
= scm_from_utf8_symbol ("abort-to-prompt");
1343 scm_sym_call_with_values
= scm_from_utf8_symbol ("call-with-values");
1344 scm_sym_call_with_current_continuation
=
1345 scm_from_utf8_symbol ("call-with-current-continuation");
1347 #define INIT_BUILTIN(builtin, BUILTIN, req, opt, rest) \
1348 scm_set_procedure_property_x (vm_builtin_##builtin, scm_sym_name, \
1349 scm_sym_##builtin); \
1350 scm_set_procedure_minimum_arity_x (vm_builtin_##builtin, \
1351 SCM_I_MAKINUM (req), \
1352 SCM_I_MAKINUM (opt), \
1353 scm_from_bool (rest));
1354 FOR_EACH_VM_BUILTIN (INIT_BUILTIN
);
1359 scm_bootstrap_vm (void)
1361 scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION
,
1363 (scm_t_extension_init_func
)scm_init_vm
, NULL
);
1364 scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION
,
1365 "scm_init_vm_builtins",
1366 (scm_t_extension_init_func
)scm_init_vm_builtins
,
1369 page_size
= getpagesize ();
1370 /* page_size should be a power of two. */
1371 if (page_size
& (page_size
- 1))
1374 initialize_default_stack_size ();
1376 sym_vm_run
= scm_from_latin1_symbol ("vm-run");
1377 sym_vm_error
= scm_from_latin1_symbol ("vm-error");
1378 sym_keyword_argument_error
= scm_from_latin1_symbol ("keyword-argument-error");
1379 sym_regular
= scm_from_latin1_symbol ("regular");
1380 sym_debug
= scm_from_latin1_symbol ("debug");
1382 vm_boot_continuation
= scm_i_make_program (vm_boot_continuation_code
);
1383 SCM_SET_CELL_WORD_0 (vm_boot_continuation
,
1384 (SCM_CELL_WORD_0 (vm_boot_continuation
)
1385 | SCM_F_PROGRAM_IS_BOOT
));
1387 #define DEFINE_BUILTIN(builtin, BUILTIN, req, opt, rest) \
1388 vm_builtin_##builtin = scm_i_make_program (vm_builtin_##builtin##_code);
1389 FOR_EACH_VM_BUILTIN (DEFINE_BUILTIN
);
1390 #undef DEFINE_BUILTIN
1396 #ifndef SCM_MAGIC_SNARFER
1397 #include "libguile/vm.x"