ca074056a93a9bee4873b0af94f8a37408eadf49
[bpt/guile.git] / libguile / vm.c
1 /* Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc.
2 *
3 * This library is free software; you can redistribute it and/or
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.
7 *
8 * This library is distributed in the hope that it will be useful, but
9 * WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
11 * Lesser General Public License for more details.
12 *
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
15 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
16 * 02110-1301 USA
17 */
18
19 #if HAVE_CONFIG_H
20 # include <config.h>
21 #endif
22
23 #include <stdlib.h>
24 #include <alloca.h>
25 #include <string.h>
26
27 #include "libguile/bdw-gc.h"
28 #include <gc/gc_mark.h>
29
30 #include "_scm.h"
31 #include "control.h"
32 #include "frames.h"
33 #include "instructions.h"
34 #include "objcodes.h"
35 #include "programs.h"
36 #include "vm.h"
37
38 /* I sometimes use this for debugging. */
39 #define vm_puts(OBJ) \
40 { \
41 scm_display (OBJ, scm_current_error_port ()); \
42 scm_newline (scm_current_error_port ()); \
43 }
44
45 /* The VM has a number of internal assertions that shouldn't normally be
46 necessary, but might be if you think you found a bug in the VM. */
47 #define VM_ENABLE_ASSERTIONS
48
49 /* We can add a mode that ensures that all stack items above the stack pointer
50 are NULL. This is useful for checking the internal consistency of the VM's
51 assumptions and its operators, but isn't necessary for normal operation. It
52 will ensure that assertions are enabled. Slows down the VM by about 30%. */
53 /* NB! If you enable this, search for NULLING in throw.c */
54 /* #define VM_ENABLE_STACK_NULLING */
55
56 /* #define VM_ENABLE_PARANOID_ASSERTIONS */
57
58 #if defined (VM_ENABLE_STACK_NULLING) && !defined (VM_ENABLE_ASSERTIONS)
59 #define VM_ENABLE_ASSERTIONS
60 #endif
61
62 /* When defined, arrange so that the GC doesn't scan the VM stack beyond its
63 current SP. This should help avoid excess data retention. See
64 http://thread.gmane.org/gmane.comp.programming.garbage-collection.boehmgc/3001
65 for a discussion. */
66 #define VM_ENABLE_PRECISE_STACK_GC_SCAN
67
68
69 \f
70 /*
71 * VM Continuation
72 */
73
74 void
75 scm_i_vm_cont_print (SCM x, SCM port, scm_print_state *pstate)
76 {
77 scm_puts ("#<vm-continuation ", port);
78 scm_uintprint (SCM_UNPACK (x), 16, port);
79 scm_puts (">", port);
80 }
81
82 /* In theory, a number of vm instances can be active in the call trace, and we
83 only want to reify the continuations of those in the current continuation
84 root. I don't see a nice way to do this -- ideally it would involve dynwinds,
85 and previous values of the *the-vm* fluid within the current continuation
86 root. But we don't have access to continuation roots in the dynwind stack.
87 So, just punt for now, we just capture the continuation for the current VM.
88
89 While I'm on the topic, ideally we could avoid copying the C stack if the
90 continuation root is inside VM code, and call/cc was invoked within that same
91 call to vm_run; but that's currently not implemented.
92 */
93 SCM
94 scm_i_vm_capture_stack (SCM *stack_base, SCM *fp, SCM *sp, scm_t_uint8 *ra,
95 scm_t_uint8 *mvra, scm_t_uint32 flags)
96 {
97 struct scm_vm_cont *p;
98
99 p = scm_gc_malloc (sizeof (*p), "capture_vm_cont");
100 p->stack_size = sp - stack_base + 1;
101 p->stack_base = scm_gc_malloc (p->stack_size * sizeof (SCM),
102 "capture_vm_cont");
103 #if defined(VM_ENABLE_STACK_NULLING) && 0
104 /* Tail continuations leave their frame on the stack for subsequent
105 application, but don't capture the frame -- so there are some elements on
106 the stack then, and this check doesn't work, so disable it for now. */
107 if (sp >= vp->stack_base)
108 if (!vp->sp[0] || vp->sp[1])
109 abort ();
110 memset (p->stack_base, 0, p->stack_size * sizeof (SCM));
111 #endif
112 p->ra = ra;
113 p->mvra = mvra;
114 p->sp = sp;
115 p->fp = fp;
116 memcpy (p->stack_base, stack_base, (sp + 1 - stack_base) * sizeof (SCM));
117 p->reloc = p->stack_base - stack_base;
118 p->flags = flags;
119 return scm_cell (scm_tc7_vm_cont, (scm_t_bits)p);
120 }
121
122 static void
123 vm_return_to_continuation (SCM vm, SCM cont, size_t n, SCM *argv)
124 {
125 struct scm_vm *vp;
126 struct scm_vm_cont *cp;
127 SCM *argv_copy;
128
129 argv_copy = alloca (n * sizeof(SCM));
130 memcpy (argv_copy, argv, n * sizeof(SCM));
131
132 vp = SCM_VM_DATA (vm);
133 cp = SCM_VM_CONT_DATA (cont);
134
135 if (n == 0 && !cp->mvra)
136 scm_misc_error (NULL, "Too few values returned to continuation",
137 SCM_EOL);
138
139 if (vp->stack_size < cp->stack_size + n + 1)
140 scm_misc_error ("vm-engine", "not enough space to reinstate continuation",
141 scm_list_2 (vm, cont));
142
143 #ifdef VM_ENABLE_STACK_NULLING
144 {
145 scm_t_ptrdiff nzero = (vp->sp - cp->sp);
146 if (nzero > 0)
147 memset (vp->stack_base + cp->stack_size, 0, nzero * sizeof (SCM));
148 /* actually nzero should always be negative, because vm_reset_stack will
149 unwind the stack to some point *below* this continuation */
150 }
151 #endif
152 vp->sp = cp->sp;
153 vp->fp = cp->fp;
154 memcpy (vp->stack_base, cp->stack_base, cp->stack_size * sizeof (SCM));
155
156 if (n == 1 || !cp->mvra)
157 {
158 vp->ip = cp->ra;
159 vp->sp++;
160 *vp->sp = argv_copy[0];
161 }
162 else
163 {
164 size_t i;
165 for (i = 0; i < n; i++)
166 {
167 vp->sp++;
168 *vp->sp = argv_copy[i];
169 }
170 vp->sp++;
171 *vp->sp = scm_from_size_t (n);
172 vp->ip = cp->mvra;
173 }
174 }
175
176 SCM
177 scm_i_vm_capture_continuation (SCM vm)
178 {
179 struct scm_vm *vp = SCM_VM_DATA (vm);
180 return scm_i_vm_capture_stack (vp->stack_base, vp->fp, vp->sp, vp->ip, NULL, 0);
181 }
182
183 static void
184 vm_dispatch_hook (SCM vm, int hook_num)
185 {
186 struct scm_vm *vp;
187 SCM hook;
188 SCM frame;
189
190 vp = SCM_VM_DATA (vm);
191 hook = vp->hooks[hook_num];
192
193 if (SCM_LIKELY (scm_is_false (hook))
194 || scm_is_null (SCM_HOOK_PROCEDURES (hook)))
195 return;
196
197 vp->trace_level--;
198 frame = scm_c_make_frame (vm, vp->fp, vp->sp, vp->ip, 0);
199 scm_c_run_hookn (hook, &frame, 1);
200 vp->trace_level++;
201 }
202
203 static void vm_abort (SCM vm, size_t n, scm_t_int64 cookie) SCM_NORETURN;
204 static void
205 vm_abort (SCM vm, size_t n, scm_t_int64 vm_cookie)
206 {
207 size_t i;
208 ssize_t tail_len;
209 SCM tag, tail, *argv;
210
211 /* FIXME: VM_ENABLE_STACK_NULLING */
212 tail = *(SCM_VM_DATA (vm)->sp--);
213 /* NULLSTACK (1) */
214 tail_len = scm_ilength (tail);
215 if (tail_len < 0)
216 scm_misc_error ("vm-engine", "tail values to abort should be a list",
217 scm_list_1 (tail));
218
219 tag = SCM_VM_DATA (vm)->sp[-n];
220 argv = alloca ((n + tail_len) * sizeof (SCM));
221 for (i = 0; i < n; i++)
222 argv[i] = SCM_VM_DATA (vm)->sp[-(n-1-i)];
223 for (; i < n + tail_len; i++, tail = scm_cdr (tail))
224 argv[i] = scm_car (tail);
225 /* NULLSTACK (n + 1) */
226 SCM_VM_DATA (vm)->sp -= n + 1;
227
228 scm_c_abort (vm, tag, n + tail_len, argv, vm_cookie);
229 }
230
231 static void
232 vm_reinstate_partial_continuation (SCM vm, SCM cont, SCM intwinds,
233 size_t n, SCM *argv, scm_t_int64 vm_cookie)
234 {
235 struct scm_vm *vp;
236 struct scm_vm_cont *cp;
237 SCM *argv_copy, *base;
238 size_t i;
239
240 argv_copy = alloca (n * sizeof(SCM));
241 memcpy (argv_copy, argv, n * sizeof(SCM));
242
243 vp = SCM_VM_DATA (vm);
244 cp = SCM_VM_CONT_DATA (cont);
245 base = SCM_FRAME_UPPER_ADDRESS (vp->fp) + 1;
246
247 #define RELOC(scm_p) (scm_p + cp->reloc + (base - cp->stack_base))
248
249 if ((base - vp->stack_base) + cp->stack_size + n + 1 > vp->stack_size)
250 scm_misc_error ("vm-engine",
251 "not enough space to instate partial continuation",
252 scm_list_2 (vm, cont));
253
254 memcpy (base, cp->stack_base, cp->stack_size * sizeof (SCM));
255
256 /* now relocate frame pointers */
257 {
258 SCM *fp;
259 for (fp = RELOC (cp->fp);
260 SCM_FRAME_LOWER_ADDRESS (fp) > base;
261 fp = SCM_FRAME_DYNAMIC_LINK (fp))
262 SCM_FRAME_SET_DYNAMIC_LINK (fp, RELOC (SCM_FRAME_DYNAMIC_LINK (fp)));
263 }
264
265 vp->sp = base - 1 + cp->stack_size;
266 vp->fp = RELOC (cp->fp);
267 vp->ip = cp->mvra;
268
269 /* now push args. ip is in a MV context. */
270 for (i = 0; i < n; i++)
271 {
272 vp->sp++;
273 *vp->sp = argv_copy[i];
274 }
275 vp->sp++;
276 *vp->sp = scm_from_size_t (n);
277
278 /* Finally, rewind the dynamic state.
279
280 We have to treat prompts specially, because we could be rewinding the
281 dynamic state from a different thread, or just a different position on the
282 C and/or VM stack -- so we need to reset the jump buffers so that an abort
283 comes back here, with appropriately adjusted sp and fp registers. */
284 {
285 long delta = 0;
286 SCM newwinds = scm_i_dynwinds ();
287 for (; scm_is_pair (intwinds); intwinds = scm_cdr (intwinds), delta--)
288 {
289 SCM x = scm_car (intwinds);
290 if (SCM_PROMPT_P (x))
291 /* the jmpbuf will be reset by our caller */
292 x = scm_c_make_prompt (SCM_PROMPT_TAG (x),
293 RELOC (SCM_PROMPT_REGISTERS (x)->fp),
294 RELOC (SCM_PROMPT_REGISTERS (x)->sp),
295 SCM_PROMPT_REGISTERS (x)->ip,
296 SCM_PROMPT_ESCAPE_P (x),
297 vm_cookie,
298 newwinds);
299 newwinds = scm_cons (x, newwinds);
300 }
301 scm_dowinds (newwinds, delta);
302 }
303 #undef RELOC
304 }
305
306 \f
307 /*
308 * VM Internal functions
309 */
310
311 /* Unfortunately we can't snarf these: snarfed things are only loaded up from
312 (system vm vm), which might not be loaded before an error happens. */
313 static SCM sym_vm_run, sym_vm_error, sym_keyword_argument_error, sym_debug;
314
315 void
316 scm_i_vm_print (SCM x, SCM port, scm_print_state *pstate)
317 {
318 const struct scm_vm *vm;
319
320 vm = SCM_VM_DATA (x);
321
322 scm_puts ("#<vm ", port);
323 switch (vm->engine)
324 {
325 case SCM_VM_REGULAR_ENGINE:
326 scm_puts ("regular-engine ", port);
327 break;
328
329 case SCM_VM_DEBUG_ENGINE:
330 scm_puts ("debug-engine ", port);
331 break;
332
333 default:
334 scm_puts ("unknown-engine ", port);
335 }
336 scm_uintprint (SCM_UNPACK (x), 16, port);
337 scm_puts (">", port);
338 }
339
340 static SCM
341 really_make_boot_program (long nargs)
342 {
343 SCM u8vec;
344 scm_t_uint8 text[] = { scm_op_mv_call, 0, 0, 0, 1,
345 scm_op_make_int8_1, scm_op_halt };
346 struct scm_objcode *bp;
347 SCM ret;
348
349 if (SCM_UNLIKELY (nargs > 255 || nargs < 0))
350 scm_misc_error ("vm-engine", "too many args when making boot procedure",
351 scm_list_1 (scm_from_long (nargs)));
352
353 text[1] = (scm_t_uint8)nargs;
354
355 bp = scm_malloc (sizeof (struct scm_objcode) + sizeof (text));
356 memcpy (SCM_C_OBJCODE_BASE (bp), text, sizeof (text));
357 bp->len = sizeof(text);
358 bp->metalen = 0;
359
360 u8vec = scm_c_take_bytevector ((scm_t_int8*)bp,
361 sizeof (struct scm_objcode) + sizeof (text));
362 ret = scm_make_program (scm_bytecode_to_objcode (u8vec),
363 SCM_BOOL_F, SCM_BOOL_F);
364 SCM_SET_CELL_WORD_0 (ret, SCM_CELL_WORD_0 (ret) | SCM_F_PROGRAM_IS_BOOT);
365
366 return ret;
367 }
368 #define NUM_BOOT_PROGS 8
369 static SCM
370 vm_make_boot_program (long nargs)
371 {
372 static SCM programs[NUM_BOOT_PROGS] = { 0, };
373
374 if (SCM_UNLIKELY (!programs[0]))
375 {
376 int i;
377 for (i = 0; i < NUM_BOOT_PROGS; i++)
378 programs[i] = really_make_boot_program (i);
379 }
380
381 if (SCM_LIKELY (nargs < NUM_BOOT_PROGS))
382 return programs[nargs];
383 else
384 return really_make_boot_program (nargs);
385 }
386
387 \f
388 /*
389 * VM
390 */
391
392 static SCM
393 resolve_variable (SCM what, SCM program_module)
394 {
395 if (SCM_LIKELY (scm_is_symbol (what)))
396 {
397 if (SCM_LIKELY (scm_module_system_booted_p
398 && scm_is_true (program_module)))
399 /* might longjmp */
400 return scm_module_lookup (program_module, what);
401 else
402 {
403 SCM v = scm_sym2var (what, SCM_BOOL_F, SCM_BOOL_F);
404 if (scm_is_false (v))
405 scm_misc_error (NULL, "unbound variable: ~S", scm_list_1 (what));
406 else
407 return v;
408 }
409 }
410 else
411 {
412 SCM mod;
413 /* compilation of @ or @@
414 `what' is a three-element list: (MODNAME SYM INTERFACE?)
415 INTERFACE? is #t if we compiled @ or #f if we compiled @@
416 */
417 mod = scm_resolve_module (SCM_CAR (what));
418 if (scm_is_true (SCM_CADDR (what)))
419 mod = scm_module_public_interface (mod);
420 if (scm_is_false (mod))
421 scm_misc_error (NULL, "no such module: ~S",
422 scm_list_1 (SCM_CAR (what)));
423 /* might longjmp */
424 return scm_module_lookup (mod, SCM_CADR (what));
425 }
426 }
427
428 #define VM_DEFAULT_STACK_SIZE (64 * 1024)
429
430 #define VM_NAME vm_regular_engine
431 #define FUNC_NAME "vm-regular-engine"
432 #define VM_ENGINE SCM_VM_REGULAR_ENGINE
433 #include "vm-engine.c"
434 #undef VM_NAME
435 #undef FUNC_NAME
436 #undef VM_ENGINE
437
438 #define VM_NAME vm_debug_engine
439 #define FUNC_NAME "vm-debug-engine"
440 #define VM_ENGINE SCM_VM_DEBUG_ENGINE
441 #include "vm-engine.c"
442 #undef VM_NAME
443 #undef FUNC_NAME
444 #undef VM_ENGINE
445
446 static const scm_t_vm_engine vm_engines[] =
447 { vm_regular_engine, vm_debug_engine };
448
449 #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
450
451 /* The GC "kind" for the VM stack. */
452 static int vm_stack_gc_kind;
453
454 #endif
455
456 static SCM
457 make_vm (void)
458 #define FUNC_NAME "make_vm"
459 {
460 int i;
461 struct scm_vm *vp;
462
463 vp = scm_gc_malloc (sizeof (struct scm_vm), "vm");
464
465 vp->stack_size = VM_DEFAULT_STACK_SIZE;
466
467 #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
468 vp->stack_base = (SCM *)
469 GC_generic_malloc (vp->stack_size * sizeof (SCM), vm_stack_gc_kind);
470
471 /* Keep a pointer to VP so that `vm_stack_mark ()' can know what the stack
472 top is. */
473 *vp->stack_base = PTR2SCM (vp);
474 vp->stack_base++;
475 vp->stack_size--;
476 #else
477 vp->stack_base = scm_gc_malloc (vp->stack_size * sizeof (SCM),
478 "stack-base");
479 #endif
480
481 #ifdef VM_ENABLE_STACK_NULLING
482 memset (vp->stack_base, 0, vp->stack_size * sizeof (SCM));
483 #endif
484 vp->stack_limit = vp->stack_base + vp->stack_size;
485 vp->ip = NULL;
486 vp->sp = vp->stack_base - 1;
487 vp->fp = NULL;
488 vp->engine = SCM_VM_DEBUG_ENGINE;
489 vp->options = SCM_EOL;
490 vp->trace_level = 0;
491 for (i = 0; i < SCM_VM_NUM_HOOKS; i++)
492 vp->hooks[i] = SCM_BOOL_F;
493 vp->cookie = 0;
494 return scm_cell (scm_tc7_vm, (scm_t_bits)vp);
495 }
496 #undef FUNC_NAME
497
498 #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
499
500 /* Mark the VM stack region between its base and its current top. */
501 static struct GC_ms_entry *
502 vm_stack_mark (GC_word *addr, struct GC_ms_entry *mark_stack_ptr,
503 struct GC_ms_entry *mark_stack_limit, GC_word env)
504 {
505 GC_word *word;
506 const struct scm_vm *vm;
507
508 /* The first word of the VM stack should contain a pointer to the
509 corresponding VM. */
510 vm = * ((struct scm_vm **) addr);
511
512 if (vm == NULL
513 || (SCM *) addr != vm->stack_base - 1
514 || vm->stack_limit - vm->stack_base != vm->stack_size)
515 /* ADDR must be a pointer to a free-list element, which we must ignore
516 (see warning in <gc/gc_mark.h>). */
517 return mark_stack_ptr;
518
519 for (word = (GC_word *) vm->stack_base; word <= (GC_word *) vm->sp; word++)
520 mark_stack_ptr = GC_MARK_AND_PUSH ((* (GC_word **) word),
521 mark_stack_ptr, mark_stack_limit,
522 NULL);
523
524 return mark_stack_ptr;
525 }
526
527 #endif /* VM_ENABLE_PRECISE_STACK_GC_SCAN */
528
529
530 SCM
531 scm_c_vm_run (SCM vm, SCM program, SCM *argv, int nargs)
532 {
533 struct scm_vm *vp = SCM_VM_DATA (vm);
534 return vm_engines[vp->engine](vm, program, argv, nargs);
535 }
536
537 SCM_DEFINE (scm_vm_apply, "vm-apply", 3, 0, 0,
538 (SCM vm, SCM program, SCM args),
539 "")
540 #define FUNC_NAME s_scm_vm_apply
541 {
542 SCM *argv;
543 int i, nargs;
544
545 SCM_VALIDATE_VM (1, vm);
546 SCM_VALIDATE_PROC (2, program);
547
548 nargs = scm_ilength (args);
549 if (SCM_UNLIKELY (nargs < 0))
550 scm_wrong_type_arg_msg (FUNC_NAME, 3, args, "list");
551
552 argv = alloca(nargs * sizeof(SCM));
553 for (i = 0; i < nargs; i++)
554 {
555 argv[i] = SCM_CAR (args);
556 args = SCM_CDR (args);
557 }
558
559 return scm_c_vm_run (vm, program, argv, nargs);
560 }
561 #undef FUNC_NAME
562
563 /* Scheme interface */
564
565 SCM_DEFINE (scm_vm_version, "vm-version", 0, 0, 0,
566 (void),
567 "")
568 #define FUNC_NAME s_scm_vm_version
569 {
570 return scm_from_locale_string (PACKAGE_VERSION);
571 }
572 #undef FUNC_NAME
573
574 SCM_DEFINE (scm_the_vm, "the-vm", 0, 0, 0,
575 (void),
576 "")
577 #define FUNC_NAME s_scm_the_vm
578 {
579 scm_i_thread *t = SCM_I_CURRENT_THREAD;
580
581 if (SCM_UNLIKELY (scm_is_false ((t->vm))))
582 t->vm = make_vm ();
583
584 return t->vm;
585 }
586 #undef FUNC_NAME
587
588
589 SCM_DEFINE (scm_vm_p, "vm?", 1, 0, 0,
590 (SCM obj),
591 "")
592 #define FUNC_NAME s_scm_vm_p
593 {
594 return scm_from_bool (SCM_VM_P (obj));
595 }
596 #undef FUNC_NAME
597
598 SCM_DEFINE (scm_make_vm, "make-vm", 0, 0, 0,
599 (void),
600 "")
601 #define FUNC_NAME s_scm_make_vm,
602 {
603 return make_vm ();
604 }
605 #undef FUNC_NAME
606
607 SCM_DEFINE (scm_vm_ip, "vm:ip", 1, 0, 0,
608 (SCM vm),
609 "")
610 #define FUNC_NAME s_scm_vm_ip
611 {
612 SCM_VALIDATE_VM (1, vm);
613 return scm_from_ulong ((unsigned long) SCM_VM_DATA (vm)->ip);
614 }
615 #undef FUNC_NAME
616
617 SCM_DEFINE (scm_vm_sp, "vm:sp", 1, 0, 0,
618 (SCM vm),
619 "")
620 #define FUNC_NAME s_scm_vm_sp
621 {
622 SCM_VALIDATE_VM (1, vm);
623 return scm_from_ulong ((unsigned long) SCM_VM_DATA (vm)->sp);
624 }
625 #undef FUNC_NAME
626
627 SCM_DEFINE (scm_vm_fp, "vm:fp", 1, 0, 0,
628 (SCM vm),
629 "")
630 #define FUNC_NAME s_scm_vm_fp
631 {
632 SCM_VALIDATE_VM (1, vm);
633 return scm_from_ulong ((unsigned long) SCM_VM_DATA (vm)->fp);
634 }
635 #undef FUNC_NAME
636
637 #define VM_DEFINE_HOOK(n) \
638 { \
639 struct scm_vm *vp; \
640 SCM_VALIDATE_VM (1, vm); \
641 vp = SCM_VM_DATA (vm); \
642 if (scm_is_false (vp->hooks[n])) \
643 vp->hooks[n] = scm_make_hook (SCM_I_MAKINUM (1)); \
644 return vp->hooks[n]; \
645 }
646
647 SCM_DEFINE (scm_vm_boot_hook, "vm-boot-hook", 1, 0, 0,
648 (SCM vm),
649 "")
650 #define FUNC_NAME s_scm_vm_boot_hook
651 {
652 VM_DEFINE_HOOK (SCM_VM_BOOT_HOOK);
653 }
654 #undef FUNC_NAME
655
656 SCM_DEFINE (scm_vm_halt_hook, "vm-halt-hook", 1, 0, 0,
657 (SCM vm),
658 "")
659 #define FUNC_NAME s_scm_vm_halt_hook
660 {
661 VM_DEFINE_HOOK (SCM_VM_HALT_HOOK);
662 }
663 #undef FUNC_NAME
664
665 SCM_DEFINE (scm_vm_next_hook, "vm-next-hook", 1, 0, 0,
666 (SCM vm),
667 "")
668 #define FUNC_NAME s_scm_vm_next_hook
669 {
670 VM_DEFINE_HOOK (SCM_VM_NEXT_HOOK);
671 }
672 #undef FUNC_NAME
673
674 SCM_DEFINE (scm_vm_break_hook, "vm-break-hook", 1, 0, 0,
675 (SCM vm),
676 "")
677 #define FUNC_NAME s_scm_vm_break_hook
678 {
679 VM_DEFINE_HOOK (SCM_VM_BREAK_HOOK);
680 }
681 #undef FUNC_NAME
682
683 SCM_DEFINE (scm_vm_enter_hook, "vm-enter-hook", 1, 0, 0,
684 (SCM vm),
685 "")
686 #define FUNC_NAME s_scm_vm_enter_hook
687 {
688 VM_DEFINE_HOOK (SCM_VM_ENTER_HOOK);
689 }
690 #undef FUNC_NAME
691
692 SCM_DEFINE (scm_vm_apply_hook, "vm-apply-hook", 1, 0, 0,
693 (SCM vm),
694 "")
695 #define FUNC_NAME s_scm_vm_apply_hook
696 {
697 VM_DEFINE_HOOK (SCM_VM_APPLY_HOOK);
698 }
699 #undef FUNC_NAME
700
701 SCM_DEFINE (scm_vm_exit_hook, "vm-exit-hook", 1, 0, 0,
702 (SCM vm),
703 "")
704 #define FUNC_NAME s_scm_vm_exit_hook
705 {
706 VM_DEFINE_HOOK (SCM_VM_EXIT_HOOK);
707 }
708 #undef FUNC_NAME
709
710 SCM_DEFINE (scm_vm_return_hook, "vm-return-hook", 1, 0, 0,
711 (SCM vm),
712 "")
713 #define FUNC_NAME s_scm_vm_return_hook
714 {
715 VM_DEFINE_HOOK (SCM_VM_RETURN_HOOK);
716 }
717 #undef FUNC_NAME
718
719 SCM_DEFINE (scm_vm_option, "vm-option", 2, 0, 0,
720 (SCM vm, SCM key),
721 "")
722 #define FUNC_NAME s_scm_vm_option
723 {
724 SCM_VALIDATE_VM (1, vm);
725 return scm_assq_ref (SCM_VM_DATA (vm)->options, key);
726 }
727 #undef FUNC_NAME
728
729 SCM_DEFINE (scm_set_vm_option_x, "set-vm-option!", 3, 0, 0,
730 (SCM vm, SCM key, SCM val),
731 "")
732 #define FUNC_NAME s_scm_set_vm_option_x
733 {
734 SCM_VALIDATE_VM (1, vm);
735 SCM_VM_DATA (vm)->options
736 = scm_assq_set_x (SCM_VM_DATA (vm)->options, key, val);
737 return SCM_UNSPECIFIED;
738 }
739 #undef FUNC_NAME
740
741 SCM_DEFINE (scm_vm_trace_level, "vm-trace-level", 1, 0, 0,
742 (SCM vm),
743 "")
744 #define FUNC_NAME s_scm_vm_trace_level
745 {
746 SCM_VALIDATE_VM (1, vm);
747 return scm_from_int (SCM_VM_DATA (vm)->trace_level);
748 }
749 #undef FUNC_NAME
750
751 SCM_DEFINE (scm_set_vm_trace_level_x, "set-vm-trace-level!", 2, 0, 0,
752 (SCM vm, SCM level),
753 "")
754 #define FUNC_NAME s_scm_set_vm_trace_level_x
755 {
756 SCM_VALIDATE_VM (1, vm);
757 SCM_VM_DATA (vm)->trace_level = scm_to_int (level);
758 return SCM_UNSPECIFIED;
759 }
760 #undef FUNC_NAME
761
762 \f
763 /*
764 * Initialize
765 */
766
767 SCM scm_load_compiled_with_vm (SCM file)
768 {
769 SCM program = scm_make_program (scm_load_objcode (file),
770 SCM_BOOL_F, SCM_BOOL_F);
771
772 return scm_c_vm_run (scm_the_vm (), program, NULL, 0);
773 }
774
775 void
776 scm_bootstrap_vm (void)
777 {
778 scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
779 "scm_init_vm",
780 (scm_t_extension_init_func)scm_init_vm, NULL);
781
782 sym_vm_run = scm_from_locale_symbol ("vm-run");
783 sym_vm_error = scm_from_locale_symbol ("vm-error");
784 sym_keyword_argument_error = scm_from_locale_symbol ("keyword-argument-error");
785 sym_debug = scm_from_locale_symbol ("debug");
786
787 #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
788 vm_stack_gc_kind =
789 GC_new_kind (GC_new_free_list (),
790 GC_MAKE_PROC (GC_new_proc (vm_stack_mark), 0),
791 0, 1);
792
793 #endif
794 }
795
796 void
797 scm_init_vm (void)
798 {
799 #ifndef SCM_MAGIC_SNARFER
800 #include "libguile/vm.x"
801 #endif
802 }
803
804 /*
805 Local Variables:
806 c-file-style: "gnu"
807 End:
808 */