master: arm64: prefer orr + lsl to bfm
stassats via Sbcl-commits <[email protected]> Tue, 28 Jul 2026 08:39:35 +0000
| Newsgroups | gmane.lisp.steel-bank.cvs |
|---|---|
| Message-ID | <[email protected]> |
The branch "master" has been updated in SBCL:
via e42312fedaa849a6d39363b43d22b9fa14d2276f (commit)
from 32b3f5f79e3511c6d12ac982899eac52d7547554 (commit)
- Log -----------------------------------------------------------------
commit e42312fedaa849a6d39363b43d22b9fa14d2276f
Author: Stas Boukarev <[email protected]>
Date: Mon Jul 27 02:45:56 2026 +0300
arm64: prefer orr + lsl to bfm
---
src/compiler/arm64/arith.lisp | 68 ++++++++++++++++++++++++++-----------------
src/compiler/ir2opt.lisp | 47 +++++++++++++++++++++++++++++-
src/compiler/macros.lisp | 18 ++++++++----
src/compiler/modarith.lisp | 19 +++++++-----
4 files changed, 111 insertions(+), 41 deletions(-)
diff --git a/src/compiler/arm64/arith.lisp b/src/compiler/arm64/arith.lisp
index a0e063f40..e51cf96bf 100644
--- a/src/compiler/arm64/arith.lisp
+++ b/src/compiler/arm64/arith.lisp
@@ -1048,6 +1048,39 @@
(or (zerop new)
(= (logcount new) size))))))
+(define-vop (dpb-c/orr/any-reg)
+ (:args (new :scs (unsigned-reg signed-reg any-reg))
+ (integer :scs (any-reg)))
+ (:arg-types (:or unsigned-num signed-num tagged-num)
+ (:constant integer)
+ tagged-num)
+ (:info posn)
+ (:results (res :scs (any-reg)))
+ (:result-types (:or tagged-num))
+ (:policy :fast-safe)
+ (:generator 1
+ (inst orr res integer (lsl new (+ posn
+ (if (sc-is new any-reg)
+ (- n-fixnum-tag-bits)
+ 0)
+ n-fixnum-tag-bits)))))
+
+(define-vop (dpb-c/orr/signed-reg)
+ (:args (new :scs (unsigned-reg signed-reg any-reg))
+ (integer :scs (unsigned-reg signed-reg)))
+ (:arg-types (:or unsigned-num signed-num tagged-num)
+ (:constant integer)
+ (:or unsigned-num signed-num))
+ (:info posn)
+ (:results (res :scs (unsigned-reg signed-reg)))
+ (:result-types (:or unsigned-num signed-num))
+ (:policy :fast-safe)
+ (:generator 1
+ (inst orr res integer (lsl new (+ posn
+ (if (sc-is new any-reg)
+ (- n-fixnum-tag-bits)
+ 0))))))
+
(define-vop (dpb-c/fixnum)
(:translate %dpb)
(:args (x :scs (signed-reg) :to :save)
@@ -1066,36 +1099,17 @@
(- (1- n-word-bits) posn)
size)))))
-(define-vop (dpb-c/signed)
+(define-vop (dpb-c/signed-unsigned)
(:translate %dpb)
- (:args (x :scs (signed-reg) :to :save)
- (y :scs (signed-reg) :target res))
- (:arg-types signed-num
+ (:args (x :scs (unsigned-reg signed-reg) :to :save)
+ (y :scs (unsigned-reg signed-reg) :target res))
+ (:arg-types (:or unsigned-num signed-num)
(:constant integer) (:constant integer)
- signed-num)
+ (:or unsigned-num signed-num))
+ (:arg-refs x-ref y-ref)
(:info size posn)
- (:results (res :scs (signed-reg)))
- (:result-types signed-num)
- (:policy :fast-safe)
- (:generator 3
- (move res y)
- (inst bfm res x (if (= posn 0)
- 0
- (- n-word-bits posn)) (1- (if (>= (+ size posn)
- n-word-bits)
- (- n-word-bits posn)
- size)))))
-
-(define-vop (dpb-c/unsigned)
- (:translate %dpb)
- (:args (x :scs (unsigned-reg) :to :save)
- (y :scs (unsigned-reg) :target res))
- (:arg-types unsigned-num
- (:constant integer) (:constant integer)
- unsigned-num)
- (:info size posn)
- (:results (res :scs (unsigned-reg)))
- (:result-types unsigned-num)
+ (:results (res :scs (unsigned-reg signed-reg)))
+ (:result-types (:or unsigned-num signed-num))
(:policy :fast-safe)
(:generator 3
(move res y)
diff --git a/src/compiler/ir2opt.lisp b/src/compiler/ir2opt.lisp
index 45899fdfb..f6f639206 100644
--- a/src/compiler/ir2opt.lisp
+++ b/src/compiler/ir2opt.lisp
@@ -1,4 +1,4 @@
-;;;; This file implements some optimisations at the IR2 level.
+;;; This file implements some optimisations at the IR2 level.
;;;; Currently, the pass converts branches to conditional moves,
;;;; deletes subsequently dead blocks and then reoptimizes jumps.
@@ -1082,6 +1082,23 @@
,@(gen 'vop-results results))
,@(bind-info body))))
+(defmacro vop-bind-tn-refs (args results vop &body body)
+ (flet ((gen (accessor operands)
+ (loop for op in operands
+ and tn-ref = `(,accessor ,vop) then `(tn-ref-across ,op)
+ until (eq op :info)
+ collect `(,op ,tn-ref)))
+ (bind-info (body)
+ (let ((info (cdr (member :info args))))
+ (if info
+ `((loop named #:vop-bind
+ with ,info = (vop-codegen-info ,vop)
+ return (progn ,@body)))
+ body))))
+ `(let* (,@(gen 'vop-args args)
+ ,@(gen 'vop-results results))
+ ,@(bind-info body))))
+
(defun tn-reader (tn &key single-writer
single-reader)
(let ((reads (tn-reads tn))
@@ -1301,6 +1318,34 @@
(list symbols))
(mapc #'delete-vop binds)))))))
+#+arm64
+(defoptimizers vop-optimize (sb-vm::dpb-c/fixnum sb-vm::dpb-c/signed-unsigned) (vop)
+ ;; bfm usually has fewer execution units and might have higher
+ ;; latency, and might require a move or untagging, prefer ORR when
+ ;; possible
+ (vop-bind-tn-refs (new integer :info size posn) (res) vop
+ (let* ((new-type (tn-ref-type new))
+ (integer-type (tn-ref-type integer))
+ (new-width (unsigned-type-width new-type))
+ (integer-width (unsigned-type-width integer-type)))
+ (when (and size posn
+ new-width integer-width
+ (<= new-width size)
+ (<= integer-width posn))
+ (emit-and-insert-vop (vop-node vop)
+ (vop-block vop)
+ (template-or-lose
+ (if (and (csubtypep integer-type (specifier-type 'fixnum))
+ (csubtypep (tn-ref-type res) (specifier-type 'fixnum)))
+ 'sb-vm::dpb-c/orr/any-reg
+ 'sb-vm::dpb-c/orr/signed-reg))
+ (reference-tn-refs new nil)
+ (reference-tn-refs res t)
+ vop
+ (list posn))
+ (delete-vop vop)))
+ nil))
+
(defun very-temporary-p (tn)
(let ((writes (tn-writes tn))
(reads (tn-reads tn)))
diff --git a/src/compiler/macros.lisp b/src/compiler/macros.lisp
index 34f7bf937..c3b49720b 100644
--- a/src/compiler/macros.lisp
+++ b/src/compiler/macros.lisp
@@ -491,16 +491,24 @@
&optional (node (gensym))
&rest vars)
&body body)
- (let* ((name (list (car names) kind))
+ (let* ((name (if (eq kind 'vop-optimize)
+ (list kind (car names))
+ (list (car names) kind)))
(optimizer-name (make-optimizer-name name)))
`(progn
(defoptimizer ,name
(,lambda-list ,node ,@vars)
,@body)
- ,@(loop for name in (cdr names)
- collect `(setf (,(package-symbolicate #.(find-package "SB-C") "FUN-INFO-" kind)
- (fun-info-or-lose ',name))
- #',optimizer-name)))))
+ ,@(if (eq kind 'vop-optimize)
+ (loop for name in (cdr names)
+ collect
+ `(set-vop-optimizer (template-or-lose ',name)
+ #',optimizer-name))
+ (loop for name in (cdr names)
+ collect
+ `(setf (,(package-symbolicate #.(find-package "SB-C") "FUN-INFO-" kind)
+ (fun-info-or-lose ',name))
+ #',optimizer-name))))))
;;;; IR groveling macros
diff --git a/src/compiler/modarith.lisp b/src/compiler/modarith.lisp
index e7be97e61..e6f103cd4 100644
--- a/src/compiler/modarith.lisp
+++ b/src/compiler/modarith.lisp
@@ -471,17 +471,20 @@
)))
-(defun unsigned-mask-width (type)
+(defun unsigned-type-width (type)
(let* ((int (type-approximate-interval type))
- (high (interval-high int)))
- (when high
+ (high (interval-high int))
+ (low (interval-low int)))
+ (when (and high
+ low
+ (>= low 0))
(integer-length high))))
(deftransform logand ((x y) (t (constant-arg integer)) word
:node node :important nil)
;; Reduce constant width
(let* ((mask (lvar-value y))
- (cut (ldb (byte (unsigned-mask-width (single-value-result-type node t)) 0)
+ (cut (ldb (byte (unsigned-type-width (single-value-result-type node t)) 0)
mask)))
(if (= cut mask)
(give-up-ir1-transform)
@@ -493,7 +496,7 @@
(or (combination-match (:node node)
(logand (:type unsigned-byte a) (logand x (:constant b)))
(block nil
- (let* ((width (or (unsigned-mask-width (lvar-type a))
+ (let* ((width (or (unsigned-type-width (lvar-type a))
(return)))
(full-mask (if (constant-lvar-p a)
(lvar-value a)
@@ -523,7 +526,7 @@
(combination-match (:node node)
(logand (:type unsigned-byte a) (logior * (:constant b)))
(block nil
- (let* ((width (or (unsigned-mask-width (lvar-type a))
+ (let* ((width (or (unsigned-type-width (lvar-type a))
(return)))
(full-mask (ldb (byte width 0) -1))
(mask (if (constant-lvar-p a)
@@ -553,7 +556,7 @@
(combination-match (:node node)
(logand (:type unsigned-byte a) (logxor * (:constant b)))
(block nil
- (let* ((width (or (unsigned-mask-width (lvar-type a))
+ (let* ((width (or (unsigned-type-width (lvar-type a))
(return)))
(full-mask (ldb (byte width 0) -1))
(mask (if (constant-lvar-p a)
@@ -575,7 +578,7 @@
(combination-match (:node node)
(logand (:type unsigned-byte a) (mask-signed-field (:constant sign) b))
(block nil
- (let ((width (or (unsigned-mask-width (lvar-type a))
+ (let ((width (or (unsigned-type-width (lvar-type a))
(return))))
(when (> sign width)
(extract-lvar-n b 1 node))))))
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL