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