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 (struct scm_vm *vp, SCM cont, size_t n, SCM *argv)
 116 {
 117   struct scm_vm_cont *cp;
 118   SCM *argv_copy;
 119
 120   argv_copy = alloca (n * sizeof(SCM));
 121   memcpy (argv_copy, argv, n * sizeof(SCM));
 122
 123   cp = SCM_VM_CONT_DATA (cont);
 124
 125   if (vp->stack_size < cp->stack_size + n + 3)
 126     scm_misc_error ("vm-engine", "not enough space to reinstate continuation",
 127                     scm_list_1 (cont));
 128
 129   vp->sp = cp->sp;
 130   vp->fp = cp->fp;
 131   memcpy (vp->stack_base, cp->stack_base, cp->stack_size * sizeof (SCM));
 132
 133   {
 134     size_t i;
 135
 136     /* Push on an empty frame, as the continuation expects.  */
 137     for (i = 0; i < 3; i++)
 138       {
 139         vp->sp++;
 140         *vp->sp = SCM_BOOL_F;
 141       }
 142
 143     /* Push the return values.  */
 144     for (i = 0; i < n; i++)
 145       {
 146         vp->sp++;
 147         *vp->sp = argv_copy[i];
 148       }
 149     vp->ip = cp->ra;
 150   }
 151 }
 152
 153 static struct scm_vm * thread_vm (scm_i_thread *t);
 154 SCM
 155 scm_i_capture_current_stack (void)
 156 {
 157   scm_i_thread *thread;
 158   struct scm_vm *vp;
 159
 160   thread = SCM_I_CURRENT_THREAD;
 161   vp = thread_vm (thread);
 162
 163   return scm_i_vm_capture_stack (vp->stack_base, vp->fp, vp->sp, vp->ip,
 164                                  scm_dynstack_capture_all (&thread->dynstack),
 165                                  0);
 166 }
 167
 168 static void vm_dispatch_apply_hook (struct scm_vm *vp) SCM_NOINLINE;
 169 static void vm_dispatch_push_continuation_hook (struct scm_vm *vp) SCM_NOINLINE;
 170 static void vm_dispatch_pop_continuation_hook (struct scm_vm *vp, SCM *old_fp) SCM_NOINLINE;
 171 static void vm_dispatch_next_hook (struct scm_vm *vp) SCM_NOINLINE;
 172 static void vm_dispatch_abort_hook (struct scm_vm *vp) SCM_NOINLINE;
 173 static void vm_dispatch_restore_continuation_hook (struct scm_vm *vp) SCM_NOINLINE;
 174
 175 static void
 176 vm_dispatch_hook (struct scm_vm *vp, int hook_num, SCM *argv, int n)
 177 {
 178   SCM hook;
 179   struct scm_frame c_frame;
 180   scm_t_cell *frame;
 181   int saved_trace_level;
 182
 183   hook = vp->hooks[hook_num];
 184
 185   if (SCM_LIKELY (scm_is_false (hook))
 186       || scm_is_null (SCM_HOOK_PROCEDURES (hook)))
 187     return;
 188
 189   saved_trace_level = vp->trace_level;
 190   vp->trace_level = 0;
 191
 192   /* Allocate a frame object on the stack.  This is more efficient than calling
 193      `scm_c_make_frame ()' to allocate on the heap, but it forces hooks to not
 194      capture frame objects.
 195
 196      At the same time, procedures such as `frame-procedure' make sense only
 197      while the stack frame represented by the frame object is visible, so it
 198      seems reasonable to limit the lifetime of frame objects.  */
 199
 200   c_frame.stack_holder = vp;
 201   c_frame.fp_offset = vp->fp - vp->stack_base;
 202   c_frame.sp_offset = vp->sp - vp->stack_base;
 203   c_frame.ip = vp->ip;
 204
 205   /* Arrange for FRAME to be 8-byte aligned, like any other cell.  */
 206   frame = alloca (sizeof (*frame) + 8);
 207   frame = (scm_t_cell *) ROUND_UP ((scm_t_uintptr) frame, 8UL);
 208
 209   frame->word_0 = SCM_PACK (scm_tc7_frame | (SCM_VM_FRAME_KIND_VM << 8));
 210   frame->word_1 = SCM_PACK_POINTER (&c_frame);
 211
 212   if (n == 0)
 213     {
 214       SCM args[1];
 215
 216       args[0] = SCM_PACK_POINTER (frame);
 217       scm_c_run_hookn (hook, args, 1);
 218     }
 219   else if (n == 1)
 220     {
 221       SCM args[2];
 222
 223       args[0] = SCM_PACK_POINTER (frame);
 224       args[1] = argv[0];
 225       scm_c_run_hookn (hook, args, 2);
 226     }
 227   else
 228     {
 229       SCM args = SCM_EOL;
 230
 231       while (n--)
 232         args = scm_cons (argv[n], args);
 233       scm_c_run_hook (hook, scm_cons (SCM_PACK_POINTER (frame), args));
 234     }
 235
 236   vp->trace_level = saved_trace_level;
 237 }
 238
 239 static void
 240 vm_dispatch_apply_hook (struct scm_vm *vp)
 241 {
 242   return vm_dispatch_hook (vp, SCM_VM_APPLY_HOOK, NULL, 0);
 243 }
 244 static void vm_dispatch_push_continuation_hook (struct scm_vm *vp)
 245 {
 246   return vm_dispatch_hook (vp, SCM_VM_PUSH_CONTINUATION_HOOK, NULL, 0);
 247 }
 248 static void vm_dispatch_pop_continuation_hook (struct scm_vm *vp, SCM *old_fp)
 249 {
 250   return vm_dispatch_hook (vp, SCM_VM_POP_CONTINUATION_HOOK,
 251                            &SCM_FRAME_LOCAL (old_fp, 1),
 252                            SCM_FRAME_NUM_LOCALS (old_fp, vp->sp) - 1);
 253 }
 254 static void vm_dispatch_next_hook (struct scm_vm *vp)
 255 {
 256   return vm_dispatch_hook (vp, SCM_VM_NEXT_HOOK, NULL, 0);
 257 }
 258 static void vm_dispatch_abort_hook (struct scm_vm *vp)
 259 {
 260   return vm_dispatch_hook (vp, SCM_VM_ABORT_CONTINUATION_HOOK,
 261                            &SCM_FRAME_LOCAL (vp->fp, 1),
 262                            SCM_FRAME_NUM_LOCALS (vp->fp, vp->sp) - 1);
 263 }
 264 static void vm_dispatch_restore_continuation_hook (struct scm_vm *vp)
 265 {
 266   return vm_dispatch_hook (vp, SCM_VM_RESTORE_CONTINUATION_HOOK, NULL, 0);
 267 }
 268
 269 static void
 270 vm_abort (struct scm_vm *vp, SCM tag,
 271           size_t nstack, SCM *stack_args, SCM tail, SCM *sp,
 272           scm_i_jmp_buf *current_registers) SCM_NORETURN;
 273
 274 static void
 275 vm_abort (struct scm_vm *vp, SCM tag,
 276           size_t nstack, SCM *stack_args, SCM tail, SCM *sp,
 277           scm_i_jmp_buf *current_registers)
 278 {
 279   size_t i;
 280   ssize_t tail_len;
 281   SCM *argv;
 282
 283   tail_len = scm_ilength (tail);
 284   if (tail_len < 0)
 285     scm_misc_error ("vm-engine", "tail values to abort should be a list",
 286                     scm_list_1 (tail));
 287
 288   argv = alloca ((nstack + tail_len) * sizeof (SCM));
 289   for (i = 0; i < nstack; i++)
 290     argv[i] = stack_args[i];
 291   for (; i < nstack + tail_len; i++, tail = scm_cdr (tail))
 292     argv[i] = scm_car (tail);
 293
 294   /* FIXME: NULLSTACK (SCM_VM_DATA (vp)->sp - sp) */
 295   vp->sp = sp;
 296
 297   scm_c_abort (vp, tag, nstack + tail_len, argv, current_registers);
 298 }
 299
 300 static void
 301 vm_reinstate_partial_continuation (struct scm_vm *vp, SCM cont,
 302                                    size_t n, SCM *argv,
 303                                    scm_t_dynstack *dynstack,
 304                                    scm_i_jmp_buf *registers)
 305 {
 306   struct scm_vm_cont *cp;
 307   SCM *argv_copy, *base;
 308   scm_t_ptrdiff reloc;
 309   size_t i;
 310
 311   argv_copy = alloca (n * sizeof(SCM));
 312   memcpy (argv_copy, argv, n * sizeof(SCM));
 313
 314   cp = SCM_VM_CONT_DATA (cont);
 315   base = SCM_FRAME_LOCALS_ADDRESS (vp->fp);
 316   reloc = cp->reloc + (base - cp->stack_base);
 317
 318 #define RELOC(scm_p)                                            \
 319   (((SCM *) (scm_p)) + reloc)
 320
 321   if ((base - vp->stack_base) + cp->stack_size + n + 1 > vp->stack_size)
 322     scm_misc_error ("vm-engine",
 323                     "not enough space to instate partial continuation",
 324                     scm_list_1 (cont));
 325
 326   memcpy (base, cp->stack_base, cp->stack_size * sizeof (SCM));
 327
 328   /* now relocate frame pointers */
 329   {
 330     SCM *fp;
 331     for (fp = RELOC (cp->fp);
 332          SCM_FRAME_LOWER_ADDRESS (fp) > base;
 333          fp = SCM_FRAME_DYNAMIC_LINK (fp))
 334       SCM_FRAME_SET_DYNAMIC_LINK (fp, RELOC (SCM_FRAME_DYNAMIC_LINK (fp)));
 335   }
 336
 337   vp->sp = base - 1 + cp->stack_size;
 338   vp->fp = RELOC (cp->fp);
 339   vp->ip = cp->ra;
 340
 341   /* Push the arguments. */
 342   for (i = 0; i < n; i++)
 343     {
 344       vp->sp++;
 345       *vp->sp = argv_copy[i];
 346     }
 347
 348   /* The prompt captured a slice of the dynamic stack.  Here we wind
 349      those entries onto the current thread's stack.  We also have to
 350      relocate any prompts that we see along the way.  */
 351   {
 352     scm_t_bits *walk;
 353
 354     for (walk = SCM_DYNSTACK_FIRST (cp->dynstack);
 355          SCM_DYNSTACK_TAG (walk);
 356          walk = SCM_DYNSTACK_NEXT (walk))
 357       {
 358         scm_t_bits tag = SCM_DYNSTACK_TAG (walk);
 359
 360         if (SCM_DYNSTACK_TAG_TYPE (tag) == SCM_DYNSTACK_TYPE_PROMPT)
 361           scm_dynstack_wind_prompt (dynstack, walk, reloc, registers);
 362         else
 363           scm_dynstack_wind_1 (dynstack, walk);
 364       }
 365   }
 366 #undef RELOC
 367 }
 368
 369 \f
 370 /*
 371  * VM Error Handling
 372  */
 373
 374 static void vm_error (const char *msg, SCM arg) SCM_NORETURN;
 375 static void vm_error_bad_instruction (scm_t_uint32 inst) SCM_NORETURN SCM_NOINLINE;
 376 static void vm_error_unbound (SCM proc, SCM sym) SCM_NORETURN SCM_NOINLINE;
 377 static void vm_error_unbound_fluid (SCM proc, SCM fluid) SCM_NORETURN SCM_NOINLINE;
 378 static void vm_error_not_a_variable (const char *func_name, SCM x) SCM_NORETURN SCM_NOINLINE;
 379 static void vm_error_apply_to_non_list (SCM x) SCM_NORETURN SCM_NOINLINE;
 380 static void vm_error_kwargs_length_not_even (SCM proc) SCM_NORETURN SCM_NOINLINE;
 381 static void vm_error_kwargs_invalid_keyword (SCM proc, SCM obj) SCM_NORETURN SCM_NOINLINE;
 382 static void vm_error_kwargs_unrecognized_keyword (SCM proc, SCM kw) SCM_NORETURN SCM_NOINLINE;
 383 static void vm_error_too_many_args (int nargs) SCM_NORETURN SCM_NOINLINE;
 384 static void vm_error_wrong_num_args (SCM proc) SCM_NORETURN SCM_NOINLINE;
 385 static void vm_error_wrong_type_apply (SCM proc) SCM_NORETURN SCM_NOINLINE;
 386 static void vm_error_stack_overflow (struct scm_vm *vp) SCM_NORETURN SCM_NOINLINE;
 387 static void vm_error_stack_underflow (void) SCM_NORETURN SCM_NOINLINE;
 388 static void vm_error_improper_list (SCM x) SCM_NORETURN SCM_NOINLINE;
 389 static void vm_error_not_a_pair (const char *subr, SCM x) SCM_NORETURN SCM_NOINLINE;
 390 static void vm_error_not_a_bytevector (const char *subr, SCM x) SCM_NORETURN SCM_NOINLINE;
 391 static void vm_error_not_a_struct (const char *subr, SCM x) SCM_NORETURN SCM_NOINLINE;
 392 static void vm_error_no_values (void) SCM_NORETURN SCM_NOINLINE;
 393 static void vm_error_not_enough_values (void) SCM_NORETURN SCM_NOINLINE;
 394 static void vm_error_wrong_number_of_values (scm_t_uint32 expected) SCM_NORETURN SCM_NOINLINE;
 395 static void vm_error_continuation_not_rewindable (SCM cont) SCM_NORETURN SCM_NOINLINE;
 396 static void vm_error_bad_wide_string_length (size_t len) SCM_NORETURN SCM_NOINLINE;
 397
 398 static void
 399 vm_error (const char *msg, SCM arg)
 400 {
 401   scm_throw (sym_vm_error,
 402              scm_list_3 (sym_vm_run, scm_from_latin1_string (msg),
 403                          SCM_UNBNDP (arg) ? SCM_EOL : scm_list_1 (arg)));
 404   abort(); /* not reached */
 405 }
 406
 407 static void
 408 vm_error_bad_instruction (scm_t_uint32 inst)
 409 {
 410   vm_error ("VM: Bad instruction: ~s", scm_from_uint32 (inst));
 411 }
 412
 413 static void
 414 vm_error_unbound (SCM proc, SCM sym)
 415 {
 416   scm_error_scm (scm_misc_error_key, proc,
 417                  scm_from_latin1_string ("Unbound variable: ~s"),
 418                  scm_list_1 (sym), SCM_BOOL_F);
 419 }
 420
 421 static void
 422 vm_error_unbound_fluid (SCM proc, SCM fluid)
 423 {
 424   scm_error_scm (scm_misc_error_key, proc,
 425                  scm_from_latin1_string ("Unbound fluid: ~s"),
 426                  scm_list_1 (fluid), SCM_BOOL_F);
 427 }
 428
 429 static void
 430 vm_error_not_a_variable (const char *func_name, SCM x)
 431 {
 432   scm_error (scm_arg_type_key, func_name, "Not a variable: ~S",
 433              scm_list_1 (x), scm_list_1 (x));
 434 }
 435
 436 static void
 437 vm_error_apply_to_non_list (SCM x)
 438 {
 439   scm_error (scm_arg_type_key, "apply", "Apply to non-list: ~S",
 440              scm_list_1 (x), scm_list_1 (x));
 441 }
 442
 443 static void
 444 vm_error_kwargs_length_not_even (SCM proc)
 445 {
 446   scm_error_scm (sym_keyword_argument_error, proc,
 447                  scm_from_latin1_string ("Odd length of keyword argument list"),
 448                  SCM_EOL, SCM_BOOL_F);
 449 }
 450
 451 static void
 452 vm_error_kwargs_invalid_keyword (SCM proc, SCM obj)
 453 {
 454   scm_error_scm (sym_keyword_argument_error, proc,
 455                  scm_from_latin1_string ("Invalid keyword"),
 456                  SCM_EOL, scm_list_1 (obj));
 457 }
 458
 459 static void
 460 vm_error_kwargs_unrecognized_keyword (SCM proc, SCM kw)
 461 {
 462   scm_error_scm (sym_keyword_argument_error, proc,
 463                  scm_from_latin1_string ("Unrecognized keyword"),
 464                  SCM_EOL, scm_list_1 (kw));
 465 }
 466
 467 static void
 468 vm_error_too_many_args (int nargs)
 469 {
 470   vm_error ("VM: Too many arguments", scm_from_int (nargs));
 471 }
 472
 473 static void
 474 vm_error_wrong_num_args (SCM proc)
 475 {
 476   scm_wrong_num_args (proc);
 477 }
 478
 479 static void
 480 vm_error_wrong_type_apply (SCM proc)
 481 {
 482   scm_error (scm_arg_type_key, NULL, "Wrong type to apply: ~S",
 483              scm_list_1 (proc), scm_list_1 (proc));
 484 }
 485
 486 static void
 487 vm_error_stack_overflow (struct scm_vm *vp)
 488 {
 489   if (vp->stack_limit < vp->stack_base + vp->stack_size)
 490     /* There are VM_STACK_RESERVE_SIZE bytes left.  Make them available so
 491        that `throw' below can run on this VM.  */
 492     vp->stack_limit = vp->stack_base + vp->stack_size;
 493   else
 494     /* There is no space left on the stack.  FIXME: Do something more
 495        sensible here! */
 496     abort ();
 497   vm_error ("VM: Stack overflow", SCM_UNDEFINED);
 498 }
 499
 500 static void
 501 vm_error_stack_underflow (void)
 502 {
 503   vm_error ("VM: Stack underflow", SCM_UNDEFINED);
 504 }
 505
 506 static void
 507 vm_error_improper_list (SCM x)
 508 {
 509   vm_error ("Expected a proper list, but got object with tail ~s", x);
 510 }
 511
 512 static void
 513 vm_error_not_a_pair (const char *subr, SCM x)
 514 {
 515   scm_wrong_type_arg_msg (subr, 1, x, "pair");
 516 }
 517
 518 static void
 519 vm_error_not_a_bytevector (const char *subr, SCM x)
 520 {
 521   scm_wrong_type_arg_msg (subr, 1, x, "bytevector");
 522 }
 523
 524 static void
 525 vm_error_not_a_struct (const char *subr, SCM x)
 526 {
 527   scm_wrong_type_arg_msg (subr, 1, x, "struct");
 528 }
 529
 530 static void
 531 vm_error_no_values (void)
 532 {
 533   vm_error ("Zero values returned to single-valued continuation",
 534             SCM_UNDEFINED);
 535 }
 536
 537 static void
 538 vm_error_not_enough_values (void)
 539 {
 540   vm_error ("Too few values returned to continuation", SCM_UNDEFINED);
 541 }
 542
 543 static void
 544 vm_error_wrong_number_of_values (scm_t_uint32 expected)
 545 {
 546   vm_error ("Wrong number of values returned to continuation (expected ~a)",
 547             scm_from_uint32 (expected));
 548 }
 549
 550 static void
 551 vm_error_continuation_not_rewindable (SCM cont)
 552 {
 553   vm_error ("Unrewindable partial continuation", cont);
 554 }
 555
 556 static void
 557 vm_error_bad_wide_string_length (size_t len)
 558 {
 559   vm_error ("VM: Bad wide string length: ~S", scm_from_size_t (len));
 560 }
 561
 562
 563 \f
 564
 565 static SCM vm_boot_continuation;
 566 static SCM vm_builtin_apply;
 567 static SCM vm_builtin_values;
 568 static SCM vm_builtin_abort_to_prompt;
 569 static SCM vm_builtin_call_with_values;
 570 static SCM vm_builtin_call_with_current_continuation;
 571
 572 static const scm_t_uint32 vm_boot_continuation_code[] = {
 573   SCM_PACK_OP_24 (halt, 0)
 574 };
 575
 576 static const scm_t_uint32 vm_builtin_apply_code[] = {
 577   SCM_PACK_OP_24 (assert_nargs_ge, 3),
 578   SCM_PACK_OP_24 (tail_apply, 0), /* proc in r1, args from r2 */
 579 };
 580
 581 static const scm_t_uint32 vm_builtin_values_code[] = {
 582   SCM_PACK_OP_24 (return_values, 0) /* vals from r1 */
 583 };
 584
 585 static const scm_t_uint32 vm_builtin_abort_to_prompt_code[] = {
 586   SCM_PACK_OP_24 (assert_nargs_ge, 2),
 587   SCM_PACK_OP_24 (abort, 0), /* tag in r1, vals from r2 */
 588   /* FIXME: Partial continuation should capture caller regs.  */
 589   SCM_PACK_OP_24 (return_values, 0) /* vals from r1 */
 590 };
 591
 592 static const scm_t_uint32 vm_builtin_call_with_values_code[] = {
 593   SCM_PACK_OP_24 (assert_nargs_ee, 3),
 594   SCM_PACK_OP_24 (alloc_frame, 7),
 595   SCM_PACK_OP_12_12 (mov, 6, 1),
 596   SCM_PACK_OP_24 (call, 6), SCM_PACK_OP_ARG_8_24 (0, 1),
 597   SCM_PACK_OP_12_12 (mov, 0, 2),
 598   SCM_PACK_OP_24 (tail_call_shuffle, 7)
 599 };
 600
 601 static const scm_t_uint32 vm_builtin_call_with_current_continuation_code[] = {
 602   SCM_PACK_OP_24 (assert_nargs_ee, 2),
 603   SCM_PACK_OP_24 (call_cc, 0)
 604 };
 605
 606
 607 static SCM
 608 scm_vm_builtin_ref (unsigned idx)
 609 {
 610   switch (idx)
 611     {
 612 #define INDEX_TO_NAME(builtin, BUILTIN, req, opt, rest)                 \
 613       case SCM_VM_BUILTIN_##BUILTIN: return vm_builtin_##builtin;
 614       FOR_EACH_VM_BUILTIN(INDEX_TO_NAME)
 615 #undef INDEX_TO_NAME
 616       default: abort();
 617     }
 618 }
 619
 620 SCM scm_sym_apply;
 621 static SCM scm_sym_values;
 622 static SCM scm_sym_abort_to_prompt;
 623 static SCM scm_sym_call_with_values;
 624 static SCM scm_sym_call_with_current_continuation;
 625
 626 SCM
 627 scm_vm_builtin_name_to_index (SCM name)
 628 #define FUNC_NAME "builtin-name->index"
 629 {
 630   SCM_VALIDATE_SYMBOL (1, name);
 631
 632 #define NAME_TO_INDEX(builtin, BUILTIN, req, opt, rest) \
 633   if (scm_is_eq (name, scm_sym_##builtin))              \
 634     return scm_from_uint (SCM_VM_BUILTIN_##BUILTIN);
 635   FOR_EACH_VM_BUILTIN(NAME_TO_INDEX)
 636 #undef NAME_TO_INDEX
 637
 638   return SCM_BOOL_F;
 639 }
 640 #undef FUNC_NAME
 641
 642 SCM
 643 scm_vm_builtin_index_to_name (SCM index)
 644 #define FUNC_NAME "builtin-index->name"
 645 {
 646   unsigned idx;
 647
 648   SCM_VALIDATE_UINT_COPY (1, index, idx);
 649
 650   switch (idx)
 651     {
 652 #define INDEX_TO_NAME(builtin, BUILTIN, req, opt, rest)         \
 653       case SCM_VM_BUILTIN_##BUILTIN: return scm_sym_##builtin;
 654       FOR_EACH_VM_BUILTIN(INDEX_TO_NAME)
 655 #undef INDEX_TO_NAME
 656       default: return SCM_BOOL_F;
 657     }
 658 }
 659 #undef FUNC_NAME
 660
 661 static void
 662 scm_init_vm_builtins (void)
 663 {
 664   scm_c_define_gsubr ("builtin-name->index", 1, 0, 0,
 665                       scm_vm_builtin_name_to_index);
 666   scm_c_define_gsubr ("builtin-index->name", 1, 0, 0,
 667                       scm_vm_builtin_index_to_name);
 668 }
 669
 670 SCM
 671 scm_i_call_with_current_continuation (SCM proc)
 672 {
 673   return scm_call_1 (vm_builtin_call_with_current_continuation, proc);
 674 }
 675
 676 \f
 677 /*
 678  * VM
 679  */
 680
 681 #define VM_MIN_STACK_SIZE       (1024)
 682 #define VM_DEFAULT_STACK_SIZE   (256 * 1024)
 683 static size_t vm_stack_size = VM_DEFAULT_STACK_SIZE;
 684
 685 static void
 686 initialize_default_stack_size (void)
 687 {
 688   int size = scm_getenv_int ("GUILE_STACK_SIZE", vm_stack_size);
 689   if (size >= VM_MIN_STACK_SIZE)
 690     vm_stack_size = size;
 691 }
 692
 693 #define VM_NAME vm_regular_engine
 694 #define VM_USE_HOOKS 0
 695 #define FUNC_NAME "vm-regular-engine"
 696 #include "vm-engine.c"
 697 #undef FUNC_NAME
 698 #undef VM_USE_HOOKS
 699 #undef VM_NAME
 700
 701 #define VM_NAME vm_debug_engine
 702 #define VM_USE_HOOKS 1
 703 #define FUNC_NAME "vm-debug-engine"
 704 #include "vm-engine.c"
 705 #undef FUNC_NAME
 706 #undef VM_USE_HOOKS
 707 #undef VM_NAME
 708
 709 typedef SCM (*scm_t_vm_engine) (scm_i_thread *current_thread, struct scm_vm *vp);
 710
 711 static const scm_t_vm_engine vm_engines[SCM_VM_NUM_ENGINES] =
 712   { vm_regular_engine, vm_debug_engine };
 713
 714 #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
 715
 716 /* The GC "kind" for the VM stack.  */
 717 static int vm_stack_gc_kind;
 718
 719 #endif
 720
 721 static struct scm_vm *
 722 make_vm (void)
 723 #define FUNC_NAME "make_vm"
 724 {
 725   int i;
 726   struct scm_vm *vp;
 727
 728   vp = scm_gc_malloc (sizeof (struct scm_vm), "vm");
 729
 730   vp->stack_size= vm_stack_size;
 731
 732 #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
 733   vp->stack_base = (SCM *)
 734     GC_generic_malloc (vp->stack_size * sizeof (SCM), vm_stack_gc_kind);
 735
 736   /* Keep a pointer to VP so that `vm_stack_mark ()' can know what the stack
 737      top is.  */
 738   *vp->stack_base = SCM_PACK_POINTER (vp);
 739   vp->stack_base++;
 740   vp->stack_size--;
 741 #else
 742   vp->stack_base  = scm_gc_malloc (vp->stack_size * sizeof (SCM),
 743                                    "stack-base");
 744 #endif
 745
 746   vp->stack_limit = vp->stack_base + vp->stack_size - VM_STACK_RESERVE_SIZE;
 747   vp->ip          = NULL;
 748   vp->sp          = vp->stack_base - 1;
 749   vp->fp          = NULL;
 750   vp->engine      = vm_default_engine;
 751   vp->trace_level = 0;
 752   for (i = 0; i < SCM_VM_NUM_HOOKS; i++)
 753     vp->hooks[i] = SCM_BOOL_F;
 754
 755   return vp;
 756 }
 757 #undef FUNC_NAME
 758
 759 #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
 760
 761 /* Mark the VM stack region between its base and its current top.  */
 762 static struct GC_ms_entry *
 763 vm_stack_mark (GC_word *addr, struct GC_ms_entry *mark_stack_ptr,
 764                struct GC_ms_entry *mark_stack_limit, GC_word env)
 765 {
 766   GC_word *word;
 767   const struct scm_vm *vm;
 768
 769   /* The first word of the VM stack should contain a pointer to the
 770      corresponding VM.  */
 771   vm = * ((struct scm_vm **) addr);
 772
 773   if (vm == NULL
 774       || (SCM *) addr != vm->stack_base - 1)
 775     /* ADDR must be a pointer to a free-list element, which we must ignore
 776        (see warning in <gc/gc_mark.h>).  */
 777     return mark_stack_ptr;
 778
 779   for (word = (GC_word *) vm->stack_base; word <= (GC_word *) vm->sp; word++)
 780     mark_stack_ptr = GC_MARK_AND_PUSH ((* (GC_word **) word),
 781                                        mark_stack_ptr, mark_stack_limit,
 782                                        NULL);
 783
 784   return mark_stack_ptr;
 785 }
 786
 787 #endif /* VM_ENABLE_PRECISE_STACK_GC_SCAN */
 788
 789
 790 static struct scm_vm *
 791 thread_vm (scm_i_thread *t)
 792 {
 793   if (SCM_UNLIKELY (!t->vp))
 794     t->vp = make_vm ();
 795
 796   return t->vp;
 797 }
 798
 799 struct scm_vm *
 800 scm_the_vm (void)
 801 {
 802   return thread_vm (SCM_I_CURRENT_THREAD);
 803 }
 804
 805 SCM
 806 scm_call_n (SCM proc, SCM *argv, size_t nargs)
 807 {
 808   scm_i_thread *thread;
 809   struct scm_vm *vp;
 810   SCM *base;
 811   ptrdiff_t base_frame_size;
 812   size_t i;
 813
 814   thread = SCM_I_CURRENT_THREAD;
 815   vp = thread_vm (thread);
 816
 817   SCM_CHECK_STACK;
 818
 819   /* Check that we have enough space: 3 words for the boot
 820      continuation, 3 + nargs for the procedure application, and 3 for
 821      setting up a new frame.  */
 822   base_frame_size = 3 + 3 + nargs + 3;
 823   vp->sp += base_frame_size;
 824   if (vp->sp >= vp->stack_limit)
 825     vm_error_stack_overflow (vp);
 826   base = vp->sp + 1 - base_frame_size;
 827
 828   /* Since it's possible to receive the arguments on the stack itself,
 829      shuffle up the arguments first.  */
 830   for (i = nargs; i > 0; i--)
 831     base[6 + i - 1] = argv[i - 1];
 832
 833   /* Push the boot continuation, which calls PROC and returns its
 834      result(s).  */
 835   base[0] = SCM_PACK (vp->fp); /* dynamic link */
 836   base[1] = SCM_PACK (vp->ip); /* ra */
 837   base[2] = vm_boot_continuation;
 838   vp->fp = &base[2];
 839   vp->ip = (scm_t_uint32 *) vm_boot_continuation_code;
 840
 841   /* The pending call to PROC. */
 842   base[3] = SCM_PACK (vp->fp); /* dynamic link */
 843   base[4] = SCM_PACK (vp->ip); /* ra */
 844   base[5] = proc;
 845   vp->fp = &base[5];
 846   vp->sp = &SCM_FRAME_LOCAL (vp->fp, nargs);
 847
 848   return vm_engines[vp->engine](thread, vp);
 849 }
 850
 851 /* Scheme interface */
 852
 853 #define VM_DEFINE_HOOK(n)                               \
 854 {                                                       \
 855   struct scm_vm *vp;                                    \
 856   vp = scm_the_vm ();                                   \
 857   if (scm_is_false (vp->hooks[n]))                      \
 858     vp->hooks[n] = scm_make_hook (SCM_I_MAKINUM (1));   \
 859   return vp->hooks[n];                                  \
 860 }
 861
 862 SCM_DEFINE (scm_vm_apply_hook, "vm-apply-hook", 0, 0, 0,
 863             (void),
 864             "")
 865 #define FUNC_NAME s_scm_vm_apply_hook
 866 {
 867   VM_DEFINE_HOOK (SCM_VM_APPLY_HOOK);
 868 }
 869 #undef FUNC_NAME
 870
 871 SCM_DEFINE (scm_vm_push_continuation_hook, "vm-push-continuation-hook", 0, 0, 0,
 872             (void),
 873             "")
 874 #define FUNC_NAME s_scm_vm_push_continuation_hook
 875 {
 876   VM_DEFINE_HOOK (SCM_VM_PUSH_CONTINUATION_HOOK);
 877 }
 878 #undef FUNC_NAME
 879
 880 SCM_DEFINE (scm_vm_pop_continuation_hook, "vm-pop-continuation-hook", 0, 0, 0,
 881             (void),
 882             "")
 883 #define FUNC_NAME s_scm_vm_pop_continuation_hook
 884 {
 885   VM_DEFINE_HOOK (SCM_VM_POP_CONTINUATION_HOOK);
 886 }
 887 #undef FUNC_NAME
 888
 889 SCM_DEFINE (scm_vm_next_hook, "vm-next-hook", 0, 0, 0,
 890             (void),
 891             "")
 892 #define FUNC_NAME s_scm_vm_next_hook
 893 {
 894   VM_DEFINE_HOOK (SCM_VM_NEXT_HOOK);
 895 }
 896 #undef FUNC_NAME
 897
 898 SCM_DEFINE (scm_vm_abort_continuation_hook, "vm-abort-continuation-hook", 0, 0, 0,
 899             (void),
 900             "")
 901 #define FUNC_NAME s_scm_vm_abort_continuation_hook
 902 {
 903   VM_DEFINE_HOOK (SCM_VM_ABORT_CONTINUATION_HOOK);
 904 }
 905 #undef FUNC_NAME
 906
 907 SCM_DEFINE (scm_vm_restore_continuation_hook, "vm-restore-continuation-hook", 0, 0, 0,
 908             (void),
 909             "")
 910 #define FUNC_NAME s_scm_vm_restore_continuation_hook
 911 {
 912   VM_DEFINE_HOOK (SCM_VM_RESTORE_CONTINUATION_HOOK);
 913 }
 914 #undef FUNC_NAME
 915
 916 SCM_DEFINE (scm_vm_trace_level, "vm-trace-level", 0, 0, 0,
 917             (void),
 918             "")
 919 #define FUNC_NAME s_scm_vm_trace_level
 920 {
 921   return scm_from_int (scm_the_vm ()->trace_level);
 922 }
 923 #undef FUNC_NAME
 924
 925 SCM_DEFINE (scm_set_vm_trace_level_x, "set-vm-trace-level!", 1, 0, 0,
 926             (SCM level),
 927             "")
 928 #define FUNC_NAME s_scm_set_vm_trace_level_x
 929 {
 930   scm_the_vm ()->trace_level = scm_to_int (level);
 931   return SCM_UNSPECIFIED;
 932 }
 933 #undef FUNC_NAME
 934
 935 \f
 936 /*
 937  * VM engines
 938  */
 939
 940 static int
 941 symbol_to_vm_engine (SCM engine, const char *FUNC_NAME)
 942 {
 943   if (scm_is_eq (engine, sym_regular))
 944     return SCM_VM_REGULAR_ENGINE;
 945   else if (scm_is_eq (engine, sym_debug))
 946     return SCM_VM_DEBUG_ENGINE;
 947   else
 948     SCM_MISC_ERROR ("Unknown VM engine: ~a", scm_list_1 (engine));
 949 }
 950
 951 static SCM
 952 vm_engine_to_symbol (int engine, const char *FUNC_NAME)
 953 {
 954   switch (engine)
 955     {
 956     case SCM_VM_REGULAR_ENGINE:
 957       return sym_regular;
 958     case SCM_VM_DEBUG_ENGINE:
 959       return sym_debug;
 960     default:
 961       /* ? */
 962       SCM_MISC_ERROR ("Unknown VM engine: ~a",
 963                       scm_list_1 (scm_from_int (engine)));
 964     }
 965 }
 966
 967 SCM_DEFINE (scm_vm_engine, "vm-engine", 0, 0, 0,
 968             (void),
 969             "")
 970 #define FUNC_NAME s_scm_vm_engine
 971 {
 972   return vm_engine_to_symbol (scm_the_vm ()->engine, FUNC_NAME);
 973 }
 974 #undef FUNC_NAME
 975
 976 void
 977 scm_c_set_vm_engine_x (int engine)
 978 #define FUNC_NAME "set-vm-engine!"
 979 {
 980   if (engine < 0 || engine >= SCM_VM_NUM_ENGINES)
 981     SCM_MISC_ERROR ("Unknown VM engine: ~a",
 982                     scm_list_1 (scm_from_int (engine)));
 983
 984   scm_the_vm ()->engine = engine;
 985 }
 986 #undef FUNC_NAME
 987
 988 SCM_DEFINE (scm_set_vm_engine_x, "set-vm-engine!", 1, 0, 0,
 989             (SCM engine),
 990             "")
 991 #define FUNC_NAME s_scm_set_vm_engine_x
 992 {
 993   scm_c_set_vm_engine_x (symbol_to_vm_engine (engine, FUNC_NAME));
 994   return SCM_UNSPECIFIED;
 995 }
 996 #undef FUNC_NAME
 997
 998 void
 999 scm_c_set_default_vm_engine_x (int engine)
1000 #define FUNC_NAME "set-default-vm-engine!"
1001 {
1002   if (engine < 0 || engine >= SCM_VM_NUM_ENGINES)
1003     SCM_MISC_ERROR ("Unknown VM engine: ~a",
1004                     scm_list_1 (scm_from_int (engine)));
1005
1006   vm_default_engine = engine;
1007 }
1008 #undef FUNC_NAME
1009
1010 SCM_DEFINE (scm_set_default_vm_engine_x, "set-default-vm-engine!", 1, 0, 0,
1011             (SCM engine),
1012             "")
1013 #define FUNC_NAME s_scm_set_default_vm_engine_x
1014 {
1015   scm_c_set_default_vm_engine_x (symbol_to_vm_engine (engine, FUNC_NAME));
1016   return SCM_UNSPECIFIED;
1017 }
1018 #undef FUNC_NAME
1019
1020 /* FIXME: This function makes no sense, but we keep it to make sure we
1021    have a way of switching to the debug or regular VM.  */
1022 SCM_DEFINE (scm_call_with_vm, "call-with-vm", 1, 0, 1,
1023             (SCM proc, SCM args),
1024             "Apply @var{proc} to @var{args} in a dynamic extent in which\n"
1025             "@var{vm} is the current VM.")
1026 #define FUNC_NAME s_scm_call_with_vm
1027 {
1028   return scm_apply_0 (proc, args);
1029 }
1030 #undef FUNC_NAME
1031
1032 \f
1033 /*
1034  * Initialize
1035  */
1036
1037 SCM
1038 scm_load_compiled_with_vm (SCM file)
1039 {
1040   return scm_call_0 (scm_load_thunk_from_file (file));
1041 }
1042
1043
1044 void
1045 scm_init_vm_builtin_properties (void)
1046 {
1047   /* FIXME: Seems hacky to do this here, but oh well :/ */
1048   scm_sym_apply = scm_from_utf8_symbol ("apply");
1049   scm_sym_values = scm_from_utf8_symbol ("values");
1050   scm_sym_abort_to_prompt = scm_from_utf8_symbol ("abort-to-prompt");
1051   scm_sym_call_with_values = scm_from_utf8_symbol ("call-with-values");
1052   scm_sym_call_with_current_continuation =
1053     scm_from_utf8_symbol ("call-with-current-continuation");
1054
1055 #define INIT_BUILTIN(builtin, BUILTIN, req, opt, rest)                  \
1056   scm_set_procedure_property_x (vm_builtin_##builtin, scm_sym_name,     \
1057                                 scm_sym_##builtin);                     \
1058   scm_set_procedure_minimum_arity_x (vm_builtin_##builtin,              \
1059                                      SCM_I_MAKINUM (req),               \
1060                                      SCM_I_MAKINUM (opt),               \
1061                                      scm_from_bool (rest));
1062   FOR_EACH_VM_BUILTIN (INIT_BUILTIN);
1063 #undef INIT_BUILTIN
1064 }
1065
1066 void
1067 scm_bootstrap_vm (void)
1068 {
1069   scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
1070                             "scm_init_vm",
1071                             (scm_t_extension_init_func)scm_init_vm, NULL);
1072   scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
1073                             "scm_init_vm_builtins",
1074                             (scm_t_extension_init_func)scm_init_vm_builtins,
1075                             NULL);
1076
1077   initialize_default_stack_size ();
1078
1079   sym_vm_run = scm_from_latin1_symbol ("vm-run");
1080   sym_vm_error = scm_from_latin1_symbol ("vm-error");
1081   sym_keyword_argument_error = scm_from_latin1_symbol ("keyword-argument-error");
1082   sym_regular = scm_from_latin1_symbol ("regular");
1083   sym_debug = scm_from_latin1_symbol ("debug");
1084
1085   vm_boot_continuation = scm_i_make_program (vm_boot_continuation_code);
1086   SCM_SET_CELL_WORD_0 (vm_boot_continuation,
1087                        (SCM_CELL_WORD_0 (vm_boot_continuation)
1088                         | SCM_F_PROGRAM_IS_BOOT));
1089
1090 #define DEFINE_BUILTIN(builtin, BUILTIN, req, opt, rest)                \
1091   vm_builtin_##builtin = scm_i_make_program (vm_builtin_##builtin##_code);
1092   FOR_EACH_VM_BUILTIN (DEFINE_BUILTIN);
1093 #undef DEFINE_BUILTIN
1094
1095 #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
1096   vm_stack_gc_kind =
1097     GC_new_kind (GC_new_free_list (),
1098                  GC_MAKE_PROC (GC_new_proc (vm_stack_mark), 0),
1099                  0, 1);
1100
1101 #endif
1102 }
1103
1104 void
1105 scm_init_vm (void)
1106 {
1107 #ifndef SCM_MAGIC_SNARFER
1108 #include "libguile/vm.x"
1109 #endif
1110 }
1111
1112 /*
1113   Local Variables:
1114   c-file-style: "gnu"
1115   End:
1116 */