From 2c11228e5c980061a56ab8730dd4989978f13d83 Mon Sep 17 00:00:00 2001
From: wlott <wlott>
Date: Sat, 1 Dec 1990 14:36:14 +0000
Subject: [PATCH] The LOGAND derive-type optimizer though the result was going
 to have no more bits that the shorter argument, even if it was negative.  So
 I totally rewrote the derive-type optimizers for LOGAND, LOGIOR, and LOGXOR
 in case there were other problems.

---
 compiler/srctran.lisp | 196 +++++++++++++++++++++++++++---------------
 1 file changed, 126 insertions(+), 70 deletions(-)

diff --git a/compiler/srctran.lisp b/compiler/srctran.lisp
index df025b438..0ec24995e 100644
--- a/compiler/srctran.lisp
+++ b/compiler/srctran.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman (FAHLMAN@CMUC). 
 ;;; **********************************************************************
 ;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/srctran.lisp,v 1.20 1990/11/10 18:39:00 wlott Exp $
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/srctran.lisp,v 1.21 1990/12/01 14:36:14 wlott Exp $
 ;;;
 ;;;    This file contains macro-like source transformations which convert
 ;;; uses of certain functions into the canonical form desired within the
@@ -296,75 +296,6 @@
       *universal-type*))
 
 
