guile-commits
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.5-126-g53bdf


From: Andy Wingo
Subject: [Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.5-126-g53bdfcf
Date: Mon, 30 Apr 2012 19:31:38 +0000

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=53bdfcf03418c4709127140d64f12ede970c174b

The branch, stable-2.0 has been updated
       via  53bdfcf03418c4709127140d64f12ede970c174b (commit)
       via  7dbc03498a763ca6a45e26aabfa74e8c317b55bf (commit)
       via  c15defef7f1de408f35066d2f2883c110724b2f9 (commit)
      from  4bd53c1ba39ba1c2d51ff895104f27cf4bb69e4e (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit 53bdfcf03418c4709127140d64f12ede970c174b
Author: Andy Wingo <address@hidden>
Date:   Mon Apr 30 20:25:53 2012 +0200

    push error handlers out of line in the vm
    
    * libguile/vm.c:
      (vm_error):
      (vm_error_bad_instruction):
      (vm_error_unbound):
      (vm_error_unbound_fluid):
      (vm_error_not_a_variable):
      (vm_error_not_a_thunk):
      (vm_error_apply_to_non_list):
      (vm_error_kwargs_length_not_even):
      (vm_error_kwargs_invalid_keyword):
      (vm_error_kwargs_unrecognized_keyword):
      (vm_error_too_many_args):
      (vm_error_wrong_num_args):
      (vm_error_wrong_type_apply):
      (vm_error_stack_overflow):
      (vm_error_stack_underflow):
      (vm_error_improper_list):
      (vm_error_not_a_pair):
      (vm_error_not_a_bytevector):
      (vm_error_not_a_struct):
      (vm_error_no_values):
      (vm_error_not_enough_values):
      (vm_error_continuation_not_rewindable):
      (vm_error_bad_wide_string_length):
      (vm_error_invalid_address):
      (vm_error_object):
      (vm_error_free_variable): New internal helpers, implementing VM error
      handling.
    
    * libguile/vm-engine.h (VM_ASSERT): New helper macro.
      (ASSERT, CHECK_OBJECT, CHECK_FREE_VARIABLE):
      (PRE_CHECK_UNDERFLOW, PUSH_LIST): Use the new helper.
    
    * libguile/vm-i-loader.c:
    * libguile/vm-i-scheme.c:
    * libguile/vm-i-system.c: Use VM_ASSERT and the out-of-line error
      handlers.
    
    * libguile/vm-engine.c (vm_engine): Remove inline error handlers, and
      remove a couple of local vars.  Use VM_ASSERT.  Have halt handle the
      return itself.

commit 7dbc03498a763ca6a45e26aabfa74e8c317b55bf
Author: Andy Wingo <address@hidden>
Date:   Mon Apr 30 19:51:06 2012 +0200

    add internal SCM_NOINLINE definition
    
    * libguile/_scm.h (SCM_NOINLINE): New internal define, for things that
      we definitely don't want the compiler to inline.

commit c15defef7f1de408f35066d2f2883c110724b2f9
Author: Andy Wingo <address@hidden>
Date:   Mon Apr 30 19:40:52 2012 +0200

    add scm_c_values helper
    
    * libguile/values.h:
    * libguile/values.c (scm_c_values): New public helper.

-----------------------------------------------------------------------

Summary of changes:
 libguile/_scm.h        |    5 +
 libguile/values.c      |   20 ++++-
 libguile/values.h      |    3 +-
 libguile/vm-engine.c   |  184 ++------------------------------------
 libguile/vm-engine.h   |   41 ++++-----
 libguile/vm-i-loader.c |    9 +--
 libguile/vm-i-scheme.c |   26 +-----
 libguile/vm-i-system.c |  163 ++++++++++++++--------------------
 libguile/vm.c          |  227 ++++++++++++++++++++++++++++++++++++++++++++++++
 9 files changed, 354 insertions(+), 324 deletions(-)

diff --git a/libguile/_scm.h b/libguile/_scm.h
index 48fb2cc..5b4f3b7 100644
--- a/libguile/_scm.h
+++ b/libguile/_scm.h
@@ -190,6 +190,11 @@
 #define scm_to_off64_t    scm_to_int64
 #define scm_from_off64_t  scm_from_int64
 
+#if (defined __GNUC__)
+# define SCM_NOINLINE __attribute__ ((__noinline__))
+#else
+# define SCM_NOINLINE /* noinline */
+#endif
 
 /* The endianness marker in objcode.  */
 #ifdef WORDS_BIGENDIAN
diff --git a/libguile/values.c b/libguile/values.c
index 9c9e5ff..ff56230 100644
--- a/libguile/values.c
+++ b/libguile/values.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 2000, 2001, 2006, 2008, 2009, 2011 Free Software Foundation, 
Inc.
+/* Copyright (C) 2000, 2001, 2006, 2008, 2009, 2011, 2012 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
@@ -108,14 +108,26 @@ SCM_DEFINE (scm_values, "values", 0, 0, 1,
   if (n == 1)
     result = SCM_CAR (args);
   else
-    {
-      result = scm_c_make_struct (scm_values_vtable, 0, 1, SCM_UNPACK (args));
-    }
+    result = scm_c_make_struct (scm_values_vtable, 0, 1, SCM_UNPACK (args));
 
   return result;
 }
 #undef FUNC_NAME
 
+SCM
+scm_c_values (SCM *base, size_t nvalues)
+{
+  SCM ret, *walk;
+
+  if (nvalues == 1)
+    return *base;
+
+  for (ret = SCM_EOL, walk = base + nvalues - 1; walk >= base; walk--)
+    ret = scm_cons (*walk, ret);
+
+  return scm_values (ret);
+}
+
 void
 scm_init_values (void)
 {
diff --git a/libguile/values.h b/libguile/values.h
index 5f79855..f11c9d9 100644
--- a/libguile/values.h
+++ b/libguile/values.h
@@ -3,7 +3,7 @@
 #ifndef SCM_VALUES_H
 #define SCM_VALUES_H
 
-/* Copyright (C) 2000,2001, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 2000,2001, 2006, 2008, 2012 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
@@ -33,6 +33,7 @@ SCM_API SCM scm_values_vtable;
 SCM_INTERNAL void scm_i_extract_values_2 (SCM obj, SCM *p1, SCM *p2);
 
 SCM_API SCM scm_values (SCM args);
+SCM_API SCM scm_c_values (SCM *base, size_t nvalues);
 SCM_API SCM scm_c_value_ref (SCM values, size_t idx);
 SCM_INTERNAL void scm_init_values (void);
 
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index c90458d..67d6062 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 2001, 2009, 2010, 2011 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2009, 2010, 2011, 2012 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
@@ -57,9 +57,7 @@ VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
 
   /* 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 */
+
 #ifdef HAVE_LABELS_AS_VALUES
   static const void **jump_table_pointer = NULL;
 #endif
@@ -109,8 +107,7 @@ VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
     PUSH (SCM_PACK (0)); /* mvra */
     PUSH (SCM_PACK (0)); /* ra */
     PUSH (prog);
-    if (SCM_UNLIKELY (sp + nargs >= stack_limit))
-      goto vm_error_too_many_args;
+    VM_ASSERT (sp + nargs < stack_limit, vm_error_too_many_args (nargs));
     while (nargs--)
       PUSH (*argv++);
   }
@@ -134,176 +131,15 @@ VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
   }
 #endif
 
