libguile/vm.c

   1 /* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013 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 <alignof.h>
  26 #include <string.h>
  27 #include <stdint.h>
  28
  29 #include "libguile/bdw-gc.h"
  30 #include <gc/gc_mark.h>
  31
  32 #include "_scm.h"
  33 #include "control.h"
  34 #include "frames.h"
  35 #include "instructions.h"
  36 #include "loader.h"
  37 #include "programs.h"
  38 #include "vm.h"
  39 #include "vm-builtins.h"
  40
  41 #include "private-gc.h" /* scm_getenv_int */
  42
  43 static int vm_default_engine = SCM_VM_REGULAR_ENGINE;
  44
  45 /* Unfortunately we can't snarf these: snarfed things are only loaded up from
  46    (system vm vm), which might not be loaded before an error happens. */
  47 static SCM sym_vm_run;
  48 static SCM sym_vm_error;
  49 static SCM sym_keyword_argument_error;
  50 static SCM sym_regular;
  51 static SCM sym_debug;
  52
  53 /* The VM has a number of internal assertions that shouldn't normally be
  54    necessary, but might be if you think you found a bug in the VM. */
  55 #define VM_ENABLE_ASSERTIONS
  56
  57 /* #define VM_ENABLE_PARANOID_ASSERTIONS */
  58
  59 /* When defined, arrange so that the GC doesn't scan the VM stack beyond its
  60    current SP.  This should help avoid excess data retention.  See
  61    http://thread.gmane.org/gmane.comp.programming.garbage-collection.boehmgc/3001
  62    for a discussion.  */
  63 #define VM_ENABLE_PRECISE_STACK_GC_SCAN
  64
  65 /* Size in SCM objects of the stack reserve.  The reserve is used to run
  66    exception handling code in case of a VM stack overflow.  */
  67 #define VM_STACK_RESERVE_SIZE  512
  68
  69
  70 \f
  71 /*
  72  * VM Continuation
  73  */
  74
  75 void
  76 scm_i_vm_cont_print (SCM x, SCM port, scm_print_state *pstate)
  77 {
  78   scm_puts_unlocked ("#<vm-continuation ", port);
  79   scm_uintprint (SCM_UNPACK (x), 16, port);
  80   scm_puts_unlocked (">", port);
  81 }
  82
  83 /* In theory, a number of vm instances can be active in the call trace, and we
  84    only want to reify the continuations of those in the current continuation
  85    root. I don't see a nice way to do this -- ideally it would involve dynwinds,
  86    and previous values of the *the-vm* fluid within the current continuation
  87    root. But we don't have access to continuation roots in the dynwind stack.
  88    So, just punt for now, we just capture the continuation for the current VM.
  89
  90    While I'm on the topic, ideally we could avoid copying the C stack if the
  91    continuation root is inside VM code, and call/cc was invoked within that same
  92    call to vm_run; but that's currently not implemented.
  93  */
  94 SCM
  95 scm_i_vm_capture_stack (SCM *stack_base, SCM *fp, SCM *sp, scm_t_uint32 *ra,
  96                         scm_t_dynstack *dynstack, scm_t_uint32 flags)
  97 {
  98   struct scm_vm_cont *p;
  99
 100   p = scm_gc_malloc (sizeof (*p), "capture_vm_cont");
 101   p->stack_size = sp - stack_base + 1;
 102   p->stack_base = scm_gc_malloc (p->stack_size * sizeof (SCM),
 103                                  "capture_vm_cont");
 104   p->ra = ra;
 105   p->sp = sp;
 106   p->fp = fp;
 107   memcpy (p->stack_base, stack_base, (sp + 1 - stack_base) * sizeof (SCM));
 108   p->reloc = p->stack_base - stack_base;
 109   p->dynstack = dynstack;
 110   p->flags = flags;
 111   return scm_cell (scm_tc7_vm_cont, (scm_t_bits)p);
 112 }
 113
 114 static void
 115 vm_return_to_continuation (SCM vm, SCM cont, size_t n, SCM *argv)
 116 {
 117   struct scm_vm *vp;
 118   struct scm_vm_cont *cp;
 119   SCM *argv_copy;
 120
 121   argv_copy = alloca (n * sizeof(SCM));
 122   memcpy (argv_copy, argv, n * sizeof(SCM));
 123
 124   vp = SCM_VM_DATA (vm);
 125   cp = SCM_VM_CONT_DATA (cont);
 126
 127   if (vp->stack_size < cp->stack_size + n + 3)
 128     scm_misc_error ("vm-engine", "not enough space to reinstate continuation",
 129                     scm_list_2 (vm, cont));
 130
 131   vp->sp = cp->sp;
 132   vp->fp = cp->fp;
 133   memcpy (vp->stack_base, cp->stack_base, cp->stack_size * sizeof (SCM));
 134
 135   {
 136     size_t i;
 137
 138     /* Push on an empty frame, as the continuation expects.  */
 139     for (i = 0; i < 3; i++)
 140       {
 141         vp->sp++;
 142         *vp->sp = SCM_BOOL_F;
 143       }
 144
 145     /* Push the return values.  */
 146     for (i = 0; i < n; i++)
 147       {
 148         vp->sp++;
 149         *vp->sp = argv_copy[i];
 150       }
 151     vp->ip = cp->ra;
 152   }
 153 }
 154
 155 SCM
 156 scm_i_capture_current_stack (void)
 157 {
 158   scm_i_thread *thread;
 159   SCM vm;
 160   struct scm_vm *vp;
 161
 162   thread = SCM_I_CURRENT_THREAD;
 163   vm = scm_the_vm ();
 164   vp = SCM_VM_DATA (vm);
 165
 166   return scm_i_vm_capture_stack (vp->stack_base, vp->fp, vp->sp, vp->ip,
 167                                  scm_dynstack_capture_all (&thread->dynstack),
 168                                  0);
 169 }
 170
 171 static void vm_dispatch_apply_hook (SCM vm) SCM_NOINLINE;
 172 static void vm_dispatch_push_continuation_hook (SCM vm) SCM_NOINLINE;
 173 static void vm_dispatch_pop_continuation_hook (SCM vm, SCM *old_fp) SCM_NOINLINE;
 174 static void vm_dispatch_next_hook (SCM vm) SCM_NOINLINE;
 175 static void vm_dispatch_abort_hook (SCM vm) SCM_NOINLINE;
 176 static void vm_dispatch_restore_continuation_hook (SCM vm) SCM_NOINLINE;
 177
 178 static void
 179 vm_dispatch_hook (SCM vm, int hook_num, SCM *argv, int n)
 180 {
 181   struct scm_vm *vp;
 182   SCM hook;
 183   struct scm_frame c_frame;
 184   scm_t_cell *frame;
 185   int saved_trace_level;
 186
 187   vp = SCM_VM_DATA (vm);
 188   hook = vp->hooks[hook_num];
 189
 190   if (SCM_LIKELY (scm_is_false (hook))
 191       || scm_is_null (SCM_HOOK_PROCEDURES (hook)))
 192     return;
 193
 194   saved_trace_level = vp->trace_level;
 195   vp->trace_level = 0;
 196
 197   /* Allocate a frame object on the stack.  This is more efficient than calling
 198      `scm_c_make_frame ()' to allocate on the heap, but it forces hooks to not
 199      capture frame objects.
 200
 201      At the same time, procedures such as `frame-procedure' make sense only
 202      while the stack frame represented by the frame object is visible, so it
 203      seems reasonable to limit the lifetime of frame objects.  */
 204
 205   c_frame.stack_holder = vm;
 206   c_frame.fp_offset = vp->fp - vp->stack_base;
 207   c_frame.sp_offset = vp->sp - vp->stack_base;
 208   c_frame.ip = vp->ip;
 209
 210   /* Arrange for FRAME to be 8-byte aligned, like any other cell.  */
 211   frame = alloca (sizeof (*frame) + 8);
 212   frame = (scm_t_cell *) ROUND_UP ((scm_t_uintptr) frame, 8UL);
 213
 214   frame->word_0 = SCM_PACK (scm_tc7_frame);
 215   frame->word_1 = SCM_PACK_POINTER (&c_frame);
 216
 217   if (n == 0)
 218     {
 219       SCM args[1];
 220
 221       args[0] = SCM_PACK_POINTER (frame);
 222       scm_c_run_hookn (hook, args, 1);
 223     }
 224   else if (n == 1)
 225     {
 226       SCM args[2];
 227
 228       args[0] = SCM_PACK_POINTER (frame);
 229       args[1] = argv[0];
 230       scm_c_run_hookn (hook, args, 2);
 231     }
 232   else
 233     {
 234       SCM args = SCM_EOL;
 235
 236       while (n--)
 237         args = scm_cons (argv[n], args);
 238       scm_c_run_hook (hook, scm_cons (SCM_PACK_POINTER (frame), args));
 239     }
 240
 241   vp->trace_level = saved_trace_level;
 242 }
 243
 244 static void
 245 vm_dispatch_apply_hook (SCM vm)
 246 {
 247   return vm_dispatch_hook (vm, SCM_VM_APPLY_HOOK, NULL, 0);
 248 }
 249 static void vm_dispatch_push_continuation_hook (SCM vm)
 250 {
 251   return vm_dispatch_hook (vm, SCM_VM_PUSH_CONTINUATION_HOOK, NULL, 0);
 252 }
 253 static void vm_dispatch_pop_continuation_hook (SCM vm, SCM *old_fp)
 254 {
 255   struct scm_vm *vp = SCM_VM_DATA (vm);
 256   return vm_dispatch_hook (vm, SCM_VM_POP_CONTINUATION_HOOK,
 257                            &SCM_FRAME_LOCAL (old_fp, 1),
 258                            SCM_FRAME_NUM_LOCALS (old_fp, vp->sp) - 1);
 259 }
 260 static void vm_dispatch_next_hook (SCM vm)
 261 {
 262   return vm_dispatch_hook (vm, SCM_VM_NEXT_HOOK, NULL, 0);
 263 }
 264 static void vm_dispatch_abort_hook (SCM vm)
 265 {
 266   struct scm_vm *vp = SCM_VM_DATA (vm);
 267   return vm_dispatch_hook (vm, SCM_VM_ABORT_CONTINUATION_HOOK,
 268                            &SCM_FRAME_LOCAL (vp->fp, 1),
 269                            SCM_FRAME_NUM_LOCALS (vp->fp, vp->sp) - 1);
 270 }
 271 static void vm_dispatch_restore_continuation_hook (SCM vm)
 272 {
 273   return vm_dispatch_hook (vm, SCM_VM_RESTORE_CONTINUATION_HOOK, NULL, 0);
 274 }
 275
 276 static void
 277 vm_abort (SCM vm, SCM tag, size_t nstack, SCM *stack_args, SCM tail, SCM *sp,
 278           scm_i_jmp_buf *current_registers) SCM_NORETURN;
 279
 280 static void
 281 vm_abort (SCM vm, SCM tag, size_t nstack, SCM *stack_args, SCM tail, SCM *sp,
 282           scm_i_jmp_buf *current_registers)
 283 {
 284   size_t i;
 285   ssize_t tail_len;
 286   SCM *argv;
 287
 288   tail_len = scm_ilength (tail);
 289   if (tail_len < 0)
 290     scm_misc_error ("vm-engine", "tail values to abort should be a list",
 291                     scm_list_1 (tail));
 292
 293   argv = alloca ((nstack + tail_len) * sizeof (SCM));
 294   for (i = 0; i < nstack; i++)
 295     argv[i] = stack_args[i];
 296   for (; i < nstack + tail_len; i++, tail = scm_cdr (tail))
 297     argv[i] = scm_car (tail);
 298
 299   /* FIXME: NULLSTACK (SCM_VM_DATA (vp)->sp - sp) */
 300   SCM_VM_DATA (vm)->sp = sp;
 301
 302   scm_c_abort (vm, tag, nstack + tail_len, argv, current_registers);
 303 }
 304
 305 static void
 306 vm_reinstate_partial_continuation (SCM vm, SCM cont, size_t n, SCM *argv,
 307                                    scm_t_dynstack *dynstack,
 308                                    scm_i_jmp_buf *registers)
 309 {
 310   struct scm_vm *vp;
 311   struct scm_vm_cont *cp;
 312   SCM *argv_copy, *base;
 313   scm_t_ptrdiff reloc;
 314   size_t i;
 315
 316   argv_copy = alloca (n * sizeof(SCM));
 317   memcpy (argv_copy, argv, n * sizeof(SCM));
 318
 319   vp = SCM_VM_DATA (vm);
 320   cp = SCM_VM_CONT_DATA (cont);
 321   base = SCM_FRAME_LOCALS_ADDRESS (vp->fp);
 322   reloc = cp->reloc + (base - cp->stack_base);
 323
 324 #define RELOC(scm_p)                                            \
 325   (((SCM *) (scm_p)) + reloc)
 326
 327   if ((base - vp->stack_base) + cp->stack_size + n + 1 > vp->stack_size)
 328     scm_misc_error ("vm-engine",
 329                     "not enough space to instate partial continuation",
 330                     scm_list_2 (vm, cont));
 331
 332   memcpy (base, cp->stack_base, cp->stack_size * sizeof (SCM));
 333
 334   /* now relocate frame pointers */
 335   {
 336     SCM *fp;
 337     for (fp = RELOC (cp->fp);
 338          SCM_FRAME_LOWER_ADDRESS (fp) > base;
 339          fp = SCM_FRAME_DYNAMIC_LINK (fp))
 340       SCM_FRAME_SET_DYNAMIC_LINK (fp, RELOC (SCM_FRAME_DYNAMIC_LINK (fp)));
 341   }
 342
 343   vp->sp = base - 1 + cp->stack_size;
 344   vp->fp = RELOC (cp->fp);
 345   vp->ip = cp->ra;
 346
 347   /* Push the arguments. */
 348   for (i = 0; i < n; i++)
 349     {
 350       vp->sp++;
 351       *vp->sp = argv_copy[i];
 352     }
 353
 354   /* The prompt captured a slice of the dynamic stack.  Here we wind
 355      those entries onto the current thread's stack.  We also have to
 356      relocate any prompts that we see along the way.  */
 357   {
 358     scm_t_bits *walk;
 359
 360     for (walk = SCM_DYNSTACK_FIRST (cp->dynstack);
 361          SCM_DYNSTACK_TAG (walk);
 362          walk = SCM_DYNSTACK_NEXT (walk))
 363       {
 364         scm_t_bits tag = SCM_DYNSTACK_TAG (walk);
 365
 366         if (SCM_DYNSTACK_TAG_TYPE (tag) == SCM_DYNSTACK_TYPE_PROMPT)
 367           scm_dynstack_wind_prompt (dynstack, walk, reloc, registers);
 368         else
 369           scm_dynstack_wind_1 (dynstack, walk);
 370       }
 371   }
 372 #undef RELOC
 373 }
 374
 375 \f
 376 /*
 377  * VM Internal functions
 378  */
 379
 380 void
 381 scm_i_vm_print (SCM x, SCM port, scm_print_state *pstate)
 382 {
 383   const struct scm_vm *vm;
 384
 385   vm = SCM_VM_DATA (x);
 386
 387   scm_puts_unlocked ("#<vm ", port);
 388   switch (vm->engine)
 389     {
 390     case SCM_VM_REGULAR_ENGINE:
 391       scm_puts_unlocked ("regular-engine ", port);
 392       break;
 393
 394     case SCM_VM_DEBUG_ENGINE:
 395       scm_puts_unlocked ("debug-engine ", port);
 396       break;
 397
 398     default:
 399       scm_puts_unlocked ("unknown-engine ", port);
 400     }
 401   scm_uintprint (SCM_UNPACK (x), 16, port);
 402   scm_puts_unlocked (">", port);
 403 }
 404
 405 \f
 406 /*
 407  * VM Error Handling
 408  */
 409
 410 static void vm_error (const char *msg, SCM arg) SCM_NORETURN;
 411 static void vm_error_bad_instruction (scm_t_uint32 inst) SCM_NORETURN SCM_NOINLINE;
 412 static void vm_error_unbound (SCM proc, SCM sym) SCM_NORETURN SCM_NOINLINE;
 413 static void vm_error_unbound_fluid (SCM proc, SCM fluid) SCM_NORETURN SCM_NOINLINE;
 414 static void vm_error_not_a_variable (const char *func_name, SCM x) SCM_NORETURN SCM_NOINLINE;
 415 static void vm_error_apply_to_non_list (SCM x) SCM_NORETURN SCM_NOINLINE;
 416 static void vm_error_kwargs_length_not_even (SCM proc) SCM_NORETURN SCM_NOINLINE;
 417 static void vm_error_kwargs_invalid_keyword (SCM proc, SCM obj) SCM_NORETURN SCM_NOINLINE;
 418 static void vm_error_kwargs_unrecognized_keyword (SCM proc, SCM kw) SCM_NORETURN SCM_NOINLINE;
 419 static void vm_error_too_many_args (int nargs) SCM_NORETURN SCM_NOINLINE;
 420 static void vm_error_wrong_num_args (SCM proc) SCM_NORETURN SCM_NOINLINE;
 421 static void vm_error_wrong_type_apply (SCM proc) SCM_NORETURN SCM_NOINLINE;
 422 static void vm_error_stack_overflow (struct scm_vm *vp) SCM_NORETURN SCM_NOINLINE;
 423 static void vm_error_stack_underflow (void) SCM_NORETURN SCM_NOINLINE;
 424 static void vm_error_improper_list (SCM x) SCM_NORETURN SCM_NOINLINE;
 425 static void vm_error_not_a_pair (const char *subr, SCM x) SCM_NORETURN SCM_NOINLINE;
 426 static void vm_error_not_a_bytevector (const char *subr, SCM x) SCM_NORETURN SCM_NOINLINE;
 427 static void vm_error_not_a_struct (const char *subr, SCM x) SCM_NORETURN SCM_NOINLINE;
 428 static void vm_error_no_values (void) SCM_NORETURN SCM_NOINLINE;
 429 static void vm_error_not_enough_values (void) SCM_NORETURN SCM_NOINLINE;
 430 static void vm_error_wrong_number_of_values (scm_t_uint32 expected) SCM_NORETURN SCM_NOINLINE;
 431 static void vm_error_continuation_not_rewindable (SCM cont) SCM_NORETURN SCM_NOINLINE;
 432 static void vm_error_bad_wide_string_length (size_t len) SCM_NORETURN SCM_NOINLINE;
 433
 434 static void
 435 vm_error (const char *msg, SCM arg)
 436 {
 437   scm_throw (sym_vm_error,
 438              scm_list_3 (sym_vm_run, scm_from_latin1_string (msg),
 439                          SCM_UNBNDP (arg) ? SCM_EOL : scm_list_1 (arg)));
 440   abort(); /* not reached */
 441 }
 442
 443 static void
 444 vm_error_bad_instruction (scm_t_uint32 inst)
 445 {
 446   vm_error ("VM: Bad instruction: ~s", scm_from_uint32 (inst));
 447 }
 448
 449 static void
 450 vm_error_unbound (SCM proc, SCM sym)
 451 {
 452   scm_error_scm (scm_misc_error_key, proc,
 453                  scm_from_latin1_string ("Unbound variable: ~s"),
 454                  scm_list_1 (sym), SCM_BOOL_F);
 455 }
 456
 457 static void
 458 vm_error_unbound_fluid (SCM proc, SCM fluid)
 459 {
 460   scm_error_scm (scm_misc_error_key, proc,
 461                  scm_from_latin1_string ("Unbound fluid: ~s"),
 462                  scm_list_1 (fluid), SCM_BOOL_F);
 463 }
 464
 465 static void
 466 vm_error_not_a_variable (const char *func_name, SCM x)
 467 {
 468   scm_error (scm_arg_type_key, func_name, "Not a variable: ~S",
 469              scm_list_1 (x), scm_list_1 (x));
 470 }
 471
 472 static void
 473 vm_error_apply_to_non_list (SCM x)
 474 {
 475   scm_error (scm_arg_type_key, "apply", "Apply to non-list: ~S",
 476              scm_list_1 (x), scm_list_1 (x));
 477 }
 478
 479 static void
 480 vm_error_kwargs_length_not_even (SCM proc)
 481 {
 482   scm_error_scm (sym_keyword_argument_error, proc,
 483                  scm_from_latin1_string ("Odd length of keyword argument list"),
 484                  SCM_EOL, SCM_BOOL_F);
 485 }
 486
 487 static void
 488 vm_error_kwargs_invalid_keyword (SCM proc, SCM obj)
 489 {
 490   scm_error_scm (sym_keyword_argument_error, proc,
 491                  scm_from_latin1_string ("Invalid keyword"),
 492                  SCM_EOL, scm_list_1 (obj));
 493 }
 494
 495 static void
 496 vm_error_kwargs_unrecognized_keyword (SCM proc, SCM kw)
 497 {
 498   scm_error_scm (sym_keyword_argument_error, proc,
 499                  scm_from_latin1_string ("Unrecognized keyword"),
 500                  SCM_EOL, scm_list_1 (kw));
 501 }
 502
 503 static void
 504 vm_error_too_many_args (int nargs)
 505 {
 506   vm_error ("VM: Too many arguments", scm_from_int (nargs));
 507 }
 508
 509 static void
 510 vm_error_wrong_num_args (SCM proc)
 511 {
 512   scm_wrong_num_args (proc);
 513 }
 514
 515 static void
 516 vm_error_wrong_type_apply (SCM proc)
 517 {
 518   scm_error (scm_arg_type_key, NULL, "Wrong type to apply: ~S",
 519              scm_list_1 (proc), scm_list_1 (proc));
 520 }
 521
 522 static void
 523 vm_error_stack_overflow (struct scm_vm *vp)
 524 {
 525   if (vp->stack_limit < vp->stack_base + vp->stack_size)
 526     /* There are VM_STACK_RESERVE_SIZE bytes left.  Make them available so
 527        that `throw' below can run on this VM.  */
 528     vp->stack_limit = vp->stack_base + vp->stack_size;
 529   else
 530     /* There is no space left on the stack.  FIXME: Do something more
 531        sensible here! */
 532     abort ();
 533   vm_error ("VM: Stack overflow", SCM_UNDEFINED);
 534 }
 535
 536 static void
 537 vm_error_stack_underflow (void)
 538 {
 539   vm_error ("VM: Stack underflow", SCM_UNDEFINED);
 540 }
 541
 542 static void
 543 vm_error_improper_list (SCM x)
 544 {
 545   vm_error ("Expected a proper list, but got object with tail ~s", x);
 546 }
 547
 548 static void
 549 vm_error_not_a_pair (const char *subr, SCM x)
 550 {
 551   scm_wrong_type_arg_msg (subr, 1, x, "pair");
 552 }
 553
 554 static void
 555 vm_error_not_a_bytevector (const char *subr, SCM x)
 556 {
 557   scm_wrong_type_arg_msg (subr, 1, x, "bytevector");
 558 }
 559
 560 static void
 561 vm_error_not_a_struct (const char *subr, SCM x)
 562 {
 563   scm_wrong_type_arg_msg (subr, 1, x, "struct");
 564 }
 565
 566 static void
 567 vm_error_no_values (void)
 568 {
 569   vm_error ("Zero values returned to single-valued continuation",
 570             SCM_UNDEFINED);
 571 }
 572
 573 static void
 574 vm_error_not_enough_values (void)
 575 {
 576   vm_error ("Too few values returned to continuation", SCM_UNDEFINED);
 577 }
 578
 579 static void
 580 vm_error_wrong_number_of_values (scm_t_uint32 expected)
 581 {
 582   vm_error ("Wrong number of values returned to continuation (expected ~a)",
 583             scm_from_uint32 (expected));
 584 }
 585
 586 static void
 587 vm_error_continuation_not_rewindable (SCM cont)
 588 {
 589   vm_error ("Unrewindable partial continuation", cont);
 590 }
 591
 592 static void
 593 vm_error_bad_wide_string_length (size_t len)
 594 {
 595   vm_error ("VM: Bad wide string length: ~S", scm_from_size_t (len));
 596 }
 597
 598
 599 \f
 600
 601 static SCM vm_boot_continuation;
 602 static SCM vm_builtin_apply;
 603 static SCM vm_builtin_values;
 604 static SCM vm_builtin_abort_to_prompt;
 605 static SCM vm_builtin_call_with_values;
 606 static SCM vm_builtin_call_with_current_continuation;
 607
 608 static const scm_t_uint32 vm_boot_continuation_code[] = {
 609   SCM_PACK_OP_24 (halt, 0)
 610 };
 611
 612 static const scm_t_uint32 vm_builtin_apply_code[] = {
 613   SCM_PACK_OP_24 (assert_nargs_ge, 3),
 614   SCM_PACK_OP_24 (tail_apply, 0), /* proc in r1, args from r2 */
 615 };
 616
 617 static const scm_t_uint32 vm_builtin_values_code[] = {
 618   SCM_PACK_OP_24 (return_values, 0) /* vals from r1 */
 619 };
 620
 621 static const scm_t_uint32 vm_builtin_abort_to_prompt_code[] = {
 622   SCM_PACK_OP_24 (assert_nargs_ge, 2),
 623   SCM_PACK_OP_24 (abort, 0), /* tag in r1, vals from r2 */
 624   /* FIXME: Partial continuation should capture caller regs.  */
 625   SCM_PACK_OP_24 (return_values, 0) /* vals from r1 */
 626 };
 627
 628 static const scm_t_uint32 vm_builtin_call_with_values_code[] = {
 629   SCM_PACK_OP_24 (assert_nargs_ee, 3),
 630   SCM_PACK_OP_24 (alloc_frame, 7),
 631   SCM_PACK_OP_12_12 (mov, 6, 1),
 632   SCM_PACK_OP_24 (call, 6), SCM_PACK_OP_ARG_8_24 (0, 1),
 633   SCM_PACK_OP_12_12 (mov, 0, 2),
 634   SCM_PACK_OP_24 (tail_call_shuffle, 7)
 635 };
 636
 637 static const scm_t_uint32 vm_builtin_call_with_current_continuation_code[] = {
 638   SCM_PACK_OP_24 (assert_nargs_ee, 2),
 639   SCM_PACK_OP_24 (call_cc, 0)
 640 };
 641
 642
 643 static SCM
 644 scm_vm_builtin_ref (unsigned idx)
 645 {
 646   switch (idx)
 647     {
 648 #define INDEX_TO_NAME(builtin, BUILTIN, req, opt, rest)                 \
 649       case SCM_VM_BUILTIN_##BUILTIN: return vm_builtin_##builtin;
 650       FOR_EACH_VM_BUILTIN(INDEX_TO_NAME)
 651 #undef INDEX_TO_NAME
 652       default: abort();
 653     }
 654 }
 655
 656 SCM scm_sym_apply;
 657 static SCM scm_sym_values;
 658 static SCM scm_sym_abort_to_prompt;
 659 static SCM scm_sym_call_with_values;
 660 static SCM scm_sym_call_with_current_continuation;
 661
 662 SCM
 663 scm_vm_builtin_name_to_index (SCM name)
 664 #define FUNC_NAME "builtin-name->index"
 665 {
 666   SCM_VALIDATE_SYMBOL (1, name);
 667
 668 #define NAME_TO_INDEX(builtin, BUILTIN, req, opt, rest) \
 669   if (scm_is_eq (name, scm_sym_##builtin))              \
 670     return scm_from_uint (SCM_VM_BUILTIN_##BUILTIN);
 671   FOR_EACH_VM_BUILTIN(NAME_TO_INDEX)
 672 #undef NAME_TO_INDEX
 673
 674   return SCM_BOOL_F;
 675 }
 676 #undef FUNC_NAME
 677
 678 SCM
 679 scm_vm_builtin_index_to_name (SCM index)
 680 #define FUNC_NAME "builtin-index->name"
 681 {
 682   unsigned idx;
 683
 684   SCM_VALIDATE_UINT_COPY (1, index, idx);
 685
 686   switch (idx)
 687     {
 688 #define INDEX_TO_NAME(builtin, BUILTIN, req, opt, rest)         \
 689       case SCM_VM_BUILTIN_##BUILTIN: return scm_sym_##builtin;
 690       FOR_EACH_VM_BUILTIN(INDEX_TO_NAME)
 691 #undef INDEX_TO_NAME
 692       default: return SCM_BOOL_F;
 693     }
 694 }
 695 #undef FUNC_NAME
 696
 697 static void
 698 scm_init_vm_builtins (void)
 699 {
 700   scm_c_define_gsubr ("builtin-name->index", 1, 0, 0,
 701                       scm_vm_builtin_name_to_index);
 702   scm_c_define_gsubr ("builtin-index->name", 1, 0, 0,
 703                       scm_vm_builtin_index_to_name);
 704 }
 705
 706 SCM
 707 scm_i_call_with_current_continuation (SCM proc)
 708 {
 709   return scm_call_1 (vm_builtin_call_with_current_continuation, proc);
 710 }
 711
 712 \f
 713 /*
 714  * VM
 715  */
 716
 717 #define VM_MIN_STACK_SIZE       (1024)
 718 #define VM_DEFAULT_STACK_SIZE   (256 * 1024)
 719 static size_t vm_stack_size = VM_DEFAULT_STACK_SIZE;
 720
 721 static void
 722 initialize_default_stack_size (void)
 723 {
 724   int size = scm_getenv_int ("GUILE_STACK_SIZE", vm_stack_size);
 725   if (size >= VM_MIN_STACK_SIZE)
 726     vm_stack_size = size;
 727 }
 728
 729 #define VM_NAME vm_regular_engine
 730 #define VM_USE_HOOKS 0
 731 #define FUNC_NAME "vm-regular-engine"
 732 #include "vm-engine.c"
 733 #undef FUNC_NAME
 734 #undef VM_USE_HOOKS
 735 #undef VM_NAME
 736
 737 #define VM_NAME vm_debug_engine
 738 #define VM_USE_HOOKS 1
 739 #define FUNC_NAME "vm-debug-engine"
 740 #include "vm-engine.c"
 741 #undef FUNC_NAME
 742 #undef VM_USE_HOOKS
 743 #undef VM_NAME
 744
 745 typedef SCM (*scm_t_vm_engine) (SCM vm, SCM program, SCM *argv, size_t nargs);
 746
 747 static const scm_t_vm_engine vm_engines[SCM_VM_NUM_ENGINES] =
 748   { vm_regular_engine, vm_debug_engine };
 749
 750 #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
 751
 752 /* The GC "kind" for the VM stack.  */
 753 static int vm_stack_gc_kind;
 754
 755 #endif
 756
 757 static SCM
 758 make_vm (void)
 759 #define FUNC_NAME "make_vm"
 760 {
 761   int i;
 762   struct scm_vm *vp;
 763
 764   vp = scm_gc_malloc (sizeof (struct scm_vm), "vm");
 765
 766   vp->stack_size= vm_stack_size;
 767
 768 #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
 769   vp->stack_base = (SCM *)
 770     GC_generic_malloc (vp->stack_size * sizeof (SCM), vm_stack_gc_kind);
 771
 772   /* Keep a pointer to VP so that `vm_stack_mark ()' can know what the stack
 773      top is.  */
 774   *vp->stack_base = SCM_PACK_POINTER (vp);
 775   vp->stack_base++;
 776   vp->stack_size--;
 777 #else
 778   vp->stack_base  = scm_gc_malloc (vp->stack_size * sizeof (SCM),
 779                                    "stack-base");
 780 #endif
 781
 782   vp->stack_limit = vp->stack_base + vp->stack_size - VM_STACK_RESERVE_SIZE;
 783   vp->ip          = NULL;
 784   vp->sp          = vp->stack_base - 1;
 785   vp->fp          = NULL;
 786   vp->engine      = vm_default_engine;
 787   vp->trace_level = 0;
 788   for (i = 0; i < SCM_VM_NUM_HOOKS; i++)
 789     vp->hooks[i] = SCM_BOOL_F;
 790   return scm_cell (scm_tc7_vm, (scm_t_bits)vp);
 791 }
 792 #undef FUNC_NAME
 793
 794 #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
 795
 796 /* Mark the VM stack region between its base and its current top.  */
 797 static struct GC_ms_entry *
 798 vm_stack_mark (GC_word *addr, struct GC_ms_entry *mark_stack_ptr,
 799                struct GC_ms_entry *mark_stack_limit, GC_word env)
 800 {
 801   GC_word *word;
 802   const struct scm_vm *vm;
 803
 804   /* The first word of the VM stack should contain a pointer to the
 805      corresponding VM.  */
 806   vm = * ((struct scm_vm **) addr);
 807
 808   if (vm == NULL
 809       || (SCM *) addr != vm->stack_base - 1)
 810     /* ADDR must be a pointer to a free-list element, which we must ignore
 811        (see warning in <gc/gc_mark.h>).  */
 812     return mark_stack_ptr;
 813
 814   for (word = (GC_word *) vm->stack_base; word <= (GC_word *) vm->sp; word++)
 815     mark_stack_ptr = GC_MARK_AND_PUSH ((* (GC_word **) word),
 816                                        mark_stack_ptr, mark_stack_limit,
 817                                        NULL);
 818
 819   return mark_stack_ptr;
 820 }
 821
 822 #endif /* VM_ENABLE_PRECISE_STACK_GC_SCAN */
 823
 824
 825 SCM
 826 scm_c_vm_run (SCM vm, SCM program, SCM *argv, int nargs)
 827 {
 828   struct scm_vm *vp = SCM_VM_DATA (vm);
 829   SCM_CHECK_STACK;
 830   return vm_engines[vp->engine](vm, program, argv, nargs);
 831 }
 832
 833 /* Scheme interface */
 834
 835 SCM_DEFINE (scm_the_vm, "the-vm", 0, 0, 0,
 836             (void),
 837             "Return the current thread's VM.")
 838 #define FUNC_NAME s_scm_the_vm
 839 {
 840   scm_i_thread *t = SCM_I_CURRENT_THREAD;
 841
 842   if (SCM_UNLIKELY (scm_is_false (t->vm)))
 843     t->vm = make_vm ();
 844
 845   return t->vm;
 846 }
 847 #undef FUNC_NAME
 848
 849
 850 SCM_DEFINE (scm_vm_p, "vm?", 1, 0, 0,
 851             (SCM obj),
 852             "")
 853 #define FUNC_NAME s_scm_vm_p
 854 {
 855   return scm_from_bool (SCM_VM_P (obj));
 856 }
 857 #undef FUNC_NAME
 858
 859 SCM_DEFINE (scm_make_vm, "make-vm", 0, 0, 0,
 860             (void),
 861             "")
 862 #define FUNC_NAME s_scm_make_vm,
 863 {
 864   return make_vm ();
 865 }
 866 #undef FUNC_NAME
 867
 868 SCM_DEFINE (scm_vm_ip, "vm:ip", 1, 0, 0,
 869             (SCM vm),
 870             "")
 871 #define FUNC_NAME s_scm_vm_ip
 872 {
 873   SCM_VALIDATE_VM (1, vm);
 874   return scm_from_unsigned_integer ((scm_t_bits) SCM_VM_DATA (vm)->ip);
 875 }
 876 #undef FUNC_NAME
 877
 878 SCM_DEFINE (scm_vm_sp, "vm:sp", 1, 0, 0,
 879             (SCM vm),
 880             "")
 881 #define FUNC_NAME s_scm_vm_sp
 882 {
 883   SCM_VALIDATE_VM (1, vm);
 884   return scm_from_unsigned_integer ((scm_t_bits) SCM_VM_DATA (vm)->sp);
 885 }
 886 #undef FUNC_NAME
 887
 888 SCM_DEFINE (scm_vm_fp, "vm:fp", 1, 0, 0,
 889             (SCM vm),
 890             "")
 891 #define FUNC_NAME s_scm_vm_fp
 892 {
 893   SCM_VALIDATE_VM (1, vm);
 894   return scm_from_unsigned_integer ((scm_t_bits) SCM_VM_DATA (vm)->fp);
 895 }
 896 #undef FUNC_NAME
 897
 898 #define VM_DEFINE_HOOK(n)                               \
 899 {                                                       \
 900   struct scm_vm *vp;                                    \
 901   SCM_VALIDATE_VM (1, vm);                              \
 902   vp = SCM_VM_DATA (vm);                                \
 903   if (scm_is_false (vp->hooks[n]))                      \
 904     vp->hooks[n] = scm_make_hook (SCM_I_MAKINUM (1));   \
 905   return vp->hooks[n];                                  \
 906 }
 907
 908 SCM_DEFINE (scm_vm_apply_hook, "vm-apply-hook", 1, 0, 0,
 909             (SCM vm),
 910             "")
 911 #define FUNC_NAME s_scm_vm_apply_hook
 912 {
 913   VM_DEFINE_HOOK (SCM_VM_APPLY_HOOK);
 914 }
 915 #undef FUNC_NAME
 916
 917 SCM_DEFINE (scm_vm_push_continuation_hook, "vm-push-continuation-hook", 1, 0, 0,
 918             (SCM vm),
 919             "")
 920 #define FUNC_NAME s_scm_vm_push_continuation_hook
 921 {
 922   VM_DEFINE_HOOK (SCM_VM_PUSH_CONTINUATION_HOOK);
 923 }
 924 #undef FUNC_NAME
 925
 926 SCM_DEFINE (scm_vm_pop_continuation_hook, "vm-pop-continuation-hook", 1, 0, 0,
 927             (SCM vm),
 928             "")
 929 #define FUNC_NAME s_scm_vm_pop_continuation_hook
 930 {
 931   VM_DEFINE_HOOK (SCM_VM_POP_CONTINUATION_HOOK);
 932 }
 933 #undef FUNC_NAME
 934
 935 SCM_DEFINE (scm_vm_next_hook, "vm-next-hook", 1, 0, 0,
 936             (SCM vm),
 937             "")
 938 #define FUNC_NAME s_scm_vm_next_hook
 939 {
 940   VM_DEFINE_HOOK (SCM_VM_NEXT_HOOK);
 941 }
 942 #undef FUNC_NAME
 943
 944 SCM_DEFINE (scm_vm_abort_continuation_hook, "vm-abort-continuation-hook", 1, 0, 0,
 945             (SCM vm),
 946             "")
 947 #define FUNC_NAME s_scm_vm_abort_continuation_hook
 948 {
 949   VM_DEFINE_HOOK (SCM_VM_ABORT_CONTINUATION_HOOK);
 950 }
 951 #undef FUNC_NAME
 952
 953 SCM_DEFINE (scm_vm_restore_continuation_hook, "vm-restore-continuation-hook", 1, 0, 0,
 954             (SCM vm),
 955             "")
 956 #define FUNC_NAME s_scm_vm_restore_continuation_hook
 957 {
 958   VM_DEFINE_HOOK (SCM_VM_RESTORE_CONTINUATION_HOOK);
 959 }
 960 #undef FUNC_NAME
 961
 962 SCM_DEFINE (scm_vm_trace_level, "vm-trace-level", 1, 0, 0,
 963             (SCM vm),
 964             "")
 965 #define FUNC_NAME s_scm_vm_trace_level
 966 {
 967   SCM_VALIDATE_VM (1, vm);
 968   return scm_from_int (SCM_VM_DATA (vm)->trace_level);
 969 }
 970 #undef FUNC_NAME
 971
 972 SCM_DEFINE (scm_set_vm_trace_level_x, "set-vm-trace-level!", 2, 0, 0,
 973             (SCM vm, SCM level),
 974             "")
 975 #define FUNC_NAME s_scm_set_vm_trace_level_x
 976 {
 977   SCM_VALIDATE_VM (1, vm);
 978   SCM_VM_DATA (vm)->trace_level = scm_to_int (level);
 979   return SCM_UNSPECIFIED;
 980 }
 981 #undef FUNC_NAME
 982
 983 \f
 984 /*
 985  * VM engines
 986  */
 987
 988 static int
 989 symbol_to_vm_engine (SCM engine, const char *FUNC_NAME)
 990 {
 991   if (scm_is_eq (engine, sym_regular))
 992     return SCM_VM_REGULAR_ENGINE;
 993   else if (scm_is_eq (engine, sym_debug))
 994     return SCM_VM_DEBUG_ENGINE;
 995   else
 996     SCM_MISC_ERROR ("Unknown VM engine: ~a", scm_list_1 (engine));
 997 }
 998
 999 static SCM
1000 vm_engine_to_symbol (int engine, const char *FUNC_NAME)
1001 {
1002   switch (engine)
1003     {
1004     case SCM_VM_REGULAR_ENGINE:
1005       return sym_regular;
1006     case SCM_VM_DEBUG_ENGINE:
1007       return sym_debug;
1008     default:
1009       /* ? */
1010       SCM_MISC_ERROR ("Unknown VM engine: ~a",
1011                       scm_list_1 (scm_from_int (engine)));
1012     }
1013 }
1014
1015 SCM_DEFINE (scm_vm_engine, "vm-engine", 1, 0, 0,
1016             (SCM vm),
1017             "")
1018 #define FUNC_NAME s_scm_vm_engine
1019 {
1020   SCM_VALIDATE_VM (1, vm);
1021   return vm_engine_to_symbol (SCM_VM_DATA (vm)->engine, FUNC_NAME);
1022 }
1023 #undef FUNC_NAME
1024
1025 void
1026 scm_c_set_vm_engine_x (SCM vm, int engine)
1027 #define FUNC_NAME "set-vm-engine!"
1028 {
1029   SCM_VALIDATE_VM (1, vm);
1030
1031   if (engine < 0 || engine >= SCM_VM_NUM_ENGINES)
1032     SCM_MISC_ERROR ("Unknown VM engine: ~a",
1033                     scm_list_1 (scm_from_int (engine)));
1034
1035   SCM_VM_DATA (vm)->engine = engine;
1036 }
1037 #undef FUNC_NAME
1038
1039 SCM_DEFINE (scm_set_vm_engine_x, "set-vm-engine!", 2, 0, 0,
1040             (SCM vm, SCM engine),
1041             "")
1042 #define FUNC_NAME s_scm_set_vm_engine_x
1043 {
1044   scm_c_set_vm_engine_x (vm, symbol_to_vm_engine (engine, FUNC_NAME));
1045   return SCM_UNSPECIFIED;
1046 }
1047 #undef FUNC_NAME
1048
1049 void
1050 scm_c_set_default_vm_engine_x (int engine)
1051 #define FUNC_NAME "set-default-vm-engine!"
1052 {
1053   if (engine < 0 || engine >= SCM_VM_NUM_ENGINES)
1054     SCM_MISC_ERROR ("Unknown VM engine: ~a",
1055                     scm_list_1 (scm_from_int (engine)));
1056
1057   vm_default_engine = engine;
1058 }
1059 #undef FUNC_NAME
1060
1061 SCM_DEFINE (scm_set_default_vm_engine_x, "set-default-vm-engine!", 1, 0, 0,
1062             (SCM engine),
1063             "")
1064 #define FUNC_NAME s_scm_set_default_vm_engine_x
1065 {
1066   scm_c_set_default_vm_engine_x (symbol_to_vm_engine (engine, FUNC_NAME));
1067   return SCM_UNSPECIFIED;
1068 }
1069 #undef FUNC_NAME
1070
1071 static void reinstate_vm (SCM vm)
1072 {
1073   scm_i_thread *t = SCM_I_CURRENT_THREAD;
1074   t->vm = vm;
1075 }
1076
1077 SCM_DEFINE (scm_call_with_vm, "call-with-vm", 2, 0, 1,
1078             (SCM vm, SCM proc, SCM args),
1079             "Apply @var{proc} to @var{args} in a dynamic extent in which\n"
1080             "@var{vm} is the current VM.\n\n"
1081             "As an implementation restriction, if @var{vm} is not the same\n"
1082             "as the current thread's VM, continuations captured within the\n"
1083             "call to @var{proc} may not be reinstated once control leaves\n"
1084             "@var{proc}.")
1085 #define FUNC_NAME s_scm_call_with_vm
1086 {
1087   SCM prev_vm, ret;
1088   SCM *argv;
1089   int i, nargs;
1090   scm_t_wind_flags flags;
1091   scm_i_thread *t = SCM_I_CURRENT_THREAD;
1092
1093   SCM_VALIDATE_VM (1, vm);
1094   SCM_VALIDATE_PROC (2, proc);
1095
1096   nargs = scm_ilength (args);
1097   if (SCM_UNLIKELY (nargs < 0))
1098     scm_wrong_type_arg_msg (FUNC_NAME, 3, args, "list");
1099
1100   argv = alloca (nargs * sizeof(SCM));
1101   for (i = 0; i < nargs; i++)
1102     {
1103       argv[i] = SCM_CAR (args);
1104       args = SCM_CDR (args);
1105     }
1106
1107   prev_vm = t->vm;
1108
1109   /* Reentry can happen via invokation of a saved continuation, but
1110      continuations only save the state of the VM that they are in at
1111      capture-time, which might be different from this one.  So, in the
1112      case that the VMs are different, set up a non-rewindable frame to
1113      prevent reinstating an incomplete continuation.  */
1114   flags = scm_is_eq (prev_vm, vm) ? 0 : SCM_F_WIND_EXPLICITLY;
1115   if (flags)
1116     {
1117       scm_dynwind_begin (0);
1118       scm_dynwind_unwind_handler_with_scm (reinstate_vm, prev_vm, flags);
1119       t->vm = vm;
1120     }
1121
1122   ret = scm_c_vm_run (vm, proc, argv, nargs);
1123
1124   if (flags)
1125     scm_dynwind_end ();
1126
1127   return ret;
1128 }
1129 #undef FUNC_NAME
1130
1131 \f
1132 /*
1133  * Initialize
1134  */
1135
1136 SCM scm_load_compiled_with_vm (SCM file)
1137 {
1138   SCM program = scm_load_thunk_from_file (file);
1139
1140   return scm_c_vm_run (scm_the_vm (), program, NULL, 0);
1141 }
1142
1143
1144 void
1145 scm_init_vm_builtin_properties (void)
1146 {
1147   /* FIXME: Seems hacky to do this here, but oh well :/ */
1148   scm_sym_apply = scm_from_utf8_symbol ("apply");
1149   scm_sym_values = scm_from_utf8_symbol ("values");
1150   scm_sym_abort_to_prompt = scm_from_utf8_symbol ("abort-to-prompt");
1151   scm_sym_call_with_values = scm_from_utf8_symbol ("call-with-values");
1152   scm_sym_call_with_current_continuation =
1153     scm_from_utf8_symbol ("call-with-current-continuation");
1154
1155 #define INIT_BUILTIN(builtin, BUILTIN, req, opt, rest)                  \
1156   scm_set_procedure_property_x (vm_builtin_##builtin, scm_sym_name,     \
1157                                 scm_sym_##builtin);                     \
1158   scm_set_procedure_minimum_arity_x (vm_builtin_##builtin,              \
1159                                      SCM_I_MAKINUM (req),               \
1160                                      SCM_I_MAKINUM (opt),               \
1161                                      scm_from_bool (rest));
1162   FOR_EACH_VM_BUILTIN (INIT_BUILTIN);
1163 #undef INIT_BUILTIN
1164 }
1165
1166 void
1167 scm_bootstrap_vm (void)
1168 {
1169   scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
1170                             "scm_init_vm",
1171                             (scm_t_extension_init_func)scm_init_vm, NULL);
1172   scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
1173                             "scm_init_vm_builtins",
1174                             (scm_t_extension_init_func)scm_init_vm_builtins,
1175                             NULL);
1176
1177   initialize_default_stack_size ();
1178
1179   sym_vm_run = scm_from_latin1_symbol ("vm-run");
1180   sym_vm_error = scm_from_latin1_symbol ("vm-error");
1181   sym_keyword_argument_error = scm_from_latin1_symbol ("keyword-argument-error");
1182   sym_regular = scm_from_latin1_symbol ("regular");
1183   sym_debug = scm_from_latin1_symbol ("debug");
1184
1185   vm_boot_continuation = scm_i_make_program (vm_boot_continuation_code);
1186   SCM_SET_CELL_WORD_0 (vm_boot_continuation,
1187                        (SCM_CELL_WORD_0 (vm_boot_continuation)
1188                         | SCM_F_PROGRAM_IS_BOOT));
1189
1190 #define DEFINE_BUILTIN(builtin, BUILTIN, req, opt, rest)                \
1191   vm_builtin_##builtin = scm_i_make_program (vm_builtin_##builtin##_code);
1192   FOR_EACH_VM_BUILTIN (DEFINE_BUILTIN);
1193 #undef DEFINE_BUILTIN
1194
1195 #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
1196   vm_stack_gc_kind =
1197     GC_new_kind (GC_new_free_list (),
1198                  GC_MAKE_PROC (GC_new_proc (vm_stack_mark), 0),
1199                  0, 1);
1200
1201 #endif
1202 }
1203
1204 void
1205 scm_init_vm (void)
1206 {
1207 #ifndef SCM_MAGIC_SNARFER
1208 #include "libguile/vm.x"
1209 #endif
1210 }
1211
1212 /*
1213   Local Variables:
1214   c-file-style: "gnu"
1215   End:
1216 */