common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity

Factor out boilerplate from structure-is-a

Browse source
This commit is contained in:
Douglas Katzman 2026-08-16 22:19:14 -04:00
parent 65b968f2ac
commit b3b9f0efa2
11 changed files with 27 additions and 53 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

7
src/compiler/arm/system.lisp
View file

@ -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))

7
src/compiler/arm64/type-vops.lisp
View file

@ -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)

6
src/compiler/generic/utils.lisp
View file

@ -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

7
src/compiler/loongarch64/system.lisp
View file

@ -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)

12
src/compiler/mips/system.lisp
View file

@ -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)

7
src/compiler/ppc/system.lisp
View file

@ -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))))

7
src/compiler/ppc64/system.lisp
View file

@ -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))))

7
src/compiler/riscv/system.lisp
View file

@ -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)

7
src/compiler/sparc/system.lisp
View file

@ -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)

7
src/compiler/x86-64/type-vops.lisp
View file

@ -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.

6
src/compiler/x86/system.lisp
View file

@ -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)