summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2012-04-30 20:25:53 +0200
committerAndy Wingo <wingo@pobox.com>2012-04-30 21:29:11 +0200
commit53bdfcf03418c4709127140d64f12ede970c174b (patch)
tree426f86597bad304acf3db0acc1f20f9a78bf7a72
parent7dbc03498a763ca6a45e26aabfa74e8c317b55bf (diff)
downloadguile-53bdfcf03418c4709127140d64f12ede970c174b.tar.gz
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.
-rw-r--r--libguile/vm-engine.c184
-rw-r--r--libguile/vm-engine.h41
-rw-r--r--libguile/vm-i-loader.c9
-rw-r--r--libguile/vm-i-scheme.c26
-rw-r--r--libguile/vm-i-system.c163
-rw-r--r--libguile/vm.c227
6 files changed, 331 insertions, 319 deletions
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index c90458df6..67d606201 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 000397de2..46d4cfff0 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 6fa8eb2ea..c3231568e 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 80328cde8..5191b8eac 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 21fa5a195..3ac0097b4 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 d1c7bbcb0..781175cbc 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)
{