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