From bdec2d2d464919572ae948ba8150e014aa649191 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Mon, 30 Oct 2023 00:59:19 -0400 Subject: [PATCH] comp-cstr.el: The type hierarchy is a DAG, not a tree Adjust the type operations to account for the fact that types can have several parents. * lisp/emacs-lisp/comp-cstr.el (comp--cl-class-hierarchy): Use `cl--class-allparents`. Add FIXME. (comp--direct-supertype): Declare obsolete. (comp--direct-supertypes): New function. (comp--normalize-typeset0): Rewrite to use `comp--direct-supertypes`; adjust to account for the DAG structure; use `cl-set-difference`. (comp--direct-subtypes): Rewrite. (comp--intersection): New function. (comp-supertypes): Rewrite and change return type. (comp-subtype-p): Simplify. (comp-union-typesets): Use `comp-supertypes` instead of iterating over `comp-cstr-ctxt-typeof-types`. * lisp/emacs-lisp/comp.el (comp--native-compile): Don't catch errors if we're debugging. * test/lisp/emacs-lisp/comp-cstr-tests.el: Adjust tests. * lisp/emacs-lisp/cl-macs.el (cl-defstruct): Fix mishap when we evaluate (cl-defstruct cl-structure-object ..) during the compilation of `cl-preloaded.el`. * lisp/emacs-lisp/cl-preloaded.el: Add corresponding assertion. --- lisp/emacs-lisp/cl-macs.el | 8 +- lisp/emacs-lisp/cl-preloaded.el | 3 + lisp/emacs-lisp/comp-cstr.el | 156 ++++++++++++++---------- lisp/emacs-lisp/comp.el | 5 +- test/lisp/emacs-lisp/comp-cstr-tests.el | 12 +- 5 files changed, 112 insertions(+), 72 deletions(-) diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 722d561b9f4..a4a241d9c63 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -3092,7 +3092,11 @@ To see the documentation for a defined struct type, use descs))) (t (error "Structure option %s unrecognized" opt))))) - (unless (or include-name type) + (unless (or include-name type + ;; Don't create a bogus parent to `cl-structure-object' + ;; while compiling the (cl-defstruct cl-structure-object ..) + ;; in `cl-preloaded.el'. + (eq name cl--struct-default-parent)) (setq include-name cl--struct-default-parent)) (when include-name (setq include (cl--struct-get-class include-name))) (if print-func @@ -3331,7 +3335,7 @@ To see the documentation for a defined struct type, use ;;; Add cl-struct support to pcase ;;In use by comp.el -(defun cl--struct-all-parents (class) +(defun cl--struct-all-parents (class) ;FIXME: Merge with `cl--class-allparents' (when (cl--struct-class-p class) (let ((res ()) (classes (list class))) diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el index 27603ae8626..03068639575 100644 --- a/lisp/emacs-lisp/cl-preloaded.el +++ b/lisp/emacs-lisp/cl-preloaded.el @@ -333,6 +333,9 @@ supertypes from the most specific to least specific.") (cl--class-parents class))))) (nreverse parents))) +(eval-and-compile + (cl-assert (null (cl--class-parents (cl--find-class 'cl-structure-object))))) + ;; 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 ;; directly on that function, since those cookies only go to cl-loaddefs. diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index d23304c8874..ee0ae10539d 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -89,8 +89,10 @@ Integer values are handled in the `range' slot.") (defun comp--cl-class-hierarchy (x) "Given a class name `x' return its hierarchy." - `(,@(mapcar #'cl--struct-class-name (cl--struct-all-parents - (cl--struct-get-class x))) + `(,@(cl--class-allparents (cl--struct-get-class x)) + ;; FIXME: AFAICT, `comp--all-classes' will also find those struct types + ;; which use :type and can thus be either `vector' or `cons' (the latter + ;; isn't `atom'). atom t)) @@ -267,8 +269,9 @@ Return them as multiple value." (string-lessp (symbol-name x) (symbol-name y))) -(defun comp--direct-supertype (type) +(defun comp--direct-supertype (type) ;FIXME: There can be several! "Return the direct supertype of TYPE." + (declare (obsolete comp--direct-supertype "30.1")) (cl-loop named outer for i in (comp-cstr-ctxt-typeof-types comp-ctxt) @@ -276,24 +279,50 @@ Return them as multiple value." when (eq j type) do (cl-return-from outer y)))) +(defun comp--direct-supertypes (type) + "Return the direct supertypes of TYPE." + (let ((supers (comp-supertypes type))) + (cl-assert (eq type (car supers))) + (cl-loop + with notdirect = nil + with direct = nil + for parent in (cdr supers) + unless (memq parent notdirect) + do (progn + (push parent direct) + (setq notdirect (append notdirect (comp-supertypes parent)))) + finally return direct))) + (defun comp--normalize-typeset0 (typeset) - ;; For every type search its supertype. If all the subtypes of that + ;; For every type search its supertypes. If all the subtypes of a ;; supertype are presents remove all of them, add the identified ;; supertype and restart. + ;; FIXME: The intention is to return a 100% equivalent but simpler + ;; typeset, but this is only the case when the supertype is abstract + ;; and "final/closed" (i.e. can't have new subtypes). (when typeset (while (eq 'restart (cl-loop named main - for i in typeset - for sup = (comp--direct-supertype i) + for sup in (cl-remove-duplicates + (apply #'append + (mapcar #'comp--direct-supertypes typeset))) for subs = (comp--direct-subtypes sup) - when (and sup - (length> subs 1) - (cl-every (lambda (x) (member x typeset)) subs)) - do (cl-loop for s in subs - do (setq typeset (cl-delete s typeset)) - finally (progn (push sup typeset) - (cl-return-from main 'restart)))))) + when (and (length> subs 1) ;;FIXME: Why? + ;; Every subtype of `sup` is a subtype of + ;; some element of `typeset`? + ;; It's tempting to just check (member x typeset), + ;; but think of the typeset (marker number), + ;; where `sup' is `integer-or-marker' and `sub' + ;; is `integer'. + (cl-every (lambda (sub) + (cl-some (lambda (type) + (comp-subtype-p sub type)) + typeset)) + subs)) + do (progn + (setq typeset (cons sup (cl-set-difference typeset subs))) + (cl-return-from main 'restart))))) typeset)) (defun comp-normalize-typeset (typeset) @@ -303,56 +332,53 @@ Return them as multiple value." (defun comp--direct-subtypes (type) "Return all the direct subtypes of TYPE." ;; TODO: memoize. - (cl-sort - (cl-loop for j in (comp-cstr-ctxt-typeof-types comp-ctxt) - for res = (cl-loop for i in j - with last = nil - when (eq i type) - return last - do (setq last i)) - when res - collect res) - #'comp--sym-lessp)) + (let ((subtypes ())) + (dolist (j (comp-cstr-ctxt-typeof-types comp-ctxt)) + (let ((occur (memq type j))) + (when occur + (while (not (eq j occur)) + (let ((candidate (pop j))) + (when (and (not (memq candidate subtypes)) + (memq type (comp--direct-supertypes candidate))) + (push candidate subtypes))))))) + (cl-sort subtypes #'comp--sym-lessp))) + +(defun comp--intersection (list1 list2) + "Like `cl-intersection` but preserves the order of one of its args." + (if (equal list1 list2) list1 + (let ((res nil)) + (while list2 + (if (memq (car list2) list1) + (push (car list2) res)) + (pop list2)) + (nreverse res)))) (defun comp-supertypes (type) - "Return a list of pairs (supertype . hierarchy-level) for TYPE." + "Return the ordered list of supertypes of TYPE." + ;; FIXME: We should probably keep the results in + ;; `comp-cstr-ctxt-typeof-types' (or maybe even precompute them + ;; and maybe turn `comp-cstr-ctxt-typeof-types' into a hash-table). + ;; Or maybe we shouldn't keep structs and defclasses in it, + ;; and just use `cl--class-allparents' when needed (and refuse to + ;; compute their direct subtypes since we can't know them). (cl-loop - named outer - with found = nil - for l in (comp-cstr-ctxt-typeof-types comp-ctxt) - do (cl-loop - for x in l - for i from (length l) downto 0 - when (eq type x) - do (setf found t) - when found - collect `(,x . ,i) into res - finally (when found - (cl-return-from outer res))))) - -(defun comp-common-supertype-2 (type1 type2) - "Return the first common supertype of TYPE1 TYPE2." - (when-let ((types (cl-intersection - (comp-supertypes type1) - (comp-supertypes type2) - :key #'car))) - (car (cl-reduce (lambda (x y) - (if (> (cdr x) (cdr y)) x y)) - types)))) - -(defun comp-common-supertype (&rest types) - "Return the first common supertype of TYPES." - (or (gethash types (comp-cstr-ctxt-common-supertype-mem comp-ctxt)) - (puthash types - (cl-reduce #'comp-common-supertype-2 types) - (comp-cstr-ctxt-common-supertype-mem comp-ctxt)))) + named loop + with above + for lane in (comp-cstr-ctxt-typeof-types comp-ctxt) + do (let ((x (memq type lane))) + (cond + ((null x) nil) + ((eq x lane) (cl-return-from loop x)) ;A base type: easy case. + (t (setq above + (if above (comp--intersection x above) x))))) + finally return above)) (defsubst comp-subtype-p (type1 type2) "Return t if TYPE1 is a subtype of TYPE2 or nil otherwise." (let ((types (cons type1 type2))) (or (gethash types (comp-cstr-ctxt-subtype-p-mem comp-ctxt)) (puthash types - (eq (comp-common-supertype-2 type1 type2) type2) + (memq type2 (comp-supertypes type1)) (comp-cstr-ctxt-subtype-p-mem comp-ctxt))))) (defun comp-union-typesets (&rest typesets) @@ -360,16 +386,18 @@ Return them as multiple value." (or (gethash typesets (comp-cstr-ctxt-union-typesets-mem comp-ctxt)) (puthash typesets (cl-loop - with types = (apply #'append typesets) + ;; List of (TYPE . SUPERTYPES)", ordered from + ;; "most general" to "least general" + with typess = (sort (mapcar #'comp-supertypes + (apply #'append typesets)) + (lambda (l1 l2) + (<= (length l1) (length l2)))) with res = '() - for lane in (comp-cstr-ctxt-typeof-types comp-ctxt) - do (cl-loop - with last = nil - for x in lane - when (memq x types) - do (setf last x) - finally (when last - (push last res))) + for types in typess + ;; Don't keep this type if it's a subtype of one of + ;; the other types. + unless (comp--intersection types res) + do (push (car types) res) finally return (comp-normalize-typeset res)) (comp-cstr-ctxt-union-typesets-mem comp-ctxt)))) @@ -863,7 +891,7 @@ Non memoized version of `comp-cstr-intersection-no-mem'." (comp-subtype-p neg-type pos-type)) do (cl-loop with found - for (type . _) in (comp-supertypes neg-type) + for type in (comp-supertypes neg-type) when found collect type into res when (eq type pos-type) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 181e5ca96a1..bdc59703de9 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -4180,7 +4180,7 @@ the deferred compilation mechanism." (comp-log "\n \n" 1) (unwind-protect (progn - (condition-case err + (condition-case-unless-debug err (cl-loop with report = nil for t0 = (current-time) @@ -4199,7 +4199,8 @@ the deferred compilation mechanism." (comp-log (format "Done compiling %s" data) 0) (cl-loop for (pass . time) in (reverse report) do (comp-log (format "Pass %s took: %fs." - pass time) 0)))) + pass time) + 0)))) (native-compiler-skip) (t (let ((err-val (cdr err))) diff --git a/test/lisp/emacs-lisp/comp-cstr-tests.el b/test/lisp/emacs-lisp/comp-cstr-tests.el index d2f552af6fa..cbedce0c47d 100644 --- a/test/lisp/emacs-lisp/comp-cstr-tests.el +++ b/test/lisp/emacs-lisp/comp-cstr-tests.el @@ -42,14 +42,14 @@ ',expected-type-spec)))) (defconst comp-cstr-typespec-tests-alist - `(;; 1 + '(;; 1 (symbol . symbol) ;; 2 ((or string array) . array) ;; 3 ((or symbol number) . (or number symbol)) ;; 4 - ((or cons atom) . (or atom cons)) ;; SBCL return T + ((or cons atom) . t) ;; SBCL return T ;; 5 ((or integer number) . number) ;; 6 @@ -219,14 +219,18 @@ ;; 88 ((and (or (member a b c)) (not (or (member a b)))) . (member c)) ;; 89 - ((or cons symbol) . list) + ((or cons symbol) . (or list symbol)) ;; FIXME: Why `list'? ;; 90 ((or string char-table bool-vector vector) . array) ;; 91 ((or string char-table bool-vector vector number) . (or array number)) ;; 92 ((or string char-table bool-vector vector cons symbol number) . - (or number sequence))) + (or number sequence symbol)) + ;; 93? + ;; FIXME: I get `cons' rather than `list'? + ;;((or null cons) . list) + ) "Alist type specifier -> expected type specifier.")) (defmacro comp-cstr-synthesize-tests () -- 2.39.2