libguile/vm.c

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