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. */
32 #ifdef HAVE_SYS_MMAN_H
36 #include "libguile/bdw-gc.h"
37 #include <gc/gc_mark.h>
42 #include "instructions.h"
47 #include "vm-builtins.h"
49 static int vm_default_engine
= SCM_VM_REGULAR_ENGINE
;
51 /* Unfortunately we can't snarf these: snarfed things are only loaded up from
52 (system vm vm), which might not be loaded before an error happens. */
53 static SCM sym_vm_run
;
54 static SCM sym_vm_error
;
55 static SCM sym_keyword_argument_error
;
56 static SCM sym_regular
;
59 /* The VM has a number of internal assertions that shouldn't normally be
60 necessary, but might be if you think you found a bug in the VM. */
61 #define VM_ENABLE_ASSERTIONS
63 /* #define VM_ENABLE_PARANOID_ASSERTIONS */
72 scm_i_vm_cont_print (SCM x
, SCM port
, scm_print_state
*pstate
)
74 scm_puts_unlocked ("#<vm-continuation ", port
);
75 scm_uintprint (SCM_UNPACK (x
), 16, port
);
76 scm_puts_unlocked (">", port
);
79 /* In theory, a number of vm instances can be active in the call trace, and we
80 only want to reify the continuations of those in the current continuation
81 root. I don't see a nice way to do this -- ideally it would involve dynwinds,
82 and previous values of the *the-vm* fluid within the current continuation
83 root. But we don't have access to continuation roots in the dynwind stack.
84 So, just punt for now, we just capture the continuation for the current VM.
86 While I'm on the topic, ideally we could avoid copying the C stack if the
87 continuation root is inside VM code, and call/cc was invoked within that same
88 call to vm_run; but that's currently not implemented.
91 scm_i_vm_capture_stack (SCM
*stack_base
, SCM
*fp
, SCM
*sp
, scm_t_uint32
*ra
,
92 scm_t_dynstack
*dynstack
, scm_t_uint32 flags
)
94 struct scm_vm_cont
*p
;
96 p
= scm_gc_malloc (sizeof (*p
), "capture_vm_cont");
97 p
->stack_size
= sp
- stack_base
+ 1;
98 p
->stack_base
= scm_gc_malloc (p
->stack_size
* sizeof (SCM
),
103 memcpy (p
->stack_base
, stack_base
, (sp
+ 1 - stack_base
) * sizeof (SCM
));
104 p
->reloc
= p
->stack_base
- stack_base
;
105 p
->dynstack
= dynstack
;
107 return scm_cell (scm_tc7_vm_cont
, (scm_t_bits
)p
);
111 vm_return_to_continuation (struct scm_vm
*vp
, SCM cont
, size_t n
, SCM
*argv
)
113 struct scm_vm_cont
*cp
;
116 argv_copy
= alloca (n
* sizeof(SCM
));
117 memcpy (argv_copy
, argv
, n
* sizeof(SCM
));
119 cp
= SCM_VM_CONT_DATA (cont
);
121 if (vp
->stack_size
< cp
->stack_size
+ n
+ 3)
122 scm_misc_error ("vm-engine", "not enough space to reinstate continuation",
127 memcpy (vp
->stack_base
, cp
->stack_base
, cp
->stack_size
* sizeof (SCM
));
132 /* Push on an empty frame, as the continuation expects. */
133 for (i
= 0; i
< 3; i
++)
136 *vp
->sp
= SCM_BOOL_F
;
139 /* Push the return values. */
140 for (i
= 0; i
< n
; i
++)
143 *vp
->sp
= argv_copy
[i
];
149 static struct scm_vm
* thread_vm (scm_i_thread
*t
);
151 scm_i_capture_current_stack (void)
153 scm_i_thread
*thread
;
156 thread
= SCM_I_CURRENT_THREAD
;
157 vp
= thread_vm (thread
);
159 return scm_i_vm_capture_stack (vp
->stack_base
, vp
->fp
, vp
->sp
, vp
->ip
,
160 scm_dynstack_capture_all (&thread
->dynstack
),
164 static void vm_dispatch_apply_hook (struct scm_vm
*vp
) SCM_NOINLINE
;
165 static void vm_dispatch_push_continuation_hook (struct scm_vm
*vp
) SCM_NOINLINE
;
166 static void vm_dispatch_pop_continuation_hook (struct scm_vm
*vp
, SCM
*old_fp
) SCM_NOINLINE
;
167 static void vm_dispatch_next_hook (struct scm_vm
*vp
) SCM_NOINLINE
;
168 static void vm_dispatch_abort_hook (struct scm_vm
*vp
) SCM_NOINLINE
;
171 vm_dispatch_hook (struct scm_vm
*vp
, int hook_num
, SCM
*argv
, int n
)
174 struct scm_frame c_frame
;
176 int saved_trace_level
;
178 hook
= vp
->hooks
[hook_num
];
180 if (SCM_LIKELY (scm_is_false (hook
))
181 || scm_is_null (SCM_HOOK_PROCEDURES (hook
)))
184 saved_trace_level
= vp
->trace_level
;
187 /* Allocate a frame object on the stack. This is more efficient than calling
188 `scm_c_make_frame ()' to allocate on the heap, but it forces hooks to not
189 capture frame objects.
191 At the same time, procedures such as `frame-procedure' make sense only
192 while the stack frame represented by the frame object is visible, so it
193 seems reasonable to limit the lifetime of frame objects. */
195 c_frame
.stack_holder
= vp
;
196 c_frame
.fp_offset
= vp
->fp
- vp
->stack_base
;
197 c_frame
.sp_offset
= vp
->sp
- vp
->stack_base
;
200 /* Arrange for FRAME to be 8-byte aligned, like any other cell. */
201 frame
= alloca (sizeof (*frame
) + 8);
202 frame
= (scm_t_cell
*) ROUND_UP ((scm_t_uintptr
) frame
, 8UL);
204 frame
->word_0
= SCM_PACK (scm_tc7_frame
| (SCM_VM_FRAME_KIND_VM
<< 8));
205 frame
->word_1
= SCM_PACK_POINTER (&c_frame
);
211 args
[0] = SCM_PACK_POINTER (frame
);
212 scm_c_run_hookn (hook
, args
, 1);
218 args
[0] = SCM_PACK_POINTER (frame
);
220 scm_c_run_hookn (hook
, args
, 2);
227 args
= scm_cons (argv
[n
], args
);
228 scm_c_run_hook (hook
, scm_cons (SCM_PACK_POINTER (frame
), args
));
231 vp
->trace_level
= saved_trace_level
;
235 vm_dispatch_apply_hook (struct scm_vm
*vp
)
237 return vm_dispatch_hook (vp
, SCM_VM_APPLY_HOOK
, NULL
, 0);
239 static void vm_dispatch_push_continuation_hook (struct scm_vm
*vp
)
241 return vm_dispatch_hook (vp
, SCM_VM_PUSH_CONTINUATION_HOOK
, NULL
, 0);
243 static void vm_dispatch_pop_continuation_hook (struct scm_vm
*vp
, SCM
*old_fp
)
245 return vm_dispatch_hook (vp
, SCM_VM_POP_CONTINUATION_HOOK
,
246 &SCM_FRAME_LOCAL (old_fp
, 1),
247 SCM_FRAME_NUM_LOCALS (old_fp
, vp
->sp
) - 1);
249 static void vm_dispatch_next_hook (struct scm_vm
*vp
)
251 return vm_dispatch_hook (vp
, SCM_VM_NEXT_HOOK
, NULL
, 0);
253 static void vm_dispatch_abort_hook (struct scm_vm
*vp
)
255 return vm_dispatch_hook (vp
, SCM_VM_ABORT_CONTINUATION_HOOK
,
256 &SCM_FRAME_LOCAL (vp
->fp
, 1),
257 SCM_FRAME_NUM_LOCALS (vp
->fp
, vp
->sp
) - 1);
261 vm_abort (struct scm_vm
*vp
, SCM tag
,
262 size_t nstack
, SCM
*stack_args
, SCM tail
, SCM
*sp
,
263 scm_i_jmp_buf
*current_registers
) SCM_NORETURN
;
266 vm_abort (struct scm_vm
*vp
, SCM tag
,
267 size_t nstack
, SCM
*stack_args
, SCM tail
, SCM
*sp
,
268 scm_i_jmp_buf
*current_registers
)
274 tail_len
= scm_ilength (tail
);
276 scm_misc_error ("vm-engine", "tail values to abort should be a list",
279 argv
= alloca ((nstack
+ tail_len
) * sizeof (SCM
));
280 for (i
= 0; i
< nstack
; i
++)
281 argv
[i
] = stack_args
[i
];
282 for (; i
< nstack
+ tail_len
; i
++, tail
= scm_cdr (tail
))
283 argv
[i
] = scm_car (tail
);
285 /* FIXME: NULLSTACK (SCM_VM_DATA (vp)->sp - sp) */
288 scm_c_abort (vp
, tag
, nstack
+ tail_len
, argv
, current_registers
);
292 vm_reinstate_partial_continuation (struct scm_vm
*vp
, SCM cont
,
294 scm_t_dynstack
*dynstack
,
295 scm_i_jmp_buf
*registers
)
297 struct scm_vm_cont
*cp
;
298 SCM
*argv_copy
, *base
;
302 argv_copy
= alloca (n
* sizeof(SCM
));
303 memcpy (argv_copy
, argv
, n
* sizeof(SCM
));
305 cp
= SCM_VM_CONT_DATA (cont
);
306 base
= SCM_FRAME_LOCALS_ADDRESS (vp
->fp
);
307 reloc
= cp
->reloc
+ (base
- cp
->stack_base
);
309 #define RELOC(scm_p) \
310 (((SCM *) (scm_p)) + reloc)
312 if ((base
- vp
->stack_base
) + cp
->stack_size
+ n
+ 1 > vp
->stack_size
)
313 scm_misc_error ("vm-engine",
314 "not enough space to instate partial continuation",
317 memcpy (base
, cp
->stack_base
, cp
->stack_size
* sizeof (SCM
));
319 /* now relocate frame pointers */
322 for (fp
= RELOC (cp
->fp
);
323 SCM_FRAME_LOWER_ADDRESS (fp
) > base
;
324 fp
= SCM_FRAME_DYNAMIC_LINK (fp
))
325 SCM_FRAME_SET_DYNAMIC_LINK (fp
, RELOC (SCM_FRAME_DYNAMIC_LINK (fp
)));
328 vp
->sp
= base
- 1 + cp
->stack_size
;
329 vp
->fp
= RELOC (cp
->fp
);
332 /* Push the arguments. */
333 for (i
= 0; i
< n
; i
++)
336 *vp
->sp
= argv_copy
[i
];
339 /* The prompt captured a slice of the dynamic stack. Here we wind
340 those entries onto the current thread's stack. We also have to
341 relocate any prompts that we see along the way. */
345 for (walk
= SCM_DYNSTACK_FIRST (cp
->dynstack
);
346 SCM_DYNSTACK_TAG (walk
);
347 walk
= SCM_DYNSTACK_NEXT (walk
))
349 scm_t_bits tag
= SCM_DYNSTACK_TAG (walk
);
351 if (SCM_DYNSTACK_TAG_TYPE (tag
) == SCM_DYNSTACK_TYPE_PROMPT
)
352 scm_dynstack_wind_prompt (dynstack
, walk
, reloc
, registers
);
354 scm_dynstack_wind_1 (dynstack
, walk
);
365 static void vm_error (const char *msg
, SCM arg
) SCM_NORETURN
;
366 static void vm_error_bad_instruction (scm_t_uint32 inst
) SCM_NORETURN SCM_NOINLINE
;
367 static void vm_error_unbound (SCM proc
, SCM sym
) SCM_NORETURN SCM_NOINLINE
;
368 static void vm_error_unbound_fluid (SCM proc
, SCM fluid
) SCM_NORETURN SCM_NOINLINE
;
369 static void vm_error_not_a_variable (const char *func_name
, SCM x
) SCM_NORETURN SCM_NOINLINE
;
370 static void vm_error_apply_to_non_list (SCM x
) SCM_NORETURN SCM_NOINLINE
;
371 static void vm_error_kwargs_length_not_even (SCM proc
) SCM_NORETURN SCM_NOINLINE
;
372 static void vm_error_kwargs_invalid_keyword (SCM proc
, SCM obj
) SCM_NORETURN SCM_NOINLINE
;
373 static void vm_error_kwargs_unrecognized_keyword (SCM proc
, SCM kw
) SCM_NORETURN SCM_NOINLINE
;
374 static void vm_error_too_many_args (int nargs
) SCM_NORETURN SCM_NOINLINE
;
375 static void vm_error_wrong_num_args (SCM proc
) SCM_NORETURN SCM_NOINLINE
;
376 static void vm_error_wrong_type_apply (SCM proc
) SCM_NORETURN SCM_NOINLINE
;
377 static void vm_error_stack_underflow (void) SCM_NORETURN SCM_NOINLINE
;
378 static void vm_error_improper_list (SCM x
) SCM_NORETURN SCM_NOINLINE
;
379 static void vm_error_not_a_pair (const char *subr
, SCM x
) SCM_NORETURN SCM_NOINLINE
;
380 static void vm_error_not_a_bytevector (const char *subr
, SCM x
) SCM_NORETURN SCM_NOINLINE
;
381 static void vm_error_not_a_struct (const char *subr
, SCM x
) SCM_NORETURN SCM_NOINLINE
;
382 static void vm_error_no_values (void) SCM_NORETURN SCM_NOINLINE
;
383 static void vm_error_not_enough_values (void) SCM_NORETURN SCM_NOINLINE
;
384 static void vm_error_wrong_number_of_values (scm_t_uint32 expected
) SCM_NORETURN SCM_NOINLINE
;
385 static void vm_error_continuation_not_rewindable (SCM cont
) SCM_NORETURN SCM_NOINLINE
;
386 static void vm_error_bad_wide_string_length (size_t len
) SCM_NORETURN SCM_NOINLINE
;
389 vm_error (const char *msg
, SCM arg
)
391 scm_throw (sym_vm_error
,
392 scm_list_3 (sym_vm_run
, scm_from_latin1_string (msg
),
393 SCM_UNBNDP (arg
) ? SCM_EOL
: scm_list_1 (arg
)));
394 abort(); /* not reached */
398 vm_error_bad_instruction (scm_t_uint32 inst
)
400 vm_error ("VM: Bad instruction: ~s", scm_from_uint32 (inst
));
404 vm_error_unbound (SCM proc
, SCM sym
)
406 scm_error_scm (scm_misc_error_key
, proc
,
407 scm_from_latin1_string ("Unbound variable: ~s"),
408 scm_list_1 (sym
), SCM_BOOL_F
);
412 vm_error_unbound_fluid (SCM proc
, SCM fluid
)
414 scm_error_scm (scm_misc_error_key
, proc
,
415 scm_from_latin1_string ("Unbound fluid: ~s"),
416 scm_list_1 (fluid
), SCM_BOOL_F
);
420 vm_error_not_a_variable (const char *func_name
, SCM x
)
422 scm_error (scm_arg_type_key
, func_name
, "Not a variable: ~S",
423 scm_list_1 (x
), scm_list_1 (x
));
427 vm_error_apply_to_non_list (SCM x
)
429 scm_error (scm_arg_type_key
, "apply", "Apply to non-list: ~S",
430 scm_list_1 (x
), scm_list_1 (x
));
434 vm_error_kwargs_length_not_even (SCM proc
)
436 scm_error_scm (sym_keyword_argument_error
, proc
,
437 scm_from_latin1_string ("Odd length of keyword argument list"),
438 SCM_EOL
, SCM_BOOL_F
);
442 vm_error_kwargs_invalid_keyword (SCM proc
, SCM obj
)
444 scm_error_scm (sym_keyword_argument_error
, proc
,
445 scm_from_latin1_string ("Invalid keyword"),
446 SCM_EOL
, scm_list_1 (obj
));
450 vm_error_kwargs_unrecognized_keyword (SCM proc
, SCM kw
)
452 scm_error_scm (sym_keyword_argument_error
, proc
,
453 scm_from_latin1_string ("Unrecognized keyword"),
454 SCM_EOL
, scm_list_1 (kw
));
458 vm_error_too_many_args (int nargs
)
460 vm_error ("VM: Too many arguments", scm_from_int (nargs
));
464 vm_error_wrong_num_args (SCM proc
)
466 scm_wrong_num_args (proc
);
470 vm_error_wrong_type_apply (SCM proc
)
472 scm_error (scm_arg_type_key
, NULL
, "Wrong type to apply: ~S",
473 scm_list_1 (proc
), scm_list_1 (proc
));
477 vm_error_stack_underflow (void)
479 vm_error ("VM: Stack underflow", SCM_UNDEFINED
);
483 vm_error_improper_list (SCM x
)
485 vm_error ("Expected a proper list, but got object with tail ~s", x
);
489 vm_error_not_a_pair (const char *subr
, SCM x
)
491 scm_wrong_type_arg_msg (subr
, 1, x
, "pair");
495 vm_error_not_a_bytevector (const char *subr
, SCM x
)
497 scm_wrong_type_arg_msg (subr
, 1, x
, "bytevector");
501 vm_error_not_a_struct (const char *subr
, SCM x
)
503 scm_wrong_type_arg_msg (subr
, 1, x
, "struct");
507 vm_error_no_values (void)
509 vm_error ("Zero values returned to single-valued continuation",
514 vm_error_not_enough_values (void)
516 vm_error ("Too few values returned to continuation", SCM_UNDEFINED
);
520 vm_error_wrong_number_of_values (scm_t_uint32 expected
)
522 vm_error ("Wrong number of values returned to continuation (expected ~a)",
523 scm_from_uint32 (expected
));
527 vm_error_continuation_not_rewindable (SCM cont
)
529 vm_error ("Unrewindable partial continuation", cont
);
533 vm_error_bad_wide_string_length (size_t len
)
535 vm_error ("VM: Bad wide string length: ~S", scm_from_size_t (len
));
541 static SCM vm_boot_continuation
;
542 static SCM vm_builtin_apply
;
543 static SCM vm_builtin_values
;
544 static SCM vm_builtin_abort_to_prompt
;
545 static SCM vm_builtin_call_with_values
;
546 static SCM vm_builtin_call_with_current_continuation
;
548 static const scm_t_uint32 vm_boot_continuation_code
[] = {
549 SCM_PACK_OP_24 (halt
, 0)
552 static const scm_t_uint32 vm_builtin_apply_code
[] = {
553 SCM_PACK_OP_24 (assert_nargs_ge
, 3),
554 SCM_PACK_OP_24 (tail_apply
, 0), /* proc in r1, args from r2 */
557 static const scm_t_uint32 vm_builtin_values_code
[] = {
558 SCM_PACK_OP_24 (return_values
, 0) /* vals from r1 */
561 static const scm_t_uint32 vm_builtin_abort_to_prompt_code
[] = {
562 SCM_PACK_OP_24 (assert_nargs_ge
, 2),
563 SCM_PACK_OP_24 (abort
, 0), /* tag in r1, vals from r2 */
564 /* FIXME: Partial continuation should capture caller regs. */
565 SCM_PACK_OP_24 (return_values
, 0) /* vals from r1 */
568 static const scm_t_uint32 vm_builtin_call_with_values_code
[] = {
569 SCM_PACK_OP_24 (assert_nargs_ee
, 3),
570 SCM_PACK_OP_24 (alloc_frame
, 7),
571 SCM_PACK_OP_12_12 (mov
, 6, 1),
572 SCM_PACK_OP_24 (call
, 6), SCM_PACK_OP_ARG_8_24 (0, 1),
573 SCM_PACK_OP_12_12 (mov
, 0, 2),
574 SCM_PACK_OP_24 (tail_call_shuffle
, 7)
577 static const scm_t_uint32 vm_builtin_call_with_current_continuation_code
[] = {
578 SCM_PACK_OP_24 (assert_nargs_ee
, 2),
579 SCM_PACK_OP_24 (call_cc
, 0)
584 scm_vm_builtin_ref (unsigned idx
)
588 #define INDEX_TO_NAME(builtin, BUILTIN, req, opt, rest) \
589 case SCM_VM_BUILTIN_##BUILTIN: return vm_builtin_##builtin;
590 FOR_EACH_VM_BUILTIN(INDEX_TO_NAME
)
597 static SCM scm_sym_values
;
598 static SCM scm_sym_abort_to_prompt
;
599 static SCM scm_sym_call_with_values
;
600 static SCM scm_sym_call_with_current_continuation
;
603 scm_vm_builtin_name_to_index (SCM name
)
604 #define FUNC_NAME "builtin-name->index"
606 SCM_VALIDATE_SYMBOL (1, name
);
608 #define NAME_TO_INDEX(builtin, BUILTIN, req, opt, rest) \
609 if (scm_is_eq (name, scm_sym_##builtin)) \
610 return scm_from_uint (SCM_VM_BUILTIN_##BUILTIN);
611 FOR_EACH_VM_BUILTIN(NAME_TO_INDEX
)
619 scm_vm_builtin_index_to_name (SCM index
)
620 #define FUNC_NAME "builtin-index->name"
624 SCM_VALIDATE_UINT_COPY (1, index
, idx
);
628 #define INDEX_TO_NAME(builtin, BUILTIN, req, opt, rest) \
629 case SCM_VM_BUILTIN_##BUILTIN: return scm_sym_##builtin;
630 FOR_EACH_VM_BUILTIN(INDEX_TO_NAME
)
632 default: return SCM_BOOL_F
;
638 scm_init_vm_builtins (void)
640 scm_c_define_gsubr ("builtin-name->index", 1, 0, 0,
641 scm_vm_builtin_name_to_index
);
642 scm_c_define_gsubr ("builtin-index->name", 1, 0, 0,
643 scm_vm_builtin_index_to_name
);
647 scm_i_call_with_current_continuation (SCM proc
)
649 return scm_call_1 (vm_builtin_call_with_current_continuation
, proc
);
657 /* Hard stack limit is 512M words: 2 gigabytes on 32-bit machines, 4 on
659 static const size_t hard_max_stack_size
= 512 * 1024 * 1024;
661 /* Initial stack size: 4 or 8 kB. */
662 static const size_t initial_stack_size
= 1024;
664 /* Default soft stack limit is 1M words (4 or 8 megabytes). */
665 static size_t default_max_stack_size
= 1024 * 1024;
668 initialize_default_stack_size (void)
670 int size
= scm_getenv_int ("GUILE_STACK_SIZE", (int) default_max_stack_size
);
671 if (size
>= initial_stack_size
&& (size_t) size
< ((size_t) -1) / sizeof(SCM
))
672 default_max_stack_size
= size
;
675 static void vm_expand_stack (struct scm_vm
*vp
) SCM_NOINLINE
;
676 #define VM_NAME vm_regular_engine
677 #define VM_USE_HOOKS 0
678 #define FUNC_NAME "vm-regular-engine"
679 #include "vm-engine.c"
684 #define VM_NAME vm_debug_engine
685 #define VM_USE_HOOKS 1
686 #define FUNC_NAME "vm-debug-engine"
687 #include "vm-engine.c"
692 typedef SCM (*scm_t_vm_engine
) (scm_i_thread
*current_thread
, struct scm_vm
*vp
,
693 scm_i_jmp_buf
*registers
, int resume
);
695 static const scm_t_vm_engine vm_engines
[SCM_VM_NUM_ENGINES
] =
696 { vm_regular_engine
, vm_debug_engine
};
699 allocate_stack (size_t size
)
700 #define FUNC_NAME "make_vm"
704 if (size
>= ((size_t) -1) / sizeof (SCM
))
707 size
*= sizeof (SCM
);
710 ret
= mmap (NULL
, size
, PROT_READ
| PROT_WRITE
,
711 MAP_PRIVATE
| MAP_ANONYMOUS
, -1, 0);
712 if (ret
== MAP_FAILED
)
725 free_stack (SCM
*stack
, size_t size
)
727 size
*= sizeof (SCM
);
730 munmap (stack
, size
);
737 expand_stack (SCM
*old_stack
, size_t old_size
, size_t new_size
)
738 #define FUNC_NAME "expand_stack"
740 #if defined MREMAP_MAYMOVE
743 if (new_size
>= ((size_t) -1) / sizeof (SCM
))
746 old_size
*= sizeof (SCM
);
747 new_size
*= sizeof (SCM
);
749 new_stack
= mremap (old_stack
, old_size
, new_size
, MREMAP_MAYMOVE
);
750 if (new_stack
== MAP_FAILED
)
753 return (SCM
*) new_stack
;
757 new_stack
= allocate_stack (new_size
);
758 memcpy (new_stack
, old_stack
, old_size
* sizeof (SCM
));
759 free_stack (old_stack
, old_size
);
766 static struct scm_vm
*
768 #define FUNC_NAME "make_vm"
773 vp
= scm_gc_malloc (sizeof (struct scm_vm
), "vm");
775 vp
->stack_size
= initial_stack_size
;
776 vp
->stack_base
= allocate_stack (vp
->stack_size
);
777 vp
->stack_limit
= vp
->stack_base
+ vp
->stack_size
;
778 vp
->max_stack_size
= default_max_stack_size
;
780 vp
->sp
= vp
->stack_base
- 1;
782 vp
->engine
= vm_default_engine
;
784 for (i
= 0; i
< SCM_VM_NUM_HOOKS
; i
++)
785 vp
->hooks
[i
] = SCM_BOOL_F
;
791 /* Mark the VM stack region between its base and its current top. */
793 scm_i_vm_mark_stack (struct scm_vm
*vp
, struct GC_ms_entry
*mark_stack_ptr
,
794 struct GC_ms_entry
*mark_stack_limit
)
797 /* The first frame will be marked conservatively (without a dead
798 slot map). This is because GC can happen at any point within the
799 hottest activation, due to multiple threads or per-instruction
800 hooks, and providing dead slot maps for all points in a program
801 would take a prohibitive amount of space. */
802 const scm_t_uint8
*dead_slots
= NULL
;
804 for (fp
= vp
->fp
, sp
= vp
->sp
; fp
; fp
= SCM_FRAME_DYNAMIC_LINK (fp
))
806 for (; sp
>= &SCM_FRAME_LOCAL (fp
, 0); sp
--)
813 size_t slot
= sp
- &SCM_FRAME_LOCAL (fp
, 0);
814 if (dead_slots
[slot
/ 8U] & (1U << (slot
% 8U)))
816 /* This value may become dead as a result of GC,
817 so we can't just leave it on the stack. */
823 mark_stack_ptr
= GC_MARK_AND_PUSH ((GC_word
*) elt
,
829 sp
= SCM_FRAME_PREVIOUS_SP (fp
);
830 /* Inner frames may have a dead slots map for precise marking.
831 Note that there may be other reasons to not have a dead slots
832 map, e.g. if all of the frame's slots below the callee frame
835 scm_find_dead_slot_map_unlocked (SCM_FRAME_RETURN_ADDRESS (fp
));
838 return mark_stack_ptr
;
841 /* Free the VM stack, as this thread is exiting. */
843 scm_i_vm_free_stack (struct scm_vm
*vp
)
845 free_stack (vp
->stack_base
, vp
->stack_size
);
846 vp
->stack_base
= vp
->stack_limit
= NULL
;
851 vm_expand_stack (struct scm_vm
*vp
)
853 scm_t_ptrdiff stack_size
= vp
->sp
+ 1 - vp
->stack_base
;
855 if (stack_size
> hard_max_stack_size
)
857 /* We have expanded the soft limit to the point that we reached a
858 hard limit. There is nothing sensible to do. */
859 fprintf (stderr
, "Hard stack size limit (%zu words) reached; aborting.\n",
860 hard_max_stack_size
);
864 if (stack_size
> vp
->stack_size
)
870 new_size
= vp
->stack_size
;
871 while (new_size
< stack_size
)
873 old_stack
= vp
->stack_base
;
874 vp
->stack_base
= expand_stack (old_stack
, vp
->stack_size
, new_size
);
875 vp
->stack_size
= new_size
;
876 vp
->stack_limit
= vp
->stack_base
+ new_size
;
877 reloc
= vp
->stack_base
- old_stack
;
887 SCM
*next_fp
= SCM_FRAME_DYNAMIC_LINK (fp
);
891 SCM_FRAME_SET_DYNAMIC_LINK (fp
, next_fp
);
898 if (stack_size
>= vp
->max_stack_size
)
900 /* Expand the soft limit by 256K entries to give us space to
902 vp
->max_stack_size
+= 256 * 1024;
904 /* If it's still not big enough... it's quite improbable, but go
905 ahead and set to the full available stack size. */
906 if (vp
->max_stack_size
< stack_size
)
907 vp
->max_stack_size
= vp
->stack_size
;
909 /* But don't exceed the hard maximum. */
910 if (vp
->max_stack_size
> hard_max_stack_size
)
911 vp
->max_stack_size
= hard_max_stack_size
;
913 /* Finally, reset the limit, to catch further overflows. */
914 vp
->stack_limit
= vp
->stack_base
+ vp
->max_stack_size
;
916 vm_error ("VM: Stack overflow", SCM_UNDEFINED
);
919 /* Otherwise continue, with the new enlarged stack. */
922 static struct scm_vm
*
923 thread_vm (scm_i_thread
*t
)
925 if (SCM_UNLIKELY (!t
->vp
))
934 return thread_vm (SCM_I_CURRENT_THREAD
);
938 scm_call_n (SCM proc
, SCM
*argv
, size_t nargs
)
940 scm_i_thread
*thread
;
943 ptrdiff_t base_frame_size
;
944 /* Cached variables. */
945 scm_i_jmp_buf registers
; /* used for prompts */
948 thread
= SCM_I_CURRENT_THREAD
;
949 vp
= thread_vm (thread
);
953 /* Check that we have enough space: 3 words for the boot
954 continuation, 3 + nargs for the procedure application, and 3 for
955 setting up a new frame. */
956 base_frame_size
= 3 + 3 + nargs
+ 3;
957 vp
->sp
+= base_frame_size
;
958 if (vp
->sp
>= vp
->stack_limit
)
959 vm_expand_stack (vp
);
960 base
= vp
->sp
+ 1 - base_frame_size
;
962 /* Since it's possible to receive the arguments on the stack itself,
963 shuffle up the arguments first. */
964 for (i
= nargs
; i
> 0; i
--)
965 base
[6 + i
- 1] = argv
[i
- 1];
967 /* Push the boot continuation, which calls PROC and returns its
969 base
[0] = SCM_PACK (vp
->fp
); /* dynamic link */
970 base
[1] = SCM_PACK (vp
->ip
); /* ra */
971 base
[2] = vm_boot_continuation
;
973 vp
->ip
= (scm_t_uint32
*) vm_boot_continuation_code
;
975 /* The pending call to PROC. */
976 base
[3] = SCM_PACK (vp
->fp
); /* dynamic link */
977 base
[4] = SCM_PACK (vp
->ip
); /* ra */
980 vp
->sp
= &SCM_FRAME_LOCAL (vp
->fp
, nargs
);
983 int resume
= SCM_I_SETJMP (registers
);
985 if (SCM_UNLIKELY (resume
))
986 /* Non-local return. */
987 vm_dispatch_abort_hook (vp
);
989 return vm_engines
[vp
->engine
](thread
, vp
, ®isters
, resume
);
993 /* Scheme interface */
995 #define VM_DEFINE_HOOK(n) \
998 vp = scm_the_vm (); \
999 if (scm_is_false (vp->hooks[n])) \
1000 vp->hooks[n] = scm_make_hook (SCM_I_MAKINUM (1)); \
1001 return vp->hooks[n]; \
1004 SCM_DEFINE (scm_vm_apply_hook
, "vm-apply-hook", 0, 0, 0,
1007 #define FUNC_NAME s_scm_vm_apply_hook
1009 VM_DEFINE_HOOK (SCM_VM_APPLY_HOOK
);
1013 SCM_DEFINE (scm_vm_push_continuation_hook
, "vm-push-continuation-hook", 0, 0, 0,
1016 #define FUNC_NAME s_scm_vm_push_continuation_hook
1018 VM_DEFINE_HOOK (SCM_VM_PUSH_CONTINUATION_HOOK
);
1022 SCM_DEFINE (scm_vm_pop_continuation_hook
, "vm-pop-continuation-hook", 0, 0, 0,
1025 #define FUNC_NAME s_scm_vm_pop_continuation_hook
1027 VM_DEFINE_HOOK (SCM_VM_POP_CONTINUATION_HOOK
);
1031 SCM_DEFINE (scm_vm_next_hook
, "vm-next-hook", 0, 0, 0,
1034 #define FUNC_NAME s_scm_vm_next_hook
1036 VM_DEFINE_HOOK (SCM_VM_NEXT_HOOK
);
1040 SCM_DEFINE (scm_vm_abort_continuation_hook
, "vm-abort-continuation-hook", 0, 0, 0,
1043 #define FUNC_NAME s_scm_vm_abort_continuation_hook
1045 VM_DEFINE_HOOK (SCM_VM_ABORT_CONTINUATION_HOOK
);
1049 SCM_DEFINE (scm_vm_trace_level
, "vm-trace-level", 0, 0, 0,
1052 #define FUNC_NAME s_scm_vm_trace_level
1054 return scm_from_int (scm_the_vm ()->trace_level
);
1058 SCM_DEFINE (scm_set_vm_trace_level_x
, "set-vm-trace-level!", 1, 0, 0,
1061 #define FUNC_NAME s_scm_set_vm_trace_level_x
1063 scm_the_vm ()->trace_level
= scm_to_int (level
);
1064 return SCM_UNSPECIFIED
;
1074 symbol_to_vm_engine (SCM engine
, const char *FUNC_NAME
)
1076 if (scm_is_eq (engine
, sym_regular
))
1077 return SCM_VM_REGULAR_ENGINE
;
1078 else if (scm_is_eq (engine
, sym_debug
))
1079 return SCM_VM_DEBUG_ENGINE
;
1081 SCM_MISC_ERROR ("Unknown VM engine: ~a", scm_list_1 (engine
));
1085 vm_engine_to_symbol (int engine
, const char *FUNC_NAME
)
1089 case SCM_VM_REGULAR_ENGINE
:
1091 case SCM_VM_DEBUG_ENGINE
:
1095 SCM_MISC_ERROR ("Unknown VM engine: ~a",
1096 scm_list_1 (scm_from_int (engine
)));
1100 SCM_DEFINE (scm_vm_engine
, "vm-engine", 0, 0, 0,
1103 #define FUNC_NAME s_scm_vm_engine
1105 return vm_engine_to_symbol (scm_the_vm ()->engine
, FUNC_NAME
);
1110 scm_c_set_vm_engine_x (int engine
)
1111 #define FUNC_NAME "set-vm-engine!"
1113 if (engine
< 0 || engine
>= SCM_VM_NUM_ENGINES
)
1114 SCM_MISC_ERROR ("Unknown VM engine: ~a",
1115 scm_list_1 (scm_from_int (engine
)));
1117 scm_the_vm ()->engine
= engine
;
1121 SCM_DEFINE (scm_set_vm_engine_x
, "set-vm-engine!", 1, 0, 0,
1124 #define FUNC_NAME s_scm_set_vm_engine_x
1126 scm_c_set_vm_engine_x (symbol_to_vm_engine (engine
, FUNC_NAME
));
1127 return SCM_UNSPECIFIED
;
1132 scm_c_set_default_vm_engine_x (int engine
)
1133 #define FUNC_NAME "set-default-vm-engine!"
1135 if (engine
< 0 || engine
>= SCM_VM_NUM_ENGINES
)
1136 SCM_MISC_ERROR ("Unknown VM engine: ~a",
1137 scm_list_1 (scm_from_int (engine
)));
1139 vm_default_engine
= engine
;
1143 SCM_DEFINE (scm_set_default_vm_engine_x
, "set-default-vm-engine!", 1, 0, 0,
1146 #define FUNC_NAME s_scm_set_default_vm_engine_x
1148 scm_c_set_default_vm_engine_x (symbol_to_vm_engine (engine
, FUNC_NAME
));
1149 return SCM_UNSPECIFIED
;
1153 /* FIXME: This function makes no sense, but we keep it to make sure we
1154 have a way of switching to the debug or regular VM. */
1155 SCM_DEFINE (scm_call_with_vm
, "call-with-vm", 1, 0, 1,
1156 (SCM proc
, SCM args
),
1157 "Apply @var{proc} to @var{args} in a dynamic extent in which\n"
1158 "@var{vm} is the current VM.")
1159 #define FUNC_NAME s_scm_call_with_vm
1161 return scm_apply_0 (proc
, args
);
1171 scm_load_compiled_with_vm (SCM file
)
1173 return scm_call_0 (scm_load_thunk_from_file (file
));
1178 scm_init_vm_builtin_properties (void)
1180 /* FIXME: Seems hacky to do this here, but oh well :/ */
1181 scm_sym_apply
= scm_from_utf8_symbol ("apply");
1182 scm_sym_values
= scm_from_utf8_symbol ("values");
1183 scm_sym_abort_to_prompt
= scm_from_utf8_symbol ("abort-to-prompt");
1184 scm_sym_call_with_values
= scm_from_utf8_symbol ("call-with-values");
1185 scm_sym_call_with_current_continuation
=
1186 scm_from_utf8_symbol ("call-with-current-continuation");
1188 #define INIT_BUILTIN(builtin, BUILTIN, req, opt, rest) \
1189 scm_set_procedure_property_x (vm_builtin_##builtin, scm_sym_name, \
1190 scm_sym_##builtin); \
1191 scm_set_procedure_minimum_arity_x (vm_builtin_##builtin, \
1192 SCM_I_MAKINUM (req), \
1193 SCM_I_MAKINUM (opt), \
1194 scm_from_bool (rest));
1195 FOR_EACH_VM_BUILTIN (INIT_BUILTIN
);
1200 scm_bootstrap_vm (void)
1202 scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION
,
1204 (scm_t_extension_init_func
)scm_init_vm
, NULL
);
1205 scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION
,
1206 "scm_init_vm_builtins",
1207 (scm_t_extension_init_func
)scm_init_vm_builtins
,
1210 initialize_default_stack_size ();
1212 sym_vm_run
= scm_from_latin1_symbol ("vm-run");
1213 sym_vm_error
= scm_from_latin1_symbol ("vm-error");
1214 sym_keyword_argument_error
= scm_from_latin1_symbol ("keyword-argument-error");
1215 sym_regular
= scm_from_latin1_symbol ("regular");
1216 sym_debug
= scm_from_latin1_symbol ("debug");
1218 vm_boot_continuation
= scm_i_make_program (vm_boot_continuation_code
);
1219 SCM_SET_CELL_WORD_0 (vm_boot_continuation
,
1220 (SCM_CELL_WORD_0 (vm_boot_continuation
)
1221 | SCM_F_PROGRAM_IS_BOOT
));
1223 #define DEFINE_BUILTIN(builtin, BUILTIN, req, opt, rest) \
1224 vm_builtin_##builtin = scm_i_make_program (vm_builtin_##builtin##_code);
1225 FOR_EACH_VM_BUILTIN (DEFINE_BUILTIN
);
1226 #undef DEFINE_BUILTIN
1232 #ifndef SCM_MAGIC_SNARFER
1233 #include "libguile/vm.x"