From 854fd9d31a626e22575d562e19dd0652815f2763 Mon Sep 17 00:00:00 2001 From: David Ponce Date: Tue, 29 Apr 2025 10:48:37 -0400 Subject: [PATCH] (cl-types-of): Speed up by caching more of its work MIME-Version: 1.0 Content-Type: text/plain; charset=utf8 Content-Transfer-Encoding: 8bit * lisp/emacs-lisp/cl-types.el (cl--type-parents): Make it a proper function. (cl--type-children): Use `cl--class-children` and make it a `defsubst`. (cl--type-dag): η-reduce and make it a `defsubst`. (cl--type-undefine): Also reset `cl--type-error`. (cl--type-deftype): Modify `cl--type-list` atomically so we never need to restore it upon error. Don't test bogus parent here. (cl-deftype2): Test bogus parent here instead. Also, better preserve the declarations for the lambda. (cl-types-of): Do less uncached work. (cherry picked from commit 4323ff209f2f73ca4e6d389de69eb310988c0b1f) --- lisp/emacs-lisp/cl-types.el | 122 +++++++++++++++++++++--------------- 1 file changed, 71 insertions(+), 51 deletions(-) diff --git a/lisp/emacs-lisp/cl-types.el b/lisp/emacs-lisp/cl-types.el index 0a384e09d79..c10ce4a24fb 100644 --- a/lisp/emacs-lisp/cl-types.el +++ b/lisp/emacs-lisp/cl-types.el @@ -3,9 +3,11 @@ ;; Data types defined by `cl-deftype' are now recognized as argument ;; types for dispatching generic functions methods. -;; Will be removed when included in cl-lib. +;; Needed until merged in existing libraries. (require 'cl-lib) (eval-when-compile (require 'cl-macs)) ;For cl--find-class. +(declare-function cl-remprop "cl-extra" (symbol propname)) +(declare-function cl--class-children "cl-extra" (class)) ;; Extend `cl-deftype' to define data types which are also valid ;; argument types for dispatching generic function methods (see also @@ -42,62 +44,60 @@ "Type descriptors for types defined by `cl-deftype'.") (defun cl--type-p (object) - "Return non-nil if OBJECT is a used defined type. -That is, a type of class `cl-type-class'." + "Return non-nil if OBJECT is a cl-type. +That is, a type defined by `cl-deftype', of class `cl-type-class'." (and (symbolp object) (cl-type-class-p (cl--find-class object)))) -(defmacro cl--type-parents (name) +(defsubst cl--type-parents (name) "Get parents of type with NAME. -NAME is a symbol representing a type." - `(cl--class-allparents (cl--find-class ,name))) +NAME is a symbol representing a type. +Return a possibly empty list of types." + (cl--class-allparents (cl--find-class name))) -(defun cl--type-children (name) +(defsubst cl--type-children (name) "Get children of the type with NAME. NAME is a symbol representing a type. Return a possibly empty list of types." - (cl-check-type name (satisfies cl--type-p)) - (let (children) - (dolist (elt cl--type-list) - (or (eq name elt) - (if (memq name (cl--type-parents elt)) - (push elt children)))) - children)) + (cl--class-children (cl--find-class name))) -(defun cl--type-dag () - "Return a DAG from the list of defined types." - (mapcar (lambda (type) (cl--type-parents type)) cl--type-list)) +(defsubst cl--type-dag (types) + "Return a DAG from the list of TYPES." + (mapcar #'cl--type-parents types)) ;; Keep it for now, for testing. (defun cl--type-undefine (name) - "Remove the definitions of type with NAME. -NAME is an unquoted symbol representing a type. -Signal an error if other types inherit from NAME." - (declare-function cl-remprop "cl-extra" (symbol propname)) + "Remove the definition of cl-type with NAME. +NAME is an unquoted symbol representing a cl-type. +Signal an error if NAME has subtypes." (cl-check-type name (satisfies cl--type-p)) (when-let* ((children (and (cl--type-p name) (cl--type-children name)))) (error "Type has children: %S" children)) + (cl-remprop name 'cl--type-error) (cl-remprop name 'cl--class) (cl-remprop name 'cl-deftype-handler) (setq cl--type-list (delq name cl--type-list))) (defun cl--type-deftype (name parents &optional docstring) - "Generalize type with NAME for method dispatching. + ;; FIXME: Should we also receive the arglist? + "Generalize cl-type with NAME for method dispatching. PARENTS is a list of types NAME is a subtype of, or nil. DOCSTRING is an optional documentation string." - (let ((oldtlist (copy-sequence cl--type-list)) + (let ((typelist cl--type-list) (oldplist (copy-sequence (symbol-plist name)))) (condition-case err (let* ((class (cl--find-class name)) - (recorded (memq name cl--type-list))) + (recorded (memq name typelist))) (if (null class) (or (null recorded) (error "Type generalized, but doesn't exist")) (or recorded (error "Type exists, but not generalized")) (or (cl-type-class-p class) + ;; FIXME: We have some uses `cl-deftype' in Emacs that + ;; "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 in another class: %S" (type-of class)))) - (if (memq name parents) - (error "Type in parents: %S" parents)) ;; Setup a type descriptor for NAME. (setf (cl--find-class name) (cl--type-class-make name docstring parents)) @@ -105,18 +105,23 @@ DOCSTRING is an optional documentation string." ;; Clear any previous error mark. (cl-remprop name 'cl--type-error) ;; Record new type to include its dependency in the DAG. - (push name cl--type-list)) + (push name typelist)) ;; `cl-types-of' iterates through all known types to collect ;; all those an object belongs to, sorted from the most ;; specific type to the more general type. So, keep the ;; global list in this order. + ;; FIXME: This global operation is a bit worrisome, because it + ;; scales poorly with the number of types. I guess it's OK + ;; for now because `cl-deftype' is not very popular, but it'll + ;; probably need to be replaced at some point. Maybe we + ;; should simply require that the parents be defined already, + ;; then we can just `push' the new type, knowing it's in + ;; topological order by construction. (setq cl--type-list (merge-ordered-lists - (cl--type-dag) + (cl--type-dag typelist) (lambda (_) (error "Invalid dependency graph"))))) (error - ;; On error restore previous data. - (setq cl--type-list oldtlist) (setf (symbol-plist name) oldplist) (error (format "Define %S failed: %s" name (error-message-string err))))))) @@ -155,16 +160,30 @@ If PARENTS is non-nil, ARGLIST must be nil." ((`(,decls . ,forms) (macroexp-parse-body body)) (docstring (if (stringp (car decls)) (car decls) - (cadr (assq :documentation decls)))) - (parents (cdr (assq 'parents (cdr (assq 'declare decls)))))) + (cadr (assq :documentation decls)))) + (declares (assq 'declare decls)) + (parent-decl (assq 'parents (cdr declares))) + (parents (cdr parent-decl))) + (when parent-decl + ;; "Consume" the `parents' declaration. + (cl-callf (lambda (x) (delq parent-decl x)) (cdr declares)) + (when (equal declares '(declare)) + (cl-callf (lambda (x) (delq declares x)) decls))) + (if (memq name parents) + (error "Type in parents: %S" parents)) (and parents arglist (error "Parents specified, but arglist not empty")) - (if docstring (setq forms (cons docstring forms))) `(eval-and-compile ;;cl-eval-when (compile load eval) + ;; FIXME: Where should `cl--type-deftype' go? Currently, code + ;; using `cl-deftype' can use (eval-when-compile (require + ;; 'cl-lib)), so `cl--type-deftype' needs to go either to + ;; `cl-preloaded.el' or it should be autoloaded even when + ;; `cl-lib' is not loaded. (cl--type-deftype ',name ',parents ,docstring) (define-symbol-prop ',name 'cl-deftype-handler (cl-function (lambda (&cl-defs ('*) ,@arglist) + ,@decls ,@forms)))))) ;; Ensure each type satisfies `eql'. @@ -226,8 +245,8 @@ If PARENTS is non-nil, ARGLIST must be nil." "Return the types OBJECT belongs to. Return an unique list of types OBJECT belongs to, ordered from the most specific type to the most general." - (let ((found (list (cl--type-parents (cl-type-of object))))) - ;; Build a DAG of all types OBJECT belongs to. + (let (found) + ;; Build a list of all types OBJECT belongs to. (dolist (type cl--type-list) (and ;; Skip type, if it previously produced an error. @@ -241,24 +260,25 @@ most specific type to the most general." ;; of another type, assuming that, most of the time, `assq' ;; will be faster than `cl-typep'. (null (assq type found)) - ;; If OBJECT is of type, add type and its parents to the DAG. - (condition-case e + ;; If OBJECT is of type, add type to the matching list. + (condition-case-unless-debug e (cl-typep object type) (error (cl--type-error type e))) - ;; (dolist (p (cl--type-parents type)) - ;; (push (cl--type-parents p) found)) - ;; Equivalent to the `dolist' above, but faster: avoid to - ;; recompute several lists of parents we already know. - (let ((pl (cl--type-parents type))) - (while pl - (push pl found) - (setq pl (cdr pl)))))) - ;; Compute an ordered list of types from the collected DAG. - (setq found (merge-ordered-lists found)) - ;; Return an unique value of this list of types, which is also the - ;; list of specifiers for this type. + (push type found))) + ;; Return an unique value of the list of types OBJECT belongs to, + ;; which is also the list of specifiers for OBJECT. (with-memoization (gethash found cl--type-unique) - found))) + ;; Compute a DAG from the collected matching types. + (let (dag) + (dolist (type found) + (let ((pl (cl--type-parents type))) + (while pl + (push pl dag) + (setq pl (cdr pl))))) + ;; Compute an ordered list of types from the DAG. + (merge-ordered-lists + (nreverse (cons (cl--type-parents (cl-type-of object)) + dag))))))) ;;; Method dispatching ;; @@ -268,7 +288,7 @@ most specific type to the most general." (lambda (tag &rest _) (if (consp tag) tag))) (cl-defmethod cl-generic-generalizers :extra "cl-types-of" (type) - "Support for dispatch on types." + "Support for dispatch on cl-types." (if (cl--type-p type) (list cl--type-generalizer) (cl-call-next-method))) -- 2.39.5