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/boehm-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   /* Make sure "bytes" is 64-bit aligned.  */
 184   scm_t_uint8 text[] = { scm_op_mv_call, 0, 0, 1,
 185                          scm_op_make_int8_1, scm_op_nop, scm_op_nop, scm_op_nop,
 186                          scm_op_halt };
 187   struct scm_objcode *bp;
 188   SCM ret;
 189
 190   if (SCM_UNLIKELY (nargs > 255 || nargs < 0))
 191     abort ();
 192   text[1] = (scm_t_uint8)nargs;
 193
 194   bp = scm_gc_malloc (sizeof (struct scm_objcode) + sizeof (text),
 195                       "make-u8vector");
 196   memcpy (bp->base, text, sizeof (text));
 197   bp->nargs = 0;
 198   bp->nrest = 0;
 199   bp->nlocs = 0;
 200   bp->len = sizeof(text);
 201   bp->metalen = 0;
 202   bp->unused = 0;
 203
 204   u8vec = scm_take_u8vector ((scm_t_uint8*)bp,
 205                              sizeof (struct scm_objcode) + sizeof (text));
 206   ret = scm_make_program (scm_bytecode_to_objcode (u8vec),
 207                           SCM_BOOL_F, SCM_BOOL_F);
 208   SCM_SET_SMOB_FLAGS (ret, SCM_F_PROGRAM_IS_BOOT);
 209
 210   return ret;
 211 }
 212 #define NUM_BOOT_PROGS 8
 213 static SCM
 214 vm_make_boot_program (long nargs)
 215 {
 216   static SCM programs[NUM_BOOT_PROGS] = { 0, };
 217
 218   if (SCM_UNLIKELY (!programs[0]))
 219     {
 220       int i;
 221       for (i = 0; i < NUM_BOOT_PROGS; i++)
 222         programs[i] = scm_permanent_object (really_make_boot_program (i));
 223     }
 224
 225   if (SCM_LIKELY (nargs < NUM_BOOT_PROGS))
 226     return programs[nargs];
 227   else
 228     return really_make_boot_program (nargs);
 229 }
 230
 231 \f
 232 /*
 233  * VM
 234  */
 235
 236 static SCM
 237 resolve_variable (SCM what, SCM program_module)
 238 {
 239   if (SCM_LIKELY (SCM_SYMBOLP (what)))
 240     {
 241       if (SCM_LIKELY (scm_module_system_booted_p
 242                       && scm_is_true (program_module)))
 243         /* might longjmp */
 244         return scm_module_lookup (program_module, what);
 245       else
 246         {
 247           SCM v = scm_sym2var (what, SCM_BOOL_F, SCM_BOOL_F);
 248           if (scm_is_false (v))
 249             scm_misc_error (NULL, "unbound variable: ~S", scm_list_1 (what));
 250           else
 251             return v;
 252         }
 253     }
 254   else
 255     {
 256       SCM mod;
 257       /* compilation of @ or @@
 258          `what' is a three-element list: (MODNAME SYM INTERFACE?)
 259          INTERFACE? is #t if we compiled @ or #f if we compiled @@
 260       */
 261       mod = scm_resolve_module (SCM_CAR (what));
 262       if (scm_is_true (SCM_CADDR (what)))
 263         mod = scm_module_public_interface (mod);
 264       if (SCM_FALSEP (mod))
 265         scm_misc_error (NULL, "no such module: ~S",
 266                         scm_list_1 (SCM_CAR (what)));
 267       /* might longjmp */
 268       return scm_module_lookup (mod, SCM_CADR (what));
 269     }
 270 }
 271
 272
 273 #define VM_DEFAULT_STACK_SIZE   (64 * 1024)
 274
 275 #define VM_NAME   vm_regular_engine
 276 #define FUNC_NAME "vm-regular-engine"
 277 #define VM_ENGINE SCM_VM_REGULAR_ENGINE
 278 #include "vm-engine.c"
 279 #undef VM_NAME
 280 #undef FUNC_NAME
 281 #undef VM_ENGINE
 282
 283 #define VM_NAME   vm_debug_engine
 284 #define FUNC_NAME "vm-debug-engine"
 285 #define VM_ENGINE SCM_VM_DEBUG_ENGINE
 286 #include "vm-engine.c"
 287 #undef VM_NAME
 288 #undef FUNC_NAME
 289 #undef VM_ENGINE
 290
 291 static const scm_t_vm_engine vm_engines[] =
 292   { vm_regular_engine, vm_debug_engine };
 293
 294 scm_t_bits scm_tc16_vm;
 295
 296 #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
 297
 298 /* The GC "kind" for the VM stack.  */
 299 static int vm_stack_gc_kind;
 300
 301 #endif
 302
 303 static SCM
 304 make_vm (void)
 305 #define FUNC_NAME "make_vm"
 306 {
 307   int i;
 308
 309   if (!scm_tc16_vm)
 310     return SCM_BOOL_F; /* not booted yet */
 311
 312   struct scm_vm *vp = scm_gc_malloc (sizeof (struct scm_vm), "vm");
 313
 314   vp->stack_size  = VM_DEFAULT_STACK_SIZE;
 315
 316 #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
 317   vp->stack_base = GC_generic_malloc (vp->stack_size * sizeof (SCM),
 318                                       vm_stack_gc_kind);
 319
 320   /* Keep a pointer to VP so that `vm_stack_mark ()' can know what the stack
 321      top is.  */
 322   *vp->stack_base = PTR2SCM (vp);
 323   vp->stack_base++;
 324   vp->stack_size--;
 325 #else
 326   vp->stack_base  = scm_gc_malloc (vp->stack_size * sizeof (SCM),
 327                                    "stack-base");
 328 #endif
 329
 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;
 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 #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
 349
 350 /* Mark the VM stack region between its base and its current top.  */
 351 static struct GC_ms_entry *
 352 vm_stack_mark (GC_word *addr, struct GC_ms_entry *mark_stack_ptr,
 353                struct GC_ms_entry *mark_stack_limit, GC_word env)
 354 {
 355   GC_word *word;
 356   const struct scm_vm *vm;
 357
 358   /* The first word of the VM stack should contain a pointer to the
 359      corresponding VM.  */
 360   vm = * ((struct scm_vm **) addr);
 361
 362   if (vm->stack_base == NULL)
 363     /* ADDR must be a pointer to a free-list element, which we must ignore
 364        (see warning in <gc/gc_mark.h>).  */
 365     return mark_stack_ptr;
 366
 367   /* Sanity checks.  */
 368   assert ((SCM *) addr == vm->stack_base - 1);
 369   assert (vm->sp >= (SCM *) addr);
 370   assert (vm->stack_limit - vm->stack_base == vm->stack_size);
 371
 372   for (word = (GC_word *) vm->stack_base; word <= (GC_word *) vm->sp; word++)
 373     mark_stack_ptr = GC_MARK_AND_PUSH ((* (GC_word **) word),
 374                                        mark_stack_ptr, mark_stack_limit,
 375                                        NULL);
 376
 377   return mark_stack_ptr;
 378 }
 379
 380 #endif /* VM_ENABLE_PRECISE_STACK_GC_SCAN */
 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_BOOL_F);
 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
 650   scm_tc16_vm = scm_make_smob_type ("vm", 0);
 651   scm_set_smob_apply (scm_tc16_vm, scm_vm_apply, 1, 0, 1);
 652
 653   scm_c_define ("load-compiled",
 654                 scm_c_make_gsubr ("load-compiled/vm", 1, 0, 0,
 655                                   scm_load_compiled_with_vm));
 656
 657   sym_vm_run = scm_permanent_object (scm_from_locale_symbol ("vm-run"));
 658   sym_vm_error = scm_permanent_object (scm_from_locale_symbol ("vm-error"));
 659   sym_debug = scm_permanent_object (scm_from_locale_symbol ("debug"));
 660
 661   scm_c_register_extension ("libguile", "scm_init_vm",
 662                             (scm_t_extension_init_func)scm_init_vm, NULL);
 663
 664   strappage = 1;
 665
 666 #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
 667   vm_stack_gc_kind =
 668     GC_new_kind (GC_new_free_list (),
 669                  GC_MAKE_PROC (GC_new_proc (vm_stack_mark), 0),
 670                  0, 1);
 671
 672 #endif
 673 }
 674
 675 void
 676 scm_init_vm (void)
 677 {
 678   scm_bootstrap_vm ();
 679
 680 #ifndef SCM_MAGIC_SNARFER
 681 #include "libguile/vm.x"
 682 #endif
 683 }
 684
 685 /*
 686   Local Variables:
 687   c-file-style: "gnu"
 688   End:
 689 */