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 vm_abort (SCM vm, size_t n, scm_t_int64 cookie) SCM_NORETURN;
 251 static void
 252 vm_abort (SCM vm, size_t n, scm_t_int64 vm_cookie)
 253 {
 254   size_t i;
 255   ssize_t tail_len;
 256   SCM tag, tail, *argv;
 257
 258   /* FIXME: VM_ENABLE_STACK_NULLING */
 259   tail = *(SCM_VM_DATA (vm)->sp--);
 260   /* NULLSTACK (1) */
 261   tail_len = scm_ilength (tail);
 262   if (tail_len < 0)
 263     scm_misc_error ("vm-engine", "tail values to abort should be a list",
 264                     scm_list_1 (tail));
 265
 266   tag = SCM_VM_DATA (vm)->sp[-n];
 267   argv = alloca ((n + tail_len) * sizeof (SCM));
 268   for (i = 0; i < n; i++)
 269     argv[i] = SCM_VM_DATA (vm)->sp[-(n-1-i)];
 270   for (; i < n + tail_len; i++, tail = scm_cdr (tail))
 271     argv[i] = scm_car (tail);
 272   /* NULLSTACK (n + 1) */
 273   SCM_VM_DATA (vm)->sp -= n + 1;
 274
 275   scm_c_abort (vm, tag, n + tail_len, argv, vm_cookie);
 276 }
 277
 278 static scm_t_ptrdiff
 279 vm_reinstate_partial_continuation (SCM vm, SCM cont,
 280                                    size_t n, SCM *argv, scm_t_int64 vm_cookie)
 281 {
 282   struct scm_vm *vp;
 283   struct scm_vm_cont *cp;
 284   SCM *argv_copy, *base;
 285   scm_t_ptrdiff reloc;
 286   size_t i;
 287
 288   argv_copy = alloca (n * sizeof(SCM));
 289   memcpy (argv_copy, argv, n * sizeof(SCM));
 290
 291   vp = SCM_VM_DATA (vm);
 292   cp = SCM_VM_CONT_DATA (cont);
 293   base = SCM_FRAME_UPPER_ADDRESS (vp->fp) + 1;
 294   reloc = cp->reloc + (base - cp->stack_base);
 295
 296 #define RELOC(scm_p)                                            \
 297   (((SCM *) (scm_p)) + reloc)
 298
 299   if ((base - vp->stack_base) + cp->stack_size + n + 1 > vp->stack_size)
 300     scm_misc_error ("vm-engine",
 301                     "not enough space to instate partial continuation",
 302                     scm_list_2 (vm, cont));
 303
 304   memcpy (base, cp->stack_base, cp->stack_size * sizeof (SCM));
 305
 306   /* now relocate frame pointers */
 307   {
 308     SCM *fp;
 309     for (fp = RELOC (cp->fp);
 310          SCM_FRAME_LOWER_ADDRESS (fp) > base;
 311          fp = SCM_FRAME_DYNAMIC_LINK (fp))
 312       SCM_FRAME_SET_DYNAMIC_LINK (fp, RELOC (SCM_FRAME_DYNAMIC_LINK (fp)));
 313   }
 314
 315   vp->sp = base - 1 + cp->stack_size;
 316   vp->fp = RELOC (cp->fp);
 317   vp->ip = cp->mvra;
 318
 319   /* now push args. ip is in a MV context. */
 320   for (i = 0; i < n; i++)
 321     {
 322       vp->sp++;
 323       *vp->sp = argv_copy[i];
 324     }
 325   vp->sp++;
 326   *vp->sp = scm_from_size_t (n);
 327
 328   /* Finally, rewind the dynamic state.  Unhappily, we have to do this
 329      in the vm_engine.  If we do it here, the stack frame will likely
 330      have been stompled by some future call out of the VM, so we will
 331      return to some other part of the VM.
 332
 333      We used to wind and relocate the prompts here, but that's bogus,
 334      because a rewinder would then be able to abort to a prompt with a
 335      stale jmpbuf.  */
 336
 337   return reloc;
 338 #undef RELOC
 339 }
 340
 341 \f
 342 /*
 343  * VM Internal functions
 344  */
 345
 346 void
 347 scm_i_vm_print (SCM x, SCM port, scm_print_state *pstate)
 348 {
 349   const struct scm_vm *vm;
 350
 351   vm = SCM_VM_DATA (x);
 352
 353   scm_puts_unlocked ("#<vm ", port);
 354   switch (vm->engine)
 355     {
 356     case SCM_VM_REGULAR_ENGINE:
 357       scm_puts_unlocked ("regular-engine ", port);
 358       break;
 359
 360     case SCM_VM_DEBUG_ENGINE:
 361       scm_puts_unlocked ("debug-engine ", port);
 362       break;
 363
 364     default:
 365       scm_puts_unlocked ("unknown-engine ", port);
 366     }
 367   scm_uintprint (SCM_UNPACK (x), 16, port);
 368   scm_puts_unlocked (">", port);
 369 }
 370
 371 static SCM
 372 really_make_boot_program (long nargs)
 373 {
 374   SCM u8vec;
 375   scm_t_uint8 text[] = { scm_op_mv_call, 0, 0, 0, 1,
 376                          scm_op_make_int8_1, scm_op_halt };
 377   struct scm_objcode *bp;
 378   SCM ret;
 379
 380   if (SCM_UNLIKELY (nargs > 255 || nargs < 0))
 381     scm_misc_error ("vm-engine", "too many args when making boot procedure",
 382                     scm_list_1 (scm_from_long (nargs)));
 383
 384   text[1] = (scm_t_uint8)nargs;
 385
 386   bp = scm_gc_malloc_pointerless (sizeof (struct scm_objcode) + sizeof (text),
 387                                   "boot-program");
 388   memcpy (SCM_C_OBJCODE_BASE (bp), text, sizeof (text));
 389   bp->len = sizeof(text);
 390   bp->metalen = 0;
 391
 392   u8vec = scm_c_take_gc_bytevector ((scm_t_int8*)bp,
 393                                     sizeof (struct scm_objcode) + sizeof (text),
 394                                     SCM_BOOL_F);
 395   ret = scm_make_program (scm_bytecode_to_native_objcode (u8vec),
 396                           SCM_BOOL_F, SCM_BOOL_F);
 397   SCM_SET_CELL_WORD_0 (ret, SCM_CELL_WORD_0 (ret) | SCM_F_PROGRAM_IS_BOOT);
 398
 399   return ret;
 400 }
 401 #define NUM_BOOT_PROGS 8
 402 static SCM
 403 vm_make_boot_program (long nargs)
 404 {
 405   static SCM programs[NUM_BOOT_PROGS] = { SCM_BOOL_F, };
 406
 407   if (SCM_UNLIKELY (scm_is_false (programs[0])))
 408     {
 409       int i;
 410       for (i = 0; i < NUM_BOOT_PROGS; i++)
 411         programs[i] = really_make_boot_program (i);
 412     }
 413
 414   if (SCM_LIKELY (nargs < NUM_BOOT_PROGS))
 415     return programs[nargs];
 416   else
 417     return really_make_boot_program (nargs);
 418 }
 419
 420 \f
 421 /*
 422  * VM
 423  */
 424
 425 static SCM
 426 resolve_variable (SCM what, SCM program_module)
 427 {
 428   if (SCM_LIKELY (scm_is_symbol (what)))
 429     {
 430       if (SCM_LIKELY (scm_module_system_booted_p
 431                       && scm_is_true (program_module)))
 432         /* might longjmp */
 433         return scm_module_lookup (program_module, what);
 434       else
 435         {
 436           SCM v = scm_sym2var (what, SCM_BOOL_F, SCM_BOOL_F);
 437           if (scm_is_false (v))
 438             scm_misc_error (NULL, "unbound variable: ~S", scm_list_1 (what));
 439           else
 440             return v;
 441         }
 442     }
 443   else
 444     {
 445       SCM mod;
 446       /* compilation of @ or @@
 447          `what' is a three-element list: (MODNAME SYM INTERFACE?)
 448          INTERFACE? is #t if we compiled @ or #f if we compiled @@
 449       */
 450       mod = scm_resolve_module (SCM_CAR (what));
 451       if (scm_is_true (SCM_CADDR (what)))
 452         mod = scm_module_public_interface (mod);
 453       if (scm_is_false (mod))
 454         scm_misc_error (NULL, "no such module: ~S",
 455                         scm_list_1 (SCM_CAR (what)));
 456       /* might longjmp */
 457       return scm_module_lookup (mod, SCM_CADR (what));
 458     }
 459 }
 460
 461 #define VM_DEFAULT_STACK_SIZE   (64 * 1024)
 462
 463 #define VM_NAME   vm_regular_engine
 464 #define FUNC_NAME "vm-regular-engine"
 465 #define VM_ENGINE SCM_VM_REGULAR_ENGINE
 466 #include "vm-engine.c"
 467 #undef VM_NAME
 468 #undef FUNC_NAME
 469 #undef VM_ENGINE
 470
 471 #define VM_NAME   vm_debug_engine
 472 #define FUNC_NAME "vm-debug-engine"
 473 #define VM_ENGINE SCM_VM_DEBUG_ENGINE
 474 #include "vm-engine.c"
 475 #undef VM_NAME
 476 #undef FUNC_NAME
 477 #undef VM_ENGINE
 478
 479 static const scm_t_vm_engine vm_engines[] =
 480   { vm_regular_engine, vm_debug_engine };
 481
 482 #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
 483
 484 /* The GC "kind" for the VM stack.  */
 485 static int vm_stack_gc_kind;
 486
 487 #endif
 488
 489 static SCM
 490 make_vm (void)
 491 #define FUNC_NAME "make_vm"
 492 {
 493   int i;
 494   struct scm_vm *vp;
 495
 496   vp = scm_gc_malloc (sizeof (struct scm_vm), "vm");
 497
 498   vp->stack_size  = VM_DEFAULT_STACK_SIZE;
 499
 500 #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
 501   vp->stack_base = (SCM *)
 502     GC_generic_malloc (vp->stack_size * sizeof (SCM), vm_stack_gc_kind);
 503
 504   /* Keep a pointer to VP so that `vm_stack_mark ()' can know what the stack
 505      top is.  */
 506   *vp->stack_base = SCM_PACK_POINTER (vp);
 507   vp->stack_base++;
 508   vp->stack_size--;
 509 #else
 510   vp->stack_base  = scm_gc_malloc (vp->stack_size * sizeof (SCM),
 511                                    "stack-base");
 512 #endif
 513
 514 #ifdef VM_ENABLE_STACK_NULLING
 515   memset (vp->stack_base, 0, vp->stack_size * sizeof (SCM));
 516 #endif
 517   vp->stack_limit = vp->stack_base + vp->stack_size - VM_STACK_RESERVE_SIZE;
 518   vp->ip          = NULL;
 519   vp->sp          = vp->stack_base - 1;
 520   vp->fp          = NULL;
 521   vp->engine      = vm_default_engine;
 522   vp->trace_level = 0;
 523   for (i = 0; i < SCM_VM_NUM_HOOKS; i++)
 524     vp->hooks[i] = SCM_BOOL_F;
 525   vp->cookie = 0;
 526   return scm_cell (scm_tc7_vm, (scm_t_bits)vp);
 527 }
 528 #undef FUNC_NAME
 529
 530 #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
 531
 532 /* Mark the VM stack region between its base and its current top.  */
 533 static struct GC_ms_entry *
 534 vm_stack_mark (GC_word *addr, struct GC_ms_entry *mark_stack_ptr,
 535                struct GC_ms_entry *mark_stack_limit, GC_word env)
 536 {
 537   GC_word *word;
 538   const struct scm_vm *vm;
 539
 540   /* The first word of the VM stack should contain a pointer to the
 541      corresponding VM.  */
 542   vm = * ((struct scm_vm **) addr);
 543
 544   if (vm == NULL
 545       || (SCM *) addr != vm->stack_base - 1)
 546     /* ADDR must be a pointer to a free-list element, which we must ignore
 547        (see warning in <gc/gc_mark.h>).  */
 548     return mark_stack_ptr;
 549
 550   for (word = (GC_word *) vm->stack_base; word <= (GC_word *) vm->sp; word++)
 551     mark_stack_ptr = GC_MARK_AND_PUSH ((* (GC_word **) word),
 552                                        mark_stack_ptr, mark_stack_limit,
 553                                        NULL);
 554
 555   return mark_stack_ptr;
 556 }
 557
 558 #endif /* VM_ENABLE_PRECISE_STACK_GC_SCAN */
 559
 560
 561 SCM
 562 scm_c_vm_run (SCM vm, SCM program, SCM *argv, int nargs)
 563 {
 564   struct scm_vm *vp = SCM_VM_DATA (vm);
 565   SCM_CHECK_STACK;
 566   return vm_engines[vp->engine](vm, program, argv, nargs);
 567 }
 568
 569 /* Scheme interface */
 570
 571 SCM_DEFINE (scm_the_vm, "the-vm", 0, 0, 0,
 572             (void),
 573             "Return the current thread's VM.")
 574 #define FUNC_NAME s_scm_the_vm
 575 {
 576   scm_i_thread *t = SCM_I_CURRENT_THREAD;
 577
 578   if (SCM_UNLIKELY (scm_is_false (t->vm)))
 579     t->vm = make_vm ();
 580
 581   return t->vm;
 582 }
 583 #undef FUNC_NAME
 584
 585
 586 SCM_DEFINE (scm_vm_p, "vm?", 1, 0, 0,
 587             (SCM obj),
 588             "")
 589 #define FUNC_NAME s_scm_vm_p
 590 {
 591   return scm_from_bool (SCM_VM_P (obj));
 592 }
 593 #undef FUNC_NAME
 594
 595 SCM_DEFINE (scm_make_vm, "make-vm", 0, 0, 0,
 596             (void),
 597             "")
 598 #define FUNC_NAME s_scm_make_vm,
 599 {
 600   return make_vm ();
 601 }
 602 #undef FUNC_NAME
 603
 604 SCM_DEFINE (scm_vm_ip, "vm:ip", 1, 0, 0,
 605             (SCM vm),
 606             "")
 607 #define FUNC_NAME s_scm_vm_ip
 608 {
 609   SCM_VALIDATE_VM (1, vm);
 610   return scm_from_unsigned_integer ((scm_t_bits) SCM_VM_DATA (vm)->ip);
 611 }
 612 #undef FUNC_NAME
 613
 614 SCM_DEFINE (scm_vm_sp, "vm:sp", 1, 0, 0,
 615             (SCM vm),
 616             "")
 617 #define FUNC_NAME s_scm_vm_sp
 618 {
 619   SCM_VALIDATE_VM (1, vm);
 620   return scm_from_unsigned_integer ((scm_t_bits) SCM_VM_DATA (vm)->sp);
 621 }
 622 #undef FUNC_NAME
 623
 624 SCM_DEFINE (scm_vm_fp, "vm:fp", 1, 0, 0,
 625             (SCM vm),
 626             "")
 627 #define FUNC_NAME s_scm_vm_fp
 628 {
 629   SCM_VALIDATE_VM (1, vm);
 630   return scm_from_unsigned_integer ((scm_t_bits) SCM_VM_DATA (vm)->fp);
 631 }
 632 #undef FUNC_NAME
 633
 634 #define VM_DEFINE_HOOK(n)                               \
 635 {                                                       \
 636   struct scm_vm *vp;                                    \
 637   SCM_VALIDATE_VM (1, vm);                              \
 638   vp = SCM_VM_DATA (vm);                                \
 639   if (scm_is_false (vp->hooks[n]))                      \
 640     vp->hooks[n] = scm_make_hook (SCM_I_MAKINUM (1));   \
 641   return vp->hooks[n];                                  \
 642 }
 643
 644 SCM_DEFINE (scm_vm_apply_hook, "vm-apply-hook", 1, 0, 0,
 645             (SCM vm),
 646             "")
 647 #define FUNC_NAME s_scm_vm_apply_hook
 648 {
 649   VM_DEFINE_HOOK (SCM_VM_APPLY_HOOK);
 650 }
 651 #undef FUNC_NAME
 652
 653 SCM_DEFINE (scm_vm_push_continuation_hook, "vm-push-continuation-hook", 1, 0, 0,
 654             (SCM vm),
 655             "")
 656 #define FUNC_NAME s_scm_vm_push_continuation_hook
 657 {
 658   VM_DEFINE_HOOK (SCM_VM_PUSH_CONTINUATION_HOOK);
 659 }
 660 #undef FUNC_NAME
 661
 662 SCM_DEFINE (scm_vm_pop_continuation_hook, "vm-pop-continuation-hook", 1, 0, 0,
 663             (SCM vm),
 664             "")
 665 #define FUNC_NAME s_scm_vm_pop_continuation_hook
 666 {
 667   VM_DEFINE_HOOK (SCM_VM_POP_CONTINUATION_HOOK);
 668 }
 669 #undef FUNC_NAME
 670
 671 SCM_DEFINE (scm_vm_next_hook, "vm-next-hook", 1, 0, 0,
 672             (SCM vm),
 673             "")
 674 #define FUNC_NAME s_scm_vm_next_hook
 675 {
 676   VM_DEFINE_HOOK (SCM_VM_NEXT_HOOK);
 677 }
 678 #undef FUNC_NAME
 679
 680 SCM_DEFINE (scm_vm_abort_continuation_hook, "vm-abort-continuation-hook", 1, 0, 0,
 681             (SCM vm),
 682             "")
 683 #define FUNC_NAME s_scm_vm_abort_continuation_hook
 684 {
 685   VM_DEFINE_HOOK (SCM_VM_ABORT_CONTINUATION_HOOK);
 686 }
 687 #undef FUNC_NAME
 688
 689 SCM_DEFINE (scm_vm_restore_continuation_hook, "vm-restore-continuation-hook", 1, 0, 0,
 690             (SCM vm),
 691             "")
 692 #define FUNC_NAME s_scm_vm_restore_continuation_hook
 693 {
 694   VM_DEFINE_HOOK (SCM_VM_RESTORE_CONTINUATION_HOOK);
 695 }
 696 #undef FUNC_NAME
 697
 698 SCM_DEFINE (scm_vm_trace_level, "vm-trace-level", 1, 0, 0,
 699             (SCM vm),
 700             "")
 701 #define FUNC_NAME s_scm_vm_trace_level
 702 {
 703   SCM_VALIDATE_VM (1, vm);
 704   return scm_from_int (SCM_VM_DATA (vm)->trace_level);
 705 }
 706 #undef FUNC_NAME
 707
 708 SCM_DEFINE (scm_set_vm_trace_level_x, "set-vm-trace-level!", 2, 0, 0,
 709             (SCM vm, SCM level),
 710             "")
 711 #define FUNC_NAME s_scm_set_vm_trace_level_x
 712 {
 713   SCM_VALIDATE_VM (1, vm);
 714   SCM_VM_DATA (vm)->trace_level = scm_to_int (level);
 715   return SCM_UNSPECIFIED;
 716 }
 717 #undef FUNC_NAME
 718
 719 \f
 720 /*
 721  * VM engines
 722  */
 723
 724 static int
 725 symbol_to_vm_engine (SCM engine, const char *FUNC_NAME)
 726 {
 727   if (scm_is_eq (engine, sym_regular))
 728     return SCM_VM_REGULAR_ENGINE;
 729   else if (scm_is_eq (engine, sym_debug))
 730     return SCM_VM_DEBUG_ENGINE;
 731   else
 732     SCM_MISC_ERROR ("Unknown VM engine: ~a", scm_list_1 (engine));
 733 }
 734
 735 static SCM
 736 vm_engine_to_symbol (int engine, const char *FUNC_NAME)
 737 {
 738   switch (engine)
 739     {
 740     case SCM_VM_REGULAR_ENGINE:
 741       return sym_regular;
 742     case SCM_VM_DEBUG_ENGINE:
 743       return sym_debug;
 744     default:
 745       /* ? */
 746       SCM_MISC_ERROR ("Unknown VM engine: ~a",
 747                       scm_list_1 (scm_from_int (engine)));
 748     }
 749 }
 750
 751 SCM_DEFINE (scm_vm_engine, "vm-engine", 1, 0, 0,
 752             (SCM vm),
 753             "")
 754 #define FUNC_NAME s_scm_vm_engine
 755 {
 756   SCM_VALIDATE_VM (1, vm);
 757   return vm_engine_to_symbol (SCM_VM_DATA (vm)->engine, FUNC_NAME);
 758 }
 759 #undef FUNC_NAME
 760
 761 void
 762 scm_c_set_vm_engine_x (SCM vm, int engine)
 763 #define FUNC_NAME "set-vm-engine!"
 764 {
 765   SCM_VALIDATE_VM (1, vm);
 766
 767   if (engine < 0 || engine >= SCM_VM_NUM_ENGINES)
 768     SCM_MISC_ERROR ("Unknown VM engine: ~a",
 769                     scm_list_1 (scm_from_int (engine)));
 770
 771   SCM_VM_DATA (vm)->engine = engine;
 772 }
 773 #undef FUNC_NAME
 774
 775 SCM_DEFINE (scm_set_vm_engine_x, "set-vm-engine!", 2, 0, 0,
 776             (SCM vm, SCM engine),
 777             "")
 778 #define FUNC_NAME s_scm_set_vm_engine_x
 779 {
 780   scm_c_set_vm_engine_x (vm, symbol_to_vm_engine (engine, FUNC_NAME));
 781   return SCM_UNSPECIFIED;
 782 }
 783 #undef FUNC_NAME
 784
 785 void
 786 scm_c_set_default_vm_engine_x (int engine)
 787 #define FUNC_NAME "set-default-vm-engine!"
 788 {
 789   if (engine < 0 || engine >= SCM_VM_NUM_ENGINES)
 790     SCM_MISC_ERROR ("Unknown VM engine: ~a",
 791                     scm_list_1 (scm_from_int (engine)));
 792
 793   vm_default_engine = engine;
 794 }
 795 #undef FUNC_NAME
 796
 797 SCM_DEFINE (scm_set_default_vm_engine_x, "set-default-vm-engine!", 1, 0, 0,
 798             (SCM engine),
 799             "")
 800 #define FUNC_NAME s_scm_set_default_vm_engine_x
 801 {
 802   scm_c_set_default_vm_engine_x (symbol_to_vm_engine (engine, FUNC_NAME));
 803   return SCM_UNSPECIFIED;
 804 }
 805 #undef FUNC_NAME
 806
 807 static void reinstate_vm (SCM vm)
 808 {
 809   scm_i_thread *t = SCM_I_CURRENT_THREAD;
 810   t->vm = vm;
 811 }
 812
 813 SCM_DEFINE (scm_call_with_vm, "call-with-vm", 2, 0, 1,
 814             (SCM vm, SCM proc, SCM args),
 815             "Apply @var{proc} to @var{args} in a dynamic extent in which\n"
 816             "@var{vm} is the current VM.\n\n"
 817             "As an implementation restriction, if @var{vm} is not the same\n"
 818             "as the current thread's VM, continuations captured within the\n"
 819             "call to @var{proc} may not be reinstated once control leaves\n"
 820             "@var{proc}.")
 821 #define FUNC_NAME s_scm_call_with_vm
 822 {
 823   SCM prev_vm, ret;
 824   SCM *argv;
 825   int i, nargs;
 826   scm_t_wind_flags flags;
 827   scm_i_thread *t = SCM_I_CURRENT_THREAD;
 828
 829   SCM_VALIDATE_VM (1, vm);
 830   SCM_VALIDATE_PROC (2, proc);
 831
 832   nargs = scm_ilength (args);
 833   if (SCM_UNLIKELY (nargs < 0))
 834     scm_wrong_type_arg_msg (FUNC_NAME, 3, args, "list");
 835
 836   argv = alloca (nargs * sizeof(SCM));
 837   for (i = 0; i < nargs; i++)
 838     {
 839       argv[i] = SCM_CAR (args);
 840       args = SCM_CDR (args);
 841     }
 842
 843   prev_vm = t->vm;
 844
 845   /* Reentry can happen via invokation of a saved continuation, but
 846      continuations only save the state of the VM that they are in at
 847      capture-time, which might be different from this one.  So, in the
 848      case that the VMs are different, set up a non-rewindable frame to
 849      prevent reinstating an incomplete continuation.  */
 850   flags = scm_is_eq (prev_vm, vm) ? 0 : SCM_F_WIND_EXPLICITLY;
 851   if (flags)
 852     {
 853       scm_dynwind_begin (0);
 854       scm_dynwind_unwind_handler_with_scm (reinstate_vm, prev_vm, flags);
 855       t->vm = vm;
 856     }
 857
 858   ret = scm_c_vm_run (vm, proc, argv, nargs);
 859
 860   if (flags)
 861     scm_dynwind_end ();
 862
 863   return ret;
 864 }
 865 #undef FUNC_NAME
 866
 867 \f
 868 /*
 869  * Initialize
 870  */
 871
 872 SCM scm_load_compiled_with_vm (SCM file)
 873 {
 874   SCM program = scm_make_program (scm_load_objcode (file),
 875                                   SCM_BOOL_F, SCM_BOOL_F);
 876
 877   return scm_c_vm_run (scm_the_vm (), program, NULL, 0);
 878 }
 879
 880 void
 881 scm_bootstrap_vm (void)
 882 {
 883   scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
 884                             "scm_init_vm",
 885                             (scm_t_extension_init_func)scm_init_vm, NULL);
 886
 887   sym_vm_run = scm_from_latin1_symbol ("vm-run");
 888   sym_vm_error = scm_from_latin1_symbol ("vm-error");
 889   sym_keyword_argument_error = scm_from_latin1_symbol ("keyword-argument-error");
 890   sym_regular = scm_from_latin1_symbol ("regular");
 891   sym_debug = scm_from_latin1_symbol ("debug");
 892
 893 #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
 894   vm_stack_gc_kind =
 895     GC_new_kind (GC_new_free_list (),
 896                  GC_MAKE_PROC (GC_new_proc (vm_stack_mark), 0),
 897                  0, 1);
 898
 899 #endif
 900 }
 901
 902 void
 903 scm_init_vm (void)
 904 {
 905 #ifndef SCM_MAGIC_SNARFER
 906 #include "libguile/vm.x"
 907 #endif
 908 }
 909
 910 /*
 911   Local Variables:
 912   c-file-style: "gnu"
 913   End:
 914 */