master: x86-64: TRUNCATE using the Lemire, Kaser, Kurz transform

The branch "master" has been updated in SBCL:
       via  ae89d7be84002e48bea7cfd8be84bd6c7896a2c0 (commit)
      from  c41011cb52eb089b3edf219a871224afcfb8a122 (commit)

- Log -----------------------------------------------------------------
commit ae89d7be84002e48bea7cfd8be84bd6c7896a2c0
Author: Douglas Katzman <[email protected]>
Date:   Sat Apr 18 22:02:34 2026 -0400

    x86-64: TRUNCATE using the Lemire, Kaser, Kurz transform
    
    2 MULs outperforms one DIV or IDIV by at least 2x based on my
    testing and also Agner Fog's instruction latency tables
---
 src/code/target-package.lisp    |  2 +-
 src/compiler/generic/utils.lisp |  8 +++++-
 src/compiler/x86-64/arith.lisp  | 56 ++++++++++++++++++++++++++++++++++-------
 tests/integerdiv.pure.lisp      | 18 +++++++++++++
 4 files changed, 73 insertions(+), 11 deletions(-)

diff --git a/src/code/target-package.lisp b/src/code/target-package.lisp
index 1fc56ea2f..97135bea5 100644
--- a/src/code/target-package.lisp
+++ b/src/code/target-package.lisp
@@ -439,7 +439,7 @@ of :INHERITED :EXTERNAL :INTERNAL."
          (n min-numerator-bits))
     (loop
      (multiple-value-bind (c frac-bits)
-         (sb-c:compute-fastrem-coefficient denominator n :variable)
+         (sb-c:compute-fastrem-coefficient denominator n :minimum)
        (cond ((= frac-bits 32)
               (return (values (ldb (byte n 0) -1) c)))
              ((> frac-bits 32)
diff --git a/src/compiler/generic/utils.lisp b/src/compiler/generic/utils.lisp
index 4a8a39cc1..85e6f5533 100644
--- a/src/compiler/generic/utils.lisp
+++ b/src/compiler/generic/utils.lisp
@@ -577,7 +577,7 @@
                        (when (<= d (+ (mod 2^F d) (expt 2 L)))
                          (let ((c (ceiling (expt 2 F) d)))
                            (return (values F c))))))))
-    (cond ((eq fraction-bits :variable) ; return the smallest F
+    (cond ((eq fraction-bits :minimum) ; return the smallest F
            (values c smallest-f))
           (t
            ;; Otherwise hardwire F to 32 so the algorithm can use :DWORD
@@ -589,6 +589,12 @@
                     smallest-f d n))
            (values (ceiling (expt 2 fraction-bits) d) fraction-bits)))))
 
+(defun type-width-in-bits (ctype)
+  ;; Return (integer-length upper-bound) of numeric type. This is NOT a theoretical
+  ;; smallest N bits needed to encode an element of type in a packed representation
+  ;; (e.g. the interval 5..8 _could_ be stored in 2 bits) but we don't do that.
+  (integer-length (sb-c::interval-high (sb-c::numeric-type->interval ctype))))
+
 (defun env-system-tlab-p (env)
   #-system-tlabs (declare (ignore env))
   #+system-tlabs
diff --git a/src/compiler/x86-64/arith.lisp b/src/compiler/x86-64/arith.lisp
index 31ab987a4..2b5b9de99 100644
--- a/src/compiler/x86-64/arith.lisp
+++ b/src/compiler/x86-64/arith.lisp
@@ -2056,13 +2056,13 @@
 
 (define-vop (fast-truncate-c/fixnum=>fixnum fast-safe-arith-op)
   (:translate truncate)
-  (:args (x :scs (any-reg) :target eax))
+  (:args (x :scs (any-reg) :target rax))
   (:info y)
   (:arg-types tagged-num (:constant fixnum))
   (:temporary (:sc signed-reg :offset rax-offset :target quo
-                   :from :argument :to (:result 0)) eax)
+                   :from :argument :to (:result 0)) rax)
   (:temporary (:sc any-reg :offset rdx-offset :target rem
-                   :from :eval :to (:result 1)) edx)
+                   :from :eval :to (:result 1)) rdx)
   (:temporary (:sc any-reg :from :eval :to :result) y-arg)
   (:results (quo :scs (any-reg))
             (rem :scs (any-reg)))
