libguile/vm.c

   1 /* Copyright (C) 2001 Free Software Foundation, Inc.
   2  *
   3  * This program is free software; you can redistribute it and/or modify
   4  * it under the terms of the GNU General Public License as published by
   5  * the Free Software Foundation; either version 2, or (at your option)
   6  * any later version.
   7  *
   8  * This program is distributed in the hope that it will be useful,
   9  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  10  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11  * GNU General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU General Public License
  14  * along with this software; see the file COPYING.  If not, write to
  15  * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  16  * Boston, MA 02111-1307 USA
  17  *
  18  * As a special exception, the Free Software Foundation gives permission
  19  * for additional uses of the text contained in its release of GUILE.
  20  *
  21  * The exception is that, if you link the GUILE library with other files
  22  * to produce an executable, this does not by itself cause the
  23  * resulting executable to be covered by the GNU General Public License.
  24  * Your use of that executable is in no way restricted on account of
  25  * linking the GUILE library code into it.
  26  *
  27  * This exception does not however invalidate any other reasons why
  28  * the executable file might be covered by the GNU General Public License.
  29  *
  30  * This exception applies only to the code released by the
  31  * Free Software Foundation under the name GUILE.  If you copy
  32  * code from other Free Software Foundation releases into a copy of
  33  * GUILE, as the General Public License permits, the exception does
  34  * not apply to the code that you add in this way.  To avoid misleading
  35  * anyone as to the status of such modified files, you must delete
  36  * this exception notice from them.
  37  *
  38  * If you write modifications of your own for GUILE, it is your choice
  39  * whether to permit this exception to apply to your modifications.
  40  * If you do not wish that, delete this exception notice.  */
  41
  42 #if HAVE_CONFIG_H
  43 #  include <config.h>
  44 #endif
  45
  46 #include <alloca.h>
  47 #include <string.h>
  48 #include "vm-bootstrap.h"
  49 #include "frames.h"
  50 #include "instructions.h"
  51 #include "objcodes.h"
  52 #include "programs.h"
  53 #include "lang.h" /* NULL_OR_NIL_P */
  54 #include "vm.h"
  55
  56 /* I sometimes use this for debugging. */
  57 #define vm_puts(OBJ)                            \
  58 {                                               \
  59   scm_display (OBJ, scm_current_error_port ()); \
  60   scm_newline (scm_current_error_port ());      \
  61 }
  62
  63 /* The VM has a number of internal assertions that shouldn't normally be
  64    necessary, but might be if you think you found a bug in the VM. */
  65 #define VM_ENABLE_ASSERTIONS
  66
  67 /* We can add a mode that ensures that all stack items above the stack pointer
  68    are NULL. This is useful for checking the internal consistency of the VM's
  69    assumptions and its operators, but isn't necessary for normal operation. It
  70    will ensure that assertions are enabled. Slows down the VM by about 30%. */
  71 /* NB! If you enable this, search for NULLING in throw.c */
  72 /* #define VM_ENABLE_STACK_NULLING */
  73
  74 /* #define VM_ENABLE_PARANOID_ASSERTIONS */
  75
  76 #if defined (VM_ENABLE_STACK_NULLING) && !defined (VM_ENABLE_ASSERTIONS)
  77 #define VM_ENABLE_ASSERTIONS
  78 #endif
  79
  80 \f
  81 /*
  82  * VM Continuation
  83  */
  84
  85 scm_t_bits scm_tc16_vm_cont;
  86
  87 static void
  88 vm_mark_stack (SCM *base, scm_t_ptrdiff size, SCM *fp, scm_t_ptrdiff reloc)
  89 {
  90   SCM *sp, *upper, *lower;
  91   sp = base + size - 1;
  92
  93   while (sp > base && fp)
  94     {
  95       upper = SCM_FRAME_UPPER_ADDRESS (fp);
  96       lower = SCM_FRAME_LOWER_ADDRESS (fp);
  97
  98       for (; sp >= upper; sp--)
  99         if (SCM_NIMP (*sp))
 100           {
 101             if (scm_in_heap_p (*sp))
 102               scm_gc_mark (*sp);
 103             else
 104               fprintf (stderr, "BADNESS: crap on the stack: %p\n", *sp);
 105           }
 106
 107
 108       /* skip ra, mvra */
 109       sp -= 2;
 110
 111       /* update fp from the dynamic link */
 112       fp = (SCM*)*sp-- + reloc;
 113
 114       /* mark from the el down to the lower address */
 115       for (; sp >= lower; sp--)
 116         if (*sp && SCM_NIMP (*sp))
 117           scm_gc_mark (*sp);
 118     }
 119 }
 120
 121 static SCM
 122 vm_cont_mark (SCM obj)
 123 {
 124   struct scm_vm_cont *p = SCM_VM_CONT_DATA (obj);
 125
 126   if (p->stack_size)
 127     vm_mark_stack (p->stack_base, p->stack_size, p->fp + p->reloc, p->reloc);
 128
 129   return SCM_BOOL_F;
 130 }
 131
 132 static scm_sizet
 133 vm_cont_free (SCM obj)
 134 {
 135   struct scm_vm_cont *p = SCM_VM_CONT_DATA (obj);
 136
 137   scm_gc_free (p->stack_base, p->stack_size * sizeof (SCM), "stack-base");
 138   scm_gc_free (p, sizeof (struct scm_vm), "vm");
 139
 140   return 0;
 141 }
 142
 143 static SCM
 144 capture_vm_cont (struct scm_vm *vp)
 145 {
 146   struct scm_vm_cont *p = scm_gc_malloc (sizeof (*p), "capture_vm_cont");
 147   p->stack_size = vp->sp - vp->stack_base + 1;
 148   p->stack_base = scm_gc_malloc (p->stack_size * sizeof (SCM),
 149                                  "capture_vm_cont");
 150 #ifdef VM_ENABLE_STACK_NULLING
 151   if (vp->sp >= vp->stack_base)
 152     if (!vp->sp[0] || vp->sp[1])
 153       abort ();
 154   memset (p->stack_base, 0, p->stack_size * sizeof (SCM));
 155 #endif
 156   p->ip = vp->ip;
 157   p->sp = vp->sp;
 158   p->fp = vp->fp;
 159   memcpy (p->stack_base, vp->stack_base, p->stack_size * sizeof (SCM));
 160   p->reloc = p->stack_base - vp->stack_base;
 161   SCM_RETURN_NEWSMOB (scm_tc16_vm_cont, p);
 162 }
 163
 164 static void
 165 reinstate_vm_cont (struct scm_vm *vp, SCM cont)
 166 {
 167   struct scm_vm_cont *p = SCM_VM_CONT_DATA (cont);
 168   if (vp->stack_size < p->stack_size)
 169     {
 170       /* puts ("FIXME: Need to expand"); */
 171       abort ();
 172     }
 173 #ifdef VM_ENABLE_STACK_NULLING
 174   {
 175     scm_t_ptrdiff nzero = (vp->sp - p->sp);
 176     if (nzero > 0)
 177       memset (vp->stack_base + p->stack_size, 0, nzero * sizeof (SCM));
 178     /* actually nzero should always be negative, because vm_reset_stack will
 179        unwind the stack to some point *below* this continuation */
 180   }
 181 #endif
 182   vp->ip = p->ip;
 183   vp->sp = p->sp;
 184   vp->fp = p->fp;
 185   memcpy (vp->stack_base, p->stack_base, p->stack_size * sizeof (SCM));
 186 }
 187
 188 /* In theory, a number of vm instances can be active in the call trace, and we
 189    only want to reify the continuations of those in the current continuation
 190    root. I don't see a nice way to do this -- ideally it would involve dynwinds,
 191    and previous values of the *the-vm* fluid within the current continuation
 192    root. But we don't have access to continuation roots in the dynwind stack.
 193    So, just punt for now -- take the current value of *the-vm*.
 194
 195    While I'm on the topic, ideally we could avoid copying the C stack if the
 196    continuation root is inside VM code, and call/cc was invoked within that same
 197    call to vm_run; but that's currently not implemented.
 198  */
 199 SCM
 200 scm_vm_capture_continuations (void)
 201 {
 202   SCM vm = scm_the_vm ();
 203   return scm_acons (vm, capture_vm_cont (SCM_VM_DATA (vm)), SCM_EOL);
 204 }
 205
 206 void
 207 scm_vm_reinstate_continuations (SCM conts)
 208 {
 209   for (; conts != SCM_EOL; conts = SCM_CDR (conts))
 210     reinstate_vm_cont (SCM_VM_DATA (SCM_CAAR (conts)), SCM_CDAR (conts));
 211 }
 212
 213 static void enfalsen_frame (void *p)
 214 {
 215   struct scm_vm *vp = p;
 216   vp->trace_frame = SCM_BOOL_F;
 217 }
 218
 219 static void
 220 vm_dispatch_hook (struct scm_vm *vp, SCM hook, SCM hook_args)
 221 {
 222   if (!SCM_FALSEP (vp->trace_frame))
 223     return;
 224
 225   scm_dynwind_begin (0);
 226   // FIXME, stack holder should be the vm
 227   vp->trace_frame = scm_c_make_vm_frame (SCM_BOOL_F, vp->fp, vp->sp, vp->ip, 0);
 228   scm_dynwind_unwind_handler (enfalsen_frame, vp, SCM_F_WIND_EXPLICITLY);
 229
 230   scm_c_run_hook (hook, hook_args);
 231
 232   scm_dynwind_end ();
 233 }
 234
 235 \f
 236 /*
 237  * VM Internal functions
 238  */
 239
 240 static SCM sym_vm_run;
 241 static SCM sym_vm_error;
 242 static SCM sym_debug;
 243
 244 static SCM make_u8vector (const scm_t_uint8 *bytes, size_t len)
 245 {
 246   scm_t_uint8 *new_bytes = scm_gc_malloc (len, "make-u8vector");
 247   memcpy (new_bytes, bytes, len);
 248   return scm_take_u8vector (new_bytes, len);
 249 }
 250
 251 static SCM
 252 really_make_boot_program (long nargs)
 253 {
 254   scm_byte_t bytes[] = {0, 0, 0, 0,
 255                         0, 0, 0, 0,
 256                         0, 0, 0, 0,
 257                         scm_op_mv_call, 0, 0, 1, scm_op_make_int8_1, scm_op_halt};
 258   SCM ret;
 259   ((scm_t_uint32*)bytes)[1] = 6; /* set len in current endianness, no meta */
 260   if (SCM_UNLIKELY (nargs > 255 || nargs < 0))
 261     abort ();
 262   bytes[13] = (scm_byte_t)nargs;
 263   ret = scm_make_program (scm_bytecode_to_objcode (make_u8vector (bytes, sizeof(bytes))),
 264                           SCM_BOOL_F, SCM_EOL);
 265   SCM_SET_SMOB_FLAGS (ret, SCM_F_PROGRAM_IS_BOOT);
 266   return ret;
 267 }
 268 #define NUM_BOOT_PROGS 8
 269 static SCM
 270 vm_make_boot_program (long nargs)
 271 {
 272   static SCM programs[NUM_BOOT_PROGS] = { 0, };
 273
 274   if (SCM_UNLIKELY (!programs[0]))
 275     {
 276       int i;
 277       for (i = 0; i < NUM_BOOT_PROGS; i++)
 278         programs[i] = scm_permanent_object (really_make_boot_program (i));
 279     }
 280
 281   if (SCM_LIKELY (nargs < NUM_BOOT_PROGS))
 282     return programs[nargs];
 283   else
 284     return really_make_boot_program (nargs);
 285 }
 286
 287 \f
 288 /*
 289  * VM
 290  */
 291
 292 #define VM_DEFAULT_STACK_SIZE   (16 * 1024)
 293
 294 #define VM_NAME   vm_regular_engine
 295 #define FUNC_NAME "vm-regular-engine"
 296 #define VM_ENGINE SCM_VM_REGULAR_ENGINE
 297 #include "vm-engine.c"
 298 #undef VM_NAME
 299 #undef FUNC_NAME
 300 #undef VM_ENGINE
 301
 302 #define VM_NAME   vm_debug_engine
 303 #define FUNC_NAME "vm-debug-engine"
 304 #define VM_ENGINE SCM_VM_DEBUG_ENGINE
 305 #include "vm-engine.c"
 306 #undef VM_NAME
 307 #undef FUNC_NAME
 308 #undef VM_ENGINE
 309
 310 static const scm_t_vm_engine vm_engines[] =
 311   { vm_regular_engine, vm_debug_engine };
 312
 313 scm_t_bits scm_tc16_vm;
 314
 315 static SCM
 316 make_vm (void)
 317 #define FUNC_NAME "make_vm"
 318 {
 319   int i;
 320
 321   if (!scm_tc16_vm)
 322     return SCM_BOOL_F; /* not booted yet */
 323
 324   struct scm_vm *vp = scm_gc_malloc (sizeof (struct scm_vm), "vm");
 325
 326   vp->stack_size  = VM_DEFAULT_STACK_SIZE;
 327   vp->stack_base  = scm_gc_malloc (vp->stack_size * sizeof (SCM),
 328                                    "stack-base");
 329 #ifdef VM_ENABLE_STACK_NULLING
 330   memset (vp->stack_base, 0, vp->stack_size * sizeof (SCM));
 331 #endif
 332   vp->stack_limit = vp->stack_base + vp->stack_size - 3;
 333   vp->ip          = NULL;
 334   vp->sp          = vp->stack_base - 1;
 335   vp->fp          = NULL;
 336   vp->engine      = SCM_VM_DEBUG_ENGINE;
 337   vp->time        = 0;
 338   vp->clock       = 0;
 339   vp->options     = SCM_EOL;
 340   for (i = 0; i < SCM_VM_NUM_HOOKS; i++)
 341     vp->hooks[i] = SCM_BOOL_F;
 342   vp->trace_frame = SCM_BOOL_F;
 343   SCM_RETURN_NEWSMOB (scm_tc16_vm, vp);
 344 }
 345 #undef FUNC_NAME
 346
 347 static SCM
 348 vm_mark (SCM obj)
 349 {
 350   int i;
 351   struct scm_vm *vp = SCM_VM_DATA (obj);
 352
 353 #ifdef VM_ENABLE_STACK_NULLING
 354   if (vp->sp >= vp->stack_base)
 355     if (!vp->sp[0] || vp->sp[1])
 356       abort ();
 357 #endif
 358
 359   /* mark the stack, precisely */
 360   vm_mark_stack (vp->stack_base, vp->sp + 1 - vp->stack_base, vp->fp, 0);
 361
 362   /* mark other objects  */
 363   for (i = 0; i < SCM_VM_NUM_HOOKS; i++)
 364     scm_gc_mark (vp->hooks[i]);
 365
 366   scm_gc_mark (vp->trace_frame);
 367
 368   return vp->options;
 369 }
 370
 371 static scm_sizet
 372 vm_free (SCM obj)
 373 {
 374   struct scm_vm *vp = SCM_VM_DATA (obj);
 375
 376   scm_gc_free (vp->stack_base, vp->stack_size * sizeof (SCM),
 377                "stack-base");
 378   scm_gc_free (vp, sizeof (struct scm_vm), "vm");
 379
 380   return 0;
 381 }
 382
 383 SCM
 384 scm_c_vm_run (SCM vm, SCM program, SCM *argv, int nargs)
 385 {
 386   struct scm_vm *vp = SCM_VM_DATA (vm);
 387   return vm_engines[vp->engine](vp, program, argv, nargs);
 388 }
 389
 390 SCM
 391 scm_vm_apply (SCM vm, SCM program, SCM args)
 392 #define FUNC_NAME "scm_vm_apply"
 393 {
 394   SCM *argv;
 395   int i, nargs;
 396
 397   SCM_VALIDATE_VM (1, vm);
 398   SCM_VALIDATE_PROGRAM (2, program);
 399
 400   nargs = scm_ilength (args);
 401   if (SCM_UNLIKELY (nargs < 0))
 402     scm_wrong_type_arg_msg (FUNC_NAME, 3, args, "list");
 403
 404   argv = alloca(nargs * sizeof(SCM));
 405   for (i = 0; i < nargs; i++)
 406     {
 407       argv[i] = SCM_CAR (args);
 408       args = SCM_CDR (args);
 409     }
 410
 411   return scm_c_vm_run (vm, program, argv, nargs);
 412 }
 413 #undef FUNC_NAME
 414
 415 /* Scheme interface */
 416
 417 SCM_DEFINE (scm_vm_version, "vm-version", 0, 0, 0,
 418             (void),
 419             "")
 420 #define FUNC_NAME s_scm_vm_version
 421 {
 422   return scm_from_locale_string (PACKAGE_VERSION);
 423 }
 424 #undef FUNC_NAME
 425
 426 SCM_DEFINE (scm_the_vm, "the-vm", 0, 0, 0,
 427             (void),
 428             "")
 429 #define FUNC_NAME s_scm_the_vm
 430 {
 431   scm_i_thread *t = SCM_I_CURRENT_THREAD;
 432
 433   if (SCM_UNLIKELY (SCM_FALSEP ((t->vm))))
 434     t->vm = make_vm ();
 435
 436   return t->vm;
 437 }
 438 #undef FUNC_NAME
 439
 440
 441 SCM_DEFINE (scm_vm_p, "vm?", 1, 0, 0,
 442             (SCM obj),
 443             "")
 444 #define FUNC_NAME s_scm_vm_p
 445 {
 446   return SCM_BOOL (SCM_VM_P (obj));
 447 }
 448 #undef FUNC_NAME
 449
 450 SCM_DEFINE (scm_make_vm, "make-vm", 0, 0, 0,
 451             (void),
 452             "")
 453 #define FUNC_NAME s_scm_make_vm,
 454 {
 455   return make_vm ();
 456 }
 457 #undef FUNC_NAME
 458
 459 SCM_DEFINE (scm_vm_ip, "vm:ip", 1, 0, 0,
 460             (SCM vm),
 461             "")
 462 #define FUNC_NAME s_scm_vm_ip
 463 {
 464   SCM_VALIDATE_VM (1, vm);
 465   return scm_from_ulong ((unsigned long) SCM_VM_DATA (vm)->ip);
 466 }
 467 #undef FUNC_NAME
 468
 469 SCM_DEFINE (scm_vm_sp, "vm:sp", 1, 0, 0,
 470             (SCM vm),
 471             "")
 472 #define FUNC_NAME s_scm_vm_sp
 473 {
 474   SCM_VALIDATE_VM (1, vm);
 475   return scm_from_ulong ((unsigned long) SCM_VM_DATA (vm)->sp);
 476 }
 477 #undef FUNC_NAME
 478
 479 SCM_DEFINE (scm_vm_fp, "vm:fp", 1, 0, 0,
 480             (SCM vm),
 481             "")
 482 #define FUNC_NAME s_scm_vm_fp
 483 {
 484   SCM_VALIDATE_VM (1, vm);
 485   return scm_from_ulong ((unsigned long) SCM_VM_DATA (vm)->fp);
 486 }
 487 #undef FUNC_NAME
 488
 489 #define VM_DEFINE_HOOK(n)                               \
 490 {                                                       \
 491   struct scm_vm *vp;                                    \
 492   SCM_VALIDATE_VM (1, vm);                              \
 493   vp = SCM_VM_DATA (vm);                                \
 494   if (SCM_FALSEP (vp->hooks[n]))                        \
 495     vp->hooks[n] = scm_make_hook (SCM_I_MAKINUM (1));   \
 496   return vp->hooks[n];                                  \
 497 }
 498
 499 SCM_DEFINE (scm_vm_boot_hook, "vm-boot-hook", 1, 0, 0,
 500             (SCM vm),
 501             "")
 502 #define FUNC_NAME s_scm_vm_boot_hook
 503 {
 504   VM_DEFINE_HOOK (SCM_VM_BOOT_HOOK);
 505 }
 506 #undef FUNC_NAME
 507
 508 SCM_DEFINE (scm_vm_halt_hook, "vm-halt-hook", 1, 0, 0,
 509             (SCM vm),
 510             "")
 511 #define FUNC_NAME s_scm_vm_halt_hook
 512 {
 513   VM_DEFINE_HOOK (SCM_VM_HALT_HOOK);
 514 }
 515 #undef FUNC_NAME
 516
 517 SCM_DEFINE (scm_vm_next_hook, "vm-next-hook", 1, 0, 0,
 518             (SCM vm),
 519             "")
 520 #define FUNC_NAME s_scm_vm_next_hook
 521 {
 522   VM_DEFINE_HOOK (SCM_VM_NEXT_HOOK);
 523 }
 524 #undef FUNC_NAME
 525
 526 SCM_DEFINE (scm_vm_break_hook, "vm-break-hook", 1, 0, 0,
 527             (SCM vm),
 528             "")
 529 #define FUNC_NAME s_scm_vm_break_hook
 530 {
 531   VM_DEFINE_HOOK (SCM_VM_BREAK_HOOK);
 532 }
 533 #undef FUNC_NAME
 534
 535 SCM_DEFINE (scm_vm_enter_hook, "vm-enter-hook", 1, 0, 0,
 536             (SCM vm),
 537             "")
 538 #define FUNC_NAME s_scm_vm_enter_hook
 539 {
 540   VM_DEFINE_HOOK (SCM_VM_ENTER_HOOK);
 541 }
 542 #undef FUNC_NAME
 543
 544 SCM_DEFINE (scm_vm_apply_hook, "vm-apply-hook", 1, 0, 0,
 545             (SCM vm),
 546             "")
 547 #define FUNC_NAME s_scm_vm_apply_hook
 548 {
 549   VM_DEFINE_HOOK (SCM_VM_APPLY_HOOK);
 550 }
 551 #undef FUNC_NAME
 552
 553 SCM_DEFINE (scm_vm_exit_hook, "vm-exit-hook", 1, 0, 0,
 554             (SCM vm),
 555             "")
 556 #define FUNC_NAME s_scm_vm_exit_hook
 557 {
 558   VM_DEFINE_HOOK (SCM_VM_EXIT_HOOK);
 559 }
 560 #undef FUNC_NAME
 561
 562 SCM_DEFINE (scm_vm_return_hook, "vm-return-hook", 1, 0, 0,
 563             (SCM vm),
 564             "")
 565 #define FUNC_NAME s_scm_vm_return_hook
 566 {
 567   VM_DEFINE_HOOK (SCM_VM_RETURN_HOOK);
 568 }
 569 #undef FUNC_NAME
 570
 571 SCM_DEFINE (scm_vm_option, "vm-option", 2, 0, 0,
 572             (SCM vm, SCM key),
 573             "")
 574 #define FUNC_NAME s_scm_vm_option
 575 {
 576   SCM_VALIDATE_VM (1, vm);
 577   return scm_assq_ref (SCM_VM_DATA (vm)->options, key);
 578 }
 579 #undef FUNC_NAME
 580
 581 SCM_DEFINE (scm_set_vm_option_x, "set-vm-option!", 3, 0, 0,
 582             (SCM vm, SCM key, SCM val),
 583             "")
 584 #define FUNC_NAME s_scm_set_vm_option_x
 585 {
 586   SCM_VALIDATE_VM (1, vm);
 587   SCM_VM_DATA (vm)->options
 588     = scm_assq_set_x (SCM_VM_DATA (vm)->options, key, val);
 589   return SCM_UNSPECIFIED;
 590 }
 591 #undef FUNC_NAME
 592
 593 SCM_DEFINE (scm_vm_stats, "vm-stats", 1, 0, 0,
 594             (SCM vm),
 595             "")
 596 #define FUNC_NAME s_scm_vm_stats
 597 {
 598   SCM stats;
 599
 600   SCM_VALIDATE_VM (1, vm);
 601
 602   stats = scm_make_vector (SCM_I_MAKINUM (2), SCM_UNSPECIFIED);
 603   scm_vector_set_x (stats, SCM_I_MAKINUM (0),
 604                     scm_from_ulong (SCM_VM_DATA (vm)->time));
 605   scm_vector_set_x (stats, SCM_I_MAKINUM (1),
 606                     scm_from_ulong (SCM_VM_DATA (vm)->clock));
 607
 608   return stats;
 609 }
 610 #undef FUNC_NAME
 611
 612 SCM_DEFINE (scm_vm_trace_frame, "vm-trace-frame", 1, 0, 0,
 613             (SCM vm),
 614             "")
 615 #define FUNC_NAME s_scm_vm_trace_frame
 616 {
 617   SCM_VALIDATE_VM (1, vm);
 618   return SCM_VM_DATA (vm)->trace_frame;
 619 }
 620 #undef FUNC_NAME
 621
 622 \f
 623 /*
 624  * Initialize
 625  */
 626
 627 SCM scm_load_compiled_with_vm (SCM file)
 628 {
 629   SCM program = scm_make_program (scm_load_objcode (file),
 630                                   SCM_BOOL_F, SCM_EOL);
 631
 632   return scm_c_vm_run (scm_the_vm (), program, NULL, 0);
 633 }
 634
 635 void
 636 scm_bootstrap_vm (void)
 637 {
 638   static int strappage = 0;
 639
 640   if (strappage)
 641     return;
 642
 643   scm_bootstrap_frames ();
 644   scm_bootstrap_instructions ();
 645   scm_bootstrap_objcodes ();
 646   scm_bootstrap_programs ();
 647
 648   scm_tc16_vm_cont = scm_make_smob_type ("vm-cont", 0);
 649   scm_set_smob_mark (scm_tc16_vm_cont, vm_cont_mark);
 650   scm_set_smob_free (scm_tc16_vm_cont, vm_cont_free);
 651
 652   scm_tc16_vm = scm_make_smob_type ("vm", 0);
 653   scm_set_smob_mark (scm_tc16_vm, vm_mark);
 654   scm_set_smob_free (scm_tc16_vm, vm_free);
 655   scm_set_smob_apply (scm_tc16_vm, scm_vm_apply, 1, 0, 1);
 656
 657   scm_c_define ("load-compiled",
 658                 scm_c_make_gsubr ("load-compiled/vm", 1, 0, 0,
 659                                   scm_load_compiled_with_vm));
 660
 661   sym_vm_run = scm_permanent_object (scm_from_locale_symbol ("vm-run"));
 662   sym_vm_error = scm_permanent_object (scm_from_locale_symbol ("vm-error"));
 663   sym_debug = scm_permanent_object (scm_from_locale_symbol ("debug"));
 664
 665   strappage = 1;
 666 }
 667
 668 void
 669 scm_init_vm (void)
 670 {
 671   scm_bootstrap_vm ();
 672
 673 #ifndef SCM_MAGIC_SNARFER
 674 #include "vm.x"
 675 #endif
 676 }
 677
 678 /*
 679   Local Variables:
 680   c-file-style: "gnu"
 681   End:
 682 */