-  
- vm_done:
-  SYNC_ALL ();
-  return finish_args;
-
-  /* Errors */
-  {
-    SCM err_msg;
-
-    /* FIXME: need to sync regs before allocating anything, in each case. */
-
-  vm_error_bad_instruction:
-    err_msg  = scm_from_latin1_string ("VM: Bad instruction: ~s");
-    finish_args = scm_list_1 (scm_from_uchar (ip[-1]));
-    goto vm_error;
-
-  vm_error_unbound:
-    /* FINISH_ARGS should be the name of the unbound variable.  */
-    SYNC_ALL ();
-    err_msg = scm_from_latin1_string ("Unbound variable: ~s");
-    scm_error_scm (scm_misc_error_key, program, err_msg,
-                   scm_list_1 (finish_args), SCM_BOOL_F);
-    goto vm_error;
-
-  vm_error_unbound_fluid:
-    SYNC_ALL ();
-    err_msg = scm_from_latin1_string ("Unbound fluid: ~s");
-    scm_error_scm (scm_misc_error_key, program, err_msg,
-                   scm_list_1 (finish_args), SCM_BOOL_F);
-    goto vm_error;
-
-  vm_error_not_a_variable:
-    SYNC_ALL ();
-    scm_error (scm_arg_type_key, func_name, "Not a variable: ~S",
-               scm_list_1 (finish_args), scm_list_1 (finish_args));
-    goto vm_error;
-
-  vm_error_apply_to_non_list:
-    SYNC_ALL ();
-    scm_error (scm_arg_type_key, "apply", "Apply to non-list: ~S",
-               scm_list_1 (finish_args), scm_list_1 (finish_args));
-    goto vm_error;
-
-  vm_error_kwargs_length_not_even:
-    SYNC_ALL ();
-    err_msg = scm_from_latin1_string ("Odd length of keyword argument list");
-    scm_error_scm (sym_keyword_argument_error, program, err_msg,
-                   SCM_EOL, SCM_BOOL_F);
-
-  vm_error_kwargs_invalid_keyword:
-    /* FIXME say which one it was */
-    SYNC_ALL ();
-    err_msg = scm_from_latin1_string ("Invalid keyword");
-    scm_error_scm (sym_keyword_argument_error, program, err_msg,
-                   SCM_EOL, SCM_BOOL_F);
-
-  vm_error_kwargs_unrecognized_keyword:
-    /* FIXME say which one it was */
-    SYNC_ALL ();
-    err_msg = scm_from_latin1_string ("Unrecognized keyword");
-    scm_error_scm (sym_keyword_argument_error, program, err_msg,
-                   SCM_EOL, SCM_BOOL_F);
-
-  vm_error_too_many_args:
-    err_msg  = scm_from_latin1_string ("VM: Too many arguments");
-    finish_args = scm_list_1 (scm_from_int (nargs));
-    goto vm_error;
-
-  vm_error_wrong_num_args:
-    /* nargs and program are valid */
-    SYNC_ALL ();
-    scm_wrong_num_args (program);
-    /* shouldn't get here */
-    goto vm_error;
-
-  vm_error_wrong_type_apply:
-    SYNC_ALL ();
-    scm_error (scm_arg_type_key, NULL, "Wrong type to apply: ~S",
-               scm_list_1 (program), scm_list_1 (program));
-    goto vm_error;
-
-  vm_error_stack_overflow:
-    err_msg  = scm_from_latin1_string ("VM: Stack overflow");
-    finish_args = SCM_EOL;
-    if (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;
-    goto vm_error;
-
-  vm_error_stack_underflow:
-    err_msg  = scm_from_latin1_string ("VM: Stack underflow");
-    finish_args = SCM_EOL;
-    goto vm_error;
-
-  vm_error_improper_list:
-    err_msg  = scm_from_latin1_string ("Expected a proper list, but got object 
with tail ~s");
-    goto vm_error;
-
-  vm_error_not_a_pair:
-    SYNC_ALL ();
-    scm_wrong_type_arg_msg (func_name, 1, finish_args, "pair");
-    /* shouldn't get here */
-    goto vm_error;
-
-  vm_error_not_a_bytevector:
-    SYNC_ALL ();
-    scm_wrong_type_arg_msg (func_name, 1, finish_args, "bytevector");
-    /* shouldn't get here */
-    goto vm_error;
-
-  vm_error_not_a_struct:
-    SYNC_ALL ();
-    scm_wrong_type_arg_msg (func_name, 1, finish_args, "struct");
-    /* shouldn't get here */
-    goto vm_error;
-
-  vm_error_not_a_thunk:
-    SYNC_ALL ();
-    scm_wrong_type_arg_msg ("dynamic-wind", 1, finish_args, "thunk");
-    /* shouldn't get here */
-    goto vm_error;
-
-  vm_error_no_values:
-    err_msg  = scm_from_latin1_string ("Zero values returned to single-valued 
continuation");
-    finish_args = SCM_EOL;
-    goto vm_error;
-
-  vm_error_not_enough_values:
-    err_msg  = scm_from_latin1_string ("Too few values returned to 
continuation");
-    finish_args = SCM_EOL;
-    goto vm_error;
-
-  vm_error_continuation_not_rewindable:
-    err_msg  = scm_from_latin1_string ("Unrewindable partial continuation");
-    finish_args = scm_cons (finish_args, SCM_EOL);
-    goto vm_error;
-
-  vm_error_bad_wide_string_length:
-    err_msg  = scm_from_latin1_string ("VM: Bad wide string length: ~S");
-    goto vm_error;
-
-#ifdef VM_CHECK_IP
-  vm_error_invalid_address:
-    err_msg  = scm_from_latin1_string ("VM: Invalid program address");
-    finish_args = SCM_EOL;
-    goto vm_error;
-#endif
-
-#if VM_CHECK_OBJECT
-  vm_error_object:
-    err_msg = scm_from_latin1_string ("VM: Invalid object table access");
-    finish_args = SCM_EOL;
-    goto vm_error;
-#endif
-
-#if VM_CHECK_FREE_VARIABLES
-  vm_error_free_variable:
-    err_msg = scm_from_latin1_string ("VM: Invalid free variable access");
-    finish_args = SCM_EOL;
-    goto vm_error;
-#endif
-
-  vm_error:
-    SYNC_ALL ();
+  abort (); /* never reached */
 
-    scm_ithrow (sym_vm_error, scm_list_3 (sym_vm_run, err_msg, finish_args),
-               1);
-  }
+ vm_error_bad_instruction:
+  vm_error_bad_instruction (ip[-1]);
+  abort (); /* never reached */
 
+ handle_overflow:
+  SYNC_ALL ();
+  vm_error_stack_overflow (vp);
   abort (); /* never reached */
 }
 
diff --git a/libguile/vm-engine.h b/libguile/vm-engine.h
index 000397d..46d4cff 100644
--- a/libguile/vm-engine.h
+++ b/libguile/vm-engine.h
@@ -1,4 +1,4 @@
-/* Copyright (C) 2001, 2009, 2010, 2011 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2009, 2010, 2011, 2012 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
@@ -103,8 +103,11 @@
  * Cache/Sync
  */
 
+#define VM_ASSERT(condition, handler) \
+  do { if (SCM_UNLIKELY (!(condition))) { SYNC_ALL(); handler; } } while (0)
+
 #ifdef VM_ENABLE_ASSERTIONS
-# define ASSERT(condition) if (SCM_UNLIKELY (!(condition))) abort()
+# define ASSERT(condition) VM_ASSERT (condition, abort())
 #else
 # define ASSERT(condition)
 #endif
@@ -191,18 +194,16 @@
 
 /* Accesses to a program's object table.  */
 #if VM_CHECK_OBJECT
-#define CHECK_OBJECT(_num) \
-  do { if (SCM_UNLIKELY ((_num) >= object_count)) goto vm_error_object; } 
while (0)
+#define CHECK_OBJECT(_num)                              \
+  VM_ASSERT ((_num) < object_count, vm_error_object ())
 #else
 #define CHECK_OBJECT(_num)
 #endif
 
 #if VM_CHECK_FREE_VARIABLES
-#define CHECK_FREE_VARIABLE(_num)                                       \
-  do {                                                                  \
-    if (SCM_UNLIKELY ((_num) >= SCM_PROGRAM_NUM_FREE_VARIABLES (program))) \
-      goto vm_error_free_variable;                                      \
-  } while (0)
+#define CHECK_FREE_VARIABLE(_num)                               \
+  VM_ASSERT ((_num) < SCM_PROGRAM_NUM_FREE_VARIABLES (program), \
+             vm_error_free_variable ())
 #else
 #define CHECK_FREE_VARIABLE(_num)
 #endif
@@ -276,21 +277,20 @@
 # 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
 
 
@@ -333,10 +333,7 @@ do                                         \
 {                                              \
   for (; scm_is_pair (l); l = SCM_CDR (l))      \
     PUSH (SCM_CAR (l));                         \
-  if (SCM_UNLIKELY (!NILP (l))) {               \
-    finish_args = scm_list_1 (l);               \
-    goto vm_error_improper_list;                \
-  }                                             \
+  VM_ASSERT (NILP (l), vm_error_improper_list (l)); \
 } while (0)
 
 
diff --git a/libguile/vm-i-loader.c b/libguile/vm-i-loader.c
index 6fa8eb2..c323156 100644
--- a/libguile/vm-i-loader.c
+++ b/libguile/vm-i-loader.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 2001,2008,2009,2010,2011 Free Software Foundation, Inc.
+/* Copyright (C) 2001,2008,2009,2010,2011,2012 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
@@ -105,11 +105,8 @@ VM_DEFINE_LOADER (107, load_wide_string, 
"load-wide-string")
   scm_t_wchar *wbuf;
 
   FETCH_LENGTH (len);
-  if (SCM_UNLIKELY (len % 4))
-    {
-      finish_args = scm_list_1 (scm_from_size_t (len));
-      goto vm_error_bad_wide_string_length;
-    }
+  VM_ASSERT ((len % 4) == 0,
+             vm_error_bad_wide_string_length (len));
 
   SYNC_REGISTER ();
   PUSH (scm_i_make_wide_string (len / 4, &wbuf, 1));
diff --git a/libguile/vm-i-scheme.c b/libguile/vm-i-scheme.c
index 80328cd..5191b8e 100644
--- a/libguile/vm-i-scheme.c
+++ b/libguile/vm-i-scheme.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 2001, 2009, 2010, 2011 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2009, 2010, 2011, 2012 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
@@ -124,11 +124,7 @@ VM_DEFINE_FUNCTION (140, cons, "cons", 2)
 }
 
 #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)
 {
@@ -503,12 +499,7 @@ VM_DEFINE_INSTRUCTION (165, make_array, "make-array", 3, 
-1, 1)
  * 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)
 {
@@ -654,16 +645,7 @@ VM_DEFINE_INSTRUCTION (173, slot_set, "slot-set", 0, 3, 0)
  * Bytevectors
  */
 #define VM_VALIDATE_BYTEVECTOR(x, proc)                \
-  do                                           \
-    {                                          \
-      if (SCM_UNLIKELY (!SCM_BYTEVECTOR_P (x)))        \
-       {                                       \
-          func_name = proc;                     \
-         finish_args = x;                      \
-         goto vm_error_not_a_bytevector;       \
-       }                                       \
-    }                                          \
-  while (0)
+  VM_ASSERT (SCM_BYTEVECTOR_P (x), vm_error_not_a_bytevector (proc, x))
 
 #define BV_REF_WITH_ENDIANNESS(stem, fn_stem)                           \
 {                                                                       \
diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index 21fa5a1..3ac0097 100644
--- a/libguile/vm-i-system.c
+++ b/libguile/vm-i-system.c
@@ -31,16 +31,20 @@ VM_DEFINE_INSTRUCTION (0, nop, "nop", 0, 0, 0)
 
 VM_DEFINE_INSTRUCTION (1, halt, "halt", 0, 0, 0)
 {
+  SCM ret;
+
   nvalues = SCM_I_INUM (*sp--);
   NULLSTACK (1);
+
   if (nvalues == 1)
-    POP (finish_args);
+    POP (ret);
   else
     {
-      POP_LIST (nvalues);
-      POP (finish_args);
       SYNC_REGISTER ();
-      finish_args = scm_values (finish_args);
+      sp -= nvalues;
+      CHECK_UNDERFLOW ();
+      ret = scm_c_values (sp + 1, nvalues);
+      NULLSTACK (nvalues);
     }
     
   {
@@ -58,7 +62,8 @@ VM_DEFINE_INSTRUCTION (1, halt, "halt", 0, 0, 0)
     NULLSTACK (old_sp - sp);
   }
   
-  goto vm_done;
+  SYNC_ALL ();
+  return ret;
 }
 
 VM_DEFINE_INSTRUCTION (2, drop, "drop", 0, 1, 0)
@@ -298,20 +303,16 @@ VM_DEFINE_INSTRUCTION (25, variable_ref, "variable-ref", 
0, 1, 1)
      unlike in top-variable-ref, it really isn't an internal assertion
      that can be optimized out -- the variable could be coming directly
      from the user.  */
-  if (SCM_UNLIKELY (!SCM_VARIABLEP (x)))
-    {
-      func_name = "variable-ref";
-      finish_args = x;
-      goto vm_error_not_a_variable;
-    }
-  else if (SCM_UNLIKELY (!VARIABLE_BOUNDP (x)))
+  VM_ASSERT (SCM_VARIABLEP (x),
+             vm_error_not_a_variable ("variable-ref", x));
+
+  if (SCM_UNLIKELY (!VARIABLE_BOUNDP (x)))
     {
       SCM var_name;
 
       /* Attempt to provide the variable name in the error message.  */
       var_name = scm_module_reverse_lookup (scm_current_module (), x);
-      finish_args = scm_is_true (var_name) ? var_name : x;
-      goto vm_error_unbound;
+      vm_error_unbound (program, scm_is_true (var_name) ? var_name : x);
     }
   else
     {
@@ -326,14 +327,10 @@ VM_DEFINE_INSTRUCTION (26, variable_bound, 
"variable-bound?", 0, 1, 1)
 {
   SCM x = *sp;
   
-  if (SCM_UNLIKELY (!SCM_VARIABLEP (x)))
-    {
-      func_name = "variable-bound?";
-      finish_args = x;
-      goto vm_error_not_a_variable;
-    }
-  else
-    *sp = scm_from_bool (VARIABLE_BOUNDP (x));
+  VM_ASSERT (SCM_VARIABLEP (x),
+             vm_error_not_a_variable ("variable-bound?", x));
+
+  *sp = scm_from_bool (VARIABLE_BOUNDP (x));
   NEXT;
 }
 
@@ -348,11 +345,7 @@ VM_DEFINE_INSTRUCTION (27, toplevel_ref, "toplevel-ref", 
1, 0, 1)
     {
       SYNC_REGISTER ();
       resolved = resolve_variable (what, scm_program_module (program));
-      if (!VARIABLE_BOUNDP (resolved))
-        {
-          finish_args = what;
-          goto vm_error_unbound;
-        }
+      VM_ASSERT (VARIABLE_BOUNDP (resolved), vm_error_unbound (program, what));
       what = resolved;
       OBJECT_SET (objnum, what);
     }
@@ -374,11 +367,8 @@ VM_DEFINE_INSTRUCTION (28, long_toplevel_ref, 
"long-toplevel-ref", 2, 0, 1)
     {
       SYNC_REGISTER ();
       resolved = resolve_variable (what, scm_program_module (program));
-      if (!VARIABLE_BOUNDP (resolved))
-        {
-          finish_args = what;
-          goto vm_error_unbound;
-        }
+      VM_ASSERT (VARIABLE_BOUNDP (resolved),
+                 vm_error_unbound (program, what));
       what = resolved;
       OBJECT_SET (objnum, what);
     }
@@ -410,12 +400,8 @@ VM_DEFINE_INSTRUCTION (30, long_local_set, 
"long-local-set", 2, 1, 0)
 
 VM_DEFINE_INSTRUCTION (31, variable_set, "variable-set", 0, 2, 0)
 {
-  if (SCM_UNLIKELY (!SCM_VARIABLEP (sp[0])))
-    {
-      func_name = "variable-set!";
-      finish_args = sp[0];
-      goto vm_error_not_a_variable;
-    }
+  VM_ASSERT (SCM_VARIABLEP (sp[0]),
+             vm_error_not_a_variable ("variable-set!", sp[0]));
   VARIABLE_SET (sp[0], sp[-1]);
   DROPN (2);
   NEXT;
@@ -585,8 +571,8 @@ VM_DEFINE_INSTRUCTION (44, assert_nargs_ee, 
"assert-nargs-ee", 2, 0, 0)
   scm_t_ptrdiff n;
   n = FETCH () << 8;
   n += FETCH ();
-  if (sp - (fp - 1) != n)
-    goto vm_error_wrong_num_args;
+  VM_ASSERT (sp - (fp - 1) == n,
+             vm_error_wrong_num_args (program));
   NEXT;
 }
 
@@ -595,8 +581,8 @@ VM_DEFINE_INSTRUCTION (45, assert_nargs_ge, 
"assert-nargs-ge", 2, 0, 0)
   scm_t_ptrdiff n;
   n = FETCH () << 8;
   n += FETCH ();
-  if (sp - (fp - 1) < n)
-    goto vm_error_wrong_num_args;
+  VM_ASSERT (sp - (fp - 1) >= n,
+             vm_error_wrong_num_args (program));
   NEXT;
 }
 
@@ -666,9 +652,9 @@ VM_DEFINE_INSTRUCTION (48, bind_kwargs, "bind-kwargs", 5, 
0, 0)
   nkw += FETCH ();
   kw_and_rest_flags = FETCH ();
 
-  if (!(kw_and_rest_flags & F_REST)
-      && ((sp - (fp - 1) - nkw) % 2))
-    goto vm_error_kwargs_length_not_even;
+  VM_ASSERT ((kw_and_rest_flags & F_REST)
+             || ((sp - (fp - 1) - nkw) % 2) == 0,
+             vm_error_kwargs_length_not_even (program))
 
   CHECK_OBJECT (idx);
   kw = OBJECT_REF (idx);
@@ -690,13 +676,14 @@ VM_DEFINE_INSTRUCTION (48, bind_kwargs, "bind-kwargs", 5, 
0, 0)
                  break;
                }
            }
-         if (!(kw_and_rest_flags & F_ALLOW_OTHER_KEYS) && !scm_is_pair (walk))
-           goto vm_error_kwargs_unrecognized_keyword;
-
+          VM_ASSERT (scm_is_pair (walk)
+                     || (kw_and_rest_flags & F_ALLOW_OTHER_KEYS),
+                     vm_error_kwargs_unrecognized_keyword (program));
          nkw++;
        }
-      else if (!(kw_and_rest_flags & F_REST))
-        goto vm_error_kwargs_invalid_keyword;
+      else
+        VM_ASSERT (kw_and_rest_flags & F_REST,
+                   vm_error_kwargs_invalid_keyword (program));
     }
 
   NEXT;
