1 /* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc.
3 * This library is free software; you can redistribute it and/or
4 * modify it under the terms of the GNU Lesser General Public License
5 * as published by the Free Software Foundation; either version 3 of
6 * the License, or (at your option) any later version.
8 * This library is distributed in the hope that it will be useful, but
9 * WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
11 * Lesser General Public License for more details.
13 * You should have received a copy of the GNU Lesser General Public
14 * License along with this library; if not, write to the Free Software
15 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
19 /* For mremap(2) on GNU/Linux systems. */
33 #ifdef HAVE_SYS_MMAN_H
37 #include "libguile/bdw-gc.h"
38 #include <gc/gc_mark.h>
43 #include "instructions.h"
48 #include "vm-builtins.h"
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
];
146 if (vp
->sp
> vp
->sp_max_since_gc
)
147 vp
->sp_max_since_gc
= vp
->sp
;
152 static struct scm_vm
* thread_vm (scm_i_thread
*t
);
154 scm_i_capture_current_stack (void)
156 scm_i_thread
*thread
;
159 thread
= SCM_I_CURRENT_THREAD
;
160 vp
= thread_vm (thread
);
162 return scm_i_vm_capture_stack (vp
->stack_base
, vp
->fp
, vp
->sp
, vp
->ip
,
163 scm_dynstack_capture_all (&thread
->dynstack
),
167 static void vm_dispatch_apply_hook (struct scm_vm
*vp
) SCM_NOINLINE
;
168 static void vm_dispatch_push_continuation_hook (struct scm_vm
*vp
) SCM_NOINLINE
;
169 static void vm_dispatch_pop_continuation_hook (struct scm_vm
*vp
, SCM
*old_fp
) SCM_NOINLINE
;
170 static void vm_dispatch_next_hook (struct scm_vm
*vp
) SCM_NOINLINE
;
171 static void vm_dispatch_abort_hook (struct scm_vm
*vp
) SCM_NOINLINE
;
174 vm_dispatch_hook (struct scm_vm
*vp
, int hook_num
, SCM
*argv
, int n
)
177 struct scm_frame c_frame
;
179 int saved_trace_level
;
181 hook
= vp
->hooks
[hook_num
];
183 if (SCM_LIKELY (scm_is_false (hook
))
184 || scm_is_null (SCM_HOOK_PROCEDURES (hook
)))
187 saved_trace_level
= vp
->trace_level
;
190 /* Allocate a frame object on the stack. This is more efficient than calling
191 `scm_c_make_frame ()' to allocate on the heap, but it forces hooks to not
192 capture frame objects.
194 At the same time, procedures such as `frame-procedure' make sense only
195 while the stack frame represented by the frame object is visible, so it
196 seems reasonable to limit the lifetime of frame objects. */
198 c_frame
.stack_holder
= vp
;
199 c_frame
.fp_offset
= vp
->fp
- vp
->stack_base
;
200 c_frame
.sp_offset
= vp
->sp
- vp
->stack_base
;
203 /* Arrange for FRAME to be 8-byte aligned, like any other cell. */
204 frame
= alloca (sizeof (*frame
) + 8);
205 frame
= (scm_t_cell
*) ROUND_UP ((scm_t_uintptr
) frame
, 8UL);
207 frame
->word_0
= SCM_PACK (scm_tc7_frame
| (SCM_VM_FRAME_KIND_VM
<< 8));
208 frame
->word_1
= SCM_PACK_POINTER (&c_frame
);
214 args
[0] = SCM_PACK_POINTER (frame
);
215 scm_c_run_hookn (hook
, args
, 1);
221 args
[0] = SCM_PACK_POINTER (frame
);
223 scm_c_run_hookn (hook
, args
, 2);
230 args
= scm_cons (argv
[n
], args
);
231 scm_c_run_hook (hook
, scm_cons (SCM_PACK_POINTER (frame
), args
));
234 vp
->trace_level
= saved_trace_level
;
238 vm_dispatch_apply_hook (struct scm_vm
*vp
)
240 return vm_dispatch_hook (vp
, SCM_VM_APPLY_HOOK
, NULL
, 0);
242 static void vm_dispatch_push_continuation_hook (struct scm_vm
*vp
)
244 return vm_dispatch_hook (vp
, SCM_VM_PUSH_CONTINUATION_HOOK
, NULL
, 0);
246 static void vm_dispatch_pop_continuation_hook (struct scm_vm
*vp
, SCM
*old_fp
)
248 return vm_dispatch_hook (vp
, SCM_VM_POP_CONTINUATION_HOOK
,
249 &SCM_FRAME_LOCAL (old_fp
, 1),
250 SCM_FRAME_NUM_LOCALS (old_fp
, vp
->sp
) - 1);
252 static void vm_dispatch_next_hook (struct scm_vm
*vp
)
254 return vm_dispatch_hook (vp
, SCM_VM_NEXT_HOOK
, NULL
, 0);
256 static void vm_dispatch_abort_hook (struct scm_vm
*vp
)
258 return vm_dispatch_hook (vp
, SCM_VM_ABORT_CONTINUATION_HOOK
,
259 &SCM_FRAME_LOCAL (vp
->fp
, 1),
260 SCM_FRAME_NUM_LOCALS (vp
->fp
, vp
->sp
) - 1);
264 vm_abort (struct scm_vm
*vp
, SCM tag
,
265 size_t nstack
, SCM
*stack_args
, SCM tail
, SCM
*sp
,
266 scm_i_jmp_buf
*current_registers
) SCM_NORETURN
;
269 vm_abort (struct scm_vm
*vp
, SCM tag
,
270 size_t nstack
, SCM
*stack_args
, SCM tail
, SCM
*sp
,
271 scm_i_jmp_buf
*current_registers
)
277 tail_len
= scm_ilength (tail
);
279 scm_misc_error ("vm-engine", "tail values to abort should be a list",
282 argv
= alloca ((nstack
+ tail_len
) * sizeof (SCM
));
283 for (i
= 0; i
< nstack
; i
++)
284 argv
[i
] = stack_args
[i
];
285 for (; i
< nstack
+ tail_len
; i
++, tail
= scm_cdr (tail
))
286 argv
[i
] = scm_car (tail
);
288 /* FIXME: NULLSTACK (SCM_VM_DATA (vp)->sp - sp) */
291 scm_c_abort (vp
, tag
, nstack
+ tail_len
, argv
, current_registers
);
294 static void vm_expand_stack (struct scm_vm
*vp
) SCM_NOINLINE
;
297 vm_reinstate_partial_continuation (struct scm_vm
*vp
, SCM cont
,
299 scm_t_dynstack
*dynstack
,
300 scm_i_jmp_buf
*registers
)
302 struct scm_vm_cont
*cp
;
303 SCM
*argv_copy
, *base
;
307 argv_copy
= alloca (n
* sizeof(SCM
));
308 memcpy (argv_copy
, argv
, n
* sizeof(SCM
));
310 cp
= SCM_VM_CONT_DATA (cont
);
314 scm_t_ptrdiff saved_stack_height
= vp
->sp
- vp
->stack_base
;
316 base
= SCM_FRAME_LOCALS_ADDRESS (vp
->fp
);
317 reloc
= cp
->reloc
+ (base
- cp
->stack_base
);
319 vp
->sp
= base
+ cp
->stack_size
+ n
+ 1;
320 if (vp
->sp
< vp
->stack_limit
)
323 vm_expand_stack (vp
);
324 vp
->sp
= vp
->stack_base
+ saved_stack_height
;
327 #define RELOC(scm_p) \
328 (((SCM *) (scm_p)) + reloc)
330 memcpy (base
, cp
->stack_base
, cp
->stack_size
* sizeof (SCM
));
332 /* now relocate frame pointers */
335 for (fp
= RELOC (cp
->fp
);
336 SCM_FRAME_LOWER_ADDRESS (fp
) > base
;
337 fp
= SCM_FRAME_DYNAMIC_LINK (fp
))
338 SCM_FRAME_SET_DYNAMIC_LINK (fp
, RELOC (SCM_FRAME_DYNAMIC_LINK (fp
)));
341 vp
->sp
= base
- 1 + cp
->stack_size
;
342 vp
->fp
= RELOC (cp
->fp
);
345 /* Push the arguments. */
346 for (i
= 0; i
< n
; i
++)
349 *vp
->sp
= argv_copy
[i
];
352 if (vp
->sp
> vp
->sp_max_since_gc
)
353 vp
->sp_max_since_gc
= vp
->sp
;
355 /* The prompt captured a slice of the dynamic stack. Here we wind
356 those entries onto the current thread's stack. We also have to
357 relocate any prompts that we see along the way. */
361 for (walk
= SCM_DYNSTACK_FIRST (cp
->dynstack
);
362 SCM_DYNSTACK_TAG (walk
);
363 walk
= SCM_DYNSTACK_NEXT (walk
))
365 scm_t_bits tag
= SCM_DYNSTACK_TAG (walk
);
367 if (SCM_DYNSTACK_TAG_TYPE (tag
) == SCM_DYNSTACK_TYPE_PROMPT
)
368 scm_dynstack_wind_prompt (dynstack
, walk
, reloc
, registers
);
370 scm_dynstack_wind_1 (dynstack
, walk
);
381 static void vm_error (const char *msg
, SCM arg
) SCM_NORETURN
;
382 static void vm_error_bad_instruction (scm_t_uint32 inst
) SCM_NORETURN SCM_NOINLINE
;
383 static void vm_error_unbound (SCM proc
, SCM sym
) SCM_NORETURN SCM_NOINLINE
;
384 static void vm_error_unbound_fluid (SCM proc
, SCM fluid
) SCM_NORETURN SCM_NOINLINE
;
385 static void vm_error_not_a_variable (const char *func_name
, SCM x
) SCM_NORETURN SCM_NOINLINE
;
386 static void vm_error_apply_to_non_list (SCM x
) SCM_NORETURN SCM_NOINLINE
;
387 static void vm_error_kwargs_length_not_even (SCM proc
) SCM_NORETURN SCM_NOINLINE
;
388 static void vm_error_kwargs_invalid_keyword (SCM proc
, SCM obj
) SCM_NORETURN SCM_NOINLINE
;
389 static void vm_error_kwargs_unrecognized_keyword (SCM proc
, SCM kw
) SCM_NORETURN SCM_NOINLINE
;
390 static void vm_error_too_many_args (int nargs
) SCM_NORETURN SCM_NOINLINE
;
391 static void vm_error_wrong_num_args (SCM proc
) SCM_NORETURN SCM_NOINLINE
;
392 static void vm_error_wrong_type_apply (SCM proc
) SCM_NORETURN SCM_NOINLINE
;
393 static void vm_error_stack_underflow (void) SCM_NORETURN SCM_NOINLINE
;
394 static void vm_error_improper_list (SCM x
) SCM_NORETURN SCM_NOINLINE
;
395 static void vm_error_not_a_pair (const char *subr
, SCM x
) SCM_NORETURN SCM_NOINLINE
;
396 static void vm_error_not_a_bytevector (const char *subr
, SCM x
) SCM_NORETURN SCM_NOINLINE
;
397 static void vm_error_not_a_struct (const char *subr
, SCM x
) SCM_NORETURN SCM_NOINLINE
;
398 static void vm_error_no_values (void) SCM_NORETURN SCM_NOINLINE
;
399 static void vm_error_not_enough_values (void) SCM_NORETURN SCM_NOINLINE
;
400 static void vm_error_wrong_number_of_values (scm_t_uint32 expected
) SCM_NORETURN SCM_NOINLINE
;
401 static void vm_error_continuation_not_rewindable (SCM cont
) SCM_NORETURN SCM_NOINLINE
;
402 static void vm_error_bad_wide_string_length (size_t len
) SCM_NORETURN SCM_NOINLINE
;
405 vm_error (const char *msg
, SCM arg
)
407 scm_throw (sym_vm_error
,
408 scm_list_3 (sym_vm_run
, scm_from_latin1_string (msg
),
409 SCM_UNBNDP (arg
) ? SCM_EOL
: scm_list_1 (arg
)));
410 abort(); /* not reached */
414 vm_error_bad_instruction (scm_t_uint32 inst
)
416 vm_error ("VM: Bad instruction: ~s", scm_from_uint32 (inst
));
420 vm_error_unbound (SCM proc
, SCM sym
)
422 scm_error_scm (scm_misc_error_key
, proc
,
423 scm_from_latin1_string ("Unbound variable: ~s"),
424 scm_list_1 (sym
), SCM_BOOL_F
);
428 vm_error_unbound_fluid (SCM proc
, SCM fluid
)
430 scm_error_scm (scm_misc_error_key
, proc
,
431 scm_from_latin1_string ("Unbound fluid: ~s"),
432 scm_list_1 (fluid
), SCM_BOOL_F
);
436 vm_error_not_a_variable (const char *func_name
, SCM x
)
438 scm_error (scm_arg_type_key
, func_name
, "Not a variable: ~S",
439 scm_list_1 (x
), scm_list_1 (x
));
443 vm_error_apply_to_non_list (SCM x
)
445 scm_error (scm_arg_type_key
, "apply", "Apply to non-list: ~S",
446 scm_list_1 (x
), scm_list_1 (x
));
450 vm_error_kwargs_length_not_even (SCM proc
)
452 scm_error_scm (sym_keyword_argument_error
, proc
,
453 scm_from_latin1_string ("Odd length of keyword argument list"),
454 SCM_EOL
, SCM_BOOL_F
);
458 vm_error_kwargs_invalid_keyword (SCM proc
, SCM obj
)
460 scm_error_scm (sym_keyword_argument_error
, proc
,
461 scm_from_latin1_string ("Invalid keyword"),
462 SCM_EOL
, scm_list_1 (obj
));
466 vm_error_kwargs_unrecognized_keyword (SCM proc
, SCM kw
)
468 scm_error_scm (sym_keyword_argument_error
, proc
,
469 scm_from_latin1_string ("Unrecognized keyword"),
470 SCM_EOL
, scm_list_1 (kw
));
474 vm_error_too_many_args (int nargs
)
476 vm_error ("VM: Too many arguments", scm_from_int (nargs
));
480 vm_error_wrong_num_args (SCM proc
)
482 scm_wrong_num_args (proc
);
486 vm_error_wrong_type_apply (SCM proc
)
488 scm_error (scm_arg_type_key
, NULL
, "Wrong type to apply: ~S",
489 scm_list_1 (proc
), scm_list_1 (proc
));
493 vm_error_stack_underflow (void)
495 vm_error ("VM: Stack underflow", SCM_UNDEFINED
);
499 vm_error_improper_list (SCM x
)
501 vm_error ("Expected a proper list, but got object with tail ~s", x
);
505 vm_error_not_a_pair (const char *subr
, SCM x
)
507 scm_wrong_type_arg_msg (subr
, 1, x
, "pair");
511 vm_error_not_a_bytevector (const char *subr
, SCM x
)
513 scm_wrong_type_arg_msg (subr
, 1, x
, "bytevector");
517 vm_error_not_a_struct (const char *subr
, SCM x
)
519 scm_wrong_type_arg_msg (subr
, 1, x
, "struct");
523 vm_error_no_values (void)
525 vm_error ("Zero values returned to single-valued continuation",
530 vm_error_not_enough_values (void)
532 vm_error ("Too few values returned to continuation", SCM_UNDEFINED
);
536 vm_error_wrong_number_of_values (scm_t_uint32 expected
)
538 vm_error ("Wrong number of values returned to continuation (expected ~a)",
539 scm_from_uint32 (expected
));
543 vm_error_continuation_not_rewindable (SCM cont
)
545 vm_error ("Unrewindable partial continuation", cont
);
549 vm_error_bad_wide_string_length (size_t len
)
551 vm_error ("VM: Bad wide string length: ~S", scm_from_size_t (len
));
557 static SCM vm_boot_continuation
;
558 static SCM vm_builtin_apply
;
559 static SCM vm_builtin_values
;
560 static SCM vm_builtin_abort_to_prompt
;
561 static SCM vm_builtin_call_with_values
;
562 static SCM vm_builtin_call_with_current_continuation
;
564 static const scm_t_uint32 vm_boot_continuation_code
[] = {
565 SCM_PACK_OP_24 (halt
, 0)
568 static const scm_t_uint32 vm_builtin_apply_code
[] = {
569 SCM_PACK_OP_24 (assert_nargs_ge
, 3),
570 SCM_PACK_OP_24 (tail_apply
, 0), /* proc in r1, args from r2 */
573 static const scm_t_uint32 vm_builtin_values_code
[] = {
574 SCM_PACK_OP_24 (return_values
, 0) /* vals from r1 */
577 static const scm_t_uint32 vm_builtin_abort_to_prompt_code
[] = {
578 SCM_PACK_OP_24 (assert_nargs_ge
, 2),
579 SCM_PACK_OP_24 (abort
, 0), /* tag in r1, vals from r2 */
580 /* FIXME: Partial continuation should capture caller regs. */
581 SCM_PACK_OP_24 (return_values
, 0) /* vals from r1 */
584 static const scm_t_uint32 vm_builtin_call_with_values_code
[] = {
585 SCM_PACK_OP_24 (assert_nargs_ee
, 3),
586 SCM_PACK_OP_24 (alloc_frame
, 7),
587 SCM_PACK_OP_12_12 (mov
, 6, 1),
588 SCM_PACK_OP_24 (call
, 6), SCM_PACK_OP_ARG_8_24 (0, 1),
589 SCM_PACK_OP_12_12 (mov
, 0, 2),
590 SCM_PACK_OP_24 (tail_call_shuffle
, 7)
593 static const scm_t_uint32 vm_builtin_call_with_current_continuation_code
[] = {
594 SCM_PACK_OP_24 (assert_nargs_ee
, 2),
595 SCM_PACK_OP_24 (call_cc
, 0)
600 scm_vm_builtin_ref (unsigned idx
)
604 #define INDEX_TO_NAME(builtin, BUILTIN, req, opt, rest) \
605 case SCM_VM_BUILTIN_##BUILTIN: return vm_builtin_##builtin;
606 FOR_EACH_VM_BUILTIN(INDEX_TO_NAME
)
613 static SCM scm_sym_values
;
614 static SCM scm_sym_abort_to_prompt
;
615 static SCM scm_sym_call_with_values
;
616 static SCM scm_sym_call_with_current_continuation
;
619 scm_vm_builtin_name_to_index (SCM name
)
620 #define FUNC_NAME "builtin-name->index"
622 SCM_VALIDATE_SYMBOL (1, name
);
624 #define NAME_TO_INDEX(builtin, BUILTIN, req, opt, rest) \
625 if (scm_is_eq (name, scm_sym_##builtin)) \
626 return scm_from_uint (SCM_VM_BUILTIN_##BUILTIN);
627 FOR_EACH_VM_BUILTIN(NAME_TO_INDEX
)
635 scm_vm_builtin_index_to_name (SCM index
)
636 #define FUNC_NAME "builtin-index->name"
640 SCM_VALIDATE_UINT_COPY (1, index
, idx
);
644 #define INDEX_TO_NAME(builtin, BUILTIN, req, opt, rest) \
645 case SCM_VM_BUILTIN_##BUILTIN: return scm_sym_##builtin;
646 FOR_EACH_VM_BUILTIN(INDEX_TO_NAME
)
648 default: return SCM_BOOL_F
;
654 scm_init_vm_builtins (void)
656 scm_c_define_gsubr ("builtin-name->index", 1, 0, 0,
657 scm_vm_builtin_name_to_index
);
658 scm_c_define_gsubr ("builtin-index->name", 1, 0, 0,
659 scm_vm_builtin_index_to_name
);
663 scm_i_call_with_current_continuation (SCM proc
)
665 return scm_call_1 (vm_builtin_call_with_current_continuation
, proc
);
673 /* Hard stack limit is 512M words: 2 gigabytes on 32-bit machines, 4 on
675 static const size_t hard_max_stack_size
= 512 * 1024 * 1024;
677 /* Initial stack size: 4 or 8 kB. */
678 static const size_t initial_stack_size
= 1024;
680 /* Default soft stack limit is 1M words (4 or 8 megabytes). */
681 static size_t default_max_stack_size
= 1024 * 1024;
684 initialize_default_stack_size (void)
686 int size
= scm_getenv_int ("GUILE_STACK_SIZE", (int) default_max_stack_size
);
687 if (size
>= initial_stack_size
&& (size_t) size
< ((size_t) -1) / sizeof(SCM
))
688 default_max_stack_size
= size
;
691 #define VM_NAME vm_regular_engine
692 #define VM_USE_HOOKS 0
693 #define FUNC_NAME "vm-regular-engine"
694 #include "vm-engine.c"
699 #define VM_NAME vm_debug_engine
700 #define VM_USE_HOOKS 1
701 #define FUNC_NAME "vm-debug-engine"
702 #include "vm-engine.c"
707 typedef SCM (*scm_t_vm_engine
) (scm_i_thread
*current_thread
, struct scm_vm
*vp
,
708 scm_i_jmp_buf
*registers
, int resume
);
710 static const scm_t_vm_engine vm_engines
[SCM_VM_NUM_ENGINES
] =
711 { vm_regular_engine
, vm_debug_engine
};
714 allocate_stack (size_t size
)
715 #define FUNC_NAME "make_vm"
719 if (size
>= ((size_t) -1) / sizeof (SCM
))
722 size
*= sizeof (SCM
);
725 ret
= mmap (NULL
, size
, PROT_READ
| PROT_WRITE
,
726 MAP_PRIVATE
| MAP_ANONYMOUS
, -1, 0);
727 if (ret
== MAP_FAILED
)
740 free_stack (SCM
*stack
, size_t size
)
742 size
*= sizeof (SCM
);
745 munmap (stack
, size
);
752 expand_stack (SCM
*old_stack
, size_t old_size
, size_t new_size
)
753 #define FUNC_NAME "expand_stack"
755 #if defined MREMAP_MAYMOVE
758 if (new_size
>= ((size_t) -1) / sizeof (SCM
))
761 old_size
*= sizeof (SCM
);
762 new_size
*= sizeof (SCM
);
764 new_stack
= mremap (old_stack
, old_size
, new_size
, MREMAP_MAYMOVE
);
765 if (new_stack
== MAP_FAILED
)
768 return (SCM
*) new_stack
;
772 new_stack
= allocate_stack (new_size
);
773 memcpy (new_stack
, old_stack
, old_size
* sizeof (SCM
));
774 free_stack (old_stack
, old_size
);
781 static struct scm_vm
*
783 #define FUNC_NAME "make_vm"
788 vp
= scm_gc_malloc (sizeof (struct scm_vm
), "vm");
790 vp
->stack_size
= initial_stack_size
;
791 vp
->stack_base
= allocate_stack (vp
->stack_size
);
792 vp
->stack_limit
= vp
->stack_base
+ vp
->stack_size
;
793 vp
->max_stack_size
= default_max_stack_size
;
795 vp
->sp
= vp
->stack_base
- 1;
797 vp
->engine
= vm_default_engine
;
799 for (i
= 0; i
< SCM_VM_NUM_HOOKS
; i
++)
800 vp
->hooks
[i
] = SCM_BOOL_F
;
806 static size_t page_size
;
809 return_unused_stack_to_os (struct scm_vm
*vp
)
812 scm_t_uintptr start
= (scm_t_uintptr
) vp
->sp
;
813 scm_t_uintptr end
= (scm_t_uintptr
) vp
->sp_max_since_gc
;
815 start
= ((start
- 1U) | (page_size
- 1U)) + 1U; /* round up */
816 end
= ((end
- 1U) | (page_size
- 1U)) + 1U; /* round up */
818 /* Return these pages to the OS. The next time they are paged in,
819 they will be zeroed. */
821 madvise ((void *) start
, end
- start
, MADV_DONTNEED
);
823 vp
->sp_max_since_gc
= vp
->sp
;
827 /* Mark the VM stack region between its base and its current top. */
829 scm_i_vm_mark_stack (struct scm_vm
*vp
, struct GC_ms_entry
*mark_stack_ptr
,
830 struct GC_ms_entry
*mark_stack_limit
)
833 /* The first frame will be marked conservatively (without a dead
834 slot map). This is because GC can happen at any point within the
835 hottest activation, due to multiple threads or per-instruction
836 hooks, and providing dead slot maps for all points in a program
837 would take a prohibitive amount of space. */
838 const scm_t_uint8
*dead_slots
= NULL
;
839 scm_t_uintptr upper
= (scm_t_uintptr
) GC_greatest_plausible_heap_addr
;
840 scm_t_uintptr lower
= (scm_t_uintptr
) GC_least_plausible_heap_addr
;
842 for (fp
= vp
->fp
, sp
= vp
->sp
; fp
; fp
= SCM_FRAME_DYNAMIC_LINK (fp
))
844 for (; sp
>= &SCM_FRAME_LOCAL (fp
, 0); sp
--)
848 && SCM_UNPACK (elt
) >= lower
&& SCM_UNPACK (elt
) <= upper
)
852 size_t slot
= sp
- &SCM_FRAME_LOCAL (fp
, 0);
853 if (dead_slots
[slot
/ 8U] & (1U << (slot
% 8U)))
855 /* This value may become dead as a result of GC,
856 so we can't just leave it on the stack. */
862 mark_stack_ptr
= GC_mark_and_push ((void *) elt
,
868 sp
= SCM_FRAME_PREVIOUS_SP (fp
);
869 /* Inner frames may have a dead slots map for precise marking.
870 Note that there may be other reasons to not have a dead slots
871 map, e.g. if all of the frame's slots below the callee frame
874 scm_find_dead_slot_map_unlocked (SCM_FRAME_RETURN_ADDRESS (fp
));
877 return_unused_stack_to_os (vp
);
879 return mark_stack_ptr
;
882 /* Free the VM stack, as this thread is exiting. */
884 scm_i_vm_free_stack (struct scm_vm
*vp
)
886 free_stack (vp
->stack_base
, vp
->stack_size
);
887 vp
->stack_base
= vp
->stack_limit
= NULL
;
892 vm_expand_stack (struct scm_vm
*vp
)
894 scm_t_ptrdiff stack_size
= vp
->sp
+ 1 - vp
->stack_base
;
896 if (stack_size
> hard_max_stack_size
)
898 /* We have expanded the soft limit to the point that we reached a
899 hard limit. There is nothing sensible to do. */
900 fprintf (stderr
, "Hard stack size limit (%zu words) reached; aborting.\n",
901 hard_max_stack_size
);
905 if (stack_size
> vp
->stack_size
)
911 new_size
= vp
->stack_size
;
912 while (new_size
< stack_size
)
914 old_stack
= vp
->stack_base
;
915 vp
->stack_base
= expand_stack (old_stack
, vp
->stack_size
, new_size
);
916 vp
->stack_size
= new_size
;
917 vp
->stack_limit
= vp
->stack_base
+ new_size
;
918 reloc
= vp
->stack_base
- old_stack
;
925 vp
->sp_max_since_gc
+= reloc
;
929 SCM
*next_fp
= SCM_FRAME_DYNAMIC_LINK (fp
);
933 SCM_FRAME_SET_DYNAMIC_LINK (fp
, next_fp
);
940 if (stack_size
>= vp
->max_stack_size
)
942 /* Expand the soft limit by 256K entries to give us space to
944 vp
->max_stack_size
+= 256 * 1024;
946 /* If it's still not big enough... it's quite improbable, but go
947 ahead and set to the full available stack size. */
948 if (vp
->max_stack_size
< stack_size
)
949 vp
->max_stack_size
= vp
->stack_size
;
951 /* But don't exceed the hard maximum. */
952 if (vp
->max_stack_size
> hard_max_stack_size
)
953 vp
->max_stack_size
= hard_max_stack_size
;
955 /* Finally, reset the limit, to catch further overflows. */
956 vp
->stack_limit
= vp
->stack_base
+ vp
->max_stack_size
;
958 vm_error ("VM: Stack overflow", SCM_UNDEFINED
);
961 /* Otherwise continue, with the new enlarged stack. */
964 static struct scm_vm
*
965 thread_vm (scm_i_thread
*t
)
967 if (SCM_UNLIKELY (!t
->vp
))
976 return thread_vm (SCM_I_CURRENT_THREAD
);
980 scm_call_n (SCM proc
, SCM
*argv
, size_t nargs
)
982 scm_i_thread
*thread
;
985 ptrdiff_t base_frame_size
;
986 /* Cached variables. */
987 scm_i_jmp_buf registers
; /* used for prompts */
990 thread
= SCM_I_CURRENT_THREAD
;
991 vp
= thread_vm (thread
);
995 /* Check that we have enough space: 3 words for the boot
996 continuation, 3 + nargs for the procedure application, and 3 for
997 setting up a new frame. */
998 base_frame_size
= 3 + 3 + nargs
+ 3;
999 vp
->sp
+= base_frame_size
;
1000 if (vp
->sp
>= vp
->stack_limit
)
1001 vm_expand_stack (vp
);
1002 base
= vp
->sp
+ 1 - base_frame_size
;
1004 /* Since it's possible to receive the arguments on the stack itself,
1005 shuffle up the arguments first. */
1006 for (i
= nargs
; i
> 0; i
--)
1007 base
[6 + i
- 1] = argv
[i
- 1];
1009 /* Push the boot continuation, which calls PROC and returns its
1011 base
[0] = SCM_PACK (vp
->fp
); /* dynamic link */
1012 base
[1] = SCM_PACK (vp
->ip
); /* ra */
1013 base
[2] = vm_boot_continuation
;
1015 vp
->ip
= (scm_t_uint32
*) vm_boot_continuation_code
;
1017 /* The pending call to PROC. */
1018 base
[3] = SCM_PACK (vp
->fp
); /* dynamic link */
1019 base
[4] = SCM_PACK (vp
->ip
); /* ra */
1022 vp
->sp
= &SCM_FRAME_LOCAL (vp
->fp
, nargs
);
1024 if (vp
->sp
> vp
->sp_max_since_gc
)
1025 vp
->sp_max_since_gc
= vp
->sp
;
1028 int resume
= SCM_I_SETJMP (registers
);
1030 if (SCM_UNLIKELY (resume
))
1031 /* Non-local return. */
1032 vm_dispatch_abort_hook (vp
);
1034 return vm_engines
[vp
->engine
](thread
, vp
, ®isters
, resume
);
1038 /* Scheme interface */
1040 #define VM_DEFINE_HOOK(n) \
1042 struct scm_vm *vp; \
1043 vp = scm_the_vm (); \
1044 if (scm_is_false (vp->hooks[n])) \
1045 vp->hooks[n] = scm_make_hook (SCM_I_MAKINUM (1)); \
1046 return vp->hooks[n]; \
1049 SCM_DEFINE (scm_vm_apply_hook
, "vm-apply-hook", 0, 0, 0,
1052 #define FUNC_NAME s_scm_vm_apply_hook
1054 VM_DEFINE_HOOK (SCM_VM_APPLY_HOOK
);
1058 SCM_DEFINE (scm_vm_push_continuation_hook
, "vm-push-continuation-hook", 0, 0, 0,
1061 #define FUNC_NAME s_scm_vm_push_continuation_hook
1063 VM_DEFINE_HOOK (SCM_VM_PUSH_CONTINUATION_HOOK
);
1067 SCM_DEFINE (scm_vm_pop_continuation_hook
, "vm-pop-continuation-hook", 0, 0, 0,
1070 #define FUNC_NAME s_scm_vm_pop_continuation_hook
1072 VM_DEFINE_HOOK (SCM_VM_POP_CONTINUATION_HOOK
);
1076 SCM_DEFINE (scm_vm_next_hook
, "vm-next-hook", 0, 0, 0,
1079 #define FUNC_NAME s_scm_vm_next_hook
1081 VM_DEFINE_HOOK (SCM_VM_NEXT_HOOK
);
1085 SCM_DEFINE (scm_vm_abort_continuation_hook
, "vm-abort-continuation-hook", 0, 0, 0,
1088 #define FUNC_NAME s_scm_vm_abort_continuation_hook
1090 VM_DEFINE_HOOK (SCM_VM_ABORT_CONTINUATION_HOOK
);
1094 SCM_DEFINE (scm_vm_trace_level
, "vm-trace-level", 0, 0, 0,
1097 #define FUNC_NAME s_scm_vm_trace_level
1099 return scm_from_int (scm_the_vm ()->trace_level
);
1103 SCM_DEFINE (scm_set_vm_trace_level_x
, "set-vm-trace-level!", 1, 0, 0,
1106 #define FUNC_NAME s_scm_set_vm_trace_level_x
1108 scm_the_vm ()->trace_level
= scm_to_int (level
);
1109 return SCM_UNSPECIFIED
;
1119 symbol_to_vm_engine (SCM engine
, const char *FUNC_NAME
)
1121 if (scm_is_eq (engine
, sym_regular
))
1122 return SCM_VM_REGULAR_ENGINE
;
1123 else if (scm_is_eq (engine
, sym_debug
))
1124 return SCM_VM_DEBUG_ENGINE
;
1126 SCM_MISC_ERROR ("Unknown VM engine: ~a", scm_list_1 (engine
));
1130 vm_engine_to_symbol (int engine
, const char *FUNC_NAME
)
1134 case SCM_VM_REGULAR_ENGINE
:
1136 case SCM_VM_DEBUG_ENGINE
:
1140 SCM_MISC_ERROR ("Unknown VM engine: ~a",
1141 scm_list_1 (scm_from_int (engine
)));
1145 SCM_DEFINE (scm_vm_engine
, "vm-engine", 0, 0, 0,
1148 #define FUNC_NAME s_scm_vm_engine
1150 return vm_engine_to_symbol (scm_the_vm ()->engine
, FUNC_NAME
);
1155 scm_c_set_vm_engine_x (int engine
)
1156 #define FUNC_NAME "set-vm-engine!"
1158 if (engine
< 0 || engine
>= SCM_VM_NUM_ENGINES
)
1159 SCM_MISC_ERROR ("Unknown VM engine: ~a",
1160 scm_list_1 (scm_from_int (engine
)));
1162 scm_the_vm ()->engine
= engine
;
1166 SCM_DEFINE (scm_set_vm_engine_x
, "set-vm-engine!", 1, 0, 0,
1169 #define FUNC_NAME s_scm_set_vm_engine_x
1171 scm_c_set_vm_engine_x (symbol_to_vm_engine (engine
, FUNC_NAME
));
1172 return SCM_UNSPECIFIED
;
1177 scm_c_set_default_vm_engine_x (int engine
)
1178 #define FUNC_NAME "set-default-vm-engine!"
1180 if (engine
< 0 || engine
>= SCM_VM_NUM_ENGINES
)
1181 SCM_MISC_ERROR ("Unknown VM engine: ~a",
1182 scm_list_1 (scm_from_int (engine
)));
1184 vm_default_engine
= engine
;
1188 SCM_DEFINE (scm_set_default_vm_engine_x
, "set-default-vm-engine!", 1, 0, 0,
1191 #define FUNC_NAME s_scm_set_default_vm_engine_x
1193 scm_c_set_default_vm_engine_x (symbol_to_vm_engine (engine
, FUNC_NAME
));
1194 return SCM_UNSPECIFIED
;
1198 /* FIXME: This function makes no sense, but we keep it to make sure we
1199 have a way of switching to the debug or regular VM. */
1200 SCM_DEFINE (scm_call_with_vm
, "call-with-vm", 1, 0, 1,
1201 (SCM proc
, SCM args
),
1202 "Apply @var{proc} to @var{args} in a dynamic extent in which\n"
1203 "@var{vm} is the current VM.")
1204 #define FUNC_NAME s_scm_call_with_vm
1206 return scm_apply_0 (proc
, args
);
1216 scm_load_compiled_with_vm (SCM file
)
1218 return scm_call_0 (scm_load_thunk_from_file (file
));
1223 scm_init_vm_builtin_properties (void)
1225 /* FIXME: Seems hacky to do this here, but oh well :/ */
1226 scm_sym_apply
= scm_from_utf8_symbol ("apply");
1227 scm_sym_values
= scm_from_utf8_symbol ("values");
1228 scm_sym_abort_to_prompt
= scm_from_utf8_symbol ("abort-to-prompt");
1229 scm_sym_call_with_values
= scm_from_utf8_symbol ("call-with-values");
1230 scm_sym_call_with_current_continuation
=
1231 scm_from_utf8_symbol ("call-with-current-continuation");
1233 #define INIT_BUILTIN(builtin, BUILTIN, req, opt, rest) \
1234 scm_set_procedure_property_x (vm_builtin_##builtin, scm_sym_name, \
1235 scm_sym_##builtin); \
1236 scm_set_procedure_minimum_arity_x (vm_builtin_##builtin, \
1237 SCM_I_MAKINUM (req), \
1238 SCM_I_MAKINUM (opt), \
1239 scm_from_bool (rest));
1240 FOR_EACH_VM_BUILTIN (INIT_BUILTIN
);
1245 scm_bootstrap_vm (void)
1247 scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION
,
1249 (scm_t_extension_init_func
)scm_init_vm
, NULL
);
1250 scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION
,
1251 "scm_init_vm_builtins",
1252 (scm_t_extension_init_func
)scm_init_vm_builtins
,
1255 page_size
= getpagesize ();
1256 /* page_size should be a power of two. */
1257 if (page_size
& (page_size
- 1))
1260 initialize_default_stack_size ();
1262 sym_vm_run
= scm_from_latin1_symbol ("vm-run");
1263 sym_vm_error
= scm_from_latin1_symbol ("vm-error");
1264 sym_keyword_argument_error
= scm_from_latin1_symbol ("keyword-argument-error");
1265 sym_regular
= scm_from_latin1_symbol ("regular");
1266 sym_debug
= scm_from_latin1_symbol ("debug");
1268 vm_boot_continuation
= scm_i_make_program (vm_boot_continuation_code
);
1269 SCM_SET_CELL_WORD_0 (vm_boot_continuation
,
1270 (SCM_CELL_WORD_0 (vm_boot_continuation
)
1271 | SCM_F_PROGRAM_IS_BOOT
));
1273 #define DEFINE_BUILTIN(builtin, BUILTIN, req, opt, rest) \
1274 vm_builtin_##builtin = scm_i_make_program (vm_builtin_##builtin##_code);
1275 FOR_EACH_VM_BUILTIN (DEFINE_BUILTIN
);
1276 #undef DEFINE_BUILTIN
1282 #ifndef SCM_MAGIC_SNARFER
1283 #include "libguile/vm.x"