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

From: David Ponce <[email-masked]>
Date: Sat, 24 May 2025 12:52:08 +0200

Hello Stefan,

Please find below the proposal for a new approach to speed up dispatch
of methods with derived type specializers.

Currently, to dispatch a method with derived type specializers, all
the derived types of all such methods are checked.  This is not very
efficient when the number of methods using derived types becomes high.

My reasoning is that to achieve the same only the method specializers
of the called generic function need to be checked.  For instance to
dispatch the below generic function `foo:

(cl-defmethod foo ((arg1 A) (arg2 B))
   ...
   )
(cl-defmethod foo ((arg1 A) (arg2 C))
   ...
   )

It is enough to test that the type of the objects passed to `foo'
belongs to the list of derived types (A B C).
               
Thus, the number of types to check will depend on the number of
different derived types "specializers" used in methods defined for one
generic function.  IMO, this number should remain very reasonable for
a given generic function.

The other advantage of this approach is that it limits the impact of
an ill-defined type to only the methods that use it, making error
handling in `cl-types-of' unnecessary.

It turns out that the dispatcher produced by the function
`cl--generic-get-dispatcher' already captures the list of methods of
the called generic function in its lexical environment.  So I modified
`cl--generic-get-dispatcher' to be able to pass this method list to
the tagcode function via an optional additional argument.  Then, I
modified the tagcode function of `cl--derived-type-generalizer' to
compute a "dispatch" list from the list of methods defined for the
called generic function.  This calculation is memoized to save time,
since the methods of a generic function shouldn't change much, except
perhaps during development.  Finally, I simplified the `cl-types-of'
function by removing error handling, no longer really useful here.

The tests in `cl-types-test' pass with the new implementation, which
also works well in some of my libraries I use daily :-)

I hope I didn't miss anything important!
Your opinion will obviously be more than welcome ;-)

Patch attached and a possible change log below.

Thanks!
David

2025-05-24  David Ponce  <[email-masked]>

	To speed up dispatch of methods with derived types specializers,
	limit the list of types that need to be checked to those used in
	methods specializers of the called generic function.

	* lisp/emacs-lisp/cl-generic.el (cl--generic-get-dispatcher): Add
	an optional second argument to the tagcode function to receive the
	methods of the called generic function.
         (cl--generic-derived-generalizer): Fix arglist of the tagcode
	function.

	* lisp/emacs-lisp/cl-extra.el (cl-types-of): There is no need to
	filter out errors: we can assume that the dispatch method is used
	only on sanely-defined types; when "cl-types-of" is called
	directly, whe can use the usual debugging tools to analyze and fix
	ill-defined types.
	(cl--derived-type-dispatch-memo): New variable.
	(cl--derived-type-dispatch-list): Replace variable by a function.
	(cl--derived-type-generalizer): Call it in the tagcode function.
	(cl--derived-type-generalizers): Simplify.

diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el
index 1fe0411062f..5289702a9ce 100644
--- a/lisp/emacs-lisp/cl-extra.el
+++ b/lisp/emacs-lisp/cl-extra.el
@@ -1034,22 +1034,9 @@ cl-types-of
   (let* ((found nil))
     ;; 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))))
+      ;; If OBJECT is of type, add type to the matching list.
+      (if (funcall (get type 'cl-deftype-satisfies) object)
+          (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:
@@ -1063,8 +1050,24 @@ cl-types-of
           (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.")
+(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))))
+      ;; There is no need to sort the result list.  `cl-types-of' 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.  :-(
@@ -1077,30 +1080,19 @@ cl--derived-type-generalizer
   ;; 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))
+  (lambda (obj &optional methods &rest _)
+    `(cl-types-of ,obj (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-types-of' 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)))