@@ -795,7 +782,10 @@ VM_DEFINE_INSTRUCTION (53, call, "call", 1, -1, 1)
           goto vm_call;
         }
       else
-        goto vm_error_wrong_type_apply;
+        {
+          SYNC_ALL();
+          vm_error_wrong_type_apply (program);
+        }
     }
 
   CACHE_PROGRAM ();
@@ -843,7 +833,10 @@ VM_DEFINE_INSTRUCTION (54, tail_call, "tail-call", 1, -1, 
1)
           goto vm_tail_call;
         }
       else
-        goto vm_error_wrong_type_apply;
+        {
+          SYNC_ALL();
+          vm_error_wrong_type_apply (program);
+        }
     }
   else
     {
@@ -1035,10 +1028,8 @@ VM_DEFINE_INSTRUCTION (59, partial_cont_call, 
"partial-cont-call", 0, -1, 0)
   SCM vmcont, intwinds, prevwinds;
   POP2 (intwinds, 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);
@@ -1104,7 +1095,10 @@ VM_DEFINE_INSTRUCTION (62, mv_call, "mv-call", 4, -1, 1)
           goto vm_mv_call;
         }
       else
-        goto vm_error_wrong_type_apply;
+        {
+          SYNC_ALL();
+          vm_error_wrong_type_apply (program);
+        }
     }
 
   CACHE_PROGRAM ();
