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