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"
46 #include "vm-builtins.h"
48 #include "private-gc.h" /* scm_getenv_int */
50 static int vm_default_engine
= SCM_VM_REGULAR_ENGINE
;
52 /* Unfortunately we can't snarf these: snarfed things are only loaded up from
53 (system vm vm), which might not be loaded before an error happens. */
54 static SCM sym_vm_run
;
55 static SCM sym_vm_error
;
56 static SCM sym_keyword_argument_error
;
57 static SCM sym_regular
;
60 /* The VM has a number of internal assertions that shouldn't normally be
61 necessary, but might be if you think you found a bug in the VM. */
62 #define VM_ENABLE_ASSERTIONS
64 /* #define VM_ENABLE_PARANOID_ASSERTIONS */
73 scm_i_vm_cont_print (SCM x
, SCM port
, scm_print_state
*pstate
)
75 scm_puts_unlocked ("#<vm-continuation ", port
);
76 scm_uintprint (SCM_UNPACK (x
), 16, port
);
77 scm_puts_unlocked (">", port
);
80 /* In theory, a number of vm instances can be active in the call trace, and we
81 only want to reify the continuations of those in the current continuation
82 root. I don't see a nice way to do this -- ideally it would involve dynwinds,
83 and previous values of the *the-vm* fluid within the current continuation
84 root. But we don't have access to continuation roots in the dynwind stack.
85 So, just punt for now, we just capture the continuation for the current VM.
87 While I'm on the topic, ideally we could avoid copying the C stack if the
88 continuation root is inside VM code, and call/cc was invoked within that same
89 call to vm_run; but that's currently not implemented.
92 scm_i_vm_capture_stack (SCM
*stack_base
, SCM
*fp
, SCM
*sp
, scm_t_uint32
*ra
,
93 scm_t_dynstack
*dynstack
, scm_t_uint32 flags
)
95 struct scm_vm_cont
*p
;
97 p
= scm_gc_malloc (sizeof (*p
), "capture_vm_cont");
98 p
->stack_size
= sp
- stack_base
+ 1;
99 p
->stack_base
= scm_gc_malloc (p
->stack_size
* sizeof (SCM
),
104 memcpy (p
->stack_base
, stack_base
, (sp
+ 1 - stack_base
) * sizeof (SCM
));
105 p
->reloc
= p
->stack_base
- stack_base
;
106 p
->dynstack
= dynstack
;
108 return scm_cell (scm_tc7_vm_cont
, (scm_t_bits
)p
);
112 vm_return_to_continuation (struct scm_vm
*vp
, SCM cont
, size_t n
, SCM
*argv
)
114 struct scm_vm_cont
*cp
;
117 argv_copy
= alloca (n
* sizeof(SCM
));
118 memcpy (argv_copy
, argv
, n
* sizeof(SCM
));
120 cp
= SCM_VM_CONT_DATA (cont
);
122 if (vp
->stack_size
< cp
->stack_size
+ n
+ 3)
123 scm_misc_error ("vm-engine", "not enough space to reinstate continuation",
128 memcpy (vp
->stack_base
, cp
->stack_base
, cp
->stack_size
* sizeof (SCM
));
133 /* Push on an empty frame, as the continuation expects. */
134 for (i
= 0; i
< 3; i
++)
137 *vp
->sp
= SCM_BOOL_F
;
140 /* Push the return values. */
141 for (i
= 0; i
< n
; i
++)
144 *vp
->sp
= argv_copy
[i
];
150 static struct scm_vm
* thread_vm (scm_i_thread
*t
);
152 scm_i_capture_current_stack (void)
154 scm_i_thread
*thread
;
157 thread
= SCM_I_CURRENT_THREAD
;
158 vp
= thread_vm (thread
);
160 return scm_i_vm_capture_stack (vp
->stack_base
, vp
->fp
, vp
->sp
, vp
->ip
,
161 scm_dynstack_capture_all (&thread
->dynstack
),
165 static void vm_dispatch_apply_hook (struct scm_vm
*vp
) SCM_NOINLINE
;
166 static void vm_dispatch_push_continuation_hook (struct scm_vm
*vp
) SCM_NOINLINE
;
167 static void vm_dispatch_pop_continuation_hook (struct scm_vm
*vp
, SCM
*old_fp
) SCM_NOINLINE
;
168 static void vm_dispatch_next_hook (struct scm_vm
*vp
) SCM_NOINLINE
;
169 static void vm_dispatch_abort_hook (struct scm_vm
*vp
) SCM_NOINLINE
;
170 static void vm_dispatch_restore_continuation_hook (struct scm_vm
*vp
) SCM_NOINLINE
;
173 vm_dispatch_hook (struct scm_vm
*vp
, int hook_num
, SCM
*argv
, int n
)
176 struct scm_frame c_frame
;
178 int saved_trace_level
;
180 hook
= vp
->hooks
[hook_num
];
182 if (SCM_LIKELY (scm_is_false (hook
))
183 || scm_is_null (SCM_HOOK_PROCEDURES (hook
)))
186 saved_trace_level
= vp
->trace_level
;
189 /* Allocate a frame object on the stack. This is more efficient than calling
190 `scm_c_make_frame ()' to allocate on the heap, but it forces hooks to not
191 capture frame objects.
193 At the same time, procedures such as `frame-procedure' make sense only
194 while the stack frame represented by the frame object is visible, so it
195 seems reasonable to limit the lifetime of frame objects. */
197 c_frame
.stack_holder
= vp
;
198 c_frame
.fp_offset
= vp
->fp
- vp
->stack_base
;
199 c_frame
.sp_offset
= vp
->sp
- vp
->stack_base
;
202 /* Arrange for FRAME to be 8-byte aligned, like any other cell. */
203 frame
= alloca (sizeof (*frame
) + 8);
204 frame
= (scm_t_cell
*) ROUND_UP ((scm_t_uintptr
) frame
, 8UL);
206 frame
->word_0
= SCM_PACK (scm_tc7_frame
| (SCM_VM_FRAME_KIND_VM
<< 8));
207 frame
->word_1
= SCM_PACK_POINTER (&c_frame
);
213 args
[0] = SCM_PACK_POINTER (frame
);
214 scm_c_run_hookn (hook
, args
, 1);
220 args
[0] = SCM_PACK_POINTER (frame
);
222 scm_c_run_hookn (hook
, args
, 2);
229 args
= scm_cons (argv
[n
], args
);
230 scm_c_run_hook (hook
, scm_cons (SCM_PACK_POINTER (frame
), args
));
233 vp
->trace_level
= saved_trace_level
;
237 vm_dispatch_apply_hook (struct scm_vm
*vp
)
239 return vm_dispatch_hook (vp
, SCM_VM_APPLY_HOOK
, NULL
, 0);
241 static void vm_dispatch_push_continuation_hook (struct scm_vm
*vp
)
243 return vm_dispatch_hook (vp
, SCM_VM_PUSH_CONTINUATION_HOOK
, NULL
, 0);
245 static void vm_dispatch_pop_continuation_hook (struct scm_vm
*vp
, SCM
*old_fp
)
247 return vm_dispatch_hook (vp
, SCM_VM_POP_CONTINUATION_HOOK
,
248 &SCM_FRAME_LOCAL (old_fp
, 1),
249 SCM_FRAME_NUM_LOCALS (old_fp
, vp
->sp
) - 1);
251 static void vm_dispatch_next_hook (struct scm_vm
*vp
)
253 return vm_dispatch_hook (vp
, SCM_VM_NEXT_HOOK
, NULL
, 0);
255 static void vm_dispatch_abort_hook (struct scm_vm
*vp
)
257 return vm_dispatch_hook (vp
, SCM_VM_ABORT_CONTINUATION_HOOK
,
258 &SCM_FRAME_LOCAL (vp
->fp
, 1),
259 SCM_FRAME_NUM_LOCALS (vp
->fp
, vp
->sp
) - 1);
261 static void vm_dispatch_restore_continuation_hook (struct scm_vm
*vp
)
263 return vm_dispatch_hook (vp
, SCM_VM_RESTORE_CONTINUATION_HOOK
, NULL
, 0);
267 vm_abort (struct scm_vm
*vp
, SCM tag
,
268 size_t nstack
, SCM
*stack_args
, SCM tail
, SCM
*sp
,
269 scm_i_jmp_buf
*current_registers
) SCM_NORETURN
;
272 vm_abort (struct scm_vm
*vp
, SCM tag
,
273 size_t nstack
, SCM
*stack_args
, SCM tail
, SCM
*sp
,
274 scm_i_jmp_buf
*current_registers
)
280 tail_len
= scm_ilength (tail
);
282 scm_misc_error ("vm-engine", "tail values to abort should be a list",
285 argv
= alloca ((nstack
+ tail_len
) * sizeof (SCM
));
286 for (i
= 0; i
< nstack
; i
++)
287 argv
[i
] = stack_args
[i
];
288 for (; i
< nstack
+ tail_len
; i
++, tail
= scm_cdr (tail
))
289 argv
[i
] = scm_car (tail
);
291 /* FIXME: NULLSTACK (SCM_VM_DATA (vp)->sp - sp) */
294 scm_c_abort (vp
, tag
, nstack
+ tail_len
, argv
, current_registers
);
298 vm_reinstate_partial_continuation (struct scm_vm
*vp
, SCM cont
,
300 scm_t_dynstack
*dynstack
,
301 scm_i_jmp_buf
*registers
)
303 struct scm_vm_cont
*cp
;
304 SCM
*argv_copy
, *base
;
308 argv_copy
= alloca (n
* sizeof(SCM
));
309 memcpy (argv_copy
, argv
, n
* sizeof(SCM
));
311 cp
= SCM_VM_CONT_DATA (cont
);
312 base
= SCM_FRAME_LOCALS_ADDRESS (vp
->fp
);
313 reloc
= cp
->reloc
+ (base
- cp
->stack_base
);
315 #define RELOC(scm_p) \
316 (((SCM *) (scm_p)) + reloc)
318 if ((base
- vp
->stack_base
) + cp
->stack_size
+ n
+ 1 > vp
->stack_size
)
319 scm_misc_error ("vm-engine",
320 "not enough space to instate partial continuation",
323 memcpy (base
, cp
->stack_base
, cp
->stack_size
* sizeof (SCM
));
325 /* now relocate frame pointers */
328 for (fp
= RELOC (cp
->fp
);
329 SCM_FRAME_LOWER_ADDRESS (fp
) > base
;
330 fp
= SCM_FRAME_DYNAMIC_LINK (fp
))
331 SCM_FRAME_SET_DYNAMIC_LINK (fp
, RELOC (SCM_FRAME_DYNAMIC_LINK (fp
)));
334 vp
->sp
= base
- 1 + cp
->stack_size
;
335 vp
->fp
= RELOC (cp
->fp
);
338 /* Push the arguments. */
339 for (i
= 0; i
< n
; i
++)
342 *vp
->sp
= argv_copy
[i
];
345 /* The prompt captured a slice of the dynamic stack. Here we wind
346 those entries onto the current thread's stack. We also have to
347 relocate any prompts that we see along the way. */
351 for (walk
= SCM_DYNSTACK_FIRST (cp
->dynstack
);
352 SCM_DYNSTACK_TAG (walk
);
353 walk
= SCM_DYNSTACK_NEXT (walk
))
355 scm_t_bits tag
= SCM_DYNSTACK_TAG (walk
);
357 if (SCM_DYNSTACK_TAG_TYPE (tag
) == SCM_DYNSTACK_TYPE_PROMPT
)
358 scm_dynstack_wind_prompt (dynstack
, walk
, reloc
, registers
);
360 scm_dynstack_wind_1 (dynstack
, walk
);
371 static void vm_error (const char *msg
, SCM arg
) SCM_NORETURN
;
372 static void vm_error_bad_instruction (scm_t_uint32 inst
) SCM_NORETURN SCM_NOINLINE
;
373 static void vm_error_unbound (SCM proc
, SCM sym
) SCM_NORETURN SCM_NOINLINE
;
374 static void vm_error_unbound_fluid (SCM proc
, SCM fluid
) SCM_NORETURN SCM_NOINLINE
;
375 static void vm_error_not_a_variable (const char *func_name
, SCM x
) SCM_NORETURN SCM_NOINLINE
;
376 static void vm_error_apply_to_non_list (SCM x
) SCM_NORETURN SCM_NOINLINE
;
377 static void vm_error_kwargs_length_not_even (SCM proc
) SCM_NORETURN SCM_NOINLINE
;
378 static void vm_error_kwargs_invalid_keyword (SCM proc
, SCM obj
) SCM_NORETURN SCM_NOINLINE
;
379 static void vm_error_kwargs_unrecognized_keyword (SCM proc
, SCM kw
) SCM_NORETURN SCM_NOINLINE
;
380 static void vm_error_too_many_args (int nargs
) SCM_NORETURN SCM_NOINLINE
;
381 static void vm_error_wrong_num_args (SCM proc
) SCM_NORETURN SCM_NOINLINE
;
382 static void vm_error_wrong_type_apply (SCM proc
) SCM_NORETURN SCM_NOINLINE
;
383 static void vm_error_stack_underflow (void) SCM_NORETURN SCM_NOINLINE
;
384 static void vm_error_improper_list (SCM x
) SCM_NORETURN SCM_NOINLINE
;
385 static void vm_error_not_a_pair (const char *subr
, SCM x
) SCM_NORETURN SCM_NOINLINE
;
386 static void vm_error_not_a_bytevector (const char *subr
, SCM x
) SCM_NORETURN SCM_NOINLINE
;
387 static void vm_error_not_a_struct (const char *subr
, SCM x
) SCM_NORETURN SCM_NOINLINE
;
388 static void vm_error_no_values (void) SCM_NORETURN SCM_NOINLINE
;
389 static void vm_error_not_enough_values (void) SCM_NORETURN SCM_NOINLINE
;
390 static void vm_error_wrong_number_of_values (scm_t_uint32 expected
) SCM_NORETURN SCM_NOINLINE
;
391 static void vm_error_continuation_not_rewindable (SCM cont
) SCM_NORETURN SCM_NOINLINE
;
392 static void vm_error_bad_wide_string_length (size_t len
) SCM_NORETURN SCM_NOINLINE
;
395 vm_error (const char *msg
, SCM arg
)
397 scm_throw (sym_vm_error
,
398 scm_list_3 (sym_vm_run
, scm_from_latin1_string (msg
),
399 SCM_UNBNDP (arg
) ? SCM_EOL
: scm_list_1 (arg
)));
400 abort(); /* not reached */
404 vm_error_bad_instruction (scm_t_uint32 inst
)
406 vm_error ("VM: Bad instruction: ~s", scm_from_uint32 (inst
));
410 vm_error_unbound (SCM proc
, SCM sym
)
412 scm_error_scm (scm_misc_error_key
, proc
,
413 scm_from_latin1_string ("Unbound variable: ~s"),
414 scm_list_1 (sym
), SCM_BOOL_F
);
418 vm_error_unbound_fluid (SCM proc
, SCM fluid
)
420 scm_error_scm (scm_misc_error_key
, proc
,
421 scm_from_latin1_string ("Unbound fluid: ~s"),
422 scm_list_1 (fluid
), SCM_BOOL_F
);
426 vm_error_not_a_variable (const char *func_name
, SCM x
)
428 scm_error (scm_arg_type_key
, func_name
, "Not a variable: ~S",
429 scm_list_1 (x
), scm_list_1 (x
));
433 vm_error_apply_to_non_list (SCM x
)
435 scm_error (scm_arg_type_key
, "apply", "Apply to non-list: ~S",
436 scm_list_1 (x
), scm_list_1 (x
));
440 vm_error_kwargs_length_not_even (SCM proc
)
442 scm_error_scm (sym_keyword_argument_error
, proc
,
443 scm_from_latin1_string ("Odd length of keyword argument list"),
444 SCM_EOL
, SCM_BOOL_F
);
448 vm_error_kwargs_invalid_keyword (SCM proc
, SCM obj
)
450 scm_error_scm (sym_keyword_argument_error
, proc
,
451 scm_from_latin1_string ("Invalid keyword"),
452 SCM_EOL
, scm_list_1 (obj
));
456 vm_error_kwargs_unrecognized_keyword (SCM proc
, SCM kw
)
458 scm_error_scm (sym_keyword_argument_error
, proc
,
459 scm_from_latin1_string ("Unrecognized keyword"),
460 SCM_EOL
, scm_list_1 (kw
));
464 vm_error_too_many_args (int nargs
)
466 vm_error ("VM: Too many arguments", scm_from_int (nargs
));
470 vm_error_wrong_num_args (SCM proc
)
472 scm_wrong_num_args (proc
);
476 vm_error_wrong_type_apply (SCM proc
)
478 scm_error (scm_arg_type_key
, NULL
, "Wrong type to apply: ~S",
479 scm_list_1 (proc
), scm_list_1 (proc
));
483 vm_error_stack_underflow (void)
485 vm_error ("VM: Stack underflow", SCM_UNDEFINED
);
489 vm_error_improper_list (SCM x
)
491 vm_error ("Expected a proper list, but got object with tail ~s", x
);
495 vm_error_not_a_pair (const char *subr
, SCM x
)
497 scm_wrong_type_arg_msg (subr
, 1, x
, "pair");
501 vm_error_not_a_bytevector (const char *subr
, SCM x
)
503 scm_wrong_type_arg_msg (subr
, 1, x
, "bytevector");
507 vm_error_not_a_struct (const char *subr
, SCM x
)
509 scm_wrong_type_arg_msg (subr
, 1, x
, "struct");
513 vm_error_no_values (void)
515 vm_error ("Zero values returned to single-valued continuation",
520 vm_error_not_enough_values (void)
522 vm_error ("Too few values returned to continuation", SCM_UNDEFINED
);
526 vm_error_wrong_number_of_values (scm_t_uint32 expected
)
528 vm_error ("Wrong number of values returned to continuation (expected ~a)",
529 scm_from_uint32 (expected
));
533 vm_error_continuation_not_rewindable (SCM cont
)
535 vm_error ("Unrewindable partial continuation", cont
);
539 vm_error_bad_wide_string_length (size_t len
)
541 vm_error ("VM: Bad wide string length: ~S", scm_from_size_t (len
));
547 static SCM vm_boot_continuation
;
548 static SCM vm_builtin_apply
;
549 static SCM vm_builtin_values
;
550 static SCM vm_builtin_abort_to_prompt
;
551 static SCM vm_builtin_call_with_values
;
552 static SCM vm_builtin_call_with_current_continuation
;
554 static const scm_t_uint32 vm_boot_continuation_code
[] = {
555 SCM_PACK_OP_24 (halt
, 0)
558 static const scm_t_uint32 vm_builtin_apply_code
[] = {
559 SCM_PACK_OP_24 (assert_nargs_ge
, 3),
560 SCM_PACK_OP_24 (tail_apply
, 0), /* proc in r1, args from r2 */
563 static const scm_t_uint32 vm_builtin_values_code
[] = {
564 SCM_PACK_OP_24 (return_values
, 0) /* vals from r1 */
567 static const scm_t_uint32 vm_builtin_abort_to_prompt_code
[] = {
568 SCM_PACK_OP_24 (assert_nargs_ge
, 2),
569 SCM_PACK_OP_24 (abort
, 0), /* tag in r1, vals from r2 */
570 /* FIXME: Partial continuation should capture caller regs. */
571 SCM_PACK_OP_24 (return_values
, 0) /* vals from r1 */
574 static const scm_t_uint32 vm_builtin_call_with_values_code
[] = {
575 SCM_PACK_OP_24 (assert_nargs_ee
, 3),
576 SCM_PACK_OP_24 (alloc_frame
, 7),
577 SCM_PACK_OP_12_12 (mov
, 6, 1),
578 SCM_PACK_OP_24 (call
, 6), SCM_PACK_OP_ARG_8_24 (0, 1),
579 SCM_PACK_OP_12_12 (mov
, 0, 2),
580 SCM_PACK_OP_24 (tail_call_shuffle
, 7)
583 static const scm_t_uint32 vm_builtin_call_with_current_continuation_code
[] = {
584 SCM_PACK_OP_24 (assert_nargs_ee
, 2),
585 SCM_PACK_OP_24 (call_cc
, 0)
590 scm_vm_builtin_ref (unsigned idx
)
594 #define INDEX_TO_NAME(builtin, BUILTIN, req, opt, rest) \
595 case SCM_VM_BUILTIN_##BUILTIN: return vm_builtin_##builtin;
596 FOR_EACH_VM_BUILTIN(INDEX_TO_NAME
)
603 static SCM scm_sym_values
;
604 static SCM scm_sym_abort_to_prompt
;
605 static SCM scm_sym_call_with_values
;
606 static SCM scm_sym_call_with_current_continuation
;
609 scm_vm_builtin_name_to_index (SCM name
)
610 #define FUNC_NAME "builtin-name->index"
612 SCM_VALIDATE_SYMBOL (1, name
);
614 #define NAME_TO_INDEX(builtin, BUILTIN, req, opt, rest) \
615 if (scm_is_eq (name, scm_sym_##builtin)) \
616 return scm_from_uint (SCM_VM_BUILTIN_##BUILTIN);
617 FOR_EACH_VM_BUILTIN(NAME_TO_INDEX
)
625 scm_vm_builtin_index_to_name (SCM index
)
626 #define FUNC_NAME "builtin-index->name"
630 SCM_VALIDATE_UINT_COPY (1, index
, idx
);
634 #define INDEX_TO_NAME(builtin, BUILTIN, req, opt, rest) \
635 case SCM_VM_BUILTIN_##BUILTIN: return scm_sym_##builtin;
636 FOR_EACH_VM_BUILTIN(INDEX_TO_NAME
)
638 default: return SCM_BOOL_F
;
644 scm_init_vm_builtins (void)
646 scm_c_define_gsubr ("builtin-name->index", 1, 0, 0,
647 scm_vm_builtin_name_to_index
);
648 scm_c_define_gsubr ("builtin-index->name", 1, 0, 0,
649 scm_vm_builtin_index_to_name
);
653 scm_i_call_with_current_continuation (SCM proc
)
655 return scm_call_1 (vm_builtin_call_with_current_continuation
, proc
);
663 /* Hard stack limit is 512M words: 2 gigabytes on 32-bit machines, 4 on
665 static const size_t hard_max_stack_size
= 512 * 1024 * 1024;
667 /* Initial stack size: 4 or 8 kB. */
668 static const size_t initial_stack_size
= 1024;
670 /* Default soft stack limit is 1M words (4 or 8 megabytes). */
671 static size_t default_max_stack_size
= 1024 * 1024;
674 initialize_default_stack_size (void)
676 int size
= scm_getenv_int ("GUILE_STACK_SIZE", (int) default_max_stack_size
);
677 if (size
>= initial_stack_size
&& (size_t) size
< ((size_t) -1) / sizeof(SCM
))
678 default_max_stack_size
= size
;
681 static void vm_expand_stack (struct scm_vm
*vp
) SCM_NOINLINE
;
682 #define VM_NAME vm_regular_engine
683 #define VM_USE_HOOKS 0
684 #define FUNC_NAME "vm-regular-engine"
685 #include "vm-engine.c"
690 #define VM_NAME vm_debug_engine
691 #define VM_USE_HOOKS 1
692 #define FUNC_NAME "vm-debug-engine"
693 #include "vm-engine.c"
698 typedef SCM (*scm_t_vm_engine
) (scm_i_thread
*current_thread
, struct scm_vm
*vp
,
699 scm_i_jmp_buf
*registers
, int resume
);
701 static const scm_t_vm_engine vm_engines
[SCM_VM_NUM_ENGINES
] =
702 { vm_regular_engine
, vm_debug_engine
};
705 allocate_stack (size_t size
)
706 #define FUNC_NAME "make_vm"
710 if (size
>= ((size_t) -1) / sizeof (SCM
))
713 size
*= sizeof (SCM
);
716 ret
= mmap (NULL
, size
, PROT_READ
| PROT_WRITE
,
717 MAP_PRIVATE
| MAP_ANONYMOUS
, -1, 0);
718 if (ret
== MAP_FAILED
)
731 free_stack (SCM
*stack
, size_t size
)
733 size
*= sizeof (SCM
);
736 munmap (stack
, size
);
743 expand_stack (SCM
*old_stack
, size_t old_size
, size_t new_size
)
744 #define FUNC_NAME "expand_stack"
746 #if defined MREMAP_MAYMOVE
749 if (new_size
>= ((size_t) -1) / sizeof (SCM
))
752 old_size
*= sizeof (SCM
);
753 new_size
*= sizeof (SCM
);
755 new_stack
= mremap (old_stack
, old_size
, new_size
, MREMAP_MAYMOVE
);
756 if (new_stack
== MAP_FAILED
)
759 return (SCM
*) new_stack
;
763 new_stack
= allocate_stack (new_size
);
764 memcpy (new_stack
, old_stack
, old_size
* sizeof (SCM
));
765 free_stack (old_stack
, old_size
);
772 static struct scm_vm
*
774 #define FUNC_NAME "make_vm"
779 vp
= scm_gc_malloc (sizeof (struct scm_vm
), "vm");
781 vp
->stack_size
= initial_stack_size
;
782 vp
->stack_base
= allocate_stack (vp
->stack_size
);
783 vp
->stack_limit
= vp
->stack_base
+ vp
->stack_size
;
784 vp
->max_stack_size
= default_max_stack_size
;
786 vp
->sp
= vp
->stack_base
- 1;
788 vp
->engine
= vm_default_engine
;
790 for (i
= 0; i
< SCM_VM_NUM_HOOKS
; i
++)
791 vp
->hooks
[i
] = SCM_BOOL_F
;
797 /* Mark the VM stack region between its base and its current top. */
799 scm_i_vm_mark_stack (struct scm_vm
*vp
, struct GC_ms_entry
*mark_stack_ptr
,
800 struct GC_ms_entry
*mark_stack_limit
)
804 for (fp
= vp
->fp
, sp
= vp
->sp
; fp
; fp
= SCM_FRAME_DYNAMIC_LINK (fp
))
806 for (; sp
>= &SCM_FRAME_LOCAL (fp
, 0); sp
--)
810 mark_stack_ptr
= GC_MARK_AND_PUSH ((GC_word
*) elt
,
811 mark_stack_ptr
, mark_stack_limit
,
814 sp
= SCM_FRAME_PREVIOUS_SP (fp
);
817 return mark_stack_ptr
;
820 /* Free the VM stack, as this thread is exiting. */
822 scm_i_vm_free_stack (struct scm_vm
*vp
)
824 free_stack (vp
->stack_base
, vp
->stack_size
);
825 vp
->stack_base
= vp
->stack_limit
= NULL
;
830 vm_expand_stack (struct scm_vm
*vp
)
832 scm_t_ptrdiff stack_size
= vp
->sp
+ 1 - vp
->stack_base
;
834 if (stack_size
> hard_max_stack_size
)
836 /* We have expanded the soft limit to the point that we reached a
837 hard limit. There is nothing sensible to do. */
838 fprintf (stderr
, "Hard stack size limit (%zu words) reached; aborting.\n",
839 hard_max_stack_size
);
843 if (stack_size
> vp
->stack_size
)
849 new_size
= vp
->stack_size
;
850 while (new_size
< stack_size
)
852 old_stack
= vp
->stack_base
;
853 vp
->stack_base
= expand_stack (old_stack
, vp
->stack_size
, new_size
);
854 vp
->stack_size
= new_size
;
855 vp
->stack_limit
= vp
->stack_base
+ new_size
;
856 reloc
= vp
->stack_base
- old_stack
;
866 SCM
*next_fp
= SCM_FRAME_DYNAMIC_LINK (fp
);
870 SCM_FRAME_SET_DYNAMIC_LINK (fp
, next_fp
);
877 if (stack_size
>= vp
->max_stack_size
)
879 /* Expand the soft limit by 256K entries to give us space to
881 vp
->max_stack_size
+= 256 * 1024;
883 /* If it's still not big enough... it's quite improbable, but go
884 ahead and set to the full available stack size. */
885 if (vp
->max_stack_size
< stack_size
)
886 vp
->max_stack_size
= vp
->stack_size
;
888 /* But don't exceed the hard maximum. */
889 if (vp
->max_stack_size
> hard_max_stack_size
)
890 vp
->max_stack_size
= hard_max_stack_size
;
892 /* Finally, reset the limit, to catch further overflows. */
893 vp
->stack_limit
= vp
->stack_base
+ vp
->max_stack_size
;
895 vm_error ("VM: Stack overflow", SCM_UNDEFINED
);
898 /* Otherwise continue, with the new enlarged stack. */
901 static struct scm_vm
*
902 thread_vm (scm_i_thread
*t
)
904 if (SCM_UNLIKELY (!t
->vp
))
913 return thread_vm (SCM_I_CURRENT_THREAD
);
917 scm_call_n (SCM proc
, SCM
*argv
, size_t nargs
)
919 scm_i_thread
*thread
;
922 ptrdiff_t base_frame_size
;
923 /* Cached variables. */
924 scm_i_jmp_buf registers
; /* used for prompts */
927 thread
= SCM_I_CURRENT_THREAD
;
928 vp
= thread_vm (thread
);
932 /* Check that we have enough space: 3 words for the boot
933 continuation, 3 + nargs for the procedure application, and 3 for
934 setting up a new frame. */
935 base_frame_size
= 3 + 3 + nargs
+ 3;
936 vp
->sp
+= base_frame_size
;
937 if (vp
->sp
>= vp
->stack_limit
)
938 vm_expand_stack (vp
);
939 base
= vp
->sp
+ 1 - base_frame_size
;
941 /* Since it's possible to receive the arguments on the stack itself,
942 shuffle up the arguments first. */
943 for (i
= nargs
; i
> 0; i
--)
944 base
[6 + i
- 1] = argv
[i
- 1];
946 /* Push the boot continuation, which calls PROC and returns its
948 base
[0] = SCM_PACK (vp
->fp
); /* dynamic link */
949 base
[1] = SCM_PACK (vp
->ip
); /* ra */
950 base
[2] = vm_boot_continuation
;
952 vp
->ip
= (scm_t_uint32
*) vm_boot_continuation_code
;
954 /* The pending call to PROC. */
955 base
[3] = SCM_PACK (vp
->fp
); /* dynamic link */
956 base
[4] = SCM_PACK (vp
->ip
); /* ra */
959 vp
->sp
= &SCM_FRAME_LOCAL (vp
->fp
, nargs
);
962 int resume
= SCM_I_SETJMP (registers
);
964 if (SCM_UNLIKELY (resume
))
965 /* Non-local return. */
966 vm_dispatch_abort_hook (vp
);
968 return vm_engines
[vp
->engine
](thread
, vp
, ®isters
, resume
);
972 /* Scheme interface */
974 #define VM_DEFINE_HOOK(n) \
977 vp = scm_the_vm (); \
978 if (scm_is_false (vp->hooks[n])) \
979 vp->hooks[n] = scm_make_hook (SCM_I_MAKINUM (1)); \
980 return vp->hooks[n]; \
983 SCM_DEFINE (scm_vm_apply_hook
, "vm-apply-hook", 0, 0, 0,
986 #define FUNC_NAME s_scm_vm_apply_hook
988 VM_DEFINE_HOOK (SCM_VM_APPLY_HOOK
);
992 SCM_DEFINE (scm_vm_push_continuation_hook
, "vm-push-continuation-hook", 0, 0, 0,
995 #define FUNC_NAME s_scm_vm_push_continuation_hook
997 VM_DEFINE_HOOK (SCM_VM_PUSH_CONTINUATION_HOOK
);
1001 SCM_DEFINE (scm_vm_pop_continuation_hook
, "vm-pop-continuation-hook", 0, 0, 0,
1004 #define FUNC_NAME s_scm_vm_pop_continuation_hook
1006 VM_DEFINE_HOOK (SCM_VM_POP_CONTINUATION_HOOK
);
1010 SCM_DEFINE (scm_vm_next_hook
, "vm-next-hook", 0, 0, 0,
1013 #define FUNC_NAME s_scm_vm_next_hook
1015 VM_DEFINE_HOOK (SCM_VM_NEXT_HOOK
);
1019 SCM_DEFINE (scm_vm_abort_continuation_hook
, "vm-abort-continuation-hook", 0, 0, 0,
1022 #define FUNC_NAME s_scm_vm_abort_continuation_hook
1024 VM_DEFINE_HOOK (SCM_VM_ABORT_CONTINUATION_HOOK
);
1028 SCM_DEFINE (scm_vm_restore_continuation_hook
, "vm-restore-continuation-hook", 0, 0, 0,
1031 #define FUNC_NAME s_scm_vm_restore_continuation_hook
1033 VM_DEFINE_HOOK (SCM_VM_RESTORE_CONTINUATION_HOOK
);
1037 SCM_DEFINE (scm_vm_trace_level
, "vm-trace-level", 0, 0, 0,
1040 #define FUNC_NAME s_scm_vm_trace_level
1042 return scm_from_int (scm_the_vm ()->trace_level
);
1046 SCM_DEFINE (scm_set_vm_trace_level_x
, "set-vm-trace-level!", 1, 0, 0,
1049 #define FUNC_NAME s_scm_set_vm_trace_level_x
1051 scm_the_vm ()->trace_level
= scm_to_int (level
);
1052 return SCM_UNSPECIFIED
;
1062 symbol_to_vm_engine (SCM engine
, const char *FUNC_NAME
)
1064 if (scm_is_eq (engine
, sym_regular
))
1065 return SCM_VM_REGULAR_ENGINE
;
1066 else if (scm_is_eq (engine
, sym_debug
))
1067 return SCM_VM_DEBUG_ENGINE
;
1069 SCM_MISC_ERROR ("Unknown VM engine: ~a", scm_list_1 (engine
));
1073 vm_engine_to_symbol (int engine
, const char *FUNC_NAME
)
1077 case SCM_VM_REGULAR_ENGINE
:
1079 case SCM_VM_DEBUG_ENGINE
:
1083 SCM_MISC_ERROR ("Unknown VM engine: ~a",
1084 scm_list_1 (scm_from_int (engine
)));
1088 SCM_DEFINE (scm_vm_engine
, "vm-engine", 0, 0, 0,
1091 #define FUNC_NAME s_scm_vm_engine
1093 return vm_engine_to_symbol (scm_the_vm ()->engine
, FUNC_NAME
);
1098 scm_c_set_vm_engine_x (int engine
)
1099 #define FUNC_NAME "set-vm-engine!"
1101 if (engine
< 0 || engine
>= SCM_VM_NUM_ENGINES
)
1102 SCM_MISC_ERROR ("Unknown VM engine: ~a",
1103 scm_list_1 (scm_from_int (engine
)));
1105 scm_the_vm ()->engine
= engine
;
1109 SCM_DEFINE (scm_set_vm_engine_x
, "set-vm-engine!", 1, 0, 0,
1112 #define FUNC_NAME s_scm_set_vm_engine_x
1114 scm_c_set_vm_engine_x (symbol_to_vm_engine (engine
, FUNC_NAME
));
1115 return SCM_UNSPECIFIED
;
1120 scm_c_set_default_vm_engine_x (int engine
)
1121 #define FUNC_NAME "set-default-vm-engine!"
1123 if (engine
< 0 || engine
>= SCM_VM_NUM_ENGINES
)
1124 SCM_MISC_ERROR ("Unknown VM engine: ~a",
1125 scm_list_1 (scm_from_int (engine
)));
1127 vm_default_engine
= engine
;
1131 SCM_DEFINE (scm_set_default_vm_engine_x
, "set-default-vm-engine!", 1, 0, 0,
1134 #define FUNC_NAME s_scm_set_default_vm_engine_x
1136 scm_c_set_default_vm_engine_x (symbol_to_vm_engine (engine
, FUNC_NAME
));
1137 return SCM_UNSPECIFIED
;
1141 /* FIXME: This function makes no sense, but we keep it to make sure we
1142 have a way of switching to the debug or regular VM. */
1143 SCM_DEFINE (scm_call_with_vm
, "call-with-vm", 1, 0, 1,
1144 (SCM proc
, SCM args
),
1145 "Apply @var{proc} to @var{args} in a dynamic extent in which\n"
1146 "@var{vm} is the current VM.")
1147 #define FUNC_NAME s_scm_call_with_vm
1149 return scm_apply_0 (proc
, args
);
1159 scm_load_compiled_with_vm (SCM file
)
1161 return scm_call_0 (scm_load_thunk_from_file (file
));
1166 scm_init_vm_builtin_properties (void)
1168 /* FIXME: Seems hacky to do this here, but oh well :/ */
1169 scm_sym_apply
= scm_from_utf8_symbol ("apply");
1170 scm_sym_values
= scm_from_utf8_symbol ("values");
1171 scm_sym_abort_to_prompt
= scm_from_utf8_symbol ("abort-to-prompt");
1172 scm_sym_call_with_values
= scm_from_utf8_symbol ("call-with-values");
1173 scm_sym_call_with_current_continuation
=
1174 scm_from_utf8_symbol ("call-with-current-continuation");
1176 #define INIT_BUILTIN(builtin, BUILTIN, req, opt, rest) \
1177 scm_set_procedure_property_x (vm_builtin_##builtin, scm_sym_name, \
1178 scm_sym_##builtin); \
1179 scm_set_procedure_minimum_arity_x (vm_builtin_##builtin, \
1180 SCM_I_MAKINUM (req), \
1181 SCM_I_MAKINUM (opt), \
1182 scm_from_bool (rest));
1183 FOR_EACH_VM_BUILTIN (INIT_BUILTIN
);
1188 scm_bootstrap_vm (void)
1190 scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION
,
1192 (scm_t_extension_init_func
)scm_init_vm
, NULL
);
1193 scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION
,
1194 "scm_init_vm_builtins",
1195 (scm_t_extension_init_func
)scm_init_vm_builtins
,
1198 initialize_default_stack_size ();
1200 sym_vm_run
= scm_from_latin1_symbol ("vm-run");
1201 sym_vm_error
= scm_from_latin1_symbol ("vm-error");
1202 sym_keyword_argument_error
= scm_from_latin1_symbol ("keyword-argument-error");
1203 sym_regular
= scm_from_latin1_symbol ("regular");
1204 sym_debug
= scm_from_latin1_symbol ("debug");
1206 vm_boot_continuation
= scm_i_make_program (vm_boot_continuation_code
);
1207 SCM_SET_CELL_WORD_0 (vm_boot_continuation
,
1208 (SCM_CELL_WORD_0 (vm_boot_continuation
)
1209 | SCM_F_PROGRAM_IS_BOOT
));
1211 #define DEFINE_BUILTIN(builtin, BUILTIN, req, opt, rest) \
1212 vm_builtin_##builtin = scm_i_make_program (vm_builtin_##builtin##_code);
1213 FOR_EACH_VM_BUILTIN (DEFINE_BUILTIN
);
1214 #undef DEFINE_BUILTIN
1220 #ifndef SCM_MAGIC_SNARFER
1221 #include "libguile/vm.x"