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