libguile/vm.c

   1 /* Copyright (C) 2001, 2009, 2010, 2011, 2012 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 <alignof.h>
  26 #include <string.h>
  27 #include <stdint.h>
  28
  29 #include "libguile/bdw-gc.h"
  30 #include <gc/gc_mark.h>
  31
  32 #include "_scm.h"
  33 #include "control.h"
  34 #include "frames.h"
  35 #include "instructions.h"
  36 #include "objcodes.h"
  37 #include "programs.h"
  38 #include "vm.h"
  39
  40 static int vm_default_engine = SCM_VM_REGULAR_ENGINE;
  41
  42 /* Unfortunately we can't snarf these: snarfed things are only loaded up from
  43    (system vm vm), which might not be loaded before an error happens. */
  44 static SCM sym_vm_run;
  45 static SCM sym_vm_error;
  46 static SCM sym_keyword_argument_error;
  47 static SCM sym_regular;
  48 static SCM sym_debug;
  49
  50 /* The VM has a number of internal assertions that shouldn't normally be
  51    necessary, but might be if you think you found a bug in the VM. */
  52 #define VM_ENABLE_ASSERTIONS
  53
  54 /* We can add a mode that ensures that all stack items above the stack pointer
  55    are NULL. This is useful for checking the internal consistency of the VM's
  56    assumptions and its operators, but isn't necessary for normal operation. It
  57    will ensure that assertions are enabled. Slows down the VM by about 30%. */
  58 /* NB! If you enable this, search for NULLING in throw.c */
  59 /* #define VM_ENABLE_STACK_NULLING */
  60
  61 /* #define VM_ENABLE_PARANOID_ASSERTIONS */
  62
  63 #if defined (VM_ENABLE_STACK_NULLING) && !defined (VM_ENABLE_ASSERTIONS)
  64 #define VM_ENABLE_ASSERTIONS
  65 #endif
  66
  67 /* When defined, arrange so that the GC doesn't scan the VM stack beyond its
  68    current SP.  This should help avoid excess data retention.  See
  69    http://thread.gmane.org/gmane.comp.programming.garbage-collection.boehmgc/3001
  70    for a discussion.  */
  71 #define VM_ENABLE_PRECISE_STACK_GC_SCAN
  72
  73 /* Size in SCM objects of the stack reserve.  The reserve is used to run
  74    exception handling code in case of a VM stack overflow.  */
  75 #define VM_STACK_RESERVE_SIZE  512
  76
  77
  78 \f
  79 /*
  80  * VM Continuation
  81  */
  82
  83 void
  84 scm_i_vm_cont_print (SCM x, SCM port, scm_print_state *pstate)
  85 {
  86   scm_puts_unlocked ("#<vm-continuation ", port);
  87   scm_uintprint (SCM_UNPACK (x), 16, port);
  88   scm_puts_unlocked (">", port);
  89 }
  90
  91 /* In theory, a number of vm instances can be active in the call trace, and we
  92    only want to reify the continuations of those in the current continuation
  93    root. I don't see a nice way to do this -- ideally it would involve dynwinds,
  94    and previous values of the *the-vm* fluid within the current continuation
  95    root. But we don't have access to continuation roots in the dynwind stack.
  96    So, just punt for now, we just capture the continuation for the current VM.
  97
  98    While I'm on the topic, ideally we could avoid copying the C stack if the
  99    continuation root is inside VM code, and call/cc was invoked within that same
 100    call to vm_run; but that's currently not implemented.
 101  */
 102 SCM
 103 scm_i_vm_capture_stack (SCM *stack_base, SCM *fp, SCM *sp, scm_t_uint8 *ra,
 104                         scm_t_uint8 *mvra, scm_t_dynstack *dynstack,
 105                         scm_t_uint32 flags)
 106 {
 107   struct scm_vm_cont *p;
 108
 109   p = scm_gc_malloc (sizeof (*p), "capture_vm_cont");
 110   p->stack_size = sp - stack_base + 1;
 111   p->stack_base = scm_gc_malloc (p->stack_size * sizeof (SCM),
 112                                  "capture_vm_cont");
 113 #if defined(VM_ENABLE_STACK_NULLING) && 0
 114   /* Tail continuations leave their frame on the stack for subsequent
 115      application, but don't capture the frame -- so there are some elements on
 116      the stack then, and this check doesn't work, so disable it for now. */
 117   if (sp >= vp->stack_base)
 118     if (!vp->sp[0] || vp->sp[1])
 119       abort ();
 120   memset (p->stack_base, 0, p->stack_size * sizeof (SCM));
 121 #endif
 122   p->ra = ra;
 123   p->mvra = mvra;
 124   p->sp = sp;
 125   p->fp = fp;
 126   memcpy (p->stack_base, stack_base, (sp + 1 - stack_base) * sizeof (SCM));
 127   p->reloc = p->stack_base - stack_base;
 128   p->dynstack = dynstack;
 129   p->flags = flags;
 130   return scm_cell (scm_tc7_vm_cont, (scm_t_bits)p);
 131 }
 132
 133 static void
 134 vm_return_to_continuation (SCM vm, SCM cont, size_t n, SCM *argv)
 135 {
 136   struct scm_vm *vp;
 137   struct scm_vm_cont *cp;
 138   SCM *argv_copy;
 139
 140   argv_copy = alloca (n * sizeof(SCM));
 141   memcpy (argv_copy, argv, n * sizeof(SCM));
 142
 143   vp = SCM_VM_DATA (vm);
 144   cp = SCM_VM_CONT_DATA (cont);
 145
 146   if (n == 0 && !cp->mvra)
 147     scm_misc_error (NULL, "Too few values returned to continuation",
 148                     SCM_EOL);
 149
 150   if (vp->stack_size < cp->stack_size + n + 1)
 151     scm_misc_error ("vm-engine", "not enough space to reinstate continuation",
 152                     scm_list_2 (vm, cont));
 153
 154 #ifdef VM_ENABLE_STACK_NULLING
 155   {
 156     scm_t_ptrdiff nzero = (vp->sp - cp->sp);
 157     if (nzero > 0)
 158       memset (vp->stack_base + cp->stack_size, 0, nzero * sizeof (SCM));
 159     /* actually nzero should always be negative, because vm_reset_stack will
 160        unwind the stack to some point *below* this continuation */
 161   }
 162 #endif
 163   vp->sp = cp->sp;
 164   vp->fp = cp->fp;
 165   memcpy (vp->stack_base, cp->stack_base, cp->stack_size * sizeof (SCM));
 166
 167   if (n == 1 || !cp->mvra)
 168     {
 169       vp->ip = cp->ra;
 170       vp->sp++;
 171       *vp->sp = argv_copy[0];
 172     }
 173   else
 174     {
 175       size_t i;
 176       for (i = 0; i < n; i++)
 177         {
 178           vp->sp++;
 179           *vp->sp = argv_copy[i];
 180         }
 181       vp->sp++;
 182       *vp->sp = scm_from_size_t (n);
 183       vp->ip = cp->mvra;
 184     }
 185 }
 186
 187 SCM
 188 scm_i_capture_current_stack (void)
 189 {
 190   scm_i_thread *thread;
 191   SCM vm;
 192   struct scm_vm *vp;
 193
 194   thread = SCM_I_CURRENT_THREAD;
 195   vm = scm_the_vm ();
 196   vp = SCM_VM_DATA (vm);
 197
 198   return scm_i_vm_capture_stack (vp->stack_base, vp->fp, vp->sp, vp->ip, NULL,
 199                                  scm_dynstack_capture_all (&thread->dynstack),
 200                                  0);
 201 }
 202
 203 static void
 204 vm_dispatch_hook (SCM vm, int hook_num)
 205 {
 206   struct scm_vm *vp;
 207   SCM hook;
 208   struct scm_frame c_frame;
 209   scm_t_cell *frame;
 210   SCM args[1];
 211   int saved_trace_level;
 212
 213   vp = SCM_VM_DATA (vm);
 214   hook = vp->hooks[hook_num];
 215
 216   if (SCM_LIKELY (scm_is_false (hook))
 217       || scm_is_null (SCM_HOOK_PROCEDURES (hook)))
 218     return;
 219
 220   saved_trace_level = vp->trace_level;
 221   vp->trace_level = 0;
 222
 223   /* Allocate a frame object on the stack.  This is more efficient than calling
 224      `scm_c_make_frame ()' to allocate on the heap, but it forces hooks to not
 225      capture frame objects.
 226
 227      At the same time, procedures such as `frame-procedure' make sense only
 228      while the stack frame represented by the frame object is visible, so it
 229      seems reasonable to limit the lifetime of frame objects.  */
 230
 231   c_frame.stack_holder = vm;
 232   c_frame.fp = vp->fp;
 233   c_frame.sp = vp->sp;
 234   c_frame.ip = vp->ip;
 235   c_frame.offset = 0;
 236
 237   /* Arrange for FRAME to be 8-byte aligned, like any other cell.  */
 238   frame = alloca (sizeof (*frame) + 8);
 239   frame = (scm_t_cell *) ROUND_UP ((scm_t_uintptr) frame, 8UL);
 240
 241   frame->word_0 = SCM_PACK (scm_tc7_frame);
 242   frame->word_1 = SCM_PACK_POINTER (&c_frame);
 243   args[0] = SCM_PACK_POINTER (frame);
 244
 245   scm_c_run_hookn (hook, args, 1);
 246
 247   vp->trace_level = saved_trace_level;
 248 }
 249
 250 static void
 251 vm_abort (SCM vm, size_t n, scm_i_jmp_buf *current_registers) SCM_NORETURN;
 252
 253 static void
 254 vm_abort (SCM vm, size_t n, scm_i_jmp_buf *current_registers)
 255 {
 256   size_t i;
 257   ssize_t tail_len;
 258   SCM tag, tail, *argv;
 259
 260   /* FIXME: VM_ENABLE_STACK_NULLING */
 261   tail = *(SCM_VM_DATA (vm)->sp--);
 262   /* NULLSTACK (1) */
 263   tail_len = scm_ilength (tail);
 264   if (tail_len < 0)
 265     scm_misc_error ("vm-engine", "tail values to abort should be a list",
 266                     scm_list_1 (tail));
 267
 268   tag = SCM_VM_DATA (vm)->sp[-n];
 269   argv = alloca ((n + tail_len) * sizeof (SCM));
 270   for (i = 0; i < n; i++)
 271     argv[i] = SCM_VM_DATA (vm)->sp[-(n-1-i)];
 272   for (; i < n + tail_len; i++, tail = scm_cdr (tail))
 273     argv[i] = scm_car (tail);
 274   /* NULLSTACK (n + 1) */
 275   SCM_VM_DATA (vm)->sp -= n + 1;
 276
 277   scm_c_abort (vm, tag, n + tail_len, argv, current_registers);
 278 }
 279
 280 static void
 281 vm_reinstate_partial_continuation (SCM vm, SCM cont, size_t n, SCM *argv,
 282                                    scm_t_dynstack *dynstack,
 283                                    scm_i_jmp_buf *registers)
 284 {
 285   struct scm_vm *vp;
 286   struct scm_vm_cont *cp;
 287   SCM *argv_copy, *base;
 288   scm_t_ptrdiff reloc;
 289   size_t i;
 290
 291   argv_copy = alloca (n * sizeof(SCM));
 292   memcpy (argv_copy, argv, n * sizeof(SCM));
 293
 294   vp = SCM_VM_DATA (vm);
 295   cp = SCM_VM_CONT_DATA (cont);
 296   base = SCM_FRAME_UPPER_ADDRESS (vp->fp) + 1;
 297   reloc = cp->reloc + (base - cp->stack_base);
 298
 299 #define RELOC(scm_p)                                            \
 300   (((SCM *) (scm_p)) + reloc)
 301
 302   if ((base - vp->stack_base) + cp->stack_size + n + 1 > vp->stack_size)
 303     scm_misc_error ("vm-engine",
 304                     "not enough space to instate partial continuation",
 305                     scm_list_2 (vm, cont));
 306
 307   memcpy (base, cp->stack_base, cp->stack_size * sizeof (SCM));
 308
 309   /* now relocate frame pointers */
 310   {
 311     SCM *fp;
 312     for (fp = RELOC (cp->fp);
 313          SCM_FRAME_LOWER_ADDRESS (fp) > base;
 314          fp = SCM_FRAME_DYNAMIC_LINK (fp))
 315       SCM_FRAME_SET_DYNAMIC_LINK (fp, RELOC (SCM_FRAME_DYNAMIC_LINK (fp)));
 316   }
 317
 318   vp->sp = base - 1 + cp->stack_size;
 319   vp->fp = RELOC (cp->fp);
 320   vp->ip = cp->mvra;
 321
 322   /* now push args. ip is in a MV context. */
 323   for (i = 0; i < n; i++)
 324     {
 325       vp->sp++;
 326       *vp->sp = argv_copy[i];
 327     }
 328   vp->sp++;
 329   *vp->sp = scm_from_size_t (n);
 330
 331   /* The prompt captured a slice of the dynamic stack.  Here we wind
 332      those entries onto the current thread's stack.  We also have to
 333      relocate any prompts that we see along the way.  */
 334   {
 335     scm_t_bits *walk;
 336
 337     for (walk = SCM_DYNSTACK_FIRST (cp->dynstack);
 338          SCM_DYNSTACK_TAG (walk);
 339          walk = SCM_DYNSTACK_NEXT (walk))
 340       {
 341         scm_t_bits tag = SCM_DYNSTACK_TAG (walk);
 342
 343         if (SCM_DYNSTACK_TAG_TYPE (tag) == SCM_DYNSTACK_TYPE_PROMPT)
 344           scm_dynstack_wind_prompt (dynstack, walk, reloc, registers);
 345         else
 346           scm_dynstack_wind_1 (dynstack, walk);
 347       }
 348   }
 349 #undef RELOC
 350 }
 351
 352 \f
 353 /*
 354  * VM Internal functions
 355  */
 356
 357 void
 358 scm_i_vm_print (SCM x, SCM port, scm_print_state *pstate)
 359 {
 360   const struct scm_vm *vm;
 361
 362   vm = SCM_VM_DATA (x);
 363
 364   scm_puts_unlocked ("#<vm ", port);
 365   switch (vm->engine)
 366     {
 367     case SCM_VM_REGULAR_ENGINE:
 368       scm_puts_unlocked ("regular-engine ", port);
 369       break;
 370
 371     case SCM_VM_DEBUG_ENGINE:
 372       scm_puts_unlocked ("debug-engine ", port);
 373       break;
 374
 375     default:
 376       scm_puts_unlocked ("unknown-engine ", port);
 377     }
 378   scm_uintprint (SCM_UNPACK (x), 16, port);
 379   scm_puts_unlocked (">", port);
 380 }
 381
 382 static SCM
 383 really_make_boot_program (long nargs)
 384 {
 385   SCM u8vec;
 386   scm_t_uint8 text[] = { scm_op_mv_call, 0, 0, 0, 1,
 387                          scm_op_make_int8_1, scm_op_halt };
 388   struct scm_objcode *bp;
 389   SCM ret;
 390
 391   if (SCM_UNLIKELY (nargs > 255 || nargs < 0))
 392     scm_misc_error ("vm-engine", "too many args when making boot procedure",
 393                     scm_list_1 (scm_from_long (nargs)));
 394
 395   text[1] = (scm_t_uint8)nargs;
 396
 397   bp = scm_gc_malloc_pointerless (sizeof (struct scm_objcode) + sizeof (text),
 398                                   "boot-program");
 399   memcpy (SCM_C_OBJCODE_BASE (bp), text, sizeof (text));
 400   bp->len = sizeof(text);
 401   bp->metalen = 0;
 402
 403   u8vec = scm_c_take_gc_bytevector ((scm_t_int8*)bp,
 404                                     sizeof (struct scm_objcode) + sizeof (text),
 405                                     SCM_BOOL_F);
 406   ret = scm_make_program (scm_bytecode_to_native_objcode (u8vec),
 407                           SCM_BOOL_F, SCM_BOOL_F);
 408   SCM_SET_CELL_WORD_0 (ret, SCM_CELL_WORD_0 (ret) | SCM_F_PROGRAM_IS_BOOT);
 409
 410   return ret;
 411 }
 412 #define NUM_BOOT_PROGS 8
 413 static SCM
 414 vm_make_boot_program (long nargs)
 415 {
 416   static SCM programs[NUM_BOOT_PROGS] = { SCM_BOOL_F, };
 417
 418   if (SCM_UNLIKELY (scm_is_false (programs[0])))
 419     {
 420       int i;
 421       for (i = 0; i < NUM_BOOT_PROGS; i++)
 422         programs[i] = really_make_boot_program (i);
 423     }
 424
 425   if (SCM_LIKELY (nargs < NUM_BOOT_PROGS))
 426     return programs[nargs];
 427   else
 428     return really_make_boot_program (nargs);
 429 }
 430
 431 \f
 432 /*
 433  * VM
 434  */
 435
 436 static SCM
 437 resolve_variable (SCM what, SCM program_module)
 438 {
 439   if (SCM_LIKELY (scm_is_symbol (what)))
 440     {
 441       if (SCM_LIKELY (scm_module_system_booted_p
 442                       && scm_is_true (program_module)))
 443         /* might longjmp */
 444         return scm_module_lookup (program_module, what);
 445       else
 446         {
 447           SCM v = scm_sym2var (what, SCM_BOOL_F, SCM_BOOL_F);
 448           if (scm_is_false (v))
 449             scm_misc_error (NULL, "unbound variable: ~S", scm_list_1 (what));
 450           else
 451             return v;
 452         }
 453     }
 454   else
 455     {
 456       SCM mod;
 457       /* compilation of @ or @@
 458          `what' is a three-element list: (MODNAME SYM INTERFACE?)
 459          INTERFACE? is #t if we compiled @ or #f if we compiled @@
 460       */
 461       mod = scm_resolve_module (SCM_CAR (what));
 462       if (scm_is_true (SCM_CADDR (what)))
 463         mod = scm_module_public_interface (mod);
 464       if (scm_is_false (mod))
 465         scm_misc_error (NULL, "no such module: ~S",
 466                         scm_list_1 (SCM_CAR (what)));
 467       /* might longjmp */
 468       return scm_module_lookup (mod, SCM_CADR (what));
 469     }
 470 }
 471
 472 #define VM_DEFAULT_STACK_SIZE   (64 * 1024)
 473
 474 #define VM_NAME   vm_regular_engine
 475 #define FUNC_NAME "vm-regular-engine"
 476 #define VM_ENGINE SCM_VM_REGULAR_ENGINE
 477 #include "vm-engine.c"
 478 #undef VM_NAME
 479 #undef FUNC_NAME
 480 #undef VM_ENGINE
 481
 482 #define VM_NAME   vm_debug_engine
 483 #define FUNC_NAME "vm-debug-engine"
 484 #define VM_ENGINE SCM_VM_DEBUG_ENGINE
 485 #include "vm-engine.c"
 486 #undef VM_NAME
 487 #undef FUNC_NAME
 488 #undef VM_ENGINE
 489
 490 static const scm_t_vm_engine vm_engines[] =
 491   { vm_regular_engine, vm_debug_engine };
 492
 493 #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
 494
 495 /* The GC "kind" for the VM stack.  */
 496 static int vm_stack_gc_kind;
 497
 498 #endif
 499
 500 static SCM
 501 make_vm (void)
 502 #define FUNC_NAME "make_vm"
 503 {
 504   int i;
 505   struct scm_vm *vp;
 506
 507   vp = scm_gc_malloc (sizeof (struct scm_vm), "vm");
 508
 509   vp->stack_size  = VM_DEFAULT_STACK_SIZE;
 510
 511 #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
 512   vp->stack_base = (SCM *)
 513     GC_generic_malloc (vp->stack_size * sizeof (SCM), vm_stack_gc_kind);
 514
 515   /* Keep a pointer to VP so that `vm_stack_mark ()' can know what the stack
 516      top is.  */
 517   *vp->stack_base = SCM_PACK_POINTER (vp);
 518   vp->stack_base++;
 519   vp->stack_size--;
 520 #else
 521   vp->stack_base  = scm_gc_malloc (vp->stack_size * sizeof (SCM),
 522                                    "stack-base");
 523 #endif
 524
 525 #ifdef VM_ENABLE_STACK_NULLING
 526   memset (vp->stack_base, 0, vp->stack_size * sizeof (SCM));
 527 #endif
 528   vp->stack_limit = vp->stack_base + vp->stack_size - VM_STACK_RESERVE_SIZE;
 529   vp->ip          = NULL;
 530   vp->sp          = vp->stack_base - 1;
 531   vp->fp          = NULL;
 532   vp->engine      = vm_default_engine;
 533   vp->trace_level = 0;
 534   for (i = 0; i < SCM_VM_NUM_HOOKS; i++)
 535     vp->hooks[i] = SCM_BOOL_F;
 536   return scm_cell (scm_tc7_vm, (scm_t_bits)vp);
 537 }
 538 #undef FUNC_NAME
 539
 540 #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
 541
 542 /* Mark the VM stack region between its base and its current top.  */
 543 static struct GC_ms_entry *
 544 vm_stack_mark (GC_word *addr, struct GC_ms_entry *mark_stack_ptr,
 545                struct GC_ms_entry *mark_stack_limit, GC_word env)
 546 {
 547   GC_word *word;
 548   const struct scm_vm *vm;
 549
 550   /* The first word of the VM stack should contain a pointer to the
 551      corresponding VM.  */
 552   vm = * ((struct scm_vm **) addr);
 553
 554   if (vm == NULL
 555       || (SCM *) addr != vm->stack_base - 1)
 556     /* ADDR must be a pointer to a free-list element, which we must ignore
 557        (see warning in <gc/gc_mark.h>).  */
 558     return mark_stack_ptr;
 559
 560   for (word = (GC_word *) vm->stack_base; word <= (GC_word *) vm->sp; word++)
 561     mark_stack_ptr = GC_MARK_AND_PUSH ((* (GC_word **) word),
 562                                        mark_stack_ptr, mark_stack_limit,
 563                                        NULL);
 564
 565   return mark_stack_ptr;
 566 }
 567
 568 #endif /* VM_ENABLE_PRECISE_STACK_GC_SCAN */
 569
 570
 571 SCM
 572 scm_c_vm_run (SCM vm, SCM program, SCM *argv, int nargs)
 573 {
 574   struct scm_vm *vp = SCM_VM_DATA (vm);
 575   SCM_CHECK_STACK;
 576   return vm_engines[vp->engine](vm, program, argv, nargs);
 577 }
 578
 579 /* Scheme interface */
 580
 581 SCM_DEFINE (scm_the_vm, "the-vm", 0, 0, 0,
 582             (void),
 583             "Return the current thread's VM.")
 584 #define FUNC_NAME s_scm_the_vm
 585 {
 586   scm_i_thread *t = SCM_I_CURRENT_THREAD;
 587
 588   if (SCM_UNLIKELY (scm_is_false (t->vm)))
 589     t->vm = make_vm ();
 590
 591   return t->vm;
 592 }
 593 #undef FUNC_NAME
 594
 595
 596 SCM_DEFINE (scm_vm_p, "vm?", 1, 0, 0,
 597             (SCM obj),
 598             "")
 599 #define FUNC_NAME s_scm_vm_p
 600 {
 601   return scm_from_bool (SCM_VM_P (obj));
 602 }
 603 #undef FUNC_NAME
 604
 605 SCM_DEFINE (scm_make_vm, "make-vm", 0, 0, 0,
 606             (void),
 607             "")
 608 #define FUNC_NAME s_scm_make_vm,
 609 {
 610   return make_vm ();
 611 }
 612 #undef FUNC_NAME
 613
 614 SCM_DEFINE (scm_vm_ip, "vm:ip", 1, 0, 0,
 615             (SCM vm),
 616             "")
 617 #define FUNC_NAME s_scm_vm_ip
 618 {
 619   SCM_VALIDATE_VM (1, vm);
 620   return scm_from_unsigned_integer ((scm_t_bits) SCM_VM_DATA (vm)->ip);
 621 }
 622 #undef FUNC_NAME
 623
 624 SCM_DEFINE (scm_vm_sp, "vm:sp", 1, 0, 0,
 625             (SCM vm),
 626             "")
 627 #define FUNC_NAME s_scm_vm_sp
 628 {
 629   SCM_VALIDATE_VM (1, vm);
 630   return scm_from_unsigned_integer ((scm_t_bits) SCM_VM_DATA (vm)->sp);
 631 }
 632 #undef FUNC_NAME
 633
 634 SCM_DEFINE (scm_vm_fp, "vm:fp", 1, 0, 0,
 635             (SCM vm),
 636             "")
 637 #define FUNC_NAME s_scm_vm_fp
 638 {
 639   SCM_VALIDATE_VM (1, vm);
 640   return scm_from_unsigned_integer ((scm_t_bits) SCM_VM_DATA (vm)->fp);
 641 }
 642 #undef FUNC_NAME
 643
 644 #define VM_DEFINE_HOOK(n)                               \
 645 {                                                       \
 646   struct scm_vm *vp;                                    \
 647   SCM_VALIDATE_VM (1, vm);                              \
 648   vp = SCM_VM_DATA (vm);                                \
 649   if (scm_is_false (vp->hooks[n]))                      \
 650     vp->hooks[n] = scm_make_hook (SCM_I_MAKINUM (1));   \
 651   return vp->hooks[n];                                  \
 652 }
 653
 654 SCM_DEFINE (scm_vm_apply_hook, "vm-apply-hook", 1, 0, 0,
 655             (SCM vm),
 656             "")
 657 #define FUNC_NAME s_scm_vm_apply_hook
 658 {
 659   VM_DEFINE_HOOK (SCM_VM_APPLY_HOOK);
 660 }
 661 #undef FUNC_NAME
 662
 663 SCM_DEFINE (scm_vm_push_continuation_hook, "vm-push-continuation-hook", 1, 0, 0,
 664             (SCM vm),
 665             "")
 666 #define FUNC_NAME s_scm_vm_push_continuation_hook
 667 {
 668   VM_DEFINE_HOOK (SCM_VM_PUSH_CONTINUATION_HOOK);
 669 }
 670 #undef FUNC_NAME
 671
 672 SCM_DEFINE (scm_vm_pop_continuation_hook, "vm-pop-continuation-hook", 1, 0, 0,
 673             (SCM vm),
 674             "")
 675 #define FUNC_NAME s_scm_vm_pop_continuation_hook
 676 {
 677   VM_DEFINE_HOOK (SCM_VM_POP_CONTINUATION_HOOK);
 678 }
 679 #undef FUNC_NAME
 680
 681 SCM_DEFINE (scm_vm_next_hook, "vm-next-hook", 1, 0, 0,
 682             (SCM vm),
 683             "")
 684 #define FUNC_NAME s_scm_vm_next_hook
 685 {
 686   VM_DEFINE_HOOK (SCM_VM_NEXT_HOOK);
 687 }
 688 #undef FUNC_NAME
 689
 690 SCM_DEFINE (scm_vm_abort_continuation_hook, "vm-abort-continuation-hook", 1, 0, 0,
 691             (SCM vm),
 692             "")
 693 #define FUNC_NAME s_scm_vm_abort_continuation_hook
 694 {
 695   VM_DEFINE_HOOK (SCM_VM_ABORT_CONTINUATION_HOOK);
 696 }
 697 #undef FUNC_NAME
 698
 699 SCM_DEFINE (scm_vm_restore_continuation_hook, "vm-restore-continuation-hook", 1, 0, 0,
 700             (SCM vm),
 701             "")
 702 #define FUNC_NAME s_scm_vm_restore_continuation_hook
 703 {
 704   VM_DEFINE_HOOK (SCM_VM_RESTORE_CONTINUATION_HOOK);
 705 }
 706 #undef FUNC_NAME
 707
 708 SCM_DEFINE (scm_vm_trace_level, "vm-trace-level", 1, 0, 0,
 709             (SCM vm),
 710             "")
 711 #define FUNC_NAME s_scm_vm_trace_level
 712 {
 713   SCM_VALIDATE_VM (1, vm);
 714   return scm_from_int (SCM_VM_DATA (vm)->trace_level);
 715 }
 716 #undef FUNC_NAME
 717
 718 SCM_DEFINE (scm_set_vm_trace_level_x, "set-vm-trace-level!", 2, 0, 0,
 719             (SCM vm, SCM level),
 720             "")
 721 #define FUNC_NAME s_scm_set_vm_trace_level_x
 722 {
 723   SCM_VALIDATE_VM (1, vm);
 724   SCM_VM_DATA (vm)->trace_level = scm_to_int (level);
 725   return SCM_UNSPECIFIED;
 726 }
 727 #undef FUNC_NAME
 728
 729 \f
 730 /*
 731  * VM engines
 732  */
 733
 734 static int
 735 symbol_to_vm_engine (SCM engine, const char *FUNC_NAME)
 736 {
 737   if (scm_is_eq (engine, sym_regular))
 738     return SCM_VM_REGULAR_ENGINE;
 739   else if (scm_is_eq (engine, sym_debug))
 740     return SCM_VM_DEBUG_ENGINE;
 741   else
 742     SCM_MISC_ERROR ("Unknown VM engine: ~a", scm_list_1 (engine));
 743 }
 744
 745 static SCM
 746 vm_engine_to_symbol (int engine, const char *FUNC_NAME)
 747 {
 748   switch (engine)
 749     {
 750     case SCM_VM_REGULAR_ENGINE:
 751       return sym_regular;
 752     case SCM_VM_DEBUG_ENGINE:
 753       return sym_debug;
 754     default:
 755       /* ? */
 756       SCM_MISC_ERROR ("Unknown VM engine: ~a",
 757                       scm_list_1 (scm_from_int (engine)));
 758     }
 759 }
 760
 761 SCM_DEFINE (scm_vm_engine, "vm-engine", 1, 0, 0,
 762             (SCM vm),
 763             "")
 764 #define FUNC_NAME s_scm_vm_engine
 765 {
 766   SCM_VALIDATE_VM (1, vm);
 767   return vm_engine_to_symbol (SCM_VM_DATA (vm)->engine, FUNC_NAME);
 768 }
 769 #undef FUNC_NAME
 770
 771 void
 772 scm_c_set_vm_engine_x (SCM vm, int engine)
 773 #define FUNC_NAME "set-vm-engine!"
 774 {
 775   SCM_VALIDATE_VM (1, vm);
 776
 777   if (engine < 0 || engine >= SCM_VM_NUM_ENGINES)
 778     SCM_MISC_ERROR ("Unknown VM engine: ~a",
 779                     scm_list_1 (scm_from_int (engine)));
 780
 781   SCM_VM_DATA (vm)->engine = engine;
 782 }
 783 #undef FUNC_NAME
 784
 785 SCM_DEFINE (scm_set_vm_engine_x, "set-vm-engine!", 2, 0, 0,
 786             (SCM vm, SCM engine),
 787             "")
 788 #define FUNC_NAME s_scm_set_vm_engine_x
 789 {
 790   scm_c_set_vm_engine_x (vm, symbol_to_vm_engine (engine, FUNC_NAME));
 791   return SCM_UNSPECIFIED;
 792 }
 793 #undef FUNC_NAME
 794
 795 void
 796 scm_c_set_default_vm_engine_x (int engine)
 797 #define FUNC_NAME "set-default-vm-engine!"
 798 {
 799   if (engine < 0 || engine >= SCM_VM_NUM_ENGINES)
 800     SCM_MISC_ERROR ("Unknown VM engine: ~a",
 801                     scm_list_1 (scm_from_int (engine)));
 802
 803   vm_default_engine = engine;
 804 }
 805 #undef FUNC_NAME
 806
 807 SCM_DEFINE (scm_set_default_vm_engine_x, "set-default-vm-engine!", 1, 0, 0,
 808             (SCM engine),
 809             "")
 810 #define FUNC_NAME s_scm_set_default_vm_engine_x
 811 {
 812   scm_c_set_default_vm_engine_x (symbol_to_vm_engine (engine, FUNC_NAME));
 813   return SCM_UNSPECIFIED;
 814 }
 815 #undef FUNC_NAME
 816
 817 static void reinstate_vm (SCM vm)
 818 {
 819   scm_i_thread *t = SCM_I_CURRENT_THREAD;
 820   t->vm = vm;
 821 }
 822
 823 SCM_DEFINE (scm_call_with_vm, "call-with-vm", 2, 0, 1,
 824             (SCM vm, SCM proc, SCM args),
 825             "Apply @var{proc} to @var{args} in a dynamic extent in which\n"
 826             "@var{vm} is the current VM.\n\n"
 827             "As an implementation restriction, if @var{vm} is not the same\n"
 828             "as the current thread's VM, continuations captured within the\n"
 829             "call to @var{proc} may not be reinstated once control leaves\n"
 830             "@var{proc}.")
 831 #define FUNC_NAME s_scm_call_with_vm
 832 {
 833   SCM prev_vm, ret;
 834   SCM *argv;
 835   int i, nargs;
 836   scm_t_wind_flags flags;
 837   scm_i_thread *t = SCM_I_CURRENT_THREAD;
 838
 839   SCM_VALIDATE_VM (1, vm);
 840   SCM_VALIDATE_PROC (2, proc);
 841
 842   nargs = scm_ilength (args);
 843   if (SCM_UNLIKELY (nargs < 0))
 844     scm_wrong_type_arg_msg (FUNC_NAME, 3, args, "list");
 845
 846   argv = alloca (nargs * sizeof(SCM));
 847   for (i = 0; i < nargs; i++)
 848     {
 849       argv[i] = SCM_CAR (args);
 850       args = SCM_CDR (args);
 851     }
 852
 853   prev_vm = t->vm;
 854
 855   /* Reentry can happen via invokation of a saved continuation, but
 856      continuations only save the state of the VM that they are in at
 857      capture-time, which might be different from this one.  So, in the
 858      case that the VMs are different, set up a non-rewindable frame to
 859      prevent reinstating an incomplete continuation.  */
 860   flags = scm_is_eq (prev_vm, vm) ? 0 : SCM_F_WIND_EXPLICITLY;
 861   if (flags)
 862     {
 863       scm_dynwind_begin (0);
 864       scm_dynwind_unwind_handler_with_scm (reinstate_vm, prev_vm, flags);
 865       t->vm = vm;
 866     }
 867
 868   ret = scm_c_vm_run (vm, proc, argv, nargs);
 869
 870   if (flags)
 871     scm_dynwind_end ();
 872
 873   return ret;
 874 }
 875 #undef FUNC_NAME
 876
 877 \f
 878 /*
 879  * Initialize
 880  */
 881
 882 SCM scm_load_compiled_with_vm (SCM file)
 883 {
 884   SCM program = scm_make_program (scm_load_objcode (file),
 885                                   SCM_BOOL_F, SCM_BOOL_F);
 886
 887   return scm_c_vm_run (scm_the_vm (), program, NULL, 0);
 888 }
 889
 890 void
 891 scm_bootstrap_vm (void)
 892 {
 893   scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
 894                             "scm_init_vm",
 895                             (scm_t_extension_init_func)scm_init_vm, NULL);
 896
 897   sym_vm_run = scm_from_latin1_symbol ("vm-run");
 898   sym_vm_error = scm_from_latin1_symbol ("vm-error");
 899   sym_keyword_argument_error = scm_from_latin1_symbol ("keyword-argument-error");
 900   sym_regular = scm_from_latin1_symbol ("regular");
 901   sym_debug = scm_from_latin1_symbol ("debug");
 902
 903 #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
 904   vm_stack_gc_kind =
 905     GC_new_kind (GC_new_free_list (),
 906                  GC_MAKE_PROC (GC_new_proc (vm_stack_mark), 0),
 907                  0, 1);
 908
 909 #endif
 910 }
 911
 912 void
 913 scm_init_vm (void)
 914 {
 915 #ifndef SCM_MAGIC_SNARFER
 916 #include "libguile/vm.x"
 917 #endif
 918 }
 919
 920 /*
 921   Local Variables:
 922   c-file-style: "gnu"
 923   End:
 924 */