Minor improvement to union of structs transform

Handle very limited cases of (and this (not that))

src/code/class.lisp

@@ -347,6 +347,17 @@ between the ~A definition and the ~A definition"
                table))
   nil)
 
+;;; Recursively expand classoid-subclasses. Classoid should probably be a sealed
+;;; classoid for the answer to be meaningful, otherwise the true answer is unbounded.
+(defun classoid-all-subclassoids (classoid &aux result)
+  (labels ((add-descendants (classoid &optional layout)
+             (declare (ignore layout))
+             (unless (member classoid result)
+               (push classoid result)
+               (sb-kernel::call-with-subclassoids #'add-descendants classoid))))
+    (add-descendants classoid)
+    result))
+
 ;;; Record LAYOUT as the layout for its class, adding it as a subtype
 ;;; of all superclasses. This is the operation that "installs" a
 ;;; layout for a class in the type system, clobbering any old layout.

src/cold/exports.lisp

@@ -1848,7 +1848,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries.")
            "MOST-POSITIVE-EXACTLY-DOUBLE-FLOAT-INTEGER"
            "MOST-POSITIVE-EXACTLY-SINGLE-FLOAT-INTEGER"
            "NAMED-TYPE" "NAMED-TYPE-NAME" "NAMED-TYPE-P"
-           "NEGATE" "NEGATION-TYPE" "NEGATION-TYPE-TYPE"
+           "NEGATE" "NEGATION-TYPE" "NEGATION-TYPE-TYPE" "NEGATION-TYPE-P"
            "NIL-ARRAY-ACCESSED-ERROR"
            "NIL-FUN-RETURNED-ERROR"
            "NON-NULL-SYMBOL-P"
@@ -2169,6 +2169,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries.")
            "UNDEFINE-FUN-NAME" "DD-TYPE" "CLASSOID-STATE" "INSTANCE"
            "*TYPE-SYSTEM-INITIALIZED*" "FIND-LAYOUT"
            "%TYPEP" "%%TYPEP" "DD-FLAGS" "DD-NAME" "CLASSOID-SUBCLASSES"
+           "CLASSOID-ALL-SUBCLASSOIDS"
            "+DD-VARYLEN+"
            "CLASSOID-LAYOUT" "CLASSOID-NAME" "CLASSOID-P" "CLASSOID-WRAPPER"
            "NOTE-NAME-DEFINED"

src/compiler/typetran.lisp

@@ -713,25 +713,58 @@
                        (or (check a b)
                            (check b a)))))))))
 
