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
;
172 vm_dispatch_hook (struct scm_vm
*vp
, int hook_num
, SCM
*argv
, int n
)
175 struct scm_frame c_frame
;
177 int saved_trace_level
;
179 hook
= vp
->hooks
[hook_num
];
181 if (SCM_LIKELY (scm_is_false (hook
))
182 || scm_is_null (SCM_HOOK_PROCEDURES (hook
)))
185 saved_trace_level
= vp
->trace_level
;
188 /* Allocate a frame object on the stack. This is more efficient than calling
189 `scm_c_make_frame ()' to allocate on the heap, but it forces hooks to not
190 capture frame objects.
192 At the same time, procedures such as `frame-procedure' make sense only
193 while the stack frame represented by the frame object is visible, so it
194 seems reasonable to limit the lifetime of frame objects. */
196 c_frame
.stack_holder
= vp
;
197 c_frame
.fp_offset
= vp
->fp
- vp
->stack_base
;
198 c_frame
.sp_offset
= vp
->sp
- vp
->stack_base
;
201 /* Arrange for FRAME to be 8-byte aligned, like any other cell. */
202 frame
= alloca (sizeof (*frame
) + 8);
203 frame
= (scm_t_cell
*) ROUND_UP ((scm_t_uintptr
) frame
, 8UL);
205 frame
->word_0
= SCM_PACK (scm_tc7_frame
| (SCM_VM_FRAME_KIND_VM
<< 8));
206 frame
->word_1
= SCM_PACK_POINTER (&c_frame
);
212 args
[0] = SCM_PACK_POINTER (frame
);
213 scm_c_run_hookn (hook
, args
, 1);
219 args
[0] = SCM_PACK_POINTER (frame
);
221 scm_c_run_hookn (hook
, args
, 2);
228 args
= scm_cons (argv
[n
], args
);
229 scm_c_run_hook (hook
, scm_cons (SCM_PACK_POINTER (frame
), args
));
232 vp
->trace_level
= saved_trace_level
;
236 vm_dispatch_apply_hook (struct scm_vm
*vp
)
238 return vm_dispatch_hook (vp
, SCM_VM_APPLY_HOOK
, NULL
, 0);
240 static void vm_dispatch_push_continuation_hook (struct scm_vm
*vp
)
242 return vm_dispatch_hook (vp
, SCM_VM_PUSH_CONTINUATION_HOOK
, NULL
, 0);
244 static void vm_dispatch_pop_continuation_hook (struct scm_vm
*vp
, SCM
*old_fp
)
246 return vm_dispatch_hook (vp
, SCM_VM_POP_CONTINUATION_HOOK
,
247 &SCM_FRAME_LOCAL (old_fp
, 1),
248 SCM_FRAME_NUM_LOCALS (old_fp
, vp
->sp
) - 1);
250 static void vm_dispatch_next_hook (struct scm_vm
*vp
)
252 return vm_dispatch_hook (vp
, SCM_VM_NEXT_HOOK
, NULL
, 0);
254 static void vm_dispatch_abort_hook (struct scm_vm
*vp
)
256 return vm_dispatch_hook (vp
, SCM_VM_ABORT_CONTINUATION_HOOK
,
257 &SCM_FRAME_LOCAL (vp
->fp
, 1),
258 SCM_FRAME_NUM_LOCALS (vp
->fp
, vp
->sp
) - 1);
262 vm_abort (struct scm_vm
*vp
, SCM tag
,
263 size_t nstack
, SCM
*stack_args
, SCM tail
, SCM
*sp
,
264 scm_i_jmp_buf
*current_registers
) SCM_NORETURN
;
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
)
275 tail_len
= scm_ilength (tail
);
277 scm_misc_error ("vm-engine", "tail values to abort should be a list",
280 argv
= alloca ((nstack
+ tail_len
) * sizeof (SCM
));
281 for (i
= 0; i
< nstack
; i
++)
282 argv
[i
] = stack_args
[i
];
283 for (; i
< nstack
+ tail_len
; i
++, tail
= scm_cdr (tail
))
284 argv
[i
] = scm_car (tail
);
286 /* FIXME: NULLSTACK (SCM_VM_DATA (vp)->sp - sp) */
289 scm_c_abort (vp
, tag
, nstack
+ tail_len
, argv
, current_registers
);
293 vm_reinstate_partial_continuation (struct scm_vm
*vp
, SCM cont
,
295 scm_t_dynstack
*dynstack
,
296 scm_i_jmp_buf
*registers
)
298 struct scm_vm_cont
*cp
;
299 SCM
*argv_copy
, *base
;
303 argv_copy
= alloca (n
* sizeof(SCM
));
304 memcpy (argv_copy
, argv
, n
* sizeof(SCM
));
306 cp
= SCM_VM_CONT_DATA (cont
);
307 base
= SCM_FRAME_LOCALS_ADDRESS (vp
->fp
);
308 reloc
= cp
->reloc
+ (base
- cp
->stack_base
);
310 #define RELOC(scm_p) \
311 (((SCM *) (scm_p)) + reloc)
313 if ((base
- vp
->stack_base
) + cp
->stack_size
+ n
+ 1 > vp
->stack_size
)
314 scm_misc_error ("vm-engine",
315 "not enough space to instate partial continuation",
318 memcpy (base
, cp
->stack_base
, cp
->stack_size
* sizeof (SCM
));
320 /* now relocate frame pointers */
323 for (fp
= RELOC (cp
->fp
);
324 SCM_FRAME_LOWER_ADDRESS (fp
) > base
;
325 fp
= SCM_FRAME_DYNAMIC_LINK (fp
))
326 SCM_FRAME_SET_DYNAMIC_LINK (fp
, RELOC (SCM_FRAME_DYNAMIC_LINK (fp
)));
329 vp
->sp
= base
- 1 + cp
->stack_size
;
330 vp
->fp
= RELOC (cp
->fp
);
333 /* Push the arguments. */
334 for (i
= 0; i
< n
; i
++)
337 *vp
->sp
= argv_copy
[i
];
340 /* The prompt captured a slice of the dynamic stack. Here we wind
341 those entries onto the current thread's stack. We also have to
342 relocate any prompts that we see along the way. */
346 for (walk
= SCM_DYNSTACK_FIRST (cp
->dynstack
);
347 SCM_DYNSTACK_TAG (walk
);
348 walk
= SCM_DYNSTACK_NEXT (walk
))
350 scm_t_bits tag
= SCM_DYNSTACK_TAG (walk
);
352 if (SCM_DYNSTACK_TAG_TYPE (tag
) == SCM_DYNSTACK_TYPE_PROMPT
)
353 scm_dynstack_wind_prompt (dynstack
, walk
, reloc
, registers
);
355 scm_dynstack_wind_1 (dynstack
, walk
);
366 static void vm_error (const char *msg
, SCM arg
) SCM_NORETURN
;
367 static void vm_error_bad_instruction (scm_t_uint32 inst
) SCM_NORETURN SCM_NOINLINE
;
368 static void vm_error_unbound (SCM proc
, SCM sym
) SCM_NORETURN SCM_NOINLINE
;
369 static void vm_error_unbound_fluid (SCM proc
, SCM fluid
) SCM_NORETURN SCM_NOINLINE
;
370 static void vm_error_not_a_variable (const char *func_name
, SCM x
) SCM_NORETURN SCM_NOINLINE
;
371 static void vm_error_apply_to_non_list (SCM x
) SCM_NORETURN SCM_NOINLINE
;
372 static void vm_error_kwargs_length_not_even (SCM proc
) SCM_NORETURN SCM_NOINLINE
;
373 static void vm_error_kwargs_invalid_keyword (SCM proc
, SCM obj
) SCM_NORETURN SCM_NOINLINE
;
374 static void vm_error_kwargs_unrecognized_keyword (SCM proc
, SCM kw
) SCM_NORETURN SCM_NOINLINE
;
375 static void vm_error_too_many_args (int nargs
) SCM_NORETURN SCM_NOINLINE
;
376 static void vm_error_wrong_num_args (SCM proc
) SCM_NORETURN SCM_NOINLINE
;
377 static void vm_error_wrong_type_apply (SCM proc
) SCM_NORETURN SCM_NOINLINE
;
378 static void vm_error_stack_underflow (void) SCM_NORETURN SCM_NOINLINE
;
379 static void vm_error_improper_list (SCM x
) SCM_NORETURN SCM_NOINLINE
;
380 static void vm_error_not_a_pair (const char *subr
, SCM x
) SCM_NORETURN SCM_NOINLINE
;
381 static void vm_error_not_a_bytevector (const char *subr
, SCM x
) SCM_NORETURN SCM_NOINLINE
;
382 static void vm_error_not_a_struct (const char *subr
, SCM x
) SCM_NORETURN SCM_NOINLINE
;
383 static void vm_error_no_values (void) SCM_NORETURN SCM_NOINLINE
;
384 static void vm_error_not_enough_values (void) SCM_NORETURN SCM_NOINLINE
;
385 static void vm_error_wrong_number_of_values (scm_t_uint32 expected
) SCM_NORETURN SCM_NOINLINE
;
386 static void vm_error_continuation_not_rewindable (SCM cont
) SCM_NORETURN SCM_NOINLINE
;
387 static void vm_error_bad_wide_string_length (size_t len
) SCM_NORETURN SCM_NOINLINE
;
390 vm_error (const char *msg
, SCM arg
)
392 scm_throw (sym_vm_error
,
393 scm_list_3 (sym_vm_run
, scm_from_latin1_string (msg
),
394 SCM_UNBNDP (arg
) ? SCM_EOL
: scm_list_1 (arg
)));
395 abort(); /* not reached */
399 vm_error_bad_instruction (scm_t_uint32 inst
)
401 vm_error ("VM: Bad instruction: ~s", scm_from_uint32 (inst
));
405 vm_error_unbound (SCM proc
, SCM sym
)
407 scm_error_scm (scm_misc_error_key
, proc
,
408 scm_from_latin1_string ("Unbound variable: ~s"),
409 scm_list_1 (sym
), SCM_BOOL_F
);
413 vm_error_unbound_fluid (SCM proc
, SCM fluid
)
415 scm_error_scm (scm_misc_error_key
, proc
,
416 scm_from_latin1_string ("Unbound fluid: ~s"),
417 scm_list_1 (fluid
), SCM_BOOL_F
);
421 vm_error_not_a_variable (const char *func_name
, SCM x
)
423 scm_error (scm_arg_type_key
, func_name
, "Not a variable: ~S",
424 scm_list_1 (x
), scm_list_1 (x
));
428 vm_error_apply_to_non_list (SCM x
)
430 scm_error (scm_arg_type_key
, "apply", "Apply to non-list: ~S",
431 scm_list_1 (x
), scm_list_1 (x
));
435 vm_error_kwargs_length_not_even (SCM proc
)
437 scm_error_scm (sym_keyword_argument_error
, proc
,
438 scm_from_latin1_string ("Odd length of keyword argument list"),
439 SCM_EOL
, SCM_BOOL_F
);
443 vm_error_kwargs_invalid_keyword (SCM proc
, SCM obj
)
445 scm_error_scm (sym_keyword_argument_error
, proc
,
446 scm_from_latin1_string ("Invalid keyword"),
447 SCM_EOL
, scm_list_1 (obj
));
451 vm_error_kwargs_unrecognized_keyword (SCM proc
, SCM kw
)
453 scm_error_scm (sym_keyword_argument_error
, proc
,
454 scm_from_latin1_string ("Unrecognized keyword"),
455 SCM_EOL
, scm_list_1 (kw
));
459 vm_error_too_many_args (int nargs
)
461 vm_error ("VM: Too many arguments", scm_from_int (nargs
));
465 vm_error_wrong_num_args (SCM proc
)
467 scm_wrong_num_args (proc
);
471 vm_error_wrong_type_apply (SCM proc
)
473 scm_error (scm_arg_type_key
, NULL
, "Wrong type to apply: ~S",
474 scm_list_1 (proc
), scm_list_1 (proc
));
478 vm_error_stack_underflow (void)
480 vm_error ("VM: Stack underflow", SCM_UNDEFINED
);
484 vm_error_improper_list (SCM x
)
486 vm_error ("Expected a proper list, but got object with tail ~s", x
);
490 vm_error_not_a_pair (const char *subr
, SCM x
)
492 scm_wrong_type_arg_msg (subr
, 1, x
, "pair");
496 vm_error_not_a_bytevector (const char *subr
, SCM x
)
498 scm_wrong_type_arg_msg (subr
, 1, x
, "bytevector");
502 vm_error_not_a_struct (const char *subr
, SCM x
)
504 scm_wrong_type_arg_msg (subr
, 1, x
, "struct");
508 vm_error_no_values (void)
510 vm_error ("Zero values returned to single-valued continuation",
515 vm_error_not_enough_values (void)
517 vm_error ("Too few values returned to continuation", SCM_UNDEFINED
);
521 vm_error_wrong_number_of_values (scm_t_uint32 expected
)
523 vm_error ("Wrong number of values returned to continuation (expected ~a)",
524 scm_from_uint32 (expected
));
528 vm_error_continuation_not_rewindable (SCM cont
)
530 vm_error ("Unrewindable partial continuation", cont
);
534 vm_error_bad_wide_string_length (size_t len
)
536 vm_error ("VM: Bad wide string length: ~S", scm_from_size_t (len
));
542 static SCM vm_boot_continuation
;
543 static SCM vm_builtin_apply
;
544 static SCM vm_builtin_values
;
545 static SCM vm_builtin_abort_to_prompt
;
546 static SCM vm_builtin_call_with_values
;
547 static SCM vm_builtin_call_with_current_continuation
;
549 static const scm_t_uint32 vm_boot_continuation_code
[] = {
550 SCM_PACK_OP_24 (halt
, 0)
553 static const scm_t_uint32 vm_builtin_apply_code
[] = {
554 SCM_PACK_OP_24 (assert_nargs_ge
, 3),
555 SCM_PACK_OP_24 (tail_apply
, 0), /* proc in r1, args from r2 */
558 static const scm_t_uint32 vm_builtin_values_code
[] = {
559 SCM_PACK_OP_24 (return_values
, 0) /* vals from r1 */
562 static const scm_t_uint32 vm_builtin_abort_to_prompt_code
[] = {
563 SCM_PACK_OP_24 (assert_nargs_ge
, 2),
564 SCM_PACK_OP_24 (abort
, 0), /* tag in r1, vals from r2 */
565 /* FIXME: Partial continuation should capture caller regs. */
566 SCM_PACK_OP_24 (return_values
, 0) /* vals from r1 */
569 static const scm_t_uint32 vm_builtin_call_with_values_code
[] = {
570 SCM_PACK_OP_24 (assert_nargs_ee
, 3),
571 SCM_PACK_OP_24 (alloc_frame
, 7),
572 SCM_PACK_OP_12_12 (mov
, 6, 1),
573 SCM_PACK_OP_24 (call
, 6), SCM_PACK_OP_ARG_8_24 (0, 1),
574 SCM_PACK_OP_12_12 (mov
, 0, 2),
575 SCM_PACK_OP_24 (tail_call_shuffle
, 7)
578 static const scm_t_uint32 vm_builtin_call_with_current_continuation_code
[] = {
579 SCM_PACK_OP_24 (assert_nargs_ee
, 2),
580 SCM_PACK_OP_24 (call_cc
, 0)
585 scm_vm_builtin_ref (unsigned idx
)
589 #define INDEX_TO_NAME(builtin, BUILTIN, req, opt, rest) \
590 case SCM_VM_BUILTIN_##BUILTIN: return vm_builtin_##builtin;
591 FOR_EACH_VM_BUILTIN(INDEX_TO_NAME
)
598 static SCM scm_sym_values
;
599 static SCM scm_sym_abort_to_prompt
;
600 static SCM scm_sym_call_with_values
;
601 static SCM scm_sym_call_with_current_continuation
;
604 scm_vm_builtin_name_to_index (SCM name
)
605 #define FUNC_NAME "builtin-name->index"
607 SCM_VALIDATE_SYMBOL (1, name
);
609 #define NAME_TO_INDEX(builtin, BUILTIN, req, opt, rest) \
610 if (scm_is_eq (name, scm_sym_##builtin)) \
611 return scm_from_uint (SCM_VM_BUILTIN_##BUILTIN);
612 FOR_EACH_VM_BUILTIN(NAME_TO_INDEX
)
620 scm_vm_builtin_index_to_name (SCM index
)
621 #define FUNC_NAME "builtin-index->name"
625 SCM_VALIDATE_UINT_COPY (1, index
, idx
);
629 #define INDEX_TO_NAME(builtin, BUILTIN, req, opt, rest) \
630 case SCM_VM_BUILTIN_##BUILTIN: return scm_sym_##builtin;
631 FOR_EACH_VM_BUILTIN(INDEX_TO_NAME
)
633 default: return SCM_BOOL_F
;
639 scm_init_vm_builtins (void)
641 scm_c_define_gsubr ("builtin-name->index", 1, 0, 0,
642 scm_vm_builtin_name_to_index
);
643 scm_c_define_gsubr ("builtin-index->name", 1, 0, 0,
644 scm_vm_builtin_index_to_name
);
648 scm_i_call_with_current_continuation (SCM proc
)
650 return scm_call_1 (vm_builtin_call_with_current_continuation
, proc
);
658 /* Hard stack limit is 512M words: 2 gigabytes on 32-bit machines, 4 on
660 static const size_t hard_max_stack_size
= 512 * 1024 * 1024;
662 /* Initial stack size: 4 or 8 kB. */
663 static const size_t initial_stack_size
= 1024;
665 /* Default soft stack limit is 1M words (4 or 8 megabytes). */
666 static size_t default_max_stack_size
= 1024 * 1024;
669 initialize_default_stack_size (void)
671 int size
= scm_getenv_int ("GUILE_STACK_SIZE", (int) default_max_stack_size
);
672 if (size
>= initial_stack_size
&& (size_t) size
< ((size_t) -1) / sizeof(SCM
))
673 default_max_stack_size
= size
;
676 static void vm_expand_stack (struct scm_vm
*vp
) SCM_NOINLINE
;
677 #define VM_NAME vm_regular_engine
678 #define VM_USE_HOOKS 0
679 #define FUNC_NAME "vm-regular-engine"
680 #include "vm-engine.c"
685 #define VM_NAME vm_debug_engine
686 #define VM_USE_HOOKS 1
687 #define FUNC_NAME "vm-debug-engine"
688 #include "vm-engine.c"
693 typedef SCM (*scm_t_vm_engine
) (scm_i_thread
*current_thread
, struct scm_vm
*vp
,
694 scm_i_jmp_buf
*registers
, int resume
);
696 static const scm_t_vm_engine vm_engines
[SCM_VM_NUM_ENGINES
] =
697 { vm_regular_engine
, vm_debug_engine
};
700 allocate_stack (size_t size
)
701 #define FUNC_NAME "make_vm"
705 if (size
>= ((size_t) -1) / sizeof (SCM
))
708 size
*= sizeof (SCM
);
711 ret
= mmap (NULL
, size
, PROT_READ
| PROT_WRITE
,
712 MAP_PRIVATE
| MAP_ANONYMOUS
, -1, 0);
713 if (ret
== MAP_FAILED
)
726 free_stack (SCM
*stack
, size_t size
)
728 size
*= sizeof (SCM
);
731 munmap (stack
, size
);
738 expand_stack (SCM
*old_stack
, size_t old_size
, size_t new_size
)
739 #define FUNC_NAME "expand_stack"
741 #if defined MREMAP_MAYMOVE
744 if (new_size
>= ((size_t) -1) / sizeof (SCM
))
747 old_size
*= sizeof (SCM
);
748 new_size
*= sizeof (SCM
);
750 new_stack
= mremap (old_stack
, old_size
, new_size
, MREMAP_MAYMOVE
);
751 if (new_stack
== MAP_FAILED
)
754 return (SCM
*) new_stack
;
758 new_stack
= allocate_stack (new_size
);
759 memcpy (new_stack
, old_stack
, old_size
* sizeof (SCM
));
760 free_stack (old_stack
, old_size
);
767 static struct scm_vm
*
769 #define FUNC_NAME "make_vm"
774 vp
= scm_gc_malloc (sizeof (struct scm_vm
), "vm");
776 vp
->stack_size
= initial_stack_size
;
777 vp
->stack_base
= allocate_stack (vp
->stack_size
);
778 vp
->stack_limit
= vp
->stack_base
+ vp
->stack_size
;
779 vp
->max_stack_size
= default_max_stack_size
;
781 vp
->sp
= vp
->stack_base
- 1;
783 vp
->engine
= vm_default_engine
;
785 for (i
= 0; i
< SCM_VM_NUM_HOOKS
; i
++)
786 vp
->hooks
[i
] = SCM_BOOL_F
;
792 /* Mark the VM stack region between its base and its current top. */
794 scm_i_vm_mark_stack (struct scm_vm
*vp
, struct GC_ms_entry
*mark_stack_ptr
,
795 struct GC_ms_entry
*mark_stack_limit
)
799 for (fp
= vp
->fp
, sp
= vp
->sp
; fp
; fp
= SCM_FRAME_DYNAMIC_LINK (fp
))
801 for (; sp
>= &SCM_FRAME_LOCAL (fp
, 0); sp
--)
805 mark_stack_ptr
= GC_MARK_AND_PUSH ((GC_word
*) elt
,
806 mark_stack_ptr
, mark_stack_limit
,
809 sp
= SCM_FRAME_PREVIOUS_SP (fp
);
812 return mark_stack_ptr
;
815 /* Free the VM stack, as this thread is exiting. */
817 scm_i_vm_free_stack (struct scm_vm
*vp
)
819 free_stack (vp
->stack_base
, vp
->stack_size
);
820 vp
->stack_base
= vp
->stack_limit
= NULL
;
825 vm_expand_stack (struct scm_vm
*vp
)
827 scm_t_ptrdiff stack_size
= vp
->sp
+ 1 - vp
->stack_base
;
829 if (stack_size
> hard_max_stack_size
)
831 /* We have expanded the soft limit to the point that we reached a
832 hard limit. There is nothing sensible to do. */
833 fprintf (stderr
, "Hard stack size limit (%zu words) reached; aborting.\n",
834 hard_max_stack_size
);
838 if (stack_size
> vp
->stack_size
)
844 new_size
= vp
->stack_size
;
845 while (new_size
< stack_size
)
847 old_stack
= vp
->stack_base
;
848 vp
->stack_base
= expand_stack (old_stack
, vp
->stack_size
, new_size
);
849 vp
->stack_size
= new_size
;
850 vp
->stack_limit
= vp
->stack_base
+ new_size
;
851 reloc
= vp
->stack_base
- old_stack
;
861 SCM
*next_fp
= SCM_FRAME_DYNAMIC_LINK (fp
);
865 SCM_FRAME_SET_DYNAMIC_LINK (fp
, next_fp
);
872 if (stack_size
>= vp
->max_stack_size
)
874 /* Expand the soft limit by 256K entries to give us space to
876 vp
->max_stack_size
+= 256 * 1024;
878 /* If it's still not big enough... it's quite improbable, but go
879 ahead and set to the full available stack size. */
880 if (vp
->max_stack_size
< stack_size
)
881 vp
->max_stack_size
= vp
->stack_size
;
883 /* But don't exceed the hard maximum. */
884 if (vp
->max_stack_size
> hard_max_stack_size
)
885 vp
->max_stack_size
= hard_max_stack_size
;
887 /* Finally, reset the limit, to catch further overflows. */
888 vp
->stack_limit
= vp
->stack_base
+ vp
->max_stack_size
;
890 vm_error ("VM: Stack overflow", SCM_UNDEFINED
);
893 /* Otherwise continue, with the new enlarged stack. */
896 static struct scm_vm
*
897 thread_vm (scm_i_thread
*t
)
899 if (SCM_UNLIKELY (!t
->vp
))
908 return thread_vm (SCM_I_CURRENT_THREAD
);
912 scm_call_n (SCM proc
, SCM
*argv
, size_t nargs
)
914 scm_i_thread
*thread
;
917 ptrdiff_t base_frame_size
;
918 /* Cached variables. */
919 scm_i_jmp_buf registers
; /* used for prompts */
922 thread
= SCM_I_CURRENT_THREAD
;
923 vp
= thread_vm (thread
);
927 /* Check that we have enough space: 3 words for the boot
928 continuation, 3 + nargs for the procedure application, and 3 for
929 setting up a new frame. */
930 base_frame_size
= 3 + 3 + nargs
+ 3;
931 vp
->sp
+= base_frame_size
;
932 if (vp
->sp
>= vp
->stack_limit
)
933 vm_expand_stack (vp
);
934 base
= vp
->sp
+ 1 - base_frame_size
;
936 /* Since it's possible to receive the arguments on the stack itself,
937 shuffle up the arguments first. */
938 for (i
= nargs
; i
> 0; i
--)
939 base
[6 + i
- 1] = argv
[i
- 1];
941 /* Push the boot continuation, which calls PROC and returns its
943 base
[0] = SCM_PACK (vp
->fp
); /* dynamic link */
944 base
[1] = SCM_PACK (vp
->ip
); /* ra */
945 base
[2] = vm_boot_continuation
;
947 vp
->ip
= (scm_t_uint32
*) vm_boot_continuation_code
;
949 /* The pending call to PROC. */
950 base
[3] = SCM_PACK (vp
->fp
); /* dynamic link */
951 base
[4] = SCM_PACK (vp
->ip
); /* ra */
954 vp
->sp
= &SCM_FRAME_LOCAL (vp
->fp
, nargs
);
957 int resume
= SCM_I_SETJMP (registers
);
959 if (SCM_UNLIKELY (resume
))
960 /* Non-local return. */
961 vm_dispatch_abort_hook (vp
);
963 return vm_engines
[vp
->engine
](thread
, vp
, ®isters
, resume
);
967 /* Scheme interface */
969 #define VM_DEFINE_HOOK(n) \
972 vp = scm_the_vm (); \
973 if (scm_is_false (vp->hooks[n])) \
974 vp->hooks[n] = scm_make_hook (SCM_I_MAKINUM (1)); \
975 return vp->hooks[n]; \
978 SCM_DEFINE (scm_vm_apply_hook
, "vm-apply-hook", 0, 0, 0,
981 #define FUNC_NAME s_scm_vm_apply_hook
983 VM_DEFINE_HOOK (SCM_VM_APPLY_HOOK
);
987 SCM_DEFINE (scm_vm_push_continuation_hook
, "vm-push-continuation-hook", 0, 0, 0,
990 #define FUNC_NAME s_scm_vm_push_continuation_hook
992 VM_DEFINE_HOOK (SCM_VM_PUSH_CONTINUATION_HOOK
);
996 SCM_DEFINE (scm_vm_pop_continuation_hook
, "vm-pop-continuation-hook", 0, 0, 0,
999 #define FUNC_NAME s_scm_vm_pop_continuation_hook
1001 VM_DEFINE_HOOK (SCM_VM_POP_CONTINUATION_HOOK
);
1005 SCM_DEFINE (scm_vm_next_hook
, "vm-next-hook", 0, 0, 0,
1008 #define FUNC_NAME s_scm_vm_next_hook
1010 VM_DEFINE_HOOK (SCM_VM_NEXT_HOOK
);
1014 SCM_DEFINE (scm_vm_abort_continuation_hook
, "vm-abort-continuation-hook", 0, 0, 0,
1017 #define FUNC_NAME s_scm_vm_abort_continuation_hook
1019 VM_DEFINE_HOOK (SCM_VM_ABORT_CONTINUATION_HOOK
);
1023 SCM_DEFINE (scm_vm_trace_level
, "vm-trace-level", 0, 0, 0,
1026 #define FUNC_NAME s_scm_vm_trace_level
1028 return scm_from_int (scm_the_vm ()->trace_level
);
1032 SCM_DEFINE (scm_set_vm_trace_level_x
, "set-vm-trace-level!", 1, 0, 0,
1035 #define FUNC_NAME s_scm_set_vm_trace_level_x
1037 scm_the_vm ()->trace_level
= scm_to_int (level
);
1038 return SCM_UNSPECIFIED
;
1048 symbol_to_vm_engine (SCM engine
, const char *FUNC_NAME
)
1050 if (scm_is_eq (engine
, sym_regular
))
1051 return SCM_VM_REGULAR_ENGINE
;
1052 else if (scm_is_eq (engine
, sym_debug
))
1053 return SCM_VM_DEBUG_ENGINE
;
1055 SCM_MISC_ERROR ("Unknown VM engine: ~a", scm_list_1 (engine
));
1059 vm_engine_to_symbol (int engine
, const char *FUNC_NAME
)
1063 case SCM_VM_REGULAR_ENGINE
:
1065 case SCM_VM_DEBUG_ENGINE
:
1069 SCM_MISC_ERROR ("Unknown VM engine: ~a",
1070 scm_list_1 (scm_from_int (engine
)));
1074 SCM_DEFINE (scm_vm_engine
, "vm-engine", 0, 0, 0,
1077 #define FUNC_NAME s_scm_vm_engine
1079 return vm_engine_to_symbol (scm_the_vm ()->engine
, FUNC_NAME
);
1084 scm_c_set_vm_engine_x (int engine
)
1085 #define FUNC_NAME "set-vm-engine!"
1087 if (engine
< 0 || engine
>= SCM_VM_NUM_ENGINES
)
1088 SCM_MISC_ERROR ("Unknown VM engine: ~a",
1089 scm_list_1 (scm_from_int (engine
)));
1091 scm_the_vm ()->engine
= engine
;
1095 SCM_DEFINE (scm_set_vm_engine_x
, "set-vm-engine!", 1, 0, 0,
1098 #define FUNC_NAME s_scm_set_vm_engine_x
1100 scm_c_set_vm_engine_x (symbol_to_vm_engine (engine
, FUNC_NAME
));
1101 return SCM_UNSPECIFIED
;
1106 scm_c_set_default_vm_engine_x (int engine
)
1107 #define FUNC_NAME "set-default-vm-engine!"
1109 if (engine
< 0 || engine
>= SCM_VM_NUM_ENGINES
)
1110 SCM_MISC_ERROR ("Unknown VM engine: ~a",
1111 scm_list_1 (scm_from_int (engine
)));
1113 vm_default_engine
= engine
;
1117 SCM_DEFINE (scm_set_default_vm_engine_x
, "set-default-vm-engine!", 1, 0, 0,
1120 #define FUNC_NAME s_scm_set_default_vm_engine_x
1122 scm_c_set_default_vm_engine_x (symbol_to_vm_engine (engine
, FUNC_NAME
));
1123 return SCM_UNSPECIFIED
;
1127 /* FIXME: This function makes no sense, but we keep it to make sure we
1128 have a way of switching to the debug or regular VM. */
1129 SCM_DEFINE (scm_call_with_vm
, "call-with-vm", 1, 0, 1,
1130 (SCM proc
, SCM args
),
1131 "Apply @var{proc} to @var{args} in a dynamic extent in which\n"
1132 "@var{vm} is the current VM.")
1133 #define FUNC_NAME s_scm_call_with_vm
1135 return scm_apply_0 (proc
, args
);
1145 scm_load_compiled_with_vm (SCM file
)
1147 return scm_call_0 (scm_load_thunk_from_file (file
));
1152 scm_init_vm_builtin_properties (void)
1154 /* FIXME: Seems hacky to do this here, but oh well :/ */
1155 scm_sym_apply
= scm_from_utf8_symbol ("apply");
1156 scm_sym_values
= scm_from_utf8_symbol ("values");
1157 scm_sym_abort_to_prompt
= scm_from_utf8_symbol ("abort-to-prompt");
1158 scm_sym_call_with_values
= scm_from_utf8_symbol ("call-with-values");
1159 scm_sym_call_with_current_continuation
=
1160 scm_from_utf8_symbol ("call-with-current-continuation");
1162 #define INIT_BUILTIN(builtin, BUILTIN, req, opt, rest) \
1163 scm_set_procedure_property_x (vm_builtin_##builtin, scm_sym_name, \
1164 scm_sym_##builtin); \
1165 scm_set_procedure_minimum_arity_x (vm_builtin_##builtin, \
1166 SCM_I_MAKINUM (req), \
1167 SCM_I_MAKINUM (opt), \
1168 scm_from_bool (rest));
1169 FOR_EACH_VM_BUILTIN (INIT_BUILTIN
);
1174 scm_bootstrap_vm (void)
1176 scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION
,
1178 (scm_t_extension_init_func
)scm_init_vm
, NULL
);
1179 scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION
,
1180 "scm_init_vm_builtins",
1181 (scm_t_extension_init_func
)scm_init_vm_builtins
,
1184 initialize_default_stack_size ();
1186 sym_vm_run
= scm_from_latin1_symbol ("vm-run");
1187 sym_vm_error
= scm_from_latin1_symbol ("vm-error");
1188 sym_keyword_argument_error
= scm_from_latin1_symbol ("keyword-argument-error");
1189 sym_regular
= scm_from_latin1_symbol ("regular");
1190 sym_debug
= scm_from_latin1_symbol ("debug");
1192 vm_boot_continuation
= scm_i_make_program (vm_boot_continuation_code
);
1193 SCM_SET_CELL_WORD_0 (vm_boot_continuation
,
1194 (SCM_CELL_WORD_0 (vm_boot_continuation
)
1195 | SCM_F_PROGRAM_IS_BOOT
));
1197 #define DEFINE_BUILTIN(builtin, BUILTIN, req, opt, rest) \
1198 vm_builtin_##builtin = scm_i_make_program (vm_builtin_##builtin##_code);
1199 FOR_EACH_VM_BUILTIN (DEFINE_BUILTIN
);
1200 #undef DEFINE_BUILTIN
1206 #ifndef SCM_MAGIC_SNARFER
1207 #include "libguile/vm.x"