libguile/vm.c

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