From 56a8d57d032c17263ba70139b85c94436e528572 Mon Sep 17 00:00:00 2001
From: Andrea Corallo <akrl@sdf.org>
Date: Sun, 28 May 2023 14:49:19 +0200
Subject: [PATCH] comp: Recompute type slots after byte compilation for user
 types

* lisp/emacs-lisp/comp-cstr.el (comp--compute-typeof-types)
(comp--compute--pred-type-h): New functions.
(comp-cstr-ctxt): Make use of.
(comp-cstr-ctxt-update-type-slots): New function.

* lisp/emacs-lisp/comp.el (comp-spill-lap): Use
`comp-cstr-ctxt-update-type-slots'.
---
 lisp/emacs-lisp/comp-cstr.el | 31 +++++++++++++++++++++++--------
 lisp/emacs-lisp/comp.el      | 12 +++++++-----
 2 files changed, 30 insertions(+), 13 deletions(-)

diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el
index e9132552506..416ca7f11b0 100644
--- a/lisp/emacs-lisp/comp-cstr.el
+++ b/lisp/emacs-lisp/comp-cstr.el
@@ -102,17 +102,23 @@ Integer values are handled in the `range' slot.")
               obarray)
     res))
 
+(defun comp--compute-typeof-types ()
+  (append comp--typeof-builtin-types
+          (mapcar #'comp--cl-class-hierarchy (comp--all-classes))))
+
+(defun comp--compute--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))
+
 (cl-defstruct comp-cstr-ctxt
-  (typeof-types (append comp--typeof-builtin-types
-                        (mapcar #'comp--cl-class-hierarchy (comp--all-classes)))
+  (typeof-types (comp--compute-typeof-types)
                 :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)
+  (pred-type-h (comp--compute--pred-type-h)
                :type hash-table
                :documentation "Hash pred -> type.")
   (union-typesets-mem (make-hash-table :test #'equal) :type hash-table
@@ -135,6 +141,15 @@ Integer values are handled in the `range' slot.")
                     :documentation "Serve memoization for
 `intersection-mem'."))
 
+(defun comp-cstr-ctxt-update-type-slots (ctxt)
+  "Update the type related slots of CTXT.
+This must run after byte compilation in order to account for user
+defined types."
+  (setf (comp-cstr-ctxt-typeof-types ctxt)
+        (comp--compute-typeof-types))
+  (setf (comp-cstr-ctxt-pred-type-h ctxt)
+        (comp--compute--pred-type-h)))
+
 (defmacro with-comp-cstr-accessors (&rest body)
   "Define some quick accessor to reduce code vergosity in BODY."
   (declare (debug (form body))
diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el
index 0556e69051d..937d9fdf926 100644
--- a/lisp/emacs-lisp/comp.el
+++ b/lisp/emacs-lisp/comp.el
@@ -1431,11 +1431,13 @@ clashes."
   "Byte-compile and spill the LAP representation for INPUT.
 If INPUT is a symbol, it is the function-name to be compiled.
 If INPUT is a string, it is the filename to be compiled."
-  (let ((byte-native-compiling t)
-        (byte-to-native-lambdas-h (make-hash-table :test #'eq))
-        (byte-to-native-top-level-forms ())
-        (byte-to-native-plist-environment ()))
-    (comp-spill-lap-function input)))
+  (let* ((byte-native-compiling t)
+         (byte-to-native-lambdas-h (make-hash-table :test #'eq))
+         (byte-to-native-top-level-forms ())
+         (byte-to-native-plist-environment ())
+         (res (comp-spill-lap-function input)))
+    (comp-cstr-ctxt-update-type-slots comp-ctxt)
+    res))
 
 
 ;;; Limplification pass specific code.
-- 
2.39.2