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