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 SCM
  95 scm_i_vm_capture_stack (SCM *stack_base, SCM *fp, SCM *sp, scm_t_uint8 *ra,
  96                         scm_t_uint8 *mvra, scm_t_uint32 flags)
  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   p->flags = flags;
 120   return scm_cell (scm_tc7_vm_cont, (scm_t_bits)p);
 121 }
 122
 123 static void
 124 vm_return_to_continuation (SCM vm, SCM cont, size_t n, SCM *argv)
 125 {
 126   struct scm_vm *vp;
 127   struct scm_vm_cont *cp;
 128   SCM *argv_copy;
 129
 130   argv_copy = alloca (n * sizeof(SCM));
 131   memcpy (argv_copy, argv, n * sizeof(SCM));
 132
 133   vp = SCM_VM_DATA (vm);
 134   cp = SCM_VM_CONT_DATA (cont);
 135
 136   if (n == 0 && !cp->mvra)
 137     scm_misc_error (NULL, "Too few values returned to continuation",
 138                     SCM_EOL);
 139
 140   if (vp->stack_size < cp->stack_size + n + 1)
 141     {
 142       /* puts ("FIXME: Need to expand"); */
 143       abort ();
 144     }
 145 #ifdef VM_ENABLE_STACK_NULLING
 146   {
 147     scm_t_ptrdiff nzero = (vp->sp - cp->sp);
 148     if (nzero > 0)
 149       memset (vp->stack_base + cp->stack_size, 0, nzero * sizeof (SCM));
 150     /* actually nzero should always be negative, because vm_reset_stack will
 151        unwind the stack to some point *below* this continuation */
 152   }
 153 #endif
 154   vp->sp = cp->sp;
 155   vp->fp = cp->fp;
 156   memcpy (vp->stack_base, cp->stack_base, cp->stack_size * sizeof (SCM));
 157
 158   if (n == 1 || !cp->mvra)
 159     {
 160       vp->ip = cp->ra;
 161       vp->sp++;
 162       *vp->sp = argv_copy[0];
 163     }
 164   else
 165     {
 166       size_t i;
 167       for (i = 0; i < n; i++)
 168         {
 169           vp->sp++;
 170           *vp->sp = argv_copy[i];
 171         }
 172       vp->sp++;
 173       *vp->sp = scm_from_size_t (n);
 174       vp->ip = cp->mvra;
 175     }
 176 }
 177
 178 SCM
 179 scm_i_vm_capture_continuation (SCM vm)
 180 {
 181   struct scm_vm *vp = SCM_VM_DATA (vm);
 182   return scm_i_vm_capture_stack (vp->stack_base, vp->fp, vp->sp, vp->ip, NULL, 0);
 183 }
 184
 185 static void
 186 vm_dispatch_hook (SCM vm, int hook_num)
 187 {
 188   struct scm_vm *vp;
 189   SCM hook;
 190   SCM frame;
 191
 192   vp = SCM_VM_DATA (vm);
 193   hook = vp->hooks[hook_num];
 194
 195   if (SCM_LIKELY (scm_is_false (hook))
 196       || scm_is_null (SCM_HOOK_PROCEDURES (hook)))
 197     return;
 198
 199   vp->trace_level--;
 200   frame = scm_c_make_frame (vm, vp->fp, vp->sp, vp->ip, 0);
 201   scm_c_run_hookn (hook, &frame, 1);
 202   vp->trace_level++;
 203 }
 204
 205 static void vm_abort (SCM vm, size_t n, scm_t_int64 cookie) SCM_NORETURN;
 206 static void
 207 vm_abort (SCM vm, size_t n, scm_t_int64 vm_cookie)
 208 {
 209   size_t i;
 210   ssize_t tail_len;
 211   SCM tag, tail, *argv;
 212
 213   /* FIXME: VM_ENABLE_STACK_NULLING */
 214   tail = *(SCM_VM_DATA (vm)->sp--);
 215   /* NULLSTACK (1) */
 216   tail_len = scm_ilength (tail);
 217   if (tail_len < 0)
 218     abort ();
 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                                    SCM extwinds, size_t n, SCM *argv)
 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     {
 251       /* puts ("FIXME: Need to expand"); */
 252       abort ();
 253     }
 254
 255   memcpy (base, cp->stack_base, cp->stack_size * sizeof (SCM));
 256
 257   /* now relocate frame pointers */
 258   {
 259     SCM *fp;
 260     for (fp = RELOC (cp->fp);
 261          SCM_FRAME_LOWER_ADDRESS (fp) > base;
 262          fp = SCM_FRAME_DYNAMIC_LINK (fp))
 263       SCM_FRAME_SET_DYNAMIC_LINK (fp, RELOC (SCM_FRAME_DYNAMIC_LINK (fp)));
 264   }
 265
 266   vp->sp = base - 1 + cp->stack_size;
 267   vp->fp = RELOC (cp->fp);
 268   vp->ip = cp->mvra;
 269
 270 #undef RELOC
 271
 272   /* now push args. ip is in a MV context. */
 273   for (i = 0; i < n; i++)
 274     {
 275       vp->sp++;
 276       *vp->sp = argv_copy[i];
 277     }
 278   vp->sp++;
 279   *vp->sp = scm_from_size_t (n);
 280 }
 281
 282 \f
 283 /*
 284  * VM Internal functions
 285  */
 286
 287 SCM_SYMBOL (sym_vm_run, "vm-run");
 288 SCM_SYMBOL (sym_vm_error, "vm-error");
 289 SCM_SYMBOL (sym_keyword_argument_error, "keyword-argument-error");
 290 SCM_SYMBOL (sym_debug, "debug");
 291
 292 void
 293 scm_i_vm_print (SCM x, SCM port, scm_print_state *pstate)
 294 {
 295   scm_puts ("#<vm ", port);
 296   scm_uintprint (SCM_UNPACK (x), 16, port);
 297   scm_puts (">", port);
 298 }
 299
 300 static SCM
 301 really_make_boot_program (long nargs)
 302 {
 303   SCM u8vec;
 304   scm_t_uint8 text[] = { scm_op_mv_call, 0, 0, 0, 1,
 305                          scm_op_make_int8_1, scm_op_halt };
 306   struct scm_objcode *bp;
 307   SCM ret;
 308
 309   if (SCM_UNLIKELY (nargs > 255 || nargs < 0))
 310     abort ();
 311   text[1] = (scm_t_uint8)nargs;
 312
 313   bp = scm_malloc (sizeof (struct scm_objcode) + sizeof (text));
 314   memcpy (SCM_C_OBJCODE_BASE (bp), text, sizeof (text));
 315   bp->len = sizeof(text);
 316   bp->metalen = 0;
 317
 318   u8vec = scm_c_take_bytevector ((scm_t_int8*)bp,
 319                                  sizeof (struct scm_objcode) + sizeof (text));
 320   ret = scm_make_program (scm_bytecode_to_objcode (u8vec),
 321                           SCM_BOOL_F, SCM_BOOL_F);
 322   SCM_SET_CELL_WORD_0 (ret, SCM_CELL_WORD_0 (ret) | SCM_F_PROGRAM_IS_BOOT);
 323
 324   return ret;
 325 }
 326 #define NUM_BOOT_PROGS 8
 327 static SCM
 328 vm_make_boot_program (long nargs)
 329 {
 330   static SCM programs[NUM_BOOT_PROGS] = { 0, };
 331
 332   if (SCM_UNLIKELY (!programs[0]))
 333     {
 334       int i;
 335       for (i = 0; i < NUM_BOOT_PROGS; i++)
 336         programs[i] = really_make_boot_program (i);
 337     }
 338
 339   if (SCM_LIKELY (nargs < NUM_BOOT_PROGS))
 340     return programs[nargs];
 341   else
 342     return really_make_boot_program (nargs);
 343 }
 344
 345 \f
 346 /*
 347  * VM
 348  */
 349
 350 static SCM
 351 resolve_variable (SCM what, SCM program_module)
 352 {
 353   if (SCM_LIKELY (scm_is_symbol (what)))
 354     {
 355       if (SCM_LIKELY (scm_module_system_booted_p
 356                       && scm_is_true (program_module)))
 357         /* might longjmp */
 358         return scm_module_lookup (program_module, what);
 359       else
 360         {
 361           SCM v = scm_sym2var (what, SCM_BOOL_F, SCM_BOOL_F);
 362           if (scm_is_false (v))
 363             scm_misc_error (NULL, "unbound variable: ~S", scm_list_1 (what));
 364           else
 365             return v;
 366         }
 367     }
 368   else
 369     {
 370       SCM mod;
 371       /* compilation of @ or @@
 372          `what' is a three-element list: (MODNAME SYM INTERFACE?)
 373          INTERFACE? is #t if we compiled @ or #f if we compiled @@
 374       */
 375       mod = scm_resolve_module (SCM_CAR (what));
 376       if (scm_is_true (SCM_CADDR (what)))
 377         mod = scm_module_public_interface (mod);
 378       if (scm_is_false (mod))
 379         scm_misc_error (NULL, "no such module: ~S",
 380                         scm_list_1 (SCM_CAR (what)));
 381       /* might longjmp */
 382       return scm_module_lookup (mod, SCM_CADR (what));
 383     }
 384 }
 385
 386 #define VM_DEFAULT_STACK_SIZE   (64 * 1024)
 387
 388 #define VM_NAME   vm_regular_engine
 389 #define FUNC_NAME "vm-regular-engine"
 390 #define VM_ENGINE SCM_VM_REGULAR_ENGINE
 391 #include "vm-engine.c"
 392 #undef VM_NAME
 393 #undef FUNC_NAME
 394 #undef VM_ENGINE
 395
 396 #define VM_NAME   vm_debug_engine
 397 #define FUNC_NAME "vm-debug-engine"
 398 #define VM_ENGINE SCM_VM_DEBUG_ENGINE
 399 #include "vm-engine.c"
 400 #undef VM_NAME
 401 #undef FUNC_NAME
 402 #undef VM_ENGINE
 403
 404 static const scm_t_vm_engine vm_engines[] =
 405   { vm_regular_engine, vm_debug_engine };
 406
 407 #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
 408
 409 /* The GC "kind" for the VM stack.  */
 410 static int vm_stack_gc_kind;
 411
 412 #endif
 413
 414 static SCM
 415 make_vm (void)
 416 #define FUNC_NAME "make_vm"
 417 {
 418   int i;
 419   struct scm_vm *vp;
 420
 421   vp = scm_gc_malloc (sizeof (struct scm_vm), "vm");
 422
 423   vp->stack_size  = VM_DEFAULT_STACK_SIZE;
 424
 425 #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
 426   vp->stack_base = (SCM *)
 427     GC_generic_malloc (vp->stack_size * sizeof (SCM), vm_stack_gc_kind);
 428
 429   /* Keep a pointer to VP so that `vm_stack_mark ()' can know what the stack
 430      top is.  */
 431   *vp->stack_base = PTR2SCM (vp);
 432   vp->stack_base++;
 433   vp->stack_size--;
 434 #else
 435   vp->stack_base  = scm_gc_malloc (vp->stack_size * sizeof (SCM),
 436                                    "stack-base");
 437 #endif
 438
 439 #ifdef VM_ENABLE_STACK_NULLING
 440   memset (vp->stack_base, 0, vp->stack_size * sizeof (SCM));
 441 #endif
 442   vp->stack_limit = vp->stack_base + vp->stack_size;
 443   vp->ip          = NULL;
 444   vp->sp          = vp->stack_base - 1;
 445   vp->fp          = NULL;
 446   vp->engine      = SCM_VM_DEBUG_ENGINE;
 447   vp->options     = SCM_EOL;
 448   vp->trace_level = 0;
 449   for (i = 0; i < SCM_VM_NUM_HOOKS; i++)
 450     vp->hooks[i] = SCM_BOOL_F;
 451   vp->cookie = 0;
 452   return scm_cell (scm_tc7_vm, (scm_t_bits)vp);
 453 }
 454 #undef FUNC_NAME
 455
 456 #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
 457
 458 /* Mark the VM stack region between its base and its current top.  */
 459 static struct GC_ms_entry *
 460 vm_stack_mark (GC_word *addr, struct GC_ms_entry *mark_stack_ptr,
 461                struct GC_ms_entry *mark_stack_limit, GC_word env)
 462 {
 463   GC_word *word;
 464   const struct scm_vm *vm;
 465
 466   /* The first word of the VM stack should contain a pointer to the
 467      corresponding VM.  */
 468   vm = * ((struct scm_vm **) addr);
 469
 470   if (vm == NULL
 471       || (SCM *) addr != vm->stack_base - 1
 472       || vm->stack_limit - vm->stack_base != vm->stack_size)
 473     /* ADDR must be a pointer to a free-list element, which we must ignore
 474        (see warning in <gc/gc_mark.h>).  */
 475     return mark_stack_ptr;
 476
 477   for (word = (GC_word *) vm->stack_base; word <= (GC_word *) vm->sp; word++)
 478     mark_stack_ptr = GC_MARK_AND_PUSH ((* (GC_word **) word),
 479                                        mark_stack_ptr, mark_stack_limit,
 480                                        NULL);
 481
 482   return mark_stack_ptr;
 483 }
 484
 485 #endif /* VM_ENABLE_PRECISE_STACK_GC_SCAN */
 486
 487
 488 SCM
 489 scm_c_vm_run (SCM vm, SCM program, SCM *argv, int nargs)
 490 {
 491   struct scm_vm *vp = SCM_VM_DATA (vm);
 492   return vm_engines[vp->engine](vm, program, argv, nargs);
 493 }
 494
 495 SCM_DEFINE (scm_vm_apply, "vm-apply", 3, 0, 0,
 496             (SCM vm, SCM program, SCM args),
 497             "")
 498 #define FUNC_NAME s_scm_vm_apply
 499 {
 500   SCM *argv;
 501   int i, nargs;
 502
 503   SCM_VALIDATE_VM (1, vm);
 504   SCM_VALIDATE_PROC (2, program);
 505
 506   nargs = scm_ilength (args);
 507   if (SCM_UNLIKELY (nargs < 0))
 508     scm_wrong_type_arg_msg (FUNC_NAME, 3, args, "list");
 509
 510   argv = alloca(nargs * sizeof(SCM));
 511   for (i = 0; i < nargs; i++)
 512     {
 513       argv[i] = SCM_CAR (args);
 514       args = SCM_CDR (args);
 515     }
 516
 517   return scm_c_vm_run (vm, program, argv, nargs);
 518 }
 519 #undef FUNC_NAME
 520
 521 SCM
 522 scm_vm_call_with_new_stack (SCM vm, SCM thunk, SCM id)
 523 {
 524   return scm_c_vm_run (vm, thunk, NULL, 0);
 525 }
 526
 527 /* Scheme interface */
 528
 529 SCM_DEFINE (scm_vm_version, "vm-version", 0, 0, 0,
 530             (void),
 531             "")
 532 #define FUNC_NAME s_scm_vm_version
 533 {
 534   return scm_from_locale_string (PACKAGE_VERSION);
 535 }
 536 #undef FUNC_NAME
 537
 538 SCM_DEFINE (scm_the_vm, "the-vm", 0, 0, 0,
 539             (void),
 540             "")
 541 #define FUNC_NAME s_scm_the_vm
 542 {
 543   scm_i_thread *t = SCM_I_CURRENT_THREAD;
 544
 545   if (SCM_UNLIKELY (scm_is_false ((t->vm))))
 546     t->vm = make_vm ();
 547
 548   return t->vm;
 549 }
 550 #undef FUNC_NAME
 551
 552
 553 SCM_DEFINE (scm_vm_p, "vm?", 1, 0, 0,
 554             (SCM obj),
 555             "")
 556 #define FUNC_NAME s_scm_vm_p
 557 {
 558   return scm_from_bool (SCM_VM_P (obj));
 559 }
 560 #undef FUNC_NAME
 561
 562 SCM_DEFINE (scm_make_vm, "make-vm", 0, 0, 0,
 563             (void),
 564             "")
 565 #define FUNC_NAME s_scm_make_vm,
 566 {
 567   return make_vm ();
 568 }
 569 #undef FUNC_NAME
 570
 571 SCM_DEFINE (scm_vm_ip, "vm:ip", 1, 0, 0,
 572             (SCM vm),
 573             "")
 574 #define FUNC_NAME s_scm_vm_ip
 575 {
 576   SCM_VALIDATE_VM (1, vm);
 577   return scm_from_ulong ((unsigned long) SCM_VM_DATA (vm)->ip);
 578 }
 579 #undef FUNC_NAME
 580
 581 SCM_DEFINE (scm_vm_sp, "vm:sp", 1, 0, 0,
 582             (SCM vm),
 583             "")
 584 #define FUNC_NAME s_scm_vm_sp
 585 {
 586   SCM_VALIDATE_VM (1, vm);
 587   return scm_from_ulong ((unsigned long) SCM_VM_DATA (vm)->sp);
 588 }
 589 #undef FUNC_NAME
 590
 591 SCM_DEFINE (scm_vm_fp, "vm:fp", 1, 0, 0,
 592             (SCM vm),
 593             "")
 594 #define FUNC_NAME s_scm_vm_fp
 595 {
 596   SCM_VALIDATE_VM (1, vm);
 597   return scm_from_ulong ((unsigned long) SCM_VM_DATA (vm)->fp);
 598 }
 599 #undef FUNC_NAME
 600
 601 #define VM_DEFINE_HOOK(n)                               \
 602 {                                                       \
 603   struct scm_vm *vp;                                    \
 604   SCM_VALIDATE_VM (1, vm);                              \
 605   vp = SCM_VM_DATA (vm);                                \
 606   if (scm_is_false (vp->hooks[n]))                      \
 607     vp->hooks[n] = scm_make_hook (SCM_I_MAKINUM (1));   \
 608   return vp->hooks[n];                                  \
 609 }
 610
 611 SCM_DEFINE (scm_vm_boot_hook, "vm-boot-hook", 1, 0, 0,
 612             (SCM vm),
 613             "")
 614 #define FUNC_NAME s_scm_vm_boot_hook
 615 {
 616   VM_DEFINE_HOOK (SCM_VM_BOOT_HOOK);
 617 }
 618 #undef FUNC_NAME
 619
 620 SCM_DEFINE (scm_vm_halt_hook, "vm-halt-hook", 1, 0, 0,
 621             (SCM vm),
 622             "")
 623 #define FUNC_NAME s_scm_vm_halt_hook
 624 {
 625   VM_DEFINE_HOOK (SCM_VM_HALT_HOOK);
 626 }
 627 #undef FUNC_NAME
 628
 629 SCM_DEFINE (scm_vm_next_hook, "vm-next-hook", 1, 0, 0,
 630             (SCM vm),
 631             "")
 632 #define FUNC_NAME s_scm_vm_next_hook
 633 {
 634   VM_DEFINE_HOOK (SCM_VM_NEXT_HOOK);
 635 }
 636 #undef FUNC_NAME
 637
 638 SCM_DEFINE (scm_vm_break_hook, "vm-break-hook", 1, 0, 0,
 639             (SCM vm),
 640             "")
 641 #define FUNC_NAME s_scm_vm_break_hook
 642 {
 643   VM_DEFINE_HOOK (SCM_VM_BREAK_HOOK);
 644 }
 645 #undef FUNC_NAME
 646
 647 SCM_DEFINE (scm_vm_enter_hook, "vm-enter-hook", 1, 0, 0,
 648             (SCM vm),
 649             "")
 650 #define FUNC_NAME s_scm_vm_enter_hook
 651 {
 652   VM_DEFINE_HOOK (SCM_VM_ENTER_HOOK);
 653 }
 654 #undef FUNC_NAME
 655
 656 SCM_DEFINE (scm_vm_apply_hook, "vm-apply-hook", 1, 0, 0,
 657             (SCM vm),
 658             "")
 659 #define FUNC_NAME s_scm_vm_apply_hook
 660 {
 661   VM_DEFINE_HOOK (SCM_VM_APPLY_HOOK);
 662 }
 663 #undef FUNC_NAME
 664
 665 SCM_DEFINE (scm_vm_exit_hook, "vm-exit-hook", 1, 0, 0,
 666             (SCM vm),
 667             "")
 668 #define FUNC_NAME s_scm_vm_exit_hook
 669 {
 670   VM_DEFINE_HOOK (SCM_VM_EXIT_HOOK);
 671 }
 672 #undef FUNC_NAME
 673
 674 SCM_DEFINE (scm_vm_return_hook, "vm-return-hook", 1, 0, 0,
 675             (SCM vm),
 676             "")
 677 #define FUNC_NAME s_scm_vm_return_hook
 678 {
 679   VM_DEFINE_HOOK (SCM_VM_RETURN_HOOK);
 680 }
 681 #undef FUNC_NAME
 682
 683 SCM_DEFINE (scm_vm_option, "vm-option", 2, 0, 0,
 684             (SCM vm, SCM key),
 685             "")
 686 #define FUNC_NAME s_scm_vm_option
 687 {
 688   SCM_VALIDATE_VM (1, vm);
 689   return scm_assq_ref (SCM_VM_DATA (vm)->options, key);
 690 }
 691 #undef FUNC_NAME
 692
 693 SCM_DEFINE (scm_set_vm_option_x, "set-vm-option!", 3, 0, 0,
 694             (SCM vm, SCM key, SCM val),
 695             "")
 696 #define FUNC_NAME s_scm_set_vm_option_x
 697 {
 698   SCM_VALIDATE_VM (1, vm);
 699   SCM_VM_DATA (vm)->options
 700     = scm_assq_set_x (SCM_VM_DATA (vm)->options, key, val);
 701   return SCM_UNSPECIFIED;
 702 }
 703 #undef FUNC_NAME
 704
 705 SCM_DEFINE (scm_vm_trace_level, "vm-trace-level", 1, 0, 0,
 706             (SCM vm),
 707             "")
 708 #define FUNC_NAME s_scm_vm_trace_level
 709 {
 710   SCM_VALIDATE_VM (1, vm);
 711   return scm_from_int (SCM_VM_DATA (vm)->trace_level);
 712 }
 713 #undef FUNC_NAME
 714
 715 SCM_DEFINE (scm_set_vm_trace_level_x, "set-vm-trace-level!", 2, 0, 0,
 716             (SCM vm, SCM level),
 717             "")
 718 #define FUNC_NAME s_scm_set_vm_trace_level_x
 719 {
 720   SCM_VALIDATE_VM (1, vm);
 721   SCM_VM_DATA (vm)->trace_level = scm_to_int (level);
 722   return SCM_UNSPECIFIED;
 723 }
 724 #undef FUNC_NAME
 725
 726 \f
 727 /*
 728  * Initialize
 729  */
 730
 731 SCM scm_load_compiled_with_vm (SCM file)
 732 {
 733   SCM program = scm_make_program (scm_load_objcode (file),
 734                                   SCM_BOOL_F, SCM_BOOL_F);
 735
 736   return scm_c_vm_run (scm_the_vm (), program, NULL, 0);
 737 }
 738
 739 void
 740 scm_bootstrap_vm (void)
 741 {
 742   scm_c_register_extension ("libguile", "scm_init_vm",
 743                             (scm_t_extension_init_func)scm_init_vm, NULL);
 744
 745 #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
 746   vm_stack_gc_kind =
 747     GC_new_kind (GC_new_free_list (),
 748                  GC_MAKE_PROC (GC_new_proc (vm_stack_mark), 0),
 749                  0, 1);
 750
 751 #endif
 752 }
 753
 754 void
 755 scm_init_vm (void)
 756 {
 757 #ifndef SCM_MAGIC_SNARFER
 758 #include "libguile/vm.x"
 759 #endif
 760 }
 761
 762 /*
 763   Local Variables:
 764   c-file-style: "gnu"
 765   End:
 766 */