bug#46824: 28.0.50; nativecomp crash with cl-block/cl-defun

[Pip Cet <pipcet@gmail.com>]

[-- Attachment #1: Type: text/plain, Size: 326 bytes --]

On Mon, Mar 1, 2021 at 5:04 PM Andrea Corallo <akrl@sdf.org> wrote:
> Please add to the patch the reported reproducer into
> test/src/comp-test-funcs.el exercising it from test/src/comp-tests.el,
> you can probably place it after the last reproducer that was added there
> (46670).

Test added. Okay to commit like this?

Pip

[-- Attachment #2: 0001-Don-t-call-_setjmp-through-a-function-pointer-Bug-46.patch --]
[-- Type: text/x-patch, Size: 4658 bytes --]

From 769a3fa46abae75a6619c7813c475365f7efb509 Mon Sep 17 00:00:00 2001
From: Pip Cet <pipcet@gmail.com>
Date: Sun, 28 Feb 2021 06:31:00 +0000
Subject: [PATCH] Don't call _setjmp through a function pointer (Bug#46824)

* src/comp.c (helper_link_table): Don't include SETJMP except on Windows.
(emit_setjmp): Don't use function pointers except on Windows.
(declare_runtime_imported_funcs): Don't import SETJMP at runtime.
(ABI_VERSION): Bump.
* test/src/comp-tests.el (setjmp): New test.
* test/src/comp-test-funcs.el (comp-test-setjmp): New function.
---
 src/comp.c                  | 25 ++++++++++++++++++-------
 test/src/comp-test-funcs.el | 19 ++++++++++++++++++-
 test/src/comp-tests.el      |  6 +++++-
 3 files changed, 41 insertions(+), 9 deletions(-)

diff --git a/src/comp.c b/src/comp.c
index 21d1c1a23cf0e..3b002535768b4 100644
--- a/src/comp.c
+++ b/src/comp.c
@@ -416,7 +416,7 @@ load_gccjit_if_necessary (bool mandatory)
 
 \f
 /* Increase this number to force a new Vcomp_abi_hash to be generated.  */
-#define ABI_VERSION "1"
+#define ABI_VERSION "2"
 
 /* Length of the hashes used for eln file naming.  */
 #define HASH_LENGTH 8
@@ -640,7 +640,9 @@ #define NUM_CAST_TYPES 15
     helper_PSEUDOVECTOR_TYPEP_XUNTAG,
     pure_write_error,
     push_handler,
+#ifdef WINDOWSNT
     SETJMP_NAME,
+#endif
     record_unwind_protect_excursion,
     helper_unbind_n,
     helper_save_restriction,
@@ -1929,8 +1931,20 @@ emit_setjmp (gcc_jit_rvalue *buf)
 {
 #ifndef WINDOWSNT
   gcc_jit_rvalue *args[] = {buf};
-  return emit_call (intern_c_string (STR (SETJMP_NAME)), comp.int_type, 1, args,
-                   false);
+  gcc_jit_param *params[] =
+    {
+      gcc_jit_context_new_param (comp.ctxt, NULL, comp.void_ptr_type, "buf"),
+    };
+  /* Don't call setjmp through a function pointer (Bug#46824) */
+  return gcc_jit_context_new_call (comp.ctxt,
+				   NULL,
+				   gcc_jit_context_new_function
+				   (comp.ctxt, NULL, GCC_JIT_FUNCTION_IMPORTED,
+				    comp.int_type, STR (SETJMP_NAME),
+				    ARRAYELTS (params), params,
+				    false),
+				   1,
+				   args);
 #else
   /* _setjmp (buf, __builtin_frame_address (0)) */
   gcc_jit_rvalue *args[2];
@@ -2662,10 +2676,7 @@ #define ADD_IMPORTED(f_name, ret_type, nargs, args)			       \
   args[1] = comp.int_type;
   ADD_IMPORTED (push_handler, comp.handler_ptr_type, 2, args);
 
-#ifndef WINDOWSNT
-  args[0] = gcc_jit_type_get_pointer (gcc_jit_struct_as_type (comp.jmp_buf_s));
-  ADD_IMPORTED (SETJMP_NAME, comp.int_type, 1, args);
-#else
+#ifdef WINDOWSNT
   args[0] = gcc_jit_type_get_pointer (gcc_jit_struct_as_type (comp.jmp_buf_s));
   args[1] = comp.void_ptr_type;
   ADD_IMPORTED (SETJMP_NAME, comp.int_type, 2, args);
diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el
index 5bae743d1534c..04fe4b7b8249e 100644
--- a/test/src/comp-test-funcs.el
+++ b/test/src/comp-test-funcs.el
@@ -1,6 +1,6 @@
 ;;; comp-test-funcs.el --- compilation unit tested by comp-tests.el -*- lexical-binding: t; -*-
 
-;; Copyright (C) 2019-2020 Free Software Foundation, Inc.
+;; Copyright (C) 2019-2021 Free Software Foundation, Inc.
 
 ;; Author: Andrea Corallo <akrl@sdf.org>
 
@@ -667,6 +667,23 @@ comp-test-no-return-4
     (while (comp-test-no-return-3)
       (comp-test-no-return-3))))
 
+(cl-defun comp-test-setjmp ()
+  (let ((next-repos '(1)))
+    (while t
+      (let ((recipe (car next-repos)))
+        (cl-block loop
+          (while t
+            (let ((err
+                   (condition-case e
+                       (progn
+                         (setq next-repos
+                               (cdr next-repos))
+                         (cl-return-from loop))
+                     (error e))))
+              (format "%S"
+                      (error-message-string err))))))
+      (cl-return-from comp-test-setjmp))))
+
 (provide 'comp-test-funcs)
 
 ;;; comp-test-funcs.el ends here
diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el
index 651df3329665f..621268217596e 100644
--- a/test/src/comp-tests.el
+++ b/test/src/comp-tests.el
@@ -1,6 +1,6 @@
 ;;; comp-tests.el --- unit tests for src/comp.c      -*- lexical-binding: t; -*-
 
-;; Copyright (C) 2019-2020 Free Software Foundation, Inc.
+;; Copyright (C) 2019-2021 Free Software Foundation, Inc.
 
 ;; Author: Andrea Corallo <akrl@sdf.org>
 
@@ -1380,4 +1380,8 @@ comp-tests-cond-rw-checker-type
           (equal (comp-mvar-typeset mvar)
                  comp-tests-cond-rw-expected-type))))))))
 
+(comp-deftest setjmp ()
+  "Test that setjmp/longjmp usage doesn't crash Emacs."
+  (should (equal (comp-test-setjmp) nil)))
+
 ;;; comp-tests.el ends here
-- 
2.30.1