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, 1,
 184                          scm_op_make_int8_1, scm_op_nop, scm_op_nop, scm_op_nop,
 185                          scm_op_halt };
 186   struct scm_objcode *bp;
 187   SCM ret;
 188
 189   if (SCM_UNLIKELY (nargs > 255 || nargs < 0))
 190     abort ();
 191   text[1] = (scm_t_uint8)nargs;
 192
 193   bp = scm_malloc (sizeof (struct scm_objcode) + sizeof (text));
 194   memcpy (bp->base, text, sizeof (text));
 195   bp->nargs = 0;
 196   bp->nrest = 0;
 197   bp->nlocs = 0;
 198   bp->len = sizeof(text);
 199   bp->metalen = 0;
 200   bp->unused = 0;
 201
 202   u8vec = scm_take_u8vector ((scm_t_uint8*)bp,
 203                              sizeof (struct scm_objcode) + sizeof (text));
 204   ret = scm_make_program (scm_bytecode_to_objcode (u8vec),
 205                           SCM_BOOL_F, SCM_BOOL_F);
 206   SCM_SET_SMOB_FLAGS (ret, SCM_F_PROGRAM_IS_BOOT);
 207
 208   return ret;
 209 }
 210 #define NUM_BOOT_PROGS 8
 211 static SCM
 212 vm_make_boot_program (long nargs)
 213 {
 214   static SCM programs[NUM_BOOT_PROGS] = { 0, };
 215
 216   if (SCM_UNLIKELY (!programs[0]))
 217     {
 218       int i;
 219       for (i = 0; i < NUM_BOOT_PROGS; i++)
 220         programs[i] = scm_permanent_object (really_make_boot_program (i));
 221     }
 222
 223   if (SCM_LIKELY (nargs < NUM_BOOT_PROGS))
 224     return programs[nargs];
 225   else
 226     return really_make_boot_program (nargs);
 227 }
 228
 229 \f
 230 /*
 231  * VM
 232  */
 233
 234 static SCM
 235 resolve_variable (SCM what, SCM program_module)
 236 {
 237   if (SCM_LIKELY (SCM_SYMBOLP (what)))
 238     {
 239       if (SCM_LIKELY (scm_module_system_booted_p
 240                       && scm_is_true (program_module)))
 241         /* might longjmp */
 242         return scm_module_lookup (program_module, what);
 243       else
 244         {
 245           SCM v = scm_sym2var (what, SCM_BOOL_F, SCM_BOOL_F);
 246           if (scm_is_false (v))
 247             scm_misc_error (NULL, "unbound variable: ~S", scm_list_1 (what));
 248           else
 249             return v;
 250         }
 251     }
 252   else
 253     {
 254       SCM mod;
 255       /* compilation of @ or @@
 256          `what' is a three-element list: (MODNAME SYM INTERFACE?)
 257          INTERFACE? is #t if we compiled @ or #f if we compiled @@
 258       */
 259       mod = scm_resolve_module (SCM_CAR (what));
 260       if (scm_is_true (SCM_CADDR (what)))
 261         mod = scm_module_public_interface (mod);
 262       if (SCM_FALSEP (mod))
 263         scm_misc_error (NULL, "no such module: ~S",
 264                         scm_list_1 (SCM_CAR (what)));
 265       /* might longjmp */
 266       return scm_module_lookup (mod, SCM_CADR (what));
 267     }
 268 }
 269
 270
 271 #define VM_DEFAULT_STACK_SIZE   (64 * 1024)
 272
 273 #define VM_NAME   vm_regular_engine
 274 #define FUNC_NAME "vm-regular-engine"
 275 #define VM_ENGINE SCM_VM_REGULAR_ENGINE
 276 #include "vm-engine.c"
 277 #undef VM_NAME
 278 #undef FUNC_NAME
 279 #undef VM_ENGINE
 280
 281 #define VM_NAME   vm_debug_engine
 282 #define FUNC_NAME "vm-debug-engine"
 283 #define VM_ENGINE SCM_VM_DEBUG_ENGINE
 284 #include "vm-engine.c"
 285 #undef VM_NAME
 286 #undef FUNC_NAME
 287 #undef VM_ENGINE
 288
 289 static const scm_t_vm_engine vm_engines[] =
 290   { vm_regular_engine, vm_debug_engine };
 291
 292 scm_t_bits scm_tc16_vm;
 293
 294 #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
 295
 296 /* The GC "kind" for the VM stack.  */
 297 static int vm_stack_gc_kind;
 298
 299 #endif
 300
 301 static SCM
 302 make_vm (void)
 303 #define FUNC_NAME "make_vm"
 304 {
 305   int i;
 306
 307   if (!scm_tc16_vm)
 308     return SCM_BOOL_F; /* not booted yet */
 309
 310   struct scm_vm *vp = scm_gc_malloc (sizeof (struct scm_vm), "vm");
 311
 312   vp->stack_size  = VM_DEFAULT_STACK_SIZE;
 313
 314 #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
 315   vp->stack_base = GC_generic_malloc (vp->stack_size * sizeof (SCM),
 316                                       vm_stack_gc_kind);
 317
 318   /* Keep a pointer to VP so that `vm_stack_mark ()' can know what the stack
 319      top is.  */
 320   *vp->stack_base = PTR2SCM (vp);
 321   vp->stack_base++;
 322   vp->stack_size--;
 323 #else
 324   vp->stack_base  = scm_gc_malloc (vp->stack_size * sizeof (SCM),
 325                                    "stack-base");
 326 #endif
 327
 328 #ifdef VM_ENABLE_STACK_NULLING
 329   memset (vp->stack_base, 0, vp->stack_size * sizeof (SCM));
 330 #endif
 331   vp->stack_limit = vp->stack_base + vp->stack_size;
 332   vp->ip          = NULL;
 333   vp->sp          = vp->stack_base - 1;
 334   vp->fp          = NULL;
 335   vp->engine      = SCM_VM_DEBUG_ENGINE;
 336   vp->time        = 0;
 337   vp->clock       = 0;
 338   vp->options     = SCM_EOL;
 339   for (i = 0; i < SCM_VM_NUM_HOOKS; i++)
 340     vp->hooks[i] = SCM_BOOL_F;
 341   vp->trace_frame = SCM_BOOL_F;
 342   SCM_RETURN_NEWSMOB (scm_tc16_vm, vp);
 343 }
 344 #undef FUNC_NAME
 345
 346 #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
 347
 348 /* Mark the VM stack region between its base and its current top.  */
 349 static struct GC_ms_entry *
 350 vm_stack_mark (GC_word *addr, struct GC_ms_entry *mark_stack_ptr,
 351                struct GC_ms_entry *mark_stack_limit, GC_word env)
 352 {
 353   GC_word *word;
 354   const struct scm_vm *vm;
 355
 356   /* The first word of the VM stack should contain a pointer to the
 357      corresponding VM.  */
 358   vm = * ((struct scm_vm **) addr);
 359
 360   if ((SCM *) addr != vm->stack_base - 1
 361       || vm->stack_limit - vm->stack_base != vm->stack_size)
 362     /* ADDR must be a pointer to a free-list element, which we must ignore
 363        (see warning in <gc/gc_mark.h>).  */
 364     return mark_stack_ptr;
 365
 366   for (word = (GC_word *) vm->stack_base; word <= (GC_word *) vm->sp; word++)
 367     mark_stack_ptr = GC_MARK_AND_PUSH ((* (GC_word **) word),
 368                                        mark_stack_ptr, mark_stack_limit,
 369                                        NULL);
 370
 371   return mark_stack_ptr;
 372 }
 373
 374 #endif /* VM_ENABLE_PRECISE_STACK_GC_SCAN */
 375
 376
 377 SCM
 378 scm_c_vm_run (SCM vm, SCM program, SCM *argv, int nargs)
 379 {
 380   struct scm_vm *vp = SCM_VM_DATA (vm);
 381   return vm_engines[vp->engine](vp, program, argv, nargs);
 382 }
 383
 384 SCM
 385 scm_vm_apply (SCM vm, SCM program, SCM args)
 386 #define FUNC_NAME "scm_vm_apply"
 387 {
 388   SCM *argv;
 389   int i, nargs;
 390
 391   SCM_VALIDATE_VM (1, vm);
 392   SCM_VALIDATE_PROGRAM (2, program);
 393
 394   nargs = scm_ilength (args);
 395   if (SCM_UNLIKELY (nargs < 0))
 396     scm_wrong_type_arg_msg (FUNC_NAME, 3, args, "list");
 397
 398   argv = alloca(nargs * sizeof(SCM));
 399   for (i = 0; i < nargs; i++)
 400     {
 401       argv[i] = SCM_CAR (args);
 402       args = SCM_CDR (args);
 403     }
 404
 405   return scm_c_vm_run (vm, program, argv, nargs);
 406 }
 407 #undef FUNC_NAME
 408
 409 /* Scheme interface */
 410
 411 SCM_DEFINE (scm_vm_version, "vm-version", 0, 0, 0,
 412             (void),
 413             "")
 414 #define FUNC_NAME s_scm_vm_version
 415 {
 416   return scm_from_locale_string (PACKAGE_VERSION);
 417 }
 418 #undef FUNC_NAME
 419
 420 SCM_DEFINE (scm_the_vm, "the-vm", 0, 0, 0,
 421             (void),
 422             "")
 423 #define FUNC_NAME s_scm_the_vm
 424 {
 425   scm_i_thread *t = SCM_I_CURRENT_THREAD;
 426
 427   if (SCM_UNLIKELY (SCM_FALSEP ((t->vm))))
 428     t->vm = make_vm ();
 429
 430   return t->vm;
 431 }
 432 #undef FUNC_NAME
 433
 434
 435 SCM_DEFINE (scm_vm_p, "vm?", 1, 0, 0,
 436             (SCM obj),
 437             "")
 438 #define FUNC_NAME s_scm_vm_p
 439 {
 440   return SCM_BOOL (SCM_VM_P (obj));
 441 }
 442 #undef FUNC_NAME
 443
 444 SCM_DEFINE (scm_make_vm, "make-vm", 0, 0, 0,
 445             (void),
 446             "")
 447 #define FUNC_NAME s_scm_make_vm,
 448 {
 449   return make_vm ();
 450 }
 451 #undef FUNC_NAME
 452
 453 SCM_DEFINE (scm_vm_ip, "vm:ip", 1, 0, 0,
 454             (SCM vm),
 455             "")
 456 #define FUNC_NAME s_scm_vm_ip
 457 {
 458   SCM_VALIDATE_VM (1, vm);
 459   return scm_from_ulong ((unsigned long) SCM_VM_DATA (vm)->ip);
 460 }
 461 #undef FUNC_NAME
 462
 463 SCM_DEFINE (scm_vm_sp, "vm:sp", 1, 0, 0,
 464             (SCM vm),
 465             "")
 466 #define FUNC_NAME s_scm_vm_sp
 467 {
 468   SCM_VALIDATE_VM (1, vm);
 469   return scm_from_ulong ((unsigned long) SCM_VM_DATA (vm)->sp);
 470 }
 471 #undef FUNC_NAME
 472
 473 SCM_DEFINE (scm_vm_fp, "vm:fp", 1, 0, 0,
 474             (SCM vm),
 475             "")
 476 #define FUNC_NAME s_scm_vm_fp
 477 {
 478   SCM_VALIDATE_VM (1, vm);
 479   return scm_from_ulong ((unsigned long) SCM_VM_DATA (vm)->fp);
 480 }
 481 #undef FUNC_NAME
 482
 483 #define VM_DEFINE_HOOK(n)                               \
 484 {                                                       \
 485   struct scm_vm *vp;                                    \
 486   SCM_VALIDATE_VM (1, vm);                              \
 487   vp = SCM_VM_DATA (vm);                                \
 488   if (SCM_FALSEP (vp->hooks[n]))                        \
 489     vp->hooks[n] = scm_make_hook (SCM_I_MAKINUM (1));   \
 490   return vp->hooks[n];                                  \
 491 }
 492
 493 SCM_DEFINE (scm_vm_boot_hook, "vm-boot-hook", 1, 0, 0,
 494             (SCM vm),
 495             "")
 496 #define FUNC_NAME s_scm_vm_boot_hook
 497 {
 498   VM_DEFINE_HOOK (SCM_VM_BOOT_HOOK);
 499 }
 500 #undef FUNC_NAME
 501
 502 SCM_DEFINE (scm_vm_halt_hook, "vm-halt-hook", 1, 0, 0,
 503             (SCM vm),
 504             "")
 505 #define FUNC_NAME s_scm_vm_halt_hook
 506 {
 507   VM_DEFINE_HOOK (SCM_VM_HALT_HOOK);
 508 }
 509 #undef FUNC_NAME
 510
 511 SCM_DEFINE (scm_vm_next_hook, "vm-next-hook", 1, 0, 0,
 512             (SCM vm),
 513             "")
 514 #define FUNC_NAME s_scm_vm_next_hook
 515 {
 516   VM_DEFINE_HOOK (SCM_VM_NEXT_HOOK);
 517 }
 518 #undef FUNC_NAME
 519
 520 SCM_DEFINE (scm_vm_break_hook, "vm-break-hook", 1, 0, 0,
 521             (SCM vm),
 522             "")
 523 #define FUNC_NAME s_scm_vm_break_hook
 524 {
 525   VM_DEFINE_HOOK (SCM_VM_BREAK_HOOK);
 526 }
 527 #undef FUNC_NAME
 528
 529 SCM_DEFINE (scm_vm_enter_hook, "vm-enter-hook", 1, 0, 0,
 530             (SCM vm),
 531             "")
 532 #define FUNC_NAME s_scm_vm_enter_hook
 533 {
 534   VM_DEFINE_HOOK (SCM_VM_ENTER_HOOK);
 535 }
 536 #undef FUNC_NAME
 537
 538 SCM_DEFINE (scm_vm_apply_hook, "vm-apply-hook", 1, 0, 0,
 539             (SCM vm),
 540             "")
 541 #define FUNC_NAME s_scm_vm_apply_hook
 542 {
 543   VM_DEFINE_HOOK (SCM_VM_APPLY_HOOK);
 544 }
 545 #undef FUNC_NAME
 546
 547 SCM_DEFINE (scm_vm_exit_hook, "vm-exit-hook", 1, 0, 0,
 548             (SCM vm),
 549             "")
 550 #define FUNC_NAME s_scm_vm_exit_hook
 551 {
 552   VM_DEFINE_HOOK (SCM_VM_EXIT_HOOK);
 553 }
 554 #undef FUNC_NAME
 555
 556 SCM_DEFINE (scm_vm_return_hook, "vm-return-hook", 1, 0, 0,
 557             (SCM vm),
 558             "")
 559 #define FUNC_NAME s_scm_vm_return_hook
 560 {
 561   VM_DEFINE_HOOK (SCM_VM_RETURN_HOOK);
 562 }
 563 #undef FUNC_NAME
 564
 565 SCM_DEFINE (scm_vm_option, "vm-option", 2, 0, 0,
 566             (SCM vm, SCM key),
 567             "")
 568 #define FUNC_NAME s_scm_vm_option
 569 {
 570   SCM_VALIDATE_VM (1, vm);
 571   return scm_assq_ref (SCM_VM_DATA (vm)->options, key);
 572 }
 573 #undef FUNC_NAME
 574
 575 SCM_DEFINE (scm_set_vm_option_x, "set-vm-option!", 3, 0, 0,
 576             (SCM vm, SCM key, SCM val),
 577             "")
 578 #define FUNC_NAME s_scm_set_vm_option_x
 579 {
 580   SCM_VALIDATE_VM (1, vm);
 581   SCM_VM_DATA (vm)->options
 582     = scm_assq_set_x (SCM_VM_DATA (vm)->options, key, val);
 583   return SCM_UNSPECIFIED;
 584 }
 585 #undef FUNC_NAME
 586
 587 SCM_DEFINE (scm_vm_stats, "vm-stats", 1, 0, 0,
 588             (SCM vm),
 589             "")
 590 #define FUNC_NAME s_scm_vm_stats
 591 {
 592   SCM stats;
 593
 594   SCM_VALIDATE_VM (1, vm);
 595
 596   stats = scm_make_vector (SCM_I_MAKINUM (2), SCM_UNSPECIFIED);
 597   scm_vector_set_x (stats, SCM_I_MAKINUM (0),
 598                     scm_from_ulong (SCM_VM_DATA (vm)->time));
 599   scm_vector_set_x (stats, SCM_I_MAKINUM (1),
 600                     scm_from_ulong (SCM_VM_DATA (vm)->clock));
 601
 602   return stats;
 603 }
 604 #undef FUNC_NAME
 605
 606 SCM_DEFINE (scm_vm_trace_frame, "vm-trace-frame", 1, 0, 0,
 607             (SCM vm),
 608             "")
 609 #define FUNC_NAME s_scm_vm_trace_frame
 610 {
 611   SCM_VALIDATE_VM (1, vm);
 612   return SCM_VM_DATA (vm)->trace_frame;
 613 }
 614 #undef FUNC_NAME
 615
 616 \f
 617 /*
 618  * Initialize
 619  */
 620
 621 SCM scm_load_compiled_with_vm (SCM file)
 622 {
 623   SCM program = scm_make_program (scm_load_objcode (file),
 624                                   SCM_BOOL_F, SCM_BOOL_F);
 625
 626   return scm_c_vm_run (scm_the_vm (), program, NULL, 0);
 627 }
 628
 629 void
 630 scm_bootstrap_vm (void)
 631 {
 632   static int strappage = 0;
 633
 634   if (strappage)
 635     return;
 636
 637   scm_bootstrap_frames ();
 638   scm_bootstrap_instructions ();
 639   scm_bootstrap_objcodes ();
 640   scm_bootstrap_programs ();
 641
 642   scm_tc16_vm_cont = scm_make_smob_type ("vm-cont", 0);
 643
 644   scm_tc16_vm = scm_make_smob_type ("vm", 0);
 645   scm_set_smob_apply (scm_tc16_vm, scm_vm_apply, 1, 0, 1);
 646
 647   scm_c_define ("load-compiled",
 648                 scm_c_make_gsubr ("load-compiled/vm", 1, 0, 0,
 649                                   scm_load_compiled_with_vm));
 650
 651   sym_vm_run = scm_permanent_object (scm_from_locale_symbol ("vm-run"));
 652   sym_vm_error = scm_permanent_object (scm_from_locale_symbol ("vm-error"));
 653   sym_debug = scm_permanent_object (scm_from_locale_symbol ("debug"));
 654
 655   scm_c_register_extension ("libguile", "scm_init_vm",
 656                             (scm_t_extension_init_func)scm_init_vm, NULL);
 657
 658   strappage = 1;
 659
 660 #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
 661   vm_stack_gc_kind =
 662     GC_new_kind (GC_new_free_list (),
 663                  GC_MAKE_PROC (GC_new_proc (vm_stack_mark), 0),
 664                  0, 1);
 665
 666 #endif
 667 }
 668
 669 void
 670 scm_init_vm (void)
 671 {
 672   scm_bootstrap_vm ();
 673
 674 #ifndef SCM_MAGIC_SNARFER
 675 #include "libguile/vm.x"
 676 #endif
 677 }
 678
 679 /*
 680   Local Variables:
 681   c-file-style: "gnu"
 682   End:
 683 */