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

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

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

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)

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

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)

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!
 

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?

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