Commit | Line | Data |
---|---|---|
aab9d46c | 1 | /* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc. |
a98cef7e | 2 | * |
560b9c25 | 3 | * This library is free software; you can redistribute it and/or |
53befeb7 NJ |
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. | |
a98cef7e | 7 | * |
53befeb7 NJ |
8 | * This library is distributed in the hope that it will be useful, but |
9 | * WITHOUT ANY WARRANTY; without even the implied warranty of | |
560b9c25 AW |
10 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
11 | * Lesser General Public License for more details. | |
a98cef7e | 12 | * |
560b9c25 AW |
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 | |
53befeb7 NJ |
15 | * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA |
16 | * 02110-1301 USA | |
560b9c25 | 17 | */ |
a98cef7e | 18 | |
22d425ec AW |
19 | /* For mremap(2) on GNU/Linux systems. */ |
20 | #define _GNU_SOURCE | |
21 | ||
13c47753 AW |
22 | #if HAVE_CONFIG_H |
23 | # include <config.h> | |
24 | #endif | |
25 | ||
da8b4747 | 26 | #include <stdlib.h> |
6d14383e | 27 | #include <alloca.h> |
daccfef4 | 28 | #include <alignof.h> |
17e90c5e | 29 | #include <string.h> |
e78d4bf9 | 30 | #include <stdint.h> |
e3eb628d | 31 | |
5f18bc84 AW |
32 | #ifdef HAVE_SYS_MMAN_H |
33 | #include <sys/mman.h> | |
34 | #endif | |
35 | ||
1c44468d | 36 | #include "libguile/bdw-gc.h" |
e3eb628d LC |
37 | #include <gc/gc_mark.h> |
38 | ||
560b9c25 | 39 | #include "_scm.h" |
adaf86ec | 40 | #include "control.h" |
ac99cb0c | 41 | #include "frames.h" |
17e90c5e | 42 | #include "instructions.h" |
4cbc95f1 | 43 | #include "loader.h" |
ac99cb0c | 44 | #include "programs.h" |
87fc4596 | 45 | #include "simpos.h" |
a98cef7e | 46 | #include "vm.h" |
486013d6 | 47 | #include "vm-builtins.h" |
a98cef7e | 48 | |
97b18a66 | 49 | static int vm_default_engine = SCM_VM_REGULAR_ENGINE; |
ea9f4f4b AW |
50 | |
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; | |
57 | static SCM sym_debug; | |
a98cef7e | 58 | |
11ea1aba AW |
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 | |
62 | ||
53e28ed9 AW |
63 | /* #define VM_ENABLE_PARANOID_ASSERTIONS */ |
64 | ||
e3eb628d | 65 | |
a98cef7e | 66 | \f |
a98cef7e KN |
67 | /* |
68 | * VM Continuation | |
69 | */ | |
70 | ||
6f3b0cc2 AW |
71 | void |
72 | scm_i_vm_cont_print (SCM x, SCM port, scm_print_state *pstate) | |
73 | { | |
0607ebbf | 74 | scm_puts_unlocked ("#<vm-continuation ", port); |
6f3b0cc2 | 75 | scm_uintprint (SCM_UNPACK (x), 16, port); |
0607ebbf | 76 | scm_puts_unlocked (">", port); |
6f3b0cc2 | 77 | } |
17e90c5e | 78 | |
d8873dfe AW |
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. | |
85 | ||
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. | |
89 | */ | |
cee1d22c | 90 | SCM |
9121d9f1 | 91 | scm_i_vm_capture_stack (SCM *stack_base, SCM *fp, SCM *sp, scm_t_uint32 *ra, |
840ec334 | 92 | scm_t_dynstack *dynstack, scm_t_uint32 flags) |
a98cef7e | 93 | { |
d8873dfe AW |
94 | struct scm_vm_cont *p; |
95 | ||
96 | p = scm_gc_malloc (sizeof (*p), "capture_vm_cont"); | |
97 | p->stack_size = sp - stack_base + 1; | |
d8eeb67c LC |
98 | p->stack_base = scm_gc_malloc (p->stack_size * sizeof (SCM), |
99 | "capture_vm_cont"); | |
d8873dfe | 100 | p->ra = ra; |
d8873dfe AW |
101 | p->sp = sp; |
102 | p->fp = fp; | |
103 | memcpy (p->stack_base, stack_base, (sp + 1 - stack_base) * sizeof (SCM)); | |
104 | p->reloc = p->stack_base - stack_base; | |
9ede013f | 105 | p->dynstack = dynstack; |
cee1d22c | 106 | p->flags = flags; |
6f3b0cc2 | 107 | return scm_cell (scm_tc7_vm_cont, (scm_t_bits)p); |
a98cef7e KN |
108 | } |
109 | ||
110 | static void | |
796e54a7 | 111 | vm_return_to_continuation (struct scm_vm *vp, SCM cont, size_t n, SCM *argv) |
a98cef7e | 112 | { |
d8873dfe AW |
113 | struct scm_vm_cont *cp; |
114 | SCM *argv_copy; | |
115 | ||
116 | argv_copy = alloca (n * sizeof(SCM)); | |
117 | memcpy (argv_copy, argv, n * sizeof(SCM)); | |
118 | ||
d8873dfe AW |
119 | cp = SCM_VM_CONT_DATA (cont); |
120 | ||
f8085163 | 121 | if (vp->stack_size < cp->stack_size + n + 3) |
29366989 | 122 | scm_misc_error ("vm-engine", "not enough space to reinstate continuation", |
796e54a7 | 123 | scm_list_1 (cont)); |
29366989 | 124 | |
d8873dfe AW |
125 | vp->sp = cp->sp; |
126 | vp->fp = cp->fp; | |
127 | memcpy (vp->stack_base, cp->stack_base, cp->stack_size * sizeof (SCM)); | |
bfffd258 | 128 | |
03f16599 AW |
129 | { |
130 | size_t i; | |
131 | ||
132 | /* Push on an empty frame, as the continuation expects. */ | |
f8085163 | 133 | for (i = 0; i < 3; i++) |
03f16599 AW |
134 | { |
135 | vp->sp++; | |
136 | *vp->sp = SCM_BOOL_F; | |
137 | } | |
138 | ||
139 | /* Push the return values. */ | |
140 | for (i = 0; i < n; i++) | |
141 | { | |
142 | vp->sp++; | |
143 | *vp->sp = argv_copy[i]; | |
144 | } | |
840ec334 | 145 | vp->ip = cp->ra; |
03f16599 | 146 | } |
d8873dfe | 147 | } |
bfffd258 | 148 | |
b85cd20f | 149 | static struct scm_vm * thread_vm (scm_i_thread *t); |
bfffd258 | 150 | SCM |
9ede013f | 151 | scm_i_capture_current_stack (void) |
bfffd258 | 152 | { |
9ede013f | 153 | scm_i_thread *thread; |
9ede013f AW |
154 | struct scm_vm *vp; |
155 | ||
156 | thread = SCM_I_CURRENT_THREAD; | |
b85cd20f | 157 | vp = thread_vm (thread); |
9ede013f | 158 | |
840ec334 | 159 | return scm_i_vm_capture_stack (vp->stack_base, vp->fp, vp->sp, vp->ip, |
9ede013f AW |
160 | scm_dynstack_capture_all (&thread->dynstack), |
161 | 0); | |
a98cef7e KN |
162 | } |
163 | ||
59f85eed AW |
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; | |
c850a0ff | 169 | |
b1b942b7 | 170 | static void |
59f85eed | 171 | vm_dispatch_hook (struct scm_vm *vp, int hook_num, SCM *argv, int n) |
b1b942b7 | 172 | { |
7656f194 | 173 | SCM hook; |
b3567435 | 174 | struct scm_frame c_frame; |
8e4c60ff | 175 | scm_t_cell *frame; |
893fb8d0 | 176 | int saved_trace_level; |
b1b942b7 | 177 | |
7656f194 | 178 | hook = vp->hooks[hook_num]; |
b1b942b7 | 179 | |
7656f194 AW |
180 | if (SCM_LIKELY (scm_is_false (hook)) |
181 | || scm_is_null (SCM_HOOK_PROCEDURES (hook))) | |
182 | return; | |
b3567435 | 183 | |
893fb8d0 AW |
184 | saved_trace_level = vp->trace_level; |
185 | vp->trace_level = 0; | |
b3567435 LC |
186 | |
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. | |
190 | ||
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. */ | |
194 | ||
5515edc5 | 195 | c_frame.stack_holder = vp; |
89b235af AW |
196 | c_frame.fp_offset = vp->fp - vp->stack_base; |
197 | c_frame.sp_offset = vp->sp - vp->stack_base; | |
b3567435 | 198 | c_frame.ip = vp->ip; |
8e4c60ff LC |
199 | |
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); | |
203 | ||
050a40db | 204 | frame->word_0 = SCM_PACK (scm_tc7_frame | (SCM_VM_FRAME_KIND_VM << 8)); |
21041372 | 205 | frame->word_1 = SCM_PACK_POINTER (&c_frame); |
b3567435 | 206 | |
c850a0ff AW |
207 | if (n == 0) |
208 | { | |
209 | SCM args[1]; | |
210 | ||
211 | args[0] = SCM_PACK_POINTER (frame); | |
212 | scm_c_run_hookn (hook, args, 1); | |
213 | } | |
214 | else if (n == 1) | |
215 | { | |
216 | SCM args[2]; | |
217 | ||
218 | args[0] = SCM_PACK_POINTER (frame); | |
219 | args[1] = argv[0]; | |
220 | scm_c_run_hookn (hook, args, 2); | |
221 | } | |
222 | else | |
223 | { | |
224 | SCM args = SCM_EOL; | |
225 | ||
226 | while (n--) | |
227 | args = scm_cons (argv[n], args); | |
228 | scm_c_run_hook (hook, scm_cons (SCM_PACK_POINTER (frame), args)); | |
229 | } | |
b3567435 | 230 | |
893fb8d0 | 231 | vp->trace_level = saved_trace_level; |
b1b942b7 AW |
232 | } |
233 | ||
ea0cd17d | 234 | static void |
59f85eed | 235 | vm_dispatch_apply_hook (struct scm_vm *vp) |
ea0cd17d | 236 | { |
59f85eed | 237 | return vm_dispatch_hook (vp, SCM_VM_APPLY_HOOK, NULL, 0); |
ea0cd17d | 238 | } |
59f85eed | 239 | static void vm_dispatch_push_continuation_hook (struct scm_vm *vp) |
ea0cd17d | 240 | { |
59f85eed | 241 | return vm_dispatch_hook (vp, SCM_VM_PUSH_CONTINUATION_HOOK, NULL, 0); |
ea0cd17d | 242 | } |
59f85eed | 243 | static void vm_dispatch_pop_continuation_hook (struct scm_vm *vp, SCM *old_fp) |
ea0cd17d | 244 | { |
59f85eed | 245 | return vm_dispatch_hook (vp, SCM_VM_POP_CONTINUATION_HOOK, |
ea0cd17d AW |
246 | &SCM_FRAME_LOCAL (old_fp, 1), |
247 | SCM_FRAME_NUM_LOCALS (old_fp, vp->sp) - 1); | |
248 | } | |
59f85eed | 249 | static void vm_dispatch_next_hook (struct scm_vm *vp) |
ea0cd17d | 250 | { |
59f85eed | 251 | return vm_dispatch_hook (vp, SCM_VM_NEXT_HOOK, NULL, 0); |
ea0cd17d | 252 | } |
59f85eed | 253 | static void vm_dispatch_abort_hook (struct scm_vm *vp) |
ea0cd17d | 254 | { |
59f85eed | 255 | return vm_dispatch_hook (vp, SCM_VM_ABORT_CONTINUATION_HOOK, |
ea0cd17d AW |
256 | &SCM_FRAME_LOCAL (vp->fp, 1), |
257 | SCM_FRAME_NUM_LOCALS (vp->fp, vp->sp) - 1); | |
258 | } | |
ea0cd17d | 259 | |
4f66bcde | 260 | static void |
b44f5451 AW |
261 | vm_abort (struct scm_vm *vp, SCM tag, |
262 | size_t nstack, SCM *stack_args, SCM tail, SCM *sp, | |
99511cd0 | 263 | scm_i_jmp_buf *current_registers) SCM_NORETURN; |
9d381ba4 AW |
264 | |
265 | static void | |
b44f5451 AW |
266 | vm_abort (struct scm_vm *vp, SCM tag, |
267 | size_t nstack, SCM *stack_args, SCM tail, SCM *sp, | |
99511cd0 | 268 | scm_i_jmp_buf *current_registers) |
4f66bcde | 269 | { |
eaefabee | 270 | size_t i; |
2d026f04 | 271 | ssize_t tail_len; |
99511cd0 | 272 | SCM *argv; |
eaefabee | 273 | |
2d026f04 AW |
274 | tail_len = scm_ilength (tail); |
275 | if (tail_len < 0) | |
29366989 AW |
276 | scm_misc_error ("vm-engine", "tail values to abort should be a list", |
277 | scm_list_1 (tail)); | |
278 | ||
99511cd0 AW |
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)) | |
2d026f04 | 283 | argv[i] = scm_car (tail); |
eaefabee | 284 | |
99511cd0 | 285 | /* FIXME: NULLSTACK (SCM_VM_DATA (vp)->sp - sp) */ |
b44f5451 | 286 | vp->sp = sp; |
99511cd0 | 287 | |
b44f5451 | 288 | scm_c_abort (vp, tag, nstack + tail_len, argv, current_registers); |
cee1d22c AW |
289 | } |
290 | ||
9d381ba4 | 291 | static void |
44ece399 AW |
292 | vm_reinstate_partial_continuation (struct scm_vm *vp, SCM cont, |
293 | size_t n, SCM *argv, | |
9d381ba4 AW |
294 | scm_t_dynstack *dynstack, |
295 | scm_i_jmp_buf *registers) | |
cee1d22c | 296 | { |
07801437 AW |
297 | struct scm_vm_cont *cp; |
298 | SCM *argv_copy, *base; | |
9ede013f | 299 | scm_t_ptrdiff reloc; |
07801437 AW |
300 | size_t i; |
301 | ||
302 | argv_copy = alloca (n * sizeof(SCM)); | |
303 | memcpy (argv_copy, argv, n * sizeof(SCM)); | |
304 | ||
07801437 | 305 | cp = SCM_VM_CONT_DATA (cont); |
b636cdb0 | 306 | base = SCM_FRAME_LOCALS_ADDRESS (vp->fp); |
9ede013f | 307 | reloc = cp->reloc + (base - cp->stack_base); |
07801437 | 308 | |
0fc9040f | 309 | #define RELOC(scm_p) \ |
9ede013f | 310 | (((SCM *) (scm_p)) + reloc) |
07801437 AW |
311 | |
312 | if ((base - vp->stack_base) + cp->stack_size + n + 1 > vp->stack_size) | |
29366989 AW |
313 | scm_misc_error ("vm-engine", |
314 | "not enough space to instate partial continuation", | |
44ece399 | 315 | scm_list_1 (cont)); |
07801437 AW |
316 | |
317 | memcpy (base, cp->stack_base, cp->stack_size * sizeof (SCM)); | |
318 | ||
319 | /* now relocate frame pointers */ | |
320 | { | |
321 | SCM *fp; | |
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))); | |
326 | } | |
327 | ||
328 | vp->sp = base - 1 + cp->stack_size; | |
329 | vp->fp = RELOC (cp->fp); | |
840ec334 | 330 | vp->ip = cp->ra; |
07801437 | 331 | |
840ec334 | 332 | /* Push the arguments. */ |
07801437 AW |
333 | for (i = 0; i < n; i++) |
334 | { | |
335 | vp->sp++; | |
336 | *vp->sp = argv_copy[i]; | |
337 | } | |
9a1c6f1f | 338 | |
9d381ba4 AW |
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. */ | |
342 | { | |
343 | scm_t_bits *walk; | |
344 | ||
345 | for (walk = SCM_DYNSTACK_FIRST (cp->dynstack); | |
346 | SCM_DYNSTACK_TAG (walk); | |
347 | walk = SCM_DYNSTACK_NEXT (walk)) | |
348 | { | |
349 | scm_t_bits tag = SCM_DYNSTACK_TAG (walk); | |
350 | ||
351 | if (SCM_DYNSTACK_TAG_TYPE (tag) == SCM_DYNSTACK_TYPE_PROMPT) | |
352 | scm_dynstack_wind_prompt (dynstack, walk, reloc, registers); | |
353 | else | |
354 | scm_dynstack_wind_1 (dynstack, walk); | |
355 | } | |
356 | } | |
adbdfd6d | 357 | #undef RELOC |
4f66bcde AW |
358 | } |
359 | ||
360 | \f | |
53bdfcf0 AW |
361 | /* |
362 | * VM Error Handling | |
363 | */ | |
364 | ||
365 | static void vm_error (const char *msg, SCM arg) SCM_NORETURN; | |
4d497b62 AW |
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; | |
28d5d253 MW |
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; | |
4d497b62 AW |
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; | |
4d497b62 AW |
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; | |
82f4bac4 | 384 | static void vm_error_wrong_number_of_values (scm_t_uint32 expected) SCM_NORETURN SCM_NOINLINE; |
4d497b62 AW |
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; | |
53bdfcf0 AW |
387 | |
388 | static void | |
389 | vm_error (const char *msg, SCM arg) | |
390 | { | |
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 */ | |
395 | } | |
396 | ||
397 | static void | |
398 | vm_error_bad_instruction (scm_t_uint32 inst) | |
399 | { | |
400 | vm_error ("VM: Bad instruction: ~s", scm_from_uint32 (inst)); | |
401 | } | |
402 | ||
403 | static void | |
404 | vm_error_unbound (SCM proc, SCM sym) | |
405 | { | |
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); | |
409 | } | |
410 | ||
411 | static void | |
412 | vm_error_unbound_fluid (SCM proc, SCM fluid) | |
413 | { | |
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); | |
417 | } | |
418 | ||
419 | static void | |
420 | vm_error_not_a_variable (const char *func_name, SCM x) | |
421 | { | |
422 | scm_error (scm_arg_type_key, func_name, "Not a variable: ~S", | |
423 | scm_list_1 (x), scm_list_1 (x)); | |
424 | } | |
425 | ||
53bdfcf0 AW |
426 | static void |
427 | vm_error_apply_to_non_list (SCM x) | |
428 | { | |
429 | scm_error (scm_arg_type_key, "apply", "Apply to non-list: ~S", | |
430 | scm_list_1 (x), scm_list_1 (x)); | |
431 | } | |
432 | ||
433 | static void | |
434 | vm_error_kwargs_length_not_even (SCM proc) | |
435 | { | |
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); | |
439 | } | |
440 | ||
441 | static void | |
4af0d97e | 442 | vm_error_kwargs_invalid_keyword (SCM proc, SCM obj) |
53bdfcf0 AW |
443 | { |
444 | scm_error_scm (sym_keyword_argument_error, proc, | |
445 | scm_from_latin1_string ("Invalid keyword"), | |
4af0d97e | 446 | SCM_EOL, scm_list_1 (obj)); |
53bdfcf0 AW |
447 | } |
448 | ||
449 | static void | |
4af0d97e | 450 | vm_error_kwargs_unrecognized_keyword (SCM proc, SCM kw) |
53bdfcf0 AW |
451 | { |
452 | scm_error_scm (sym_keyword_argument_error, proc, | |
453 | scm_from_latin1_string ("Unrecognized keyword"), | |
4af0d97e | 454 | SCM_EOL, scm_list_1 (kw)); |
53bdfcf0 AW |
455 | } |
456 | ||
457 | static void | |
458 | vm_error_too_many_args (int nargs) | |
459 | { | |
460 | vm_error ("VM: Too many arguments", scm_from_int (nargs)); | |
461 | } | |
462 | ||
463 | static void | |
464 | vm_error_wrong_num_args (SCM proc) | |
465 | { | |
466 | scm_wrong_num_args (proc); | |
467 | } | |
468 | ||
469 | static void | |
470 | vm_error_wrong_type_apply (SCM proc) | |
471 | { | |
472 | scm_error (scm_arg_type_key, NULL, "Wrong type to apply: ~S", | |
473 | scm_list_1 (proc), scm_list_1 (proc)); | |
474 | } | |
475 | ||
53bdfcf0 AW |
476 | static void |
477 | vm_error_stack_underflow (void) | |
478 | { | |
479 | vm_error ("VM: Stack underflow", SCM_UNDEFINED); | |
480 | } | |
481 | ||
482 | static void | |
483 | vm_error_improper_list (SCM x) | |
484 | { | |
485 | vm_error ("Expected a proper list, but got object with tail ~s", x); | |
486 | } | |
487 | ||
488 | static void | |
489 | vm_error_not_a_pair (const char *subr, SCM x) | |
490 | { | |
491 | scm_wrong_type_arg_msg (subr, 1, x, "pair"); | |
492 | } | |
493 | ||
494 | static void | |
495 | vm_error_not_a_bytevector (const char *subr, SCM x) | |
496 | { | |
497 | scm_wrong_type_arg_msg (subr, 1, x, "bytevector"); | |
498 | } | |
499 | ||
500 | static void | |
501 | vm_error_not_a_struct (const char *subr, SCM x) | |
502 | { | |
503 | scm_wrong_type_arg_msg (subr, 1, x, "struct"); | |
504 | } | |
505 | ||
506 | static void | |
507 | vm_error_no_values (void) | |
508 | { | |
509 | vm_error ("Zero values returned to single-valued continuation", | |
510 | SCM_UNDEFINED); | |
511 | } | |
512 | ||
513 | static void | |
514 | vm_error_not_enough_values (void) | |
515 | { | |
516 | vm_error ("Too few values returned to continuation", SCM_UNDEFINED); | |
517 | } | |
518 | ||
82f4bac4 AW |
519 | static void |
520 | vm_error_wrong_number_of_values (scm_t_uint32 expected) | |
521 | { | |
522 | vm_error ("Wrong number of values returned to continuation (expected ~a)", | |
523 | scm_from_uint32 (expected)); | |
524 | } | |
525 | ||
53bdfcf0 AW |
526 | static void |
527 | vm_error_continuation_not_rewindable (SCM cont) | |
528 | { | |
529 | vm_error ("Unrewindable partial continuation", cont); | |
530 | } | |
531 | ||
532 | static void | |
533 | vm_error_bad_wide_string_length (size_t len) | |
534 | { | |
535 | vm_error ("VM: Bad wide string length: ~S", scm_from_size_t (len)); | |
536 | } | |
537 | ||
53bdfcf0 AW |
538 | |
539 | \f | |
28b119ee | 540 | |
ef6b7f71 | 541 | static SCM vm_boot_continuation; |
486013d6 AW |
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; | |
510ca126 | 547 | |
ef6b7f71 | 548 | static const scm_t_uint32 vm_boot_continuation_code[] = { |
095100bb | 549 | SCM_PACK_OP_24 (halt, 0) |
510ca126 AW |
550 | }; |
551 | ||
486013d6 | 552 | static const scm_t_uint32 vm_builtin_apply_code[] = { |
095100bb AW |
553 | SCM_PACK_OP_24 (assert_nargs_ge, 3), |
554 | SCM_PACK_OP_24 (tail_apply, 0), /* proc in r1, args from r2 */ | |
510ca126 AW |
555 | }; |
556 | ||
486013d6 | 557 | static const scm_t_uint32 vm_builtin_values_code[] = { |
095100bb | 558 | SCM_PACK_OP_24 (return_values, 0) /* vals from r1 */ |
510ca126 AW |
559 | }; |
560 | ||
486013d6 | 561 | static const scm_t_uint32 vm_builtin_abort_to_prompt_code[] = { |
095100bb AW |
562 | SCM_PACK_OP_24 (assert_nargs_ge, 2), |
563 | SCM_PACK_OP_24 (abort, 0), /* tag in r1, vals from r2 */ | |
486013d6 | 564 | /* FIXME: Partial continuation should capture caller regs. */ |
095100bb | 565 | SCM_PACK_OP_24 (return_values, 0) /* vals from r1 */ |
486013d6 AW |
566 | }; |
567 | ||
568 | static const scm_t_uint32 vm_builtin_call_with_values_code[] = { | |
095100bb AW |
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) | |
486013d6 AW |
575 | }; |
576 | ||
577 | static const scm_t_uint32 vm_builtin_call_with_current_continuation_code[] = { | |
095100bb AW |
578 | SCM_PACK_OP_24 (assert_nargs_ee, 2), |
579 | SCM_PACK_OP_24 (call_cc, 0) | |
486013d6 AW |
580 | }; |
581 | ||
582 | ||
583 | static SCM | |
584 | scm_vm_builtin_ref (unsigned idx) | |
585 | { | |
586 | switch (idx) | |
587 | { | |
9f309e2c | 588 | #define INDEX_TO_NAME(builtin, BUILTIN, req, opt, rest) \ |
486013d6 AW |
589 | case SCM_VM_BUILTIN_##BUILTIN: return vm_builtin_##builtin; |
590 | FOR_EACH_VM_BUILTIN(INDEX_TO_NAME) | |
591 | #undef INDEX_TO_NAME | |
592 | default: abort(); | |
593 | } | |
594 | } | |
595 | ||
9f309e2c | 596 | SCM scm_sym_apply; |
486013d6 AW |
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; | |
601 | ||
602 | SCM | |
603 | scm_vm_builtin_name_to_index (SCM name) | |
604 | #define FUNC_NAME "builtin-name->index" | |
605 | { | |
606 | SCM_VALIDATE_SYMBOL (1, name); | |
607 | ||
9f309e2c | 608 | #define NAME_TO_INDEX(builtin, BUILTIN, req, opt, rest) \ |
486013d6 AW |
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) | |
612 | #undef NAME_TO_INDEX | |
613 | ||
614 | return SCM_BOOL_F; | |
615 | } | |
616 | #undef FUNC_NAME | |
617 | ||
618 | SCM | |
619 | scm_vm_builtin_index_to_name (SCM index) | |
620 | #define FUNC_NAME "builtin-index->name" | |
621 | { | |
622 | unsigned idx; | |
623 | ||
624 | SCM_VALIDATE_UINT_COPY (1, index, idx); | |
625 | ||
626 | switch (idx) | |
627 | { | |
9f309e2c | 628 | #define INDEX_TO_NAME(builtin, BUILTIN, req, opt, rest) \ |
486013d6 AW |
629 | case SCM_VM_BUILTIN_##BUILTIN: return scm_sym_##builtin; |
630 | FOR_EACH_VM_BUILTIN(INDEX_TO_NAME) | |
631 | #undef INDEX_TO_NAME | |
632 | default: return SCM_BOOL_F; | |
633 | } | |
634 | } | |
635 | #undef FUNC_NAME | |
636 | ||
637 | static void | |
638 | scm_init_vm_builtins (void) | |
639 | { | |
486013d6 AW |
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); | |
644 | } | |
645 | ||
646 | SCM | |
647 | scm_i_call_with_current_continuation (SCM proc) | |
648 | { | |
649 | return scm_call_1 (vm_builtin_call_with_current_continuation, proc); | |
650 | } | |
510ca126 | 651 | |
a98cef7e KN |
652 | \f |
653 | /* | |
654 | * VM | |
655 | */ | |
656 | ||
22d425ec AW |
657 | /* Hard stack limit is 512M words: 2 gigabytes on 32-bit machines, 4 on |
658 | 64-bit machines. */ | |
659 | static const size_t hard_max_stack_size = 512 * 1024 * 1024; | |
660 | ||
661 | /* Initial stack size: 4 or 8 kB. */ | |
662 | static const size_t initial_stack_size = 1024; | |
663 | ||
664 | /* Default soft stack limit is 1M words (4 or 8 megabytes). */ | |
665 | static size_t default_max_stack_size = 1024 * 1024; | |
aab9d46c SIT |
666 | |
667 | static void | |
668 | initialize_default_stack_size (void) | |
669 | { | |
22d425ec AW |
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; | |
aab9d46c | 673 | } |
17e90c5e | 674 | |
22d425ec | 675 | static void vm_expand_stack (struct scm_vm *vp) SCM_NOINLINE; |
f42cfbf0 AW |
676 | #define VM_NAME vm_regular_engine |
677 | #define VM_USE_HOOKS 0 | |
6d14383e | 678 | #define FUNC_NAME "vm-regular-engine" |
83495480 | 679 | #include "vm-engine.c" |
6d14383e | 680 | #undef FUNC_NAME |
f42cfbf0 AW |
681 | #undef VM_USE_HOOKS |
682 | #undef VM_NAME | |
17e90c5e | 683 | |
f42cfbf0 AW |
684 | #define VM_NAME vm_debug_engine |
685 | #define VM_USE_HOOKS 1 | |
6d14383e | 686 | #define FUNC_NAME "vm-debug-engine" |
83495480 | 687 | #include "vm-engine.c" |
6d14383e | 688 | #undef FUNC_NAME |
f42cfbf0 AW |
689 | #undef VM_USE_HOOKS |
690 | #undef VM_NAME | |
17e90c5e | 691 | |
dd1c7dec AW |
692 | typedef SCM (*scm_t_vm_engine) (scm_i_thread *current_thread, struct scm_vm *vp, |
693 | scm_i_jmp_buf *registers, int resume); | |
73c3db66 | 694 | |
f42cfbf0 AW |
695 | static const scm_t_vm_engine vm_engines[SCM_VM_NUM_ENGINES] = |
696 | { vm_regular_engine, vm_debug_engine }; | |
73c3db66 | 697 | |
5f18bc84 AW |
698 | static SCM* |
699 | allocate_stack (size_t size) | |
700 | #define FUNC_NAME "make_vm" | |
701 | { | |
702 | void *ret; | |
e3eb628d | 703 | |
5f18bc84 AW |
704 | if (size >= ((size_t) -1) / sizeof (SCM)) |
705 | abort (); | |
706 | ||
707 | size *= sizeof (SCM); | |
e3eb628d | 708 | |
5f18bc84 AW |
709 | #if HAVE_SYS_MMAN_H |
710 | ret = mmap (NULL, size, PROT_READ | PROT_WRITE, | |
711 | MAP_PRIVATE | MAP_ANONYMOUS, -1, 0); | |
712 | if (ret == MAP_FAILED) | |
713 | SCM_SYSERROR; | |
714 | #else | |
715 | ret = malloc (size); | |
716 | if (!ret) | |
717 | SCM_SYSERROR; | |
e3eb628d LC |
718 | #endif |
719 | ||
5f18bc84 AW |
720 | return (SCM *) ret; |
721 | } | |
722 | #undef FUNC_NAME | |
723 | ||
724 | static void | |
725 | free_stack (SCM *stack, size_t size) | |
726 | { | |
727 | size *= sizeof (SCM); | |
728 | ||
729 | #if HAVE_SYS_MMAN_H | |
730 | munmap (stack, size); | |
731 | #else | |
732 | free (stack); | |
733 | #endif | |
734 | } | |
735 | ||
22d425ec AW |
736 | static SCM* |
737 | expand_stack (SCM *old_stack, size_t old_size, size_t new_size) | |
738 | #define FUNC_NAME "expand_stack" | |
739 | { | |
740 | #if defined MREMAP_MAYMOVE | |
741 | void *new_stack; | |
742 | ||
743 | if (new_size >= ((size_t) -1) / sizeof (SCM)) | |
744 | abort (); | |
745 | ||
746 | old_size *= sizeof (SCM); | |
747 | new_size *= sizeof (SCM); | |
748 | ||
749 | new_stack = mremap (old_stack, old_size, new_size, MREMAP_MAYMOVE); | |
750 | if (new_stack == MAP_FAILED) | |
751 | SCM_SYSERROR; | |
752 | ||
753 | return (SCM *) new_stack; | |
754 | #else | |
755 | SCM *new_stack; | |
756 | ||
757 | new_stack = allocate_stack (new_size); | |
758 | memcpy (new_stack, old_stack, old_size * sizeof (SCM)); | |
759 | free_stack (old_stack, old_size); | |
760 | ||
761 | return new_stack; | |
762 | #endif | |
763 | } | |
764 | #undef FUNC_NAME | |
765 | ||
3506b152 | 766 | static struct scm_vm * |
17e90c5e KN |
767 | make_vm (void) |
768 | #define FUNC_NAME "make_vm" | |
a98cef7e | 769 | { |
17e90c5e | 770 | int i; |
7f991c7d | 771 | struct scm_vm *vp; |
747a1635 | 772 | |
7f991c7d | 773 | vp = scm_gc_malloc (sizeof (struct scm_vm), "vm"); |
d8eeb67c | 774 | |
22d425ec | 775 | vp->stack_size = initial_stack_size; |
5f18bc84 | 776 | vp->stack_base = allocate_stack (vp->stack_size); |
22d425ec AW |
777 | vp->stack_limit = vp->stack_base + vp->stack_size; |
778 | vp->max_stack_size = default_max_stack_size; | |
3616e9e9 KN |
779 | vp->ip = NULL; |
780 | vp->sp = vp->stack_base - 1; | |
781 | vp->fp = NULL; | |
ea9f4f4b | 782 | vp->engine = vm_default_engine; |
7656f194 | 783 | vp->trace_level = 0; |
17e90c5e | 784 | for (i = 0; i < SCM_VM_NUM_HOOKS; i++) |
3d5ee0cd | 785 | vp->hooks[i] = SCM_BOOL_F; |
3506b152 AW |
786 | |
787 | return vp; | |
a98cef7e | 788 | } |
17e90c5e | 789 | #undef FUNC_NAME |
a98cef7e | 790 | |
e3eb628d | 791 | /* Mark the VM stack region between its base and its current top. */ |
5f18bc84 AW |
792 | struct GC_ms_entry * |
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) | |
e3eb628d | 795 | { |
1cdf9b78 | 796 | SCM *sp, *fp; |
e3eb628d | 797 | |
1cdf9b78 AW |
798 | for (fp = vp->fp, sp = vp->sp; fp; fp = SCM_FRAME_DYNAMIC_LINK (fp)) |
799 | { | |
800 | for (; sp >= &SCM_FRAME_LOCAL (fp, 0); sp--) | |
801 | { | |
802 | SCM elt = *sp; | |
803 | if (SCM_NIMP (elt)) | |
804 | mark_stack_ptr = GC_MARK_AND_PUSH ((GC_word *) elt, | |
805 | mark_stack_ptr, mark_stack_limit, | |
806 | NULL); | |
807 | } | |
808 | sp = SCM_FRAME_PREVIOUS_SP (fp); | |
809 | } | |
e3eb628d LC |
810 | |
811 | return mark_stack_ptr; | |
812 | } | |
813 | ||
5f18bc84 AW |
814 | /* Free the VM stack, as this thread is exiting. */ |
815 | void | |
816 | scm_i_vm_free_stack (struct scm_vm *vp) | |
817 | { | |
818 | free_stack (vp->stack_base, vp->stack_size); | |
819 | vp->stack_base = vp->stack_limit = NULL; | |
820 | vp->stack_size = 0; | |
821 | } | |
e3eb628d | 822 | |
22d425ec AW |
823 | static void |
824 | vm_expand_stack (struct scm_vm *vp) | |
825 | { | |
826 | scm_t_ptrdiff stack_size = vp->sp + 1 - vp->stack_base; | |
827 | ||
828 | if (stack_size > hard_max_stack_size) | |
829 | { | |
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); | |
834 | abort (); | |
835 | } | |
836 | ||
837 | if (stack_size > vp->stack_size) | |
838 | { | |
839 | SCM *old_stack; | |
840 | size_t new_size; | |
841 | scm_t_ptrdiff reloc; | |
842 | ||
843 | new_size = vp->stack_size; | |
844 | while (new_size < stack_size) | |
845 | new_size *= 2; | |
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; | |
851 | ||
852 | if (reloc) | |
853 | { | |
854 | SCM *fp; | |
855 | vp->fp += reloc; | |
856 | vp->sp += reloc; | |
857 | fp = vp->fp; | |
858 | while (fp) | |
859 | { | |
860 | SCM *next_fp = SCM_FRAME_DYNAMIC_LINK (fp); | |
861 | if (next_fp) | |
862 | { | |
863 | next_fp += reloc; | |
864 | SCM_FRAME_SET_DYNAMIC_LINK (fp, next_fp); | |
865 | } | |
866 | fp = next_fp; | |
867 | } | |
868 | } | |
869 | } | |
870 | ||
871 | if (stack_size >= vp->max_stack_size) | |
872 | { | |
873 | /* Expand the soft limit by 256K entries to give us space to | |
874 | handle the error. */ | |
875 | vp->max_stack_size += 256 * 1024; | |
876 | ||
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; | |
881 | ||
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; | |
885 | ||
886 | /* Finally, reset the limit, to catch further overflows. */ | |
887 | vp->stack_limit = vp->stack_base + vp->max_stack_size; | |
888 | ||
889 | vm_error ("VM: Stack overflow", SCM_UNDEFINED); | |
890 | } | |
891 | ||
892 | /* Otherwise continue, with the new enlarged stack. */ | |
893 | } | |
894 | ||
b85cd20f AW |
895 | static struct scm_vm * |
896 | thread_vm (scm_i_thread *t) | |
55ee3607 | 897 | { |
b85cd20f AW |
898 | if (SCM_UNLIKELY (!t->vp)) |
899 | t->vp = make_vm (); | |
900 | ||
901 | return t->vp; | |
55ee3607 AW |
902 | } |
903 | ||
e7f9abab | 904 | struct scm_vm * |
a222cbc9 | 905 | scm_the_vm (void) |
271c3d31 | 906 | { |
b85cd20f AW |
907 | return thread_vm (SCM_I_CURRENT_THREAD); |
908 | } | |
ea9f4f4b | 909 | |
b85cd20f AW |
910 | SCM |
911 | scm_call_n (SCM proc, SCM *argv, size_t nargs) | |
912 | { | |
913 | scm_i_thread *thread; | |
914 | struct scm_vm *vp; | |
bd63e5b2 AW |
915 | SCM *base; |
916 | ptrdiff_t base_frame_size; | |
dd1c7dec AW |
917 | /* Cached variables. */ |
918 | scm_i_jmp_buf registers; /* used for prompts */ | |
bd63e5b2 | 919 | size_t i; |
ea9f4f4b | 920 | |
b85cd20f AW |
921 | thread = SCM_I_CURRENT_THREAD; |
922 | vp = thread_vm (thread); | |
923 | ||
924 | SCM_CHECK_STACK; | |
bd63e5b2 AW |
925 | |
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) | |
22d425ec | 932 | vm_expand_stack (vp); |
bd63e5b2 AW |
933 | base = vp->sp + 1 - base_frame_size; |
934 | ||
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]; | |
939 | ||
940 | /* Push the boot continuation, which calls PROC and returns its | |
941 | result(s). */ | |
942 | base[0] = SCM_PACK (vp->fp); /* dynamic link */ | |
943 | base[1] = SCM_PACK (vp->ip); /* ra */ | |
944 | base[2] = vm_boot_continuation; | |
945 | vp->fp = &base[2]; | |
946 | vp->ip = (scm_t_uint32 *) vm_boot_continuation_code; | |
947 | ||
948 | /* The pending call to PROC. */ | |
949 | base[3] = SCM_PACK (vp->fp); /* dynamic link */ | |
950 | base[4] = SCM_PACK (vp->ip); /* ra */ | |
951 | base[5] = proc; | |
952 | vp->fp = &base[5]; | |
953 | vp->sp = &SCM_FRAME_LOCAL (vp->fp, nargs); | |
954 | ||
dd1c7dec AW |
955 | { |
956 | int resume = SCM_I_SETJMP (registers); | |
957 | ||
958 | if (SCM_UNLIKELY (resume)) | |
959 | /* Non-local return. */ | |
960 | vm_dispatch_abort_hook (vp); | |
961 | ||
962 | return vm_engines[vp->engine](thread, vp, ®isters, resume); | |
963 | } | |
271c3d31 | 964 | } |
499a4c07 | 965 | |
a222cbc9 | 966 | /* Scheme interface */ |
a98cef7e | 967 | |
17e90c5e KN |
968 | #define VM_DEFINE_HOOK(n) \ |
969 | { \ | |
3d5ee0cd | 970 | struct scm_vm *vp; \ |
e7f9abab | 971 | vp = scm_the_vm (); \ |
8b22ed7a | 972 | if (scm_is_false (vp->hooks[n])) \ |
238e7a11 | 973 | vp->hooks[n] = scm_make_hook (SCM_I_MAKINUM (1)); \ |
3d5ee0cd | 974 | return vp->hooks[n]; \ |
17e90c5e KN |
975 | } |
976 | ||
972275ee AW |
977 | SCM_DEFINE (scm_vm_apply_hook, "vm-apply-hook", 0, 0, 0, |
978 | (void), | |
17e90c5e | 979 | "") |
c45d4d77 | 980 | #define FUNC_NAME s_scm_vm_apply_hook |
a98cef7e | 981 | { |
c45d4d77 | 982 | VM_DEFINE_HOOK (SCM_VM_APPLY_HOOK); |
a98cef7e KN |
983 | } |
984 | #undef FUNC_NAME | |
985 | ||
972275ee AW |
986 | SCM_DEFINE (scm_vm_push_continuation_hook, "vm-push-continuation-hook", 0, 0, 0, |
987 | (void), | |
17e90c5e | 988 | "") |
c45d4d77 | 989 | #define FUNC_NAME s_scm_vm_push_continuation_hook |
a98cef7e | 990 | { |
c45d4d77 | 991 | VM_DEFINE_HOOK (SCM_VM_PUSH_CONTINUATION_HOOK); |
a98cef7e KN |
992 | } |
993 | #undef FUNC_NAME | |
994 | ||
972275ee AW |
995 | SCM_DEFINE (scm_vm_pop_continuation_hook, "vm-pop-continuation-hook", 0, 0, 0, |
996 | (void), | |
17e90c5e | 997 | "") |
c45d4d77 | 998 | #define FUNC_NAME s_scm_vm_pop_continuation_hook |
a98cef7e | 999 | { |
c45d4d77 | 1000 | VM_DEFINE_HOOK (SCM_VM_POP_CONTINUATION_HOOK); |
a98cef7e KN |
1001 | } |
1002 | #undef FUNC_NAME | |
1003 | ||
972275ee AW |
1004 | SCM_DEFINE (scm_vm_next_hook, "vm-next-hook", 0, 0, 0, |
1005 | (void), | |
17e90c5e | 1006 | "") |
c45d4d77 | 1007 | #define FUNC_NAME s_scm_vm_next_hook |
a98cef7e | 1008 | { |
c45d4d77 | 1009 | VM_DEFINE_HOOK (SCM_VM_NEXT_HOOK); |
a98cef7e KN |
1010 | } |
1011 | #undef FUNC_NAME | |
f3120251 | 1012 | |
972275ee AW |
1013 | SCM_DEFINE (scm_vm_abort_continuation_hook, "vm-abort-continuation-hook", 0, 0, 0, |
1014 | (void), | |
f3120251 AW |
1015 | "") |
1016 | #define FUNC_NAME s_scm_vm_abort_continuation_hook | |
1017 | { | |
1018 | VM_DEFINE_HOOK (SCM_VM_ABORT_CONTINUATION_HOOK); | |
1019 | } | |
1020 | #undef FUNC_NAME | |
1021 | ||
972275ee AW |
1022 | SCM_DEFINE (scm_vm_trace_level, "vm-trace-level", 0, 0, 0, |
1023 | (void), | |
17e90c5e | 1024 | "") |
7656f194 | 1025 | #define FUNC_NAME s_scm_vm_trace_level |
a98cef7e | 1026 | { |
e7f9abab | 1027 | return scm_from_int (scm_the_vm ()->trace_level); |
7656f194 AW |
1028 | } |
1029 | #undef FUNC_NAME | |
1030 | ||
972275ee AW |
1031 | SCM_DEFINE (scm_set_vm_trace_level_x, "set-vm-trace-level!", 1, 0, 0, |
1032 | (SCM level), | |
7656f194 AW |
1033 | "") |
1034 | #define FUNC_NAME s_scm_set_vm_trace_level_x | |
1035 | { | |
e7f9abab | 1036 | scm_the_vm ()->trace_level = scm_to_int (level); |
7656f194 | 1037 | return SCM_UNSPECIFIED; |
a98cef7e KN |
1038 | } |
1039 | #undef FUNC_NAME | |
1040 | ||
1041 | \f | |
ea9f4f4b AW |
1042 | /* |
1043 | * VM engines | |
1044 | */ | |
1045 | ||
1046 | static int | |
1047 | symbol_to_vm_engine (SCM engine, const char *FUNC_NAME) | |
1048 | { | |
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; | |
1053 | else | |
1054 | SCM_MISC_ERROR ("Unknown VM engine: ~a", scm_list_1 (engine)); | |
1055 | } | |
1056 | ||
1057 | static SCM | |
1058 | vm_engine_to_symbol (int engine, const char *FUNC_NAME) | |
1059 | { | |
1060 | switch (engine) | |
1061 | { | |
1062 | case SCM_VM_REGULAR_ENGINE: | |
1063 | return sym_regular; | |
1064 | case SCM_VM_DEBUG_ENGINE: | |
1065 | return sym_debug; | |
1066 | default: | |
1067 | /* ? */ | |
1068 | SCM_MISC_ERROR ("Unknown VM engine: ~a", | |
1069 | scm_list_1 (scm_from_int (engine))); | |
1070 | } | |
1071 | } | |
1072 | ||
972275ee AW |
1073 | SCM_DEFINE (scm_vm_engine, "vm-engine", 0, 0, 0, |
1074 | (void), | |
ea9f4f4b AW |
1075 | "") |
1076 | #define FUNC_NAME s_scm_vm_engine | |
1077 | { | |
e7f9abab | 1078 | return vm_engine_to_symbol (scm_the_vm ()->engine, FUNC_NAME); |
ea9f4f4b AW |
1079 | } |
1080 | #undef FUNC_NAME | |
1081 | ||
1082 | void | |
972275ee | 1083 | scm_c_set_vm_engine_x (int engine) |
ea9f4f4b AW |
1084 | #define FUNC_NAME "set-vm-engine!" |
1085 | { | |
ea9f4f4b AW |
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))); | |
1089 | ||
e7f9abab | 1090 | scm_the_vm ()->engine = engine; |
ea9f4f4b AW |
1091 | } |
1092 | #undef FUNC_NAME | |
1093 | ||
972275ee AW |
1094 | SCM_DEFINE (scm_set_vm_engine_x, "set-vm-engine!", 1, 0, 0, |
1095 | (SCM engine), | |
ea9f4f4b AW |
1096 | "") |
1097 | #define FUNC_NAME s_scm_set_vm_engine_x | |
1098 | { | |
972275ee | 1099 | scm_c_set_vm_engine_x (symbol_to_vm_engine (engine, FUNC_NAME)); |
ea9f4f4b AW |
1100 | return SCM_UNSPECIFIED; |
1101 | } | |
1102 | #undef FUNC_NAME | |
1103 | ||
1104 | void | |
1105 | scm_c_set_default_vm_engine_x (int engine) | |
1106 | #define FUNC_NAME "set-default-vm-engine!" | |
1107 | { | |
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))); | |
1111 | ||
1112 | vm_default_engine = engine; | |
1113 | } | |
1114 | #undef FUNC_NAME | |
1115 | ||
1116 | SCM_DEFINE (scm_set_default_vm_engine_x, "set-default-vm-engine!", 1, 0, 0, | |
1117 | (SCM engine), | |
1118 | "") | |
1119 | #define FUNC_NAME s_scm_set_default_vm_engine_x | |
1120 | { | |
1121 | scm_c_set_default_vm_engine_x (symbol_to_vm_engine (engine, FUNC_NAME)); | |
1122 | return SCM_UNSPECIFIED; | |
1123 | } | |
1124 | #undef FUNC_NAME | |
1125 | ||
972275ee AW |
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), | |
ea9f4f4b | 1130 | "Apply @var{proc} to @var{args} in a dynamic extent in which\n" |
972275ee | 1131 | "@var{vm} is the current VM.") |
ea9f4f4b AW |
1132 | #define FUNC_NAME s_scm_call_with_vm |
1133 | { | |
972275ee | 1134 | return scm_apply_0 (proc, args); |
ea9f4f4b AW |
1135 | } |
1136 | #undef FUNC_NAME | |
1137 | ||
1138 | \f | |
a98cef7e | 1139 | /* |
17e90c5e | 1140 | * Initialize |
a98cef7e KN |
1141 | */ |
1142 | ||
55ee3607 AW |
1143 | SCM |
1144 | scm_load_compiled_with_vm (SCM file) | |
07e56b27 | 1145 | { |
55ee3607 | 1146 | return scm_call_0 (scm_load_thunk_from_file (file)); |
07e56b27 AW |
1147 | } |
1148 | ||
67b699cc | 1149 | |
9f309e2c AW |
1150 | void |
1151 | scm_init_vm_builtin_properties (void) | |
1152 | { | |
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"); | |
1160 | ||
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); | |
1169 | #undef INIT_BUILTIN | |
1170 | } | |
1171 | ||
17e90c5e | 1172 | void |
07e56b27 | 1173 | scm_bootstrap_vm (void) |
17e90c5e | 1174 | { |
44602b08 AW |
1175 | scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION, |
1176 | "scm_init_vm", | |
60ae5ca2 | 1177 | (scm_t_extension_init_func)scm_init_vm, NULL); |
486013d6 AW |
1178 | scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION, |
1179 | "scm_init_vm_builtins", | |
1180 | (scm_t_extension_init_func)scm_init_vm_builtins, | |
1181 | NULL); | |
60ae5ca2 | 1182 | |
aab9d46c SIT |
1183 | initialize_default_stack_size (); |
1184 | ||
4a655e50 AW |
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"); | |
0404c97d | 1190 | |
ef6b7f71 AW |
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) | |
73c3db66 | 1194 | | SCM_F_PROGRAM_IS_BOOT)); |
9f309e2c AW |
1195 | |
1196 | #define DEFINE_BUILTIN(builtin, BUILTIN, req, opt, rest) \ | |
80797145 | 1197 | vm_builtin_##builtin = scm_i_make_program (vm_builtin_##builtin##_code); |
9f309e2c AW |
1198 | FOR_EACH_VM_BUILTIN (DEFINE_BUILTIN); |
1199 | #undef DEFINE_BUILTIN | |
07e56b27 AW |
1200 | } |
1201 | ||
1202 | void | |
1203 | scm_init_vm (void) | |
1204 | { | |
17e90c5e | 1205 | #ifndef SCM_MAGIC_SNARFER |
aeeff258 | 1206 | #include "libguile/vm.x" |
17e90c5e | 1207 | #endif |
a98cef7e | 1208 | } |
17e90c5e KN |
1209 | |
1210 | /* | |
1211 | Local Variables: | |
1212 | c-file-style: "gnu" | |
1213 | End: | |
1214 | */ |