Factor out boilerplate from structure-is-a

src/compiler/arm/system.lisp

@@ -78,11 +78,8 @@
   (:info test-layout)
   (:temporary (:sc unsigned-reg) this-id)
   (:generator 4
-    (let ((test-id (layout-id test-layout))
+    (inst ldr this-id (@ x (layout-id-offset test-layout)))
-          (offset (+ (id-bits-offset)
+    (let ((test-id (layout-id test-layout)))
-                     (ash (- (layout-depthoid test-layout) 2) 2)
-                     (- instance-pointer-lowtag))))
-      (inst ldr this-id (@ x offset))
       ;; 8-bit IDs are permanently assigned, so no fixup ever needed for those.
       (cond ((typep test-id '(and (unsigned-byte 8) (not (eql 0))))
              (inst cmp this-id test-id))

src/compiler/arm64/type-vops.lisp

@@ -828,10 +828,7 @@
           nil)
          (t
           (let* ((test-id (layout-id test-layout))
-                 (depthoid (layout-depthoid test-layout))
+                 (depthoid (layout-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 ldrsw temp
@@ -843,7 +840,7 @@
                           instance-pointer-lowtag)))
               (inst cmp temp (add-sub-immediate (fixnumize depthoid)))
               (inst b :lt (if not-p target done)))
-            (inst ldr (32-bit-reg this-id) (@ layout offset))
+            (inst ldr (32-bit-reg this-id) (@ layout (layout-id-offset test-layout)))
             ;; 8-bit IDs are permanently assigned, so no fixup ever needed for those.
             (cond ((typep test-id '(and (signed-byte 8) (not (eql 0))))
                    (if (minusp test-id)

src/compiler/generic/utils.lisp

@@ -544,6 +544,12 @@
 (defmacro id-bits-offset () ; FIXME: could this be a constant ?
   (let ((slot (get-dsd-index layout sb-kernel::id-word0)))
     (ash (+ sb-vm:instance-slots-offset slot) sb-vm:word-shift)))
+(defmacro layout-id-offset (layout)
+  ;; Compute offset at which you can read a layout-id from an unknown layout to see
+  ;; if it matches the ID at the depthoid of LAYOUT.
+  `(+ (id-bits-offset)
+      (ash (- (layout-depthoid ,layout) 2) 2)
+      (- instance-pointer-lowtag))) ; Answer is in bytes relative to tagged ptr
 
 ;; It is both an optimization and a necessity that we use a single-bit test
 ;; for these three layouts in particular, because no layout-id is stored

src/compiler/loongarch64/system.lisp

@@ -78,15 +78,12 @@
   (:info target not-p test-layout)
   (:temporary (:sc unsigned-reg) this-id temp)
   (:generator 4
-    (let ((offset (+ (id-bits-offset)
+      (inst ld.w this-id x (layout-id-offset test-layout))
-                     (ash (- (layout-depthoid test-layout) 2) 2)
-                     (- instance-pointer-lowtag))))
-      (inst ld.w this-id x offset)
       (if (or (typep (layout-id test-layout) '(and (signed-byte 8) (not (eql 0))))
               (not (sb-c::producing-fasl-file)))
           (inst li temp (layout-id test-layout))
           (inst load-layout-id temp test-layout))
-      (inst* (if not-p 'bne 'beq) this-id temp target))))
+      (inst* (if not-p 'bne 'beq) this-id temp target)))
 
 (define-vop (layout-depthoid)
   (:translate layout-depthoid)

src/compiler/mips/system.lisp

@@ -77,14 +77,10 @@
   (:info target not-p test-layout)
   (:temporary (:sc unsigned-reg) this-id test-id)
   (:generator 4
-    (let ((label (register-inline-constant :layout-id test-layout))
+    (inst lw test-id sb-vm::code-tn (register-inline-constant :layout-id test-layout))
-          (offset (+ (id-bits-offset)
+    (inst lw this-id x (layout-id test-layout))
-                     (ash (- (layout-depthoid test-layout) 2) 2)
+    (inst* (if not-p 'bne 'beq) this-id test-id target)
-                     (- instance-pointer-lowtag))))
+    (inst nop)))
-      (inst lw test-id sb-vm::code-tn label)
-      (inst lw this-id x offset)
-      (inst* (if not-p 'bne 'beq) this-id test-id target)
-      (inst nop))))
 
 (define-vop (%other-pointer-widetag)
   (:translate %other-pointer-widetag)

src/compiler/ppc/system.lisp

@@ -67,11 +67,8 @@
   (:info target not-p test-layout)
   (:temporary (:scs (non-descriptor-reg)) this-id that-id)
   (:generator 4
-    (let ((test-id (layout-id test-layout))
+    (inst lwz this-id x (layout-id-offset test-layout))
-          (offset (+ (id-bits-offset)
+    (let ((test-id (layout-id test-layout)))
-                     (ash (- (layout-depthoid test-layout) 2) 2)
-                     (- instance-pointer-lowtag))))
-      (inst lwz this-id x offset)
       ;; Always prefer 'cmpwi' if compiling to memory.
       ;; 8-bit IDs are permanently assigned, so no fixup ever needed for those.
       (cond ((or (typep test-id '(and (signed-byte 8) (not (eql 0))))

src/compiler/ppc64/system.lisp

@@ -83,11 +83,8 @@
   (:info target not-p test-layout)
   (:temporary (:scs (non-descriptor-reg)) this-id)
   (:generator 4
-    (let ((test-id (layout-id test-layout))
+    (inst lwa this-id x (layout-id-offset test-layout))
-          (offset (+ (id-bits-offset)
+    (let ((test-id (layout-id test-layout)))
-                     (ash (- (layout-depthoid test-layout) 2) 2)
-                     (- instance-pointer-lowtag))))
-      (inst lwa this-id x offset)
       ;; Always prefer 'cmpwi' if compiling to memory.
       ;; 8-bit IDs are permanently assigned, so no fixup ever needed for those.
       (cond ((or (typep test-id '(and (signed-byte 8) (not (eql 0))))

src/compiler/riscv/system.lisp

@@ -78,15 +78,12 @@
   (:info target not-p test-layout)
   (:temporary (:sc unsigned-reg) this-id temp)
   (:generator 4
-    (let ((offset (+ (id-bits-offset)
+      (inst lw this-id x (layout-id-offset test-layout))
-                     (ash (- (layout-depthoid test-layout) 2) 2)
-                     (- instance-pointer-lowtag))))
-      (inst lw this-id x offset)
       (if (or (typep (layout-id test-layout) '(and (signed-byte 8) (not (eql 0))))
               (not (sb-c::producing-fasl-file)))
           (inst li temp (layout-id test-layout))
           (inst load-layout-id temp test-layout))
-      (inst* (if not-p 'bne 'beq) this-id temp target))))
+      (inst* (if not-p 'bne 'beq) this-id temp target)))
 
 #+64-bit
 (define-vop (layout-depthoid)

src/compiler/sparc/system.lisp

@@ -70,17 +70,14 @@
   (:info target not-p test-layout)
   (:temporary (:sc unsigned-reg) this-id temp)
   (:generator 4
-    (let ((offset (+ (id-bits-offset)
+      (inst ld this-id x (layout-id-offset test-layout))
-                     (ash (- (layout-depthoid test-layout) 2) 2)
-                     (- instance-pointer-lowtag))))
-      (inst ld this-id x offset)
       (if (or (typep (layout-id test-layout) '(and (signed-byte 8) (not (eql 0))))
               (not (sb-c::producing-fasl-file)))
           (inst li temp (layout-id test-layout))
           (inst load-layout-id temp test-layout))
       (inst cmp this-id temp)
       (inst b (if not-p :ne :eq) target)
-      (inst nop))))
+      (inst nop)))
 
 (define-vop (%other-pointer-widetag)
   (:translate %other-pointer-widetag)

src/compiler/x86-64/type-vops.lisp

@@ -1260,16 +1260,13 @@
             (inst cmp (emit-constant test-layout) layout))
 
            (t
-            (let* ((depthoid (layout-depthoid test-layout))
+            (let ((depthoid (layout-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)
+                    (ea (layout-id-offset test-layout) 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.

src/compiler/x86/system.lisp

@@ -76,11 +76,7 @@
   (:conditional :e)
   (:generator 1
     (inst cmp
-          (make-ea :dword
+          (make-ea :dword :disp (layout-id-offset test) :base x)
-                   :disp (+ (id-bits-offset)
-                            (ash (- (layout-depthoid test) 2) 2)
-                            (- instance-pointer-lowtag))
-                   :base x)
           (if (or (typep (layout-id test) '(and (signed-byte 8) (not (eql 0))))
                   (not (sb-c::producing-fasl-file)))
               (layout-id test)