@@ -1138,12 +1132,8 @@ VM_DEFINE_INSTRUCTION (63, apply, "apply", 1, -1, 1)
   ASSERT (nargs >= 2);
 
   len = scm_ilength (ls);
-  if (SCM_UNLIKELY (len < 0))
-    {
-      finish_args = ls;
-      goto vm_error_apply_to_non_list;
-    }
-
+  VM_ASSERT (len >= 0,
+             vm_error_apply_to_non_list (ls));
   PUSH_LIST (ls, SCM_NULL_OR_NIL_P);
 
   nargs += len - 2;
@@ -1160,12 +1150,8 @@ VM_DEFINE_INSTRUCTION (64, tail_apply, "tail-apply", 1, 
-1, 1)
   ASSERT (nargs >= 2);
 
   len = scm_ilength (ls);
-  if (SCM_UNLIKELY (len < 0))
-    {
-      finish_args = ls;
-      goto vm_error_apply_to_non_list;
-    }
-
+  VM_ASSERT (len >= 0,
+             vm_error_apply_to_non_list (ls));
   PUSH_LIST (ls, SCM_NULL_OR_NIL_P);
 
   nargs += len - 2;
@@ -1330,7 +1316,10 @@ VM_DEFINE_INSTRUCTION (68, return_values, 
"return/values", 1, -1, -1)
       NULLSTACK (vals + nvalues - sp);
     }
   else
