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
);
716 /* Hard stack limit is 512M words: 2 gigabytes on 32-bit machines, 4 on
718 static const size_t hard_max_stack_size
= 512 * 1024 * 1024;
720 /* Initial stack size: 4 or 8 kB. */
721 static const size_t initial_stack_size
= 1024;
723 /* Default soft stack limit is 1M words (4 or 8 megabytes). */
724 static size_t default_max_stack_size
= 1024 * 1024;
727 initialize_default_stack_size (void)
729 int size
= scm_getenv_int ("GUILE_STACK_SIZE", (int) default_max_stack_size
);
730 if (size
>= initial_stack_size
&& (size_t) size
< ((size_t) -1) / sizeof(SCM
))
731 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
;
861 static size_t page_size
;
864 return_unused_stack_to_os (struct scm_vm
*vp
)
867 scm_t_uintptr start
= (scm_t_uintptr
) (vp
->sp
+ 1);
868 scm_t_uintptr end
= (scm_t_uintptr
) vp
->stack_limit
;
869 /* The second condition is needed to protect against wrap-around. */
870 if (vp
->sp_max_since_gc
< vp
->stack_limit
&& vp
->sp
< vp
->sp_max_since_gc
)
871 end
= (scm_t_uintptr
) (vp
->sp_max_since_gc
+ 1);
873 start
= ((start
- 1U) | (page_size
- 1U)) + 1U; /* round up */
874 end
= ((end
- 1U) | (page_size
- 1U)) + 1U; /* round up */
876 /* Return these pages to the OS. The next time they are paged in,
877 they will be zeroed. */
883 ret
= madvise ((void *) start
, end
- start
, MADV_DONTNEED
);
884 while (ret
&& errno
== -EAGAIN
);
887 perror ("madvise failed");
890 vp
->sp_max_since_gc
= vp
->sp
;
894 #define DEAD_SLOT_MAP_CACHE_SIZE 32U
895 struct dead_slot_map_cache_entry
898 const scm_t_uint8
*map
;
901 struct dead_slot_map_cache
903 struct dead_slot_map_cache_entry entries
[DEAD_SLOT_MAP_CACHE_SIZE
];
906 static const scm_t_uint8
*
907 find_dead_slot_map (scm_t_uint32
*ip
, struct dead_slot_map_cache
*cache
)
909 /* The lower two bits should be zero. FIXME: Use a better hash
910 function; we don't expose scm_raw_hashq currently. */
911 size_t slot
= (((scm_t_uintptr
) ip
) >> 2) % DEAD_SLOT_MAP_CACHE_SIZE
;
912 const scm_t_uint8
*map
;
914 if (cache
->entries
[slot
].ip
== ip
)
915 map
= cache
->entries
[slot
].map
;
918 map
= scm_find_dead_slot_map_unlocked (ip
);
919 cache
->entries
[slot
].ip
= ip
;
920 cache
->entries
[slot
].map
= map
;
926 /* Mark the VM stack region between its base and its current top. */
928 scm_i_vm_mark_stack (struct scm_vm
*vp
, struct GC_ms_entry
*mark_stack_ptr
,
929 struct GC_ms_entry
*mark_stack_limit
)
932 /* The first frame will be marked conservatively (without a dead
933 slot map). This is because GC can happen at any point within the
934 hottest activation, due to multiple threads or per-instruction
935 hooks, and providing dead slot maps for all points in a program
936 would take a prohibitive amount of space. */
937 const scm_t_uint8
*dead_slots
= NULL
;
938 scm_t_uintptr upper
= (scm_t_uintptr
) GC_greatest_plausible_heap_addr
;
939 scm_t_uintptr lower
= (scm_t_uintptr
) GC_least_plausible_heap_addr
;
940 struct dead_slot_map_cache cache
;
942 memset (&cache
, 0, sizeof (cache
));
944 for (fp
= vp
->fp
, sp
= vp
->sp
; fp
; fp
= SCM_FRAME_DYNAMIC_LINK (fp
))
946 for (; sp
>= &SCM_FRAME_LOCAL (fp
, 0); sp
--)
950 && SCM_UNPACK (elt
) >= lower
&& SCM_UNPACK (elt
) <= upper
)
954 size_t slot
= sp
- &SCM_FRAME_LOCAL (fp
, 0);
955 if (dead_slots
[slot
/ 8U] & (1U << (slot
% 8U)))
957 /* This value may become dead as a result of GC,
958 so we can't just leave it on the stack. */
964 mark_stack_ptr
= GC_mark_and_push ((void *) elt
,
970 sp
= SCM_FRAME_PREVIOUS_SP (fp
);
971 /* Inner frames may have a dead slots map for precise marking.
972 Note that there may be other reasons to not have a dead slots
973 map, e.g. if all of the frame's slots below the callee frame
975 dead_slots
= find_dead_slot_map (SCM_FRAME_RETURN_ADDRESS (fp
), &cache
);
978 return_unused_stack_to_os (vp
);
980 return mark_stack_ptr
;
983 /* Free the VM stack, as this thread is exiting. */
985 scm_i_vm_free_stack (struct scm_vm
*vp
)
987 free_stack (vp
->stack_base
, vp
->stack_size
);
988 vp
->stack_base
= vp
->stack_limit
= NULL
;
993 vm_expand_stack (struct scm_vm
*vp
)
995 scm_t_ptrdiff stack_size
= vp
->sp
+ 1 - vp
->stack_base
;
997 if (stack_size
> hard_max_stack_size
)
999 /* We have expanded the soft limit to the point that we reached a
1000 hard limit. There is nothing sensible to do. */
1001 fprintf (stderr
, "Hard stack size limit (%zu words) reached; aborting.\n",
1002 hard_max_stack_size
);
1006 /* FIXME: Prevent GC while we expand the stack, to ensure that a
1007 stack marker can trace the stack. */
1008 if (stack_size
> vp
->stack_size
)
1010 SCM
*old_stack
, *new_stack
;
1012 scm_t_ptrdiff reloc
;
1014 new_size
= vp
->stack_size
;
1015 while (new_size
< stack_size
)
1017 old_stack
= vp
->stack_base
;
1018 new_stack
= expand_stack (vp
->stack_base
, vp
->stack_size
, new_size
);
1020 /* It would be nice to throw an exception here, but that is
1021 extraordinarily hard. Exceptionally hard, you might say!
1022 "throw" is implemented in Scheme, and there may be arbitrary
1023 pre-unwind handlers that push on more frames. We will
1024 endeavor to do so in the future, but for now we just
1028 vp
->stack_base
= new_stack
;
1029 vp
->stack_size
= new_size
;
1030 vp
->stack_limit
= vp
->stack_base
+ new_size
;
1031 reloc
= vp
->stack_base
- old_stack
;
1039 vp
->sp_max_since_gc
+= reloc
;
1043 SCM
*next_fp
= SCM_FRAME_DYNAMIC_LINK (fp
);
1047 SCM_FRAME_SET_DYNAMIC_LINK (fp
, next_fp
);
1054 if (stack_size
>= vp
->max_stack_size
)
1056 /* Expand the soft limit by 256K entries to give us space to
1057 handle the error. */
1058 vp
->max_stack_size
+= 256 * 1024;
1060 /* If it's still not big enough... it's quite improbable, but go
1061 ahead and set to the full available stack size. */
1062 if (vp
->max_stack_size
< stack_size
)
1063 vp
->max_stack_size
= vp
->stack_size
;
1065 /* But don't exceed the hard maximum. */
1066 if (vp
->max_stack_size
> hard_max_stack_size
)
1067 vp
->max_stack_size
= hard_max_stack_size
;
1069 /* Finally, reset the limit, to catch further overflows. */
1070 vp
->stack_limit
= vp
->stack_base
+ vp
->max_stack_size
;
1072 vm_error ("VM: Stack overflow", SCM_UNDEFINED
);
1075 /* Otherwise continue, with the new enlarged stack. */
1078 static struct scm_vm
*
1079 thread_vm (scm_i_thread
*t
)
1081 if (SCM_UNLIKELY (!t
->vp
))
1090 return thread_vm (SCM_I_CURRENT_THREAD
);
1094 scm_call_n (SCM proc
, SCM
*argv
, size_t nargs
)
1096 scm_i_thread
*thread
;
1099 ptrdiff_t base_frame_size
;
1100 /* Cached variables. */
1101 scm_i_jmp_buf registers
; /* used for prompts */
1104 thread
= SCM_I_CURRENT_THREAD
;
1105 vp
= thread_vm (thread
);
1109 /* Check that we have enough space: 3 words for the boot continuation,
1110 and 3 + nargs for the procedure application. */
1111 base_frame_size
= 3 + 3 + nargs
;
1112 vm_push_sp (vp
, vp
->sp
+ base_frame_size
);
1113 base
= vp
->sp
+ 1 - base_frame_size
;
1115 /* Since it's possible to receive the arguments on the stack itself,
1116 shuffle up the arguments first. */
1117 for (i
= nargs
; i
> 0; i
--)
1118 base
[6 + i
- 1] = argv
[i
- 1];
1120 /* Push the boot continuation, which calls PROC and returns its
1122 base
[0] = SCM_PACK (vp
->fp
); /* dynamic link */
1123 base
[1] = SCM_PACK (vp
->ip
); /* ra */
1124 base
[2] = vm_boot_continuation
;
1126 vp
->ip
= (scm_t_uint32
*) vm_boot_continuation_code
;
1128 /* The pending call to PROC. */
1129 base
[3] = SCM_PACK (vp
->fp
); /* dynamic link */
1130 base
[4] = SCM_PACK (vp
->ip
); /* ra */
1135 int resume
= SCM_I_SETJMP (registers
);
1137 if (SCM_UNLIKELY (resume
))
1138 /* Non-local return. */
1139 vm_dispatch_abort_hook (vp
);
1141 return vm_engines
[vp
->engine
](thread
, vp
, ®isters
, resume
);
1145 /* Scheme interface */
1147 #define VM_DEFINE_HOOK(n) \
1149 struct scm_vm *vp; \
1150 vp = scm_the_vm (); \
1151 if (scm_is_false (vp->hooks[n])) \
1152 vp->hooks[n] = scm_make_hook (SCM_I_MAKINUM (1)); \
1153 return vp->hooks[n]; \
1156 SCM_DEFINE (scm_vm_apply_hook
, "vm-apply-hook", 0, 0, 0,
1159 #define FUNC_NAME s_scm_vm_apply_hook
1161 VM_DEFINE_HOOK (SCM_VM_APPLY_HOOK
);
1165 SCM_DEFINE (scm_vm_push_continuation_hook
, "vm-push-continuation-hook", 0, 0, 0,
1168 #define FUNC_NAME s_scm_vm_push_continuation_hook
1170 VM_DEFINE_HOOK (SCM_VM_PUSH_CONTINUATION_HOOK
);
1174 SCM_DEFINE (scm_vm_pop_continuation_hook
, "vm-pop-continuation-hook", 0, 0, 0,
1177 #define FUNC_NAME s_scm_vm_pop_continuation_hook
1179 VM_DEFINE_HOOK (SCM_VM_POP_CONTINUATION_HOOK
);
1183 SCM_DEFINE (scm_vm_next_hook
, "vm-next-hook", 0, 0, 0,
1186 #define FUNC_NAME s_scm_vm_next_hook
1188 VM_DEFINE_HOOK (SCM_VM_NEXT_HOOK
);
1192 SCM_DEFINE (scm_vm_abort_continuation_hook
, "vm-abort-continuation-hook", 0, 0, 0,
1195 #define FUNC_NAME s_scm_vm_abort_continuation_hook
1197 VM_DEFINE_HOOK (SCM_VM_ABORT_CONTINUATION_HOOK
);
1201 SCM_DEFINE (scm_vm_trace_level
, "vm-trace-level", 0, 0, 0,
1204 #define FUNC_NAME s_scm_vm_trace_level
1206 return scm_from_int (scm_the_vm ()->trace_level
);
1210 SCM_DEFINE (scm_set_vm_trace_level_x
, "set-vm-trace-level!", 1, 0, 0,
1213 #define FUNC_NAME s_scm_set_vm_trace_level_x
1215 scm_the_vm ()->trace_level
= scm_to_int (level
);
1216 return SCM_UNSPECIFIED
;
1226 symbol_to_vm_engine (SCM engine
, const char *FUNC_NAME
)
1228 if (scm_is_eq (engine
, sym_regular
))
1229 return SCM_VM_REGULAR_ENGINE
;
1230 else if (scm_is_eq (engine
, sym_debug
))
1231 return SCM_VM_DEBUG_ENGINE
;
1233 SCM_MISC_ERROR ("Unknown VM engine: ~a", scm_list_1 (engine
));
1237 vm_engine_to_symbol (int engine
, const char *FUNC_NAME
)
1241 case SCM_VM_REGULAR_ENGINE
:
1243 case SCM_VM_DEBUG_ENGINE
:
1247 SCM_MISC_ERROR ("Unknown VM engine: ~a",
1248 scm_list_1 (scm_from_int (engine
)));
1252 SCM_DEFINE (scm_vm_engine
, "vm-engine", 0, 0, 0,
1255 #define FUNC_NAME s_scm_vm_engine
1257 return vm_engine_to_symbol (scm_the_vm ()->engine
, FUNC_NAME
);
1262 scm_c_set_vm_engine_x (int engine
)
1263 #define FUNC_NAME "set-vm-engine!"
1265 if (engine
< 0 || engine
>= SCM_VM_NUM_ENGINES
)
1266 SCM_MISC_ERROR ("Unknown VM engine: ~a",
1267 scm_list_1 (scm_from_int (engine
)));
1269 scm_the_vm ()->engine
= engine
;
1273 SCM_DEFINE (scm_set_vm_engine_x
, "set-vm-engine!", 1, 0, 0,
1276 #define FUNC_NAME s_scm_set_vm_engine_x
1278 scm_c_set_vm_engine_x (symbol_to_vm_engine (engine
, FUNC_NAME
));
1279 return SCM_UNSPECIFIED
;
1284 scm_c_set_default_vm_engine_x (int engine
)
1285 #define FUNC_NAME "set-default-vm-engine!"
1287 if (engine
< 0 || engine
>= SCM_VM_NUM_ENGINES
)
1288 SCM_MISC_ERROR ("Unknown VM engine: ~a",
1289 scm_list_1 (scm_from_int (engine
)));
1291 vm_default_engine
= engine
;
1295 SCM_DEFINE (scm_set_default_vm_engine_x
, "set-default-vm-engine!", 1, 0, 0,
1298 #define FUNC_NAME s_scm_set_default_vm_engine_x
1300 scm_c_set_default_vm_engine_x (symbol_to_vm_engine (engine
, FUNC_NAME
));
1301 return SCM_UNSPECIFIED
;
1305 /* FIXME: This function makes no sense, but we keep it to make sure we
1306 have a way of switching to the debug or regular VM. */
1307 SCM_DEFINE (scm_call_with_vm
, "call-with-vm", 1, 0, 1,
1308 (SCM proc
, SCM args
),
1309 "Apply @var{proc} to @var{args} in a dynamic extent in which\n"
1310 "@var{vm} is the current VM.")
1311 #define FUNC_NAME s_scm_call_with_vm
1313 return scm_apply_0 (proc
, args
);
1323 scm_load_compiled_with_vm (SCM file
)
1325 return scm_call_0 (scm_load_thunk_from_file (file
));
1330 scm_init_vm_builtin_properties (void)
1332 /* FIXME: Seems hacky to do this here, but oh well :/ */
1333 scm_sym_apply
= scm_from_utf8_symbol ("apply");
1334 scm_sym_values
= scm_from_utf8_symbol ("values");
1335 scm_sym_abort_to_prompt
= scm_from_utf8_symbol ("abort-to-prompt");
1336 scm_sym_call_with_values
= scm_from_utf8_symbol ("call-with-values");
1337 scm_sym_call_with_current_continuation
=
1338 scm_from_utf8_symbol ("call-with-current-continuation");
1340 #define INIT_BUILTIN(builtin, BUILTIN, req, opt, rest) \
1341 scm_set_procedure_property_x (vm_builtin_##builtin, scm_sym_name, \
1342 scm_sym_##builtin); \
1343 scm_set_procedure_minimum_arity_x (vm_builtin_##builtin, \
1344 SCM_I_MAKINUM (req), \
1345 SCM_I_MAKINUM (opt), \
1346 scm_from_bool (rest));
1347 FOR_EACH_VM_BUILTIN (INIT_BUILTIN
);
1352 scm_bootstrap_vm (void)
1354 scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION
,
1356 (scm_t_extension_init_func
)scm_init_vm
, NULL
);
1357 scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION
,
1358 "scm_init_vm_builtins",
1359 (scm_t_extension_init_func
)scm_init_vm_builtins
,
1362 page_size
= getpagesize ();
1363 /* page_size should be a power of two. */
1364 if (page_size
& (page_size
- 1))
1367 initialize_default_stack_size ();
1369 sym_vm_run
= scm_from_latin1_symbol ("vm-run");
1370 sym_vm_error
= scm_from_latin1_symbol ("vm-error");
1371 sym_keyword_argument_error
= scm_from_latin1_symbol ("keyword-argument-error");
1372 sym_regular
= scm_from_latin1_symbol ("regular");
1373 sym_debug
= scm_from_latin1_symbol ("debug");
1375 vm_boot_continuation
= scm_i_make_program (vm_boot_continuation_code
);
1376 SCM_SET_CELL_WORD_0 (vm_boot_continuation
,
1377 (SCM_CELL_WORD_0 (vm_boot_continuation
)
1378 | SCM_F_PROGRAM_IS_BOOT
));
1380 #define DEFINE_BUILTIN(builtin, BUILTIN, req, opt, rest) \
1381 vm_builtin_##builtin = scm_i_make_program (vm_builtin_##builtin##_code);
1382 FOR_EACH_VM_BUILTIN (DEFINE_BUILTIN
);
1383 #undef DEFINE_BUILTIN
1389 #ifndef SCM_MAGIC_SNARFER
1390 #include "libguile/vm.x"