This is an automated email from the git hooks/post-receive script.
wingo pushed a commit to branch main
in repository guile.
The following commit(s) were added to refs/heads/main by this push:
new c2cba8678 Better compilation of calls to `raise-exception`
c2cba8678 is described below
commit c2cba86785a34351788f52ea4fccf9f10f3a1dee
Author: Andy Wingo <wi...@pobox.com>
AuthorDate: Mon Aug 28 12:03:17 2023 +0200
Better compilation of calls to `raise-exception`
Recognize `raise-exception` in the same way we recognize `throw`, though
it is a bit less optimized and the boot story is not as complicated.
* doc/ref/vm.texi (Non-Local Control Flow Instructions):
* libguile/jit.c (compile_unreachable):
(compile_unreachable_slow):
* libguile/vm-engine.c (VM_NAME):
* module/language/cps/compile-bytecode.scm (compile-function):
* module/system/vm/assembler.scm (emit-unreachable): Add new
"unreachable" instruction, inserted after a call to non-continuable
`raise-exception`.
* module/language/tree-il/compile-cps.scm (raise-exception):
* module/language/tree-il/primitives.scm
(*interesting-primitive-names*): Recognize raise-exception, and if it is
called with just one argument, prune that branch of the control-flow
graph.
---
doc/ref/vm.texi | 10 +++++++++-
libguile/jit.c | 13 ++++++++++++-
libguile/vm-engine.c | 14 ++++++++++++--
module/language/cps/compile-bytecode.scm | 4 +++-
module/language/tree-il/compile-cps.scm | 27 +++++++++++++++++++++++++++
module/language/tree-il/primitives.scm | 2 +-
module/system/vm/assembler.scm | 1 +
module/system/vm/disassembler.scm | 4 ++--
8 files changed, 67 insertions(+), 8 deletions(-)
diff --git a/doc/ref/vm.texi b/doc/ref/vm.texi
index d7a2372b8..b0669f0d4 100644
--- a/doc/ref/vm.texi
+++ b/doc/ref/vm.texi
@@ -1,6 +1,6 @@
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
-@c Copyright (C) 2008-2011, 2013, 2015, 2018, 2019, 2020, 2022
+@c Copyright (C) 2008-2011, 2013, 2015, 2018, 2019, 2020, 2022, 2023
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@@ -1014,6 +1014,14 @@ list with @var{value}, and either @code{#f} or the list
with @var{value}
as the last argument respectively.
@end deftypefn
+@deftypefn Instruction {} unreachable x24:@var{_}
+Abort the process. This instruction should never be reached and must
+not continue. You would think this is useless but that's not the case:
+it is inserted after a primcall to @code{raise-exception}, and allows
+compilers to know that this branch of control flow does not rejoin the
+graph.
+@end deftypefn
+
@node Instrumentation Instructions
@subsubsection Instrumentation Instructions
diff --git a/libguile/jit.c b/libguile/jit.c
index 515882740..986606e01 100644
--- a/libguile/jit.c
+++ b/libguile/jit.c
@@ -1,4 +1,4 @@
-/* Copyright 2018-2021
+/* Copyright 2018-2021, 2023
Free Software Foundation, Inc.
This file is part of Guile.
@@ -1991,6 +1991,17 @@ compile_throw_value_and_data_slow (scm_jit_state *j,
uint32_t val,
{
}
+static void
+compile_unreachable (scm_jit_state *j)
+{
+ jit_breakpoint (j->jit);
+ set_register_state (j, UNREACHABLE);
+}
+static void
+compile_unreachable_slow (scm_jit_state *j)
+{
+}
+
static void
compile_assert_nargs_ee (scm_jit_state *j, uint32_t nlocals)
{
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index c0145ee8a..7f41f3932 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -1,4 +1,4 @@
-/* Copyright 2001,2009-2015,2017-2021
+/* Copyright 2001,2009-2015,2017-2021,2023
Free Software Foundation, Inc.
This file is part of Guile.
@@ -3478,7 +3478,17 @@ VM_NAME (scm_thread *thread)
NEXT (4);
}
- VM_DEFINE_OP (167, unused_167, NULL, NOP)
+ /* unreachable _:24
+ *
+ * Abort the process. Guile's compiler emits these bytecodes where it
+ * knows that control cannot continue, for example after a call to
+ * non-continuing `raise-exception'.
+ */
+ VM_DEFINE_OP (167, unreachable, "unreachable", OP1 (X32))
+ {
+ abort (); /* never reached */
+ }
+
VM_DEFINE_OP (168, unused_168, NULL, NOP)
VM_DEFINE_OP (169, unused_169, NULL, NOP)
VM_DEFINE_OP (170, unused_170, NULL, NOP)
diff --git a/module/language/cps/compile-bytecode.scm
b/module/language/cps/compile-bytecode.scm
index d6d1737b3..ad5e0024d 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -417,7 +417,9 @@
(#('throw/value param (val))
(emit-throw/value asm (from-sp (slot val)) param))
(#('throw/value+data param (val))
- (emit-throw/value+data asm (from-sp (slot val)) param))))
+ (emit-throw/value+data asm (from-sp (slot val)) param))
+ (#('unreachable #f ())
+ (emit-unreachable asm))))
(define (compile-prompt label k kh escape? tag)
(let ((receive-args (gensym "handler"))
diff --git a/module/language/tree-il/compile-cps.scm
b/module/language/tree-il/compile-cps.scm
index ff22fa5ca..9ebdb72a3 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -1478,6 +1478,33 @@ use as the proc slot."
(_ (fallback)))))
(_ (fallback))))
+(define-custom-primcall-converter (raise-exception cps src args convert-args k)
+ ;; When called with just one arg, we know that raise-exception is
+ ;; non-continuing, and so we can prune the graph at its continuation.
+ ;; This improves flow analysis, because the path that leads to the
+ ;; raise-exception doesn't rejoin the graph.
+ (convert-args cps args
+ (lambda (cps args)
+ (define (maybe-prune-graph cps k)
+ (match args
+ ((_)
+ (with-cps cps
+ (letv vals)
+ (letk kunreachable ($kargs (#f) (vals)
+ ($throw src 'unreachable #f ())))
+ (letk kret ($kreceive '() 'rest kunreachable))
+ kret))
+ (_
+ (with-cps cps
+ k))))
+ (with-cps cps
+ (letv prim)
+ (let$ k (maybe-prune-graph k))
+ (letk kcall ($kargs ('prim) (prim)
+ ($continue k src ($call prim args))))
+ (build-term
+ ($continue kcall src ($prim 'raise-exception)))))))
+
(define-custom-primcall-converter (values cps src args convert-args k)
(convert-args cps args
(lambda (cps args)
diff --git a/module/language/tree-il/primitives.scm
b/module/language/tree-il/primitives.scm
index ef883ec9c..bcd2a1c05 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -95,7 +95,7 @@
abort-to-prompt* abort-to-prompt
make-prompt-tag
- throw error scm-error
+ throw error scm-error raise-exception
string-length string-ref string-set!
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index 7e0763e53..ef67c1846 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -109,6 +109,7 @@
emit-throw
(emit-throw/value* . emit-throw/value)
(emit-throw/value+data* . emit-throw/value+data)
+ emit-unreachable
emit-pair?
emit-struct?
diff --git a/module/system/vm/disassembler.scm
b/module/system/vm/disassembler.scm
index ac1d21639..0c69c2b57 100644
--- a/module/system/vm/disassembler.scm
+++ b/module/system/vm/disassembler.scm
@@ -1,6 +1,6 @@
;;; Guile bytecode disassembler
-;;; Copyright (C) 2001, 2009-2010, 2012-2015, 2017-2020, 2022 Free Software
Foundation, Inc.
+;;; Copyright (C) 2001, 2009-2010, 2012-2015, 2017-2020, 2022, 2023 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
@@ -583,7 +583,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
+ throw throw/value throw/value+data unreachable
tail-call tail-call-label
return-values
subr-call foreign-call continuation-call
