+\f
+;;; Rightward ASH
+#!+ash-right-vops
+(progn
+ (defun %ash/right (integer amount)
+ (ash integer (- amount)))
+
+ (deftransform ash ((integer amount) (sb!vm:signed-word (integer * 0)))
+ "Convert ASH of signed word to %ASH/RIGHT"
+ (when (constant-lvar-p amount)
+ (give-up-ir1-transform))
+ (let ((use (lvar-uses amount)))
+ (cond ((and (combination-p use)
+ (eql '%negate (lvar-fun-name (combination-fun use))))
+ (splice-fun-args amount '%negate 1)
+ `(lambda (integer amount)
+ (declare (type unsigned-byte amount))
+ (%ash/right integer (if (>= amount ,sb!vm:n-word-bits)
+ ,(1- sb!vm:n-word-bits)
+ amount))))
+ (t
+ `(%ash/right integer (if (<= amount ,(- sb!vm:n-word-bits))
+ ,(1- sb!vm:n-word-bits)
+ (- amount)))))))
+
+ (deftransform ash ((integer amount) (word (integer * 0)))
+ "Convert ASH of word to %ASH/RIGHT"
+ (when (constant-lvar-p amount)
+ (give-up-ir1-transform))
+ (let ((use (lvar-uses amount)))
+ (cond ((and (combination-p use)
+ (eql '%negate (lvar-fun-name (combination-fun use))))
+ (splice-fun-args amount '%negate 1)
+ `(lambda (integer amount)
+ (declare (type unsigned-byte amount))
+ (if (>= amount ,sb!vm:n-word-bits)
+ 0
+ (%ash/right integer amount))))
+ (t
+ `(if (<= amount ,(- sb!vm:n-word-bits))
+ 0
+ (%ash/right integer (- amount)))))))
+
+ (deftransform %ash/right ((integer amount) (integer (constant-arg unsigned-byte)))
+ "Convert %ASH/RIGHT by constant back to ASH"
+ `(ash integer ,(- (lvar-value amount))))
+
+ (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
+ (give-up-ir1-transform)))))