@@ -2070,16 +2070,54 @@
   (:note "inline fixnum arithmetic")
   (:vop-var vop)
   (:generator 30
-    (move eax x)
+   (block nil
+    ;; This ought to be done machine-independently, but there are already 23 transforms
+    ;; on TRUNCATE and I don't understand how they get tried in the optimal order.
+    ;; The benefit of that is we could just invoke the fastrem-32 or fastrem-64 vop
+    ;; rather than having to replicate them inside here.
+    (when (and (not (sb-c::tn-reads quo))
+               (typep y '(unsigned-byte 64))
+               (csubtypep (tn-ref-type (vop-args vop)) (specifier-type '(unsigned-byte 64))))
+      ;; The reason for the concern about inputs is that the general algorithm to accept
+      ;; any 64-bit integer (which as FIXNUM would limit be 62 bits) needs 4 MUL instructions
+      ;; (confirmed by looking at https://github.com/lemire/fastmod)
+      ;; But 2 MUL instructions is enough for reasonable inputs. Both the divisor and the
+      ;; maximum input affect how many bits are needed in intermediate results.
+      (binding* ((numerator-precision
+                  (type-width-in-bits (tn-ref-type (vop-args vop))) :exit-if-null)
+                 ((magic smallest-nbits)
+                  (sb-c:compute-fastrem-coefficient y numerator-precision :minimum))
+                 ((frac-bits operand-size)
+                  ;; "smallest" is how many bits you need for the algorithm to work, assuming
+                  ;; you could actually calculate on bit fields of arbitrary size. But to make it
+                  ;; efficient, you need a fixed-binary-point reciprocal in exactly 32 bits
+                  ;; or exactly 64 bits (or 128, if fully supporting 64-bit ints)
+                  (cond ((<= smallest-nbits 32) (values 32 :dword))
+                        ((<= smallest-nbits 64) (values 64 :qword)))))
+        (when operand-size
+          (when (/= smallest-nbits frac-bits) ; recompute MAGIC to required number of bits
+            (setq magic (sb-c:compute-fastrem-coefficient y numerator-precision frac-bits)))
+          (let ((arg-size (if (<= numerator-precision 31) :dword :qword)))
+            (move rax x arg-size)
+            (inst shr arg-size rax n-fixnum-tag-bits)) ; untag it
+          (inst mul operand-size (register-inline-constant operand-size magic))
+          (inst mul operand-size (register-inline-constant operand-size y))
+          ;; The result might fit into a :DWORD depending on the divisor
+          (let ((res-size (if (<= (integer-length (1- y)) 31) :dword :qword))) ; (tagged)
+            (if (location= rem rdx)
+                (inst shl res-size rem 1)
+                (inst lea res-size rem (ea rdx rdx))))
+          (return))))
+    (move rax x)
     (inst cqo)
     (inst mov y-arg (fixnumize y))
     (inst idiv y-arg)
-    (if (location= quo eax)
-        (inst shl eax n-fixnum-tag-bits)
+    (if (location= quo rax)
+        (inst shl rax n-fixnum-tag-bits)
         (if (= n-fixnum-tag-bits 1)
-            (inst lea quo (ea eax eax))
-            (inst lea quo (ea nil eax (ash 1 n-fixnum-tag-bits)))))
-    (move rem edx)))
+            (inst lea quo (ea rax rax))
+            (inst lea quo (ea nil rax (ash 1 n-fixnum-tag-bits)))))
+    (move rem rdx))))
 
 (define-vop (fast-truncate/unsigned=>unsigned fast-safe-arith-op)
   (:translate truncate)
diff --git a/tests/integerdiv.pure.lisp b/tests/integerdiv.pure.lisp
index a9ca38873..e28763756 100644
--- a/tests/integerdiv.pure.lisp
+++ b/tests/integerdiv.pure.lisp
@@ -150,3 +150,21 @@
   (loop for divisor from 3 to 10000
         do (format t "divisor=~d~%" divisor)
             (try-fastrem divisor 18)))
+
+(declaim (ftype function remN))
+#+x86-64 ; test the TRUNCATE -> fastrem optimization
+(with-test (:name :test-rem-transform)
+  (dolist (dividend-bits '(24 58))
+    ;; a divisor of 1235 needs too many intermediate bits for dividend-bits=58
+    (dolist (divisor `(3 7 133 ,(if (= dividend-bits 24) 1235 149)))
+      (compile 'remN `(lambda (x) (rem (the (unsigned-byte ,dividend-bits) x) ,divisor)))
+      ;; should not use DIV or IDIV instructions
+      (assert (not (search "DIV" (with-output-to-string (s) (disassemble 'remN :stream s)))))
+      (dotimes (i 10000)
+        (declare (notinline floor))
+        (assert (= (remn i) (nth-value 1 (floor i divisor)))))
+      (let ((max (ash 1 dividend-bits)))
+        (dotimes (i 10000)
+          (let ((x (random max)))
+            (declare (notinline floor))
+            (assert (= (remn x) (nth-value 1 (floor x divisor))))))))))

-----------------------------------------------------------------------


hooks/post-receive
-- 
SBCL