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     scm_misc_error ("vm-engine", "not enough space to reinstate continuation",
 142                     scm_list_2 (vm, cont));
 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 scm_i_vm_capture_stack (vp->stack_base, vp->fp, vp->sp, vp->ip, NULL, 0);
 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 static void vm_abort (SCM vm, size_t n, scm_t_int64 cookie) SCM_NORETURN;
 205 static void
 206 vm_abort (SCM vm, size_t n, scm_t_int64 vm_cookie)
 207 {
 208   size_t i;
 209   ssize_t tail_len;
 210   SCM tag, tail, *argv;
 211
 212   /* FIXME: VM_ENABLE_STACK_NULLING */
 213   tail = *(SCM_VM_DATA (vm)->sp--);
 214   /* NULLSTACK (1) */
 215   tail_len = scm_ilength (tail);
 216   if (tail_len < 0)
 217     scm_misc_error ("vm-engine", "tail values to abort should be a list",
 218                     scm_list_1 (tail));
 219
 220   tag = SCM_VM_DATA (vm)->sp[-n];
 221   argv = alloca ((n + tail_len) * sizeof (SCM));
 222   for (i = 0; i < n; i++)
 223     argv[i] = SCM_VM_DATA (vm)->sp[-(n-1-i)];
 224   for (; i < n + tail_len; i++, tail = scm_cdr (tail))
 225     argv[i] = scm_car (tail);
 226   /* NULLSTACK (n + 1) */
 227   SCM_VM_DATA (vm)->sp -= n + 1;
 228
 229   scm_c_abort (vm, tag, n + tail_len, argv, vm_cookie);
 230 }
 231
 232 static void
 233 vm_reinstate_partial_continuation (SCM vm, SCM cont, SCM intwinds,
 234                                    size_t n, SCM *argv)
 235 {
 236   struct scm_vm *vp;
 237   struct scm_vm_cont *cp;
 238   SCM *argv_copy, *base;
 239   size_t i;
 240
 241   argv_copy = alloca (n * sizeof(SCM));
 242   memcpy (argv_copy, argv, n * sizeof(SCM));
 243
 244   vp = SCM_VM_DATA (vm);
 245   cp = SCM_VM_CONT_DATA (cont);
 246   base = SCM_FRAME_UPPER_ADDRESS (vp->fp) + 1;
 247
 248 #define RELOC(scm_p) (scm_p + cp->reloc + (base - cp->stack_base))
 249
 250   if ((base - vp->stack_base) + cp->stack_size + n + 1 > vp->stack_size)
 251     scm_misc_error ("vm-engine",
 252                     "not enough space to instate partial continuation",
 253                     scm_list_2 (vm, cont));
 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   /* Finally, rewind the dynamic state. */
 282   {
 283     long delta = 0;
 284     SCM newwinds = scm_i_dynwinds ();
 285     for (; scm_is_pair (intwinds); intwinds = scm_cdr (intwinds), delta--)
 286       newwinds = scm_cons (scm_car (intwinds), newwinds);
 287     scm_dowinds (newwinds, delta);
 288   }
 289 }
 290
 291 \f
 292 /*
 293  * VM Internal functions
 294  */
 295
 296 /* Unfortunately we can't snarf these: snarfed things are only loaded up from
 297    (system vm vm), which might not be loaded before an error happens. */
 298 static SCM sym_vm_run, sym_vm_error, sym_keyword_argument_error, sym_debug;
 299
 300 void
 301 scm_i_vm_print (SCM x, SCM port, scm_print_state *pstate)
 302 {
 303   scm_puts ("#<vm ", port);
 304   scm_uintprint (SCM_UNPACK (x), 16, port);
 305   scm_puts (">", port);
 306 }
 307
 308 static SCM
 309 really_make_boot_program (long nargs)
 310 {
 311   SCM u8vec;
 312   scm_t_uint8 text[] = { scm_op_mv_call, 0, 0, 0, 1,
 313                          scm_op_make_int8_1, scm_op_halt };
 314   struct scm_objcode *bp;
 315   SCM ret;
 316
 317   if (SCM_UNLIKELY (nargs > 255 || nargs < 0))
 318     scm_misc_error ("vm-engine", "too many args when making boot procedure",
 319                     scm_list_1 (scm_from_long (nargs)));
 320
 321   text[1] = (scm_t_uint8)nargs;
 322
 323   bp = scm_malloc (sizeof (struct scm_objcode) + sizeof (text));
 324   memcpy (SCM_C_OBJCODE_BASE (bp), text, sizeof (text));
 325   bp->len = sizeof(text);
 326   bp->metalen = 0;
 327
 328   u8vec = scm_c_take_bytevector ((scm_t_int8*)bp,
 329                                  sizeof (struct scm_objcode) + sizeof (text));
 330   ret = scm_make_program (scm_bytecode_to_objcode (u8vec),
 331                           SCM_BOOL_F, SCM_BOOL_F);
 332   SCM_SET_CELL_WORD_0 (ret, SCM_CELL_WORD_0 (ret) | SCM_F_PROGRAM_IS_BOOT);
 333
 334   return ret;
 335 }
 336 #define NUM_BOOT_PROGS 8
 337 static SCM
 338 vm_make_boot_program (long nargs)
 339 {
 340   static SCM programs[NUM_BOOT_PROGS] = { 0, };
 341
 342   if (SCM_UNLIKELY (!programs[0]))
 343     {
 344       int i;
 345       for (i = 0; i < NUM_BOOT_PROGS; i++)
 346         programs[i] = really_make_boot_program (i);
 347     }
 348
 349   if (SCM_LIKELY (nargs < NUM_BOOT_PROGS))
 350     return programs[nargs];
 351   else
 352     return really_make_boot_program (nargs);
 353 }
 354
 355 \f
 356 /*
 357  * VM
 358  */
 359
 360 static SCM
 361 resolve_variable (SCM what, SCM program_module)
 362 {
 363   if (SCM_LIKELY (scm_is_symbol (what)))
 364     {
 365       if (SCM_LIKELY (scm_module_system_booted_p
 366                       && scm_is_true (program_module)))
 367         /* might longjmp */
 368         return scm_module_lookup (program_module, what);
 369       else
 370         {
 371           SCM v = scm_sym2var (what, SCM_BOOL_F, SCM_BOOL_F);
 372           if (scm_is_false (v))
 373             scm_misc_error (NULL, "unbound variable: ~S", scm_list_1 (what));
 374           else
 375             return v;
 376         }
 377     }
 378   else
 379     {
 380       SCM mod;
 381       /* compilation of @ or @@
 382          `what' is a three-element list: (MODNAME SYM INTERFACE?)
 383          INTERFACE? is #t if we compiled @ or #f if we compiled @@
 384       */
 385       mod = scm_resolve_module (SCM_CAR (what));
 386       if (scm_is_true (SCM_CADDR (what)))
 387         mod = scm_module_public_interface (mod);
 388       if (scm_is_false (mod))
 389         scm_misc_error (NULL, "no such module: ~S",
 390                         scm_list_1 (SCM_CAR (what)));
 391       /* might longjmp */
 392       return scm_module_lookup (mod, SCM_CADR (what));
 393     }
 394 }
 395
 396 #define VM_DEFAULT_STACK_SIZE   (64 * 1024)
 397
 398 #define VM_NAME   vm_regular_engine
 399 #define FUNC_NAME "vm-regular-engine"
 400 #define VM_ENGINE SCM_VM_REGULAR_ENGINE
 401 #include "vm-engine.c"
 402 #undef VM_NAME
 403 #undef FUNC_NAME
 404 #undef VM_ENGINE
 405
 406 #define VM_NAME   vm_debug_engine
 407 #define FUNC_NAME "vm-debug-engine"
 408 #define VM_ENGINE SCM_VM_DEBUG_ENGINE
 409 #include "vm-engine.c"
 410 #undef VM_NAME
 411 #undef FUNC_NAME
 412 #undef VM_ENGINE
 413
 414 static const scm_t_vm_engine vm_engines[] =
 415   { vm_regular_engine, vm_debug_engine };
 416
 417 #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
 418
 419 /* The GC "kind" for the VM stack.  */
 420 static int vm_stack_gc_kind;
 421
 422 #endif
 423
 424 static SCM
 425 make_vm (void)
 426 #define FUNC_NAME "make_vm"
 427 {
 428   int i;
 429   struct scm_vm *vp;
 430
 431   vp = scm_gc_malloc (sizeof (struct scm_vm), "vm");
 432
 433   vp->stack_size  = VM_DEFAULT_STACK_SIZE;
 434
 435 #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
 436   vp->stack_base = (SCM *)
 437     GC_generic_malloc (vp->stack_size * sizeof (SCM), vm_stack_gc_kind);
 438
 439   /* Keep a pointer to VP so that `vm_stack_mark ()' can know what the stack
 440      top is.  */
 441   *vp->stack_base = PTR2SCM (vp);
 442   vp->stack_base++;
 443   vp->stack_size--;
 444 #else
 445   vp->stack_base  = scm_gc_malloc (vp->stack_size * sizeof (SCM),
 446                                    "stack-base");
 447 #endif
 448
 449 #ifdef VM_ENABLE_STACK_NULLING
 450   memset (vp->stack_base, 0, vp->stack_size * sizeof (SCM));
 451 #endif
 452   vp->stack_limit = vp->stack_base + vp->stack_size;
 453   vp->ip          = NULL;
 454   vp->sp          = vp->stack_base - 1;
 455   vp->fp          = NULL;
 456   vp->engine      = SCM_VM_DEBUG_ENGINE;
 457   vp->options     = SCM_EOL;
 458   vp->trace_level = 0;
 459   for (i = 0; i < SCM_VM_NUM_HOOKS; i++)
 460     vp->hooks[i] = SCM_BOOL_F;
 461   vp->cookie = 0;
 462   return scm_cell (scm_tc7_vm, (scm_t_bits)vp);
 463 }
 464 #undef FUNC_NAME
 465
 466 #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
 467
 468 /* Mark the VM stack region between its base and its current top.  */
 469 static struct GC_ms_entry *
 470 vm_stack_mark (GC_word *addr, struct GC_ms_entry *mark_stack_ptr,
 471                struct GC_ms_entry *mark_stack_limit, GC_word env)
 472 {
 473   GC_word *word;
 474   const struct scm_vm *vm;
 475
 476   /* The first word of the VM stack should contain a pointer to the
 477      corresponding VM.  */
 478   vm = * ((struct scm_vm **) addr);
 479
 480   if (vm == NULL
 481       || (SCM *) addr != vm->stack_base - 1
 482       || vm->stack_limit - vm->stack_base != vm->stack_size)
 483     /* ADDR must be a pointer to a free-list element, which we must ignore
 484        (see warning in <gc/gc_mark.h>).  */
 485     return mark_stack_ptr;
 486
 487   for (word = (GC_word *) vm->stack_base; word <= (GC_word *) vm->sp; word++)
 488     mark_stack_ptr = GC_MARK_AND_PUSH ((* (GC_word **) word),
 489                                        mark_stack_ptr, mark_stack_limit,
 490                                        NULL);
 491
 492   return mark_stack_ptr;
 493 }
 494
 495 #endif /* VM_ENABLE_PRECISE_STACK_GC_SCAN */
 496
 497
 498 SCM
 499 scm_c_vm_run (SCM vm, SCM program, SCM *argv, int nargs)
 500 {
 501   struct scm_vm *vp = SCM_VM_DATA (vm);
 502   return vm_engines[vp->engine](vm, program, argv, nargs);
 503 }
 504
 505 SCM_DEFINE (scm_vm_apply, "vm-apply", 3, 0, 0,
 506             (SCM vm, SCM program, SCM args),
 507             "")
 508 #define FUNC_NAME s_scm_vm_apply
 509 {
 510   SCM *argv;
 511   int i, nargs;
 512
 513   SCM_VALIDATE_VM (1, vm);
 514   SCM_VALIDATE_PROC (2, program);
 515
 516   nargs = scm_ilength (args);
 517   if (SCM_UNLIKELY (nargs < 0))
 518     scm_wrong_type_arg_msg (FUNC_NAME, 3, args, "list");
 519
 520   argv = alloca(nargs * sizeof(SCM));
 521   for (i = 0; i < nargs; i++)
 522     {
 523       argv[i] = SCM_CAR (args);
 524       args = SCM_CDR (args);
 525     }
 526
 527   return scm_c_vm_run (vm, program, argv, nargs);
 528 }
 529 #undef FUNC_NAME
 530
 531 SCM
 532 scm_vm_call_with_new_stack (SCM vm, SCM thunk, SCM id)
 533 {
 534   return scm_c_vm_run (vm, thunk, NULL, 0);
 535 }
 536
 537 /* Scheme interface */
 538
 539 SCM_DEFINE (scm_vm_version, "vm-version", 0, 0, 0,
 540             (void),
 541             "")
 542 #define FUNC_NAME s_scm_vm_version
 543 {
 544   return scm_from_locale_string (PACKAGE_VERSION);
 545 }
 546 #undef FUNC_NAME
 547
 548 SCM_DEFINE (scm_the_vm, "the-vm", 0, 0, 0,
 549             (void),
 550             "")
 551 #define FUNC_NAME s_scm_the_vm
 552 {
 553   scm_i_thread *t = SCM_I_CURRENT_THREAD;
 554
 555   if (SCM_UNLIKELY (scm_is_false ((t->vm))))
 556     t->vm = make_vm ();
 557
 558   return t->vm;
 559 }
 560 #undef FUNC_NAME
 561
 562
 563 SCM_DEFINE (scm_vm_p, "vm?", 1, 0, 0,
 564             (SCM obj),
 565             "")
 566 #define FUNC_NAME s_scm_vm_p
 567 {
 568   return scm_from_bool (SCM_VM_P (obj));
 569 }
 570 #undef FUNC_NAME
 571
 572 SCM_DEFINE (scm_make_vm, "make-vm", 0, 0, 0,
 573             (void),
 574             "")
 575 #define FUNC_NAME s_scm_make_vm,
 576 {
 577   return make_vm ();
 578 }
 579 #undef FUNC_NAME
 580
 581 SCM_DEFINE (scm_vm_ip, "vm:ip", 1, 0, 0,
 582             (SCM vm),
 583             "")
 584 #define FUNC_NAME s_scm_vm_ip
 585 {
 586   SCM_VALIDATE_VM (1, vm);
 587   return scm_from_ulong ((unsigned long) SCM_VM_DATA (vm)->ip);
 588 }
 589 #undef FUNC_NAME
 590
 591 SCM_DEFINE (scm_vm_sp, "vm:sp", 1, 0, 0,
 592             (SCM vm),
 593             "")
 594 #define FUNC_NAME s_scm_vm_sp
 595 {
 596   SCM_VALIDATE_VM (1, vm);
 597   return scm_from_ulong ((unsigned long) SCM_VM_DATA (vm)->sp);
 598 }
 599 #undef FUNC_NAME
 600
 601 SCM_DEFINE (scm_vm_fp, "vm:fp", 1, 0, 0,
 602             (SCM vm),
 603             "")
 604 #define FUNC_NAME s_scm_vm_fp
 605 {
 606   SCM_VALIDATE_VM (1, vm);
 607   return scm_from_ulong ((unsigned long) SCM_VM_DATA (vm)->fp);
 608 }
 609 #undef FUNC_NAME
 610
 611 #define VM_DEFINE_HOOK(n)                               \
 612 {                                                       \
 613   struct scm_vm *vp;                                    \
 614   SCM_VALIDATE_VM (1, vm);                              \
 615   vp = SCM_VM_DATA (vm);                                \
 616   if (scm_is_false (vp->hooks[n]))                      \
 617     vp->hooks[n] = scm_make_hook (SCM_I_MAKINUM (1));   \
 618   return vp->hooks[n];                                  \
 619 }
 620
 621 SCM_DEFINE (scm_vm_boot_hook, "vm-boot-hook", 1, 0, 0,
 622             (SCM vm),
 623             "")
 624 #define FUNC_NAME s_scm_vm_boot_hook
 625 {
 626   VM_DEFINE_HOOK (SCM_VM_BOOT_HOOK);
 627 }
 628 #undef FUNC_NAME
 629
 630 SCM_DEFINE (scm_vm_halt_hook, "vm-halt-hook", 1, 0, 0,
 631             (SCM vm),
 632             "")
 633 #define FUNC_NAME s_scm_vm_halt_hook
 634 {
 635   VM_DEFINE_HOOK (SCM_VM_HALT_HOOK);
 636 }
 637 #undef FUNC_NAME
 638
 639 SCM_DEFINE (scm_vm_next_hook, "vm-next-hook", 1, 0, 0,
 640             (SCM vm),
 641             "")
 642 #define FUNC_NAME s_scm_vm_next_hook
 643 {
 644   VM_DEFINE_HOOK (SCM_VM_NEXT_HOOK);
 645 }
 646 #undef FUNC_NAME
 647
 648 SCM_DEFINE (scm_vm_break_hook, "vm-break-hook", 1, 0, 0,
 649             (SCM vm),
 650             "")
 651 #define FUNC_NAME s_scm_vm_break_hook
 652 {
 653   VM_DEFINE_HOOK (SCM_VM_BREAK_HOOK);
 654 }
 655 #undef FUNC_NAME
 656
 657 SCM_DEFINE (scm_vm_enter_hook, "vm-enter-hook", 1, 0, 0,
 658             (SCM vm),
 659             "")
 660 #define FUNC_NAME s_scm_vm_enter_hook
 661 {
 662   VM_DEFINE_HOOK (SCM_VM_ENTER_HOOK);
 663 }
 664 #undef FUNC_NAME
 665
 666 SCM_DEFINE (scm_vm_apply_hook, "vm-apply-hook", 1, 0, 0,
 667             (SCM vm),
 668             "")
 669 #define FUNC_NAME s_scm_vm_apply_hook
 670 {
 671   VM_DEFINE_HOOK (SCM_VM_APPLY_HOOK);
 672 }
 673 #undef FUNC_NAME
 674
 675 SCM_DEFINE (scm_vm_exit_hook, "vm-exit-hook", 1, 0, 0,
 676             (SCM vm),
 677             "")
 678 #define FUNC_NAME s_scm_vm_exit_hook
 679 {
 680   VM_DEFINE_HOOK (SCM_VM_EXIT_HOOK);
 681 }
 682 #undef FUNC_NAME
 683
 684 SCM_DEFINE (scm_vm_return_hook, "vm-return-hook", 1, 0, 0,
 685             (SCM vm),
 686             "")
 687 #define FUNC_NAME s_scm_vm_return_hook
 688 {
 689   VM_DEFINE_HOOK (SCM_VM_RETURN_HOOK);
 690 }
 691 #undef FUNC_NAME
 692
 693 SCM_DEFINE (scm_vm_option, "vm-option", 2, 0, 0,
 694             (SCM vm, SCM key),
 695             "")
 696 #define FUNC_NAME s_scm_vm_option
 697 {
 698   SCM_VALIDATE_VM (1, vm);
 699   return scm_assq_ref (SCM_VM_DATA (vm)->options, key);
 700 }
 701 #undef FUNC_NAME
 702
 703 SCM_DEFINE (scm_set_vm_option_x, "set-vm-option!", 3, 0, 0,
 704             (SCM vm, SCM key, SCM val),
 705             "")
 706 #define FUNC_NAME s_scm_set_vm_option_x
 707 {
 708   SCM_VALIDATE_VM (1, vm);
 709   SCM_VM_DATA (vm)->options
 710     = scm_assq_set_x (SCM_VM_DATA (vm)->options, key, val);
 711   return SCM_UNSPECIFIED;
 712 }
 713 #undef FUNC_NAME
 714
 715 SCM_DEFINE (scm_vm_trace_level, "vm-trace-level", 1, 0, 0,
 716             (SCM vm),
 717             "")
 718 #define FUNC_NAME s_scm_vm_trace_level
 719 {
 720   SCM_VALIDATE_VM (1, vm);
 721   return scm_from_int (SCM_VM_DATA (vm)->trace_level);
 722 }
 723 #undef FUNC_NAME
 724
 725 SCM_DEFINE (scm_set_vm_trace_level_x, "set-vm-trace-level!", 2, 0, 0,
 726             (SCM vm, SCM level),
 727             "")
 728 #define FUNC_NAME s_scm_set_vm_trace_level_x
 729 {
 730   SCM_VALIDATE_VM (1, vm);
 731   SCM_VM_DATA (vm)->trace_level = scm_to_int (level);
 732   return SCM_UNSPECIFIED;
 733 }
 734 #undef FUNC_NAME
 735
 736 \f
 737 /*
 738  * Initialize
 739  */
 740
 741 SCM scm_load_compiled_with_vm (SCM file)
 742 {
 743   SCM program = scm_make_program (scm_load_objcode (file),
 744                                   SCM_BOOL_F, SCM_BOOL_F);
 745
 746   return scm_c_vm_run (scm_the_vm (), program, NULL, 0);
 747 }
 748
 749 void
 750 scm_bootstrap_vm (void)
 751 {
 752   scm_c_register_extension ("libguile", "scm_init_vm",
 753                             (scm_t_extension_init_func)scm_init_vm, NULL);
 754
 755   sym_vm_run = scm_from_locale_string ("vm-run");
 756   sym_vm_error = scm_from_locale_string ("vm-error");
 757   sym_keyword_argument_error = scm_from_locale_string ("keyword-argument-error");
 758   sym_debug = scm_from_locale_string ("debug");
 759
 760 #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
 761   vm_stack_gc_kind =
 762     GC_new_kind (GC_new_free_list (),
 763                  GC_MAKE_PROC (GC_new_proc (vm_stack_mark), 0),
 764                  0, 1);
 765
 766 #endif
 767 }
 768
 769 void
 770 scm_init_vm (void)
 771 {
 772 #ifndef SCM_MAGIC_SNARFER
 773 #include "libguile/vm.x"
 774 #endif
 775 }
 776
 777 /*
 778   Local Variables:
 779   c-file-style: "gnu"
 780   End:
 781 */