[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 16/16: Add new "throw" VM ops
From: |
Andy Wingo |
Subject: |
[Guile-commits] 16/16: Add new "throw" VM ops |
Date: |
Sun, 5 Nov 2017 09:00:42 -0500 (EST) |
wingo pushed a commit to branch master
in repository guile.
commit f96a670332b224326b89ce135a0edfb77a70c46e
Author: Andy Wingo <address@hidden>
Date: Sun Nov 5 14:47:18 2017 +0100
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.
---
libguile/throw.c | 8 ++--
libguile/throw.h | 6 +--
libguile/vm-engine.c | 80 ++++++++++++++++++++++++++++++--
libguile/vm.c | 46 ++++++++++++++++--
module/language/cps/compile-bytecode.scm | 8 +++-
module/language/cps/prune-bailouts.scm | 34 +++++---------
module/language/cps/reify-primitives.scm | 14 ++----
module/language/tree-il/compile-cps.scm | 38 +++++++++++++++
module/system/vm/assembler.scm | 10 ++++
module/system/vm/disassembler.scm | 3 ++
10 files changed, 199 insertions(+), 48 deletions(-)
diff --git a/libguile/throw.c b/libguile/throw.c
index 123544e..a3adc42 100644
--- a/libguile/throw.c
+++ b/libguile/throw.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 2004, 2006, 2008, 2009,
2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 2004, 2006, 2008, 2009,
2010, 2011, 2012, 2013, 2014, 2017 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
@@ -263,7 +263,9 @@ scm_with_throw_handler (SCM key, SCM thunk, SCM handler)
SCM
scm_throw (SCM key, SCM args)
{
- return scm_apply_1 (scm_variable_ref (throw_var), key, args);
+ scm_apply_1 (scm_variable_ref (throw_var), key, args);
+ /* Should not be reached. */
+ abort ();
}
@@ -608,7 +610,7 @@ scm_handle_by_throw (void *handler_data SCM_UNUSED, SCM
tag, SCM args)
SCM
scm_ithrow (SCM key, SCM args, int no_return SCM_UNUSED)
{
- return scm_throw (key, args);
+ scm_throw (key, args);
}
SCM_SYMBOL (scm_stack_overflow_key, "stack-overflow");
diff --git a/libguile/throw.h b/libguile/throw.h
index f2020a3..499b7c8 100644
--- a/libguile/throw.h
+++ b/libguile/throw.h
@@ -3,7 +3,7 @@
#ifndef SCM_THROW_H
#define SCM_THROW_H
-/* Copyright (C) 1995,1996,1998,2000, 2006, 2008, 2010, 2014 Free Software
Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,2000, 2006, 2008, 2010, 2014, 2017 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
@@ -84,7 +84,7 @@ SCM_API int scm_exit_status (SCM args);
SCM_API SCM scm_catch_with_pre_unwind_handler (SCM tag, SCM thunk, SCM
handler, SCM lazy_handler);
SCM_API SCM scm_catch (SCM tag, SCM thunk, SCM handler);
SCM_API SCM scm_with_throw_handler (SCM tag, SCM thunk, SCM handler);
-SCM_API SCM scm_ithrow (SCM key, SCM args, int no_return);
+SCM_API SCM scm_ithrow (SCM key, SCM args, int no_return) SCM_NORETURN;
/* This throws to the `stack-overflow' key, without running pre-unwind
handlers. */
@@ -94,7 +94,7 @@ SCM_API void scm_report_stack_overflow (void);
handlers. */
SCM_API void scm_report_out_of_memory (void);
-SCM_API SCM scm_throw (SCM key, SCM args);
+SCM_API SCM scm_throw (SCM key, SCM args) SCM_NORETURN;
SCM_INTERNAL void scm_init_throw (void);
#endif /* SCM_THROW_H */
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 7c0a226..4c4d9eb 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
diff --git a/libguile/vm.c b/libguile/vm.c
index 6db2611..719110a 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -418,6 +418,10 @@ vm_reinstate_partial_continuation (struct scm_vm *vp, SCM
cont, size_t nargs,
* VM Error Handling
*/
+static void vm_throw (SCM key, SCM args) SCM_NORETURN;
+static void vm_throw_with_value (SCM val, SCM key_subr_and_message)
SCM_NORETURN SCM_NOINLINE;
+static void vm_throw_with_value_and_data (SCM val, SCM key_subr_and_message)
SCM_NORETURN SCM_NOINLINE;
+
static void vm_error (const char *msg, SCM arg) SCM_NORETURN;
static void vm_error_bad_instruction (scm_t_uint32 inst) SCM_NORETURN
SCM_NOINLINE;
static void vm_error_unbound (SCM sym) SCM_NORETURN SCM_NOINLINE;
@@ -448,15 +452,49 @@ static void vm_error_wrong_number_of_values (scm_t_uint32
expected) SCM_NORETURN
static void vm_error_continuation_not_rewindable (SCM cont) SCM_NORETURN
SCM_NOINLINE;
static void
-vm_error (const char *msg, SCM arg)
+vm_throw (SCM key, SCM args)
{
- 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)));
+ scm_throw (key, args);
abort(); /* not reached */
}
static void
+vm_throw_with_value (SCM val, SCM key_subr_and_message)
+{
+ SCM key, subr, message, args, data;
+
+ key = SCM_SIMPLE_VECTOR_REF (key_subr_and_message, 0);
+ subr = SCM_SIMPLE_VECTOR_REF (key_subr_and_message, 1);
+ message = SCM_SIMPLE_VECTOR_REF (key_subr_and_message, 2);
+ args = scm_list_1 (val);
+ data = SCM_BOOL_F;
+
+ vm_throw (key, scm_list_4 (subr, message, args, data));
+}
+
+static void
+vm_throw_with_value_and_data (SCM val, SCM key_subr_and_message)
+{
+ SCM key, subr, message, args, data;
+
+ key = SCM_SIMPLE_VECTOR_REF (key_subr_and_message, 0);
+ subr = SCM_SIMPLE_VECTOR_REF (key_subr_and_message, 1);
+ message = SCM_SIMPLE_VECTOR_REF (key_subr_and_message, 2);
+ args = scm_list_1 (val);
+ data = args;
+
+ vm_throw (key, scm_list_4 (subr, message, args, data));
+}
+
+static void
+vm_error (const char *msg, SCM arg)
+{
+ vm_throw (sym_vm_error,
+ scm_list_3 (sym_vm_run, scm_from_latin1_string (msg),
+ SCM_UNBNDP (arg) ? SCM_EOL : scm_list_1 (arg)));
+}
+
+static void
vm_error_bad_instruction (scm_t_uint32 inst)
{
vm_error ("VM: Bad instruction: ~s", scm_from_uint32 (inst));
diff --git a/module/language/cps/compile-bytecode.scm
b/module/language/cps/compile-bytecode.scm
index 2b5d759..1284e65 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -375,7 +375,13 @@
(($ $primcall 'atomic-box-set! #f (box val))
(emit-atomic-box-set! asm (from-sp (slot box)) (from-sp (slot val))))
(($ $primcall 'handle-interrupts #f ())
- (emit-handle-interrupts asm))))
+ (emit-handle-interrupts asm))
+ (($ $primcall 'throw #f (key args))
+ (emit-throw asm (from-sp (slot key)) (from-sp (slot args))))
+ (($ $primcall 'throw/value param (val))
+ (emit-throw/value asm (from-sp (slot val)) param))
+ (($ $primcall 'throw/value+data param (val))
+ (emit-throw/value+data asm (from-sp (slot val)) param))))
(define (compile-values label exp syms)
(match exp
diff --git a/module/language/cps/prune-bailouts.scm
b/module/language/cps/prune-bailouts.scm
index 4120872..dece1a0 100644
--- a/module/language/cps/prune-bailouts.scm
+++ b/module/language/cps/prune-bailouts.scm
@@ -49,22 +49,6 @@ unreferenced terms. In that case TAIL-LABEL is either
absent or #f."
conts
empty-intmap))
-(define (prune-bailout out tails k src exp)
- (match (intmap-ref out k)
- (($ $ktail)
- (with-cps out #f))
- (_
- (match (intmap-ref tails k (lambda (_) #f))
- (#f
- (with-cps out #f))
- (ktail
- (with-cps out
- (letv prim rest)
- (letk kresult ($kargs ('rest) (rest)
- ($continue ktail src ($values ()))))
- (letk kreceive ($kreceive '() 'rest kresult))
- (build-term ($continue kreceive src ,exp))))))))
-
(define (prune-bailouts conts)
(let ((tails (compute-tails conts)))
(with-fresh-name-state conts
@@ -73,13 +57,17 @@ unreferenced terms. In that case TAIL-LABEL is either
absent or #f."
(lambda (label cont out)
(match cont
(($ $kargs names vars
- ($ $continue k src (and exp ($ $primcall 'throw))))
- (call-with-values (lambda () (prune-bailout out tails k src exp))
- (lambda (out term)
- (if term
- (let ((cont (build-cont ($kargs names vars ,term))))
- (intmap-replace! out label cont))
- out))))
+ ($ $continue k src
+ (and exp ($ $primcall
+ (or 'throw 'throw/value 'throw/value+data)))))
+ (match (intmap-ref tails k (lambda (_) #f))
+ (#f out)
+ (ktail
+ (with-cps out
+ (letk knil ($kargs () ()
+ ($continue ktail src ($values ()))))
+ (setk label ($kargs names vars
+ ($continue knil src ,exp)))))))
(_ out)))
conts
conts)))))
diff --git a/module/language/cps/reify-primitives.scm
b/module/language/cps/reify-primitives.scm
index 47982ea..0823584 100644
--- a/module/language/cps/reify-primitives.scm
+++ b/module/language/cps/reify-primitives.scm
@@ -100,17 +100,13 @@
(define (reify-clause cps ktail)
(with-cps cps
- (letv throw)
- (let$ throw-body
+ (letk knil ($kargs () () ($continue ktail #f ($values ()))))
+ (let$ body
(with-cps-constants ((wna 'wrong-number-of-args)
- (false #f)
- (str "Wrong number of arguments")
- (eol '()))
+ (args '(#f "Wrong number of arguments" () #f)))
(build-term
- ($continue ktail #f
- ($call throw (wna false str eol false))))))
- (letk kthrow ($kargs ('throw) (throw) ,throw-body))
- (let$ body (primitive-ref 'throw kthrow #f))
+ ($continue knil #f
+ ($primcall 'throw #f (wna args))))))
(letk kbody ($kargs () () ,body))
(letk kclause ($kclause ('() '() #f '() #f) kbody #f))
kclause))
diff --git a/module/language/tree-il/compile-cps.scm
b/module/language/tree-il/compile-cps.scm
index 8d906ff..9ff497a 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -533,6 +533,41 @@
($primcall 'cons #f (head
tail))))))))
(letk ktail ($kargs ('tail) (tail) ,body))
($ (lp args ktail)))))))))))
+ ((eq? name 'throw)
+ (let ()
+ (define (fallback)
+ (match args
+ ((key . args)
+ (convert-args cps (list key (make-primcall src 'list args))
+ (lambda (cps args)
+ (with-cps cps
+ (let$ k (adapt-arity k src 0))
+ (build-term
+ ($continue k src ($primcall 'throw #f args)))))))))
+ (define (specialize op param . args)
+ (convert-args cps args
+ (lambda (cps args)
+ (with-cps cps
+ (let$ k (adapt-arity k src 0))
+ (build-term
+ ($continue k src ($primcall op param args)))))))
+ (match args
+ ((($ <const> _ key) ($ <const> _ subr) ($ <const> _ msg) args data)
+ ;; Specialize `throw' invocations corresponding to common
+ ;; "error" invocations.
+ (let ()
+ (match (vector args data)
+ (#(($ <primcall> _ 'list (x)) ($ <primcall> _ 'list (x)))
+ (specialize 'throw/value+data `#(,key ,subr ,msg) x))
+ (#(($ <primcall> _ 'cons (x ($ <const> _ ())))
+ ($ <primcall> _ 'cons (x ($ <const> _ ()))))
+ (specialize 'throw/value+data `#(,key ,subr ,msg) x))
+ (#(($ <primcall> _ 'list (x)) ($ <const> _ #f))
+ (specialize 'throw/value `#(,key ,subr ,msg) x))
+ (#(($ <primcall> _ 'cons (x ($ <const> _ ()))) ($ <const> _
#f))
+ (specialize 'throw/value `#(,key ,subr ,msg) x))
+ (_ (fallback)))))
+ (_ (fallback)))))
((prim-instruction name)
=> (lambda (instruction)
(define (box+adapt-arity cps k src out)
@@ -1131,6 +1166,9 @@ integer."
(($ <primcall> src 'logand (($ <primcall> _ 'lognot (y)) x))
(make-primcall src 'logsub (list x y)))
+ (($ <primcall> src 'throw ())
+ (make-call src (make-primitive-ref src 'throw) '()))
+
(($ <prompt> src escape-only? tag body
($ <lambda> hsrc hmeta
($ <lambda-case> _ hreq #f hrest #f () hsyms hbody #f)))
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index 67ef767..5fccd86 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -99,6 +99,10 @@
emit-untag-fixnum
+ emit-throw
+ (emit-throw/value* . emit-throw/value)
+ (emit-throw/value+data* . emit-throw/value+data)
+
emit-pair?
emit-struct?
emit-symbol?
@@ -975,6 +979,12 @@ later by the linker."
(emit-fmov* asm dst (1+ proc))
(emit-reset-frame asm nlocals))))
+(define (emit-throw/value* asm val param)
+ (emit-throw/value asm val (intern-non-immediate asm param)))
+
+(define (emit-throw/value+data* asm val param)
+ (emit-throw/value+data asm val (intern-non-immediate asm param)))
+
(define (emit-text asm instructions)
"Assemble @var{instructions} using the assembler @var{asm}.
@var{instructions} is a sequence of instructions, expressed as a list of
diff --git a/module/system/vm/disassembler.scm
b/module/system/vm/disassembler.scm
index 5183b2d..89acf60 100644
--- a/module/system/vm/disassembler.scm
+++ b/module/system/vm/disassembler.scm
@@ -260,6 +260,8 @@ address of that offset."
(when (program? val)
(push-addr! (program-code val) val))
(list "address@hidden" val)))
+ (((or 'throw/value 'throw/value+data) dst target)
+ (list "address@hidden" (reference-scm target)))
(('builtin-ref dst idx)
(list "~A" (builtin-index->name idx)))
(((or 'static-ref 'static-set!) _ target)
@@ -511,6 +513,7 @@ address of that offset."
(define (instruction-has-fallthrough? code pos)
(define non-fallthrough-set
(static-opcode-set halt
+ throw throw/value throw/value+data
tail-call tail-call-label tail-call/shuffle
return-values
subr-call foreign-call continuation-call
- [Guile-commits] 12/16: Specialize primcalls more aggressively, (continued)
- [Guile-commits] 12/16: Specialize primcalls more aggressively, Andy Wingo, 2017/11/05
- [Guile-commits] 13/16: Earlier conversion to /imm primcalls, Andy Wingo, 2017/11/05
- [Guile-commits] 02/16: cache-current-module, etc use immediate primcall parameters, Andy Wingo, 2017/11/05
- [Guile-commits] 05/16: Immediate variants of vector-ref, etc use immediate param, Andy Wingo, 2017/11/05
- [Guile-commits] 15/16: error, scm-error primcalls expand to `throw', Andy Wingo, 2017/11/05
- [Guile-commits] 07/16: builtin-ref takes immediate parameter, Andy Wingo, 2017/11/05
- [Guile-commits] 09/16: reify-primitives reifies constants for out-of-range imm params, Andy Wingo, 2017/11/05
- [Guile-commits] 03/16: load-f64, etc take immediate parameters, Andy Wingo, 2017/11/05
- [Guile-commits] 04/16: free-ref, free-set take immediate parameters, Andy Wingo, 2017/11/05
- [Guile-commits] 11/16: (system base types) uses target's idea of max size_t, Andy Wingo, 2017/11/05
- [Guile-commits] 16/16: Add new "throw" VM ops,
Andy Wingo <=
- [Guile-commits] 14/16: Add lsh, rsh instructions, Andy Wingo, 2017/11/05
- [Guile-commits] 06/16: Immediate parameter for struct-ref et al, Andy Wingo, 2017/11/05
- [Guile-commits] 08/16: Remaining /immediate instructions take primcall imm param, Andy Wingo, 2017/11/05
- [Guile-commits] 01/16: $primcall has a "param" member, Andy Wingo, 2017/11/05