Commit | Line | Data |
---|---|---|
567a6d1e | 1 | /* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013, 2014, 2015 Free Software Foundation, Inc. |
a98cef7e | 2 | * |
560b9c25 | 3 | * This library is free software; you can redistribute it and/or |
53befeb7 NJ |
4 | * modify it under the terms of the GNU Lesser General Public License |
5 | * as published by the Free Software Foundation; either version 3 of | |
6 | * the License, or (at your option) any later version. | |
a98cef7e | 7 | * |
53befeb7 NJ |
8 | * This library is distributed in the hope that it will be useful, but |
9 | * WITHOUT ANY WARRANTY; without even the implied warranty of | |
560b9c25 AW |
10 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
11 | * Lesser General Public License for more details. | |
a98cef7e | 12 | * |
560b9c25 AW |
13 | * You should have received a copy of the GNU Lesser General Public |
14 | * License along with this library; if not, write to the Free Software | |
53befeb7 NJ |
15 | * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA |
16 | * 02110-1301 USA | |
560b9c25 | 17 | */ |
a98cef7e | 18 | |
22d425ec AW |
19 | /* For mremap(2) on GNU/Linux systems. */ |
20 | #define _GNU_SOURCE | |
21 | ||
13c47753 AW |
22 | #if HAVE_CONFIG_H |
23 | # include <config.h> | |
24 | #endif | |
25 | ||
da8b4747 | 26 | #include <stdlib.h> |
6d14383e | 27 | #include <alloca.h> |
daccfef4 | 28 | #include <alignof.h> |
17e90c5e | 29 | #include <string.h> |
e78d4bf9 | 30 | #include <stdint.h> |
7dba1c2f | 31 | #include <unistd.h> |
e3eb628d | 32 | |
5f18bc84 AW |
33 | #ifdef HAVE_SYS_MMAN_H |
34 | #include <sys/mman.h> | |
35 | #endif | |
36 | ||
1c44468d | 37 | #include "libguile/bdw-gc.h" |
e3eb628d LC |
38 | #include <gc/gc_mark.h> |
39 | ||
560b9c25 | 40 | #include "_scm.h" |
adaf86ec | 41 | #include "control.h" |
ac99cb0c | 42 | #include "frames.h" |
aef1fcf9 | 43 | #include "gc-inline.h" |
17e90c5e | 44 | #include "instructions.h" |
4cbc95f1 | 45 | #include "loader.h" |
ac99cb0c | 46 | #include "programs.h" |
87fc4596 | 47 | #include "simpos.h" |
a98cef7e | 48 | #include "vm.h" |
486013d6 | 49 | #include "vm-builtins.h" |
a98cef7e | 50 | |
97b18a66 | 51 | static int vm_default_engine = SCM_VM_REGULAR_ENGINE; |
ea9f4f4b AW |
52 | |
53 | /* Unfortunately we can't snarf these: snarfed things are only loaded up from | |
54 | (system vm vm), which might not be loaded before an error happens. */ | |
55 | static SCM sym_vm_run; | |
56 | static SCM sym_vm_error; | |
57 | static SCM sym_keyword_argument_error; | |
58 | static SCM sym_regular; | |
59 | static SCM sym_debug; | |
a98cef7e | 60 | |
f764e259 AW |
61 | /* The page size. */ |
62 | static size_t page_size; | |
63 | ||
11ea1aba AW |
64 | /* The VM has a number of internal assertions that shouldn't normally be |
65 | necessary, but might be if you think you found a bug in the VM. */ | |
698c55b0 | 66 | /* #define VM_ENABLE_ASSERTIONS */ |
53e28ed9 | 67 | |
c2ae85be | 68 | static void vm_expand_stack (struct scm_vm *vp, SCM *new_sp) SCM_NOINLINE; |
b914b236 AW |
69 | |
70 | /* RESTORE is for the case where we know we have done a PUSH of equal or | |
71 | greater stack size in the past. Otherwise PUSH is the thing, which | |
72 | may expand the stack. */ | |
73 | enum vm_increase_sp_kind { VM_SP_PUSH, VM_SP_RESTORE }; | |
74 | ||
75 | static inline void | |
76 | vm_increase_sp (struct scm_vm *vp, SCM *new_sp, enum vm_increase_sp_kind kind) | |
77 | { | |
c2ae85be | 78 | if (new_sp <= vp->sp_max_since_gc) |
b914b236 | 79 | { |
c2ae85be AW |
80 | vp->sp = new_sp; |
81 | return; | |
b914b236 | 82 | } |
c2ae85be AW |
83 | |
84 | if (kind == VM_SP_PUSH && new_sp >= vp->stack_limit) | |
85 | vm_expand_stack (vp, new_sp); | |
86 | else | |
87 | vp->sp_max_since_gc = vp->sp = new_sp; | |
b914b236 AW |
88 | } |
89 | ||
90 | static inline void | |
91 | vm_push_sp (struct scm_vm *vp, SCM *new_sp) | |
92 | { | |
93 | vm_increase_sp (vp, new_sp, VM_SP_PUSH); | |
94 | } | |
95 | ||
96 | static inline void | |
97 | vm_restore_sp (struct scm_vm *vp, SCM *new_sp) | |
98 | { | |
99 | vm_increase_sp (vp, new_sp, VM_SP_RESTORE); | |
100 | } | |
e3eb628d | 101 | |
a98cef7e | 102 | \f |
a98cef7e KN |
103 | /* |
104 | * VM Continuation | |
105 | */ | |
106 | ||
6f3b0cc2 AW |
107 | void |
108 | scm_i_vm_cont_print (SCM x, SCM port, scm_print_state *pstate) | |
109 | { | |
0607ebbf | 110 | scm_puts_unlocked ("#<vm-continuation ", port); |
6f3b0cc2 | 111 | scm_uintprint (SCM_UNPACK (x), 16, port); |
0607ebbf | 112 | scm_puts_unlocked (">", port); |
6f3b0cc2 | 113 | } |
17e90c5e | 114 | |
4cfa92d6 AW |
115 | int |
116 | scm_i_vm_cont_to_frame (SCM cont, struct scm_frame *frame) | |
117 | { | |
118 | struct scm_vm_cont *data = SCM_VM_CONT_DATA (cont); | |
119 | ||
120 | frame->stack_holder = data; | |
121 | frame->fp_offset = (data->fp + data->reloc) - data->stack_base; | |
122 | frame->sp_offset = (data->sp + data->reloc) - data->stack_base; | |
123 | frame->ip = data->ra; | |
124 | ||
125 | return 1; | |
126 | } | |
127 | ||
ee1c6b57 AW |
128 | /* Ideally we could avoid copying the C stack if the continuation root |
129 | is inside VM code, and call/cc was invoked within that same call to | |
130 | vm_run. That's currently not implemented. */ | |
cee1d22c | 131 | SCM |
9121d9f1 | 132 | scm_i_vm_capture_stack (SCM *stack_base, SCM *fp, SCM *sp, scm_t_uint32 *ra, |
840ec334 | 133 | scm_t_dynstack *dynstack, scm_t_uint32 flags) |
a98cef7e | 134 | { |
d8873dfe AW |
135 | struct scm_vm_cont *p; |
136 | ||
137 | p = scm_gc_malloc (sizeof (*p), "capture_vm_cont"); | |
138 | p->stack_size = sp - stack_base + 1; | |
d8eeb67c LC |
139 | p->stack_base = scm_gc_malloc (p->stack_size * sizeof (SCM), |
140 | "capture_vm_cont"); | |
d8873dfe | 141 | p->ra = ra; |
d8873dfe AW |
142 | p->sp = sp; |
143 | p->fp = fp; | |
144 | memcpy (p->stack_base, stack_base, (sp + 1 - stack_base) * sizeof (SCM)); | |
145 | p->reloc = p->stack_base - stack_base; | |
9ede013f | 146 | p->dynstack = dynstack; |
cee1d22c | 147 | p->flags = flags; |
6f3b0cc2 | 148 | return scm_cell (scm_tc7_vm_cont, (scm_t_bits)p); |
a98cef7e KN |
149 | } |
150 | ||
c53d0f01 | 151 | struct return_to_continuation_data |
a98cef7e | 152 | { |
d8873dfe | 153 | struct scm_vm_cont *cp; |
c53d0f01 AW |
154 | struct scm_vm *vp; |
155 | }; | |
d8873dfe | 156 | |
c53d0f01 AW |
157 | /* Called with the GC lock to prevent the stack marker from traversing a |
158 | stack in an inconsistent state. */ | |
159 | static void * | |
160 | vm_return_to_continuation_inner (void *data_ptr) | |
161 | { | |
162 | struct return_to_continuation_data *data = data_ptr; | |
163 | struct scm_vm *vp = data->vp; | |
164 | struct scm_vm_cont *cp = data->cp; | |
165 | scm_t_ptrdiff reloc; | |
29366989 | 166 | |
b914b236 AW |
167 | /* We know that there is enough space for the continuation, because we |
168 | captured it in the past. However there may have been an expansion | |
169 | since the capture, so we may have to re-link the frame | |
170 | pointers. */ | |
171 | reloc = (vp->stack_base - (cp->stack_base - cp->reloc)); | |
172 | vp->fp = cp->fp + reloc; | |
d8873dfe | 173 | memcpy (vp->stack_base, cp->stack_base, cp->stack_size * sizeof (SCM)); |
b914b236 AW |
174 | vm_restore_sp (vp, cp->sp + reloc); |
175 | ||
176 | if (reloc) | |
177 | { | |
178 | SCM *fp = vp->fp; | |
179 | while (fp) | |
180 | { | |
181 | SCM *next_fp = SCM_FRAME_DYNAMIC_LINK (fp); | |
182 | if (next_fp) | |
183 | { | |
184 | next_fp += reloc; | |
185 | SCM_FRAME_SET_DYNAMIC_LINK (fp, next_fp); | |
186 | } | |
187 | fp = next_fp; | |
188 | } | |
189 | } | |
190 | ||
c53d0f01 AW |
191 | return NULL; |
192 | } | |
193 | ||
194 | static void | |
195 | vm_return_to_continuation (struct scm_vm *vp, SCM cont, size_t n, SCM *argv) | |
196 | { | |
197 | struct scm_vm_cont *cp; | |
198 | SCM *argv_copy; | |
199 | struct return_to_continuation_data data; | |
200 | ||
201 | argv_copy = alloca (n * sizeof(SCM)); | |
202 | memcpy (argv_copy, argv, n * sizeof(SCM)); | |
203 | ||
204 | cp = SCM_VM_CONT_DATA (cont); | |
205 | ||
206 | data.cp = cp; | |
207 | data.vp = vp; | |
208 | GC_call_with_alloc_lock (vm_return_to_continuation_inner, &data); | |
209 | ||
b914b236 AW |
210 | /* Now we have the continuation properly copied over. We just need to |
211 | copy the arguments. It is not guaranteed that there is actually | |
212 | space for the arguments, though, so we have to bump the SP first. */ | |
213 | vm_push_sp (vp, vp->sp + 3 + n); | |
bfffd258 | 214 | |
b914b236 AW |
215 | /* Now copy on an empty frame and the return values, as the |
216 | continuation expects. */ | |
03f16599 | 217 | { |
b914b236 | 218 | SCM *base = vp->sp + 1 - 3 - n; |
03f16599 AW |
219 | size_t i; |
220 | ||
f8085163 | 221 | for (i = 0; i < 3; i++) |
b914b236 | 222 | base[i] = SCM_BOOL_F; |
03f16599 | 223 | |
03f16599 | 224 | for (i = 0; i < n; i++) |
b914b236 | 225 | base[i + 3] = argv_copy[i]; |
03f16599 | 226 | } |
b914b236 AW |
227 | |
228 | vp->ip = cp->ra; | |
d8873dfe | 229 | } |
bfffd258 | 230 | |
b85cd20f | 231 | static struct scm_vm * thread_vm (scm_i_thread *t); |
bfffd258 | 232 | SCM |
9ede013f | 233 | scm_i_capture_current_stack (void) |
bfffd258 | 234 | { |
9ede013f | 235 | scm_i_thread *thread; |
9ede013f AW |
236 | struct scm_vm *vp; |
237 | ||
238 | thread = SCM_I_CURRENT_THREAD; | |
b85cd20f | 239 | vp = thread_vm (thread); |
9ede013f | 240 | |
840ec334 | 241 | return scm_i_vm_capture_stack (vp->stack_base, vp->fp, vp->sp, vp->ip, |
9ede013f AW |
242 | scm_dynstack_capture_all (&thread->dynstack), |
243 | 0); | |
a98cef7e KN |
244 | } |
245 | ||
59f85eed AW |
246 | static void vm_dispatch_apply_hook (struct scm_vm *vp) SCM_NOINLINE; |
247 | static void vm_dispatch_push_continuation_hook (struct scm_vm *vp) SCM_NOINLINE; | |
248 | static void vm_dispatch_pop_continuation_hook (struct scm_vm *vp, SCM *old_fp) SCM_NOINLINE; | |
249 | static void vm_dispatch_next_hook (struct scm_vm *vp) SCM_NOINLINE; | |
250 | static void vm_dispatch_abort_hook (struct scm_vm *vp) SCM_NOINLINE; | |
c850a0ff | 251 | |
b1b942b7 | 252 | static void |
59f85eed | 253 | vm_dispatch_hook (struct scm_vm *vp, int hook_num, SCM *argv, int n) |
b1b942b7 | 254 | { |
7656f194 | 255 | SCM hook; |
b3567435 | 256 | struct scm_frame c_frame; |
8e4c60ff | 257 | scm_t_cell *frame; |
893fb8d0 | 258 | int saved_trace_level; |
b1b942b7 | 259 | |
7656f194 | 260 | hook = vp->hooks[hook_num]; |
b1b942b7 | 261 | |
7656f194 AW |
262 | if (SCM_LIKELY (scm_is_false (hook)) |
263 | || scm_is_null (SCM_HOOK_PROCEDURES (hook))) | |
264 | return; | |
b3567435 | 265 | |
893fb8d0 AW |
266 | saved_trace_level = vp->trace_level; |
267 | vp->trace_level = 0; | |
b3567435 LC |
268 | |
269 | /* Allocate a frame object on the stack. This is more efficient than calling | |
270 | `scm_c_make_frame ()' to allocate on the heap, but it forces hooks to not | |
271 | capture frame objects. | |
272 | ||
273 | At the same time, procedures such as `frame-procedure' make sense only | |
274 | while the stack frame represented by the frame object is visible, so it | |
275 | seems reasonable to limit the lifetime of frame objects. */ | |
276 | ||
5515edc5 | 277 | c_frame.stack_holder = vp; |
89b235af AW |
278 | c_frame.fp_offset = vp->fp - vp->stack_base; |
279 | c_frame.sp_offset = vp->sp - vp->stack_base; | |
b3567435 | 280 | c_frame.ip = vp->ip; |
8e4c60ff LC |
281 | |
282 | /* Arrange for FRAME to be 8-byte aligned, like any other cell. */ | |
283 | frame = alloca (sizeof (*frame) + 8); | |
284 | frame = (scm_t_cell *) ROUND_UP ((scm_t_uintptr) frame, 8UL); | |
285 | ||
050a40db | 286 | frame->word_0 = SCM_PACK (scm_tc7_frame | (SCM_VM_FRAME_KIND_VM << 8)); |
21041372 | 287 | frame->word_1 = SCM_PACK_POINTER (&c_frame); |
b3567435 | 288 | |
c850a0ff AW |
289 | if (n == 0) |
290 | { | |
291 | SCM args[1]; | |
292 | ||
293 | args[0] = SCM_PACK_POINTER (frame); | |
294 | scm_c_run_hookn (hook, args, 1); | |
295 | } | |
296 | else if (n == 1) | |
297 | { | |
298 | SCM args[2]; | |
299 | ||
300 | args[0] = SCM_PACK_POINTER (frame); | |
301 | args[1] = argv[0]; | |
302 | scm_c_run_hookn (hook, args, 2); | |
303 | } | |
304 | else | |
305 | { | |
306 | SCM args = SCM_EOL; | |
307 | ||
308 | while (n--) | |
309 | args = scm_cons (argv[n], args); | |
310 | scm_c_run_hook (hook, scm_cons (SCM_PACK_POINTER (frame), args)); | |
311 | } | |
b3567435 | 312 | |
893fb8d0 | 313 | vp->trace_level = saved_trace_level; |
b1b942b7 AW |
314 | } |
315 | ||
ea0cd17d | 316 | static void |
59f85eed | 317 | vm_dispatch_apply_hook (struct scm_vm *vp) |
ea0cd17d | 318 | { |
59f85eed | 319 | return vm_dispatch_hook (vp, SCM_VM_APPLY_HOOK, NULL, 0); |
ea0cd17d | 320 | } |
59f85eed | 321 | static void vm_dispatch_push_continuation_hook (struct scm_vm *vp) |
ea0cd17d | 322 | { |
59f85eed | 323 | return vm_dispatch_hook (vp, SCM_VM_PUSH_CONTINUATION_HOOK, NULL, 0); |
ea0cd17d | 324 | } |
59f85eed | 325 | static void vm_dispatch_pop_continuation_hook (struct scm_vm *vp, SCM *old_fp) |
ea0cd17d | 326 | { |
59f85eed | 327 | return vm_dispatch_hook (vp, SCM_VM_POP_CONTINUATION_HOOK, |
ea0cd17d AW |
328 | &SCM_FRAME_LOCAL (old_fp, 1), |
329 | SCM_FRAME_NUM_LOCALS (old_fp, vp->sp) - 1); | |
330 | } | |
59f85eed | 331 | static void vm_dispatch_next_hook (struct scm_vm *vp) |
ea0cd17d | 332 | { |
59f85eed | 333 | return vm_dispatch_hook (vp, SCM_VM_NEXT_HOOK, NULL, 0); |
ea0cd17d | 334 | } |
59f85eed | 335 | static void vm_dispatch_abort_hook (struct scm_vm *vp) |
ea0cd17d | 336 | { |
59f85eed | 337 | return vm_dispatch_hook (vp, SCM_VM_ABORT_CONTINUATION_HOOK, |
ea0cd17d AW |
338 | &SCM_FRAME_LOCAL (vp->fp, 1), |
339 | SCM_FRAME_NUM_LOCALS (vp->fp, vp->sp) - 1); | |
340 | } | |
ea0cd17d | 341 | |
4f66bcde | 342 | static void |
b44f5451 AW |
343 | vm_abort (struct scm_vm *vp, SCM tag, |
344 | size_t nstack, SCM *stack_args, SCM tail, SCM *sp, | |
99511cd0 | 345 | scm_i_jmp_buf *current_registers) SCM_NORETURN; |
9d381ba4 AW |
346 | |
347 | static void | |
b44f5451 AW |
348 | vm_abort (struct scm_vm *vp, SCM tag, |
349 | size_t nstack, SCM *stack_args, SCM tail, SCM *sp, | |
99511cd0 | 350 | scm_i_jmp_buf *current_registers) |
4f66bcde | 351 | { |
eaefabee | 352 | size_t i; |
2d026f04 | 353 | ssize_t tail_len; |
99511cd0 | 354 | SCM *argv; |
eaefabee | 355 | |
2d026f04 AW |
356 | tail_len = scm_ilength (tail); |
357 | if (tail_len < 0) | |
29366989 AW |
358 | scm_misc_error ("vm-engine", "tail values to abort should be a list", |
359 | scm_list_1 (tail)); | |
360 | ||
99511cd0 AW |
361 | argv = alloca ((nstack + tail_len) * sizeof (SCM)); |
362 | for (i = 0; i < nstack; i++) | |
363 | argv[i] = stack_args[i]; | |
364 | for (; i < nstack + tail_len; i++, tail = scm_cdr (tail)) | |
2d026f04 | 365 | argv[i] = scm_car (tail); |
eaefabee | 366 | |
b44f5451 | 367 | vp->sp = sp; |
99511cd0 | 368 | |
b44f5451 | 369 | scm_c_abort (vp, tag, nstack + tail_len, argv, current_registers); |
cee1d22c AW |
370 | } |
371 | ||
c53d0f01 | 372 | struct vm_reinstate_partial_continuation_data |
cee1d22c | 373 | { |
c53d0f01 | 374 | struct scm_vm *vp; |
07801437 | 375 | struct scm_vm_cont *cp; |
9ede013f | 376 | scm_t_ptrdiff reloc; |
c53d0f01 | 377 | }; |
7dba1c2f | 378 | |
c53d0f01 AW |
379 | static void * |
380 | vm_reinstate_partial_continuation_inner (void *data_ptr) | |
381 | { | |
382 | struct vm_reinstate_partial_continuation_data *data = data_ptr; | |
383 | struct scm_vm *vp = data->vp; | |
384 | struct scm_vm_cont *cp = data->cp; | |
385 | SCM *base; | |
386 | scm_t_ptrdiff reloc; | |
7dba1c2f | 387 | |
b914b236 AW |
388 | base = SCM_FRAME_LOCALS_ADDRESS (vp->fp); |
389 | reloc = cp->reloc + (base - cp->stack_base); | |
07801437 | 390 | |
07801437 AW |
391 | memcpy (base, cp->stack_base, cp->stack_size * sizeof (SCM)); |
392 | ||
b914b236 AW |
393 | vp->fp = cp->fp + reloc; |
394 | vp->ip = cp->ra; | |
395 | ||
07801437 AW |
396 | /* now relocate frame pointers */ |
397 | { | |
398 | SCM *fp; | |
b914b236 | 399 | for (fp = vp->fp; |
a2ebdba7 | 400 | SCM_FRAME_LOWER_ADDRESS (fp) >= base; |
07801437 | 401 | fp = SCM_FRAME_DYNAMIC_LINK (fp)) |
b914b236 | 402 | SCM_FRAME_SET_DYNAMIC_LINK (fp, SCM_FRAME_DYNAMIC_LINK (fp) + reloc); |
07801437 AW |
403 | } |
404 | ||
c53d0f01 AW |
405 | data->reloc = reloc; |
406 | ||
407 | return NULL; | |
408 | } | |
409 | ||
410 | static void | |
411 | vm_reinstate_partial_continuation (struct scm_vm *vp, SCM cont, | |
412 | size_t n, SCM *argv, | |
413 | scm_t_dynstack *dynstack, | |
414 | scm_i_jmp_buf *registers) | |
415 | { | |
416 | struct vm_reinstate_partial_continuation_data data; | |
417 | struct scm_vm_cont *cp; | |
418 | SCM *argv_copy; | |
419 | scm_t_ptrdiff reloc; | |
420 | size_t i; | |
421 | ||
422 | argv_copy = alloca (n * sizeof(SCM)); | |
423 | memcpy (argv_copy, argv, n * sizeof(SCM)); | |
424 | ||
425 | cp = SCM_VM_CONT_DATA (cont); | |
426 | ||
427 | vm_push_sp (vp, SCM_FRAME_LOCALS_ADDRESS (vp->fp) + cp->stack_size + n - 1); | |
428 | ||
429 | data.vp = vp; | |
430 | data.cp = cp; | |
431 | GC_call_with_alloc_lock (vm_reinstate_partial_continuation_inner, &data); | |
432 | reloc = data.reloc; | |
433 | ||
840ec334 | 434 | /* Push the arguments. */ |
07801437 | 435 | for (i = 0; i < n; i++) |
b914b236 | 436 | vp->sp[i + 1 - n] = argv_copy[i]; |
7dba1c2f | 437 | |
9d381ba4 AW |
438 | /* The prompt captured a slice of the dynamic stack. Here we wind |
439 | those entries onto the current thread's stack. We also have to | |
440 | relocate any prompts that we see along the way. */ | |
441 | { | |
442 | scm_t_bits *walk; | |
443 | ||
444 | for (walk = SCM_DYNSTACK_FIRST (cp->dynstack); | |
445 | SCM_DYNSTACK_TAG (walk); | |
446 | walk = SCM_DYNSTACK_NEXT (walk)) | |
447 | { | |
448 | scm_t_bits tag = SCM_DYNSTACK_TAG (walk); | |
449 | ||
450 | if (SCM_DYNSTACK_TAG_TYPE (tag) == SCM_DYNSTACK_TYPE_PROMPT) | |
451 | scm_dynstack_wind_prompt (dynstack, walk, reloc, registers); | |
452 | else | |
453 | scm_dynstack_wind_1 (dynstack, walk); | |
454 | } | |
455 | } | |
4f66bcde AW |
456 | } |
457 | ||
458 | \f | |
53bdfcf0 AW |
459 | /* |
460 | * VM Error Handling | |
461 | */ | |
462 | ||
463 | static void vm_error (const char *msg, SCM arg) SCM_NORETURN; | |
4d497b62 | 464 | static void vm_error_bad_instruction (scm_t_uint32 inst) SCM_NORETURN SCM_NOINLINE; |
73fc4e73 AW |
465 | static void vm_error_unbound (SCM sym) SCM_NORETURN SCM_NOINLINE; |
466 | static void vm_error_unbound_fluid (SCM fluid) SCM_NORETURN SCM_NOINLINE; | |
4d497b62 AW |
467 | static void vm_error_not_a_variable (const char *func_name, SCM x) SCM_NORETURN SCM_NOINLINE; |
468 | static void vm_error_apply_to_non_list (SCM x) SCM_NORETURN SCM_NOINLINE; | |
469 | static void vm_error_kwargs_length_not_even (SCM proc) SCM_NORETURN SCM_NOINLINE; | |
28d5d253 MW |
470 | static void vm_error_kwargs_invalid_keyword (SCM proc, SCM obj) SCM_NORETURN SCM_NOINLINE; |
471 | static void vm_error_kwargs_unrecognized_keyword (SCM proc, SCM kw) SCM_NORETURN SCM_NOINLINE; | |
4d497b62 AW |
472 | static void vm_error_too_many_args (int nargs) SCM_NORETURN SCM_NOINLINE; |
473 | static void vm_error_wrong_num_args (SCM proc) SCM_NORETURN SCM_NOINLINE; | |
474 | static void vm_error_wrong_type_apply (SCM proc) SCM_NORETURN SCM_NOINLINE; | |
4d497b62 AW |
475 | static void vm_error_stack_underflow (void) SCM_NORETURN SCM_NOINLINE; |
476 | static void vm_error_improper_list (SCM x) SCM_NORETURN SCM_NOINLINE; | |
477 | static void vm_error_not_a_pair (const char *subr, SCM x) SCM_NORETURN SCM_NOINLINE; | |
478 | static void vm_error_not_a_bytevector (const char *subr, SCM x) SCM_NORETURN SCM_NOINLINE; | |
479 | static void vm_error_not_a_struct (const char *subr, SCM x) SCM_NORETURN SCM_NOINLINE; | |
a32488ba AW |
480 | static void vm_error_not_a_vector (const char *subr, SCM v) SCM_NORETURN SCM_NOINLINE; |
481 | static void vm_error_out_of_range (const char *subr, SCM k) SCM_NORETURN SCM_NOINLINE; | |
4d497b62 AW |
482 | static void vm_error_no_values (void) SCM_NORETURN SCM_NOINLINE; |
483 | static void vm_error_not_enough_values (void) SCM_NORETURN SCM_NOINLINE; | |
82f4bac4 | 484 | static void vm_error_wrong_number_of_values (scm_t_uint32 expected) SCM_NORETURN SCM_NOINLINE; |
4d497b62 AW |
485 | static void vm_error_continuation_not_rewindable (SCM cont) SCM_NORETURN SCM_NOINLINE; |
486 | static void vm_error_bad_wide_string_length (size_t len) SCM_NORETURN SCM_NOINLINE; | |
53bdfcf0 AW |
487 | |
488 | static void | |
489 | vm_error (const char *msg, SCM arg) | |
490 | { | |
491 | scm_throw (sym_vm_error, | |
492 | scm_list_3 (sym_vm_run, scm_from_latin1_string (msg), | |
493 | SCM_UNBNDP (arg) ? SCM_EOL : scm_list_1 (arg))); | |
494 | abort(); /* not reached */ | |
495 | } | |
496 | ||
497 | static void | |
498 | vm_error_bad_instruction (scm_t_uint32 inst) | |
499 | { | |
500 | vm_error ("VM: Bad instruction: ~s", scm_from_uint32 (inst)); | |
501 | } | |
502 | ||
503 | static void | |
73fc4e73 | 504 | vm_error_unbound (SCM sym) |
53bdfcf0 | 505 | { |
73fc4e73 | 506 | scm_error_scm (scm_misc_error_key, SCM_BOOL_F, |
53bdfcf0 AW |
507 | scm_from_latin1_string ("Unbound variable: ~s"), |
508 | scm_list_1 (sym), SCM_BOOL_F); | |
509 | } | |
510 | ||
511 | static void | |
73fc4e73 | 512 | vm_error_unbound_fluid (SCM fluid) |
53bdfcf0 | 513 | { |
73fc4e73 | 514 | scm_error_scm (scm_misc_error_key, SCM_BOOL_F, |
53bdfcf0 AW |
515 | scm_from_latin1_string ("Unbound fluid: ~s"), |
516 | scm_list_1 (fluid), SCM_BOOL_F); | |
517 | } | |
518 | ||
519 | static void | |
520 | vm_error_not_a_variable (const char *func_name, SCM x) | |
521 | { | |
522 | scm_error (scm_arg_type_key, func_name, "Not a variable: ~S", | |
523 | scm_list_1 (x), scm_list_1 (x)); | |
524 | } | |
525 | ||
53bdfcf0 AW |
526 | static void |
527 | vm_error_apply_to_non_list (SCM x) | |
528 | { | |
529 | scm_error (scm_arg_type_key, "apply", "Apply to non-list: ~S", | |
530 | scm_list_1 (x), scm_list_1 (x)); | |
531 | } | |
532 | ||
533 | static void | |
534 | vm_error_kwargs_length_not_even (SCM proc) | |
535 | { | |
536 | scm_error_scm (sym_keyword_argument_error, proc, | |
537 | scm_from_latin1_string ("Odd length of keyword argument list"), | |
538 | SCM_EOL, SCM_BOOL_F); | |
539 | } | |
540 | ||
541 | static void | |
4af0d97e | 542 | vm_error_kwargs_invalid_keyword (SCM proc, SCM obj) |
53bdfcf0 AW |
543 | { |
544 | scm_error_scm (sym_keyword_argument_error, proc, | |
545 | scm_from_latin1_string ("Invalid keyword"), | |
4af0d97e | 546 | SCM_EOL, scm_list_1 (obj)); |
53bdfcf0 AW |
547 | } |
548 | ||
549 | static void | |
4af0d97e | 550 | vm_error_kwargs_unrecognized_keyword (SCM proc, SCM kw) |
53bdfcf0 AW |
551 | { |
552 | scm_error_scm (sym_keyword_argument_error, proc, | |
553 | scm_from_latin1_string ("Unrecognized keyword"), | |
4af0d97e | 554 | SCM_EOL, scm_list_1 (kw)); |
53bdfcf0 AW |
555 | } |
556 | ||
557 | static void | |
558 | vm_error_too_many_args (int nargs) | |
559 | { | |
560 | vm_error ("VM: Too many arguments", scm_from_int (nargs)); | |
561 | } | |
562 | ||
563 | static void | |
564 | vm_error_wrong_num_args (SCM proc) | |
565 | { | |
566 | scm_wrong_num_args (proc); | |
567 | } | |
568 | ||
569 | static void | |
570 | vm_error_wrong_type_apply (SCM proc) | |
571 | { | |
572 | scm_error (scm_arg_type_key, NULL, "Wrong type to apply: ~S", | |
573 | scm_list_1 (proc), scm_list_1 (proc)); | |
574 | } | |
575 | ||
53bdfcf0 AW |
576 | static void |
577 | vm_error_stack_underflow (void) | |
578 | { | |
579 | vm_error ("VM: Stack underflow", SCM_UNDEFINED); | |
580 | } | |
581 | ||
582 | static void | |
583 | vm_error_improper_list (SCM x) | |
584 | { | |
585 | vm_error ("Expected a proper list, but got object with tail ~s", x); | |
586 | } | |
587 | ||
588 | static void | |
589 | vm_error_not_a_pair (const char *subr, SCM x) | |
590 | { | |
591 | scm_wrong_type_arg_msg (subr, 1, x, "pair"); | |
592 | } | |
593 | ||
594 | static void | |
595 | vm_error_not_a_bytevector (const char *subr, SCM x) | |
596 | { | |
597 | scm_wrong_type_arg_msg (subr, 1, x, "bytevector"); | |
598 | } | |
599 | ||
600 | static void | |
601 | vm_error_not_a_struct (const char *subr, SCM x) | |
602 | { | |
603 | scm_wrong_type_arg_msg (subr, 1, x, "struct"); | |
604 | } | |
605 | ||
a32488ba AW |
606 | static void |
607 | vm_error_not_a_vector (const char *subr, SCM x) | |
608 | { | |
609 | scm_wrong_type_arg_msg (subr, 1, x, "vector"); | |
610 | } | |
611 | ||
612 | static void | |
613 | vm_error_out_of_range (const char *subr, SCM k) | |
614 | { | |
615 | scm_to_size_t (k); | |
616 | scm_out_of_range (subr, k); | |
617 | } | |
618 | ||
53bdfcf0 AW |
619 | static void |
620 | vm_error_no_values (void) | |
621 | { | |
622 | vm_error ("Zero values returned to single-valued continuation", | |
623 | SCM_UNDEFINED); | |
624 | } | |
625 | ||
626 | static void | |
627 | vm_error_not_enough_values (void) | |
628 | { | |
629 | vm_error ("Too few values returned to continuation", SCM_UNDEFINED); | |
630 | } | |
631 | ||
82f4bac4 AW |
632 | static void |
633 | vm_error_wrong_number_of_values (scm_t_uint32 expected) | |
634 | { | |
635 | vm_error ("Wrong number of values returned to continuation (expected ~a)", | |
636 | scm_from_uint32 (expected)); | |
637 | } | |
638 | ||
53bdfcf0 AW |
639 | static void |
640 | vm_error_continuation_not_rewindable (SCM cont) | |
641 | { | |
642 | vm_error ("Unrewindable partial continuation", cont); | |
643 | } | |
644 | ||
645 | static void | |
646 | vm_error_bad_wide_string_length (size_t len) | |
647 | { | |
648 | vm_error ("VM: Bad wide string length: ~S", scm_from_size_t (len)); | |
649 | } | |
650 | ||
53bdfcf0 AW |
651 | |
652 | \f | |
28b119ee | 653 | |
ef6b7f71 | 654 | static SCM vm_boot_continuation; |
486013d6 AW |
655 | static SCM vm_builtin_apply; |
656 | static SCM vm_builtin_values; | |
657 | static SCM vm_builtin_abort_to_prompt; | |
658 | static SCM vm_builtin_call_with_values; | |
659 | static SCM vm_builtin_call_with_current_continuation; | |
510ca126 | 660 | |
ef6b7f71 | 661 | static const scm_t_uint32 vm_boot_continuation_code[] = { |
095100bb | 662 | SCM_PACK_OP_24 (halt, 0) |
510ca126 AW |
663 | }; |
664 | ||
486013d6 | 665 | static const scm_t_uint32 vm_builtin_apply_code[] = { |
095100bb AW |
666 | SCM_PACK_OP_24 (assert_nargs_ge, 3), |
667 | SCM_PACK_OP_24 (tail_apply, 0), /* proc in r1, args from r2 */ | |
510ca126 AW |
668 | }; |
669 | ||
486013d6 | 670 | static const scm_t_uint32 vm_builtin_values_code[] = { |
095100bb | 671 | SCM_PACK_OP_24 (return_values, 0) /* vals from r1 */ |
510ca126 AW |
672 | }; |
673 | ||
486013d6 | 674 | static const scm_t_uint32 vm_builtin_abort_to_prompt_code[] = { |
095100bb AW |
675 | SCM_PACK_OP_24 (assert_nargs_ge, 2), |
676 | SCM_PACK_OP_24 (abort, 0), /* tag in r1, vals from r2 */ | |
486013d6 | 677 | /* FIXME: Partial continuation should capture caller regs. */ |
095100bb | 678 | SCM_PACK_OP_24 (return_values, 0) /* vals from r1 */ |
486013d6 AW |
679 | }; |
680 | ||
681 | static const scm_t_uint32 vm_builtin_call_with_values_code[] = { | |
095100bb AW |
682 | SCM_PACK_OP_24 (assert_nargs_ee, 3), |
683 | SCM_PACK_OP_24 (alloc_frame, 7), | |
684 | SCM_PACK_OP_12_12 (mov, 6, 1), | |
685 | SCM_PACK_OP_24 (call, 6), SCM_PACK_OP_ARG_8_24 (0, 1), | |
686 | SCM_PACK_OP_12_12 (mov, 0, 2), | |
687 | SCM_PACK_OP_24 (tail_call_shuffle, 7) | |
486013d6 AW |
688 | }; |
689 | ||
690 | static const scm_t_uint32 vm_builtin_call_with_current_continuation_code[] = { | |
095100bb AW |
691 | SCM_PACK_OP_24 (assert_nargs_ee, 2), |
692 | SCM_PACK_OP_24 (call_cc, 0) | |
486013d6 AW |
693 | }; |
694 | ||
695 | ||
696 | static SCM | |
697 | scm_vm_builtin_ref (unsigned idx) | |
698 | { | |
699 | switch (idx) | |
700 | { | |
9f309e2c | 701 | #define INDEX_TO_NAME(builtin, BUILTIN, req, opt, rest) \ |
486013d6 AW |
702 | case SCM_VM_BUILTIN_##BUILTIN: return vm_builtin_##builtin; |
703 | FOR_EACH_VM_BUILTIN(INDEX_TO_NAME) | |
704 | #undef INDEX_TO_NAME | |
705 | default: abort(); | |
706 | } | |
707 | } | |
708 | ||
9f309e2c | 709 | SCM scm_sym_apply; |
486013d6 AW |
710 | static SCM scm_sym_values; |
711 | static SCM scm_sym_abort_to_prompt; | |
712 | static SCM scm_sym_call_with_values; | |
713 | static SCM scm_sym_call_with_current_continuation; | |
714 | ||
715 | SCM | |
716 | scm_vm_builtin_name_to_index (SCM name) | |
717 | #define FUNC_NAME "builtin-name->index" | |
718 | { | |
719 | SCM_VALIDATE_SYMBOL (1, name); | |
720 | ||
9f309e2c | 721 | #define NAME_TO_INDEX(builtin, BUILTIN, req, opt, rest) \ |
486013d6 AW |
722 | if (scm_is_eq (name, scm_sym_##builtin)) \ |
723 | return scm_from_uint (SCM_VM_BUILTIN_##BUILTIN); | |
724 | FOR_EACH_VM_BUILTIN(NAME_TO_INDEX) | |
725 | #undef NAME_TO_INDEX | |
726 | ||
727 | return SCM_BOOL_F; | |
728 | } | |
729 | #undef FUNC_NAME | |
730 | ||
731 | SCM | |
732 | scm_vm_builtin_index_to_name (SCM index) | |
733 | #define FUNC_NAME "builtin-index->name" | |
734 | { | |
735 | unsigned idx; | |
736 | ||
737 | SCM_VALIDATE_UINT_COPY (1, index, idx); | |
738 | ||
739 | switch (idx) | |
740 | { | |
9f309e2c | 741 | #define INDEX_TO_NAME(builtin, BUILTIN, req, opt, rest) \ |
486013d6 AW |
742 | case SCM_VM_BUILTIN_##BUILTIN: return scm_sym_##builtin; |
743 | FOR_EACH_VM_BUILTIN(INDEX_TO_NAME) | |
744 | #undef INDEX_TO_NAME | |
745 | default: return SCM_BOOL_F; | |
746 | } | |
747 | } | |
748 | #undef FUNC_NAME | |
749 | ||
750 | static void | |
751 | scm_init_vm_builtins (void) | |
752 | { | |
486013d6 AW |
753 | scm_c_define_gsubr ("builtin-name->index", 1, 0, 0, |
754 | scm_vm_builtin_name_to_index); | |
755 | scm_c_define_gsubr ("builtin-index->name", 1, 0, 0, | |
756 | scm_vm_builtin_index_to_name); | |
757 | } | |
758 | ||
759 | SCM | |
760 | scm_i_call_with_current_continuation (SCM proc) | |
761 | { | |
762 | return scm_call_1 (vm_builtin_call_with_current_continuation, proc); | |
763 | } | |
510ca126 | 764 | |
a98cef7e KN |
765 | \f |
766 | /* | |
767 | * VM | |
768 | */ | |
769 | ||
f42cfbf0 AW |
770 | #define VM_NAME vm_regular_engine |
771 | #define VM_USE_HOOKS 0 | |
6d14383e | 772 | #define FUNC_NAME "vm-regular-engine" |
83495480 | 773 | #include "vm-engine.c" |
6d14383e | 774 | #undef FUNC_NAME |
f42cfbf0 AW |
775 | #undef VM_USE_HOOKS |
776 | #undef VM_NAME | |
17e90c5e | 777 | |
f42cfbf0 AW |
778 | #define VM_NAME vm_debug_engine |
779 | #define VM_USE_HOOKS 1 | |
6d14383e | 780 | #define FUNC_NAME "vm-debug-engine" |
83495480 | 781 | #include "vm-engine.c" |
6d14383e | 782 | #undef FUNC_NAME |
f42cfbf0 AW |
783 | #undef VM_USE_HOOKS |
784 | #undef VM_NAME | |
17e90c5e | 785 | |
dd1c7dec AW |
786 | typedef SCM (*scm_t_vm_engine) (scm_i_thread *current_thread, struct scm_vm *vp, |
787 | scm_i_jmp_buf *registers, int resume); | |
73c3db66 | 788 | |
f42cfbf0 AW |
789 | static const scm_t_vm_engine vm_engines[SCM_VM_NUM_ENGINES] = |
790 | { vm_regular_engine, vm_debug_engine }; | |
73c3db66 | 791 | |
5f18bc84 AW |
792 | static SCM* |
793 | allocate_stack (size_t size) | |
794 | #define FUNC_NAME "make_vm" | |
795 | { | |
796 | void *ret; | |
e3eb628d | 797 | |
5f18bc84 AW |
798 | if (size >= ((size_t) -1) / sizeof (SCM)) |
799 | abort (); | |
800 | ||
801 | size *= sizeof (SCM); | |
e3eb628d | 802 | |
5f18bc84 AW |
803 | #if HAVE_SYS_MMAN_H |
804 | ret = mmap (NULL, size, PROT_READ | PROT_WRITE, | |
805 | MAP_PRIVATE | MAP_ANONYMOUS, -1, 0); | |
806 | if (ret == MAP_FAILED) | |
b8321c24 | 807 | ret = NULL; |
5f18bc84 AW |
808 | #else |
809 | ret = malloc (size); | |
e3eb628d LC |
810 | #endif |
811 | ||
b8321c24 AW |
812 | if (!ret) |
813 | { | |
814 | perror ("allocate_stack failed"); | |
815 | return NULL; | |
816 | } | |
817 | ||
5f18bc84 AW |
818 | return (SCM *) ret; |
819 | } | |
820 | #undef FUNC_NAME | |
821 | ||
822 | static void | |
823 | free_stack (SCM *stack, size_t size) | |
824 | { | |
825 | size *= sizeof (SCM); | |
826 | ||
827 | #if HAVE_SYS_MMAN_H | |
828 | munmap (stack, size); | |
829 | #else | |
830 | free (stack); | |
831 | #endif | |
832 | } | |
833 | ||
22d425ec AW |
834 | static SCM* |
835 | expand_stack (SCM *old_stack, size_t old_size, size_t new_size) | |
836 | #define FUNC_NAME "expand_stack" | |
837 | { | |
838 | #if defined MREMAP_MAYMOVE | |
839 | void *new_stack; | |
840 | ||
841 | if (new_size >= ((size_t) -1) / sizeof (SCM)) | |
842 | abort (); | |
843 | ||
844 | old_size *= sizeof (SCM); | |
845 | new_size *= sizeof (SCM); | |
846 | ||
847 | new_stack = mremap (old_stack, old_size, new_size, MREMAP_MAYMOVE); | |
848 | if (new_stack == MAP_FAILED) | |
b8321c24 | 849 | return NULL; |
22d425ec AW |
850 | |
851 | return (SCM *) new_stack; | |
852 | #else | |
853 | SCM *new_stack; | |
854 | ||
855 | new_stack = allocate_stack (new_size); | |
b8321c24 AW |
856 | if (!new_stack) |
857 | return NULL; | |
858 | ||
22d425ec AW |
859 | memcpy (new_stack, old_stack, old_size * sizeof (SCM)); |
860 | free_stack (old_stack, old_size); | |
861 | ||
862 | return new_stack; | |
863 | #endif | |
864 | } | |
865 | #undef FUNC_NAME | |
866 | ||
3506b152 | 867 | static struct scm_vm * |
17e90c5e KN |
868 | make_vm (void) |
869 | #define FUNC_NAME "make_vm" | |
a98cef7e | 870 | { |
17e90c5e | 871 | int i; |
7f991c7d | 872 | struct scm_vm *vp; |
747a1635 | 873 | |
7f991c7d | 874 | vp = scm_gc_malloc (sizeof (struct scm_vm), "vm"); |
d8eeb67c | 875 | |
f764e259 | 876 | vp->stack_size = page_size / sizeof (SCM); |
5f18bc84 | 877 | vp->stack_base = allocate_stack (vp->stack_size); |
b8321c24 AW |
878 | if (!vp->stack_base) |
879 | /* As in expand_stack, we don't have any way to throw an exception | |
880 | if we can't allocate one measely page -- there's no stack to | |
881 | handle it. For now, abort. */ | |
882 | abort (); | |
22d425ec | 883 | vp->stack_limit = vp->stack_base + vp->stack_size; |
f764e259 | 884 | vp->overflow_handler_stack = SCM_EOL; |
3616e9e9 KN |
885 | vp->ip = NULL; |
886 | vp->sp = vp->stack_base - 1; | |
887 | vp->fp = NULL; | |
ea9f4f4b | 888 | vp->engine = vm_default_engine; |
7656f194 | 889 | vp->trace_level = 0; |
17e90c5e | 890 | for (i = 0; i < SCM_VM_NUM_HOOKS; i++) |
3d5ee0cd | 891 | vp->hooks[i] = SCM_BOOL_F; |
3506b152 AW |
892 | |
893 | return vp; | |
a98cef7e | 894 | } |
17e90c5e | 895 | #undef FUNC_NAME |
a98cef7e | 896 | |
7dba1c2f AW |
897 | static void |
898 | return_unused_stack_to_os (struct scm_vm *vp) | |
899 | { | |
900 | #if HAVE_SYS_MMAN_H | |
b914b236 AW |
901 | scm_t_uintptr start = (scm_t_uintptr) (vp->sp + 1); |
902 | scm_t_uintptr end = (scm_t_uintptr) vp->stack_limit; | |
903 | /* The second condition is needed to protect against wrap-around. */ | |
904 | if (vp->sp_max_since_gc < vp->stack_limit && vp->sp < vp->sp_max_since_gc) | |
905 | end = (scm_t_uintptr) (vp->sp_max_since_gc + 1); | |
7dba1c2f AW |
906 | |
907 | start = ((start - 1U) | (page_size - 1U)) + 1U; /* round up */ | |
908 | end = ((end - 1U) | (page_size - 1U)) + 1U; /* round up */ | |
909 | ||
910 | /* Return these pages to the OS. The next time they are paged in, | |
911 | they will be zeroed. */ | |
912 | if (start < end) | |
b8321c24 AW |
913 | { |
914 | int ret = 0; | |
915 | ||
916 | do | |
917 | ret = madvise ((void *) start, end - start, MADV_DONTNEED); | |
918 | while (ret && errno == -EAGAIN); | |
919 | ||
920 | if (ret) | |
921 | perror ("madvise failed"); | |
922 | } | |
7dba1c2f AW |
923 | |
924 | vp->sp_max_since_gc = vp->sp; | |
925 | #endif | |
926 | } | |
927 | ||
40719006 AW |
928 | #define DEAD_SLOT_MAP_CACHE_SIZE 32U |
929 | struct dead_slot_map_cache_entry | |
930 | { | |
931 | scm_t_uint32 *ip; | |
932 | const scm_t_uint8 *map; | |
933 | }; | |
934 | ||
935 | struct dead_slot_map_cache | |
936 | { | |
937 | struct dead_slot_map_cache_entry entries[DEAD_SLOT_MAP_CACHE_SIZE]; | |
938 | }; | |
939 | ||
940 | static const scm_t_uint8 * | |
941 | find_dead_slot_map (scm_t_uint32 *ip, struct dead_slot_map_cache *cache) | |
942 | { | |
943 | /* The lower two bits should be zero. FIXME: Use a better hash | |
944 | function; we don't expose scm_raw_hashq currently. */ | |
945 | size_t slot = (((scm_t_uintptr) ip) >> 2) % DEAD_SLOT_MAP_CACHE_SIZE; | |
946 | const scm_t_uint8 *map; | |
947 | ||
948 | if (cache->entries[slot].ip == ip) | |
949 | map = cache->entries[slot].map; | |
950 | else | |
951 | { | |
952 | map = scm_find_dead_slot_map_unlocked (ip); | |
953 | cache->entries[slot].ip = ip; | |
954 | cache->entries[slot].map = map; | |
955 | } | |
956 | ||
957 | return map; | |
958 | } | |
959 | ||
e3eb628d | 960 | /* Mark the VM stack region between its base and its current top. */ |
5f18bc84 AW |
961 | struct GC_ms_entry * |
962 | scm_i_vm_mark_stack (struct scm_vm *vp, struct GC_ms_entry *mark_stack_ptr, | |
963 | struct GC_ms_entry *mark_stack_limit) | |
e3eb628d | 964 | { |
1cdf9b78 | 965 | SCM *sp, *fp; |
02c624fc AW |
966 | /* The first frame will be marked conservatively (without a dead |
967 | slot map). This is because GC can happen at any point within the | |
968 | hottest activation, due to multiple threads or per-instruction | |
969 | hooks, and providing dead slot maps for all points in a program | |
970 | would take a prohibitive amount of space. */ | |
971 | const scm_t_uint8 *dead_slots = NULL; | |
7161ec11 AW |
972 | scm_t_uintptr upper = (scm_t_uintptr) GC_greatest_plausible_heap_addr; |
973 | scm_t_uintptr lower = (scm_t_uintptr) GC_least_plausible_heap_addr; | |
40719006 AW |
974 | struct dead_slot_map_cache cache; |
975 | ||
976 | memset (&cache, 0, sizeof (cache)); | |
e3eb628d | 977 | |
1cdf9b78 AW |
978 | for (fp = vp->fp, sp = vp->sp; fp; fp = SCM_FRAME_DYNAMIC_LINK (fp)) |
979 | { | |
980 | for (; sp >= &SCM_FRAME_LOCAL (fp, 0); sp--) | |
981 | { | |
982 | SCM elt = *sp; | |
7161ec11 AW |
983 | if (SCM_NIMP (elt) |
984 | && SCM_UNPACK (elt) >= lower && SCM_UNPACK (elt) <= upper) | |
02c624fc AW |
985 | { |
986 | if (dead_slots) | |
987 | { | |
988 | size_t slot = sp - &SCM_FRAME_LOCAL (fp, 0); | |
989 | if (dead_slots[slot / 8U] & (1U << (slot % 8U))) | |
990 | { | |
991 | /* This value may become dead as a result of GC, | |
992 | so we can't just leave it on the stack. */ | |
567a6d1e | 993 | *sp = SCM_UNSPECIFIED; |
02c624fc AW |
994 | continue; |
995 | } | |
996 | } | |
997 | ||
7161ec11 | 998 | mark_stack_ptr = GC_mark_and_push ((void *) elt, |
02c624fc AW |
999 | mark_stack_ptr, |
1000 | mark_stack_limit, | |
1001 | NULL); | |
1002 | } | |
1cdf9b78 AW |
1003 | } |
1004 | sp = SCM_FRAME_PREVIOUS_SP (fp); | |
02c624fc AW |
1005 | /* Inner frames may have a dead slots map for precise marking. |
1006 | Note that there may be other reasons to not have a dead slots | |
1007 | map, e.g. if all of the frame's slots below the callee frame | |
1008 | are live. */ | |
40719006 | 1009 | dead_slots = find_dead_slot_map (SCM_FRAME_RETURN_ADDRESS (fp), &cache); |
1cdf9b78 | 1010 | } |
e3eb628d | 1011 | |
7dba1c2f AW |
1012 | return_unused_stack_to_os (vp); |
1013 | ||
e3eb628d LC |
1014 | return mark_stack_ptr; |
1015 | } | |
1016 | ||
5f18bc84 AW |
1017 | /* Free the VM stack, as this thread is exiting. */ |
1018 | void | |
1019 | scm_i_vm_free_stack (struct scm_vm *vp) | |
1020 | { | |
1021 | free_stack (vp->stack_base, vp->stack_size); | |
1022 | vp->stack_base = vp->stack_limit = NULL; | |
1023 | vp->stack_size = 0; | |
1024 | } | |
e3eb628d | 1025 | |
c53d0f01 AW |
1026 | struct vm_expand_stack_data |
1027 | { | |
1028 | struct scm_vm *vp; | |
1029 | size_t stack_size; | |
1030 | SCM *new_sp; | |
1031 | }; | |
1032 | ||
1033 | static void * | |
1034 | vm_expand_stack_inner (void *data_ptr) | |
1035 | { | |
1036 | struct vm_expand_stack_data *data = data_ptr; | |
1037 | ||
1038 | struct scm_vm *vp = data->vp; | |
1039 | SCM *old_stack, *new_stack; | |
1040 | size_t new_size; | |
1041 | scm_t_ptrdiff reloc; | |
1042 | ||
1043 | new_size = vp->stack_size; | |
1044 | while (new_size < data->stack_size) | |
1045 | new_size *= 2; | |
1046 | old_stack = vp->stack_base; | |
1047 | ||
1048 | new_stack = expand_stack (vp->stack_base, vp->stack_size, new_size); | |
1049 | if (!new_stack) | |
1050 | return NULL; | |
1051 | ||
1052 | vp->stack_base = new_stack; | |
1053 | vp->stack_size = new_size; | |
1054 | vp->stack_limit = vp->stack_base + new_size; | |
1055 | reloc = vp->stack_base - old_stack; | |
1056 | ||
1057 | if (reloc) | |
1058 | { | |
1059 | SCM *fp; | |
1060 | if (vp->fp) | |
1061 | vp->fp += reloc; | |
1062 | data->new_sp += reloc; | |
1063 | fp = vp->fp; | |
1064 | while (fp) | |
1065 | { | |
1066 | SCM *next_fp = SCM_FRAME_DYNAMIC_LINK (fp); | |
1067 | if (next_fp) | |
1068 | { | |
1069 | next_fp += reloc; | |
1070 | SCM_FRAME_SET_DYNAMIC_LINK (fp, next_fp); | |
1071 | } | |
1072 | fp = next_fp; | |
1073 | } | |
1074 | } | |
1075 | ||
1076 | return new_stack; | |
1077 | } | |
1078 | ||
f764e259 AW |
1079 | static scm_t_ptrdiff |
1080 | current_overflow_size (struct scm_vm *vp) | |
1081 | { | |
1082 | if (scm_is_pair (vp->overflow_handler_stack)) | |
1083 | return scm_to_ptrdiff_t (scm_caar (vp->overflow_handler_stack)); | |
1084 | return -1; | |
1085 | } | |
1086 | ||
1087 | static int | |
1088 | should_handle_stack_overflow (struct scm_vm *vp, scm_t_ptrdiff stack_size) | |
1089 | { | |
1090 | scm_t_ptrdiff overflow_size = current_overflow_size (vp); | |
1091 | return overflow_size >= 0 && stack_size >= overflow_size; | |
1092 | } | |
1093 | ||
1094 | static void | |
1095 | reset_stack_limit (struct scm_vm *vp) | |
1096 | { | |
1097 | if (should_handle_stack_overflow (vp, vp->stack_size)) | |
1098 | vp->stack_limit = vp->stack_base + current_overflow_size (vp); | |
1099 | else | |
1100 | vp->stack_limit = vp->stack_base + vp->stack_size; | |
1101 | } | |
1102 | ||
1103 | struct overflow_handler_data | |
1104 | { | |
1105 | struct scm_vm *vp; | |
1106 | SCM overflow_handler_stack; | |
1107 | }; | |
1108 | ||
1109 | static void | |
1110 | wind_overflow_handler (void *ptr) | |
1111 | { | |
1112 | struct overflow_handler_data *data = ptr; | |
1113 | ||
1114 | data->vp->overflow_handler_stack = data->overflow_handler_stack; | |
1115 | ||
1116 | reset_stack_limit (data->vp); | |
1117 | } | |
1118 | ||
1119 | static void | |
1120 | unwind_overflow_handler (void *ptr) | |
1121 | { | |
1122 | struct overflow_handler_data *data = ptr; | |
1123 | ||
1124 | data->vp->overflow_handler_stack = scm_cdr (data->overflow_handler_stack); | |
1125 | ||
1126 | reset_stack_limit (data->vp); | |
1127 | } | |
1128 | ||
22d425ec | 1129 | static void |
c2ae85be | 1130 | vm_expand_stack (struct scm_vm *vp, SCM *new_sp) |
22d425ec | 1131 | { |
c2ae85be | 1132 | scm_t_ptrdiff stack_size = new_sp + 1 - vp->stack_base; |
22d425ec | 1133 | |
22d425ec AW |
1134 | if (stack_size > vp->stack_size) |
1135 | { | |
c53d0f01 | 1136 | struct vm_expand_stack_data data; |
b8321c24 | 1137 | |
c53d0f01 AW |
1138 | data.vp = vp; |
1139 | data.stack_size = stack_size; | |
1140 | data.new_sp = new_sp; | |
1141 | ||
1142 | if (!GC_call_with_alloc_lock (vm_expand_stack_inner, &data)) | |
f764e259 | 1143 | /* Throw an unwind-only exception. */ |
c53d0f01 | 1144 | scm_report_stack_overflow (); |
22d425ec | 1145 | |
c53d0f01 | 1146 | new_sp = data.new_sp; |
22d425ec AW |
1147 | } |
1148 | ||
2a62eda8 AW |
1149 | vp->sp_max_since_gc = vp->sp = new_sp; |
1150 | ||
f764e259 | 1151 | if (should_handle_stack_overflow (vp, stack_size)) |
22d425ec | 1152 | { |
f764e259 AW |
1153 | SCM more_stack, new_limit; |
1154 | ||
1155 | struct overflow_handler_data data; | |
1156 | data.vp = vp; | |
1157 | data.overflow_handler_stack = vp->overflow_handler_stack; | |
22d425ec | 1158 | |
f764e259 | 1159 | scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE); |
22d425ec | 1160 | |
f764e259 AW |
1161 | scm_dynwind_rewind_handler (unwind_overflow_handler, &data, |
1162 | SCM_F_WIND_EXPLICITLY); | |
1163 | scm_dynwind_unwind_handler (wind_overflow_handler, &data, | |
1164 | SCM_F_WIND_EXPLICITLY); | |
22d425ec | 1165 | |
f764e259 AW |
1166 | /* Call the overflow handler. */ |
1167 | more_stack = scm_call_0 (scm_cdar (data.overflow_handler_stack)); | |
1168 | ||
1169 | /* If the overflow handler returns, its return value should be an | |
1170 | integral number of words from the outer stack limit to transfer | |
1171 | to the inner limit. */ | |
1172 | if (scm_to_ptrdiff_t (more_stack) <= 0) | |
1173 | scm_out_of_range (NULL, more_stack); | |
1174 | new_limit = scm_sum (scm_caar (data.overflow_handler_stack), more_stack); | |
1175 | if (scm_is_pair (scm_cdr (data.overflow_handler_stack))) | |
1176 | new_limit = scm_min (new_limit, | |
1177 | scm_caadr (data.overflow_handler_stack)); | |
1178 | ||
1179 | /* Ensure the new limit is in range. */ | |
1180 | scm_to_ptrdiff_t (new_limit); | |
1181 | ||
1182 | /* Increase the limit that we will restore. */ | |
1183 | scm_set_car_x (scm_car (data.overflow_handler_stack), new_limit); | |
22d425ec | 1184 | |
f764e259 AW |
1185 | scm_dynwind_end (); |
1186 | ||
1187 | /* Recurse */ | |
1188 | return vm_expand_stack (vp, new_sp); | |
1189 | } | |
22d425ec AW |
1190 | } |
1191 | ||
b85cd20f AW |
1192 | static struct scm_vm * |
1193 | thread_vm (scm_i_thread *t) | |
55ee3607 | 1194 | { |
b85cd20f AW |
1195 | if (SCM_UNLIKELY (!t->vp)) |
1196 | t->vp = make_vm (); | |
1197 | ||
1198 | return t->vp; | |
55ee3607 AW |
1199 | } |
1200 | ||
e7f9abab | 1201 | struct scm_vm * |
a222cbc9 | 1202 | scm_the_vm (void) |
271c3d31 | 1203 | { |
b85cd20f AW |
1204 | return thread_vm (SCM_I_CURRENT_THREAD); |
1205 | } | |
ea9f4f4b | 1206 | |
b85cd20f AW |
1207 | SCM |
1208 | scm_call_n (SCM proc, SCM *argv, size_t nargs) | |
1209 | { | |
1210 | scm_i_thread *thread; | |
1211 | struct scm_vm *vp; | |
bd63e5b2 AW |
1212 | SCM *base; |
1213 | ptrdiff_t base_frame_size; | |
dd1c7dec AW |
1214 | /* Cached variables. */ |
1215 | scm_i_jmp_buf registers; /* used for prompts */ | |
bd63e5b2 | 1216 | size_t i; |
ea9f4f4b | 1217 | |
b85cd20f AW |
1218 | thread = SCM_I_CURRENT_THREAD; |
1219 | vp = thread_vm (thread); | |
1220 | ||
1221 | SCM_CHECK_STACK; | |
bd63e5b2 | 1222 | |
b914b236 AW |
1223 | /* Check that we have enough space: 3 words for the boot continuation, |
1224 | and 3 + nargs for the procedure application. */ | |
1225 | base_frame_size = 3 + 3 + nargs; | |
1226 | vm_push_sp (vp, vp->sp + base_frame_size); | |
bd63e5b2 AW |
1227 | base = vp->sp + 1 - base_frame_size; |
1228 | ||
1229 | /* Since it's possible to receive the arguments on the stack itself, | |
1230 | shuffle up the arguments first. */ | |
1231 | for (i = nargs; i > 0; i--) | |
1232 | base[6 + i - 1] = argv[i - 1]; | |
1233 | ||
1234 | /* Push the boot continuation, which calls PROC and returns its | |
1235 | result(s). */ | |
1236 | base[0] = SCM_PACK (vp->fp); /* dynamic link */ | |
1237 | base[1] = SCM_PACK (vp->ip); /* ra */ | |
1238 | base[2] = vm_boot_continuation; | |
1239 | vp->fp = &base[2]; | |
1240 | vp->ip = (scm_t_uint32 *) vm_boot_continuation_code; | |
1241 | ||
1242 | /* The pending call to PROC. */ | |
1243 | base[3] = SCM_PACK (vp->fp); /* dynamic link */ | |
1244 | base[4] = SCM_PACK (vp->ip); /* ra */ | |
1245 | base[5] = proc; | |
1246 | vp->fp = &base[5]; | |
7dba1c2f | 1247 | |
dd1c7dec AW |
1248 | { |
1249 | int resume = SCM_I_SETJMP (registers); | |
1250 | ||
1251 | if (SCM_UNLIKELY (resume)) | |
c2247b78 AW |
1252 | { |
1253 | scm_gc_after_nonlocal_exit (); | |
1254 | /* Non-local return. */ | |
1255 | vm_dispatch_abort_hook (vp); | |
1256 | } | |
dd1c7dec AW |
1257 | |
1258 | return vm_engines[vp->engine](thread, vp, ®isters, resume); | |
1259 | } | |
271c3d31 | 1260 | } |
499a4c07 | 1261 | |
a222cbc9 | 1262 | /* Scheme interface */ |
a98cef7e | 1263 | |
17e90c5e KN |
1264 | #define VM_DEFINE_HOOK(n) \ |
1265 | { \ | |
3d5ee0cd | 1266 | struct scm_vm *vp; \ |
e7f9abab | 1267 | vp = scm_the_vm (); \ |
8b22ed7a | 1268 | if (scm_is_false (vp->hooks[n])) \ |
238e7a11 | 1269 | vp->hooks[n] = scm_make_hook (SCM_I_MAKINUM (1)); \ |
3d5ee0cd | 1270 | return vp->hooks[n]; \ |
17e90c5e KN |
1271 | } |
1272 | ||
972275ee AW |
1273 | SCM_DEFINE (scm_vm_apply_hook, "vm-apply-hook", 0, 0, 0, |
1274 | (void), | |
17e90c5e | 1275 | "") |
c45d4d77 | 1276 | #define FUNC_NAME s_scm_vm_apply_hook |
a98cef7e | 1277 | { |
c45d4d77 | 1278 | VM_DEFINE_HOOK (SCM_VM_APPLY_HOOK); |
a98cef7e KN |
1279 | } |
1280 | #undef FUNC_NAME | |
1281 | ||
972275ee AW |
1282 | SCM_DEFINE (scm_vm_push_continuation_hook, "vm-push-continuation-hook", 0, 0, 0, |
1283 | (void), | |
17e90c5e | 1284 | "") |
c45d4d77 | 1285 | #define FUNC_NAME s_scm_vm_push_continuation_hook |
a98cef7e | 1286 | { |
c45d4d77 | 1287 | VM_DEFINE_HOOK (SCM_VM_PUSH_CONTINUATION_HOOK); |
a98cef7e KN |
1288 | } |
1289 | #undef FUNC_NAME | |
1290 | ||
972275ee AW |
1291 | SCM_DEFINE (scm_vm_pop_continuation_hook, "vm-pop-continuation-hook", 0, 0, 0, |
1292 | (void), | |
17e90c5e | 1293 | "") |
c45d4d77 | 1294 | #define FUNC_NAME s_scm_vm_pop_continuation_hook |
a98cef7e | 1295 | { |
c45d4d77 | 1296 | VM_DEFINE_HOOK (SCM_VM_POP_CONTINUATION_HOOK); |
a98cef7e KN |
1297 | } |
1298 | #undef FUNC_NAME | |
1299 | ||
972275ee AW |
1300 | SCM_DEFINE (scm_vm_next_hook, "vm-next-hook", 0, 0, 0, |
1301 | (void), | |
17e90c5e | 1302 | "") |
c45d4d77 | 1303 | #define FUNC_NAME s_scm_vm_next_hook |
a98cef7e | 1304 | { |
c45d4d77 | 1305 | VM_DEFINE_HOOK (SCM_VM_NEXT_HOOK); |
a98cef7e KN |
1306 | } |
1307 | #undef FUNC_NAME | |
f3120251 | 1308 | |
972275ee AW |
1309 | SCM_DEFINE (scm_vm_abort_continuation_hook, "vm-abort-continuation-hook", 0, 0, 0, |
1310 | (void), | |
f3120251 AW |
1311 | "") |
1312 | #define FUNC_NAME s_scm_vm_abort_continuation_hook | |
1313 | { | |
1314 | VM_DEFINE_HOOK (SCM_VM_ABORT_CONTINUATION_HOOK); | |
1315 | } | |
1316 | #undef FUNC_NAME | |
1317 | ||
972275ee AW |
1318 | SCM_DEFINE (scm_vm_trace_level, "vm-trace-level", 0, 0, 0, |
1319 | (void), | |
17e90c5e | 1320 | "") |
7656f194 | 1321 | #define FUNC_NAME s_scm_vm_trace_level |
a98cef7e | 1322 | { |
e7f9abab | 1323 | return scm_from_int (scm_the_vm ()->trace_level); |
7656f194 AW |
1324 | } |
1325 | #undef FUNC_NAME | |
1326 | ||
972275ee AW |
1327 | SCM_DEFINE (scm_set_vm_trace_level_x, "set-vm-trace-level!", 1, 0, 0, |
1328 | (SCM level), | |
7656f194 AW |
1329 | "") |
1330 | #define FUNC_NAME s_scm_set_vm_trace_level_x | |
1331 | { | |
e7f9abab | 1332 | scm_the_vm ()->trace_level = scm_to_int (level); |
7656f194 | 1333 | return SCM_UNSPECIFIED; |
a98cef7e KN |
1334 | } |
1335 | #undef FUNC_NAME | |
1336 | ||
1337 | \f | |
ea9f4f4b AW |
1338 | /* |
1339 | * VM engines | |
1340 | */ | |
1341 | ||
1342 | static int | |
1343 | symbol_to_vm_engine (SCM engine, const char *FUNC_NAME) | |
1344 | { | |
1345 | if (scm_is_eq (engine, sym_regular)) | |
1346 | return SCM_VM_REGULAR_ENGINE; | |
1347 | else if (scm_is_eq (engine, sym_debug)) | |
1348 | return SCM_VM_DEBUG_ENGINE; | |
1349 | else | |
1350 | SCM_MISC_ERROR ("Unknown VM engine: ~a", scm_list_1 (engine)); | |
1351 | } | |
1352 | ||
1353 | static SCM | |
1354 | vm_engine_to_symbol (int engine, const char *FUNC_NAME) | |
1355 | { | |
1356 | switch (engine) | |
1357 | { | |
1358 | case SCM_VM_REGULAR_ENGINE: | |
1359 | return sym_regular; | |
1360 | case SCM_VM_DEBUG_ENGINE: | |
1361 | return sym_debug; | |
1362 | default: | |
1363 | /* ? */ | |
1364 | SCM_MISC_ERROR ("Unknown VM engine: ~a", | |
1365 | scm_list_1 (scm_from_int (engine))); | |
1366 | } | |
1367 | } | |
1368 | ||
972275ee AW |
1369 | SCM_DEFINE (scm_vm_engine, "vm-engine", 0, 0, 0, |
1370 | (void), | |
ea9f4f4b AW |
1371 | "") |
1372 | #define FUNC_NAME s_scm_vm_engine | |
1373 | { | |
e7f9abab | 1374 | return vm_engine_to_symbol (scm_the_vm ()->engine, FUNC_NAME); |
ea9f4f4b AW |
1375 | } |
1376 | #undef FUNC_NAME | |
1377 | ||
1378 | void | |
972275ee | 1379 | scm_c_set_vm_engine_x (int engine) |
ea9f4f4b AW |
1380 | #define FUNC_NAME "set-vm-engine!" |
1381 | { | |
ea9f4f4b AW |
1382 | if (engine < 0 || engine >= SCM_VM_NUM_ENGINES) |
1383 | SCM_MISC_ERROR ("Unknown VM engine: ~a", | |
1384 | scm_list_1 (scm_from_int (engine))); | |
1385 | ||
e7f9abab | 1386 | scm_the_vm ()->engine = engine; |
ea9f4f4b AW |
1387 | } |
1388 | #undef FUNC_NAME | |
1389 | ||
972275ee AW |
1390 | SCM_DEFINE (scm_set_vm_engine_x, "set-vm-engine!", 1, 0, 0, |
1391 | (SCM engine), | |
ea9f4f4b AW |
1392 | "") |
1393 | #define FUNC_NAME s_scm_set_vm_engine_x | |
1394 | { | |
972275ee | 1395 | scm_c_set_vm_engine_x (symbol_to_vm_engine (engine, FUNC_NAME)); |
ea9f4f4b AW |
1396 | return SCM_UNSPECIFIED; |
1397 | } | |
1398 | #undef FUNC_NAME | |
1399 | ||
1400 | void | |
1401 | scm_c_set_default_vm_engine_x (int engine) | |
1402 | #define FUNC_NAME "set-default-vm-engine!" | |
1403 | { | |
1404 | if (engine < 0 || engine >= SCM_VM_NUM_ENGINES) | |
1405 | SCM_MISC_ERROR ("Unknown VM engine: ~a", | |
1406 | scm_list_1 (scm_from_int (engine))); | |
1407 | ||
1408 | vm_default_engine = engine; | |
1409 | } | |
1410 | #undef FUNC_NAME | |
1411 | ||
1412 | SCM_DEFINE (scm_set_default_vm_engine_x, "set-default-vm-engine!", 1, 0, 0, | |
1413 | (SCM engine), | |
1414 | "") | |
1415 | #define FUNC_NAME s_scm_set_default_vm_engine_x | |
1416 | { | |
1417 | scm_c_set_default_vm_engine_x (symbol_to_vm_engine (engine, FUNC_NAME)); | |
1418 | return SCM_UNSPECIFIED; | |
1419 | } | |
1420 | #undef FUNC_NAME | |
1421 | ||
972275ee AW |
1422 | /* FIXME: This function makes no sense, but we keep it to make sure we |
1423 | have a way of switching to the debug or regular VM. */ | |
1424 | SCM_DEFINE (scm_call_with_vm, "call-with-vm", 1, 0, 1, | |
1425 | (SCM proc, SCM args), | |
ea9f4f4b | 1426 | "Apply @var{proc} to @var{args} in a dynamic extent in which\n" |
972275ee | 1427 | "@var{vm} is the current VM.") |
ea9f4f4b AW |
1428 | #define FUNC_NAME s_scm_call_with_vm |
1429 | { | |
972275ee | 1430 | return scm_apply_0 (proc, args); |
ea9f4f4b AW |
1431 | } |
1432 | #undef FUNC_NAME | |
1433 | ||
f764e259 AW |
1434 | SCM_DEFINE (scm_call_with_stack_overflow_handler, |
1435 | "call-with-stack-overflow-handler", 3, 0, 0, | |
1436 | (SCM limit, SCM thunk, SCM handler), | |
1437 | "Call @var{thunk} in an environment in which the stack limit has\n" | |
1438 | "been reduced to @var{limit} additional words. If the limit is\n" | |
1439 | "reached, @var{handler} (a thunk) will be invoked in the dynamic\n" | |
1440 | "environment of the error. For the extent of the call to\n" | |
1441 | "@var{handler}, the stack limit and handler are restored to the\n" | |
1442 | "values that were in place when\n" | |
1443 | "@code{call-with-stack-overflow-handler} was called.") | |
1444 | #define FUNC_NAME s_scm_call_with_stack_overflow_handler | |
1445 | { | |
1446 | struct scm_vm *vp; | |
1447 | scm_t_ptrdiff c_limit, stack_size; | |
1448 | struct overflow_handler_data data; | |
1449 | SCM new_limit, ret; | |
1450 | ||
1451 | vp = scm_the_vm (); | |
1452 | stack_size = vp->sp - vp->stack_base; | |
1453 | ||
1454 | c_limit = scm_to_ptrdiff_t (limit); | |
1455 | if (c_limit <= 0) | |
1456 | scm_out_of_range (FUNC_NAME, limit); | |
1457 | ||
1458 | new_limit = scm_sum (scm_from_ptrdiff_t (stack_size), limit); | |
1459 | if (scm_is_pair (vp->overflow_handler_stack)) | |
1460 | new_limit = scm_min (new_limit, scm_caar (vp->overflow_handler_stack)); | |
1461 | ||
1462 | /* Hacky check that the current stack depth plus the limit is within | |
1463 | the range of a ptrdiff_t. */ | |
1464 | scm_to_ptrdiff_t (new_limit); | |
1465 | ||
1466 | data.vp = vp; | |
1467 | data.overflow_handler_stack = | |
1468 | scm_acons (limit, handler, vp->overflow_handler_stack); | |
1469 | ||
1470 | scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE); | |
1471 | ||
1472 | scm_dynwind_rewind_handler (wind_overflow_handler, &data, | |
1473 | SCM_F_WIND_EXPLICITLY); | |
1474 | scm_dynwind_unwind_handler (unwind_overflow_handler, &data, | |
1475 | SCM_F_WIND_EXPLICITLY); | |
1476 | ||
1477 | /* Reset vp->sp_max_since_gc so that the VM checks actually | |
1478 | trigger. */ | |
1479 | return_unused_stack_to_os (vp); | |
1480 | ||
1481 | ret = scm_call_0 (thunk); | |
1482 | ||
1483 | scm_dynwind_end (); | |
1484 | ||
1485 | return ret; | |
1486 | } | |
1487 | #undef FUNC_NAME | |
1488 | ||
ea9f4f4b | 1489 | \f |
a98cef7e | 1490 | /* |
17e90c5e | 1491 | * Initialize |
a98cef7e KN |
1492 | */ |
1493 | ||
55ee3607 AW |
1494 | SCM |
1495 | scm_load_compiled_with_vm (SCM file) | |
07e56b27 | 1496 | { |
55ee3607 | 1497 | return scm_call_0 (scm_load_thunk_from_file (file)); |
07e56b27 AW |
1498 | } |
1499 | ||
67b699cc | 1500 | |
9f309e2c AW |
1501 | void |
1502 | scm_init_vm_builtin_properties (void) | |
1503 | { | |
1504 | /* FIXME: Seems hacky to do this here, but oh well :/ */ | |
1505 | scm_sym_apply = scm_from_utf8_symbol ("apply"); | |
1506 | scm_sym_values = scm_from_utf8_symbol ("values"); | |
1507 | scm_sym_abort_to_prompt = scm_from_utf8_symbol ("abort-to-prompt"); | |
1508 | scm_sym_call_with_values = scm_from_utf8_symbol ("call-with-values"); | |
1509 | scm_sym_call_with_current_continuation = | |
1510 | scm_from_utf8_symbol ("call-with-current-continuation"); | |
1511 | ||
1512 | #define INIT_BUILTIN(builtin, BUILTIN, req, opt, rest) \ | |
1513 | scm_set_procedure_property_x (vm_builtin_##builtin, scm_sym_name, \ | |
1514 | scm_sym_##builtin); \ | |
1515 | scm_set_procedure_minimum_arity_x (vm_builtin_##builtin, \ | |
1516 | SCM_I_MAKINUM (req), \ | |
1517 | SCM_I_MAKINUM (opt), \ | |
1518 | scm_from_bool (rest)); | |
1519 | FOR_EACH_VM_BUILTIN (INIT_BUILTIN); | |
1520 | #undef INIT_BUILTIN | |
1521 | } | |
1522 | ||
17e90c5e | 1523 | void |
07e56b27 | 1524 | scm_bootstrap_vm (void) |
17e90c5e | 1525 | { |
44602b08 AW |
1526 | scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION, |
1527 | "scm_init_vm", | |
60ae5ca2 | 1528 | (scm_t_extension_init_func)scm_init_vm, NULL); |
486013d6 AW |
1529 | scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION, |
1530 | "scm_init_vm_builtins", | |
1531 | (scm_t_extension_init_func)scm_init_vm_builtins, | |
1532 | NULL); | |
60ae5ca2 | 1533 | |
7dba1c2f AW |
1534 | page_size = getpagesize (); |
1535 | /* page_size should be a power of two. */ | |
1536 | if (page_size & (page_size - 1)) | |
1537 | abort (); | |
1538 | ||
4a655e50 AW |
1539 | sym_vm_run = scm_from_latin1_symbol ("vm-run"); |
1540 | sym_vm_error = scm_from_latin1_symbol ("vm-error"); | |
1541 | sym_keyword_argument_error = scm_from_latin1_symbol ("keyword-argument-error"); | |
1542 | sym_regular = scm_from_latin1_symbol ("regular"); | |
1543 | sym_debug = scm_from_latin1_symbol ("debug"); | |
0404c97d | 1544 | |
ef6b7f71 AW |
1545 | vm_boot_continuation = scm_i_make_program (vm_boot_continuation_code); |
1546 | SCM_SET_CELL_WORD_0 (vm_boot_continuation, | |
1547 | (SCM_CELL_WORD_0 (vm_boot_continuation) | |
73c3db66 | 1548 | | SCM_F_PROGRAM_IS_BOOT)); |
9f309e2c AW |
1549 | |
1550 | #define DEFINE_BUILTIN(builtin, BUILTIN, req, opt, rest) \ | |
80797145 | 1551 | vm_builtin_##builtin = scm_i_make_program (vm_builtin_##builtin##_code); |
9f309e2c AW |
1552 | FOR_EACH_VM_BUILTIN (DEFINE_BUILTIN); |
1553 | #undef DEFINE_BUILTIN | |
07e56b27 AW |
1554 | } |
1555 | ||
1556 | void | |
1557 | scm_init_vm (void) | |
1558 | { | |
17e90c5e | 1559 | #ifndef SCM_MAGIC_SNARFER |
aeeff258 | 1560 | #include "libguile/vm.x" |
17e90c5e | 1561 | #endif |
a98cef7e | 1562 | } |
17e90c5e KN |
1563 | |
1564 | /* | |
1565 | Local Variables: | |
1566 | c-file-style: "gnu" | |
1567 | End: | |
1568 | */ |