master: Factor out boilerplate from structure-is-a
snuglas via Sbcl-commits <[email protected]>
| Newsgroups | gmane.lisp.steel-bank.cvs |
|---|---|
| Message-ID | <[email protected]> |
The branch "master" has been updated in SBCL:
via b3b9f0efa2eda1f4d04ab7dfdb7c630bc96dd0df (commit)
from 65b968f2ac117c7306766ebf7593750e112c1b2a (commit)
- Log -----------------------------------------------------------------
commit b3b9f0efa2eda1f4d04ab7dfdb7c630bc96dd0df
Author: Douglas Katzman <[email protected]>
Date: Sun Aug 16 22:19:14 2026 -0400
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)
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL