[Guile-commits] branch main updated: Better compilation of calls to `raise-exception`

[Andy Wingo]

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