-    goto vm_error_no_values;
+    {
+      SYNC_ALL ();
+      vm_error_no_values ();
+    }
 
   /* Restore the last program */
   program = SCM_FRAME_PROGRAM (fp);
@@ -1354,10 +1343,7 @@ VM_DEFINE_INSTRUCTION (69, return_values_star, 
"return/values*", 1, -1, -1)
       l = SCM_CDR (l);
       nvalues++;
     }
-  if (SCM_UNLIKELY (!SCM_NULL_OR_NIL_P (l))) {
-    finish_args = scm_list_1 (l);
-    goto vm_error_improper_list;
-  }
+  VM_ASSERT (SCM_NULL_OR_NIL_P (l), vm_error_improper_list (l));
 
   goto vm_return_values;
 }
@@ -1383,8 +1369,7 @@ VM_DEFINE_INSTRUCTION (71, truncate_values, 
"truncate-values", 2, -1, -1)
   if (rest)
     nbinds--;
 
-  if (nvalues < nbinds)
-    goto vm_error_not_enough_values;
+  VM_ASSERT (nvalues >= nbinds, vm_error_not_enough_values ());
 
   if (rest)
     POP_LIST (nvalues - nbinds);
@@ -1585,16 +1570,8 @@ VM_DEFINE_INSTRUCTION (86, wind, "wind", 0, 2, 0)
   /* Push wind and unwind procedures onto the dynamic stack. Note that neither
      are actually called; the compiler should emit calls to wind and unwind for
      the normal dynamic-wind control flow. */