+;; If TYPE is a strict subtype of a frozen classoid specified as
+;; (AND someclassoid (NOT somesubclassoid)) then return the "exact" set
+;; of classoids is is. i.e. pretend that membership in the resulting set
+;; is determined by the classoid of an object being EQ to one of the classoids
+;; and that the SUBTYPEP relation is irrelevant. Practically speaking: the
+;; instance-layout of a candidate object must be EQ to the layout for one
+;; of the classoids in the answer.  The consumer of this output should not
+;; take a union of the set for purposes of constructing a type.
+(defun frozen-struct-classoid-carve-out (type)
+  (flet ((matchp (a b) ; does this type match (AND (NOT a) B)
+           (and (negation-type-p a)
+                (structure-classoid-p b)
+                (structure-classoid-p (negation-type-type a))
+                (eq (classoid-state (negation-type-type a)) :sealed)
+                (eq (classoid-state b) :sealed)
+                ;; I think this has gotta be true. Why would the type algebra
+                ;; leave it in if it weren't possible? It would just delete the
+                ;; negation, and not represent it as an intersection at all.
+                (csubtypep (negation-type-type a) b)))
+         (difference (super sub)
+           (set-difference (classoid-all-subclassoids super)
+                           (classoid-all-subclassoids (negation-type-type sub)))))
+    (when (intersection-type-p type)
+      (let ((types (compound-type-types type)))
+        ;; We could try to match C - c1 - c2 - ... cN but I don't care to do it.
+        (when (= (length types) 2)
+          (let ((first (first types)) (second (second types)))
+            ;; intersection is commutative so try both ways
+            (cond ((matchp first second) (difference second first))
+                  ((matchp second first) (difference first second)))))))))
+
 (defun transform-frozen-struct-union-typep (object types)
   ;; If at least 4 sealed structs (before accounting for hierarchy), try to use
   ;; a test based on layout-clos-hash.
-  (when (< (count-if (lambda (type)
-                       (and (structure-classoid-p type)
-                            (eq (classoid-state type) :sealed)))
-                     types)
-           4)
-    (return-from transform-frozen-struct-union-typep nil))
-  (collect ((structs) (other))
+  (let ((count 0))
     (dolist (type types)
-      (labels ((add-descendants (classoid &optional layout)
-                 (declare (ignore layout))
-                 (unless (member classoid (structs))
-                   (structs classoid)
-                   (sb-kernel::call-with-subclassoids #'add-descendants classoid))))
+      (incf count
             (if (and (structure-classoid-p type) (eq (classoid-state type) :sealed))
-            (add-descendants type)
-            (other type))))
+                1
+                (length (frozen-struct-classoid-carve-out type)))))
+    (when (< count 4)
+      (return-from transform-frozen-struct-union-typep nil)))
+  (collect ((structs) (other))
+    (flet ((add (list)
+             (dolist (type list)
+               (unless (member type (structs)) (structs type)))))
+      (dolist (type types)
+        (acond ((and (structure-classoid-p type) (eq (classoid-state type) :sealed))
+                (add (classoid-all-subclassoids type)))
+               ((frozen-struct-classoid-carve-out type)
+                (add it))
+               (t (other type)))))
     (flet ((typehash (x) (ldb (byte 32 0) (layout-clos-hash (classoid-layout x)))))
       (let* ((hashes (map '(array (unsigned-byte 32) 1) #'typehash (structs)))
              (lexpr (or (make-perfect-hash-lambda hashes (mapcar 'classoid-name (structs)))
@@ -1593,7 +1626,7 @@
                    dimensions-removed)
                (dolist (type types)
                  (unless (or (hairy-type-p type)
-                             (sb-kernel::negation-type-p type))
+                             (negation-type-p type))
                    (multiple-value-bind (type et upgraded dimensions) (simplify type)
                      (push type array-types)
                      (push et element-types)

tests/perfecthash.impure.lisp

@@ -18,6 +18,40 @@
                (^ A (AREF TAB B))))))))
 |#
 
+(defstruct root)
+(defstruct (parent (:include root)))
+(defstruct (kid (:include root)))
+(defstruct (otherkid (:include root)))
+(defstruct foo)
+(defstruct bar)
+(defstruct baz)
+(declaim (freeze-type root foo bar baz))
+
+(defvar *transform-result*)
+(sb-int:encapsulate 'sb-c::transform-frozen-struct-union-typep 'check-if-called
+ (lambda (realfun &rest args)
+   (setf *transform-result* (apply realfun args))))
+
+(defun typecheck-almost-branchlessly (x)
+  (declare (optimize (sb-c::verify-arg-count 0)))
+  ;; the check for NIL and %instancep are the only branches
+  (values t (the (or null foo bar baz (and root (not otherkid))) x)))
+(compile 'typecheck-almost-branchlessly)
+
+(with-test (:name :structure-union-typep)
+  (assert *transform-result*)
+  ;; assert correct types accepted, some of them unrelated
+  (dolist (ctor '(make-root make-parent make-kid
+                  make-foo make-bar make-baz))
+    (assert (typecheck-almost-branchlessly (funcall ctor))))
+  (assert (typecheck-almost-branchlessly nil))
+  (assert-error (typecheck-almost-branchlessly (make-otherkid)))
+  (assert-error (typecheck-almost-branchlessly #p"zook"))
+  #+x86-64 ; assert only 3 conditional jumps needed
+  (let* ((model (get-simple-fun-instruction-model #'typecheck-almost-branchlessly))
+         (jmps (count-if (lambda (x) (string= (second x) "JMP")) model)))
+    (assert (= jmps 3))))
+
 (with-test (:name :minimal-vs-non-minimal)
   (let* ((symbols
           ;; Not sure why INTERN would randomly occur in SB-WALKER but it did,