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