tests: Improve lack-of-/dev/null detection.
[bpt/guile.git] / libguile / vm.c
index 17ad96d..d4c8b5f 100644 (file)
@@ -1,4 +1,4 @@
-/* Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
  * 
  * This library is free software; you can redistribute it and/or
  * modify it under the terms of the GNU Lesser General Public License
@@ -24,6 +24,7 @@
 #include <alloca.h>
 #include <alignof.h>
 #include <string.h>
+#include <stdint.h>
 
 #include "libguile/bdw-gc.h"
 #include <gc/gc_mark.h>
 #include "programs.h"
 #include "vm.h"
 
-/* I sometimes use this for debugging. */
-#define vm_puts(OBJ)                           \
-{                                              \
-  scm_display (OBJ, scm_current_error_port ()); \
-  scm_newline (scm_current_error_port ());      \
-}
+#include "private-gc.h" /* scm_getenv_int */
+
+static int vm_default_engine = SCM_VM_REGULAR_ENGINE;
+
+/* Unfortunately we can't snarf these: snarfed things are only loaded up from
+   (system vm vm), which might not be loaded before an error happens. */
+static SCM sym_vm_run;
+static SCM sym_vm_error;
+static SCM sym_keyword_argument_error;
+static SCM sym_regular;
+static SCM sym_debug;
 
 /* The VM has a number of internal assertions that shouldn't normally be
    necessary, but might be if you think you found a bug in the VM. */
