master: Possibly eliminate 1 or 2 instructions from DEREF of integer arrays
snuglas via Sbcl-commits <[email protected]> Thu, 09 Jul 2026 17:01:18 +0000
| Newsgroups | gmane.lisp.steel-bank.cvs |
|---|---|
| Message-ID | <[email protected]> |
The branch "master" has been updated in SBCL:
via c5c0dba53554373597e44b6b482f6a2d4195943a (commit)
from 2dc5c051b7e0f283e74e555f328c798f3dadca03 (commit)
- Log -----------------------------------------------------------------
commit c5c0dba53554373597e44b6b482f6a2d4195943a
Author: Douglas Katzman <[email protected]>
Date: Thu Jul 9 17:01:07 2026 +0000
Possibly eliminate 1 or 2 instructions from DEREF of integer arrays
---
src/cold/exports.lisp | 5 +++++
src/compiler/aliencomp.lisp | 27 +++++++++++++++++++++++----
src/compiler/arm64/sap.lisp | 31 +++++++++++++++++++++++++++++++
src/compiler/saptran.lisp | 11 +++++++++++
src/compiler/x86-64/sap.lisp | 37 +++++++++++++++++++++++++++++++++++++
tests/arm64-codegen.impure.lisp | 23 +++++++++++++++++++++++
tests/x86-64-codegen.impure.lisp | 15 +++++++++++++++
7 files changed, 145 insertions(+), 4 deletions(-)
diff --git a/src/cold/exports.lisp b/src/cold/exports.lisp
index 0e2478bc4..1892d97ac 100644
--- a/src/cold/exports.lisp
+++ b/src/cold/exports.lisp
@@ -1159,6 +1159,11 @@ of `SB-KERNEL`) have been undone, but probably more remain.")
"SAP-REF-8"
"SAP-REF-DOUBLE" "SAP-REF-LISPOBJ" "SAP-REF-LONG"
"SAP-REF-SAP" "SAP-REF-SINGLE"
+ ;; The "internal" sap ref accessors are only to aid compiling DEREF
+ ;; and not for users.
+ "%SAP-REF-16-INDEXED" "%SIGNED-SAP-REF-16-INDEXED"
+ "%SAP-REF-32-INDEXED" "%SIGNED-SAP-REF-32-INDEXED"
+ "%SAP-REF-64-INDEXED" "%SIGNED-SAP-REF-64-INDEXED"
"SAP<" "SAP<=" "SAP=" "SAP>" "SAP>="
"SCRUB-CONTROL-STACK" "SERVE-ALL-EVENTS"
"SIGNAL-DEADLINE"
diff --git a/src/compiler/aliencomp.lisp b/src/compiler/aliencomp.lisp
index 4222f975b..d0a310654 100644
--- a/src/compiler/aliencomp.lisp
+++ b/src/compiler/aliencomp.lisp
@@ -254,10 +254,29 @@
(deftransform deref ((alien &rest indices))
(multiple-value-bind (indices-args offset-expr element-type)
(compute-deref-guts alien indices)
- `(lambda (alien ,@indices-args)
- (%alien-value (alien-sap alien)
- ,offset-expr
- ',element-type))))
+ ;; DEREF with a variable index off a (* int) was doing two extra shifts- one to
+ ;; premultiply the index, one to untag. We can try to fold at least one shift
+ ;; into the effective address of the load. arm64 can only choose to scale the
+ ;; index by 1 or by the element size though. x86-64 can remove both shifts
+ ;; because if the index is a tagged fixnum, the scale can simply be halved.
+ (if (and (= (length indices) 1)
+ (sb-alien::alien-integer-type-p element-type)
+ (not (constant-lvar-p (car indices)))
+ (or (and (vop-existsp :translate %sap-ref-16-indexed)
+ (= (sb-alien::alien-integer-type-bits element-type) 16))
+ (and (vop-existsp :translate %sap-ref-32-indexed)
+ (= (sb-alien::alien-integer-type-bits element-type) 32))
+ (and (vop-existsp :translate %sap-ref-64-indexed)
+ (= (sb-alien::alien-integer-type-bits element-type) 64))))
+ (let* ((signed (sb-alien::alien-integer-type-signed element-type))
+ (accessor
+ (case (sb-alien::alien-integer-type-bits element-type)
+ (16 (if signed '%signed-sap-ref-16-indexed '%sap-ref-16-indexed))
+ (32 (if signed '%signed-sap-ref-32-indexed '%sap-ref-32-indexed))
+ (64 (if signed '%signed-sap-ref-64-indexed '%sap-ref-64-indexed)))))
+ `(lambda (alien index) (,accessor (alien-sap alien) index)))
+ `(lambda (alien ,@indices-args)
+ (%alien-value (alien-sap alien) ,offset-expr ',element-type)))))
#+nil ;; ### Again, the value might be coerced.
(defoptimizer (%set-deref derive-type) ((alien value &rest noise))
diff --git a/src/compiler/arm64/sap.lisp b/src/compiler/arm64/sap.lisp
index d7feed6b0..c6fd024c3 100644
--- a/src/compiler/arm64/sap.lisp
+++ b/src/compiler/arm64/sap.lisp
@@ -302,6 +302,37 @@
single-reg single-float :single)
(def-system-ref-and-set sap-ref-double %set-sap-ref-double
double-reg double-float :double))
+
+(define-vop (%sap-ref-indexed)
+ (:translate %sap-ref-16-indexed %sap-ref-32-indexed %sap-ref-64-indexed)
+ (:policy :fast-safe)
+ (:args (sap :scs (sap-reg))
+ (index :scs (signed-reg unsigned-reg)))
+ (:arg-types system-area-pointer untagged-num)
+ (:results (result :scs (unsigned-reg)))
+ (:result-types unsigned-num)
+ (:node-var node)
+ (:generator 1
+ (ecase (sb-c::combination-fun-source-name node)
+ (%sap-ref-16-indexed (inst ldrh result (@ sap (extend index :lsl 1))))
+ (%sap-ref-32-indexed (inst ldr (32-bit-reg result) (@ sap (extend index :lsl 2))))
+ (%sap-ref-64-indexed (inst ldr result (@ sap (extend index :lsl 3)))))))
+
+(define-vop (%signed-sap-ref-indexed)
+ (:translate %signed-sap-ref-16-indexed %signed-sap-ref-32-indexed
+ %signed-sap-ref-64-indexed)
+ (:policy :fast-safe)
+ (:args (sap :scs (sap-reg))
+ (index :scs (signed-reg unsigned-reg)))
+ (:arg-types system-area-pointer untagged-num)
+ (:results (result :scs (signed-reg)))
+ (:result-types signed-num)
+ (:node-var node)
+ (:generator 1
+ (ecase (sb-c::combination-fun-source-name node)
+ (%signed-sap-ref-16-indexed (inst ldrsh result (@ sap (extend index :lsl 1))))
+ (%signed-sap-ref-32-indexed (inst ldrsw result (@ sap (extend index :lsl 2))))
+ (%signed-sap-ref-64-indexed (inst ldr result (@ sap (extend index :lsl 2)))))))
;;; Noise to convert normal lisp data objects into SAPs.
(define-vop (vector-sap)
diff --git a/src/compiler/saptran.lisp b/src/compiler/saptran.lisp
index fc16e77d8..e634784b9 100644
--- a/src/compiler/saptran.lisp
+++ b/src/compiler/saptran.lisp
@@ -113,6 +113,17 @@
(defsapref sap-ref-long long-float) ; actually DOUBLE-FLOAT
) ; MACROLET
+;;; These are not settable, but could be made to be
+(macrolet ((defsaprefx (n)
+ `(progn
+ (defknown ,(symbolicate "%SAP-REF-" n "-INDEXED")
+ (system-area-pointer fixnum) (unsigned-byte ,n) (flushable always-translatable))
+ (defknown ,(symbolicate "%SIGNED-SAP-REF-" n "-INDEXED")
+ (system-area-pointer fixnum) (signed-byte ,n) (flushable always-translatable)))))
+ (defsaprefx 16)
+ (defsaprefx 32)
+ (defsaprefx 64))
+
;;;; transforms for converting sap relation operators
diff --git a/src/compiler/x86-64/sap.lisp b/src/compiler/x86-64/sap.lisp
index 31ba6e756..05315f217 100644
--- a/src/compiler/x86-64/sap.lisp
+++ b/src/compiler/x86-64/sap.lisp
@@ -396,6 +396,43 @@ https://llvm.org/doxygen/MemorySanitizer_8cpp.html
(inst movq newval-temp newval)
(inst cmpxchg :lock (sap+offset-to-ea sap offset nil) newval-temp)
(inst movq result rax))))
+
+(define-vop (%sap-ref-indexed)
+ (:translate %sap-ref-16-indexed %sap-ref-32-indexed %sap-ref-64-indexed)
+ (:policy :fast-safe)
+ (:args (sap :scs (sap-reg))
+ (index :scs (any-reg signed-reg unsigned-reg)))
+ (:arg-types system-area-pointer tagged-num)
+ (:results (result :scs (unsigned-reg)))
+ (:result-types unsigned-num)
+ (:node-var node)
+ (:generator 1
+ (ecase (sb-c::combination-fun-source-name node)
+ (%sap-ref-16-indexed
+ (inst movzx '(:word :qword) result (ea sap index (index-scale 2 index))))
+ (%sap-ref-32-indexed
+ (inst mov :dword result (ea sap index (index-scale 4 index))))
+ (%sap-ref-64-indexed
+ (inst mov :qword result (ea sap index (index-scale 8 index)))))))
+
+(define-vop (%signed-sap-ref-indexed)
+ (:translate %signed-sap-ref-16-indexed %signed-sap-ref-32-indexed
+ %signed-sap-ref-64-indexed)
+ (:policy :fast-safe)
+ (:args (sap :scs (sap-reg))
+ (index :scs (any-reg signed-reg unsigned-reg)))
+ (:arg-types system-area-pointer tagged-num)
+ (:results (result :scs (signed-reg)))
+ (:result-types signed-num)
+ (:node-var node)
+ (:generator 1
+ (ecase (sb-c::combination-fun-source-name node)
+ (%signed-sap-ref-16-indexed
+ (inst movsx '(:word :qword) result (ea sap index (index-scale 2 index))))
+ (%signed-sap-ref-32-indexed
+ (inst movsx '(:dword :qword) result (ea sap index (index-scale 4 index))))
+ (%signed-sap-ref-64-indexed
+ (inst mov :qword result (ea sap index (index-scale 8 index)))))))
;;; noise to convert normal lisp data objects into SAPs
diff --git a/tests/arm64-codegen.impure.lisp b/tests/arm64-codegen.impure.lisp
new file mode 100644
index 000000000..942016144
--- /dev/null
+++ b/tests/arm64-codegen.impure.lisp
@@ -0,0 +1,23 @@
+#-arm64 (invoke-restart 'run-tests::skip-file)
+
+(load "compiler-test-util.lisp")
+
+(with-test (:name :alien-deref-indexed)
+ (flet ((try (type left-shift)
+ (let ((lines
+ (ctu:disassembly-lines
+ `(lambda (i)
+ (declare (optimize (debug 0)))
+ (let ((a (alien-funcall (extern-alien "f" (function (* ,type))))))
+ (deref a (sb-ext:truly-the sb-int:index i))))))
+ (look-for
+ (format nil ", LSL #~D]" left-shift)))
+ ;; some line should have an LDR with an "extended" index
+ (assert
+ (= (count-if (lambda (line)
+ (and (search "LDR" line) (search look-for line)))
+ lines)
+ 1)))))
+ (try 'unsigned-short 1)
+ (try 'unsigned-int 2)
+ (try 'unsigned-long 3)))
diff --git a/tests/x86-64-codegen.impure.lisp b/tests/x86-64-codegen.impure.lisp
index e8672ecaa..dc7434c32 100644
--- a/tests/x86-64-codegen.impure.lisp
+++ b/tests/x86-64-codegen.impure.lisp
@@ -1483,3 +1483,18 @@
(declare (optimize (debug 0)))
(deref (alien-funcall (extern-alien "f" (function (* char)))) 0)))))
(assert (eql (loop for line in lines count (search "MOVSX" line)) 1))))
+
+(with-test (:name :alien-deref-indexed)
+ (let ((lines (disassembly-lines
+ '(lambda (i)
+ (declare (optimize (debug 0)))
+ (let ((a (alien-funcall (extern-alien "f" (function (* unsigned-int))))))
+ (deref a (sb-ext:truly-the sb-int:index i)))))))
+ ;; some line should have a MOV instruction with a base and scaled index,
+ ;; it should have a #\+ and #\* operation in the effective address.
+ ;; Since the index is a tagged fixnum, the scale should be 2 which
+ ;; equates to 4 in bytes.
+ (assert
+ (some (lambda (line)
+ (and (search "MOV" line) (search "+R" line) (search "*2]" line)))
+ lines))))
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL