Test for sealed classes using structure-typep too.

3 files changed, 112 insertions, 54 deletions

diff --git a/src/compiler/arm64/type-vops.lisp b/src/compiler/arm64/type-vops.lisp
index 2a266901c..74ea9d994 100644
--- a/src/compiler/arm64/type-vops.lisp
+++ b/src/compiler/arm64/type-vops.lisp
@@ -595,7 +595,7 @@
       (inst b :ne not-instance))
     (loadw r object instance-slots-offset instance-pointer-lowtag)))
 
-(defun structure-is-a (layout temp this-id test-layout &optional target not-p done)
+(defun structure-is-a (layout temp this-id test-layout &optional desc-temp target not-p done)
   (cond ((integerp test-layout)
          (inst ldrsw temp
                (@ layout
@@ -604,6 +604,11 @@
                           word-shift)
                      instance-pointer-lowtag)))
          (inst tst temp test-layout))
+        ((and desc-temp
+              (neq (tn-kind desc-temp) :unused))
+         (inst load-constant desc-temp
+               (tn-byte-offset (emit-constant test-layout)))
+         (inst cmp layout desc-temp))
         (t
          (let* ((test-id (layout-id test-layout))
                 (depthoid (wrapper-depthoid test-layout))
@@ -658,14 +663,28 @@
   (:conditional)
   (:info target not-p test-layout)
   (:temporary (:sc descriptor-reg) layout)
-  (:temporary (:sc unsigned-reg) this-id temp)
+  (:temporary (:sc unsigned-reg
+               :unused-if
+               (and (instance-tn-ref-p args)
+                    #1=(and (not (integerp test-layout))
+                            (let ((classoid (wrapper-classoid test-layout)))
+                              (and (eq (classoid-state classoid) :sealed)
+                                   (not (classoid-subclasses classoid)))))))
+              temp)
+  (:temporary (:sc unsigned-reg
+               :unused-if (or (integerp test-layout)
+                              #1#))
+              this-id)
+  (:temporary (:sc descriptor-reg
+               :unused-if (not #1#))
+              desc-temp)
   (:generator 4
     (unless (instance-tn-ref-p args)
       (inst and temp object lowtag-mask)
       (inst cmp temp instance-pointer-lowtag)
       (inst b :ne (if not-p target done)))
     (loadw layout object instance-slots-offset instance-pointer-lowtag)
-    (structure-is-a layout temp this-id test-layout target not-p done)
+    (structure-is-a layout temp this-id test-layout desc-temp target not-p done)
     (inst b (if (if (integerp test-layout)
                     (not not-p)
                     not-p)
@@ -678,9 +697,22 @@
   (:policy :fast-safe)
   (:conditional)
   (:info target not-p test-layout)
-  (:temporary (:sc unsigned-reg) this-id temp)
+  (:temporary (:sc unsigned-reg
+               :unused-if
+               #1=(and (not (integerp test-layout))
+                       (let ((classoid (wrapper-classoid test-layout)))
+                         (and (eq (classoid-state classoid) :sealed)
+                              (not (classoid-subclasses classoid))))))
+              temp)
+  (:temporary (:sc unsigned-reg
+               :unused-if (or (integerp test-layout)
+                              #1#))
+              this-id)
+  (:temporary (:sc descriptor-reg
+               :unused-if (not #1#))
+              desc-temp)
   (:generator 4
-    (structure-is-a layout temp this-id test-layout target not-p done)
+    (structure-is-a layout temp this-id test-layout desc-temp target not-p done)
     (inst b (if (if (integerp test-layout)
                     (not not-p)
                     not-p)
diff --git a/src/compiler/typetran.lisp b/src/compiler/typetran.lisp
index 7e3964e9a..273df6921 100644
--- a/src/compiler/typetran.lisp
+++ b/src/compiler/typetran.lisp
@@ -922,19 +922,23 @@
           ((and wrapper
                 (eq (classoid-state classoid) :sealed)
                 (not (classoid-subclasses classoid)))
-           (if lowtag-test
-               `(and ,lowtag-test
-                     ,(if (vop-existsp :translate layout-eq)
-                          `(layout-eq object ,wrapper ,lowtag)
-                          `(eq ,slot-reader ,layout)))
-               ;; `(eq ,layout
-               ;;      (if-vop-existsp (:translate %instanceoid-layout)
-               ;;        (%instanceoid-layout object)
-               ;;        ;; Slightly quicker than LAYOUT-OF. See also %PCL-INSTANCE-P
-               ;;        (cond ((%instancep object) (%instance-layout object))
-               ;;              ((funcallable-instance-p object) (%fun-layout object))
-               ;;              (t ,(find-layout 't)))))
-               (bug "Unexpected metatype for ~S" wrapper)))
+           (cond ((and (eq lowtag sb-vm:instance-pointer-lowtag)
+                       (vop-existsp :translate structure-typep))
+                  `(structure-typep object ,wrapper))
+                 (lowtag-test
+                  `(and ,lowtag-test
+                        ,(if (vop-existsp :translate layout-eq)
+                             `(layout-eq object ,wrapper ,lowtag)
+                             `(eq ,slot-reader ,layout))))
+                 (t
+                  ;; `(eq ,layout
+                  ;;      (if-vop-existsp (:translate %instanceoid-layout)
+                  ;;        (%instanceoid-layout object)
+                  ;;        ;; Slightly quicker than LAYOUT-OF. See also %PCL-INSTANCE-P
+                  ;;        (cond ((%instancep object) (%instance-layout object))
+                  ;;              ((funcallable-instance-p object) (%fun-layout object))
+                  ;;              (t ,(find-layout 't)))))
+                  (bug "Unexpected metatype for ~S" wrapper))))
 
           ;; All other structure types
           ((and (typep classoid 'structure-classoid) wrapper)
diff --git a/src/compiler/x86-64/type-vops.lisp b/src/compiler/x86-64/type-vops.lisp
index 5c75fb7aa..8cba092c1 100644
--- a/src/compiler/x86-64/type-vops.lisp
+++ b/src/compiler/x86-64/type-vops.lisp
@@ -942,37 +942,46 @@
       (inst cmp :dword (read-depthoid) (fixnumize k))))
 
   (defun structure-is-a (layout test-layout &optional target not-p done)
-    (if (integerp test-layout)
-        (inst test
-              (if (typep test-layout '(unsigned-byte 8))
-                  :byte
-                  :dword)
-              (ea (- (ash (+ instance-slots-offset
-                             (get-dsd-index layout sb-kernel::flags))
-                          word-shift)
-                     instance-pointer-lowtag)
-                  layout)
-              test-layout)
-        (let* ((depthoid (wrapper-depthoid test-layout))
-               (offset (+ (id-bits-offset)
-                          (ash (- depthoid 2) 2)
-                          (- instance-pointer-lowtag))))
-          (when (and target
-                     (> depthoid sb-kernel::layout-id-vector-fixed-capacity))
-            (inst cmp :dword (read-depthoid) (fixnumize depthoid))
-            (inst jmp :l (if not-p target done)))
-          (inst cmp :dword
-                (ea offset layout)
-                ;; Small layout-ids can only occur for layouts made in genesis.
-                ;; Therefore if the compile-time value of the ID is small,
-                ;; it is permanently assigned to that type.
-                ;; Otherwise, we allow for the possibility that the compile-time ID
-                ;; is not the same as the load-time ID.
-                ;; I don't think layout-id 0 can get here, but be sure to exclude it.
-                (if (or (typep (layout-id test-layout) '(and (signed-byte 8) (not (eql 0))))
-                        (not (sb-c::producing-fasl-file)))
-                    (layout-id test-layout)
-                    (make-fixup test-layout :layout-id)))))))
+    (cond ((integerp test-layout)
+           (inst test
+                 (if (typep test-layout '(unsigned-byte 8))
+                     :byte
+                     :dword)
+                 (ea (- (ash (+ instance-slots-offset
+                                (get-dsd-index layout sb-kernel::flags))
+                             word-shift)
+                        instance-pointer-lowtag)
+                     layout)
+                 test-layout))
+          ((let ((classoid (wrapper-classoid test-layout)))
+             (and (eq (classoid-state classoid) :sealed)
+                  (not (classoid-subclasses classoid))))
+           (emit-constant test-layout)
+           (inst cmp #+compact-instance-header :dword
+                     layout (make-fixup test-layout :layout)))
+
+          (t
+           (let* ((depthoid (wrapper-depthoid test-layout))
+                  (offset (+ (id-bits-offset)
+                             (ash (- depthoid 2) 2)
+                             (- instance-pointer-lowtag))))
+             (when (and target
+                        (> depthoid sb-kernel::layout-id-vector-fixed-capacity))
+               (inst cmp :dword (read-depthoid) (fixnumize depthoid))
+               (inst jmp :l (if not-p target done)))
+             (inst cmp #+compact-instance-header :dword
+                       (ea offset layout)
+                       ;; Small layout-ids can only occur for layouts made in genesis.
+                       ;; Therefore if the compile-time value of the ID is small,
+                       ;; it is permanently assigned to that type.
+                       ;; Otherwise, we allow for the possibility that the compile-time ID
+                       ;; is not the same as the load-time ID.
+                       ;; I don't think layout-id 0 can get here, but be sure to exclude it.
+                       (cond ((or (typep (layout-id test-layout) '(and (signed-byte 8) (not (eql 0))))
+                                  (not (sb-c::producing-fasl-file)))
+                              (layout-id test-layout))
+                             (t
+                              (make-fixup test-layout :layout-id)))))))))
 
 (define-vop ()
   (:translate sb-c::%structure-is-a)
@@ -996,11 +1005,24 @@
   (:generator 4
     (unless (instance-tn-ref-p args)
       (%test-lowtag object layout (if not-p target done) t instance-pointer-lowtag))
-    #+compact-instance-header
-    (inst mov :dword layout (ea (- 4 instance-pointer-lowtag) object))
-    #-compact-instance-header
-    (loadw layout object instance-slots-offset instance-pointer-lowtag)
-    (structure-is-a layout test-layout target not-p done)
+
+    (cond ((and (not (integerp test-layout))
+                (let ((classoid (wrapper-classoid test-layout)))
+                  (and (eq (classoid-state classoid) :sealed)
+                       (not (classoid-subclasses classoid)))))
+           (emit-constant test-layout)
+           #+compact-instance-header
+           (inst cmp :dword (ea (- 4 instance-pointer-lowtag) object)
+                 (make-fixup test-layout :layout))
+           #-compact-instance-header
+           (inst cmp (object-slot-ea layout instance-slots-offset instance-pointer-lowtag)
+                 (make-fixup test-layout :layout)))
+          (t
+           #+compact-instance-header
+           (inst mov :dword layout (ea (- 4 instance-pointer-lowtag) object))
+           #-compact-instance-header
+           (loadw layout object instance-slots-offset instance-pointer-lowtag)
+           (structure-is-a layout test-layout target not-p done)))
     (inst jmp (if (if (integerp test-layout)
                       (not not-p)
                       not-p)