mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 11:40:18 +02:00
Code Activity

Add new "throw" VM ops

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2017-11-05 14:47:18 +01:00
parent cf486700b7
commit f96a670332
10 changed files with 199 additions and 48 deletions
Download patch file Download diff file Expand all files Collapse all files

8
libguile/throw.c
View file

@ -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");

6
libguile/throw.h
View file

@ -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 */

80
libguile/vm-engine.c
View file

@ -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

42
libguile/vm.c
View file

@ -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,
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)));
abort(); /* not reached */
}
static void

8
module/language/cps/compile-bytecode.scm
View file

@ -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

34
module/language/cps/prune-bailouts.scm
View file

@ -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)))))

14
module/language/cps/reify-primitives.scm
View file

@ -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))

38
module/language/tree-il/compile-cps.scm
View file

@ -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)))

10
module/system/vm/assembler.scm
View file

@ -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

3
module/system/vm/disassembler.scm
View file

@ -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