Skip to content
Snippets Groups Projects
Commit 2c11228e authored by wlott's avatar wlott
Browse files

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.
parent b8c3d8ce
No related branches found
No related tags found
No related merge requests found
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
;;; Scott Fahlman (FAHLMAN@CMUC). ;;; 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 ;;; This file contains macro-like source transformations which convert
;;; uses of certain functions into the canonical form desired within the ;;; uses of certain functions into the canonical form desired within the
...@@ -296,75 +296,6 @@ ...@@ -296,75 +296,6 @@
*universal-type*)) *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) (macrolet ((frob (fun)
`#'(lambda (type type2) `#'(lambda (type type2)
(declare (ignore type2)) (declare (ignore type2))
...@@ -528,6 +459,131 @@ ...@@ -528,6 +459,131 @@
0 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: ;;;; Miscellaneous derive-type methods:
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment