(or (null min) (minusp min))))
(values nil t t)))
+;;; See _Hacker's Delight_, Henry S. Warren, Jr. pp 58-63 for an
+;;; explanation of LOG{AND,IOR,XOR}-DERIVE-UNSIGNED-{LOW,HIGH}-BOUND.
+;;; Credit also goes to Raymond Toy for writing (and debugging!) similar
+;;; versions in CMUCL, from which these functions copy liberally.
+
+(defun logand-derive-unsigned-low-bound (x y)
+ (let ((a (numeric-type-low x))
+ (b (numeric-type-high x))
+ (c (numeric-type-low y))
+ (d (numeric-type-high y)))
+ (loop for m = (ash 1 (integer-length (lognor a c))) then (ash m -1)
+ until (zerop m) do
+ (unless (zerop (logand m (lognot a) (lognot c)))
+ (let ((temp (logandc2 (logior a m) (1- m))))
+ (when (<= temp b)
+ (setf a temp)
+ (loop-finish))
+ (setf temp (logandc2 (logior c m) (1- m)))
+ (when (<= temp d)
+ (setf c temp)
+ (loop-finish))))
+ finally (return (logand a c)))))
+
+(defun logand-derive-unsigned-high-bound (x y)
+ (let ((a (numeric-type-low x))
+ (b (numeric-type-high x))
+ (c (numeric-type-low y))
+ (d (numeric-type-high y)))
+ (loop for m = (ash 1 (integer-length (logxor b d))) then (ash m -1)
+ until (zerop m) do
+ (cond
+ ((not (zerop (logand b (lognot d) m)))
+ (let ((temp (logior (logandc2 b m) (1- m))))
+ (when (>= temp a)
+ (setf b temp)
+ (loop-finish))))
+ ((not (zerop (logand (lognot b) d m)))
+ (let ((temp (logior (logandc2 d m) (1- m))))
+ (when (>= temp c)
+ (setf d temp)
+ (loop-finish)))))
+ finally (return (logand b d)))))
+
(defun logand-derive-type-aux (x y &optional same-leaf)
(when same-leaf
(return-from logand-derive-type-aux x))
((null y-len)
(specifier-type `(unsigned-byte* ,x-len)))
(t
- (specifier-type `(unsigned-byte* ,(min x-len y-len)))))
+ (let ((low (logand-derive-unsigned-low-bound x y))
+ (high (logand-derive-unsigned-high-bound x y)))
+ (specifier-type `(integer ,low ,high)))))
;; X is positive, but Y might be negative.
(cond ((null x-len)
(specifier-type 'unsigned-byte))
;; We can't tell squat about the result.
(specifier-type 'integer)))))))
+(defun logior-derive-unsigned-low-bound (x y)
+ (let ((a (numeric-type-low x))
+ (b (numeric-type-high x))
+ (c (numeric-type-low y))
+ (d (numeric-type-high y)))
+ (loop for m = (ash 1 (integer-length (logxor a c))) then (ash m -1)
+ until (zerop m) do
+ (cond
+ ((not (zerop (logandc2 (logand c m) a)))
+ (let ((temp (logand (logior a m) (1+ (lognot m)))))
+ (when (<= temp b)
+ (setf a temp)
+ (loop-finish))))
+ ((not (zerop (logandc2 (logand a m) c)))
+ (let ((temp (logand (logior c m) (1+ (lognot m)))))
+ (when (<= temp d)
+ (setf c temp)
+ (loop-finish)))))
+ finally (return (logior a c)))))
+
+(defun logior-derive-unsigned-high-bound (x y)
+ (let ((a (numeric-type-low x))
+ (b (numeric-type-high x))
+ (c (numeric-type-low y))
+ (d (numeric-type-high y)))
+ (loop for m = (ash 1 (integer-length (logand b d))) then (ash m -1)
+ until (zerop m) do
+ (unless (zerop (logand b d m))
+ (let ((temp (logior (- b m) (1- m))))
+ (when (>= temp a)
+ (setf b temp)
+ (loop-finish))
+ (setf temp (logior (- d m) (1- m)))
+ (when (>= temp c)
+ (setf d temp)
+ (loop-finish))))
+ finally (return (logior b d)))))
+
(defun logior-derive-type-aux (x y &optional same-leaf)
(when same-leaf
(return-from logior-derive-type-aux x))
(cond
((and (not x-neg) (not y-neg))
;; Both are positive.
- (specifier-type `(unsigned-byte* ,(if (and x-len y-len)
- (max x-len y-len)
- '*))))
+ (if (and x-len y-len)
+ (let ((low (logior-derive-unsigned-low-bound x y))
+ (high (logior-derive-unsigned-high-bound x y)))
+ (specifier-type `(integer ,low ,high)))
+ (specifier-type `(unsigned-byte* *))))
((not x-pos)
;; X must be negative.
(if (not y-pos)
;; Unbounded.
(specifier-type 'integer))))))))
+(defun logxor-derive-unsigned-low-bound (x y)
+ (let ((a (numeric-type-low x))
+ (b (numeric-type-high x))
+ (c (numeric-type-low y))
+ (d (numeric-type-high y)))
+ (loop for m = (ash 1 (integer-length (logxor a c))) then (ash m -1)
+ until (zerop m) do
+ (cond
+ ((not (zerop (logandc2 (logand c m) a)))
+ (let ((temp (logand (logior a m)
+ (1+ (lognot m)))))
+ (when (<= temp b)
+ (setf a temp))))
+ ((not (zerop (logandc2 (logand a m) c)))
+ (let ((temp (logand (logior c m)
+ (1+ (lognot m)))))
+ (when (<= temp d)
+ (setf c temp)))))
+ finally (return (logxor a c)))))
+
+(defun logxor-derive-unsigned-high-bound (x y)
+ (let ((a (numeric-type-low x))
+ (b (numeric-type-high x))
+ (c (numeric-type-low y))
+ (d (numeric-type-high y)))
+ (loop for m = (ash 1 (integer-length (logand b d))) then (ash m -1)
+ until (zerop m) do
+ (unless (zerop (logand b d m))
+ (let ((temp (logior (- b m) (1- m))))
+ (cond
+ ((>= temp a) (setf b temp))
+ (t (let ((temp (logior (- d m) (1- m))))
+ (when (>= temp c)
+ (setf d temp)))))))
+ finally (return (logxor b d)))))
+
(defun logxor-derive-type-aux (x y &optional same-leaf)
(when same-leaf
(return-from logxor-derive-type-aux (specifier-type '(eql 0))))
(multiple-value-bind (x-len x-pos x-neg) (integer-type-length x)
(multiple-value-bind (y-len y-pos y-neg) (integer-type-length y)
(cond
- ((or (and (not x-neg) (not y-neg))
- (and (not x-pos) (not y-pos)))
- ;; Either both are negative or both are positive. The result
- ;; will be positive, and as long as the longer.
- (specifier-type `(unsigned-byte* ,(if (and x-len y-len)
- (max x-len y-len)
- '*))))
- ((or (and (not x-pos) (not y-neg))
- (and (not y-pos) (not x-neg)))
- ;; Either X is negative and Y is positive or vice-versa. The
- ;; result will be negative.
- (specifier-type `(integer ,(if (and x-len y-len)
- (ash -1 (max x-len y-len))
- '*)
- -1)))
- ;; We can't tell what the sign of the result is going to be.
- ;; All we know is that we don't create new bits.
- ((and x-len y-len)
- (specifier-type `(signed-byte ,(1+ (max x-len y-len)))))
- (t
- (specifier-type 'integer))))))
+ ((and (not x-neg) (not y-neg))
+ ;; Both are positive
+ (if (and x-len y-len)
+ (let ((low (logxor-derive-unsigned-low-bound x y))
+ (high (logxor-derive-unsigned-high-bound x y)))
+ (specifier-type `(integer ,low ,high)))
+ (specifier-type '(unsigned-byte* *))))
+ ((and (not x-pos) (not y-pos))
+ ;; Both are negative. The result will be positive, and as long
+ ;; as the longer.
+ (specifier-type `(unsigned-byte* ,(if (and x-len y-len)
+ (max x-len y-len)
+ '*))))
+ ((or (and (not x-pos) (not y-neg))
+ (and (not y-pos) (not x-neg)))
+ ;; Either X is negative and Y is positive or vice-versa. The
+ ;; result will be negative.
+ (specifier-type `(integer ,(if (and x-len y-len)
+ (ash -1 (max x-len y-len))
+ '*)
+ -1)))
+ ;; We can't tell what the sign of the result is going to be.
+ ;; All we know is that we don't create new bits.
+ ((and x-len y-len)
+ (specifier-type `(signed-byte ,(1+ (max x-len y-len)))))
+ (t
+ (specifier-type 'integer))))))
(macrolet ((deffrob (logfun)
(let ((fun-aux (symbolicate logfun "-DERIVE-TYPE-AUX")))
(fun (fun-info-derive-type info) :exit-if-null)
(mask-type (specifier-type
(ecase class
- (:unsigned `(unsigned-byte* ,width))
+ (:unsigned (let ((mask (1- (ash 1 width))))
+ `(integer ,mask ,mask)))
(:signed `(signed-byte ,width))))))
(lambda (call)
(let ((res (funcall fun call)))
(res (funcall fun call) :exit-if-null)
(mask-type (specifier-type
(ecase class
- (:unsigned `(unsigned-byte* ,width))
+ (:unsigned (let ((mask (1- (ash 1 width))))
+ `(integer ,mask ,mask)))
(:signed `(signed-byte ,width))))))
(if (eq class :unsigned)
(logand-derive-type-aux res mask-type)))))
;;; -- If both args are characters, convert to CHAR=. This is better than
;;; just converting to EQ, since CHAR= may have special compilation
;;; strategies for non-standard representations, etc.
-;;; -- If either arg is definitely not a number, then we can compare
-;;; with EQ.
+;;; -- If either arg is definitely a fixnum we punt and let the backend
+;;; deal with it.
+;;; -- If either arg is definitely not a number or a fixnum, then we
+;;; can compare with EQ.
;;; -- Otherwise, we try to put the arg we know more about second. If X
;;; is constant then we put it second. If X is a subtype of Y, we put
;;; it second. These rules make it easier for the back end to match
;;; these interesting cases.
-;;; -- If Y is a fixnum, then we quietly pass because the back end can
-;;; handle that case, otherwise give an efficiency note.
(deftransform eql ((x y) * *)
"convert to simpler equality predicate"
(let ((x-type (lvar-type x))
(y-type (lvar-type y))
- (char-type (specifier-type 'character))
- (number-type (specifier-type 'number)))
- (cond
- ((same-leaf-ref-p x y) t)
- ((not (types-equal-or-intersect x-type y-type))
- nil)
- ((and (csubtypep x-type char-type)
- (csubtypep y-type char-type))
- '(char= x y))
- ((or (not (types-equal-or-intersect x-type number-type))
- (not (types-equal-or-intersect y-type number-type)))
- '(eq x y))
- ((and (not (constant-lvar-p y))
- (or (constant-lvar-p x)
- (and (csubtypep x-type y-type)
- (not (csubtypep y-type x-type)))))
- '(eql y x))
- (t
- (give-up-ir1-transform)))))
+ (char-type (specifier-type 'character)))
+ (flet ((simple-type-p (type)
+ (csubtypep type (specifier-type '(or fixnum (not number)))))
+ (fixnum-type-p (type)
+ (csubtypep type (specifier-type 'fixnum))))
+ (cond
+ ((same-leaf-ref-p x y) t)
+ ((not (types-equal-or-intersect x-type y-type))
+ nil)
+ ((and (csubtypep x-type char-type)
+ (csubtypep y-type char-type))
+ '(char= x y))
+ ((or (fixnum-type-p x-type) (fixnum-type-p y-type))
+ (give-up-ir1-transform))
+ ((or (simple-type-p x-type) (simple-type-p y-type))
+ '(eq x y))
+ ((and (not (constant-lvar-p y))
+ (or (constant-lvar-p x)
+ (and (csubtypep x-type y-type)
+ (not (csubtypep y-type x-type)))))
+ '(eql y x))
+ (t
+ (give-up-ir1-transform))))))
;;; similarly to the EQL transform above, we attempt to constant-fold
;;; or convert to a simpler predicate: mostly we have to be careful
-;;; with strings.
+;;; with strings and bit-vectors.
(deftransform equal ((x y) * *)
"convert to simpler equality predicate"
(let ((x-type (lvar-type x))
(y-type (lvar-type y))
- (string-type (specifier-type 'string)))
+ (string-type (specifier-type 'string))
+ (bit-vector-type (specifier-type 'bit-vector)))
(cond
((same-leaf-ref-p x y) t)
((and (csubtypep x-type string-type)
(csubtypep y-type string-type))
'(string= x y))
- ((and (or (not (types-equal-or-intersect x-type string-type))
- (not (types-equal-or-intersect y-type string-type)))
+ ((and (csubtypep x-type bit-vector-type)
+ (csubtypep y-type bit-vector-type))
+ '(bit-vector-= x y))
+ ;; if at least one is not a string, and at least one is not a
+ ;; bit-vector, then we can reason from types.
+ ((and (not (and (types-equal-or-intersect x-type string-type)
+ (types-equal-or-intersect y-type string-type)))
+ (not (and (types-equal-or-intersect x-type bit-vector-type)
+ (types-equal-or-intersect y-type bit-vector-type)))
(not (types-equal-or-intersect x-type y-type)))
nil)
(t (give-up-ir1-transform)))))
projects / sbcl.git / blobdiff