master bdec2d2d464: comp-cstr.el: The type hierarchy is a DAG, not a tree

[Stefan Monnier]

branch: master
commit bdec2d2d464919572ae948ba8150e014aa649191
Author: Stefan Monnier <monnier@iro.umontreal.ca>
Commit: Stefan Monnier <monnier@iro.umontreal.ca>

    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 ()