From: Stefan Monnier Date: Thu, 28 Mar 2024 04:06:00 +0000 (-0400) Subject: (pcase-mutually-exclusive): Use auto-generated table X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=236a519f36df7042478d547f72f1ea18771d4314;p=emacs.git (pcase-mutually-exclusive): Use auto-generated table The `pcase-mutually-exclusive-predicates` table was not very efficient since it grew like O(N²) with the number of predicates. Replace it with an O(N) table that's auto-generated from the `built-in-class` objects. * lisp/emacs-lisp/pcase.el (pcase-mutually-exclusive-predicates): Delete variable. (pcase--subtype-bitsets): New function and constant. (pcase--mutually-exclusive-p): Use them. * lisp/emacs-lisp/cl-preloaded.el (built-in-class): Don't inline. (cherry picked from commit f1fe13ea057237f5426c93876488cb95be86156c) --- diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el index 260478c3a39..d23ad3972a9 100644 --- a/lisp/emacs-lisp/cl-preloaded.el +++ b/lisp/emacs-lisp/cl-preloaded.el @@ -303,6 +303,7 @@ (cl-defstruct (built-in-class (:include cl--class) + (:noinline t) (:constructor nil) (:constructor built-in-class--make (name docstring parents)) (:copier nil)) diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index 40d917795e3..e2d0c0dc068 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -623,62 +623,83 @@ recording whether the var has been referenced by earlier parts of the match." (defun pcase--and (match matches) (if matches `(and ,match ,@matches) match)) -(defconst pcase-mutually-exclusive-predicates - '((symbolp . integerp) - (symbolp . numberp) - (symbolp . consp) - (symbolp . arrayp) - (symbolp . vectorp) - (symbolp . stringp) - (symbolp . byte-code-function-p) - (symbolp . compiled-function-p) - (symbolp . recordp) - (null . integerp) - (null . numberp) - (null . numberp) - (null . consp) - (null . arrayp) - (null . vectorp) - (null . stringp) - (null . byte-code-function-p) - (null . compiled-function-p) - (null . recordp) - (integerp . consp) - (integerp . arrayp) - (integerp . vectorp) - (integerp . stringp) - (integerp . byte-code-function-p) - (integerp . compiled-function-p) - (integerp . recordp) - (numberp . consp) - (numberp . arrayp) - (numberp . vectorp) - (numberp . stringp) - (numberp . byte-code-function-p) - (numberp . compiled-function-p) - (numberp . recordp) - (consp . arrayp) - (consp . atom) - (consp . vectorp) - (consp . stringp) - (consp . byte-code-function-p) - (consp . compiled-function-p) - (consp . recordp) - (arrayp . byte-code-function-p) - (arrayp . compiled-function-p) - (vectorp . byte-code-function-p) - (vectorp . compiled-function-p) - (vectorp . recordp) - (stringp . vectorp) - (stringp . recordp) - (stringp . byte-code-function-p) - (stringp . compiled-function-p))) - +(defun pcase--subtype-bitsets () + (let ((built-in-types ())) + (mapatoms (lambda (sym) + (let ((class (get sym 'cl--class))) + (when (and (built-in-class-p class) + (get sym 'cl-deftype-satisfies)) + (push (list sym + (get sym 'cl-deftype-satisfies) + (cl--class-allparents class)) + built-in-types))))) + ;; The "true" predicate for `function' type is `cl-functionp'. + (setcar (nthcdr 1 (assq 'function built-in-types)) 'cl-functionp) + ;; Sort the types from deepest in the hierarchy so all children + ;; are processed before their parent. It also gives lowest + ;; numbers to those types that are subtypes of the largest number + ;; of types, which minimize the need to use bignums. + (setq built-in-types (sort built-in-types + (lambda (x y) + (> (length (nth 2 x)) (length (nth 2 y)))))) + + (let ((bitsets (make-hash-table)) + (i 1)) + (dolist (x built-in-types) + ;; Don't dedicate any bit to those predicates which already + ;; have a bitset, since it means they're already represented + ;; by their subtypes. + (unless (and (nth 1 x) (gethash (nth 1 x) bitsets)) + (dolist (parent (nth 2 x)) + (let ((pred (nth 1 (assq parent built-in-types)))) + (unless (or (eq parent t) (null pred)) + (puthash pred (+ i (gethash pred bitsets 0)) + bitsets)))) + (setq i (+ i i)))) + + ;; Extra predicates that don't have matching types. + (dolist (pred-types '((functionp cl-functionp consp symbolp) + (keywordp symbolp) + (characterp fixnump) + (natnump integerp) + (facep symbolp stringp) + (plistp listp) + (cl-struct-p recordp) + ;; ;; FIXME: These aren't quite in the same + ;; ;; category since they'll signal errors. + (fboundp symbolp) + )) + (puthash (car pred-types) + (apply #'logior + (mapcar (lambda (pred) + (gethash pred bitsets)) + (cdr pred-types))) + bitsets)) + bitsets))) + +(defconst pcase--subtype-bitsets + (if (fboundp 'built-in-class-p) + (pcase--subtype-bitsets) + ;; Early bootstrap: we don't have the built-in classes yet, so just + ;; use an empty table for now. + (prog1 (make-hash-table) + ;; The empty table leads to significantly worse code, so upgrade + ;; to the real table as soon as possible (most importantly: before we + ;; start compiling code, and hence baking the result into files). + (with-eval-after-load 'cl-preloaded + (defconst pcase--subtype-bitsets (pcase--subtype-bitsets))))) + "Table mapping predicates to their set of types. +These are the set of built-in types for which they may return non-nil. +The sets are represented as bitsets (integers) where each bit represents +a specific leaf type. Which bit represents which type is unspecified.") + +;; Extra predicates (defun pcase--mutually-exclusive-p (pred1 pred2) - (or (member (cons pred1 pred2) - pcase-mutually-exclusive-predicates) - (member (cons pred2 pred1) - pcase-mutually-exclusive-predicates))) + (let ((subtypes1 (gethash pred1 pcase--subtype-bitsets))) + (when subtypes1 + (let ((subtypes2 (gethash pred2 pcase--subtype-bitsets))) + (when subtypes2 + (zerop (logand subtypes1 subtypes2))))))) (defun pcase--split-match (sym splitter match) (cond @@ -814,7 +835,8 @@ A and B can be one of: ((vectorp (cadr pat)) #'vectorp) ((compiled-function-p (cadr pat)) #'compiled-function-p)))) - (pcase--mutually-exclusive-p (cadr upat) otherpred)) + (and otherpred + (pcase--mutually-exclusive-p (cadr upat) otherpred))) '(:pcase--fail . nil)) ;; Since we turn (or 'a 'b 'c) into (pred (memq _ '(a b c))) ;; try and preserve the info we get from that memq test. diff --git a/test/lisp/emacs-lisp/pcase-tests.el b/test/lisp/emacs-lisp/pcase-tests.el index d062965952a..c79adcdfec5 100644 --- a/test/lisp/emacs-lisp/pcase-tests.el +++ b/test/lisp/emacs-lisp/pcase-tests.el @@ -160,4 +160,18 @@ (should-error (pcase-setq a) :type '(wrong-number-of-arguments))) +(ert-deftest pcase-tests-mutually-exclusive () + (dolist (x '((functionp consp nil) + (functionp stringp t) + (compiled-function-p consp t) + (keywordp symbolp nil) + (keywordp symbol-with-pos-p nil) + (keywordp stringp t))) + (if (nth 2 x) + (should (pcase--mutually-exclusive-p (nth 0 x) (nth 1 x))) + (should-not (pcase--mutually-exclusive-p (nth 0 x) (nth 1 x)))) + (if (nth 2 x) + (should (pcase--mutually-exclusive-p (nth 1 x) (nth 0 x))) + (should-not (pcase--mutually-exclusive-p (nth 1 x) (nth 0 x)))))) + ;;; pcase-tests.el ends here.