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