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 "lang.h" /* NULL_OR_NIL_P */
  37 #include "vm.h"
  38
  39 /* I sometimes use this for debugging. */
  40 #define vm_puts(OBJ)                            \
  41 {                                               \
  42   scm_display (OBJ, scm_current_error_port ()); \
  43   scm_newline (scm_current_error_port ());      \
  44 }
  45
  46 /* The VM has a number of internal assertions that shouldn't normally be
  47    necessary, but might be if you think you found a bug in the VM. */
  48 #define VM_ENABLE_ASSERTIONS
  49
  50 /* We can add a mode that ensures that all stack items above the stack pointer
  51    are NULL. This is useful for checking the internal consistency of the VM's
  52    assumptions and its operators, but isn't necessary for normal operation. It
  53    will ensure that assertions are enabled. Slows down the VM by about 30%. */
  54 /* NB! If you enable this, search for NULLING in throw.c */
  55 /* #define VM_ENABLE_STACK_NULLING */
  56
  57 /* #define VM_ENABLE_PARANOID_ASSERTIONS */
  58
  59 #if defined (VM_ENABLE_STACK_NULLING) && !defined (VM_ENABLE_ASSERTIONS)
  60 #define VM_ENABLE_ASSERTIONS
  61 #endif
  62
  63 /* When defined, arrange so that the GC doesn't scan the VM stack beyond its
  64    current SP.  This should help avoid excess data retention.  See
  65    http://thread.gmane.org/gmane.comp.programming.garbage-collection.boehmgc/3001
  66    for a discussion.  */
  67 #define VM_ENABLE_PRECISE_STACK_GC_SCAN
  68
  69
  70 \f
  71 /*
  72  * VM Continuation
  73  */
  74
  75 void
  76 scm_i_vm_cont_print (SCM x, SCM port, scm_print_state *pstate)
  77 {
  78   scm_puts ("#<vm-continuation ", port);
  79   scm_uintprint (SCM_UNPACK (x), 16, port);
  80   scm_puts (">", port);
  81 }
  82
  83 /* In theory, a number of vm instances can be active in the call trace, and we
  84    only want to reify the continuations of those in the current continuation
  85    root. I don't see a nice way to do this -- ideally it would involve dynwinds,
  86    and previous values of the *the-vm* fluid within the current continuation
  87    root. But we don't have access to continuation roots in the dynwind stack.
  88    So, just punt for now, we just capture the continuation for the current VM.
  89
  90    While I'm on the topic, ideally we could avoid copying the C stack if the
  91    continuation root is inside VM code, and call/cc was invoked within that same
  92    call to vm_run; but that's currently not implemented.
  93  */
  94 static SCM
  95 vm_capture_continuation (SCM *stack_base,
  96                          SCM *fp, SCM *sp, scm_t_uint8 *ra, scm_t_uint8 *mvra)
  97 {
  98   struct scm_vm_cont *p;
  99
 100   p = scm_gc_malloc (sizeof (*p), "capture_vm_cont");
 101   p->stack_size = sp - stack_base + 1;
 102   p->stack_base = scm_gc_malloc (p->stack_size * sizeof (SCM),
 103                                  "capture_vm_cont");
 104 #if defined(VM_ENABLE_STACK_NULLING) && 0
 105   /* Tail continuations leave their frame on the stack for subsequent
 106      application, but don't capture the frame -- so there are some elements on
 107      the stack then, and this check doesn't work, so disable it for now. */
 108   if (sp >= vp->stack_base)
 109     if (!vp->sp[0] || vp->sp[1])
 110       abort ();
 111   memset (p->stack_base, 0, p->stack_size * sizeof (SCM));
 112 #endif
 113   p->ra = ra;
 114   p->mvra = mvra;
 115   p->sp = sp;
 116   p->fp = fp;
 117   memcpy (p->stack_base, stack_base, (sp + 1 - stack_base) * sizeof (SCM));
 118   p->reloc = p->stack_base - stack_base;
 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     {
 141       /* puts ("FIXME: Need to expand"); */
 142       abort ();
 143     }
 144 #ifdef VM_ENABLE_STACK_NULLING
 145   {
 146     scm_t_ptrdiff nzero = (vp->sp - cp->sp);
 147     if (nzero > 0)
 148       memset (vp->stack_base + cp->stack_size, 0, nzero * sizeof (SCM));
 149     /* actually nzero should always be negative, because vm_reset_stack will
 150        unwind the stack to some point *below* this continuation */
 151   }
 152 #endif
 153   vp->sp = cp->sp;
 154   vp->fp = cp->fp;
 155   memcpy (vp->stack_base, cp->stack_base, cp->stack_size * sizeof (SCM));
 156
 157   if (n == 1 || !cp->mvra)
 158     {
 159       vp->ip = cp->ra;
 160       vp->sp++;
 161       *vp->sp = argv_copy[0];
 162     }
 163   else
 164     {
 165       size_t i;
 166       for (i = 0; i < n; i++)
 167         {
 168           vp->sp++;
 169           *vp->sp = argv_copy[i];
 170         }
 171       vp->sp++;
 172       *vp->sp = scm_from_size_t (n);
 173       vp->ip = cp->mvra;
 174     }
 175 }
 176
 177 SCM
 178 scm_i_vm_capture_continuation (SCM vm)
 179 {
 180   struct scm_vm *vp = SCM_VM_DATA (vm);
 181   return vm_capture_continuation (vp->stack_base, vp->fp, vp->sp, vp->ip, NULL);
 182 }
 183
 184 static void
 185 vm_dispatch_hook (SCM vm, int hook_num)
 186 {
 187   struct scm_vm *vp;
 188   SCM hook;
 189   SCM frame;
 190
 191   vp = SCM_VM_DATA (vm);
 192   hook = vp->hooks[hook_num];
 193
 194   if (SCM_LIKELY (scm_is_false (hook))
 195       || scm_is_null (SCM_HOOK_PROCEDURES (hook)))
 196     return;
 197
 198   vp->trace_level--;
 199   frame = scm_c_make_frame (vm, vp->fp, vp->sp, vp->ip, 0);
 200   scm_c_run_hookn (hook, &frame, 1);
 201   vp->trace_level++;
 202 }
 203
 204 \f
 205 /*
 206  * The dynamic stack
 207  */
 208 #define VM_SETJMP(jmpbuf) 0
 209
 210 static void vm_throw (SCM vm, SCM k, SCM args) SCM_NORETURN;
 211 static void
 212 vm_throw (SCM vm, SCM k, SCM args)
 213 {
 214   abort ();
 215 }
 216
 217 \f
 218 /*
 219  * VM Internal functions
 220  */
 221
 222 SCM_SYMBOL (sym_vm_run, "vm-run");
 223 SCM_SYMBOL (sym_vm_error, "vm-error");
 224 SCM_SYMBOL (sym_keyword_argument_error, "keyword-argument-error");
 225 SCM_SYMBOL (sym_debug, "debug");
 226
 227 void
 228 scm_i_vm_print (SCM x, SCM port, scm_print_state *pstate)
 229 {
 230   scm_puts ("#<vm ", port);
 231   scm_uintprint (SCM_UNPACK (x), 16, port);
 232   scm_puts (">", port);
 233 }
 234
 235 static SCM
 236 really_make_boot_program (long nargs)
 237 {
 238   SCM u8vec;
 239   scm_t_uint8 text[] = { scm_op_mv_call, 0, 0, 0, 1,
 240                          scm_op_make_int8_1, scm_op_halt };
 241   struct scm_objcode *bp;
 242   SCM ret;
 243
 244   if (SCM_UNLIKELY (nargs > 255 || nargs < 0))
 245     abort ();
 246   text[1] = (scm_t_uint8)nargs;
 247
 248   bp = scm_malloc (sizeof (struct scm_objcode) + sizeof (text));
 249   memcpy (SCM_C_OBJCODE_BASE (bp), text, sizeof (text));
 250   bp->len = sizeof(text);
 251   bp->metalen = 0;
 252
 253   u8vec = scm_c_take_bytevector ((scm_t_int8*)bp,
 254                                  sizeof (struct scm_objcode) + sizeof (text));
 255   ret = scm_make_program (scm_bytecode_to_objcode (u8vec),
 256                           SCM_BOOL_F, SCM_BOOL_F);
 257   SCM_SET_CELL_WORD_0 (ret, SCM_CELL_WORD_0 (ret) | SCM_F_PROGRAM_IS_BOOT);
 258
 259   return ret;
 260 }
 261 #define NUM_BOOT_PROGS 8
 262 static SCM
 263 vm_make_boot_program (long nargs)
 264 {
 265   static SCM programs[NUM_BOOT_PROGS] = { 0, };
 266
 267   if (SCM_UNLIKELY (!programs[0]))
 268     {
 269       int i;
 270       for (i = 0; i < NUM_BOOT_PROGS; i++)
 271         programs[i] = really_make_boot_program (i);
 272     }
 273
 274   if (SCM_LIKELY (nargs < NUM_BOOT_PROGS))
 275     return programs[nargs];
 276   else
 277     return really_make_boot_program (nargs);
 278 }
 279
 280 \f
 281 /*
 282  * VM
 283  */
 284
 285 static SCM
 286 resolve_variable (SCM what, SCM program_module)
 287 {
 288   if (SCM_LIKELY (scm_is_symbol (what)))
 289     {
 290       if (SCM_LIKELY (scm_module_system_booted_p
 291                       && scm_is_true (program_module)))
 292         /* might longjmp */
 293         return scm_module_lookup (program_module, what);
 294       else
 295         {
 296           SCM v = scm_sym2var (what, SCM_BOOL_F, SCM_BOOL_F);
 297           if (scm_is_false (v))
 298             scm_misc_error (NULL, "unbound variable: ~S", scm_list_1 (what));
 299           else
 300             return v;
 301         }
 302     }
 303   else
 304     {
 305       SCM mod;
 306       /* compilation of @ or @@
 307          `what' is a three-element list: (MODNAME SYM INTERFACE?)
 308          INTERFACE? is #t if we compiled @ or #f if we compiled @@
 309       */
 310       mod = scm_resolve_module (SCM_CAR (what));
 311       if (scm_is_true (SCM_CADDR (what)))
 312         mod = scm_module_public_interface (mod);
 313       if (scm_is_false (mod))
 314         scm_misc_error (NULL, "no such module: ~S",
 315                         scm_list_1 (SCM_CAR (what)));
 316       /* might longjmp */
 317       return scm_module_lookup (mod, SCM_CADR (what));
 318     }
 319 }
 320
 321 #define VM_DEFAULT_STACK_SIZE   (64 * 1024)
 322
 323 #define VM_NAME   vm_regular_engine
 324 #define FUNC_NAME "vm-regular-engine"
 325 #define VM_ENGINE SCM_VM_REGULAR_ENGINE
 326 #include "vm-engine.c"
 327 #undef VM_NAME
 328 #undef FUNC_NAME
 329 #undef VM_ENGINE
 330
 331 #define VM_NAME   vm_debug_engine
 332 #define FUNC_NAME "vm-debug-engine"
 333 #define VM_ENGINE SCM_VM_DEBUG_ENGINE
 334 #include "vm-engine.c"
 335 #undef VM_NAME
 336 #undef FUNC_NAME
 337 #undef VM_ENGINE
 338
 339 static const scm_t_vm_engine vm_engines[] =
 340   { vm_regular_engine, vm_debug_engine };
 341
 342 #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
 343
 344 /* The GC "kind" for the VM stack.  */
 345 static int vm_stack_gc_kind;
 346
 347 #endif
 348
 349 static SCM
 350 make_vm (void)
 351 #define FUNC_NAME "make_vm"
 352 {
 353   int i;
 354   struct scm_vm *vp;
 355
 356   vp = scm_gc_malloc (sizeof (struct scm_vm), "vm");
 357
 358   vp->stack_size  = VM_DEFAULT_STACK_SIZE;
 359
 360 #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
 361   vp->stack_base = (SCM *)
 362     GC_generic_malloc (vp->stack_size * sizeof (SCM), vm_stack_gc_kind);
 363
 364   /* Keep a pointer to VP so that `vm_stack_mark ()' can know what the stack
 365      top is.  */
 366   *vp->stack_base = PTR2SCM (vp);
 367   vp->stack_base++;
 368   vp->stack_size--;
 369 #else
 370   vp->stack_base  = scm_gc_malloc (vp->stack_size * sizeof (SCM),
 371                                    "stack-base");
 372 #endif
 373
 374 #ifdef VM_ENABLE_STACK_NULLING
 375   memset (vp->stack_base, 0, vp->stack_size * sizeof (SCM));
 376 #endif
 377   vp->stack_limit = vp->stack_base + vp->stack_size;
 378   vp->ip          = NULL;
 379   vp->sp          = vp->stack_base - 1;
 380   vp->fp          = NULL;
 381   vp->engine      = SCM_VM_DEBUG_ENGINE;
 382   vp->options     = SCM_EOL;
 383   vp->trace_level = 0;
 384   for (i = 0; i < SCM_VM_NUM_HOOKS; i++)
 385     vp->hooks[i] = SCM_BOOL_F;
 386   return scm_cell (scm_tc7_vm, (scm_t_bits)vp);
 387 }
 388 #undef FUNC_NAME
 389
 390 #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
 391
 392 /* Mark the VM stack region between its base and its current top.  */
 393 static struct GC_ms_entry *
 394 vm_stack_mark (GC_word *addr, struct GC_ms_entry *mark_stack_ptr,
 395                struct GC_ms_entry *mark_stack_limit, GC_word env)
 396 {
 397   GC_word *word;
 398   const struct scm_vm *vm;
 399
 400   /* The first word of the VM stack should contain a pointer to the
 401      corresponding VM.  */
 402   vm = * ((struct scm_vm **) addr);
 403
 404   if (vm == NULL
 405       || (SCM *) addr != vm->stack_base - 1
 406       || vm->stack_limit - vm->stack_base != vm->stack_size)
 407     /* ADDR must be a pointer to a free-list element, which we must ignore
 408        (see warning in <gc/gc_mark.h>).  */
 409     return mark_stack_ptr;
 410
 411   for (word = (GC_word *) vm->stack_base; word <= (GC_word *) vm->sp; word++)
 412     mark_stack_ptr = GC_MARK_AND_PUSH ((* (GC_word **) word),
 413                                        mark_stack_ptr, mark_stack_limit,
 414                                        NULL);
 415
 416   return mark_stack_ptr;
 417 }
 418
 419 #endif /* VM_ENABLE_PRECISE_STACK_GC_SCAN */
 420
 421
 422 SCM
 423 scm_c_vm_run (SCM vm, SCM program, SCM *argv, int nargs)
 424 {
 425   struct scm_vm *vp = SCM_VM_DATA (vm);
 426   return vm_engines[vp->engine](vm, program, argv, nargs);
 427 }
 428
 429 SCM_DEFINE (scm_vm_apply, "vm-apply", 3, 0, 0,
 430             (SCM vm, SCM program, SCM args),
 431             "")
 432 #define FUNC_NAME s_scm_vm_apply
 433 {
 434   SCM *argv;
 435   int i, nargs;
 436
 437   SCM_VALIDATE_VM (1, vm);
 438   SCM_VALIDATE_PROC (2, program);
 439
 440   nargs = scm_ilength (args);
 441   if (SCM_UNLIKELY (nargs < 0))
 442     scm_wrong_type_arg_msg (FUNC_NAME, 3, args, "list");
 443
 444   argv = alloca(nargs * sizeof(SCM));
 445   for (i = 0; i < nargs; i++)
 446     {
 447       argv[i] = SCM_CAR (args);
 448       args = SCM_CDR (args);
 449     }
 450
 451   return scm_c_vm_run (vm, program, argv, nargs);
 452 }
 453 #undef FUNC_NAME
 454
 455 SCM
 456 scm_vm_call_with_new_stack (SCM vm, SCM thunk, SCM id)
 457 {
 458   return scm_c_vm_run (vm, thunk, NULL, 0);
 459 }
 460
 461 /* Scheme interface */
 462
 463 SCM_DEFINE (scm_vm_version, "vm-version", 0, 0, 0,
 464             (void),
 465             "")
 466 #define FUNC_NAME s_scm_vm_version
 467 {
 468   return scm_from_locale_string (PACKAGE_VERSION);
 469 }
 470 #undef FUNC_NAME
 471
 472 SCM_DEFINE (scm_the_vm, "the-vm", 0, 0, 0,
 473             (void),
 474             "")
 475 #define FUNC_NAME s_scm_the_vm
 476 {
 477   scm_i_thread *t = SCM_I_CURRENT_THREAD;
 478
 479   if (SCM_UNLIKELY (scm_is_false ((t->vm))))
 480     t->vm = make_vm ();
 481
 482   return t->vm;
 483 }
 484 #undef FUNC_NAME
 485
 486
 487 SCM_DEFINE (scm_vm_p, "vm?", 1, 0, 0,
 488             (SCM obj),
 489             "")
 490 #define FUNC_NAME s_scm_vm_p
 491 {
 492   return scm_from_bool (SCM_VM_P (obj));
 493 }
 494 #undef FUNC_NAME
 495
 496 SCM_DEFINE (scm_make_vm, "make-vm", 0, 0, 0,
 497             (void),
 498             "")
 499 #define FUNC_NAME s_scm_make_vm,
 500 {
 501   return make_vm ();
 502 }
 503 #undef FUNC_NAME
 504
 505 SCM_DEFINE (scm_vm_ip, "vm:ip", 1, 0, 0,
 506             (SCM vm),
 507             "")
 508 #define FUNC_NAME s_scm_vm_ip
 509 {
 510   SCM_VALIDATE_VM (1, vm);
 511   return scm_from_ulong ((unsigned long) SCM_VM_DATA (vm)->ip);
 512 }
 513 #undef FUNC_NAME
 514
 515 SCM_DEFINE (scm_vm_sp, "vm:sp", 1, 0, 0,
 516             (SCM vm),
 517             "")
 518 #define FUNC_NAME s_scm_vm_sp
 519 {
 520   SCM_VALIDATE_VM (1, vm);
 521   return scm_from_ulong ((unsigned long) SCM_VM_DATA (vm)->sp);
 522 }
 523 #undef FUNC_NAME
 524
 525 SCM_DEFINE (scm_vm_fp, "vm:fp", 1, 0, 0,
 526             (SCM vm),
 527             "")
 528 #define FUNC_NAME s_scm_vm_fp
 529 {
 530   SCM_VALIDATE_VM (1, vm);
 531   return scm_from_ulong ((unsigned long) SCM_VM_DATA (vm)->fp);
 532 }
 533 #undef FUNC_NAME
 534
 535 #define VM_DEFINE_HOOK(n)                               \
 536 {                                                       \
 537   struct scm_vm *vp;                                    \
 538   SCM_VALIDATE_VM (1, vm);                              \
 539   vp = SCM_VM_DATA (vm);                                \
 540   if (scm_is_false (vp->hooks[n]))                      \
 541     vp->hooks[n] = scm_make_hook (SCM_I_MAKINUM (1));   \
 542   return vp->hooks[n];                                  \
 543 }
 544
 545 SCM_DEFINE (scm_vm_boot_hook, "vm-boot-hook", 1, 0, 0,
 546             (SCM vm),
 547             "")
 548 #define FUNC_NAME s_scm_vm_boot_hook
 549 {
 550   VM_DEFINE_HOOK (SCM_VM_BOOT_HOOK);
 551 }
 552 #undef FUNC_NAME
 553
 554 SCM_DEFINE (scm_vm_halt_hook, "vm-halt-hook", 1, 0, 0,
 555             (SCM vm),
 556             "")
 557 #define FUNC_NAME s_scm_vm_halt_hook
 558 {
 559   VM_DEFINE_HOOK (SCM_VM_HALT_HOOK);
 560 }
 561 #undef FUNC_NAME
 562
 563 SCM_DEFINE (scm_vm_next_hook, "vm-next-hook", 1, 0, 0,
 564             (SCM vm),
 565             "")
 566 #define FUNC_NAME s_scm_vm_next_hook
 567 {
 568   VM_DEFINE_HOOK (SCM_VM_NEXT_HOOK);
 569 }
 570 #undef FUNC_NAME
 571
 572 SCM_DEFINE (scm_vm_break_hook, "vm-break-hook", 1, 0, 0,
 573             (SCM vm),
 574             "")
 575 #define FUNC_NAME s_scm_vm_break_hook
 576 {
 577   VM_DEFINE_HOOK (SCM_VM_BREAK_HOOK);
 578 }
 579 #undef FUNC_NAME
 580
 581 SCM_DEFINE (scm_vm_enter_hook, "vm-enter-hook", 1, 0, 0,
 582             (SCM vm),
 583             "")
 584 #define FUNC_NAME s_scm_vm_enter_hook
 585 {
 586   VM_DEFINE_HOOK (SCM_VM_ENTER_HOOK);
 587 }
 588 #undef FUNC_NAME
 589
 590 SCM_DEFINE (scm_vm_apply_hook, "vm-apply-hook", 1, 0, 0,
 591             (SCM vm),
 592             "")
 593 #define FUNC_NAME s_scm_vm_apply_hook
 594 {
 595   VM_DEFINE_HOOK (SCM_VM_APPLY_HOOK);
 596 }
 597 #undef FUNC_NAME
 598
 599 SCM_DEFINE (scm_vm_exit_hook, "vm-exit-hook", 1, 0, 0,
 600             (SCM vm),
 601             "")
 602 #define FUNC_NAME s_scm_vm_exit_hook
 603 {
 604   VM_DEFINE_HOOK (SCM_VM_EXIT_HOOK);
 605 }
 606 #undef FUNC_NAME
 607
 608 SCM_DEFINE (scm_vm_return_hook, "vm-return-hook", 1, 0, 0,
 609             (SCM vm),
 610             "")
 611 #define FUNC_NAME s_scm_vm_return_hook
 612 {
 613   VM_DEFINE_HOOK (SCM_VM_RETURN_HOOK);
 614 }
 615 #undef FUNC_NAME
 616
 617 SCM_DEFINE (scm_vm_option, "vm-option", 2, 0, 0,
 618             (SCM vm, SCM key),
 619             "")
 620 #define FUNC_NAME s_scm_vm_option
 621 {
 622   SCM_VALIDATE_VM (1, vm);
 623   return scm_assq_ref (SCM_VM_DATA (vm)->options, key);
 624 }
 625 #undef FUNC_NAME
 626
 627 SCM_DEFINE (scm_set_vm_option_x, "set-vm-option!", 3, 0, 0,
 628             (SCM vm, SCM key, SCM val),
 629             "")
 630 #define FUNC_NAME s_scm_set_vm_option_x
 631 {
 632   SCM_VALIDATE_VM (1, vm);
 633   SCM_VM_DATA (vm)->options
 634     = scm_assq_set_x (SCM_VM_DATA (vm)->options, key, val);
 635   return SCM_UNSPECIFIED;
 636 }
 637 #undef FUNC_NAME
 638
 639 SCM_DEFINE (scm_vm_trace_level, "vm-trace-level", 1, 0, 0,
 640             (SCM vm),
 641             "")
 642 #define FUNC_NAME s_scm_vm_trace_level
 643 {
 644   SCM_VALIDATE_VM (1, vm);
 645   return scm_from_int (SCM_VM_DATA (vm)->trace_level);
 646 }
 647 #undef FUNC_NAME
 648
 649 SCM_DEFINE (scm_set_vm_trace_level_x, "set-vm-trace-level!", 2, 0, 0,
 650             (SCM vm, SCM level),
 651             "")
 652 #define FUNC_NAME s_scm_set_vm_trace_level_x
 653 {
 654   SCM_VALIDATE_VM (1, vm);
 655   SCM_VM_DATA (vm)->trace_level = scm_to_int (level);
 656   return SCM_UNSPECIFIED;
 657 }
 658 #undef FUNC_NAME
 659
 660 \f
 661 /*
 662  * Initialize
 663  */
 664
 665 SCM scm_load_compiled_with_vm (SCM file)
 666 {
 667   SCM program = scm_make_program (scm_load_objcode (file),
 668                                   SCM_BOOL_F, SCM_BOOL_F);
 669
 670   return scm_c_vm_run (scm_the_vm (), program, NULL, 0);
 671 }
 672
 673 void
 674 scm_bootstrap_vm (void)
 675 {
 676   scm_c_register_extension ("libguile", "scm_init_vm",
 677                             (scm_t_extension_init_func)scm_init_vm, NULL);
 678
 679 #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
 680   vm_stack_gc_kind =
 681     GC_new_kind (GC_new_free_list (),
 682                  GC_MAKE_PROC (GC_new_proc (vm_stack_mark), 0),
 683                  0, 1);
 684
 685 #endif
 686 }
 687
 688 void
 689 scm_init_vm (void)
 690 {
 691 #ifndef SCM_MAGIC_SNARFER
 692 #include "libguile/vm.x"
 693 #endif
 694 }
 695
 696 /*
 697   Local Variables:
 698   c-file-style: "gnu"
 699   End:
 700 */