master: Don't endlessly bounce between ash and logand transforms

The branch "master" has been updated in SBCL:
       via  91ab23b309313579a37a2067cc40d61279af17e3 (commit)
      from  b64590858b43fcd320dc8d8e39c4dc464adf6454 (commit)

- Log -----------------------------------------------------------------
commit 91ab23b309313579a37a2067cc40d61279af17e3
Author: Stas Boukarev <[email protected]>
Date:   Sun Apr 12 01:03:25 2026 +0300

    Don't endlessly bounce between ash and logand transforms
    
    Fixes lp#2148056
---
 src/compiler/srctran.lisp | 25 ++++++++++++++++++++++---
 tests/arith-2.pure.lisp   |  7 ++++++-
 2 files changed, 28 insertions(+), 4 deletions(-)

diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index edefee755..bc861db43 100644
--- a/src/compiler/srctran.lisp
+++ b/src/compiler/srctran.lisp
@@ -3920,17 +3920,36 @@
 
 ;; (ash (unsigned-byte 128) -64) produces a word sized result
 (when-vop-existsp (:translate ash-right-two-words)
-  (deftransform ash ((integer amount) * signed-word :node node :important nil)
+  (deftransform ash ((integer amount) (t fixnum) signed-word :node node :important nil)
     (if (or (word-sized-lvar-p integer)
             (combination-matches 'logand `(* ,most-positive-word) (node-dest node)))
         (give-up-ir1-transform)
         `(mask-signed-field ,sb-vm:n-word-bits (logand (ash integer amount) ,most-positive-word))))
 
-  (deftransform ash ((integer amount) * word :node node :important nil)
+  (deftransform ash ((integer amount) (t fixnum) word :node node :important nil)
     (if (or (word-sized-lvar-p integer)
             (combination-matches 'logand `(* ,most-positive-word) (node-dest node)))
         (give-up-ir1-transform)
-        `(logand (ash integer amount) ,most-positive-word))))
+        `(logand (ash integer amount) ,most-positive-word)))
+
+  (deftransform ash ((integer amount) (t (integer * 0)) signed-word
+                     :node node :important nil)
+    (when (word-sized-lvar-p amount)
+      (give-up-ir1-transform))
+    (delay-ir1-transform node :ir1-phases)
+    `(ash integer (if (fixnump amount)
+                      (truly-the fixnum amount)
+                      most-negative-fixnum)))
+
+
+  (deftransform ash ((integer amount) (t (integer * 0)) word
+                     :node node :important nil)
+    (when (word-sized-lvar-p amount)
+      (give-up-ir1-transform))
+    (delay-ir1-transform node :ir1-phases)
+    `(if (fixnump amount)
+         (ash integer (truly-the fixnum amount))
+         0)))
 
 (defoptimizers fold-p (expt sb-kernel::intexp) ((base power))
   (or (typep base '(and number
diff --git a/tests/arith-2.pure.lisp b/tests/arith-2.pure.lisp
index ed480fac7..58eda9c91 100644
--- a/tests/arith-2.pure.lisp
+++ b/tests/arith-2.pure.lisp
@@ -2465,7 +2465,12 @@
   (assert (not (ctu:ir1-named-calls
                 `(lambda (x)
                    (ash (the (signed-byte ,(* 2 sb-vm:n-word-bits)) x)
-                        ,(- sb-vm:n-word-bits)))))))
+                        ,(- sb-vm:n-word-bits))))))
+  (assert (not (ctu:ir1-named-calls
+                `(lambda (x p3)
+                   (declare (type (integer * ,(- sb-vm:n-word-bits)) p3)
+                            ((unsigned-byte ,(* (- sb-vm:n-word-bits 4) 2)) x))
+                   (ash x p3))))))
 
 (with-test (:name :truncate-by-zero-type)
   (assert-type

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


hooks/post-receive
-- 
SBCL