@@ -276,7 +282,8 @@ vm_reinstate_partial_continuation (SCM vm, SCM cont, SCM intwinds,
   cp = SCM_VM_CONT_DATA (cont);
   base = SCM_FRAME_UPPER_ADDRESS (vp->fp) + 1;
 
-#define RELOC(scm_p) (scm_p + cp->reloc + (base - cp->stack_base))
+#define RELOC(scm_p)                                           \
+  (((SCM *) (scm_p)) + cp->reloc + (base - cp->stack_base))
 
   if ((base - vp->stack_base) + cp->stack_size + n + 1 > vp->stack_size)
     scm_misc_error ("vm-engine",
@@ -340,10 +347,6 @@ vm_reinstate_partial_continuation (SCM vm, SCM cont, SCM intwinds,
  * VM Internal functions
  */
 
-/* Unfortunately we can't snarf these: snarfed things are only loaded up from
-   (system vm vm), which might not be loaded before an error happens. */
-static SCM sym_vm_run, sym_vm_error, sym_keyword_argument_error, sym_debug;
-
 void
 scm_i_vm_print (SCM x, SCM port, scm_print_state *pstate)
 {
@@ -369,53 +372,251 @@ scm_i_vm_print (SCM x, SCM port, scm_print_state *pstate)
   scm_puts (">", port);
 }
 
-static SCM
-really_make_boot_program (long nargs)
+\f
+/*
+ * VM Error Handling
+ */
+
+static void vm_error (const char *msg, SCM arg) SCM_NORETURN;
+static void vm_error_bad_instruction (scm_t_uint32 inst) SCM_NORETURN;
+static void vm_error_unbound (SCM proc, SCM sym) SCM_NORETURN;
+static void vm_error_unbound_fluid (SCM proc, SCM fluid) SCM_NORETURN;
+static void vm_error_not_a_variable (const char *func_name, SCM x) SCM_NORETURN;
+static void vm_error_not_a_thunk (const char *func_name, SCM x) SCM_NORETURN;
+static void vm_error_apply_to_non_list (SCM x) SCM_NORETURN;
+static void vm_error_kwargs_length_not_even (SCM proc) SCM_NORETURN;
+static void vm_error_kwargs_invalid_keyword (SCM proc, SCM obj) SCM_NORETURN;
+static void vm_error_kwargs_unrecognized_keyword (SCM proc, SCM kw) SCM_NORETURN;
+static void vm_error_too_many_args (int nargs) SCM_NORETURN;
+static void vm_error_wrong_num_args (SCM proc) SCM_NORETURN;
+static void vm_error_wrong_type_apply (SCM proc) SCM_NORETURN;
+static void vm_error_stack_overflow (struct scm_vm *vp) SCM_NORETURN;
+static void vm_error_stack_underflow (void) SCM_NORETURN;
+static void vm_error_improper_list (SCM x) SCM_NORETURN;
+static void vm_error_not_a_pair (const char *subr, SCM x) SCM_NORETURN;
+static void vm_error_not_a_bytevector (const char *subr, SCM x) SCM_NORETURN;
+static void vm_error_not_a_struct (const char *subr, SCM x) SCM_NORETURN;
+static void vm_error_no_values (void) SCM_NORETURN;
+static void vm_error_not_enough_values (void) SCM_NORETURN;
+static void vm_error_continuation_not_rewindable (SCM cont) SCM_NORETURN;
+static void vm_error_bad_wide_string_length (size_t len) SCM_NORETURN;
+#if VM_CHECK_IP
+static void vm_error_invalid_address (void) SCM_NORETURN;
+#endif
+#if VM_CHECK_OBJECT
+static void vm_error_object (void) SCM_NORETURN;
+#endif
+#if VM_CHECK_FREE_VARIABLES
+static void vm_error_free_variable (void) SCM_NORETURN;
+#endif
+
+static void
+vm_error (const char *msg, SCM arg)
 {
-  SCM u8vec;
-  scm_t_uint8 text[] = { scm_op_mv_call, 0, 0, 0, 1,
-                         scm_op_make_int8_1, scm_op_halt };
-  struct scm_objcode *bp;
-  SCM ret;
+  scm_throw (sym_vm_error,
+             scm_list_3 (sym_vm_run, scm_from_latin1_string (msg),
+                         SCM_UNBNDP (arg) ? SCM_EOL : scm_list_1 (arg)));
+  abort(); /* not reached */
+}
 
-  if (SCM_UNLIKELY (nargs > 255 || nargs < 0))
-    scm_misc_error ("vm-engine", "too many args when making boot procedure",
-                    scm_list_1 (scm_from_long (nargs)));
+static void
+vm_error_bad_instruction (scm_t_uint32 inst)
+{
+  vm_error ("VM: Bad instruction: ~s", scm_from_uint32 (inst));
+}
 
-  text[1] = (scm_t_uint8)nargs;
+static void
+vm_error_unbound (SCM proc, SCM sym)
+{
+  scm_error_scm (scm_misc_error_key, proc,
+                 scm_from_latin1_string ("Unbound variable: ~s"),
+                 scm_list_1 (sym), SCM_BOOL_F);
+}
 
-  bp = scm_malloc (sizeof (struct scm_objcode) + sizeof (text));
-  memcpy (SCM_C_OBJCODE_BASE (bp), text, sizeof (text));
-  bp->len = sizeof(text);
-  bp->metalen = 0;
+static void
+vm_error_unbound_fluid (SCM proc, SCM fluid)
+{
+  scm_error_scm (scm_misc_error_key, proc,
+                 scm_from_latin1_string ("Unbound fluid: ~s"),
+                 scm_list_1 (fluid), SCM_BOOL_F);
+}
 
-  u8vec = scm_c_take_bytevector ((scm_t_int8*)bp,
-                                 sizeof (struct scm_objcode) + sizeof (text));
-  ret = scm_make_program (scm_bytecode_to_objcode (u8vec),
-                          SCM_BOOL_F, SCM_BOOL_F);
-  SCM_SET_CELL_WORD_0 (ret, SCM_CELL_WORD_0 (ret) | SCM_F_PROGRAM_IS_BOOT);
+static void
+vm_error_not_a_variable (const char *func_name, SCM x)
+{
+  scm_error (scm_arg_type_key, func_name, "Not a variable: ~S",
+             scm_list_1 (x), scm_list_1 (x));
+}
 
-  return ret;
+static void
+vm_error_not_a_thunk (const char *func_name, SCM x)
+{
+  scm_error (scm_arg_type_key, func_name, "Not a thunk: ~S",
+             scm_list_1 (x), scm_list_1 (x));
 }
-#define NUM_BOOT_PROGS 8
-static SCM
-vm_make_boot_program (long nargs)
+
+static void
+vm_error_apply_to_non_list (SCM x)
 {
-  static SCM programs[NUM_BOOT_PROGS] = { 0, };
+  scm_error (scm_arg_type_key, "apply", "Apply to non-list: ~S",
+             scm_list_1 (x), scm_list_1 (x));
+}
 
-  if (SCM_UNLIKELY (!programs[0])) 
-    {
-      int i;
-      for (i = 0; i < NUM_BOOT_PROGS; i++)
-        programs[i] = really_make_boot_program (i);
-    }
-  
-  if (SCM_LIKELY (nargs < NUM_BOOT_PROGS))
-    return programs[nargs];
+static void
+vm_error_kwargs_length_not_even (SCM proc)
+{
+  scm_error_scm (sym_keyword_argument_error, proc,
+                 scm_from_latin1_string ("Odd length of keyword argument list"),
+                 SCM_EOL, SCM_BOOL_F);
+}
+
+static void
+vm_error_kwargs_invalid_keyword (SCM proc, SCM obj)
+{
+  scm_error_scm (sym_keyword_argument_error, proc,
+                 scm_from_latin1_string ("Invalid keyword"),
+                 SCM_EOL, scm_list_1 (obj));
+}
+
+static void
+vm_error_kwargs_unrecognized_keyword (SCM proc, SCM kw)
+{
+  scm_error_scm (sym_keyword_argument_error, proc,
+                 scm_from_latin1_string ("Unrecognized keyword"),
+                 SCM_EOL, scm_list_1 (kw));
+}
+
+static void
+vm_error_too_many_args (int nargs)
+{
+  vm_error ("VM: Too many arguments", scm_from_int (nargs));
+}
+
+static void
+vm_error_wrong_num_args (SCM proc)
+{
+  scm_wrong_num_args (proc);
+}
+
+static void
+vm_error_wrong_type_apply (SCM proc)
+{
+  scm_error (scm_arg_type_key, NULL, "Wrong type to apply: ~S",
+             scm_list_1 (proc), scm_list_1 (proc));
+}
+
+/* Reinstate the stack reserve in the VM pointed to by DATA.  */
+static void
+reinstate_stack_reserve (void *data)
+{
+  struct scm_vm *vp = data;
+
+  vp->stack_limit -= VM_STACK_RESERVE_SIZE;
+}
+
+static void
+vm_error_stack_overflow (struct scm_vm *vp)
+{
+  if (vp->stack_limit < vp->stack_base + vp->stack_size)
+    /* There are VM_STACK_RESERVE_SIZE bytes left.  Make them available so
+       that `throw' below can run on this VM.  */
+    vp->stack_limit = vp->stack_base + vp->stack_size;
   else
-    return really_make_boot_program (nargs);
+    /* There is no space left on the stack.  FIXME: Do something more
+       sensible here! */
+    abort ();
+
+  /* Before throwing, install a handler that reinstates the reserve so
+     that subsequent overflows are gracefully handled.  */
+  scm_dynwind_begin (0);
+  scm_dynwind_unwind_handler (reinstate_stack_reserve, vp, 0);
+  vm_error ("VM: Stack overflow", SCM_UNDEFINED);
+  scm_dynwind_end ();
+}
+
+static void
+vm_error_stack_underflow (void)
+{
+  vm_error ("VM: Stack underflow", SCM_UNDEFINED);
+}
+
+static void
+vm_error_improper_list (SCM x)
+{
+  vm_error ("Expected a proper list, but got object with tail ~s", x);
+}
+
+static void
+vm_error_not_a_pair (const char *subr, SCM x)
+{
+  scm_wrong_type_arg_msg (subr, 1, x, "pair");
+}
+
+static void
+vm_error_not_a_bytevector (const char *subr, SCM x)
+{
+  scm_wrong_type_arg_msg (subr, 1, x, "bytevector");
+}
+
+static void
+vm_error_not_a_struct (const char *subr, SCM x)
+{
+  scm_wrong_type_arg_msg (subr, 1, x, "struct");
+}
+
+static void
+vm_error_no_values (void)
+{
+  vm_error ("Zero values returned to single-valued continuation",
+            SCM_UNDEFINED);
+}
+
+static void
+vm_error_not_enough_values (void)
+{
+  vm_error ("Too few values returned to continuation", SCM_UNDEFINED);
 }
 
+static void
+vm_error_continuation_not_rewindable (SCM cont)
+{
+  vm_error ("Unrewindable partial continuation", cont);
+}
+
+static void
+vm_error_bad_wide_string_length (size_t len)
+{
+  vm_error ("VM: Bad wide string length: ~S", scm_from_size_t (len));
+}
+
+#ifdef VM_CHECK_IP
+static void
+vm_error_invalid_address (void)
+{
+  vm_error ("VM: Invalid program address", SCM_UNDEFINED);
+}
+#endif
+
+#if VM_CHECK_OBJECT
+static void
+vm_error_object ()
+{
+  vm_error ("VM: Invalid object table access", SCM_UNDEFINED);
+}
+#endif
+
+#if VM_CHECK_FREE_VARIABLES
+static void
+vm_error_free_variable ()
+{
+  vm_error ("VM: Invalid free variable access", SCM_UNDEFINED);
+}
+#endif
+
+\f
+
+static SCM boot_continuation;
+
 \f
 /*
  * VM
@@ -426,18 +627,10 @@ resolve_variable (SCM what, SCM program_module)
 {
   if (SCM_LIKELY (scm_is_symbol (what)))
     {
-      if (SCM_LIKELY (scm_module_system_booted_p
-                      && scm_is_true (program_module)))
-        /* might longjmp */
+      if (scm_is_true (program_module))
         return scm_module_lookup (program_module, what);
       else
-        {
-          SCM v = scm_sym2var (what, SCM_BOOL_F, SCM_BOOL_F);
-          if (scm_is_false (v))
-            scm_misc_error (NULL, "unbound variable: ~S", scm_list_1 (what));
-          else
-            return v;
-        }
+        return scm_module_lookup (scm_the_root_module (), what);
     }
   else
     {
@@ -457,7 +650,17 @@ resolve_variable (SCM what, SCM program_module)
     }
 }
   
+#define VM_MIN_STACK_SIZE      (1024)
 #define VM_DEFAULT_STACK_SIZE  (64 * 1024)
+static size_t vm_stack_size = VM_DEFAULT_STACK_SIZE;
+
+static void
+initialize_default_stack_size (void)
+{
+  int size = scm_getenv_int ("GUILE_STACK_SIZE", vm_stack_size);
+  if (size >= VM_MIN_STACK_SIZE)
+    vm_stack_size = size;
+}
 
 #define VM_NAME   vm_regular_engine
 #define FUNC_NAME "vm-regular-engine"
@@ -494,7 +697,7 @@ make_vm (void)
 
   vp = scm_gc_malloc (sizeof (struct scm_vm), "vm");
 
-  vp->stack_size  = VM_DEFAULT_STACK_SIZE;
+  vp->stack_size= vm_stack_size;
 
 #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
   vp->stack_base = (SCM *)
@@ -517,7 +720,7 @@ make_vm (void)
   vp->ip         = NULL;
   vp->sp         = vp->stack_base - 1;
   vp->fp         = NULL;
-  vp->engine      = SCM_VM_DEBUG_ENGINE;
+  vp->engine      = vm_default_engine;
   vp->trace_level = 0;
   for (i = 0; i < SCM_VM_NUM_HOOKS; i++)
     vp->hooks[i] = SCM_BOOL_F;
@@ -561,83 +764,23 @@ SCM
 scm_c_vm_run (SCM vm, SCM program, SCM *argv, int nargs)
 {
   struct scm_vm *vp = SCM_VM_DATA (vm);
+  SCM_CHECK_STACK;
   return vm_engines[vp->engine](vm, program, argv, nargs);
 }
 
-SCM_DEFINE (scm_vm_apply, "vm-apply", 3, 0, 0,
-            (SCM vm, SCM program, SCM args),
-            "")
-#define FUNC_NAME s_scm_vm_apply
-{
-  SCM *argv;
-  int i, nargs;
-  
-  SCM_VALIDATE_VM (1, vm);
-  SCM_VALIDATE_PROC (2, program);
-
-  nargs = scm_ilength (args);
-  if (SCM_UNLIKELY (nargs < 0))
-    scm_wrong_type_arg_msg (FUNC_NAME, 3, args, "list");
-  
-  argv = alloca(nargs * sizeof(SCM));
-  for (i = 0; i < nargs; i++)
-    {
-      argv[i] = SCM_CAR (args);
-      args = SCM_CDR (args);
-    }
-
-  return scm_c_vm_run (vm, program, argv, nargs);
-}
-#undef FUNC_NAME
-
 /* Scheme interface */
 
-/* Return T's VM.  */
-static inline SCM
-thread_vm (scm_i_thread *t)
-{
-  if (SCM_UNLIKELY (scm_is_false (t->vm)))
-    t->vm = make_vm ();
-
-  return t->vm;
-}
-
-SCM_DEFINE (scm_thread_vm, "thread-vm", 1, 0, 0,
-           (SCM thread),
-           "Return @var{thread}'s VM.")
-#define FUNC_NAME s_scm_thread_vm
-{
-  SCM_VALIDATE_THREAD (1, thread);
-
-  return thread_vm (SCM_I_THREAD_DATA (thread));
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_set_thread_vm_x, "set-thread-vm!", 2, 0, 0,
-           (SCM thread, SCM vm),
-           "Set @var{thread}'s VM to @var{vm}.  Warning: Code being\n"
-           "executed by @var{thread}'s current VM won't automatically\n"
-           "switch to @var{vm}.")
-#define FUNC_NAME s_scm_set_thread_vm_x
-{
-  scm_i_thread *t;
-
-  SCM_VALIDATE_THREAD (1, thread);
-  SCM_VALIDATE_VM (2, vm);
-
-  t = SCM_I_THREAD_DATA (thread);
-  t->vm = vm;
-
-  return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
 SCM_DEFINE (scm_the_vm, "the-vm", 0, 0, 0,
            (void),
            "Return the current thread's VM.")
 #define FUNC_NAME s_scm_the_vm
 {
-  return thread_vm (SCM_I_CURRENT_THREAD);
+  scm_i_thread *t = SCM_I_CURRENT_THREAD;
+
+  if (SCM_UNLIKELY (scm_is_false (t->vm)))
+    t->vm = make_vm ();
+
+  return t->vm;
 }
 #undef FUNC_NAME
 
@@ -666,7 +809,7 @@ SCM_DEFINE (scm_vm_ip, "vm:ip", 1, 0, 0,
 #define FUNC_NAME s_scm_vm_ip
 {
   SCM_VALIDATE_VM (1, vm);
-  return scm_from_ulong ((unsigned long) SCM_VM_DATA (vm)->ip);
+  return scm_from_unsigned_integer ((scm_t_bits) SCM_VM_DATA (vm)->ip);
 }
 #undef FUNC_NAME
 
@@ -676,7 +819,7 @@ SCM_DEFINE (scm_vm_sp, "vm:sp", 1, 0, 0,
 #define FUNC_NAME s_scm_vm_sp
 {
   SCM_VALIDATE_VM (1, vm);
-  return scm_from_ulong ((unsigned long) SCM_VM_DATA (vm)->sp);
+  return scm_from_unsigned_integer ((scm_t_bits) SCM_VM_DATA (vm)->sp);
 }
 #undef FUNC_NAME
 
@@ -686,7 +829,7 @@ SCM_DEFINE (scm_vm_fp, "vm:fp", 1, 0, 0,
 #define FUNC_NAME s_scm_vm_fp
 {
   SCM_VALIDATE_VM (1, vm);
-  return scm_from_ulong ((unsigned long) SCM_VM_DATA (vm)->fp);
+  return scm_from_unsigned_integer ((scm_t_bits) SCM_VM_DATA (vm)->fp);
 }
 #undef FUNC_NAME
 
@@ -776,6 +919,154 @@ SCM_DEFINE (scm_set_vm_trace_level_x, "set-vm-trace-level!", 2, 0, 0,
 #undef FUNC_NAME
 
 \f
+/*
+ * VM engines
+ */
+
+static int
+symbol_to_vm_engine (SCM engine, const char *FUNC_NAME)
+{
+  if (scm_is_eq (engine, sym_regular))
+    return SCM_VM_REGULAR_ENGINE;
+  else if (scm_is_eq (engine, sym_debug))
+    return SCM_VM_DEBUG_ENGINE;
+  else
+    SCM_MISC_ERROR ("Unknown VM engine: ~a", scm_list_1 (engine));
+}
+  
+static SCM
+vm_engine_to_symbol (int engine, const char *FUNC_NAME)
+{
+  switch (engine)
+    {
+    case SCM_VM_REGULAR_ENGINE:
+      return sym_regular;
+    case SCM_VM_DEBUG_ENGINE:
+      return sym_debug;
+    default:
+      /* ? */
+      SCM_MISC_ERROR ("Unknown VM engine: ~a",
+                      scm_list_1 (scm_from_int (engine)));
+    }
+}
+  
+SCM_DEFINE (scm_vm_engine, "vm-engine", 1, 0, 0,
+           (SCM vm),
+           "")
+#define FUNC_NAME s_scm_vm_engine
+{
+  SCM_VALIDATE_VM (1, vm);
+  return vm_engine_to_symbol (SCM_VM_DATA (vm)->engine, FUNC_NAME);
+}
+#undef FUNC_NAME
+
+void
+scm_c_set_vm_engine_x (SCM vm, int engine)
+#define FUNC_NAME "set-vm-engine!"
+{
+  SCM_VALIDATE_VM (1, vm);
+
+  if (engine < 0 || engine >= SCM_VM_NUM_ENGINES)
+    SCM_MISC_ERROR ("Unknown VM engine: ~a",
+                    scm_list_1 (scm_from_int (engine)));
+    
+  SCM_VM_DATA (vm)->engine = engine;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_set_vm_engine_x, "set-vm-engine!", 2, 0, 0,
+           (SCM vm, SCM engine),
+           "")
+#define FUNC_NAME s_scm_set_vm_engine_x
+{
+  scm_c_set_vm_engine_x (vm, symbol_to_vm_engine (engine, FUNC_NAME));
+  return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+void
+scm_c_set_default_vm_engine_x (int engine)
+#define FUNC_NAME "set-default-vm-engine!"
+{
+  if (engine < 0 || engine >= SCM_VM_NUM_ENGINES)
+    SCM_MISC_ERROR ("Unknown VM engine: ~a",
+                    scm_list_1 (scm_from_int (engine)));
+    
+  vm_default_engine = engine;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_set_default_vm_engine_x, "set-default-vm-engine!", 1, 0, 0,
+           (SCM engine),
+           "")
+#define FUNC_NAME s_scm_set_default_vm_engine_x
+{
+  scm_c_set_default_vm_engine_x (symbol_to_vm_engine (engine, FUNC_NAME));
+  return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+static void reinstate_vm (SCM vm)
+{
+  scm_i_thread *t = SCM_I_CURRENT_THREAD;
+  t->vm = vm;
+}
+
+SCM_DEFINE (scm_call_with_vm, "call-with-vm", 2, 0, 1,
+           (SCM vm, SCM proc, SCM args),
+           "Apply @var{proc} to @var{args} in a dynamic extent in which\n"
+            "@var{vm} is the current VM.\n\n"
+            "As an implementation restriction, if @var{vm} is not the same\n"
+            "as the current thread's VM, continuations captured within the\n"
+            "call to @var{proc} may not be reinstated once control leaves\n"
+            "@var{proc}.")
+#define FUNC_NAME s_scm_call_with_vm
+{
+  SCM prev_vm, ret;
+  SCM *argv;
+  int i, nargs;
+  scm_t_wind_flags flags;
+  scm_i_thread *t = SCM_I_CURRENT_THREAD;
+
+  SCM_VALIDATE_VM (1, vm);
+  SCM_VALIDATE_PROC (2, proc);
+
+  nargs = scm_ilength (args);
+  if (SCM_UNLIKELY (nargs < 0))
+    scm_wrong_type_arg_msg (FUNC_NAME, 3, args, "list");
+  
+  argv = alloca (nargs * sizeof(SCM));
+  for (i = 0; i < nargs; i++)
+    {
+      argv[i] = SCM_CAR (args);
+      args = SCM_CDR (args);
+    }
+
+  prev_vm = t->vm;
+
+  /* Reentry can happen via invokation of a saved continuation, but
+     continuations only save the state of the VM that they are in at
+     capture-time, which might be different from this one.  So, in the
+     case that the VMs are different, set up a non-rewindable frame to
+     prevent reinstating an incomplete continuation.  */
+  flags = scm_is_eq (prev_vm, vm) ? 0 : SCM_F_WIND_EXPLICITLY;
+  if (flags)
+    {
+      scm_dynwind_begin (0);
+      scm_dynwind_unwind_handler_with_scm (reinstate_vm, prev_vm, flags);
+      t->vm = vm;
+    }
+
+  ret = scm_c_vm_run (vm, proc, argv, nargs);
+
+  if (flags)
+    scm_dynwind_end ();
+  
+  return ret;
+}
+#undef FUNC_NAME
+
+\f
 /*
  * Initialize
  */
@@ -788,6 +1079,33 @@ SCM scm_load_compiled_with_vm (SCM file)
   return scm_c_vm_run (scm_the_vm (), program, NULL, 0);
 }
 
+  
+static SCM
+make_boot_program (void)
+{
+  struct scm_objcode *bp;
+  size_t bp_size;
+  SCM u8vec, ret;
+
+  const scm_t_uint8 text[] = {
+    scm_op_make_int8_1,
+    scm_op_halt
+  };
+
+  bp_size = sizeof (struct scm_objcode) + sizeof (text);
+  bp = scm_gc_malloc_pointerless (bp_size, "boot-program");
+  memcpy (SCM_C_OBJCODE_BASE (bp), text, sizeof (text));
+  bp->len = sizeof(text);
+  bp->metalen = 0;
+
+  u8vec = scm_c_take_gc_bytevector ((scm_t_int8*)bp, bp_size);
+  ret = scm_make_program (scm_bytecode_to_native_objcode (u8vec),
+                          SCM_BOOL_F, SCM_BOOL_F);
+  SCM_SET_CELL_WORD_0 (ret, (SCM_CELL_WORD_0 (ret) | SCM_F_PROGRAM_IS_BOOT));
+
+  return ret;
+}
+
 void
 scm_bootstrap_vm (void)
 {
@@ -795,10 +1113,15 @@ scm_bootstrap_vm (void)
                             "scm_init_vm",
                             (scm_t_extension_init_func)scm_init_vm, NULL);
 
-  sym_vm_run = scm_from_locale_symbol ("vm-run");
-  sym_vm_error = scm_from_locale_symbol ("vm-error");
-  sym_keyword_argument_error = scm_from_locale_symbol ("keyword-argument-error");
-  sym_debug = scm_from_locale_symbol ("debug");
+  initialize_default_stack_size ();
+
+  sym_vm_run = scm_from_latin1_symbol ("vm-run");
+  sym_vm_error = scm_from_latin1_symbol ("vm-error");
+  sym_keyword_argument_error = scm_from_latin1_symbol ("keyword-argument-error");
+  sym_regular = scm_from_latin1_symbol ("regular");
+  sym_debug = scm_from_latin1_symbol ("debug");
+
+  boot_continuation = make_boot_program ();
 
 #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
   vm_stack_gc_kind =