From f96a670332b224326b89ce135a0edfb77a70c46e Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 5 Nov 2017 14:47:18 +0100 Subject: [PATCH] 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 123544e79..a3adc4231 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 f2020a331..499b7c882 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 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 diff --git a/libguile/vm.c b/libguile/vm.c index 6db2611db..719110a44 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; @@ -447,13 +451,47 @@ static void vm_error_not_enough_values (void) SCM_NORETURN SCM_NOINLINE; static void vm_error_wrong_number_of_values (scm_t_uint32 expected) SCM_NORETURN SCM_NOINLINE; static void vm_error_continuation_not_rewindable (SCM cont) SCM_NORETURN SCM_NOINLINE; +static void +vm_throw (SCM key, SCM args) +{ + 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) { - 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 */ + 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 diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm index 2b5d7591a..1284e6541 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 412087231..dece1a0de 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 47982ea87..0823584d4 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 8d906ffc2..9ff497a2b 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 + ((($ _ key) ($ _ subr) ($ _ msg) args data) + ;; Specialize `throw' invocations corresponding to common + ;; "error" invocations. + (let () + (match (vector args data) + (#(($ _ 'list (x)) ($ _ 'list (x))) + (specialize 'throw/value+data `#(,key ,subr ,msg) x)) + (#(($ _ 'cons (x ($ _ ()))) + ($ _ 'cons (x ($ _ ())))) + (specialize 'throw/value+data `#(,key ,subr ,msg) x)) + (#(($ _ 'list (x)) ($ _ #f)) + (specialize 'throw/value `#(,key ,subr ,msg) x)) + (#(($ _ 'cons (x ($ _ ()))) ($ _ #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." (($ src 'logand (($ _ 'lognot (y)) x)) (make-primcall src 'logsub (list x y))) + (($ src 'throw ()) + (make-call src (make-primitive-ref src 'throw) '())) + (($ src escape-only? tag body ($ hsrc hmeta ($ _ hreq #f hrest #f () hsyms hbody #f))) diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index 67ef7676a..5fccd866d 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 5183b2d2e..89acf6090 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 "~@Y" val))) + (((or 'throw/value 'throw/value+data) dst target) + (list "~@Y" (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