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_no_values (void) SCM_NORETURN SCM_NOINLINE
;
427 static void vm_error_not_enough_values (void) SCM_NORETURN SCM_NOINLINE
;
428 static void vm_error_wrong_number_of_values (scm_t_uint32 expected
) SCM_NORETURN SCM_NOINLINE
;
429 static void vm_error_continuation_not_rewindable (SCM cont
) SCM_NORETURN SCM_NOINLINE
;
430 static void vm_error_bad_wide_string_length (size_t len
) SCM_NORETURN SCM_NOINLINE
;
433 vm_error (const char *msg
, SCM arg
)
435 scm_throw (sym_vm_error
,
436 scm_list_3 (sym_vm_run
, scm_from_latin1_string (msg
),
437 SCM_UNBNDP (arg
) ? SCM_EOL
: scm_list_1 (arg
)));
438 abort(); /* not reached */
442 vm_error_bad_instruction (scm_t_uint32 inst
)
444 vm_error ("VM: Bad instruction: ~s", scm_from_uint32 (inst
));
448 vm_error_unbound (SCM proc
, SCM sym
)
450 scm_error_scm (scm_misc_error_key
, proc
,
451 scm_from_latin1_string ("Unbound variable: ~s"),
452 scm_list_1 (sym
), SCM_BOOL_F
);
456 vm_error_unbound_fluid (SCM proc
, SCM fluid
)
458 scm_error_scm (scm_misc_error_key
, proc
,
459 scm_from_latin1_string ("Unbound fluid: ~s"),
460 scm_list_1 (fluid
), SCM_BOOL_F
);
464 vm_error_not_a_variable (const char *func_name
, SCM x
)
466 scm_error (scm_arg_type_key
, func_name
, "Not a variable: ~S",
467 scm_list_1 (x
), scm_list_1 (x
));
471 vm_error_apply_to_non_list (SCM x
)
473 scm_error (scm_arg_type_key
, "apply", "Apply to non-list: ~S",
474 scm_list_1 (x
), scm_list_1 (x
));
478 vm_error_kwargs_length_not_even (SCM proc
)
480 scm_error_scm (sym_keyword_argument_error
, proc
,
481 scm_from_latin1_string ("Odd length of keyword argument list"),
482 SCM_EOL
, SCM_BOOL_F
);
486 vm_error_kwargs_invalid_keyword (SCM proc
, SCM obj
)
488 scm_error_scm (sym_keyword_argument_error
, proc
,
489 scm_from_latin1_string ("Invalid keyword"),
490 SCM_EOL
, scm_list_1 (obj
));
494 vm_error_kwargs_unrecognized_keyword (SCM proc
, SCM kw
)
496 scm_error_scm (sym_keyword_argument_error
, proc
,
497 scm_from_latin1_string ("Unrecognized keyword"),
498 SCM_EOL
, scm_list_1 (kw
));
502 vm_error_too_many_args (int nargs
)
504 vm_error ("VM: Too many arguments", scm_from_int (nargs
));
508 vm_error_wrong_num_args (SCM proc
)
510 scm_wrong_num_args (proc
);
514 vm_error_wrong_type_apply (SCM proc
)
516 scm_error (scm_arg_type_key
, NULL
, "Wrong type to apply: ~S",
517 scm_list_1 (proc
), scm_list_1 (proc
));
521 vm_error_stack_underflow (void)
523 vm_error ("VM: Stack underflow", SCM_UNDEFINED
);
527 vm_error_improper_list (SCM x
)
529 vm_error ("Expected a proper list, but got object with tail ~s", x
);
533 vm_error_not_a_pair (const char *subr
, SCM x
)
535 scm_wrong_type_arg_msg (subr
, 1, x
, "pair");
539 vm_error_not_a_bytevector (const char *subr
, SCM x
)
541 scm_wrong_type_arg_msg (subr
, 1, x
, "bytevector");
545 vm_error_not_a_struct (const char *subr
, SCM x
)
547 scm_wrong_type_arg_msg (subr
, 1, x
, "struct");
551 vm_error_no_values (void)
553 vm_error ("Zero values returned to single-valued continuation",
558 vm_error_not_enough_values (void)
560 vm_error ("Too few values returned to continuation", SCM_UNDEFINED
);
564 vm_error_wrong_number_of_values (scm_t_uint32 expected
)
566 vm_error ("Wrong number of values returned to continuation (expected ~a)",
567 scm_from_uint32 (expected
));
571 vm_error_continuation_not_rewindable (SCM cont
)
573 vm_error ("Unrewindable partial continuation", cont
);
577 vm_error_bad_wide_string_length (size_t len
)
579 vm_error ("VM: Bad wide string length: ~S", scm_from_size_t (len
));
585 static SCM vm_boot_continuation
;
586 static SCM vm_builtin_apply
;
587 static SCM vm_builtin_values
;
588 static SCM vm_builtin_abort_to_prompt
;
589 static SCM vm_builtin_call_with_values
;
590 static SCM vm_builtin_call_with_current_continuation
;
592 static const scm_t_uint32 vm_boot_continuation_code
[] = {
593 SCM_PACK_OP_24 (halt
, 0)
596 static const scm_t_uint32 vm_builtin_apply_code
[] = {
597 SCM_PACK_OP_24 (assert_nargs_ge
, 3),
598 SCM_PACK_OP_24 (tail_apply
, 0), /* proc in r1, args from r2 */
601 static const scm_t_uint32 vm_builtin_values_code
[] = {
602 SCM_PACK_OP_24 (return_values
, 0) /* vals from r1 */
605 static const scm_t_uint32 vm_builtin_abort_to_prompt_code
[] = {
606 SCM_PACK_OP_24 (assert_nargs_ge
, 2),
607 SCM_PACK_OP_24 (abort
, 0), /* tag in r1, vals from r2 */
608 /* FIXME: Partial continuation should capture caller regs. */
609 SCM_PACK_OP_24 (return_values
, 0) /* vals from r1 */
612 static const scm_t_uint32 vm_builtin_call_with_values_code
[] = {
613 SCM_PACK_OP_24 (assert_nargs_ee
, 3),
614 SCM_PACK_OP_24 (alloc_frame
, 7),
615 SCM_PACK_OP_12_12 (mov
, 6, 1),
616 SCM_PACK_OP_24 (call
, 6), SCM_PACK_OP_ARG_8_24 (0, 1),
617 SCM_PACK_OP_12_12 (mov
, 0, 2),
618 SCM_PACK_OP_24 (tail_call_shuffle
, 7)
621 static const scm_t_uint32 vm_builtin_call_with_current_continuation_code
[] = {
622 SCM_PACK_OP_24 (assert_nargs_ee
, 2),
623 SCM_PACK_OP_24 (call_cc
, 0)
628 scm_vm_builtin_ref (unsigned idx
)
632 #define INDEX_TO_NAME(builtin, BUILTIN, req, opt, rest) \
633 case SCM_VM_BUILTIN_##BUILTIN: return vm_builtin_##builtin;
634 FOR_EACH_VM_BUILTIN(INDEX_TO_NAME
)
641 static SCM scm_sym_values
;
642 static SCM scm_sym_abort_to_prompt
;
643 static SCM scm_sym_call_with_values
;
644 static SCM scm_sym_call_with_current_continuation
;
647 scm_vm_builtin_name_to_index (SCM name
)
648 #define FUNC_NAME "builtin-name->index"
650 SCM_VALIDATE_SYMBOL (1, name
);
652 #define NAME_TO_INDEX(builtin, BUILTIN, req, opt, rest) \
653 if (scm_is_eq (name, scm_sym_##builtin)) \
654 return scm_from_uint (SCM_VM_BUILTIN_##BUILTIN);
655 FOR_EACH_VM_BUILTIN(NAME_TO_INDEX
)
663 scm_vm_builtin_index_to_name (SCM index
)
664 #define FUNC_NAME "builtin-index->name"
668 SCM_VALIDATE_UINT_COPY (1, index
, idx
);
672 #define INDEX_TO_NAME(builtin, BUILTIN, req, opt, rest) \
673 case SCM_VM_BUILTIN_##BUILTIN: return scm_sym_##builtin;
674 FOR_EACH_VM_BUILTIN(INDEX_TO_NAME
)
676 default: return SCM_BOOL_F
;
682 scm_init_vm_builtins (void)
684 scm_c_define_gsubr ("builtin-name->index", 1, 0, 0,
685 scm_vm_builtin_name_to_index
);
686 scm_c_define_gsubr ("builtin-index->name", 1, 0, 0,
687 scm_vm_builtin_index_to_name
);
691 scm_i_call_with_current_continuation (SCM proc
)
693 return scm_call_1 (vm_builtin_call_with_current_continuation
, proc
);
701 /* Hard stack limit is 512M words: 2 gigabytes on 32-bit machines, 4 on
703 static const size_t hard_max_stack_size
= 512 * 1024 * 1024;
705 /* Initial stack size: 4 or 8 kB. */
706 static const size_t initial_stack_size
= 1024;
708 /* Default soft stack limit is 1M words (4 or 8 megabytes). */
709 static size_t default_max_stack_size
= 1024 * 1024;
712 initialize_default_stack_size (void)
714 int size
= scm_getenv_int ("GUILE_STACK_SIZE", (int) default_max_stack_size
);
715 if (size
>= initial_stack_size
&& (size_t) size
< ((size_t) -1) / sizeof(SCM
))
716 default_max_stack_size
= size
;
719 #define VM_NAME vm_regular_engine
720 #define VM_USE_HOOKS 0
721 #define FUNC_NAME "vm-regular-engine"
722 #include "vm-engine.c"
727 #define VM_NAME vm_debug_engine
728 #define VM_USE_HOOKS 1
729 #define FUNC_NAME "vm-debug-engine"
730 #include "vm-engine.c"
735 typedef SCM (*scm_t_vm_engine
) (scm_i_thread
*current_thread
, struct scm_vm
*vp
,
736 scm_i_jmp_buf
*registers
, int resume
);
738 static const scm_t_vm_engine vm_engines
[SCM_VM_NUM_ENGINES
] =
739 { vm_regular_engine
, vm_debug_engine
};
742 allocate_stack (size_t size
)
743 #define FUNC_NAME "make_vm"
747 if (size
>= ((size_t) -1) / sizeof (SCM
))
750 size
*= sizeof (SCM
);
753 ret
= mmap (NULL
, size
, PROT_READ
| PROT_WRITE
,
754 MAP_PRIVATE
| MAP_ANONYMOUS
, -1, 0);
755 if (ret
== MAP_FAILED
)
768 free_stack (SCM
*stack
, size_t size
)
770 size
*= sizeof (SCM
);
773 munmap (stack
, size
);
780 expand_stack (SCM
*old_stack
, size_t old_size
, size_t new_size
)
781 #define FUNC_NAME "expand_stack"
783 #if defined MREMAP_MAYMOVE
786 if (new_size
>= ((size_t) -1) / sizeof (SCM
))
789 old_size
*= sizeof (SCM
);
790 new_size
*= sizeof (SCM
);
792 new_stack
= mremap (old_stack
, old_size
, new_size
, MREMAP_MAYMOVE
);
793 if (new_stack
== MAP_FAILED
)
796 return (SCM
*) new_stack
;
800 new_stack
= allocate_stack (new_size
);
801 memcpy (new_stack
, old_stack
, old_size
* sizeof (SCM
));
802 free_stack (old_stack
, old_size
);
809 static struct scm_vm
*
811 #define FUNC_NAME "make_vm"
816 vp
= scm_gc_malloc (sizeof (struct scm_vm
), "vm");
818 vp
->stack_size
= initial_stack_size
;
819 vp
->stack_base
= allocate_stack (vp
->stack_size
);
820 vp
->stack_limit
= vp
->stack_base
+ vp
->stack_size
;
821 vp
->max_stack_size
= default_max_stack_size
;
823 vp
->sp
= vp
->stack_base
- 1;
825 vp
->engine
= vm_default_engine
;
827 for (i
= 0; i
< SCM_VM_NUM_HOOKS
; i
++)
828 vp
->hooks
[i
] = SCM_BOOL_F
;
834 static size_t page_size
;
837 return_unused_stack_to_os (struct scm_vm
*vp
)
840 scm_t_uintptr start
= (scm_t_uintptr
) (vp
->sp
+ 1);
841 scm_t_uintptr end
= (scm_t_uintptr
) vp
->stack_limit
;
842 /* The second condition is needed to protect against wrap-around. */
843 if (vp
->sp_max_since_gc
< vp
->stack_limit
&& vp
->sp
< vp
->sp_max_since_gc
)
844 end
= (scm_t_uintptr
) (vp
->sp_max_since_gc
+ 1);
846 start
= ((start
- 1U) | (page_size
- 1U)) + 1U; /* round up */
847 end
= ((end
- 1U) | (page_size
- 1U)) + 1U; /* round up */
849 /* Return these pages to the OS. The next time they are paged in,
850 they will be zeroed. */
852 madvise ((void *) start
, end
- start
, MADV_DONTNEED
);
854 vp
->sp_max_since_gc
= vp
->sp
;
858 #define DEAD_SLOT_MAP_CACHE_SIZE 32U
859 struct dead_slot_map_cache_entry
862 const scm_t_uint8
*map
;
865 struct dead_slot_map_cache
867 struct dead_slot_map_cache_entry entries
[DEAD_SLOT_MAP_CACHE_SIZE
];
870 static const scm_t_uint8
*
871 find_dead_slot_map (scm_t_uint32
*ip
, struct dead_slot_map_cache
*cache
)
873 /* The lower two bits should be zero. FIXME: Use a better hash
874 function; we don't expose scm_raw_hashq currently. */
875 size_t slot
= (((scm_t_uintptr
) ip
) >> 2) % DEAD_SLOT_MAP_CACHE_SIZE
;
876 const scm_t_uint8
*map
;
878 if (cache
->entries
[slot
].ip
== ip
)
879 map
= cache
->entries
[slot
].map
;
882 map
= scm_find_dead_slot_map_unlocked (ip
);
883 cache
->entries
[slot
].ip
= ip
;
884 cache
->entries
[slot
].map
= map
;
890 /* Mark the VM stack region between its base and its current top. */
892 scm_i_vm_mark_stack (struct scm_vm
*vp
, struct GC_ms_entry
*mark_stack_ptr
,
893 struct GC_ms_entry
*mark_stack_limit
)
896 /* The first frame will be marked conservatively (without a dead
897 slot map). This is because GC can happen at any point within the
898 hottest activation, due to multiple threads or per-instruction
899 hooks, and providing dead slot maps for all points in a program
900 would take a prohibitive amount of space. */
901 const scm_t_uint8
*dead_slots
= NULL
;
902 scm_t_uintptr upper
= (scm_t_uintptr
) GC_greatest_plausible_heap_addr
;
903 scm_t_uintptr lower
= (scm_t_uintptr
) GC_least_plausible_heap_addr
;
904 struct dead_slot_map_cache cache
;
906 memset (&cache
, 0, sizeof (cache
));
908 for (fp
= vp
->fp
, sp
= vp
->sp
; fp
; fp
= SCM_FRAME_DYNAMIC_LINK (fp
))
910 for (; sp
>= &SCM_FRAME_LOCAL (fp
, 0); sp
--)
914 && SCM_UNPACK (elt
) >= lower
&& SCM_UNPACK (elt
) <= upper
)
918 size_t slot
= sp
- &SCM_FRAME_LOCAL (fp
, 0);
919 if (dead_slots
[slot
/ 8U] & (1U << (slot
% 8U)))
921 /* This value may become dead as a result of GC,
922 so we can't just leave it on the stack. */
928 mark_stack_ptr
= GC_mark_and_push ((void *) elt
,
934 sp
= SCM_FRAME_PREVIOUS_SP (fp
);
935 /* Inner frames may have a dead slots map for precise marking.
936 Note that there may be other reasons to not have a dead slots
937 map, e.g. if all of the frame's slots below the callee frame
939 dead_slots
= find_dead_slot_map (SCM_FRAME_RETURN_ADDRESS (fp
), &cache
);
942 return_unused_stack_to_os (vp
);
944 return mark_stack_ptr
;
947 /* Free the VM stack, as this thread is exiting. */
949 scm_i_vm_free_stack (struct scm_vm
*vp
)
951 free_stack (vp
->stack_base
, vp
->stack_size
);
952 vp
->stack_base
= vp
->stack_limit
= NULL
;
957 vm_expand_stack (struct scm_vm
*vp
)
959 scm_t_ptrdiff stack_size
= vp
->sp
+ 1 - vp
->stack_base
;
961 if (stack_size
> hard_max_stack_size
)
963 /* We have expanded the soft limit to the point that we reached a
964 hard limit. There is nothing sensible to do. */
965 fprintf (stderr
, "Hard stack size limit (%zu words) reached; aborting.\n",
966 hard_max_stack_size
);
970 /* FIXME: Prevent GC while we expand the stack, to ensure that a
971 stack marker can trace the stack. */
972 if (stack_size
> vp
->stack_size
)
978 new_size
= vp
->stack_size
;
979 while (new_size
< stack_size
)
981 old_stack
= vp
->stack_base
;
982 vp
->stack_base
= expand_stack (old_stack
, vp
->stack_size
, new_size
);
983 vp
->stack_size
= new_size
;
984 vp
->stack_limit
= vp
->stack_base
+ new_size
;
985 reloc
= vp
->stack_base
- old_stack
;
993 vp
->sp_max_since_gc
+= reloc
;
997 SCM
*next_fp
= SCM_FRAME_DYNAMIC_LINK (fp
);
1001 SCM_FRAME_SET_DYNAMIC_LINK (fp
, next_fp
);
1008 if (stack_size
>= vp
->max_stack_size
)
1010 /* Expand the soft limit by 256K entries to give us space to
1011 handle the error. */
1012 vp
->max_stack_size
+= 256 * 1024;
1014 /* If it's still not big enough... it's quite improbable, but go
1015 ahead and set to the full available stack size. */
1016 if (vp
->max_stack_size
< stack_size
)
1017 vp
->max_stack_size
= vp
->stack_size
;
1019 /* But don't exceed the hard maximum. */
1020 if (vp
->max_stack_size
> hard_max_stack_size
)
1021 vp
->max_stack_size
= hard_max_stack_size
;
1023 /* Finally, reset the limit, to catch further overflows. */
1024 vp
->stack_limit
= vp
->stack_base
+ vp
->max_stack_size
;
1026 vm_error ("VM: Stack overflow", SCM_UNDEFINED
);
1029 /* Otherwise continue, with the new enlarged stack. */
1032 static struct scm_vm
*
1033 thread_vm (scm_i_thread
*t
)
1035 if (SCM_UNLIKELY (!t
->vp
))
1044 return thread_vm (SCM_I_CURRENT_THREAD
);
1048 scm_call_n (SCM proc
, SCM
*argv
, size_t nargs
)
1050 scm_i_thread
*thread
;
1053 ptrdiff_t base_frame_size
;
1054 /* Cached variables. */
1055 scm_i_jmp_buf registers
; /* used for prompts */
1058 thread
= SCM_I_CURRENT_THREAD
;
1059 vp
= thread_vm (thread
);
1063 /* Check that we have enough space: 3 words for the boot continuation,
1064 and 3 + nargs for the procedure application. */
1065 base_frame_size
= 3 + 3 + nargs
;
1066 vm_push_sp (vp
, vp
->sp
+ base_frame_size
);
1067 base
= vp
->sp
+ 1 - base_frame_size
;
1069 /* Since it's possible to receive the arguments on the stack itself,
1070 shuffle up the arguments first. */
1071 for (i
= nargs
; i
> 0; i
--)
1072 base
[6 + i
- 1] = argv
[i
- 1];
1074 /* Push the boot continuation, which calls PROC and returns its
1076 base
[0] = SCM_PACK (vp
->fp
); /* dynamic link */
1077 base
[1] = SCM_PACK (vp
->ip
); /* ra */
1078 base
[2] = vm_boot_continuation
;
1080 vp
->ip
= (scm_t_uint32
*) vm_boot_continuation_code
;
1082 /* The pending call to PROC. */
1083 base
[3] = SCM_PACK (vp
->fp
); /* dynamic link */
1084 base
[4] = SCM_PACK (vp
->ip
); /* ra */
1089 int resume
= SCM_I_SETJMP (registers
);
1091 if (SCM_UNLIKELY (resume
))
1092 /* Non-local return. */
1093 vm_dispatch_abort_hook (vp
);
1095 return vm_engines
[vp
->engine
](thread
, vp
, ®isters
, resume
);
1099 /* Scheme interface */
1101 #define VM_DEFINE_HOOK(n) \
1103 struct scm_vm *vp; \
1104 vp = scm_the_vm (); \
1105 if (scm_is_false (vp->hooks[n])) \
1106 vp->hooks[n] = scm_make_hook (SCM_I_MAKINUM (1)); \
1107 return vp->hooks[n]; \
1110 SCM_DEFINE (scm_vm_apply_hook
, "vm-apply-hook", 0, 0, 0,
1113 #define FUNC_NAME s_scm_vm_apply_hook
1115 VM_DEFINE_HOOK (SCM_VM_APPLY_HOOK
);
1119 SCM_DEFINE (scm_vm_push_continuation_hook
, "vm-push-continuation-hook", 0, 0, 0,
1122 #define FUNC_NAME s_scm_vm_push_continuation_hook
1124 VM_DEFINE_HOOK (SCM_VM_PUSH_CONTINUATION_HOOK
);
1128 SCM_DEFINE (scm_vm_pop_continuation_hook
, "vm-pop-continuation-hook", 0, 0, 0,
1131 #define FUNC_NAME s_scm_vm_pop_continuation_hook
1133 VM_DEFINE_HOOK (SCM_VM_POP_CONTINUATION_HOOK
);
1137 SCM_DEFINE (scm_vm_next_hook
, "vm-next-hook", 0, 0, 0,
1140 #define FUNC_NAME s_scm_vm_next_hook
1142 VM_DEFINE_HOOK (SCM_VM_NEXT_HOOK
);
1146 SCM_DEFINE (scm_vm_abort_continuation_hook
, "vm-abort-continuation-hook", 0, 0, 0,
1149 #define FUNC_NAME s_scm_vm_abort_continuation_hook
1151 VM_DEFINE_HOOK (SCM_VM_ABORT_CONTINUATION_HOOK
);
1155 SCM_DEFINE (scm_vm_trace_level
, "vm-trace-level", 0, 0, 0,
1158 #define FUNC_NAME s_scm_vm_trace_level
1160 return scm_from_int (scm_the_vm ()->trace_level
);
1164 SCM_DEFINE (scm_set_vm_trace_level_x
, "set-vm-trace-level!", 1, 0, 0,
1167 #define FUNC_NAME s_scm_set_vm_trace_level_x
1169 scm_the_vm ()->trace_level
= scm_to_int (level
);
1170 return SCM_UNSPECIFIED
;
1180 symbol_to_vm_engine (SCM engine
, const char *FUNC_NAME
)
1182 if (scm_is_eq (engine
, sym_regular
))
1183 return SCM_VM_REGULAR_ENGINE
;
1184 else if (scm_is_eq (engine
, sym_debug
))
1185 return SCM_VM_DEBUG_ENGINE
;
1187 SCM_MISC_ERROR ("Unknown VM engine: ~a", scm_list_1 (engine
));
1191 vm_engine_to_symbol (int engine
, const char *FUNC_NAME
)
1195 case SCM_VM_REGULAR_ENGINE
:
1197 case SCM_VM_DEBUG_ENGINE
:
1201 SCM_MISC_ERROR ("Unknown VM engine: ~a",
1202 scm_list_1 (scm_from_int (engine
)));
1206 SCM_DEFINE (scm_vm_engine
, "vm-engine", 0, 0, 0,
1209 #define FUNC_NAME s_scm_vm_engine
1211 return vm_engine_to_symbol (scm_the_vm ()->engine
, FUNC_NAME
);
1216 scm_c_set_vm_engine_x (int engine
)
1217 #define FUNC_NAME "set-vm-engine!"
1219 if (engine
< 0 || engine
>= SCM_VM_NUM_ENGINES
)
1220 SCM_MISC_ERROR ("Unknown VM engine: ~a",
1221 scm_list_1 (scm_from_int (engine
)));
1223 scm_the_vm ()->engine
= engine
;
1227 SCM_DEFINE (scm_set_vm_engine_x
, "set-vm-engine!", 1, 0, 0,
1230 #define FUNC_NAME s_scm_set_vm_engine_x
1232 scm_c_set_vm_engine_x (symbol_to_vm_engine (engine
, FUNC_NAME
));
1233 return SCM_UNSPECIFIED
;
1238 scm_c_set_default_vm_engine_x (int engine
)
1239 #define FUNC_NAME "set-default-vm-engine!"
1241 if (engine
< 0 || engine
>= SCM_VM_NUM_ENGINES
)
1242 SCM_MISC_ERROR ("Unknown VM engine: ~a",
1243 scm_list_1 (scm_from_int (engine
)));
1245 vm_default_engine
= engine
;
1249 SCM_DEFINE (scm_set_default_vm_engine_x
, "set-default-vm-engine!", 1, 0, 0,
1252 #define FUNC_NAME s_scm_set_default_vm_engine_x
1254 scm_c_set_default_vm_engine_x (symbol_to_vm_engine (engine
, FUNC_NAME
));
1255 return SCM_UNSPECIFIED
;
1259 /* FIXME: This function makes no sense, but we keep it to make sure we
1260 have a way of switching to the debug or regular VM. */
1261 SCM_DEFINE (scm_call_with_vm
, "call-with-vm", 1, 0, 1,
1262 (SCM proc
, SCM args
),
1263 "Apply @var{proc} to @var{args} in a dynamic extent in which\n"
1264 "@var{vm} is the current VM.")
1265 #define FUNC_NAME s_scm_call_with_vm
1267 return scm_apply_0 (proc
, args
);
1277 scm_load_compiled_with_vm (SCM file
)
1279 return scm_call_0 (scm_load_thunk_from_file (file
));
1284 scm_init_vm_builtin_properties (void)
1286 /* FIXME: Seems hacky to do this here, but oh well :/ */
1287 scm_sym_apply
= scm_from_utf8_symbol ("apply");
1288 scm_sym_values
= scm_from_utf8_symbol ("values");
1289 scm_sym_abort_to_prompt
= scm_from_utf8_symbol ("abort-to-prompt");
1290 scm_sym_call_with_values
= scm_from_utf8_symbol ("call-with-values");
1291 scm_sym_call_with_current_continuation
=
1292 scm_from_utf8_symbol ("call-with-current-continuation");
1294 #define INIT_BUILTIN(builtin, BUILTIN, req, opt, rest) \
1295 scm_set_procedure_property_x (vm_builtin_##builtin, scm_sym_name, \
1296 scm_sym_##builtin); \
1297 scm_set_procedure_minimum_arity_x (vm_builtin_##builtin, \
1298 SCM_I_MAKINUM (req), \
1299 SCM_I_MAKINUM (opt), \
1300 scm_from_bool (rest));
1301 FOR_EACH_VM_BUILTIN (INIT_BUILTIN
);
1306 scm_bootstrap_vm (void)
1308 scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION
,
1310 (scm_t_extension_init_func
)scm_init_vm
, NULL
);
1311 scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION
,
1312 "scm_init_vm_builtins",
1313 (scm_t_extension_init_func
)scm_init_vm_builtins
,
1316 page_size
= getpagesize ();
1317 /* page_size should be a power of two. */
1318 if (page_size
& (page_size
- 1))
1321 initialize_default_stack_size ();
1323 sym_vm_run
= scm_from_latin1_symbol ("vm-run");
1324 sym_vm_error
= scm_from_latin1_symbol ("vm-error");
1325 sym_keyword_argument_error
= scm_from_latin1_symbol ("keyword-argument-error");
1326 sym_regular
= scm_from_latin1_symbol ("regular");
1327 sym_debug
= scm_from_latin1_symbol ("debug");
1329 vm_boot_continuation
= scm_i_make_program (vm_boot_continuation_code
);
1330 SCM_SET_CELL_WORD_0 (vm_boot_continuation
,
1331 (SCM_CELL_WORD_0 (vm_boot_continuation
)
1332 | SCM_F_PROGRAM_IS_BOOT
));
1334 #define DEFINE_BUILTIN(builtin, BUILTIN, req, opt, rest) \
1335 vm_builtin_##builtin = scm_i_make_program (vm_builtin_##builtin##_code);
1336 FOR_EACH_VM_BUILTIN (DEFINE_BUILTIN
);
1337 #undef DEFINE_BUILTIN
1343 #ifndef SCM_MAGIC_SNARFER
1344 #include "libguile/vm.x"