-  if (SCM_UNLIKELY (scm_is_false (scm_thunk_p (wind))))
-    {
-      finish_args = wind;
-      goto vm_error_not_a_thunk;
-    }
-  if (SCM_UNLIKELY (scm_is_false (scm_thunk_p (unwind))))
-    {
-      finish_args = unwind;
-      goto vm_error_not_a_thunk;
-    }
+  VM_ASSERT (scm_thunk_p (wind), vm_error_not_a_thunk ("dynamic-wind", wind));
+  VM_ASSERT (scm_thunk_p (unwind), vm_error_not_a_thunk ("dynamic-wind", 
unwind));
   scm_i_set_dynwinds (scm_cons (scm_cons (wind, unwind), scm_i_dynwinds ()));
   NEXT;
 }
@@ -1603,8 +1580,7 @@ VM_DEFINE_INSTRUCTION (87, abort, "abort", 1, -1, -1)
 {
   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 should not return */
   abort ();
@@ -1662,11 +1638,8 @@ VM_DEFINE_INSTRUCTION (91, fluid_ref, "fluid-ref", 0, 1, 
1)
       SCM val = SCM_SIMPLE_VECTOR_REF (fluids, num);
       if (scm_is_eq (val, SCM_UNDEFINED))
         val = SCM_I_FLUID_DEFAULT (*sp);
-      if (SCM_UNLIKELY (scm_is_eq (val, SCM_UNDEFINED)))
-        {
-          finish_args = *sp;
-          goto vm_error_unbound_fluid;
-        }
+      VM_ASSERT (!scm_is_eq (val, SCM_UNDEFINED),
+                 vm_error_unbound_fluid (program, *sp));
       *sp = val;
     }
   
@@ -1701,8 +1674,8 @@ VM_DEFINE_INSTRUCTION (93, assert_nargs_ee_locals, 
"assert-nargs-ee/locals", 1,
   /* nargs = n & 0x7, nlocs = nargs + (n >> 3) */
   n = FETCH ();
 
-  if (SCM_UNLIKELY (sp - (fp - 1) != (n & 0x7)))
-    goto vm_error_wrong_num_args;
+  VM_ASSERT (sp - (fp - 1) == (n & 0x7),
+             vm_error_wrong_num_args (program));
 
   old_sp = sp;
   sp += (n >> 3);
diff --git a/libguile/vm.c b/libguile/vm.c
index d1c7bbc..781175c 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -370,6 +370,233 @@ scm_i_vm_print (SCM x, SCM port, scm_print_state *pstate)
   scm_puts (">", port);
 }
 
+
+/*
+ * 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_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;
+#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_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_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_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
+
+
 static SCM
 really_make_boot_program (long nargs)
 {


hooks/post-receive
-- 
GNU Guile



reply via email to

[Prev in Thread] Current Thread [Next in Thread]