-;;; Negative-Integer-P  --  Internal
-;;;
-;;;    Return true if Type is a integer type that includes negative numbers.
-;;;
-(defun negative-integer-p (type)
-  (declare (type numeric-type type))
-  (let ((low (numeric-type-low type)))
-    (or (not low) (minusp low))))
-
-(defoptimizer (logand derive-type) ((x y))
-  (derive-integer-type
-   x y
-   #'(lambda (x y)
-       (let* ((x-high (numeric-type-high x))
-	      (y-high (numeric-type-high y))
-	      (both-neg (and (negative-integer-p x)
-			     (negative-integer-p y)))
-	      (min (cond ((not x-high) y-high)
-			 ((not y-high) x-high)
-			 (t
-			  (min x-high y-high)))))
-	 (if min
-	     (let ((mag (ldb (byte (integer-length min) 0) -1)))
-	       (values (if both-neg (lognot mag) 0) mag))
-	     (values (if both-neg nil 0) nil))))))
-
-
-(defoptimizer (logior derive-type) ((x y))
-  (derive-integer-type
-   x y
-   #'(lambda (x y)
-       (let* ((x-high (numeric-type-high x))
-	      (y-high (numeric-type-high y))
-	      (one-neg (or (negative-integer-p x)
-			   (negative-integer-p y)))
-	      (max (cond ((not x-high) nil)
-			 ((not y-high) nil)
-			 (t
-			  (max x-high y-high)))))
-	 (if max
-	     (let ((mag (ldb (byte (integer-length max) 0) -1)))
-	       (values (if one-neg (lognot mag) 0) mag))
-	     (values (if one-neg nil 0) nil))))))
-
-;;; All we attempt to do is determine the maximum integer length that the
-;;; result can take on, as that is all that is interesting.
-
-(defoptimizer (logxor derive-type) ((x y))
-  (derive-integer-type
-   x y
-   #'(lambda (x y)
-       (let* ((x-high (numeric-type-high x))
-	      (x-pos (plusp (or x-high 1)))
-	      (y-high (numeric-type-high y))
-	      (y-pos (plusp (or y-high 1)))
-	      (x-low (numeric-type-low x))
-	      (x-neg (minusp (or x-low -1)))
-	      (y-low (numeric-type-low y))
-	      (y-neg (minusp (or y-low -1)))
-	      (signed (or (and x-pos y-neg) (and x-neg y-pos))))
-	 (if (and x-high y-high x-low y-low)
-	     (let ((max (max (integer-length x-high)
-			     (integer-length x-low)
-			     (integer-length y-high)
-			     (integer-length y-low))))
-	       (values (if signed (ash -1 max) 0)
-		       (1- (ash 1 max))))
-	     (values (if signed nil 0) nil))))))
-
 (macrolet ((frob (fun)
 	     `#'(lambda (type type2)
 		  (declare (ignore type2))
@@ -528,6 +459,131 @@
 		     0
 		     '*))))
 
+
+;;;; Logical derive-type methods:
+
+
+;;; Integer-Type-Length -- Internal
+;;;
+;;; Return the maximum number of bits an integer of the supplied type can take
+;;; up, or NIL if it is unbounded.  The second (third) value is T if the
+;;; integer can be positive (negative) and NIL if not.  Zero counts as
+;;; positive.
+;;;
+(defun integer-type-length (type)
+  (if (numeric-type-p type)
+      (let ((min (numeric-type-low type))
+	    (max (numeric-type-high type)))
+	(values (and min max (max (integer-length min) (integer-length max)))
+		(or (null max) (not (minusp max)))
+		(or (null min) (minusp min))))
+      (values nil t t)))
+
+(defoptimizer (logand derive-type) ((x y))
+  (multiple-value-bind
+      (x-len x-pos x-neg)
+      (integer-type-length (continuation-type x))
+    (declare (ignore x-pos))
+    (multiple-value-bind
+	(y-len y-pos y-neg)
+	(integer-type-length (continuation-type y))
+      (declare (ignore y-pos))
+      (if (not x-neg)
+	  ;; X must be positive.
+	  (if (not y-neg)
+	      ;; The must both be positive.
+	      (specifier-type
+	       `(unsigned-byte ,(if (and x-len y-len)
+				    (min x-len y-len)
+				    '*)))
+	      ;; X is positive, but Y might be negative.
+	      (specifier-type
+	       `(unsigned-byte ,(or x-len '*))))
+	  ;; X might be negative.
+	  (if (not y-neg)
+	      ;; Y must be positive.
+	      (specifier-type
+	       `(unsigned-byte ,(or y-len '*)))
+	      ;; Either might be negative.
+	      (if (and x-len y-len)
+		  ;; The result is bounded.
+		  (specifier-type `(signed-byte ,(1+ (max x-len y-len))))
+		  ;; We can't tell squat about the result.
+		  (specifier-type 'integer)))))))
+
+(defoptimizer (logior derive-type) ((x y))
+  (multiple-value-bind
+      (x-len x-pos x-neg)
+      (integer-type-length (continuation-type x))
+    (multiple-value-bind
+	(y-len y-pos y-neg)
+	(integer-type-length (continuation-type y))
+      (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)
+					     '*))))
+       ((not x-pos)
+	;; X must be negative.
+	(if (not y-pos)
+	    ;; Both are negative.  The result is going to be negative and be
+	    ;; the same length or shorter than the smaller.
+	    (if (and x-len y-len)
+		;; It's bounded.
+		(specifier-type `(integer ,(ash -1 (min x-len y-len)) -1))
+		;; It's unbounded.
+		(specifier-type '(integer * -1)))
+	    ;; X is negative, but we don't know about Y.  The result will be
+	    ;; negative, but no more negative than X.
+	    (specifier-type
+	     `(integer ,(or (numeric-type-low (continuation-type x)) '*)
+		       -1))))
+       (t
+	;; X might be either positive or negative.
+	(if (not y-pos)
+	    ;; But Y is negative.  The result will be negative.
+	    (specifier-type
+	     `(integer ,(or (numeric-type-low (continuation-type y)) '*)
+		       -1))
+	    ;; We don't know squat about either.  It won't get any bigger.
+	    (if (and x-len y-len)
+		;; Bounded.
+		(specifier-type `(signed-byte ,(1+ (max x-len y-len))))
+		;; Unbounded.
+		(specifier-type 'integer))))))))
+
+(defoptimizer (logxor derive-type) ((x y))
+  (multiple-value-bind
+      (x-len x-pos x-neg)
+      (integer-type-length (continuation-type x))
+    (multiple-value-bind
+	(y-len y-pos y-neg)
+	(integer-type-length (continuation-type 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-neg) (not y-pos)))
+	;; Either X is negative and Y is positive of vice-verca.  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))))))
+
+
 
 ;;;; Miscellaneous derive-type methods:
 
-- 
GitLab