Merge remote-tracking branch 'origin/stable-2.0'

Conflicts:
	libguile/vm-engine.c
	libguile/vm-i-system.c

diff --cc libguile/_scm.h
index c3384be,5b4f3b7..7dd188d
--- 1/libguile/_scm.h
--- 2/libguile/_scm.h
+++ b/libguile/_scm.h
@@@ -190,63 -190,12 +190,71 @@@
  #define scm_to_off64_t    scm_to_int64
  #define scm_from_off64_t  scm_from_int64
  
 +
 +\f
 +
 +#if defined (vms)
 +/* VMS: Implement SCM_I_SETJMP in terms of setjump.  */
 +extern int setjump(scm_i_jmp_buf env);
 +extern int longjump(scm_i_jmp_buf env, int ret);
 +#define SCM_I_SETJMP setjump
 +#define SCM_I_LONGJMP longjump
 +
 +#elif defined (_CRAY1)
 +/* Cray: Implement SCM_I_SETJMP in terms of setjump.  */
 +extern int setjump(scm_i_jmp_buf env);
 +extern int longjump(scm_i_jmp_buf env, int ret);
 +#define SCM_I_SETJMP setjump
 +#define SCM_I_LONGJMP longjump
 +
 +#elif defined (__ia64__)
 +/* IA64: Implement SCM_I_SETJMP in terms of getcontext. */
 +# define SCM_I_SETJMP(JB)                             \
 +  ( (JB).fresh = 1,                                   \
 +    getcontext (&((JB).ctx)),                           \
 +    ((JB).fresh ? ((JB).fresh = 0, 0) : 1) )
 +# define SCM_I_LONGJMP(JB,VAL) scm_ia64_longjmp (&(JB), VAL)
 +void scm_ia64_longjmp (scm_i_jmp_buf *, int);
 +
 +#else
 +/* All other systems just use setjmp and longjmp.  */
 +
 +#define SCM_I_SETJMP setjmp
 +#define SCM_I_LONGJMP longjmp
 +#endif
 +
 +\f
 +
 +#define SCM_ASYNC_TICK                                                  \
 +  do                                                                    \
 +    {                                                                   \
 +      if (SCM_UNLIKELY (SCM_I_CURRENT_THREAD->pending_asyncs))          \
 +        scm_async_tick ();                                              \
 +    }                                                                   \
 +  while (0)
 +
 +#define SCM_ASYNC_TICK_WITH_CODE(thr, stmt)                             \
 +  do                                                                    \
 +    {                                                                   \
 +      if (SCM_UNLIKELY (thr->pending_asyncs))                           \
 +        {                                                               \
 +          stmt;                                                         \
 +          scm_async_tick ();                                            \
 +        }                                                               \
 +    }                                                                   \
 +  while (0)
 +
 +
 +\f
 +
+ #if (defined __GNUC__)
+ # define SCM_NOINLINE __attribute__ ((__noinline__))
+ #else
+ # define SCM_NOINLINE /* noinline */
+ #endif
+ 
++\f
++
  /* The endianness marker in objcode.  */
  #ifdef WORDS_BIGENDIAN
  # define SCM_OBJCODE_ENDIANNESS "BE"

diff --cc libguile/values.c
Simple merge

