From 13ec843352eab570d37476c980bc3350e38ecf5a Mon Sep 17 00:00:00 2001 From: David Ponce Date: Fri, 31 Oct 2025 13:28:35 -0400 Subject: [PATCH] cl-extra.el: Use the new API to speed up dispatch on derived types * lisp/emacs-lisp/cl-extra.el (cl--types-of-memo): Delete var. (cl--derived-type-specializers-memo): New var. (cl-types-of): Delete function. (cl--derived-type-specializers): New function. (cl--derived-type-dispatch-list): Delete var. (cl--derived-type-generalizer): Use the `:need-specializers` API instead. (cl--derived-type-generalizers): Don't fill `cl--derived-type-dispatch-list` any more. * lisp/emacs-lisp/cl-preloaded.el (cl--derived-type-list): Delete var. (cl--define-derived-type): Don't add type to `cl--derived-type-list`. * test/lisp/emacs-lisp/cl-extra-tests.el (cl-types-test): Adjust. --- lisp/emacs-lisp/cl-extra.el | 107 +++++++++---------------- lisp/emacs-lisp/cl-preloaded.el | 17 +--- test/lisp/emacs-lisp/cl-extra-tests.el | 27 ++++--- 3 files changed, 55 insertions(+), 96 deletions(-) diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el index 4a9819a2039..0c80400d028 100644 --- a/lisp/emacs-lisp/cl-extra.el +++ b/lisp/emacs-lisp/cl-extra.el @@ -974,23 +974,11 @@ Outputs to the current buffer." ;; Extend `cl-deftype' to define data types which are also valid ;; argument types for dispatching generic function methods (see also ;; ). -;; -;; 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'.") +(defvar cl--derived-type-specializers-memo (make-hash-table :test 'equal) + "Memoization table used in `cl--derived-type-specializers'.") -;; 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. -;; ;; The usual dispatch is ;; ;; (lambda (arg &rest args) @@ -1026,49 +1014,34 @@ Outputs to the current buffer." ;; 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." + ;; This function is speed critical for the dispatch on CL's derived types. + ;; Currently TYPES is just the set of types we're interested in. + ;; TODO: We could speed this up by replacing TYPES with anything that can + ;; be precomputed from it. + (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))))) (cl-generic-define-generalizer cl--derived-type-generalizer ;; FIXME: This priority can't be always right. :-( @@ -1080,31 +1053,23 @@ TYPES is an internal argument." ;; 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 types &rest _) + (if (not types) + :need-specializers + `(nil ;; Extra bindings, if any. + . (cl--derived-type-specializers ,obj ,types)))) (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-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el index 71b4a863b30..36437b346d2 100644 --- a/lisp/emacs-lisp/cl-preloaded.el +++ b/lisp/emacs-lisp/cl-preloaded.el @@ -473,9 +473,6 @@ The fields are used as follows: ;;;; 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). @@ -521,19 +518,7 @@ PARENTS is a list of types NAME is a subtype of, or nil." 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 5290ed9d04e..2414959237e 100644 --- a/test/lisp/emacs-lisp/cl-extra-tests.el +++ b/test/lisp/emacs-lisp/cl-extra-tests.el @@ -392,7 +392,7 @@ (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 @@ ;; 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.