From 6f5a71349149eb2b4bcfb34e254a16c9385fdfd3 Mon Sep 17 00:00:00 2001 From: David Ponce Date: Mon, 5 May 2025 11:03:56 -0400 Subject: [PATCH] cl-types.el: Speed up deftype and dispatch * lisp/emacs-lisp/cl-types.el (cl--type-list): Doc string. (cl--type-dispatch-list): New variable. (cl--type-parents): Make it a plain defun. (cl--type-children, cl--type-dag): Remove. (cl--type-undefine): Remove duplicate test for `cl--type-p'. Use `cl--class-children'. Clear `cl--type-flag' instead of `cl--type-error'. Also remove type from the dispatch list. (cl--type-deftype): Doc string. Remove useless safeguard of data on error. Fix some error messages. Clear `cl--type-flag' when a type is (re)defined. Just push new types on `cl--type-list'. (cl--type-error): Set `cl--type-flag' to the symbol `error' and remove type in error from the dispatch list. (cl-types-of): Doc string. Remove useless check for `cl-type-class-p'. Skip types which we are sure will not match. Simplify creation of the DAG. (cl--type-generalizer): In the tagcode-function, check only types that can be dispatched. (cl-generic-generalizers): Populate the dispatch list. (cherry picked from commit 8f649c42702144dbbacba180c78ab0df04951807) --- lisp/emacs-lisp/cl-types.el | 190 +++++++++++++++++++----------------- 1 file changed, 100 insertions(+), 90 deletions(-) diff --git a/lisp/emacs-lisp/cl-types.el b/lisp/emacs-lisp/cl-types.el index c10ce4a24fb..b7816ca3a84 100644 --- a/lisp/emacs-lisp/cl-types.el +++ b/lisp/emacs-lisp/cl-types.el @@ -20,7 +20,10 @@ ;; - `cl-types-of', that returns the types an object belongs to. (defvar cl--type-list nil - "List of defined types to lookup for method dispatching.") + "Precedence list of the defined cl-types.") + +(defvar cl--type-dispatch-list nil + "List of types that need to be checked during dispatch.") ;; FIXME: The `cl-deftype-handler' property should arguably be turned ;; into a field of this struct (but it has performance and @@ -48,83 +51,71 @@ That is, a type defined by `cl-deftype', of class `cl-type-class'." (and (symbolp object) (cl-type-class-p (cl--find-class object)))) -(defsubst cl--type-parents (name) +(defun cl--type-parents (name) "Get parents of type with NAME. NAME is a symbol representing a type. Return a possibly empty list of types." (cl--class-allparents (cl--find-class 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--class-children (cl--find-class name))) - -(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 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)))) + (when-let* ((children (cl--class-children (cl--find-class name)))) (error "Type has children: %S" children)) - (cl-remprop name 'cl--type-error) + (cl-remprop name 'cl--type-flag) (cl-remprop name 'cl--class) (cl-remprop name 'cl-deftype-handler) + (setq cl--type-dispatch-list (delq name cl--type-dispatch-list)) (setq cl--type-list (delq name cl--type-list))) (defun cl--type-deftype (name parents &optional docstring) ;; FIXME: Should we also receive the arglist? - "Generalize cl-type with NAME for method dispatching. + "Register 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 ((typelist cl--type-list) - (oldplist (copy-sequence (symbol-plist name)))) - (condition-case err - (let* ((class (cl--find-class name)) - (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)))) - ;; Setup a type descriptor for NAME. - (setf (cl--find-class name) - (cl--type-class-make name docstring parents)) - (if recorded - ;; Clear any previous error mark. - (cl-remprop name 'cl--type-error) - ;; Record new type to include its dependency in the DAG. - (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 typelist) - (lambda (_) (error "Invalid dependency graph"))))) - (error - (setf (symbol-plist name) oldplist) - (error (format "Define %S failed: %s" - name (error-message-string err))))))) + (condition-case err + (let* ((class (cl--find-class name)) + (recorded (memq name cl--type-list))) + (if (null class) + (or (null recorded) + (error "Type registered, but doesn't exist")) + (or recorded (error "Type exists, but not registered")) + (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)))) + ;; Setup a type descriptor for NAME. + (setf (cl--find-class name) + (cl--type-class-make name docstring parents)) + ;; Reset NAME as a newly defined type. + (cl-remprop name 'cl--type-flag) + ;; Record new type. 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--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 more complicated, because child types may + ;; be in the list, so moving the type to the head can be + ;; incorrect. The "cheap" solution is to leave the list + ;; unchanged (and hope the redefinition doesn't change the + ;; hierarchy too much). + ;; Side note: Redefinitions introduce other problems as well + ;; because the class object's `parents` slot contains + ;; references to `cl--class` objects, so after a redefinition + ;; via (setf (cl--find-class FOO) ...), the children's + ;; `parents` slots point to the old class object. That's a + ;; problem that affects all types and that we don't really try + ;; to solve currently. + (or recorded (push name cl--type-list))) + (error + (error (format "Define %S failed: %s" + name (error-message-string err)))))) ;;;###autoload (defmacro cl-deftype2 (name arglist &rest body) @@ -192,10 +183,12 @@ If PARENTS is non-nil, ARGLIST must be nil." (defun cl--type-error (type error) "Mark TYPE as in-error, and report the produced ERROR value." - (put type 'cl--type-error error) ;; Mark TYPE as in-error. ;; Temporarily raise the recursion limit to avoid another recursion ;; error while reporting ERROR. (let ((max-lisp-eval-depth (+ 800 max-lisp-eval-depth))) + ;; Mark TYPE as in-error and remove it from the dispatch list. + (put type 'cl--type-flag 'error) + (setq cl--type-dispatch-list (delq type cl--type-dispatch-list)) (warn "cl-types-of %s, %s" type (error-message-string error))) nil) @@ -242,55 +235,72 @@ If PARENTS is non-nil, ARGLIST must be nil." ;; to find which cl-types may need to be checked. ;; (defun cl-types-of (object) - "Return the types OBJECT belongs to. +"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) - ;; Build a list of all types OBJECT belongs to. - (dolist (type cl--type-list) +(let* ((root-type (cl-type-of object)) + (found (list root-type))) + ;; Build a list of all types OBJECT belongs to. + (dolist (type cl--type-list) + (let ((flag (get type 'cl--type-flag))) (and ;; Skip type, if it previously produced an error. - (null (get type 'cl--type-error)) - ;; Skip type not defined by `cl-deftype'. - (cl-type-class-p (cl--find-class type)) - ;; If BAR is declared as a parent of FOO and `cl-types-of' has - ;; already decided that the value is of type FOO, then we - ;; already know BAR will be in the output anyway and there's no - ;; point testing BAR. So, skip type already selected as parent - ;; of another type, assuming that, most of the time, `assq' - ;; will be faster than `cl-typep'. - (null (assq type found)) + (not (eq flag 'error)) + ;; Skip type which we are sure will not match. + (or (null flag) (eq flag root-type)) ;; 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))) - (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) - ;; 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))))))) + (or flag (put type 'cl--type-flag root-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) + ;; Compute an ordered list of types from the DAG. + (merge-ordered-lists (mapcar #'cl--type-parents found))))) ;;; Method dispatching ;; + +;; For a declaration like +;; +;; (cl-deftype list-of (elem-type) +;; `(and list +;; (satisfies ,(lambda (list) +;; (cl-every (lambda (elem) +;; (cl-typep elem elem-type)) +;; list))))) +;; +;; we add the type to `cl--type-list' even though it's unusable there +;; (the `cl-typep` call in `cl-types-of' will always signal an error +;; because the type can't be used without argument). +;; +;; One way to solve this (and even open up the possibility to +;; dispatch on complex types like `(list-of FOO)') is to populate +;; `cl--type-dispatch-list' (i.e. the list of types that need to +;; be checked during dispatch) from `cl-generic-generalizers' so it +;; includes only those types for which there's a method, rather than +;; all defined types. + (cl-generic-define-generalizer cl--type-generalizer 20 ;; "typeof" < "cl-types-of" < "head" priority - (lambda (obj &rest _) `(cl-types-of ,obj)) + (lambda (obj &rest _) `(let ((cl--type-list cl--type-dispatch-list)) + (cl-types-of ,obj))) (lambda (tag &rest _) (if (consp tag) tag))) (cl-defmethod cl-generic-generalizers :extra "cl-types-of" (type) "Support for dispatch on cl-types." (if (cl--type-p type) - (list cl--type-generalizer) + (progn + ;; Add a new dispatch type to the dispatch list, then + ;; synchronize with `cl--type-list' so that both lists follow + ;; the same type precedence order. + (unless (memq type cl--type-dispatch-list) + (setq cl--type-dispatch-list + (seq-intersection cl--type-list + (cons type cl--type-dispatch-list)))) + (list cl--type-generalizer)) (cl-call-next-method))) (provide 'cl-types) -- 2.39.5