master: Improve codegen for chain of structure-TYPEP tests
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 1faf50d3dc5f3bd51f75955e64adac329f472e9b (commit)
from 0ed5ec0d57160926b01558e299cb5bbe86fcc924 (commit)
- Log -----------------------------------------------------------------
commit 1faf50d3dc5f3bd51f75955e64adac329f472e9b
Author: Douglas Katzman <[email protected]>
Date: Thu Aug 13 20:13:27 2026 -0400
Improve codegen for chain of structure-TYPEP tests
When performing successive tests, if all types have the same depthoid, then
rather than emit an instruction to load instance-layout, and then a series
of instructions to compare the layout-id against various numbers (each
entailing a memory load), instead load the layout-id once up front and
compare that against the various IDs under consideration for equality.
If the depthoids are not all the same, fall back to the slightly suboptimal
code that loads a layout-id every time. (Better would be to try to group
comparisons into sequences of tests that can all use the same loaded ID.)
Test cases by Gemini
---
src/compiler/arm64/type-vops.lisp | 30 +++++++++++++++++++++++++++
src/compiler/ir2opt.lisp | 23 +++++++++++++++++++--
src/compiler/x86-64/type-vops.lisp | 24 ++++++++++++++++++++++
tests/x86-64-codegen.impure.lisp | 42 ++++++++++++++++++++++++++++++++++++++
4 files changed, 117 insertions(+), 2 deletions(-)
diff --git a/src/compiler/arm64/type-vops.lisp b/src/compiler/arm64/type-vops.lisp
index 7a01362a1..6e65bec52 100644
--- a/src/compiler/arm64/type-vops.lisp
+++ b/src/compiler/arm64/type-vops.lisp
@@ -933,6 +933,36 @@
:ne :eq) target)
done))
+(define-vop (get-layout-id)
+ (:args (layout :scs (descriptor-reg)))
+ (:info offset)
+ (:results (r :scs (signed-reg)))
+ (:result-types signed-num)
+ (:generator 1
+ ;; Layout IDs are 32-bit (signed-byte 30) values. As long as GET-LAYOUT-ID and
+ ;; TEST-LAYOUT-ID both use 32-bit-reg, no sign-extension is needed.
+ (inst ldr (32-bit-reg r) (@ layout (- offset instance-pointer-lowtag)))))
+
+(define-vop (test-layout-id)
+ (:args (id :scs (signed-reg)))
+ (:arg-types signed-num (:constant t))
+ (:policy :fast-safe)
+ (:info target not-p test-layout)
+ (:temporary (:sc non-descriptor-reg) temp)
+ (:generator 1
+ (let ((test-id (layout-id test-layout)))
+ (cond ((typep test-id '(and (signed-byte 8) (not (eql 0))))
+ (if (minusp test-id)
+ (inst cmn (32-bit-reg id) (- test-id))
+ (inst cmp (32-bit-reg id) test-id)))
+ (t
+ (destructuring-bind (size . label)
+ (register-inline-constant :dword `(:layout-id ,test-layout))
+ (declare (ignore size))
+ (inst load-from-label (32-bit-reg temp) label))
+ (inst cmp (32-bit-reg id) (32-bit-reg temp)))))
+ (inst b (if not-p :ne :eq) target)))
+
(define-vop (keywordp type-predicate)
(:translate keywordp)
(:generator 3
diff --git a/src/compiler/ir2opt.lisp b/src/compiler/ir2opt.lisp
index f6f639206..b3d011b68 100644
--- a/src/compiler/ir2opt.lisp
+++ b/src/compiler/ir2opt.lisp
@@ -1036,6 +1036,7 @@
(when (> (length vops) 1)
(let ((layout (make-representation-tn *backend-t-primitive-type*
sb-vm:descriptor-reg-sc-number))
+ (test-layouts (mapcar (lambda (v) (third (vop-codegen-info v))) vops))
(block (vop-block vop)))
(setf (tn-type value)
(tn-ref-type (vop-args vop)))
@@ -1049,14 +1050,32 @@
(update-block-succ block
(cons stop
(ir2block-successors block)))
- (let ((test-vop (template-or-lose 'sb-vm::structure-typep*)))
+ (let ((test-vop (template-or-lose 'sb-vm::structure-typep*))
+ (test-arg layout)
+ ;; not to be confused with "load-layout-id" in some */insts.lisp files
+ (depthoid (and (vop-existsp :named sb-vm::get-layout-id)
+ (notany 'sb-vm::struct-typep-bit-test-p test-layouts)
+ (layout-depthoid (car test-layouts)))))
+ (when (and depthoid
+ (<= 2 depthoid sb-kernel::layout-id-vector-fixed-capacity)
+ (every (lambda (l) (eql (layout-depthoid l) depthoid)) test-layouts))
+ (let ((id-tn (make-representation-tn
+ (primitive-type-or-lose 'sb-vm::signed-byte-64)
+ sb-vm:signed-reg-sc-number))
+ (offset (+ (sb-vm::id-bits-offset) (ash (- depthoid 2) 2))))
+ (emit-and-insert-vop (vop-node vop) block
+ (template-or-lose 'sb-vm::get-layout-id)
+ (reference-tn layout nil) (reference-tn id-tn t)
+ vop (list offset))
+ (setq test-vop (template-or-lose 'sb-vm::test-layout-id)
+ test-arg id-tn)))
(loop for vop in vops
for info = (vop-codegen-info vop)
do
(emit-and-insert-vop (vop-node vop)
(vop-block vop)
test-vop
- (reference-tn layout nil)
+ (reference-tn test-arg nil)
nil
vop
info)
diff --git a/src/compiler/x86-64/type-vops.lisp b/src/compiler/x86-64/type-vops.lisp
index 20fa77f83..11cc1c4d3 100644
--- a/src/compiler/x86-64/type-vops.lisp
+++ b/src/compiler/x86-64/type-vops.lisp
@@ -1354,3 +1354,27 @@
(inst mov :dword r (ea (- 4 instance-pointer-lowtag) object))
#-compact-instance-header
(loadw r object instance-slots-offset instance-pointer-lowtag)))
+
+(define-vop (get-layout-id)
+ (:args (layout :scs (descriptor-reg)))
+ (:info offset)
+ (:results (r :scs (signed-reg)))
+ (:result-types signed-num)
+ (:generator 1
+ ;; Layout IDs are 32-bit (signed-byte 30) values. As long as GET-LAYOUT-ID and
+ ;; TEST-LAYOUT-ID both use :DWORD operand size, no sign-extension is needed.
+ (inst mov :dword r (ea (- offset instance-pointer-lowtag) layout))))
+
+(define-vop (test-layout-id)
+ (:args (id :scs (signed-reg)))
+ (:arg-types signed-num (:constant t))
+ (:policy :fast-safe)
+ (:info target not-p test-layout)
+ (:generator 1
+ (inst cmp :dword id
+ (cond ((or (typep (layout-id test-layout) '(and (signed-byte 8) (not (eql 0))))
+ (not (sb-c::producing-fasl-file)))
+ (layout-id test-layout))
+ (t
+ (make-fixup test-layout :layout-id))))
+ (inst jmp (if not-p :ne :e) target)))
diff --git a/tests/x86-64-codegen.impure.lisp b/tests/x86-64-codegen.impure.lisp
index dc7434c32..143ace035 100644
--- a/tests/x86-64-codegen.impure.lisp
+++ b/tests/x86-64-codegen.impure.lisp
@@ -1498,3 +1498,45 @@
(some (lambda (line)
(and (search "MOV" line) (search "+R" line) (search "*2]" line)))
lines))))
+
+(defstruct test-struct-alpha)
+(defstruct test-struct-beta)
+(defstruct test-struct-gamma)
+
+(with-test (:name :hoist-typecase-layout-id)
+ (let* ((f (compile nil '(lambda (x)
+ (declare (optimize speed))
+ (typecase x
+ (test-struct-alpha 1)
+ (test-struct-beta 2)
+ (test-struct-gamma 3)))))
+ (lines (disassembly-lines f))
+ (mem-cmps (loop for line in lines
+ count (and (search "CMP" line)
+ (search "[" line))))
+ (reg-cmps (loop for line in lines
+ count (and (search "CMP" line)
+ (not (search "[" line))))))
+ (assert (eql (funcall f (make-test-struct-alpha)) 1))
+ (assert (eql (funcall f (make-test-struct-beta)) 2))
+ (assert (eql (funcall f (make-test-struct-gamma)) 3))
+ (assert (eql (funcall f "other") nil))
+ (assert (>= reg-cmps 3))
+ (assert (<= mem-cmps 1))))
+
+(with-test (:name :single-struct-typep-fused-cmp)
+ (let* ((f (compile nil '(lambda (x)
+ (declare (optimize speed))
+ (if (typep x 'test-struct-alpha) 1 2))))
+ (lines (disassembly-lines f))
+ (mem-cmps (loop for line in lines
+ count (and (search "CMP" line)
+ (search "[" line))))
+ (reg-cmps (loop for line in lines
+ count (and (search "CMP" line)
+ (not (search "[" line))))))
+ (assert (eql (funcall f (make-test-struct-alpha)) 1))
+ (assert (eql (funcall f "other") 2))
+ ;; Must keep the single fused memory CMP and avoid separate register CMPs
+ (assert (= mem-cmps 1))
+ (assert (= reg-cmps 0))))
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL