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 | |
13c47753 AW |
19 | #if HAVE_CONFIG_H |
20 | # include <config.h> | |
21 | #endif | |
22 | ||
da8b4747 | 23 | #include <stdlib.h> |
6d14383e | 24 | #include <alloca.h> |
daccfef4 | 25 | #include <alignof.h> |
17e90c5e | 26 | #include <string.h> |
e78d4bf9 | 27 | #include <stdint.h> |
e3eb628d | 28 | |
1c44468d | 29 | #include "libguile/bdw-gc.h" |
e3eb628d LC |
30 | #include <gc/gc_mark.h> |
31 | ||
560b9c25 | 32 | #include "_scm.h" |
adaf86ec | 33 | #include "control.h" |
ac99cb0c | 34 | #include "frames.h" |
17e90c5e | 35 | #include "instructions.h" |
4cbc95f1 | 36 | #include "loader.h" |
ac99cb0c | 37 | #include "programs.h" |
a98cef7e | 38 | #include "vm.h" |
486013d6 | 39 | #include "vm-builtins.h" |
a98cef7e | 40 | |
aab9d46c SIT |
41 | #include "private-gc.h" /* scm_getenv_int */ |
42 | ||
97b18a66 | 43 | static int vm_default_engine = SCM_VM_REGULAR_ENGINE; |
ea9f4f4b AW |
44 | |
45 | /* Unfortunately we can't snarf these: snarfed things are only loaded up from | |
46 | (system vm vm), which might not be loaded before an error happens. */ | |
47 | static SCM sym_vm_run; | |
48 | static SCM sym_vm_error; | |
49 | static SCM sym_keyword_argument_error; | |
50 | static SCM sym_regular; | |
51 | static SCM sym_debug; | |
a98cef7e | 52 | |
11ea1aba AW |
53 | /* The VM has a number of internal assertions that shouldn't normally be |
54 | necessary, but might be if you think you found a bug in the VM. */ | |
55 | #define VM_ENABLE_ASSERTIONS | |
56 | ||
53e28ed9 AW |
57 | /* #define VM_ENABLE_PARANOID_ASSERTIONS */ |
58 | ||
e3eb628d LC |
59 | /* When defined, arrange so that the GC doesn't scan the VM stack beyond its |
60 | current SP. This should help avoid excess data retention. See | |
61 | http://thread.gmane.org/gmane.comp.programming.garbage-collection.boehmgc/3001 | |
62 | for a discussion. */ | |
63 | #define VM_ENABLE_PRECISE_STACK_GC_SCAN | |
64 | ||
f1046e6b LC |
65 | /* Size in SCM objects of the stack reserve. The reserve is used to run |
66 | exception handling code in case of a VM stack overflow. */ | |
67 | #define VM_STACK_RESERVE_SIZE 512 | |
68 | ||
e3eb628d | 69 | |
a98cef7e | 70 | \f |
a98cef7e KN |
71 | /* |
72 | * VM Continuation | |
73 | */ | |
74 | ||
6f3b0cc2 AW |
75 | void |
76 | scm_i_vm_cont_print (SCM x, SCM port, scm_print_state *pstate) | |
77 | { | |
0607ebbf | 78 | scm_puts_unlocked ("#<vm-continuation ", port); |
6f3b0cc2 | 79 | scm_uintprint (SCM_UNPACK (x), 16, port); |
0607ebbf | 80 | scm_puts_unlocked (">", port); |
6f3b0cc2 | 81 | } |
17e90c5e | 82 | |
d8873dfe AW |
83 | /* In theory, a number of vm instances can be active in the call trace, and we |
84 | only want to reify the continuations of those in the current continuation | |
85 | root. I don't see a nice way to do this -- ideally it would involve dynwinds, | |
86 | and previous values of the *the-vm* fluid within the current continuation | |
87 | root. But we don't have access to continuation roots in the dynwind stack. | |
88 | So, just punt for now, we just capture the continuation for the current VM. | |
89 | ||
90 | While I'm on the topic, ideally we could avoid copying the C stack if the | |
91 | continuation root is inside VM code, and call/cc was invoked within that same | |
92 | call to vm_run; but that's currently not implemented. | |
93 | */ | |
cee1d22c | 94 | SCM |
9121d9f1 | 95 | scm_i_vm_capture_stack (SCM *stack_base, SCM *fp, SCM *sp, scm_t_uint32 *ra, |
840ec334 | 96 | scm_t_dynstack *dynstack, scm_t_uint32 flags) |
a98cef7e | 97 | { |
d8873dfe AW |
98 | struct scm_vm_cont *p; |
99 | ||
100 | p = scm_gc_malloc (sizeof (*p), "capture_vm_cont"); | |
101 | p->stack_size = sp - stack_base + 1; | |
d8eeb67c LC |
102 | p->stack_base = scm_gc_malloc (p->stack_size * sizeof (SCM), |
103 | "capture_vm_cont"); | |
d8873dfe | 104 | p->ra = ra; |
d8873dfe AW |
105 | p->sp = sp; |
106 | p->fp = fp; | |
107 | memcpy (p->stack_base, stack_base, (sp + 1 - stack_base) * sizeof (SCM)); | |
108 | p->reloc = p->stack_base - stack_base; | |
9ede013f | 109 | p->dynstack = dynstack; |
cee1d22c | 110 | p->flags = flags; |
6f3b0cc2 | 111 | return scm_cell (scm_tc7_vm_cont, (scm_t_bits)p); |
a98cef7e KN |
112 | } |
113 | ||
114 | static void | |
796e54a7 | 115 | vm_return_to_continuation (struct scm_vm *vp, SCM cont, size_t n, SCM *argv) |
a98cef7e | 116 | { |
d8873dfe AW |
117 | struct scm_vm_cont *cp; |
118 | SCM *argv_copy; | |
119 | ||
120 | argv_copy = alloca (n * sizeof(SCM)); | |
121 | memcpy (argv_copy, argv, n * sizeof(SCM)); | |
122 | ||
d8873dfe AW |
123 | cp = SCM_VM_CONT_DATA (cont); |
124 | ||
f8085163 | 125 | if (vp->stack_size < cp->stack_size + n + 3) |
29366989 | 126 | scm_misc_error ("vm-engine", "not enough space to reinstate continuation", |
796e54a7 | 127 | scm_list_1 (cont)); |
29366989 | 128 | |
d8873dfe AW |
129 | vp->sp = cp->sp; |
130 | vp->fp = cp->fp; | |
131 | memcpy (vp->stack_base, cp->stack_base, cp->stack_size * sizeof (SCM)); | |
bfffd258 | 132 | |
03f16599 AW |
133 | { |
134 | size_t i; | |
135 | ||
136 | /* Push on an empty frame, as the continuation expects. */ | |
f8085163 | 137 | for (i = 0; i < 3; i++) |
03f16599 AW |
138 | { |
139 | vp->sp++; | |
140 | *vp->sp = SCM_BOOL_F; | |
141 | } | |
142 | ||
143 | /* Push the return values. */ | |
144 | for (i = 0; i < n; i++) | |
145 | { | |
146 | vp->sp++; | |
147 | *vp->sp = argv_copy[i]; | |
148 | } | |
840ec334 | 149 | vp->ip = cp->ra; |
03f16599 | 150 | } |
d8873dfe | 151 | } |
bfffd258 | 152 | |
bfffd258 | 153 | SCM |
9ede013f | 154 | scm_i_capture_current_stack (void) |
bfffd258 | 155 | { |
9ede013f | 156 | scm_i_thread *thread; |
9ede013f AW |
157 | struct scm_vm *vp; |
158 | ||
159 | thread = SCM_I_CURRENT_THREAD; | |
55ee3607 | 160 | vp = SCM_VM_DATA (scm_the_vm ()); |
9ede013f | 161 | |
840ec334 | 162 | return scm_i_vm_capture_stack (vp->stack_base, vp->fp, vp->sp, vp->ip, |
9ede013f AW |
163 | scm_dynstack_capture_all (&thread->dynstack), |
164 | 0); | |
a98cef7e KN |
165 | } |
166 | ||
59f85eed AW |
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; | |
172 | static void vm_dispatch_restore_continuation_hook (struct scm_vm *vp) SCM_NOINLINE; | |
c850a0ff | 173 | |
b1b942b7 | 174 | static void |
59f85eed | 175 | vm_dispatch_hook (struct scm_vm *vp, int hook_num, SCM *argv, int n) |
b1b942b7 | 176 | { |
7656f194 | 177 | SCM hook; |
b3567435 | 178 | struct scm_frame c_frame; |
8e4c60ff | 179 | scm_t_cell *frame; |
893fb8d0 | 180 | int saved_trace_level; |
b1b942b7 | 181 | |
7656f194 | 182 | hook = vp->hooks[hook_num]; |
b1b942b7 | 183 | |
7656f194 AW |
184 | if (SCM_LIKELY (scm_is_false (hook)) |
185 | || scm_is_null (SCM_HOOK_PROCEDURES (hook))) | |
186 | return; | |
b3567435 | 187 | |
893fb8d0 AW |
188 | saved_trace_level = vp->trace_level; |
189 | vp->trace_level = 0; | |
b3567435 LC |
190 | |
191 | /* Allocate a frame object on the stack. This is more efficient than calling | |
192 | `scm_c_make_frame ()' to allocate on the heap, but it forces hooks to not | |
193 | capture frame objects. | |
194 | ||
195 | At the same time, procedures such as `frame-procedure' make sense only | |
196 | while the stack frame represented by the frame object is visible, so it | |
197 | seems reasonable to limit the lifetime of frame objects. */ | |
198 | ||
5515edc5 | 199 | c_frame.stack_holder = vp; |
89b235af AW |
200 | c_frame.fp_offset = vp->fp - vp->stack_base; |
201 | c_frame.sp_offset = vp->sp - vp->stack_base; | |
b3567435 | 202 | c_frame.ip = vp->ip; |
8e4c60ff LC |
203 | |
204 | /* Arrange for FRAME to be 8-byte aligned, like any other cell. */ | |
205 | frame = alloca (sizeof (*frame) + 8); | |
206 | frame = (scm_t_cell *) ROUND_UP ((scm_t_uintptr) frame, 8UL); | |
207 | ||
050a40db | 208 | frame->word_0 = SCM_PACK (scm_tc7_frame | (SCM_VM_FRAME_KIND_VM << 8)); |
21041372 | 209 | frame->word_1 = SCM_PACK_POINTER (&c_frame); |
b3567435 | 210 | |
c850a0ff AW |
211 | if (n == 0) |
212 | { | |
213 | SCM args[1]; | |
214 | ||
215 | args[0] = SCM_PACK_POINTER (frame); | |
216 | scm_c_run_hookn (hook, args, 1); | |
217 | } | |
218 | else if (n == 1) | |
219 | { | |
220 | SCM args[2]; | |
221 | ||
222 | args[0] = SCM_PACK_POINTER (frame); | |
223 | args[1] = argv[0]; | |
224 | scm_c_run_hookn (hook, args, 2); | |
225 | } | |
226 | else | |
227 | { | |
228 | SCM args = SCM_EOL; | |
229 | ||
230 | while (n--) | |
231 | args = scm_cons (argv[n], args); | |
232 | scm_c_run_hook (hook, scm_cons (SCM_PACK_POINTER (frame), args)); | |
233 | } | |
b3567435 | 234 | |
893fb8d0 | 235 | vp->trace_level = saved_trace_level; |
b1b942b7 AW |
236 | } |
237 | ||
ea0cd17d | 238 | static void |
59f85eed | 239 | vm_dispatch_apply_hook (struct scm_vm *vp) |
ea0cd17d | 240 | { |
59f85eed | 241 | return vm_dispatch_hook (vp, SCM_VM_APPLY_HOOK, NULL, 0); |
ea0cd17d | 242 | } |
59f85eed | 243 | static void vm_dispatch_push_continuation_hook (struct scm_vm *vp) |
ea0cd17d | 244 | { |
59f85eed | 245 | return vm_dispatch_hook (vp, SCM_VM_PUSH_CONTINUATION_HOOK, NULL, 0); |
ea0cd17d | 246 | } |
59f85eed | 247 | static void vm_dispatch_pop_continuation_hook (struct scm_vm *vp, SCM *old_fp) |
ea0cd17d | 248 | { |
59f85eed | 249 | return vm_dispatch_hook (vp, SCM_VM_POP_CONTINUATION_HOOK, |
ea0cd17d AW |
250 | &SCM_FRAME_LOCAL (old_fp, 1), |
251 | SCM_FRAME_NUM_LOCALS (old_fp, vp->sp) - 1); | |
252 | } | |
59f85eed | 253 | static void vm_dispatch_next_hook (struct scm_vm *vp) |
ea0cd17d | 254 | { |
59f85eed | 255 | return vm_dispatch_hook (vp, SCM_VM_NEXT_HOOK, NULL, 0); |
ea0cd17d | 256 | } |
59f85eed | 257 | static void vm_dispatch_abort_hook (struct scm_vm *vp) |
ea0cd17d | 258 | { |
59f85eed | 259 | return vm_dispatch_hook (vp, SCM_VM_ABORT_CONTINUATION_HOOK, |
ea0cd17d AW |
260 | &SCM_FRAME_LOCAL (vp->fp, 1), |
261 | SCM_FRAME_NUM_LOCALS (vp->fp, vp->sp) - 1); | |
262 | } | |
59f85eed | 263 | static void vm_dispatch_restore_continuation_hook (struct scm_vm *vp) |
ea0cd17d | 264 | { |
59f85eed | 265 | return vm_dispatch_hook (vp, SCM_VM_RESTORE_CONTINUATION_HOOK, NULL, 0); |
ea0cd17d AW |
266 | } |
267 | ||
4f66bcde | 268 | static void |
b44f5451 AW |
269 | vm_abort (struct scm_vm *vp, SCM tag, |
270 | size_t nstack, SCM *stack_args, SCM tail, SCM *sp, | |
99511cd0 | 271 | scm_i_jmp_buf *current_registers) SCM_NORETURN; |
9d381ba4 AW |
272 | |
273 | static void | |
b44f5451 AW |
274 | vm_abort (struct scm_vm *vp, SCM tag, |
275 | size_t nstack, SCM *stack_args, SCM tail, SCM *sp, | |
99511cd0 | 276 | scm_i_jmp_buf *current_registers) |
4f66bcde | 277 | { |
eaefabee | 278 | size_t i; |
2d026f04 | 279 | ssize_t tail_len; |
99511cd0 | 280 | SCM *argv; |
eaefabee | 281 | |
2d026f04 AW |
282 | tail_len = scm_ilength (tail); |
283 | if (tail_len < 0) | |
29366989 AW |
284 | scm_misc_error ("vm-engine", "tail values to abort should be a list", |
285 | scm_list_1 (tail)); | |
286 | ||
99511cd0 AW |
287 | argv = alloca ((nstack + tail_len) * sizeof (SCM)); |
288 | for (i = 0; i < nstack; i++) | |
289 | argv[i] = stack_args[i]; | |
290 | for (; i < nstack + tail_len; i++, tail = scm_cdr (tail)) | |
2d026f04 | 291 | argv[i] = scm_car (tail); |
eaefabee | 292 | |
99511cd0 | 293 | /* FIXME: NULLSTACK (SCM_VM_DATA (vp)->sp - sp) */ |
b44f5451 | 294 | vp->sp = sp; |
99511cd0 | 295 | |
b44f5451 | 296 | scm_c_abort (vp, tag, nstack + tail_len, argv, current_registers); |
cee1d22c AW |
297 | } |
298 | ||
9d381ba4 | 299 | static void |
44ece399 AW |
300 | vm_reinstate_partial_continuation (struct scm_vm *vp, SCM cont, |
301 | size_t n, SCM *argv, | |
9d381ba4 AW |
302 | scm_t_dynstack *dynstack, |
303 | scm_i_jmp_buf *registers) | |
cee1d22c | 304 | { |
07801437 AW |
305 | struct scm_vm_cont *cp; |
306 | SCM *argv_copy, *base; | |
9ede013f | 307 | scm_t_ptrdiff reloc; |
07801437 AW |
308 | size_t i; |
309 | ||
310 | argv_copy = alloca (n * sizeof(SCM)); | |
311 | memcpy (argv_copy, argv, n * sizeof(SCM)); | |
312 | ||
07801437 | 313 | cp = SCM_VM_CONT_DATA (cont); |
b636cdb0 | 314 | base = SCM_FRAME_LOCALS_ADDRESS (vp->fp); |
9ede013f | 315 | reloc = cp->reloc + (base - cp->stack_base); |
07801437 | 316 | |
0fc9040f | 317 | #define RELOC(scm_p) \ |
9ede013f | 318 | (((SCM *) (scm_p)) + reloc) |
07801437 AW |
319 | |
320 | if ((base - vp->stack_base) + cp->stack_size + n + 1 > vp->stack_size) | |
29366989 AW |
321 | scm_misc_error ("vm-engine", |
322 | "not enough space to instate partial continuation", | |
44ece399 | 323 | scm_list_1 (cont)); |
07801437 AW |
324 | |
325 | memcpy (base, cp->stack_base, cp->stack_size * sizeof (SCM)); | |
326 | ||
327 | /* now relocate frame pointers */ | |
328 | { | |
329 | SCM *fp; | |
330 | for (fp = RELOC (cp->fp); | |
331 | SCM_FRAME_LOWER_ADDRESS (fp) > base; | |
332 | fp = SCM_FRAME_DYNAMIC_LINK (fp)) | |
333 | SCM_FRAME_SET_DYNAMIC_LINK (fp, RELOC (SCM_FRAME_DYNAMIC_LINK (fp))); | |
334 | } | |
335 | ||
336 | vp->sp = base - 1 + cp->stack_size; | |
337 | vp->fp = RELOC (cp->fp); | |
840ec334 | 338 | vp->ip = cp->ra; |
07801437 | 339 | |
840ec334 | 340 | /* Push the arguments. */ |
07801437 AW |
341 | for (i = 0; i < n; i++) |
342 | { | |
343 | vp->sp++; | |
344 | *vp->sp = argv_copy[i]; | |
345 | } | |
9a1c6f1f | 346 | |
9d381ba4 AW |
347 | /* The prompt captured a slice of the dynamic stack. Here we wind |
348 | those entries onto the current thread's stack. We also have to | |
349 | relocate any prompts that we see along the way. */ | |
350 | { | |
351 | scm_t_bits *walk; | |
352 | ||
353 | for (walk = SCM_DYNSTACK_FIRST (cp->dynstack); | |
354 | SCM_DYNSTACK_TAG (walk); | |
355 | walk = SCM_DYNSTACK_NEXT (walk)) | |
356 | { | |
357 | scm_t_bits tag = SCM_DYNSTACK_TAG (walk); | |
358 | ||
359 | if (SCM_DYNSTACK_TAG_TYPE (tag) == SCM_DYNSTACK_TYPE_PROMPT) | |
360 | scm_dynstack_wind_prompt (dynstack, walk, reloc, registers); | |
361 | else | |
362 | scm_dynstack_wind_1 (dynstack, walk); | |
363 | } | |
364 | } | |
adbdfd6d | 365 | #undef RELOC |
4f66bcde AW |
366 | } |
367 | ||
368 | \f | |
17e90c5e KN |
369 | /* |
370 | * VM Internal functions | |
371 | */ | |
372 | ||
6f3b0cc2 AW |
373 | void |
374 | scm_i_vm_print (SCM x, SCM port, scm_print_state *pstate) | |
375 | { | |
0a935b2a LC |
376 | const struct scm_vm *vm; |
377 | ||
378 | vm = SCM_VM_DATA (x); | |
379 | ||
0607ebbf | 380 | scm_puts_unlocked ("#<vm ", port); |
0a935b2a LC |
381 | switch (vm->engine) |
382 | { | |
383 | case SCM_VM_REGULAR_ENGINE: | |
0607ebbf | 384 | scm_puts_unlocked ("regular-engine ", port); |
0a935b2a LC |
385 | break; |
386 | ||
387 | case SCM_VM_DEBUG_ENGINE: | |
0607ebbf | 388 | scm_puts_unlocked ("debug-engine ", port); |
0a935b2a LC |
389 | break; |
390 | ||
391 | default: | |
0607ebbf | 392 | scm_puts_unlocked ("unknown-engine ", port); |
0a935b2a | 393 | } |
6f3b0cc2 | 394 | scm_uintprint (SCM_UNPACK (x), 16, port); |
0607ebbf | 395 | scm_puts_unlocked (">", port); |
6f3b0cc2 AW |
396 | } |
397 | ||
53bdfcf0 AW |
398 | \f |
399 | /* | |
400 | * VM Error Handling | |
401 | */ | |
402 | ||
403 | static void vm_error (const char *msg, SCM arg) SCM_NORETURN; | |
4d497b62 AW |
404 | static void vm_error_bad_instruction (scm_t_uint32 inst) SCM_NORETURN SCM_NOINLINE; |
405 | static void vm_error_unbound (SCM proc, SCM sym) SCM_NORETURN SCM_NOINLINE; | |
406 | static void vm_error_unbound_fluid (SCM proc, SCM fluid) SCM_NORETURN SCM_NOINLINE; | |
407 | static void vm_error_not_a_variable (const char *func_name, SCM x) SCM_NORETURN SCM_NOINLINE; | |
408 | static void vm_error_apply_to_non_list (SCM x) SCM_NORETURN SCM_NOINLINE; | |
409 | static void vm_error_kwargs_length_not_even (SCM proc) SCM_NORETURN SCM_NOINLINE; | |
28d5d253 MW |
410 | static void vm_error_kwargs_invalid_keyword (SCM proc, SCM obj) SCM_NORETURN SCM_NOINLINE; |
411 | static void vm_error_kwargs_unrecognized_keyword (SCM proc, SCM kw) SCM_NORETURN SCM_NOINLINE; | |
4d497b62 AW |
412 | static void vm_error_too_many_args (int nargs) SCM_NORETURN SCM_NOINLINE; |
413 | static void vm_error_wrong_num_args (SCM proc) SCM_NORETURN SCM_NOINLINE; | |
414 | static void vm_error_wrong_type_apply (SCM proc) SCM_NORETURN SCM_NOINLINE; | |
415 | static void vm_error_stack_overflow (struct scm_vm *vp) SCM_NORETURN SCM_NOINLINE; | |
416 | static void vm_error_stack_underflow (void) SCM_NORETURN SCM_NOINLINE; | |
417 | static void vm_error_improper_list (SCM x) SCM_NORETURN SCM_NOINLINE; | |
418 | static void vm_error_not_a_pair (const char *subr, SCM x) SCM_NORETURN SCM_NOINLINE; | |
419 | static void vm_error_not_a_bytevector (const char *subr, SCM x) SCM_NORETURN SCM_NOINLINE; | |
420 | static void vm_error_not_a_struct (const char *subr, SCM x) SCM_NORETURN SCM_NOINLINE; | |
421 | static void vm_error_no_values (void) SCM_NORETURN SCM_NOINLINE; | |
422 | static void vm_error_not_enough_values (void) SCM_NORETURN SCM_NOINLINE; | |
82f4bac4 | 423 | static void vm_error_wrong_number_of_values (scm_t_uint32 expected) SCM_NORETURN SCM_NOINLINE; |
4d497b62 AW |
424 | static void vm_error_continuation_not_rewindable (SCM cont) SCM_NORETURN SCM_NOINLINE; |
425 | static void vm_error_bad_wide_string_length (size_t len) SCM_NORETURN SCM_NOINLINE; | |
53bdfcf0 AW |
426 | |
427 | static void | |
428 | vm_error (const char *msg, SCM arg) | |
429 | { | |
430 | scm_throw (sym_vm_error, | |
431 | scm_list_3 (sym_vm_run, scm_from_latin1_string (msg), | |
432 | SCM_UNBNDP (arg) ? SCM_EOL : scm_list_1 (arg))); | |
433 | abort(); /* not reached */ | |
434 | } | |
435 | ||
436 | static void | |
437 | vm_error_bad_instruction (scm_t_uint32 inst) | |
438 | { | |
439 | vm_error ("VM: Bad instruction: ~s", scm_from_uint32 (inst)); | |
440 | } | |
441 | ||
442 | static void | |
443 | vm_error_unbound (SCM proc, SCM sym) | |
444 | { | |
445 | scm_error_scm (scm_misc_error_key, proc, | |
446 | scm_from_latin1_string ("Unbound variable: ~s"), | |
447 | scm_list_1 (sym), SCM_BOOL_F); | |
448 | } | |
449 | ||
450 | static void | |
451 | vm_error_unbound_fluid (SCM proc, SCM fluid) | |
452 | { | |
453 | scm_error_scm (scm_misc_error_key, proc, | |
454 | scm_from_latin1_string ("Unbound fluid: ~s"), | |
455 | scm_list_1 (fluid), SCM_BOOL_F); | |
456 | } | |
457 | ||
458 | static void | |
459 | vm_error_not_a_variable (const char *func_name, SCM x) | |
460 | { | |
461 | scm_error (scm_arg_type_key, func_name, "Not a variable: ~S", | |
462 | scm_list_1 (x), scm_list_1 (x)); | |
463 | } | |
464 | ||
53bdfcf0 AW |
465 | static void |
466 | vm_error_apply_to_non_list (SCM x) | |
467 | { | |
468 | scm_error (scm_arg_type_key, "apply", "Apply to non-list: ~S", | |
469 | scm_list_1 (x), scm_list_1 (x)); | |
470 | } | |
471 | ||
472 | static void | |
473 | vm_error_kwargs_length_not_even (SCM proc) | |
474 | { | |
475 | scm_error_scm (sym_keyword_argument_error, proc, | |
476 | scm_from_latin1_string ("Odd length of keyword argument list"), | |
477 | SCM_EOL, SCM_BOOL_F); | |
478 | } | |
479 | ||
480 | static void | |
4af0d97e | 481 | vm_error_kwargs_invalid_keyword (SCM proc, SCM obj) |
53bdfcf0 AW |
482 | { |
483 | scm_error_scm (sym_keyword_argument_error, proc, | |
484 | scm_from_latin1_string ("Invalid keyword"), | |
4af0d97e | 485 | SCM_EOL, scm_list_1 (obj)); |
53bdfcf0 AW |
486 | } |
487 | ||
488 | static void | |
4af0d97e | 489 | vm_error_kwargs_unrecognized_keyword (SCM proc, SCM kw) |
53bdfcf0 AW |
490 | { |
491 | scm_error_scm (sym_keyword_argument_error, proc, | |
492 | scm_from_latin1_string ("Unrecognized keyword"), | |
4af0d97e | 493 | SCM_EOL, scm_list_1 (kw)); |
53bdfcf0 AW |
494 | } |
495 | ||
496 | static void | |
497 | vm_error_too_many_args (int nargs) | |
498 | { | |
499 | vm_error ("VM: Too many arguments", scm_from_int (nargs)); | |
500 | } | |
501 | ||
502 | static void | |
503 | vm_error_wrong_num_args (SCM proc) | |
504 | { | |
505 | scm_wrong_num_args (proc); | |
506 | } | |
507 | ||
508 | static void | |
509 | vm_error_wrong_type_apply (SCM proc) | |
510 | { | |
511 | scm_error (scm_arg_type_key, NULL, "Wrong type to apply: ~S", | |
512 | scm_list_1 (proc), scm_list_1 (proc)); | |
513 | } | |
514 | ||
515 | static void | |
516 | vm_error_stack_overflow (struct scm_vm *vp) | |
517 | { | |
518 | if (vp->stack_limit < vp->stack_base + vp->stack_size) | |
519 | /* There are VM_STACK_RESERVE_SIZE bytes left. Make them available so | |
520 | that `throw' below can run on this VM. */ | |
521 | vp->stack_limit = vp->stack_base + vp->stack_size; | |
522 | else | |
523 | /* There is no space left on the stack. FIXME: Do something more | |
524 | sensible here! */ | |
525 | abort (); | |
526 | vm_error ("VM: Stack overflow", SCM_UNDEFINED); | |
527 | } | |
528 | ||
529 | static void | |
530 | vm_error_stack_underflow (void) | |
531 | { | |
532 | vm_error ("VM: Stack underflow", SCM_UNDEFINED); | |
533 | } | |
534 | ||
535 | static void | |
536 | vm_error_improper_list (SCM x) | |
537 | { | |
538 | vm_error ("Expected a proper list, but got object with tail ~s", x); | |
539 | } | |
540 | ||
541 | static void | |
542 | vm_error_not_a_pair (const char *subr, SCM x) | |
543 | { | |
544 | scm_wrong_type_arg_msg (subr, 1, x, "pair"); | |
545 | } | |
546 | ||
547 | static void | |
548 | vm_error_not_a_bytevector (const char *subr, SCM x) | |
549 | { | |
550 | scm_wrong_type_arg_msg (subr, 1, x, "bytevector"); | |
551 | } | |
552 | ||
553 | static void | |
554 | vm_error_not_a_struct (const char *subr, SCM x) | |
555 | { | |
556 | scm_wrong_type_arg_msg (subr, 1, x, "struct"); | |
557 | } | |
558 | ||
559 | static void | |
560 | vm_error_no_values (void) | |
561 | { | |
562 | vm_error ("Zero values returned to single-valued continuation", | |
563 | SCM_UNDEFINED); | |
564 | } | |
565 | ||
566 | static void | |
567 | vm_error_not_enough_values (void) | |
568 | { | |
569 | vm_error ("Too few values returned to continuation", SCM_UNDEFINED); | |
570 | } | |
571 | ||
82f4bac4 AW |
572 | static void |
573 | vm_error_wrong_number_of_values (scm_t_uint32 expected) | |
574 | { | |
575 | vm_error ("Wrong number of values returned to continuation (expected ~a)", | |
576 | scm_from_uint32 (expected)); | |
577 | } | |
578 | ||
53bdfcf0 AW |
579 | static void |
580 | vm_error_continuation_not_rewindable (SCM cont) | |
581 | { | |
582 | vm_error ("Unrewindable partial continuation", cont); | |
583 | } | |
584 | ||
585 | static void | |
586 | vm_error_bad_wide_string_length (size_t len) | |
587 | { | |
588 | vm_error ("VM: Bad wide string length: ~S", scm_from_size_t (len)); | |
589 | } | |
590 | ||
53bdfcf0 AW |
591 | |
592 | \f | |
28b119ee | 593 | |
ef6b7f71 | 594 | static SCM vm_boot_continuation; |
486013d6 AW |
595 | static SCM vm_builtin_apply; |
596 | static SCM vm_builtin_values; | |
597 | static SCM vm_builtin_abort_to_prompt; | |
598 | static SCM vm_builtin_call_with_values; | |
599 | static SCM vm_builtin_call_with_current_continuation; | |
510ca126 | 600 | |
ef6b7f71 | 601 | static const scm_t_uint32 vm_boot_continuation_code[] = { |
095100bb | 602 | SCM_PACK_OP_24 (halt, 0) |
510ca126 AW |
603 | }; |
604 | ||
486013d6 | 605 | static const scm_t_uint32 vm_builtin_apply_code[] = { |
095100bb AW |
606 | SCM_PACK_OP_24 (assert_nargs_ge, 3), |
607 | SCM_PACK_OP_24 (tail_apply, 0), /* proc in r1, args from r2 */ | |
510ca126 AW |
608 | }; |
609 | ||
486013d6 | 610 | static const scm_t_uint32 vm_builtin_values_code[] = { |
095100bb | 611 | SCM_PACK_OP_24 (return_values, 0) /* vals from r1 */ |
510ca126 AW |
612 | }; |
613 | ||
486013d6 | 614 | static const scm_t_uint32 vm_builtin_abort_to_prompt_code[] = { |
095100bb AW |
615 | SCM_PACK_OP_24 (assert_nargs_ge, 2), |
616 | SCM_PACK_OP_24 (abort, 0), /* tag in r1, vals from r2 */ | |
486013d6 | 617 | /* FIXME: Partial continuation should capture caller regs. */ |
095100bb | 618 | SCM_PACK_OP_24 (return_values, 0) /* vals from r1 */ |
486013d6 AW |
619 | }; |
620 | ||
621 | static const scm_t_uint32 vm_builtin_call_with_values_code[] = { | |
095100bb AW |
622 | SCM_PACK_OP_24 (assert_nargs_ee, 3), |
623 | SCM_PACK_OP_24 (alloc_frame, 7), | |
624 | SCM_PACK_OP_12_12 (mov, 6, 1), | |
625 | SCM_PACK_OP_24 (call, 6), SCM_PACK_OP_ARG_8_24 (0, 1), | |
626 | SCM_PACK_OP_12_12 (mov, 0, 2), | |
627 | SCM_PACK_OP_24 (tail_call_shuffle, 7) | |
486013d6 AW |
628 | }; |
629 | ||
630 | static const scm_t_uint32 vm_builtin_call_with_current_continuation_code[] = { | |
095100bb AW |
631 | SCM_PACK_OP_24 (assert_nargs_ee, 2), |
632 | SCM_PACK_OP_24 (call_cc, 0) | |
486013d6 AW |
633 | }; |
634 | ||
635 | ||
636 | static SCM | |
637 | scm_vm_builtin_ref (unsigned idx) | |
638 | { | |
639 | switch (idx) | |
640 | { | |
9f309e2c | 641 | #define INDEX_TO_NAME(builtin, BUILTIN, req, opt, rest) \ |
486013d6 AW |
642 | case SCM_VM_BUILTIN_##BUILTIN: return vm_builtin_##builtin; |
643 | FOR_EACH_VM_BUILTIN(INDEX_TO_NAME) | |
644 | #undef INDEX_TO_NAME | |
645 | default: abort(); | |
646 | } | |
647 | } | |
648 | ||
9f309e2c | 649 | SCM scm_sym_apply; |
486013d6 AW |
650 | static SCM scm_sym_values; |
651 | static SCM scm_sym_abort_to_prompt; | |
652 | static SCM scm_sym_call_with_values; | |
653 | static SCM scm_sym_call_with_current_continuation; | |
654 | ||
655 | SCM | |
656 | scm_vm_builtin_name_to_index (SCM name) | |
657 | #define FUNC_NAME "builtin-name->index" | |
658 | { | |
659 | SCM_VALIDATE_SYMBOL (1, name); | |
660 | ||
9f309e2c | 661 | #define NAME_TO_INDEX(builtin, BUILTIN, req, opt, rest) \ |
486013d6 AW |
662 | if (scm_is_eq (name, scm_sym_##builtin)) \ |
663 | return scm_from_uint (SCM_VM_BUILTIN_##BUILTIN); | |
664 | FOR_EACH_VM_BUILTIN(NAME_TO_INDEX) | |
665 | #undef NAME_TO_INDEX | |
666 | ||
667 | return SCM_BOOL_F; | |
668 | } | |
669 | #undef FUNC_NAME | |
670 | ||
671 | SCM | |
672 | scm_vm_builtin_index_to_name (SCM index) | |
673 | #define FUNC_NAME "builtin-index->name" | |
674 | { | |
675 | unsigned idx; | |
676 | ||
677 | SCM_VALIDATE_UINT_COPY (1, index, idx); | |
678 | ||
679 | switch (idx) | |
680 | { | |
9f309e2c | 681 | #define INDEX_TO_NAME(builtin, BUILTIN, req, opt, rest) \ |
486013d6 AW |
682 | case SCM_VM_BUILTIN_##BUILTIN: return scm_sym_##builtin; |
683 | FOR_EACH_VM_BUILTIN(INDEX_TO_NAME) | |
684 | #undef INDEX_TO_NAME | |
685 | default: return SCM_BOOL_F; | |
686 | } | |
687 | } | |
688 | #undef FUNC_NAME | |
689 | ||
690 | static void | |
691 | scm_init_vm_builtins (void) | |
692 | { | |
486013d6 AW |
693 | scm_c_define_gsubr ("builtin-name->index", 1, 0, 0, |
694 | scm_vm_builtin_name_to_index); | |
695 | scm_c_define_gsubr ("builtin-index->name", 1, 0, 0, | |
696 | scm_vm_builtin_index_to_name); | |
697 | } | |
698 | ||
699 | SCM | |
700 | scm_i_call_with_current_continuation (SCM proc) | |
701 | { | |
702 | return scm_call_1 (vm_builtin_call_with_current_continuation, proc); | |
703 | } | |
510ca126 | 704 | |
a98cef7e KN |
705 | \f |
706 | /* | |
707 | * VM | |
708 | */ | |
709 | ||
aab9d46c | 710 | #define VM_MIN_STACK_SIZE (1024) |
486013d6 | 711 | #define VM_DEFAULT_STACK_SIZE (256 * 1024) |
aab9d46c SIT |
712 | static size_t vm_stack_size = VM_DEFAULT_STACK_SIZE; |
713 | ||
714 | static void | |
715 | initialize_default_stack_size (void) | |
716 | { | |
717 | int size = scm_getenv_int ("GUILE_STACK_SIZE", vm_stack_size); | |
718 | if (size >= VM_MIN_STACK_SIZE) | |
719 | vm_stack_size = size; | |
720 | } | |
17e90c5e | 721 | |
f42cfbf0 AW |
722 | #define VM_NAME vm_regular_engine |
723 | #define VM_USE_HOOKS 0 | |
6d14383e | 724 | #define FUNC_NAME "vm-regular-engine" |
83495480 | 725 | #include "vm-engine.c" |
6d14383e | 726 | #undef FUNC_NAME |
f42cfbf0 AW |
727 | #undef VM_USE_HOOKS |
728 | #undef VM_NAME | |
17e90c5e | 729 | |
f42cfbf0 AW |
730 | #define VM_NAME vm_debug_engine |
731 | #define VM_USE_HOOKS 1 | |
6d14383e | 732 | #define FUNC_NAME "vm-debug-engine" |
83495480 | 733 | #include "vm-engine.c" |
6d14383e | 734 | #undef FUNC_NAME |
f42cfbf0 AW |
735 | #undef VM_USE_HOOKS |
736 | #undef VM_NAME | |
17e90c5e | 737 | |
9b4c3ab5 AW |
738 | typedef SCM (*scm_t_vm_engine) (struct scm_vm *vp, |
739 | SCM program, SCM *argv, size_t nargs); | |
73c3db66 | 740 | |
f42cfbf0 AW |
741 | static const scm_t_vm_engine vm_engines[SCM_VM_NUM_ENGINES] = |
742 | { vm_regular_engine, vm_debug_engine }; | |
73c3db66 | 743 | |
e3eb628d LC |
744 | #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN |
745 | ||
746 | /* The GC "kind" for the VM stack. */ | |
747 | static int vm_stack_gc_kind; | |
748 | ||
749 | #endif | |
750 | ||
a98cef7e | 751 | static SCM |
17e90c5e KN |
752 | make_vm (void) |
753 | #define FUNC_NAME "make_vm" | |
a98cef7e | 754 | { |
17e90c5e | 755 | int i; |
7f991c7d | 756 | struct scm_vm *vp; |
747a1635 | 757 | |
7f991c7d | 758 | vp = scm_gc_malloc (sizeof (struct scm_vm), "vm"); |
d8eeb67c | 759 | |
aab9d46c | 760 | vp->stack_size= vm_stack_size; |
e3eb628d LC |
761 | |
762 | #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN | |
4168aa46 TTN |
763 | vp->stack_base = (SCM *) |
764 | GC_generic_malloc (vp->stack_size * sizeof (SCM), vm_stack_gc_kind); | |
e3eb628d LC |
765 | |
766 | /* Keep a pointer to VP so that `vm_stack_mark ()' can know what the stack | |
767 | top is. */ | |
21041372 | 768 | *vp->stack_base = SCM_PACK_POINTER (vp); |
e3eb628d LC |
769 | vp->stack_base++; |
770 | vp->stack_size--; | |
771 | #else | |
d8eeb67c LC |
772 | vp->stack_base = scm_gc_malloc (vp->stack_size * sizeof (SCM), |
773 | "stack-base"); | |
e3eb628d LC |
774 | #endif |
775 | ||
f1046e6b | 776 | vp->stack_limit = vp->stack_base + vp->stack_size - VM_STACK_RESERVE_SIZE; |
3616e9e9 KN |
777 | vp->ip = NULL; |
778 | vp->sp = vp->stack_base - 1; | |
779 | vp->fp = NULL; | |
ea9f4f4b | 780 | vp->engine = vm_default_engine; |
7656f194 | 781 | vp->trace_level = 0; |
17e90c5e | 782 | for (i = 0; i < SCM_VM_NUM_HOOKS; i++) |
3d5ee0cd | 783 | vp->hooks[i] = SCM_BOOL_F; |
6f3b0cc2 | 784 | return scm_cell (scm_tc7_vm, (scm_t_bits)vp); |
a98cef7e | 785 | } |
17e90c5e | 786 | #undef FUNC_NAME |
a98cef7e | 787 | |
e3eb628d LC |
788 | #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN |
789 | ||
790 | /* Mark the VM stack region between its base and its current top. */ | |
791 | static struct GC_ms_entry * | |
792 | vm_stack_mark (GC_word *addr, struct GC_ms_entry *mark_stack_ptr, | |
793 | struct GC_ms_entry *mark_stack_limit, GC_word env) | |
794 | { | |
795 | GC_word *word; | |
796 | const struct scm_vm *vm; | |
797 | ||
798 | /* The first word of the VM stack should contain a pointer to the | |
799 | corresponding VM. */ | |
800 | vm = * ((struct scm_vm **) addr); | |
801 | ||
8071c490 | 802 | if (vm == NULL |
f1046e6b | 803 | || (SCM *) addr != vm->stack_base - 1) |
e3eb628d LC |
804 | /* ADDR must be a pointer to a free-list element, which we must ignore |
805 | (see warning in <gc/gc_mark.h>). */ | |
806 | return mark_stack_ptr; | |
807 | ||
e3eb628d LC |
808 | for (word = (GC_word *) vm->stack_base; word <= (GC_word *) vm->sp; word++) |
809 | mark_stack_ptr = GC_MARK_AND_PUSH ((* (GC_word **) word), | |
810 | mark_stack_ptr, mark_stack_limit, | |
811 | NULL); | |
812 | ||
813 | return mark_stack_ptr; | |
814 | } | |
815 | ||
816 | #endif /* VM_ENABLE_PRECISE_STACK_GC_SCAN */ | |
817 | ||
818 | ||
6d14383e | 819 | SCM |
4abef68f | 820 | scm_c_vm_run (SCM vm, SCM program, SCM *argv, int nargs) |
6d14383e | 821 | { |
4abef68f | 822 | struct scm_vm *vp = SCM_VM_DATA (vm); |
b95d76fc | 823 | SCM_CHECK_STACK; |
9b4c3ab5 | 824 | return vm_engines[vp->engine](vp, program, argv, nargs); |
6d14383e AW |
825 | } |
826 | ||
55ee3607 AW |
827 | SCM |
828 | scm_call_n (SCM proc, SCM *argv, size_t nargs) | |
829 | { | |
830 | return scm_c_vm_run (scm_the_vm (), proc, argv, nargs); | |
831 | } | |
832 | ||
a222cbc9 AW |
833 | SCM |
834 | scm_the_vm (void) | |
271c3d31 | 835 | { |
ea9f4f4b AW |
836 | scm_i_thread *t = SCM_I_CURRENT_THREAD; |
837 | ||
838 | if (SCM_UNLIKELY (scm_is_false (t->vm))) | |
839 | t->vm = make_vm (); | |
840 | ||
841 | return t->vm; | |
271c3d31 | 842 | } |
499a4c07 | 843 | |
a222cbc9 | 844 | /* Scheme interface */ |
a98cef7e | 845 | |
17e90c5e KN |
846 | #define VM_DEFINE_HOOK(n) \ |
847 | { \ | |
3d5ee0cd | 848 | struct scm_vm *vp; \ |
972275ee | 849 | vp = SCM_VM_DATA (scm_the_vm ()); \ |
8b22ed7a | 850 | if (scm_is_false (vp->hooks[n])) \ |
238e7a11 | 851 | vp->hooks[n] = scm_make_hook (SCM_I_MAKINUM (1)); \ |
3d5ee0cd | 852 | return vp->hooks[n]; \ |
17e90c5e KN |
853 | } |
854 | ||
972275ee AW |
855 | SCM_DEFINE (scm_vm_apply_hook, "vm-apply-hook", 0, 0, 0, |
856 | (void), | |
17e90c5e | 857 | "") |
c45d4d77 | 858 | #define FUNC_NAME s_scm_vm_apply_hook |
a98cef7e | 859 | { |
c45d4d77 | 860 | VM_DEFINE_HOOK (SCM_VM_APPLY_HOOK); |
a98cef7e KN |
861 | } |
862 | #undef FUNC_NAME | |
863 | ||
972275ee AW |
864 | SCM_DEFINE (scm_vm_push_continuation_hook, "vm-push-continuation-hook", 0, 0, 0, |
865 | (void), | |
17e90c5e | 866 | "") |
c45d4d77 | 867 | #define FUNC_NAME s_scm_vm_push_continuation_hook |
a98cef7e | 868 | { |
c45d4d77 | 869 | VM_DEFINE_HOOK (SCM_VM_PUSH_CONTINUATION_HOOK); |
a98cef7e KN |
870 | } |
871 | #undef FUNC_NAME | |
872 | ||
972275ee AW |
873 | SCM_DEFINE (scm_vm_pop_continuation_hook, "vm-pop-continuation-hook", 0, 0, 0, |
874 | (void), | |
17e90c5e | 875 | "") |
c45d4d77 | 876 | #define FUNC_NAME s_scm_vm_pop_continuation_hook |
a98cef7e | 877 | { |
c45d4d77 | 878 | VM_DEFINE_HOOK (SCM_VM_POP_CONTINUATION_HOOK); |
a98cef7e KN |
879 | } |
880 | #undef FUNC_NAME | |
881 | ||
972275ee AW |
882 | SCM_DEFINE (scm_vm_next_hook, "vm-next-hook", 0, 0, 0, |
883 | (void), | |
17e90c5e | 884 | "") |
c45d4d77 | 885 | #define FUNC_NAME s_scm_vm_next_hook |
a98cef7e | 886 | { |
c45d4d77 | 887 | VM_DEFINE_HOOK (SCM_VM_NEXT_HOOK); |
a98cef7e KN |
888 | } |
889 | #undef FUNC_NAME | |
f3120251 | 890 | |
972275ee AW |
891 | SCM_DEFINE (scm_vm_abort_continuation_hook, "vm-abort-continuation-hook", 0, 0, 0, |
892 | (void), | |
f3120251 AW |
893 | "") |
894 | #define FUNC_NAME s_scm_vm_abort_continuation_hook | |
895 | { | |
896 | VM_DEFINE_HOOK (SCM_VM_ABORT_CONTINUATION_HOOK); | |
897 | } | |
898 | #undef FUNC_NAME | |
899 | ||
972275ee AW |
900 | SCM_DEFINE (scm_vm_restore_continuation_hook, "vm-restore-continuation-hook", 0, 0, 0, |
901 | (void), | |
f3120251 AW |
902 | "") |
903 | #define FUNC_NAME s_scm_vm_restore_continuation_hook | |
904 | { | |
905 | VM_DEFINE_HOOK (SCM_VM_RESTORE_CONTINUATION_HOOK); | |
906 | } | |
907 | #undef FUNC_NAME | |
a98cef7e | 908 | |
972275ee AW |
909 | SCM_DEFINE (scm_vm_trace_level, "vm-trace-level", 0, 0, 0, |
910 | (void), | |
17e90c5e | 911 | "") |
7656f194 | 912 | #define FUNC_NAME s_scm_vm_trace_level |
a98cef7e | 913 | { |
972275ee | 914 | return scm_from_int (SCM_VM_DATA (scm_the_vm ())->trace_level); |
7656f194 AW |
915 | } |
916 | #undef FUNC_NAME | |
917 | ||
972275ee AW |
918 | SCM_DEFINE (scm_set_vm_trace_level_x, "set-vm-trace-level!", 1, 0, 0, |
919 | (SCM level), | |
7656f194 AW |
920 | "") |
921 | #define FUNC_NAME s_scm_set_vm_trace_level_x | |
922 | { | |
972275ee | 923 | SCM_VM_DATA (scm_the_vm ())->trace_level = scm_to_int (level); |
7656f194 | 924 | return SCM_UNSPECIFIED; |
a98cef7e KN |
925 | } |
926 | #undef FUNC_NAME | |
927 | ||
928 | \f | |
ea9f4f4b AW |
929 | /* |
930 | * VM engines | |
931 | */ | |
932 | ||
933 | static int | |
934 | symbol_to_vm_engine (SCM engine, const char *FUNC_NAME) | |
935 | { | |
936 | if (scm_is_eq (engine, sym_regular)) | |
937 | return SCM_VM_REGULAR_ENGINE; | |
938 | else if (scm_is_eq (engine, sym_debug)) | |
939 | return SCM_VM_DEBUG_ENGINE; | |
940 | else | |
941 | SCM_MISC_ERROR ("Unknown VM engine: ~a", scm_list_1 (engine)); | |
942 | } | |
943 | ||
944 | static SCM | |
945 | vm_engine_to_symbol (int engine, const char *FUNC_NAME) | |
946 | { | |
947 | switch (engine) | |
948 | { | |
949 | case SCM_VM_REGULAR_ENGINE: | |
950 | return sym_regular; | |
951 | case SCM_VM_DEBUG_ENGINE: | |
952 | return sym_debug; | |
953 | default: | |
954 | /* ? */ | |
955 | SCM_MISC_ERROR ("Unknown VM engine: ~a", | |
956 | scm_list_1 (scm_from_int (engine))); | |
957 | } | |
958 | } | |
959 | ||
972275ee AW |
960 | SCM_DEFINE (scm_vm_engine, "vm-engine", 0, 0, 0, |
961 | (void), | |
ea9f4f4b AW |
962 | "") |
963 | #define FUNC_NAME s_scm_vm_engine | |
964 | { | |
972275ee | 965 | return vm_engine_to_symbol (SCM_VM_DATA (scm_the_vm ())->engine, FUNC_NAME); |
ea9f4f4b AW |
966 | } |
967 | #undef FUNC_NAME | |
968 | ||
969 | void | |
972275ee | 970 | scm_c_set_vm_engine_x (int engine) |
ea9f4f4b AW |
971 | #define FUNC_NAME "set-vm-engine!" |
972 | { | |
ea9f4f4b AW |
973 | if (engine < 0 || engine >= SCM_VM_NUM_ENGINES) |
974 | SCM_MISC_ERROR ("Unknown VM engine: ~a", | |
975 | scm_list_1 (scm_from_int (engine))); | |
976 | ||
972275ee | 977 | SCM_VM_DATA (scm_the_vm ())->engine = engine; |
ea9f4f4b AW |
978 | } |
979 | #undef FUNC_NAME | |
980 | ||
972275ee AW |
981 | SCM_DEFINE (scm_set_vm_engine_x, "set-vm-engine!", 1, 0, 0, |
982 | (SCM engine), | |
ea9f4f4b AW |
983 | "") |
984 | #define FUNC_NAME s_scm_set_vm_engine_x | |
985 | { | |
972275ee | 986 | scm_c_set_vm_engine_x (symbol_to_vm_engine (engine, FUNC_NAME)); |
ea9f4f4b AW |
987 | return SCM_UNSPECIFIED; |
988 | } | |
989 | #undef FUNC_NAME | |
990 | ||
991 | void | |
992 | scm_c_set_default_vm_engine_x (int engine) | |
993 | #define FUNC_NAME "set-default-vm-engine!" | |
994 | { | |
995 | if (engine < 0 || engine >= SCM_VM_NUM_ENGINES) | |
996 | SCM_MISC_ERROR ("Unknown VM engine: ~a", | |
997 | scm_list_1 (scm_from_int (engine))); | |
998 | ||
999 | vm_default_engine = engine; | |
1000 | } | |
1001 | #undef FUNC_NAME | |
1002 | ||
1003 | SCM_DEFINE (scm_set_default_vm_engine_x, "set-default-vm-engine!", 1, 0, 0, | |
1004 | (SCM engine), | |
1005 | "") | |
1006 | #define FUNC_NAME s_scm_set_default_vm_engine_x | |
1007 | { | |
1008 | scm_c_set_default_vm_engine_x (symbol_to_vm_engine (engine, FUNC_NAME)); | |
1009 | return SCM_UNSPECIFIED; | |
1010 | } | |
1011 | #undef FUNC_NAME | |
1012 | ||
972275ee AW |
1013 | /* FIXME: This function makes no sense, but we keep it to make sure we |
1014 | have a way of switching to the debug or regular VM. */ | |
1015 | SCM_DEFINE (scm_call_with_vm, "call-with-vm", 1, 0, 1, | |
1016 | (SCM proc, SCM args), | |
ea9f4f4b | 1017 | "Apply @var{proc} to @var{args} in a dynamic extent in which\n" |
972275ee | 1018 | "@var{vm} is the current VM.") |
ea9f4f4b AW |
1019 | #define FUNC_NAME s_scm_call_with_vm |
1020 | { | |
972275ee | 1021 | return scm_apply_0 (proc, args); |
ea9f4f4b AW |
1022 | } |
1023 | #undef FUNC_NAME | |
1024 | ||
1025 | \f | |
a98cef7e | 1026 | /* |
17e90c5e | 1027 | * Initialize |
a98cef7e KN |
1028 | */ |
1029 | ||
55ee3607 AW |
1030 | SCM |
1031 | scm_load_compiled_with_vm (SCM file) | |
07e56b27 | 1032 | { |
55ee3607 | 1033 | return scm_call_0 (scm_load_thunk_from_file (file)); |
07e56b27 AW |
1034 | } |
1035 | ||
67b699cc | 1036 | |
9f309e2c AW |
1037 | void |
1038 | scm_init_vm_builtin_properties (void) | |
1039 | { | |
1040 | /* FIXME: Seems hacky to do this here, but oh well :/ */ | |
1041 | scm_sym_apply = scm_from_utf8_symbol ("apply"); | |
1042 | scm_sym_values = scm_from_utf8_symbol ("values"); | |
1043 | scm_sym_abort_to_prompt = scm_from_utf8_symbol ("abort-to-prompt"); | |
1044 | scm_sym_call_with_values = scm_from_utf8_symbol ("call-with-values"); | |
1045 | scm_sym_call_with_current_continuation = | |
1046 | scm_from_utf8_symbol ("call-with-current-continuation"); | |
1047 | ||
1048 | #define INIT_BUILTIN(builtin, BUILTIN, req, opt, rest) \ | |
1049 | scm_set_procedure_property_x (vm_builtin_##builtin, scm_sym_name, \ | |
1050 | scm_sym_##builtin); \ | |
1051 | scm_set_procedure_minimum_arity_x (vm_builtin_##builtin, \ | |
1052 | SCM_I_MAKINUM (req), \ | |
1053 | SCM_I_MAKINUM (opt), \ | |
1054 | scm_from_bool (rest)); | |
1055 | FOR_EACH_VM_BUILTIN (INIT_BUILTIN); | |
1056 | #undef INIT_BUILTIN | |
1057 | } | |
1058 | ||
17e90c5e | 1059 | void |
07e56b27 | 1060 | scm_bootstrap_vm (void) |
17e90c5e | 1061 | { |
44602b08 AW |
1062 | scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION, |
1063 | "scm_init_vm", | |
60ae5ca2 | 1064 | (scm_t_extension_init_func)scm_init_vm, NULL); |
486013d6 AW |
1065 | scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION, |
1066 | "scm_init_vm_builtins", | |
1067 | (scm_t_extension_init_func)scm_init_vm_builtins, | |
1068 | NULL); | |
60ae5ca2 | 1069 | |
aab9d46c SIT |
1070 | initialize_default_stack_size (); |
1071 | ||
4a655e50 AW |
1072 | sym_vm_run = scm_from_latin1_symbol ("vm-run"); |
1073 | sym_vm_error = scm_from_latin1_symbol ("vm-error"); | |
1074 | sym_keyword_argument_error = scm_from_latin1_symbol ("keyword-argument-error"); | |
1075 | sym_regular = scm_from_latin1_symbol ("regular"); | |
1076 | sym_debug = scm_from_latin1_symbol ("debug"); | |
0404c97d | 1077 | |
ef6b7f71 AW |
1078 | vm_boot_continuation = scm_i_make_program (vm_boot_continuation_code); |
1079 | SCM_SET_CELL_WORD_0 (vm_boot_continuation, | |
1080 | (SCM_CELL_WORD_0 (vm_boot_continuation) | |
73c3db66 | 1081 | | SCM_F_PROGRAM_IS_BOOT)); |
9f309e2c AW |
1082 | |
1083 | #define DEFINE_BUILTIN(builtin, BUILTIN, req, opt, rest) \ | |
80797145 | 1084 | vm_builtin_##builtin = scm_i_make_program (vm_builtin_##builtin##_code); |
9f309e2c AW |
1085 | FOR_EACH_VM_BUILTIN (DEFINE_BUILTIN); |
1086 | #undef DEFINE_BUILTIN | |
73c3db66 | 1087 | |
e3eb628d LC |
1088 | #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN |
1089 | vm_stack_gc_kind = | |
1090 | GC_new_kind (GC_new_free_list (), | |
1091 | GC_MAKE_PROC (GC_new_proc (vm_stack_mark), 0), | |
1092 | 0, 1); | |
1093 | ||
1094 | #endif | |
07e56b27 AW |
1095 | } |
1096 | ||
1097 | void | |
1098 | scm_init_vm (void) | |
1099 | { | |
17e90c5e | 1100 | #ifndef SCM_MAGIC_SNARFER |
aeeff258 | 1101 | #include "libguile/vm.x" |
17e90c5e | 1102 | #endif |
a98cef7e | 1103 | } |
17e90c5e KN |
1104 | |
1105 | /* | |
1106 | Local Variables: | |
1107 | c-file-style: "gnu" | |
1108 | End: | |
1109 | */ |