From 2378406d6eda78090dfe05e372438495aeace5e0 Mon Sep 17 00:00:00 2001
From: Paul Khuong <pvk@pvk.ca>
Date: Thu, 30 May 2013 21:49:55 -0400
Subject: [PATCH] Stricter precondition when strength reducing variable right
 shifts

 Looking at the node's derived type is safer than a result type
 constraint, which seems to consider the LVAR's derived or
 truly-declared type.

 Remove a redundant AVER too. If people call %ash/right directly and
 incorrectly, they're looking for trouble. Moreover, the call's
 type will be derived only if the argument types are correct.

 Reported by Eric Marsden on sbcl-devel; further reduced test cases
 by Christophe Rhodes.
---
 src/compiler/srctran.lisp |    9 +++++----
 tests/compiler.pure.lisp  |   12 ++++++++++++
 2 files changed, 17 insertions(+), 4 deletions(-)

diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index 4fc7754..ef9de86 100644
--- a/src/compiler/srctran.lisp
+++ b/src/compiler/srctran.lisp
@@ -2823,16 +2823,17 @@
     "Convert %ASH/RIGHT by constant back to ASH"
     `(ash integer ,(- (lvar-value amount))))
 
-  (deftransform %ash/right ((integer amount) * (member -1 0) :node node)
-    ;; constant-fold large shifts
+  (deftransform %ash/right ((integer amount) * * :node node)
+    "strength reduce large variable right shift"
     (let ((return-type (single-value-type (node-derived-type node))))
       (cond ((type= return-type (specifier-type '(eql 0)))
              0)
             ((type= return-type (specifier-type '(eql -1)))
              -1)
+            ((csubtypep return-type (specifier-type '(member -1 0)))
+             `(ash integer ,(- sb!vm:n-word-bits)))
             (t
-             (aver (csubtypep (lvar-type integer) (specifier-type 'sb!vm:signed-word)))
-             `(ash integer ,(- 1 sb!vm:n-word-bits))))))
+             (give-up-ir1-transform)))))
 
   (defun %ash/right-derive-type-aux (n-type shift same-arg)
     (declare (ignore same-arg))
diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index bccf8ef..3e949b3 100644
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -4584,3 +4584,15 @@
                            ((simple-array character (*)) vector)
                            ((unsigned-byte 24) index))
                   (aref vector (1+ (mod index (1- (length vector))))))))
+
+(test-util:with-test (:name :constant-fold-ash/right-fixnum)
+  (compile nil `(lambda (a b)
+                  (declare (type fixnum a)
+                           (type (integer * -84) b))
+                  (ash a b))))
+
+(test-util:with-test (:name :constant-fold-ash/right-word)
+  (compile nil `(lambda (a b)
+                  (declare (type word a)
+                           (type (integer * -84) b))
+                  (ash a b))))
-- 
1.7.10.4