Commit | Line | Data |
---|---|---|
0fc9040f | 1 | /* Copyright (C) 2001, 2009, 2010, 2011, 2012 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 | ||
97b18a66 | 40 | static int vm_default_engine = SCM_VM_REGULAR_ENGINE; |
ea9f4f4b AW |
41 | |
42 | /* Unfortunately we can't snarf these: snarfed things are only loaded up from | |
43 | (system vm vm), which might not be loaded before an error happens. */ | |
44 | static SCM sym_vm_run; | |
45 | static SCM sym_vm_error; | |
46 | static SCM sym_keyword_argument_error; | |
47 | static SCM sym_regular; | |
48 | static SCM sym_debug; | |
a98cef7e | 49 | |
11ea1aba AW |
50 | /* The VM has a number of internal assertions that shouldn't normally be |
51 | necessary, but might be if you think you found a bug in the VM. */ | |
52 | #define VM_ENABLE_ASSERTIONS | |
53 | ||
54 | /* We can add a mode that ensures that all stack items above the stack pointer | |
55 | are NULL. This is useful for checking the internal consistency of the VM's | |
56 | assumptions and its operators, but isn't necessary for normal operation. It | |
616167fc | 57 | will ensure that assertions are enabled. Slows down the VM by about 30%. */ |
747a1635 | 58 | /* NB! If you enable this, search for NULLING in throw.c */ |
616167fc | 59 | /* #define VM_ENABLE_STACK_NULLING */ |
11ea1aba | 60 | |
53e28ed9 AW |
61 | /* #define VM_ENABLE_PARANOID_ASSERTIONS */ |
62 | ||
11ea1aba AW |
63 | #if defined (VM_ENABLE_STACK_NULLING) && !defined (VM_ENABLE_ASSERTIONS) |
64 | #define VM_ENABLE_ASSERTIONS | |
65 | #endif | |
66 | ||
e3eb628d LC |
67 | /* When defined, arrange so that the GC doesn't scan the VM stack beyond its |
68 | current SP. This should help avoid excess data retention. See | |
69 | http://thread.gmane.org/gmane.comp.programming.garbage-collection.boehmgc/3001 | |
70 | for a discussion. */ | |
71 | #define VM_ENABLE_PRECISE_STACK_GC_SCAN | |
72 | ||
f1046e6b LC |
73 | /* Size in SCM objects of the stack reserve. The reserve is used to run |
74 | exception handling code in case of a VM stack overflow. */ | |
75 | #define VM_STACK_RESERVE_SIZE 512 | |
76 | ||
e3eb628d | 77 | |
a98cef7e | 78 | \f |
a98cef7e KN |
79 | /* |
80 | * VM Continuation | |
81 | */ | |
82 | ||
6f3b0cc2 AW |
83 | void |
84 | scm_i_vm_cont_print (SCM x, SCM port, scm_print_state *pstate) | |
85 | { | |
0607ebbf | 86 | scm_puts_unlocked ("#<vm-continuation ", port); |
6f3b0cc2 | 87 | scm_uintprint (SCM_UNPACK (x), 16, port); |
0607ebbf | 88 | scm_puts_unlocked (">", port); |
6f3b0cc2 | 89 | } |
17e90c5e | 90 | |
d8873dfe AW |
91 | /* In theory, a number of vm instances can be active in the call trace, and we |
92 | only want to reify the continuations of those in the current continuation | |
93 | root. I don't see a nice way to do this -- ideally it would involve dynwinds, | |
94 | and previous values of the *the-vm* fluid within the current continuation | |
95 | root. But we don't have access to continuation roots in the dynwind stack. | |
96 | So, just punt for now, we just capture the continuation for the current VM. | |
97 | ||
98 | While I'm on the topic, ideally we could avoid copying the C stack if the | |
99 | continuation root is inside VM code, and call/cc was invoked within that same | |
100 | call to vm_run; but that's currently not implemented. | |
101 | */ | |
cee1d22c AW |
102 | SCM |
103 | scm_i_vm_capture_stack (SCM *stack_base, SCM *fp, SCM *sp, scm_t_uint8 *ra, | |
9ede013f AW |
104 | scm_t_uint8 *mvra, scm_t_dynstack *dynstack, |
105 | scm_t_uint32 flags) | |
a98cef7e | 106 | { |
d8873dfe AW |
107 | struct scm_vm_cont *p; |
108 | ||
109 | p = scm_gc_malloc (sizeof (*p), "capture_vm_cont"); | |
110 | p->stack_size = sp - stack_base + 1; | |
d8eeb67c LC |
111 | p->stack_base = scm_gc_malloc (p->stack_size * sizeof (SCM), |
112 | "capture_vm_cont"); | |
d8873dfe AW |
113 | #if defined(VM_ENABLE_STACK_NULLING) && 0 |
114 | /* Tail continuations leave their frame on the stack for subsequent | |
115 | application, but don't capture the frame -- so there are some elements on | |
116 | the stack then, and this check doesn't work, so disable it for now. */ | |
117 | if (sp >= vp->stack_base) | |
66db076a AW |
118 | if (!vp->sp[0] || vp->sp[1]) |
119 | abort (); | |
11ea1aba AW |
120 | memset (p->stack_base, 0, p->stack_size * sizeof (SCM)); |
121 | #endif | |
d8873dfe AW |
122 | p->ra = ra; |
123 | p->mvra = mvra; | |
124 | p->sp = sp; | |
125 | p->fp = fp; | |
126 | memcpy (p->stack_base, stack_base, (sp + 1 - stack_base) * sizeof (SCM)); | |
127 | p->reloc = p->stack_base - stack_base; | |
9ede013f | 128 | p->dynstack = dynstack; |
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 |
9ede013f | 188 | scm_i_capture_current_stack (void) |
bfffd258 | 189 | { |
9ede013f AW |
190 | scm_i_thread *thread; |
191 | SCM vm; | |
192 | struct scm_vm *vp; | |
193 | ||
194 | thread = SCM_I_CURRENT_THREAD; | |
195 | vm = scm_the_vm (); | |
196 | vp = SCM_VM_DATA (vm); | |
197 | ||
198 | return scm_i_vm_capture_stack (vp->stack_base, vp->fp, vp->sp, vp->ip, NULL, | |
199 | scm_dynstack_capture_all (&thread->dynstack), | |
200 | 0); | |
a98cef7e KN |
201 | } |
202 | ||
b1b942b7 | 203 | static void |
7656f194 | 204 | vm_dispatch_hook (SCM vm, int hook_num) |
b1b942b7 | 205 | { |
7656f194 AW |
206 | struct scm_vm *vp; |
207 | SCM hook; | |
b3567435 | 208 | struct scm_frame c_frame; |
8e4c60ff | 209 | scm_t_cell *frame; |
b3567435 | 210 | SCM args[1]; |
893fb8d0 | 211 | int saved_trace_level; |
b1b942b7 | 212 | |
7656f194 AW |
213 | vp = SCM_VM_DATA (vm); |
214 | hook = vp->hooks[hook_num]; | |
b1b942b7 | 215 | |
7656f194 AW |
216 | if (SCM_LIKELY (scm_is_false (hook)) |
217 | || scm_is_null (SCM_HOOK_PROCEDURES (hook))) | |
218 | return; | |
b3567435 | 219 | |
893fb8d0 AW |
220 | saved_trace_level = vp->trace_level; |
221 | vp->trace_level = 0; | |
b3567435 LC |
222 | |
223 | /* Allocate a frame object on the stack. This is more efficient than calling | |
224 | `scm_c_make_frame ()' to allocate on the heap, but it forces hooks to not | |
225 | capture frame objects. | |
226 | ||
227 | At the same time, procedures such as `frame-procedure' make sense only | |
228 | while the stack frame represented by the frame object is visible, so it | |
229 | seems reasonable to limit the lifetime of frame objects. */ | |
230 | ||
231 | c_frame.stack_holder = vm; | |
232 | c_frame.fp = vp->fp; | |
233 | c_frame.sp = vp->sp; | |
234 | c_frame.ip = vp->ip; | |
235 | c_frame.offset = 0; | |
8e4c60ff LC |
236 | |
237 | /* Arrange for FRAME to be 8-byte aligned, like any other cell. */ | |
238 | frame = alloca (sizeof (*frame) + 8); | |
239 | frame = (scm_t_cell *) ROUND_UP ((scm_t_uintptr) frame, 8UL); | |
240 | ||
241 | frame->word_0 = SCM_PACK (scm_tc7_frame); | |
21041372 AW |
242 | frame->word_1 = SCM_PACK_POINTER (&c_frame); |
243 | args[0] = SCM_PACK_POINTER (frame); | |
b3567435 LC |
244 | |
245 | scm_c_run_hookn (hook, args, 1); | |
246 | ||
893fb8d0 | 247 | vp->trace_level = saved_trace_level; |
b1b942b7 AW |
248 | } |
249 | ||
4f66bcde | 250 | static void |
9d381ba4 AW |
251 | vm_abort (SCM vm, size_t n, scm_i_jmp_buf *current_registers) SCM_NORETURN; |
252 | ||
253 | static void | |
254 | vm_abort (SCM vm, size_t n, scm_i_jmp_buf *current_registers) | |
4f66bcde | 255 | { |
eaefabee | 256 | size_t i; |
2d026f04 AW |
257 | ssize_t tail_len; |
258 | SCM tag, tail, *argv; | |
eaefabee | 259 | |
2d026f04 AW |
260 | /* FIXME: VM_ENABLE_STACK_NULLING */ |
261 | tail = *(SCM_VM_DATA (vm)->sp--); | |
262 | /* NULLSTACK (1) */ | |
263 | tail_len = scm_ilength (tail); | |
264 | if (tail_len < 0) | |
29366989 AW |
265 | scm_misc_error ("vm-engine", "tail values to abort should be a list", |
266 | scm_list_1 (tail)); | |
267 | ||
eaefabee | 268 | tag = SCM_VM_DATA (vm)->sp[-n]; |
2d026f04 | 269 | argv = alloca ((n + tail_len) * sizeof (SCM)); |
eaefabee AW |
270 | for (i = 0; i < n; i++) |
271 | argv[i] = SCM_VM_DATA (vm)->sp[-(n-1-i)]; | |
2d026f04 AW |
272 | for (; i < n + tail_len; i++, tail = scm_cdr (tail)) |
273 | argv[i] = scm_car (tail); | |
274 | /* NULLSTACK (n + 1) */ | |
eaefabee AW |
275 | SCM_VM_DATA (vm)->sp -= n + 1; |
276 | ||
9d381ba4 | 277 | scm_c_abort (vm, tag, n + tail_len, argv, current_registers); |
cee1d22c AW |
278 | } |
279 | ||
9d381ba4 AW |
280 | static void |
281 | vm_reinstate_partial_continuation (SCM vm, SCM cont, size_t n, SCM *argv, | |
282 | scm_t_dynstack *dynstack, | |
283 | scm_i_jmp_buf *registers) | |
cee1d22c | 284 | { |
07801437 AW |
285 | struct scm_vm *vp; |
286 | struct scm_vm_cont *cp; | |
287 | SCM *argv_copy, *base; | |
9ede013f | 288 | scm_t_ptrdiff reloc; |
07801437 AW |
289 | size_t i; |
290 | ||
291 | argv_copy = alloca (n * sizeof(SCM)); | |
292 | memcpy (argv_copy, argv, n * sizeof(SCM)); | |
293 | ||
294 | vp = SCM_VM_DATA (vm); | |
295 | cp = SCM_VM_CONT_DATA (cont); | |
296 | base = SCM_FRAME_UPPER_ADDRESS (vp->fp) + 1; | |
9ede013f | 297 | reloc = cp->reloc + (base - cp->stack_base); |
07801437 | 298 | |
0fc9040f | 299 | #define RELOC(scm_p) \ |
9ede013f | 300 | (((SCM *) (scm_p)) + reloc) |
07801437 AW |
301 | |
302 | if ((base - vp->stack_base) + cp->stack_size + n + 1 > vp->stack_size) | |
29366989 AW |
303 | scm_misc_error ("vm-engine", |
304 | "not enough space to instate partial continuation", | |
305 | scm_list_2 (vm, cont)); | |
07801437 AW |
306 | |
307 | memcpy (base, cp->stack_base, cp->stack_size * sizeof (SCM)); | |
308 | ||
309 | /* now relocate frame pointers */ | |
310 | { | |
311 | SCM *fp; | |
312 | for (fp = RELOC (cp->fp); | |
313 | SCM_FRAME_LOWER_ADDRESS (fp) > base; | |
314 | fp = SCM_FRAME_DYNAMIC_LINK (fp)) | |
315 | SCM_FRAME_SET_DYNAMIC_LINK (fp, RELOC (SCM_FRAME_DYNAMIC_LINK (fp))); | |
316 | } | |
317 | ||
318 | vp->sp = base - 1 + cp->stack_size; | |
319 | vp->fp = RELOC (cp->fp); | |
320 | vp->ip = cp->mvra; | |
321 | ||
07801437 AW |
322 | /* now push args. ip is in a MV context. */ |
323 | for (i = 0; i < n; i++) | |
324 | { | |
325 | vp->sp++; | |
326 | *vp->sp = argv_copy[i]; | |
327 | } | |
328 | vp->sp++; | |
329 | *vp->sp = scm_from_size_t (n); | |
9a1c6f1f | 330 | |
9d381ba4 AW |
331 | /* The prompt captured a slice of the dynamic stack. Here we wind |
332 | those entries onto the current thread's stack. We also have to | |
333 | relocate any prompts that we see along the way. */ | |
334 | { | |
335 | scm_t_bits *walk; | |
336 | ||
337 | for (walk = SCM_DYNSTACK_FIRST (cp->dynstack); | |
338 | SCM_DYNSTACK_TAG (walk); | |
339 | walk = SCM_DYNSTACK_NEXT (walk)) | |
340 | { | |
341 | scm_t_bits tag = SCM_DYNSTACK_TAG (walk); | |
342 | ||
343 | if (SCM_DYNSTACK_TAG_TYPE (tag) == SCM_DYNSTACK_TYPE_PROMPT) | |
344 | scm_dynstack_wind_prompt (dynstack, walk, reloc, registers); | |
345 | else | |
346 | scm_dynstack_wind_1 (dynstack, walk); | |
347 | } | |
348 | } | |
adbdfd6d | 349 | #undef RELOC |
4f66bcde AW |
350 | } |
351 | ||
352 | \f | |
17e90c5e KN |
353 | /* |
354 | * VM Internal functions | |
355 | */ | |
356 | ||
6f3b0cc2 AW |
357 | void |
358 | scm_i_vm_print (SCM x, SCM port, scm_print_state *pstate) | |
359 | { | |
0a935b2a LC |
360 | const struct scm_vm *vm; |
361 | ||
362 | vm = SCM_VM_DATA (x); | |
363 | ||
0607ebbf | 364 | scm_puts_unlocked ("#<vm ", port); |
0a935b2a LC |
365 | switch (vm->engine) |
366 | { | |
367 | case SCM_VM_REGULAR_ENGINE: | |
0607ebbf | 368 | scm_puts_unlocked ("regular-engine ", port); |
0a935b2a LC |
369 | break; |
370 | ||
371 | case SCM_VM_DEBUG_ENGINE: | |
0607ebbf | 372 | scm_puts_unlocked ("debug-engine ", port); |
0a935b2a LC |
373 | break; |
374 | ||
375 | default: | |
0607ebbf | 376 | scm_puts_unlocked ("unknown-engine ", port); |
0a935b2a | 377 | } |
6f3b0cc2 | 378 | scm_uintprint (SCM_UNPACK (x), 16, port); |
0607ebbf | 379 | scm_puts_unlocked (">", port); |
6f3b0cc2 AW |
380 | } |
381 | ||
2fda0242 | 382 | static SCM |
d2d7acd5 | 383 | really_make_boot_program (long nargs) |
2fda0242 | 384 | { |
5bd047ce | 385 | SCM u8vec; |
97fcf583 AW |
386 | scm_t_uint8 text[] = { scm_op_mv_call, 0, 0, 0, 1, |
387 | scm_op_make_int8_1, scm_op_halt }; | |
28b119ee | 388 | struct scm_objcode *bp; |
3b9e095b | 389 | SCM ret; |
5bd047ce | 390 | |
53e28ed9 | 391 | if (SCM_UNLIKELY (nargs > 255 || nargs < 0)) |
29366989 AW |
392 | scm_misc_error ("vm-engine", "too many args when making boot procedure", |
393 | scm_list_1 (scm_from_long (nargs))); | |
394 | ||
28b119ee AW |
395 | text[1] = (scm_t_uint8)nargs; |
396 | ||
fb031aba AW |
397 | bp = scm_gc_malloc_pointerless (sizeof (struct scm_objcode) + sizeof (text), |
398 | "boot-program"); | |
3dbbe28d | 399 | memcpy (SCM_C_OBJCODE_BASE (bp), text, sizeof (text)); |
28b119ee AW |
400 | bp->len = sizeof(text); |
401 | bp->metalen = 0; | |
28b119ee | 402 | |
fb031aba | 403 | u8vec = scm_c_take_gc_bytevector ((scm_t_int8*)bp, |
8b66aa8f AW |
404 | sizeof (struct scm_objcode) + sizeof (text), |
405 | SCM_BOOL_F); | |
de2c0a10 | 406 | ret = scm_make_program (scm_bytecode_to_native_objcode (u8vec), |
20d47c39 | 407 | SCM_BOOL_F, SCM_BOOL_F); |
ba20f78a | 408 | SCM_SET_CELL_WORD_0 (ret, SCM_CELL_WORD_0 (ret) | SCM_F_PROGRAM_IS_BOOT); |
5bd047ce | 409 | |
3b9e095b | 410 | return ret; |
2fda0242 | 411 | } |
d2d7acd5 AW |
412 | #define NUM_BOOT_PROGS 8 |
413 | static SCM | |
414 | vm_make_boot_program (long nargs) | |
415 | { | |
0b0ac740 | 416 | static SCM programs[NUM_BOOT_PROGS] = { SCM_BOOL_F, }; |
d2d7acd5 | 417 | |
0b0ac740 | 418 | if (SCM_UNLIKELY (scm_is_false (programs[0]))) |
d2d7acd5 AW |
419 | { |
420 | int i; | |
421 | for (i = 0; i < NUM_BOOT_PROGS; i++) | |
f39448c5 | 422 | programs[i] = really_make_boot_program (i); |
d2d7acd5 AW |
423 | } |
424 | ||
425 | if (SCM_LIKELY (nargs < NUM_BOOT_PROGS)) | |
426 | return programs[nargs]; | |
427 | else | |
428 | return really_make_boot_program (nargs); | |
429 | } | |
2fda0242 | 430 | |
a98cef7e KN |
431 | \f |
432 | /* | |
433 | * VM | |
434 | */ | |
435 | ||
80be163f AW |
436 | /* We are calling a SMOB. The calling code pushed the SMOB after the |
437 | args, and incremented nargs. That nargs is passed here. This | |
438 | function's job is to replace the procedure with the trampoline, and | |
439 | shuffle the smob itself to be argument 0. This function must not | |
440 | allocate or throw, as the VM registers are not synchronized. */ | |
441 | static void | |
442 | prepare_smob_call (SCM *sp, int nargs, SCM smob) | |
443 | { | |
444 | SCM *args = sp - nargs + 1; | |
445 | ||
446 | /* Shuffle args up. */ | |
447 | while (nargs--) | |
448 | args[nargs + 1] = args[nargs]; | |
449 | ||
450 | args[0] = smob; | |
451 | args[-1] = SCM_SMOB_DESCRIPTOR (smob).apply_trampoline; | |
452 | } | |
453 | ||
b7393ea1 AW |
454 | static SCM |
455 | resolve_variable (SCM what, SCM program_module) | |
456 | { | |
9bd48cb1 | 457 | if (SCM_LIKELY (scm_is_symbol (what))) |
b7393ea1 AW |
458 | { |
459 | if (SCM_LIKELY (scm_module_system_booted_p | |
460 | && scm_is_true (program_module))) | |
461 | /* might longjmp */ | |
462 | return scm_module_lookup (program_module, what); | |
463 | else | |
464 | { | |
465 | SCM v = scm_sym2var (what, SCM_BOOL_F, SCM_BOOL_F); | |
466 | if (scm_is_false (v)) | |
467 | scm_misc_error (NULL, "unbound variable: ~S", scm_list_1 (what)); | |
468 | else | |
469 | return v; | |
470 | } | |
471 | } | |
472 | else | |
473 | { | |
474 | SCM mod; | |
475 | /* compilation of @ or @@ | |
476 | `what' is a three-element list: (MODNAME SYM INTERFACE?) | |
477 | INTERFACE? is #t if we compiled @ or #f if we compiled @@ | |
478 | */ | |
479 | mod = scm_resolve_module (SCM_CAR (what)); | |
480 | if (scm_is_true (SCM_CADDR (what))) | |
481 | mod = scm_module_public_interface (mod); | |
5c8cefe5 | 482 | if (scm_is_false (mod)) |
b7393ea1 AW |
483 | scm_misc_error (NULL, "no such module: ~S", |
484 | scm_list_1 (SCM_CAR (what))); | |
485 | /* might longjmp */ | |
486 | return scm_module_lookup (mod, SCM_CADR (what)); | |
487 | } | |
488 | } | |
489 | ||
51e9ba2f | 490 | #define VM_DEFAULT_STACK_SIZE (64 * 1024) |
17e90c5e | 491 | |
17e90c5e | 492 | #define VM_NAME vm_regular_engine |
6d14383e AW |
493 | #define FUNC_NAME "vm-regular-engine" |
494 | #define VM_ENGINE SCM_VM_REGULAR_ENGINE | |
83495480 | 495 | #include "vm-engine.c" |
17e90c5e | 496 | #undef VM_NAME |
6d14383e | 497 | #undef FUNC_NAME |
17e90c5e | 498 | #undef VM_ENGINE |
17e90c5e KN |
499 | |
500 | #define VM_NAME vm_debug_engine | |
6d14383e AW |
501 | #define FUNC_NAME "vm-debug-engine" |
502 | #define VM_ENGINE SCM_VM_DEBUG_ENGINE | |
83495480 | 503 | #include "vm-engine.c" |
17e90c5e | 504 | #undef VM_NAME |
6d14383e | 505 | #undef FUNC_NAME |
17e90c5e KN |
506 | #undef VM_ENGINE |
507 | ||
6d14383e AW |
508 | static const scm_t_vm_engine vm_engines[] = |
509 | { vm_regular_engine, vm_debug_engine }; | |
510 | ||
e3eb628d LC |
511 | #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN |
512 | ||
513 | /* The GC "kind" for the VM stack. */ | |
514 | static int vm_stack_gc_kind; | |
515 | ||
516 | #endif | |
517 | ||
a98cef7e | 518 | static SCM |
17e90c5e KN |
519 | make_vm (void) |
520 | #define FUNC_NAME "make_vm" | |
a98cef7e | 521 | { |
17e90c5e | 522 | int i; |
7f991c7d | 523 | struct scm_vm *vp; |
747a1635 | 524 | |
7f991c7d | 525 | vp = scm_gc_malloc (sizeof (struct scm_vm), "vm"); |
d8eeb67c | 526 | |
3d5ee0cd | 527 | vp->stack_size = VM_DEFAULT_STACK_SIZE; |
e3eb628d LC |
528 | |
529 | #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN | |
4168aa46 TTN |
530 | vp->stack_base = (SCM *) |
531 | GC_generic_malloc (vp->stack_size * sizeof (SCM), vm_stack_gc_kind); | |
e3eb628d LC |
532 | |
533 | /* Keep a pointer to VP so that `vm_stack_mark ()' can know what the stack | |
534 | top is. */ | |
21041372 | 535 | *vp->stack_base = SCM_PACK_POINTER (vp); |
e3eb628d LC |
536 | vp->stack_base++; |
537 | vp->stack_size--; | |
538 | #else | |
d8eeb67c LC |
539 | vp->stack_base = scm_gc_malloc (vp->stack_size * sizeof (SCM), |
540 | "stack-base"); | |
e3eb628d LC |
541 | #endif |
542 | ||
2bbe1533 AW |
543 | #ifdef VM_ENABLE_STACK_NULLING |
544 | memset (vp->stack_base, 0, vp->stack_size * sizeof (SCM)); | |
545 | #endif | |
f1046e6b | 546 | vp->stack_limit = vp->stack_base + vp->stack_size - VM_STACK_RESERVE_SIZE; |
3616e9e9 KN |
547 | vp->ip = NULL; |
548 | vp->sp = vp->stack_base - 1; | |
549 | vp->fp = NULL; | |
ea9f4f4b | 550 | vp->engine = vm_default_engine; |
7656f194 | 551 | vp->trace_level = 0; |
17e90c5e | 552 | for (i = 0; i < SCM_VM_NUM_HOOKS; i++) |
3d5ee0cd | 553 | vp->hooks[i] = SCM_BOOL_F; |
6f3b0cc2 | 554 | return scm_cell (scm_tc7_vm, (scm_t_bits)vp); |
a98cef7e | 555 | } |
17e90c5e | 556 | #undef FUNC_NAME |
a98cef7e | 557 | |
e3eb628d LC |
558 | #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN |
559 | ||
560 | /* Mark the VM stack region between its base and its current top. */ | |
561 | static struct GC_ms_entry * | |
562 | vm_stack_mark (GC_word *addr, struct GC_ms_entry *mark_stack_ptr, | |
563 | struct GC_ms_entry *mark_stack_limit, GC_word env) | |
564 | { | |
565 | GC_word *word; | |
566 | const struct scm_vm *vm; | |
567 | ||
568 | /* The first word of the VM stack should contain a pointer to the | |
569 | corresponding VM. */ | |
570 | vm = * ((struct scm_vm **) addr); | |
571 | ||
8071c490 | 572 | if (vm == NULL |
f1046e6b | 573 | || (SCM *) addr != vm->stack_base - 1) |
e3eb628d LC |
574 | /* ADDR must be a pointer to a free-list element, which we must ignore |
575 | (see warning in <gc/gc_mark.h>). */ | |
576 | return mark_stack_ptr; | |
577 | ||
e3eb628d LC |
578 | for (word = (GC_word *) vm->stack_base; word <= (GC_word *) vm->sp; word++) |
579 | mark_stack_ptr = GC_MARK_AND_PUSH ((* (GC_word **) word), | |
580 | mark_stack_ptr, mark_stack_limit, | |
581 | NULL); | |
582 | ||
583 | return mark_stack_ptr; | |
584 | } | |
585 | ||
586 | #endif /* VM_ENABLE_PRECISE_STACK_GC_SCAN */ | |
587 | ||
588 | ||
6d14383e | 589 | SCM |
4abef68f | 590 | scm_c_vm_run (SCM vm, SCM program, SCM *argv, int nargs) |
6d14383e | 591 | { |
4abef68f | 592 | struct scm_vm *vp = SCM_VM_DATA (vm); |
b95d76fc | 593 | SCM_CHECK_STACK; |
7656f194 | 594 | return vm_engines[vp->engine](vm, program, argv, nargs); |
6d14383e AW |
595 | } |
596 | ||
a98cef7e KN |
597 | /* Scheme interface */ |
598 | ||
271c3d31 LC |
599 | SCM_DEFINE (scm_the_vm, "the-vm", 0, 0, 0, |
600 | (void), | |
601 | "Return the current thread's VM.") | |
602 | #define FUNC_NAME s_scm_the_vm | |
603 | { | |
ea9f4f4b AW |
604 | scm_i_thread *t = SCM_I_CURRENT_THREAD; |
605 | ||
606 | if (SCM_UNLIKELY (scm_is_false (t->vm))) | |
607 | t->vm = make_vm (); | |
608 | ||
609 | return t->vm; | |
271c3d31 | 610 | } |
499a4c07 KN |
611 | #undef FUNC_NAME |
612 | ||
613 | ||
a98cef7e KN |
614 | SCM_DEFINE (scm_vm_p, "vm?", 1, 0, 0, |
615 | (SCM obj), | |
17e90c5e | 616 | "") |
a98cef7e KN |
617 | #define FUNC_NAME s_scm_vm_p |
618 | { | |
9bd48cb1 | 619 | return scm_from_bool (SCM_VM_P (obj)); |
a98cef7e KN |
620 | } |
621 | #undef FUNC_NAME | |
622 | ||
623 | SCM_DEFINE (scm_make_vm, "make-vm", 0, 0, 0, | |
17e90c5e KN |
624 | (void), |
625 | "") | |
626 | #define FUNC_NAME s_scm_make_vm, | |
a98cef7e | 627 | { |
17e90c5e | 628 | return make_vm (); |
a98cef7e KN |
629 | } |
630 | #undef FUNC_NAME | |
631 | ||
17e90c5e | 632 | SCM_DEFINE (scm_vm_ip, "vm:ip", 1, 0, 0, |
a98cef7e | 633 | (SCM vm), |
17e90c5e KN |
634 | "") |
635 | #define FUNC_NAME s_scm_vm_ip | |
a98cef7e KN |
636 | { |
637 | SCM_VALIDATE_VM (1, vm); | |
3d27ef4b | 638 | return scm_from_unsigned_integer ((scm_t_bits) SCM_VM_DATA (vm)->ip); |
a98cef7e KN |
639 | } |
640 | #undef FUNC_NAME | |
641 | ||
642 | SCM_DEFINE (scm_vm_sp, "vm:sp", 1, 0, 0, | |
643 | (SCM vm), | |
17e90c5e | 644 | "") |
a98cef7e KN |
645 | #define FUNC_NAME s_scm_vm_sp |
646 | { | |
647 | SCM_VALIDATE_VM (1, vm); | |
3d27ef4b | 648 | return scm_from_unsigned_integer ((scm_t_bits) SCM_VM_DATA (vm)->sp); |
a98cef7e KN |
649 | } |
650 | #undef FUNC_NAME | |
651 | ||
652 | SCM_DEFINE (scm_vm_fp, "vm:fp", 1, 0, 0, | |
653 | (SCM vm), | |
17e90c5e | 654 | "") |
a98cef7e KN |
655 | #define FUNC_NAME s_scm_vm_fp |
656 | { | |
657 | SCM_VALIDATE_VM (1, vm); | |
3d27ef4b | 658 | return scm_from_unsigned_integer ((scm_t_bits) SCM_VM_DATA (vm)->fp); |
a98cef7e KN |
659 | } |
660 | #undef FUNC_NAME | |
661 | ||
17e90c5e KN |
662 | #define VM_DEFINE_HOOK(n) \ |
663 | { \ | |
3d5ee0cd | 664 | struct scm_vm *vp; \ |
17e90c5e | 665 | SCM_VALIDATE_VM (1, vm); \ |
3d5ee0cd | 666 | vp = SCM_VM_DATA (vm); \ |
8b22ed7a | 667 | if (scm_is_false (vp->hooks[n])) \ |
238e7a11 | 668 | vp->hooks[n] = scm_make_hook (SCM_I_MAKINUM (1)); \ |
3d5ee0cd | 669 | return vp->hooks[n]; \ |
17e90c5e KN |
670 | } |
671 | ||
c45d4d77 | 672 | SCM_DEFINE (scm_vm_apply_hook, "vm-apply-hook", 1, 0, 0, |
17e90c5e KN |
673 | (SCM vm), |
674 | "") | |
c45d4d77 | 675 | #define FUNC_NAME s_scm_vm_apply_hook |
a98cef7e | 676 | { |
c45d4d77 | 677 | VM_DEFINE_HOOK (SCM_VM_APPLY_HOOK); |
a98cef7e KN |
678 | } |
679 | #undef FUNC_NAME | |
680 | ||
c45d4d77 | 681 | SCM_DEFINE (scm_vm_push_continuation_hook, "vm-push-continuation-hook", 1, 0, 0, |
17e90c5e KN |
682 | (SCM vm), |
683 | "") | |
c45d4d77 | 684 | #define FUNC_NAME s_scm_vm_push_continuation_hook |
a98cef7e | 685 | { |
c45d4d77 | 686 | VM_DEFINE_HOOK (SCM_VM_PUSH_CONTINUATION_HOOK); |
a98cef7e KN |
687 | } |
688 | #undef FUNC_NAME | |
689 | ||
c45d4d77 | 690 | SCM_DEFINE (scm_vm_pop_continuation_hook, "vm-pop-continuation-hook", 1, 0, 0, |
a98cef7e | 691 | (SCM vm), |
17e90c5e | 692 | "") |
c45d4d77 | 693 | #define FUNC_NAME s_scm_vm_pop_continuation_hook |
a98cef7e | 694 | { |
c45d4d77 | 695 | VM_DEFINE_HOOK (SCM_VM_POP_CONTINUATION_HOOK); |
a98cef7e KN |
696 | } |
697 | #undef FUNC_NAME | |
698 | ||
c45d4d77 | 699 | SCM_DEFINE (scm_vm_next_hook, "vm-next-hook", 1, 0, 0, |
a98cef7e | 700 | (SCM vm), |
17e90c5e | 701 | "") |
c45d4d77 | 702 | #define FUNC_NAME s_scm_vm_next_hook |
a98cef7e | 703 | { |
c45d4d77 | 704 | VM_DEFINE_HOOK (SCM_VM_NEXT_HOOK); |
a98cef7e KN |
705 | } |
706 | #undef FUNC_NAME | |
f3120251 AW |
707 | |
708 | SCM_DEFINE (scm_vm_abort_continuation_hook, "vm-abort-continuation-hook", 1, 0, 0, | |
709 | (SCM vm), | |
710 | "") | |
711 | #define FUNC_NAME s_scm_vm_abort_continuation_hook | |
712 | { | |
713 | VM_DEFINE_HOOK (SCM_VM_ABORT_CONTINUATION_HOOK); | |
714 | } | |
715 | #undef FUNC_NAME | |
716 | ||
717 | SCM_DEFINE (scm_vm_restore_continuation_hook, "vm-restore-continuation-hook", 1, 0, 0, | |
718 | (SCM vm), | |
719 | "") | |
720 | #define FUNC_NAME s_scm_vm_restore_continuation_hook | |
721 | { | |
722 | VM_DEFINE_HOOK (SCM_VM_RESTORE_CONTINUATION_HOOK); | |
723 | } | |
724 | #undef FUNC_NAME | |
a98cef7e | 725 | |
7656f194 | 726 | SCM_DEFINE (scm_vm_trace_level, "vm-trace-level", 1, 0, 0, |
17e90c5e KN |
727 | (SCM vm), |
728 | "") | |
7656f194 | 729 | #define FUNC_NAME s_scm_vm_trace_level |
a98cef7e | 730 | { |
a98cef7e | 731 | SCM_VALIDATE_VM (1, vm); |
7656f194 AW |
732 | return scm_from_int (SCM_VM_DATA (vm)->trace_level); |
733 | } | |
734 | #undef FUNC_NAME | |
735 | ||
736 | SCM_DEFINE (scm_set_vm_trace_level_x, "set-vm-trace-level!", 2, 0, 0, | |
737 | (SCM vm, SCM level), | |
738 | "") | |
739 | #define FUNC_NAME s_scm_set_vm_trace_level_x | |
740 | { | |
741 | SCM_VALIDATE_VM (1, vm); | |
742 | SCM_VM_DATA (vm)->trace_level = scm_to_int (level); | |
743 | return SCM_UNSPECIFIED; | |
a98cef7e KN |
744 | } |
745 | #undef FUNC_NAME | |
746 | ||
747 | \f | |
ea9f4f4b AW |
748 | /* |
749 | * VM engines | |
750 | */ | |
751 | ||
752 | static int | |
753 | symbol_to_vm_engine (SCM engine, const char *FUNC_NAME) | |
754 | { | |
755 | if (scm_is_eq (engine, sym_regular)) | |
756 | return SCM_VM_REGULAR_ENGINE; | |
757 | else if (scm_is_eq (engine, sym_debug)) | |
758 | return SCM_VM_DEBUG_ENGINE; | |
759 | else | |
760 | SCM_MISC_ERROR ("Unknown VM engine: ~a", scm_list_1 (engine)); | |
761 | } | |
762 | ||
763 | static SCM | |
764 | vm_engine_to_symbol (int engine, const char *FUNC_NAME) | |
765 | { | |
766 | switch (engine) | |
767 | { | |
768 | case SCM_VM_REGULAR_ENGINE: | |
769 | return sym_regular; | |
770 | case SCM_VM_DEBUG_ENGINE: | |
771 | return sym_debug; | |
772 | default: | |
773 | /* ? */ | |
774 | SCM_MISC_ERROR ("Unknown VM engine: ~a", | |
775 | scm_list_1 (scm_from_int (engine))); | |
776 | } | |
777 | } | |
778 | ||
ea9f4f4b AW |
779 | SCM_DEFINE (scm_vm_engine, "vm-engine", 1, 0, 0, |
780 | (SCM vm), | |
781 | "") | |
782 | #define FUNC_NAME s_scm_vm_engine | |
783 | { | |
784 | SCM_VALIDATE_VM (1, vm); | |
785 | return vm_engine_to_symbol (SCM_VM_DATA (vm)->engine, FUNC_NAME); | |
786 | } | |
787 | #undef FUNC_NAME | |
788 | ||
789 | void | |
790 | scm_c_set_vm_engine_x (SCM vm, int engine) | |
791 | #define FUNC_NAME "set-vm-engine!" | |
792 | { | |
793 | SCM_VALIDATE_VM (1, vm); | |
794 | ||
ea9f4f4b AW |
795 | if (engine < 0 || engine >= SCM_VM_NUM_ENGINES) |
796 | SCM_MISC_ERROR ("Unknown VM engine: ~a", | |
797 | scm_list_1 (scm_from_int (engine))); | |
798 | ||
799 | SCM_VM_DATA (vm)->engine = engine; | |
800 | } | |
801 | #undef FUNC_NAME | |
802 | ||
803 | SCM_DEFINE (scm_set_vm_engine_x, "set-vm-engine!", 2, 0, 0, | |
804 | (SCM vm, SCM engine), | |
805 | "") | |
806 | #define FUNC_NAME s_scm_set_vm_engine_x | |
807 | { | |
808 | scm_c_set_vm_engine_x (vm, symbol_to_vm_engine (engine, FUNC_NAME)); | |
809 | return SCM_UNSPECIFIED; | |
810 | } | |
811 | #undef FUNC_NAME | |
812 | ||
813 | void | |
814 | scm_c_set_default_vm_engine_x (int engine) | |
815 | #define FUNC_NAME "set-default-vm-engine!" | |
816 | { | |
817 | if (engine < 0 || engine >= SCM_VM_NUM_ENGINES) | |
818 | SCM_MISC_ERROR ("Unknown VM engine: ~a", | |
819 | scm_list_1 (scm_from_int (engine))); | |
820 | ||
821 | vm_default_engine = engine; | |
822 | } | |
823 | #undef FUNC_NAME | |
824 | ||
825 | SCM_DEFINE (scm_set_default_vm_engine_x, "set-default-vm-engine!", 1, 0, 0, | |
826 | (SCM engine), | |
827 | "") | |
828 | #define FUNC_NAME s_scm_set_default_vm_engine_x | |
829 | { | |
830 | scm_c_set_default_vm_engine_x (symbol_to_vm_engine (engine, FUNC_NAME)); | |
831 | return SCM_UNSPECIFIED; | |
832 | } | |
833 | #undef FUNC_NAME | |
834 | ||
835 | static void reinstate_vm (SCM vm) | |
836 | { | |
837 | scm_i_thread *t = SCM_I_CURRENT_THREAD; | |
838 | t->vm = vm; | |
839 | } | |
840 | ||
841 | SCM_DEFINE (scm_call_with_vm, "call-with-vm", 2, 0, 1, | |
842 | (SCM vm, SCM proc, SCM args), | |
843 | "Apply @var{proc} to @var{args} in a dynamic extent in which\n" | |
844 | "@var{vm} is the current VM.\n\n" | |
845 | "As an implementation restriction, if @var{vm} is not the same\n" | |
846 | "as the current thread's VM, continuations captured within the\n" | |
847 | "call to @var{proc} may not be reinstated once control leaves\n" | |
848 | "@var{proc}.") | |
849 | #define FUNC_NAME s_scm_call_with_vm | |
850 | { | |
851 | SCM prev_vm, ret; | |
852 | SCM *argv; | |
853 | int i, nargs; | |
854 | scm_t_wind_flags flags; | |
855 | scm_i_thread *t = SCM_I_CURRENT_THREAD; | |
856 | ||
857 | SCM_VALIDATE_VM (1, vm); | |
858 | SCM_VALIDATE_PROC (2, proc); | |
859 | ||
860 | nargs = scm_ilength (args); | |
861 | if (SCM_UNLIKELY (nargs < 0)) | |
862 | scm_wrong_type_arg_msg (FUNC_NAME, 3, args, "list"); | |
863 | ||
864 | argv = alloca (nargs * sizeof(SCM)); | |
865 | for (i = 0; i < nargs; i++) | |
866 | { | |
867 | argv[i] = SCM_CAR (args); | |
868 | args = SCM_CDR (args); | |
869 | } | |
870 | ||
871 | prev_vm = t->vm; | |
872 | ||
873 | /* Reentry can happen via invokation of a saved continuation, but | |
874 | continuations only save the state of the VM that they are in at | |
875 | capture-time, which might be different from this one. So, in the | |
876 | case that the VMs are different, set up a non-rewindable frame to | |
877 | prevent reinstating an incomplete continuation. */ | |
878 | flags = scm_is_eq (prev_vm, vm) ? 0 : SCM_F_WIND_EXPLICITLY; | |
879 | if (flags) | |
880 | { | |
881 | scm_dynwind_begin (0); | |
882 | scm_dynwind_unwind_handler_with_scm (reinstate_vm, prev_vm, flags); | |
883 | t->vm = vm; | |
884 | } | |
885 | ||
886 | ret = scm_c_vm_run (vm, proc, argv, nargs); | |
887 | ||
888 | if (flags) | |
889 | scm_dynwind_end (); | |
890 | ||
891 | return ret; | |
892 | } | |
893 | #undef FUNC_NAME | |
894 | ||
895 | \f | |
a98cef7e | 896 | /* |
17e90c5e | 897 | * Initialize |
a98cef7e KN |
898 | */ |
899 | ||
07e56b27 AW |
900 | SCM scm_load_compiled_with_vm (SCM file) |
901 | { | |
53e28ed9 | 902 | SCM program = scm_make_program (scm_load_objcode (file), |
20d47c39 | 903 | SCM_BOOL_F, SCM_BOOL_F); |
07e56b27 | 904 | |
4abef68f | 905 | return scm_c_vm_run (scm_the_vm (), program, NULL, 0); |
07e56b27 AW |
906 | } |
907 | ||
17e90c5e | 908 | void |
07e56b27 | 909 | scm_bootstrap_vm (void) |
17e90c5e | 910 | { |
44602b08 AW |
911 | scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION, |
912 | "scm_init_vm", | |
60ae5ca2 AW |
913 | (scm_t_extension_init_func)scm_init_vm, NULL); |
914 | ||
4a655e50 AW |
915 | sym_vm_run = scm_from_latin1_symbol ("vm-run"); |
916 | sym_vm_error = scm_from_latin1_symbol ("vm-error"); | |
917 | sym_keyword_argument_error = scm_from_latin1_symbol ("keyword-argument-error"); | |
918 | sym_regular = scm_from_latin1_symbol ("regular"); | |
919 | sym_debug = scm_from_latin1_symbol ("debug"); | |
0404c97d | 920 | |
e3eb628d LC |
921 | #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN |
922 | vm_stack_gc_kind = | |
923 | GC_new_kind (GC_new_free_list (), | |
924 | GC_MAKE_PROC (GC_new_proc (vm_stack_mark), 0), | |
925 | 0, 1); | |
926 | ||
927 | #endif | |
07e56b27 AW |
928 | } |
929 | ||
930 | void | |
931 | scm_init_vm (void) | |
932 | { | |
17e90c5e | 933 | #ifndef SCM_MAGIC_SNARFER |
aeeff258 | 934 | #include "libguile/vm.x" |
17e90c5e | 935 | #endif |
a98cef7e | 936 | } |
17e90c5e KN |
937 | |
938 | /* | |
939 | Local Variables: | |
940 | c-file-style: "gnu" | |
941 | End: | |
942 | */ |