summaryrefslogtreecommitdiff
path: root/libguile/vm-engine.c
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2017-11-05 14:47:18 +0100
committerAndy Wingo <wingo@pobox.com>2017-11-05 15:00:16 +0100
commitf96a670332b224326b89ce135a0edfb77a70c46e (patch)
tree9db32959b5f53e2d245bce5735214d462caffa3c /libguile/vm-engine.c
parentcf486700b78a72f1bcab5b450394a63cf3ec7bff (diff)
downloadguile-f96a670332b224326b89ce135a0edfb77a70c46e.tar.gz
Add new "throw" VM ops
* libguile/throw.h (scm_ithrow, scm_throw): Mark as SCM_NORETURN. * libguile/throw.c (scm_throw, scm_ithrow): Adapt to not return. * libguile/vm-engine.c (throw, throw/value, throw/value+data): New instructions. * libguile/vm.c (vm_throw, vm_throw_with_value) (vm_throw_with_value_and_data): New helpers. * module/language/cps/compile-bytecode.scm (compile-function): Add cases for new instructions. * module/language/cps/prune-bailouts.scm (prune-bailouts): More simple, now that there are no $kreceives in play. * module/language/cps/reify-primitives.scm (reify-clause): Update reification of no-clause functions to use new throw op. * module/language/tree-il/compile-cps.scm (convert): Convert invocations of the variable-arity 'throw primitive from Tree-IL to the new fixed-arity CPS instructions. * module/system/vm/assembler.scm (emit-throw/value*) (emit-throw/value+data*, emit-throw): Export new instructions. * module/system/vm/disassembler.scm (code-annotation): Add annotation.
Diffstat (limited to 'libguile/vm-engine.c')
-rw-r--r--libguile/vm-engine.c80
1 files changed, 75 insertions, 5 deletions
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 7c0a226b3..4c4d9eb7b 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -931,12 +931,82 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
* Function prologues
*/
- VM_DEFINE_OP (18, unused_18, NULL, NOP)
- VM_DEFINE_OP (19, unused_19, NULL, NOP)
- VM_DEFINE_OP (20, unused_20, NULL, NOP)
+ /* throw key:12 args:12
+ *
+ * Throw to KEY and ARGS. ARGS should be a list.
+ */
+ VM_DEFINE_OP (18, throw, "throw", OP1 (X8_S12_S12))
{
- vm_error_bad_instruction (op);
- abort ();
+ scm_t_uint16 a, b;
+ SCM key, args;
+
+ UNPACK_12_12 (op, a, b);
+
+ key = SP_REF (a);
+ args = SP_REF (b);
+
+ SYNC_IP ();
+ vm_throw (key, args);
+
+ abort (); /* never reached */
+ }
+
+ /* throw/value val:24 key-subr-and-message:32
+ *
+ * Raise an error, indicating VAL as the bad value.
+ * KEY-SUBR-AND-MESSAGE should be a vector, where the first element is
+ * the symbol to which to throw, the second is the procedure in which
+ * to signal the error (a string) or #f, and the third is a format
+ * string for the message, with one template.
+ */
+ VM_DEFINE_OP (19, throw_value, "throw/value", OP2 (X8_S24, N32))
+ {
+ scm_t_uint32 a;
+ scm_t_int32 offset;
+ scm_t_bits key_subr_and_message_bits;
+ SCM val, key_subr_and_message;
+
+ UNPACK_24 (op, a);
+ val = SP_REF (a);
+
+ offset = ip[1];
+ key_subr_and_message_bits = (scm_t_bits) (ip + offset);
+ VM_ASSERT (!(key_subr_and_message_bits & 0x7), abort());
+ key_subr_and_message = SCM_PACK (key_subr_and_message_bits);
+
+ SYNC_IP ();
+ vm_throw_with_value (val, key_subr_and_message);
+
+ abort (); /* never reached */
+ }
+
+ /* throw/value+data val:24 key-subr-and-message:32
+ *
+ * Raise an error, indicating VAL as the bad value.
+ * KEY-SUBR-AND-MESSAGE should be a vector, where the first element is
+ * the symbol to which to throw, the second is the procedure in which
+ * to signal the error (a string) or #f, and the third is a format
+ * string for the message, with one template.
+ */
+ VM_DEFINE_OP (20, throw_value_and_data, "throw/value+data", OP2 (X8_S24, N32))
+ {
+ scm_t_uint32 a;
+ scm_t_int32 offset;
+ scm_t_bits key_subr_and_message_bits;
+ SCM val, key_subr_and_message;
+
+ UNPACK_24 (op, a);
+ val = SP_REF (a);
+
+ offset = ip[1];
+ key_subr_and_message_bits = (scm_t_bits) (ip + offset);
+ VM_ASSERT (!(key_subr_and_message_bits & 0x7), abort());
+ key_subr_and_message = SCM_PACK (key_subr_and_message_bits);
+
+ SYNC_IP ();
+ vm_throw_with_value_and_data (val, key_subr_and_message);
+
+ abort (); /* never reached */
}
/* assert-nargs-ee expected:24