diff --cc libguile/vm-engine.c
index 1d16ec4,67d6062..4b6c98a
--- 1/libguile/vm-engine.c
--- 2/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@@ -56,10 -56,7 +56,7 @@@ VM_NAME (SCM vm, SCM program, SCM *argv
  
    /* Internal variables */
    int nvalues = 0;
-   const char *func_name = NULL;         /* used for error reporting */
-   SCM finish_args;                      /* used both for returns: both in error
-                                            and normal situations */
 +  scm_i_jmp_buf registers;              /* used for prompts */
  
  #ifdef HAVE_LABELS_AS_VALUES
    static const void **jump_table_pointer = NULL;

diff --cc libguile/vm-engine.h
index 000397d,46d4cff..5a4bf40
--- 1/libguile/vm-engine.h
--- 2/libguile/vm-engine.h
+++ b/libguile/vm-engine.h
@@@ -276,21 -277,20 +277,19 @@@
  # define NULLSTACK_FOR_NONLOCAL_EXIT()
  #endif
  
- #define CHECK_OVERFLOW()                      \
-   if (SCM_UNLIKELY (sp >= stack_limit))         \
-     goto vm_error_stack_overflow
- 
+ /* For this check, we don't use VM_ASSERT, because that leads to a
+    per-site SYNC_ALL, which is too much code growth.  The real problem
+    of course is having to check for overflow all the time... */
+ #define CHECK_OVERFLOW()                                                \
+   do { if (SCM_UNLIKELY (sp >= stack_limit)) goto handle_overflow; } while (0)
  
 -
  #ifdef VM_CHECK_UNDERFLOW
- #define CHECK_UNDERFLOW()                       \
-   if (SCM_UNLIKELY (sp <= SCM_FRAME_UPPER_ADDRESS (fp)))        \
-     goto vm_error_stack_underflow
  #define PRE_CHECK_UNDERFLOW(N)                  \
-   if (SCM_UNLIKELY (sp - N <= SCM_FRAME_UPPER_ADDRESS (fp)))    \
-     goto vm_error_stack_underflow
+   VM_ASSERT (sp - (N) > SCM_FRAME_UPPER_ADDRESS (fp), vm_error_stack_underflow ())
+ #define CHECK_UNDERFLOW() PRE_CHECK_UNDERFLOW (0)
  #else
- #define CHECK_UNDERFLOW() /* nop */
  #define PRE_CHECK_UNDERFLOW(N) /* nop */
+ #define CHECK_UNDERFLOW() /* nop */
  #endif
  
  

diff --cc libguile/vm-i-scheme.c
index 89c3555,5191b8e..0e39563
--- 1/libguile/vm-i-scheme.c
--- 2/libguile/vm-i-scheme.c
+++ b/libguile/vm-i-scheme.c
@@@ -136,13 -124,9 +136,9 @@@ VM_DEFINE_FUNCTION (142, cons, "cons", 
  }
  
  #define VM_VALIDATE_CONS(x, proc)             \
-   if (SCM_UNLIKELY (!scm_is_pair (x)))          \
-     { func_name = proc;                         \
-       finish_args = x;                          \
-       goto vm_error_not_a_pair;                 \
-     }
+   VM_ASSERT (scm_is_pair (x), vm_error_not_a_pair (proc, x))
    
 -VM_DEFINE_FUNCTION (141, car, "car", 1)
 +VM_DEFINE_FUNCTION (143, car, "car", 1)
  {
    ARGS1 (x);
    VM_VALIDATE_CONS (x, "car");
@@@ -562,14 -499,9 +558,9 @@@ VM_DEFINE_INSTRUCTION (170, make_array
   * Structs
   */
  #define VM_VALIDATE_STRUCT(obj, proc)           \
-   if (SCM_UNLIKELY (!SCM_STRUCTP (obj)))      \
-     {                                         \
-       func_name = proc;                         \
-       finish_args = (obj);                    \
-       goto vm_error_not_a_struct;             \
-     }
+   VM_ASSERT (SCM_STRUCTP (obj), vm_error_not_a_pair (proc, obj))
  
 -VM_DEFINE_FUNCTION (166, struct_p, "struct?", 1)
 +VM_DEFINE_FUNCTION (171, struct_p, "struct?", 1)
  {
    ARGS1 (obj);
    RETURN (scm_from_bool (SCM_STRUCTP (obj)));

diff --cc libguile/vm-i-system.c
index 7153ab5,3ac0097..b6c15d2
--- 1/libguile/vm-i-system.c
--- 2/libguile/vm-i-system.c
+++ b/libguile/vm-i-system.c
@@@ -998,19 -1023,25 +991,17 @@@ VM_DEFINE_INSTRUCTION (60, continuation
    abort ();
  }
  
 -VM_DEFINE_INSTRUCTION (59, partial_cont_call, "partial-cont-call", 0, -1, 0)
 +VM_DEFINE_INSTRUCTION (61, partial_cont_call, "partial-cont-call", 0, -1, 0)
  {
 -  SCM vmcont, intwinds, prevwinds;
 -  POP2 (intwinds, vmcont);
 +  SCM vmcont;
 +  POP (vmcont);
    SYNC_REGISTER ();
-   if (SCM_UNLIKELY (!SCM_VM_CONT_REWINDABLE_P (vmcont)))
-     { finish_args = vmcont;
-       goto vm_error_continuation_not_rewindable;
-     }
+   VM_ASSERT (SCM_VM_CONT_REWINDABLE_P (vmcont),
+              vm_error_continuation_not_rewindable (vmcont));
 -  prevwinds = scm_i_dynwinds ();
 -  vm_reinstate_partial_continuation (vm, vmcont, intwinds, sp + 1 - fp, fp,
 -                                     vm_cookie);
 +  vm_reinstate_partial_continuation (vm, vmcont, sp + 1 - fp, fp,
 +                                     &current_thread->dynstack,
 +                                     &registers);
  
 -  /* Rewind prompt jmpbuffers, if any. */
 -  {
 -    SCM winds = scm_i_dynwinds ();
 -    for (; !scm_is_eq (winds, prevwinds); winds = scm_cdr (winds))
 -      if (SCM_PROMPT_P (scm_car (winds)) && SCM_PROMPT_SETJMP (scm_car (winds)))
 -        break;
 -  }
 -    
    CACHE_REGISTER ();
    program = SCM_FRAME_PROGRAM (fp);
    CACHE_PROGRAM ();
@@@ -1542,9 -1580,8 +1527,8 @@@ VM_DEFINE_INSTRUCTION (89, abort, "abor
  {
    unsigned n = FETCH ();
    SYNC_REGISTER ();
-   if (sp - n - 2 <= SCM_FRAME_UPPER_ADDRESS (fp))
-     goto vm_error_stack_underflow;
+   PRE_CHECK_UNDERFLOW (n + 2);
 -  vm_abort (vm, n, vm_cookie);
 +  vm_abort (vm, n, &registers);
    /* vm_abort should not return */
    abort ();
  }

diff --cc libguile/vm.c
index 5645f81,781175c..b2d0731
--- 1/libguile/vm.c
--- 2/libguile/vm.c
+++ b/libguile/vm.c
@@@ -373,12 -364,239 +373,231 @@@ scm_i_vm_print (SCM x, SCM port, scm_pr
        break;
  
      default:
 -      scm_puts ("unknown-engine ", port);
 +      scm_puts_unlocked ("unknown-engine ", port);
      }
    scm_uintprint (SCM_UNPACK (x), 16, port);
 -  scm_puts (">", port);
 +  scm_puts_unlocked (">", port);
  }
  
 -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_NORETURN;
 -static void vm_error_kwargs_unrecognized_keyword (SCM proc) 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;
+ \f
+ /*
+  * VM Error Handling
+  */
+ 
+ static void vm_error (const char *msg, SCM arg) SCM_NORETURN;
 -static void vm_error_invalid_address (void) SCM_NORETURN;
++static void vm_error_bad_instruction (scm_t_uint32 inst) SCM_NORETURN SCM_NOINLINE;
++static void vm_error_unbound (SCM proc, SCM sym) SCM_NORETURN SCM_NOINLINE;
++static void vm_error_unbound_fluid (SCM proc, SCM fluid) SCM_NORETURN SCM_NOINLINE;
++static void vm_error_not_a_variable (const char *func_name, SCM x) SCM_NORETURN SCM_NOINLINE;
++static void vm_error_apply_to_non_list (SCM x) SCM_NORETURN SCM_NOINLINE;
++static void vm_error_kwargs_length_not_even (SCM proc) SCM_NORETURN SCM_NOINLINE;
++static void vm_error_kwargs_invalid_keyword (SCM proc) SCM_NORETURN SCM_NOINLINE;
++static void vm_error_kwargs_unrecognized_keyword (SCM proc) SCM_NORETURN SCM_NOINLINE;
++static void vm_error_too_many_args (int nargs) SCM_NORETURN SCM_NOINLINE;
++static void vm_error_wrong_num_args (SCM proc) SCM_NORETURN SCM_NOINLINE;
++static void vm_error_wrong_type_apply (SCM proc) SCM_NORETURN SCM_NOINLINE;
++static void vm_error_stack_overflow (struct scm_vm *vp) SCM_NORETURN SCM_NOINLINE;
++static void vm_error_stack_underflow (void) SCM_NORETURN SCM_NOINLINE;
++static void vm_error_improper_list (SCM x) SCM_NORETURN SCM_NOINLINE;
++static void vm_error_not_a_pair (const char *subr, SCM x) SCM_NORETURN SCM_NOINLINE;
++static void vm_error_not_a_bytevector (const char *subr, SCM x) SCM_NORETURN SCM_NOINLINE;
++static void vm_error_not_a_struct (const char *subr, SCM x) SCM_NORETURN SCM_NOINLINE;
++static void vm_error_no_values (void) SCM_NORETURN SCM_NOINLINE;
++static void vm_error_not_enough_values (void) SCM_NORETURN SCM_NOINLINE;
++static void vm_error_continuation_not_rewindable (SCM cont) SCM_NORETURN SCM_NOINLINE;
++static void vm_error_bad_wide_string_length (size_t len) SCM_NORETURN SCM_NOINLINE;
+ #if VM_CHECK_IP
 -static void vm_error_object (void) SCM_NORETURN;
++static void vm_error_invalid_address (void) SCM_NORETURN SCM_NOINLINE;
+ #endif
+ #if VM_CHECK_OBJECT
 -static void vm_error_free_variable (void) SCM_NORETURN;
++static void vm_error_object (void) SCM_NORETURN SCM_NOINLINE;
+ #endif
+ #if VM_CHECK_FREE_VARIABLES
 -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));
 -}
 -
++static void vm_error_free_variable (void) SCM_NORETURN SCM_NOINLINE;
+ #endif
+ 
+ static void
+ vm_error (const char *msg, SCM arg)
+ {
+   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 */
+ }
+ 
+ static void
+ vm_error_bad_instruction (scm_t_uint32 inst)
+ {
+   vm_error ("VM: Bad instruction: ~s", scm_from_uint32 (inst));
+ }
+ 
+ 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);
+ }
+ 
+ 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);
+ }
+ 
+ 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));
+ }
+ 
+ static void
+ vm_error_apply_to_non_list (SCM x)
+ {
+   scm_error (scm_arg_type_key, "apply", "Apply to non-list: ~S",
+              scm_list_1 (x), scm_list_1 (x));
+ }
+ 
+ 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_error_scm (sym_keyword_argument_error, proc,
+                  scm_from_latin1_string ("Invalid keyword"),
+                  SCM_EOL, SCM_BOOL_F);
+ }
+ 
+ static void
+ vm_error_kwargs_unrecognized_keyword (SCM proc)
+ {
+   scm_error_scm (sym_keyword_argument_error, proc,
+                  scm_from_latin1_string ("Unrecognized keyword"),
+                  SCM_EOL, SCM_BOOL_F);
+ }
+ 
+ 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));
+ }
+ 
+ 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
+     /* There is no space left on the stack.  FIXME: Do something more
+        sensible here! */
+     abort ();
+   vm_error ("VM: Stack overflow", SCM_UNDEFINED);
+ }
+ 
+ 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
  really_make_boot_program (long nargs)
  {