1 /* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013 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
)
798 for (fp
= vp
->fp
, sp
= vp
->sp
; fp
; fp
= SCM_FRAME_DYNAMIC_LINK (fp
))
800 for (; sp
>= &SCM_FRAME_LOCAL (fp
, 0); sp
--)
804 mark_stack_ptr
= GC_MARK_AND_PUSH ((GC_word
*) elt
,
805 mark_stack_ptr
, mark_stack_limit
,
808 sp
= SCM_FRAME_PREVIOUS_SP (fp
);
811 return mark_stack_ptr
;
814 /* Free the VM stack, as this thread is exiting. */
816 scm_i_vm_free_stack (struct scm_vm
*vp
)
818 free_stack (vp
->stack_base
, vp
->stack_size
);
819 vp
->stack_base
= vp
->stack_limit
= NULL
;
824 vm_expand_stack (struct scm_vm
*vp
)
826 scm_t_ptrdiff stack_size
= vp
->sp
+ 1 - vp
->stack_base
;
828 if (stack_size
> hard_max_stack_size
)
830 /* We have expanded the soft limit to the point that we reached a
831 hard limit. There is nothing sensible to do. */
832 fprintf (stderr
, "Hard stack size limit (%zu words) reached; aborting.\n",
833 hard_max_stack_size
);
837 if (stack_size
> vp
->stack_size
)
843 new_size
= vp
->stack_size
;
844 while (new_size
< stack_size
)
846 old_stack
= vp
->stack_base
;
847 vp
->stack_base
= expand_stack (old_stack
, vp
->stack_size
, new_size
);
848 vp
->stack_size
= new_size
;
849 vp
->stack_limit
= vp
->stack_base
+ new_size
;
850 reloc
= vp
->stack_base
- old_stack
;
860 SCM
*next_fp
= SCM_FRAME_DYNAMIC_LINK (fp
);
864 SCM_FRAME_SET_DYNAMIC_LINK (fp
, next_fp
);
871 if (stack_size
>= vp
->max_stack_size
)
873 /* Expand the soft limit by 256K entries to give us space to
875 vp
->max_stack_size
+= 256 * 1024;
877 /* If it's still not big enough... it's quite improbable, but go
878 ahead and set to the full available stack size. */
879 if (vp
->max_stack_size
< stack_size
)
880 vp
->max_stack_size
= vp
->stack_size
;
882 /* But don't exceed the hard maximum. */
883 if (vp
->max_stack_size
> hard_max_stack_size
)
884 vp
->max_stack_size
= hard_max_stack_size
;
886 /* Finally, reset the limit, to catch further overflows. */
887 vp
->stack_limit
= vp
->stack_base
+ vp
->max_stack_size
;
889 vm_error ("VM: Stack overflow", SCM_UNDEFINED
);
892 /* Otherwise continue, with the new enlarged stack. */
895 static struct scm_vm
*
896 thread_vm (scm_i_thread
*t
)
898 if (SCM_UNLIKELY (!t
->vp
))
907 return thread_vm (SCM_I_CURRENT_THREAD
);
911 scm_call_n (SCM proc
, SCM
*argv
, size_t nargs
)
913 scm_i_thread
*thread
;
916 ptrdiff_t base_frame_size
;
917 /* Cached variables. */
918 scm_i_jmp_buf registers
; /* used for prompts */
921 thread
= SCM_I_CURRENT_THREAD
;
922 vp
= thread_vm (thread
);
926 /* Check that we have enough space: 3 words for the boot
927 continuation, 3 + nargs for the procedure application, and 3 for
928 setting up a new frame. */
929 base_frame_size
= 3 + 3 + nargs
+ 3;
930 vp
->sp
+= base_frame_size
;
931 if (vp
->sp
>= vp
->stack_limit
)
932 vm_expand_stack (vp
);
933 base
= vp
->sp
+ 1 - base_frame_size
;
935 /* Since it's possible to receive the arguments on the stack itself,
936 shuffle up the arguments first. */
937 for (i
= nargs
; i
> 0; i
--)
938 base
[6 + i
- 1] = argv
[i
- 1];
940 /* Push the boot continuation, which calls PROC and returns its
942 base
[0] = SCM_PACK (vp
->fp
); /* dynamic link */
943 base
[1] = SCM_PACK (vp
->ip
); /* ra */
944 base
[2] = vm_boot_continuation
;
946 vp
->ip
= (scm_t_uint32
*) vm_boot_continuation_code
;
948 /* The pending call to PROC. */
949 base
[3] = SCM_PACK (vp
->fp
); /* dynamic link */
950 base
[4] = SCM_PACK (vp
->ip
); /* ra */
953 vp
->sp
= &SCM_FRAME_LOCAL (vp
->fp
, nargs
);
956 int resume
= SCM_I_SETJMP (registers
);
958 if (SCM_UNLIKELY (resume
))
959 /* Non-local return. */
960 vm_dispatch_abort_hook (vp
);
962 return vm_engines
[vp
->engine
](thread
, vp
, ®isters
, resume
);
966 /* Scheme interface */
968 #define VM_DEFINE_HOOK(n) \
971 vp = scm_the_vm (); \
972 if (scm_is_false (vp->hooks[n])) \
973 vp->hooks[n] = scm_make_hook (SCM_I_MAKINUM (1)); \
974 return vp->hooks[n]; \
977 SCM_DEFINE (scm_vm_apply_hook
, "vm-apply-hook", 0, 0, 0,
980 #define FUNC_NAME s_scm_vm_apply_hook
982 VM_DEFINE_HOOK (SCM_VM_APPLY_HOOK
);
986 SCM_DEFINE (scm_vm_push_continuation_hook
, "vm-push-continuation-hook", 0, 0, 0,
989 #define FUNC_NAME s_scm_vm_push_continuation_hook
991 VM_DEFINE_HOOK (SCM_VM_PUSH_CONTINUATION_HOOK
);
995 SCM_DEFINE (scm_vm_pop_continuation_hook
, "vm-pop-continuation-hook", 0, 0, 0,
998 #define FUNC_NAME s_scm_vm_pop_continuation_hook
1000 VM_DEFINE_HOOK (SCM_VM_POP_CONTINUATION_HOOK
);
1004 SCM_DEFINE (scm_vm_next_hook
, "vm-next-hook", 0, 0, 0,
1007 #define FUNC_NAME s_scm_vm_next_hook
1009 VM_DEFINE_HOOK (SCM_VM_NEXT_HOOK
);
1013 SCM_DEFINE (scm_vm_abort_continuation_hook
, "vm-abort-continuation-hook", 0, 0, 0,
1016 #define FUNC_NAME s_scm_vm_abort_continuation_hook
1018 VM_DEFINE_HOOK (SCM_VM_ABORT_CONTINUATION_HOOK
);
1022 SCM_DEFINE (scm_vm_trace_level
, "vm-trace-level", 0, 0, 0,
1025 #define FUNC_NAME s_scm_vm_trace_level
1027 return scm_from_int (scm_the_vm ()->trace_level
);
1031 SCM_DEFINE (scm_set_vm_trace_level_x
, "set-vm-trace-level!", 1, 0, 0,
1034 #define FUNC_NAME s_scm_set_vm_trace_level_x
1036 scm_the_vm ()->trace_level
= scm_to_int (level
);
1037 return SCM_UNSPECIFIED
;
1047 symbol_to_vm_engine (SCM engine
, const char *FUNC_NAME
)
1049 if (scm_is_eq (engine
, sym_regular
))
1050 return SCM_VM_REGULAR_ENGINE
;
1051 else if (scm_is_eq (engine
, sym_debug
))
1052 return SCM_VM_DEBUG_ENGINE
;
1054 SCM_MISC_ERROR ("Unknown VM engine: ~a", scm_list_1 (engine
));
1058 vm_engine_to_symbol (int engine
, const char *FUNC_NAME
)
1062 case SCM_VM_REGULAR_ENGINE
:
1064 case SCM_VM_DEBUG_ENGINE
:
1068 SCM_MISC_ERROR ("Unknown VM engine: ~a",
1069 scm_list_1 (scm_from_int (engine
)));
1073 SCM_DEFINE (scm_vm_engine
, "vm-engine", 0, 0, 0,
1076 #define FUNC_NAME s_scm_vm_engine
1078 return vm_engine_to_symbol (scm_the_vm ()->engine
, FUNC_NAME
);
1083 scm_c_set_vm_engine_x (int engine
)
1084 #define FUNC_NAME "set-vm-engine!"
1086 if (engine
< 0 || engine
>= SCM_VM_NUM_ENGINES
)
1087 SCM_MISC_ERROR ("Unknown VM engine: ~a",
1088 scm_list_1 (scm_from_int (engine
)));
1090 scm_the_vm ()->engine
= engine
;
1094 SCM_DEFINE (scm_set_vm_engine_x
, "set-vm-engine!", 1, 0, 0,
1097 #define FUNC_NAME s_scm_set_vm_engine_x
1099 scm_c_set_vm_engine_x (symbol_to_vm_engine (engine
, FUNC_NAME
));
1100 return SCM_UNSPECIFIED
;
1105 scm_c_set_default_vm_engine_x (int engine
)
1106 #define FUNC_NAME "set-default-vm-engine!"
1108 if (engine
< 0 || engine
>= SCM_VM_NUM_ENGINES
)
1109 SCM_MISC_ERROR ("Unknown VM engine: ~a",
1110 scm_list_1 (scm_from_int (engine
)));
1112 vm_default_engine
= engine
;
1116 SCM_DEFINE (scm_set_default_vm_engine_x
, "set-default-vm-engine!", 1, 0, 0,
1119 #define FUNC_NAME s_scm_set_default_vm_engine_x
1121 scm_c_set_default_vm_engine_x (symbol_to_vm_engine (engine
, FUNC_NAME
));
1122 return SCM_UNSPECIFIED
;
1126 /* FIXME: This function makes no sense, but we keep it to make sure we
1127 have a way of switching to the debug or regular VM. */
1128 SCM_DEFINE (scm_call_with_vm
, "call-with-vm", 1, 0, 1,
1129 (SCM proc
, SCM args
),
1130 "Apply @var{proc} to @var{args} in a dynamic extent in which\n"
1131 "@var{vm} is the current VM.")
1132 #define FUNC_NAME s_scm_call_with_vm
1134 return scm_apply_0 (proc
, args
);
1144 scm_load_compiled_with_vm (SCM file
)
1146 return scm_call_0 (scm_load_thunk_from_file (file
));
1151 scm_init_vm_builtin_properties (void)
1153 /* FIXME: Seems hacky to do this here, but oh well :/ */
1154 scm_sym_apply
= scm_from_utf8_symbol ("apply");
1155 scm_sym_values
= scm_from_utf8_symbol ("values");
1156 scm_sym_abort_to_prompt
= scm_from_utf8_symbol ("abort-to-prompt");
1157 scm_sym_call_with_values
= scm_from_utf8_symbol ("call-with-values");
1158 scm_sym_call_with_current_continuation
=
1159 scm_from_utf8_symbol ("call-with-current-continuation");
1161 #define INIT_BUILTIN(builtin, BUILTIN, req, opt, rest) \
1162 scm_set_procedure_property_x (vm_builtin_##builtin, scm_sym_name, \
1163 scm_sym_##builtin); \
1164 scm_set_procedure_minimum_arity_x (vm_builtin_##builtin, \
1165 SCM_I_MAKINUM (req), \
1166 SCM_I_MAKINUM (opt), \
1167 scm_from_bool (rest));
1168 FOR_EACH_VM_BUILTIN (INIT_BUILTIN
);
1173 scm_bootstrap_vm (void)
1175 scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION
,
1177 (scm_t_extension_init_func
)scm_init_vm
, NULL
);
1178 scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION
,
1179 "scm_init_vm_builtins",
1180 (scm_t_extension_init_func
)scm_init_vm_builtins
,
1183 initialize_default_stack_size ();
1185 sym_vm_run
= scm_from_latin1_symbol ("vm-run");
1186 sym_vm_error
= scm_from_latin1_symbol ("vm-error");
1187 sym_keyword_argument_error
= scm_from_latin1_symbol ("keyword-argument-error");
1188 sym_regular
= scm_from_latin1_symbol ("regular");
1189 sym_debug
= scm_from_latin1_symbol ("debug");
1191 vm_boot_continuation
= scm_i_make_program (vm_boot_continuation_code
);
1192 SCM_SET_CELL_WORD_0 (vm_boot_continuation
,
1193 (SCM_CELL_WORD_0 (vm_boot_continuation
)
1194 | SCM_F_PROGRAM_IS_BOOT
));
1196 #define DEFINE_BUILTIN(builtin, BUILTIN, req, opt, rest) \
1197 vm_builtin_##builtin = scm_i_make_program (vm_builtin_##builtin##_code);
1198 FOR_EACH_VM_BUILTIN (DEFINE_BUILTIN
);
1199 #undef DEFINE_BUILTIN
1205 #ifndef SCM_MAGIC_SNARFER
1206 #include "libguile/vm.x"