From b3b9f0efa2eda1f4d04ab7dfdb7c630bc96dd0df Mon Sep 17 00:00:00 2001 From: Douglas Katzman Date: Sun, 16 Aug 2026 22:19:14 -0400 Subject: [PATCH] Factor out boilerplate from structure-is-a --- src/compiler/arm/system.lisp | 7 ++----- src/compiler/arm64/type-vops.lisp | 7 ++----- src/compiler/generic/utils.lisp | 6 ++++++ src/compiler/loongarch64/system.lisp | 7 ++----- src/compiler/mips/system.lisp | 12 ++++-------- src/compiler/ppc/system.lisp | 7 ++----- src/compiler/ppc64/system.lisp | 7 ++----- src/compiler/riscv/system.lisp | 7 ++----- src/compiler/sparc/system.lisp | 7 ++----- src/compiler/x86-64/type-vops.lisp | 7 ++----- src/compiler/x86/system.lisp | 6 +----- 11 files changed, 27 insertions(+), 53 deletions(-) diff --git a/src/compiler/arm/system.lisp b/src/compiler/arm/system.lisp index e2fcedc86..3047f4518 100644 --- a/src/compiler/arm/system.lisp +++ b/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)) - (offset (+ (id-bits-offset) - (ash (- (layout-depthoid test-layout) 2) 2) - (- instance-pointer-lowtag)))) - (inst ldr this-id (@ x offset)) + (inst ldr this-id (@ x (layout-id-offset test-layout))) + (let ((test-id (layout-id test-layout))) ;; 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)) diff --git a/src/compiler/arm64/type-vops.lisp b/src/compiler/arm64/type-vops.lisp index 6e65bec52..d17d67c7b 100644 --- a/src/compiler/arm64/type-vops.lisp +++ b/src/compiler/arm64/type-vops.lisp @@ -828,10 +828,7 @@ nil) (t (let* ((test-id (layout-id test-layout)) - (depthoid (layout-depthoid test-layout)) - (offset (+ (id-bits-offset) - (ash (- depthoid 2) 2) - (- instance-pointer-lowtag)))) + (depthoid (layout-depthoid test-layout))) (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) diff --git a/src/compiler/generic/utils.lisp b/src/compiler/generic/utils.lisp index 454caa52a..3e4acfb3a 100644 --- a/src/compiler/generic/utils.lisp +++ b/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 diff --git a/src/compiler/loongarch64/system.lisp b/src/compiler/loongarch64/system.lisp index e3c9d84d4..55ad453c3 100644 --- a/src/compiler/loongarch64/system.lisp +++ b/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) - (ash (- (layout-depthoid test-layout) 2) 2) - (- instance-pointer-lowtag)))) - (inst ld.w this-id x offset) + (inst ld.w this-id x (layout-id-offset test-layout)) (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) diff --git a/src/compiler/mips/system.lisp b/src/compiler/mips/system.lisp index 9898944ab..719c0023c 100644 --- a/src/compiler/mips/system.lisp +++ b/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)) - (offset (+ (id-bits-offset) - (ash (- (layout-depthoid test-layout) 2) 2) - (- instance-pointer-lowtag)))) - (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)))) + (inst lw test-id sb-vm::code-tn (register-inline-constant :layout-id test-layout)) + (inst lw this-id x (layout-id test-layout)) + (inst* (if not-p 'bne 'beq) this-id test-id target) + (inst nop))) (define-vop (%other-pointer-widetag) (:translate %other-pointer-widetag) diff --git a/src/compiler/ppc/system.lisp b/src/compiler/ppc/system.lisp index e4ddb8684..173321001 100644 --- a/src/compiler/ppc/system.lisp +++ b/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)) - (offset (+ (id-bits-offset) - (ash (- (layout-depthoid test-layout) 2) 2) - (- instance-pointer-lowtag)))) - (inst lwz this-id x offset) + (inst lwz this-id x (layout-id-offset test-layout)) + (let ((test-id (layout-id test-layout))) ;; 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)))) diff --git a/src/compiler/ppc64/system.lisp b/src/compiler/ppc64/system.lisp index 66fe9e947..d8d591168 100644 --- a/src/compiler/ppc64/system.lisp +++ b/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)) - (offset (+ (id-bits-offset) - (ash (- (layout-depthoid test-layout) 2) 2) - (- instance-pointer-lowtag)))) - (inst lwa this-id x offset) + (inst lwa this-id x (layout-id-offset test-layout)) + (let ((test-id (layout-id test-layout))) ;; 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)))) diff --git a/src/compiler/riscv/system.lisp b/src/compiler/riscv/system.lisp index 2d1624e92..e48153702 100644 --- a/src/compiler/riscv/system.lisp +++ b/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) - (ash (- (layout-depthoid test-layout) 2) 2) - (- instance-pointer-lowtag)))) - (inst lw this-id x offset) + (inst lw this-id x (layout-id-offset test-layout)) (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) diff --git a/src/compiler/sparc/system.lisp b/src/compiler/sparc/system.lisp index f9fafd34a..68c137e81 100644 --- a/src/compiler/sparc/system.lisp +++ b/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) - (ash (- (layout-depthoid test-layout) 2) 2) - (- instance-pointer-lowtag)))) - (inst ld this-id x offset) + (inst ld this-id x (layout-id-offset test-layout)) (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) diff --git a/src/compiler/x86-64/type-vops.lisp b/src/compiler/x86-64/type-vops.lisp index 11cc1c4d3..c01b08a56 100644 --- a/src/compiler/x86-64/type-vops.lisp +++ b/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)) - (offset (+ (id-bits-offset) - (ash (- depthoid 2) 2) - (- instance-pointer-lowtag)))) + (let ((depthoid (layout-depthoid test-layout))) (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. diff --git a/src/compiler/x86/system.lisp b/src/compiler/x86/system.lisp index 4a8fb6b20..724670047 100644 --- a/src/compiler/x86/system.lisp +++ b/src/compiler/x86/system.lisp @@ -76,11 +76,7 @@ (:conditional :e) (:generator 1 (inst cmp - (make-ea :dword - :disp (+ (id-bits-offset) - (ash (- (layout-depthoid test) 2) 2) - (- instance-pointer-lowtag)) - :base x) + (make-ea :dword :disp (layout-id-offset test) :base x) (if (or (typep (layout-id test) '(and (signed-byte 8) (not (eql 0)))) (not (sb-c::producing-fasl-file))) (layout-id test)