master: Improve TYPEP for (and some-instance-type (not some-subtype))

The branch "master" has been updated in SBCL:
       via  b5c57d2d40001c1d4af0c83876ba9bcd7d62af4a (commit)
      from  0c21989ac51f144c127e1b718fd0534d1f9420f9 (commit)

- Log -----------------------------------------------------------------
commit b5c57d2d40001c1d4af0c83876ba9bcd7d62af4a
Author: Douglas Katzman <[email protected]>
Date:   Mon May 4 01:10:07 2026 -0400

    Improve TYPEP for (and some-instance-type (not some-subtype))
    
    Instead of a hierarchical layout test for the ancestor and then a test
    to exclude the child, simply compare for EQness to a single layout.
---
 src/compiler/typetran.lisp       | 24 +++++++++++++++++++++++-
 tests/x86-64-codegen.impure.lisp | 19 +++++++++++++++++++
 2 files changed, 42 insertions(+), 1 deletion(-)

diff --git a/src/compiler/typetran.lisp b/src/compiler/typetran.lisp
index 4f1892c98..1a099e50d 100644
--- a/src/compiler/typetran.lisp
+++ b/src/compiler/typetran.lisp
@@ -1005,7 +1005,26 @@
                                   '(or ,@(mapcar (lambda (x) (if (ctype-p x)
                                                                  (type-specifier x)
                                                                  x))
-                                          negated)))))))
+                                          negated))))))
+                  (maybe-exactly-struct-type (type negated)
+                    ;; If it is "exactly" an ancestral type, it is always more efficient
+                    ;; to test LAYOUT= of the type rather than using STRUCTURE-IS-A
+                    ;; and then ruling out descendant types individually.
+                    (let ((whole (classoid-all-subclassoids type)))
+                      (dolist (neg negated)
+                        (when (typep neg 'structure-classoid)
+                          (dolist (remove (classoid-all-subclassoids neg))
+                            (if (member remove whole)
+                                (setq whole (remove remove whole))
+                                (return-from maybe-exactly-struct-type nil))))) ; just give up
+                      (when (singleton-p whole) ; a winner
+                        (let ((layout (info :type :compiler-layout (classoid-name (car whole)))))
+                          ;; funcallable structures should never get here.
+                          `(and (%instancep ,object)
+                                ,(if (vop-existsp :translate layout-eq)
+                                     `(layout-eq ,object ,layout ,sb-vm:instance-pointer-lowtag)
+                                     `(eq (%instance-layout ,object) ,layout))))))))
+
              (cond
                ;; (and array (not vector))
                ((and (eq (car types) (specifier-type 'array))
@@ -1030,6 +1049,9 @@
                                           (let ((rem (remove nil members)))
                                             (when rem
                                               `((member ,@rem)))))))))))
+               ((and (typep types '(cons structure-classoid null))
+                     (eq (classoid-state (car types)) :sealed)
+                     (maybe-exactly-struct-type (car types) negated)))
                (t
                 (test types negated)))))
           (t
diff --git a/tests/x86-64-codegen.impure.lisp b/tests/x86-64-codegen.impure.lisp
index 01e8074ce..fa2aa9842 100644
--- a/tests/x86-64-codegen.impure.lisp
+++ b/tests/x86-64-codegen.impure.lisp
@@ -1456,3 +1456,22 @@
               (assert (oddp index)))
           ;; No always-thread-local special clashes with *PACKAGE*'s indirection cell
           (assert (/= index (1- index-of-package))))))))
+
+(defstruct frozenthing)
+(defstruct (specialthing (:include frozenthing)))
+(defstruct (subspecialthing (:include specialthing)))
+(defstruct (otherspecialthing (:include frozenthing)))
+(declaim (freeze-type frozenthing))
+(with-test (:name :typep-layout-eq-one-type)
+  (let ((expr `(lambda (x)
+                 (declare (optimize (sb-c::verify-arg-count 0)))
+                 (the (and frozenthing (not (or specialthing otherspecialthing))) x)))
+        (comparisons 0)
+        (saw-layout))
+    ;; there should be exactly one CMP instruction comparing to #<LAYOUT for THING>
+    (dolist (line (disassembly-lines (compile nil expr)))
+      (when (search "CMP " line)
+        (incf comparisons)
+        (when (and (search "#<LAYOUT" line) (search "FROZENTHING" line))
+          (setq saw-layout t))))
+    (assert (and saw-layout (eql comparisons 1)))))

-----------------------------------------------------------------------


hooks/post-receive
-- 
SBCL