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" |
8f5cfc81 | 36 | #include "objcodes.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 | ||
57 | /* We can add a mode that ensures that all stack items above the stack pointer | |
58 | are NULL. This is useful for checking the internal consistency of the VM's | |
59 | assumptions and its operators, but isn't necessary for normal operation. It | |
616167fc | 60 | will ensure that assertions are enabled. Slows down the VM by about 30%. */ |
747a1635 | 61 | /* NB! If you enable this, search for NULLING in throw.c */ |
616167fc | 62 | /* #define VM_ENABLE_STACK_NULLING */ |
11ea1aba | 63 | |
53e28ed9 AW |
64 | /* #define VM_ENABLE_PARANOID_ASSERTIONS */ |
65 | ||
11ea1aba AW |
66 | #if defined (VM_ENABLE_STACK_NULLING) && !defined (VM_ENABLE_ASSERTIONS) |
67 | #define VM_ENABLE_ASSERTIONS | |
68 | #endif | |
69 | ||
e3eb628d LC |
70 | /* When defined, arrange so that the GC doesn't scan the VM stack beyond its |
71 | current SP. This should help avoid excess data retention. See | |
72 | http://thread.gmane.org/gmane.comp.programming.garbage-collection.boehmgc/3001 | |
73 | for a discussion. */ | |
74 | #define VM_ENABLE_PRECISE_STACK_GC_SCAN | |
75 | ||
f1046e6b LC |
76 | /* Size in SCM objects of the stack reserve. The reserve is used to run |
77 | exception handling code in case of a VM stack overflow. */ | |
78 | #define VM_STACK_RESERVE_SIZE 512 | |
79 | ||
e3eb628d | 80 | |
a98cef7e | 81 | \f |
a98cef7e KN |
82 | /* |
83 | * VM Continuation | |
84 | */ | |
85 | ||
6f3b0cc2 AW |
86 | void |
87 | scm_i_vm_cont_print (SCM x, SCM port, scm_print_state *pstate) | |
88 | { | |
0607ebbf | 89 | scm_puts_unlocked ("#<vm-continuation ", port); |
6f3b0cc2 | 90 | scm_uintprint (SCM_UNPACK (x), 16, port); |
0607ebbf | 91 | scm_puts_unlocked (">", port); |
6f3b0cc2 | 92 | } |
17e90c5e | 93 | |
d8873dfe AW |
94 | /* In theory, a number of vm instances can be active in the call trace, and we |
95 | only want to reify the continuations of those in the current continuation | |
96 | root. I don't see a nice way to do this -- ideally it would involve dynwinds, | |
97 | and previous values of the *the-vm* fluid within the current continuation | |
98 | root. But we don't have access to continuation roots in the dynwind stack. | |
99 | So, just punt for now, we just capture the continuation for the current VM. | |
100 | ||
101 | While I'm on the topic, ideally we could avoid copying the C stack if the | |
102 | continuation root is inside VM code, and call/cc was invoked within that same | |
103 | call to vm_run; but that's currently not implemented. | |
104 | */ | |
cee1d22c AW |
105 | SCM |
106 | scm_i_vm_capture_stack (SCM *stack_base, SCM *fp, SCM *sp, scm_t_uint8 *ra, | |
9ede013f AW |
107 | scm_t_uint8 *mvra, scm_t_dynstack *dynstack, |
108 | scm_t_uint32 flags) | |
a98cef7e | 109 | { |
d8873dfe AW |
110 | struct scm_vm_cont *p; |
111 | ||
112 | p = scm_gc_malloc (sizeof (*p), "capture_vm_cont"); | |
113 | p->stack_size = sp - stack_base + 1; | |
d8eeb67c LC |
114 | p->stack_base = scm_gc_malloc (p->stack_size * sizeof (SCM), |
115 | "capture_vm_cont"); | |
d8873dfe AW |
116 | #if defined(VM_ENABLE_STACK_NULLING) && 0 |
117 | /* Tail continuations leave their frame on the stack for subsequent | |
118 | application, but don't capture the frame -- so there are some elements on | |
119 | the stack then, and this check doesn't work, so disable it for now. */ | |
120 | if (sp >= vp->stack_base) | |
66db076a AW |
121 | if (!vp->sp[0] || vp->sp[1]) |
122 | abort (); | |
11ea1aba AW |
123 | memset (p->stack_base, 0, p->stack_size * sizeof (SCM)); |
124 | #endif | |
d8873dfe AW |
125 | p->ra = ra; |
126 | p->mvra = mvra; | |
127 | p->sp = sp; | |
128 | p->fp = fp; | |
129 | memcpy (p->stack_base, stack_base, (sp + 1 - stack_base) * sizeof (SCM)); | |
130 | p->reloc = p->stack_base - stack_base; | |
9ede013f | 131 | p->dynstack = dynstack; |
cee1d22c | 132 | p->flags = flags; |
6f3b0cc2 | 133 | return scm_cell (scm_tc7_vm_cont, (scm_t_bits)p); |
a98cef7e KN |
134 | } |
135 | ||
136 | static void | |
d8873dfe | 137 | vm_return_to_continuation (SCM vm, SCM cont, size_t n, SCM *argv) |
a98cef7e | 138 | { |
d8873dfe AW |
139 | struct scm_vm *vp; |
140 | struct scm_vm_cont *cp; | |
141 | SCM *argv_copy; | |
142 | ||
143 | argv_copy = alloca (n * sizeof(SCM)); | |
144 | memcpy (argv_copy, argv, n * sizeof(SCM)); | |
145 | ||
146 | vp = SCM_VM_DATA (vm); | |
147 | cp = SCM_VM_CONT_DATA (cont); | |
148 | ||
149 | if (n == 0 && !cp->mvra) | |
150 | scm_misc_error (NULL, "Too few values returned to continuation", | |
151 | SCM_EOL); | |
152 | ||
153 | if (vp->stack_size < cp->stack_size + n + 1) | |
29366989 AW |
154 | scm_misc_error ("vm-engine", "not enough space to reinstate continuation", |
155 | scm_list_2 (vm, cont)); | |
156 | ||
11ea1aba AW |
157 | #ifdef VM_ENABLE_STACK_NULLING |
158 | { | |
d8873dfe | 159 | scm_t_ptrdiff nzero = (vp->sp - cp->sp); |
11ea1aba | 160 | if (nzero > 0) |
d8873dfe | 161 | memset (vp->stack_base + cp->stack_size, 0, nzero * sizeof (SCM)); |
66db076a AW |
162 | /* actually nzero should always be negative, because vm_reset_stack will |
163 | unwind the stack to some point *below* this continuation */ | |
11ea1aba AW |
164 | } |
165 | #endif | |
d8873dfe AW |
166 | vp->sp = cp->sp; |
167 | vp->fp = cp->fp; | |
168 | memcpy (vp->stack_base, cp->stack_base, cp->stack_size * sizeof (SCM)); | |
bfffd258 | 169 | |
d8873dfe AW |
170 | if (n == 1 || !cp->mvra) |
171 | { | |
172 | vp->ip = cp->ra; | |
173 | vp->sp++; | |
174 | *vp->sp = argv_copy[0]; | |
175 | } | |
176 | else | |
177 | { | |
178 | size_t i; | |
179 | for (i = 0; i < n; i++) | |
180 | { | |
181 | vp->sp++; | |
182 | *vp->sp = argv_copy[i]; | |
183 | } | |
184 | vp->sp++; | |
185 | *vp->sp = scm_from_size_t (n); | |
186 | vp->ip = cp->mvra; | |
187 | } | |
188 | } | |
bfffd258 | 189 | |
bfffd258 | 190 | SCM |
9ede013f | 191 | scm_i_capture_current_stack (void) |
bfffd258 | 192 | { |
9ede013f AW |
193 | scm_i_thread *thread; |
194 | SCM vm; | |
195 | struct scm_vm *vp; | |
196 | ||
197 | thread = SCM_I_CURRENT_THREAD; | |
198 | vm = scm_the_vm (); | |
199 | vp = SCM_VM_DATA (vm); | |
200 | ||
201 | return scm_i_vm_capture_stack (vp->stack_base, vp->fp, vp->sp, vp->ip, NULL, | |
202 | scm_dynstack_capture_all (&thread->dynstack), | |
203 | 0); | |
a98cef7e KN |
204 | } |
205 | ||
c850a0ff AW |
206 | static void vm_dispatch_hook (SCM vm, int hook_num, |
207 | SCM *argv, int n) SCM_NOINLINE; | |
208 | ||
b1b942b7 | 209 | static void |
c850a0ff | 210 | vm_dispatch_hook (SCM vm, int hook_num, SCM *argv, int n) |
b1b942b7 | 211 | { |
7656f194 AW |
212 | struct scm_vm *vp; |
213 | SCM hook; | |
b3567435 | 214 | struct scm_frame c_frame; |
8e4c60ff | 215 | scm_t_cell *frame; |
893fb8d0 | 216 | int saved_trace_level; |
b1b942b7 | 217 | |
7656f194 AW |
218 | vp = SCM_VM_DATA (vm); |
219 | hook = vp->hooks[hook_num]; | |
b1b942b7 | 220 | |
7656f194 AW |
221 | if (SCM_LIKELY (scm_is_false (hook)) |
222 | || scm_is_null (SCM_HOOK_PROCEDURES (hook))) | |
223 | return; | |
b3567435 | 224 | |
893fb8d0 AW |
225 | saved_trace_level = vp->trace_level; |
226 | vp->trace_level = 0; | |
b3567435 LC |
227 | |
228 | /* Allocate a frame object on the stack. This is more efficient than calling | |
229 | `scm_c_make_frame ()' to allocate on the heap, but it forces hooks to not | |
230 | capture frame objects. | |
231 | ||
232 | At the same time, procedures such as `frame-procedure' make sense only | |
233 | while the stack frame represented by the frame object is visible, so it | |
234 | seems reasonable to limit the lifetime of frame objects. */ | |
235 | ||
236 | c_frame.stack_holder = vm; | |
237 | c_frame.fp = vp->fp; | |
238 | c_frame.sp = vp->sp; | |
239 | c_frame.ip = vp->ip; | |
240 | c_frame.offset = 0; | |
8e4c60ff LC |
241 | |
242 | /* Arrange for FRAME to be 8-byte aligned, like any other cell. */ | |
243 | frame = alloca (sizeof (*frame) + 8); | |
244 | frame = (scm_t_cell *) ROUND_UP ((scm_t_uintptr) frame, 8UL); | |
245 | ||
246 | frame->word_0 = SCM_PACK (scm_tc7_frame); | |
21041372 | 247 | frame->word_1 = SCM_PACK_POINTER (&c_frame); |
b3567435 | 248 | |
c850a0ff AW |
249 | if (n == 0) |
250 | { | |
251 | SCM args[1]; | |
252 | ||
253 | args[0] = SCM_PACK_POINTER (frame); | |
254 | scm_c_run_hookn (hook, args, 1); | |
255 | } | |
256 | else if (n == 1) | |
257 | { | |
258 | SCM args[2]; | |
259 | ||
260 | args[0] = SCM_PACK_POINTER (frame); | |
261 | args[1] = argv[0]; | |
262 | scm_c_run_hookn (hook, args, 2); | |
263 | } | |
264 | else | |
265 | { | |
266 | SCM args = SCM_EOL; | |
267 | ||
268 | while (n--) | |
269 | args = scm_cons (argv[n], args); | |
270 | scm_c_run_hook (hook, scm_cons (SCM_PACK_POINTER (frame), args)); | |
271 | } | |
b3567435 | 272 | |
893fb8d0 | 273 | vp->trace_level = saved_trace_level; |
b1b942b7 AW |
274 | } |
275 | ||
4f66bcde | 276 | static void |
99511cd0 AW |
277 | vm_abort (SCM vm, SCM tag, size_t nstack, SCM *stack_args, SCM tail, SCM *sp, |
278 | scm_i_jmp_buf *current_registers) SCM_NORETURN; | |
9d381ba4 AW |
279 | |
280 | static void | |
99511cd0 AW |
281 | vm_abort (SCM vm, SCM tag, size_t nstack, SCM *stack_args, SCM tail, SCM *sp, |
282 | scm_i_jmp_buf *current_registers) | |
4f66bcde | 283 | { |
eaefabee | 284 | size_t i; |
2d026f04 | 285 | ssize_t tail_len; |
99511cd0 | 286 | SCM *argv; |
eaefabee | 287 | |
2d026f04 AW |
288 | tail_len = scm_ilength (tail); |
289 | if (tail_len < 0) | |
29366989 AW |
290 | scm_misc_error ("vm-engine", "tail values to abort should be a list", |
291 | scm_list_1 (tail)); | |
292 | ||
99511cd0 AW |
293 | argv = alloca ((nstack + tail_len) * sizeof (SCM)); |
294 | for (i = 0; i < nstack; i++) | |
295 | argv[i] = stack_args[i]; | |
296 | for (; i < nstack + tail_len; i++, tail = scm_cdr (tail)) | |
2d026f04 | 297 | argv[i] = scm_car (tail); |
eaefabee | 298 | |
99511cd0 AW |
299 | /* FIXME: NULLSTACK (SCM_VM_DATA (vp)->sp - sp) */ |
300 | SCM_VM_DATA (vm)->sp = sp; | |
301 | ||
302 | scm_c_abort (vm, tag, nstack + tail_len, argv, current_registers); | |
cee1d22c AW |
303 | } |
304 | ||
9d381ba4 AW |
305 | static void |
306 | vm_reinstate_partial_continuation (SCM vm, SCM cont, size_t n, SCM *argv, | |
307 | scm_t_dynstack *dynstack, | |
308 | scm_i_jmp_buf *registers) | |
cee1d22c | 309 | { |
07801437 AW |
310 | struct scm_vm *vp; |
311 | struct scm_vm_cont *cp; | |
312 | SCM *argv_copy, *base; | |
9ede013f | 313 | scm_t_ptrdiff reloc; |
07801437 AW |
314 | size_t i; |
315 | ||
316 | argv_copy = alloca (n * sizeof(SCM)); | |
317 | memcpy (argv_copy, argv, n * sizeof(SCM)); | |
318 | ||
319 | vp = SCM_VM_DATA (vm); | |
320 | cp = SCM_VM_CONT_DATA (cont); | |
321 | base = SCM_FRAME_UPPER_ADDRESS (vp->fp) + 1; | |
9ede013f | 322 | reloc = cp->reloc + (base - cp->stack_base); |
07801437 | 323 | |
0fc9040f | 324 | #define RELOC(scm_p) \ |
9ede013f | 325 | (((SCM *) (scm_p)) + reloc) |
07801437 AW |
326 | |
327 | if ((base - vp->stack_base) + cp->stack_size + n + 1 > vp->stack_size) | |
29366989 AW |
328 | scm_misc_error ("vm-engine", |
329 | "not enough space to instate partial continuation", | |
330 | scm_list_2 (vm, cont)); | |
07801437 AW |
331 | |
332 | memcpy (base, cp->stack_base, cp->stack_size * sizeof (SCM)); | |
333 | ||
334 | /* now relocate frame pointers */ | |
335 | { | |
336 | SCM *fp; | |
337 | for (fp = RELOC (cp->fp); | |
338 | SCM_FRAME_LOWER_ADDRESS (fp) > base; | |
339 | fp = SCM_FRAME_DYNAMIC_LINK (fp)) | |
340 | SCM_FRAME_SET_DYNAMIC_LINK (fp, RELOC (SCM_FRAME_DYNAMIC_LINK (fp))); | |
341 | } | |
342 | ||
343 | vp->sp = base - 1 + cp->stack_size; | |
344 | vp->fp = RELOC (cp->fp); | |
345 | vp->ip = cp->mvra; | |
346 | ||
07801437 AW |
347 | /* now push args. ip is in a MV context. */ |
348 | for (i = 0; i < n; i++) | |
349 | { | |
350 | vp->sp++; | |
351 | *vp->sp = argv_copy[i]; | |
352 | } | |
186b56c4 AW |
353 | #if 0 |
354 | /* The number-of-values marker, only used by the stack VM. */ | |
07801437 AW |
355 | vp->sp++; |
356 | *vp->sp = scm_from_size_t (n); | |
186b56c4 | 357 | #endif |
9a1c6f1f | 358 | |
9d381ba4 AW |
359 | /* The prompt captured a slice of the dynamic stack. Here we wind |
360 | those entries onto the current thread's stack. We also have to | |
361 | relocate any prompts that we see along the way. */ | |
362 | { | |
363 | scm_t_bits *walk; | |
364 | ||
365 | for (walk = SCM_DYNSTACK_FIRST (cp->dynstack); | |
366 | SCM_DYNSTACK_TAG (walk); | |
367 | walk = SCM_DYNSTACK_NEXT (walk)) | |
368 | { | |
369 | scm_t_bits tag = SCM_DYNSTACK_TAG (walk); | |
370 | ||
371 | if (SCM_DYNSTACK_TAG_TYPE (tag) == SCM_DYNSTACK_TYPE_PROMPT) | |
372 | scm_dynstack_wind_prompt (dynstack, walk, reloc, registers); | |
373 | else | |
374 | scm_dynstack_wind_1 (dynstack, walk); | |
375 | } | |
376 | } | |
adbdfd6d | 377 | #undef RELOC |
4f66bcde AW |
378 | } |
379 | ||
380 | \f | |
17e90c5e KN |
381 | /* |
382 | * VM Internal functions | |
383 | */ | |
384 | ||
6f3b0cc2 AW |
385 | void |
386 | scm_i_vm_print (SCM x, SCM port, scm_print_state *pstate) | |
387 | { | |
0a935b2a LC |
388 | const struct scm_vm *vm; |
389 | ||
390 | vm = SCM_VM_DATA (x); | |
391 | ||
0607ebbf | 392 | scm_puts_unlocked ("#<vm ", port); |
0a935b2a LC |
393 | switch (vm->engine) |
394 | { | |
395 | case SCM_VM_REGULAR_ENGINE: | |
0607ebbf | 396 | scm_puts_unlocked ("regular-engine ", port); |
0a935b2a LC |
397 | break; |
398 | ||
399 | case SCM_VM_DEBUG_ENGINE: | |
0607ebbf | 400 | scm_puts_unlocked ("debug-engine ", port); |
0a935b2a LC |
401 | break; |
402 | ||
403 | default: | |
0607ebbf | 404 | scm_puts_unlocked ("unknown-engine ", port); |
0a935b2a | 405 | } |
6f3b0cc2 | 406 | scm_uintprint (SCM_UNPACK (x), 16, port); |
0607ebbf | 407 | scm_puts_unlocked (">", port); |
6f3b0cc2 AW |
408 | } |
409 | ||
53bdfcf0 AW |
410 | \f |
411 | /* | |
412 | * VM Error Handling | |
413 | */ | |
414 | ||
415 | static void vm_error (const char *msg, SCM arg) SCM_NORETURN; | |
4d497b62 AW |
416 | static void vm_error_bad_instruction (scm_t_uint32 inst) SCM_NORETURN SCM_NOINLINE; |
417 | static void vm_error_unbound (SCM proc, SCM sym) SCM_NORETURN SCM_NOINLINE; | |
418 | static void vm_error_unbound_fluid (SCM proc, SCM fluid) SCM_NORETURN SCM_NOINLINE; | |
419 | static void vm_error_not_a_variable (const char *func_name, SCM x) SCM_NORETURN SCM_NOINLINE; | |
420 | static void vm_error_apply_to_non_list (SCM x) SCM_NORETURN SCM_NOINLINE; | |
421 | static void vm_error_kwargs_length_not_even (SCM proc) SCM_NORETURN SCM_NOINLINE; | |
28d5d253 MW |
422 | static void vm_error_kwargs_invalid_keyword (SCM proc, SCM obj) SCM_NORETURN SCM_NOINLINE; |
423 | static void vm_error_kwargs_unrecognized_keyword (SCM proc, SCM kw) SCM_NORETURN SCM_NOINLINE; | |
4d497b62 AW |
424 | static void vm_error_too_many_args (int nargs) SCM_NORETURN SCM_NOINLINE; |
425 | static void vm_error_wrong_num_args (SCM proc) SCM_NORETURN SCM_NOINLINE; | |
426 | static void vm_error_wrong_type_apply (SCM proc) SCM_NORETURN SCM_NOINLINE; | |
427 | static void vm_error_stack_overflow (struct scm_vm *vp) SCM_NORETURN SCM_NOINLINE; | |
428 | static void vm_error_stack_underflow (void) SCM_NORETURN SCM_NOINLINE; | |
429 | static void vm_error_improper_list (SCM x) SCM_NORETURN SCM_NOINLINE; | |
430 | static void vm_error_not_a_pair (const char *subr, SCM x) SCM_NORETURN SCM_NOINLINE; | |
431 | static void vm_error_not_a_bytevector (const char *subr, SCM x) SCM_NORETURN SCM_NOINLINE; | |
432 | static void vm_error_not_a_struct (const char *subr, SCM x) SCM_NORETURN SCM_NOINLINE; | |
433 | static void vm_error_no_values (void) SCM_NORETURN SCM_NOINLINE; | |
434 | static void vm_error_not_enough_values (void) SCM_NORETURN SCM_NOINLINE; | |
82f4bac4 | 435 | static void vm_error_wrong_number_of_values (scm_t_uint32 expected) SCM_NORETURN SCM_NOINLINE; |
4d497b62 AW |
436 | static void vm_error_continuation_not_rewindable (SCM cont) SCM_NORETURN SCM_NOINLINE; |
437 | static void vm_error_bad_wide_string_length (size_t len) SCM_NORETURN SCM_NOINLINE; | |
53bdfcf0 AW |
438 | |
439 | static void | |
440 | vm_error (const char *msg, SCM arg) | |
441 | { | |
442 | scm_throw (sym_vm_error, | |
443 | scm_list_3 (sym_vm_run, scm_from_latin1_string (msg), | |
444 | SCM_UNBNDP (arg) ? SCM_EOL : scm_list_1 (arg))); | |
445 | abort(); /* not reached */ | |
446 | } | |
447 | ||
448 | static void | |
449 | vm_error_bad_instruction (scm_t_uint32 inst) | |
450 | { | |
451 | vm_error ("VM: Bad instruction: ~s", scm_from_uint32 (inst)); | |
452 | } | |
453 | ||
454 | static void | |
455 | vm_error_unbound (SCM proc, SCM sym) | |
456 | { | |
457 | scm_error_scm (scm_misc_error_key, proc, | |
458 | scm_from_latin1_string ("Unbound variable: ~s"), | |
459 | scm_list_1 (sym), SCM_BOOL_F); | |
460 | } | |
461 | ||
462 | static void | |
463 | vm_error_unbound_fluid (SCM proc, SCM fluid) | |
464 | { | |
465 | scm_error_scm (scm_misc_error_key, proc, | |
466 | scm_from_latin1_string ("Unbound fluid: ~s"), | |
467 | scm_list_1 (fluid), SCM_BOOL_F); | |
468 | } | |
469 | ||
470 | static void | |
471 | vm_error_not_a_variable (const char *func_name, SCM x) | |
472 | { | |
473 | scm_error (scm_arg_type_key, func_name, "Not a variable: ~S", | |
474 | scm_list_1 (x), scm_list_1 (x)); | |
475 | } | |
476 | ||
53bdfcf0 AW |
477 | static void |
478 | vm_error_apply_to_non_list (SCM x) | |
479 | { | |
480 | scm_error (scm_arg_type_key, "apply", "Apply to non-list: ~S", | |
481 | scm_list_1 (x), scm_list_1 (x)); | |
482 | } | |
483 | ||
484 | static void | |
485 | vm_error_kwargs_length_not_even (SCM proc) | |
486 | { | |
487 | scm_error_scm (sym_keyword_argument_error, proc, | |
488 | scm_from_latin1_string ("Odd length of keyword argument list"), | |
489 | SCM_EOL, SCM_BOOL_F); | |
490 | } | |
491 | ||
492 | static void | |
4af0d97e | 493 | vm_error_kwargs_invalid_keyword (SCM proc, SCM obj) |
53bdfcf0 AW |
494 | { |
495 | scm_error_scm (sym_keyword_argument_error, proc, | |
496 | scm_from_latin1_string ("Invalid keyword"), | |
4af0d97e | 497 | SCM_EOL, scm_list_1 (obj)); |
53bdfcf0 AW |
498 | } |
499 | ||
500 | static void | |
4af0d97e | 501 | vm_error_kwargs_unrecognized_keyword (SCM proc, SCM kw) |
53bdfcf0 AW |
502 | { |
503 | scm_error_scm (sym_keyword_argument_error, proc, | |
504 | scm_from_latin1_string ("Unrecognized keyword"), | |
4af0d97e | 505 | SCM_EOL, scm_list_1 (kw)); |
53bdfcf0 AW |
506 | } |
507 | ||
508 | static void | |
509 | vm_error_too_many_args (int nargs) | |
510 | { | |
511 | vm_error ("VM: Too many arguments", scm_from_int (nargs)); | |
512 | } | |
513 | ||
514 | static void | |
515 | vm_error_wrong_num_args (SCM proc) | |
516 | { | |
517 | scm_wrong_num_args (proc); | |
518 | } | |
519 | ||
520 | static void | |
521 | vm_error_wrong_type_apply (SCM proc) | |
522 | { | |
523 | scm_error (scm_arg_type_key, NULL, "Wrong type to apply: ~S", | |
524 | scm_list_1 (proc), scm_list_1 (proc)); | |
525 | } | |
526 | ||
527 | static void | |
528 | vm_error_stack_overflow (struct scm_vm *vp) | |
529 | { | |
530 | if (vp->stack_limit < vp->stack_base + vp->stack_size) | |
531 | /* There are VM_STACK_RESERVE_SIZE bytes left. Make them available so | |
532 | that `throw' below can run on this VM. */ | |
533 | vp->stack_limit = vp->stack_base + vp->stack_size; | |
534 | else | |
535 | /* There is no space left on the stack. FIXME: Do something more | |
536 | sensible here! */ | |
537 | abort (); | |
538 | vm_error ("VM: Stack overflow", SCM_UNDEFINED); | |
539 | } | |
540 | ||
541 | static void | |
542 | vm_error_stack_underflow (void) | |
543 | { | |
544 | vm_error ("VM: Stack underflow", SCM_UNDEFINED); | |
545 | } | |
546 | ||
547 | static void | |
548 | vm_error_improper_list (SCM x) | |
549 | { | |
550 | vm_error ("Expected a proper list, but got object with tail ~s", x); | |
551 | } | |
552 | ||
553 | static void | |
554 | vm_error_not_a_pair (const char *subr, SCM x) | |
555 | { | |
556 | scm_wrong_type_arg_msg (subr, 1, x, "pair"); | |
557 | } | |
558 | ||
559 | static void | |
560 | vm_error_not_a_bytevector (const char *subr, SCM x) | |
561 | { | |
562 | scm_wrong_type_arg_msg (subr, 1, x, "bytevector"); | |
563 | } | |
564 | ||
565 | static void | |
566 | vm_error_not_a_struct (const char *subr, SCM x) | |
567 | { | |
568 | scm_wrong_type_arg_msg (subr, 1, x, "struct"); | |
569 | } | |
570 | ||
571 | static void | |
572 | vm_error_no_values (void) | |
573 | { | |
574 | vm_error ("Zero values returned to single-valued continuation", | |
575 | SCM_UNDEFINED); | |
576 | } | |
577 | ||
578 | static void | |
579 | vm_error_not_enough_values (void) | |
580 | { | |
581 | vm_error ("Too few values returned to continuation", SCM_UNDEFINED); | |
582 | } | |
583 | ||
82f4bac4 AW |
584 | static void |
585 | vm_error_wrong_number_of_values (scm_t_uint32 expected) | |
586 | { | |
587 | vm_error ("Wrong number of values returned to continuation (expected ~a)", | |
588 | scm_from_uint32 (expected)); | |
589 | } | |
590 | ||
53bdfcf0 AW |
591 | static void |
592 | vm_error_continuation_not_rewindable (SCM cont) | |
593 | { | |
594 | vm_error ("Unrewindable partial continuation", cont); | |
595 | } | |
596 | ||
597 | static void | |
598 | vm_error_bad_wide_string_length (size_t len) | |
599 | { | |
600 | vm_error ("VM: Bad wide string length: ~S", scm_from_size_t (len)); | |
601 | } | |
602 | ||
53bdfcf0 AW |
603 | |
604 | \f | |
28b119ee | 605 | |
67b699cc | 606 | static SCM boot_continuation; |
2fda0242 | 607 | |
510ca126 | 608 | static SCM rtl_boot_continuation; |
486013d6 AW |
609 | static SCM vm_builtin_apply; |
610 | static SCM vm_builtin_values; | |
611 | static SCM vm_builtin_abort_to_prompt; | |
612 | static SCM vm_builtin_call_with_values; | |
613 | static SCM vm_builtin_call_with_current_continuation; | |
510ca126 AW |
614 | |
615 | static const scm_t_uint32 rtl_boot_continuation_code[] = { | |
7396d216 | 616 | SCM_PACK_RTL_24 (scm_rtl_op_halt, 0) |
510ca126 AW |
617 | }; |
618 | ||
486013d6 AW |
619 | static const scm_t_uint32 vm_builtin_apply_code[] = { |
620 | SCM_PACK_RTL_24 (scm_rtl_op_assert_nargs_ge, 3), | |
621 | SCM_PACK_RTL_24 (scm_rtl_op_tail_apply, 0), /* proc in r1, args from r2 */ | |
510ca126 AW |
622 | }; |
623 | ||
486013d6 | 624 | static const scm_t_uint32 vm_builtin_values_code[] = { |
af95414f | 625 | SCM_PACK_RTL_24 (scm_rtl_op_return_values, 0) /* vals from r1 */ |
510ca126 AW |
626 | }; |
627 | ||
486013d6 AW |
628 | static const scm_t_uint32 vm_builtin_abort_to_prompt_code[] = { |
629 | SCM_PACK_RTL_24 (scm_rtl_op_assert_nargs_ge, 2), | |
630 | SCM_PACK_RTL_24 (scm_rtl_op_abort, 0), /* tag in r1, vals from r2 */ | |
631 | /* FIXME: Partial continuation should capture caller regs. */ | |
632 | SCM_PACK_RTL_24 (scm_rtl_op_return_values, 0) /* vals from r1 */ | |
633 | }; | |
634 | ||
635 | static const scm_t_uint32 vm_builtin_call_with_values_code[] = { | |
636 | SCM_PACK_RTL_24 (scm_rtl_op_assert_nargs_ee, 3), | |
637 | SCM_PACK_RTL_24 (scm_rtl_op_alloc_frame, 7), | |
638 | SCM_PACK_RTL_12_12 (scm_rtl_op_mov, 6, 1), | |
639 | SCM_PACK_RTL_24 (scm_rtl_op_call, 6), SCM_PACK_RTL_24 (0, 1), | |
640 | SCM_PACK_RTL_12_12 (scm_rtl_op_mov, 0, 2), | |
641 | SCM_PACK_RTL_24 (scm_rtl_op_tail_call_shuffle, 7) | |
642 | }; | |
643 | ||
644 | static const scm_t_uint32 vm_builtin_call_with_current_continuation_code[] = { | |
645 | SCM_PACK_RTL_24 (scm_rtl_op_assert_nargs_ee, 2), | |
646 | SCM_PACK_RTL_24 (scm_rtl_op_call_cc, 0) | |
647 | }; | |
648 | ||
649 | ||
650 | static SCM | |
651 | scm_vm_builtin_ref (unsigned idx) | |
652 | { | |
653 | switch (idx) | |
654 | { | |
655 | #define INDEX_TO_NAME(builtin, BUILTIN) \ | |
656 | case SCM_VM_BUILTIN_##BUILTIN: return vm_builtin_##builtin; | |
657 | FOR_EACH_VM_BUILTIN(INDEX_TO_NAME) | |
658 | #undef INDEX_TO_NAME | |
659 | default: abort(); | |
660 | } | |
661 | } | |
662 | ||
663 | static SCM scm_sym_values; | |
664 | static SCM scm_sym_abort_to_prompt; | |
665 | static SCM scm_sym_call_with_values; | |
666 | static SCM scm_sym_call_with_current_continuation; | |
667 | ||
668 | SCM | |
669 | scm_vm_builtin_name_to_index (SCM name) | |
670 | #define FUNC_NAME "builtin-name->index" | |
671 | { | |
672 | SCM_VALIDATE_SYMBOL (1, name); | |
673 | ||
674 | #define NAME_TO_INDEX(builtin, BUILTIN) \ | |
675 | if (scm_is_eq (name, scm_sym_##builtin)) \ | |
676 | return scm_from_uint (SCM_VM_BUILTIN_##BUILTIN); | |
677 | FOR_EACH_VM_BUILTIN(NAME_TO_INDEX) | |
678 | #undef NAME_TO_INDEX | |
679 | ||
680 | return SCM_BOOL_F; | |
681 | } | |
682 | #undef FUNC_NAME | |
683 | ||
684 | SCM | |
685 | scm_vm_builtin_index_to_name (SCM index) | |
686 | #define FUNC_NAME "builtin-index->name" | |
687 | { | |
688 | unsigned idx; | |
689 | ||
690 | SCM_VALIDATE_UINT_COPY (1, index, idx); | |
691 | ||
692 | switch (idx) | |
693 | { | |
694 | #define INDEX_TO_NAME(builtin, BUILTIN) \ | |
695 | case SCM_VM_BUILTIN_##BUILTIN: return scm_sym_##builtin; | |
696 | FOR_EACH_VM_BUILTIN(INDEX_TO_NAME) | |
697 | #undef INDEX_TO_NAME | |
698 | default: return SCM_BOOL_F; | |
699 | } | |
700 | } | |
701 | #undef FUNC_NAME | |
702 | ||
703 | static void | |
704 | scm_init_vm_builtins (void) | |
705 | { | |
706 | scm_sym_values = scm_from_utf8_symbol ("values"); | |
707 | scm_sym_abort_to_prompt = scm_from_utf8_symbol ("abort-to-prompt"); | |
708 | scm_sym_call_with_values = scm_from_utf8_symbol ("call-with-values"); | |
709 | scm_sym_call_with_current_continuation = | |
710 | scm_from_utf8_symbol ("call-with-current-continuation"); | |
711 | ||
712 | scm_c_define_gsubr ("builtin-name->index", 1, 0, 0, | |
713 | scm_vm_builtin_name_to_index); | |
714 | scm_c_define_gsubr ("builtin-index->name", 1, 0, 0, | |
715 | scm_vm_builtin_index_to_name); | |
716 | } | |
717 | ||
718 | SCM | |
719 | scm_i_call_with_current_continuation (SCM proc) | |
720 | { | |
721 | return scm_call_1 (vm_builtin_call_with_current_continuation, proc); | |
722 | } | |
510ca126 | 723 | |
a98cef7e KN |
724 | \f |
725 | /* | |
726 | * VM | |
727 | */ | |
728 | ||
b7393ea1 | 729 | static SCM |
b782ed01 | 730 | resolve_variable (SCM what, SCM module) |
b7393ea1 | 731 | { |
9bd48cb1 | 732 | if (SCM_LIKELY (scm_is_symbol (what))) |
b7393ea1 | 733 | { |
b782ed01 AW |
734 | if (scm_is_true (module)) |
735 | return scm_module_lookup (module, what); | |
b7393ea1 | 736 | else |
62e15979 | 737 | return scm_module_lookup (scm_the_root_module (), what); |
b7393ea1 AW |
738 | } |
739 | else | |
740 | { | |
b782ed01 AW |
741 | SCM modname, sym, public; |
742 | ||
743 | modname = SCM_CAR (what); | |
744 | sym = SCM_CADR (what); | |
745 | public = SCM_CADDR (what); | |
746 | ||
d6fbf0c0 AW |
747 | if (!scm_module_system_booted_p) |
748 | { | |
749 | #ifdef VM_ENABLE_PARANOID_ASSERTIONS | |
750 | ASSERT (scm_is_false (public)); | |
751 | ASSERT (scm_is_true | |
752 | (scm_equal_p (modname, | |
753 | scm_list_1 (scm_from_utf8_symbol ("guile"))))); | |
754 | #endif | |
755 | return scm_lookup (sym); | |
756 | } | |
757 | else if (scm_is_true (public)) | |
b782ed01 AW |
758 | return scm_public_lookup (modname, sym); |
759 | else | |
760 | return scm_private_lookup (modname, sym); | |
b7393ea1 AW |
761 | } |
762 | } | |
763 | ||
aab9d46c | 764 | #define VM_MIN_STACK_SIZE (1024) |
486013d6 | 765 | #define VM_DEFAULT_STACK_SIZE (256 * 1024) |
aab9d46c SIT |
766 | static size_t vm_stack_size = VM_DEFAULT_STACK_SIZE; |
767 | ||
768 | static void | |
769 | initialize_default_stack_size (void) | |
770 | { | |
771 | int size = scm_getenv_int ("GUILE_STACK_SIZE", vm_stack_size); | |
772 | if (size >= VM_MIN_STACK_SIZE) | |
773 | vm_stack_size = size; | |
774 | } | |
17e90c5e | 775 | |
17e90c5e | 776 | #define VM_NAME vm_regular_engine |
510ca126 | 777 | #define RTL_VM_NAME rtl_vm_regular_engine |
6d14383e AW |
778 | #define FUNC_NAME "vm-regular-engine" |
779 | #define VM_ENGINE SCM_VM_REGULAR_ENGINE | |
83495480 | 780 | #include "vm-engine.c" |
17e90c5e | 781 | #undef VM_NAME |
510ca126 | 782 | #undef RTL_VM_NAME |
6d14383e | 783 | #undef FUNC_NAME |
17e90c5e | 784 | #undef VM_ENGINE |
17e90c5e KN |
785 | |
786 | #define VM_NAME vm_debug_engine | |
510ca126 | 787 | #define RTL_VM_NAME rtl_vm_debug_engine |
6d14383e AW |
788 | #define FUNC_NAME "vm-debug-engine" |
789 | #define VM_ENGINE SCM_VM_DEBUG_ENGINE | |
83495480 | 790 | #include "vm-engine.c" |
17e90c5e | 791 | #undef VM_NAME |
510ca126 | 792 | #undef RTL_VM_NAME |
6d14383e | 793 | #undef FUNC_NAME |
17e90c5e KN |
794 | #undef VM_ENGINE |
795 | ||
6d14383e AW |
796 | static const scm_t_vm_engine vm_engines[] = |
797 | { vm_regular_engine, vm_debug_engine }; | |
798 | ||
73c3db66 AW |
799 | typedef SCM (*scm_t_rtl_vm_engine) (SCM vm, SCM program, SCM *argv, size_t nargs); |
800 | ||
801 | static const scm_t_rtl_vm_engine rtl_vm_engines[] = | |
802 | { rtl_vm_regular_engine, rtl_vm_debug_engine }; | |
803 | ||
e3eb628d LC |
804 | #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN |
805 | ||
806 | /* The GC "kind" for the VM stack. */ | |
807 | static int vm_stack_gc_kind; | |
808 | ||
809 | #endif | |
810 | ||
a98cef7e | 811 | static SCM |
17e90c5e KN |
812 | make_vm (void) |
813 | #define FUNC_NAME "make_vm" | |
a98cef7e | 814 | { |
17e90c5e | 815 | int i; |
7f991c7d | 816 | struct scm_vm *vp; |
747a1635 | 817 | |
7f991c7d | 818 | vp = scm_gc_malloc (sizeof (struct scm_vm), "vm"); |
d8eeb67c | 819 | |
aab9d46c | 820 | vp->stack_size= vm_stack_size; |
e3eb628d LC |
821 | |
822 | #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN | |
4168aa46 TTN |
823 | vp->stack_base = (SCM *) |
824 | GC_generic_malloc (vp->stack_size * sizeof (SCM), vm_stack_gc_kind); | |
e3eb628d LC |
825 | |
826 | /* Keep a pointer to VP so that `vm_stack_mark ()' can know what the stack | |
827 | top is. */ | |
21041372 | 828 | *vp->stack_base = SCM_PACK_POINTER (vp); |
e3eb628d LC |
829 | vp->stack_base++; |
830 | vp->stack_size--; | |
831 | #else | |
d8eeb67c LC |
832 | vp->stack_base = scm_gc_malloc (vp->stack_size * sizeof (SCM), |
833 | "stack-base"); | |
e3eb628d LC |
834 | #endif |
835 | ||
2bbe1533 AW |
836 | #ifdef VM_ENABLE_STACK_NULLING |
837 | memset (vp->stack_base, 0, vp->stack_size * sizeof (SCM)); | |
838 | #endif | |
f1046e6b | 839 | vp->stack_limit = vp->stack_base + vp->stack_size - VM_STACK_RESERVE_SIZE; |
3616e9e9 KN |
840 | vp->ip = NULL; |
841 | vp->sp = vp->stack_base - 1; | |
842 | vp->fp = NULL; | |
ea9f4f4b | 843 | vp->engine = vm_default_engine; |
7656f194 | 844 | vp->trace_level = 0; |
17e90c5e | 845 | for (i = 0; i < SCM_VM_NUM_HOOKS; i++) |
3d5ee0cd | 846 | vp->hooks[i] = SCM_BOOL_F; |
6f3b0cc2 | 847 | return scm_cell (scm_tc7_vm, (scm_t_bits)vp); |
a98cef7e | 848 | } |
17e90c5e | 849 | #undef FUNC_NAME |
a98cef7e | 850 | |
e3eb628d LC |
851 | #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN |
852 | ||
853 | /* Mark the VM stack region between its base and its current top. */ | |
854 | static struct GC_ms_entry * | |
855 | vm_stack_mark (GC_word *addr, struct GC_ms_entry *mark_stack_ptr, | |
856 | struct GC_ms_entry *mark_stack_limit, GC_word env) | |
857 | { | |
858 | GC_word *word; | |
859 | const struct scm_vm *vm; | |
860 | ||
861 | /* The first word of the VM stack should contain a pointer to the | |
862 | corresponding VM. */ | |
863 | vm = * ((struct scm_vm **) addr); | |
864 | ||
8071c490 | 865 | if (vm == NULL |
f1046e6b | 866 | || (SCM *) addr != vm->stack_base - 1) |
e3eb628d LC |
867 | /* ADDR must be a pointer to a free-list element, which we must ignore |
868 | (see warning in <gc/gc_mark.h>). */ | |
869 | return mark_stack_ptr; | |
870 | ||
e3eb628d LC |
871 | for (word = (GC_word *) vm->stack_base; word <= (GC_word *) vm->sp; word++) |
872 | mark_stack_ptr = GC_MARK_AND_PUSH ((* (GC_word **) word), | |
873 | mark_stack_ptr, mark_stack_limit, | |
874 | NULL); | |
875 | ||
876 | return mark_stack_ptr; | |
877 | } | |
878 | ||
879 | #endif /* VM_ENABLE_PRECISE_STACK_GC_SCAN */ | |
880 | ||
881 | ||
6d14383e | 882 | SCM |
4abef68f | 883 | scm_c_vm_run (SCM vm, SCM program, SCM *argv, int nargs) |
6d14383e | 884 | { |
4abef68f | 885 | struct scm_vm *vp = SCM_VM_DATA (vm); |
b95d76fc | 886 | SCM_CHECK_STACK; |
486013d6 | 887 | if (SCM_PROGRAM_P (program)) |
73c3db66 | 888 | return vm_engines[vp->engine](vm, program, argv, nargs); |
486013d6 AW |
889 | else |
890 | return rtl_vm_engines[vp->engine](vm, program, argv, nargs); | |
6d14383e AW |
891 | } |
892 | ||
a98cef7e KN |
893 | /* Scheme interface */ |
894 | ||
271c3d31 LC |
895 | SCM_DEFINE (scm_the_vm, "the-vm", 0, 0, 0, |
896 | (void), | |
897 | "Return the current thread's VM.") | |
898 | #define FUNC_NAME s_scm_the_vm | |
899 | { | |
ea9f4f4b AW |
900 | scm_i_thread *t = SCM_I_CURRENT_THREAD; |
901 | ||
902 | if (SCM_UNLIKELY (scm_is_false (t->vm))) | |
903 | t->vm = make_vm (); | |
904 | ||
905 | return t->vm; | |
271c3d31 | 906 | } |
499a4c07 KN |
907 | #undef FUNC_NAME |
908 | ||
909 | ||
a98cef7e KN |
910 | SCM_DEFINE (scm_vm_p, "vm?", 1, 0, 0, |
911 | (SCM obj), | |
17e90c5e | 912 | "") |
a98cef7e KN |
913 | #define FUNC_NAME s_scm_vm_p |
914 | { | |
9bd48cb1 | 915 | return scm_from_bool (SCM_VM_P (obj)); |
a98cef7e KN |
916 | } |
917 | #undef FUNC_NAME | |
918 | ||
919 | SCM_DEFINE (scm_make_vm, "make-vm", 0, 0, 0, | |
17e90c5e KN |
920 | (void), |
921 | "") | |
922 | #define FUNC_NAME s_scm_make_vm, | |
a98cef7e | 923 | { |
17e90c5e | 924 | return make_vm (); |
a98cef7e KN |
925 | } |
926 | #undef FUNC_NAME | |
927 | ||
17e90c5e | 928 | SCM_DEFINE (scm_vm_ip, "vm:ip", 1, 0, 0, |
a98cef7e | 929 | (SCM vm), |
17e90c5e KN |
930 | "") |
931 | #define FUNC_NAME s_scm_vm_ip | |
a98cef7e KN |
932 | { |
933 | SCM_VALIDATE_VM (1, vm); | |
3d27ef4b | 934 | return scm_from_unsigned_integer ((scm_t_bits) SCM_VM_DATA (vm)->ip); |
a98cef7e KN |
935 | } |
936 | #undef FUNC_NAME | |
937 | ||
938 | SCM_DEFINE (scm_vm_sp, "vm:sp", 1, 0, 0, | |
939 | (SCM vm), | |
17e90c5e | 940 | "") |
a98cef7e KN |
941 | #define FUNC_NAME s_scm_vm_sp |
942 | { | |
943 | SCM_VALIDATE_VM (1, vm); | |
3d27ef4b | 944 | return scm_from_unsigned_integer ((scm_t_bits) SCM_VM_DATA (vm)->sp); |
a98cef7e KN |
945 | } |
946 | #undef FUNC_NAME | |
947 | ||
948 | SCM_DEFINE (scm_vm_fp, "vm:fp", 1, 0, 0, | |
949 | (SCM vm), | |
17e90c5e | 950 | "") |
a98cef7e KN |
951 | #define FUNC_NAME s_scm_vm_fp |
952 | { | |
953 | SCM_VALIDATE_VM (1, vm); | |
3d27ef4b | 954 | return scm_from_unsigned_integer ((scm_t_bits) SCM_VM_DATA (vm)->fp); |
a98cef7e KN |
955 | } |
956 | #undef FUNC_NAME | |
957 | ||
17e90c5e KN |
958 | #define VM_DEFINE_HOOK(n) \ |
959 | { \ | |
3d5ee0cd | 960 | struct scm_vm *vp; \ |
17e90c5e | 961 | SCM_VALIDATE_VM (1, vm); \ |
3d5ee0cd | 962 | vp = SCM_VM_DATA (vm); \ |
8b22ed7a | 963 | if (scm_is_false (vp->hooks[n])) \ |
238e7a11 | 964 | vp->hooks[n] = scm_make_hook (SCM_I_MAKINUM (1)); \ |
3d5ee0cd | 965 | return vp->hooks[n]; \ |
17e90c5e KN |
966 | } |
967 | ||
c45d4d77 | 968 | SCM_DEFINE (scm_vm_apply_hook, "vm-apply-hook", 1, 0, 0, |
17e90c5e KN |
969 | (SCM vm), |
970 | "") | |
c45d4d77 | 971 | #define FUNC_NAME s_scm_vm_apply_hook |
a98cef7e | 972 | { |
c45d4d77 | 973 | VM_DEFINE_HOOK (SCM_VM_APPLY_HOOK); |
a98cef7e KN |
974 | } |
975 | #undef FUNC_NAME | |
976 | ||
c45d4d77 | 977 | SCM_DEFINE (scm_vm_push_continuation_hook, "vm-push-continuation-hook", 1, 0, 0, |
17e90c5e KN |
978 | (SCM vm), |
979 | "") | |
c45d4d77 | 980 | #define FUNC_NAME s_scm_vm_push_continuation_hook |
a98cef7e | 981 | { |
c45d4d77 | 982 | VM_DEFINE_HOOK (SCM_VM_PUSH_CONTINUATION_HOOK); |
a98cef7e KN |
983 | } |
984 | #undef FUNC_NAME | |
985 | ||
c45d4d77 | 986 | SCM_DEFINE (scm_vm_pop_continuation_hook, "vm-pop-continuation-hook", 1, 0, 0, |
a98cef7e | 987 | (SCM vm), |
17e90c5e | 988 | "") |
c45d4d77 | 989 | #define FUNC_NAME s_scm_vm_pop_continuation_hook |
a98cef7e | 990 | { |
c45d4d77 | 991 | VM_DEFINE_HOOK (SCM_VM_POP_CONTINUATION_HOOK); |
a98cef7e KN |
992 | } |
993 | #undef FUNC_NAME | |
994 | ||
c45d4d77 | 995 | SCM_DEFINE (scm_vm_next_hook, "vm-next-hook", 1, 0, 0, |
a98cef7e | 996 | (SCM vm), |
17e90c5e | 997 | "") |
c45d4d77 | 998 | #define FUNC_NAME s_scm_vm_next_hook |
a98cef7e | 999 | { |
c45d4d77 | 1000 | VM_DEFINE_HOOK (SCM_VM_NEXT_HOOK); |
a98cef7e KN |
1001 | } |
1002 | #undef FUNC_NAME | |
f3120251 AW |
1003 | |
1004 | SCM_DEFINE (scm_vm_abort_continuation_hook, "vm-abort-continuation-hook", 1, 0, 0, | |
1005 | (SCM vm), | |
1006 | "") | |
1007 | #define FUNC_NAME s_scm_vm_abort_continuation_hook | |
1008 | { | |
1009 | VM_DEFINE_HOOK (SCM_VM_ABORT_CONTINUATION_HOOK); | |
1010 | } | |
1011 | #undef FUNC_NAME | |
1012 | ||
1013 | SCM_DEFINE (scm_vm_restore_continuation_hook, "vm-restore-continuation-hook", 1, 0, 0, | |
1014 | (SCM vm), | |
1015 | "") | |
1016 | #define FUNC_NAME s_scm_vm_restore_continuation_hook | |
1017 | { | |
1018 | VM_DEFINE_HOOK (SCM_VM_RESTORE_CONTINUATION_HOOK); | |
1019 | } | |
1020 | #undef FUNC_NAME | |
a98cef7e | 1021 | |
7656f194 | 1022 | SCM_DEFINE (scm_vm_trace_level, "vm-trace-level", 1, 0, 0, |
17e90c5e KN |
1023 | (SCM vm), |
1024 | "") | |
7656f194 | 1025 | #define FUNC_NAME s_scm_vm_trace_level |
a98cef7e | 1026 | { |
a98cef7e | 1027 | SCM_VALIDATE_VM (1, vm); |
7656f194 AW |
1028 | return scm_from_int (SCM_VM_DATA (vm)->trace_level); |
1029 | } | |
1030 | #undef FUNC_NAME | |
1031 | ||
1032 | SCM_DEFINE (scm_set_vm_trace_level_x, "set-vm-trace-level!", 2, 0, 0, | |
1033 | (SCM vm, SCM level), | |
1034 | "") | |
1035 | #define FUNC_NAME s_scm_set_vm_trace_level_x | |
1036 | { | |
1037 | SCM_VALIDATE_VM (1, vm); | |
1038 | SCM_VM_DATA (vm)->trace_level = scm_to_int (level); | |
1039 | return SCM_UNSPECIFIED; | |
a98cef7e KN |
1040 | } |
1041 | #undef FUNC_NAME | |
1042 | ||
1043 | \f | |
ea9f4f4b AW |
1044 | /* |
1045 | * VM engines | |
1046 | */ | |
1047 | ||
1048 | static int | |
1049 | symbol_to_vm_engine (SCM engine, const char *FUNC_NAME) | |
1050 | { | |
1051 | if (scm_is_eq (engine, sym_regular)) | |
1052 | return SCM_VM_REGULAR_ENGINE; | |
1053 | else if (scm_is_eq (engine, sym_debug)) | |
1054 | return SCM_VM_DEBUG_ENGINE; | |
1055 | else | |
1056 | SCM_MISC_ERROR ("Unknown VM engine: ~a", scm_list_1 (engine)); | |
1057 | } | |
1058 | ||
1059 | static SCM | |
1060 | vm_engine_to_symbol (int engine, const char *FUNC_NAME) | |
1061 | { | |
1062 | switch (engine) | |
1063 | { | |
1064 | case SCM_VM_REGULAR_ENGINE: | |
1065 | return sym_regular; | |
1066 | case SCM_VM_DEBUG_ENGINE: | |
1067 | return sym_debug; | |
1068 | default: | |
1069 | /* ? */ | |
1070 | SCM_MISC_ERROR ("Unknown VM engine: ~a", | |
1071 | scm_list_1 (scm_from_int (engine))); | |
1072 | } | |
1073 | } | |
1074 | ||
ea9f4f4b AW |
1075 | SCM_DEFINE (scm_vm_engine, "vm-engine", 1, 0, 0, |
1076 | (SCM vm), | |
1077 | "") | |
1078 | #define FUNC_NAME s_scm_vm_engine | |
1079 | { | |
1080 | SCM_VALIDATE_VM (1, vm); | |
1081 | return vm_engine_to_symbol (SCM_VM_DATA (vm)->engine, FUNC_NAME); | |
1082 | } | |
1083 | #undef FUNC_NAME | |
1084 | ||
1085 | void | |
1086 | scm_c_set_vm_engine_x (SCM vm, int engine) | |
1087 | #define FUNC_NAME "set-vm-engine!" | |
1088 | { | |
1089 | SCM_VALIDATE_VM (1, vm); | |
1090 | ||
ea9f4f4b AW |
1091 | if (engine < 0 || engine >= SCM_VM_NUM_ENGINES) |
1092 | SCM_MISC_ERROR ("Unknown VM engine: ~a", | |
1093 | scm_list_1 (scm_from_int (engine))); | |
1094 | ||
1095 | SCM_VM_DATA (vm)->engine = engine; | |
1096 | } | |
1097 | #undef FUNC_NAME | |
1098 | ||
1099 | SCM_DEFINE (scm_set_vm_engine_x, "set-vm-engine!", 2, 0, 0, | |
1100 | (SCM vm, SCM engine), | |
1101 | "") | |
1102 | #define FUNC_NAME s_scm_set_vm_engine_x | |
1103 | { | |
1104 | scm_c_set_vm_engine_x (vm, symbol_to_vm_engine (engine, FUNC_NAME)); | |
1105 | return SCM_UNSPECIFIED; | |
1106 | } | |
1107 | #undef FUNC_NAME | |
1108 | ||
1109 | void | |
1110 | scm_c_set_default_vm_engine_x (int engine) | |
1111 | #define FUNC_NAME "set-default-vm-engine!" | |
1112 | { | |
1113 | if (engine < 0 || engine >= SCM_VM_NUM_ENGINES) | |
1114 | SCM_MISC_ERROR ("Unknown VM engine: ~a", | |
1115 | scm_list_1 (scm_from_int (engine))); | |
1116 | ||
1117 | vm_default_engine = engine; | |
1118 | } | |
1119 | #undef FUNC_NAME | |
1120 | ||
1121 | SCM_DEFINE (scm_set_default_vm_engine_x, "set-default-vm-engine!", 1, 0, 0, | |
1122 | (SCM engine), | |
1123 | "") | |
1124 | #define FUNC_NAME s_scm_set_default_vm_engine_x | |
1125 | { | |
1126 | scm_c_set_default_vm_engine_x (symbol_to_vm_engine (engine, FUNC_NAME)); | |
1127 | return SCM_UNSPECIFIED; | |
1128 | } | |
1129 | #undef FUNC_NAME | |
1130 | ||
1131 | static void reinstate_vm (SCM vm) | |
1132 | { | |
1133 | scm_i_thread *t = SCM_I_CURRENT_THREAD; | |
1134 | t->vm = vm; | |
1135 | } | |
1136 | ||
1137 | SCM_DEFINE (scm_call_with_vm, "call-with-vm", 2, 0, 1, | |
1138 | (SCM vm, SCM proc, SCM args), | |
1139 | "Apply @var{proc} to @var{args} in a dynamic extent in which\n" | |
1140 | "@var{vm} is the current VM.\n\n" | |
1141 | "As an implementation restriction, if @var{vm} is not the same\n" | |
1142 | "as the current thread's VM, continuations captured within the\n" | |
1143 | "call to @var{proc} may not be reinstated once control leaves\n" | |
1144 | "@var{proc}.") | |
1145 | #define FUNC_NAME s_scm_call_with_vm | |
1146 | { | |
1147 | SCM prev_vm, ret; | |
1148 | SCM *argv; | |
1149 | int i, nargs; | |
1150 | scm_t_wind_flags flags; | |
1151 | scm_i_thread *t = SCM_I_CURRENT_THREAD; | |
1152 | ||
1153 | SCM_VALIDATE_VM (1, vm); | |
1154 | SCM_VALIDATE_PROC (2, proc); | |
1155 | ||
1156 | nargs = scm_ilength (args); | |
1157 | if (SCM_UNLIKELY (nargs < 0)) | |
1158 | scm_wrong_type_arg_msg (FUNC_NAME, 3, args, "list"); | |
1159 | ||
1160 | argv = alloca (nargs * sizeof(SCM)); | |
1161 | for (i = 0; i < nargs; i++) | |
1162 | { | |
1163 | argv[i] = SCM_CAR (args); | |
1164 | args = SCM_CDR (args); | |
1165 | } | |
1166 | ||
1167 | prev_vm = t->vm; | |
1168 | ||
1169 | /* Reentry can happen via invokation of a saved continuation, but | |
1170 | continuations only save the state of the VM that they are in at | |
1171 | capture-time, which might be different from this one. So, in the | |
1172 | case that the VMs are different, set up a non-rewindable frame to | |
1173 | prevent reinstating an incomplete continuation. */ | |
1174 | flags = scm_is_eq (prev_vm, vm) ? 0 : SCM_F_WIND_EXPLICITLY; | |
1175 | if (flags) | |
1176 | { | |
1177 | scm_dynwind_begin (0); | |
1178 | scm_dynwind_unwind_handler_with_scm (reinstate_vm, prev_vm, flags); | |
1179 | t->vm = vm; | |
1180 | } | |
1181 | ||
1182 | ret = scm_c_vm_run (vm, proc, argv, nargs); | |
1183 | ||
1184 | if (flags) | |
1185 | scm_dynwind_end (); | |
1186 | ||
1187 | return ret; | |
1188 | } | |
1189 | #undef FUNC_NAME | |
1190 | ||
1191 | \f | |
a98cef7e | 1192 | /* |
17e90c5e | 1193 | * Initialize |
a98cef7e KN |
1194 | */ |
1195 | ||
07e56b27 AW |
1196 | SCM scm_load_compiled_with_vm (SCM file) |
1197 | { | |
b8bc86bc AW |
1198 | SCM program = scm_load_thunk_from_file (file); |
1199 | ||
4abef68f | 1200 | return scm_c_vm_run (scm_the_vm (), program, NULL, 0); |
07e56b27 AW |
1201 | } |
1202 | ||
67b699cc AW |
1203 | |
1204 | static SCM | |
1205 | make_boot_program (void) | |
1206 | { | |
1207 | struct scm_objcode *bp; | |
1208 | size_t bp_size; | |
1209 | SCM u8vec, ret; | |
968a9add AW |
1210 | |
1211 | const scm_t_uint8 text[] = { | |
67b699cc AW |
1212 | scm_op_make_int8_1, |
1213 | scm_op_halt | |
1214 | }; | |
1215 | ||
1216 | bp_size = sizeof (struct scm_objcode) + sizeof (text); | |
1217 | bp = scm_gc_malloc_pointerless (bp_size, "boot-program"); | |
1218 | memcpy (SCM_C_OBJCODE_BASE (bp), text, sizeof (text)); | |
1219 | bp->len = sizeof(text); | |
1220 | bp->metalen = 0; | |
1221 | ||
968a9add | 1222 | u8vec = scm_c_take_gc_bytevector ((scm_t_int8*)bp, bp_size, SCM_BOOL_F); |
b8bc86bc | 1223 | ret = scm_make_program (scm_bytecode_to_objcode (u8vec, SCM_UNDEFINED), |
67b699cc AW |
1224 | SCM_BOOL_F, SCM_BOOL_F); |
1225 | SCM_SET_CELL_WORD_0 (ret, (SCM_CELL_WORD_0 (ret) | SCM_F_PROGRAM_IS_BOOT)); | |
1226 | ||
1227 | return ret; | |
1228 | } | |
1229 | ||
17e90c5e | 1230 | void |
07e56b27 | 1231 | scm_bootstrap_vm (void) |
17e90c5e | 1232 | { |
44602b08 AW |
1233 | scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION, |
1234 | "scm_init_vm", | |
60ae5ca2 | 1235 | (scm_t_extension_init_func)scm_init_vm, NULL); |
486013d6 AW |
1236 | scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION, |
1237 | "scm_init_vm_builtins", | |
1238 | (scm_t_extension_init_func)scm_init_vm_builtins, | |
1239 | NULL); | |
60ae5ca2 | 1240 | |
aab9d46c SIT |
1241 | initialize_default_stack_size (); |
1242 | ||
4a655e50 AW |
1243 | sym_vm_run = scm_from_latin1_symbol ("vm-run"); |
1244 | sym_vm_error = scm_from_latin1_symbol ("vm-error"); | |
1245 | sym_keyword_argument_error = scm_from_latin1_symbol ("keyword-argument-error"); | |
1246 | sym_regular = scm_from_latin1_symbol ("regular"); | |
1247 | sym_debug = scm_from_latin1_symbol ("debug"); | |
0404c97d | 1248 | |
67b699cc AW |
1249 | boot_continuation = make_boot_program (); |
1250 | ||
73c3db66 AW |
1251 | rtl_boot_continuation = scm_i_make_rtl_program (rtl_boot_continuation_code); |
1252 | SCM_SET_CELL_WORD_0 (rtl_boot_continuation, | |
1253 | (SCM_CELL_WORD_0 (rtl_boot_continuation) | |
1254 | | SCM_F_PROGRAM_IS_BOOT)); | |
486013d6 AW |
1255 | vm_builtin_apply = scm_i_make_rtl_program (vm_builtin_apply_code); |
1256 | vm_builtin_values = scm_i_make_rtl_program (vm_builtin_values_code); | |
1257 | vm_builtin_abort_to_prompt = | |
1258 | scm_i_make_rtl_program (vm_builtin_abort_to_prompt_code); | |
1259 | vm_builtin_call_with_values = | |
1260 | scm_i_make_rtl_program (vm_builtin_call_with_values_code); | |
1261 | vm_builtin_call_with_current_continuation = | |
1262 | scm_i_make_rtl_program (vm_builtin_call_with_current_continuation_code); | |
73c3db66 | 1263 | |
e3eb628d LC |
1264 | #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN |
1265 | vm_stack_gc_kind = | |
1266 | GC_new_kind (GC_new_free_list (), | |
1267 | GC_MAKE_PROC (GC_new_proc (vm_stack_mark), 0), | |
1268 | 0, 1); | |
1269 | ||
1270 | #endif | |
07e56b27 AW |
1271 | } |
1272 | ||
1273 | void | |
1274 | scm_init_vm (void) | |
1275 | { | |
17e90c5e | 1276 | #ifndef SCM_MAGIC_SNARFER |
aeeff258 | 1277 | #include "libguile/vm.x" |
17e90c5e | 1278 | #endif |
a98cef7e | 1279 | } |
17e90c5e KN |
1280 | |
1281 | /* | |
1282 | Local Variables: | |
1283 | c-file-style: "gnu" | |
1284 | End: | |
1285 | */ |