Work around https://lists.gnu.org/archive/html/bug-gnu-emacs/2023-05/msg01512.html

2 files changed, 298 insertions, 0 deletions

diff --git a/overlays/emacs.nix b/overlays/emacs.nix
index 79353f1776ad..6bcc92f66289 100644
--- a/overlays/emacs.nix
+++ b/overlays/emacs.nix
@@ -146,6 +146,8 @@ let
       patches = oa.patches ++ [
         # XXX: #318
         ./bytecomp-revert.patch
+        # XXX: https://lists.gnu.org/archive/html/bug-gnu-emacs/2023-05/msg01512.html
+        ./nativecomp-revert.patch
       ]; }
   );
 
@@ -154,6 +156,8 @@ let
       patches = oa.patches ++ [
         # XXX: #318
         ./bytecomp-revert.patch
+        # XXX: https://lists.gnu.org/archive/html/bug-gnu-emacs/2023-05/msg01512.html
+        ./nativecomp-revert.patch
       ]; }
   );
 
diff --git a/overlays/nativecomp-revert.patch b/overlays/nativecomp-revert.patch
new file mode 100644
index 000000000000..087f73547a4f
--- /dev/null
+++ b/overlays/nativecomp-revert.patch
@@ -0,0 +1,294 @@
+diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
+index 0b09cd7d225..8fdafe18c50 100644
+--- a/lisp/emacs-lisp/cl-macs.el
++++ b/lisp/emacs-lisp/cl-macs.el
+@@ -3093,16 +3093,13 @@ cl-defstruct
+                               (cons 'and (cdddr pred-form))
+                             `(,predicate cl-x))))
+     (when pred-form
+-      (push `(eval-and-compile
+-               ;; Define the predicate to be effective at compile time
+-               ;; as native comp relies on `cl-typep' that relies on
+-               ;; predicates to be defined as they are registered in
+-               ;; cl-deftype-satisfies.
+-               (,defsym ,predicate (cl-x)
++      (push `(,defsym ,predicate (cl-x)
+                (declare (side-effect-free error-free) (pure t))
+                ,(if (eq (car pred-form) 'and)
+                     (append pred-form '(t))
+                   `(and ,pred-form t)))
++            forms)
++      (push `(eval-and-compile
+                (define-symbol-prop ',name 'cl-deftype-satisfies ',predicate))
+             forms))
+     (let ((pos 0) (descp descs))
+@@ -3252,7 +3249,6 @@ cl-defstruct
+ 
+ ;;; Add cl-struct support to pcase
+ 
+-;;In use by comp.el
+ (defun cl--struct-all-parents (class)
+   (when (cl--struct-class-p class)
+     (let ((res ())
+diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el
+index f410270d340..5235be52996 100644
+--- a/lisp/emacs-lisp/cl-preloaded.el
++++ b/lisp/emacs-lisp/cl-preloaded.el
+@@ -113,7 +113,6 @@ cl-struct-cl-structure-object-tags
+         (record 'cl-slot-descriptor
+                 name initform type props)))
+ 
+-;; In use by comp.el
+ (defun cl--struct-get-class (name)
+   (or (if (not (symbolp name)) name)
+       (cl--find-class name)
+diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el
+index e9132552506..d4200c16c19 100644
+--- a/lisp/emacs-lisp/comp-cstr.el
++++ b/lisp/emacs-lisp/comp-cstr.el
+@@ -86,35 +86,7 @@ comp-cstr-f
+   (ret nil :type (or comp-cstr comp-cstr-f)
+        :documentation "Returned value."))
+ 
+-(defun comp--cl-class-hierarchy (x)
+-  "Given a class name `x' return its hierarchy."
+-  `(,@(mapcar #'cl--struct-class-name (cl--struct-all-parents
+-                                       (cl--struct-get-class x)))
+-    atom
+-    t))
+-
+-(defun comp--all-classes ()
+-  "Return all non built-in type names currently defined."
+-  (let (res)
+-    (mapatoms (lambda (x)
+-                (when (cl-find-class x)
+-                  (push x res)))
+-              obarray)
+-    res))
+-
+ (cl-defstruct comp-cstr-ctxt
+-  (typeof-types (append comp--typeof-builtin-types
+-                        (mapcar #'comp--cl-class-hierarchy (comp--all-classes)))
+-                :type list
+-                :documentation "Type hierarchy.")
+-  (pred-type-h (cl-loop with h = (make-hash-table :test #'eq)
+-	                for class-name in (comp--all-classes)
+-                        for pred = (get class-name 'cl-deftype-satisfies)
+-                        when pred
+-                          do (puthash pred class-name h)
+-	                finally return h)
+-               :type hash-table
+-               :documentation "Hash pred -> type.")
+   (union-typesets-mem (make-hash-table :test #'equal) :type hash-table
+                       :documentation "Serve memoization for
+ `comp-union-typesets'.")
+@@ -258,7 +230,7 @@ comp-supertypes
+   (cl-loop
+    named outer
+    with found = nil
+-   for l in (comp-cstr-ctxt-typeof-types comp-ctxt)
++   for l in comp--typeof-builtin-types
+    do (cl-loop
+        for x in l
+        for i from (length l) downto 0
+@@ -301,7 +273,7 @@ comp-union-typesets
+                (cl-loop
+                 with types = (apply #'append typesets)
+                 with res = '()
+-                for lane in (comp-cstr-ctxt-typeof-types comp-ctxt)
++                for lane in comp--typeof-builtin-types
+                 do (cl-loop
+                     with last = nil
+                     for x in lane
+@@ -895,23 +867,6 @@ comp-cstr-cons-p
+          (null (neg cstr))
+          (equal (typeset cstr) '(cons)))))
+ 
+-;; Move to comp.el?
+-(defsubst comp-cstr-cl-tag-p (cstr)
+-  "Return non-nil if CSTR is a CL tag."
+-  (with-comp-cstr-accessors
+-    (and (null (range cstr))
+-         (null (neg cstr))
+-         (null (typeset cstr))
+-         (length= (valset cstr) 1)
+-         (string-match (rx "cl-struct-" (group-n 1 (1+ not-newline)) "-tags")
+-                       (symbol-name (car (valset cstr)))))))
+-
+-(defsubst comp-cstr-cl-tag (cstr)
+-  "If CSTR is a CL tag return its tag name."
+-  (with-comp-cstr-accessors
+-    (and (comp-cstr-cl-tag-p cstr)
+-         (intern (match-string 1 (symbol-name (car (valset cstr))))))))
+-
+ (defun comp-cstr-= (dst op1 op2)
+   "Constraint OP1 being = OP2 setting the result into DST."
+   (with-comp-cstr-accessors
+diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el
+index 8e59c06d40e..2e07b0b0e60 100644
+--- a/lisp/emacs-lisp/comp.el
++++ b/lisp/emacs-lisp/comp.el
+@@ -641,14 +641,11 @@ comp-known-predicates-h
+ 
+ (defun comp-known-predicate-p (predicate)
+   "Return t if PREDICATE is known."
+-  (when (or (gethash predicate comp-known-predicates-h)
+-            (gethash predicate (comp-cstr-ctxt-pred-type-h comp-ctxt)))
+-    t))
++  (when (gethash predicate comp-known-predicates-h) t))
+ 
+ (defun comp-pred-to-cstr (predicate)
+   "Given PREDICATE, return the corresponding constraint."
+-  (or (gethash predicate comp-known-predicates-h)
+-      (gethash predicate (comp-cstr-ctxt-pred-type-h comp-ctxt))))
++  (gethash predicate comp-known-predicates-h))
+ 
+ (defconst comp-symbol-values-optimizable '(most-positive-fixnum
+                                            most-negative-fixnum)
+@@ -1543,7 +1540,7 @@ comp-callref
+                              for sp from stack-off
+                              collect (comp-slot-n sp))))
+ 
+-(cl-defun make-comp-mvar (&key slot (constant nil const-vld) type neg)
++(cl-defun make-comp-mvar (&key slot (constant nil const-vld) type)
+   "`comp-mvar' initializer."
+   (let ((mvar (make--comp-mvar :slot slot)))
+     (when const-vld
+@@ -1551,8 +1548,6 @@ make-comp-mvar
+       (setf (comp-cstr-imm mvar) constant))
+     (when type
+       (setf (comp-mvar-typeset mvar) (list type)))
+-    (when neg
+-      (setf (comp-mvar-neg mvar) t))
+     mvar))
+ 
+ (defun comp-new-frame (size vsize &optional ssa)
+@@ -2548,19 +2543,6 @@ comp-add-cond-cstrs
+     for insns-seq on (comp-block-insns b)
+     do
+     (pcase insns-seq
+-      (`((set ,(and (pred comp-mvar-p) mvar-tested-copy)
+-              ,(and (pred comp-mvar-p) mvar-tested))
+-         (set ,(and (pred comp-mvar-p) mvar-1)
+-              (call type-of ,(and (pred comp-mvar-p) mvar-tested-copy)))
+-         (set ,(and (pred comp-mvar-p) mvar-2)
+-              (call symbol-value ,(and (pred comp-cstr-cl-tag-p) mvar-tag)))
+-         (set ,(and (pred comp-mvar-p) mvar-3)
+-              (call memq ,(and (pred comp-mvar-p) mvar-1) ,(and (pred comp-mvar-p) mvar-2)))
+-         (cond-jump ,(and (pred comp-mvar-p) mvar-3) ,(pred comp-mvar-p) ,bb1 ,bb2))
+-       (push  `(assume ,mvar-tested ,(make-comp-mvar :type (comp-cstr-cl-tag mvar-tag)))
+-              (comp-block-insns (comp-add-cond-cstrs-target-block b bb2)))
+-       (push  `(assume ,mvar-tested ,(make-comp-mvar :type (comp-cstr-cl-tag mvar-tag) :neg t))
+-              (comp-block-insns (comp-add-cond-cstrs-target-block b bb1))))
+       (`((set ,(and (pred comp-mvar-p) cmp-res)
+               (,(pred comp-call-op-p)
+                ,(and (or (pred comp-equality-fun-p)
+@@ -3216,11 +3198,7 @@ comp-fwprop-call
+       (+ (comp-cstr-add lval args))
+       (- (comp-cstr-sub lval args))
+       (1+ (comp-cstr-add lval `(,(car args) ,comp-cstr-one)))
+-      (1- (comp-cstr-sub lval `(,(car args) ,comp-cstr-one)))
+-      (record (when (comp-cstr-imm-vld-p (car args))
+-                (comp-cstr-shallow-copy lval
+-                                        (comp-type-spec-to-cstr
+-                                         (comp-cstr-imm (car args)))))))))
++      (1- (comp-cstr-sub lval `(,(car args) ,comp-cstr-one))))))
+ 
+ (defun comp-fwprop-insn (insn)
+   "Propagate within INSN."
+diff --git a/lisp/loadup.el b/lisp/loadup.el
+index 532d2ca176d..1cc70348267 100644
+--- a/lisp/loadup.el
++++ b/lisp/loadup.el
+@@ -103,7 +103,7 @@
+       ;; During bootstrapping the byte-compiler is run interpreted
+       ;; when compiling itself, which uses a lot more stack
+       ;; than usual.
+-      (setq max-lisp-eval-depth (max max-lisp-eval-depth 3400))))
++      (setq max-lisp-eval-depth 2200)))
+ 
+ (if (eq t purify-flag)
+     ;; Hash consing saved around 11% of pure space in my tests.
+diff --git a/test/src/comp-resources/comp-test-funcs.el b/test/src/comp-resources/comp-test-funcs.el
+index d8c72c1a920..73da7182a54 100644
+--- a/test/src/comp-resources/comp-test-funcs.el
++++ b/test/src/comp-resources/comp-test-funcs.el
+@@ -23,8 +23,6 @@
+ 
+ ;;; Code:
+ 
+-(require 'cl-lib)
+-
+ (defvar comp-tests-var1 3)
+ 
+ (defun comp-tests-varref-f ()
+@@ -532,12 +530,6 @@ comp-test-62537-2-f
+     (comp-test-62537-1-f))
+   t)
+ 
+-(cl-defstruct comp-test-struct)
+-
+-(defun comp-test-63674-1-f (x)
+-  (or
+-   (if (comp-test-struct-p pkg) x)
+-   t))
+ 
+ 
+ ;;;;;;;;;;;;;;;;;;;;
+diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el
+index 673a9342f1f..4682cac450e 100644
+--- a/test/src/comp-tests.el
++++ b/test/src/comp-tests.el
+@@ -875,8 +875,6 @@ comp-tests-check-ret-type-spec
+                    ret-type))))
+ 
+ (cl-eval-when (compile eval load)
+-  (cl-defstruct comp-foo a b)
+-  (cl-defstruct (comp-bar (:include comp-foo)) c)
+   (defconst comp-tests-type-spec-tests
+     ;; Why we quote everything here, you ask?  So that values of
+     ;; `most-positive-fixnum' and `most-negative-fixnum', which can be
+@@ -1406,39 +1404,7 @@ comp-tests-check-ret-type-spec
+          (if (eq x 0)
+ 	     (error "")
+ 	   (1+ x)))
+-       'number)
+-
+-      ;; 75
+-      ((defun comp-tests-ret-type-spec-f ()
+-         (make-comp-foo))
+-       'comp-foo)
+-
+-      ;; 76
+-      ((defun comp-tests-ret-type-spec-f ()
+-         (make-comp-bar))
+-       'comp-bar)
+-
+-      ;; 77
+-      ((defun comp-tests-ret-type-spec-f (x)
+-          (setf (comp-foo-a x) 2)
+-          x)
+-       'comp-foo)
+-
+-      ;; 78
+-      ((defun comp-tests-ret-type-spec-f (x)
+-          (if x
+-              (if (> x 11)
+-	          x
+-	        (make-comp-foo))
+-            (make-comp-bar)))
+-       '(or comp-foo float (integer 12 *)))
+-
+-      ;; 79
+-      ((defun comp-tests-ret-type-spec-f (x)
+-         (if (comp-foo-p x)
+-             x
+-           (error "")))
+-       'comp-foo)))
++       'number)))
+ 
+   (defun comp-tests-define-type-spec-test (number x)
+     `(comp-deftest ,(intern (format "ret-type-spec-%d" number)) ()
+-- 
+2.40.1
+