master: Decrease some repetition
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 9c6a402b32485014fd34b3026fb1b9c4fe00e7de (commit)
from 4d580f8f270ad9443ae32bdc3e7704ba4e9ea5c2 (commit)
- Log -----------------------------------------------------------------
commit 9c6a402b32485014fd34b3026fb1b9c4fe00e7de
Author: Douglas Katzman <[email protected]>
Date: Thu Aug 13 15:07:45 2026 -0400
Decrease some repetition
---
src/compiler/arm64/type-vops.lisp | 20 +++++---------------
src/compiler/generic/utils.lisp | 10 ++++++++++
src/compiler/typetran.lisp | 9 +++------
src/compiler/x86-64/type-vops.lisp | 22 ++++++----------------
4 files changed, 24 insertions(+), 37 deletions(-)
diff --git a/src/compiler/arm64/type-vops.lisp b/src/compiler/arm64/type-vops.lisp
index 10e63c677..7a01362a1 100644
--- a/src/compiler/arm64/type-vops.lisp
+++ b/src/compiler/arm64/type-vops.lisp
@@ -810,11 +810,7 @@
(loadw r object instance-slots-offset instance-pointer-lowtag)))
(defun structure-is-a (layout temp this-id test-layout &optional desc-temp target not-p done)
- (let ((test-layout (case (layout-classoid-name test-layout)
- (condition +condition-layout-flag+)
- (pathname +pathname-layout-flag+)
- (structure-object +structure-layout-flag+)
- (t test-layout))))
+ (let ((test-layout (or (struct-typep-bit-test-p test-layout) test-layout)))
(cond ((integerp test-layout)
(inst ldrsw temp
(@ layout
@@ -888,16 +884,13 @@
(:temporary (:sc unsigned-reg
:unused-if
(and (instance-tn-ref-p args)
- #1=(and (not (memq (layout-classoid-name test-layout)
- '(condition pathname structure-object)))
+ #1=(and (not (struct-typep-bit-test-p test-layout))
(let ((classoid (layout-classoid test-layout)))
(and (eq (classoid-state classoid) :sealed)
(not (classoid-subclasses classoid)))))))
temp)
(:temporary (:sc unsigned-reg
- :unused-if (or (memq (layout-classoid-name test-layout)
- '(condition pathname structure-object))
- #1#))
+ :unused-if (or (struct-typep-bit-test-p test-layout) #1#))
this-id)
(:temporary (:sc descriptor-reg
:unused-if (not #1#))
@@ -922,16 +915,13 @@
(:info target not-p test-layout)
(:temporary (:sc unsigned-reg
:unused-if
- #1=(and (not (memq (layout-classoid-name test-layout)
- '(condition pathname structure-object)))
+ #1=(and (not (struct-typep-bit-test-p test-layout))
(let ((classoid (layout-classoid test-layout)))
(and (eq (classoid-state classoid) :sealed)
(not (classoid-subclasses classoid))))))
temp)
(:temporary (:sc unsigned-reg
- :unused-if (or (memq (layout-classoid-name test-layout)
- '(condition pathname structure-object))
- #1#))
+ :unused-if (or (struct-typep-bit-test-p test-layout) #1#))
this-id)
(:temporary (:sc descriptor-reg
:unused-if (not #1#))
diff --git a/src/compiler/generic/utils.lisp b/src/compiler/generic/utils.lisp
index c18306d14..454caa52a 100644
--- a/src/compiler/generic/utils.lisp
+++ b/src/compiler/generic/utils.lisp
@@ -545,6 +545,16 @@
(let ((slot (get-dsd-index layout sb-kernel::id-word0)))
(ash (+ sb-vm:instance-slots-offset slot) sb-vm:word-shift)))
+;; 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
+;; for depthoid=1 in the ID array within a layout.
+(defun struct-typep-bit-test-p (layout)
+ (let ((name (if (symbolp layout) layout (layout-classoid-name layout))))
+ (case name
+ (condition +condition-layout-flag+)
+ (pathname +pathname-layout-flag+)
+ (structure-object +structure-layout-flag+))))
+
;;; I'd like the division-by-constant-integer optimization to work
;;; during cross-compilation, but the algorithm to compute the magic
;;; parameters is expressed in C, not Lisp. I need to translate it.
diff --git a/src/compiler/typetran.lisp b/src/compiler/typetran.lisp
index 53c9fa61c..033c548c3 100644
--- a/src/compiler/typetran.lisp
+++ b/src/compiler/typetran.lisp
@@ -1601,16 +1601,13 @@
(type (make-symbol "TYPE")))
(declare (ignorable layout))
+ (acond
;; Easiest case first: single bit test.
- (cond ((member name '(condition pathname structure-object))
- (let ((flag (case name
- (condition +condition-layout-flag+)
- (pathname +pathname-layout-flag+)
- (t +structure-layout-flag+))))
+ ((sb-vm::struct-typep-bit-test-p name)
(if (vop-existsp :translate structure-typep)
`(structure-typep object ,layout)
`(and (%instancep object)
- (logtest (,get-flags (%instance-layout object)) ,flag)))))
+ (logtest (,get-flags (%instance-layout object)) ,it))))
;; Next easiest: Sealed and no subtypes. Typically for DEFSTRUCT only.
;; Even if you don't seal a DEFCLASS, we're allowed to assume that things
diff --git a/src/compiler/x86-64/type-vops.lisp b/src/compiler/x86-64/type-vops.lisp
index ced028090..20fa77f83 100644
--- a/src/compiler/x86-64/type-vops.lisp
+++ b/src/compiler/x86-64/type-vops.lisp
@@ -1237,12 +1237,7 @@
(inst cmp :dword (read-depthoid) (fixnumize k))))
(defun structure-is-a (layout test-layout &optional target not-p done)
- (let ((test-layout
- (case (layout-classoid-name test-layout)
- (condition +condition-layout-flag+)
- (pathname +pathname-layout-flag+)
- (structure-object +structure-layout-flag+)
- (t test-layout))))
+ (let ((test-layout (or (struct-typep-bit-test-p test-layout) test-layout)))
(cond ((integerp test-layout)
(inst test
(if (typep test-layout '(unsigned-byte 8))
@@ -1310,8 +1305,7 @@
(unless (instance-tn-ref-p args)
(%test-lowtag object layout (if not-p target done) t instance-pointer-lowtag))
- (cond ((and (not (memq (layout-classoid-name test-layout)
- '(condition pathname structure-object)))
+ (cond ((and (not (struct-typep-bit-test-p test-layout))
(let ((classoid (layout-classoid test-layout)))
(and (eq (classoid-state classoid) :sealed)
(not (classoid-subclasses classoid)))))
@@ -1330,10 +1324,9 @@
#-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 (memq (layout-classoid-name test-layout)
- '(condition pathname structure-object))
- (not not-p)
- not-p)
+ ;; Flag sense: in layout tests that use the CMP instruction (most of them),
+ ;; the :E flag means "yes" though for 1-bit tests the :NE flag means "yes"
+ (inst jmp (if (if (struct-typep-bit-test-p test-layout) (not not-p) not-p)
:ne :e) target)
done))
@@ -1344,10 +1337,7 @@
(:info target not-p test-layout)
(:generator 4
(structure-is-a layout test-layout target not-p done)
- (inst jmp (if (if (memq (layout-classoid-name test-layout)
- '(condition pathname structure-object))
- (not not-p)
- not-p)
+ (inst jmp (if (if (struct-typep-bit-test-p test-layout) (not not-p) not-p)
:ne :e) target)
done))
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL