Subject: bug#77725: 31.0.50; Add support for types accepted by `cl-typep' to cl-generic?

From: David Ponce <[email-masked]>
Date: Thu, 5 Jun 2025 11:14:59 +0200

On 2025-05-24 12:52, David Ponce wrote:
> Hello Stefan,
> 
> Please find below the proposal for a new approach to speed up dispatch
> of methods with derived type specializers.

Hello Stefan,

Following our last exchange in French, to feed our discussion more
concretely, please find attached a new patch that explore further the
idea of removing the global variable `cl--derived-type-list', and make
`cl-types-of' a private function named `cl--derived-type-specializers'
with a mandatory argument to receive the list of dispatch types to
check.

The patch also improve a little the `cl-deftype' macro to allow
dispatching of atomic derived type with both optional
arguments and parents, like in this example:

(cl-deftype my-integer ()
   'integer)

;; Currently the below declaration is not valid because ARGLIST and
;; PARENTS are both non-nil.
(cl-deftype unsigned-byte (&optional bits)
   "Unsigned integer."
   (declare (parents my-integer))
   `(integer 0 ,(if (memq bits '(nil *)) bits (1- (ash 1 bits)))))

(cl-defmethod test-byte ((this my-integer))
   (format "%S is an integer" this))

(cl-defmethod test-byte ((this unsigned-byte))
   (format "%S is an unsigned byte - %s" this
           (cl-call-next-method)))

David
diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el
index 1fe0411062f..6cacffd8619 100644
--- a/lisp/emacs-lisp/cl-extra.el
+++ b/lisp/emacs-lisp/cl-extra.el
@@ -970,22 +970,16 @@ cl--describe-class-slots
 ;; Extend `cl-deftype' to define data types which are also valid
 ;; argument types for dispatching generic function methods (see also
 ;; <https://debbugs.gnu.org/cgi/bugreport.cgi?bug=77725>).
-;;
-;; The main entry points are:
-;;
-;; - `cl-deftype', that defines new data types.
-;;
-;; - `cl-types-of', that returns the types an object belongs to.
 
 ;; Ensure each type satisfies `eql'.
-(defvar cl--types-of-memo (make-hash-table :test 'equal)
-  "Memoization table used in `cl-types-of'.")
-
-;; FIXME: `cl-types-of' CPU cost is proportional to the number of types
-;; defined with `cl-deftype', so the more popular it gets, the slower
-;; it becomes.  And of course, the cost of each type check is
-;; unbounded, so a single "expensive" type can slow everything down
-;; further.
+(defvar cl--derived-type-specializers-memo (make-hash-table :test 'equal)
+  "Memoization table used in `cl--derived-type-specializers'.")
+
+;; FIXME: `cl--derived-type-specializers' CPU cost is proportional to
+;; the number of types defined with `cl-deftype', so the more popular it
+;; gets, the slower it becomes.  And of course, the cost of each type
+;; check is unbounded, so a single "expensive" type can slow everything
+;; down further.
 ;;
 ;; The usual dispatch is
 ;;
@@ -1022,49 +1016,50 @@ cl--types-of-memo
 ;;   associated with the `t' "dummy parent".  [ We could even go crazy
 ;;   and try and guess PARENTS when not provided, by analyzing the
 ;;   type's definition. ]
-;; - in `cl-types-of' start by calling `cl-type-of', then use the map
-;;   to find which cl-types may need to be checked.
+;; - in `cl--derived-type-specializers' start by calling `cl-type-of',
+;;   then use the map to find which cl-types may need to be checked.
 ;;
 ;;;###autoload
-(defun cl-types-of (object &optional types)
-  "Return the atomic types OBJECT belongs to.
-Return an unique list of types OBJECT belongs to, ordered from the
-most specific type to the most general.
-TYPES is an internal argument."
-  (let* ((found nil))
+(defun cl--derived-type-specializers (object types)
+  "Return the list of specializers for OBJECT, derived from TYPES.
+Return an unique (eq) list of atomic types OBJECT belongs to, ordered
+from the most specific type to the most general.
+TYPES is a list of types that OBJECT can potentially belong to."
+  (let* ((found (list (cl-type-of object))))
     ;; Build a list of all types OBJECT belongs to.
-    (dolist (type (or types cl--derived-type-list))
-      (let ((pred (get type 'cl-deftype-satisfies)))
-        (and
-         ;; If OBJECT is of type, add type to the matching list.
-         (if types
-             ;; For method dispatch, we don't need to filter out errors,
-             ;; since we can presume that method dispatch is used only on
-             ;; sanely-defined types.
-             (funcall pred object)
-           (condition-case-unless-debug e
-               (funcall pred object)
-             (error (setq cl--derived-type-list
-                          (delq type cl--derived-type-list))
-                    (warn  "cl-types-of %S: %s"
-                           type (error-message-string e))
-                    nil)))
-         (push type found))))
-    (push (cl-type-of object) found)
-    ;; Return the list of types OBJECT belongs to, which is also the list
-    ;; of specifiers for OBJECT. This memoization has two purposes:
+    (dolist (type types)
+      ;; If OBJECT is of type, add type to the matching list.
+      (if (funcall (get type 'cl-deftype-satisfies) object)
+          (push type found)))
+    ;; This memoization has two purposes:
     ;; - Speed up computation.
     ;; - Make sure we always return the same (eq) object, so that the
     ;;   method dispatch's own caching works as it should.
-    (with-memoization (gethash found cl--types-of-memo)
+    (with-memoization (gethash found cl--derived-type-specializers-memo)
       ;; Compute an ordered list of types from the DAG.
-      (let (dag)
-        (dolist (type found)
-          (push (cl--class-allparents (cl--find-class type)) dag))
-        (merge-ordered-lists dag)))))
-
-(defvar cl--derived-type-dispatch-list nil
-  "List of types that need to be checked during dispatch.")
+      (merge-ordered-lists
+       (mapcar (lambda (type)
+                 (cl--class-allparents (cl--find-class type)))
+               found)))))
+
+(defvar cl--derived-type-dispatch-memo (make-hash-table :weakness 'key)
+  "Memoization table used in `cl--derived-type-dispatch-list'.")
+
+(defun cl--derived-type-dispatch-list (methods)
+  "Gather the list of derived types from METHODS specializers.
+Return the list of types to be checked during dispatch of the generic
+function with these METHODS."
+  (with-memoization (gethash methods cl--derived-type-dispatch-memo)
+    (let (types)
+      (dolist (method methods)
+        (dolist (type (cl--generic-method-specializers method))
+          (and (symbolp type)
+               (cl-derived-type-class-p (cl--find-class type))
+               (not (memq type types))
+               (push type types))))
+      ;; `cl--derived-type-specializers' will ensure that types are in
+      ;; the expected dispatch order.
+      types)))
 
 (cl-generic-define-generalizer cl--derived-type-generalizer
   ;; FIXME: This priority can't be always right.  :-(
@@ -1076,31 +1071,26 @@ cl--derived-type-generalizer
   ;; Fixing this 100% is impossible so this generalizer is condemned to
   ;; suffer from "undefined method ordering" problems, unless/until we
   ;; restrict it somehow to a subset that we can handle reliably.
-  20 ;; "typeof" < "cl-types-of" < "head" priority
-  (lambda (obj &rest _) `(cl-types-of ,obj cl--derived-type-dispatch-list))
+  20 ;; "typeof" < "derived-types" < "head" priority
+  (lambda (obj &optional methods &rest _)
+    `(cl--derived-type-specializers
+      ,obj
+      ;; Check only derived types used as METHODS specializers of the
+      ;; generic function currently called.  `cl-generic-generalizers'
+      ;; for "derived type" ensures that at least one such method
+      ;; exists.
+      (cl--derived-type-dispatch-list ,methods)))
   (lambda (tag &rest _) (if (consp tag) tag)))
 
 ;;;###autoload
 (defun cl--derived-type-generalizers (type)
   ;; Make sure this derived type can be used without arguments.
-  (let ((expander (or (get type 'cl-deftype-handler)
-                      (error "Type %S lacks cl-deftype-handler" type))))
-    ;; Check that the type can be used without arguments.
-    (funcall expander)
-    ;; Check that we have a precomputed predicate since that's what
-    ;; `cl-types-of' uses.
-    (unless (get type 'cl-deftype-satisfies)
-      (error "Type %S lacks cl-deftype-satisfies" type)))
-  ;; Add a new dispatch type to the dispatch list, then
-  ;; synchronize with `cl--derived-type-list' so that both lists follow
-  ;; the same type precedence order.
-  ;; The `merge-ordered-lists' is `cl-types-of' should we make this
-  ;; ordering unnecessary, but it's still handy for all those types
-  ;; that don't declare their parents.
-  (unless (memq type cl--derived-type-dispatch-list)
-    (setq cl--derived-type-dispatch-list
-          (seq-intersection cl--derived-type-list
-                            (cons type cl--derived-type-dispatch-list))))
+  (funcall (or (get type 'cl-deftype-handler)
+               (error "Type %S lacks cl-deftype-handler" type)))
+  ;; Check that we have a precomputed predicate since that's what
+  ;; `cl--derived-type-specializers' uses.
+  (or (get type 'cl-deftype-satisfies)
+      (error "Type %S lacks cl-deftype-satisfies" type))
   (list cl--derived-type-generalizer))
 
 ;;;; Trailer
diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el
index 4c6c6a0007c..6cc98f69a2a 100644
--- a/lisp/emacs-lisp/cl-generic.el
+++ b/lisp/emacs-lisp/cl-generic.el
@@ -704,11 +704,12 @@ cl--generic-get-dispatcher
     (let* ((dispatch-arg (car dispatch))
            (generalizers (cdr dispatch))
            (lexical-binding t)
+           (methods-arg (make-symbol "methods"))
            (tagcodes
             (mapcar (lambda (generalizer)
                       (funcall (cl--generic-generalizer-tagcode-function
                                 generalizer)
-                               'arg))
+                               'arg methods-arg))
                     generalizers))
            (typescodes
             (mapcar
@@ -717,7 +718,7 @@ cl--generic-get-dispatcher
                             generalizer)
                          ,(funcall (cl--generic-generalizer-tagcode-function
                                     generalizer)
-                                   'arg)))
+                                   'arg methods-arg)))
              generalizers))
            (tag-exp
             ;; Minor optimization: since this tag-exp is
@@ -741,14 +742,14 @@ cl--generic-get-dispatcher
       ;; overkill: better just use a `cl-typep' test.
       (funcall
        cl--generic-compiler
-       `(lambda (generic dispatches-left methods)
+       `(lambda (generic dispatches-left ,methods-arg)
           (let ((method-cache (make-hash-table :test #'eql)))
             (lambda (,@fixedargs &rest args)
               (let ,bindings
                 (apply (with-memoization
                            (gethash ,tag-exp method-cache)
                          (cl--generic-cache-miss
-                          generic ',dispatch-arg dispatches-left methods
+                          generic ',dispatch-arg dispatches-left ,methods-arg
                           ,(if (cdr typescodes)
                                `(append ,@typescodes) (car typescodes))))
                        ,@fixedargs args)))))))))
@@ -1399,7 +1400,7 @@ cl--generic-derived-specializers
           (derived-mode-all-parents mode)))
 
 (cl-generic-define-generalizer cl--generic-derived-generalizer
-  90 (lambda (name) `(and (symbolp ,name) (functionp ,name) ,name))
+  90 (lambda (name &rest _) `(and (symbolp ,name) (functionp ,name) ,name))
   #'cl--generic-derived-specializers)
 
 (cl-defmethod cl-generic-generalizers ((_specializer (head derived-mode)))
diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index a076012cd30..d076ebb7f15 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -3797,12 +3797,17 @@ cl-deftype
       (cl-callf (lambda (x) (delq parent-decl x)) (cdr declares))
       (when (equal declares '(declare))
         (cl-callf (lambda (x) (delq declares x)) decls)))
-    (and parents arglist
-         (error "Parents specified, but arglist not empty"))
     (let* ((expander
-            `(cl-function (lambda (&cl-defs ('*) ,@arglist) ,@decls ,@forms)))
-           ;; FIXME: Pass a better lexical context.
-           (specifier (ignore-errors (funcall (eval expander t))))
+            `(cl-function
+              (lambda (&cl-defs ('*) ,@arglist) ,@decls ,@forms)))
+           (specifier
+            (condition-case nil
+                ;; FIXME: Pass a better lexical context.
+                (funcall (eval expander t))
+              (error
+               (if parents
+                   (error "Type %S with parents is not atomic: %S"
+                          name arglist)))))
            (predicate
             (pcase specifier
               (`(satisfies ,f) `#',f)
diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el
index 263a9b85225..5a0425a07e6 100644
--- a/lisp/emacs-lisp/cl-preloaded.el
+++ b/lisp/emacs-lisp/cl-preloaded.el
@@ -467,9 +467,6 @@ primitive-function
 
 ;;;; Support for `cl-deftype'.
 
-(defvar cl--derived-type-list nil
-  "Precedence list of the defined cl-types.")
-
 ;; FIXME: The `cl-deftype-handler' property should arguably be turned
 ;; into a field of this struct (but it has performance and
 ;; compatibility implications, so let's not make that change for now).
@@ -505,7 +502,8 @@ cl--define-derived-type
           ;; "complement" another declaration of the same type,
           ;; so maybe we should turn this into a warning (and
           ;; not overwrite the `cl--find-class' in that case)?
-          (error "Type %S already in another class: %S" name (type-of class))))
+          (error "Type %S already in another class: %S"
+                 name (type-of class))))
     ;; Setup a type descriptor for NAME.
     (setf (cl--find-class name)
           (cl--derived-type-class-make
@@ -515,19 +513,7 @@ cl--define-derived-type
            parents))
     (define-symbol-prop name 'cl-deftype-handler expander)
     (when predicate
-      (define-symbol-prop name 'cl-deftype-satisfies predicate)
-      ;; If the type can be used without arguments, record it for
-      ;; use by `cl-types-of'.
-      ;; The order in `cl--derived-type-list' is important, but the
-      ;; constructor of the class `cl-type-class' already ensures that
-      ;; parent types must be defined before their "child" types
-      ;; (i.e. already added to the `cl--derived-type-list' for types
-      ;; defined with `cl-deftype').  So it is enough to simply push
-      ;; a new type at the beginning of the list.
-      ;; Redefinition is a can of worms anyway, so we don't try to be clever
-      ;; in that case.
-      (or (memq name cl--derived-type-list)
-          (push name cl--derived-type-list)))))
+      (define-symbol-prop name 'cl-deftype-satisfies predicate))))
 
 ;; Make sure functions defined with cl-defsubst can be inlined even in
 ;; packages which do not require CL.  We don't put an autoload cookie
diff --git a/test/lisp/emacs-lisp/cl-extra-tests.el b/test/lisp/emacs-lisp/cl-extra-tests.el
index 6280be06cbb..b2229175404 100644
--- a/test/lisp/emacs-lisp/cl-extra-tests.el
+++ b/test/lisp/emacs-lisp/cl-extra-tests.el
@@ -392,7 +392,7 @@ my-foo
           (cl-call-next-method)))
 
 (ert-deftest cl-types-test ()
-  "Test types definition, cl-types-of and method dispatching."
+  "Test types definition, specializers and method dispatching."
 
   ;; Invalid DAG error
   ;; FIXME: We don't test that any more.
@@ -405,26 +405,35 @@ cl-types-test
   ;;   lexical-binding
   ;;   ))
 
-  ;; Test that (cl-types-of 4) is (multiples-of-4 multiples-of-2 ...)
-  ;; Test that (cl-types-of 6) is (multiples-of-3 multiples-of-2 ...)
-  ;; Test that (cl-types-of 12) is (multiples-of-4 multiples-of-3 multiples-of-2 ...)
+  ;; With possible 'types' in multiples-of-{2,3,4} verify that:
   (let ((types '(multiples-of-2 multiples-of-3 multiples-of-4)))
+
+    ;; (cl--derived-type-specializers  2 types) is multiples-of-2
     (should (equal '(multiples-of-2)
-		   (seq-intersection (cl-types-of 2) types)))
+		   (seq-intersection
+                    (cl--derived-type-specializers 2 types) types)))
 
+    ;; (cl--derived-type-specializers  4 types) is multiples-of-{4,2}
     (should (equal '(multiples-of-4 multiples-of-2)
-		   (seq-intersection (cl-types-of 4) types)))
+		   (seq-intersection
+                    (cl--derived-type-specializers 4 types) types)))
 
+    ;; (cl--derived-type-specializers  6 types) is multiples-of-{3,2}
     (should (equal '(multiples-of-3 multiples-of-2)
-		   (seq-intersection (cl-types-of 6) types)))
+		   (seq-intersection
+                    (cl--derived-type-specializers 6 types) types)))
 
-    (should (member (seq-intersection (cl-types-of 12) types)
+    ;; (cl--derived-type-specializers 12 types) is multiples-of-{4,3,2}
+    (should (member (seq-intersection
+                     (cl--derived-type-specializers 12 types) types)
 		    ;; Order between 3 and 4/2 is undefined.
 		    '((multiples-of-3 multiples-of-4 multiples-of-2)
 		      (multiples-of-4 multiples-of-2 multiples-of-3))))
 
+    ;; (cl--derived-type-specializers  5 types) is not of any 'types'
     (should (equal '()
-		   (seq-intersection (cl-types-of 5) types)))
+		   (seq-intersection
+                    (cl--derived-type-specializers 5 types) types)))
     )
 
   ;;; Method dispatching.