X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fsrctran.lisp;h=b4214fc5412901b1ab4c1b40cefed998704c02b7;hb=e67cc0f952040723f7d0f37ddb88fe895f4b1464;hp=4b1f05ae37cfb9f7c4604762d7a8420a373fa9a9;hpb=d04b59670ab69405c4115ea3caac99fd62a4b7ab;p=sbcl.git

diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index 4b1f05a..b4214fc 100644
--- a/src/compiler/srctran.lisp
+++ b/src/compiler/srctran.lisp
@@ -2131,6 +2131,49 @@
 		(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))
@@ -2149,7 +2192,9 @@
 		    ((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))
@@ -2168,6 +2213,44 @@
 		  ;; 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))
@@ -2176,9 +2259,11 @@
       (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)
@@ -2208,33 +2293,75 @@
 		;; 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")))
@@ -2575,7 +2702,8 @@
              (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)))
@@ -2589,7 +2717,8 @@
                (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)))))
@@ -3071,7 +3200,9 @@
 ;;; -- 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, or a fixnum, then we
+;;; -- 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
@@ -3083,16 +3214,20 @@
 	(y-type (lvar-type y))
 	(char-type (specifier-type 'character)))
     (flet ((simple-type-p (type)
-	     (csubtypep type (specifier-type '(or fixnum (not number))))))
+             (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))
+        ((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 (simple-type-p x-type) (simple-type-p y-type))
-	 '(eq 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)